take Module::Build out of inc. it doesn't work. don't use it.
This commit is contained in:
Scott Walters
1117
inc/Module/Build.pm
1117
inc/Module/Build.pm
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@@ -1,326 +0,0 @@
|
||||
=head1 NAME
|
||||
|
||||
Module::Build::Authoring - Authoring Module::Build modules
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
When creating a C<Build.PL> script for a module, something like the
|
||||
following code will typically be used:
|
||||
|
||||
use Module::Build;
|
||||
my $build = Module::Build->new
|
||||
(
|
||||
module_name => 'Foo::Bar',
|
||||
license => 'perl',
|
||||
requires => {
|
||||
'perl' => '5.6.1',
|
||||
'Some::Module' => '1.23',
|
||||
'Other::Module' => '>= 1.2, != 1.5, < 2.0',
|
||||
},
|
||||
);
|
||||
$build->create_build_script;
|
||||
|
||||
A simple module could get away with something as short as this for its
|
||||
C<Build.PL> script:
|
||||
|
||||
use Module::Build;
|
||||
Module::Build->new(
|
||||
module_name => 'Foo::Bar',
|
||||
license => 'perl',
|
||||
)->create_build_script;
|
||||
|
||||
The model used by C<Module::Build> is a lot like the C<MakeMaker>
|
||||
metaphor, with the following correspondences:
|
||||
|
||||
In Module::Build In ExtUtils::MakeMaker
|
||||
--------------------------- ------------------------
|
||||
Build.PL (initial script) Makefile.PL (initial script)
|
||||
Build (a short perl script) Makefile (a long Makefile)
|
||||
_build/ (saved state info) various config text in the Makefile
|
||||
|
||||
Any customization can be done simply by subclassing C<Module::Build>
|
||||
and adding a method called (for example) C<ACTION_test>, overriding
|
||||
the default 'test' action. You could also add a method called
|
||||
C<ACTION_whatever>, and then you could perform the action C<Build
|
||||
whatever>.
|
||||
|
||||
For information on providing compatibility with
|
||||
C<ExtUtils::MakeMaker>, see L<Module::Build::Compat> and
|
||||
L<http://www.makemaker.org/wiki/index.cgi?ModuleBuildConversionGuide>.
|
||||
|
||||
|
||||
=head1 STRUCTURE
|
||||
|
||||
Module::Build creates a class hierarchy conducive to customization.
|
||||
Here is the parent-child class hierarchy in classy ASCII art:
|
||||
|
||||
/--------------------\
|
||||
| Your::Parent | (If you subclass Module::Build)
|
||||
\--------------------/
|
||||
|
|
||||
|
|
||||
/--------------------\ (Doesn't define any functionality
|
||||
| Module::Build | of its own - just figures out what
|
||||
\--------------------/ other modules to load.)
|
||||
|
|
||||
|
|
||||
/-----------------------------------\ (Some values of $^O may
|
||||
| Module::Build::Platform::$^O | define specialized functionality.
|
||||
\-----------------------------------/ Otherwise it's ...::Default, a
|
||||
| pass-through class.)
|
||||
|
|
||||
/--------------------------\
|
||||
| Module::Build::Base | (Most of the functionality of
|
||||
\--------------------------/ Module::Build is defined here.)
|
||||
|
||||
|
||||
=head1 SUBCLASSING
|
||||
|
||||
Right now, there are two ways to subclass Module::Build. The first
|
||||
way is to create a regular module (in a C<.pm> file) that inherits
|
||||
from Module::Build, and use that module's class instead of using
|
||||
Module::Build directly:
|
||||
|
||||
------ in Build.PL: ----------
|
||||
#!/usr/bin/perl
|
||||
|
||||
use lib q(/nonstandard/library/path);
|
||||
use My::Builder; # Or whatever you want to call it
|
||||
|
||||
my $build = My::Builder->new
|
||||
(
|
||||
module_name => 'Foo::Bar', # All the regular args...
|
||||
license => 'perl',
|
||||
dist_author => 'A N Other <me@here.net.au>',
|
||||
requires => { Carp => 0 }
|
||||
);
|
||||
$build->create_build_script;
|
||||
|
||||
This is relatively straightforward, and is the best way to do things
|
||||
if your My::Builder class contains lots of code. The
|
||||
C<create_build_script()> method will ensure that the current value of
|
||||
C<@INC> (including the C</nonstandard/library/path>) is propagated to
|
||||
the Build script, so that My::Builder can be found when running build
|
||||
actions. If you find that you need to C<chdir> into a different directories
|
||||
in your subclass methods or actions, be sure to always return to the original
|
||||
directory (available via the C<base_dir()> method) before returning control
|
||||
to the parent class. This is important to avoid data serialization problems.
|
||||
|
||||
For very small additions, Module::Build provides a C<subclass()>
|
||||
method that lets you subclass Module::Build more conveniently, without
|
||||
creating a separate file for your module:
|
||||
|
||||
------ in Build.PL: ----------
|
||||
#!/usr/bin/perl
|
||||
|
||||
use Module::Build;
|
||||
my $class = Module::Build->subclass
|
||||
(
|
||||
class => 'My::Builder',
|
||||
code => q{
|
||||
sub ACTION_foo {
|
||||
print "I'm fooing to death!\n";
|
||||
}
|
||||
},
|
||||
);
|
||||
|
||||
my $build = $class->new
|
||||
(
|
||||
module_name => 'Foo::Bar', # All the regular args...
|
||||
license => 'perl',
|
||||
dist_author => 'A N Other <me@here.net.au>',
|
||||
requires => { Carp => 0 }
|
||||
);
|
||||
$build->create_build_script;
|
||||
|
||||
Behind the scenes, this actually does create a C<.pm> file, since the
|
||||
code you provide must persist after Build.PL is run if it is to be
|
||||
very useful.
|
||||
|
||||
See also the documentation for the L<Module::Build::API/"subclass()">
|
||||
method.
|
||||
|
||||
|
||||
=head1 PREREQUISITES
|
||||
|
||||
=head2 Types of prerequisites
|
||||
|
||||
To specify what versions of other modules are used by this
|
||||
distribution, several types of prerequisites can be defined with the
|
||||
following parameters:
|
||||
|
||||
=over 3
|
||||
|
||||
=item configure_requires
|
||||
|
||||
Items that must be installed I<before> configuring this distribution
|
||||
(i.e. before running the F<Build.PL> script). This might be a
|
||||
specific minimum version of C<Module::Build> or any other module the
|
||||
F<Build.PL> needs in order to do its stuff. Clients like C<CPAN.pm>
|
||||
or C<CPANPLUS> will be expected to pick C<configure_requires> out of the
|
||||
F<META.yml> file and install these items before running the
|
||||
C<Build.PL>.
|
||||
|
||||
If no configure_requires is specified, the current version of Module::Build
|
||||
is automatically added to configure_requires.
|
||||
|
||||
=item build_requires
|
||||
|
||||
Items that are necessary for building and testing this distribution,
|
||||
but aren't necessary after installation. This can help users who only
|
||||
want to install these items temporarily. It also helps reduce the
|
||||
size of the CPAN dependency graph if everything isn't smooshed into
|
||||
C<requires>.
|
||||
|
||||
=item requires
|
||||
|
||||
Items that are necessary for basic functioning.
|
||||
|
||||
=item recommends
|
||||
|
||||
Items that are recommended for enhanced functionality, but there are
|
||||
ways to use this distribution without having them installed. You
|
||||
might also think of this as "can use" or "is aware of" or "changes
|
||||
behavior in the presence of".
|
||||
|
||||
=item test_requires
|
||||
|
||||
Items that are necessary for testing.
|
||||
|
||||
=item conflicts
|
||||
|
||||
Items that can cause problems with this distribution when installed.
|
||||
This is pretty rare.
|
||||
|
||||
=back
|
||||
|
||||
=head2 Format of prerequisites
|
||||
|
||||
The prerequisites are given in a hash reference, where the keys are
|
||||
the module names and the values are version specifiers:
|
||||
|
||||
requires => {
|
||||
Foo::Module => '2.4',
|
||||
Bar::Module => 0,
|
||||
Ken::Module => '>= 1.2, != 1.5, < 2.0',
|
||||
perl => '5.6.0'
|
||||
},
|
||||
|
||||
The above four version specifiers have different effects. The value
|
||||
C<'2.4'> means that B<at least> version 2.4 of C<Foo::Module> must be
|
||||
installed. The value C<0> means that B<any> version of C<Bar::Module>
|
||||
is acceptable, even if C<Bar::Module> doesn't define a version. The
|
||||
more verbose value C<'E<gt>= 1.2, != 1.5, E<lt> 2.0'> means that
|
||||
C<Ken::Module>'s version must be B<at least> 1.2, B<less than> 2.0,
|
||||
and B<not equal to> 1.5. The list of criteria is separated by commas,
|
||||
and all criteria must be satisfied.
|
||||
|
||||
A special C<perl> entry lets you specify the versions of the Perl
|
||||
interpreter that are supported by your module. The same version
|
||||
dependency-checking semantics are available, except that we also
|
||||
understand perl's new double-dotted version numbers.
|
||||
|
||||
=head2 XS Extensions
|
||||
|
||||
Modules which need to compile XS code should list C<ExtUtils::CBuilder>
|
||||
as a C<build_requires> element.
|
||||
|
||||
|
||||
=head1 SAVING CONFIGURATION INFORMATION
|
||||
|
||||
Module::Build provides a very convenient way to save configuration
|
||||
information that your installed modules (or your regression tests) can
|
||||
access. If your Build process calls the C<feature()> or
|
||||
C<config_data()> methods, then a C<Foo::Bar::ConfigData> module will
|
||||
automatically be created for you, where C<Foo::Bar> is the
|
||||
C<module_name> parameter as passed to C<new()>. This module provides
|
||||
access to the data saved by these methods, and a way to update the
|
||||
values. There is also a utility script called C<config_data>
|
||||
distributed with Module::Build that provides a command line interface
|
||||
to this same functionality. See also the generated
|
||||
C<Foo::Bar::ConfigData> documentation, and the C<config_data>
|
||||
script's documentation, for more information.
|
||||
|
||||
|
||||
=head1 STARTING MODULE DEVELOPMENT
|
||||
|
||||
When starting development on a new module, it's rarely worth your time
|
||||
to create a tree of all the files by hand. Some automatic
|
||||
module-creators are available: the oldest is C<h2xs>, which has
|
||||
shipped with perl itself for a long time. Its name reflects the fact
|
||||
that modules were originally conceived of as a way to wrap up a C
|
||||
library (thus the C<h> part) into perl extensions (thus the C<xs>
|
||||
part).
|
||||
|
||||
These days, C<h2xs> has largely been superseded by modules like
|
||||
C<ExtUtils::ModuleMaker>, and C<Module::Starter>. They have varying
|
||||
degrees of support for C<Module::Build>.
|
||||
|
||||
|
||||
=head1 AUTOMATION
|
||||
|
||||
One advantage of Module::Build is that since it's implemented as Perl
|
||||
methods, you can invoke these methods directly if you want to install
|
||||
a module non-interactively. For instance, the following Perl script
|
||||
will invoke the entire build/install procedure:
|
||||
|
||||
my $build = Module::Build->new(module_name => 'MyModule');
|
||||
$build->dispatch('build');
|
||||
$build->dispatch('test');
|
||||
$build->dispatch('install');
|
||||
|
||||
If any of these steps encounters an error, it will throw a fatal
|
||||
exception.
|
||||
|
||||
You can also pass arguments as part of the build process:
|
||||
|
||||
my $build = Module::Build->new(module_name => 'MyModule');
|
||||
$build->dispatch('build');
|
||||
$build->dispatch('test', verbose => 1);
|
||||
$build->dispatch('install', sitelib => '/my/secret/place/');
|
||||
|
||||
Building and installing modules in this way skips creating the
|
||||
C<Build> script.
|
||||
|
||||
|
||||
=head1 MIGRATION
|
||||
|
||||
Note that if you want to provide both a F<Makefile.PL> and a
|
||||
F<Build.PL> for your distribution, you probably want to add the
|
||||
following to C<WriteMakefile> in your F<Makefile.PL> so that C<MakeMaker>
|
||||
doesn't try to run your F<Build.PL> as a normal F<.PL> file:
|
||||
|
||||
PL_FILES => {},
|
||||
|
||||
You may also be interested in looking at the C<Module::Build::Compat>
|
||||
module, which can automatically create various kinds of F<Makefile.PL>
|
||||
compatibility layers.
|
||||
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Ken Williams <kwilliams@cpan.org>
|
||||
|
||||
Development questions, bug reports, and patches should be sent to the
|
||||
Module-Build mailing list at <module-build@perl.org>.
|
||||
|
||||
Bug reports are also welcome at
|
||||
<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Module-Build>.
|
||||
|
||||
The latest development version is available from the Git
|
||||
repository at <https://github.com/Perl-Toolchain-Gang/Module-Build>
|
||||
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
perl(1), L<Module::Build>(3), L<Module::Build::API>(3),
|
||||
L<Module::Build::Cookbook>(3), L<ExtUtils::MakeMaker>(3), L<YAML>(3)
|
||||
|
||||
F<META.yml> Specification:
|
||||
L<CPAN::Meta::Spec>
|
||||
|
||||
L<http://www.dsmit.com/cons/>
|
||||
|
||||
L<http://search.cpan.org/dist/PerlBuildSystem/>
|
||||
|
||||
=cut
|
||||
File diff suppressed because it is too large
Load Diff
@@ -1,147 +0,0 @@
|
||||
=head1 NAME
|
||||
|
||||
Module::Build::Bundling - How to bundle Module::Build with a distribution
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
# Build.PL
|
||||
use inc::latest 'Module::Build';
|
||||
|
||||
Module::Build->new(
|
||||
module_name => 'Foo::Bar',
|
||||
license => 'perl',
|
||||
)->create_build_script;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
B<WARNING -- THIS IS AN EXPERIMENTAL FEATURE>
|
||||
|
||||
In order to install a distribution using Module::Build, users must
|
||||
have Module::Build available on their systems. There are two ways
|
||||
to do this. The first way is to include Module::Build in the
|
||||
C<configure_requires> metadata field. This field is supported by
|
||||
recent versions L<CPAN> and L<CPANPLUS> and is a standard feature
|
||||
in the Perl core as of Perl 5.10.1. Module::Build now adds itself
|
||||
to C<configure_requires> by default.
|
||||
|
||||
The second way supports older Perls that have not upgraded CPAN or
|
||||
CPANPLUS and involves bundling an entire copy of Module::Build
|
||||
into the distribution's C<inc/> directory. This is the same approach
|
||||
used by L<Module::Install>, a modern wrapper around ExtUtils::MakeMaker
|
||||
for Makefile.PL based distributions.
|
||||
|
||||
The "trick" to making this work for Module::Build is making sure the
|
||||
highest version Module::Build is used, whether this is in C<inc/> or
|
||||
already installed on the user's system. This ensures that all necessary
|
||||
features are available as well as any new bug fixes. This is done using
|
||||
the new L<inc::latest> module.
|
||||
|
||||
A "normal" Build.PL looks like this (with only the minimum required
|
||||
fields):
|
||||
|
||||
use Module::Build;
|
||||
|
||||
Module::Build->new(
|
||||
module_name => 'Foo::Bar',
|
||||
license => 'perl',
|
||||
)->create_build_script;
|
||||
|
||||
A "bundling" Build.PL replaces the initial "use" line with a nearly
|
||||
transparent replacement:
|
||||
|
||||
use inc::latest 'Module::Build';
|
||||
|
||||
Module::Build->new(
|
||||
module_name => 'Foo::Bar',
|
||||
license => 'perl',
|
||||
)->create_build_script;
|
||||
|
||||
For I<authors>, when "Build dist" is run, Module::Build will be
|
||||
automatically bundled into C<inc> according to the rules for
|
||||
L<inc::latest>.
|
||||
|
||||
For I<users>, inc::latest will load the latest Module::Build, whether
|
||||
installed or bundled in C<inc/>.
|
||||
|
||||
=head1 BUNDLING OTHER CONFIGURATION DEPENDENCIES
|
||||
|
||||
The same approach works for other configuration dependencies -- modules
|
||||
that I<must> be available for Build.PL to run. All other dependencies can
|
||||
be specified as usual in the Build.PL and CPAN or CPANPLUS will install
|
||||
them after Build.PL finishes.
|
||||
|
||||
For example, to bundle the L<Devel::AssertOS::Unix> module (which ensures a
|
||||
"Unix-like" operating system), one could do this:
|
||||
|
||||
use inc::latest 'Devel::AssertOS::Unix';
|
||||
use inc::latest 'Module::Build';
|
||||
|
||||
Module::Build->new(
|
||||
module_name => 'Foo::Bar',
|
||||
license => 'perl',
|
||||
)->create_build_script;
|
||||
|
||||
The C<inc::latest> module creates bundled directories based on the packlist
|
||||
file of an installed distribution. Even though C<inc::latest> takes module
|
||||
name arguments, it is better to think of it as bundling and making
|
||||
available entire I<distributions>. When a module is loaded through
|
||||
C<inc::latest>, it looks in all bundled distributions in C<inc/> for a
|
||||
newer module than can be found in the existing C<@INC> array.
|
||||
|
||||
Thus, the module-name provided should usually be the "top-level" module
|
||||
name of a distribution, though this is not strictly required. For example,
|
||||
L<Module::Build> has a number of heuristics to map module names to
|
||||
packlists, allowing users to do things like this:
|
||||
|
||||
use inc::latest 'Devel::AssertOS::Unix';
|
||||
|
||||
even though Devel::AssertOS::Unix is contained within the Devel-CheckOS
|
||||
distribution.
|
||||
|
||||
At the current time, packlists are required. Thus, bundling dual-core
|
||||
modules, I<including Module::Build>, may require a 'forced install' over
|
||||
versions in the latest version of perl in order to create the necessary
|
||||
packlist for bundling. This limitation will hopefully be addressed in a
|
||||
future version of Module::Build.
|
||||
|
||||
=head2 WARNING -- How to Manage Dependency Chains
|
||||
|
||||
Before bundling a distribution you must ensure that all prerequisites are
|
||||
also bundled and load in the correct order. For Module::Build itself, this
|
||||
should not be necessary, but it is necessary for any other distribution.
|
||||
(A future release of Module::Build will hopefully address this deficiency.)
|
||||
|
||||
For example, if you need C<Wibble>, but C<Wibble> depends on C<Wobble>,
|
||||
your Build.PL might look like this:
|
||||
|
||||
use inc::latest 'Wobble';
|
||||
use inc::latest 'Wibble';
|
||||
use inc::latest 'Module::Build';
|
||||
|
||||
Module::Build->new(
|
||||
module_name => 'Foo::Bar',
|
||||
license => 'perl',
|
||||
)->create_build_script;
|
||||
|
||||
Authors are strongly suggested to limit the bundling of additional
|
||||
dependencies if at all possible and to carefully test their distribution
|
||||
tarballs on older versions of Perl before uploading to CPAN.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
David Golden <dagolden@cpan.org>
|
||||
|
||||
Development questions, bug reports, and patches should be sent to the
|
||||
Module-Build mailing list at <module-build@perl.org>.
|
||||
|
||||
Bug reports are also welcome at
|
||||
<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Module-Build>.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
perl(1), L<inc::latest>, L<Module::Build>(3), L<Module::Build::API>(3),
|
||||
L<Module::Build::Cookbook>(3),
|
||||
|
||||
=cut
|
||||
|
||||
# vim: tw=75
|
||||
@@ -1,632 +0,0 @@
|
||||
package Module::Build::Compat;
|
||||
|
||||
use strict;
|
||||
use vars qw($VERSION);
|
||||
$VERSION = '0.4206';
|
||||
|
||||
use File::Basename ();
|
||||
use File::Spec;
|
||||
use Config;
|
||||
use Module::Build;
|
||||
use Module::Build::ModuleInfo;
|
||||
use Module::Build::Version;
|
||||
use Data::Dumper;
|
||||
|
||||
my %convert_installdirs = (
|
||||
PERL => 'core',
|
||||
SITE => 'site',
|
||||
VENDOR => 'vendor',
|
||||
);
|
||||
|
||||
my %makefile_to_build =
|
||||
(
|
||||
TEST_VERBOSE => 'verbose',
|
||||
VERBINST => 'verbose',
|
||||
INC => sub { map {(extra_compiler_flags => $_)} Module::Build->split_like_shell(shift) },
|
||||
POLLUTE => sub { (extra_compiler_flags => '-DPERL_POLLUTE') },
|
||||
INSTALLDIRS => sub { (installdirs => $convert_installdirs{uc shift()}) },
|
||||
LIB => sub {
|
||||
my $lib = shift;
|
||||
my %config = (
|
||||
installprivlib => $lib,
|
||||
installsitelib => $lib,
|
||||
installarchlib => "$lib/$Config{archname}",
|
||||
installsitearch => "$lib/$Config{archname}"
|
||||
);
|
||||
return map { (config => "$_=$config{$_}") } keys %config;
|
||||
},
|
||||
|
||||
# Convert INSTALLVENDORLIB and friends.
|
||||
(
|
||||
map {
|
||||
my $name = $_;
|
||||
$name => sub {
|
||||
my @ret = (config => lc($name) . "=" . shift );
|
||||
print STDERR "# Converted to @ret\n";
|
||||
|
||||
return @ret;
|
||||
}
|
||||
} qw(
|
||||
INSTALLARCHLIB INSTALLSITEARCH INSTALLVENDORARCH
|
||||
INSTALLPRIVLIB INSTALLSITELIB INSTALLVENDORLIB
|
||||
INSTALLBIN INSTALLSITEBIN INSTALLVENDORBIN
|
||||
INSTALLSCRIPT INSTALLSITESCRIPT INSTALLVENDORSCRIPT
|
||||
INSTALLMAN1DIR INSTALLSITEMAN1DIR INSTALLVENDORMAN1DIR
|
||||
INSTALLMAN3DIR INSTALLSITEMAN3DIR INSTALLVENDORMAN3DIR
|
||||
)
|
||||
),
|
||||
|
||||
# Some names they have in common
|
||||
map {$_, lc($_)} qw(DESTDIR PREFIX INSTALL_BASE UNINST),
|
||||
);
|
||||
|
||||
my %macro_to_build = %makefile_to_build;
|
||||
# "LIB=foo make" is not the same as "perl Makefile.PL LIB=foo"
|
||||
delete $macro_to_build{LIB};
|
||||
|
||||
sub _merge_prereq {
|
||||
my ($req, $breq) = @_;
|
||||
$req ||= {};
|
||||
$breq ||= {};
|
||||
|
||||
# validate formats
|
||||
for my $p ( $req, $breq ) {
|
||||
for my $k (keys %$p) {
|
||||
next if $k eq 'perl';
|
||||
|
||||
my $v_obj = eval { Module::Build::Version->new($p->{$k}) };
|
||||
if ( ! defined $v_obj ) {
|
||||
die "A prereq of the form '$p->{$k}' for '$k' is not supported by Module::Build::Compat ( use a simpler version like '0.05' or 'v1.4.25' )\n";
|
||||
}
|
||||
|
||||
# It seems like a lot of people trip over "0.1.2" stuff, so we help them here...
|
||||
if ( $v_obj->is_qv ) {
|
||||
my $proper_ver = $v_obj->numify;
|
||||
warn "Dotted-decimal prereq '$p->{$k}' for '$k' is not portable - converting it to '$proper_ver'\n";
|
||||
$p->{$k} = $proper_ver;
|
||||
}
|
||||
}
|
||||
}
|
||||
# merge
|
||||
my $merge = { %$req };
|
||||
for my $k ( keys %$breq ) {
|
||||
my $v1 = $merge->{$k} || 0;
|
||||
my $v2 = $breq->{$k};
|
||||
$merge->{$k} = $v1 > $v2 ? $v1 : $v2;
|
||||
}
|
||||
return %$merge;
|
||||
}
|
||||
|
||||
|
||||
sub create_makefile_pl {
|
||||
my ($package, $type, $build, %args) = @_;
|
||||
|
||||
die "Don't know how to build Makefile.PL of type '$type'"
|
||||
unless $type =~ /^(small|passthrough|traditional)$/;
|
||||
|
||||
if ($type eq 'passthrough') {
|
||||
$build->log_warn(<<"HERE");
|
||||
|
||||
IMPORTANT NOTE: The '$type' style of Makefile.PL is deprecated and
|
||||
may be removed in a future version of Module::Build in favor of the
|
||||
'configure_requires' property. See Module::Build::Compat
|
||||
documentation for details.
|
||||
|
||||
HERE
|
||||
}
|
||||
|
||||
my $fh;
|
||||
if ($args{fh}) {
|
||||
$fh = $args{fh};
|
||||
} else {
|
||||
$args{file} ||= 'Makefile.PL';
|
||||
local $build->{properties}{quiet} = 1;
|
||||
$build->delete_filetree($args{file});
|
||||
open($fh, '>', "$args{file}") or die "Can't write $args{file}: $!";
|
||||
}
|
||||
|
||||
print {$fh} "# Note: this file was auto-generated by ", __PACKAGE__, " version $VERSION\n";
|
||||
|
||||
# Minimum perl version should be specified as "require 5.XXXXXX" in
|
||||
# Makefile.PL
|
||||
my $requires = $build->requires;
|
||||
if ( my $minimum_perl = $requires->{perl} ) {
|
||||
my $min_ver = Module::Build::Version->new($minimum_perl)->numify;
|
||||
print {$fh} "require $min_ver;\n";
|
||||
}
|
||||
|
||||
# If a *bundled* custom subclass is being used, make sure we add its
|
||||
# directory to @INC. Also, lib.pm always needs paths in Unix format.
|
||||
my $subclass_load = '';
|
||||
if (ref($build) ne "Module::Build") {
|
||||
my $subclass_dir = $package->subclass_dir($build);
|
||||
|
||||
if (File::Spec->file_name_is_absolute($subclass_dir)) {
|
||||
my $base_dir = $build->base_dir;
|
||||
|
||||
if ($build->dir_contains($base_dir, $subclass_dir)) {
|
||||
$subclass_dir = File::Spec->abs2rel($subclass_dir, $base_dir);
|
||||
$subclass_dir = $package->unixify_dir($subclass_dir);
|
||||
$subclass_load = "use lib '$subclass_dir';";
|
||||
}
|
||||
# Otherwise, leave it the empty string
|
||||
|
||||
} else {
|
||||
$subclass_dir = $package->unixify_dir($subclass_dir);
|
||||
$subclass_load = "use lib '$subclass_dir';";
|
||||
}
|
||||
}
|
||||
|
||||
if ($type eq 'small') {
|
||||
printf {$fh} <<'EOF', $subclass_load, ref($build), ref($build);
|
||||
use Module::Build::Compat 0.02;
|
||||
%s
|
||||
Module::Build::Compat->run_build_pl(args => \@ARGV);
|
||||
require %s;
|
||||
Module::Build::Compat->write_makefile(build_class => '%s');
|
||||
EOF
|
||||
|
||||
} elsif ($type eq 'passthrough') {
|
||||
printf {$fh} <<'EOF', $subclass_load, ref($build), ref($build);
|
||||
|
||||
unless (eval "use Module::Build::Compat 0.02; 1" ) {
|
||||
print "This module requires Module::Build to install itself.\n";
|
||||
|
||||
require ExtUtils::MakeMaker;
|
||||
my $yn = ExtUtils::MakeMaker::prompt
|
||||
(' Install Module::Build now from CPAN?', 'y');
|
||||
|
||||
unless ($yn =~ /^y/i) {
|
||||
die " *** Cannot install without Module::Build. Exiting ...\n";
|
||||
}
|
||||
|
||||
require Cwd;
|
||||
require File::Spec;
|
||||
require CPAN;
|
||||
|
||||
# Save this 'cause CPAN will chdir all over the place.
|
||||
my $cwd = Cwd::cwd();
|
||||
|
||||
CPAN::Shell->install('Module::Build::Compat');
|
||||
CPAN::Shell->expand("Module", "Module::Build::Compat")->uptodate
|
||||
or die "Couldn't install Module::Build, giving up.\n";
|
||||
|
||||
chdir $cwd or die "Cannot chdir() back to $cwd: $!";
|
||||
}
|
||||
eval "use Module::Build::Compat 0.02; 1" or die $@;
|
||||
%s
|
||||
Module::Build::Compat->run_build_pl(args => \@ARGV);
|
||||
my $build_script = 'Build';
|
||||
$build_script .= '.com' if $^O eq 'VMS';
|
||||
exit(0) unless(-e $build_script); # cpantesters convention
|
||||
require %s;
|
||||
Module::Build::Compat->write_makefile(build_class => '%s');
|
||||
EOF
|
||||
|
||||
} elsif ($type eq 'traditional') {
|
||||
|
||||
my (%MM_Args, %prereq);
|
||||
if (eval "use Tie::IxHash 1.2; 1") {
|
||||
tie %MM_Args, 'Tie::IxHash'; # Don't care if it fails here
|
||||
tie %prereq, 'Tie::IxHash'; # Don't care if it fails here
|
||||
}
|
||||
|
||||
my %name = ($build->module_name
|
||||
? (NAME => $build->module_name)
|
||||
: (DISTNAME => $build->dist_name));
|
||||
|
||||
my %version = ($build->dist_version_from
|
||||
? (VERSION_FROM => $build->dist_version_from)
|
||||
: (VERSION => $build->dist_version)
|
||||
);
|
||||
%MM_Args = (%name, %version);
|
||||
|
||||
%prereq = _merge_prereq( $build->requires, $build->build_requires );
|
||||
%prereq = map {$_, $prereq{$_}} sort keys %prereq;
|
||||
|
||||
delete $prereq{perl};
|
||||
$MM_Args{PREREQ_PM} = \%prereq;
|
||||
|
||||
$MM_Args{INSTALLDIRS} = $build->installdirs eq 'core' ? 'perl' : $build->installdirs;
|
||||
|
||||
$MM_Args{EXE_FILES} = [ sort keys %{$build->script_files} ] if $build->script_files;
|
||||
|
||||
$MM_Args{PL_FILES} = $build->PL_files || {};
|
||||
|
||||
if ($build->recursive_test_files) {
|
||||
$MM_Args{test} = { TESTS => join q{ }, $package->_test_globs($build) };
|
||||
}
|
||||
|
||||
local $Data::Dumper::Terse = 1;
|
||||
my $args = Data::Dumper::Dumper(\%MM_Args);
|
||||
$args =~ s/\{(.*)\}/($1)/s;
|
||||
|
||||
print $fh <<"EOF";
|
||||
use ExtUtils::MakeMaker;
|
||||
WriteMakefile
|
||||
$args;
|
||||
EOF
|
||||
}
|
||||
}
|
||||
|
||||
sub _test_globs {
|
||||
my ($self, $build) = @_;
|
||||
|
||||
return map { File::Spec->catfile($_, '*.t') }
|
||||
@{$build->rscan_dir('t', sub { -d $File::Find::name })};
|
||||
}
|
||||
|
||||
sub subclass_dir {
|
||||
my ($self, $build) = @_;
|
||||
|
||||
return (Module::Build::ModuleInfo->find_module_dir_by_name(ref $build)
|
||||
|| File::Spec->catdir($build->config_dir, 'lib'));
|
||||
}
|
||||
|
||||
sub unixify_dir {
|
||||
my ($self, $path) = @_;
|
||||
return join '/', File::Spec->splitdir($path);
|
||||
}
|
||||
|
||||
sub makefile_to_build_args {
|
||||
my $class = shift;
|
||||
my @out;
|
||||
foreach my $arg (@_) {
|
||||
next if $arg eq '';
|
||||
|
||||
my ($key, $val) = ($arg =~ /^(\w+)=(.+)/ ? ($1, $2) :
|
||||
die "Malformed argument '$arg'");
|
||||
|
||||
# Do tilde-expansion if it looks like a tilde prefixed path
|
||||
( $val ) = Module::Build->_detildefy( $val ) if $val =~ /^~/;
|
||||
|
||||
if (exists $makefile_to_build{$key}) {
|
||||
my $trans = $makefile_to_build{$key};
|
||||
push @out, $class->_argvify( ref($trans) ? $trans->($val) : ($trans => $val) );
|
||||
} elsif (exists $Config{lc($key)}) {
|
||||
push @out, $class->_argvify( config => lc($key) . "=$val" );
|
||||
} else {
|
||||
# Assume M::B can handle it in lowercase form
|
||||
push @out, $class->_argvify("\L$key" => $val);
|
||||
}
|
||||
}
|
||||
return @out;
|
||||
}
|
||||
|
||||
sub _argvify {
|
||||
my ($self, @pairs) = @_;
|
||||
my @out;
|
||||
while (@pairs) {
|
||||
my ($k, $v) = splice @pairs, 0, 2;
|
||||
push @out, ("--$k", $v);
|
||||
}
|
||||
return @out;
|
||||
}
|
||||
|
||||
sub makefile_to_build_macros {
|
||||
my @out;
|
||||
my %config; # must accumulate and return as a hashref
|
||||
while (my ($macro, $trans) = each %macro_to_build) {
|
||||
# On some platforms (e.g. Cygwin with 'make'), the mere presence
|
||||
# of "EXPORT: FOO" in the Makefile will make $ENV{FOO} defined.
|
||||
# Therefore we check length() too.
|
||||
next unless exists $ENV{$macro} && length $ENV{$macro};
|
||||
my $val = $ENV{$macro};
|
||||
my @args = ref($trans) ? $trans->($val) : ($trans => $val);
|
||||
while (@args) {
|
||||
my ($k, $v) = splice(@args, 0, 2);
|
||||
if ( $k eq 'config' ) {
|
||||
if ( $v =~ /^([^=]+)=(.*)$/ ) {
|
||||
$config{$1} = $2;
|
||||
}
|
||||
else {
|
||||
warn "Couldn't parse config '$v'\n";
|
||||
}
|
||||
}
|
||||
else {
|
||||
push @out, ($k => $v);
|
||||
}
|
||||
}
|
||||
}
|
||||
push @out, (config => \%config) if %config;
|
||||
return @out;
|
||||
}
|
||||
|
||||
sub run_build_pl {
|
||||
my ($pack, %in) = @_;
|
||||
$in{script} ||= 'Build.PL';
|
||||
my @args = $in{args} ? $pack->makefile_to_build_args(@{$in{args}}) : ();
|
||||
print "# running $in{script} @args\n";
|
||||
Module::Build->run_perl_script($in{script}, [], \@args) or die "Couldn't run $in{script}: $!";
|
||||
}
|
||||
|
||||
sub fake_makefile {
|
||||
my ($self, %args) = @_;
|
||||
unless (exists $args{build_class}) {
|
||||
warn "Unknown 'build_class', defaulting to 'Module::Build'\n";
|
||||
$args{build_class} = 'Module::Build';
|
||||
}
|
||||
my $class = $args{build_class};
|
||||
|
||||
my $perl = $class->find_perl_interpreter;
|
||||
|
||||
# VMS MMS/MMK need to use MCR to run the Perl image.
|
||||
$perl = 'MCR ' . $perl if $self->_is_vms_mms;
|
||||
|
||||
my $noop = ($class->is_windowsish ? 'rem>nul' :
|
||||
$self->_is_vms_mms ? 'Continue' :
|
||||
'true');
|
||||
|
||||
my $filetype = $class->is_vmsish ? '.COM' : '';
|
||||
|
||||
my $Build = 'Build' . $filetype . ' --makefile_env_macros 1';
|
||||
my $unlink = $class->oneliner('1 while unlink $ARGV[0]', [], [$args{makefile}]);
|
||||
$unlink =~ s/\$/\$\$/g unless $class->is_vmsish;
|
||||
|
||||
my $maketext = ($^O eq 'os2' ? "SHELL = sh\n\n" : '');
|
||||
|
||||
$maketext .= <<"EOF";
|
||||
all : force_do_it
|
||||
$perl $Build
|
||||
realclean : force_do_it
|
||||
$perl $Build realclean
|
||||
$unlink
|
||||
distclean : force_do_it
|
||||
$perl $Build distclean
|
||||
$unlink
|
||||
|
||||
|
||||
force_do_it :
|
||||
@ $noop
|
||||
EOF
|
||||
|
||||
foreach my $action ($class->known_actions) {
|
||||
next if $action =~ /^(all|distclean|realclean|force_do_it)$/; # Don't double-define
|
||||
$maketext .= <<"EOF";
|
||||
$action : force_do_it
|
||||
$perl $Build $action
|
||||
EOF
|
||||
}
|
||||
|
||||
if ($self->_is_vms_mms) {
|
||||
# Roll our own .EXPORT as MMS/MMK don't honor that directive.
|
||||
$maketext .= "\n.FIRST\n\t\@ $noop\n";
|
||||
for my $macro (keys %macro_to_build) {
|
||||
$maketext .= ".IFDEF $macro\n\tDEFINE $macro \"\$($macro)\"\n.ENDIF\n";
|
||||
}
|
||||
$maketext .= "\n";
|
||||
}
|
||||
else {
|
||||
$maketext .= "\n.EXPORT : " . join(' ', keys %macro_to_build) . "\n\n";
|
||||
}
|
||||
|
||||
return $maketext;
|
||||
}
|
||||
|
||||
sub fake_prereqs {
|
||||
my $file = File::Spec->catfile('_build', 'prereqs');
|
||||
open(my $fh, '<', "$file") or die "Can't read $file: $!";
|
||||
my $prereqs = eval do {local $/; <$fh>};
|
||||
close $fh;
|
||||
|
||||
my %merged = _merge_prereq( $prereqs->{requires}, $prereqs->{build_requires} );
|
||||
my @prereq;
|
||||
foreach (sort keys %merged) {
|
||||
next if $_ eq 'perl';
|
||||
push @prereq, "$_=>q[$merged{$_}]";
|
||||
}
|
||||
return unless @prereq;
|
||||
return "# PREREQ_PM => { " . join(", ", @prereq) . " }\n\n";
|
||||
}
|
||||
|
||||
|
||||
sub write_makefile {
|
||||
my ($pack, %in) = @_;
|
||||
|
||||
unless (exists $in{build_class}) {
|
||||
warn "Unknown 'build_class', defaulting to 'Module::Build'\n";
|
||||
$in{build_class} = 'Module::Build';
|
||||
}
|
||||
my $class = $in{build_class};
|
||||
$in{makefile} ||= $pack->_is_vms_mms ? 'Descrip.MMS' : 'Makefile';
|
||||
|
||||
open MAKE, "> $in{makefile}" or die "Cannot write $in{makefile}: $!";
|
||||
print MAKE $pack->fake_prereqs;
|
||||
print MAKE $pack->fake_makefile(%in);
|
||||
close MAKE;
|
||||
}
|
||||
|
||||
sub _is_vms_mms {
|
||||
return Module::Build->is_vmsish && ($Config{make} =~ m/MM[SK]/i);
|
||||
}
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
=for :stopwords passthrough
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Module::Build::Compat - Compatibility with ExtUtils::MakeMaker
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
# In a Build.PL :
|
||||
use Module::Build;
|
||||
my $build = Module::Build->new
|
||||
( module_name => 'Foo::Bar',
|
||||
license => 'perl',
|
||||
create_makefile_pl => 'traditional' );
|
||||
...
|
||||
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Because C<ExtUtils::MakeMaker> has been the standard way to distribute
|
||||
modules for a long time, many tools (CPAN.pm, or your system
|
||||
administrator) may expect to find a working F<Makefile.PL> in every
|
||||
distribution they download from CPAN. If you want to throw them a
|
||||
bone, you can use C<Module::Build::Compat> to automatically generate a
|
||||
F<Makefile.PL> for you, in one of several different styles.
|
||||
|
||||
C<Module::Build::Compat> also provides some code that helps out the
|
||||
F<Makefile.PL> at runtime.
|
||||
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=over 4
|
||||
|
||||
=item create_makefile_pl($style, $build)
|
||||
|
||||
Creates a F<Makefile.PL> in the current directory in one of several
|
||||
styles, based on the supplied C<Module::Build> object C<$build>. This is
|
||||
typically controlled by passing the desired style as the
|
||||
C<create_makefile_pl> parameter to C<Module::Build>'s C<new()> method;
|
||||
the F<Makefile.PL> will then be automatically created during the
|
||||
C<distdir> action.
|
||||
|
||||
The currently supported styles are:
|
||||
|
||||
=over 4
|
||||
|
||||
=item traditional
|
||||
|
||||
A F<Makefile.PL> will be created in the "traditional" style, i.e. it will
|
||||
use C<ExtUtils::MakeMaker> and won't rely on C<Module::Build> at all.
|
||||
In order to create the F<Makefile.PL>, we'll include the C<requires> and
|
||||
C<build_requires> dependencies as the C<PREREQ_PM> parameter.
|
||||
|
||||
You don't want to use this style if during the C<perl Build.PL> stage
|
||||
you ask the user questions, or do some auto-sensing about the user's
|
||||
environment, or if you subclass C<Module::Build> to do some
|
||||
customization, because the vanilla F<Makefile.PL> won't do any of that.
|
||||
|
||||
=item small
|
||||
|
||||
A small F<Makefile.PL> will be created that passes all functionality
|
||||
through to the F<Build.PL> script in the same directory. The user must
|
||||
already have C<Module::Build> installed in order to use this, or else
|
||||
they'll get a module-not-found error.
|
||||
|
||||
=item passthrough (DEPRECATED)
|
||||
|
||||
This is just like the C<small> option above, but if C<Module::Build> is
|
||||
not already installed on the user's system, the script will offer to
|
||||
use C<CPAN.pm> to download it and install it before continuing with
|
||||
the build.
|
||||
|
||||
This option has been deprecated and may be removed in a future version
|
||||
of Module::Build. Modern CPAN.pm and CPANPLUS will recognize the
|
||||
C<configure_requires> metadata property and install Module::Build before
|
||||
running Build.PL if Module::Build is listed and Module::Build now
|
||||
adds itself to configure_requires by default.
|
||||
|
||||
Perl 5.10.1 includes C<configure_requires> support. In the future, when
|
||||
C<configure_requires> support is deemed sufficiently widespread, the
|
||||
C<passthrough> style will be removed.
|
||||
|
||||
=back
|
||||
|
||||
=item run_build_pl(args => \@ARGV)
|
||||
|
||||
This method runs the F<Build.PL> script, passing it any arguments the
|
||||
user may have supplied to the C<perl Makefile.PL> command. Because
|
||||
C<ExtUtils::MakeMaker> and C<Module::Build> accept different arguments, this
|
||||
method also performs some translation between the two.
|
||||
|
||||
C<run_build_pl()> accepts the following named parameters:
|
||||
|
||||
=over 4
|
||||
|
||||
=item args
|
||||
|
||||
The C<args> parameter specifies the parameters that would usually
|
||||
appear on the command line of the C<perl Makefile.PL> command -
|
||||
typically you'll just pass a reference to C<@ARGV>.
|
||||
|
||||
=item script
|
||||
|
||||
This is the filename of the script to run - it defaults to C<Build.PL>.
|
||||
|
||||
=back
|
||||
|
||||
=item write_makefile()
|
||||
|
||||
This method writes a 'dummy' F<Makefile> that will pass all commands
|
||||
through to the corresponding C<Module::Build> actions.
|
||||
|
||||
C<write_makefile()> accepts the following named parameters:
|
||||
|
||||
=over 4
|
||||
|
||||
=item makefile
|
||||
|
||||
The name of the file to write - defaults to the string C<Makefile>.
|
||||
|
||||
=back
|
||||
|
||||
=back
|
||||
|
||||
|
||||
=head1 SCENARIOS
|
||||
|
||||
So, some common scenarios are:
|
||||
|
||||
=over 4
|
||||
|
||||
=item 1.
|
||||
|
||||
Just include a F<Build.PL> script (without a F<Makefile.PL>
|
||||
script), and give installation directions in a F<README> or F<INSTALL>
|
||||
document explaining how to install the module. In particular, explain
|
||||
that the user must install C<Module::Build> before installing your
|
||||
module.
|
||||
|
||||
Note that if you do this, you may make things easier for yourself, but
|
||||
harder for people with older versions of CPAN or CPANPLUS on their
|
||||
system, because those tools generally only understand the
|
||||
F<Makefile.PL>/C<ExtUtils::MakeMaker> way of doing things.
|
||||
|
||||
=item 2.
|
||||
|
||||
Include a F<Build.PL> script and a "traditional" F<Makefile.PL>,
|
||||
created either manually or with C<create_makefile_pl()>. Users won't
|
||||
ever have to install C<Module::Build> if they use the F<Makefile.PL>, but
|
||||
they won't get to take advantage of C<Module::Build>'s extra features
|
||||
either.
|
||||
|
||||
For good measure, of course, test both the F<Makefile.PL> and the
|
||||
F<Build.PL> before shipping.
|
||||
|
||||
=item 3.
|
||||
|
||||
Include a F<Build.PL> script and a "pass-through" F<Makefile.PL>
|
||||
built using C<Module::Build::Compat>. This will mean that people can
|
||||
continue to use the "old" installation commands, and they may never
|
||||
notice that it's actually doing something else behind the scenes. It
|
||||
will also mean that your installation process is compatible with older
|
||||
versions of tools like CPAN and CPANPLUS.
|
||||
|
||||
=back
|
||||
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Ken Williams <kwilliams@cpan.org>
|
||||
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2001-2006 Ken Williams. All rights reserved.
|
||||
|
||||
This library is free software; you can redistribute it and/or
|
||||
modify it under the same terms as Perl itself.
|
||||
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Module::Build>(3), L<ExtUtils::MakeMaker>(3)
|
||||
|
||||
|
||||
=cut
|
||||
@@ -1,59 +0,0 @@
|
||||
package Module::Build::Config;
|
||||
|
||||
use strict;
|
||||
use vars qw($VERSION);
|
||||
$VERSION = '0.4206';
|
||||
$VERSION = eval $VERSION;
|
||||
use Config;
|
||||
|
||||
sub new {
|
||||
my ($pack, %args) = @_;
|
||||
return bless {
|
||||
stack => {},
|
||||
values => $args{values} || {},
|
||||
}, $pack;
|
||||
}
|
||||
|
||||
sub get {
|
||||
my ($self, $key) = @_;
|
||||
return $self->{values}{$key} if ref($self) && exists $self->{values}{$key};
|
||||
return $Config{$key};
|
||||
}
|
||||
|
||||
sub set {
|
||||
my ($self, $key, $val) = @_;
|
||||
$self->{values}{$key} = $val;
|
||||
}
|
||||
|
||||
sub push {
|
||||
my ($self, $key, $val) = @_;
|
||||
push @{$self->{stack}{$key}}, $self->{values}{$key}
|
||||
if exists $self->{values}{$key};
|
||||
$self->{values}{$key} = $val;
|
||||
}
|
||||
|
||||
sub pop {
|
||||
my ($self, $key) = @_;
|
||||
|
||||
my $val = delete $self->{values}{$key};
|
||||
if ( exists $self->{stack}{$key} ) {
|
||||
$self->{values}{$key} = pop @{$self->{stack}{$key}};
|
||||
delete $self->{stack}{$key} unless @{$self->{stack}{$key}};
|
||||
}
|
||||
|
||||
return $val;
|
||||
}
|
||||
|
||||
sub values_set {
|
||||
my $self = shift;
|
||||
return undef unless ref($self);
|
||||
return $self->{values};
|
||||
}
|
||||
|
||||
sub all_config {
|
||||
my $self = shift;
|
||||
my $v = ref($self) ? $self->{values} : {};
|
||||
return {%Config, %$v};
|
||||
}
|
||||
|
||||
1;
|
||||
@@ -1,210 +0,0 @@
|
||||
package Module::Build::ConfigData;
|
||||
use strict;
|
||||
my $arrayref = eval do {local $/; <DATA>}
|
||||
or die "Couldn't load ConfigData data: $@";
|
||||
close DATA;
|
||||
my ($config, $features, $auto_features) = @$arrayref;
|
||||
|
||||
sub config { $config->{$_[1]} }
|
||||
|
||||
sub set_config { $config->{$_[1]} = $_[2] }
|
||||
sub set_feature { $features->{$_[1]} = 0+!!$_[2] } # Constrain to 1 or 0
|
||||
|
||||
sub auto_feature_names { grep !exists $features->{$_}, keys %$auto_features }
|
||||
|
||||
sub feature_names {
|
||||
my @features = (keys %$features, auto_feature_names());
|
||||
@features;
|
||||
}
|
||||
|
||||
sub config_names { keys %$config }
|
||||
|
||||
sub write {
|
||||
my $me = __FILE__;
|
||||
|
||||
# Can't use Module::Build::Dumper here because M::B is only a
|
||||
# build-time prereq of this module
|
||||
require Data::Dumper;
|
||||
|
||||
my $mode_orig = (stat $me)[2] & 07777;
|
||||
chmod($mode_orig | 0222, $me); # Make it writeable
|
||||
open(my $fh, '+<', $me) or die "Can't rewrite $me: $!";
|
||||
seek($fh, 0, 0);
|
||||
while (<$fh>) {
|
||||
last if /^__DATA__$/;
|
||||
}
|
||||
die "Couldn't find __DATA__ token in $me" if eof($fh);
|
||||
|
||||
seek($fh, tell($fh), 0);
|
||||
my $data = [$config, $features, $auto_features];
|
||||
print($fh 'do{ my '
|
||||
. Data::Dumper->new([$data],['x'])->Purity(1)->Dump()
|
||||
. '$x; }' );
|
||||
truncate($fh, tell($fh));
|
||||
close $fh;
|
||||
|
||||
chmod($mode_orig, $me)
|
||||
or warn "Couldn't restore permissions on $me: $!";
|
||||
}
|
||||
|
||||
sub feature {
|
||||
my ($package, $key) = @_;
|
||||
return $features->{$key} if exists $features->{$key};
|
||||
|
||||
my $info = $auto_features->{$key} or return 0;
|
||||
|
||||
# Under perl 5.005, each(%$foo) isn't working correctly when $foo
|
||||
# was reanimated with Data::Dumper and eval(). Not sure why, but
|
||||
# copying to a new hash seems to solve it.
|
||||
my %info = %$info;
|
||||
|
||||
require Module::Build; # XXX should get rid of this
|
||||
while (my ($type, $prereqs) = each %info) {
|
||||
next if $type eq 'description' || $type eq 'recommends';
|
||||
|
||||
my %p = %$prereqs; # Ditto here.
|
||||
while (my ($modname, $spec) = each %p) {
|
||||
my $status = Module::Build->check_installed_status($modname, $spec);
|
||||
if ((!$status->{ok}) xor ($type =~ /conflicts$/)) { return 0; }
|
||||
if ( ! eval "require $modname; 1" ) { return 0; }
|
||||
}
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Module::Build::ConfigData - Configuration for Module::Build
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Module::Build::ConfigData;
|
||||
$value = Module::Build::ConfigData->config('foo');
|
||||
$value = Module::Build::ConfigData->feature('bar');
|
||||
|
||||
@names = Module::Build::ConfigData->config_names;
|
||||
@names = Module::Build::ConfigData->feature_names;
|
||||
|
||||
Module::Build::ConfigData->set_config(foo => $new_value);
|
||||
Module::Build::ConfigData->set_feature(bar => $new_value);
|
||||
Module::Build::ConfigData->write; # Save changes
|
||||
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module holds the configuration data for the C<Module::Build>
|
||||
module. It also provides a programmatic interface for getting or
|
||||
setting that configuration data. Note that in order to actually make
|
||||
changes, you'll have to have write access to the C<Module::Build::ConfigData>
|
||||
module, and you should attempt to understand the repercussions of your
|
||||
actions.
|
||||
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=over 4
|
||||
|
||||
=item config($name)
|
||||
|
||||
Given a string argument, returns the value of the configuration item
|
||||
by that name, or C<undef> if no such item exists.
|
||||
|
||||
=item feature($name)
|
||||
|
||||
Given a string argument, returns the value of the feature by that
|
||||
name, or C<undef> if no such feature exists.
|
||||
|
||||
=item set_config($name, $value)
|
||||
|
||||
Sets the configuration item with the given name to the given value.
|
||||
The value may be any Perl scalar that will serialize correctly using
|
||||
C<Data::Dumper>. This includes references, objects (usually), and
|
||||
complex data structures. It probably does not include transient
|
||||
things like filehandles or sockets.
|
||||
|
||||
=item set_feature($name, $value)
|
||||
|
||||
Sets the feature with the given name to the given boolean value. The
|
||||
value will be converted to 0 or 1 automatically.
|
||||
|
||||
=item config_names()
|
||||
|
||||
Returns a list of all the names of config items currently defined in
|
||||
C<Module::Build::ConfigData>, or in scalar context the number of items.
|
||||
|
||||
=item feature_names()
|
||||
|
||||
Returns a list of all the names of features currently defined in
|
||||
C<Module::Build::ConfigData>, or in scalar context the number of features.
|
||||
|
||||
=item auto_feature_names()
|
||||
|
||||
Returns a list of all the names of features whose availability is
|
||||
dynamically determined, or in scalar context the number of such
|
||||
features. Does not include such features that have later been set to
|
||||
a fixed value.
|
||||
|
||||
=item write()
|
||||
|
||||
Commits any changes from C<set_config()> and C<set_feature()> to disk.
|
||||
Requires write access to the C<Module::Build::ConfigData> module.
|
||||
|
||||
=back
|
||||
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
C<Module::Build::ConfigData> was automatically created using C<Module::Build>.
|
||||
C<Module::Build> was written by Ken Williams, but he holds no
|
||||
authorship claim or copyright claim to the contents of C<Module::Build::ConfigData>.
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
__DATA__
|
||||
do{ my $x = [
|
||||
{},
|
||||
{},
|
||||
{
|
||||
'PPM_support' => {
|
||||
'description' => 'Generate PPM files for distributions'
|
||||
},
|
||||
'HTML_support' => {
|
||||
'requires' => {
|
||||
'Pod::Html' => 0
|
||||
},
|
||||
'description' => 'Create HTML documentation'
|
||||
},
|
||||
'dist_authoring' => {
|
||||
'description' => 'Create new distributions',
|
||||
'recommends' => {
|
||||
'Module::Signature' => '0.21',
|
||||
'Pod::Readme' => '0.04'
|
||||
},
|
||||
'requires' => {
|
||||
'Archive::Tar' => '1.09'
|
||||
}
|
||||
},
|
||||
'manpage_support' => {
|
||||
'description' => 'Create Unix man pages',
|
||||
'requires' => {
|
||||
'Pod::Man' => 0
|
||||
}
|
||||
},
|
||||
'inc_bundling_support' => {
|
||||
'description' => 'Bundle Module::Build in inc/',
|
||||
'requires' => {
|
||||
'ExtUtils::Installed' => '1.999',
|
||||
'ExtUtils::Install' => '1.54'
|
||||
}
|
||||
},
|
||||
'license_creation' => {
|
||||
'description' => 'Create licenses automatically in distributions',
|
||||
'requires' => {
|
||||
'Software::License' => '0.103009'
|
||||
}
|
||||
}
|
||||
}
|
||||
];
|
||||
$x; }
|
||||
@@ -1,529 +0,0 @@
|
||||
package Module::Build::Cookbook;
|
||||
use strict;
|
||||
use vars qw($VERSION);
|
||||
$VERSION = '0.4206';
|
||||
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Module::Build::Cookbook - Examples of Module::Build Usage
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
C<Module::Build> isn't conceptually very complicated, but examples are
|
||||
always helpful. The following recipes should help developers and/or
|
||||
installers put together the pieces from the other parts of the
|
||||
documentation.
|
||||
|
||||
|
||||
=head1 BASIC RECIPES
|
||||
|
||||
|
||||
=head2 Installing modules that use Module::Build
|
||||
|
||||
In most cases, you can just issue the following commands:
|
||||
|
||||
perl Build.PL
|
||||
./Build
|
||||
./Build test
|
||||
./Build install
|
||||
|
||||
There's nothing complicated here - first you're running a script
|
||||
called F<Build.PL>, then you're running a (newly-generated) script
|
||||
called F<Build> and passing it various arguments.
|
||||
|
||||
The exact commands may vary a bit depending on how you invoke perl
|
||||
scripts on your system. For instance, if you have multiple versions
|
||||
of perl installed, you can install to one particular perl's library
|
||||
directories like so:
|
||||
|
||||
/usr/bin/perl5.8.1 Build.PL
|
||||
./Build
|
||||
./Build test
|
||||
./Build install
|
||||
|
||||
If you're on Windows where the current directory is always searched
|
||||
first for scripts, you'll probably do something like this:
|
||||
|
||||
perl Build.PL
|
||||
Build
|
||||
Build test
|
||||
Build install
|
||||
|
||||
On the old Mac OS (version 9 or lower) using MacPerl, you can
|
||||
double-click on the F<Build.PL> script to create the F<Build> script,
|
||||
then double-click on the F<Build> script to run its C<build>, C<test>,
|
||||
and C<install> actions.
|
||||
|
||||
The F<Build> script knows what perl was used to run F<Build.PL>, so
|
||||
you don't need to re-invoke the F<Build> script with the complete perl
|
||||
path each time. If you invoke it with the I<wrong> perl path, you'll
|
||||
get a warning or a fatal error.
|
||||
|
||||
=head2 Modifying Config.pm values
|
||||
|
||||
C<Module::Build> relies heavily on various values from perl's
|
||||
C<Config.pm> to do its work. For example, default installation paths
|
||||
are given by C<installsitelib> and C<installvendorman3dir> and
|
||||
friends, C linker & compiler settings are given by C<ld>,
|
||||
C<lddlflags>, C<cc>, C<ccflags>, and so on. I<If you're pretty sure
|
||||
you know what you're doing>, you can tell C<Module::Build> to pretend
|
||||
there are different values in F<Config.pm> than what's really there,
|
||||
by passing arguments for the C<--config> parameter on the command
|
||||
line:
|
||||
|
||||
perl Build.PL --config cc=gcc --config ld=gcc
|
||||
|
||||
Inside the C<Build.PL> script the same thing can be accomplished by
|
||||
passing values for the C<config> parameter to C<new()>:
|
||||
|
||||
my $build = Module::Build->new
|
||||
(
|
||||
...
|
||||
config => { cc => 'gcc', ld => 'gcc' },
|
||||
...
|
||||
);
|
||||
|
||||
In custom build code, the same thing can be accomplished by calling
|
||||
the L<Module::Build/config> method:
|
||||
|
||||
$build->config( cc => 'gcc' ); # Set
|
||||
$build->config( ld => 'gcc' ); # Set
|
||||
...
|
||||
my $linker = $build->config('ld'); # Get
|
||||
|
||||
|
||||
=head2 Installing modules using the programmatic interface
|
||||
|
||||
If you need to build, test, and/or install modules from within some
|
||||
other perl code (as opposed to having the user type installation
|
||||
commands at the shell), you can use the programmatic interface.
|
||||
Create a Module::Build object (or an object of a custom Module::Build
|
||||
subclass) and then invoke its C<dispatch()> method to run various
|
||||
actions.
|
||||
|
||||
my $build = Module::Build->new
|
||||
(
|
||||
module_name => 'Foo::Bar',
|
||||
license => 'perl',
|
||||
requires => { 'Some::Module' => '1.23' },
|
||||
);
|
||||
$build->dispatch('build');
|
||||
$build->dispatch('test', verbose => 1);
|
||||
$build->dispatch('install');
|
||||
|
||||
The first argument to C<dispatch()> is the name of the action, and any
|
||||
following arguments are named parameters.
|
||||
|
||||
This is the interface we use to test Module::Build itself in the
|
||||
regression tests.
|
||||
|
||||
|
||||
=head2 Installing to a temporary directory
|
||||
|
||||
To create packages for package managers like RedHat's C<rpm> or
|
||||
Debian's C<deb>, you may need to install to a temporary directory
|
||||
first and then create the package from that temporary installation.
|
||||
To do this, specify the C<destdir> parameter to the C<install> action:
|
||||
|
||||
./Build install --destdir /tmp/my-package-1.003
|
||||
|
||||
This essentially just prepends all the installation paths with the
|
||||
F</tmp/my-package-1.003> directory.
|
||||
|
||||
|
||||
=head2 Installing to a non-standard directory
|
||||
|
||||
To install to a non-standard directory (for example, if you don't have
|
||||
permission to install in the system-wide directories), you can use the
|
||||
C<install_base> or C<prefix> parameters:
|
||||
|
||||
./Build install --install_base /foo/bar
|
||||
|
||||
See L<Module::Build/"INSTALL PATHS"> for a much more complete
|
||||
discussion of how installation paths are determined.
|
||||
|
||||
|
||||
=head2 Installing in the same location as ExtUtils::MakeMaker
|
||||
|
||||
With the introduction of C<--prefix> in Module::Build 0.28 and
|
||||
C<INSTALL_BASE> in C<ExtUtils::MakeMaker> 6.31 its easy to get them both
|
||||
to install to the same locations.
|
||||
|
||||
First, ensure you have at least version 0.28 of Module::Build
|
||||
installed and 6.31 of C<ExtUtils::MakeMaker>. Prior versions have
|
||||
differing (and in some cases quite strange) installation behaviors.
|
||||
|
||||
The following installation flags are equivalent between
|
||||
C<ExtUtils::MakeMaker> and C<Module::Build>.
|
||||
|
||||
MakeMaker Module::Build
|
||||
PREFIX=... --prefix ...
|
||||
INSTALL_BASE=... --install_base ...
|
||||
DESTDIR=... --destdir ...
|
||||
LIB=... --install_path lib=...
|
||||
INSTALLDIRS=... --installdirs ...
|
||||
INSTALLDIRS=perl --installdirs core
|
||||
UNINST=... --uninst ...
|
||||
INC=... --extra_compiler_flags ...
|
||||
POLLUTE=1 --extra_compiler_flags -DPERL_POLLUTE
|
||||
|
||||
For example, if you are currently installing C<MakeMaker> modules with
|
||||
this command:
|
||||
|
||||
perl Makefile.PL PREFIX=~
|
||||
make test
|
||||
make install UNINST=1
|
||||
|
||||
You can install into the same location with Module::Build using this:
|
||||
|
||||
perl Build.PL --prefix ~
|
||||
./Build test
|
||||
./Build install --uninst 1
|
||||
|
||||
=head3 C<prefix> vs C<install_base>
|
||||
|
||||
The behavior of C<prefix> is complicated and depends on
|
||||
how your Perl is configured. The resulting installation locations
|
||||
will vary from machine to machine and even different installations of
|
||||
Perl on the same machine. Because of this, it's difficult to document
|
||||
where C<prefix> will place your modules.
|
||||
|
||||
In contrast, C<install_base> has predictable, easy to explain
|
||||
installation locations. Now that C<Module::Build> and C<MakeMaker> both
|
||||
have C<install_base> there is little reason to use C<prefix> other
|
||||
than to preserve your existing installation locations. If you are
|
||||
starting a fresh Perl installation we encourage you to use
|
||||
C<install_base>. If you have an existing installation installed via
|
||||
C<prefix>, consider moving it to an installation structure matching
|
||||
C<install_base> and using that instead.
|
||||
|
||||
|
||||
=head2 Running a single test file
|
||||
|
||||
C<Module::Build> supports running a single test, which enables you to
|
||||
track down errors more quickly. Use the following format:
|
||||
|
||||
./Build test --test_files t/mytest.t
|
||||
|
||||
In addition, you may want to run the test in verbose mode to get more
|
||||
informative output:
|
||||
|
||||
./Build test --test_files t/mytest.t --verbose 1
|
||||
|
||||
I run this so frequently that I define the following shell alias:
|
||||
|
||||
alias t './Build test --verbose 1 --test_files'
|
||||
|
||||
So then I can just execute C<t t/mytest.t> to run a single test.
|
||||
|
||||
|
||||
=head1 ADVANCED RECIPES
|
||||
|
||||
|
||||
=head2 Making a CPAN.pm-compatible distribution
|
||||
|
||||
New versions of CPAN.pm understand how to use a F<Build.PL> script,
|
||||
but old versions don't. If authors want to help users who have old
|
||||
versions, some form of F<Makefile.PL> should be supplied. The easiest
|
||||
way to accomplish this is to use the C<create_makefile_pl> parameter to
|
||||
C<< Module::Build->new() >> in the C<Build.PL> script, which can
|
||||
create various flavors of F<Makefile.PL> during the C<dist> action.
|
||||
|
||||
As a best practice, we recommend using the "traditional" style of
|
||||
F<Makefile.PL> unless your distribution has needs that can't be
|
||||
accomplished that way.
|
||||
|
||||
The C<Module::Build::Compat> module, which is part of
|
||||
C<Module::Build>'s distribution, is responsible for creating these
|
||||
F<Makefile.PL>s. Please see L<Module::Build::Compat> for the details.
|
||||
|
||||
|
||||
=head2 Changing the order of the build process
|
||||
|
||||
The C<build_elements> property specifies the steps C<Module::Build>
|
||||
will take when building a distribution. To change the build order,
|
||||
change the order of the entries in that property:
|
||||
|
||||
# Process pod files first
|
||||
my @e = @{$build->build_elements};
|
||||
my ($i) = grep {$e[$_] eq 'pod'} 0..$#e;
|
||||
unshift @e, splice @e, $i, 1;
|
||||
|
||||
Currently, C<build_elements> has the following default value:
|
||||
|
||||
[qw( PL support pm xs pod script )]
|
||||
|
||||
Do take care when altering this property, since there may be
|
||||
non-obvious (and non-documented!) ordering dependencies in the
|
||||
C<Module::Build> code.
|
||||
|
||||
|
||||
=head2 Adding new file types to the build process
|
||||
|
||||
Sometimes you might have extra types of files that you want to install
|
||||
alongside the standard types like F<.pm> and F<.pod> files. For
|
||||
instance, you might have a F<Bar.dat> file containing some data
|
||||
related to the C<Foo::Bar> module and you'd like for it to end up as
|
||||
F<Foo/Bar.dat> somewhere in perl's C<@INC> path so C<Foo::Bar> can
|
||||
access it easily at runtime. The following code from a sample
|
||||
C<Build.PL> file demonstrates how to accomplish this:
|
||||
|
||||
use Module::Build;
|
||||
my $build = Module::Build->new
|
||||
(
|
||||
module_name => 'Foo::Bar',
|
||||
...other stuff here...
|
||||
);
|
||||
$build->add_build_element('dat');
|
||||
$build->create_build_script;
|
||||
|
||||
This will find all F<.dat> files in the F<lib/> directory, copy them
|
||||
to the F<blib/lib/> directory during the C<build> action, and install
|
||||
them during the C<install> action.
|
||||
|
||||
If your extra files aren't located in the C<lib/> directory in your
|
||||
distribution, you can explicitly say where they are, just as you'd do
|
||||
with F<.pm> or F<.pod> files:
|
||||
|
||||
use Module::Build;
|
||||
my $build = new Module::Build
|
||||
(
|
||||
module_name => 'Foo::Bar',
|
||||
dat_files => {'some/dir/Bar.dat' => 'lib/Foo/Bar.dat'},
|
||||
...other stuff here...
|
||||
);
|
||||
$build->add_build_element('dat');
|
||||
$build->create_build_script;
|
||||
|
||||
If your extra files actually need to be created on the user's machine,
|
||||
or if they need some other kind of special processing, you'll probably
|
||||
want to subclass C<Module::Build> and create a special method to
|
||||
process them, named C<process_${kind}_files()>:
|
||||
|
||||
use Module::Build;
|
||||
my $class = Module::Build->subclass(code => <<'EOF');
|
||||
sub process_dat_files {
|
||||
my $self = shift;
|
||||
... locate and process *.dat files,
|
||||
... and create something in blib/lib/
|
||||
}
|
||||
EOF
|
||||
my $build = $class->new
|
||||
(
|
||||
module_name => 'Foo::Bar',
|
||||
...other stuff here...
|
||||
);
|
||||
$build->add_build_element('dat');
|
||||
$build->create_build_script;
|
||||
|
||||
If your extra files don't go in F<lib/> but in some other place, see
|
||||
L<"Adding new elements to the install process"> for how to actually
|
||||
get them installed.
|
||||
|
||||
Please note that these examples use some capabilities of Module::Build
|
||||
that first appeared in version 0.26. Before that it could
|
||||
still be done, but the simple cases took a bit more work.
|
||||
|
||||
|
||||
=head2 Adding new elements to the install process
|
||||
|
||||
By default, Module::Build creates seven subdirectories of the F<blib>
|
||||
directory during the build process: F<lib>, F<arch>, F<bin>,
|
||||
F<script>, F<bindoc>, F<libdoc>, and F<html> (some of these may be
|
||||
missing or empty if there's nothing to go in them). Anything copied
|
||||
to these directories during the build will eventually be installed
|
||||
during the C<install> action (see L<Module::Build/"INSTALL PATHS">.
|
||||
|
||||
If you need to create a new custom type of installable element, e.g. C<conf>,
|
||||
then you need to tell Module::Build where things in F<blib/conf/>
|
||||
should be installed. To do this, use the C<install_path> parameter to
|
||||
the C<new()> method:
|
||||
|
||||
my $build = Module::Build->new
|
||||
(
|
||||
...other stuff here...
|
||||
install_path => { conf => $installation_path }
|
||||
);
|
||||
|
||||
Or you can call the C<install_path()> method later:
|
||||
|
||||
$build->install_path(conf => $installation_path);
|
||||
|
||||
The user may also specify the path on the command line:
|
||||
|
||||
perl Build.PL --install_path conf=/foo/path/etc
|
||||
|
||||
The important part, though, is that I<somehow> the install path needs
|
||||
to be set, or else nothing in the F<blib/conf/> directory will get
|
||||
installed, and a runtime error during the C<install> action will
|
||||
result.
|
||||
|
||||
See also L<"Adding new file types to the build process"> for how to
|
||||
create the stuff in F<blib/conf/> in the first place.
|
||||
|
||||
|
||||
=head1 EXAMPLES ON CPAN
|
||||
|
||||
Several distributions on CPAN are making good use of various features
|
||||
of Module::Build. They can serve as real-world examples for others.
|
||||
|
||||
|
||||
=head2 SVN-Notify-Mirror
|
||||
|
||||
L<http://search.cpan.org/~jpeacock/SVN-Notify-Mirror/>
|
||||
|
||||
John Peacock, author of the C<SVN-Notify-Mirror> distribution, says:
|
||||
|
||||
=over 4
|
||||
|
||||
=item 1. Using C<auto_features>, I check to see whether two optional
|
||||
modules are available - SVN::Notify::Config and Net::SSH;
|
||||
|
||||
=item 2. If the S::N::Config module is loaded, I automatically
|
||||
generate test files for it during Build (using the C<PL_files>
|
||||
property).
|
||||
|
||||
=item 3. If the C<ssh_feature> is available, I ask if the user wishes
|
||||
to perform the ssh tests (since it requires a little preliminary
|
||||
setup);
|
||||
|
||||
=item 4. Only if the user has C<ssh_feature> and answers yes to the
|
||||
testing, do I generate a test file.
|
||||
|
||||
I'm sure I could not have handled this complexity with EU::MM, but it
|
||||
was very easy to do with M::B.
|
||||
|
||||
=back
|
||||
|
||||
|
||||
=head2 Modifying an action
|
||||
|
||||
Sometimes you might need an to have an action, say C<./Build install>,
|
||||
do something unusual. For instance, you might need to change the
|
||||
ownership of a file or do something else peculiar to your application.
|
||||
|
||||
You can subclass C<Module::Build> on the fly using the C<subclass()>
|
||||
method and override the methods that perform the actions. You may
|
||||
need to read through C<Module::Build::Authoring> and
|
||||
C<Module::Build::API> to find the methods you want to override. All
|
||||
"action" methods are implemented by a method called "ACTION_" followed
|
||||
by the action's name, so here's an example of how it would work for
|
||||
the C<install> action:
|
||||
|
||||
# Build.PL
|
||||
use Module::Build;
|
||||
my $class = Module::Build->subclass(
|
||||
class => "Module::Build::Custom",
|
||||
code => <<'SUBCLASS' );
|
||||
|
||||
sub ACTION_install {
|
||||
my $self = shift;
|
||||
# YOUR CODE HERE
|
||||
$self->SUPER::ACTION_install;
|
||||
}
|
||||
SUBCLASS
|
||||
|
||||
$class->new(
|
||||
module_name => 'Your::Module',
|
||||
# rest of the usual Module::Build parameters
|
||||
)->create_build_script;
|
||||
|
||||
|
||||
=head2 Adding an action
|
||||
|
||||
You can add a new C<./Build> action simply by writing the method for
|
||||
it in your subclass. Use C<depends_on> to declare that another action
|
||||
must have been run before your action.
|
||||
|
||||
For example, let's say you wanted to be able to write C<./Build
|
||||
commit> to test your code and commit it to Subversion.
|
||||
|
||||
# Build.PL
|
||||
use Module::Build;
|
||||
my $class = Module::Build->subclass(
|
||||
class => "Module::Build::Custom",
|
||||
code => <<'SUBCLASS' );
|
||||
|
||||
sub ACTION_commit {
|
||||
my $self = shift;
|
||||
|
||||
$self->depends_on("test");
|
||||
$self->do_system(qw(svn commit));
|
||||
}
|
||||
SUBCLASS
|
||||
|
||||
|
||||
=head2 Bundling Module::Build
|
||||
|
||||
Note: This section probably needs an update as the technology improves
|
||||
(see contrib/bundle.pl in the distribution).
|
||||
|
||||
Suppose you want to use some new-ish features of Module::Build,
|
||||
e.g. newer than the version of Module::Build your users are likely to
|
||||
already have installed on their systems. The first thing you should
|
||||
do is set C<configure_requires> to your minimum version of
|
||||
Module::Build. See L<Module::Build::Authoring>.
|
||||
|
||||
But not every build system honors C<configure_requires> yet. Here's
|
||||
how you can ship a copy of Module::Build, but still use a newer
|
||||
installed version to take advantage of any bug fixes and upgrades.
|
||||
|
||||
First, install Module::Build into F<Your-Project/inc/Module-Build>.
|
||||
CPAN will not index anything in the F<inc> directory so this copy will
|
||||
not show up in CPAN searches.
|
||||
|
||||
cd Module-Build
|
||||
perl Build.PL --install_base /path/to/Your-Project/inc/Module-Build
|
||||
./Build test
|
||||
./Build install
|
||||
|
||||
You should now have all the Module::Build .pm files in
|
||||
F<Your-Project/inc/Module-Build/lib/perl5>.
|
||||
|
||||
Next, add this to the top of your F<Build.PL>.
|
||||
|
||||
my $Bundled_MB = 0.30; # or whatever version it was.
|
||||
|
||||
# Find out what version of Module::Build is installed or fail quietly.
|
||||
# This should be cross-platform.
|
||||
my $Installed_MB =
|
||||
`$^X -e "eval q{require Module::Build; print Module::Build->VERSION} or exit 1";
|
||||
|
||||
# some operating systems put a newline at the end of every print.
|
||||
chomp $Installed_MB;
|
||||
|
||||
$Installed_MB = 0 if $?;
|
||||
|
||||
# Use our bundled copy of Module::Build if it's newer than the installed.
|
||||
unshift @INC, "inc/Module-Build/lib/perl5" if $Bundled_MB > $Installed_MB;
|
||||
|
||||
require Module::Build;
|
||||
|
||||
And write the rest of your F<Build.PL> normally. Module::Build will
|
||||
remember your change to C<@INC> and use it when you run F<./Build>.
|
||||
|
||||
In the future, we hope to provide a more automated solution for this
|
||||
scenario; see C<inc/latest.pm> in the Module::Build distribution for
|
||||
one indication of the direction we're moving.
|
||||
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Ken Williams <kwilliams@cpan.org>
|
||||
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2001-2008 Ken Williams. All rights reserved.
|
||||
|
||||
This library is free software; you can redistribute it and/or
|
||||
modify it under the same terms as Perl itself.
|
||||
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
perl(1), L<Module::Build>(3), L<Module::Build::Authoring>(3),
|
||||
L<Module::Build::API>(3)
|
||||
|
||||
=cut
|
||||
@@ -1,19 +0,0 @@
|
||||
package Module::Build::Dumper;
|
||||
use strict;
|
||||
use vars qw($VERSION);
|
||||
$VERSION = '0.4206';
|
||||
|
||||
# This is just a split-out of a wrapper function to do Data::Dumper
|
||||
# stuff "the right way". See:
|
||||
# http://groups.google.com/group/perl.module.build/browse_thread/thread/c8065052b2e0d741
|
||||
|
||||
use Data::Dumper;
|
||||
|
||||
sub _data_dump {
|
||||
my ($self, $data) = @_;
|
||||
return ("do{ my "
|
||||
. Data::Dumper->new([$data],['x'])->Purity(1)->Terse(0)->Dump()
|
||||
. '$x; }')
|
||||
}
|
||||
|
||||
1;
|
||||
@@ -1,34 +0,0 @@
|
||||
# -*- mode: cperl; tab-width: 8; indent-tabs-mode: nil; basic-offset: 2 -*-
|
||||
# vim:ts=8:sw=2:et:sta:sts=2
|
||||
package Module::Build::ModuleInfo;
|
||||
|
||||
use strict;
|
||||
use vars qw($VERSION);
|
||||
$VERSION = '0.4206';
|
||||
$VERSION = eval $VERSION;
|
||||
|
||||
require Module::Metadata;
|
||||
our @ISA = qw/Module::Metadata/;
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=for :stopwords ModuleInfo
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Module::Build::ModuleInfo - DEPRECATED
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module has been extracted into a separate distribution and renamed
|
||||
L<Module::Metadata>. This module is kept as a subclass wrapper for
|
||||
compatibility.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
perl(1), L<Module::Build>, L<Module::Metadata>
|
||||
|
||||
=cut
|
||||
|
||||
@@ -1,332 +0,0 @@
|
||||
package Module::Build::Notes;
|
||||
|
||||
# A class for persistent hashes
|
||||
|
||||
use strict;
|
||||
use vars qw($VERSION);
|
||||
$VERSION = '0.4206';
|
||||
$VERSION = eval $VERSION;
|
||||
use Data::Dumper;
|
||||
use Module::Build::Dumper;
|
||||
|
||||
sub new {
|
||||
my ($class, %args) = @_;
|
||||
my $file = delete $args{file} or die "Missing required parameter 'file' to new()";
|
||||
my $self = bless {
|
||||
disk => {},
|
||||
new => {},
|
||||
file => $file,
|
||||
%args,
|
||||
}, $class;
|
||||
}
|
||||
|
||||
sub restore {
|
||||
my $self = shift;
|
||||
|
||||
open(my $fh, '<', $self->{file}) or die "Can't read $self->{file}: $!";
|
||||
$self->{disk} = eval do {local $/; <$fh>};
|
||||
die $@ if $@;
|
||||
close $fh;
|
||||
$self->{new} = {};
|
||||
}
|
||||
|
||||
sub access {
|
||||
my $self = shift;
|
||||
return $self->read() unless @_;
|
||||
|
||||
my $key = shift;
|
||||
return $self->read($key) unless @_;
|
||||
|
||||
my $value = shift;
|
||||
$self->write({ $key => $value });
|
||||
return $self->read($key);
|
||||
}
|
||||
|
||||
sub has_data {
|
||||
my $self = shift;
|
||||
return keys %{$self->read()} > 0;
|
||||
}
|
||||
|
||||
sub exists {
|
||||
my ($self, $key) = @_;
|
||||
return exists($self->{new}{$key}) || exists($self->{disk}{$key});
|
||||
}
|
||||
|
||||
sub read {
|
||||
my $self = shift;
|
||||
|
||||
if (@_) {
|
||||
# Return 1 key as a scalar
|
||||
my $key = shift;
|
||||
return $self->{new}{$key} if exists $self->{new}{$key};
|
||||
return $self->{disk}{$key};
|
||||
}
|
||||
|
||||
# Return all data
|
||||
my $out = (keys %{$self->{new}}
|
||||
? {%{$self->{disk}}, %{$self->{new}}}
|
||||
: $self->{disk});
|
||||
return wantarray ? %$out : $out;
|
||||
}
|
||||
|
||||
sub _same {
|
||||
my ($self, $x, $y) = @_;
|
||||
return 1 if !defined($x) and !defined($y);
|
||||
return 0 if !defined($x) or !defined($y);
|
||||
return $x eq $y;
|
||||
}
|
||||
|
||||
sub write {
|
||||
my ($self, $href) = @_;
|
||||
$href ||= {};
|
||||
|
||||
@{$self->{new}}{ keys %$href } = values %$href; # Merge
|
||||
|
||||
# Do some optimization to avoid unnecessary writes
|
||||
foreach my $key (keys %{ $self->{new} }) {
|
||||
next if ref $self->{new}{$key};
|
||||
next if ref $self->{disk}{$key} or !exists $self->{disk}{$key};
|
||||
delete $self->{new}{$key} if $self->_same($self->{new}{$key}, $self->{disk}{$key});
|
||||
}
|
||||
|
||||
if (my $file = $self->{file}) {
|
||||
my ($vol, $dir, $base) = File::Spec->splitpath($file);
|
||||
$dir = File::Spec->catpath($vol, $dir, '');
|
||||
return unless -e $dir && -d $dir; # The user needs to arrange for this
|
||||
|
||||
return if -e $file and !keys %{ $self->{new} }; # Nothing to do
|
||||
|
||||
@{$self->{disk}}{ keys %{$self->{new}} } = values %{$self->{new}}; # Merge
|
||||
$self->_dump($file, $self->{disk});
|
||||
|
||||
$self->{new} = {};
|
||||
}
|
||||
return $self->read;
|
||||
}
|
||||
|
||||
sub _dump {
|
||||
my ($self, $file, $data) = @_;
|
||||
|
||||
open(my $fh, '>', $file) or die "Can't create '$file': $!";
|
||||
print {$fh} Module::Build::Dumper->_data_dump($data);
|
||||
close $fh;
|
||||
}
|
||||
|
||||
my $orig_template = do { local $/; <DATA> };
|
||||
close DATA;
|
||||
|
||||
sub write_config_data {
|
||||
my ($self, %args) = @_;
|
||||
|
||||
my $template = $orig_template;
|
||||
$template =~ s/NOTES_NAME/$args{config_module}/g;
|
||||
$template =~ s/MODULE_NAME/$args{module}/g;
|
||||
$template =~ s/=begin private\n//;
|
||||
$template =~ s/=end private/=cut/;
|
||||
|
||||
# strip out private POD markers we use to keep pod from being
|
||||
# recognized for *this* source file
|
||||
$template =~ s{$_\n}{} for '=begin private', '=end private';
|
||||
|
||||
open(my $fh, '>', $args{file}) or die "Can't create '$args{file}': $!";
|
||||
print {$fh} $template;
|
||||
print {$fh} "\n__DATA__\n";
|
||||
print {$fh} Module::Build::Dumper->_data_dump([$args{config_data}, $args{feature}, $args{auto_features}]);
|
||||
close $fh;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Module::Build::Notes - Create persistent distribution configuration modules
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module is used internally by Module::Build to create persistent
|
||||
configuration files that can be installed with a distribution. See
|
||||
L<Module::Build::ConfigData> for an example.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Ken Williams <kwilliams@cpan.org>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2001-2006 Ken Williams. All rights reserved.
|
||||
|
||||
This library is free software; you can redistribute it and/or
|
||||
modify it under the same terms as Perl itself.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
perl(1), L<Module::Build>(3)
|
||||
|
||||
=cut
|
||||
|
||||
__DATA__
|
||||
package NOTES_NAME;
|
||||
use strict;
|
||||
my $arrayref = eval do {local $/; <DATA>}
|
||||
or die "Couldn't load ConfigData data: $@";
|
||||
close DATA;
|
||||
my ($config, $features, $auto_features) = @$arrayref;
|
||||
|
||||
sub config { $config->{$_[1]} }
|
||||
|
||||
sub set_config { $config->{$_[1]} = $_[2] }
|
||||
sub set_feature { $features->{$_[1]} = 0+!!$_[2] } # Constrain to 1 or 0
|
||||
|
||||
sub auto_feature_names { grep !exists $features->{$_}, keys %$auto_features }
|
||||
|
||||
sub feature_names {
|
||||
my @features = (keys %$features, auto_feature_names());
|
||||
@features;
|
||||
}
|
||||
|
||||
sub config_names { keys %$config }
|
||||
|
||||
sub write {
|
||||
my $me = __FILE__;
|
||||
|
||||
# Can't use Module::Build::Dumper here because M::B is only a
|
||||
# build-time prereq of this module
|
||||
require Data::Dumper;
|
||||
|
||||
my $mode_orig = (stat $me)[2] & 07777;
|
||||
chmod($mode_orig | 0222, $me); # Make it writeable
|
||||
open(my $fh, '+<', $me) or die "Can't rewrite $me: $!";
|
||||
seek($fh, 0, 0);
|
||||
while (<$fh>) {
|
||||
last if /^__DATA__$/;
|
||||
}
|
||||
die "Couldn't find __DATA__ token in $me" if eof($fh);
|
||||
|
||||
seek($fh, tell($fh), 0);
|
||||
my $data = [$config, $features, $auto_features];
|
||||
print($fh 'do{ my '
|
||||
. Data::Dumper->new([$data],['x'])->Purity(1)->Dump()
|
||||
. '$x; }' );
|
||||
truncate($fh, tell($fh));
|
||||
close $fh;
|
||||
|
||||
chmod($mode_orig, $me)
|
||||
or warn "Couldn't restore permissions on $me: $!";
|
||||
}
|
||||
|
||||
sub feature {
|
||||
my ($package, $key) = @_;
|
||||
return $features->{$key} if exists $features->{$key};
|
||||
|
||||
my $info = $auto_features->{$key} or return 0;
|
||||
|
||||
# Under perl 5.005, each(%$foo) isn't working correctly when $foo
|
||||
# was reanimated with Data::Dumper and eval(). Not sure why, but
|
||||
# copying to a new hash seems to solve it.
|
||||
my %info = %$info;
|
||||
|
||||
require Module::Build; # XXX should get rid of this
|
||||
while (my ($type, $prereqs) = each %info) {
|
||||
next if $type eq 'description' || $type eq 'recommends';
|
||||
|
||||
my %p = %$prereqs; # Ditto here.
|
||||
while (my ($modname, $spec) = each %p) {
|
||||
my $status = Module::Build->check_installed_status($modname, $spec);
|
||||
if ((!$status->{ok}) xor ($type =~ /conflicts$/)) { return 0; }
|
||||
if ( ! eval "require $modname; 1" ) { return 0; }
|
||||
}
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
=begin private
|
||||
|
||||
=head1 NAME
|
||||
|
||||
NOTES_NAME - Configuration for MODULE_NAME
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use NOTES_NAME;
|
||||
$value = NOTES_NAME->config('foo');
|
||||
$value = NOTES_NAME->feature('bar');
|
||||
|
||||
@names = NOTES_NAME->config_names;
|
||||
@names = NOTES_NAME->feature_names;
|
||||
|
||||
NOTES_NAME->set_config(foo => $new_value);
|
||||
NOTES_NAME->set_feature(bar => $new_value);
|
||||
NOTES_NAME->write; # Save changes
|
||||
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module holds the configuration data for the C<MODULE_NAME>
|
||||
module. It also provides a programmatic interface for getting or
|
||||
setting that configuration data. Note that in order to actually make
|
||||
changes, you'll have to have write access to the C<NOTES_NAME>
|
||||
module, and you should attempt to understand the repercussions of your
|
||||
actions.
|
||||
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=over 4
|
||||
|
||||
=item config($name)
|
||||
|
||||
Given a string argument, returns the value of the configuration item
|
||||
by that name, or C<undef> if no such item exists.
|
||||
|
||||
=item feature($name)
|
||||
|
||||
Given a string argument, returns the value of the feature by that
|
||||
name, or C<undef> if no such feature exists.
|
||||
|
||||
=item set_config($name, $value)
|
||||
|
||||
Sets the configuration item with the given name to the given value.
|
||||
The value may be any Perl scalar that will serialize correctly using
|
||||
C<Data::Dumper>. This includes references, objects (usually), and
|
||||
complex data structures. It probably does not include transient
|
||||
things like filehandles or sockets.
|
||||
|
||||
=item set_feature($name, $value)
|
||||
|
||||
Sets the feature with the given name to the given boolean value. The
|
||||
value will be converted to 0 or 1 automatically.
|
||||
|
||||
=item config_names()
|
||||
|
||||
Returns a list of all the names of config items currently defined in
|
||||
C<NOTES_NAME>, or in scalar context the number of items.
|
||||
|
||||
=item feature_names()
|
||||
|
||||
Returns a list of all the names of features currently defined in
|
||||
C<NOTES_NAME>, or in scalar context the number of features.
|
||||
|
||||
=item auto_feature_names()
|
||||
|
||||
Returns a list of all the names of features whose availability is
|
||||
dynamically determined, or in scalar context the number of such
|
||||
features. Does not include such features that have later been set to
|
||||
a fixed value.
|
||||
|
||||
=item write()
|
||||
|
||||
Commits any changes from C<set_config()> and C<set_feature()> to disk.
|
||||
Requires write access to the C<NOTES_NAME> module.
|
||||
|
||||
=back
|
||||
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
C<NOTES_NAME> was automatically created using C<Module::Build>.
|
||||
C<Module::Build> was written by Ken Williams, but he holds no
|
||||
authorship claim or copyright claim to the contents of C<NOTES_NAME>.
|
||||
|
||||
=end private
|
||||
|
||||
@@ -1,186 +0,0 @@
|
||||
package Module::Build::PPMMaker;
|
||||
|
||||
use strict;
|
||||
use Config;
|
||||
use vars qw($VERSION);
|
||||
|
||||
$VERSION = '0.4206';
|
||||
$VERSION = eval $VERSION;
|
||||
|
||||
# This code is mostly borrowed from ExtUtils::MM_Unix 6.10_03, with a
|
||||
# few tweaks based on the PPD spec at
|
||||
# http://www.xav.com/perl/site/lib/XML/PPD.html
|
||||
|
||||
# The PPD spec is based on <http://www.w3.org/TR/NOTE-OSD>
|
||||
|
||||
sub new {
|
||||
my $package = shift;
|
||||
return bless {@_}, $package;
|
||||
}
|
||||
|
||||
sub make_ppd {
|
||||
my ($self, %args) = @_;
|
||||
my $build = delete $args{build};
|
||||
|
||||
my @codebase;
|
||||
if (exists $args{codebase}) {
|
||||
@codebase = ref $args{codebase} ? @{$args{codebase}} : ($args{codebase});
|
||||
} else {
|
||||
my $distfile = $build->ppm_name . '.tar.gz';
|
||||
print "Using default codebase '$distfile'\n";
|
||||
@codebase = ($distfile);
|
||||
}
|
||||
|
||||
my %dist;
|
||||
foreach my $info (qw(name author abstract version)) {
|
||||
my $method = "dist_$info";
|
||||
$dist{$info} = $build->$method() or die "Can't determine distribution's $info\n";
|
||||
}
|
||||
|
||||
$self->_simple_xml_escape($_) foreach $dist{abstract}, @{$dist{author}};
|
||||
|
||||
# TODO: could add <LICENSE HREF=...> tag if we knew what the URLs were for
|
||||
# various licenses
|
||||
my $ppd = <<"PPD";
|
||||
<SOFTPKG NAME=\"$dist{name}\" VERSION=\"$dist{version}\">
|
||||
<ABSTRACT>$dist{abstract}</ABSTRACT>
|
||||
@{[ join "\n", map " <AUTHOR>$_</AUTHOR>", @{$dist{author}} ]}
|
||||
<IMPLEMENTATION>
|
||||
PPD
|
||||
|
||||
# We don't include recommended dependencies because PPD has no way
|
||||
# to distinguish them from normal dependencies. We don't include
|
||||
# build_requires dependencies because the PPM installer doesn't
|
||||
# build or test before installing. And obviously we don't include
|
||||
# conflicts either.
|
||||
|
||||
foreach my $type (qw(requires)) {
|
||||
my $prereq = $build->$type();
|
||||
while (my ($modname, $spec) = each %$prereq) {
|
||||
next if $modname eq 'perl';
|
||||
|
||||
my $min_version = '0.0';
|
||||
foreach my $c ($build->_parse_conditions($spec)) {
|
||||
my ($op, $version) = $c =~ /^\s* (<=?|>=?|==|!=) \s* ([\w.]+) \s*$/x;
|
||||
|
||||
# This is a nasty hack because it fails if there is no >= op
|
||||
if ($op eq '>=') {
|
||||
$min_version = $version;
|
||||
last;
|
||||
}
|
||||
}
|
||||
|
||||
# PPM4 spec requires a '::' for top level modules
|
||||
$modname .= '::' unless $modname =~ /::/;
|
||||
|
||||
$ppd .= qq! <REQUIRE NAME="$modname" VERSION="$min_version" />\n!;
|
||||
}
|
||||
}
|
||||
|
||||
# We only include these tags if this module involves XS, on the
|
||||
# assumption that pure Perl modules will work on any OS.
|
||||
if (keys %{$build->find_xs_files}) {
|
||||
my $perl_version = $self->_ppd_version($build->perl_version);
|
||||
$ppd .= sprintf(<<'EOF', $self->_varchname($build->config) );
|
||||
<ARCHITECTURE NAME="%s" />
|
||||
EOF
|
||||
}
|
||||
|
||||
foreach my $codebase (@codebase) {
|
||||
$self->_simple_xml_escape($codebase);
|
||||
$ppd .= sprintf(<<'EOF', $codebase);
|
||||
<CODEBASE HREF="%s" />
|
||||
EOF
|
||||
}
|
||||
|
||||
$ppd .= <<'EOF';
|
||||
</IMPLEMENTATION>
|
||||
</SOFTPKG>
|
||||
EOF
|
||||
|
||||
my $ppd_file = "$dist{name}.ppd";
|
||||
open(my $fh, '>', $ppd_file)
|
||||
or die "Cannot write to $ppd_file: $!";
|
||||
|
||||
binmode($fh, ":utf8")
|
||||
if $] >= 5.008 && $Config{useperlio};
|
||||
print $fh $ppd;
|
||||
close $fh;
|
||||
|
||||
return $ppd_file;
|
||||
}
|
||||
|
||||
sub _ppd_version {
|
||||
my ($self, $version) = @_;
|
||||
|
||||
# generates something like "0,18,0,0"
|
||||
return join ',', (split(/\./, $version), (0)x4)[0..3];
|
||||
}
|
||||
|
||||
sub _varchname { # Copied from PPM.pm
|
||||
my ($self, $config) = @_;
|
||||
my $varchname = $config->{archname};
|
||||
# Append "-5.8" to architecture name for Perl 5.8 and later
|
||||
if ($] >= 5.008) {
|
||||
my $vstring = sprintf "%vd", $^V;
|
||||
$vstring =~ s/\.\d+$//;
|
||||
$varchname .= "-$vstring";
|
||||
}
|
||||
return $varchname;
|
||||
}
|
||||
|
||||
{
|
||||
my %escapes = (
|
||||
"\n" => "\\n",
|
||||
'"' => '"',
|
||||
'&' => '&',
|
||||
'>' => '>',
|
||||
'<' => '<',
|
||||
);
|
||||
my $rx = join '|', keys %escapes;
|
||||
|
||||
sub _simple_xml_escape {
|
||||
$_[1] =~ s/($rx)/$escapes{$1}/go;
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Module::Build::PPMMaker - Perl Package Manager file creation
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
On the command line, builds a .ppd file:
|
||||
./Build ppd
|
||||
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This package contains the code that builds F<.ppd> "Perl Package
|
||||
Description" files, in support of ActiveState's "Perl Package
|
||||
Manager". Details are here:
|
||||
L<http://aspn.activestate.com/ASPN/Downloads/ActivePerl/PPM/>
|
||||
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Dave Rolsky <autarch@urth.org>, Ken Williams <kwilliams@cpan.org>
|
||||
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2001-2006 Ken Williams. All rights reserved.
|
||||
|
||||
This library is free software; you can redistribute it and/or
|
||||
modify it under the same terms as Perl itself.
|
||||
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
perl(1), Module::Build(3)
|
||||
|
||||
=cut
|
||||
@@ -1,33 +0,0 @@
|
||||
package Module::Build::Platform::Default;
|
||||
|
||||
use strict;
|
||||
use vars qw($VERSION);
|
||||
$VERSION = '0.4206';
|
||||
$VERSION = eval $VERSION;
|
||||
use Module::Build::Base;
|
||||
|
||||
use vars qw(@ISA);
|
||||
@ISA = qw(Module::Build::Base);
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Module::Build::Platform::Default - Stub class for unknown platforms
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
The sole purpose of this module is to inherit from
|
||||
C<Module::Build::Base>. Please see the L<Module::Build> for the docs.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Ken Williams <kwilliams@cpan.org>
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
perl(1), Module::Build(3), ExtUtils::MakeMaker(3)
|
||||
|
||||
=cut
|
||||
@@ -1,152 +0,0 @@
|
||||
package Module::Build::Platform::MacOS;
|
||||
|
||||
use strict;
|
||||
use vars qw($VERSION);
|
||||
$VERSION = '0.4206';
|
||||
$VERSION = eval $VERSION;
|
||||
use Module::Build::Base;
|
||||
use vars qw(@ISA);
|
||||
@ISA = qw(Module::Build::Base);
|
||||
|
||||
use ExtUtils::Install;
|
||||
|
||||
sub have_forkpipe { 0 }
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $self = $class->SUPER::new(@_);
|
||||
|
||||
# $Config{sitelib} and $Config{sitearch} are, unfortunately, missing.
|
||||
foreach ('sitelib', 'sitearch') {
|
||||
$self->config($_ => $self->config("install$_"))
|
||||
unless $self->config($_);
|
||||
}
|
||||
|
||||
# For some reason $Config{startperl} is filled with a bunch of crap.
|
||||
(my $sp = $self->config('startperl')) =~ s/.*Exit \{Status\}\s//;
|
||||
$self->config(startperl => $sp);
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub make_executable {
|
||||
my $self = shift;
|
||||
require MacPerl;
|
||||
foreach (@_) {
|
||||
MacPerl::SetFileInfo('McPL', 'TEXT', $_);
|
||||
}
|
||||
}
|
||||
|
||||
sub dispatch {
|
||||
my $self = shift;
|
||||
|
||||
if( !@_ and !@ARGV ) {
|
||||
require MacPerl;
|
||||
|
||||
# What comes first in the action list.
|
||||
my @action_list = qw(build test install);
|
||||
my %actions = map {+($_, 1)} $self->known_actions;
|
||||
delete @actions{@action_list};
|
||||
push @action_list, sort { $a cmp $b } keys %actions;
|
||||
|
||||
my %toolserver = map {+$_ => 1} qw(test disttest diff testdb);
|
||||
foreach (@action_list) {
|
||||
$_ .= ' *' if $toolserver{$_};
|
||||
}
|
||||
|
||||
my $cmd = MacPerl::Pick("What build command? ('*' requires ToolServer)", @action_list);
|
||||
return unless defined $cmd;
|
||||
$cmd =~ s/ \*$//;
|
||||
$ARGV[0] = ($cmd);
|
||||
|
||||
my $args = MacPerl::Ask('Any extra arguments? (ie. verbose=1)', '');
|
||||
return unless defined $args;
|
||||
push @ARGV, $self->split_like_shell($args);
|
||||
}
|
||||
|
||||
$self->SUPER::dispatch(@_);
|
||||
}
|
||||
|
||||
sub ACTION_realclean {
|
||||
my $self = shift;
|
||||
chmod 0666, $self->{properties}{build_script};
|
||||
$self->SUPER::ACTION_realclean;
|
||||
}
|
||||
|
||||
# ExtUtils::Install has a hard-coded '.' directory in versions less
|
||||
# than 1.30. We use a sneaky trick to turn that into ':'.
|
||||
#
|
||||
# Note that we do it here in a cross-platform way, so this code could
|
||||
# actually go in Module::Build::Base. But we put it here to be less
|
||||
# intrusive for other platforms.
|
||||
|
||||
sub ACTION_install {
|
||||
my $self = shift;
|
||||
|
||||
return $self->SUPER::ACTION_install(@_)
|
||||
if eval {ExtUtils::Install->VERSION('1.30'); 1};
|
||||
|
||||
local $^W = 0; # Avoid a 'redefine' warning
|
||||
local *ExtUtils::Install::find = sub {
|
||||
my ($code, @dirs) = @_;
|
||||
|
||||
@dirs = map { $_ eq '.' ? File::Spec->curdir : $_ } @dirs;
|
||||
|
||||
return File::Find::find($code, @dirs);
|
||||
};
|
||||
|
||||
return $self->SUPER::ACTION_install(@_);
|
||||
}
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Module::Build::Platform::MacOS - Builder class for MacOS platforms
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
The sole purpose of this module is to inherit from
|
||||
C<Module::Build::Base> and override a few methods. Please see
|
||||
L<Module::Build> for the docs.
|
||||
|
||||
=head2 Overridden Methods
|
||||
|
||||
=over 4
|
||||
|
||||
=item new()
|
||||
|
||||
MacPerl doesn't define $Config{sitelib} or $Config{sitearch} for some
|
||||
reason, but $Config{installsitelib} and $Config{installsitearch} are
|
||||
there. So we copy the install variables to the other location
|
||||
|
||||
=item make_executable()
|
||||
|
||||
On MacOS we set the file type and creator to MacPerl so it will run
|
||||
with a double-click.
|
||||
|
||||
=item dispatch()
|
||||
|
||||
Because there's no easy way to say "./Build test" on MacOS, if
|
||||
dispatch is called with no arguments and no @ARGV a dialog box will
|
||||
pop up asking what action to take and any extra arguments.
|
||||
|
||||
Default action is "test".
|
||||
|
||||
=item ACTION_realclean()
|
||||
|
||||
Need to unlock the Build program before deleting.
|
||||
|
||||
=back
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Michael G Schwern <schwern@pobox.com>
|
||||
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
perl(1), Module::Build(3), ExtUtils::MakeMaker(3)
|
||||
|
||||
=cut
|
||||
@@ -1,73 +0,0 @@
|
||||
package Module::Build::Platform::Unix;
|
||||
|
||||
use strict;
|
||||
use vars qw($VERSION);
|
||||
$VERSION = '0.4206';
|
||||
$VERSION = eval $VERSION;
|
||||
use Module::Build::Base;
|
||||
|
||||
use vars qw(@ISA);
|
||||
@ISA = qw(Module::Build::Base);
|
||||
|
||||
sub is_executable {
|
||||
# We consider the owner bit to be authoritative on a file, because
|
||||
# -x will always return true if the user is root and *any*
|
||||
# executable bit is set. The -x test seems to try to answer the
|
||||
# question "can I execute this file", but I think we want "is this
|
||||
# file executable".
|
||||
|
||||
my ($self, $file) = @_;
|
||||
return +(stat $file)[2] & 0100;
|
||||
}
|
||||
|
||||
sub _startperl { "#! " . shift()->perl }
|
||||
|
||||
sub _construct {
|
||||
my $self = shift()->SUPER::_construct(@_);
|
||||
|
||||
# perl 5.8.1-RC[1-3] had some broken %Config entries, and
|
||||
# unfortunately Red Hat 9 shipped it like that. Fix 'em up here.
|
||||
my $c = $self->{config};
|
||||
for (qw(siteman1 siteman3 vendorman1 vendorman3)) {
|
||||
$c->{"install${_}dir"} ||= $c->{"install${_}"};
|
||||
}
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
# Open group says username should be portable filename characters,
|
||||
# but some Unix OS working with ActiveDirectory wind up with user-names
|
||||
# with back-slashes in the name. The new code below is very liberal
|
||||
# in what it accepts.
|
||||
sub _detildefy {
|
||||
my ($self, $value) = @_;
|
||||
$value =~ s[^~([^/]+)?(?=/|$)] # tilde with optional username
|
||||
[$1 ?
|
||||
(eval{(getpwnam $1)[7]} || "~$1") :
|
||||
($ENV{HOME} || eval{(getpwuid $>)[7]} || glob("~"))
|
||||
]ex;
|
||||
return $value;
|
||||
}
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Module::Build::Platform::Unix - Builder class for Unix platforms
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
The sole purpose of this module is to inherit from
|
||||
C<Module::Build::Base>. Please see the L<Module::Build> for the docs.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Ken Williams <kwilliams@cpan.org>
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
perl(1), Module::Build(3), ExtUtils::MakeMaker(3)
|
||||
|
||||
=cut
|
||||
@@ -1,523 +0,0 @@
|
||||
package Module::Build::Platform::VMS;
|
||||
|
||||
use strict;
|
||||
use vars qw($VERSION);
|
||||
$VERSION = '0.4206';
|
||||
$VERSION = eval $VERSION;
|
||||
use Module::Build::Base;
|
||||
use Config;
|
||||
|
||||
use vars qw(@ISA);
|
||||
@ISA = qw(Module::Build::Base);
|
||||
|
||||
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Module::Build::Platform::VMS - Builder class for VMS platforms
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module inherits from C<Module::Build::Base> and alters a few
|
||||
minor details of its functionality. Please see L<Module::Build> for
|
||||
the general docs.
|
||||
|
||||
=head2 Overridden Methods
|
||||
|
||||
=over 4
|
||||
|
||||
=item _set_defaults
|
||||
|
||||
Change $self->{build_script} to 'Build.com' so @Build works.
|
||||
|
||||
=cut
|
||||
|
||||
sub _set_defaults {
|
||||
my $self = shift;
|
||||
$self->SUPER::_set_defaults(@_);
|
||||
|
||||
$self->{properties}{build_script} = 'Build.com';
|
||||
}
|
||||
|
||||
|
||||
=item cull_args
|
||||
|
||||
'@Build foo' on VMS will not preserve the case of 'foo'. Rather than forcing
|
||||
people to write '@Build "foo"' we'll dispatch case-insensitively.
|
||||
|
||||
=cut
|
||||
|
||||
sub cull_args {
|
||||
my $self = shift;
|
||||
my($action, $args) = $self->SUPER::cull_args(@_);
|
||||
my @possible_actions = grep { lc $_ eq lc $action } $self->known_actions;
|
||||
|
||||
die "Ambiguous action '$action'. Could be one of @possible_actions"
|
||||
if @possible_actions > 1;
|
||||
|
||||
return ($possible_actions[0], $args);
|
||||
}
|
||||
|
||||
|
||||
=item manpage_separator
|
||||
|
||||
Use '__' instead of '::'.
|
||||
|
||||
=cut
|
||||
|
||||
sub manpage_separator {
|
||||
return '__';
|
||||
}
|
||||
|
||||
|
||||
=item prefixify
|
||||
|
||||
Prefixify taking into account VMS' filepath syntax.
|
||||
|
||||
=cut
|
||||
|
||||
# Translated from ExtUtils::MM_VMS::prefixify()
|
||||
|
||||
sub _catprefix {
|
||||
my($self, $rprefix, $default) = @_;
|
||||
|
||||
my($rvol, $rdirs) = File::Spec->splitpath($rprefix);
|
||||
if( $rvol ) {
|
||||
return File::Spec->catpath($rvol,
|
||||
File::Spec->catdir($rdirs, $default),
|
||||
''
|
||||
)
|
||||
}
|
||||
else {
|
||||
return File::Spec->catdir($rdirs, $default);
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
sub _prefixify {
|
||||
my($self, $path, $sprefix, $type) = @_;
|
||||
my $rprefix = $self->prefix;
|
||||
|
||||
return '' unless defined $path;
|
||||
|
||||
$self->log_verbose(" prefixify $path from $sprefix to $rprefix\n");
|
||||
|
||||
# Translate $(PERLPREFIX) to a real path.
|
||||
$rprefix = VMS::Filespec::vmspath($rprefix) if $rprefix;
|
||||
$sprefix = VMS::Filespec::vmspath($sprefix) if $sprefix;
|
||||
|
||||
$self->log_verbose(" rprefix translated to $rprefix\n".
|
||||
" sprefix translated to $sprefix\n");
|
||||
|
||||
if( length($path) == 0 ) {
|
||||
$self->log_verbose(" no path to prefixify.\n")
|
||||
}
|
||||
elsif( !File::Spec->file_name_is_absolute($path) ) {
|
||||
$self->log_verbose(" path is relative, not prefixifying.\n");
|
||||
}
|
||||
elsif( $sprefix eq $rprefix ) {
|
||||
$self->log_verbose(" no new prefix.\n");
|
||||
}
|
||||
else {
|
||||
my($path_vol, $path_dirs) = File::Spec->splitpath( $path );
|
||||
my $vms_prefix = $self->config('vms_prefix');
|
||||
if( $path_vol eq $vms_prefix.':' ) {
|
||||
$self->log_verbose(" $vms_prefix: seen\n");
|
||||
|
||||
$path_dirs =~ s{^\[}{\[.} unless $path_dirs =~ m{^\[\.};
|
||||
$path = $self->_catprefix($rprefix, $path_dirs);
|
||||
}
|
||||
else {
|
||||
$self->log_verbose(" cannot prefixify.\n");
|
||||
return $self->prefix_relpaths($self->installdirs, $type);
|
||||
}
|
||||
}
|
||||
|
||||
$self->log_verbose(" now $path\n");
|
||||
|
||||
return $path;
|
||||
}
|
||||
|
||||
=item _quote_args
|
||||
|
||||
Command-line arguments (but not the command itself) must be quoted
|
||||
to ensure case preservation.
|
||||
|
||||
=cut
|
||||
|
||||
sub _quote_args {
|
||||
# Returns a string that can become [part of] a command line with
|
||||
# proper quoting so that the subprocess sees this same list of args,
|
||||
# or if we get a single arg that is an array reference, quote the
|
||||
# elements of it and return the reference.
|
||||
my ($self, @args) = @_;
|
||||
my $got_arrayref = (scalar(@args) == 1
|
||||
&& UNIVERSAL::isa($args[0], 'ARRAY'))
|
||||
? 1
|
||||
: 0;
|
||||
|
||||
# Do not quote qualifiers that begin with '/'.
|
||||
map { if (!/^\//) {
|
||||
$_ =~ s/\"/""/g; # escape C<"> by doubling
|
||||
$_ = q(").$_.q(");
|
||||
}
|
||||
}
|
||||
($got_arrayref ? @{$args[0]}
|
||||
: @args
|
||||
);
|
||||
|
||||
return $got_arrayref ? $args[0]
|
||||
: join(' ', @args);
|
||||
}
|
||||
|
||||
=item have_forkpipe
|
||||
|
||||
There is no native fork(), so some constructs depending on it are not
|
||||
available.
|
||||
|
||||
=cut
|
||||
|
||||
sub have_forkpipe { 0 }
|
||||
|
||||
=item _backticks
|
||||
|
||||
Override to ensure that we quote the arguments but not the command.
|
||||
|
||||
=cut
|
||||
|
||||
sub _backticks {
|
||||
# The command must not be quoted but the arguments to it must be.
|
||||
my ($self, @cmd) = @_;
|
||||
my $cmd = shift @cmd;
|
||||
my $args = $self->_quote_args(@cmd);
|
||||
return `$cmd $args`;
|
||||
}
|
||||
|
||||
=item find_command
|
||||
|
||||
Local an executable program
|
||||
|
||||
=cut
|
||||
|
||||
sub find_command {
|
||||
my ($self, $command) = @_;
|
||||
|
||||
# a lot of VMS executables have a symbol defined
|
||||
# check those first
|
||||
if ( $^O eq 'VMS' ) {
|
||||
require VMS::DCLsym;
|
||||
my $syms = VMS::DCLsym->new;
|
||||
return $command if scalar $syms->getsym( uc $command );
|
||||
}
|
||||
|
||||
$self->SUPER::find_command($command);
|
||||
}
|
||||
|
||||
# _maybe_command copied from ExtUtils::MM_VMS::maybe_command
|
||||
|
||||
=item _maybe_command (override)
|
||||
|
||||
Follows VMS naming conventions for executable files.
|
||||
If the name passed in doesn't exactly match an executable file,
|
||||
appends F<.Exe> (or equivalent) to check for executable image, and F<.Com>
|
||||
to check for DCL procedure. If this fails, checks directories in DCL$PATH
|
||||
and finally F<Sys$System:> for an executable file having the name specified,
|
||||
with or without the F<.Exe>-equivalent suffix.
|
||||
|
||||
=cut
|
||||
|
||||
sub _maybe_command {
|
||||
my($self,$file) = @_;
|
||||
return $file if -x $file && ! -d _;
|
||||
my(@dirs) = ('');
|
||||
my(@exts) = ('',$Config{'exe_ext'},'.exe','.com');
|
||||
|
||||
if ($file !~ m![/:>\]]!) {
|
||||
for (my $i = 0; defined $ENV{"DCL\$PATH;$i"}; $i++) {
|
||||
my $dir = $ENV{"DCL\$PATH;$i"};
|
||||
$dir .= ':' unless $dir =~ m%[\]:]$%;
|
||||
push(@dirs,$dir);
|
||||
}
|
||||
push(@dirs,'Sys$System:');
|
||||
foreach my $dir (@dirs) {
|
||||
my $sysfile = "$dir$file";
|
||||
foreach my $ext (@exts) {
|
||||
return $file if -x "$sysfile$ext" && ! -d _;
|
||||
}
|
||||
}
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
=item do_system
|
||||
|
||||
Override to ensure that we quote the arguments but not the command.
|
||||
|
||||
=cut
|
||||
|
||||
sub do_system {
|
||||
# The command must not be quoted but the arguments to it must be.
|
||||
my ($self, @cmd) = @_;
|
||||
$self->log_verbose("@cmd\n");
|
||||
my $cmd = shift @cmd;
|
||||
my $args = $self->_quote_args(@cmd);
|
||||
return !system("$cmd $args");
|
||||
}
|
||||
|
||||
=item oneliner
|
||||
|
||||
Override to ensure that we do not quote the command.
|
||||
|
||||
=cut
|
||||
|
||||
sub oneliner {
|
||||
my $self = shift;
|
||||
my $oneliner = $self->SUPER::oneliner(@_);
|
||||
|
||||
$oneliner =~ s/^\"\S+\"//;
|
||||
|
||||
return "MCR $^X $oneliner";
|
||||
}
|
||||
|
||||
=item rscan_dir
|
||||
|
||||
Inherit the standard version but remove dots at end of name.
|
||||
If the extended character set is in effect, do not remove dots from filenames
|
||||
with Unix path delimiters.
|
||||
|
||||
=cut
|
||||
|
||||
sub rscan_dir {
|
||||
my ($self, $dir, $pattern) = @_;
|
||||
|
||||
my $result = $self->SUPER::rscan_dir( $dir, $pattern );
|
||||
|
||||
for my $file (@$result) {
|
||||
if (!_efs() && ($file =~ m#/#)) {
|
||||
$file =~ s/\.$//;
|
||||
}
|
||||
}
|
||||
return $result;
|
||||
}
|
||||
|
||||
=item dist_dir
|
||||
|
||||
Inherit the standard version but replace embedded dots with underscores because
|
||||
a dot is the directory delimiter on VMS.
|
||||
|
||||
=cut
|
||||
|
||||
sub dist_dir {
|
||||
my $self = shift;
|
||||
|
||||
my $dist_dir = $self->SUPER::dist_dir;
|
||||
$dist_dir =~ s/\./_/g unless _efs();
|
||||
return $dist_dir;
|
||||
}
|
||||
|
||||
=item man3page_name
|
||||
|
||||
Inherit the standard version but chop the extra manpage delimiter off the front if
|
||||
there is one. The VMS version of splitdir('[.foo]') returns '', 'foo'.
|
||||
|
||||
=cut
|
||||
|
||||
sub man3page_name {
|
||||
my $self = shift;
|
||||
|
||||
my $mpname = $self->SUPER::man3page_name( shift );
|
||||
my $sep = $self->manpage_separator;
|
||||
$mpname =~ s/^$sep//;
|
||||
return $mpname;
|
||||
}
|
||||
|
||||
=item expand_test_dir
|
||||
|
||||
Inherit the standard version but relativize the paths as the native glob() doesn't
|
||||
do that for us.
|
||||
|
||||
=cut
|
||||
|
||||
sub expand_test_dir {
|
||||
my ($self, $dir) = @_;
|
||||
|
||||
my @reldirs = $self->SUPER::expand_test_dir( $dir );
|
||||
|
||||
for my $eachdir (@reldirs) {
|
||||
my ($v,$d,$f) = File::Spec->splitpath( $eachdir );
|
||||
my $reldir = File::Spec->abs2rel( File::Spec->catpath( $v, $d, '' ) );
|
||||
$eachdir = File::Spec->catfile( $reldir, $f );
|
||||
}
|
||||
return @reldirs;
|
||||
}
|
||||
|
||||
=item _detildefy
|
||||
|
||||
The home-grown glob() does not currently handle tildes, so provide limited support
|
||||
here. Expect only UNIX format file specifications for now.
|
||||
|
||||
=cut
|
||||
|
||||
sub _detildefy {
|
||||
my ($self, $arg) = @_;
|
||||
|
||||
# Apparently double ~ are not translated.
|
||||
return $arg if ($arg =~ /^~~/);
|
||||
|
||||
# Apparently ~ followed by whitespace are not translated.
|
||||
return $arg if ($arg =~ /^~ /);
|
||||
|
||||
if ($arg =~ /^~/) {
|
||||
my $spec = $arg;
|
||||
|
||||
# Remove the tilde
|
||||
$spec =~ s/^~//;
|
||||
|
||||
# Remove any slash following the tilde if present.
|
||||
$spec =~ s#^/##;
|
||||
|
||||
# break up the paths for the merge
|
||||
my $home = VMS::Filespec::unixify($ENV{HOME});
|
||||
|
||||
# In the default VMS mode, the trailing slash is present.
|
||||
# In Unix report mode it is not. The parsing logic assumes that
|
||||
# it is present.
|
||||
$home .= '/' unless $home =~ m#/$#;
|
||||
|
||||
# Trivial case of just ~ by it self
|
||||
if ($spec eq '') {
|
||||
$home =~ s#/$##;
|
||||
return $home;
|
||||
}
|
||||
|
||||
my ($hvol, $hdir, $hfile) = File::Spec::Unix->splitpath($home);
|
||||
if ($hdir eq '') {
|
||||
# Someone has tampered with $ENV{HOME}
|
||||
# So hfile is probably the directory since this should be
|
||||
# a path.
|
||||
$hdir = $hfile;
|
||||
}
|
||||
|
||||
my ($vol, $dir, $file) = File::Spec::Unix->splitpath($spec);
|
||||
|
||||
my @hdirs = File::Spec::Unix->splitdir($hdir);
|
||||
my @dirs = File::Spec::Unix->splitdir($dir);
|
||||
|
||||
unless ($arg =~ m#^~/#) {
|
||||
# There is a home directory after the tilde, but it will already
|
||||
# be present in in @hdirs so we need to remove it by from @dirs.
|
||||
|
||||
shift @dirs;
|
||||
}
|
||||
my $newdirs = File::Spec::Unix->catdir(@hdirs, @dirs);
|
||||
|
||||
$arg = File::Spec::Unix->catpath($hvol, $newdirs, $file);
|
||||
}
|
||||
return $arg;
|
||||
|
||||
}
|
||||
|
||||
=item find_perl_interpreter
|
||||
|
||||
On VMS, $^X returns the fully qualified absolute path including version
|
||||
number. It's logically impossible to improve on it for getting the perl
|
||||
we're currently running, and attempting to manipulate it is usually
|
||||
lossy.
|
||||
|
||||
=cut
|
||||
|
||||
sub find_perl_interpreter {
|
||||
return VMS::Filespec::vmsify($^X);
|
||||
}
|
||||
|
||||
=item localize_file_path
|
||||
|
||||
Convert the file path to the local syntax
|
||||
|
||||
=cut
|
||||
|
||||
sub localize_file_path {
|
||||
my ($self, $path) = @_;
|
||||
$path = VMS::Filespec::vmsify($path);
|
||||
$path =~ s/\.\z//;
|
||||
return $path;
|
||||
}
|
||||
|
||||
=item localize_dir_path
|
||||
|
||||
Convert the directory path to the local syntax
|
||||
|
||||
=cut
|
||||
|
||||
sub localize_dir_path {
|
||||
my ($self, $path) = @_;
|
||||
return VMS::Filespec::vmspath($path);
|
||||
}
|
||||
|
||||
=item ACTION_clean
|
||||
|
||||
The home-grown glob() expands a bit too aggressively when given a bare name,
|
||||
so default in a zero-length extension.
|
||||
|
||||
=cut
|
||||
|
||||
sub ACTION_clean {
|
||||
my ($self) = @_;
|
||||
foreach my $item (map glob(VMS::Filespec::rmsexpand($_, '.;0')), $self->cleanup) {
|
||||
$self->delete_filetree($item);
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
# Need to look up the feature settings. The preferred way is to use the
|
||||
# VMS::Feature module, but that may not be available to dual life modules.
|
||||
|
||||
my $use_feature;
|
||||
BEGIN {
|
||||
if (eval { local $SIG{__DIE__}; require VMS::Feature; }) {
|
||||
$use_feature = 1;
|
||||
}
|
||||
}
|
||||
|
||||
# Need to look up the UNIX report mode. This may become a dynamic mode
|
||||
# in the future.
|
||||
sub _unix_rpt {
|
||||
my $unix_rpt;
|
||||
if ($use_feature) {
|
||||
$unix_rpt = VMS::Feature::current("filename_unix_report");
|
||||
} else {
|
||||
my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || '';
|
||||
$unix_rpt = $env_unix_rpt =~ /^[ET1]/i;
|
||||
}
|
||||
return $unix_rpt;
|
||||
}
|
||||
|
||||
# Need to look up the EFS character set mode. This may become a dynamic
|
||||
# mode in the future.
|
||||
sub _efs {
|
||||
my $efs;
|
||||
if ($use_feature) {
|
||||
$efs = VMS::Feature::current("efs_charset");
|
||||
} else {
|
||||
my $env_efs = $ENV{'DECC$EFS_CHARSET'} || '';
|
||||
$efs = $env_efs =~ /^[ET1]/i;
|
||||
}
|
||||
return $efs;
|
||||
}
|
||||
|
||||
=back
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Michael G Schwern <schwern@pobox.com>
|
||||
Ken Williams <kwilliams@cpan.org>
|
||||
Craig A. Berry <craigberry@mac.com>
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
perl(1), Module::Build(3), ExtUtils::MakeMaker(3)
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
__END__
|
||||
@@ -1,34 +0,0 @@
|
||||
package Module::Build::Platform::VOS;
|
||||
|
||||
use strict;
|
||||
use vars qw($VERSION);
|
||||
$VERSION = '0.4206';
|
||||
$VERSION = eval $VERSION;
|
||||
use Module::Build::Base;
|
||||
|
||||
use vars qw(@ISA);
|
||||
@ISA = qw(Module::Build::Base);
|
||||
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Module::Build::Platform::VOS - Builder class for VOS platforms
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
The sole purpose of this module is to inherit from
|
||||
C<Module::Build::Base>. Please see the L<Module::Build> for the docs.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Ken Williams <kwilliams@cpan.org>
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
perl(1), Module::Build(3), ExtUtils::MakeMaker(3)
|
||||
|
||||
=cut
|
||||
@@ -1,319 +0,0 @@
|
||||
package Module::Build::Platform::Windows;
|
||||
|
||||
use strict;
|
||||
use vars qw($VERSION);
|
||||
$VERSION = '0.4206';
|
||||
$VERSION = eval $VERSION;
|
||||
|
||||
use Config;
|
||||
use File::Basename;
|
||||
use File::Spec;
|
||||
|
||||
use Module::Build::Base;
|
||||
|
||||
use vars qw(@ISA);
|
||||
@ISA = qw(Module::Build::Base);
|
||||
|
||||
|
||||
sub manpage_separator {
|
||||
return '.';
|
||||
}
|
||||
|
||||
sub have_forkpipe { 0 }
|
||||
|
||||
sub _detildefy {
|
||||
my ($self, $value) = @_;
|
||||
$value =~ s,^~(?= [/\\] | $ ),$ENV{HOME},x
|
||||
if $ENV{HOME};
|
||||
return $value;
|
||||
}
|
||||
|
||||
sub ACTION_realclean {
|
||||
my ($self) = @_;
|
||||
|
||||
$self->SUPER::ACTION_realclean();
|
||||
|
||||
my $basename = basename($0);
|
||||
$basename =~ s/(?:\.bat)?$//i;
|
||||
|
||||
if ( lc $basename eq lc $self->build_script ) {
|
||||
if ( $self->build_bat ) {
|
||||
$self->log_verbose("Deleting $basename.bat\n");
|
||||
my $full_progname = $0;
|
||||
$full_progname =~ s/(?:\.bat)?$/.bat/i;
|
||||
|
||||
# Voodoo required to have a batch file delete itself without error;
|
||||
# Syntax differs between 9x & NT: the later requires a null arg (???)
|
||||
require Win32;
|
||||
my $null_arg = (Win32::IsWinNT()) ? '""' : '';
|
||||
my $cmd = qq(start $null_arg /min "\%comspec\%" /c del "$full_progname");
|
||||
|
||||
open(my $fh, '>>', "$basename.bat")
|
||||
or die "Can't create $basename.bat: $!";
|
||||
print $fh $cmd;
|
||||
close $fh ;
|
||||
} else {
|
||||
$self->delete_filetree($self->build_script . '.bat');
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub make_executable {
|
||||
my $self = shift;
|
||||
|
||||
$self->SUPER::make_executable(@_);
|
||||
|
||||
foreach my $script (@_) {
|
||||
|
||||
# Native batch script
|
||||
if ( $script =~ /\.(bat|cmd)$/ ) {
|
||||
$self->SUPER::make_executable($script);
|
||||
next;
|
||||
|
||||
# Perl script that needs to be wrapped in a batch script
|
||||
} else {
|
||||
my %opts = ();
|
||||
if ( $script eq $self->build_script ) {
|
||||
$opts{ntargs} = q(-x -S %0 --build_bat %*);
|
||||
$opts{otherargs} = q(-x -S "%0" --build_bat %1 %2 %3 %4 %5 %6 %7 %8 %9);
|
||||
}
|
||||
|
||||
my $out = eval {$self->pl2bat(in => $script, update => 1, %opts)};
|
||||
if ( $@ ) {
|
||||
$self->log_warn("WARNING: Unable to convert file '$script' to an executable script:\n$@");
|
||||
} else {
|
||||
$self->SUPER::make_executable($out);
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# This routine was copied almost verbatim from the 'pl2bat' utility
|
||||
# distributed with perl. It requires too much voodoo with shell quoting
|
||||
# differences and shortcomings between the various flavors of Windows
|
||||
# to reliably shell out
|
||||
sub pl2bat {
|
||||
my $self = shift;
|
||||
my %opts = @_;
|
||||
|
||||
# NOTE: %0 is already enclosed in doublequotes by cmd.exe, as appropriate
|
||||
$opts{ntargs} = '-x -S %0 %*' unless exists $opts{ntargs};
|
||||
$opts{otherargs} = '-x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9' unless exists $opts{otherargs};
|
||||
|
||||
$opts{stripsuffix} = '/\\.plx?/' unless exists $opts{stripsuffix};
|
||||
$opts{stripsuffix} = ($opts{stripsuffix} =~ m{^/([^/]*[^/\$]|)\$?/?$} ? $1 : "\Q$opts{stripsuffix}\E");
|
||||
|
||||
unless (exists $opts{out}) {
|
||||
$opts{out} = $opts{in};
|
||||
$opts{out} =~ s/$opts{stripsuffix}$//oi;
|
||||
$opts{out} .= '.bat' unless $opts{in} =~ /\.bat$/i or $opts{in} =~ /^-$/;
|
||||
}
|
||||
|
||||
my $head = <<EOT;
|
||||
\@rem = '--*-Perl-*--
|
||||
\@echo off
|
||||
if "%OS%" == "Windows_NT" goto WinNT
|
||||
perl $opts{otherargs}
|
||||
goto endofperl
|
||||
:WinNT
|
||||
perl $opts{ntargs}
|
||||
if NOT "%COMSPEC%" == "%SystemRoot%\\system32\\cmd.exe" goto endofperl
|
||||
if %errorlevel% == 9009 echo You do not have Perl in your PATH.
|
||||
if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
|
||||
goto endofperl
|
||||
\@rem ';
|
||||
EOT
|
||||
|
||||
$head =~ s/^\s+//gm;
|
||||
my $headlines = 2 + ($head =~ tr/\n/\n/);
|
||||
my $tail = "\n__END__\n:endofperl\n";
|
||||
|
||||
my $linedone = 0;
|
||||
my $taildone = 0;
|
||||
my $linenum = 0;
|
||||
my $skiplines = 0;
|
||||
|
||||
my $start = $Config{startperl};
|
||||
$start = "#!perl" unless $start =~ /^#!.*perl/;
|
||||
|
||||
open(my $in, '<', "$opts{in}") or die "Can't open $opts{in}: $!";
|
||||
my @file = <$in>;
|
||||
close($in);
|
||||
|
||||
foreach my $line ( @file ) {
|
||||
$linenum++;
|
||||
if ( $line =~ /^:endofperl\b/ ) {
|
||||
if (!exists $opts{update}) {
|
||||
warn "$opts{in} has already been converted to a batch file!\n";
|
||||
return;
|
||||
}
|
||||
$taildone++;
|
||||
}
|
||||
if ( not $linedone and $line =~ /^#!.*perl/ ) {
|
||||
if (exists $opts{update}) {
|
||||
$skiplines = $linenum - 1;
|
||||
$line .= "#line ".(1+$headlines)."\n";
|
||||
} else {
|
||||
$line .= "#line ".($linenum+$headlines)."\n";
|
||||
}
|
||||
$linedone++;
|
||||
}
|
||||
if ( $line =~ /^#\s*line\b/ and $linenum == 2 + $skiplines ) {
|
||||
$line = "";
|
||||
}
|
||||
}
|
||||
|
||||
open(my $out, '>', "$opts{out}") or die "Can't open $opts{out}: $!";
|
||||
print $out $head;
|
||||
print $out $start, ( $opts{usewarnings} ? " -w" : "" ),
|
||||
"\n#line ", ($headlines+1), "\n" unless $linedone;
|
||||
print $out @file[$skiplines..$#file];
|
||||
print $out $tail unless $taildone;
|
||||
close($out);
|
||||
|
||||
return $opts{out};
|
||||
}
|
||||
|
||||
|
||||
sub _quote_args {
|
||||
# Returns a string that can become [part of] a command line with
|
||||
# proper quoting so that the subprocess sees this same list of args.
|
||||
my ($self, @args) = @_;
|
||||
|
||||
my @quoted;
|
||||
|
||||
for (@args) {
|
||||
if ( /^[^\s*?!\$<>;|'"\[\]\{\}]+$/ ) {
|
||||
# Looks pretty safe
|
||||
push @quoted, $_;
|
||||
} else {
|
||||
# XXX this will obviously have to improve - is there already a
|
||||
# core module lying around that does proper quoting?
|
||||
s/"/\\"/g;
|
||||
push @quoted, qq("$_");
|
||||
}
|
||||
}
|
||||
|
||||
return join " ", @quoted;
|
||||
}
|
||||
|
||||
|
||||
sub split_like_shell {
|
||||
# As it turns out, Windows command-parsing is very different from
|
||||
# Unix command-parsing. Double-quotes mean different things,
|
||||
# backslashes don't necessarily mean escapes, and so on. So we
|
||||
# can't use Text::ParseWords::shellwords() to break a command string
|
||||
# into words. The algorithm below was bashed out by Randy and Ken
|
||||
# (mostly Randy), and there are a lot of regression tests, so we
|
||||
# should feel free to adjust if desired.
|
||||
|
||||
(my $self, local $_) = @_;
|
||||
|
||||
return @$_ if defined() && UNIVERSAL::isa($_, 'ARRAY');
|
||||
|
||||
my @argv;
|
||||
return @argv unless defined() && length();
|
||||
|
||||
my $arg = '';
|
||||
my( $i, $quote_mode ) = ( 0, 0 );
|
||||
|
||||
while ( $i < length() ) {
|
||||
|
||||
my $ch = substr( $_, $i , 1 );
|
||||
my $next_ch = substr( $_, $i+1, 1 );
|
||||
|
||||
if ( $ch eq '\\' && $next_ch eq '"' ) {
|
||||
$arg .= '"';
|
||||
$i++;
|
||||
} elsif ( $ch eq '\\' && $next_ch eq '\\' ) {
|
||||
$arg .= '\\';
|
||||
$i++;
|
||||
} elsif ( $ch eq '"' && $next_ch eq '"' && $quote_mode ) {
|
||||
$quote_mode = !$quote_mode;
|
||||
$arg .= '"';
|
||||
$i++;
|
||||
} elsif ( $ch eq '"' && $next_ch eq '"' && !$quote_mode &&
|
||||
( $i + 2 == length() ||
|
||||
substr( $_, $i + 2, 1 ) eq ' ' )
|
||||
) { # for cases like: a"" => [ 'a' ]
|
||||
push( @argv, $arg );
|
||||
$arg = '';
|
||||
$i += 2;
|
||||
} elsif ( $ch eq '"' ) {
|
||||
$quote_mode = !$quote_mode;
|
||||
} elsif ( $ch eq ' ' && !$quote_mode ) {
|
||||
push( @argv, $arg ) if $arg;
|
||||
$arg = '';
|
||||
++$i while substr( $_, $i + 1, 1 ) eq ' ';
|
||||
} else {
|
||||
$arg .= $ch;
|
||||
}
|
||||
|
||||
$i++;
|
||||
}
|
||||
|
||||
push( @argv, $arg ) if defined( $arg ) && length( $arg );
|
||||
return @argv;
|
||||
}
|
||||
|
||||
|
||||
# system(@cmd) does not like having double-quotes in it on Windows.
|
||||
# So we quote them and run it as a single command.
|
||||
sub do_system {
|
||||
my ($self, @cmd) = @_;
|
||||
|
||||
my $cmd = $self->_quote_args(@cmd);
|
||||
my $status = system($cmd);
|
||||
if ($status and $! =~ /Argument list too long/i) {
|
||||
my $env_entries = '';
|
||||
foreach (sort keys %ENV) { $env_entries .= "$_=>".length($ENV{$_})."; " }
|
||||
warn "'Argument list' was 'too long', env lengths are $env_entries";
|
||||
}
|
||||
return !$status;
|
||||
}
|
||||
|
||||
# Copied from ExtUtils::MM_Win32
|
||||
sub _maybe_command {
|
||||
my($self,$file) = @_;
|
||||
my @e = exists($ENV{'PATHEXT'})
|
||||
? split(/;/, $ENV{PATHEXT})
|
||||
: qw(.com .exe .bat .cmd);
|
||||
my $e = '';
|
||||
for (@e) { $e .= "\Q$_\E|" }
|
||||
chop $e;
|
||||
# see if file ends in one of the known extensions
|
||||
if ($file =~ /($e)$/i) {
|
||||
return $file if -e $file;
|
||||
}
|
||||
else {
|
||||
for (@e) {
|
||||
return "$file$_" if -e "$file$_";
|
||||
}
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Module::Build::Platform::Windows - Builder class for Windows platforms
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
The sole purpose of this module is to inherit from
|
||||
C<Module::Build::Base> and override a few methods. Please see
|
||||
L<Module::Build> for the docs.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Ken Williams <kwilliams@cpan.org>, Randy W. Sims <RandyS@ThePierianSpring.org>
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
perl(1), Module::Build(3)
|
||||
|
||||
=cut
|
||||
@@ -1,40 +0,0 @@
|
||||
package Module::Build::Platform::aix;
|
||||
|
||||
use strict;
|
||||
use vars qw($VERSION);
|
||||
$VERSION = '0.4206';
|
||||
$VERSION = eval $VERSION;
|
||||
use Module::Build::Platform::Unix;
|
||||
|
||||
use vars qw(@ISA);
|
||||
@ISA = qw(Module::Build::Platform::Unix);
|
||||
|
||||
# This class isn't necessary anymore, but we can't delete it, because
|
||||
# some people might still have the old copy in their @INC, containing
|
||||
# code we don't want to execute, so we have to make sure an upgrade
|
||||
# will replace it with this empty subclass.
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Module::Build::Platform::aix - Builder class for AIX platform
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module provides some routines very specific to the AIX
|
||||
platform.
|
||||
|
||||
Please see the L<Module::Build> for the general docs.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Ken Williams <kwilliams@cpan.org>
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
perl(1), Module::Build(3), ExtUtils::MakeMaker(3)
|
||||
|
||||
=cut
|
||||
@@ -1,55 +0,0 @@
|
||||
package Module::Build::Platform::cygwin;
|
||||
|
||||
use strict;
|
||||
use vars qw($VERSION);
|
||||
$VERSION = '0.4206';
|
||||
$VERSION = eval $VERSION;
|
||||
use Module::Build::Platform::Unix;
|
||||
|
||||
use vars qw(@ISA);
|
||||
@ISA = qw(Module::Build::Platform::Unix);
|
||||
|
||||
sub manpage_separator {
|
||||
'.'
|
||||
}
|
||||
|
||||
# Copied from ExtUtils::MM_Cygwin::maybe_command()
|
||||
# If our path begins with F</cygdrive/> then we use the Windows version
|
||||
# to determine if it may be a command. Otherwise we use the tests
|
||||
# from C<ExtUtils::MM_Unix>.
|
||||
|
||||
sub _maybe_command {
|
||||
my ($self, $file) = @_;
|
||||
|
||||
if ($file =~ m{^/cygdrive/}i) {
|
||||
require Module::Build::Platform::Windows;
|
||||
return Module::Build::Platform::Windows->_maybe_command($file);
|
||||
}
|
||||
|
||||
return $self->SUPER::_maybe_command($file);
|
||||
}
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Module::Build::Platform::cygwin - Builder class for Cygwin platform
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module provides some routines very specific to the cygwin
|
||||
platform.
|
||||
|
||||
Please see the L<Module::Build> for the general docs.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Initial stub by Yitzchak Scott-Thoennes <sthoenna@efn.org>
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
perl(1), Module::Build(3), ExtUtils::MakeMaker(3)
|
||||
|
||||
=cut
|
||||
@@ -1,40 +0,0 @@
|
||||
package Module::Build::Platform::darwin;
|
||||
|
||||
use strict;
|
||||
use vars qw($VERSION);
|
||||
$VERSION = '0.4206';
|
||||
$VERSION = eval $VERSION;
|
||||
use Module::Build::Platform::Unix;
|
||||
|
||||
use vars qw(@ISA);
|
||||
@ISA = qw(Module::Build::Platform::Unix);
|
||||
|
||||
# This class isn't necessary anymore, but we can't delete it, because
|
||||
# some people might still have the old copy in their @INC, containing
|
||||
# code we don't want to execute, so we have to make sure an upgrade
|
||||
# will replace it with this empty subclass.
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Module::Build::Platform::darwin - Builder class for Mac OS X platform
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module provides some routines very specific to the Mac OS X
|
||||
platform.
|
||||
|
||||
Please see the L<Module::Build> for the general docs.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Ken Williams <kwilliams@cpan.org>
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
perl(1), Module::Build(3), ExtUtils::MakeMaker(3)
|
||||
|
||||
=cut
|
||||
@@ -1,49 +0,0 @@
|
||||
package Module::Build::Platform::os2;
|
||||
|
||||
use strict;
|
||||
use vars qw($VERSION);
|
||||
$VERSION = '0.4206';
|
||||
$VERSION = eval $VERSION;
|
||||
use Module::Build::Platform::Unix;
|
||||
|
||||
use vars qw(@ISA);
|
||||
@ISA = qw(Module::Build::Platform::Unix);
|
||||
|
||||
sub manpage_separator { '.' }
|
||||
|
||||
sub have_forkpipe { 0 }
|
||||
|
||||
# Copied from ExtUtils::MM_OS2::maybe_command
|
||||
sub _maybe_command {
|
||||
my($self,$file) = @_;
|
||||
$file =~ s,[/\\]+,/,g;
|
||||
return $file if -x $file && ! -d _;
|
||||
return "$file.exe" if -x "$file.exe" && ! -d _;
|
||||
return "$file.cmd" if -x "$file.cmd" && ! -d _;
|
||||
return;
|
||||
}
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Module::Build::Platform::os2 - Builder class for OS/2 platform
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module provides some routines very specific to the OS/2
|
||||
platform.
|
||||
|
||||
Please see the L<Module::Build> for the general docs.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Ken Williams <kwilliams@cpan.org>
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
perl(1), Module::Build(3), ExtUtils::MakeMaker(3)
|
||||
|
||||
=cut
|
||||
@@ -1,65 +0,0 @@
|
||||
package Module::Build::PodParser;
|
||||
|
||||
use strict;
|
||||
use vars qw($VERSION);
|
||||
$VERSION = '0.4206';
|
||||
$VERSION = eval $VERSION;
|
||||
use vars qw(@ISA);
|
||||
|
||||
sub new {
|
||||
# Perl is so fun.
|
||||
my $package = shift;
|
||||
|
||||
my $self;
|
||||
@ISA = ();
|
||||
$self = bless {have_pod_parser => 0, @_}, $package;
|
||||
|
||||
unless ($self->{fh}) {
|
||||
die "No 'file' or 'fh' parameter given" unless $self->{file};
|
||||
open($self->{fh}, '<', $self->{file}) or die "Couldn't open $self->{file}: $!";
|
||||
}
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub parse_from_filehandle {
|
||||
my ($self, $fh) = @_;
|
||||
|
||||
local $_;
|
||||
while (<$fh>) {
|
||||
next unless /^=(?!cut)/ .. /^=cut/; # in POD
|
||||
# Accept Name - abstract or C<Name> - abstract
|
||||
last if ($self->{abstract}) = /^ (?: [a-z_0-9:]+ | [BCIF] < [a-z_0-9:]+ > ) \s+ - \s+ (.*\S) /ix;
|
||||
}
|
||||
|
||||
my @author;
|
||||
while (<$fh>) {
|
||||
next unless /^=head1\s+AUTHORS?/i ... /^=/;
|
||||
next if /^=/;
|
||||
push @author, $_ if /\@/;
|
||||
}
|
||||
return unless @author;
|
||||
s/^\s+|\s+$//g foreach @author;
|
||||
|
||||
$self->{author} = \@author;
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
sub get_abstract {
|
||||
my $self = shift;
|
||||
return $self->{abstract} if defined $self->{abstract};
|
||||
|
||||
$self->parse_from_filehandle($self->{fh});
|
||||
|
||||
return $self->{abstract};
|
||||
}
|
||||
|
||||
sub get_author {
|
||||
my $self = shift;
|
||||
return $self->{author} if defined $self->{author};
|
||||
|
||||
$self->parse_from_filehandle($self->{fh});
|
||||
|
||||
return $self->{author} || [];
|
||||
}
|
||||
@@ -1,21 +0,0 @@
|
||||
package Module::Build::Version;
|
||||
use strict;
|
||||
use vars qw($VERSION);
|
||||
$VERSION = '0.87'; ### XXX sync with version of version.pm below
|
||||
|
||||
use version 0.87;
|
||||
our @ISA = qw(version);
|
||||
|
||||
1;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Module::Build::Version - DEPRECATED
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Module::Build now lists L<version> as a C<configure_requires> dependency
|
||||
and no longer installs a copy.
|
||||
|
||||
=cut
|
||||
|
||||
@@ -1,19 +0,0 @@
|
||||
package Module::Build::YAML;
|
||||
use strict;
|
||||
use CPAN::Meta::YAML 0.002 ();
|
||||
our @ISA = qw(CPAN::Meta::YAML);
|
||||
our $VERSION = '1.41';
|
||||
1;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Module::Build::YAML - DEPRECATED
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module was originally an inline copy of L<YAML::Tiny>. It has been
|
||||
deprecated in favor of using L<CPAN::Meta::YAML> directly. This module is kept
|
||||
as a subclass wrapper for compatibility.
|
||||
|
||||
=cut
|
||||
|
||||
@@ -1,248 +0,0 @@
|
||||
package inc::latest;
|
||||
|
||||
use if $] >= 5.019, 'deprecate';
|
||||
|
||||
use strict;
|
||||
use vars qw($VERSION);
|
||||
$VERSION = '0.4206';
|
||||
$VERSION = eval $VERSION;
|
||||
|
||||
use Carp;
|
||||
use File::Basename ();
|
||||
use File::Spec ();
|
||||
use File::Path ();
|
||||
use File::Copy ();
|
||||
|
||||
# track and return modules loaded by inc::latest
|
||||
my @loaded_modules;
|
||||
sub loaded_modules {@loaded_modules}
|
||||
|
||||
# must ultimately "goto" the import routine of the module to be loaded
|
||||
# so that the calling package is correct when $mod->import() runs.
|
||||
sub import {
|
||||
my ($package, $mod, @args) = @_;
|
||||
return unless(defined $mod);
|
||||
|
||||
my $private_path = 'inc/latest/private.pm';
|
||||
if(-e $private_path) {
|
||||
# user mode - delegate work to bundled private module
|
||||
require $private_path;
|
||||
splice( @_, 0, 1, 'inc::latest::private');
|
||||
goto \&inc::latest::private::import;
|
||||
}
|
||||
|
||||
# author mode - just record and load the modules
|
||||
push(@loaded_modules, $mod);
|
||||
require inc::latest::private;
|
||||
goto \&inc::latest::private::_load_module;
|
||||
}
|
||||
|
||||
sub write {
|
||||
my $package = shift;
|
||||
my ($where, @preload) = @_;
|
||||
|
||||
warn "should really be writing in inc/" unless $where =~ /inc$/;
|
||||
|
||||
# write inc/latest.pm
|
||||
File::Path::mkpath( $where );
|
||||
open my $fh, '>', File::Spec->catfile($where,'latest.pm');
|
||||
print {$fh} "# This stub created by inc::latest $VERSION\n";
|
||||
print {$fh} <<'HERE';
|
||||
package inc::latest;
|
||||
use strict;
|
||||
use vars '@ISA';
|
||||
require inc::latest::private;
|
||||
@ISA = qw/inc::latest::private/;
|
||||
HERE
|
||||
if (@preload) {
|
||||
print {$fh} "\npackage inc::latest::preload;\n";
|
||||
for my $mod (@preload) {
|
||||
print {$fh} "inc::latest->import('$mod');\n";
|
||||
}
|
||||
}
|
||||
print {$fh} "\n1;\n";
|
||||
close $fh;
|
||||
|
||||
# write inc/latest/private;
|
||||
require inc::latest::private;
|
||||
File::Path::mkpath( File::Spec->catdir( $where, 'latest' ) );
|
||||
my $from = $INC{'inc/latest/private.pm'};
|
||||
my $to = File::Spec->catfile($where,'latest','private.pm');
|
||||
File::Copy::copy( $from, $to ) or die "Couldn't copy '$from' to '$to': $!";
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub bundle_module {
|
||||
my ($package, $module, $where) = @_;
|
||||
|
||||
# create inc/inc_$foo
|
||||
(my $dist = $module) =~ s{::}{-}g;
|
||||
my $inc_lib = File::Spec->catdir($where,"inc_$dist");
|
||||
File::Path::mkpath $inc_lib;
|
||||
|
||||
# get list of files to copy
|
||||
require ExtUtils::Installed;
|
||||
# workaround buggy EU::Installed check of @INC
|
||||
my $inst = ExtUtils::Installed->new(extra_libs => [@INC]);
|
||||
my $packlist = $inst->packlist( $module ) or die "Couldn't find packlist";
|
||||
my @files = grep { /\.pm$/ } keys %$packlist;
|
||||
|
||||
|
||||
# figure out prefix
|
||||
my $mod_path = quotemeta $package->_mod2path( $module );
|
||||
my ($prefix) = grep { /$mod_path$/ } @files;
|
||||
$prefix =~ s{$mod_path$}{};
|
||||
|
||||
# copy files
|
||||
for my $from ( @files ) {
|
||||
next unless $from =~ /\.pm$/;
|
||||
(my $mod_path = $from) =~ s{^\Q$prefix\E}{};
|
||||
my $to = File::Spec->catfile( $inc_lib, $mod_path );
|
||||
File::Path::mkpath(File::Basename::dirname($to));
|
||||
File::Copy::copy( $from, $to ) or die "Couldn't copy '$from' to '$to': $!";
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
# Translate a module name into a directory/file.pm to search for in @INC
|
||||
sub _mod2path {
|
||||
my ($self, $mod) = @_;
|
||||
my @parts = split /::/, $mod;
|
||||
$parts[-1] .= '.pm';
|
||||
return $parts[0] if @parts == 1;
|
||||
return File::Spec->catfile(@parts);
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
|
||||
=head1 NAME
|
||||
|
||||
inc::latest - use modules bundled in inc/ if they are newer than installed ones
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
# in Build.PL
|
||||
use inc::latest 'Module::Build';
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
The C<inc::latest> module helps bootstrap configure-time dependencies for CPAN
|
||||
distributions. These dependencies get bundled into the C<inc> directory within
|
||||
a distribution and are used by Build.PL (or Makefile.PL).
|
||||
|
||||
Arguments to C<inc::latest> are module names that are checked against both the
|
||||
current C<@INC> array and against specially-named directories in C<inc>. If
|
||||
the bundled version is newer than the installed one (or the module isn't
|
||||
installed, then, the bundled directory is added to the start of <@INC> and the
|
||||
module is loaded from there.
|
||||
|
||||
There are actually two variations of C<inc::latest> -- one for authors and one
|
||||
for the C<inc> directory. For distribution authors, the C<inc::latest>
|
||||
installed in the system will record modules loaded via C<inc::latest> and can
|
||||
be used to create the bundled files in C<inc>, including writing the second
|
||||
variation as C<inc/latest.pm>.
|
||||
|
||||
This second C<inc::latest> is the one that is loaded in a distribution being
|
||||
installed (e.g. from Build.PL). This bundled C<inc::latest> is the one
|
||||
that determines which module to load.
|
||||
|
||||
=head2 Special notes on bundling
|
||||
|
||||
The C<inc::latest> module creates bundled directories based on the packlist
|
||||
file of an installed distribution. Even though C<inc::latest> takes module
|
||||
name arguments, it is better to think of it as bundling and making available
|
||||
entire I<distributions>. When a module is loaded through C<inc::latest>,
|
||||
it looks in all bundled distributions in C<inc/> for a newer module than
|
||||
can be found in the existing C<@INC> array.
|
||||
|
||||
Thus, the module-name provided should usually be the "top-level" module name of
|
||||
a distribution, though this is not strictly required. For example,
|
||||
L<Module::Build> has a number of heuristics to map module names to packlists,
|
||||
allowing users to do things like this:
|
||||
|
||||
use inc::latest 'Devel::AssertOS::Unix';
|
||||
|
||||
even though Devel::AssertOS::Unix is contained within the Devel-CheckOS
|
||||
distribution.
|
||||
|
||||
At the current time, packlists are required. Thus, bundling dual-core modules
|
||||
may require a 'forced install' over versions in the latest version of perl
|
||||
in order to create the necessary packlist for bundling.
|
||||
|
||||
=head1 USAGE
|
||||
|
||||
When calling C<use>, the bundled C<inc::latest> takes a single module name and
|
||||
optional arguments to pass to that module's own import method.
|
||||
|
||||
use 'inc::latest' 'Foo::Bar' qw/foo bar baz/;
|
||||
|
||||
=head2 Author-mode
|
||||
|
||||
You are in author-mode inc::latest if any of the Author-mode methods are
|
||||
available. For example:
|
||||
|
||||
if ( inc::latest->can('write') ) {
|
||||
inc::latest->write('inc');
|
||||
}
|
||||
|
||||
=over 4
|
||||
|
||||
=item loaded_modules()
|
||||
|
||||
my @list = inc::latest->loaded_modules;
|
||||
|
||||
This takes no arguments and always returns a list of module names requested for
|
||||
loading via "use inc::latest 'MODULE'", regardless of whether the load was
|
||||
successful or not.
|
||||
|
||||
=item write()
|
||||
|
||||
inc::latest->write( 'inc' );
|
||||
|
||||
This writes the bundled version of inc::latest to the directory name given as an
|
||||
argument. It almost all cases, it should be 'C<inc>'.
|
||||
|
||||
=item bundle_module()
|
||||
|
||||
for my $mod ( inc::latest->loaded_modules ) {
|
||||
inc::latest->bundle_module($mod, $dir);
|
||||
}
|
||||
|
||||
If $mod corresponds to a packlist, then this function creates a specially-named
|
||||
directory in $dir and copies all .pm files from the modlist to the new
|
||||
directory (which almost always should just be 'inc'). For example, if Foo::Bar
|
||||
is the name of the module, and $dir is 'inc', then the directory would be
|
||||
'inc/inc_Foo-Bar' and contain files like this:
|
||||
|
||||
inc/inc_Foo-Bar/Foo/Bar.pm
|
||||
|
||||
Currently, $mod B<must> have a packlist. If this is not the case (e.g. for a
|
||||
dual-core module), then the bundling will fail. You may be able to create a
|
||||
packlist by forced installing the module on top of the version that came with
|
||||
core Perl.
|
||||
|
||||
=back
|
||||
|
||||
=head2 As bundled in inc/
|
||||
|
||||
All methods are private. Only the C<import> method is public.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Eric Wilhelm <ewilhelm@cpan.org>, David Golden <dagolden@cpan.org>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2009 by Eric Wilhelm and David Golden
|
||||
|
||||
This library is free software; you can redistribute it and/or
|
||||
modify it under the same terms as Perl itself.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Module::Build>
|
||||
|
||||
=cut
|
||||
|
||||
@@ -1,102 +0,0 @@
|
||||
package inc::latest::private;
|
||||
|
||||
use if $] >= 5.019, 'deprecate';
|
||||
|
||||
use strict;
|
||||
use vars qw($VERSION);
|
||||
$VERSION = '0.4206';
|
||||
$VERSION = eval $VERSION;
|
||||
|
||||
use File::Spec;
|
||||
|
||||
# must ultimately "goto" the import routine of the module to be loaded
|
||||
# so that the calling package is correct when $mod->import() runs.
|
||||
sub import {
|
||||
my ($package, $mod, @args) = @_;
|
||||
my $file = $package->_mod2path($mod);
|
||||
|
||||
if ($INC{$file}) {
|
||||
# Already loaded, but let _load_module handle import args
|
||||
goto \&_load_module;
|
||||
}
|
||||
|
||||
# A bundled copy must be present
|
||||
my ($bundled, $bundled_dir) = $package->_search_bundled($file)
|
||||
or die "No bundled copy of $mod found";
|
||||
|
||||
my $from_inc = $package->_search_INC($file);
|
||||
unless ($from_inc) {
|
||||
# Only bundled is available
|
||||
unshift(@INC, $bundled_dir);
|
||||
goto \&_load_module;
|
||||
}
|
||||
|
||||
if (_version($from_inc) >= _version($bundled)) {
|
||||
# Ignore the bundled copy
|
||||
goto \&_load_module;
|
||||
}
|
||||
|
||||
# Load the bundled copy
|
||||
unshift(@INC, $bundled_dir);
|
||||
goto \&_load_module;
|
||||
}
|
||||
|
||||
sub _version {
|
||||
require ExtUtils::MakeMaker;
|
||||
return ExtUtils::MM->parse_version(shift);
|
||||
}
|
||||
|
||||
# use "goto" for import to preserve caller
|
||||
sub _load_module {
|
||||
my $package = shift; # remaining @_ is ready for goto
|
||||
my ($mod, @args) = @_;
|
||||
eval "require $mod; 1" or die $@;
|
||||
if ( my $import = $mod->can('import') ) {
|
||||
goto $import;
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub _search_bundled {
|
||||
my ($self, $file) = @_;
|
||||
|
||||
my $mypath = 'inc';
|
||||
|
||||
opendir my $DH, $mypath or die "Can't open directory $mypath: $!";
|
||||
|
||||
while (defined(my $e = readdir $DH)) {
|
||||
next unless $e =~ /^inc_/;
|
||||
my $try = File::Spec->catfile($mypath, $e, $file);
|
||||
|
||||
return($try, File::Spec->catdir($mypath, $e)) if -e $try;
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
# Look for the given path in @INC.
|
||||
sub _search_INC {
|
||||
# TODO: doesn't handle coderefs or arrayrefs or objects in @INC, but
|
||||
# it probably should
|
||||
my ($self, $file) = @_;
|
||||
|
||||
foreach my $dir (@INC) {
|
||||
next if ref $dir;
|
||||
my $try = File::Spec->catfile($dir, $file);
|
||||
return $try if -e $try;
|
||||
}
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
# Translate a module name into a directory/file.pm to search for in @INC
|
||||
sub _mod2path {
|
||||
my ($self, $mod) = @_;
|
||||
my @parts = split /::/, $mod;
|
||||
$parts[-1] .= '.pm';
|
||||
return $parts[0] if @parts == 1;
|
||||
return File::Spec->catfile(@parts);
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
|
||||
@@ -1,904 +0,0 @@
|
||||
## CursesFun.c -- the functions
|
||||
##
|
||||
## Copyright (c) 1994-2000 William Setzer
|
||||
##
|
||||
## You may distribute under the terms of either the Artistic License
|
||||
## or the GNU General Public License, as specified in the README file.
|
||||
|
||||
###
|
||||
## For the brave object-using person
|
||||
#
|
||||
package Curses::Window;
|
||||
|
||||
@ISA = qw(Curses);
|
||||
|
||||
package Curses::Screen;
|
||||
|
||||
@ISA = qw(Curses);
|
||||
sub new { newterm(@_) }
|
||||
sub DESTROY { }
|
||||
|
||||
package Curses::Panel;
|
||||
|
||||
@ISA = qw(Curses);
|
||||
sub new { new_panel(@_) }
|
||||
sub DESTROY { }
|
||||
|
||||
package Curses::Menu;
|
||||
|
||||
@ISA = qw(Curses);
|
||||
sub new { new_menu(@_) }
|
||||
sub DESTROY { }
|
||||
|
||||
package Curses::Item;
|
||||
|
||||
@ISA = qw(Curses);
|
||||
sub new { new_item(@_) }
|
||||
sub DESTROY { }
|
||||
|
||||
package Curses::Form;
|
||||
|
||||
@ISA = qw(Curses);
|
||||
sub new { new_form(@_) }
|
||||
sub DESTROY { }
|
||||
|
||||
package Curses::Field;
|
||||
|
||||
@ISA = qw(Curses);
|
||||
sub new { new_field(@_) }
|
||||
sub DESTROY { }
|
||||
|
||||
|
||||
package Curses;
|
||||
|
||||
$VERSION = '1.28'; # Makefile.PL picks this up
|
||||
|
||||
use Carp;
|
||||
require Exporter;
|
||||
require DynaLoader;
|
||||
@ISA = qw(Exporter DynaLoader);
|
||||
|
||||
bootstrap Curses;
|
||||
|
||||
sub new {
|
||||
my $pkg = shift;
|
||||
my ($nl, $nc, $by, $bx) = (@_,0,0,0,0);
|
||||
|
||||
unless ($_initscr++) { initscr() }
|
||||
return newwin($nl, $nc, $by, $bx);
|
||||
}
|
||||
|
||||
sub DESTROY { }
|
||||
|
||||
sub AUTOLOAD {
|
||||
my $N = $AUTOLOAD;
|
||||
$N =~ s/^.*:://;
|
||||
|
||||
croak "Curses constant '$N' is not defined by your vendor";
|
||||
}
|
||||
|
||||
sub printw { addstr(sprintf shift, @_) }
|
||||
|
||||
tie $LINES, Curses::Vars, 1;
|
||||
tie $COLS, Curses::Vars, 2;
|
||||
tie $stdscr, Curses::Vars, 3;
|
||||
tie $curscr, Curses::Vars, 4;
|
||||
tie $COLORS, Curses::Vars, 5;
|
||||
tie $COLOR_PAIRS, Curses::Vars, 6;
|
||||
|
||||
@EXPORT = qw(
|
||||
printw
|
||||
|
||||
LINES $LINES COLS $COLS stdscr $stdscr curscr $curscr COLORS $COLORS
|
||||
COLOR_PAIRS $COLOR_PAIRS
|
||||
|
||||
addch echochar addchstr addchnstr addstr addnstr attroff attron attrset
|
||||
standend standout attr_get attr_off attr_on attr_set chgat COLOR_PAIR
|
||||
PAIR_NUMBER beep flash bkgd bkgdset getbkgd border box hline vline
|
||||
erase clear clrtobot clrtoeol start_color init_pair init_color
|
||||
has_colors can_change_color color_content pair_content delch deleteln
|
||||
insdelln insertln getch ungetch has_key KEY_F getstr getnstr getyx
|
||||
getparyx getbegyx getmaxyx inch inchstr inchnstr initscr endwin
|
||||
isendwin newterm set_term delscreen cbreak nocbreak echo noecho
|
||||
halfdelay intrflush keypad meta nodelay notimeout raw noraw qiflush
|
||||
noqiflush timeout typeahead insch insstr insnstr instr innstr
|
||||
def_prog_mode def_shell_mode reset_prog_mode reset_shell_mode resetty
|
||||
savetty getsyx setsyx curs_set napms move clearok idlok idcok immedok
|
||||
leaveok setscrreg scrollok nl nonl overlay overwrite copywin newpad
|
||||
subpad prefresh pnoutrefresh pechochar refresh noutrefresh doupdate
|
||||
redrawwin redrawln scr_dump scr_restore scr_init scr_set scroll scrl
|
||||
slk_init slk_set slk_refresh slk_noutrefresh slk_label slk_clear
|
||||
slk_restore slk_touch slk_attron slk_attrset slk_attr slk_attroff
|
||||
slk_color baudrate erasechar has_ic has_il killchar longname termattrs
|
||||
termname touchwin touchline untouchwin touchln is_linetouched
|
||||
is_wintouched unctrl keyname filter use_env putwin getwin delay_output
|
||||
flushinp newwin delwin mvwin subwin derwin mvderwin dupwin syncup
|
||||
syncok cursyncup syncdown getmouse ungetmouse mousemask enclose
|
||||
mouse_trafo mouseinterval BUTTON_RELEASE BUTTON_PRESS BUTTON_CLICK
|
||||
BUTTON_DOUBLE_CLICK BUTTON_TRIPLE_CLICK BUTTON_RESERVED_EVENT
|
||||
use_default_colors assume_default_colors define_key keybound keyok
|
||||
resizeterm resize getmaxy getmaxx flusok getcap touchoverlap new_panel
|
||||
bottom_panel top_panel show_panel update_panels hide_panel panel_window
|
||||
replace_panel move_panel panel_hidden panel_above panel_below
|
||||
set_panel_userptr panel_userptr del_panel set_menu_fore menu_fore
|
||||
set_menu_back menu_back set_menu_grey menu_grey set_menu_pad menu_pad
|
||||
pos_menu_cursor menu_driver set_menu_format menu_format set_menu_items
|
||||
menu_items item_count set_menu_mark menu_mark new_menu free_menu
|
||||
menu_opts set_menu_opts menu_opts_on menu_opts_off set_menu_pattern
|
||||
menu_pattern post_menu unpost_menu set_menu_userptr menu_userptr
|
||||
set_menu_win menu_win set_menu_sub menu_sub scale_menu set_current_item
|
||||
current_item set_top_row top_row item_index item_name item_description
|
||||
new_item free_item set_item_opts item_opts_on item_opts_off item_opts
|
||||
item_userptr set_item_userptr set_item_value item_value item_visible
|
||||
menu_request_name menu_request_by_name set_menu_spacing menu_spacing
|
||||
pos_form_cursor data_ahead data_behind form_driver set_form_fields
|
||||
form_fields field_count move_field new_form free_form set_new_page
|
||||
new_page set_form_opts form_opts_on form_opts_off form_opts
|
||||
set_current_field current_field set_form_page form_page field_index
|
||||
post_form unpost_form set_form_userptr form_userptr set_form_win
|
||||
form_win set_form_sub form_sub scale_form set_field_fore field_fore
|
||||
set_field_back field_back set_field_pad field_pad set_field_buffer
|
||||
field_buffer set_field_status field_status set_max_field field_info
|
||||
dynamic_field_info set_field_just field_just new_field dup_field
|
||||
link_field free_field set_field_opts field_opts_on field_opts_off
|
||||
field_opts set_field_userptr field_userptr field_arg form_request_name
|
||||
form_request_by_name
|
||||
|
||||
ERR OK ACS_BLOCK ACS_BOARD ACS_BTEE ACS_BULLET ACS_CKBOARD ACS_DARROW
|
||||
ACS_DEGREE ACS_DIAMOND ACS_HLINE ACS_LANTERN ACS_LARROW ACS_LLCORNER
|
||||
ACS_LRCORNER ACS_LTEE ACS_PLMINUS ACS_PLUS ACS_RARROW ACS_RTEE ACS_S1
|
||||
ACS_S9 ACS_TTEE ACS_UARROW ACS_ULCORNER ACS_URCORNER ACS_VLINE
|
||||
A_ALTCHARSET A_ATTRIBUTES A_BLINK A_BOLD A_CHARTEXT A_COLOR A_DIM
|
||||
A_INVIS A_NORMAL A_PROTECT A_REVERSE A_STANDOUT A_UNDERLINE COLOR_BLACK
|
||||
COLOR_BLUE COLOR_CYAN COLOR_GREEN COLOR_MAGENTA COLOR_RED COLOR_WHITE
|
||||
COLOR_YELLOW KEY_A1 KEY_A3 KEY_B2 KEY_BACKSPACE KEY_BEG KEY_BREAK
|
||||
KEY_BTAB KEY_C1 KEY_C3 KEY_CANCEL KEY_CATAB KEY_CLEAR KEY_CLOSE
|
||||
KEY_COMMAND KEY_COPY KEY_CREATE KEY_CTAB KEY_DC KEY_DL KEY_DOWN KEY_EIC
|
||||
KEY_END KEY_ENTER KEY_EOL KEY_EOS KEY_EVENT KEY_EXIT
|
||||
KEY_F0 KEY_FIND KEY_HELP
|
||||
KEY_HOME KEY_IC KEY_IL KEY_LEFT KEY_LL KEY_MARK KEY_MAX KEY_MESSAGE
|
||||
KEY_MOUSE KEY_MIN KEY_MOVE KEY_NEXT KEY_NPAGE
|
||||
KEY_OPEN KEY_OPTIONS KEY_PPAGE
|
||||
KEY_PREVIOUS KEY_PRINT KEY_REDO KEY_REFERENCE KEY_REFRESH KEY_REPLACE
|
||||
KEY_RESET KEY_RESIZE KEY_RESTART KEY_RESUME KEY_RIGHT KEY_SAVE KEY_SBEG
|
||||
KEY_SCANCEL KEY_SCOMMAND KEY_SCOPY KEY_SCREATE KEY_SDC KEY_SDL
|
||||
KEY_SELECT KEY_SEND KEY_SEOL KEY_SEXIT KEY_SF KEY_SFIND KEY_SHELP
|
||||
KEY_SHOME KEY_SIC KEY_SLEFT KEY_SMESSAGE KEY_SMOVE KEY_SNEXT
|
||||
KEY_SOPTIONS KEY_SPREVIOUS KEY_SPRINT KEY_SR KEY_SREDO KEY_SREPLACE
|
||||
KEY_SRESET KEY_SRIGHT KEY_SRSUME KEY_SSAVE KEY_SSUSPEND KEY_STAB
|
||||
KEY_SUNDO KEY_SUSPEND KEY_UNDO KEY_UP
|
||||
BUTTON1_RELEASED BUTTON1_PRESSED BUTTON1_CLICKED BUTTON1_DOUBLE_CLICKED
|
||||
BUTTON1_TRIPLE_CLICKED BUTTON1_RESERVED_EVENT BUTTON2_RELEASED
|
||||
BUTTON2_PRESSED BUTTON2_CLICKED BUTTON2_DOUBLE_CLICKED
|
||||
BUTTON2_TRIPLE_CLICKED BUTTON2_RESERVED_EVENT BUTTON3_RELEASED
|
||||
BUTTON3_PRESSED BUTTON3_CLICKED BUTTON3_DOUBLE_CLICKED
|
||||
BUTTON3_TRIPLE_CLICKED BUTTON3_RESERVED_EVENT BUTTON4_RELEASED
|
||||
BUTTON4_PRESSED BUTTON4_CLICKED BUTTON4_DOUBLE_CLICKED
|
||||
BUTTON4_TRIPLE_CLICKED BUTTON4_RESERVED_EVENT BUTTON_CTRL BUTTON_SHIFT
|
||||
BUTTON_ALT ALL_MOUSE_EVENTS REPORT_MOUSE_POSITION NCURSES_MOUSE_VERSION
|
||||
E_OK E_SYSTEM_ERROR E_BAD_ARGUMENT E_POSTED E_CONNECTED E_BAD_STATE
|
||||
E_NO_ROOM E_NOT_POSTED E_UNKNOWN_COMMAND E_NO_MATCH E_NOT_SELECTABLE
|
||||
E_NOT_CONNECTED E_REQUEST_DENIED E_INVALID_FIELD E_CURRENT
|
||||
REQ_LEFT_ITEM REQ_RIGHT_ITEM REQ_UP_ITEM REQ_DOWN_ITEM REQ_SCR_ULINE
|
||||
REQ_SCR_DLINE REQ_SCR_DPAGE REQ_SCR_UPAGE REQ_FIRST_ITEM REQ_LAST_ITEM
|
||||
REQ_NEXT_ITEM REQ_PREV_ITEM REQ_TOGGLE_ITEM REQ_CLEAR_PATTERN
|
||||
REQ_BACK_PATTERN REQ_NEXT_MATCH REQ_PREV_MATCH MIN_MENU_COMMAND
|
||||
MAX_MENU_COMMAND O_ONEVALUE O_SHOWDESC O_ROWMAJOR O_IGNORECASE
|
||||
O_SHOWMATCH O_NONCYCLIC O_SELECTABLE REQ_NEXT_PAGE REQ_PREV_PAGE
|
||||
REQ_FIRST_PAGE REQ_LAST_PAGE REQ_NEXT_FIELD REQ_PREV_FIELD
|
||||
REQ_FIRST_FIELD REQ_LAST_FIELD REQ_SNEXT_FIELD REQ_SPREV_FIELD
|
||||
REQ_SFIRST_FIELD REQ_SLAST_FIELD REQ_LEFT_FIELD REQ_RIGHT_FIELD
|
||||
REQ_UP_FIELD REQ_DOWN_FIELD REQ_NEXT_CHAR REQ_PREV_CHAR REQ_NEXT_LINE
|
||||
REQ_PREV_LINE REQ_NEXT_WORD REQ_PREV_WORD REQ_BEG_FIELD REQ_END_FIELD
|
||||
REQ_BEG_LINE REQ_END_LINE REQ_LEFT_CHAR REQ_RIGHT_CHAR REQ_UP_CHAR
|
||||
REQ_DOWN_CHAR REQ_NEW_LINE REQ_INS_CHAR REQ_INS_LINE REQ_DEL_CHAR
|
||||
REQ_DEL_PREV REQ_DEL_LINE REQ_DEL_WORD REQ_CLR_EOL REQ_CLR_EOF
|
||||
REQ_CLR_FIELD REQ_OVL_MODE REQ_INS_MODE REQ_SCR_FLINE REQ_SCR_BLINE
|
||||
REQ_SCR_FPAGE REQ_SCR_BPAGE REQ_SCR_FHPAGE REQ_SCR_BHPAGE REQ_SCR_FCHAR
|
||||
REQ_SCR_BCHAR REQ_SCR_HFLINE REQ_SCR_HBLINE REQ_SCR_HFHALF
|
||||
REQ_SCR_HBHALF REQ_VALIDATION REQ_NEXT_CHOICE REQ_PREV_CHOICE
|
||||
MIN_FORM_COMMAND MAX_FORM_COMMAND NO_JUSTIFICATION JUSTIFY_LEFT
|
||||
JUSTIFY_CENTER JUSTIFY_RIGHT O_VISIBLE O_ACTIVE O_PUBLIC O_EDIT O_WRAP
|
||||
O_BLANK O_AUTOSKIP O_NULLOK O_PASSOK O_STATIC O_NL_OVERLOAD
|
||||
O_BS_OVERLOAD
|
||||
);
|
||||
|
||||
if ($OldCurses)
|
||||
{
|
||||
@_OLD = qw(
|
||||
wprintw mvprintw wmvprintw
|
||||
|
||||
waddch mvaddch mvwaddch wechochar waddchstr mvaddchstr
|
||||
mvwaddchstr waddchnstr mvaddchnstr mvwaddchnstr waddstr
|
||||
mvaddstr mvwaddstr waddnstr mvaddnstr mvwaddnstr wattroff
|
||||
wattron wattrset wstandend wstandout wattr_get wattr_off wattr_on
|
||||
wattr_set wchgat mvchgat mvwchgat wbkgd wbkgdset wborder whline
|
||||
mvhline mvwhline wvline mvvline mvwvline werase wclear
|
||||
wclrtobot wclrtoeol wdelch mvdelch mvwdelch wdeleteln winsdelln
|
||||
winsertln wgetch mvgetch mvwgetch wgetstr mvgetstr mvwgetstr
|
||||
wgetnstr mvgetnstr mvwgetnstr winch mvinch mvwinch winchstr
|
||||
mvinchstr mvwinchstr winchnstr mvinchnstr mvwinchnstr wtimeout
|
||||
winsch mvinsch mvwinsch winsstr mvinsstr mvwinsstr winsnstr
|
||||
mvinsnstr mvwinsnstr winstr mvinstr mvwinstr winnstr mvinnstr
|
||||
mvwinnstr wmove wsetscrreg wrefresh wnoutrefresh wredrawln wscrl
|
||||
wtouchln wsyncup wcursyncup wsyncdown wenclose wmouse_trafo wresize
|
||||
);
|
||||
|
||||
push (@EXPORT, @_OLD);
|
||||
for (@_OLD)
|
||||
{
|
||||
/^(?:mv)?(?:w)?(.*)/;
|
||||
eval "sub $_ { $1(\@_); }";
|
||||
}
|
||||
|
||||
eval <<EOS;
|
||||
sub wprintw { addstr(shift, sprintf shift, @_) }
|
||||
sub mvprintw { addstr(shift, shift, sprintf shift, @_) }
|
||||
sub mvwprintw { addstr(shift, shift, shift, sprintf shift, @_) }
|
||||
EOS
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Curses - terminal screen handling and optimization
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Curses;
|
||||
|
||||
initscr;
|
||||
...
|
||||
endwin;
|
||||
|
||||
|
||||
Curses::supports_function($function);
|
||||
Curses::supports_constant($constant);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
C<Curses> is the interface between Perl and your system's curses(3)
|
||||
library. For descriptions on the usage of a given function, variable,
|
||||
or constant, consult your system's documentation, as such information
|
||||
invariably varies (:-) between different curses(3) libraries and
|
||||
operating systems. This document describes the interface itself, and
|
||||
assumes that you already know how your system's curses(3) library
|
||||
works.
|
||||
|
||||
=head2 Unified Functions
|
||||
|
||||
Many curses(3) functions have variants starting with the prefixes
|
||||
I<w->, I<mv->, and/or I<wmv->. These variants differ only in the
|
||||
explicit addition of a window, or by the addition of two coordinates
|
||||
that are used to move the cursor first. For example, C<addch()> has
|
||||
three other variants: C<waddch()>, C<mvaddch()>, and C<mvwaddch()>.
|
||||
The variants aren't very interesting; in fact, we could roll all of
|
||||
the variants into original function by allowing a variable number
|
||||
of arguments and analyzing the argument list for which variant the
|
||||
user wanted to call.
|
||||
|
||||
Unfortunately, curses(3) predates varargs(3), so in C we were stuck
|
||||
with all the variants. However, C<Curses> is a Perl interface, so we
|
||||
are free to "unify" these variants into one function. The section
|
||||
L<"Available Functions"> below lists all curses(3) functions C<Curses>
|
||||
makes available as Perl equivalents, along with a column listing if it
|
||||
is I<unified>. If so, it takes a varying number of arguments as
|
||||
follows:
|
||||
|
||||
=over 4
|
||||
|
||||
C<function( [win], [y, x], args );>
|
||||
|
||||
I<win> is an optional window argument, defaulting to C<stdscr> if not
|
||||
specified.
|
||||
|
||||
I<y, x> is an optional coordinate pair used to move the cursor,
|
||||
defaulting to no move if not specified.
|
||||
|
||||
I<args> are the required arguments of the function. These are the
|
||||
arguments you would specify if you were just calling the base function
|
||||
and not any of the variants.
|
||||
|
||||
=back
|
||||
|
||||
This makes the variants obsolete, since their functionality has been
|
||||
merged into a single function, so C<Curses> does not define them by
|
||||
default. You can still get them if you want, by setting the
|
||||
variable C<$Curses::OldCurses> to a non-zero value before using the
|
||||
C<Curses> package. See L<"Perl 4.X C<cursperl> Compatibility">
|
||||
for an example of this.
|
||||
|
||||
=head2 Objects
|
||||
|
||||
Objects work. Example:
|
||||
|
||||
$win = new Curses;
|
||||
$win->addstr(10, 10, 'foo');
|
||||
$win->refresh;
|
||||
...
|
||||
|
||||
Any function that has been marked as I<unified> (see
|
||||
L<"Available Functions"> below and L<"Unified Functions"> above)
|
||||
can be called as a method for a Curses object.
|
||||
|
||||
Do not use C<initscr()> if using objects, as the first call to get
|
||||
a C<new Curses> will do it for you.
|
||||
|
||||
=head2 Security Concerns
|
||||
|
||||
It has always been the case with the curses functions, but please note
|
||||
that the following functions:
|
||||
|
||||
getstr() (and optional wgetstr(), mvgetstr(), and mvwgetstr())
|
||||
inchstr() (and optional winchstr(), mvinchstr(), and mvwinchstr())
|
||||
instr() (and optional winstr(), mvinstr(), and mvwinstr())
|
||||
|
||||
are subject to buffer overflow attack. This is because you pass in
|
||||
the buffer to be filled in, which has to be of finite length, but
|
||||
there is no way to stop a bad guy from typing.
|
||||
|
||||
In order to avoid this problem, use the alternate functions:
|
||||
|
||||
getnstr()
|
||||
inchnstr()
|
||||
innstr()
|
||||
|
||||
which take an extra "size of buffer" argument.
|
||||
|
||||
=head1 COMPATIBILITY
|
||||
|
||||
=head2 Perl 4.X C<cursperl> Compatibility
|
||||
|
||||
C<Curses> has been written to take advantage of the new features of
|
||||
Perl. I felt it better to provide an improved curses programming
|
||||
environment rather than to be 100% compatible. However, many old
|
||||
C<curseperl> applications will probably still work by starting the
|
||||
script with:
|
||||
|
||||
BEGIN { $Curses::OldCurses = 1; }
|
||||
use Curses;
|
||||
|
||||
Any old application that still does not work should print an
|
||||
understandable error message explaining the problem.
|
||||
|
||||
Some functions and variables are not available through C<Curses>, even with
|
||||
the C<BEGIN> line. They are listed under
|
||||
L<"curses(3) items not available through Curses">.
|
||||
|
||||
The variables C<$stdscr> and C<$curscr> are also available as
|
||||
functions C<stdscr> and C<curscr>. This is because of a Perl bug.
|
||||
See the L<BUGS> section for details.
|
||||
|
||||
=head2 Incompatibilities with previous versions of C<Curses>
|
||||
|
||||
In previous versions of this software, some Perl functions took a
|
||||
different set of parameters than their C counterparts. This is no
|
||||
longer true. You should now use C<getstr($str)> and C<getyx($y, $x)>
|
||||
instead of C<$str = getstr()> and C<($y, $x) = getyx()>.
|
||||
|
||||
=head2 Incompatibilities with other Perl programs
|
||||
|
||||
menu.pl, v3.0 and v3.1
|
||||
There were various interaction problems between these two
|
||||
releases and Curses. Please upgrade to the latest version
|
||||
(v3.3 as of 3/16/96).
|
||||
|
||||
=head1 DIAGNOSTICS
|
||||
|
||||
=over 4
|
||||
|
||||
=item * Curses function '%s' called with too %s arguments at ...
|
||||
|
||||
You have called a C<Curses> function with a wrong number of
|
||||
arguments.
|
||||
|
||||
=item * argument %d to Curses function '%s' is not a Curses %s at ...
|
||||
=item * argument is not a Curses %s at ...
|
||||
|
||||
The argument you gave to the function wasn't what it wanted.
|
||||
|
||||
This probably means that you didn't give the right arguments to a
|
||||
I<unified> function. See the DESCRIPTION section on L<Unified
|
||||
Functions> for more information.
|
||||
|
||||
=item * Curses function '%s' is not defined by your vendor at ...
|
||||
|
||||
You have a C<Curses> function in your code that your system's curses(3)
|
||||
library doesn't define.
|
||||
|
||||
=item * Curses variable '%s' is not defined by your vendor at ...
|
||||
|
||||
You have a C<Curses> variable in your code that your system's curses(3)
|
||||
library doesn't define.
|
||||
|
||||
=item * Curses constant '%s' is not defined by your vendor at ...
|
||||
|
||||
You have a C<Curses> constant in your code that your system's curses(3)
|
||||
library doesn't define.
|
||||
|
||||
=item * Curses::Vars::FETCH called with bad index at ...
|
||||
=item * Curses::Vars::STORE called with bad index at ...
|
||||
|
||||
You've been playing with the C<tie> interface to the C<Curses>
|
||||
variables. Don't do that. :-)
|
||||
|
||||
=item * Anything else
|
||||
|
||||
Check out the F<perldiag> man page to see if the error is in there.
|
||||
|
||||
=back
|
||||
|
||||
=head1 BUGS
|
||||
|
||||
If you use the variables C<$stdscr> and C<$curscr> instead of their
|
||||
functional counterparts (C<stdscr> and C<curscr>), you might run into
|
||||
a bug in Perl where the "magic" isn't called early enough. This is
|
||||
manifested by the C<Curses> package telling you C<$stdscr> isn't a
|
||||
window. One workaround is to put a line like C<$stdscr = $stdscr>
|
||||
near the front of your program.
|
||||
|
||||
Probably many more.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
William Setzer <William_Setzer@ncsu.edu>
|
||||
|
||||
=head1 SYNOPSIS OF PERL CURSES AVAILABILITY
|
||||
|
||||
=head2 Available Functions
|
||||
|
||||
Avaiable Function Unified? Available via $OldCurses[*]
|
||||
----------------- -------- ------------------------
|
||||
addch Yes waddch mvaddch mvwaddch
|
||||
echochar Yes wechochar
|
||||
addchstr Yes waddchstr mvaddchstr mvwaddchstr
|
||||
addchnstr Yes waddchnstr mvaddchnstr mvwaddchnstr
|
||||
addstr Yes waddstr mvaddstr mvwaddstr
|
||||
addnstr Yes waddnstr mvaddnstr mvwaddnstr
|
||||
attroff Yes wattroff
|
||||
attron Yes wattron
|
||||
attrset Yes wattrset
|
||||
standend Yes wstandend
|
||||
standout Yes wstandout
|
||||
attr_get Yes wattr_get
|
||||
attr_off Yes wattr_off
|
||||
attr_on Yes wattr_on
|
||||
attr_set Yes wattr_set
|
||||
chgat Yes wchgat mvchgat mvwchgat
|
||||
COLOR_PAIR No
|
||||
PAIR_NUMBER No
|
||||
beep No
|
||||
flash No
|
||||
bkgd Yes wbkgd
|
||||
bkgdset Yes wbkgdset
|
||||
getbkgd Yes
|
||||
border Yes wborder
|
||||
box Yes
|
||||
hline Yes whline mvhline mvwhline
|
||||
vline Yes wvline mvvline mvwvline
|
||||
erase Yes werase
|
||||
clear Yes wclear
|
||||
clrtobot Yes wclrtobot
|
||||
clrtoeol Yes wclrtoeol
|
||||
start_color No
|
||||
init_pair No
|
||||
init_color No
|
||||
has_colors No
|
||||
can_change_color No
|
||||
color_content No
|
||||
pair_content No
|
||||
delch Yes wdelch mvdelch mvwdelch
|
||||
deleteln Yes wdeleteln
|
||||
insdelln Yes winsdelln
|
||||
insertln Yes winsertln
|
||||
getch Yes wgetch mvgetch mvwgetch
|
||||
ungetch No
|
||||
has_key No
|
||||
KEY_F No
|
||||
getstr Yes wgetstr mvgetstr mvwgetstr
|
||||
getnstr Yes wgetnstr mvgetnstr mvwgetnstr
|
||||
getyx Yes
|
||||
getparyx Yes
|
||||
getbegyx Yes
|
||||
getmaxyx Yes
|
||||
inch Yes winch mvinch mvwinch
|
||||
inchstr Yes winchstr mvinchstr mvwinchstr
|
||||
inchnstr Yes winchnstr mvinchnstr mvwinchnstr
|
||||
initscr No
|
||||
endwin No
|
||||
isendwin No
|
||||
newterm No
|
||||
set_term No
|
||||
delscreen No
|
||||
cbreak No
|
||||
nocbreak No
|
||||
echo No
|
||||
noecho No
|
||||
halfdelay No
|
||||
intrflush Yes
|
||||
keypad Yes
|
||||
meta Yes
|
||||
nodelay Yes
|
||||
notimeout Yes
|
||||
raw No
|
||||
noraw No
|
||||
qiflush No
|
||||
noqiflush No
|
||||
timeout Yes wtimeout
|
||||
typeahead No
|
||||
insch Yes winsch mvinsch mvwinsch
|
||||
insstr Yes winsstr mvinsstr mvwinsstr
|
||||
insnstr Yes winsnstr mvinsnstr mvwinsnstr
|
||||
instr Yes winstr mvinstr mvwinstr
|
||||
innstr Yes winnstr mvinnstr mvwinnstr
|
||||
def_prog_mode No
|
||||
def_shell_mode No
|
||||
reset_prog_mode No
|
||||
reset_shell_mode No
|
||||
resetty No
|
||||
savetty No
|
||||
getsyx No
|
||||
setsyx No
|
||||
curs_set No
|
||||
napms No
|
||||
move Yes wmove
|
||||
clearok Yes
|
||||
idlok Yes
|
||||
idcok Yes
|
||||
immedok Yes
|
||||
leaveok Yes
|
||||
setscrreg Yes wsetscrreg
|
||||
scrollok Yes
|
||||
nl No
|
||||
nonl No
|
||||
overlay No
|
||||
overwrite No
|
||||
copywin No
|
||||
newpad No
|
||||
subpad No
|
||||
prefresh No
|
||||
pnoutrefresh No
|
||||
pechochar No
|
||||
refresh Yes wrefresh
|
||||
noutrefresh Yes wnoutrefresh
|
||||
doupdate No
|
||||
redrawwin Yes
|
||||
redrawln Yes wredrawln
|
||||
scr_dump No
|
||||
scr_restore No
|
||||
scr_init No
|
||||
scr_set No
|
||||
scroll Yes
|
||||
scrl Yes wscrl
|
||||
slk_init No
|
||||
slk_set No
|
||||
slk_refresh No
|
||||
slk_noutrefresh No
|
||||
slk_label No
|
||||
slk_clear No
|
||||
slk_restore No
|
||||
slk_touch No
|
||||
slk_attron No
|
||||
slk_attrset No
|
||||
slk_attr No
|
||||
slk_attroff No
|
||||
slk_color No
|
||||
baudrate No
|
||||
erasechar No
|
||||
has_ic No
|
||||
has_il No
|
||||
killchar No
|
||||
longname No
|
||||
termattrs No
|
||||
termname No
|
||||
touchwin Yes
|
||||
touchline Yes
|
||||
untouchwin Yes
|
||||
touchln Yes wtouchln
|
||||
is_linetouched Yes
|
||||
is_wintouched Yes
|
||||
unctrl No
|
||||
keyname No
|
||||
filter No
|
||||
use_env No
|
||||
putwin No
|
||||
getwin No
|
||||
delay_output No
|
||||
flushinp No
|
||||
newwin No
|
||||
delwin Yes
|
||||
mvwin Yes
|
||||
subwin Yes
|
||||
derwin Yes
|
||||
mvderwin Yes
|
||||
dupwin Yes
|
||||
syncup Yes wsyncup
|
||||
syncok Yes
|
||||
cursyncup Yes wcursyncup
|
||||
syncdown Yes wsyncdown
|
||||
getmouse No
|
||||
ungetmouse No
|
||||
mousemask No
|
||||
enclose Yes wenclose
|
||||
mouse_trafo Yes wmouse_trafo
|
||||
mouseinterval No
|
||||
BUTTON_RELEASE No
|
||||
BUTTON_PRESS No
|
||||
BUTTON_CLICK No
|
||||
BUTTON_DOUBLE_CLICK No
|
||||
BUTTON_TRIPLE_CLICK No
|
||||
BUTTON_RESERVED_EVENT No
|
||||
use_default_colors No
|
||||
assume_default_colors No
|
||||
define_key No
|
||||
keybound No
|
||||
keyok No
|
||||
resizeterm No
|
||||
resize Yes wresize
|
||||
getmaxy Yes
|
||||
getmaxx Yes
|
||||
flusok Yes
|
||||
getcap No
|
||||
touchoverlap No
|
||||
new_panel No
|
||||
bottom_panel No
|
||||
top_panel No
|
||||
show_panel No
|
||||
update_panels No
|
||||
hide_panel No
|
||||
panel_window No
|
||||
replace_panel No
|
||||
move_panel No
|
||||
panel_hidden No
|
||||
panel_above No
|
||||
panel_below No
|
||||
set_panel_userptr No
|
||||
panel_userptr No
|
||||
del_panel No
|
||||
set_menu_fore No
|
||||
menu_fore No
|
||||
set_menu_back No
|
||||
menu_back No
|
||||
set_menu_grey No
|
||||
menu_grey No
|
||||
set_menu_pad No
|
||||
menu_pad No
|
||||
pos_menu_cursor No
|
||||
menu_driver No
|
||||
set_menu_format No
|
||||
menu_format No
|
||||
set_menu_items No
|
||||
menu_items No
|
||||
item_count No
|
||||
set_menu_mark No
|
||||
menu_mark No
|
||||
new_menu No
|
||||
free_menu No
|
||||
menu_opts No
|
||||
set_menu_opts No
|
||||
menu_opts_on No
|
||||
menu_opts_off No
|
||||
set_menu_pattern No
|
||||
menu_pattern No
|
||||
post_menu No
|
||||
unpost_menu No
|
||||
set_menu_userptr No
|
||||
menu_userptr No
|
||||
set_menu_win No
|
||||
menu_win No
|
||||
set_menu_sub No
|
||||
menu_sub No
|
||||
scale_menu No
|
||||
set_current_item No
|
||||
current_item No
|
||||
set_top_row No
|
||||
top_row No
|
||||
item_index No
|
||||
item_name No
|
||||
item_description No
|
||||
new_item No
|
||||
free_item No
|
||||
set_item_opts No
|
||||
item_opts_on No
|
||||
item_opts_off No
|
||||
item_opts No
|
||||
item_userptr No
|
||||
set_item_userptr No
|
||||
set_item_value No
|
||||
item_value No
|
||||
item_visible No
|
||||
menu_request_name No
|
||||
menu_request_by_name No
|
||||
set_menu_spacing No
|
||||
menu_spacing No
|
||||
pos_form_cursor No
|
||||
data_ahead No
|
||||
data_behind No
|
||||
form_driver No
|
||||
set_form_fields No
|
||||
form_fields No
|
||||
field_count No
|
||||
move_field No
|
||||
new_form No
|
||||
free_form No
|
||||
set_new_page No
|
||||
new_page No
|
||||
set_form_opts No
|
||||
form_opts_on No
|
||||
form_opts_off No
|
||||
form_opts No
|
||||
set_current_field No
|
||||
current_field No
|
||||
set_form_page No
|
||||
form_page No
|
||||
field_index No
|
||||
post_form No
|
||||
unpost_form No
|
||||
set_form_userptr No
|
||||
form_userptr No
|
||||
set_form_win No
|
||||
form_win No
|
||||
set_form_sub No
|
||||
form_sub No
|
||||
scale_form No
|
||||
set_field_fore No
|
||||
field_fore No
|
||||
set_field_back No
|
||||
field_back No
|
||||
set_field_pad No
|
||||
field_pad No
|
||||
set_field_buffer No
|
||||
field_buffer No
|
||||
set_field_status No
|
||||
field_status No
|
||||
set_max_field No
|
||||
field_info No
|
||||
dynamic_field_info No
|
||||
set_field_just No
|
||||
field_just No
|
||||
new_field No
|
||||
dup_field No
|
||||
link_field No
|
||||
free_field No
|
||||
set_field_opts No
|
||||
field_opts_on No
|
||||
field_opts_off No
|
||||
field_opts No
|
||||
set_field_userptr No
|
||||
field_userptr No
|
||||
field_arg No
|
||||
form_request_name No
|
||||
form_request_by_name No
|
||||
|
||||
[*] To use any functions in this column, the variable
|
||||
C<$Curses::OldCurses> must be set to a non-zero value before using the
|
||||
C<Curses> package. See L<"Perl 4.X cursperl Compatibility"> for an
|
||||
example of this.
|
||||
|
||||
=head2 Available Variables
|
||||
|
||||
LINES COLS stdscr
|
||||
curscr COLORS COLOR_PAIRS
|
||||
|
||||
=head2 Available Constants
|
||||
|
||||
ERR OK ACS_BLOCK
|
||||
ACS_BOARD ACS_BTEE ACS_BULLET
|
||||
ACS_CKBOARD ACS_DARROW ACS_DEGREE
|
||||
ACS_DIAMOND ACS_HLINE ACS_LANTERN
|
||||
ACS_LARROW ACS_LLCORNER ACS_LRCORNER
|
||||
ACS_LTEE ACS_PLMINUS ACS_PLUS
|
||||
ACS_RARROW ACS_RTEE ACS_S1
|
||||
ACS_S9 ACS_TTEE ACS_UARROW
|
||||
ACS_ULCORNER ACS_URCORNER ACS_VLINE
|
||||
A_ALTCHARSET A_ATTRIBUTES A_BLINK
|
||||
A_BOLD A_CHARTEXT A_COLOR
|
||||
A_DIM A_INVIS A_NORMAL
|
||||
A_PROTECT A_REVERSE A_STANDOUT
|
||||
A_UNDERLINE COLOR_BLACK COLOR_BLUE
|
||||
COLOR_CYAN COLOR_GREEN COLOR_MAGENTA
|
||||
COLOR_RED COLOR_WHITE COLOR_YELLOW
|
||||
KEY_A1 KEY_A3 KEY_B2
|
||||
KEY_BACKSPACE KEY_BEG KEY_BREAK
|
||||
KEY_BTAB KEY_C1 KEY_C3
|
||||
KEY_CANCEL KEY_CATAB KEY_CLEAR
|
||||
KEY_CLOSE KEY_COMMAND KEY_COPY
|
||||
KEY_CREATE KEY_CTAB KEY_DC
|
||||
KEY_DL KEY_DOWN KEY_EIC
|
||||
KEY_END KEY_ENTER KEY_EOL
|
||||
KEY_EOS KEY_EVENT KEY_EXIT
|
||||
KEY_F0
|
||||
KEY_FIND KEY_HELP KEY_HOME
|
||||
KEY_IC KEY_IL KEY_LEFT
|
||||
KEY_LL KEY_MARK KEY_MAX
|
||||
KEY_MESSAGE KEY_MIN KEY_MOVE
|
||||
KEY_NEXT KEY_NPAGE KEY_OPEN
|
||||
KEY_OPTIONS KEY_PPAGE KEY_PREVIOUS
|
||||
KEY_PRINT KEY_REDO KEY_REFERENCE
|
||||
KEY_REFRESH KEY_REPLACE KEY_RESET
|
||||
KEY_RESIZE KEY_RESTART KEY_RESUME
|
||||
KEY_RIGHT
|
||||
KEY_SAVE KEY_SBEG KEY_SCANCEL
|
||||
KEY_SCOMMAND KEY_SCOPY KEY_SCREATE
|
||||
KEY_SDC KEY_SDL KEY_SELECT
|
||||
KEY_SEND KEY_SEOL KEY_SEXIT
|
||||
KEY_SF KEY_SFIND KEY_SHELP
|
||||
KEY_SHOME KEY_SIC KEY_SLEFT
|
||||
KEY_SMESSAGE KEY_SMOVE KEY_SNEXT
|
||||
KEY_SOPTIONS KEY_SPREVIOUS KEY_SPRINT
|
||||
KEY_SR KEY_SREDO KEY_SREPLACE
|
||||
KEY_SRESET KEY_SRIGHT KEY_SRSUME
|
||||
KEY_SSAVE KEY_SSUSPEND KEY_STAB
|
||||
KEY_SUNDO KEY_SUSPEND KEY_UNDO
|
||||
KEY_UP KEY_MOUSE BUTTON1_RELEASED
|
||||
BUTTON1_PRESSED BUTTON1_CLICKED BUTTON1_DOUBLE_CLICKED
|
||||
BUTTON1_TRIPLE_CLICKED BUTTON1_RESERVED_EVENT BUTTON2_RELEASED
|
||||
BUTTON2_PRESSED BUTTON2_CLICKED BUTTON2_DOUBLE_CLICKED
|
||||
BUTTON2_TRIPLE_CLICKED BUTTON2_RESERVED_EVENT BUTTON3_RELEASED
|
||||
BUTTON3_PRESSED BUTTON3_CLICKED BUTTON3_DOUBLE_CLICKED
|
||||
BUTTON3_TRIPLE_CLICKED BUTTON3_RESERVED_EVENT BUTTON4_RELEASED
|
||||
BUTTON4_PRESSED BUTTON4_CLICKED BUTTON4_DOUBLE_CLICKED
|
||||
BUTTON4_TRIPLE_CLICKED BUTTON4_RESERVED_EVENT BUTTON_CTRL
|
||||
BUTTON_SHIFT BUTTON_ALT ALL_MOUSE_EVENTS
|
||||
REPORT_MOUSE_POSITION NCURSES_MOUSE_VERSION E_OK
|
||||
E_SYSTEM_ERROR E_BAD_ARGUMENT E_POSTED
|
||||
E_CONNECTED E_BAD_STATE E_NO_ROOM
|
||||
E_NOT_POSTED E_UNKNOWN_COMMAND E_NO_MATCH
|
||||
E_NOT_SELECTABLE E_NOT_CONNECTED E_REQUEST_DENIED
|
||||
E_INVALID_FIELD E_CURRENT REQ_LEFT_ITEM
|
||||
REQ_RIGHT_ITEM REQ_UP_ITEM REQ_DOWN_ITEM
|
||||
REQ_SCR_ULINE REQ_SCR_DLINE REQ_SCR_DPAGE
|
||||
REQ_SCR_UPAGE REQ_FIRST_ITEM REQ_LAST_ITEM
|
||||
REQ_NEXT_ITEM REQ_PREV_ITEM REQ_TOGGLE_ITEM
|
||||
REQ_CLEAR_PATTERN REQ_BACK_PATTERN REQ_NEXT_MATCH
|
||||
REQ_PREV_MATCH MIN_MENU_COMMAND MAX_MENU_COMMAND
|
||||
O_ONEVALUE O_SHOWDESC O_ROWMAJOR
|
||||
O_IGNORECASE O_SHOWMATCH O_NONCYCLIC
|
||||
O_SELECTABLE REQ_NEXT_PAGE REQ_PREV_PAGE
|
||||
REQ_FIRST_PAGE REQ_LAST_PAGE REQ_NEXT_FIELD
|
||||
REQ_PREV_FIELD REQ_FIRST_FIELD REQ_LAST_FIELD
|
||||
REQ_SNEXT_FIELD REQ_SPREV_FIELD REQ_SFIRST_FIELD
|
||||
REQ_SLAST_FIELD REQ_LEFT_FIELD REQ_RIGHT_FIELD
|
||||
REQ_UP_FIELD REQ_DOWN_FIELD REQ_NEXT_CHAR
|
||||
REQ_PREV_CHAR REQ_NEXT_LINE REQ_PREV_LINE
|
||||
REQ_NEXT_WORD REQ_PREV_WORD REQ_BEG_FIELD
|
||||
REQ_END_FIELD REQ_BEG_LINE REQ_END_LINE
|
||||
REQ_LEFT_CHAR REQ_RIGHT_CHAR REQ_UP_CHAR
|
||||
REQ_DOWN_CHAR REQ_NEW_LINE REQ_INS_CHAR
|
||||
REQ_INS_LINE REQ_DEL_CHAR REQ_DEL_PREV
|
||||
REQ_DEL_LINE REQ_DEL_WORD REQ_CLR_EOL
|
||||
REQ_CLR_EOF REQ_CLR_FIELD REQ_OVL_MODE
|
||||
REQ_INS_MODE REQ_SCR_FLINE REQ_SCR_BLINE
|
||||
REQ_SCR_FPAGE REQ_SCR_BPAGE REQ_SCR_FHPAGE
|
||||
REQ_SCR_BHPAGE REQ_SCR_FCHAR REQ_SCR_BCHAR
|
||||
REQ_SCR_HFLINE REQ_SCR_HBLINE REQ_SCR_HFHALF
|
||||
REQ_SCR_HBHALF REQ_VALIDATION REQ_NEXT_CHOICE
|
||||
REQ_PREV_CHOICE MIN_FORM_COMMAND MAX_FORM_COMMAND
|
||||
NO_JUSTIFICATION JUSTIFY_LEFT JUSTIFY_CENTER
|
||||
JUSTIFY_RIGHT O_VISIBLE O_ACTIVE
|
||||
O_PUBLIC O_EDIT O_WRAP
|
||||
O_BLANK O_AUTOSKIP O_NULLOK
|
||||
O_PASSOK O_STATIC O_NL_OVERLOAD
|
||||
O_BS_OVERLOAD
|
||||
|
||||
=head2 curses(3) functions not available through C<Curses>
|
||||
|
||||
tstp _putchar fullname scanw wscanw mvscanw mvwscanw ripoffline
|
||||
setupterm setterm set_curterm del_curterm restartterm tparm tputs
|
||||
putp vidputs vidattr mvcur tigetflag tigetnum tigetstr tgetent
|
||||
tgetflag tgetnum tgetstr tgoto tputs
|
||||
|
||||
=head2 menu(3) functions not available through C<Curses>
|
||||
|
||||
set_item_init item_init set_item_term item_term set_menu_init
|
||||
menu_init set_menu_term menu_term
|
||||
|
||||
=head2 form(3) functions not available through C<Curses>
|
||||
|
||||
new_fieldtype free_fieldtype set_fieldtype_arg
|
||||
set_fieldtype_choice link_fieldtype set_form_init form_init
|
||||
set_form_term form_term set_field_init field_init set_field_term
|
||||
field_term set_field_type field_type
|
||||
@@ -1,5 +0,0 @@
|
||||
/tmp/lib/perl/5.14.2/Curses.pm
|
||||
/tmp/lib/perl/5.14.2/auto/Curses/Curses.bs
|
||||
/tmp/lib/perl/5.14.2/auto/Curses/Curses.so
|
||||
/tmp/man/man3/Curses.3
|
||||
/tmp/man/man3/Curses.3pm
|
||||
Binary file not shown.
@@ -1,39 +0,0 @@
|
||||
/tmp/man/man3/Curses::Widgets.3
|
||||
/tmp/man/man3/Curses::Widgets.3pm
|
||||
/tmp/man/man3/Curses::Widgets::ButtonSet.3
|
||||
/tmp/man/man3/Curses::Widgets::ButtonSet.3pm
|
||||
/tmp/man/man3/Curses::Widgets::Calendar.3
|
||||
/tmp/man/man3/Curses::Widgets::Calendar.3pm
|
||||
/tmp/man/man3/Curses::Widgets::ComboBox.3
|
||||
/tmp/man/man3/Curses::Widgets::ComboBox.3pm
|
||||
/tmp/man/man3/Curses::Widgets::Label.3
|
||||
/tmp/man/man3/Curses::Widgets::Label.3pm
|
||||
/tmp/man/man3/Curses::Widgets::ListBox.3
|
||||
/tmp/man/man3/Curses::Widgets::ListBox.3pm
|
||||
/tmp/man/man3/Curses::Widgets::ListBox::MultiColumn.3
|
||||
/tmp/man/man3/Curses::Widgets::ListBox::MultiColumn.3pm
|
||||
/tmp/man/man3/Curses::Widgets::Menu.3
|
||||
/tmp/man/man3/Curses::Widgets::Menu.3pm
|
||||
/tmp/man/man3/Curses::Widgets::ProgressBar.3
|
||||
/tmp/man/man3/Curses::Widgets::ProgressBar.3pm
|
||||
/tmp/man/man3/Curses::Widgets::TextField.3
|
||||
/tmp/man/man3/Curses::Widgets::TextField.3pm
|
||||
/tmp/man/man3/Curses::Widgets::TextMemo.3
|
||||
/tmp/man/man3/Curses::Widgets::TextMemo.3pm
|
||||
/tmp/man/man3/Curses::Widgets::Tutorial.3
|
||||
/tmp/man/man3/Curses::Widgets::Tutorial.3pm
|
||||
/tmp/man/man3/Curses::Widgets::Tutorial::Creation.3
|
||||
/tmp/man/man3/Curses::Widgets::Tutorial::Creation.3pm
|
||||
/tmp/share/perl/5.14.2/Curses/Widgets.pm
|
||||
/tmp/share/perl/5.14.2/Curses/Widgets/ButtonSet.pm
|
||||
/tmp/share/perl/5.14.2/Curses/Widgets/Calendar.pm
|
||||
/tmp/share/perl/5.14.2/Curses/Widgets/ComboBox.pm
|
||||
/tmp/share/perl/5.14.2/Curses/Widgets/Label.pm
|
||||
/tmp/share/perl/5.14.2/Curses/Widgets/ListBox.pm
|
||||
/tmp/share/perl/5.14.2/Curses/Widgets/ListBox/MultiColumn.pm
|
||||
/tmp/share/perl/5.14.2/Curses/Widgets/Menu.pm
|
||||
/tmp/share/perl/5.14.2/Curses/Widgets/ProgressBar.pm
|
||||
/tmp/share/perl/5.14.2/Curses/Widgets/TextField.pm
|
||||
/tmp/share/perl/5.14.2/Curses/Widgets/TextMemo.pm
|
||||
/tmp/share/perl/5.14.2/Curses/Widgets/Tutorial.pod
|
||||
/tmp/share/perl/5.14.2/Curses/Widgets/Tutorial/Creation.pod
|
||||
@@ -1,44 +0,0 @@
|
||||
=head2 Mon Aug 20 03:38:09 2012: C<Module> L<Curses|Curses>
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
C<installed into: /tmp/share/perl/5.14.2>
|
||||
|
||||
=item *
|
||||
|
||||
C<LINKTYPE: dynamic>
|
||||
|
||||
=item *
|
||||
|
||||
C<VERSION: 1.28>
|
||||
|
||||
=item *
|
||||
|
||||
C<EXE_FILES: >
|
||||
|
||||
=back
|
||||
|
||||
=head2 Mon Aug 20 03:38:12 2012: C<Module> L<Curses::Widgets|Curses::Widgets>
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
C<installed into: /tmp/share/perl/5.14.2>
|
||||
|
||||
=item *
|
||||
|
||||
C<LINKTYPE: dynamic>
|
||||
|
||||
=item *
|
||||
|
||||
C<VERSION: 1.997>
|
||||
|
||||
=item *
|
||||
|
||||
C<EXE_FILES: >
|
||||
|
||||
=back
|
||||
|
||||
@@ -1,770 +0,0 @@
|
||||
=head2 Mon Aug 13 01:19:29 2012: C<Module> L<Curses|Curses>
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
C<installed into: /tmp/lib/perl5/site_perl/5.12.3>
|
||||
|
||||
=item *
|
||||
|
||||
C<LINKTYPE: dynamic>
|
||||
|
||||
=item *
|
||||
|
||||
C<VERSION: 1.28>
|
||||
|
||||
=item *
|
||||
|
||||
C<EXE_FILES: >
|
||||
|
||||
=back
|
||||
|
||||
=head2 Mon Aug 13 01:19:30 2012: C<Module> L<Curses::Widgets|Curses::Widgets>
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
C<installed into: /tmp/lib/perl5/site_perl/5.12.3>
|
||||
|
||||
=item *
|
||||
|
||||
C<LINKTYPE: dynamic>
|
||||
|
||||
=item *
|
||||
|
||||
C<VERSION: 1.997>
|
||||
|
||||
=item *
|
||||
|
||||
C<EXE_FILES: >
|
||||
|
||||
=back
|
||||
|
||||
=head2 Sun Aug 19 02:50:07 2012: C<Module> L<Curses|Curses>
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
C<installed into: /tmp/lib/perl5/site_perl/5.12.3>
|
||||
|
||||
=item *
|
||||
|
||||
C<LINKTYPE: dynamic>
|
||||
|
||||
=item *
|
||||
|
||||
C<VERSION: 1.28>
|
||||
|
||||
=item *
|
||||
|
||||
C<EXE_FILES: >
|
||||
|
||||
=back
|
||||
|
||||
=head2 Sun Aug 19 02:55:39 2012: C<Module> L<Curses|Curses>
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
C<installed into: /tmp/lib/perl5/site_perl/5.12.3>
|
||||
|
||||
=item *
|
||||
|
||||
C<LINKTYPE: dynamic>
|
||||
|
||||
=item *
|
||||
|
||||
C<VERSION: 1.28>
|
||||
|
||||
=item *
|
||||
|
||||
C<EXE_FILES: >
|
||||
|
||||
=back
|
||||
|
||||
=head2 Sun Aug 19 02:55:43 2012: C<Module> L<Curses::Widgets|Curses::Widgets>
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
C<installed into: /tmp/lib/perl5/site_perl/5.12.3>
|
||||
|
||||
=item *
|
||||
|
||||
C<LINKTYPE: dynamic>
|
||||
|
||||
=item *
|
||||
|
||||
C<VERSION: 1.997>
|
||||
|
||||
=item *
|
||||
|
||||
C<EXE_FILES: >
|
||||
|
||||
=back
|
||||
|
||||
=head2 Sun Aug 19 02:58:20 2012: C<Module> L<Curses|Curses>
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
C<installed into: /tmp/lib/perl5/site_perl/5.12.3>
|
||||
|
||||
=item *
|
||||
|
||||
C<LINKTYPE: dynamic>
|
||||
|
||||
=item *
|
||||
|
||||
C<VERSION: 1.28>
|
||||
|
||||
=item *
|
||||
|
||||
C<EXE_FILES: >
|
||||
|
||||
=back
|
||||
|
||||
=head2 Sun Aug 19 02:58:23 2012: C<Module> L<Curses::Widgets|Curses::Widgets>
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
C<installed into: /tmp/lib/perl5/site_perl/5.12.3>
|
||||
|
||||
=item *
|
||||
|
||||
C<LINKTYPE: dynamic>
|
||||
|
||||
=item *
|
||||
|
||||
C<VERSION: 1.997>
|
||||
|
||||
=item *
|
||||
|
||||
C<EXE_FILES: >
|
||||
|
||||
=back
|
||||
|
||||
=head2 Sun Aug 19 03:25:16 2012: C<Module> L<Curses|Curses>
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
C<installed into: /tmp/lib/perl5/site_perl/5.12.3>
|
||||
|
||||
=item *
|
||||
|
||||
C<LINKTYPE: dynamic>
|
||||
|
||||
=item *
|
||||
|
||||
C<VERSION: 1.28>
|
||||
|
||||
=item *
|
||||
|
||||
C<EXE_FILES: >
|
||||
|
||||
=back
|
||||
|
||||
=head2 Sun Aug 19 03:25:18 2012: C<Module> L<Curses::Widgets|Curses::Widgets>
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
C<installed into: /tmp/lib/perl5/site_perl/5.12.3>
|
||||
|
||||
=item *
|
||||
|
||||
C<LINKTYPE: dynamic>
|
||||
|
||||
=item *
|
||||
|
||||
C<VERSION: 1.997>
|
||||
|
||||
=item *
|
||||
|
||||
C<EXE_FILES: >
|
||||
|
||||
=back
|
||||
|
||||
=head2 Sun Aug 19 04:51:18 2012: C<Module> L<Curses|Curses>
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
C<installed into: /tmp/lib/perl5/site_perl/5.12.3>
|
||||
|
||||
=item *
|
||||
|
||||
C<LINKTYPE: dynamic>
|
||||
|
||||
=item *
|
||||
|
||||
C<VERSION: 1.28>
|
||||
|
||||
=item *
|
||||
|
||||
C<EXE_FILES: >
|
||||
|
||||
=back
|
||||
|
||||
=head2 Sun Aug 19 04:51:20 2012: C<Module> L<Curses::Widgets|Curses::Widgets>
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
C<installed into: /tmp/lib/perl5/site_perl/5.12.3>
|
||||
|
||||
=item *
|
||||
|
||||
C<LINKTYPE: dynamic>
|
||||
|
||||
=item *
|
||||
|
||||
C<VERSION: 1.997>
|
||||
|
||||
=item *
|
||||
|
||||
C<EXE_FILES: >
|
||||
|
||||
=back
|
||||
|
||||
=head2 Sun Aug 19 05:16:17 2012: C<Module> L<Curses|Curses>
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
C<installed into: /tmp/lib/perl5/site_perl/5.12.3>
|
||||
|
||||
=item *
|
||||
|
||||
C<LINKTYPE: dynamic>
|
||||
|
||||
=item *
|
||||
|
||||
C<VERSION: 1.28>
|
||||
|
||||
=item *
|
||||
|
||||
C<EXE_FILES: >
|
||||
|
||||
=back
|
||||
|
||||
=head2 Sun Aug 19 05:16:19 2012: C<Module> L<Curses::Widgets|Curses::Widgets>
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
C<installed into: /tmp/lib/perl5/site_perl/5.12.3>
|
||||
|
||||
=item *
|
||||
|
||||
C<LINKTYPE: dynamic>
|
||||
|
||||
=item *
|
||||
|
||||
C<VERSION: 1.997>
|
||||
|
||||
=item *
|
||||
|
||||
C<EXE_FILES: >
|
||||
|
||||
=back
|
||||
|
||||
=head2 Sun Aug 19 06:38:27 2012: C<Module> L<Curses|Curses>
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
C<installed into: /tmp/lib/perl5/site_perl/5.12.3>
|
||||
|
||||
=item *
|
||||
|
||||
C<LINKTYPE: dynamic>
|
||||
|
||||
=item *
|
||||
|
||||
C<VERSION: 1.28>
|
||||
|
||||
=item *
|
||||
|
||||
C<EXE_FILES: >
|
||||
|
||||
=back
|
||||
|
||||
=head2 Sun Aug 19 06:38:31 2012: C<Module> L<Curses::Widgets|Curses::Widgets>
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
C<installed into: /tmp/lib/perl5/site_perl/5.12.3>
|
||||
|
||||
=item *
|
||||
|
||||
C<LINKTYPE: dynamic>
|
||||
|
||||
=item *
|
||||
|
||||
C<VERSION: 1.997>
|
||||
|
||||
=item *
|
||||
|
||||
C<EXE_FILES: >
|
||||
|
||||
=back
|
||||
|
||||
=head2 Sun Aug 19 06:58:20 2012: C<Module> L<Curses|Curses>
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
C<installed into: /tmp/lib/perl5/site_perl/5.12.3>
|
||||
|
||||
=item *
|
||||
|
||||
C<LINKTYPE: dynamic>
|
||||
|
||||
=item *
|
||||
|
||||
C<VERSION: 1.28>
|
||||
|
||||
=item *
|
||||
|
||||
C<EXE_FILES: >
|
||||
|
||||
=back
|
||||
|
||||
=head2 Sun Aug 19 06:58:22 2012: C<Module> L<Curses::Widgets|Curses::Widgets>
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
C<installed into: /tmp/lib/perl5/site_perl/5.12.3>
|
||||
|
||||
=item *
|
||||
|
||||
C<LINKTYPE: dynamic>
|
||||
|
||||
=item *
|
||||
|
||||
C<VERSION: 1.997>
|
||||
|
||||
=item *
|
||||
|
||||
C<EXE_FILES: >
|
||||
|
||||
=back
|
||||
|
||||
=head2 Sun Aug 19 07:08:30 2012: C<Module> L<Curses|Curses>
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
C<installed into: /tmp/lib/perl5/site_perl/5.12.3>
|
||||
|
||||
=item *
|
||||
|
||||
C<LINKTYPE: dynamic>
|
||||
|
||||
=item *
|
||||
|
||||
C<VERSION: 1.28>
|
||||
|
||||
=item *
|
||||
|
||||
C<EXE_FILES: >
|
||||
|
||||
=back
|
||||
|
||||
=head2 Sun Aug 19 07:08:33 2012: C<Module> L<Curses::Widgets|Curses::Widgets>
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
C<installed into: /tmp/lib/perl5/site_perl/5.12.3>
|
||||
|
||||
=item *
|
||||
|
||||
C<LINKTYPE: dynamic>
|
||||
|
||||
=item *
|
||||
|
||||
C<VERSION: 1.997>
|
||||
|
||||
=item *
|
||||
|
||||
C<EXE_FILES: >
|
||||
|
||||
=back
|
||||
|
||||
=head2 Sun Aug 19 07:09:19 2012: C<Module> L<Curses|Curses>
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
C<installed into: /tmp/lib/perl5/site_perl/5.12.3>
|
||||
|
||||
=item *
|
||||
|
||||
C<LINKTYPE: dynamic>
|
||||
|
||||
=item *
|
||||
|
||||
C<VERSION: 1.28>
|
||||
|
||||
=item *
|
||||
|
||||
C<EXE_FILES: >
|
||||
|
||||
=back
|
||||
|
||||
=head2 Sun Aug 19 07:09:21 2012: C<Module> L<Curses::Widgets|Curses::Widgets>
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
C<installed into: /tmp/lib/perl5/site_perl/5.12.3>
|
||||
|
||||
=item *
|
||||
|
||||
C<LINKTYPE: dynamic>
|
||||
|
||||
=item *
|
||||
|
||||
C<VERSION: 1.997>
|
||||
|
||||
=item *
|
||||
|
||||
C<EXE_FILES: >
|
||||
|
||||
=back
|
||||
|
||||
=head2 Sun Aug 19 07:11:43 2012: C<Module> L<Curses|Curses>
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
C<installed into: /tmp/lib/perl5/site_perl/5.12.3>
|
||||
|
||||
=item *
|
||||
|
||||
C<LINKTYPE: dynamic>
|
||||
|
||||
=item *
|
||||
|
||||
C<VERSION: 1.28>
|
||||
|
||||
=item *
|
||||
|
||||
C<EXE_FILES: >
|
||||
|
||||
=back
|
||||
|
||||
=head2 Sun Aug 19 07:11:45 2012: C<Module> L<Curses::Widgets|Curses::Widgets>
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
C<installed into: /tmp/lib/perl5/site_perl/5.12.3>
|
||||
|
||||
=item *
|
||||
|
||||
C<LINKTYPE: dynamic>
|
||||
|
||||
=item *
|
||||
|
||||
C<VERSION: 1.997>
|
||||
|
||||
=item *
|
||||
|
||||
C<EXE_FILES: >
|
||||
|
||||
=back
|
||||
|
||||
=head2 Sun Aug 19 16:38:20 2012: C<Module> L<Curses|Curses>
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
C<installed into: /tmp/lib/perl5/site_perl/5.12.3>
|
||||
|
||||
=item *
|
||||
|
||||
C<LINKTYPE: dynamic>
|
||||
|
||||
=item *
|
||||
|
||||
C<VERSION: 1.28>
|
||||
|
||||
=item *
|
||||
|
||||
C<EXE_FILES: >
|
||||
|
||||
=back
|
||||
|
||||
=head2 Sun Aug 19 16:38:22 2012: C<Module> L<Curses::Widgets|Curses::Widgets>
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
C<installed into: /tmp/lib/perl5/site_perl/5.12.3>
|
||||
|
||||
=item *
|
||||
|
||||
C<LINKTYPE: dynamic>
|
||||
|
||||
=item *
|
||||
|
||||
C<VERSION: 1.997>
|
||||
|
||||
=item *
|
||||
|
||||
C<EXE_FILES: >
|
||||
|
||||
=back
|
||||
|
||||
=head2 Sun Aug 19 21:46:05 2012: C<Module> L<Curses|Curses>
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
C<installed into: /tmp/lib/perl5/site_perl/5.12.3>
|
||||
|
||||
=item *
|
||||
|
||||
C<LINKTYPE: dynamic>
|
||||
|
||||
=item *
|
||||
|
||||
C<VERSION: 1.28>
|
||||
|
||||
=item *
|
||||
|
||||
C<EXE_FILES: >
|
||||
|
||||
=back
|
||||
|
||||
=head2 Sun Aug 19 21:46:07 2012: C<Module> L<Curses::Widgets|Curses::Widgets>
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
C<installed into: /tmp/lib/perl5/site_perl/5.12.3>
|
||||
|
||||
=item *
|
||||
|
||||
C<LINKTYPE: dynamic>
|
||||
|
||||
=item *
|
||||
|
||||
C<VERSION: 1.997>
|
||||
|
||||
=item *
|
||||
|
||||
C<EXE_FILES: >
|
||||
|
||||
=back
|
||||
|
||||
=head2 Sun Aug 19 21:54:59 2012: C<Module> L<Curses|Curses>
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
C<installed into: /tmp/lib/perl5/site_perl/5.12.3>
|
||||
|
||||
=item *
|
||||
|
||||
C<LINKTYPE: dynamic>
|
||||
|
||||
=item *
|
||||
|
||||
C<VERSION: 1.28>
|
||||
|
||||
=item *
|
||||
|
||||
C<EXE_FILES: >
|
||||
|
||||
=back
|
||||
|
||||
=head2 Sun Aug 19 21:55:01 2012: C<Module> L<Curses::Widgets|Curses::Widgets>
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
C<installed into: /tmp/lib/perl5/site_perl/5.12.3>
|
||||
|
||||
=item *
|
||||
|
||||
C<LINKTYPE: dynamic>
|
||||
|
||||
=item *
|
||||
|
||||
C<VERSION: 1.997>
|
||||
|
||||
=item *
|
||||
|
||||
C<EXE_FILES: >
|
||||
|
||||
=back
|
||||
|
||||
=head2 Mon Aug 20 00:06:37 2012: C<Module> L<Curses|Curses>
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
C<installed into: /tmp/lib/perl5/site_perl/5.12.3>
|
||||
|
||||
=item *
|
||||
|
||||
C<LINKTYPE: dynamic>
|
||||
|
||||
=item *
|
||||
|
||||
C<VERSION: 1.28>
|
||||
|
||||
=item *
|
||||
|
||||
C<EXE_FILES: >
|
||||
|
||||
=back
|
||||
|
||||
=head2 Mon Aug 20 00:06:39 2012: C<Module> L<Curses::Widgets|Curses::Widgets>
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
C<installed into: /tmp/lib/perl5/site_perl/5.12.3>
|
||||
|
||||
=item *
|
||||
|
||||
C<LINKTYPE: dynamic>
|
||||
|
||||
=item *
|
||||
|
||||
C<VERSION: 1.997>
|
||||
|
||||
=item *
|
||||
|
||||
C<EXE_FILES: >
|
||||
|
||||
=back
|
||||
|
||||
=head2 Mon Aug 20 02:39:38 2012: C<Module> L<Curses|Curses>
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
C<installed into: /tmp/lib/perl5/site_perl/5.12.3>
|
||||
|
||||
=item *
|
||||
|
||||
C<LINKTYPE: dynamic>
|
||||
|
||||
=item *
|
||||
|
||||
C<VERSION: 1.28>
|
||||
|
||||
=item *
|
||||
|
||||
C<EXE_FILES: >
|
||||
|
||||
=back
|
||||
|
||||
=head2 Mon Aug 20 02:39:41 2012: C<Module> L<Curses::Widgets|Curses::Widgets>
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
C<installed into: /tmp/lib/perl5/site_perl/5.12.3>
|
||||
|
||||
=item *
|
||||
|
||||
C<LINKTYPE: dynamic>
|
||||
|
||||
=item *
|
||||
|
||||
C<VERSION: 1.997>
|
||||
|
||||
=item *
|
||||
|
||||
C<EXE_FILES: >
|
||||
|
||||
=back
|
||||
|
||||
=head2 Tue Aug 21 05:04:07 2012: C<Module> L<Curses|Curses>
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
C<installed into: /tmp/lib/perl5/site_perl/5.12.3>
|
||||
|
||||
=item *
|
||||
|
||||
C<LINKTYPE: dynamic>
|
||||
|
||||
=item *
|
||||
|
||||
C<VERSION: 1.28>
|
||||
|
||||
=item *
|
||||
|
||||
C<EXE_FILES: >
|
||||
|
||||
=back
|
||||
|
||||
=head2 Tue Aug 21 05:04:09 2012: C<Module> L<Curses::Widgets|Curses::Widgets>
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
C<installed into: /tmp/lib/perl5/site_perl/5.12.3>
|
||||
|
||||
=item *
|
||||
|
||||
C<LINKTYPE: dynamic>
|
||||
|
||||
=item *
|
||||
|
||||
C<VERSION: 1.997>
|
||||
|
||||
=item *
|
||||
|
||||
C<EXE_FILES: >
|
||||
|
||||
=back
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
@@ -1,365 +0,0 @@
|
||||
# Curses::Widgets::ButtonSet.pm -- Button Set Widgets
|
||||
#
|
||||
# (c) 2001, Arthur Corliss <corliss@digitalmages.com>
|
||||
#
|
||||
# $Id: ButtonSet.pm,v 1.103 2002/11/03 23:31:26 corliss Exp corliss $
|
||||
#
|
||||
# This program is free software; you can redistribute it and/or modify
|
||||
# it under the terms of the GNU General Public License as published by
|
||||
# the Free Software Foundation; either version 2 of the License, or
|
||||
# any later version.
|
||||
#
|
||||
# This program is distributed in the hope that it will be useful,
|
||||
# but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
# GNU General Public License for more details.
|
||||
#
|
||||
# You should have received a copy of the GNU General Public License
|
||||
# along with this program; if not, write to the Free Software
|
||||
# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
|
||||
#
|
||||
#####################################################################
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Curses::Widgets::ButtonSet - Button Set Widgets
|
||||
|
||||
=head1 MODULE VERSION
|
||||
|
||||
$Id: ButtonSet.pm,v 1.103 2002/11/03 23:31:26 corliss Exp corliss $
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Curses::Widgets::ButtonSet;
|
||||
|
||||
$btns = Curses::Widgets::ButtonSet->({
|
||||
LENGTH => 10,
|
||||
VALUE => 0,
|
||||
INPUTFUNC => \&scankey,
|
||||
FOREGROUND => 'white',
|
||||
BACKGROUND => 'black',
|
||||
BORDER => 1,
|
||||
BORDERCOL => 'red',
|
||||
FOCUSSWITCH => "\t\n",
|
||||
HORIZONTAL => 1,
|
||||
PADDING => 1,
|
||||
X => 1,
|
||||
Y => 1,
|
||||
LABELS => [qw(OK CANCEL)],
|
||||
});
|
||||
|
||||
$btns->draw($mwh, 1);
|
||||
|
||||
See the Curses::Widgets pod for other methods.
|
||||
|
||||
=head1 REQUIREMENTS
|
||||
|
||||
=over
|
||||
|
||||
=item Curses
|
||||
|
||||
=item Curses::Widgets
|
||||
|
||||
=back
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Curses::Widgets::ButtonSet provides simplified OO access to Curses-based
|
||||
button sets. Each object maintains it's own state information.
|
||||
|
||||
=cut
|
||||
|
||||
#####################################################################
|
||||
#
|
||||
# Environment definitions
|
||||
#
|
||||
#####################################################################
|
||||
|
||||
package Curses::Widgets::ButtonSet;
|
||||
|
||||
use strict;
|
||||
use vars qw($VERSION @ISA);
|
||||
use Carp;
|
||||
use Curses;
|
||||
use Curses::Widgets;
|
||||
|
||||
($VERSION) = (q$Revision: 1.103 $ =~ /(\d+(?:\.(\d+))+)/);
|
||||
@ISA = qw(Curses::Widgets);
|
||||
|
||||
#####################################################################
|
||||
#
|
||||
# Module code follows
|
||||
#
|
||||
#####################################################################
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=head2 new (inherited from Curses::Widgets)
|
||||
|
||||
$btns = Curses::Widgets::ButtonSet->({
|
||||
LENGTH => 10,
|
||||
VALUE => 0,
|
||||
INPUTFUNC => \&scankey,
|
||||
FOREGROUND => 'white',
|
||||
BACKGROUND => 'black',
|
||||
BORDER => 1,
|
||||
BORDERCOL => 'red',
|
||||
FOCUSSWITCH => "\t\n",
|
||||
HORIZONTAL => 1,
|
||||
PADDING => 1,
|
||||
X => 1,
|
||||
Y => 1,
|
||||
LABELS => [qw(OK CANCEL)],
|
||||
});
|
||||
|
||||
The new method instantiates a new ButtonSet object. The only mandatory
|
||||
key/value pairs in the configuration hash are B<X>, B<Y>, and B<LABELS>. All
|
||||
others have the following defaults:
|
||||
|
||||
Key Default Description
|
||||
============================================================
|
||||
LENGTH 10 Number of columns for each button label
|
||||
VALUE 0 Button selected (0-based indexing)
|
||||
INPUTFUNC \&scankey Function to use to scan for keystrokes
|
||||
FOREGROUND undef Default foreground colour
|
||||
BACKGROUND undef Default blackground colour
|
||||
BORDER 1 Display border around the set
|
||||
BORDERCOL undef Foreground colour for border
|
||||
FOCUSSWITCH "\t\n" Characters which signify end of input
|
||||
HORIZONTAL 1 Horizontal orientation for set
|
||||
PADDING 1 Number of spaces between buttons
|
||||
|
||||
The last option, B<PADDING>, is only applicable to horizontal sets without
|
||||
borders.
|
||||
|
||||
=cut
|
||||
|
||||
sub _conf {
|
||||
# Validates and initialises the new TextField object.
|
||||
#
|
||||
# Usage: $self->_conf(%conf);
|
||||
|
||||
my $self = shift;
|
||||
my %conf = (
|
||||
LENGTH => 10,
|
||||
VALUE => 0,
|
||||
INPUTFUNC => \&scankey,
|
||||
BORDER => 1,
|
||||
FOCUSSWITCH => "\t\n",
|
||||
HORIZONTAL => 1,
|
||||
PADDING => 1,
|
||||
@_
|
||||
);
|
||||
my @required = qw(X Y LABELS);
|
||||
my $err = 0;
|
||||
my ($cols, $lines, $i);
|
||||
|
||||
# Check for required arguments
|
||||
foreach (@required) { $err = 1 unless exists $conf{$_} };
|
||||
|
||||
# Calculate the derived window dimensions
|
||||
$conf{LENGTH} += 2 unless $conf{BORDER};
|
||||
if ($conf{HORIZONTAL}) {
|
||||
$cols = $conf{LENGTH} * @{$conf{LABELS}};
|
||||
$i = 0;
|
||||
$i += $conf{PADDING} if ($conf{PADDING} && ! $conf{BORDER});
|
||||
$i++ if $conf{BORDER};
|
||||
$cols += (@{$conf{LABELS}} - 1) * $i;
|
||||
$lines = 1;
|
||||
} else {
|
||||
$cols = $conf{LENGTH};
|
||||
$lines = @{$conf{LABELS}};
|
||||
$lines += $conf{BORDER} ? @{$conf{LABELS}} - 1 : (@{$conf{LABELS}} - 1) *
|
||||
$conf{PADDING};
|
||||
}
|
||||
$conf{COLUMNS} = $cols;
|
||||
$conf{LINES} = $lines;
|
||||
|
||||
# Make sure the parent class didn't generate any errors
|
||||
$err = 1 unless $self->SUPER::_conf(%conf);
|
||||
|
||||
return $err == 0 ? 1 : 0;
|
||||
}
|
||||
|
||||
=head2 draw
|
||||
|
||||
$btns->draw($mwh, 1);
|
||||
|
||||
The draw method renders the button set in its current state. This
|
||||
requires a valid handle to a curses window in which it will render
|
||||
itself. The optional second argument, if true, will cause the set's
|
||||
selected button to be rendered in standout mode (inverse video).
|
||||
|
||||
=cut
|
||||
|
||||
sub _border {
|
||||
my $self = shift;
|
||||
my $dwh = shift;
|
||||
my $conf = $self->{CONF};
|
||||
my ($y, $x, $hz, $value, $length, $cols, $lines) =
|
||||
@$conf{qw(Y X HORIZONTAL VALUE LENGTH COLUMNS LINES)};
|
||||
my @labels = @{ $$conf{LABELS} };
|
||||
my $border = $$conf{BORDER};
|
||||
my ($i, $j, $l);
|
||||
|
||||
# Draw the border
|
||||
if ($border) {
|
||||
if (defined $$conf{BORDERCOL}) {
|
||||
$dwh->attrset(COLOR_PAIR(
|
||||
select_colour(@$conf{qw(BORDERCOL BACKGROUND)})));
|
||||
$dwh->attron(A_BOLD) if $$conf{BORDERCOL} eq 'yellow';
|
||||
}
|
||||
$dwh->box(ACS_VLINE, ACS_HLINE);
|
||||
if ($hz) {
|
||||
$i = $length + 1;
|
||||
until ($i > $cols) {
|
||||
$dwh->addch(0, $i, ACS_TTEE);
|
||||
$dwh->addch(1, $i, ACS_VLINE);
|
||||
$dwh->addch(2, $i, ACS_BTEE);
|
||||
$i += ($length + 1);
|
||||
}
|
||||
} else {
|
||||
$i = 2;
|
||||
until ($i > $lines) {
|
||||
$dwh->addch($i, 0, ACS_LTEE);
|
||||
for ($j = 1; $j <= $length; $j++) {
|
||||
$dwh->addch($i, $j, ACS_HLINE) };
|
||||
$dwh->addch($i, $length + 1, ACS_RTEE);
|
||||
$i += 2;
|
||||
}
|
||||
}
|
||||
$dwh->attroff(A_BOLD);
|
||||
}
|
||||
|
||||
$self->_restore($dwh);
|
||||
}
|
||||
|
||||
sub _caption {
|
||||
# We won't be needing this method, and I don't want anyone using it by
|
||||
# accident.
|
||||
}
|
||||
|
||||
sub _content {
|
||||
my $self = shift;
|
||||
my $dwh = shift;
|
||||
my $conf = $self->{CONF};
|
||||
my ($hz, $value, $length) = @$conf{qw(HORIZONTAL VALUE LENGTH)};
|
||||
my @labels = @{$$conf{LABELS}};
|
||||
my ($i, $j, $l, $offset);
|
||||
my $z = 0;
|
||||
|
||||
# Enforce a sane cursor position
|
||||
if ($$conf{VALUE} > $#labels) {
|
||||
$$conf{VALUE} = $#labels;
|
||||
} elsif ($$conf{VALUE} < 0) {
|
||||
$$conf{VALUE} = 0;
|
||||
}
|
||||
|
||||
# Calculate the cell offset
|
||||
$offset = $$conf{BORDER} ? 1 : ($$conf{PADDING} ? $$conf{PADDING} : 0);
|
||||
|
||||
# Draw the labels
|
||||
foreach (@labels) {
|
||||
$_ = substr($_, 0, $length);
|
||||
if (length($_) < $length - 1) {
|
||||
$i = int(($length - length($_)) / 2);
|
||||
unless ($$conf{BORDER}) {
|
||||
$i--;
|
||||
$_ = ' ' x $i . $_ . ' ' x ($length - (length($_) + $i + 2));
|
||||
$_ = "<$_>";
|
||||
$i = 0;
|
||||
}
|
||||
}
|
||||
if ($hz) {
|
||||
$dwh->addstr(0, $z + $i, $_);
|
||||
$z += $offset + $length;
|
||||
} else {
|
||||
$dwh->addstr($z, $i, $_);
|
||||
$z += $offset + 1;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub _cursor {
|
||||
my $self = shift;
|
||||
my $dwh = shift;
|
||||
my $conf = $self->{CONF};
|
||||
my $label = $$conf{LABELS}->[$$conf{VALUE}];
|
||||
my ($length, $hz) = @$conf{qw(LENGTH HORIZONTAL)};
|
||||
my ($y, $x) = (0, 0);
|
||||
my ($offset);
|
||||
|
||||
# Calculate the cell offset
|
||||
$offset = $$conf{BORDER} ? 1 : ($$conf{PADDING} ? $$conf{PADDING} : 0);
|
||||
|
||||
# Set the coordinates
|
||||
if ($hz) {
|
||||
$offset = $$conf{VALUE} ? $$conf{VALUE} * $length + $$conf{VALUE} *
|
||||
$offset : 0;
|
||||
$x = $offset;
|
||||
} else {
|
||||
$offset = $$conf{VALUE} ? $$conf{VALUE} + $$conf{VALUE} * $offset : 0;
|
||||
$y = $offset;
|
||||
}
|
||||
# Display the cursor
|
||||
$dwh->chgat($y, $x, $length, A_STANDOUT,
|
||||
select_colour(@$conf{qw(FOREGROUND BACKGROUND)}), 0);
|
||||
|
||||
# Restore the default settings
|
||||
$self->_restore($dwh);
|
||||
}
|
||||
|
||||
sub input_key {
|
||||
# Process input a keystroke at a time.
|
||||
#
|
||||
# Usage: $self->input_key($key);
|
||||
|
||||
my $self = shift;
|
||||
my $in = shift;
|
||||
my $conf = $self->{CONF};
|
||||
my ($value, $hz) = @$conf{qw(VALUE HORIZONTAL)};
|
||||
my $num = scalar @{ $$conf{LABELS} };
|
||||
|
||||
if ($hz) {
|
||||
if ($in eq KEY_RIGHT) {
|
||||
++$value;
|
||||
$value = 0 if $value == $num;
|
||||
} elsif ($in eq KEY_LEFT) {
|
||||
--$value;
|
||||
$value = ($num - 1) if $value == -1;
|
||||
} else {
|
||||
beep;
|
||||
}
|
||||
} else {
|
||||
if ($in eq KEY_UP) {
|
||||
--$value;
|
||||
$value = ($num - 1) if $value == -1;
|
||||
} elsif ($in eq KEY_DOWN) {
|
||||
++$value;
|
||||
$value = 0 if $value == $num;
|
||||
} else {
|
||||
beep;
|
||||
}
|
||||
}
|
||||
|
||||
$$conf{VALUE} = $value;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=head1 HISTORY
|
||||
|
||||
=over
|
||||
|
||||
=item 1999/12/29 -- Original button set widget in functional model
|
||||
|
||||
=item 2001/07/05 -- First incarnation in OO architecture
|
||||
|
||||
=back
|
||||
|
||||
=head1 AUTHOR/COPYRIGHT
|
||||
|
||||
(c) 2001 Arthur Corliss (corliss@digitalmages.com)
|
||||
|
||||
=cut
|
||||
|
||||
@@ -1,477 +0,0 @@
|
||||
# Curses::Widgets::Calendar.pm -- Button Set Widgets
|
||||
#
|
||||
# (c) 2001, Arthur Corliss <corliss@digitalmages.com>
|
||||
#
|
||||
# $Id: Calendar.pm,v 1.103 2002/11/03 23:33:05 corliss Exp corliss $
|
||||
#
|
||||
# This program is free software; you can redistribute it and/or modify
|
||||
# it under the terms of the GNU General Public License as published by
|
||||
# the Free Software Foundation; either version 2 of the License, or
|
||||
# any later version.
|
||||
#
|
||||
# This program is distributed in the hope that it will be useful,
|
||||
# but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
# GNU General Public License for more details.
|
||||
#
|
||||
# You should have received a copy of the GNU General Public License
|
||||
# along with this program; if not, write to the Free Software
|
||||
# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
|
||||
#
|
||||
#####################################################################
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Curses::Widgets::Calendar - Calendar Widgets
|
||||
|
||||
=head1 MODULE VERSION
|
||||
|
||||
$Id: Calendar.pm,v 1.103 2002/11/03 23:33:05 corliss Exp corliss $
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Curses::Widgets::Calendar;
|
||||
|
||||
$cal = Curses::Widgets::Calendar->({
|
||||
CAPTION => 'Appointments',
|
||||
CAPTIONCOL => 'yellow',
|
||||
INPUTFUNC => \&scankey,
|
||||
FOREGROUND => undef,
|
||||
BACKGROUND => 'black',
|
||||
BORDER => 1,
|
||||
BORDERCOL => 'red',
|
||||
FOCUSSWITCH => "\t",
|
||||
X => 1,
|
||||
Y => 1,
|
||||
HIGHLIGHT => [12, 17, 25],
|
||||
HIGHLIGHTCOL=> 'green',
|
||||
MONTH => '11/2001',
|
||||
ONYEAR => \&yearly,
|
||||
ONMONTH => \&monthly,
|
||||
ONDAY => \&daily,
|
||||
});
|
||||
|
||||
$cal->draw($mwh, 1);
|
||||
|
||||
See the Curses::Widgets pod for other methods.
|
||||
|
||||
=head1 REQUIREMENTS
|
||||
|
||||
=over
|
||||
|
||||
=item Curses
|
||||
|
||||
=item Curses::Widgets
|
||||
|
||||
=back
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Curses::Widgets::Calendar provides simplified OO access to Curses-based
|
||||
calendars. Each object maintains it's own state information.
|
||||
|
||||
=cut
|
||||
|
||||
#####################################################################
|
||||
#
|
||||
# Environment definitions
|
||||
#
|
||||
#####################################################################
|
||||
|
||||
package Curses::Widgets::Calendar;
|
||||
|
||||
use strict;
|
||||
use vars qw($VERSION @ISA);
|
||||
use Carp;
|
||||
use Curses;
|
||||
use Curses::Widgets;
|
||||
|
||||
($VERSION) = (q$Revision: 1.103 $ =~ /(\d+(?:\.(\d+))+)/);
|
||||
@ISA = qw(Curses::Widgets);
|
||||
|
||||
#####################################################################
|
||||
#
|
||||
# Module code follows
|
||||
#
|
||||
#####################################################################
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=head2 new (inherited from Curses::Widgets)
|
||||
|
||||
$cal = Curses::Widgets::Calendar->({
|
||||
CAPTION => 'Appointments',
|
||||
CAPTIONCOL => 'yellow',
|
||||
INPUTFUNC => \&scankey,
|
||||
FOREGROUND => undef,
|
||||
BACKGROUND => 'black',
|
||||
BORDER => 1,
|
||||
BORDERCOL => 'red',
|
||||
FOCUSSWITCH => "\t",
|
||||
X => 1,
|
||||
Y => 1,
|
||||
HIGHLIGHT => [12, 17, 25],
|
||||
HIGHLIGHTCOL=> 'green',
|
||||
MONTH => '11/2001',
|
||||
ONYEAR => \&yearly,
|
||||
ONMONTH => \&monthly,
|
||||
ONDAY => \&daily,
|
||||
});
|
||||
|
||||
The new method instantiates a new Calendar object. The only mandatory
|
||||
key/value pairs in the configuration hash are B<X> and B<Y>. All
|
||||
others have the following defaults:
|
||||
|
||||
Key Default Description
|
||||
============================================================
|
||||
CAPTION undef Caption superimposed on border
|
||||
CAPTIONCOL undef Foreground colour for caption text
|
||||
INPUTFUNC \&scankey Function to use to scan for keystrokes
|
||||
FOREGROUND undef Default foreground colour
|
||||
BACKGROUND undef Default background colour
|
||||
BORDER 1 Display a border around the field
|
||||
BORDERCOL undef Foreground colour for border
|
||||
FOCUSSWITCH "\t" Characters which signify end of input
|
||||
HIGHLIGHT [] Days to highlight
|
||||
HIGHLIGHTCOL undef Default highlighted data colour
|
||||
HEADERCOL undef Default calendar header colour
|
||||
MONTH (current) Month to display
|
||||
VALUE 1 Day of the month where the cursor is
|
||||
ONYEAR undef Callback function triggered by year
|
||||
ONMONTH undef Callback function triggered by month
|
||||
ONDAY undef Callback function triggered by day
|
||||
|
||||
Each of the ON* callback functions expect a subroutine reference that excepts
|
||||
one argument: a handle to the calendar object itself. If more than one
|
||||
trigger is called, it will be called in the order of day, month, and then
|
||||
year.
|
||||
|
||||
=cut
|
||||
|
||||
sub _conf {
|
||||
# Validates and initialises the new TextField object.
|
||||
#
|
||||
# Usage: $self->_conf(%conf);
|
||||
|
||||
my $self = shift;
|
||||
my %conf = (
|
||||
INPUTFUNC => \&scankey,
|
||||
BORDER => 1,
|
||||
FOCUSSWITCH => "\t",
|
||||
HIGHLIGHT => [],
|
||||
VALUE => 1,
|
||||
MONTH => join('/',
|
||||
(localtime)[4] + 1, (localtime)[5] + 1900),
|
||||
LINES => 8,
|
||||
COLUMNS => 20,
|
||||
@_
|
||||
);
|
||||
my @required = qw(X Y);
|
||||
my $err = 0;
|
||||
|
||||
# Check for required arguments
|
||||
foreach (@required) { $err = 1 unless exists $conf{$_} };
|
||||
|
||||
# Lowercase all colours
|
||||
foreach (qw(HIGHLIGHTCOL HEADERCOL)) {
|
||||
$conf{$_} = lc($conf{$_}) if exists $conf{$_} };
|
||||
|
||||
$err = 1 unless $self->SUPER::_conf(%conf);
|
||||
|
||||
return $err == 0 ? 1 : 0;
|
||||
}
|
||||
|
||||
=head2 draw
|
||||
|
||||
$cal->draw($mwh, 1);
|
||||
|
||||
The draw method renders the calendar in its current state. This
|
||||
requires a valid handle to a curses window in which it will render
|
||||
itself. The optional second argument, if true, will cause the calendar's
|
||||
selected day to be rendered in standout mode (inverse video).
|
||||
|
||||
=cut
|
||||
|
||||
sub _content {
|
||||
my $self = shift;
|
||||
my $dwh = shift;
|
||||
my $conf = $self->{CONF};
|
||||
my $pos = $$conf{VALUE};
|
||||
my @date = split(/\//, $$conf{MONTH});
|
||||
my @highlight = @{ $$conf{HIGHLIGHT} };
|
||||
my ($i, @cal);
|
||||
|
||||
# Get the calendar lines and print them
|
||||
@cal = _gen_cal(@date[1,0]);
|
||||
$i = 0;
|
||||
foreach (@cal) {
|
||||
|
||||
# Set the header colour (if defined)
|
||||
unless ($i > 1 || ! exists $$conf{HEADERCOL}) {
|
||||
$dwh->attrset(COLOR_PAIR(
|
||||
select_colour(@$conf{qw(HEADERCOL BACKGROUND)})));
|
||||
$dwh->attron(A_BOLD) if $$conf{HEADERCOL} eq 'yellow';
|
||||
}
|
||||
|
||||
# Save the cursor position if it's on this line
|
||||
$self->{COORD} = [$i, length($1)] if $cal[$i] =~ /^(.*\b)$pos\b/;
|
||||
|
||||
# Print the calendar line
|
||||
$dwh->addstr($i, 0, $cal[$i]);
|
||||
|
||||
# Highlight the necessary dates
|
||||
if (exists $$conf{HIGHLIGHTCOL}) {
|
||||
until ($#highlight == -1 || $cal[$i] !~ /^(.*\b)$highlight[0]\b/) {
|
||||
$dwh->chgat($i, length($1), length($highlight[0]), 0,
|
||||
select_colour(@$conf{qw(HIGHLIGHTCOL BACKGROUND)}), 0);
|
||||
shift @highlight;
|
||||
}
|
||||
}
|
||||
|
||||
# Restore the default settings (if adjusted for headers or hightlights)
|
||||
$self->_restore($dwh);
|
||||
|
||||
++$i;
|
||||
}
|
||||
}
|
||||
|
||||
sub _cursor {
|
||||
my $self = shift;
|
||||
my $dwh = shift;
|
||||
my $conf = $self->{CONF};
|
||||
my $pos = $$conf{VALUE};
|
||||
my @highlight = @{$$conf{HIGHLIGHT}};
|
||||
my ($y, $x) = @{$self->{COORD}};
|
||||
my $fg;
|
||||
|
||||
# Determine the foreground colour
|
||||
if (exists $$conf{HIGHLIGHTCOL}) {
|
||||
$fg = (grep /^$pos$/, @highlight) ? $$conf{HIGHLIGHTCOL} :
|
||||
$$conf{FOREGROUND};
|
||||
} else {
|
||||
$fg = $$conf{FOREGROUND};
|
||||
}
|
||||
|
||||
# Display the cursor
|
||||
$dwh->chgat($y, $x, length($pos), A_STANDOUT,
|
||||
select_colour($fg, $$conf{BACKGROUND}), 0);
|
||||
|
||||
# Restore the default settings
|
||||
$self->_restore($dwh);
|
||||
}
|
||||
|
||||
sub _gen_cal {
|
||||
# Generates the calendar month output, and stuffs it into a
|
||||
# LOL, which is returned by the method.
|
||||
#
|
||||
# Modified from code provided courtesy of Michael E. Schechter,
|
||||
# <mschechter@earthlink.net>
|
||||
#
|
||||
# Usage: @lines = $self->_gen_cal($year, $month);
|
||||
|
||||
my @date = @_;
|
||||
my (@lines, @tmp, $i, @out);
|
||||
|
||||
# All of these local subroutines are essentially code to replicate
|
||||
# the UNIX 'cal' command. My code parses the output to create the
|
||||
# LOL.
|
||||
|
||||
local *print_month = sub {
|
||||
my ($year, $month) = @_;
|
||||
my @month = make_month_array($year, $month);
|
||||
my @months = ('', qw(January February March April May June
|
||||
July August September October November December));
|
||||
my $days = 'Su Mo Tu We Th Fr Sa';
|
||||
my ($title, $diff, $left, $day, $end, $x, $out);
|
||||
|
||||
$title = "$months[$month] $year";
|
||||
$diff = 20 - length($title);
|
||||
$left = $diff - int($diff / 2);
|
||||
$title = ' ' x $left."$title";
|
||||
$out = "$title\n$days";
|
||||
$end = 0;
|
||||
for ($x = 0; $x < scalar @month; $x++) {
|
||||
$out .= "\n" if $end == 0;
|
||||
$out .= "$month[$x]";
|
||||
$end++;
|
||||
if ($end > 6) {
|
||||
$end = 0;
|
||||
}
|
||||
}
|
||||
$out .= "\n";
|
||||
return $out;
|
||||
};
|
||||
|
||||
local *make_month_array = sub {
|
||||
my ($year, $month) = @_;
|
||||
my $firstweekday = day_of_week_num($year, $month, 1);
|
||||
my (@month_array, $numdays, $remain, $x, $y);
|
||||
|
||||
$numdays = days_in_month($year, $month);
|
||||
$y = 1;
|
||||
for ($x = 0; $x < $firstweekday; $x++ ) { $month_array[$x] = ' ' };
|
||||
if (! ($year == 1752 && $month == 9)) {
|
||||
for ($x = 1; $x <= $numdays; $x++, $y++) {
|
||||
$month_array[$x + $firstweekday - 1] = sprintf( "%2d ", $y);
|
||||
}
|
||||
} else {
|
||||
for ($x = 1; $x <= $numdays; $x++, $y++) {
|
||||
$month_array[$x + $firstweekday - 1] = sprintf( "%2d ", $y);
|
||||
if ($y == 2) {
|
||||
$y = 13;
|
||||
}
|
||||
}
|
||||
}
|
||||
return @month_array;
|
||||
};
|
||||
|
||||
local *day_of_week_num = sub {
|
||||
my ($year, $month, $day) = @_;
|
||||
my ($a, $y, $m, $d);
|
||||
|
||||
$a = int( (14 - $month)/12 );
|
||||
$y = $year - $a;
|
||||
$m = $month + (12 * $a) - 2;
|
||||
if (is_julian($year, $month)) {
|
||||
$d = (5 + $day + $y + int($y/4) + int(31*$m/12)) % 7;
|
||||
} else {
|
||||
$d = ($day + $y + int($y/4) - int($y/100) + int($y/400) +
|
||||
int(31*$m/12)) % 7;
|
||||
}
|
||||
return $d;
|
||||
};
|
||||
|
||||
local *days_in_month = sub {
|
||||
my ($year, $month) = @_;
|
||||
my @month_days = ( 0,31,28,31,30,31,30,31,31,30,31,30,31 );
|
||||
|
||||
if ($month == 2 && is_leap_year($year)) {
|
||||
$month_days[2] = 29;
|
||||
} elsif ($year == 1752 && $month == 9) {
|
||||
$month_days[9] = 19;
|
||||
}
|
||||
return $month_days[$month];
|
||||
};
|
||||
|
||||
local *is_julian = sub {
|
||||
my ($year, $month) = @_;
|
||||
my $bool = 0;
|
||||
|
||||
$bool = 1 if ($year < 1752 || ($year == 1752 && $month <= 9));
|
||||
return $bool;
|
||||
};
|
||||
|
||||
local *is_leap_year = sub {
|
||||
my $year = shift;
|
||||
my $bool = 0;
|
||||
|
||||
if (is_julian($year, 1)) {
|
||||
$bool = 1 if ($year % 4 == 0);
|
||||
} else {
|
||||
$bool = 1 if (($year % 4 == 0 && $year % 100 != 0) ||
|
||||
$year % 400 == 0);
|
||||
}
|
||||
return $bool;
|
||||
};
|
||||
|
||||
@out = split(/\n/, print_month(@date));
|
||||
|
||||
return @out;
|
||||
|
||||
}
|
||||
|
||||
sub input_key {
|
||||
# Process input a keystroke at a time.
|
||||
#
|
||||
# Usage: $self->input_key($key);
|
||||
|
||||
my $self = shift;
|
||||
my $in = shift;
|
||||
my $conf = $self->{CONF};
|
||||
my $pos = $$conf{VALUE};
|
||||
my @date = split(/\//, $$conf{MONTH});
|
||||
my @days = (0, 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);
|
||||
my ($y, $trigger);
|
||||
|
||||
# Adjust for leap years, if necessary
|
||||
$days[2] += 1 if (($date[1] % 4 == 0 && $date[1] % 100 != 0) ||
|
||||
$date[1] % 400 == 0);
|
||||
|
||||
$trigger = 'd';
|
||||
|
||||
# Navigate according to key press
|
||||
if ($in eq KEY_LEFT) {
|
||||
$pos -= 1;
|
||||
} elsif ($in eq KEY_RIGHT) {
|
||||
$pos += 1;
|
||||
} elsif ($in eq KEY_UP) {
|
||||
$pos -= 7;
|
||||
} elsif ($in eq KEY_DOWN) {
|
||||
$pos += 7;
|
||||
} elsif ($in eq KEY_NPAGE) {
|
||||
$pos += 28;
|
||||
$pos += 7 if $pos <= $days[$date[0]];
|
||||
} elsif ($in eq KEY_PPAGE) {
|
||||
$pos -= 28;
|
||||
$pos -= 7 if $pos > 0;
|
||||
} elsif ($in eq KEY_HOME || $in eq KEY_FIND) {
|
||||
($pos, @date) = (localtime)[3..5];
|
||||
$date[0] += 1;
|
||||
$date[1] += 1900;
|
||||
|
||||
# Key press wasn't a navigation key, so reset trigger
|
||||
} else {
|
||||
$trigger = '';
|
||||
}
|
||||
|
||||
# Adjust the dates as necessary according to the cursor movement
|
||||
if ($pos < 1) {
|
||||
--$date[0];
|
||||
if ($date[0] < 1) {
|
||||
--$date[1];
|
||||
$date[0] = 12;
|
||||
}
|
||||
$pos += $days[$date[0]];
|
||||
} elsif ($pos > $days[$date[0]]) {
|
||||
++$date[0];
|
||||
if ($date[0] > 12) {
|
||||
++$date[1];
|
||||
$date[0] = 1;
|
||||
}
|
||||
$pos -= $days[$date[0] > 1 ? $date[0] - 1 : 12];
|
||||
}
|
||||
|
||||
# Compare old info to the new and set trigger flags
|
||||
$trigger .= 'm' if $date[0] != ($$conf{MONTH} =~ /^(\d+)/)[0];
|
||||
$trigger .= 'y' if $date[1] != ($$conf{MONTH} =~ /(\d+)$/)[0];
|
||||
|
||||
# Save the adjusted dates
|
||||
@$conf{qw(VALUE MONTH)} = ($pos, join('/', @date));
|
||||
|
||||
# Call the triggers
|
||||
&{$$conf{ONDAY}}($self) if (defined $$conf{ONDAY} &&
|
||||
$trigger =~ /d/);
|
||||
&{$$conf{ONMONTH}}($self) if (defined $$conf{ONMONTH} &&
|
||||
$trigger =~ /m/);
|
||||
&{$$conf{ONYEAR}}($self) if (defined $$conf{ONYEAR} &&
|
||||
$trigger =~ /y/);
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=head1 HISTORY
|
||||
|
||||
=over
|
||||
|
||||
=item 1999/12/29 -- Original calendar widget in functional model
|
||||
|
||||
=item 2001/07/05 -- First incarnation in OO architecture
|
||||
|
||||
=back
|
||||
|
||||
=head1 AUTHOR/COPYRIGHT
|
||||
|
||||
(c) 2001 Arthur Corliss (corliss@digitalmages.com)
|
||||
|
||||
=cut
|
||||
|
||||
@@ -1,373 +0,0 @@
|
||||
# Curses::Widgets::ComboBox.pm -- Text Field Widgets
|
||||
#
|
||||
# (c) 2001, Arthur Corliss <corliss@digitalmages.com>
|
||||
#
|
||||
# $Id: ComboBox.pm,v 1.103 2002/11/03 23:34:50 corliss Exp corliss $
|
||||
#
|
||||
# This program is free software; you can redistribute it and/or modify
|
||||
# it under the terms of the GNU General Public License as published by
|
||||
# the Free Software Foundation; either version 2 of the License, or
|
||||
# any later version.
|
||||
#
|
||||
# This program is distributed in the hope that it will be useful,
|
||||
# but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
# GNU General Public License for more details.
|
||||
#
|
||||
# You should have received a copy of the GNU General Public License
|
||||
# along with this program; if not, write to the Free Software
|
||||
# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
|
||||
#
|
||||
#####################################################################
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Curses::Widgets::ComboBox - Combo-Box Widgets
|
||||
|
||||
=head1 MODULE VERSION
|
||||
|
||||
$Id: ComboBox.pm,v 1.103 2002/11/03 23:34:50 corliss Exp corliss $
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Curses::Widgets::ComboBox;
|
||||
|
||||
$cb = Curses::Widgets::ComboBox->new({
|
||||
CAPTION => 'Select',
|
||||
CAPTIONCOL => 'yellow',
|
||||
COLUMNS => 10,
|
||||
MAXLENGTH => 255,
|
||||
MASK => undef,
|
||||
VALUE => '',
|
||||
INPUTFUNC => \&scankey,
|
||||
FOREGROUND => 'white',
|
||||
BACKGROUND => 'black',
|
||||
BORDER => 1,
|
||||
BORDERCOL => 'red',
|
||||
FOCUSSWITCH => "\t\n",
|
||||
CURSORPOS => 0,
|
||||
TEXTSTART => 0,
|
||||
PASSWORD => 0,
|
||||
X => 1,
|
||||
Y => 1,
|
||||
READONLY => 0,
|
||||
LISTITEMS => [qw(foo bar wop)],
|
||||
});
|
||||
|
||||
$cb->draw($mwh, 1);
|
||||
|
||||
See the Curses::Widgets pod for other methods.
|
||||
|
||||
=head1 REQUIREMENTS
|
||||
|
||||
=over
|
||||
|
||||
=item Curses
|
||||
|
||||
=item Curses::Widgets
|
||||
|
||||
=item Curses::Widgets::TextField
|
||||
|
||||
=item Curses::Widgets::ListBox
|
||||
|
||||
=back
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Curses::Widgets::ComboBox provides simplified OO access to Curses-based
|
||||
combo-boxes. This widget essentially acts as text field widget, but upon a
|
||||
KEY_DOWN or "\n", a drop-down list is displayed, and the item selected is put
|
||||
in the text field as the value.
|
||||
|
||||
=cut
|
||||
|
||||
#####################################################################
|
||||
#
|
||||
# Environment definitions
|
||||
#
|
||||
#####################################################################
|
||||
|
||||
package Curses::Widgets::ComboBox;
|
||||
|
||||
use strict;
|
||||
use vars qw($VERSION @ISA);
|
||||
use Carp;
|
||||
use Curses;
|
||||
use Curses::Widgets;
|
||||
use Curses::Widgets::TextField;
|
||||
use Curses::Widgets::ListBox;
|
||||
|
||||
($VERSION) = (q$Revision: 1.103 $ =~ /(\d+(?:\.(\d+))+)/);
|
||||
@ISA = qw(Curses::Widgets::TextField Curses::Widgets);
|
||||
|
||||
#####################################################################
|
||||
#
|
||||
# Module code follows
|
||||
#
|
||||
#####################################################################
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=head2 new (inherited from Curses::Widgets)
|
||||
|
||||
$cb = Curses::Widgets::ComboBox->new({
|
||||
CAPTION => 'Select',
|
||||
CAPTIONCOL => 'yellow',
|
||||
COLUMNS => 10,
|
||||
MAXLENGTH => 255,
|
||||
MASK => undef,
|
||||
VALUE => '',
|
||||
INPUTFUNC => \&scankey,
|
||||
FOREGROUND => 'white',
|
||||
BACKGROUND => 'black',
|
||||
BORDER => 1,
|
||||
BORDERCOL => 'red',
|
||||
FOCUSSWITCH => "\t\n",
|
||||
CURSORPOS => 0,
|
||||
TEXTSTART => 0,
|
||||
PASSWORD => 0,
|
||||
X => 1,
|
||||
Y => 1,
|
||||
READONLY => 0,
|
||||
LISTITEMS => [qw(foo bar wop)],
|
||||
});
|
||||
|
||||
The new method instantiates a new ComboBox object. The only mandatory
|
||||
key/value pairs in the configuration hash are B<X> and B<Y>. All others
|
||||
have the following defaults:
|
||||
|
||||
Key Default Description
|
||||
============================================================
|
||||
CAPTION undef Caption superimposed on border
|
||||
CAPTIONCOL undef Foreground colour for caption text
|
||||
COLUMNS 10 Number of columns displayed
|
||||
MAXLENGTH 255 Maximum string length allowed
|
||||
MASK undef Not yet implemented
|
||||
VALUE '' Current field text
|
||||
INPUTFUNC \&scankey Function to use to scan for keystrokes
|
||||
FOREGROUND undef Default foreground colour
|
||||
BACKGROUND undef Default background colour
|
||||
BORDER 1 Display a border around the field
|
||||
BORDERCOL undef Foreground colour for border
|
||||
FOCUSSWITCH "\t\n" Characters which signify end of input
|
||||
CURSORPOS 0 Starting position of the cursor
|
||||
TEXTSTART 0 Position in string to start displaying
|
||||
PASSWORD 0 Subsitutes '*' instead of characters
|
||||
READONLY 0 Prevents alteration to content
|
||||
LISTLINES 5 Number of lines to display at a time
|
||||
in the drop-down list
|
||||
LISTCOLUMNS[COLUMNS] Width of the drop-down list. Defaults
|
||||
to the same length specified for the
|
||||
CombBox widget
|
||||
LISTITEMS [] Items listed in drop-down list
|
||||
|
||||
The B<CAPTION> is only valid when the B<BORDER> is enabled. If the border
|
||||
is disabled, the field will be underlined, provided the terminal supports it.
|
||||
|
||||
If B<MAXLENGTH> is undefined, no limit will be placed on the string length.
|
||||
|
||||
=cut
|
||||
|
||||
sub _conf {
|
||||
# Validates and initialises the new ComboBox object.
|
||||
#
|
||||
# Internal use only.
|
||||
|
||||
my $self = shift;
|
||||
my %conf = (
|
||||
LISTLINES => 5,
|
||||
FOCUSSWITCH => "\t",
|
||||
LISTITEMS => [],
|
||||
@_
|
||||
);
|
||||
my $err = 0;
|
||||
|
||||
# Set the default list length to the field length if it
|
||||
# hasn't been defined
|
||||
$conf{LISTCOLUMNS} = $conf{COLUMNS} unless exists $conf{LISTLENGTH};
|
||||
|
||||
# Make sure no errors are returned by the parent method
|
||||
$err = 1 unless $self->SUPER::_conf(%conf);
|
||||
|
||||
# Get updated conf hash
|
||||
%conf = ();
|
||||
%conf = %{$self->{CONF}};
|
||||
|
||||
# Create a list box object for the popup if no errors were encountered
|
||||
$self->{LISTBOX} = Curses::Widgets::ListBox->new({
|
||||
X => 0,
|
||||
Y => 0,
|
||||
LISTITEMS => $conf{LISTITEMS},
|
||||
INPUTFUNC => $conf{INPUTFUNC},
|
||||
BORDERCOL => $conf{BORDERCOL},
|
||||
FOREGROUND => $conf{FOREGROUND},
|
||||
BACKGROUND => $conf{BACKGROUND},
|
||||
LINES => $conf{LISTLINES},
|
||||
COLUMNS => $conf{LISTCOLUMNS},
|
||||
FOCUSSWITCH => "\n\e",
|
||||
BORDER => $conf{BORDER},
|
||||
}) unless $err;
|
||||
|
||||
return $err == 0 ? 1 : 0;
|
||||
}
|
||||
|
||||
=head2 draw (inherited from Curses::Widgets::TextField)
|
||||
|
||||
$cb->draw($mwh, 1);
|
||||
|
||||
The draw method renders the text field in its current state. This
|
||||
requires a valid handle to a curses window in which it will render
|
||||
itself. The optional second argument, if true, will cause the field's
|
||||
text cursor to be rendered as well.
|
||||
|
||||
=cut
|
||||
|
||||
sub _geometry {
|
||||
my $self = shift;
|
||||
my $conf = $self->{CONF};
|
||||
my @rv = @$conf{qw(LINES COLUMNS Y X)};
|
||||
|
||||
if ($$conf{BORDER}) {
|
||||
$rv[0] += 2;
|
||||
$rv[1] += 4;
|
||||
} else {
|
||||
$rv[1]++;
|
||||
}
|
||||
|
||||
return @rv;
|
||||
}
|
||||
|
||||
sub _border {
|
||||
my $self = shift;
|
||||
my $dwh = shift;
|
||||
my $conf = $self->{CONF};
|
||||
my ($y, $x);
|
||||
|
||||
# Get maxyx
|
||||
$dwh->getmaxyx($y, $x);
|
||||
|
||||
# Set the colours
|
||||
$dwh->attrset(COLOR_PAIR(
|
||||
select_colour(@$conf{qw(BORDERCOL BACKGROUND)})));
|
||||
$dwh->attron(A_BOLD) if $$conf{BORDERCOL} eq 'yellow';
|
||||
|
||||
# Border rendering
|
||||
if ($$conf{BORDER}) {
|
||||
|
||||
# Draw the main box
|
||||
$self->SUPER::_border($dwh);
|
||||
|
||||
# Draw the tee intersections and arrow
|
||||
$dwh->addch($y - 2, $x - 2, ACS_DARROW);
|
||||
$dwh->addch(0, $x - 3 , ACS_TTEE);
|
||||
$dwh->addch($y - 2, $x - 3, ACS_VLINE);
|
||||
$dwh->addch($y - 1, $x - 3, ACS_BTEE);
|
||||
|
||||
# No border still requires the down-arrow
|
||||
} else {
|
||||
$dwh->addch(0, $x - 1, ACS_DARROW);
|
||||
}
|
||||
|
||||
# Restore the default settings
|
||||
$self->_restore($dwh);
|
||||
}
|
||||
|
||||
sub draw {
|
||||
my $self = shift;
|
||||
my $mwh = shift;
|
||||
my $active = shift;
|
||||
my ($by, $bx);
|
||||
|
||||
# Get and store the window's beginning y & x
|
||||
$mwh->getbegyx($by, $bx);
|
||||
$self->{BEGYX} = [$by, $bx];
|
||||
|
||||
# Call the parent draw
|
||||
return $self->SUPER::draw($mwh, $active);
|
||||
}
|
||||
|
||||
=head2 popup
|
||||
|
||||
$combo->popup;
|
||||
|
||||
This method causes the drop down list to be displayed. Since, theoretically,
|
||||
this list should never be seen unless it's being actively used, we will always
|
||||
assume that we need to draw a cursor on the list as well.
|
||||
|
||||
=cut
|
||||
|
||||
sub popup {
|
||||
my $self = shift;
|
||||
my $conf = $self->{CONF};
|
||||
my ($x, $y, $border) = @$conf{qw(X Y BORDER)};
|
||||
my ($by, $bx) = @{$self->{BEGYX}};
|
||||
my $lb = $self->{LISTBOX};
|
||||
my ($pwh, $items, $cp, $in, $key);
|
||||
|
||||
# Calculate the border column/lines
|
||||
$border *= 2;
|
||||
if ($border) {
|
||||
$y--;
|
||||
} else {
|
||||
$y++;
|
||||
}
|
||||
|
||||
# Create the popup window
|
||||
unless ($pwh = newwin($$conf{LISTLINES} + $border, $$conf{LISTCOLUMNS} +
|
||||
$border, $y + $border + $by, $x + $border + $bx)) {
|
||||
carp ref($self), ": Popup creation failed, possible geometry problems";
|
||||
return;
|
||||
}
|
||||
$pwh->keypad(1);
|
||||
|
||||
# Render the list box
|
||||
$key = $lb->execute($pwh);
|
||||
|
||||
# Release the window
|
||||
$pwh->delwin;
|
||||
|
||||
# Place the selected listbox value into the textfield if user
|
||||
# pressed enter
|
||||
if ($key eq "\n") {
|
||||
($cp, $items) = $lb->getField(qw(CURSORPOS LISTITEMS));
|
||||
$$conf{VALUE} = $$items[$cp] if (defined $cp && scalar @$items);
|
||||
}
|
||||
}
|
||||
|
||||
sub input_key {
|
||||
# Process input a keystroke at a time.
|
||||
#
|
||||
# Internal use only.
|
||||
|
||||
my $self = shift;
|
||||
my $in = shift;
|
||||
my $conf = $self->{CONF};
|
||||
|
||||
# Handle only special keys that will pull down the list
|
||||
if ($in eq "\n") {
|
||||
} elsif ($in eq KEY_DOWN) {
|
||||
|
||||
$self->popup;
|
||||
|
||||
# Hand everything else to the text widget
|
||||
} else {
|
||||
$self->SUPER::input_key($in);
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=head1 HISTORY
|
||||
|
||||
=over
|
||||
|
||||
=item 2001/12/09 -- First version of the combo box
|
||||
|
||||
=back
|
||||
|
||||
=head1 AUTHOR/COPYRIGHT
|
||||
|
||||
(c) 2001 Arthur Corliss (corliss@digitalmages.com)
|
||||
|
||||
=cut
|
||||
|
||||
@@ -1,211 +0,0 @@
|
||||
# Curses::Widgets::Label.pm -- Label Widgets
|
||||
#
|
||||
# (c) 2001, Arthur Corliss <corliss@digitalmages.com>
|
||||
#
|
||||
# $Id: Label.pm,v 1.102 2002/11/03 23:36:21 corliss Exp corliss $
|
||||
#
|
||||
# This program is free software; you can redistribute it and/or modify
|
||||
# it under the terms of the GNU General Public License as published by
|
||||
# the Free Software Foundation; either version 2 of the License, or
|
||||
# any later version.
|
||||
#
|
||||
# This program is distributed in the hope that it will be useful,
|
||||
# but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
# GNU General Public License for more details.
|
||||
#
|
||||
# You should have received a copy of the GNU General Public License
|
||||
# along with this program; if not, write to the Free Software
|
||||
# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
|
||||
#
|
||||
#####################################################################
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Curses::Widgets::Label - Label Widgets
|
||||
|
||||
=head1 MODULE VERSION
|
||||
|
||||
$Id: Label.pm,v 1.102 2002/11/03 23:36:21 corliss Exp corliss $
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Curses::Widgets::Label;
|
||||
|
||||
$lbl = Curses::Widgets::Label->new({
|
||||
COLUMNS => 10,
|
||||
LINES => 1,
|
||||
VALUE => 'Name:',
|
||||
FOREGROUND => undef,
|
||||
BACKGROUND => 'black',
|
||||
X => 1,
|
||||
Y => 1,
|
||||
ALIGNMENT => 'R',
|
||||
});
|
||||
|
||||
$tf->draw($mwh);
|
||||
|
||||
See the Curses::Widgets pod for other methods.
|
||||
|
||||
=head1 REQUIREMENTS
|
||||
|
||||
=over
|
||||
|
||||
=item Curses
|
||||
|
||||
=item Curses::Widgets
|
||||
|
||||
=back
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Curses::Widgets::Label provides simplified OO access to Curses-based
|
||||
single or multi-line labels.
|
||||
|
||||
=cut
|
||||
|
||||
#####################################################################
|
||||
#
|
||||
# Environment definitions
|
||||
#
|
||||
#####################################################################
|
||||
|
||||
package Curses::Widgets::Label;
|
||||
|
||||
use strict;
|
||||
use vars qw($VERSION @ISA);
|
||||
use Carp;
|
||||
use Curses;
|
||||
use Curses::Widgets;
|
||||
|
||||
($VERSION) = (q$Revision: 1.102 $ =~ /(\d+(?:\.(\d+))+)/);
|
||||
@ISA = qw(Curses::Widgets);
|
||||
|
||||
#####################################################################
|
||||
#
|
||||
# Module code follows
|
||||
#
|
||||
#####################################################################
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=head2 new (inherited from Curses::Widgets)
|
||||
|
||||
$lbl = Curses::Widgets::Label->new({
|
||||
COLUMNS => 10,
|
||||
LINES => 1,
|
||||
VALUE => 'Name:',
|
||||
FOREGROUND => undef,
|
||||
BACKGROUND => 'black',
|
||||
X => 1,
|
||||
Y => 1,
|
||||
ALIGNMENT => 'R',
|
||||
});
|
||||
|
||||
The new method instantiates a new Label object. The only mandatory
|
||||
key/value pairs in the configuration hash are B<X> and B<Y>. All others
|
||||
have the following defaults:
|
||||
|
||||
Key Default Description
|
||||
============================================================
|
||||
COLUMNS 10 Number of columns displayed
|
||||
LINES 1 Number of lines displayed
|
||||
VALUE '' Label text
|
||||
FOREGROUND undef Default foreground colour
|
||||
BACKGROUND undef Default background colour
|
||||
ALIGNMENT L 'R'ight, 'L'eft, or 'C'entered
|
||||
|
||||
If the label is a multi-line label it will filter the current VALUE through
|
||||
the Curses::Widgets::textwrap function to break it along whitespace and
|
||||
newlines.
|
||||
|
||||
=cut
|
||||
|
||||
sub _conf {
|
||||
# Validates and initialises the new Label object.
|
||||
#
|
||||
# Usage: $self->_conf(%conf);
|
||||
|
||||
my $self = shift;
|
||||
my %conf = (
|
||||
COLUMNS => 10,
|
||||
LINES => 1,
|
||||
VALUE => '',
|
||||
ALIGNMENT => 'L',
|
||||
BORDER => 0,
|
||||
@_
|
||||
);
|
||||
my @required = qw(X Y);
|
||||
my $err = 0;
|
||||
|
||||
# Check for required arguments
|
||||
foreach (@required) { $err = 1 unless exists $conf{$_} };
|
||||
|
||||
$conf{ALIGNMENT} = uc($conf{ALIGNMENT});
|
||||
|
||||
# Make sure no errors are returned by the parent method
|
||||
$err = 1 unless $self->SUPER::_conf(%conf);
|
||||
|
||||
return $err == 0 ? 1 : 0;
|
||||
}
|
||||
|
||||
=head2 draw
|
||||
|
||||
$tf->draw($mwh);
|
||||
|
||||
The draw method renders the text field in its current state. This
|
||||
requires a valid handle to a curses window in which it will render
|
||||
itself.
|
||||
|
||||
=cut
|
||||
|
||||
sub _content {
|
||||
my $self = shift;
|
||||
my $dwh = shift;
|
||||
my $conf = $self->{CONF};
|
||||
my ($lines, $cols, $value) =
|
||||
@$conf{qw(LINES COLUMNS VALUE)};
|
||||
my (@lines, $offset);
|
||||
|
||||
# Get the lines
|
||||
@lines = textwrap($value, $cols);
|
||||
|
||||
# Write the widget value
|
||||
foreach (0..$lines) {
|
||||
next unless defined $lines[$_];
|
||||
$offset = $$conf{ALIGNMENT} eq 'C' ?
|
||||
int(($$conf{COLUMNS} - length($lines[$_])) / 2) :
|
||||
($$conf{ALIGNMENT} eq 'R' ?
|
||||
$$conf{COLUMNS} - length($lines[$_]) : 0);
|
||||
$offset = 0 if $offset < 0;
|
||||
$dwh->addstr(0 + $_, 0 + $offset, $lines[$_]) if $_ <= $#lines;
|
||||
}
|
||||
}
|
||||
|
||||
# The following are overridden to make sure no one tries anything fancy with
|
||||
# this widget. ;-)
|
||||
|
||||
sub input_key {
|
||||
return;
|
||||
}
|
||||
|
||||
sub execute {
|
||||
return;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=head1 HISTORY
|
||||
|
||||
=over
|
||||
|
||||
=item 2002/10/18 -- First implementation
|
||||
|
||||
=back
|
||||
|
||||
=head1 AUTHOR/COPYRIGHT
|
||||
|
||||
(c) 2001 Arthur Corliss (corliss@digitalmages.com)
|
||||
|
||||
=cut
|
||||
|
||||
@@ -1,415 +0,0 @@
|
||||
# Curses::Widgets::ListBox.pm -- List Box Widgets
|
||||
#
|
||||
# (c) 2001, Arthur Corliss <corliss@digitalmages.com>
|
||||
#
|
||||
# $Id: ListBox.pm,v 1.104 2002/11/14 01:20:28 corliss Exp corliss $
|
||||
#
|
||||
# This program is free software; you can redistribute it and/or modify
|
||||
# it under the terms of the GNU General Public License as published by
|
||||
# the Free Software Foundation; either version 2 of the License, or
|
||||
# any later version.
|
||||
#
|
||||
# This program is distributed in the hope that it will be useful,
|
||||
# but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
# GNU General Public License for more details.
|
||||
#
|
||||
# You should have received a copy of the GNU General Public License
|
||||
# along with this program; if not, write to the Free Software
|
||||
# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
|
||||
#
|
||||
#####################################################################
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Curses::Widgets::ListBox - List Box Widgets
|
||||
|
||||
=head1 MODULE VERSION
|
||||
|
||||
$Id: ListBox.pm,v 1.104 2002/11/14 01:20:28 corliss Exp corliss $
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Curses::Widgets::ListBox;
|
||||
|
||||
$lb = Curses::Widgets::ListBox->new({
|
||||
CAPTION => 'List',
|
||||
CAPTIONCOL => 'yellow',
|
||||
COLUMNS => 10,
|
||||
LINES => 3,
|
||||
VALUE => 0,
|
||||
INPUTFUNC => \&scankey,
|
||||
FOREGROUND => 'white',
|
||||
BACKGROUND => 'black',
|
||||
SELECTEDCOL => 'green',
|
||||
BORDER => 1,
|
||||
BORDERCOL => 'red',
|
||||
FOCUSSWITCH => "\t",
|
||||
X => 1,
|
||||
Y => 1,
|
||||
TOPELEMENT => 0,
|
||||
LISTITEMS => [@list],
|
||||
});
|
||||
|
||||
$lb->draw($mwh, 1);
|
||||
|
||||
See the Curses::Widgets pod for other methods.
|
||||
|
||||
=head1 REQUIREMENTS
|
||||
|
||||
=over
|
||||
|
||||
=item Curses
|
||||
|
||||
=item Curses::Widgets
|
||||
|
||||
=back
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Curses::Widgets::ListBox provides simplified OO access to Curses-based
|
||||
single/multi-select list boxes. Each object maintains its own state
|
||||
information.
|
||||
|
||||
=cut
|
||||
|
||||
#####################################################################
|
||||
#
|
||||
# Environment definitions
|
||||
#
|
||||
#####################################################################
|
||||
|
||||
package Curses::Widgets::ListBox;
|
||||
|
||||
use strict;
|
||||
use vars qw($VERSION @ISA);
|
||||
use Carp;
|
||||
use Curses;
|
||||
use Curses::Widgets;
|
||||
|
||||
($VERSION) = (q$Revision: 1.104 $ =~ /(\d+(?:\.(\d+))+)/);
|
||||
@ISA = qw(Curses::Widgets);
|
||||
|
||||
#####################################################################
|
||||
#
|
||||
# Module code follows
|
||||
#
|
||||
#####################################################################
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=head2 new (inherited from Curses::Widgets)
|
||||
|
||||
$tm = Curses::Widgets::ListBox->new({
|
||||
CAPTION => 'List',
|
||||
CAPTIONCOL => 'yellow',
|
||||
COLUMNS => 10,
|
||||
LINES => 3,
|
||||
VALUE => 0,
|
||||
INPUTFUNC => \&scankey,
|
||||
FOREGROUND => 'white',
|
||||
BACKGROUND => 'black',
|
||||
SELECTEDCOL => 'green',
|
||||
BORDER => 1,
|
||||
BORDERCOL => 'red',
|
||||
FOCUSSWITCH => "\t",
|
||||
X => 1,
|
||||
Y => 1,
|
||||
TOPELEMENT => 0,
|
||||
LISTITEMS => [@list],
|
||||
});
|
||||
|
||||
The new method instantiates a new ListBox object. The only mandatory
|
||||
key/value pairs in the configuration hash are B<X> and B<Y>. All others
|
||||
have the following defaults:
|
||||
|
||||
Key Default Description
|
||||
============================================================
|
||||
CAPTION undef Caption superimposed on border
|
||||
CAPTIONCOL undef Foreground colour for caption text
|
||||
COLUMNS 10 Number of columns displayed
|
||||
LINES 3 Number of lines in the window
|
||||
INPUTFUNC \&scankey Function to use to scan for keystrokes
|
||||
FOREGROUND undef Default foreground colour
|
||||
BACKGROUND undef Default background colour
|
||||
SELECTEDCOL undef Default colour of selected items
|
||||
BORDER 1 Display a border around the field
|
||||
BORDERCOL undef Foreground colour for border
|
||||
FOCUSSWITCH "\t" Characters which signify end of input
|
||||
TOPELEMENT 0 Index of element displayed on line 1
|
||||
LISTITEMS [] List of list items
|
||||
MULTISEL 0 Whether or not multiple items can be
|
||||
selected
|
||||
TOGGLE "\n\s" What input toggles selection of the
|
||||
current item
|
||||
VALUE 0 or [] Index(es) of selected items
|
||||
CURSORPOS 0 Index of the item the cursor is
|
||||
currently on
|
||||
|
||||
The B<CAPTION> is only valid when the B<BORDER> is enabled. If the border
|
||||
is disabled, the field will be underlined, provided the terminal supports it.
|
||||
|
||||
The value of B<VALUE> should be an array reference when in multiple
|
||||
selection mode. Otherwise it should either undef or an integer.
|
||||
|
||||
=cut
|
||||
|
||||
sub _conf {
|
||||
# Validates and initialises the new ListBox object.
|
||||
#
|
||||
# Usage: $self->_conf(%conf);
|
||||
|
||||
my $self = shift;
|
||||
my %conf = (
|
||||
COLUMNS => 10,
|
||||
LINES => 3,
|
||||
VALUE => undef,
|
||||
INPUTFUNC => \&scankey,
|
||||
BORDER => 1,
|
||||
FOCUSSWITCH => "\t",
|
||||
TOPELEMENT => 0,
|
||||
LISTITEMS => [],
|
||||
MULTISEL => 0,
|
||||
VALUE => undef,
|
||||
CURSORPOS => 0,
|
||||
TOGGLE => "\n ",
|
||||
@_
|
||||
);
|
||||
my @required = qw(X Y);
|
||||
my $err = 0;
|
||||
|
||||
# Check for required arguments
|
||||
foreach (@required) { $err = 1 unless exists $conf{$_} };
|
||||
|
||||
$conf{SELECTEDCOL} = lc($conf{SELECTEDCOL}) if exists $conf{SELECTEDCOL};
|
||||
|
||||
# Make sure no errors are returned by the parent method
|
||||
$err = 1 unless $self->SUPER::_conf(%conf);
|
||||
|
||||
# Update VALUE depending on selection mode
|
||||
$conf{VALUE} = [] if $conf{MULTISEL} and not exists $conf{VALUE};
|
||||
|
||||
return $err == 0 ? 1 : 0;
|
||||
}
|
||||
|
||||
=head2 draw
|
||||
|
||||
$lb->draw($mwh, 1);
|
||||
|
||||
The draw method renders the list box in its current state. This
|
||||
requires a valid handle to a curses window in which it will render
|
||||
itself. The optional second argument, if true, will cause the field's
|
||||
text cursor to be rendered as well.
|
||||
|
||||
=cut
|
||||
|
||||
sub _border {
|
||||
my $self = shift;
|
||||
my $dwh = shift;
|
||||
my $conf = $self->{CONF};
|
||||
my ($top, $pos, $lines, $cols, $items) =
|
||||
@$conf{qw(TOPELEMENT CURSORPOS LINES COLUMNS LISTITEMS)};
|
||||
my ($y, $x);
|
||||
|
||||
# Render the box
|
||||
$self->SUPER::_border($dwh);
|
||||
|
||||
# Adjust the cursor position if it's out of whack
|
||||
$pos = $#{$items} if $pos > $#{$items};
|
||||
while ($pos - $top > $lines - 1) { $top++ };
|
||||
while ($top > $pos) { --$top };
|
||||
|
||||
# Render up/down arrows as needed
|
||||
$dwh->getmaxyx($y, $x);
|
||||
$dwh->addch(0, $x - 2, ACS_UARROW) if $top > 0;
|
||||
$dwh->addch($y - 1, $x - 2, ACS_DARROW) if
|
||||
$top + $lines < @$items ;
|
||||
|
||||
# Restore the default settings
|
||||
$self->_restore($dwh);
|
||||
|
||||
# Save any massaged values
|
||||
@$conf{qw(TOPELEMENT CURSORPOS)} = ($top, $pos);
|
||||
}
|
||||
|
||||
sub _content {
|
||||
my $self = shift;
|
||||
my $dwh = shift;
|
||||
my $conf = $self->{CONF};
|
||||
my ($pos, $top, $border, $cols, $lines, $sel) =
|
||||
@$conf{qw(CURSORPOS TOPELEMENT BORDER COLUMNS LINES VALUE)};
|
||||
my @items = @{$$conf{LISTITEMS}};
|
||||
my (@colours, $i);
|
||||
|
||||
# Turn on underlining (terminal-dependent) if no border is used
|
||||
$dwh->attron(A_UNDERLINE) unless $border;
|
||||
|
||||
# Display the items on the list
|
||||
if (scalar @items) {
|
||||
|
||||
# Display the items
|
||||
for $i ($top..$#items) {
|
||||
@colours = @$conf{qw(FOREGROUND BACKGROUND)};
|
||||
if (defined $sel &&
|
||||
grep /^$i$/, (ref($sel) eq 'ARRAY' ? @$sel : $sel)) {
|
||||
|
||||
# Set the colour for selected items
|
||||
if (exists $$conf{SELECTEDCOL}) {
|
||||
$colours[0] = $$conf{SELECTEDCOL};
|
||||
$dwh->attrset(COLOR_PAIR(select_colour(
|
||||
@$conf{qw(SELECTEDCOL BACKGROUND)})));
|
||||
$dwh->attron(A_BOLD) if $$conf{SELECTEDCOL} eq 'yellow';
|
||||
|
||||
# Bold it if no selection colour was defined
|
||||
} else {
|
||||
$dwh->attron(A_BOLD);
|
||||
}
|
||||
}
|
||||
|
||||
# Print the item
|
||||
$dwh->addstr($i - $top, 0, substr($items[$i], 0, $cols));
|
||||
|
||||
# Underline the line if there's no border
|
||||
$dwh->chgat($i - $top, 0, $cols, A_UNDERLINE, select_colour(@colours),
|
||||
0) unless $border;
|
||||
|
||||
# Restore the default settings
|
||||
$self->_restore($dwh);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub _cursor {
|
||||
my $self = shift;
|
||||
my $dwh = shift;
|
||||
my $conf = $self->{CONF};
|
||||
my ($pos, $top, $cols, $sel) =
|
||||
@$conf{qw(CURSORPOS TOPELEMENT COLUMNS VALUE)};
|
||||
my $fg;
|
||||
|
||||
# Determine the foreground colour
|
||||
if (defined $sel && exists $$conf{SELECTEDCOL} &&
|
||||
grep /^$pos$/, (ref($sel) eq 'ARRAY' ? @$sel : $sel)) {
|
||||
$fg = $$conf{SELECTEDCOL};
|
||||
} else {
|
||||
$fg = $$conf{FOREGROUND};
|
||||
}
|
||||
|
||||
# Display the cursor
|
||||
$dwh->chgat($pos - $top, 0, $cols, A_STANDOUT, select_colour(
|
||||
$fg, $$conf{BACKGROUND}), 0);
|
||||
|
||||
# Restore the default settings
|
||||
$self->_restore($dwh);
|
||||
}
|
||||
|
||||
sub input_key {
|
||||
# Process input a keystroke at a time.
|
||||
#
|
||||
# Usage: $self->input_key($key);
|
||||
|
||||
my $self = shift;
|
||||
my $in = shift;
|
||||
my $conf = $self->{CONF};
|
||||
my $sel = $$conf{VALUE};
|
||||
my @items = @{$$conf{LISTITEMS}};
|
||||
my $pos = $$conf{CURSORPOS};
|
||||
my $re = $$conf{TOGGLE};
|
||||
my $np;
|
||||
|
||||
# Process special keys
|
||||
if ($in eq KEY_UP) {
|
||||
if ($pos > 0) {
|
||||
--$pos;
|
||||
} else {
|
||||
beep;
|
||||
}
|
||||
} elsif ($in eq KEY_DOWN) {
|
||||
if ($pos < $#items) {
|
||||
++$pos;
|
||||
} else {
|
||||
beep;
|
||||
}
|
||||
} elsif ($in eq KEY_HOME || $in eq KEY_END || $in eq KEY_PPAGE ||
|
||||
$in eq KEY_NPAGE) {
|
||||
|
||||
if (scalar @items) {
|
||||
if ($in eq KEY_HOME) {
|
||||
beep if $pos == 0;
|
||||
$pos = 0;
|
||||
} elsif ($in eq KEY_END) {
|
||||
beep if $pos == $#items;
|
||||
$pos = $#items;
|
||||
} elsif ($in eq KEY_PPAGE) {
|
||||
beep if $pos == 0;
|
||||
$pos -= $$conf{LINES};
|
||||
$pos = 0 if $pos < 0;
|
||||
} elsif ($in eq KEY_NPAGE) {
|
||||
beep if $pos == $#items;
|
||||
$pos += $$conf{LINES};
|
||||
$pos = $#items if $pos > $#items;
|
||||
}
|
||||
} else {
|
||||
beep;
|
||||
}
|
||||
|
||||
# Process normal key strokes
|
||||
} else {
|
||||
|
||||
# Exit out if there's no list to apply strokes to
|
||||
return unless scalar @items;
|
||||
|
||||
if ($in =~ /^[$re]$/) {
|
||||
if ($$conf{MULTISEL}) {
|
||||
if (grep /^$pos$/, @$sel) {
|
||||
@$sel = grep !/^$pos$/, @$sel;
|
||||
} else {
|
||||
push(@$sel, $pos);
|
||||
}
|
||||
} else {
|
||||
$sel = $pos;
|
||||
}
|
||||
} elsif ($in =~ /^[[:print:]]$/ && $pos < $#items) {
|
||||
$pos = $self->match_key($in);
|
||||
} else {
|
||||
beep;
|
||||
}
|
||||
}
|
||||
|
||||
# Save the changes
|
||||
@$conf{qw(VALUE CURSORPOS)} = ($sel, $pos);
|
||||
}
|
||||
|
||||
sub match_key {
|
||||
my $self = shift;
|
||||
my $in = shift;
|
||||
my $conf = $self->{CONF};
|
||||
my @items = @{$$conf{LISTITEMS}};
|
||||
my $pos = $$conf{CURSORPOS};
|
||||
my $np;
|
||||
|
||||
$np = $pos + 1;
|
||||
while ($np <= $#items && $items[$np] !~ /^\Q$in\E/i) { $np++ };
|
||||
$pos = $np if $np <= $#items and $items[$np] =~ /^\Q$in\E/i;
|
||||
|
||||
return $pos;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=head1 HISTORY
|
||||
|
||||
=over
|
||||
|
||||
=item 1999/12/29 -- Original list box widget in functional model
|
||||
|
||||
=item 2001/07/05 -- First incarnation in OO architecture
|
||||
|
||||
=back
|
||||
|
||||
=head1 AUTHOR/COPYRIGHT
|
||||
|
||||
(c) 2001 Arthur Corliss (corliss@digitalmages.com)
|
||||
|
||||
=cut
|
||||
|
||||
@@ -1,358 +0,0 @@
|
||||
# Curses::Widgets::ListBox::MultiColumn.pm -- Multi-Column List Box Widgets
|
||||
#
|
||||
# (c) 2001, Arthur Corliss <corliss@digitalmages.com>
|
||||
#
|
||||
# $Id: MultiColumn.pm,v 0.1 2002/11/14 01:28:49 corliss Exp corliss $
|
||||
#
|
||||
# This program is free software; you can redistribute it and/or modify
|
||||
# it under the terms of the GNU General Public License as published by
|
||||
# the Free Software Foundation; either version 2 of the License, or
|
||||
# any later version.
|
||||
#
|
||||
# This program is distributed in the hope that it will be useful,
|
||||
# but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
# GNU General Public License for more details.
|
||||
#
|
||||
# You should have received a copy of the GNU General Public License
|
||||
# along with this program; if not, write to the Free Software
|
||||
# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
|
||||
#
|
||||
#####################################################################
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Curses::Widgets::ListBox::MultiColumn - Multi-Column List Box Widgets
|
||||
|
||||
=head1 MODULE VERSION
|
||||
|
||||
$Id: MultiColumn.pm,v 0.1 2002/11/14 01:28:49 corliss Exp corliss $
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Curses::Widgets::ListBox::MultiColumn;
|
||||
|
||||
$lb = Curses::Widgets::ListBox::MultiColumn->new({
|
||||
COLUMNS => [0, 5, 10, 3, 3],
|
||||
LISTITEMS => [@list],
|
||||
});
|
||||
|
||||
$lb->draw($mwh, 1);
|
||||
|
||||
See the Curses::Widgets pod for other methods.
|
||||
|
||||
=head1 REQUIREMENTS
|
||||
|
||||
=over
|
||||
|
||||
=item Curses
|
||||
|
||||
=item Curses::Widgets
|
||||
|
||||
=item Curses::Widgets::ListBox
|
||||
|
||||
=back
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Curses::Widgets::ListBox::MultiColumn is an extension of the standard
|
||||
Curses::Widgets::ListBox that allows a list of columns, with each column a
|
||||
specified width.
|
||||
|
||||
=cut
|
||||
|
||||
#####################################################################
|
||||
#
|
||||
# Environment definitions
|
||||
#
|
||||
#####################################################################
|
||||
|
||||
package Curses::Widgets::ListBox::MultiColumn;
|
||||
|
||||
use strict;
|
||||
use vars qw($VERSION @ISA);
|
||||
use Carp;
|
||||
use Curses;
|
||||
use Curses::Widgets;
|
||||
use Curses::Widgets::ListBox;
|
||||
|
||||
($VERSION) = (q$Revision: 0.1 $ =~ /(\d+(?:\.(\d+))+)/);
|
||||
@ISA = qw(Curses::Widgets::ListBox);
|
||||
|
||||
#####################################################################
|
||||
#
|
||||
# Module code follows
|
||||
#
|
||||
#####################################################################
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=head2 new (inherited from Curses::Widgets)
|
||||
|
||||
$tm = Curses::Widgets::ListBox->new({
|
||||
COLUMNS => [0, 5, 10, 3, 3],
|
||||
LISTITEMS => [@list],
|
||||
HEADERS => [@headers],
|
||||
HEADERCOLFG => 'white',
|
||||
HEADERCOLBG => 'green',
|
||||
BIGHEADER => 1,
|
||||
});
|
||||
|
||||
All of the same key values apply here as they do for the parent class
|
||||
Curses::Widgets::ListBox. In addition, the following new keys are defined:
|
||||
|
||||
Key Default Description
|
||||
============================================================
|
||||
COLUMNS [] Column widths
|
||||
LISTITEMS [] List of list values
|
||||
HEADERS [] Column header labels
|
||||
HEADERFGCOL undef Header foreground colour
|
||||
HEADERBGCOL undef Header background colour
|
||||
BIGHEADER 0 Use more graphics for the header
|
||||
KEYINDX 0 Index of key column
|
||||
|
||||
If headers are defined but one or both of the header colours are not, then
|
||||
they will default to the widget fore and background.
|
||||
|
||||
B<NOTE>: Headers take up more lines in addition to the border (one line for
|
||||
the normal, small header, two lines for the larger). You need to take that
|
||||
into account when setting the geometry. If no labels are passed in the
|
||||
HEADERS array, no space will be used for the headers.
|
||||
|
||||
The B<KEYINDX> value is currently only used to match keystrokes against for
|
||||
quick navigation.
|
||||
|
||||
=cut
|
||||
|
||||
sub _conf {
|
||||
# Validates and initialises the new ListBox object.
|
||||
#
|
||||
# Usage: $self->_conf(%conf);
|
||||
|
||||
my $self = shift;
|
||||
my %conf = (
|
||||
COLWIDTHS => [10],
|
||||
KEYINDEX => 0,
|
||||
HEADERS => [],
|
||||
BIGHEADER => 0,
|
||||
KEYINDX => 0,
|
||||
@_
|
||||
);
|
||||
my $err = 0;
|
||||
my @required = qw(COLWIDTHS);
|
||||
|
||||
# Check for required fields
|
||||
foreach (@required) { $err = 1 unless exists $conf{$_} };
|
||||
$err = 1 unless @{$conf{COLWIDTHS}};
|
||||
|
||||
# Lowercase extra colours
|
||||
foreach (qw(HEADERFGCOL HEADERBGCOL)) {
|
||||
$conf{$_} = lc($conf{$_}) if exists $conf{$_} };
|
||||
|
||||
# Make sure no errors are returned by the parent method
|
||||
$err = 1 unless $self->SUPER::_conf(%conf);
|
||||
|
||||
return $err == 0 ? 1 : 0;
|
||||
}
|
||||
|
||||
=head2 draw
|
||||
|
||||
$lb->draw($mwh, 1);
|
||||
|
||||
The draw method renders the list box in its current state. This
|
||||
requires a valid handle to a curses window in which it will render
|
||||
itself. The optional second argument, if true, will cause the field's
|
||||
text cursor to be rendered as well.
|
||||
|
||||
=cut
|
||||
|
||||
sub _geometry {
|
||||
my $self = shift;
|
||||
my $conf = $self->{CONF};
|
||||
my @rv;
|
||||
|
||||
@rv = $self->SUPER::_geometry;
|
||||
if (@{$$conf{HEADERS}}) {
|
||||
$rv[0]++;
|
||||
$rv[0]++ if $$conf{BIGHEADER};
|
||||
}
|
||||
|
||||
return @rv;
|
||||
}
|
||||
|
||||
sub _cgeometry {
|
||||
my $self = shift;
|
||||
my $conf = $self->{CONF};
|
||||
my @rv;
|
||||
|
||||
@rv = $self->SUPER::_cgeometry;
|
||||
if (@{$$conf{HEADERS}}) {
|
||||
$rv[2]++;
|
||||
$rv[2]++ if $$conf{BIGHEADER};
|
||||
}
|
||||
|
||||
return @rv;
|
||||
}
|
||||
|
||||
sub _border {
|
||||
my $self = shift;
|
||||
my $dwh = shift;
|
||||
my $conf = $self->{CONF};
|
||||
my (@colours, $header, @headers, $i, $h);
|
||||
my ($y, $x);
|
||||
|
||||
# Render the border
|
||||
$self->SUPER::_border($dwh);
|
||||
|
||||
# Draw the headers if any were defined
|
||||
if (@{$$conf{HEADERS}}) {
|
||||
|
||||
# Construct the header
|
||||
$i = -1;
|
||||
foreach (@{$$conf{COLWIDTHS}}) {
|
||||
++$i;
|
||||
next unless $_;
|
||||
$h = $$conf{HEADERS}[$i] || '';
|
||||
$header .= substr($h, 0, $_);
|
||||
$header .= ' ' x ($_ - length($h)) if length($h) < $_;
|
||||
$header .= ' ';
|
||||
}
|
||||
chop $header;
|
||||
|
||||
# Print the header
|
||||
$i = $$conf{BORDER} ? 1 : 0;
|
||||
$dwh->addstr($i, $i, substr($header, 0, $$conf{COLUMNS}));
|
||||
|
||||
# Set the colours
|
||||
push(@colours, exists $$conf{HEADERFGCOL} ? $$conf{HEADERFGCOL} :
|
||||
$$conf{FOREGROUND});
|
||||
push(@colours, exists $$conf{HEADERBGCOL} ? $$conf{HEADERBGCOL} :
|
||||
$$conf{BACKGROUND});
|
||||
$dwh->chgat($i, $i, $$conf{COLUMNS}, $colours[0] eq 'yellow' ? A_BOLD :
|
||||
0, select_colour(@colours), 0);
|
||||
|
||||
# Draw the big header graphics
|
||||
if ($$conf{BIGHEADER}) {
|
||||
|
||||
# Use the border colours
|
||||
$dwh->attrset(COLOR_PAIR(
|
||||
select_colour(@$conf{qw(BORDERCOL BACKGROUND)})));
|
||||
$dwh->attron(A_BOLD) if $$conf{BORDERCOL} eq 'yellow';
|
||||
|
||||
# Draw the lower line
|
||||
$dwh->getmaxyx($y, $x);
|
||||
for (0..($x - 1)) { $dwh->addch($i + 1, $_, ACS_HLINE) };
|
||||
|
||||
# Draw the vertical lines and tees
|
||||
$h = 0;
|
||||
foreach (@{$$conf{COLWIDTHS}}) {
|
||||
$h += $_ + $i;
|
||||
last if $h > $$conf{COLUMNS};
|
||||
$dwh->addch(0, $h, ACS_TTEE) if $i == 1;
|
||||
$dwh->addch($i, $h, ACS_VLINE);
|
||||
$dwh->addch($i + 1, $h, ACS_BTEE);
|
||||
}
|
||||
if ($$conf{BORDER}) {
|
||||
$dwh->addch($i + 1, 0, ACS_LTEE);
|
||||
$dwh->addch($i + 1, $x - 1, ACS_RTEE);
|
||||
}
|
||||
}
|
||||
|
||||
$self->_restore($dwh);
|
||||
}
|
||||
}
|
||||
|
||||
sub _content {
|
||||
my $self = shift;
|
||||
my $dwh = shift;
|
||||
my $conf = $self->{CONF};
|
||||
my ($pos, $top, $border, $cols, $lines, $sel) =
|
||||
@$conf{qw(CURSORPOS TOPELEMENT BORDER COLUMNS LINES VALUE)};
|
||||
my @items = @{$$conf{LISTITEMS}};
|
||||
my (@colours, $h, $i, $j, $item);
|
||||
|
||||
# Turn on underlining (terminal-dependent) if no border is used
|
||||
$dwh->attron(A_UNDERLINE) unless $border;
|
||||
|
||||
# Display the items on the list
|
||||
if (scalar @items) {
|
||||
|
||||
# Display the items
|
||||
for $i ($top..$#items) {
|
||||
|
||||
# Construct the header
|
||||
$j = -1;
|
||||
$item = '';
|
||||
foreach (@{$$conf{COLWIDTHS}}) {
|
||||
++$j;
|
||||
next unless $_;
|
||||
$h = $items[$i][$j] || '';
|
||||
$item .= substr($h, 0, $_);
|
||||
$item .= ' ' x ($_ - length($h)) if length($h) < $_;
|
||||
$item .= ' ';
|
||||
}
|
||||
chop $item;
|
||||
|
||||
@colours = @$conf{qw(FOREGROUND BACKGROUND)};
|
||||
if (defined $sel &&
|
||||
grep /^$i$/, (ref($sel) eq 'ARRAY' ? @$sel : $sel)) {
|
||||
|
||||
# Set the colour for selected items
|
||||
if (exists $$conf{SELECTEDCOL}) {
|
||||
$colours[0] = $$conf{SELECTEDCOL};
|
||||
$dwh->attrset(COLOR_PAIR(select_colour(
|
||||
@$conf{qw(SELECTEDCOL BACKGROUND)})));
|
||||
$dwh->attron(A_BOLD) if $$conf{SELECTEDCOL} eq 'yellow';
|
||||
|
||||
# Bold it if no selection colour was defined
|
||||
} else {
|
||||
$dwh->attron(A_BOLD);
|
||||
}
|
||||
}
|
||||
|
||||
# Print the item
|
||||
$dwh->addstr($i - $top, 0, substr($item, 0, $cols));
|
||||
|
||||
# Underline the line if there's no border
|
||||
$dwh->chgat($i - $top, 0, $cols, A_UNDERLINE, select_colour(@colours),
|
||||
0) unless $border;
|
||||
|
||||
# Restore the default settings
|
||||
$self->_restore($dwh);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub match_key {
|
||||
my $self = shift;
|
||||
my $in = shift;
|
||||
my $conf = $self->{CONF};
|
||||
my @items = @{$$conf{LISTITEMS}};
|
||||
my ($pos, $indx) = @$conf{qw(CURSORPOS KEYINDX)};
|
||||
my $np;
|
||||
|
||||
$np = $pos + 1;
|
||||
while ($np <= $#items && $items[$np][$indx] !~ /^\Q$in\E/i) { $np++ };
|
||||
$pos = $np if $np <= $#items and $items[$np][$indx] =~ /^\Q$in\E/i;
|
||||
|
||||
return $pos;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=head1 HISTORY
|
||||
|
||||
=over
|
||||
|
||||
=item 1999/12/29 -- Original list box widget in functional model
|
||||
|
||||
=item 2001/07/05 -- First incarnation in OO architecture
|
||||
|
||||
=back
|
||||
|
||||
=head1 AUTHOR/COPYRIGHT
|
||||
|
||||
(c) 2001 Arthur Corliss (corliss@digitalmages.com)
|
||||
|
||||
=cut
|
||||
|
||||
@@ -1,460 +0,0 @@
|
||||
# Curses::Widgets::Menu.pm -- Menu Widgets
|
||||
#
|
||||
# (c) 2001, Arthur Corliss <corliss@digitalmages.com>
|
||||
#
|
||||
# $Id: Menu.pm,v 1.103 2002/11/14 01:26:34 corliss Exp corliss $
|
||||
#
|
||||
# This program is free software; you can redistribute it and/or modify
|
||||
# it under the terms of the GNU General Public License as published by
|
||||
# the Free Software Foundation; either version 2 of the License, or
|
||||
# any later version.
|
||||
#
|
||||
# This program is distributed in the hope that it will be useful,
|
||||
# but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
# GNU General Public License for more details.
|
||||
#
|
||||
# You should have received a copy of the GNU General Public License
|
||||
# along with this program; if not, write to the Free Software
|
||||
# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
|
||||
#
|
||||
#####################################################################
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Curses::Widgets::Menu - Menu Widgets
|
||||
|
||||
=head1 MODULE VERSION
|
||||
|
||||
$Id: Menu.pm,v 1.103 2002/11/14 01:26:34 corliss Exp corliss $
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Curses::Widgets::Menu;
|
||||
|
||||
$menu = Curses::Widgets::Menu->new({
|
||||
COLUMNS => 10,
|
||||
INPUTFUNC => \&scankey,
|
||||
FOREGROUND => undef,
|
||||
BACKGROUND => 'black',
|
||||
FOCUSSWITCH => "\t",
|
||||
X => 1,
|
||||
Y => 1,
|
||||
MENUS => {
|
||||
MENUORDER => [qw(File)],
|
||||
File => {
|
||||
ITEMORDER => [qw(Save Quit)],
|
||||
Save => \&Save,
|
||||
Quit => \&Quit,
|
||||
},
|
||||
CURSORPOS => 'File',
|
||||
BORDER => 1,
|
||||
});
|
||||
|
||||
$menu->draw($mwh, 1);
|
||||
$menu->execute;
|
||||
|
||||
See the Curses::Widgets pod for other methods.
|
||||
|
||||
=head1 REQUIREMENTS
|
||||
|
||||
=over
|
||||
|
||||
=item Curses
|
||||
|
||||
=item Curses::Widgets
|
||||
|
||||
=item Curses::Widgets::ListBox
|
||||
|
||||
=back
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Curses::Widgets::Menu provides simplified OO access to menus. Each item in a
|
||||
menu can be tied to a subroutine reference which is called when selected.
|
||||
|
||||
=cut
|
||||
|
||||
#####################################################################
|
||||
#
|
||||
# Environment definitions
|
||||
#
|
||||
#####################################################################
|
||||
|
||||
package Curses::Widgets::Menu;
|
||||
|
||||
use strict;
|
||||
use vars qw($VERSION @ISA);
|
||||
use Carp;
|
||||
use Curses;
|
||||
use Curses::Widgets;
|
||||
use Curses::Widgets::ListBox;
|
||||
|
||||
($VERSION) = (q$Revision: 1.103 $ =~ /(\d+(?:\.(\d+))+)/);
|
||||
@ISA = qw(Curses::Widgets);
|
||||
|
||||
#####################################################################
|
||||
#
|
||||
# Module code follows
|
||||
#
|
||||
#####################################################################
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=head2 new (inherited from Curses::Widgets)
|
||||
|
||||
$menu = Curses::Widgets::Menu->new({
|
||||
INPUTFUNC => \&scankey,
|
||||
FOREGROUND => undef,
|
||||
BACKGROUND => 'black',
|
||||
FOCUSSWITCH => "\t",
|
||||
MENUS => {
|
||||
MENUORDER => [qw(File)],
|
||||
File => {
|
||||
ITEMORDER => [qw(Save Quit)],
|
||||
Save => \&Save,
|
||||
Quit => \&Quit,
|
||||
},
|
||||
CURSORPOS => 'File',
|
||||
BORDER => 1,
|
||||
});
|
||||
|
||||
The new method instantiates a new Menu object. The only mandatory
|
||||
key/value pairs in the configuration hash are B<X> and B<Y>. All others
|
||||
have the following defaults:
|
||||
|
||||
Key Default Description
|
||||
============================================================
|
||||
INPUTFUNC \&scankey Function to use to scan for keystrokes
|
||||
FOREGROUND undef Default foreground colour
|
||||
BACKGROUND 'black' Default background colour
|
||||
FOCUSSWITCH "\t" Characters which signify end of input
|
||||
MENUS {} Menu structure
|
||||
CURSORPOS '' Current position of the cursor
|
||||
BORDER 0 Avoid window borders
|
||||
|
||||
The B<MENUS> option is a hash of hashes, with each hash a separate menu, and
|
||||
the constituent hashes being a Entry/Function pairs. Each hash requires a
|
||||
special key/value pair that determines the order of the items when displayed.
|
||||
Each item is separated by two spaces.
|
||||
|
||||
=cut
|
||||
|
||||
sub _conf {
|
||||
# Validates and initialises the new Menu object.
|
||||
#
|
||||
# Internal use only.
|
||||
|
||||
my $self = shift;
|
||||
my %conf = (
|
||||
INPUTFUNC => \&scankey,
|
||||
FOREGROUND => undef,
|
||||
BACKGROUND => 'black',
|
||||
FOCUSSWITCH => "\t",
|
||||
MENUS => {MENUORDER => []},
|
||||
BORDER => 0,
|
||||
EXIT => 0,
|
||||
CURSORPOS => '',
|
||||
@_
|
||||
);
|
||||
my $err = 0;
|
||||
|
||||
# Set the default CURSORPOS if undefined
|
||||
$conf{CURSORPOS} = $conf{MENUS}{MENUORDER}[0] unless
|
||||
defined $conf{CURSORPOS};
|
||||
|
||||
# Make sure no errors are returned by the parent method
|
||||
$err = 1 unless $self->SUPER::_conf(%conf);
|
||||
|
||||
# Get the updated conf hash
|
||||
%conf = ();
|
||||
%conf = %{$self->{CONF}};
|
||||
|
||||
# Create a listbox as our popup menu
|
||||
$self->{LISTBOX} = Curses::Widgets::ListBox->new({
|
||||
X => 0,
|
||||
Y => 0,
|
||||
LISTITEMS => [],
|
||||
FOREGROUND => $conf{FOREGROUND},
|
||||
BACKGROUND => $conf{BACKGROUND},
|
||||
LINES => 3,
|
||||
COLUMNS => 10,
|
||||
FOCUSSWITCH => "\n\e",
|
||||
INPUTFUNC => $conf{INPUTFUNC},
|
||||
}) unless $err;
|
||||
|
||||
return $err == 0 ? 1 : 0;
|
||||
}
|
||||
|
||||
=head2 draw
|
||||
|
||||
$menu->draw($mwh, 1);
|
||||
|
||||
The draw method renders the menu in its current state. This
|
||||
requires a valid handle to a curses window in which it will render
|
||||
itself. The optional second argument, if true, will cause the selection
|
||||
cursor to be rendered as well.
|
||||
|
||||
=cut
|
||||
|
||||
sub draw {
|
||||
my $self = shift;
|
||||
my $mwh = shift;
|
||||
my $active = shift;
|
||||
my $conf = $self->{CONF};
|
||||
my ($y, $x);
|
||||
|
||||
# Get the parent window's (max|beg)yx and save the info
|
||||
$mwh->getmaxyx($y, $x);
|
||||
$$conf{COLUMNS} = $x;
|
||||
$mwh->getbegyx($y, $x);
|
||||
$self->{BEGYX} = [$y, $x];
|
||||
|
||||
# Call the parent's draw method
|
||||
return $self->SUPER::draw($mwh, $active);
|
||||
}
|
||||
|
||||
sub _geometry {
|
||||
my $self = shift;
|
||||
my $conf = $self->{CONF};
|
||||
my @rv = (1, $$conf{COLUMNS}, 0, 0);
|
||||
|
||||
if ($$conf{BORDER}) {
|
||||
$rv[1] -= 2;
|
||||
@rv[2,3] = (1, 1);
|
||||
}
|
||||
|
||||
return @rv;
|
||||
}
|
||||
|
||||
sub _cgeometry {
|
||||
my $self = shift;
|
||||
my $conf = $self->{CONF};
|
||||
my @rv = (1, $$conf{COLUMNS}, 0, 0);
|
||||
|
||||
$rv[1] -= 2 if $$conf{BORDER};
|
||||
|
||||
return @rv;
|
||||
}
|
||||
|
||||
sub _border {
|
||||
# Make sure no one tries to call this on a menu
|
||||
}
|
||||
|
||||
sub _caption {
|
||||
# Make sure no one tries to call this on a menu
|
||||
}
|
||||
|
||||
sub _content {
|
||||
my $self = shift;
|
||||
my $dwh = shift;
|
||||
my $conf = $self->{CONF};
|
||||
my $menu = $$conf{MENUS};
|
||||
my $label;
|
||||
|
||||
# Print the labels
|
||||
$label = join(' ', @{$$menu{MENUORDER}});
|
||||
carp ref($self), ": Window not wide enough to display all menus!"
|
||||
if length($label) > $$conf{COLUMNS} - 2 * $$conf{BORDER};
|
||||
$dwh->addstr(0, 0, $label);
|
||||
}
|
||||
|
||||
sub _cursor {
|
||||
my $self = shift;
|
||||
my $dwh = shift;
|
||||
my $conf = $self->{CONF};
|
||||
my $menu = $$conf{MENUS};
|
||||
my $pos = $$conf{CURSORPOS};
|
||||
my ($x, $label);
|
||||
|
||||
# Get the x coordinate of the cursor and display the cursor
|
||||
$label = join(' ', @{$$menu{MENUORDER}});
|
||||
if ($label =~ /^(.*\b)\Q$pos\E\b/) {
|
||||
$x = length($1);
|
||||
$dwh->chgat(0, $x, length($pos), A_STANDOUT, select_colour(
|
||||
@$conf{qw(FOREGROUND BACKGROUND)}), 0);
|
||||
}
|
||||
|
||||
$self->_restore($dwh);
|
||||
}
|
||||
|
||||
=head2 popup
|
||||
|
||||
$menu->popup;
|
||||
|
||||
This method causes the menu to be displayed. Since, theoretically, the menu
|
||||
should never be seen unless it's being actively used, we will always assume
|
||||
that we need to draw a cursor on the list as well.
|
||||
|
||||
=cut
|
||||
|
||||
sub popup {
|
||||
my $self = shift;
|
||||
my $conf = $self->{CONF};
|
||||
my ($x, $y, $border) = (@$conf{qw(X Y)}, 1);
|
||||
my $lb = $self->{LISTBOX};
|
||||
my ($pwh, $items, $cp, $in, $rv, $l);
|
||||
|
||||
# Calculate the border column/lines
|
||||
$border *= 2;
|
||||
|
||||
# Create the popup window
|
||||
unless ($pwh = newwin($lb->getField('LINES') + $border,
|
||||
$lb->getField('COLUMNS') + $border, $y, $x)) {
|
||||
carp ref($self), ": Popup creation failed, possible geometry problems";
|
||||
return;
|
||||
}
|
||||
$pwh->keypad(1);
|
||||
|
||||
# Render the list box
|
||||
$rv = $lb->execute($pwh);
|
||||
|
||||
# Release the window
|
||||
$pwh->delwin;
|
||||
|
||||
# Exit now if $rv is an escape
|
||||
return undef if $rv =~ /\e/;
|
||||
|
||||
# Return the menu selection
|
||||
($cp, $items) = $lb->getField(qw(CURSORPOS LISTITEMS));
|
||||
return $$items[$cp] if (defined $cp && scalar @$items);
|
||||
}
|
||||
|
||||
sub input_key {
|
||||
# Process input a keystroke at a time.
|
||||
#
|
||||
# Internal use only.
|
||||
|
||||
my $self = shift;
|
||||
my $in = shift;
|
||||
my $conf = $self->{CONF};
|
||||
my $lb = $self->{LISTBOX};
|
||||
my ($menus, $pos) = @$conf{qw(MENUS CURSORPOS)};
|
||||
my ($width, $height, $x, $y, $i, $j, $item, $rv, $sub, $l);
|
||||
|
||||
return unless @{$$menus{MENUORDER}};
|
||||
|
||||
# Get the current menu index
|
||||
$i = 0;
|
||||
while ($i < @{$$menus{MENUORDER}} &&
|
||||
$$menus{MENUORDER}[$i] ne $pos) { $i++ };
|
||||
$item = $$menus{MENUORDER}[$i];
|
||||
|
||||
# Process special keys
|
||||
if ($in eq KEY_LEFT) {
|
||||
--$i;
|
||||
$i = $#{$$menus{MENUORDER}} if $i < 0;
|
||||
} elsif ($in eq KEY_RIGHT) {
|
||||
++$i;
|
||||
$i = 0 if $i > $#{$$menus{MENUORDER}};
|
||||
|
||||
# Display the Menu
|
||||
} elsif ($in eq KEY_DOWN || $in eq "\n") {
|
||||
|
||||
# Calculate and set popup geometry
|
||||
$x = 0;
|
||||
for (0..$i) {
|
||||
$x += (length($$menus{MENUORDER}[$i]) + 2) if $_ != $i;
|
||||
}
|
||||
$x += 1 if $$conf{BORDER};
|
||||
$x += $self->{BEGYX}->[1];
|
||||
$y = $$conf{BORDER} ? 2 : 1;
|
||||
$y += $self->{BEGYX}->[0];
|
||||
@$conf{qw(Y X)} = ($y, $x);
|
||||
$l = 0;
|
||||
foreach (@{$$menus{$item}{ITEMORDER}}) {
|
||||
$l = length($_) if $l < length($_) };
|
||||
$lb->setField(
|
||||
LISTITEMS => [ @{$$menus{$item}{ITEMORDER}} ],
|
||||
LINES => scalar @{$$menus{$item}{ITEMORDER}},
|
||||
COLUMNS => $l,
|
||||
CURSORPOS => 0,
|
||||
);
|
||||
|
||||
# Display the popup
|
||||
$rv = $self->popup;
|
||||
if (defined $rv) {
|
||||
$$conf{EXIT} = 1;
|
||||
|
||||
# Execute the reference
|
||||
{
|
||||
no strict 'refs';
|
||||
|
||||
$sub = $$menus{$item}{$rv};
|
||||
if (defined $sub) {
|
||||
&$sub();
|
||||
} else {
|
||||
carp ref($self), ": undefined subroutine ($rv) call attempted";
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# Process normal key strokes
|
||||
} else {
|
||||
beep();
|
||||
}
|
||||
|
||||
# Save the changes
|
||||
$pos = $$menus{MENUORDER}[$i];
|
||||
$$conf{CURSORPOS} = $pos;
|
||||
}
|
||||
|
||||
=head2 execute
|
||||
|
||||
$menu->execute;
|
||||
|
||||
This method acts like the standard Curses::Widgets method of the same name,
|
||||
with the exception being that selection of any menu item will also cause it to
|
||||
exit (having already called the associated item subroutine).
|
||||
|
||||
=cut
|
||||
|
||||
sub execute {
|
||||
my $self = shift;
|
||||
my $mwh = shift;
|
||||
my $conf = $self->{CONF};
|
||||
my $menus = $$conf{MENUS};
|
||||
my $func = $$conf{'INPUTFUNC'} || \&scankey;
|
||||
my $regex = $$conf{'FOCUSSWITCH'};
|
||||
my $key;
|
||||
|
||||
# Don't execute unless we have menus to interact with
|
||||
return unless @{$$menus{MENUORDER}};
|
||||
|
||||
# Set the initial focused menu to the first in the list
|
||||
$$conf{CURSORPOS} = $$menus{MENUORDER}[0];
|
||||
$$conf{EXIT} = 0;
|
||||
|
||||
$self->draw($mwh, 1);
|
||||
|
||||
# Enter the scan loop
|
||||
while (1) {
|
||||
$key = &$func($mwh);
|
||||
if (defined $key) {
|
||||
if (defined $regex) {
|
||||
return $key if ($key =~ /^[$regex]/ || ($regex =~ /\t/ &&
|
||||
$key eq KEY_STAB));
|
||||
}
|
||||
$self->input_key($key);
|
||||
}
|
||||
return $key if $$conf{EXIT};
|
||||
$self->draw($mwh, 1);
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=head1 HISTORY
|
||||
|
||||
=over
|
||||
|
||||
=item 2002/10/17 -- First implementation
|
||||
|
||||
=back
|
||||
|
||||
=head1 AUTHOR/COPYRIGHT
|
||||
|
||||
(c) 2001 Arthur Corliss (corliss@digitalmages.com)
|
||||
|
||||
=cut
|
||||
|
||||
@@ -1,276 +0,0 @@
|
||||
# Curses::Widgets::ProgressBar.pm -- Progress Bar Widgets
|
||||
#
|
||||
# (c) 2001, Arthur Corliss <corliss@digitalmages.com>
|
||||
#
|
||||
# $Id: ProgressBar.pm,v 1.103 2002/11/03 23:40:04 corliss Exp corliss $
|
||||
#
|
||||
# This program is free software; you can redistribute it and/or modify
|
||||
# it under the terms of the GNU General Public License as published by
|
||||
# the Free Software Foundation; either version 2 of the License, or
|
||||
# any later version.
|
||||
#
|
||||
# This program is distributed in the hope that it will be useful,
|
||||
# but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
# GNU General Public License for more details.
|
||||
#
|
||||
# You should have received a copy of the GNU General Public License
|
||||
# along with this program; if not, write to the Free Software
|
||||
# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
|
||||
#
|
||||
#####################################################################
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Curses::Widgets::ProgressBar - Progress Bar Widgets
|
||||
|
||||
=head1 MODULE VERSION
|
||||
|
||||
$Id: ProgressBar.pm,v 1.103 2002/11/03 23:40:04 corliss Exp corliss $
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Curses::Widgets::ProgressBar;
|
||||
|
||||
$progress = Curses::Widgets::ProgessBar->({
|
||||
CAPTION => 'Progress',
|
||||
CAPTIONCOL => 'yellow',
|
||||
LENGTH => 10,
|
||||
VALUE => 0,
|
||||
FOREGROUND => undef,
|
||||
BACKGROUND => 'black',
|
||||
BORDER => 1,
|
||||
BORDERCOL => undef,
|
||||
HORIZONTAL => 1,
|
||||
X => 1,
|
||||
Y => 1,
|
||||
MIN => 0,
|
||||
MAX => 100,
|
||||
});
|
||||
|
||||
$progress->draw($mwh);
|
||||
|
||||
$progress->input(5);
|
||||
|
||||
See the Curses::Widgets pod for other methods.
|
||||
|
||||
=head1 REQUIREMENTS
|
||||
|
||||
=over
|
||||
|
||||
=item Curses
|
||||
|
||||
=item Curses::Widgets
|
||||
|
||||
=back
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Curses::Widgets::ProgressBar provides simplified OO access to Curses-based
|
||||
progress bar. Each object maintains it's own state information.
|
||||
|
||||
Note that this widget is designed for rendering, not interactive input. The
|
||||
application should update the the value of the bar by either calling the
|
||||
B<input> method, which will add the passed value to the widget's current
|
||||
value, or by setting the value directly via the B<setField> method.
|
||||
|
||||
=cut
|
||||
|
||||
#####################################################################
|
||||
#
|
||||
# Environment definitions
|
||||
#
|
||||
#####################################################################
|
||||
|
||||
package Curses::Widgets::ProgressBar;
|
||||
|
||||
use strict;
|
||||
use vars qw($VERSION @ISA);
|
||||
use Carp;
|
||||
use Curses;
|
||||
use Curses::Widgets;
|
||||
|
||||
($VERSION) = (q$Revision: 1.103 $ =~ /(\d+(?:\.(\d+))+)/);
|
||||
@ISA = qw(Curses::Widgets);
|
||||
|
||||
#####################################################################
|
||||
#
|
||||
# Module code follows
|
||||
#
|
||||
#####################################################################
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=head2 new (inherited from Curses::Widgets)
|
||||
|
||||
$progress = Curses::Widgets::ProgressBar->({
|
||||
CAPTION => 'Progress',
|
||||
CAPTIONCOL => 'yellow',
|
||||
LENGTH => 10,
|
||||
VALUE => 0,
|
||||
FOREGROUND => undef,
|
||||
BACKGROUND => 'black',
|
||||
BORDER => 1,
|
||||
BORDERCOL => undef,
|
||||
HORIZONTAL => 1,
|
||||
X => 1,
|
||||
Y => 1,
|
||||
MIN => 0,
|
||||
MAX => 100,
|
||||
});
|
||||
|
||||
The new method instantiates a new Progress Bar object. The only mandatory
|
||||
key/value pairs in the configuration hash are B<X> and B<Y>.
|
||||
All others have the following defaults:
|
||||
|
||||
Key Default Description
|
||||
============================================================
|
||||
CAPTION undef Caption superimposed on border
|
||||
CAPTIONCOL undef Foreground colour for caption text
|
||||
LENGTH 10 Number of columns for the bar
|
||||
VALUE 0 Current value
|
||||
FOREGROUND undef Default foreground colour
|
||||
BACKGROUND undef Default blackground colour
|
||||
BORDER 1 Display border around the set
|
||||
BORDERCOL undef Foreground colour for border
|
||||
HORIZONTAL 1 Horizontal orientation for bar
|
||||
MIN 0 Low value for bar (0%)
|
||||
MAX 100 High vlaue for bar (100%)
|
||||
|
||||
Setting the value will change the length of the bar, based on the bounds set
|
||||
with B<MIN> and B<MAX>. The B<CAPTION> is only rendered on the border of a
|
||||
horizontal progress bar.
|
||||
|
||||
=cut
|
||||
|
||||
sub _conf {
|
||||
# Validates and initialises the new TextField object.
|
||||
#
|
||||
# Usage: $self->_conf(%conf);
|
||||
|
||||
my $self = shift;
|
||||
my %conf = (
|
||||
CAPTION => undef,
|
||||
LENGTH => 10,
|
||||
VALUE => 0,
|
||||
BORDER => 1,
|
||||
HORIZONTAL => 1,
|
||||
MIN => 0,
|
||||
MAX => 100,
|
||||
@_
|
||||
);
|
||||
my @required = qw(X Y);
|
||||
my $err = 0;
|
||||
|
||||
$conf{COLUMNS} = $conf{HORIZONTAL} ? $conf{LENGTH} : 0;
|
||||
|
||||
# Check for required arguments
|
||||
foreach (@required) { $err = 1 unless exists $conf{$_} };
|
||||
|
||||
$conf{VALUE} = $conf{MIN} if $conf{VALUE} < $conf{MIN};
|
||||
|
||||
$err = 1 unless $self->SUPER::_conf(%conf);
|
||||
|
||||
return $err == 0 ? 1 : 0;
|
||||
}
|
||||
|
||||
=head2 draw
|
||||
|
||||
$progress->draw($mwh);
|
||||
|
||||
The draw method renders the progress bar in its current state. This
|
||||
requires a valid handle to a curses window in which it will render
|
||||
itself.
|
||||
|
||||
=cut
|
||||
|
||||
sub _geometry {
|
||||
my $self = shift;
|
||||
my $conf = $self->{CONF};
|
||||
my @rv;
|
||||
|
||||
@rv = @$conf{qw(HORIZONTAL LENGTH Y X)};
|
||||
@rv[0,1] = @rv[1,0] unless ($rv[0]);
|
||||
if ($$conf{BORDER}) {
|
||||
$rv[0] += 2;
|
||||
$rv[1] += 2;
|
||||
}
|
||||
|
||||
return @rv;
|
||||
}
|
||||
|
||||
sub _cgeometry {
|
||||
my $self = shift;
|
||||
my $conf = $self->{CONF};
|
||||
my @rv;
|
||||
|
||||
@rv = @$conf{qw(HORIZONTAL LENGTH Y X)};
|
||||
@rv[0,1] = @rv[1,0] unless ($rv[0]);
|
||||
@rv[2,3] = (1, 1) if $$conf{BORDER};
|
||||
|
||||
return @rv;
|
||||
}
|
||||
|
||||
sub _content {
|
||||
my $self = shift;
|
||||
my $dwh = shift;
|
||||
my $conf = $self->{CONF};
|
||||
my ($hz, $value, $length, $min, $max) =
|
||||
@$conf{qw(HORIZONTAL VALUE LENGTH MIN MAX)};
|
||||
my ($i, $j, $k, $l);
|
||||
|
||||
# Draw the bar
|
||||
$i = ($max - $min) / $length;
|
||||
$j = $min;
|
||||
$l = $hz ? 0 : $length - 1;
|
||||
$k = 0;
|
||||
while ($j < $value) {
|
||||
$dwh->addch($k, $l, ACS_CKBOARD);
|
||||
$hz ? ++$l : --$k;
|
||||
$j += $i;
|
||||
}
|
||||
$dwh->attroff(A_BOLD);
|
||||
}
|
||||
|
||||
sub input_key {
|
||||
# Since this widget doesn't handle interactive input,
|
||||
# this routine does nothing.
|
||||
}
|
||||
|
||||
sub execute {
|
||||
# Since this widget doesn't handle interactive input,
|
||||
# this routine does nothing.
|
||||
}
|
||||
|
||||
=head2 input
|
||||
|
||||
$progress->input(5);
|
||||
|
||||
The argument is added to the progress bar's current value.
|
||||
|
||||
=cut
|
||||
|
||||
sub input {
|
||||
my $self = shift;
|
||||
my $value = shift || 0;
|
||||
my $conf = $self->{CONF};
|
||||
|
||||
$$conf{VALUE} += $value;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=head1 HISTORY
|
||||
|
||||
=over
|
||||
|
||||
=item 2001/07/05 -- First implementation
|
||||
|
||||
=back
|
||||
|
||||
=head1 AUTHOR/COPYRIGHT
|
||||
|
||||
(c) 2001 Arthur Corliss (corliss@digitalmages.com)
|
||||
|
||||
=cut
|
||||
|
||||
@@ -1,344 +0,0 @@
|
||||
# Curses::Widgets::TextField.pm -- Text Field Widgets
|
||||
#
|
||||
# (c) 2001, Arthur Corliss <corliss@digitalmages.com>
|
||||
#
|
||||
# $Id: TextField.pm,v 1.103 2002/11/04 00:35:44 corliss Exp corliss $
|
||||
#
|
||||
# This program is free software; you can redistribute it and/or modify
|
||||
# it under the terms of the GNU General Public License as published by
|
||||
# the Free Software Foundation; either version 2 of the License, or
|
||||
# any later version.
|
||||
#
|
||||
# This program is distributed in the hope that it will be useful,
|
||||
# but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
# GNU General Public License for more details.
|
||||
#
|
||||
# You should have received a copy of the GNU General Public License
|
||||
# along with this program; if not, write to the Free Software
|
||||
# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
|
||||
#
|
||||
#####################################################################
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Curses::Widgets::TextField - Text Field Widgets
|
||||
|
||||
=head1 MODULE VERSION
|
||||
|
||||
$Id: TextField.pm,v 1.103 2002/11/04 00:35:44 corliss Exp corliss $
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Curses::Widgets::TextField;
|
||||
|
||||
$tf = Curses::Widgets::TextField->new({
|
||||
CAPTION => 'Name',
|
||||
CAPTIONCOL => 'yellow',
|
||||
COLUMNS => 10,
|
||||
MAXLENGTH => 255,
|
||||
MASK => undef,
|
||||
VALUE => '',
|
||||
INPUTFUNC => \&scankey,
|
||||
FOREGROUND => undef,
|
||||
BACKGROUND => 'black',
|
||||
BORDER => 1,
|
||||
BORDERCOL => 'red',
|
||||
FOCUSSWITCH => "\t\n",
|
||||
CURSORPOS => 0,
|
||||
TEXTSTART => 0,
|
||||
PASSWORD => 0,
|
||||
X => 1,
|
||||
Y => 1,
|
||||
READONLY => 0,
|
||||
});
|
||||
|
||||
$tf->draw($mwh, 1);
|
||||
|
||||
See the Curses::Widgets pod for other methods.
|
||||
|
||||
=head1 REQUIREMENTS
|
||||
|
||||
=over
|
||||
|
||||
=item Curses
|
||||
|
||||
=item Curses::Widgets
|
||||
|
||||
=back
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Curses::Widgets::TextField provides simplified OO access to Curses-based
|
||||
single line text fields. Each object maintains its own state information.
|
||||
|
||||
=cut
|
||||
|
||||
#####################################################################
|
||||
#
|
||||
# Environment definitions
|
||||
#
|
||||
#####################################################################
|
||||
|
||||
package Curses::Widgets::TextField;
|
||||
|
||||
use strict;
|
||||
use vars qw($VERSION @ISA);
|
||||
use Carp;
|
||||
use Curses;
|
||||
use Curses::Widgets;
|
||||
|
||||
($VERSION) = (q$Revision: 1.103 $ =~ /(\d+(?:\.(\d+))+)/);
|
||||
@ISA = qw(Curses::Widgets);
|
||||
|
||||
#####################################################################
|
||||
#
|
||||
# Module code follows
|
||||
#
|
||||
#####################################################################
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=head2 new (inherited from Curses::Widgets)
|
||||
|
||||
$tf = Curses::Widgets::TextField->new({
|
||||
CAPTION => 'Name',
|
||||
CAPTIONCOL => 'yellow',
|
||||
COLUMNS => 10,
|
||||
MAXLENGTH => 255,
|
||||
MASK => undef,
|
||||
VALUE => '',
|
||||
INPUTFUNC => \&scankey,
|
||||
FOREGROUND => undef,
|
||||
BACKGROUND => 'black',
|
||||
BORDER => 1,
|
||||
BORDERCOL => 'red',
|
||||
FOCUSSWITCH => "\t\n",
|
||||
CURSORPOS => 0,
|
||||
TEXTSTART => 0,
|
||||
PASSWORD => 0,
|
||||
X => 1,
|
||||
Y => 1,
|
||||
READONLY => 0,
|
||||
});
|
||||
|
||||
The new method instantiates a new TextField object. The only mandatory
|
||||
key/value pairs in the configuration hash are B<X> and B<Y>. All others
|
||||
have the following defaults:
|
||||
|
||||
Key Default Description
|
||||
============================================================
|
||||
CAPTION undef Caption superimposed on border
|
||||
CAPTIONCOL undef Foreground colour for caption text
|
||||
COLUMNS 10 Number of columns displayed
|
||||
MAXLENGTH 255 Maximum string length allowed
|
||||
MASK undef Not yet implemented
|
||||
VALUE '' Current field text
|
||||
INPUTFUNC \&scankey Function to use to scan for keystrokes
|
||||
FOREGROUND undef Default foreground colour
|
||||
BACKGROUND undef Default background colour
|
||||
BORDER 1 Display a border around the field
|
||||
BORDERCOL undef Foreground colour for border
|
||||
FOCUSSWITCH "\t\n" Characters which signify end of input
|
||||
CURSORPOS 0 Starting position of the cursor
|
||||
TEXTSTART 0 Position in string to start displaying
|
||||
PASSWORD 0 Subsitutes '*' instead of characters
|
||||
READONLY 0 Prevents alteration to content
|
||||
|
||||
The B<CAPTION> is only valid when the B<BORDER> is enabled. If the border
|
||||
is disabled, the field will be underlined, provided the terminal supports it.
|
||||
|
||||
If B<MAXLENGTH> is undefined, no limit will be placed on the string length.
|
||||
|
||||
If B<BORDER> is true, the widget will be enlarged to three columns and two
|
||||
more columns to make room for the border.
|
||||
|
||||
=cut
|
||||
|
||||
sub _conf {
|
||||
# Validates and initialises the new TextField object.
|
||||
#
|
||||
# Usage: $self->_conf(%conf);
|
||||
|
||||
my $self = shift;
|
||||
my %conf = (
|
||||
CAPTION => undef,
|
||||
COLUMNS => 10,
|
||||
LINES => 1,
|
||||
MAXLENGTH => 255,
|
||||
MASK => undef,
|
||||
VALUE => '',
|
||||
INPUTFUNC => \&scankey,
|
||||
BORDER => 1,
|
||||
FOCUSSWITCH => "\t\n",
|
||||
CURSORPOS => 0,
|
||||
TEXTSTART => 0,
|
||||
PASSWORD => 0,
|
||||
READONLY => 0,
|
||||
@_
|
||||
);
|
||||
my @required = qw(X Y);
|
||||
my $err = 0;
|
||||
|
||||
# Check for required arguments
|
||||
foreach (@required) { $err = 1 unless exists $conf{$_} };
|
||||
|
||||
# Make sure no errors are returned by the parent method
|
||||
$err = 1 unless $self->SUPER::_conf(%conf);
|
||||
|
||||
return $err == 0 ? 1 : 0;
|
||||
}
|
||||
|
||||
=head2 draw
|
||||
|
||||
$tf->draw($mwh, 1);
|
||||
|
||||
The draw method renders the text field in its current state. This
|
||||
requires a valid handle to a curses window in which it will render
|
||||
itself. The optional second argument, if true, will cause the field's
|
||||
text cursor to be rendered as well.
|
||||
|
||||
=cut
|
||||
|
||||
sub _content {
|
||||
my $self = shift;
|
||||
my $dwh = shift;
|
||||
my $cursor = shift;
|
||||
my $conf = $self->{CONF};
|
||||
my ($pos, $ts, $value, $border, $col) =
|
||||
@$conf{qw(CURSORPOS TEXTSTART VALUE BORDER COLUMNS)};
|
||||
my $seg;
|
||||
|
||||
# Trim the value if it exceeds the maximum length
|
||||
$value = substr($value, 0, $$conf{MAXLENGTH}) if $$conf{MAXLENGTH};
|
||||
|
||||
# Turn on underlining (terminal-dependent) if no border is used
|
||||
$dwh->attron(A_UNDERLINE) unless $border;
|
||||
|
||||
# Adjust the cursor position and text start if it's out of whack
|
||||
if ($pos > length($value)) {
|
||||
$pos = length($value);
|
||||
} elsif ($pos < 0) {
|
||||
$pos = 0;
|
||||
}
|
||||
if ($pos > $ts + $$conf{COLUMNS} - 1) {
|
||||
$ts = $pos + 1 - $$conf{COLUMNS};
|
||||
} elsif ($pos < $ts) {
|
||||
$ts = $pos;
|
||||
}
|
||||
$ts = 0 if $ts < 0;
|
||||
|
||||
# Write the widget value (adjusting for horizontal scrolling)
|
||||
$seg = substr($value, $ts, $$conf{COLUMNS});
|
||||
$seg = '*' x length($seg) if $$conf{PASSWORD};
|
||||
$seg .= ' ' x ($$conf{COLUMNS} - length($seg));
|
||||
$dwh->addstr(0, 0, $seg);
|
||||
$dwh->attroff(A_BOLD);
|
||||
|
||||
# Underline the field if no border is used
|
||||
$dwh->chgat(0, 0, $col, A_UNDERLINE,
|
||||
select_colour(@$conf{qw(FOREGROUND BACKGROUND)}), 0) unless $border;
|
||||
|
||||
# Save the textstart, cursorpos, and value in case it was tweaked
|
||||
@$conf{qw(TEXTSTART CURSORPOS VALUE)} = ($ts, $pos, $value);
|
||||
}
|
||||
|
||||
sub _cursor {
|
||||
my $self = shift;
|
||||
my $dwh = shift;
|
||||
my $conf = $self->{CONF};
|
||||
|
||||
# Display the cursor
|
||||
$dwh->chgat(0, $$conf{CURSORPOS} - $$conf{TEXTSTART}, 1, A_STANDOUT,
|
||||
select_colour(@$conf{qw(FOREGROUND BACKGROUND)}), 0)
|
||||
unless $$conf{READONLY};
|
||||
|
||||
# Restore the default settings
|
||||
$self->_restore($dwh);
|
||||
}
|
||||
|
||||
sub input_key {
|
||||
# Process input a keystroke at a time.
|
||||
#
|
||||
# Usage: $self->input_key($key);
|
||||
|
||||
my $self = shift;
|
||||
my $in = shift;
|
||||
my $conf = $self->{CONF};
|
||||
my $mask = $$conf{MASK};
|
||||
my ($value, $pos, $max, $ro) =
|
||||
@$conf{qw(VALUE CURSORPOS MAXLENGTH READONLY)};
|
||||
my @string = split(//, $value);
|
||||
|
||||
# Process special keys
|
||||
if ($in eq KEY_BACKSPACE) {
|
||||
return if $ro;
|
||||
if ($pos > 0) {
|
||||
splice(@string, $pos - 1, 1);
|
||||
$value = join('', @string);
|
||||
--$pos;
|
||||
} else {
|
||||
beep;
|
||||
}
|
||||
} elsif ($in eq KEY_RIGHT) {
|
||||
$pos < length($value) ? ++$pos : beep;
|
||||
} elsif ($in eq KEY_LEFT) {
|
||||
$pos > 0 ? --$pos : beep;
|
||||
} elsif ($in eq KEY_HOME) {
|
||||
$pos = 0;
|
||||
} elsif ($in eq KEY_END) {
|
||||
$pos = length($value);
|
||||
|
||||
# Process other keys
|
||||
} else {
|
||||
|
||||
return if $ro || $in !~ /^[[:print:]]$/;
|
||||
|
||||
# Exit if it's a non-printing character
|
||||
return unless $in =~ /^[\w\W]$/;
|
||||
|
||||
# Reject if we're already at the max length
|
||||
if (defined $max && length($value) == $max) {
|
||||
beep;
|
||||
return;
|
||||
|
||||
# Append to the end if the cursor's at the end
|
||||
} elsif ($pos == length($value)) {
|
||||
$value .= $in;
|
||||
|
||||
# Insert the character at the cursor's position
|
||||
} elsif ($pos > 0) {
|
||||
@string = (@string[0..($pos - 1)], $in, @string[$pos..$#string]);
|
||||
$value = join('', @string);
|
||||
|
||||
# Insert the character at the beginning of the string
|
||||
} else {
|
||||
$value = "$in$value";
|
||||
}
|
||||
|
||||
# Increment the cursor's position
|
||||
++$pos;
|
||||
}
|
||||
|
||||
# Save the changes
|
||||
@$conf{qw(VALUE CURSORPOS)} = ($value, $pos);
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=head1 HISTORY
|
||||
|
||||
=over
|
||||
|
||||
=item 1999/12/29 -- Original text field widget in functional model
|
||||
|
||||
=item 2001/07/05 -- First incarnation in OO architecture
|
||||
|
||||
=back
|
||||
|
||||
=head1 AUTHOR/COPYRIGHT
|
||||
|
||||
(c) 2001 Arthur Corliss (corliss@digitalmages.com)
|
||||
|
||||
=cut
|
||||
|
||||
@@ -1,489 +0,0 @@
|
||||
# Curses::Widgets::TextMemo.pm -- Text Memo Widgets
|
||||
#
|
||||
# (c) 2001, Arthur Corliss <corliss@digitalmages.com>
|
||||
#
|
||||
# $Id: TextMemo.pm,v 1.104 2002/11/14 01:27:31 corliss Exp corliss $
|
||||
#
|
||||
# This program is free software; you can redistribute it and/or modify
|
||||
# it under the terms of the GNU General Public License as published by
|
||||
# the Free Software Foundation; either version 2 of the License, or
|
||||
# any later version.
|
||||
#
|
||||
# This program is distributed in the hope that it will be useful,
|
||||
# but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
# GNU General Public License for more details.
|
||||
#
|
||||
# You should have received a copy of the GNU General Public License
|
||||
# along with this program; if not, write to the Free Software
|
||||
# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
|
||||
#
|
||||
#####################################################################
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Curses::Widgets::TextMemo - Text Memo Widgets
|
||||
|
||||
=head1 MODULE VERSION
|
||||
|
||||
$Id: TextMemo.pm,v 1.104 2002/11/14 01:27:31 corliss Exp corliss $
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Curses::Widgets::TextMemo;
|
||||
|
||||
$tm = Curses::Widgets::TextMemo->new({
|
||||
CAPTION => 'Memo',
|
||||
CAPTIONCOL => 'blue',
|
||||
COLUMNS => 10,
|
||||
MAXLENGTH => undef,
|
||||
LINES => 3,
|
||||
MASK => undef,
|
||||
VALUE => '',
|
||||
INPUTFUNC => \&scankey,
|
||||
FOREGROUND => 'white',
|
||||
BACKGROUND => 'black',
|
||||
BORDER => 1,
|
||||
BORDERCOL => 'red',
|
||||
FOCUSSWITCH => "\t",
|
||||
CURSORPOS => 0,
|
||||
TEXTSTART => 0,
|
||||
PASSWORD => 0,
|
||||
X => 1,
|
||||
Y => 1,
|
||||
READONLY => 0,
|
||||
});
|
||||
|
||||
$tm->draw($mwh, 1);
|
||||
|
||||
See the Curses::Widgets pod for other methods.
|
||||
|
||||
=head1 REQUIREMENTS
|
||||
|
||||
=over
|
||||
|
||||
=item Curses
|
||||
|
||||
=item Curses::Widgets
|
||||
|
||||
=back
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Curses::Widgets::TextMemo provides simplified OO access to Curses-based
|
||||
single line text fields. Each object maintains its own state information.
|
||||
|
||||
=cut
|
||||
|
||||
#####################################################################
|
||||
#
|
||||
# Environment definitions
|
||||
#
|
||||
#####################################################################
|
||||
|
||||
package Curses::Widgets::TextMemo;
|
||||
|
||||
use strict;
|
||||
use vars qw($VERSION @ISA);
|
||||
use Carp;
|
||||
use Curses;
|
||||
use Curses::Widgets;
|
||||
|
||||
($VERSION) = (q$Revision: 1.104 $ =~ /(\d+(?:\.(\d+))+)/);
|
||||
@ISA = qw(Curses::Widgets);
|
||||
|
||||
#####################################################################
|
||||
#
|
||||
# Module code follows
|
||||
#
|
||||
#####################################################################
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=head2 new (inherited from Curses::Widgets)
|
||||
|
||||
$tm = Curses::Widgets::TextMemo->new({
|
||||
CAPTION => 'Memo',
|
||||
CAPTIONCOL => 'blue',
|
||||
COLUMNS => 10,
|
||||
MAXLENGTH => undef,
|
||||
LINES => 3,
|
||||
MASK => undef,
|
||||
VALUE => '',
|
||||
INPUTFUNC => \&scankey,
|
||||
FOREGROUND => 'white',
|
||||
BACKGROUND => 'black',
|
||||
BORDER => 1,
|
||||
BORDERCOL => 'red',
|
||||
FOCUSSWITCH => "\t",
|
||||
CURSORPOS => 0,
|
||||
TEXTSTART => 0,
|
||||
PASSWORD => 0,
|
||||
X => 1,
|
||||
Y => 1,
|
||||
READONLY => 0,
|
||||
});
|
||||
|
||||
The new method instantiates a new TextMemo object. The only mandatory
|
||||
key/value pairs in the configuration hash are B<X> and B<Y>. All others
|
||||
have the following defaults:
|
||||
|
||||
Key Default Description
|
||||
============================================================
|
||||
CAPTION undef Caption superimposed on border
|
||||
CAPTIONCOL undef Foreground colour for caption text
|
||||
COLUMNS 10 Number of columns displayed
|
||||
MAXLENGTH undef Maximum string length allowed
|
||||
LINES 3 Number of lines in the window
|
||||
VALUE '' Current field text
|
||||
INPUTFUNC \&scankey Function to use to scan for keystrokes
|
||||
FOREGROUND undef Default foreground colour
|
||||
BACKGROUND undef Default background colour
|
||||
BORDER 1 Display a border around the field
|
||||
BORDERCOL undef Foreground colour for border
|
||||
FOCUSSWITCH "\t" Characters which signify end of input
|
||||
CURSORPOS 0 Starting position of the cursor
|
||||
TEXTSTART 0 Line number of string to start
|
||||
displaying
|
||||
PASSWORD 0 Subsitutes '*' instead of characters
|
||||
READONLY 0 Prevents alteration to content
|
||||
|
||||
The B<CAPTION> is only valid when the B<BORDER> is enabled. If the border
|
||||
is disabled, the field will be underlined, provided the terminal supports it.
|
||||
The B<MAXLENGTH> has no effect if left undefined.
|
||||
|
||||
=cut
|
||||
|
||||
sub _conf {
|
||||
# Validates and initialises the new TextMemo object.
|
||||
#
|
||||
# Usage: $self->_conf(%conf);
|
||||
|
||||
my $self = shift;
|
||||
my %conf = (
|
||||
COLUMNS => 10,
|
||||
MAXLENGTH => undef,
|
||||
LINES => 3,
|
||||
VALUE => '',
|
||||
INPUTFUNC => \&scankey,
|
||||
BORDER => 1,
|
||||
UNDERLINE => 1,
|
||||
FOCUSSWITCH => "\t",
|
||||
CURSORPOS => 0,
|
||||
TEXTSTART => 0,
|
||||
PASSWORD => 0,
|
||||
READONLY => 0,
|
||||
@_
|
||||
);
|
||||
my @required = qw(X Y);
|
||||
my $err = 0;
|
||||
|
||||
# Check for required arguments
|
||||
foreach (@required) { $err = 1 unless exists $conf{$_} };
|
||||
|
||||
# Make sure no errors are returned by the parent method
|
||||
$err = 1 unless $self->SUPER::_conf(%conf);
|
||||
|
||||
return $err == 0 ? 1 : 0;
|
||||
}
|
||||
|
||||
=head2 draw
|
||||
|
||||
$tm->draw($mwh, 1);
|
||||
|
||||
The draw method renders the text memo in its current state. This
|
||||
requires a valid handle to a curses window in which it will render
|
||||
itself. The optional second argument, if true, will cause the field's
|
||||
text cursor to be rendered as well.
|
||||
|
||||
=cut
|
||||
|
||||
sub _border {
|
||||
my $self = shift;
|
||||
my $dwh = shift;
|
||||
my $conf = $self->{CONF};
|
||||
my ($border, $ts, $pos, $value, $lines) =
|
||||
@$conf{qw(BORDER TEXTSTART CURSORPOS VALUE LINES)};
|
||||
my (@lines, $v, $i, $y, $x);
|
||||
|
||||
# Massage the value as needed, and split the result
|
||||
$value = '' unless defined $value;
|
||||
$value = substr($value, 0, $$conf{MAXLENGTH}) if
|
||||
defined $$conf{MAXLENGTH};
|
||||
@lines = textwrap($value, $$conf{COLUMNS} - 1);
|
||||
|
||||
# Adjust the cursor position and text start line if they're out of whack
|
||||
$pos = $pos < 0 ? 0 : ($pos > length($value) ? $pos = length($value) :
|
||||
$pos);
|
||||
$ts = $#lines if $ts > $#lines;
|
||||
$ts = 0 if $ts < 0;
|
||||
if ($ts > 0 && $pos < length(join('', @lines[0..($ts - 1)]))) {
|
||||
$v = length(join('', @lines[0..($ts - 1)]));
|
||||
$i = $ts - 1;
|
||||
until ($v <= $pos) {
|
||||
$v -= length($lines[$i]);
|
||||
--$i;
|
||||
}
|
||||
$ts = $i > 0 ? $i : 0;
|
||||
++$ts unless $pos < length($lines[0]);
|
||||
} elsif ($ts + $lines - 1 < $#lines &&
|
||||
$pos >= length(join('', @lines[0..($ts + $lines - 1)]))) {
|
||||
$v = length(join('', @lines[0..($ts + $lines - 1)]));
|
||||
$i = $ts + $lines;
|
||||
until ($v >= $pos) {
|
||||
$v += length($lines[$i]);
|
||||
++$i;
|
||||
}
|
||||
$ts = $i - $lines;
|
||||
++$ts if $pos == $v;
|
||||
}
|
||||
++$ts if $pos == length($value) and $ts + $lines == @lines;
|
||||
|
||||
# Save the adjust values
|
||||
@$conf{qw(TEXTSTART CURSORPOS VALUE)} = ($ts, $pos, $value);
|
||||
$self->{SPLIT} = [@lines];
|
||||
|
||||
# Render the border
|
||||
if ($border) {
|
||||
|
||||
# Call the parent method
|
||||
$self->SUPER::_border($dwh);
|
||||
|
||||
# Place the arrows
|
||||
$dwh->getmaxyx($y, $x);
|
||||
$dwh->addch(0, $x - 2, ACS_UARROW) if $ts > 0;
|
||||
$dwh->addch($y - 1, $x - 2, ACS_DARROW)
|
||||
if $#lines - $ts > $lines;
|
||||
}
|
||||
}
|
||||
|
||||
sub _content {
|
||||
my $self = shift;
|
||||
my $dwh = shift;
|
||||
my $conf = $self->{CONF};
|
||||
my ($border, $ts, $pos, $lines, $cols) =
|
||||
@$conf{qw(BORDER TEXTSTART CURSORPOS LINES COLUMNS)};
|
||||
my @lines = @{$self->{SPLIT}};
|
||||
my ($i, $j);
|
||||
|
||||
# Print the lines
|
||||
$j = 0;
|
||||
for ($i = $ts; $i < $ts + $lines; $i++) {
|
||||
unless ($i > $#lines) {
|
||||
$$conf{PASSWORD} ?
|
||||
$dwh->addstr($j, 0, '*' x length($lines[$i])) :
|
||||
$dwh->addstr($j, 0, $lines[$i]) ;
|
||||
}
|
||||
|
||||
# Underline each line if there's no border
|
||||
$dwh->chgat($j, 0, $cols, A_UNDERLINE,
|
||||
select_colour(@$conf{qw(FOREGROUND BACKGROUND)}), 0) unless $border;
|
||||
|
||||
$j++;
|
||||
}
|
||||
}
|
||||
|
||||
sub _cursor {
|
||||
my $self = shift;
|
||||
my $dwh = shift;
|
||||
my $conf = $self->{CONF};
|
||||
my ($pos, $ts) = @$conf{qw(CURSORPOS TEXTSTART)};
|
||||
my @lines = @{$self->{SPLIT}};
|
||||
my $i = 0;
|
||||
my $v = 0;
|
||||
my $seg;
|
||||
|
||||
$v = length(join('', @lines[0..($ts - 1)])) if $ts > 0;
|
||||
while ($ts + $i < $#lines && $v + length($lines[$ts + $i]) <= $pos) {
|
||||
$v += length($lines[$ts + $i]);
|
||||
++$i;
|
||||
}
|
||||
$v = $pos - $v;
|
||||
#$i-- if $i > 0 and substr($$conf{VALUE}, $pos - 1, 1) eq "\n";
|
||||
if ($pos == length($$conf{VALUE}) && substr($$conf{VALUE}, $pos - 1, 1) eq
|
||||
"\n") {
|
||||
++$i;
|
||||
$v = 0;
|
||||
}
|
||||
|
||||
$dwh->chgat($i, $v, 1, A_STANDOUT,
|
||||
select_colour(@$conf{qw(FOREGROUND BACKGROUND)}), 0);
|
||||
|
||||
$self->_restore($dwh);
|
||||
}
|
||||
|
||||
sub input_key {
|
||||
# Process input a keystroke at a time.
|
||||
#
|
||||
# Usage: $self->input_key($key);
|
||||
|
||||
my $self = shift;
|
||||
my $in = shift;
|
||||
my $conf = $self->{CONF};
|
||||
my ($value, $pos, $max, $ro, $ts) =
|
||||
@$conf{qw(VALUE CURSORPOS MAXLENGTH READONLY TEXTSTART)};
|
||||
my @string = split(//, $value);
|
||||
my @lines = @{$self->{SPLIT}};
|
||||
my ($snippet, $i, $lpos, $l);
|
||||
|
||||
# Process special keys
|
||||
if ($in eq KEY_BACKSPACE) {
|
||||
return if $ro;
|
||||
if ($pos > 0) {
|
||||
splice(@string, $pos - 1, 1);
|
||||
$value = join('', @string);
|
||||
--$pos;
|
||||
} else {
|
||||
beep;
|
||||
}
|
||||
} elsif ($in eq KEY_RIGHT) {
|
||||
$pos < length($value) ? ++$pos : beep;
|
||||
} elsif ($in eq KEY_LEFT) {
|
||||
$pos > 0 ? --$pos : beep;
|
||||
} elsif ($in eq KEY_UP || $in eq KEY_DOWN ||
|
||||
$in eq KEY_NPAGE || $in eq KEY_PPAGE) {
|
||||
|
||||
# Exit early if there's no text
|
||||
unless (length($value) > 0) {
|
||||
beep;
|
||||
return;
|
||||
}
|
||||
|
||||
# Get the text length up to the displayed window
|
||||
$snippet = $ts == 0 ? 0 : length(join('', @lines[0..($ts - 1)]));
|
||||
|
||||
# Get the position of the cursor relative to the line it's on,
|
||||
# as well as the line index
|
||||
if ($pos == length($value)) {
|
||||
$l = $#lines;
|
||||
$lpos = length($lines[$#lines]);
|
||||
} else {
|
||||
$i = 0;
|
||||
while ($snippet + length($lines[$ts + $i]) <= $pos) {
|
||||
$snippet += length($lines[$ts + $i]);
|
||||
++$i;
|
||||
}
|
||||
$l = $ts + $i;
|
||||
$lpos = $pos - $snippet;
|
||||
}
|
||||
|
||||
# Process according to the key
|
||||
if ($in eq KEY_UP) {
|
||||
if ($l > 0) {
|
||||
if (length($lines[$l - 1]) >= $lpos) {
|
||||
$pos -= length($lines[$l - 1]);
|
||||
} else {
|
||||
$pos -= ($lpos + 1);
|
||||
}
|
||||
} else {
|
||||
beep;
|
||||
}
|
||||
} elsif ($in eq KEY_DOWN) {
|
||||
if ($l < $#lines) {
|
||||
if (length($lines[$l + 1]) >= $lpos) {
|
||||
$pos += length($lines[$l]);
|
||||
} else {
|
||||
$pos += ((length($lines[$l]) - $lpos) +
|
||||
length($lines[$l + 1]) - 1);
|
||||
}
|
||||
} else {
|
||||
beep;
|
||||
}
|
||||
} elsif ($in eq KEY_PPAGE) {
|
||||
if ($l >= $$conf{LINES}) {
|
||||
$pos -= length(join('',
|
||||
@lines[(1 + $l - $$conf{LINES})..($l - 1)]));
|
||||
if (length($lines[$l - $$conf{LINES}]) > $lpos) {
|
||||
$pos -= length($lines[$l - $$conf{LINES}]);
|
||||
} else {
|
||||
$pos -= ($lpos + 1);
|
||||
}
|
||||
} elsif ($l > 0) {
|
||||
if ($lpos > length($lines[0])) {
|
||||
$pos = length($lines[0]) - 1;
|
||||
} else {
|
||||
$pos = $lpos;
|
||||
}
|
||||
} else {
|
||||
beep;
|
||||
}
|
||||
} elsif ($in eq KEY_NPAGE) {
|
||||
if ($l <= $#lines - $$conf{LINES}) {
|
||||
$pos += length(join('',
|
||||
@lines[($l + 1) ..($l + $$conf{LINES} - 1)]));
|
||||
if (length($lines[$l + $$conf{LINES}]) >= $lpos) {
|
||||
$pos += (length($lines[$l + $$conf{LINES}]) + 1);
|
||||
} else {
|
||||
$pos += ((length($lines[$l]) - $lpos) +
|
||||
length($lines[$l + $$conf{LINES}]) - 1);
|
||||
}
|
||||
} elsif ($l < $#lines) {
|
||||
if (length($lines[$#lines]) > $lpos) {
|
||||
$pos = length($value) - (length($lines[$#lines]) -
|
||||
$lpos);
|
||||
} else {
|
||||
$pos = length($value);
|
||||
}
|
||||
} else {
|
||||
beep;
|
||||
}
|
||||
}
|
||||
|
||||
} elsif ($in eq KEY_HOME) {
|
||||
$pos = 0;
|
||||
} elsif ($in eq KEY_END) {
|
||||
$pos = length($value);
|
||||
|
||||
# Process other keys
|
||||
} else {
|
||||
|
||||
return if $ro || $in !~ /^[[:print:]]$/;
|
||||
|
||||
# Exit if it's a non-printing character
|
||||
return unless $in =~ /^[\w\W]$/;
|
||||
|
||||
# Reject if we're already at the max length
|
||||
if (defined $max && length($value) == $max) {
|
||||
beep;
|
||||
return;
|
||||
|
||||
# Append to the end if the cursor's at the end
|
||||
} elsif ($pos == length($value)) {
|
||||
$value .= $in;
|
||||
|
||||
# Insert the character at the cursor's position
|
||||
} elsif ($pos > 0) {
|
||||
@string = (@string[0..($pos - 1)], $in, @string[$pos..$#string]);
|
||||
$value = join('', @string);
|
||||
|
||||
# Insert the character at the beginning of the string
|
||||
} else {
|
||||
$value = "$in$value";
|
||||
}
|
||||
|
||||
# Increment the cursor's position
|
||||
++$pos;
|
||||
}
|
||||
|
||||
# Save the changes
|
||||
@$conf{qw(VALUE CURSORPOS TEXTSTART)} = ($value, $pos, $ts);
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=head1 HISTORY
|
||||
|
||||
=over
|
||||
|
||||
=item 1999/12/29 -- Original text field widget in functional model
|
||||
|
||||
=item 2001/07/05 -- First incarnation in OO architecture
|
||||
|
||||
=back
|
||||
|
||||
=head1 AUTHOR/COPYRIGHT
|
||||
|
||||
(c) 2001 Arthur Corliss (corliss@digitalmages.com)
|
||||
|
||||
=cut
|
||||
|
||||
@@ -1,230 +0,0 @@
|
||||
# Curses::Widget::Tutorial.pod -- Widget Usage Tutorial
|
||||
#
|
||||
# (c) 2001, Arthur Corliss <corliss@digitalmages.com>
|
||||
#
|
||||
# $Id: Tutorial.pod,v 1.2 2002/11/04 00:44:04 corliss Exp corliss $
|
||||
#
|
||||
# This program is free software; you can redistribute it and/or modify
|
||||
# it under the terms of the GNU General Public License as published by
|
||||
# the Free Software Foundation; either version 2 of the License, or
|
||||
# any later version.
|
||||
#
|
||||
# This program is distributed in the hope that it will be useful,
|
||||
# but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
# GNU General Public License for more details.
|
||||
#
|
||||
# You should have received a copy of the GNU General Public License
|
||||
# along with this program; if not, write to the Free Software
|
||||
# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
|
||||
#
|
||||
#####################################################################
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Curses::Widget::Tutorial -- Widget Usage Tutorial
|
||||
|
||||
=head1 POD VERSION
|
||||
|
||||
$Id: Tutorial.pod,v 1.2 2002/11/04 00:44:04 corliss Exp corliss $
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Usage of any given widget is fairly simple, but plenty of flexibility is built
|
||||
into the system in order to allow you to completely control every aspect of
|
||||
their behaviour.
|
||||
|
||||
=head2 ENVIRONMENT
|
||||
|
||||
Due to the usage of Curses constants and the way that the screen is
|
||||
controlled, care must be taken in how the running environment is set up. To
|
||||
begin, one would initiate a Curses session on the console in a typical
|
||||
fashion:
|
||||
|
||||
$mwh = new Curses;
|
||||
|
||||
We then turn off echoing, since the widgets will determine what and were any
|
||||
input is sent to the display:
|
||||
|
||||
noecho();
|
||||
|
||||
I typically use half-blocking input reads, since there may be periodic
|
||||
routines that I want to run while waiting for input. If you're comfortable
|
||||
with that, you can do the same:
|
||||
|
||||
halfdelay(5);
|
||||
|
||||
Next, I turned on cooked input, since the widgets make heavy use of constants
|
||||
for recognising special keys:
|
||||
|
||||
$mwh->keypad(1);
|
||||
|
||||
Finally, we set the cursor visibility to invisible, since the widgets will
|
||||
provide their own as necessary:
|
||||
|
||||
curs_set(0);
|
||||
|
||||
From this point, we're not ready to start splashing widgets to the screen and
|
||||
start handling input.
|
||||
|
||||
=head1 USAGE INSTRUCTIONS
|
||||
|
||||
=head2 BASIC USAGE
|
||||
|
||||
When using the widgets, you must have B<use> line for each type of widget used
|
||||
in your program. In addition, it's good practice to include the base class as
|
||||
well, since it provides some useful functions for handling both reading input
|
||||
and managing colour pairs.
|
||||
|
||||
Example:
|
||||
========
|
||||
|
||||
use Curses;
|
||||
use Curses::Widgets;
|
||||
use Curses::Widgets::TextField;
|
||||
|
||||
# Initialise the environment
|
||||
$mwh = new Curses;
|
||||
noecho();
|
||||
halfdelay(5);
|
||||
$mwh->keypad(1);
|
||||
curs_set(0);
|
||||
|
||||
Next, we instantiate the widget(s) we want to use.
|
||||
|
||||
$tf = Curses::Widgets::TextField->new({
|
||||
X => 5,
|
||||
Y => 5,
|
||||
COLUMNS => 10,
|
||||
CAPTION => 'Login'
|
||||
});
|
||||
|
||||
One thing you need to remember is that B<COLUMNS> (and B<LINES>, for those
|
||||
widgets that support it) always pertain to the I<content> area in the widget.
|
||||
If the widget supports a bordered mode, the actual dimensions will increase by
|
||||
two in both the Y and the X axis. In other words, since TextFields have
|
||||
borders on by default, the actual number of columns and lines that will be
|
||||
used by the above widget is 10 and 3, respectively.
|
||||
|
||||
To cause the widget to display itself, call the B<draw> method:
|
||||
|
||||
$tf->draw($mwh, 0);
|
||||
|
||||
The first argument is a handle to the window in which you want the widget to
|
||||
draw itself. All widgets are drawn in derived windows. The second argument
|
||||
should be a Perlish boolean value which instructs the draw method whether or
|
||||
not to draw the cursor.
|
||||
|
||||
When you're ready to accept input, the simplest method is to use the
|
||||
B<execute> method:
|
||||
|
||||
$tf->execute($mwh);
|
||||
|
||||
This method is a blocking call until the widget is fed a character matching
|
||||
the class defined by FOCUSSWITCH ([\n\t] by default). Until it recieves a
|
||||
matching character, the widget will respond appropriately to all user input
|
||||
and update the display automatically.
|
||||
|
||||
Once the B<execute> method call exits, you can retrieve the final value of the
|
||||
widget via the B<getField> method:
|
||||
|
||||
$login = $tf->getField('VALUE');
|
||||
|
||||
=head2 ADVANCED USAGE
|
||||
|
||||
You may have a need to run period routines while waiting for (or handling)
|
||||
user input. The simplest way add this functionality is to create your own
|
||||
input handler. The default handler (provided by Curses::Widgets: B<scankey>)
|
||||
is coded as such:
|
||||
|
||||
sub scankey {
|
||||
my $mwh = shift;
|
||||
my $key = -1;
|
||||
|
||||
while ($key eq -1) {
|
||||
$key = $mwh->getch;
|
||||
}
|
||||
|
||||
return $key;
|
||||
}
|
||||
|
||||
If, for example, we wanted that function to update a clock (the actual code
|
||||
for which we'll pretend is in the B<update_clock> function) we could insert
|
||||
that call inside of our new input handler's while loop:
|
||||
|
||||
sub myscankey {
|
||||
my $mwh = shift;
|
||||
my $key = -1;
|
||||
|
||||
while ($key eq -1) {
|
||||
$key = $mwh->getch;
|
||||
update_clock($mwh);
|
||||
}
|
||||
|
||||
return $key;
|
||||
}
|
||||
|
||||
We can then hand this function to the widgets during instantiation, or via the
|
||||
B<setField> method:
|
||||
|
||||
$tf = Curses::Widgets::TextField->new({
|
||||
X => 5,
|
||||
Y => 5,
|
||||
INPUTFUNC => \&myscankey
|
||||
});
|
||||
|
||||
-- Or --
|
||||
|
||||
$tf->setField(INPUTFUNC => \&myscankey);
|
||||
|
||||
Another way to handle this is to set up your own loop, and instead of each
|
||||
widget calling it privately, handle all input yourself, sending it to the
|
||||
appropriate widget via each widget's B<input> method:
|
||||
|
||||
while (1) {
|
||||
|
||||
while ($key eq -1) {
|
||||
$key = $mwh->getch;
|
||||
update_clock($mwh);
|
||||
}
|
||||
|
||||
# Send numbers to one field
|
||||
if ($key =~ /^\d$/) {
|
||||
$tf1->input($key);
|
||||
|
||||
# Send alphas to another
|
||||
} elsif ($key =~ /^\w$/) {
|
||||
$tf2->input($key);
|
||||
|
||||
# Send KEY_UP/DOWN to a list box
|
||||
} elsif ($key eq KEY_UP || $key eq KEY_DOWN) {
|
||||
$lb->input($key);
|
||||
}
|
||||
|
||||
# Update the display
|
||||
foreach ($tf1, $tf2, $lb) {
|
||||
$_->draw($mwh, 0);
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
This is a rather simplistic example, but hopefully the applications of this
|
||||
are obvious. One could easily set hot key sequences for switching focus to
|
||||
various widgets, or use input from one widget to update another, and so on.
|
||||
|
||||
=head2 CONCLUSION
|
||||
|
||||
That, in a nutshell, is how to use the widgets. Hopefully the system is
|
||||
flexible enough to be bound to the event model and input systems of your
|
||||
choice.
|
||||
|
||||
=head1 HISTORY
|
||||
|
||||
2001/12/09 -- First draft.
|
||||
|
||||
=head1 AUTHOR/COPYRIGHT
|
||||
|
||||
(c) 2001 Arthur Corliss (corliss@digitalmages.com)
|
||||
|
||||
=cut
|
||||
|
||||
@@ -1,217 +0,0 @@
|
||||
# Curses::Widget::Tutorial::Creation.pod -- Widget Creation Tutorial
|
||||
#
|
||||
# (c) 2001, Arthur Corliss <corliss@digitalmages.com>
|
||||
#
|
||||
# $Id: Creation.pod,v 0.3 2002/11/04 00:45:06 corliss Exp corliss $
|
||||
#
|
||||
# This program is free software; you can redistribute it and/or modify
|
||||
# it under the terms of the GNU General Public License as published by
|
||||
# the Free Software Foundation; either version 2 of the License, or
|
||||
# any later version.
|
||||
#
|
||||
# This program is distributed in the hope that it will be useful,
|
||||
# but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
# GNU General Public License for more details.
|
||||
#
|
||||
# You should have received a copy of the GNU General Public License
|
||||
# along with this program; if not, write to the Free Software
|
||||
# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
|
||||
#
|
||||
#####################################################################
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Curses::Widget::Tutorial::Creation -- Widget Creation Tutorial
|
||||
|
||||
=head1 POD VERSION
|
||||
|
||||
$Id: Creation.pod,v 0.3 2002/11/04 00:45:06 corliss Exp corliss $
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Creating a custom widget is as easy as creating a descendant class of
|
||||
B<Curses::Widget> and defining as few as four methods:
|
||||
|
||||
Method Purpose
|
||||
====================================================
|
||||
_conf Validates configurations options and
|
||||
initialises the internal state/data
|
||||
_content Renders the widget according to the
|
||||
current state
|
||||
_cursor Renders the widget cursor according to the
|
||||
current state
|
||||
input_key Updates the state information according
|
||||
to the passed character input
|
||||
|
||||
=head2 BASIC MODULE STRUCTURE
|
||||
|
||||
A decent code template for custom widgets would start with the following
|
||||
(we'll call our new widget B<MyWidget>):
|
||||
|
||||
package MyWidget;
|
||||
|
||||
use strict;
|
||||
use vars qw($VERSION @ISA);
|
||||
use Curses;
|
||||
use Curses::Widget;
|
||||
|
||||
($VERSION) = (q$Revision: 0.3 $ =~ /(\d+(?:\.(\d+))+)/);
|
||||
@ISA = qw(Curses::Widget);
|
||||
|
||||
Please note that the B<use Curses::Widget;> statment provides more than just a
|
||||
base class to inherit methods from, it also imports standard functions for
|
||||
use in the module:
|
||||
|
||||
Function Purpose
|
||||
===========================================================
|
||||
select_colour Initialises new colour pairs, and returns
|
||||
the appropriate colour pair number, for use
|
||||
with $wh->attrset(COLOR_PAIR($n)) calls.
|
||||
select_color, the American English spelling,
|
||||
also works.
|
||||
scankey This blocks until a key is pressed, and that
|
||||
key returned.
|
||||
textwrap Splits the text given into lines no longer
|
||||
than the column limit specified.
|
||||
|
||||
See the B<Curses::Widget> pod for the specific syntax.
|
||||
|
||||
Descendent classes will automatically know the following fields (as used by
|
||||
the B<new> or B<get/setField> methods):
|
||||
|
||||
Field Type Description
|
||||
===========================================================
|
||||
Y int Y coordinate of upper left corner of widget
|
||||
X int X coordinate of upper left corner of widget
|
||||
LINES int Number of lines in the content area of the widget
|
||||
COLUMNS int Number of columsn inthe content area
|
||||
BORDER boolean Whether to surround the widget with a box
|
||||
CAPTION string Caption to display on top of border
|
||||
FOREGROUND string Default foreground colour
|
||||
BACKGROUND string Default background colour
|
||||
BORDERCOL string Default border foreground colour
|
||||
CAPTIONCOL string Default caption foreground colour
|
||||
|
||||
The colours, if not specified during widget instantiation, will default to the
|
||||
colours in colour pair 0 (the terminal default). Borders will only be drawn
|
||||
if BORDER is true, and that decision is made in the default B<_border> method,
|
||||
not in the B<draw> method. The B<_caption> method also decides internally
|
||||
whether or not to draw itself according to the value of BORDER.
|
||||
|
||||
=head2 METHOD SEMANTICS
|
||||
|
||||
The _conf method is called by the class constructor (provided by
|
||||
B<Curses::Widget>, unless you override it here as well). Widget objects
|
||||
should be created with all configuration options passed in a hash ref:
|
||||
|
||||
$widget = Curses::Widget::MyWidget->new({
|
||||
OPTION1 => $value1,
|
||||
OPTION2 => $value2,
|
||||
[. . .]
|
||||
});
|
||||
|
||||
The configuration hash is dereferenced and passed as arguments to the _conf
|
||||
method inside of the B<new> constructor:
|
||||
|
||||
$rv = $self->_conf(%$conf);
|
||||
|
||||
Because of this, the _conf method should probably begin along these lines:
|
||||
|
||||
sub _conf {
|
||||
my $self = shift;
|
||||
my %conf = (
|
||||
OPTION1 => default1,
|
||||
OPTION2 => default2,
|
||||
[. . .],
|
||||
@_
|
||||
);
|
||||
my $err = 0;
|
||||
|
||||
# Validate and initialise the widget's state
|
||||
# and store in the %conf hash
|
||||
|
||||
# Always include the following
|
||||
$err = 1 unless $self->SUPER::_conf(%conf);
|
||||
|
||||
return ($err == 0) ? 1 : 0;
|
||||
}
|
||||
|
||||
You should perform any initialisation and validation of the configuration
|
||||
options here. This routine is expected to return a true or false value,
|
||||
depending on whether or not any critical errors were found. A false value
|
||||
will prevent the B<new> constructor from returning an object reference,
|
||||
causing the instantiation request to fail.
|
||||
|
||||
The last two lines of code should always be included in this subroutine. The
|
||||
call to the parent class' _conf method stores the final initialised state
|
||||
information in %conf in the object field B<CONF>, after initialising many of
|
||||
the standard colour fields, should they have been left undefined. You can
|
||||
retrieve and update the state information via $self->{CONF}. A copy of that
|
||||
state information will be stored in $self->{OCONF}, and can be restored with
|
||||
a call to B<reset>, a method provided by B<Curses::Widgets>.
|
||||
|
||||
The second method you should override is the B<_content> method. This method,
|
||||
as mentioned above, is responsible for rendering the widget according to its
|
||||
state information. This method should handle one arguments:
|
||||
|
||||
$widget->_content($cwh);
|
||||
|
||||
The argument will be a window handle to the I<content area> of the widget.
|
||||
You should always layout your widget with the upper left corner as (0, 0),
|
||||
since the B<draw> method is responsible for allocating any extra space needed
|
||||
for borders and captions.
|
||||
|
||||
If your widget doesn't support borders and/or captions you can do one of two
|
||||
things: override those methods (B<_border> and B<_caption>) to immediately
|
||||
return without doing anything, or override the B<draw> method to exclude those
|
||||
calls. Typically, the former method of handling this would be preferred.
|
||||
|
||||
The third method you need to override is the B<_cursor> method. This accepts
|
||||
the same window handle as the B<_content> method. The default B<draw> method
|
||||
will only call this method if it was called with a true I<active> argument.
|
||||
|
||||
Neither of these two methods will need to allocate, refresh, or destroy window
|
||||
handles, just print the content. The windows will already be erased and
|
||||
initialised to specified foreground/background pairs, and those settings saved
|
||||
via the B<_save> method. If at any time you need to reset the window handle's
|
||||
current cursor back to those settings you can call B<_restore>:
|
||||
|
||||
$self->_restore($dwh);
|
||||
|
||||
In fact, in order to make the state of the window handle more predictable for
|
||||
descendent classes you should probably call _restore at the end of each of
|
||||
these methods.
|
||||
|
||||
The final method that should be overridden is the input_key method. This
|
||||
expects a single argument, that being the keystroke captured by the keyboard
|
||||
scanning function. It uses that value to update (if it's not rejected) the
|
||||
widget's state information. A rough skeleton for this function would be as
|
||||
follows:
|
||||
|
||||
sub input_key {
|
||||
my $self = shift;
|
||||
my $key = shift;
|
||||
my $conf = $self->{CONF};
|
||||
|
||||
# validate/update state information
|
||||
}
|
||||
|
||||
=head2 CONCLUSION
|
||||
|
||||
That, in a nutshell, is all there is to creating a custom widget. For a
|
||||
working example which uses the structure noted above, look at the TextField or
|
||||
ButtonSet widgets. Both consist of nothing more than the routines listed
|
||||
above.
|
||||
|
||||
=head1 HISTORY
|
||||
|
||||
2001/07/07 -- First draft.
|
||||
2002/11/01 -- Updated for reworked internals.
|
||||
|
||||
=head1 AUTHOR/COPYRIGHT
|
||||
|
||||
(c) 2001 Arthur Corliss (corliss@digitalmages.com),
|
||||
|
||||
=cut
|
||||
|
||||
@@ -1,904 +0,0 @@
|
||||
## CursesFun.c -- the functions
|
||||
##
|
||||
## Copyright (c) 1994-2000 William Setzer
|
||||
##
|
||||
## You may distribute under the terms of either the Artistic License
|
||||
## or the GNU General Public License, as specified in the README file.
|
||||
|
||||
###
|
||||
## For the brave object-using person
|
||||
#
|
||||
package Curses::Window;
|
||||
|
||||
@ISA = qw(Curses);
|
||||
|
||||
package Curses::Screen;
|
||||
|
||||
@ISA = qw(Curses);
|
||||
sub new { newterm(@_) }
|
||||
sub DESTROY { }
|
||||
|
||||
package Curses::Panel;
|
||||
|
||||
@ISA = qw(Curses);
|
||||
sub new { new_panel(@_) }
|
||||
sub DESTROY { }
|
||||
|
||||
package Curses::Menu;
|
||||
|
||||
@ISA = qw(Curses);
|
||||
sub new { new_menu(@_) }
|
||||
sub DESTROY { }
|
||||
|
||||
package Curses::Item;
|
||||
|
||||
@ISA = qw(Curses);
|
||||
sub new { new_item(@_) }
|
||||
sub DESTROY { }
|
||||
|
||||
package Curses::Form;
|
||||
|
||||
@ISA = qw(Curses);
|
||||
sub new { new_form(@_) }
|
||||
sub DESTROY { }
|
||||
|
||||
package Curses::Field;
|
||||
|
||||
@ISA = qw(Curses);
|
||||
sub new { new_field(@_) }
|
||||
sub DESTROY { }
|
||||
|
||||
|
||||
package Curses;
|
||||
|
||||
$VERSION = '1.28'; # Makefile.PL picks this up
|
||||
|
||||
use Carp;
|
||||
require Exporter;
|
||||
require DynaLoader;
|
||||
@ISA = qw(Exporter DynaLoader);
|
||||
|
||||
bootstrap Curses;
|
||||
|
||||
sub new {
|
||||
my $pkg = shift;
|
||||
my ($nl, $nc, $by, $bx) = (@_,0,0,0,0);
|
||||
|
||||
unless ($_initscr++) { initscr() }
|
||||
return newwin($nl, $nc, $by, $bx);
|
||||
}
|
||||
|
||||
sub DESTROY { }
|
||||
|
||||
sub AUTOLOAD {
|
||||
my $N = $AUTOLOAD;
|
||||
$N =~ s/^.*:://;
|
||||
|
||||
croak "Curses constant '$N' is not defined by your vendor";
|
||||
}
|
||||
|
||||
sub printw { addstr(sprintf shift, @_) }
|
||||
|
||||
tie $LINES, Curses::Vars, 1;
|
||||
tie $COLS, Curses::Vars, 2;
|
||||
tie $stdscr, Curses::Vars, 3;
|
||||
tie $curscr, Curses::Vars, 4;
|
||||
tie $COLORS, Curses::Vars, 5;
|
||||
tie $COLOR_PAIRS, Curses::Vars, 6;
|
||||
|
||||
@EXPORT = qw(
|
||||
printw
|
||||
|
||||
LINES $LINES COLS $COLS stdscr $stdscr curscr $curscr COLORS $COLORS
|
||||
COLOR_PAIRS $COLOR_PAIRS
|
||||
|
||||
addch echochar addchstr addchnstr addstr addnstr attroff attron attrset
|
||||
standend standout attr_get attr_off attr_on attr_set chgat COLOR_PAIR
|
||||
PAIR_NUMBER beep flash bkgd bkgdset getbkgd border box hline vline
|
||||
erase clear clrtobot clrtoeol start_color init_pair init_color
|
||||
has_colors can_change_color color_content pair_content delch deleteln
|
||||
insdelln insertln getch ungetch has_key KEY_F getstr getnstr getyx
|
||||
getparyx getbegyx getmaxyx inch inchstr inchnstr initscr endwin
|
||||
isendwin newterm set_term delscreen cbreak nocbreak echo noecho
|
||||
halfdelay intrflush keypad meta nodelay notimeout raw noraw qiflush
|
||||
noqiflush timeout typeahead insch insstr insnstr instr innstr
|
||||
def_prog_mode def_shell_mode reset_prog_mode reset_shell_mode resetty
|
||||
savetty getsyx setsyx curs_set napms move clearok idlok idcok immedok
|
||||
leaveok setscrreg scrollok nl nonl overlay overwrite copywin newpad
|
||||
subpad prefresh pnoutrefresh pechochar refresh noutrefresh doupdate
|
||||
redrawwin redrawln scr_dump scr_restore scr_init scr_set scroll scrl
|
||||
slk_init slk_set slk_refresh slk_noutrefresh slk_label slk_clear
|
||||
slk_restore slk_touch slk_attron slk_attrset slk_attr slk_attroff
|
||||
slk_color baudrate erasechar has_ic has_il killchar longname termattrs
|
||||
termname touchwin touchline untouchwin touchln is_linetouched
|
||||
is_wintouched unctrl keyname filter use_env putwin getwin delay_output
|
||||
flushinp newwin delwin mvwin subwin derwin mvderwin dupwin syncup
|
||||
syncok cursyncup syncdown getmouse ungetmouse mousemask enclose
|
||||
mouse_trafo mouseinterval BUTTON_RELEASE BUTTON_PRESS BUTTON_CLICK
|
||||
BUTTON_DOUBLE_CLICK BUTTON_TRIPLE_CLICK BUTTON_RESERVED_EVENT
|
||||
use_default_colors assume_default_colors define_key keybound keyok
|
||||
resizeterm resize getmaxy getmaxx flusok getcap touchoverlap new_panel
|
||||
bottom_panel top_panel show_panel update_panels hide_panel panel_window
|
||||
replace_panel move_panel panel_hidden panel_above panel_below
|
||||
set_panel_userptr panel_userptr del_panel set_menu_fore menu_fore
|
||||
set_menu_back menu_back set_menu_grey menu_grey set_menu_pad menu_pad
|
||||
pos_menu_cursor menu_driver set_menu_format menu_format set_menu_items
|
||||
menu_items item_count set_menu_mark menu_mark new_menu free_menu
|
||||
menu_opts set_menu_opts menu_opts_on menu_opts_off set_menu_pattern
|
||||
menu_pattern post_menu unpost_menu set_menu_userptr menu_userptr
|
||||
set_menu_win menu_win set_menu_sub menu_sub scale_menu set_current_item
|
||||
current_item set_top_row top_row item_index item_name item_description
|
||||
new_item free_item set_item_opts item_opts_on item_opts_off item_opts
|
||||
item_userptr set_item_userptr set_item_value item_value item_visible
|
||||
menu_request_name menu_request_by_name set_menu_spacing menu_spacing
|
||||
pos_form_cursor data_ahead data_behind form_driver set_form_fields
|
||||
form_fields field_count move_field new_form free_form set_new_page
|
||||
new_page set_form_opts form_opts_on form_opts_off form_opts
|
||||
set_current_field current_field set_form_page form_page field_index
|
||||
post_form unpost_form set_form_userptr form_userptr set_form_win
|
||||
form_win set_form_sub form_sub scale_form set_field_fore field_fore
|
||||
set_field_back field_back set_field_pad field_pad set_field_buffer
|
||||
field_buffer set_field_status field_status set_max_field field_info
|
||||
dynamic_field_info set_field_just field_just new_field dup_field
|
||||
link_field free_field set_field_opts field_opts_on field_opts_off
|
||||
field_opts set_field_userptr field_userptr field_arg form_request_name
|
||||
form_request_by_name
|
||||
|
||||
ERR OK ACS_BLOCK ACS_BOARD ACS_BTEE ACS_BULLET ACS_CKBOARD ACS_DARROW
|
||||
ACS_DEGREE ACS_DIAMOND ACS_HLINE ACS_LANTERN ACS_LARROW ACS_LLCORNER
|
||||
ACS_LRCORNER ACS_LTEE ACS_PLMINUS ACS_PLUS ACS_RARROW ACS_RTEE ACS_S1
|
||||
ACS_S9 ACS_TTEE ACS_UARROW ACS_ULCORNER ACS_URCORNER ACS_VLINE
|
||||
A_ALTCHARSET A_ATTRIBUTES A_BLINK A_BOLD A_CHARTEXT A_COLOR A_DIM
|
||||
A_INVIS A_NORMAL A_PROTECT A_REVERSE A_STANDOUT A_UNDERLINE COLOR_BLACK
|
||||
COLOR_BLUE COLOR_CYAN COLOR_GREEN COLOR_MAGENTA COLOR_RED COLOR_WHITE
|
||||
COLOR_YELLOW KEY_A1 KEY_A3 KEY_B2 KEY_BACKSPACE KEY_BEG KEY_BREAK
|
||||
KEY_BTAB KEY_C1 KEY_C3 KEY_CANCEL KEY_CATAB KEY_CLEAR KEY_CLOSE
|
||||
KEY_COMMAND KEY_COPY KEY_CREATE KEY_CTAB KEY_DC KEY_DL KEY_DOWN KEY_EIC
|
||||
KEY_END KEY_ENTER KEY_EOL KEY_EOS KEY_EVENT KEY_EXIT
|
||||
KEY_F0 KEY_FIND KEY_HELP
|
||||
KEY_HOME KEY_IC KEY_IL KEY_LEFT KEY_LL KEY_MARK KEY_MAX KEY_MESSAGE
|
||||
KEY_MOUSE KEY_MIN KEY_MOVE KEY_NEXT KEY_NPAGE
|
||||
KEY_OPEN KEY_OPTIONS KEY_PPAGE
|
||||
KEY_PREVIOUS KEY_PRINT KEY_REDO KEY_REFERENCE KEY_REFRESH KEY_REPLACE
|
||||
KEY_RESET KEY_RESIZE KEY_RESTART KEY_RESUME KEY_RIGHT KEY_SAVE KEY_SBEG
|
||||
KEY_SCANCEL KEY_SCOMMAND KEY_SCOPY KEY_SCREATE KEY_SDC KEY_SDL
|
||||
KEY_SELECT KEY_SEND KEY_SEOL KEY_SEXIT KEY_SF KEY_SFIND KEY_SHELP
|
||||
KEY_SHOME KEY_SIC KEY_SLEFT KEY_SMESSAGE KEY_SMOVE KEY_SNEXT
|
||||
KEY_SOPTIONS KEY_SPREVIOUS KEY_SPRINT KEY_SR KEY_SREDO KEY_SREPLACE
|
||||
KEY_SRESET KEY_SRIGHT KEY_SRSUME KEY_SSAVE KEY_SSUSPEND KEY_STAB
|
||||
KEY_SUNDO KEY_SUSPEND KEY_UNDO KEY_UP
|
||||
BUTTON1_RELEASED BUTTON1_PRESSED BUTTON1_CLICKED BUTTON1_DOUBLE_CLICKED
|
||||
BUTTON1_TRIPLE_CLICKED BUTTON1_RESERVED_EVENT BUTTON2_RELEASED
|
||||
BUTTON2_PRESSED BUTTON2_CLICKED BUTTON2_DOUBLE_CLICKED
|
||||
BUTTON2_TRIPLE_CLICKED BUTTON2_RESERVED_EVENT BUTTON3_RELEASED
|
||||
BUTTON3_PRESSED BUTTON3_CLICKED BUTTON3_DOUBLE_CLICKED
|
||||
BUTTON3_TRIPLE_CLICKED BUTTON3_RESERVED_EVENT BUTTON4_RELEASED
|
||||
BUTTON4_PRESSED BUTTON4_CLICKED BUTTON4_DOUBLE_CLICKED
|
||||
BUTTON4_TRIPLE_CLICKED BUTTON4_RESERVED_EVENT BUTTON_CTRL BUTTON_SHIFT
|
||||
BUTTON_ALT ALL_MOUSE_EVENTS REPORT_MOUSE_POSITION NCURSES_MOUSE_VERSION
|
||||
E_OK E_SYSTEM_ERROR E_BAD_ARGUMENT E_POSTED E_CONNECTED E_BAD_STATE
|
||||
E_NO_ROOM E_NOT_POSTED E_UNKNOWN_COMMAND E_NO_MATCH E_NOT_SELECTABLE
|
||||
E_NOT_CONNECTED E_REQUEST_DENIED E_INVALID_FIELD E_CURRENT
|
||||
REQ_LEFT_ITEM REQ_RIGHT_ITEM REQ_UP_ITEM REQ_DOWN_ITEM REQ_SCR_ULINE
|
||||
REQ_SCR_DLINE REQ_SCR_DPAGE REQ_SCR_UPAGE REQ_FIRST_ITEM REQ_LAST_ITEM
|
||||
REQ_NEXT_ITEM REQ_PREV_ITEM REQ_TOGGLE_ITEM REQ_CLEAR_PATTERN
|
||||
REQ_BACK_PATTERN REQ_NEXT_MATCH REQ_PREV_MATCH MIN_MENU_COMMAND
|
||||
MAX_MENU_COMMAND O_ONEVALUE O_SHOWDESC O_ROWMAJOR O_IGNORECASE
|
||||
O_SHOWMATCH O_NONCYCLIC O_SELECTABLE REQ_NEXT_PAGE REQ_PREV_PAGE
|
||||
REQ_FIRST_PAGE REQ_LAST_PAGE REQ_NEXT_FIELD REQ_PREV_FIELD
|
||||
REQ_FIRST_FIELD REQ_LAST_FIELD REQ_SNEXT_FIELD REQ_SPREV_FIELD
|
||||
REQ_SFIRST_FIELD REQ_SLAST_FIELD REQ_LEFT_FIELD REQ_RIGHT_FIELD
|
||||
REQ_UP_FIELD REQ_DOWN_FIELD REQ_NEXT_CHAR REQ_PREV_CHAR REQ_NEXT_LINE
|
||||
REQ_PREV_LINE REQ_NEXT_WORD REQ_PREV_WORD REQ_BEG_FIELD REQ_END_FIELD
|
||||
REQ_BEG_LINE REQ_END_LINE REQ_LEFT_CHAR REQ_RIGHT_CHAR REQ_UP_CHAR
|
||||
REQ_DOWN_CHAR REQ_NEW_LINE REQ_INS_CHAR REQ_INS_LINE REQ_DEL_CHAR
|
||||
REQ_DEL_PREV REQ_DEL_LINE REQ_DEL_WORD REQ_CLR_EOL REQ_CLR_EOF
|
||||
REQ_CLR_FIELD REQ_OVL_MODE REQ_INS_MODE REQ_SCR_FLINE REQ_SCR_BLINE
|
||||
REQ_SCR_FPAGE REQ_SCR_BPAGE REQ_SCR_FHPAGE REQ_SCR_BHPAGE REQ_SCR_FCHAR
|
||||
REQ_SCR_BCHAR REQ_SCR_HFLINE REQ_SCR_HBLINE REQ_SCR_HFHALF
|
||||
REQ_SCR_HBHALF REQ_VALIDATION REQ_NEXT_CHOICE REQ_PREV_CHOICE
|
||||
MIN_FORM_COMMAND MAX_FORM_COMMAND NO_JUSTIFICATION JUSTIFY_LEFT
|
||||
JUSTIFY_CENTER JUSTIFY_RIGHT O_VISIBLE O_ACTIVE O_PUBLIC O_EDIT O_WRAP
|
||||
O_BLANK O_AUTOSKIP O_NULLOK O_PASSOK O_STATIC O_NL_OVERLOAD
|
||||
O_BS_OVERLOAD
|
||||
);
|
||||
|
||||
if ($OldCurses)
|
||||
{
|
||||
@_OLD = qw(
|
||||
wprintw mvprintw wmvprintw
|
||||
|
||||
waddch mvaddch mvwaddch wechochar waddchstr mvaddchstr
|
||||
mvwaddchstr waddchnstr mvaddchnstr mvwaddchnstr waddstr
|
||||
mvaddstr mvwaddstr waddnstr mvaddnstr mvwaddnstr wattroff
|
||||
wattron wattrset wstandend wstandout wattr_get wattr_off wattr_on
|
||||
wattr_set wchgat mvchgat mvwchgat wbkgd wbkgdset wborder whline
|
||||
mvhline mvwhline wvline mvvline mvwvline werase wclear
|
||||
wclrtobot wclrtoeol wdelch mvdelch mvwdelch wdeleteln winsdelln
|
||||
winsertln wgetch mvgetch mvwgetch wgetstr mvgetstr mvwgetstr
|
||||
wgetnstr mvgetnstr mvwgetnstr winch mvinch mvwinch winchstr
|
||||
mvinchstr mvwinchstr winchnstr mvinchnstr mvwinchnstr wtimeout
|
||||
winsch mvinsch mvwinsch winsstr mvinsstr mvwinsstr winsnstr
|
||||
mvinsnstr mvwinsnstr winstr mvinstr mvwinstr winnstr mvinnstr
|
||||
mvwinnstr wmove wsetscrreg wrefresh wnoutrefresh wredrawln wscrl
|
||||
wtouchln wsyncup wcursyncup wsyncdown wenclose wmouse_trafo wresize
|
||||
);
|
||||
|
||||
push (@EXPORT, @_OLD);
|
||||
for (@_OLD)
|
||||
{
|
||||
/^(?:mv)?(?:w)?(.*)/;
|
||||
eval "sub $_ { $1(\@_); }";
|
||||
}
|
||||
|
||||
eval <<EOS;
|
||||
sub wprintw { addstr(shift, sprintf shift, @_) }
|
||||
sub mvprintw { addstr(shift, shift, sprintf shift, @_) }
|
||||
sub mvwprintw { addstr(shift, shift, shift, sprintf shift, @_) }
|
||||
EOS
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Curses - terminal screen handling and optimization
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Curses;
|
||||
|
||||
initscr;
|
||||
...
|
||||
endwin;
|
||||
|
||||
|
||||
Curses::supports_function($function);
|
||||
Curses::supports_constant($constant);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
C<Curses> is the interface between Perl and your system's curses(3)
|
||||
library. For descriptions on the usage of a given function, variable,
|
||||
or constant, consult your system's documentation, as such information
|
||||
invariably varies (:-) between different curses(3) libraries and
|
||||
operating systems. This document describes the interface itself, and
|
||||
assumes that you already know how your system's curses(3) library
|
||||
works.
|
||||
|
||||
=head2 Unified Functions
|
||||
|
||||
Many curses(3) functions have variants starting with the prefixes
|
||||
I<w->, I<mv->, and/or I<wmv->. These variants differ only in the
|
||||
explicit addition of a window, or by the addition of two coordinates
|
||||
that are used to move the cursor first. For example, C<addch()> has
|
||||
three other variants: C<waddch()>, C<mvaddch()>, and C<mvwaddch()>.
|
||||
The variants aren't very interesting; in fact, we could roll all of
|
||||
the variants into original function by allowing a variable number
|
||||
of arguments and analyzing the argument list for which variant the
|
||||
user wanted to call.
|
||||
|
||||
Unfortunately, curses(3) predates varargs(3), so in C we were stuck
|
||||
with all the variants. However, C<Curses> is a Perl interface, so we
|
||||
are free to "unify" these variants into one function. The section
|
||||
L<"Available Functions"> below lists all curses(3) functions C<Curses>
|
||||
makes available as Perl equivalents, along with a column listing if it
|
||||
is I<unified>. If so, it takes a varying number of arguments as
|
||||
follows:
|
||||
|
||||
=over 4
|
||||
|
||||
C<function( [win], [y, x], args );>
|
||||
|
||||
I<win> is an optional window argument, defaulting to C<stdscr> if not
|
||||
specified.
|
||||
|
||||
I<y, x> is an optional coordinate pair used to move the cursor,
|
||||
defaulting to no move if not specified.
|
||||
|
||||
I<args> are the required arguments of the function. These are the
|
||||
arguments you would specify if you were just calling the base function
|
||||
and not any of the variants.
|
||||
|
||||
=back
|
||||
|
||||
This makes the variants obsolete, since their functionality has been
|
||||
merged into a single function, so C<Curses> does not define them by
|
||||
default. You can still get them if you want, by setting the
|
||||
variable C<$Curses::OldCurses> to a non-zero value before using the
|
||||
C<Curses> package. See L<"Perl 4.X C<cursperl> Compatibility">
|
||||
for an example of this.
|
||||
|
||||
=head2 Objects
|
||||
|
||||
Objects work. Example:
|
||||
|
||||
$win = new Curses;
|
||||
$win->addstr(10, 10, 'foo');
|
||||
$win->refresh;
|
||||
...
|
||||
|
||||
Any function that has been marked as I<unified> (see
|
||||
L<"Available Functions"> below and L<"Unified Functions"> above)
|
||||
can be called as a method for a Curses object.
|
||||
|
||||
Do not use C<initscr()> if using objects, as the first call to get
|
||||
a C<new Curses> will do it for you.
|
||||
|
||||
=head2 Security Concerns
|
||||
|
||||
It has always been the case with the curses functions, but please note
|
||||
that the following functions:
|
||||
|
||||
getstr() (and optional wgetstr(), mvgetstr(), and mvwgetstr())
|
||||
inchstr() (and optional winchstr(), mvinchstr(), and mvwinchstr())
|
||||
instr() (and optional winstr(), mvinstr(), and mvwinstr())
|
||||
|
||||
are subject to buffer overflow attack. This is because you pass in
|
||||
the buffer to be filled in, which has to be of finite length, but
|
||||
there is no way to stop a bad guy from typing.
|
||||
|
||||
In order to avoid this problem, use the alternate functions:
|
||||
|
||||
getnstr()
|
||||
inchnstr()
|
||||
innstr()
|
||||
|
||||
which take an extra "size of buffer" argument.
|
||||
|
||||
=head1 COMPATIBILITY
|
||||
|
||||
=head2 Perl 4.X C<cursperl> Compatibility
|
||||
|
||||
C<Curses> has been written to take advantage of the new features of
|
||||
Perl. I felt it better to provide an improved curses programming
|
||||
environment rather than to be 100% compatible. However, many old
|
||||
C<curseperl> applications will probably still work by starting the
|
||||
script with:
|
||||
|
||||
BEGIN { $Curses::OldCurses = 1; }
|
||||
use Curses;
|
||||
|
||||
Any old application that still does not work should print an
|
||||
understandable error message explaining the problem.
|
||||
|
||||
Some functions and variables are not available through C<Curses>, even with
|
||||
the C<BEGIN> line. They are listed under
|
||||
L<"curses(3) items not available through Curses">.
|
||||
|
||||
The variables C<$stdscr> and C<$curscr> are also available as
|
||||
functions C<stdscr> and C<curscr>. This is because of a Perl bug.
|
||||
See the L<BUGS> section for details.
|
||||
|
||||
=head2 Incompatibilities with previous versions of C<Curses>
|
||||
|
||||
In previous versions of this software, some Perl functions took a
|
||||
different set of parameters than their C counterparts. This is no
|
||||
longer true. You should now use C<getstr($str)> and C<getyx($y, $x)>
|
||||
instead of C<$str = getstr()> and C<($y, $x) = getyx()>.
|
||||
|
||||
=head2 Incompatibilities with other Perl programs
|
||||
|
||||
menu.pl, v3.0 and v3.1
|
||||
There were various interaction problems between these two
|
||||
releases and Curses. Please upgrade to the latest version
|
||||
(v3.3 as of 3/16/96).
|
||||
|
||||
=head1 DIAGNOSTICS
|
||||
|
||||
=over 4
|
||||
|
||||
=item * Curses function '%s' called with too %s arguments at ...
|
||||
|
||||
You have called a C<Curses> function with a wrong number of
|
||||
arguments.
|
||||
|
||||
=item * argument %d to Curses function '%s' is not a Curses %s at ...
|
||||
=item * argument is not a Curses %s at ...
|
||||
|
||||
The argument you gave to the function wasn't what it wanted.
|
||||
|
||||
This probably means that you didn't give the right arguments to a
|
||||
I<unified> function. See the DESCRIPTION section on L<Unified
|
||||
Functions> for more information.
|
||||
|
||||
=item * Curses function '%s' is not defined by your vendor at ...
|
||||
|
||||
You have a C<Curses> function in your code that your system's curses(3)
|
||||
library doesn't define.
|
||||
|
||||
=item * Curses variable '%s' is not defined by your vendor at ...
|
||||
|
||||
You have a C<Curses> variable in your code that your system's curses(3)
|
||||
library doesn't define.
|
||||
|
||||
=item * Curses constant '%s' is not defined by your vendor at ...
|
||||
|
||||
You have a C<Curses> constant in your code that your system's curses(3)
|
||||
library doesn't define.
|
||||
|
||||
=item * Curses::Vars::FETCH called with bad index at ...
|
||||
=item * Curses::Vars::STORE called with bad index at ...
|
||||
|
||||
You've been playing with the C<tie> interface to the C<Curses>
|
||||
variables. Don't do that. :-)
|
||||
|
||||
=item * Anything else
|
||||
|
||||
Check out the F<perldiag> man page to see if the error is in there.
|
||||
|
||||
=back
|
||||
|
||||
=head1 BUGS
|
||||
|
||||
If you use the variables C<$stdscr> and C<$curscr> instead of their
|
||||
functional counterparts (C<stdscr> and C<curscr>), you might run into
|
||||
a bug in Perl where the "magic" isn't called early enough. This is
|
||||
manifested by the C<Curses> package telling you C<$stdscr> isn't a
|
||||
window. One workaround is to put a line like C<$stdscr = $stdscr>
|
||||
near the front of your program.
|
||||
|
||||
Probably many more.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
William Setzer <William_Setzer@ncsu.edu>
|
||||
|
||||
=head1 SYNOPSIS OF PERL CURSES AVAILABILITY
|
||||
|
||||
=head2 Available Functions
|
||||
|
||||
Avaiable Function Unified? Available via $OldCurses[*]
|
||||
----------------- -------- ------------------------
|
||||
addch Yes waddch mvaddch mvwaddch
|
||||
echochar Yes wechochar
|
||||
addchstr Yes waddchstr mvaddchstr mvwaddchstr
|
||||
addchnstr Yes waddchnstr mvaddchnstr mvwaddchnstr
|
||||
addstr Yes waddstr mvaddstr mvwaddstr
|
||||
addnstr Yes waddnstr mvaddnstr mvwaddnstr
|
||||
attroff Yes wattroff
|
||||
attron Yes wattron
|
||||
attrset Yes wattrset
|
||||
standend Yes wstandend
|
||||
standout Yes wstandout
|
||||
attr_get Yes wattr_get
|
||||
attr_off Yes wattr_off
|
||||
attr_on Yes wattr_on
|
||||
attr_set Yes wattr_set
|
||||
chgat Yes wchgat mvchgat mvwchgat
|
||||
COLOR_PAIR No
|
||||
PAIR_NUMBER No
|
||||
beep No
|
||||
flash No
|
||||
bkgd Yes wbkgd
|
||||
bkgdset Yes wbkgdset
|
||||
getbkgd Yes
|
||||
border Yes wborder
|
||||
box Yes
|
||||
hline Yes whline mvhline mvwhline
|
||||
vline Yes wvline mvvline mvwvline
|
||||
erase Yes werase
|
||||
clear Yes wclear
|
||||
clrtobot Yes wclrtobot
|
||||
clrtoeol Yes wclrtoeol
|
||||
start_color No
|
||||
init_pair No
|
||||
init_color No
|
||||
has_colors No
|
||||
can_change_color No
|
||||
color_content No
|
||||
pair_content No
|
||||
delch Yes wdelch mvdelch mvwdelch
|
||||
deleteln Yes wdeleteln
|
||||
insdelln Yes winsdelln
|
||||
insertln Yes winsertln
|
||||
getch Yes wgetch mvgetch mvwgetch
|
||||
ungetch No
|
||||
has_key No
|
||||
KEY_F No
|
||||
getstr Yes wgetstr mvgetstr mvwgetstr
|
||||
getnstr Yes wgetnstr mvgetnstr mvwgetnstr
|
||||
getyx Yes
|
||||
getparyx Yes
|
||||
getbegyx Yes
|
||||
getmaxyx Yes
|
||||
inch Yes winch mvinch mvwinch
|
||||
inchstr Yes winchstr mvinchstr mvwinchstr
|
||||
inchnstr Yes winchnstr mvinchnstr mvwinchnstr
|
||||
initscr No
|
||||
endwin No
|
||||
isendwin No
|
||||
newterm No
|
||||
set_term No
|
||||
delscreen No
|
||||
cbreak No
|
||||
nocbreak No
|
||||
echo No
|
||||
noecho No
|
||||
halfdelay No
|
||||
intrflush Yes
|
||||
keypad Yes
|
||||
meta Yes
|
||||
nodelay Yes
|
||||
notimeout Yes
|
||||
raw No
|
||||
noraw No
|
||||
qiflush No
|
||||
noqiflush No
|
||||
timeout Yes wtimeout
|
||||
typeahead No
|
||||
insch Yes winsch mvinsch mvwinsch
|
||||
insstr Yes winsstr mvinsstr mvwinsstr
|
||||
insnstr Yes winsnstr mvinsnstr mvwinsnstr
|
||||
instr Yes winstr mvinstr mvwinstr
|
||||
innstr Yes winnstr mvinnstr mvwinnstr
|
||||
def_prog_mode No
|
||||
def_shell_mode No
|
||||
reset_prog_mode No
|
||||
reset_shell_mode No
|
||||
resetty No
|
||||
savetty No
|
||||
getsyx No
|
||||
setsyx No
|
||||
curs_set No
|
||||
napms No
|
||||
move Yes wmove
|
||||
clearok Yes
|
||||
idlok Yes
|
||||
idcok Yes
|
||||
immedok Yes
|
||||
leaveok Yes
|
||||
setscrreg Yes wsetscrreg
|
||||
scrollok Yes
|
||||
nl No
|
||||
nonl No
|
||||
overlay No
|
||||
overwrite No
|
||||
copywin No
|
||||
newpad No
|
||||
subpad No
|
||||
prefresh No
|
||||
pnoutrefresh No
|
||||
pechochar No
|
||||
refresh Yes wrefresh
|
||||
noutrefresh Yes wnoutrefresh
|
||||
doupdate No
|
||||
redrawwin Yes
|
||||
redrawln Yes wredrawln
|
||||
scr_dump No
|
||||
scr_restore No
|
||||
scr_init No
|
||||
scr_set No
|
||||
scroll Yes
|
||||
scrl Yes wscrl
|
||||
slk_init No
|
||||
slk_set No
|
||||
slk_refresh No
|
||||
slk_noutrefresh No
|
||||
slk_label No
|
||||
slk_clear No
|
||||
slk_restore No
|
||||
slk_touch No
|
||||
slk_attron No
|
||||
slk_attrset No
|
||||
slk_attr No
|
||||
slk_attroff No
|
||||
slk_color No
|
||||
baudrate No
|
||||
erasechar No
|
||||
has_ic No
|
||||
has_il No
|
||||
killchar No
|
||||
longname No
|
||||
termattrs No
|
||||
termname No
|
||||
touchwin Yes
|
||||
touchline Yes
|
||||
untouchwin Yes
|
||||
touchln Yes wtouchln
|
||||
is_linetouched Yes
|
||||
is_wintouched Yes
|
||||
unctrl No
|
||||
keyname No
|
||||
filter No
|
||||
use_env No
|
||||
putwin No
|
||||
getwin No
|
||||
delay_output No
|
||||
flushinp No
|
||||
newwin No
|
||||
delwin Yes
|
||||
mvwin Yes
|
||||
subwin Yes
|
||||
derwin Yes
|
||||
mvderwin Yes
|
||||
dupwin Yes
|
||||
syncup Yes wsyncup
|
||||
syncok Yes
|
||||
cursyncup Yes wcursyncup
|
||||
syncdown Yes wsyncdown
|
||||
getmouse No
|
||||
ungetmouse No
|
||||
mousemask No
|
||||
enclose Yes wenclose
|
||||
mouse_trafo Yes wmouse_trafo
|
||||
mouseinterval No
|
||||
BUTTON_RELEASE No
|
||||
BUTTON_PRESS No
|
||||
BUTTON_CLICK No
|
||||
BUTTON_DOUBLE_CLICK No
|
||||
BUTTON_TRIPLE_CLICK No
|
||||
BUTTON_RESERVED_EVENT No
|
||||
use_default_colors No
|
||||
assume_default_colors No
|
||||
define_key No
|
||||
keybound No
|
||||
keyok No
|
||||
resizeterm No
|
||||
resize Yes wresize
|
||||
getmaxy Yes
|
||||
getmaxx Yes
|
||||
flusok Yes
|
||||
getcap No
|
||||
touchoverlap No
|
||||
new_panel No
|
||||
bottom_panel No
|
||||
top_panel No
|
||||
show_panel No
|
||||
update_panels No
|
||||
hide_panel No
|
||||
panel_window No
|
||||
replace_panel No
|
||||
move_panel No
|
||||
panel_hidden No
|
||||
panel_above No
|
||||
panel_below No
|
||||
set_panel_userptr No
|
||||
panel_userptr No
|
||||
del_panel No
|
||||
set_menu_fore No
|
||||
menu_fore No
|
||||
set_menu_back No
|
||||
menu_back No
|
||||
set_menu_grey No
|
||||
menu_grey No
|
||||
set_menu_pad No
|
||||
menu_pad No
|
||||
pos_menu_cursor No
|
||||
menu_driver No
|
||||
set_menu_format No
|
||||
menu_format No
|
||||
set_menu_items No
|
||||
menu_items No
|
||||
item_count No
|
||||
set_menu_mark No
|
||||
menu_mark No
|
||||
new_menu No
|
||||
free_menu No
|
||||
menu_opts No
|
||||
set_menu_opts No
|
||||
menu_opts_on No
|
||||
menu_opts_off No
|
||||
set_menu_pattern No
|
||||
menu_pattern No
|
||||
post_menu No
|
||||
unpost_menu No
|
||||
set_menu_userptr No
|
||||
menu_userptr No
|
||||
set_menu_win No
|
||||
menu_win No
|
||||
set_menu_sub No
|
||||
menu_sub No
|
||||
scale_menu No
|
||||
set_current_item No
|
||||
current_item No
|
||||
set_top_row No
|
||||
top_row No
|
||||
item_index No
|
||||
item_name No
|
||||
item_description No
|
||||
new_item No
|
||||
free_item No
|
||||
set_item_opts No
|
||||
item_opts_on No
|
||||
item_opts_off No
|
||||
item_opts No
|
||||
item_userptr No
|
||||
set_item_userptr No
|
||||
set_item_value No
|
||||
item_value No
|
||||
item_visible No
|
||||
menu_request_name No
|
||||
menu_request_by_name No
|
||||
set_menu_spacing No
|
||||
menu_spacing No
|
||||
pos_form_cursor No
|
||||
data_ahead No
|
||||
data_behind No
|
||||
form_driver No
|
||||
set_form_fields No
|
||||
form_fields No
|
||||
field_count No
|
||||
move_field No
|
||||
new_form No
|
||||
free_form No
|
||||
set_new_page No
|
||||
new_page No
|
||||
set_form_opts No
|
||||
form_opts_on No
|
||||
form_opts_off No
|
||||
form_opts No
|
||||
set_current_field No
|
||||
current_field No
|
||||
set_form_page No
|
||||
form_page No
|
||||
field_index No
|
||||
post_form No
|
||||
unpost_form No
|
||||
set_form_userptr No
|
||||
form_userptr No
|
||||
set_form_win No
|
||||
form_win No
|
||||
set_form_sub No
|
||||
form_sub No
|
||||
scale_form No
|
||||
set_field_fore No
|
||||
field_fore No
|
||||
set_field_back No
|
||||
field_back No
|
||||
set_field_pad No
|
||||
field_pad No
|
||||
set_field_buffer No
|
||||
field_buffer No
|
||||
set_field_status No
|
||||
field_status No
|
||||
set_max_field No
|
||||
field_info No
|
||||
dynamic_field_info No
|
||||
set_field_just No
|
||||
field_just No
|
||||
new_field No
|
||||
dup_field No
|
||||
link_field No
|
||||
free_field No
|
||||
set_field_opts No
|
||||
field_opts_on No
|
||||
field_opts_off No
|
||||
field_opts No
|
||||
set_field_userptr No
|
||||
field_userptr No
|
||||
field_arg No
|
||||
form_request_name No
|
||||
form_request_by_name No
|
||||
|
||||
[*] To use any functions in this column, the variable
|
||||
C<$Curses::OldCurses> must be set to a non-zero value before using the
|
||||
C<Curses> package. See L<"Perl 4.X cursperl Compatibility"> for an
|
||||
example of this.
|
||||
|
||||
=head2 Available Variables
|
||||
|
||||
LINES COLS stdscr
|
||||
curscr COLORS COLOR_PAIRS
|
||||
|
||||
=head2 Available Constants
|
||||
|
||||
ERR OK ACS_BLOCK
|
||||
ACS_BOARD ACS_BTEE ACS_BULLET
|
||||
ACS_CKBOARD ACS_DARROW ACS_DEGREE
|
||||
ACS_DIAMOND ACS_HLINE ACS_LANTERN
|
||||
ACS_LARROW ACS_LLCORNER ACS_LRCORNER
|
||||
ACS_LTEE ACS_PLMINUS ACS_PLUS
|
||||
ACS_RARROW ACS_RTEE ACS_S1
|
||||
ACS_S9 ACS_TTEE ACS_UARROW
|
||||
ACS_ULCORNER ACS_URCORNER ACS_VLINE
|
||||
A_ALTCHARSET A_ATTRIBUTES A_BLINK
|
||||
A_BOLD A_CHARTEXT A_COLOR
|
||||
A_DIM A_INVIS A_NORMAL
|
||||
A_PROTECT A_REVERSE A_STANDOUT
|
||||
A_UNDERLINE COLOR_BLACK COLOR_BLUE
|
||||
COLOR_CYAN COLOR_GREEN COLOR_MAGENTA
|
||||
COLOR_RED COLOR_WHITE COLOR_YELLOW
|
||||
KEY_A1 KEY_A3 KEY_B2
|
||||
KEY_BACKSPACE KEY_BEG KEY_BREAK
|
||||
KEY_BTAB KEY_C1 KEY_C3
|
||||
KEY_CANCEL KEY_CATAB KEY_CLEAR
|
||||
KEY_CLOSE KEY_COMMAND KEY_COPY
|
||||
KEY_CREATE KEY_CTAB KEY_DC
|
||||
KEY_DL KEY_DOWN KEY_EIC
|
||||
KEY_END KEY_ENTER KEY_EOL
|
||||
KEY_EOS KEY_EVENT KEY_EXIT
|
||||
KEY_F0
|
||||
KEY_FIND KEY_HELP KEY_HOME
|
||||
KEY_IC KEY_IL KEY_LEFT
|
||||
KEY_LL KEY_MARK KEY_MAX
|
||||
KEY_MESSAGE KEY_MIN KEY_MOVE
|
||||
KEY_NEXT KEY_NPAGE KEY_OPEN
|
||||
KEY_OPTIONS KEY_PPAGE KEY_PREVIOUS
|
||||
KEY_PRINT KEY_REDO KEY_REFERENCE
|
||||
KEY_REFRESH KEY_REPLACE KEY_RESET
|
||||
KEY_RESIZE KEY_RESTART KEY_RESUME
|
||||
KEY_RIGHT
|
||||
KEY_SAVE KEY_SBEG KEY_SCANCEL
|
||||
KEY_SCOMMAND KEY_SCOPY KEY_SCREATE
|
||||
KEY_SDC KEY_SDL KEY_SELECT
|
||||
KEY_SEND KEY_SEOL KEY_SEXIT
|
||||
KEY_SF KEY_SFIND KEY_SHELP
|
||||
KEY_SHOME KEY_SIC KEY_SLEFT
|
||||
KEY_SMESSAGE KEY_SMOVE KEY_SNEXT
|
||||
KEY_SOPTIONS KEY_SPREVIOUS KEY_SPRINT
|
||||
KEY_SR KEY_SREDO KEY_SREPLACE
|
||||
KEY_SRESET KEY_SRIGHT KEY_SRSUME
|
||||
KEY_SSAVE KEY_SSUSPEND KEY_STAB
|
||||
KEY_SUNDO KEY_SUSPEND KEY_UNDO
|
||||
KEY_UP KEY_MOUSE BUTTON1_RELEASED
|
||||
BUTTON1_PRESSED BUTTON1_CLICKED BUTTON1_DOUBLE_CLICKED
|
||||
BUTTON1_TRIPLE_CLICKED BUTTON1_RESERVED_EVENT BUTTON2_RELEASED
|
||||
BUTTON2_PRESSED BUTTON2_CLICKED BUTTON2_DOUBLE_CLICKED
|
||||
BUTTON2_TRIPLE_CLICKED BUTTON2_RESERVED_EVENT BUTTON3_RELEASED
|
||||
BUTTON3_PRESSED BUTTON3_CLICKED BUTTON3_DOUBLE_CLICKED
|
||||
BUTTON3_TRIPLE_CLICKED BUTTON3_RESERVED_EVENT BUTTON4_RELEASED
|
||||
BUTTON4_PRESSED BUTTON4_CLICKED BUTTON4_DOUBLE_CLICKED
|
||||
BUTTON4_TRIPLE_CLICKED BUTTON4_RESERVED_EVENT BUTTON_CTRL
|
||||
BUTTON_SHIFT BUTTON_ALT ALL_MOUSE_EVENTS
|
||||
REPORT_MOUSE_POSITION NCURSES_MOUSE_VERSION E_OK
|
||||
E_SYSTEM_ERROR E_BAD_ARGUMENT E_POSTED
|
||||
E_CONNECTED E_BAD_STATE E_NO_ROOM
|
||||
E_NOT_POSTED E_UNKNOWN_COMMAND E_NO_MATCH
|
||||
E_NOT_SELECTABLE E_NOT_CONNECTED E_REQUEST_DENIED
|
||||
E_INVALID_FIELD E_CURRENT REQ_LEFT_ITEM
|
||||
REQ_RIGHT_ITEM REQ_UP_ITEM REQ_DOWN_ITEM
|
||||
REQ_SCR_ULINE REQ_SCR_DLINE REQ_SCR_DPAGE
|
||||
REQ_SCR_UPAGE REQ_FIRST_ITEM REQ_LAST_ITEM
|
||||
REQ_NEXT_ITEM REQ_PREV_ITEM REQ_TOGGLE_ITEM
|
||||
REQ_CLEAR_PATTERN REQ_BACK_PATTERN REQ_NEXT_MATCH
|
||||
REQ_PREV_MATCH MIN_MENU_COMMAND MAX_MENU_COMMAND
|
||||
O_ONEVALUE O_SHOWDESC O_ROWMAJOR
|
||||
O_IGNORECASE O_SHOWMATCH O_NONCYCLIC
|
||||
O_SELECTABLE REQ_NEXT_PAGE REQ_PREV_PAGE
|
||||
REQ_FIRST_PAGE REQ_LAST_PAGE REQ_NEXT_FIELD
|
||||
REQ_PREV_FIELD REQ_FIRST_FIELD REQ_LAST_FIELD
|
||||
REQ_SNEXT_FIELD REQ_SPREV_FIELD REQ_SFIRST_FIELD
|
||||
REQ_SLAST_FIELD REQ_LEFT_FIELD REQ_RIGHT_FIELD
|
||||
REQ_UP_FIELD REQ_DOWN_FIELD REQ_NEXT_CHAR
|
||||
REQ_PREV_CHAR REQ_NEXT_LINE REQ_PREV_LINE
|
||||
REQ_NEXT_WORD REQ_PREV_WORD REQ_BEG_FIELD
|
||||
REQ_END_FIELD REQ_BEG_LINE REQ_END_LINE
|
||||
REQ_LEFT_CHAR REQ_RIGHT_CHAR REQ_UP_CHAR
|
||||
REQ_DOWN_CHAR REQ_NEW_LINE REQ_INS_CHAR
|
||||
REQ_INS_LINE REQ_DEL_CHAR REQ_DEL_PREV
|
||||
REQ_DEL_LINE REQ_DEL_WORD REQ_CLR_EOL
|
||||
REQ_CLR_EOF REQ_CLR_FIELD REQ_OVL_MODE
|
||||
REQ_INS_MODE REQ_SCR_FLINE REQ_SCR_BLINE
|
||||
REQ_SCR_FPAGE REQ_SCR_BPAGE REQ_SCR_FHPAGE
|
||||
REQ_SCR_BHPAGE REQ_SCR_FCHAR REQ_SCR_BCHAR
|
||||
REQ_SCR_HFLINE REQ_SCR_HBLINE REQ_SCR_HFHALF
|
||||
REQ_SCR_HBHALF REQ_VALIDATION REQ_NEXT_CHOICE
|
||||
REQ_PREV_CHOICE MIN_FORM_COMMAND MAX_FORM_COMMAND
|
||||
NO_JUSTIFICATION JUSTIFY_LEFT JUSTIFY_CENTER
|
||||
JUSTIFY_RIGHT O_VISIBLE O_ACTIVE
|
||||
O_PUBLIC O_EDIT O_WRAP
|
||||
O_BLANK O_AUTOSKIP O_NULLOK
|
||||
O_PASSOK O_STATIC O_NL_OVERLOAD
|
||||
O_BS_OVERLOAD
|
||||
|
||||
=head2 curses(3) functions not available through C<Curses>
|
||||
|
||||
tstp _putchar fullname scanw wscanw mvscanw mvwscanw ripoffline
|
||||
setupterm setterm set_curterm del_curterm restartterm tparm tputs
|
||||
putp vidputs vidattr mvcur tigetflag tigetnum tigetstr tgetent
|
||||
tgetflag tgetnum tgetstr tgoto tputs
|
||||
|
||||
=head2 menu(3) functions not available through C<Curses>
|
||||
|
||||
set_item_init item_init set_item_term item_term set_menu_init
|
||||
menu_init set_menu_term menu_term
|
||||
|
||||
=head2 form(3) functions not available through C<Curses>
|
||||
|
||||
new_fieldtype free_fieldtype set_fieldtype_arg
|
||||
set_fieldtype_choice link_fieldtype set_form_init form_init
|
||||
set_form_term form_term set_field_init field_init set_field_term
|
||||
field_term set_field_type field_type
|
||||
@@ -1,5 +0,0 @@
|
||||
/tmp/lib/perl5/site_perl/5.12.3/i686-linux/Curses.pm
|
||||
/tmp/lib/perl5/site_perl/5.12.3/i686-linux/auto/Curses/Curses.bs
|
||||
/tmp/lib/perl5/site_perl/5.12.3/i686-linux/auto/Curses/Curses.so
|
||||
/tmp/share/man/man3/Curses.3
|
||||
/tmp/share/man/man3/Curses.3pm
|
||||
Binary file not shown.
@@ -1,39 +0,0 @@
|
||||
/tmp/lib/perl5/site_perl/5.12.3/Curses/Widgets.pm
|
||||
/tmp/lib/perl5/site_perl/5.12.3/Curses/Widgets/ButtonSet.pm
|
||||
/tmp/lib/perl5/site_perl/5.12.3/Curses/Widgets/Calendar.pm
|
||||
/tmp/lib/perl5/site_perl/5.12.3/Curses/Widgets/ComboBox.pm
|
||||
/tmp/lib/perl5/site_perl/5.12.3/Curses/Widgets/Label.pm
|
||||
/tmp/lib/perl5/site_perl/5.12.3/Curses/Widgets/ListBox.pm
|
||||
/tmp/lib/perl5/site_perl/5.12.3/Curses/Widgets/ListBox/MultiColumn.pm
|
||||
/tmp/lib/perl5/site_perl/5.12.3/Curses/Widgets/Menu.pm
|
||||
/tmp/lib/perl5/site_perl/5.12.3/Curses/Widgets/ProgressBar.pm
|
||||
/tmp/lib/perl5/site_perl/5.12.3/Curses/Widgets/TextField.pm
|
||||
/tmp/lib/perl5/site_perl/5.12.3/Curses/Widgets/TextMemo.pm
|
||||
/tmp/lib/perl5/site_perl/5.12.3/Curses/Widgets/Tutorial.pod
|
||||
/tmp/lib/perl5/site_perl/5.12.3/Curses/Widgets/Tutorial/Creation.pod
|
||||
/tmp/share/man/man3/Curses::Widgets.3
|
||||
/tmp/share/man/man3/Curses::Widgets.3pm
|
||||
/tmp/share/man/man3/Curses::Widgets::ButtonSet.3
|
||||
/tmp/share/man/man3/Curses::Widgets::ButtonSet.3pm
|
||||
/tmp/share/man/man3/Curses::Widgets::Calendar.3
|
||||
/tmp/share/man/man3/Curses::Widgets::Calendar.3pm
|
||||
/tmp/share/man/man3/Curses::Widgets::ComboBox.3
|
||||
/tmp/share/man/man3/Curses::Widgets::ComboBox.3pm
|
||||
/tmp/share/man/man3/Curses::Widgets::Label.3
|
||||
/tmp/share/man/man3/Curses::Widgets::Label.3pm
|
||||
/tmp/share/man/man3/Curses::Widgets::ListBox.3
|
||||
/tmp/share/man/man3/Curses::Widgets::ListBox.3pm
|
||||
/tmp/share/man/man3/Curses::Widgets::ListBox::MultiColumn.3
|
||||
/tmp/share/man/man3/Curses::Widgets::ListBox::MultiColumn.3pm
|
||||
/tmp/share/man/man3/Curses::Widgets::Menu.3
|
||||
/tmp/share/man/man3/Curses::Widgets::Menu.3pm
|
||||
/tmp/share/man/man3/Curses::Widgets::ProgressBar.3
|
||||
/tmp/share/man/man3/Curses::Widgets::ProgressBar.3pm
|
||||
/tmp/share/man/man3/Curses::Widgets::TextField.3
|
||||
/tmp/share/man/man3/Curses::Widgets::TextField.3pm
|
||||
/tmp/share/man/man3/Curses::Widgets::TextMemo.3
|
||||
/tmp/share/man/man3/Curses::Widgets::TextMemo.3pm
|
||||
/tmp/share/man/man3/Curses::Widgets::Tutorial.3
|
||||
/tmp/share/man/man3/Curses::Widgets::Tutorial.3pm
|
||||
/tmp/share/man/man3/Curses::Widgets::Tutorial::Creation.3
|
||||
/tmp/share/man/man3/Curses::Widgets::Tutorial::Creation.3pm
|
||||
Reference in New Issue
Block a user