summaryrefslogtreecommitdiff
path: root/Master
diff options
context:
space:
mode:
authorReinhard Kotucha <reinhard.kotucha@web.de>2007-12-04 22:27:27 +0000
committerReinhard Kotucha <reinhard.kotucha@web.de>2007-12-04 22:27:27 +0000
commit37d7b23081fa11aa28f19754b6c41345970bbcf8 (patch)
treefc0bf4ab8abc0ff190ddf7aad76b57bca8576c78 /Master
parent89221f59ee74a56ee842fad38609aa49d389e940 (diff)
A tiny Perl distribution (win32) for the installer.
git-svn-id: svn://tug.org/texlive/trunk@5709 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master')
-rwxr-xr-xMaster/install-tl.pl11
-rwxr-xr-xMaster/tlpkg/bin/perl.exebin0 -> 5632 bytes
-rwxr-xr-xMaster/tlpkg/bin/perl58.dllbin0 -> 1098752 bytes
-rw-r--r--Master/tlpkg/lib/Perl5_lib-TL_inst/Carp.pm274
-rw-r--r--Master/tlpkg/lib/Perl5_lib-TL_inst/Exporter.pm440
-rw-r--r--Master/tlpkg/lib/Perl5_lib-TL_inst/Exporter/Heavy.pm248
-rw-r--r--Master/tlpkg/lib/Perl5_lib-TL_inst/Getopt/Long.pm2504
-rw-r--r--Master/tlpkg/lib/Perl5_lib-TL_inst/constant.pm340
-rw-r--r--Master/tlpkg/lib/Perl5_lib-TL_inst/strict.pm136
-rw-r--r--Master/tlpkg/lib/Perl5_lib-TL_inst/vars.pm82
-rw-r--r--Master/tlpkg/lib/Perl5_lib-TL_inst/warnings.pm497
-rw-r--r--Master/tlpkg/lib/Perl5_lib-TL_inst/warnings/register.pm51
12 files changed, 4583 insertions, 0 deletions
diff --git a/Master/install-tl.pl b/Master/install-tl.pl
index b5737ec9900..aa8a6051915 100755
--- a/Master/install-tl.pl
+++ b/Master/install-tl.pl
@@ -13,11 +13,22 @@ BEGIN {
$^W = 1;
my $me=$0;
$me=~s!\\!/!g if $^O=~/^MSWin(32|64)$/i;
+
if ($me=~m!/!) {
($::installerdir=$me)=~s!(.*)/.*$!$1!;
} else {
$::installerdir='.';
}
+# The installer uses a minimal subset of Perl for Windows. In order
+# to avoid conflicts with other versions of Perl already installed on
+# the system, we simply ignore them. The installer has to execute
+# $::installerdir/tlpkg/bin/perl.exe and should not rely on any other
+# Perl executable.
+
+ if ($^O=~/^MSWin(32|64)$/i) {
+ $ENV{'PERL5LIB'}=undef;
+ @INC="$::installerdir/tlpkg/lib/Perl5_lib-TL_inst";
+ }
unshift (@INC, "$::installerdir/tlpkg");
}
diff --git a/Master/tlpkg/bin/perl.exe b/Master/tlpkg/bin/perl.exe
new file mode 100755
index 00000000000..30108d9a8cc
--- /dev/null
+++ b/Master/tlpkg/bin/perl.exe
Binary files differ
diff --git a/Master/tlpkg/bin/perl58.dll b/Master/tlpkg/bin/perl58.dll
new file mode 100755
index 00000000000..d783261a862
--- /dev/null
+++ b/Master/tlpkg/bin/perl58.dll
Binary files differ
diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Carp.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Carp.pm
new file mode 100644
index 00000000000..1a814ead34f
--- /dev/null
+++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/Carp.pm
@@ -0,0 +1,274 @@
+package Carp;
+
+our $VERSION = '1.04';
+
+=head1 NAME
+
+carp - warn of errors (from perspective of caller)
+
+cluck - warn of errors with stack backtrace
+ (not exported by default)
+
+croak - die of errors (from perspective of caller)
+
+confess - die of errors with stack backtrace
+
+shortmess - return the message that carp and croak produce
+
+longmess - return the message that cluck and confess produce
+
+=head1 SYNOPSIS
+
+ use Carp;
+ croak "We're outta here!";
+
+ use Carp qw(cluck);
+ cluck "This is how we got here!";
+
+ print FH Carp::shortmess("This will have caller's details added");
+ print FH Carp::longmess("This will have stack backtrace added");
+
+=head1 DESCRIPTION
+
+The Carp routines are useful in your own modules because
+they act like die() or warn(), but with a message which is more
+likely to be useful to a user of your module. In the case of
+cluck, confess, and longmess that context is a summary of every
+call in the call-stack. For a shorter message you can use carp,
+croak or shortmess which report the error as being from where
+your module was called. There is no guarantee that that is where
+the error was, but it is a good educated guess.
+
+You can also alter the way the output and logic of C<Carp> works, by
+changing some global variables in the C<Carp> namespace. See the
+section on C<GLOBAL VARIABLES> below.
+
+Here is a more complete description of how shortmess works. What
+it does is search the call-stack for a function call stack where
+it hasn't been told that there shouldn't be an error. If every
+call is marked safe, it then gives up and gives a full stack
+backtrace instead. In other words it presumes that the first likely
+looking potential suspect is guilty. Its rules for telling whether
+a call shouldn't generate errors work as follows:
+
+=over 4
+
+=item 1.
+
+Any call from a package to itself is safe.
+
+=item 2.
+
+Packages claim that there won't be errors on calls to or from
+packages explicitly marked as safe by inclusion in @CARP_NOT, or
+(if that array is empty) @ISA. The ability to override what
+@ISA says is new in 5.8.
+
+=item 3.
+
+The trust in item 2 is transitive. If A trusts B, and B
+trusts C, then A trusts C. So if you do not override @ISA
+with @CARP_NOT, then this trust relationship is identical to,
+"inherits from".
+
+=item 4.
+
+Any call from an internal Perl module is safe. (Nothing keeps
+user modules from marking themselves as internal to Perl, but
+this practice is discouraged.)
+
+=item 5.
+
+Any call to Carp is safe. (This rule is what keeps it from
+reporting the error where you call carp/croak/shortmess.)
+
+=back
+
+=head2 Forcing a Stack Trace
+
+As a debugging aid, you can force Carp to treat a croak as a confess
+and a carp as a cluck across I<all> modules. In other words, force a
+detailed stack trace to be given. This can be very helpful when trying
+to understand why, or from where, a warning or error is being generated.
+
+This feature is enabled by 'importing' the non-existent symbol
+'verbose'. You would typically enable it by saying
+
+ perl -MCarp=verbose script.pl
+
+or by including the string C<MCarp=verbose> in the PERL5OPT
+environment variable.
+
+Alternately, you can set the global variable C<$Carp::Verbose> to true.
+See the C<GLOBAL VARIABLES> section below.
+
+=cut
+
+# This package is heavily used. Be small. Be fast. Be good.
+
+# Comments added by Andy Wardley <abw@kfs.org> 09-Apr-98, based on an
+# _almost_ complete understanding of the package. Corrections and
+# comments are welcome.
+
+# The members of %Internal are packages that are internal to perl.
+# Carp will not report errors from within these packages if it
+# can. The members of %CarpInternal are internal to Perl's warning
+# system. Carp will not report errors from within these packages
+# either, and will not report calls *to* these packages for carp and
+# croak. They replace $CarpLevel, which is deprecated. The
+# $Max(EvalLen|(Arg(Len|Nums)) variables are used to specify how the eval
+# text and function arguments should be formatted when printed.
+
+# Comments added by Jos I. Boumans <kane@dwim.org> 11-Aug-2004
+# I can not get %CarpInternal or %Internal to work as advertised,
+# therefor leaving it out of the below documentation.
+# $CarpLevel may be decprecated according to the last comment, but
+# after 6 years, it's still around and in heavy use ;)
+
+=pod
+
+=head1 GLOBAL VARIABLES
+
+=head2 $Carp::CarpLevel
+
+This variable determines how many call frames are to be skipped when
+reporting where an error occurred on a call to one of C<Carp>'s
+functions. For example:
+
+ $Carp::CarpLevel = 1;
+ sub bar { .... or _error('Wrong input') }
+ sub _error { Carp::carp(@_) }
+
+This would make Carp report the error as coming from C<bar>'s caller,
+rather than from C<_error>'s caller, as it normally would.
+
+Defaults to C<0>.
+
+=head2 $Carp::MaxEvalLen
+
+This variable determines how many characters of a string-eval are to
+be shown in the output. Use a value of C<0> to show all text.
+
+Defaults to C<0>.
+
+=head2 $Carp::MaxArgLen
+
+This variable determines how many characters of each argument to a
+function to print. Use a value of C<0> to show the full length of the
+argument.
+
+Defaults to C<64>.
+
+=head2 $Carp::MaxArgNums
+
+This variable determines how many arguments to each function to show.
+Use a value of C<0> to show all arguments to a function call.
+
+Defaults to C<8>.
+
+=head2 $Carp::Verbose
+
+This variable makes C<Carp> use the C<longmess> function at all times.
+This effectively means that all calls to C<carp> become C<cluck> and
+all calls to C<croak> become C<confess>.
+
+Note, this is analogous to using C<use Carp 'verbose'>.
+
+Defaults to C<0>.
+
+=cut
+
+
+$CarpInternal{Carp}++;
+$CarpInternal{warnings}++;
+$CarpLevel = 0; # How many extra package levels to skip on carp.
+ # How many calls to skip on confess.
+ # Reconciling these notions is hard, use
+ # %Internal and %CarpInternal instead.
+$MaxEvalLen = 0; # How much eval '...text...' to show. 0 = all.
+$MaxArgLen = 64; # How much of each argument to print. 0 = all.
+$MaxArgNums = 8; # How many arguments to print. 0 = all.
+$Verbose = 0; # If true then make shortmess call longmess instead
+
+require Exporter;
+@ISA = ('Exporter');
+@EXPORT = qw(confess croak carp);
+@EXPORT_OK = qw(cluck verbose longmess shortmess);
+@EXPORT_FAIL = qw(verbose); # hook to enable verbose mode
+
+=head1 BUGS
+
+The Carp routines don't handle exception objects currently.
+If called with a first argument that is a reference, they simply
+call die() or warn(), as appropriate.
+
+=cut
+
+# if the caller specifies verbose usage ("perl -MCarp=verbose script.pl")
+# then the following method will be called by the Exporter which knows
+# to do this thanks to @EXPORT_FAIL, above. $_[1] will contain the word
+# 'verbose'.
+
+sub export_fail {
+ shift;
+ $Verbose = shift if $_[0] eq 'verbose';
+ return @_;
+}
+
+
+# longmess() crawls all the way up the stack reporting on all the function
+# calls made. The error string, $error, is originally constructed from the
+# arguments passed into longmess() via confess(), cluck() or shortmess().
+# This gets appended with the stack trace messages which are generated for
+# each function call on the stack.
+
+sub longmess {
+ {
+ local($@, $!);
+ # XXX fix require to not clear $@ or $!?
+ # don't use require unless we need to (for Safe compartments)
+ require Carp::Heavy unless $INC{"Carp/Heavy.pm"};
+ }
+ # Icky backwards compatibility wrapper. :-(
+ my $call_pack = caller();
+ if ($Internal{$call_pack} or $CarpInternal{$call_pack}) {
+ return longmess_heavy(@_);
+ }
+ else {
+ local $CarpLevel = $CarpLevel + 1;
+ return longmess_heavy(@_);
+ }
+}
+
+
+# shortmess() is called by carp() and croak() to skip all the way up to
+# the top-level caller's package and report the error from there. confess()
+# and cluck() generate a full stack trace so they call longmess() to
+# generate that. In verbose mode shortmess() calls longmess() so
+# you always get a stack trace
+
+sub shortmess { # Short-circuit &longmess if called via multiple packages
+ {
+ local($@, $!);
+ # XXX fix require to not clear $@ or $!?
+ # don't use require unless we need to (for Safe compartments)
+ require Carp::Heavy unless $INC{"Carp/Heavy.pm"};
+ }
+ # Icky backwards compatibility wrapper. :-(
+ my $call_pack = caller();
+ local @CARP_NOT = caller();
+ shortmess_heavy(@_);
+}
+
+
+# the following four functions call longmess() or shortmess() depending on
+# whether they should generate a full stack trace (confess() and cluck())
+# or simply report the caller's package (croak() and carp()), respectively.
+# confess() and croak() die, carp() and cluck() warn.
+
+sub croak { die shortmess @_ }
+sub confess { die longmess @_ }
+sub carp { warn shortmess @_ }
+sub cluck { warn longmess @_ }
+
+1;
diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Exporter.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Exporter.pm
new file mode 100644
index 00000000000..d9c22049776
--- /dev/null
+++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/Exporter.pm
@@ -0,0 +1,440 @@
+package Exporter;
+
+require 5.006;
+
+# Be lean.
+#use strict;
+#no strict 'refs';
+
+our $Debug = 0;
+our $ExportLevel = 0;
+our $Verbose ||= 0;
+our $VERSION = '5.58';
+our (%Cache);
+$Carp::Internal{Exporter} = 1;
+
+sub as_heavy {
+ require Exporter::Heavy;
+ # Unfortunately, this does not work if the caller is aliased as *name = \&foo
+ # Thus the need to create a lot of identical subroutines
+ my $c = (caller(1))[3];
+ $c =~ s/.*:://;
+ \&{"Exporter::Heavy::heavy_$c"};
+}
+
+sub export {
+ goto &{as_heavy()};
+}
+
+sub import {
+ my $pkg = shift;
+ my $callpkg = caller($ExportLevel);
+
+ if ($pkg eq "Exporter" and @_ and $_[0] eq "import") {
+ *{$callpkg."::import"} = \&import;
+ return;
+ }
+
+ # We *need* to treat @{"$pkg\::EXPORT_FAIL"} since Carp uses it :-(
+ my($exports, $fail) = (\@{"$pkg\::EXPORT"}, \@{"$pkg\::EXPORT_FAIL"});
+ return export $pkg, $callpkg, @_
+ if $Verbose or $Debug or @$fail > 1;
+ my $export_cache = ($Cache{$pkg} ||= {});
+ my $args = @_ or @_ = @$exports;
+
+ local $_;
+ if ($args and not %$export_cache) {
+ s/^&//, $export_cache->{$_} = 1
+ foreach (@$exports, @{"$pkg\::EXPORT_OK"});
+ }
+ my $heavy;
+ # Try very hard not to use {} and hence have to enter scope on the foreach
+ # We bomb out of the loop with last as soon as heavy is set.
+ if ($args or $fail) {
+ ($heavy = (/\W/ or $args and not exists $export_cache->{$_}
+ or @$fail and $_ eq $fail->[0])) and last
+ foreach (@_);
+ } else {
+ ($heavy = /\W/) and last
+ foreach (@_);
+ }
+ return export $pkg, $callpkg, ($args ? @_ : ()) if $heavy;
+ local $SIG{__WARN__} =
+ sub {require Carp; &Carp::carp};
+ # shortcut for the common case of no type character
+ *{"$callpkg\::$_"} = \&{"$pkg\::$_"} foreach @_;
+}
+
+# Default methods
+
+sub export_fail {
+ my $self = shift;
+ @_;
+}
+
+# Unfortunately, caller(1)[3] "does not work" if the caller is aliased as
+# *name = \&foo. Thus the need to create a lot of identical subroutines
+# Otherwise we could have aliased them to export().
+
+sub export_to_level {
+ goto &{as_heavy()};
+}
+
+sub export_tags {
+ goto &{as_heavy()};
+}
+
+sub export_ok_tags {
+ goto &{as_heavy()};
+}
+
+sub require_version {
+ goto &{as_heavy()};
+}
+
+1;
+__END__
+
+=head1 NAME
+
+Exporter - Implements default import method for modules
+
+=head1 SYNOPSIS
+
+In module YourModule.pm:
+
+ package YourModule;
+ require Exporter;
+ @ISA = qw(Exporter);
+ @EXPORT_OK = qw(munge frobnicate); # symbols to export on request
+
+or
+
+ package YourModule;
+ use Exporter 'import'; # gives you Exporter's import() method directly
+ @EXPORT_OK = qw(munge frobnicate); # symbols to export on request
+
+In other files which wish to use YourModule:
+
+ use ModuleName qw(frobnicate); # import listed symbols
+ frobnicate ($left, $right) # calls YourModule::frobnicate
+
+=head1 DESCRIPTION
+
+The Exporter module implements an C<import> method which allows a module
+to export functions and variables to its users' namespaces. Many modules
+use Exporter rather than implementing their own C<import> method because
+Exporter provides a highly flexible interface, with an implementation optimised
+for the common case.
+
+Perl automatically calls the C<import> method when processing a
+C<use> statement for a module. Modules and C<use> are documented
+in L<perlfunc> and L<perlmod>. Understanding the concept of
+modules and how the C<use> statement operates is important to
+understanding the Exporter.
+
+=head2 How to Export
+
+The arrays C<@EXPORT> and C<@EXPORT_OK> in a module hold lists of
+symbols that are going to be exported into the users name space by
+default, or which they can request to be exported, respectively. The
+symbols can represent functions, scalars, arrays, hashes, or typeglobs.
+The symbols must be given by full name with the exception that the
+ampersand in front of a function is optional, e.g.
+
+ @EXPORT = qw(afunc $scalar @array); # afunc is a function
+ @EXPORT_OK = qw(&bfunc %hash *typeglob); # explicit prefix on &bfunc
+
+If you are only exporting function names it is recommended to omit the
+ampersand, as the implementation is faster this way.
+
+=head2 Selecting What To Export
+
+Do B<not> export method names!
+
+Do B<not> export anything else by default without a good reason!
+
+Exports pollute the namespace of the module user. If you must export
+try to use @EXPORT_OK in preference to @EXPORT and avoid short or
+common symbol names to reduce the risk of name clashes.
+
+Generally anything not exported is still accessible from outside the
+module using the ModuleName::item_name (or $blessed_ref-E<gt>method)
+syntax. By convention you can use a leading underscore on names to
+informally indicate that they are 'internal' and not for public use.
+
+(It is actually possible to get private functions by saying:
+
+ my $subref = sub { ... };
+ $subref->(@args); # Call it as a function
+ $obj->$subref(@args); # Use it as a method
+
+However if you use them for methods it is up to you to figure out
+how to make inheritance work.)
+
+As a general rule, if the module is trying to be object oriented
+then export nothing. If it's just a collection of functions then
+@EXPORT_OK anything but use @EXPORT with caution. For function and
+method names use barewords in preference to names prefixed with
+ampersands for the export lists.
+
+Other module design guidelines can be found in L<perlmod>.
+
+=head2 How to Import
+
+In other files which wish to use your module there are three basic ways for
+them to load your module and import its symbols:
+
+=over 4
+
+=item C<use ModuleName;>
+
+This imports all the symbols from ModuleName's @EXPORT into the namespace
+of the C<use> statement.
+
+=item C<use ModuleName ();>
+
+This causes perl to load your module but does not import any symbols.
+
+=item C<use ModuleName qw(...);>
+
+This imports only the symbols listed by the caller into their namespace.
+All listed symbols must be in your @EXPORT or @EXPORT_OK, else an error
+occurs. The advanced export features of Exporter are accessed like this,
+but with list entries that are syntactically distinct from symbol names.
+
+=back
+
+Unless you want to use its advanced features, this is probably all you
+need to know to use Exporter.
+
+=head1 Advanced features
+
+=head2 Specialised Import Lists
+
+If any of the entries in an import list begins with !, : or / then
+the list is treated as a series of specifications which either add to
+or delete from the list of names to import. They are processed left to
+right. Specifications are in the form:
+
+ [!]name This name only
+ [!]:DEFAULT All names in @EXPORT
+ [!]:tag All names in $EXPORT_TAGS{tag} anonymous list
+ [!]/pattern/ All names in @EXPORT and @EXPORT_OK which match
+
+A leading ! indicates that matching names should be deleted from the
+list of names to import. If the first specification is a deletion it
+is treated as though preceded by :DEFAULT. If you just want to import
+extra names in addition to the default set you will still need to
+include :DEFAULT explicitly.
+
+e.g., Module.pm defines:
+
+ @EXPORT = qw(A1 A2 A3 A4 A5);
+ @EXPORT_OK = qw(B1 B2 B3 B4 B5);
+ %EXPORT_TAGS = (T1 => [qw(A1 A2 B1 B2)], T2 => [qw(A1 A2 B3 B4)]);
+
+ Note that you cannot use tags in @EXPORT or @EXPORT_OK.
+ Names in EXPORT_TAGS must also appear in @EXPORT or @EXPORT_OK.
+
+An application using Module can say something like:
+
+ use Module qw(:DEFAULT :T2 !B3 A3);
+
+Other examples include:
+
+ use Socket qw(!/^[AP]F_/ !SOMAXCONN !SOL_SOCKET);
+ use POSIX qw(:errno_h :termios_h !TCSADRAIN !/^EXIT/);
+
+Remember that most patterns (using //) will need to be anchored
+with a leading ^, e.g., C</^EXIT/> rather than C</EXIT/>.
+
+You can say C<BEGIN { $Exporter::Verbose=1 }> to see how the
+specifications are being processed and what is actually being imported
+into modules.
+
+=head2 Exporting without using Exporter's import method
+
+Exporter has a special method, 'export_to_level' which is used in situations
+where you can't directly call Exporter's import method. The export_to_level
+method looks like:
+
+ MyPackage->export_to_level($where_to_export, $package, @what_to_export);
+
+where $where_to_export is an integer telling how far up the calling stack
+to export your symbols, and @what_to_export is an array telling what
+symbols *to* export (usually this is @_). The $package argument is
+currently unused.
+
+For example, suppose that you have a module, A, which already has an
+import function:
+
+ package A;
+
+ @ISA = qw(Exporter);
+ @EXPORT_OK = qw ($b);
+
+ sub import
+ {
+ $A::b = 1; # not a very useful import method
+ }
+
+and you want to Export symbol $A::b back to the module that called
+package A. Since Exporter relies on the import method to work, via
+inheritance, as it stands Exporter::import() will never get called.
+Instead, say the following:
+
+ package A;
+ @ISA = qw(Exporter);
+ @EXPORT_OK = qw ($b);
+
+ sub import
+ {
+ $A::b = 1;
+ A->export_to_level(1, @_);
+ }
+
+This will export the symbols one level 'above' the current package - ie: to
+the program or module that used package A.
+
+Note: Be careful not to modify C<@_> at all before you call export_to_level
+- or people using your package will get very unexplained results!
+
+=head2 Exporting without inheriting from Exporter
+
+By including Exporter in your @ISA you inherit an Exporter's import() method
+but you also inherit several other helper methods which you probably don't
+want. To avoid this you can do
+
+ package YourModule;
+ use Exporter qw( import );
+
+which will export Exporter's own import() method into YourModule.
+Everything will work as before but you won't need to include Exporter in
+@YourModule::ISA.
+
+=head2 Module Version Checking
+
+The Exporter module will convert an attempt to import a number from a
+module into a call to $module_name-E<gt>require_version($value). This can
+be used to validate that the version of the module being used is
+greater than or equal to the required version.
+
+The Exporter module supplies a default require_version method which
+checks the value of $VERSION in the exporting module.
+
+Since the default require_version method treats the $VERSION number as
+a simple numeric value it will regard version 1.10 as lower than
+1.9. For this reason it is strongly recommended that you use numbers
+with at least two decimal places, e.g., 1.09.
+
+=head2 Managing Unknown Symbols
+
+In some situations you may want to prevent certain symbols from being
+exported. Typically this applies to extensions which have functions
+or constants that may not exist on some systems.
+
+The names of any symbols that cannot be exported should be listed
+in the C<@EXPORT_FAIL> array.
+
+If a module attempts to import any of these symbols the Exporter
+will give the module an opportunity to handle the situation before
+generating an error. The Exporter will call an export_fail method
+with a list of the failed symbols:
+
+ @failed_symbols = $module_name->export_fail(@failed_symbols);
+
+If the export_fail method returns an empty list then no error is
+recorded and all the requested symbols are exported. If the returned
+list is not empty then an error is generated for each symbol and the
+export fails. The Exporter provides a default export_fail method which
+simply returns the list unchanged.
+
+Uses for the export_fail method include giving better error messages
+for some symbols and performing lazy architectural checks (put more
+symbols into @EXPORT_FAIL by default and then take them out if someone
+actually tries to use them and an expensive check shows that they are
+usable on that platform).
+
+=head2 Tag Handling Utility Functions
+
+Since the symbols listed within %EXPORT_TAGS must also appear in either
+@EXPORT or @EXPORT_OK, two utility functions are provided which allow
+you to easily add tagged sets of symbols to @EXPORT or @EXPORT_OK:
+
+ %EXPORT_TAGS = (foo => [qw(aa bb cc)], bar => [qw(aa cc dd)]);
+
+ Exporter::export_tags('foo'); # add aa, bb and cc to @EXPORT
+ Exporter::export_ok_tags('bar'); # add aa, cc and dd to @EXPORT_OK
+
+Any names which are not tags are added to @EXPORT or @EXPORT_OK
+unchanged but will trigger a warning (with C<-w>) to avoid misspelt tags
+names being silently added to @EXPORT or @EXPORT_OK. Future versions
+may make this a fatal error.
+
+=head2 Generating combined tags
+
+If several symbol categories exist in %EXPORT_TAGS, it's usually
+useful to create the utility ":all" to simplify "use" statements.
+
+The simplest way to do this is:
+
+ %EXPORT_TAGS = (foo => [qw(aa bb cc)], bar => [qw(aa cc dd)]);
+
+ # add all the other ":class" tags to the ":all" class,
+ # deleting duplicates
+ {
+ my %seen;
+
+ push @{$EXPORT_TAGS{all}},
+ grep {!$seen{$_}++} @{$EXPORT_TAGS{$_}} foreach keys %EXPORT_TAGS;
+ }
+
+CGI.pm creates an ":all" tag which contains some (but not really
+all) of its categories. That could be done with one small
+change:
+
+ # add some of the other ":class" tags to the ":all" class,
+ # deleting duplicates
+ {
+ my %seen;
+
+ push @{$EXPORT_TAGS{all}},
+ grep {!$seen{$_}++} @{$EXPORT_TAGS{$_}}
+ foreach qw/html2 html3 netscape form cgi internal/;
+ }
+
+Note that the tag names in %EXPORT_TAGS don't have the leading ':'.
+
+=head2 C<AUTOLOAD>ed Constants
+
+Many modules make use of C<AUTOLOAD>ing for constant subroutines to
+avoid having to compile and waste memory on rarely used values (see
+L<perlsub> for details on constant subroutines). Calls to such
+constant subroutines are not optimized away at compile time because
+they can't be checked at compile time for constancy.
+
+Even if a prototype is available at compile time, the body of the
+subroutine is not (it hasn't been C<AUTOLOAD>ed yet). perl needs to
+examine both the C<()> prototype and the body of a subroutine at
+compile time to detect that it can safely replace calls to that
+subroutine with the constant value.
+
+A workaround for this is to call the constants once in a C<BEGIN> block:
+
+ package My ;
+
+ use Socket ;
+
+ foo( SO_LINGER ); ## SO_LINGER NOT optimized away; called at runtime
+ BEGIN { SO_LINGER }
+ foo( SO_LINGER ); ## SO_LINGER optimized away at compile time.
+
+This forces the C<AUTOLOAD> for C<SO_LINGER> to take place before
+SO_LINGER is encountered later in C<My> package.
+
+If you are writing a package that C<AUTOLOAD>s, consider forcing
+an C<AUTOLOAD> for any constants explicitly imported by other packages
+or which are usually used when your package is C<use>d.
+
+=cut
diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Exporter/Heavy.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Exporter/Heavy.pm
new file mode 100644
index 00000000000..2cc792288f0
--- /dev/null
+++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/Exporter/Heavy.pm
@@ -0,0 +1,248 @@
+package Exporter::Heavy;
+
+use strict;
+no strict 'refs';
+
+# On one line so MakeMaker will see it.
+require Exporter; our $VERSION = $Exporter::VERSION;
+$Carp::Internal{"Exporter::Heavy"} = 1;
+
+=head1 NAME
+
+Exporter::Heavy - Exporter guts
+
+=head1 SYNOPSIS
+
+(internal use only)
+
+=head1 DESCRIPTION
+
+No user-serviceable parts inside.
+
+=cut
+
+#
+# We go to a lot of trouble not to 'require Carp' at file scope,
+# because Carp requires Exporter, and something has to give.
+#
+
+sub _rebuild_cache {
+ my ($pkg, $exports, $cache) = @_;
+ s/^&// foreach @$exports;
+ @{$cache}{@$exports} = (1) x @$exports;
+ my $ok = \@{"${pkg}::EXPORT_OK"};
+ if (@$ok) {
+ s/^&// foreach @$ok;
+ @{$cache}{@$ok} = (1) x @$ok;
+ }
+}
+
+sub heavy_export {
+
+ # First make import warnings look like they're coming from the "use".
+ local $SIG{__WARN__} = sub {
+ my $text = shift;
+ if ($text =~ s/ at \S*Exporter\S*.pm line \d+.*\n//) {
+ require Carp;
+ local $Carp::CarpLevel = 1; # ignore package calling us too.
+ Carp::carp($text);
+ }
+ else {
+ warn $text;
+ }
+ };
+ local $SIG{__DIE__} = sub {
+ require Carp;
+ local $Carp::CarpLevel = 1; # ignore package calling us too.
+ Carp::croak("$_[0]Illegal null symbol in \@${1}::EXPORT")
+ if $_[0] =~ /^Unable to create sub named "(.*?)::"/;
+ };
+
+ my($pkg, $callpkg, @imports) = @_;
+ my($type, $sym, $cache_is_current, $oops);
+ my($exports, $export_cache) = (\@{"${pkg}::EXPORT"},
+ $Exporter::Cache{$pkg} ||= {});
+
+ if (@imports) {
+ if (!%$export_cache) {
+ _rebuild_cache ($pkg, $exports, $export_cache);
+ $cache_is_current = 1;
+ }
+
+ if (grep m{^[/!:]}, @imports) {
+ my $tagsref = \%{"${pkg}::EXPORT_TAGS"};
+ my $tagdata;
+ my %imports;
+ my($remove, $spec, @names, @allexports);
+ # negated first item implies starting with default set:
+ unshift @imports, ':DEFAULT' if $imports[0] =~ m/^!/;
+ foreach $spec (@imports){
+ $remove = $spec =~ s/^!//;
+
+ if ($spec =~ s/^://){
+ if ($spec eq 'DEFAULT'){
+ @names = @$exports;
+ }
+ elsif ($tagdata = $tagsref->{$spec}) {
+ @names = @$tagdata;
+ }
+ else {
+ warn qq["$spec" is not defined in %${pkg}::EXPORT_TAGS];
+ ++$oops;
+ next;
+ }
+ }
+ elsif ($spec =~ m:^/(.*)/$:){
+ my $patn = $1;
+ @allexports = keys %$export_cache unless @allexports; # only do keys once
+ @names = grep(/$patn/, @allexports); # not anchored by default
+ }
+ else {
+ @names = ($spec); # is a normal symbol name
+ }
+
+ warn "Import ".($remove ? "del":"add").": @names "
+ if $Exporter::Verbose;
+
+ if ($remove) {
+ foreach $sym (@names) { delete $imports{$sym} }
+ }
+ else {
+ @imports{@names} = (1) x @names;
+ }
+ }
+ @imports = keys %imports;
+ }
+
+ my @carp;
+ foreach $sym (@imports) {
+ if (!$export_cache->{$sym}) {
+ if ($sym =~ m/^\d/) {
+ $pkg->VERSION($sym); # inherit from UNIVERSAL
+ # If the version number was the only thing specified
+ # then we should act as if nothing was specified:
+ if (@imports == 1) {
+ @imports = @$exports;
+ last;
+ }
+ # We need a way to emulate 'use Foo ()' but still
+ # allow an easy version check: "use Foo 1.23, ''";
+ if (@imports == 2 and !$imports[1]) {
+ @imports = ();
+ last;
+ }
+ } elsif ($sym !~ s/^&// || !$export_cache->{$sym}) {
+ # Last chance - see if they've updated EXPORT_OK since we
+ # cached it.
+
+ unless ($cache_is_current) {
+ %$export_cache = ();
+ _rebuild_cache ($pkg, $exports, $export_cache);
+ $cache_is_current = 1;
+ }
+
+ if (!$export_cache->{$sym}) {
+ # accumulate the non-exports
+ push @carp,
+ qq["$sym" is not exported by the $pkg module\n];
+ $oops++;
+ }
+ }
+ }
+ }
+ if ($oops) {
+ require Carp;
+ Carp::croak("@{carp}Can't continue after import errors");
+ }
+ }
+ else {
+ @imports = @$exports;
+ }
+
+ my($fail, $fail_cache) = (\@{"${pkg}::EXPORT_FAIL"},
+ $Exporter::FailCache{$pkg} ||= {});
+
+ if (@$fail) {
+ if (!%$fail_cache) {
+ # Build cache of symbols. Optimise the lookup by adding
+ # barewords twice... both with and without a leading &.
+ # (Technique could be applied to $export_cache at cost of memory)
+ my @expanded = map { /^\w/ ? ($_, '&'.$_) : $_ } @$fail;
+ warn "${pkg}::EXPORT_FAIL cached: @expanded" if $Exporter::Verbose;
+ @{$fail_cache}{@expanded} = (1) x @expanded;
+ }
+ my @failed;
+ foreach $sym (@imports) { push(@failed, $sym) if $fail_cache->{$sym} }
+ if (@failed) {
+ @failed = $pkg->export_fail(@failed);
+ foreach $sym (@failed) {
+ require Carp;
+ Carp::carp(qq["$sym" is not implemented by the $pkg module ],
+ "on this architecture");
+ }
+ if (@failed) {
+ require Carp;
+ Carp::croak("Can't continue after import errors");
+ }
+ }
+ }
+
+ warn "Importing into $callpkg from $pkg: ",
+ join(", ",sort @imports) if $Exporter::Verbose;
+
+ foreach $sym (@imports) {
+ # shortcut for the common case of no type character
+ (*{"${callpkg}::$sym"} = \&{"${pkg}::$sym"}, next)
+ unless $sym =~ s/^(\W)//;
+ $type = $1;
+ *{"${callpkg}::$sym"} =
+ $type eq '&' ? \&{"${pkg}::$sym"} :
+ $type eq '$' ? \${"${pkg}::$sym"} :
+ $type eq '@' ? \@{"${pkg}::$sym"} :
+ $type eq '%' ? \%{"${pkg}::$sym"} :
+ $type eq '*' ? *{"${pkg}::$sym"} :
+ do { require Carp; Carp::croak("Can't export symbol: $type$sym") };
+ }
+}
+
+sub heavy_export_to_level
+{
+ my $pkg = shift;
+ my $level = shift;
+ (undef) = shift; # XXX redundant arg
+ my $callpkg = caller($level);
+ $pkg->export($callpkg, @_);
+}
+
+# Utility functions
+
+sub _push_tags {
+ my($pkg, $var, $syms) = @_;
+ my @nontag = ();
+ my $export_tags = \%{"${pkg}::EXPORT_TAGS"};
+ push(@{"${pkg}::$var"},
+ map { $export_tags->{$_} ? @{$export_tags->{$_}}
+ : scalar(push(@nontag,$_),$_) }
+ (@$syms) ? @$syms : keys %$export_tags);
+ if (@nontag and $^W) {
+ # This may change to a die one day
+ require Carp;
+ Carp::carp(join(", ", @nontag)." are not tags of $pkg");
+ }
+}
+
+sub heavy_require_version {
+ my($self, $wanted) = @_;
+ my $pkg = ref $self || $self;
+ return ${pkg}->VERSION($wanted);
+}
+
+sub heavy_export_tags {
+ _push_tags((caller)[0], "EXPORT", \@_);
+}
+
+sub heavy_export_ok_tags {
+ _push_tags((caller)[0], "EXPORT_OK", \@_);
+}
+
+1;
diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Getopt/Long.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Getopt/Long.pm
new file mode 100644
index 00000000000..04038db58e3
--- /dev/null
+++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/Getopt/Long.pm
@@ -0,0 +1,2504 @@
+# Getopt::Long.pm -- Universal options parsing
+
+package Getopt::Long;
+
+# RCS Status : $Id: GetoptLong.pm,v 2.72 2005-04-28 21:18:33+02 jv Exp $
+# Author : Johan Vromans
+# Created On : Tue Sep 11 15:00:12 1990
+# Last Modified By: Johan Vromans
+# Last Modified On: Wed Dec 14 21:17:21 2005
+# Update Count : 1458
+# Status : Released
+
+################ Copyright ################
+
+# This program is Copyright 1990,2005 by Johan Vromans.
+# This program is free software; you can redistribute it and/or
+# modify it under the terms of the Perl Artistic License or the
+# GNU General Public License as published by the Free Software
+# Foundation; either version 2 of the License, or (at your option) 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.
+#
+# If you do not have a copy of the GNU General Public License write to
+# the Free Software Foundation, Inc., 675 Mass Ave, Cambridge,
+# MA 02139, USA.
+
+################ Module Preamble ################
+
+use 5.004;
+
+use strict;
+
+use vars qw($VERSION);
+$VERSION = 2.35;
+# For testing versions only.
+#use vars qw($VERSION_STRING);
+#$VERSION_STRING = "2.35";
+
+use Exporter;
+use vars qw(@ISA @EXPORT @EXPORT_OK);
+@ISA = qw(Exporter);
+
+# Exported subroutines.
+sub GetOptions(@); # always
+sub Configure(@); # on demand
+sub HelpMessage(@); # on demand
+sub VersionMessage(@); # in demand
+
+BEGIN {
+ # Init immediately so their contents can be used in the 'use vars' below.
+ @EXPORT = qw(&GetOptions $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER);
+ @EXPORT_OK = qw(&HelpMessage &VersionMessage &Configure);
+}
+
+# User visible variables.
+use vars @EXPORT, @EXPORT_OK;
+use vars qw($error $debug $major_version $minor_version);
+# Deprecated visible variables.
+use vars qw($autoabbrev $getopt_compat $ignorecase $bundling $order
+ $passthrough);
+# Official invisible variables.
+use vars qw($genprefix $caller $gnu_compat $auto_help $auto_version $longprefix);
+
+# Public subroutines.
+sub config(@); # deprecated name
+
+# Private subroutines.
+sub ConfigDefaults();
+sub ParseOptionSpec($$);
+sub OptCtl($);
+sub FindOption($$$$);
+sub ValidValue ($$$$$);
+
+################ Local Variables ################
+
+# $requested_version holds the version that was mentioned in the 'use'
+# or 'require', if any. It can be used to enable or disable specific
+# features.
+my $requested_version = 0;
+
+################ Resident subroutines ################
+
+sub ConfigDefaults() {
+ # Handle POSIX compliancy.
+ if ( defined $ENV{"POSIXLY_CORRECT"} ) {
+ $genprefix = "(--|-)";
+ $autoabbrev = 0; # no automatic abbrev of options
+ $bundling = 0; # no bundling of single letter switches
+ $getopt_compat = 0; # disallow '+' to start options
+ $order = $REQUIRE_ORDER;
+ }
+ else {
+ $genprefix = "(--|-|\\+)";
+ $autoabbrev = 1; # automatic abbrev of options
+ $bundling = 0; # bundling off by default
+ $getopt_compat = 1; # allow '+' to start options
+ $order = $PERMUTE;
+ }
+ # Other configurable settings.
+ $debug = 0; # for debugging
+ $error = 0; # error tally
+ $ignorecase = 1; # ignore case when matching options
+ $passthrough = 0; # leave unrecognized options alone
+ $gnu_compat = 0; # require --opt=val if value is optional
+ $longprefix = "(--)"; # what does a long prefix look like
+}
+
+# Override import.
+sub import {
+ my $pkg = shift; # package
+ my @syms = (); # symbols to import
+ my @config = (); # configuration
+ my $dest = \@syms; # symbols first
+ for ( @_ ) {
+ if ( $_ eq ':config' ) {
+ $dest = \@config; # config next
+ next;
+ }
+ push(@$dest, $_); # push
+ }
+ # Hide one level and call super.
+ local $Exporter::ExportLevel = 1;
+ push(@syms, qw(&GetOptions)) if @syms; # always export GetOptions
+ $pkg->SUPER::import(@syms);
+ # And configure.
+ Configure(@config) if @config;
+}
+
+################ Initialization ################
+
+# Values for $order. See GNU getopt.c for details.
+($REQUIRE_ORDER, $PERMUTE, $RETURN_IN_ORDER) = (0..2);
+# Version major/minor numbers.
+($major_version, $minor_version) = $VERSION =~ /^(\d+)\.(\d+)/;
+
+ConfigDefaults();
+
+################ OO Interface ################
+
+package Getopt::Long::Parser;
+
+# Store a copy of the default configuration. Since ConfigDefaults has
+# just been called, what we get from Configure is the default.
+my $default_config = do {
+ Getopt::Long::Configure ()
+};
+
+sub new {
+ my $that = shift;
+ my $class = ref($that) || $that;
+ my %atts = @_;
+
+ # Register the callers package.
+ my $self = { caller_pkg => (caller)[0] };
+
+ bless ($self, $class);
+
+ # Process config attributes.
+ if ( defined $atts{config} ) {
+ my $save = Getopt::Long::Configure ($default_config, @{$atts{config}});
+ $self->{settings} = Getopt::Long::Configure ($save);
+ delete ($atts{config});
+ }
+ # Else use default config.
+ else {
+ $self->{settings} = $default_config;
+ }
+
+ if ( %atts ) { # Oops
+ die(__PACKAGE__.": unhandled attributes: ".
+ join(" ", sort(keys(%atts)))."\n");
+ }
+
+ $self;
+}
+
+sub configure {
+ my ($self) = shift;
+
+ # Restore settings, merge new settings in.
+ my $save = Getopt::Long::Configure ($self->{settings}, @_);
+
+ # Restore orig config and save the new config.
+ $self->{settings} = Getopt::Long::Configure ($save);
+}
+
+sub getoptions {
+ my ($self) = shift;
+
+ # Restore config settings.
+ my $save = Getopt::Long::Configure ($self->{settings});
+
+ # Call main routine.
+ my $ret = 0;
+ $Getopt::Long::caller = $self->{caller_pkg};
+
+ eval {
+ # Locally set exception handler to default, otherwise it will
+ # be called implicitly here, and again explicitly when we try
+ # to deliver the messages.
+ local ($SIG{__DIE__}) = '__DEFAULT__';
+ $ret = Getopt::Long::GetOptions (@_);
+ };
+
+ # Restore saved settings.
+ Getopt::Long::Configure ($save);
+
+ # Handle errors and return value.
+ die ($@) if $@;
+ return $ret;
+}
+
+package Getopt::Long;
+
+################ Back to Normal ################
+
+# Indices in option control info.
+# Note that ParseOptions uses the fields directly. Search for 'hard-wired'.
+use constant CTL_TYPE => 0;
+#use constant CTL_TYPE_FLAG => '';
+#use constant CTL_TYPE_NEG => '!';
+#use constant CTL_TYPE_INCR => '+';
+#use constant CTL_TYPE_INT => 'i';
+#use constant CTL_TYPE_INTINC => 'I';
+#use constant CTL_TYPE_XINT => 'o';
+#use constant CTL_TYPE_FLOAT => 'f';
+#use constant CTL_TYPE_STRING => 's';
+
+use constant CTL_CNAME => 1;
+
+use constant CTL_DEFAULT => 2;
+
+use constant CTL_DEST => 3;
+ use constant CTL_DEST_SCALAR => 0;
+ use constant CTL_DEST_ARRAY => 1;
+ use constant CTL_DEST_HASH => 2;
+ use constant CTL_DEST_CODE => 3;
+
+use constant CTL_AMIN => 4;
+use constant CTL_AMAX => 5;
+
+# FFU.
+#use constant CTL_RANGE => ;
+#use constant CTL_REPEAT => ;
+
+sub GetOptions(@) {
+
+ my @optionlist = @_; # local copy of the option descriptions
+ my $argend = '--'; # option list terminator
+ my %opctl = (); # table of option specs
+ my $pkg = $caller || (caller)[0]; # current context
+ # Needed if linkage is omitted.
+ my @ret = (); # accum for non-options
+ my %linkage; # linkage
+ my $userlinkage; # user supplied HASH
+ my $opt; # current option
+ my $prefix = $genprefix; # current prefix
+
+ $error = '';
+
+ if ( $debug ) {
+ # Avoid some warnings if debugging.
+ local ($^W) = 0;
+ print STDERR
+ ("Getopt::Long $Getopt::Long::VERSION (",
+ '$Revision: 2.72 $', ") ",
+ "called from package \"$pkg\".",
+ "\n ",
+ "ARGV: (@ARGV)",
+ "\n ",
+ "autoabbrev=$autoabbrev,".
+ "bundling=$bundling,",
+ "getopt_compat=$getopt_compat,",
+ "gnu_compat=$gnu_compat,",
+ "order=$order,",
+ "\n ",
+ "ignorecase=$ignorecase,",
+ "requested_version=$requested_version,",
+ "passthrough=$passthrough,",
+ "genprefix=\"$genprefix\",",
+ "longprefix=\"$longprefix\".",
+ "\n");
+ }
+
+ # Check for ref HASH as first argument.
+ # First argument may be an object. It's OK to use this as long
+ # as it is really a hash underneath.
+ $userlinkage = undef;
+ if ( @optionlist && ref($optionlist[0]) and
+ UNIVERSAL::isa($optionlist[0],'HASH') ) {
+ $userlinkage = shift (@optionlist);
+ print STDERR ("=> user linkage: $userlinkage\n") if $debug;
+ }
+
+ # See if the first element of the optionlist contains option
+ # starter characters.
+ # Be careful not to interpret '<>' as option starters.
+ if ( @optionlist && $optionlist[0] =~ /^\W+$/
+ && !($optionlist[0] eq '<>'
+ && @optionlist > 0
+ && ref($optionlist[1])) ) {
+ $prefix = shift (@optionlist);
+ # Turn into regexp. Needs to be parenthesized!
+ $prefix =~ s/(\W)/\\$1/g;
+ $prefix = "([" . $prefix . "])";
+ print STDERR ("=> prefix=\"$prefix\"\n") if $debug;
+ }
+
+ # Verify correctness of optionlist.
+ %opctl = ();
+ while ( @optionlist ) {
+ my $opt = shift (@optionlist);
+
+ unless ( defined($opt) ) {
+ $error .= "Undefined argument in option spec\n";
+ next;
+ }
+
+ # Strip leading prefix so people can specify "--foo=i" if they like.
+ $opt = $+ if $opt =~ /^$prefix+(.*)$/s;
+
+ if ( $opt eq '<>' ) {
+ if ( (defined $userlinkage)
+ && !(@optionlist > 0 && ref($optionlist[0]))
+ && (exists $userlinkage->{$opt})
+ && ref($userlinkage->{$opt}) ) {
+ unshift (@optionlist, $userlinkage->{$opt});
+ }
+ unless ( @optionlist > 0
+ && ref($optionlist[0]) && ref($optionlist[0]) eq 'CODE' ) {
+ $error .= "Option spec <> requires a reference to a subroutine\n";
+ # Kill the linkage (to avoid another error).
+ shift (@optionlist)
+ if @optionlist && ref($optionlist[0]);
+ next;
+ }
+ $linkage{'<>'} = shift (@optionlist);
+ next;
+ }
+
+ # Parse option spec.
+ my ($name, $orig) = ParseOptionSpec ($opt, \%opctl);
+ unless ( defined $name ) {
+ # Failed. $orig contains the error message. Sorry for the abuse.
+ $error .= $orig;
+ # Kill the linkage (to avoid another error).
+ shift (@optionlist)
+ if @optionlist && ref($optionlist[0]);
+ next;
+ }
+
+ # If no linkage is supplied in the @optionlist, copy it from
+ # the userlinkage if available.
+ if ( defined $userlinkage ) {
+ unless ( @optionlist > 0 && ref($optionlist[0]) ) {
+ if ( exists $userlinkage->{$orig} &&
+ ref($userlinkage->{$orig}) ) {
+ print STDERR ("=> found userlinkage for \"$orig\": ",
+ "$userlinkage->{$orig}\n")
+ if $debug;
+ unshift (@optionlist, $userlinkage->{$orig});
+ }
+ else {
+ # Do nothing. Being undefined will be handled later.
+ next;
+ }
+ }
+ }
+
+ # Copy the linkage. If omitted, link to global variable.
+ if ( @optionlist > 0 && ref($optionlist[0]) ) {
+ print STDERR ("=> link \"$orig\" to $optionlist[0]\n")
+ if $debug;
+ my $rl = ref($linkage{$orig} = shift (@optionlist));
+
+ if ( $rl eq "ARRAY" ) {
+ $opctl{$name}[CTL_DEST] = CTL_DEST_ARRAY;
+ }
+ elsif ( $rl eq "HASH" ) {
+ $opctl{$name}[CTL_DEST] = CTL_DEST_HASH;
+ }
+ elsif ( $rl eq "SCALAR" ) {
+# if ( $opctl{$name}[CTL_DEST] == CTL_DEST_ARRAY ) {
+# my $t = $linkage{$orig};
+# $$t = $linkage{$orig} = [];
+# }
+# elsif ( $opctl{$name}[CTL_DEST] == CTL_DEST_HASH ) {
+# }
+# else {
+ # Ok.
+# }
+ }
+ elsif ( $rl eq "CODE" ) {
+ # Ok.
+ }
+ else {
+ $error .= "Invalid option linkage for \"$opt\"\n";
+ }
+ }
+ else {
+ # Link to global $opt_XXX variable.
+ # Make sure a valid perl identifier results.
+ my $ov = $orig;
+ $ov =~ s/\W/_/g;
+ if ( $opctl{$name}[CTL_DEST] == CTL_DEST_ARRAY ) {
+ print STDERR ("=> link \"$orig\" to \@$pkg","::opt_$ov\n")
+ if $debug;
+ eval ("\$linkage{\$orig} = \\\@".$pkg."::opt_$ov;");
+ }
+ elsif ( $opctl{$name}[CTL_DEST] == CTL_DEST_HASH ) {
+ print STDERR ("=> link \"$orig\" to \%$pkg","::opt_$ov\n")
+ if $debug;
+ eval ("\$linkage{\$orig} = \\\%".$pkg."::opt_$ov;");
+ }
+ else {
+ print STDERR ("=> link \"$orig\" to \$$pkg","::opt_$ov\n")
+ if $debug;
+ eval ("\$linkage{\$orig} = \\\$".$pkg."::opt_$ov;");
+ }
+ }
+ }
+
+ # Bail out if errors found.
+ die ($error) if $error;
+ $error = 0;
+
+ # Supply --version and --help support, if needed and allowed.
+ if ( defined($auto_version) ? $auto_version : ($requested_version >= 2.3203) ) {
+ if ( !defined($opctl{version}) ) {
+ $opctl{version} = ['','version',0,CTL_DEST_CODE,undef];
+ $linkage{version} = \&VersionMessage;
+ }
+ $auto_version = 1;
+ }
+ if ( defined($auto_help) ? $auto_help : ($requested_version >= 2.3203) ) {
+ if ( !defined($opctl{help}) && !defined($opctl{'?'}) ) {
+ $opctl{help} = $opctl{'?'} = ['','help',0,CTL_DEST_CODE,undef];
+ $linkage{help} = \&HelpMessage;
+ }
+ $auto_help = 1;
+ }
+
+ # Show the options tables if debugging.
+ if ( $debug ) {
+ my ($arrow, $k, $v);
+ $arrow = "=> ";
+ while ( ($k,$v) = each(%opctl) ) {
+ print STDERR ($arrow, "\$opctl{$k} = $v ", OptCtl($v), "\n");
+ $arrow = " ";
+ }
+ }
+
+ # Process argument list
+ my $goon = 1;
+ while ( $goon && @ARGV > 0 ) {
+
+ # Get next argument.
+ $opt = shift (@ARGV);
+ print STDERR ("=> arg \"", $opt, "\"\n") if $debug;
+
+ # Double dash is option list terminator.
+ if ( $opt eq $argend ) {
+ push (@ret, $argend) if $passthrough;
+ last;
+ }
+
+ # Look it up.
+ my $tryopt = $opt;
+ my $found; # success status
+ my $key; # key (if hash type)
+ my $arg; # option argument
+ my $ctl; # the opctl entry
+
+ ($found, $opt, $ctl, $arg, $key) =
+ FindOption ($prefix, $argend, $opt, \%opctl);
+
+ if ( $found ) {
+
+ # FindOption undefines $opt in case of errors.
+ next unless defined $opt;
+
+ my $argcnt = 0;
+ while ( defined $arg ) {
+
+ # Get the canonical name.
+ print STDERR ("=> cname for \"$opt\" is ") if $debug;
+ $opt = $ctl->[CTL_CNAME];
+ print STDERR ("\"$ctl->[CTL_CNAME]\"\n") if $debug;
+
+ if ( defined $linkage{$opt} ) {
+ print STDERR ("=> ref(\$L{$opt}) -> ",
+ ref($linkage{$opt}), "\n") if $debug;
+
+ if ( ref($linkage{$opt}) eq 'SCALAR' ) {
+ if ( $ctl->[CTL_TYPE] eq '+' ) {
+ print STDERR ("=> \$\$L{$opt} += \"$arg\"\n")
+ if $debug;
+ if ( defined ${$linkage{$opt}} ) {
+ ${$linkage{$opt}} += $arg;
+ }
+ else {
+ ${$linkage{$opt}} = $arg;
+ }
+ }
+ elsif ( $ctl->[CTL_DEST] == CTL_DEST_ARRAY ) {
+ print STDERR ("=> ref(\$L{$opt}) auto-vivified",
+ " to ARRAY\n")
+ if $debug;
+ my $t = $linkage{$opt};
+ $$t = $linkage{$opt} = [];
+ print STDERR ("=> push(\@{\$L{$opt}, \"$arg\")\n")
+ if $debug;
+ push (@{$linkage{$opt}}, $arg);
+ }
+ elsif ( $ctl->[CTL_DEST] == CTL_DEST_HASH ) {
+ print STDERR ("=> ref(\$L{$opt}) auto-vivified",
+ " to HASH\n")
+ if $debug;
+ my $t = $linkage{$opt};
+ $$t = $linkage{$opt} = {};
+ print STDERR ("=> \$\$L{$opt}->{$key} = \"$arg\"\n")
+ if $debug;
+ $linkage{$opt}->{$key} = $arg;
+ }
+ else {
+ print STDERR ("=> \$\$L{$opt} = \"$arg\"\n")
+ if $debug;
+ ${$linkage{$opt}} = $arg;
+ }
+ }
+ elsif ( ref($linkage{$opt}) eq 'ARRAY' ) {
+ print STDERR ("=> push(\@{\$L{$opt}, \"$arg\")\n")
+ if $debug;
+ push (@{$linkage{$opt}}, $arg);
+ }
+ elsif ( ref($linkage{$opt}) eq 'HASH' ) {
+ print STDERR ("=> \$\$L{$opt}->{$key} = \"$arg\"\n")
+ if $debug;
+ $linkage{$opt}->{$key} = $arg;
+ }
+ elsif ( ref($linkage{$opt}) eq 'CODE' ) {
+ print STDERR ("=> &L{$opt}(\"$opt\"",
+ $ctl->[CTL_DEST] == CTL_DEST_HASH ? ", \"$key\"" : "",
+ ", \"$arg\")\n")
+ if $debug;
+ my $eval_error = do {
+ local $@;
+ local $SIG{__DIE__} = '__DEFAULT__';
+ eval {
+ &{$linkage{$opt}}($opt,
+ $ctl->[CTL_DEST] == CTL_DEST_HASH ? ($key) : (),
+ $arg);
+ };
+ $@;
+ };
+ print STDERR ("=> die($eval_error)\n")
+ if $debug && $eval_error ne '';
+ if ( $eval_error =~ /^!/ ) {
+ if ( $eval_error =~ /^!FINISH\b/ ) {
+ $goon = 0;
+ }
+ }
+ elsif ( $eval_error ne '' ) {
+ warn ($eval_error);
+ $error++;
+ }
+ }
+ else {
+ print STDERR ("Invalid REF type \"", ref($linkage{$opt}),
+ "\" in linkage\n");
+ die("Getopt::Long -- internal error!\n");
+ }
+ }
+ # No entry in linkage means entry in userlinkage.
+ elsif ( $ctl->[CTL_DEST] == CTL_DEST_ARRAY ) {
+ if ( defined $userlinkage->{$opt} ) {
+ print STDERR ("=> push(\@{\$L{$opt}}, \"$arg\")\n")
+ if $debug;
+ push (@{$userlinkage->{$opt}}, $arg);
+ }
+ else {
+ print STDERR ("=>\$L{$opt} = [\"$arg\"]\n")
+ if $debug;
+ $userlinkage->{$opt} = [$arg];
+ }
+ }
+ elsif ( $ctl->[CTL_DEST] == CTL_DEST_HASH ) {
+ if ( defined $userlinkage->{$opt} ) {
+ print STDERR ("=> \$L{$opt}->{$key} = \"$arg\"\n")
+ if $debug;
+ $userlinkage->{$opt}->{$key} = $arg;
+ }
+ else {
+ print STDERR ("=>\$L{$opt} = {$key => \"$arg\"}\n")
+ if $debug;
+ $userlinkage->{$opt} = {$key => $arg};
+ }
+ }
+ else {
+ if ( $ctl->[CTL_TYPE] eq '+' ) {
+ print STDERR ("=> \$L{$opt} += \"$arg\"\n")
+ if $debug;
+ if ( defined $userlinkage->{$opt} ) {
+ $userlinkage->{$opt} += $arg;
+ }
+ else {
+ $userlinkage->{$opt} = $arg;
+ }
+ }
+ else {
+ print STDERR ("=>\$L{$opt} = \"$arg\"\n") if $debug;
+ $userlinkage->{$opt} = $arg;
+ }
+ }
+
+ $argcnt++;
+ last if $argcnt >= $ctl->[CTL_AMAX] && $ctl->[CTL_AMAX] != -1;
+ undef($arg);
+
+ # Need more args?
+ if ( $argcnt < $ctl->[CTL_AMIN] ) {
+ if ( @ARGV ) {
+ if ( ValidValue($ctl, $ARGV[0], 1, $argend, $prefix) ) {
+ $arg = shift(@ARGV);
+ ($key,$arg) = $arg =~ /^([^=]+)=(.*)/
+ if $ctl->[CTL_DEST] == CTL_DEST_HASH;
+ next;
+ }
+ warn("Value \"$ARGV[0]\" invalid for option $opt\n");
+ $error++;
+ }
+ else {
+ warn("Insufficient arguments for option $opt\n");
+ $error++;
+ }
+ }
+
+ # Any more args?
+ if ( @ARGV && ValidValue($ctl, $ARGV[0], 0, $argend, $prefix) ) {
+ $arg = shift(@ARGV);
+ ($key,$arg) = $arg =~ /^([^=]+)=(.*)/
+ if $ctl->[CTL_DEST] == CTL_DEST_HASH;
+ next;
+ }
+ }
+ }
+
+ # Not an option. Save it if we $PERMUTE and don't have a <>.
+ elsif ( $order == $PERMUTE ) {
+ # Try non-options call-back.
+ my $cb;
+ if ( (defined ($cb = $linkage{'<>'})) ) {
+ print STDERR ("=> &L{$tryopt}(\"$tryopt\")\n")
+ if $debug;
+ my $eval_error = do {
+ local $@;
+ local $SIG{__DIE__} = '__DEFAULT__';
+ eval { &$cb ($tryopt) };
+ $@;
+ };
+ print STDERR ("=> die($eval_error)\n")
+ if $debug && $eval_error ne '';
+ if ( $eval_error =~ /^!/ ) {
+ if ( $eval_error =~ /^!FINISH\b/ ) {
+ $goon = 0;
+ }
+ }
+ elsif ( $eval_error ne '' ) {
+ warn ($eval_error);
+ $error++;
+ }
+ }
+ else {
+ print STDERR ("=> saving \"$tryopt\" ",
+ "(not an option, may permute)\n") if $debug;
+ push (@ret, $tryopt);
+ }
+ next;
+ }
+
+ # ...otherwise, terminate.
+ else {
+ # Push this one back and exit.
+ unshift (@ARGV, $tryopt);
+ return ($error == 0);
+ }
+
+ }
+
+ # Finish.
+ if ( @ret && $order == $PERMUTE ) {
+ # Push back accumulated arguments
+ print STDERR ("=> restoring \"", join('" "', @ret), "\"\n")
+ if $debug;
+ unshift (@ARGV, @ret);
+ }
+
+ return ($error == 0);
+}
+
+# A readable representation of what's in an optbl.
+sub OptCtl ($) {
+ my ($v) = @_;
+ my @v = map { defined($_) ? ($_) : ("<undef>") } @$v;
+ "[".
+ join(",",
+ "\"$v[CTL_TYPE]\"",
+ "\"$v[CTL_CNAME]\"",
+ "\"$v[CTL_DEFAULT]\"",
+ ("\$","\@","\%","\&")[$v[CTL_DEST] || 0],
+ $v[CTL_AMIN] || '',
+ $v[CTL_AMAX] || '',
+# $v[CTL_RANGE] || '',
+# $v[CTL_REPEAT] || '',
+ ). "]";
+}
+
+# Parse an option specification and fill the tables.
+sub ParseOptionSpec ($$) {
+ my ($opt, $opctl) = @_;
+
+ # Match option spec.
+ if ( $opt !~ m;^
+ (
+ # Option name
+ (?: \w+[-\w]* )
+ # Alias names, or "?"
+ (?: \| (?: \? | \w[-\w]* )? )*
+ )?
+ (
+ # Either modifiers ...
+ [!+]
+ |
+ # ... or a value/dest/repeat specification
+ [=:] [ionfs] [@%]? (?: \{\d*,?\d*\} )?
+ |
+ # ... or an optional-with-default spec
+ : (?: -?\d+ | \+ ) [@%]?
+ )?
+ $;x ) {
+ return (undef, "Error in option spec: \"$opt\"\n");
+ }
+
+ my ($names, $spec) = ($1, $2);
+ $spec = '' unless defined $spec;
+
+ # $orig keeps track of the primary name the user specified.
+ # This name will be used for the internal or external linkage.
+ # In other words, if the user specifies "FoO|BaR", it will
+ # match any case combinations of 'foo' and 'bar', but if a global
+ # variable needs to be set, it will be $opt_FoO in the exact case
+ # as specified.
+ my $orig;
+
+ my @names;
+ if ( defined $names ) {
+ @names = split (/\|/, $names);
+ $orig = $names[0];
+ }
+ else {
+ @names = ('');
+ $orig = '';
+ }
+
+ # Construct the opctl entries.
+ my $entry;
+ if ( $spec eq '' || $spec eq '+' || $spec eq '!' ) {
+ # Fields are hard-wired here.
+ $entry = [$spec,$orig,undef,CTL_DEST_SCALAR,0,0];
+ }
+ elsif ( $spec =~ /^:(-?\d+|\+)([@%])?$/ ) {
+ my $def = $1;
+ my $dest = $2;
+ my $type = $def eq '+' ? 'I' : 'i';
+ $dest ||= '$';
+ $dest = $dest eq '@' ? CTL_DEST_ARRAY
+ : $dest eq '%' ? CTL_DEST_HASH : CTL_DEST_SCALAR;
+ # Fields are hard-wired here.
+ $entry = [$type,$orig,$def eq '+' ? undef : $def,
+ $dest,0,1];
+ }
+ else {
+ my ($mand, $type, $dest) =
+ $spec =~ /^([=:])([ionfs])([@%])?(\{(\d+)?(,)?(\d+)?\})?$/;
+ return (undef, "Cannot repeat while bundling: \"$opt\"\n")
+ if $bundling && defined($4);
+ my ($mi, $cm, $ma) = ($5, $6, $7);
+ return (undef, "{0} is useless in option spec: \"$opt\"\n")
+ if defined($mi) && !$mi && !defined($ma) && !defined($cm);
+
+ $type = 'i' if $type eq 'n';
+ $dest ||= '$';
+ $dest = $dest eq '@' ? CTL_DEST_ARRAY
+ : $dest eq '%' ? CTL_DEST_HASH : CTL_DEST_SCALAR;
+ # Default minargs to 1/0 depending on mand status.
+ $mi = $mand eq '=' ? 1 : 0 unless defined $mi;
+ # Adjust mand status according to minargs.
+ $mand = $mi ? '=' : ':';
+ # Adjust maxargs.
+ $ma = $mi ? $mi : 1 unless defined $ma || defined $cm;
+ return (undef, "Max must be greater than zero in option spec: \"$opt\"\n")
+ if defined($ma) && !$ma;
+ return (undef, "Max less than min in option spec: \"$opt\"\n")
+ if defined($ma) && $ma < $mi;
+
+ # Fields are hard-wired here.
+ $entry = [$type,$orig,undef,$dest,$mi,$ma||-1];
+ }
+
+ # Process all names. First is canonical, the rest are aliases.
+ my $dups = '';
+ foreach ( @names ) {
+
+ $_ = lc ($_)
+ if $ignorecase > (($bundling && length($_) == 1) ? 1 : 0);
+
+ if ( exists $opctl->{$_} ) {
+ $dups .= "Duplicate specification \"$opt\" for option \"$_\"\n";
+ }
+
+ if ( $spec eq '!' ) {
+ $opctl->{"no$_"} = $entry;
+ $opctl->{"no-$_"} = $entry;
+ $opctl->{$_} = [@$entry];
+ $opctl->{$_}->[CTL_TYPE] = '';
+ }
+ else {
+ $opctl->{$_} = $entry;
+ }
+ }
+
+ if ( $dups && $^W ) {
+ foreach ( split(/\n+/, $dups) ) {
+ warn($_."\n");
+ }
+ }
+ ($names[0], $orig);
+}
+
+# Option lookup.
+sub FindOption ($$$$) {
+
+ # returns (1, $opt, $ctl, $arg, $key) if okay,
+ # returns (1, undef) if option in error,
+ # returns (0) otherwise.
+
+ my ($prefix, $argend, $opt, $opctl) = @_;
+
+ print STDERR ("=> find \"$opt\"\n") if $debug;
+
+ return (0) unless $opt =~ /^$prefix(.*)$/s;
+ return (0) if $opt eq "-" && !defined $opctl->{''};
+
+ $opt = $+;
+ my $starter = $1;
+
+ print STDERR ("=> split \"$starter\"+\"$opt\"\n") if $debug;
+
+ my $optarg; # value supplied with --opt=value
+ my $rest; # remainder from unbundling
+
+ # If it is a long option, it may include the value.
+ # With getopt_compat, only if not bundling.
+ if ( ($starter=~/^$longprefix$/
+ || ($getopt_compat && ($bundling == 0 || $bundling == 2)))
+ && $opt =~ /^([^=]+)=(.*)$/s ) {
+ $opt = $1;
+ $optarg = $2;
+ print STDERR ("=> option \"", $opt,
+ "\", optarg = \"$optarg\"\n") if $debug;
+ }
+
+ #### Look it up ###
+
+ my $tryopt = $opt; # option to try
+
+ if ( $bundling && $starter eq '-' ) {
+
+ # To try overrides, obey case ignore.
+ $tryopt = $ignorecase ? lc($opt) : $opt;
+
+ # If bundling == 2, long options can override bundles.
+ if ( $bundling == 2 && length($tryopt) > 1
+ && defined ($opctl->{$tryopt}) ) {
+ print STDERR ("=> $starter$tryopt overrides unbundling\n")
+ if $debug;
+ }
+ else {
+ $tryopt = $opt;
+ # Unbundle single letter option.
+ $rest = length ($tryopt) > 0 ? substr ($tryopt, 1) : '';
+ $tryopt = substr ($tryopt, 0, 1);
+ $tryopt = lc ($tryopt) if $ignorecase > 1;
+ print STDERR ("=> $starter$tryopt unbundled from ",
+ "$starter$tryopt$rest\n") if $debug;
+ $rest = undef unless $rest ne '';
+ }
+ }
+
+ # Try auto-abbreviation.
+ elsif ( $autoabbrev ) {
+ # Sort the possible long option names.
+ my @names = sort(keys (%$opctl));
+ # Downcase if allowed.
+ $opt = lc ($opt) if $ignorecase;
+ $tryopt = $opt;
+ # Turn option name into pattern.
+ my $pat = quotemeta ($opt);
+ # Look up in option names.
+ my @hits = grep (/^$pat/, @names);
+ print STDERR ("=> ", scalar(@hits), " hits (@hits) with \"$pat\" ",
+ "out of ", scalar(@names), "\n") if $debug;
+
+ # Check for ambiguous results.
+ unless ( (@hits <= 1) || (grep ($_ eq $opt, @hits) == 1) ) {
+ # See if all matches are for the same option.
+ my %hit;
+ foreach ( @hits ) {
+ my $hit = $_;
+ $hit = $opctl->{$hit}->[CTL_CNAME]
+ if defined $opctl->{$hit}->[CTL_CNAME];
+ $hit{$hit} = 1;
+ }
+ # Remove auto-supplied options (version, help).
+ if ( keys(%hit) == 2 ) {
+ if ( $auto_version && exists($hit{version}) ) {
+ delete $hit{version};
+ }
+ elsif ( $auto_help && exists($hit{help}) ) {
+ delete $hit{help};
+ }
+ }
+ # Now see if it really is ambiguous.
+ unless ( keys(%hit) == 1 ) {
+ return (0) if $passthrough;
+ warn ("Option ", $opt, " is ambiguous (",
+ join(", ", @hits), ")\n");
+ $error++;
+ return (1, undef);
+ }
+ @hits = keys(%hit);
+ }
+
+ # Complete the option name, if appropriate.
+ if ( @hits == 1 && $hits[0] ne $opt ) {
+ $tryopt = $hits[0];
+ $tryopt = lc ($tryopt) if $ignorecase;
+ print STDERR ("=> option \"$opt\" -> \"$tryopt\"\n")
+ if $debug;
+ }
+ }
+
+ # Map to all lowercase if ignoring case.
+ elsif ( $ignorecase ) {
+ $tryopt = lc ($opt);
+ }
+
+ # Check validity by fetching the info.
+ my $ctl = $opctl->{$tryopt};
+ unless ( defined $ctl ) {
+ return (0) if $passthrough;
+ # Pretend one char when bundling.
+ if ( $bundling == 1 && length($starter) == 1 ) {
+ $opt = substr($opt,0,1);
+ unshift (@ARGV, $starter.$rest) if defined $rest;
+ }
+ warn ("Unknown option: ", $opt, "\n");
+ $error++;
+ return (1, undef);
+ }
+ # Apparently valid.
+ $opt = $tryopt;
+ print STDERR ("=> found ", OptCtl($ctl),
+ " for \"", $opt, "\"\n") if $debug;
+
+ #### Determine argument status ####
+
+ # If it is an option w/o argument, we're almost finished with it.
+ my $type = $ctl->[CTL_TYPE];
+ my $arg;
+
+ if ( $type eq '' || $type eq '!' || $type eq '+' ) {
+ if ( defined $optarg ) {
+ return (0) if $passthrough;
+ warn ("Option ", $opt, " does not take an argument\n");
+ $error++;
+ undef $opt;
+ }
+ elsif ( $type eq '' || $type eq '+' ) {
+ # Supply explicit value.
+ $arg = 1;
+ }
+ else {
+ $opt =~ s/^no-?//i; # strip NO prefix
+ $arg = 0; # supply explicit value
+ }
+ unshift (@ARGV, $starter.$rest) if defined $rest;
+ return (1, $opt, $ctl, $arg);
+ }
+
+ # Get mandatory status and type info.
+ my $mand = $ctl->[CTL_AMIN];
+
+ # Check if there is an option argument available.
+ if ( $gnu_compat && defined $optarg && $optarg eq '' ) {
+ return (1, $opt, $ctl, $type eq 's' ? '' : 0) unless $mand;
+ $optarg = 0 unless $type eq 's';
+ }
+
+ # Check if there is an option argument available.
+ if ( defined $optarg
+ ? ($optarg eq '')
+ : !(defined $rest || @ARGV > 0) ) {
+ # Complain if this option needs an argument.
+ if ( $mand ) {
+ return (0) if $passthrough;
+ warn ("Option ", $opt, " requires an argument\n");
+ $error++;
+ return (1, undef);
+ }
+ if ( $type eq 'I' ) {
+ # Fake incremental type.
+ my @c = @$ctl;
+ $c[CTL_TYPE] = '+';
+ return (1, $opt, \@c, 1);
+ }
+ return (1, $opt, $ctl,
+ defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] :
+ $type eq 's' ? '' : 0);
+ }
+
+ # Get (possibly optional) argument.
+ $arg = (defined $rest ? $rest
+ : (defined $optarg ? $optarg : shift (@ARGV)));
+
+ # Get key if this is a "name=value" pair for a hash option.
+ my $key;
+ if ($ctl->[CTL_DEST] == CTL_DEST_HASH && defined $arg) {
+ ($key, $arg) = ($arg =~ /^([^=]*)=(.*)$/s) ? ($1, $2)
+ : ($arg, defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] :
+ ($mand ? undef : ($type eq 's' ? "" : 1)));
+ if (! defined $arg) {
+ warn ("Option $opt, key \"$key\", requires a value\n");
+ $error++;
+ # Push back.
+ unshift (@ARGV, $starter.$rest) if defined $rest;
+ return (1, undef);
+ }
+ }
+
+ #### Check if the argument is valid for this option ####
+
+ my $key_valid = $ctl->[CTL_DEST] == CTL_DEST_HASH ? "[^=]+=" : "";
+
+ if ( $type eq 's' ) { # string
+ # A mandatory string takes anything.
+ return (1, $opt, $ctl, $arg, $key) if $mand;
+
+ # An optional string takes almost anything.
+ return (1, $opt, $ctl, $arg, $key)
+ if defined $optarg || defined $rest;
+ return (1, $opt, $ctl, $arg, $key) if $arg eq "-"; # ??
+
+ # Check for option or option list terminator.
+ if ($arg eq $argend ||
+ $arg =~ /^$prefix.+/) {
+ # Push back.
+ unshift (@ARGV, $arg);
+ # Supply empty value.
+ $arg = '';
+ }
+ }
+
+ elsif ( $type eq 'i' # numeric/integer
+ || $type eq 'I' # numeric/integer w/ incr default
+ || $type eq 'o' ) { # dec/oct/hex/bin value
+
+ my $o_valid =
+ $type eq 'o' ? "[-+]?[1-9][0-9]*|0x[0-9a-f]+|0b[01]+|0[0-7]*"
+ : "[-+]?[0-9]+";
+
+ if ( $bundling && defined $rest
+ && $rest =~ /^($key_valid)($o_valid)(.*)$/si ) {
+ ($key, $arg, $rest) = ($1, $2, $+);
+ chop($key) if $key;
+ $arg = ($type eq 'o' && $arg =~ /^0/) ? oct($arg) : 0+$arg;
+ unshift (@ARGV, $starter.$rest) if defined $rest && $rest ne '';
+ }
+ elsif ( $arg =~ /^($o_valid)$/si ) {
+ $arg = ($type eq 'o' && $arg =~ /^0/) ? oct($arg) : 0+$arg;
+ }
+ else {
+ if ( defined $optarg || $mand ) {
+ if ( $passthrough ) {
+ unshift (@ARGV, defined $rest ? $starter.$rest : $arg)
+ unless defined $optarg;
+ return (0);
+ }
+ warn ("Value \"", $arg, "\" invalid for option ",
+ $opt, " (",
+ $type eq 'o' ? "extended " : '',
+ "number expected)\n");
+ $error++;
+ # Push back.
+ unshift (@ARGV, $starter.$rest) if defined $rest;
+ return (1, undef);
+ }
+ else {
+ # Push back.
+ unshift (@ARGV, defined $rest ? $starter.$rest : $arg);
+ if ( $type eq 'I' ) {
+ # Fake incremental type.
+ my @c = @$ctl;
+ $c[CTL_TYPE] = '+';
+ return (1, $opt, \@c, 1);
+ }
+ # Supply default value.
+ $arg = defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] : 0;
+ }
+ }
+ }
+
+ elsif ( $type eq 'f' ) { # real number, int is also ok
+ # We require at least one digit before a point or 'e',
+ # and at least one digit following the point and 'e'.
+ # [-]NN[.NN][eNN]
+ if ( $bundling && defined $rest &&
+ $rest =~ /^($key_valid)([-+]?[0-9]+(\.[0-9]+)?([eE][-+]?[0-9]+)?)(.*)$/s ) {
+ ($key, $arg, $rest) = ($1, $2, $+);
+ chop($key) if $key;
+ unshift (@ARGV, $starter.$rest) if defined $rest && $rest ne '';
+ }
+ elsif ( $arg !~ /^[-+]?[0-9.]+(\.[0-9]+)?([eE][-+]?[0-9]+)?$/ ) {
+ if ( defined $optarg || $mand ) {
+ if ( $passthrough ) {
+ unshift (@ARGV, defined $rest ? $starter.$rest : $arg)
+ unless defined $optarg;
+ return (0);
+ }
+ warn ("Value \"", $arg, "\" invalid for option ",
+ $opt, " (real number expected)\n");
+ $error++;
+ # Push back.
+ unshift (@ARGV, $starter.$rest) if defined $rest;
+ return (1, undef);
+ }
+ else {
+ # Push back.
+ unshift (@ARGV, defined $rest ? $starter.$rest : $arg);
+ # Supply default value.
+ $arg = 0.0;
+ }
+ }
+ }
+ else {
+ die("Getopt::Long internal error (Can't happen)\n");
+ }
+ return (1, $opt, $ctl, $arg, $key);
+}
+
+sub ValidValue ($$$$$) {
+ my ($ctl, $arg, $mand, $argend, $prefix) = @_;
+
+ if ( $ctl->[CTL_DEST] == CTL_DEST_HASH ) {
+ return 0 unless $arg =~ /[^=]+=(.*)/;
+ $arg = $1;
+ }
+
+ my $type = $ctl->[CTL_TYPE];
+
+ if ( $type eq 's' ) { # string
+ # A mandatory string takes anything.
+ return (1) if $mand;
+
+ return (1) if $arg eq "-";
+
+ # Check for option or option list terminator.
+ return 0 if $arg eq $argend || $arg =~ /^$prefix.+/;
+ return 1;
+ }
+
+ elsif ( $type eq 'i' # numeric/integer
+ || $type eq 'I' # numeric/integer w/ incr default
+ || $type eq 'o' ) { # dec/oct/hex/bin value
+
+ my $o_valid =
+ $type eq 'o' ? "[-+]?[1-9][0-9]*|0x[0-9a-f]+|0b[01]+|0[0-7]*"
+ : "[-+]?[0-9]+";
+
+ return $arg =~ /^$o_valid$/si;
+ }
+
+ elsif ( $type eq 'f' ) { # real number, int is also ok
+ # We require at least one digit before a point or 'e',
+ # and at least one digit following the point and 'e'.
+ # [-]NN[.NN][eNN]
+ return $arg =~ /^[-+]?[0-9.]+(\.[0-9]+)?([eE][-+]?[0-9]+)?$/;
+ }
+ die("ValidValue: Cannot happen\n");
+}
+
+# Getopt::Long Configuration.
+sub Configure (@) {
+ my (@options) = @_;
+
+ my $prevconfig =
+ [ $error, $debug, $major_version, $minor_version,
+ $autoabbrev, $getopt_compat, $ignorecase, $bundling, $order,
+ $gnu_compat, $passthrough, $genprefix, $auto_version, $auto_help,
+ $longprefix ];
+
+ if ( ref($options[0]) eq 'ARRAY' ) {
+ ( $error, $debug, $major_version, $minor_version,
+ $autoabbrev, $getopt_compat, $ignorecase, $bundling, $order,
+ $gnu_compat, $passthrough, $genprefix, $auto_version, $auto_help,
+ $longprefix ) = @{shift(@options)};
+ }
+
+ my $opt;
+ foreach $opt ( @options ) {
+ my $try = lc ($opt);
+ my $action = 1;
+ if ( $try =~ /^no_?(.*)$/s ) {
+ $action = 0;
+ $try = $+;
+ }
+ if ( ($try eq 'default' or $try eq 'defaults') && $action ) {
+ ConfigDefaults ();
+ }
+ elsif ( ($try eq 'posix_default' or $try eq 'posix_defaults') ) {
+ local $ENV{POSIXLY_CORRECT};
+ $ENV{POSIXLY_CORRECT} = 1 if $action;
+ ConfigDefaults ();
+ }
+ elsif ( $try eq 'auto_abbrev' or $try eq 'autoabbrev' ) {
+ $autoabbrev = $action;
+ }
+ elsif ( $try eq 'getopt_compat' ) {
+ $getopt_compat = $action;
+ }
+ elsif ( $try eq 'gnu_getopt' ) {
+ if ( $action ) {
+ $gnu_compat = 1;
+ $bundling = 1;
+ $getopt_compat = 0;
+ $order = $PERMUTE;
+ }
+ }
+ elsif ( $try eq 'gnu_compat' ) {
+ $gnu_compat = $action;
+ }
+ elsif ( $try =~ /^(auto_?)?version$/ ) {
+ $auto_version = $action;
+ }
+ elsif ( $try =~ /^(auto_?)?help$/ ) {
+ $auto_help = $action;
+ }
+ elsif ( $try eq 'ignorecase' or $try eq 'ignore_case' ) {
+ $ignorecase = $action;
+ }
+ elsif ( $try eq 'ignore_case_always' ) {
+ $ignorecase = $action ? 2 : 0;
+ }
+ elsif ( $try eq 'bundling' ) {
+ $bundling = $action;
+ }
+ elsif ( $try eq 'bundling_override' ) {
+ $bundling = $action ? 2 : 0;
+ }
+ elsif ( $try eq 'require_order' ) {
+ $order = $action ? $REQUIRE_ORDER : $PERMUTE;
+ }
+ elsif ( $try eq 'permute' ) {
+ $order = $action ? $PERMUTE : $REQUIRE_ORDER;
+ }
+ elsif ( $try eq 'pass_through' or $try eq 'passthrough' ) {
+ $passthrough = $action;
+ }
+ elsif ( $try =~ /^prefix=(.+)$/ && $action ) {
+ $genprefix = $1;
+ # Turn into regexp. Needs to be parenthesized!
+ $genprefix = "(" . quotemeta($genprefix) . ")";
+ eval { '' =~ /$genprefix/; };
+ die("Getopt::Long: invalid pattern \"$genprefix\"") if $@;
+ }
+ elsif ( $try =~ /^prefix_pattern=(.+)$/ && $action ) {
+ $genprefix = $1;
+ # Parenthesize if needed.
+ $genprefix = "(" . $genprefix . ")"
+ unless $genprefix =~ /^\(.*\)$/;
+ eval { '' =~ m"$genprefix"; };
+ die("Getopt::Long: invalid pattern \"$genprefix\"") if $@;
+ }
+ elsif ( $try =~ /^long_prefix_pattern=(.+)$/ && $action ) {
+ $longprefix = $1;
+ # Parenthesize if needed.
+ $longprefix = "(" . $longprefix . ")"
+ unless $longprefix =~ /^\(.*\)$/;
+ eval { '' =~ m"$longprefix"; };
+ die("Getopt::Long: invalid long prefix pattern \"$longprefix\"") if $@;
+ }
+ elsif ( $try eq 'debug' ) {
+ $debug = $action;
+ }
+ else {
+ die("Getopt::Long: unknown config parameter \"$opt\"")
+ }
+ }
+ $prevconfig;
+}
+
+# Deprecated name.
+sub config (@) {
+ Configure (@_);
+}
+
+# Issue a standard message for --version.
+#
+# The arguments are mostly the same as for Pod::Usage::pod2usage:
+#
+# - a number (exit value)
+# - a string (lead in message)
+# - a hash with options. See Pod::Usage for details.
+#
+sub VersionMessage(@) {
+ # Massage args.
+ my $pa = setup_pa_args("version", @_);
+
+ my $v = $main::VERSION;
+ my $fh = $pa->{-output} ||
+ ($pa->{-exitval} eq "NOEXIT" || $pa->{-exitval} < 2) ? \*STDOUT : \*STDERR;
+
+ print $fh (defined($pa->{-message}) ? $pa->{-message} : (),
+ $0, defined $v ? " version $v" : (),
+ "\n",
+ "(", __PACKAGE__, "::", "GetOptions",
+ " version ",
+ defined($Getopt::Long::VERSION_STRING)
+ ? $Getopt::Long::VERSION_STRING : $VERSION, ";",
+ " Perl version ",
+ $] >= 5.006 ? sprintf("%vd", $^V) : $],
+ ")\n");
+ exit($pa->{-exitval}) unless $pa->{-exitval} eq "NOEXIT";
+}
+
+# Issue a standard message for --help.
+#
+# The arguments are the same as for Pod::Usage::pod2usage:
+#
+# - a number (exit value)
+# - a string (lead in message)
+# - a hash with options. See Pod::Usage for details.
+#
+sub HelpMessage(@) {
+ eval {
+ require Pod::Usage;
+ import Pod::Usage;
+ 1;
+ } || die("Cannot provide help: cannot load Pod::Usage\n");
+
+ # Note that pod2usage will issue a warning if -exitval => NOEXIT.
+ pod2usage(setup_pa_args("help", @_));
+
+}
+
+# Helper routine to set up a normalized hash ref to be used as
+# argument to pod2usage.
+sub setup_pa_args($@) {
+ my $tag = shift; # who's calling
+
+ # If called by direct binding to an option, it will get the option
+ # name and value as arguments. Remove these, if so.
+ @_ = () if @_ == 2 && $_[0] eq $tag;
+
+ my $pa;
+ if ( @_ > 1 ) {
+ $pa = { @_ };
+ }
+ else {
+ $pa = shift || {};
+ }
+
+ # At this point, $pa can be a number (exit value), string
+ # (message) or hash with options.
+
+ if ( UNIVERSAL::isa($pa, 'HASH') ) {
+ # Get rid of -msg vs. -message ambiguity.
+ $pa->{-message} = $pa->{-msg};
+ delete($pa->{-msg});
+ }
+ elsif ( $pa =~ /^-?\d+$/ ) {
+ $pa = { -exitval => $pa };
+ }
+ else {
+ $pa = { -message => $pa };
+ }
+
+ # These are _our_ defaults.
+ $pa->{-verbose} = 0 unless exists($pa->{-verbose});
+ $pa->{-exitval} = 0 unless exists($pa->{-exitval});
+ $pa;
+}
+
+# Sneak way to know what version the user requested.
+sub VERSION {
+ $requested_version = $_[1];
+ shift->SUPER::VERSION(@_);
+}
+
+1;
+
+################ Documentation ################
+
+=head1 NAME
+
+Getopt::Long - Extended processing of command line options
+
+=head1 SYNOPSIS
+
+ use Getopt::Long;
+ my $data = "file.dat";
+ my $length = 24;
+ my $verbose;
+ $result = GetOptions ("length=i" => \$length, # numeric
+ "file=s" => \$data, # string
+ "verbose" => \$verbose); # flag
+
+=head1 DESCRIPTION
+
+The Getopt::Long module implements an extended getopt function called
+GetOptions(). This function adheres to the POSIX syntax for command
+line options, with GNU extensions. In general, this means that options
+have long names instead of single letters, and are introduced with a
+double dash "--". Support for bundling of command line options, as was
+the case with the more traditional single-letter approach, is provided
+but not enabled by default.
+
+=head1 Command Line Options, an Introduction
+
+Command line operated programs traditionally take their arguments from
+the command line, for example filenames or other information that the
+program needs to know. Besides arguments, these programs often take
+command line I<options> as well. Options are not necessary for the
+program to work, hence the name 'option', but are used to modify its
+default behaviour. For example, a program could do its job quietly,
+but with a suitable option it could provide verbose information about
+what it did.
+
+Command line options come in several flavours. Historically, they are
+preceded by a single dash C<->, and consist of a single letter.
+
+ -l -a -c
+
+Usually, these single-character options can be bundled:
+
+ -lac
+
+Options can have values, the value is placed after the option
+character. Sometimes with whitespace in between, sometimes not:
+
+ -s 24 -s24
+
+Due to the very cryptic nature of these options, another style was
+developed that used long names. So instead of a cryptic C<-l> one
+could use the more descriptive C<--long>. To distinguish between a
+bundle of single-character options and a long one, two dashes are used
+to precede the option name. Early implementations of long options used
+a plus C<+> instead. Also, option values could be specified either
+like
+
+ --size=24
+
+or
+
+ --size 24
+
+The C<+> form is now obsolete and strongly deprecated.
+
+=head1 Getting Started with Getopt::Long
+
+Getopt::Long is the Perl5 successor of C<newgetopt.pl>. This was the
+first Perl module that provided support for handling the new style of
+command line options, hence the name Getopt::Long. This module also
+supports single-character options and bundling. Single character
+options may be any alphabetic character, a question mark, and a dash.
+Long options may consist of a series of letters, digits, and dashes.
+Although this is currently not enforced by Getopt::Long, multiple
+consecutive dashes are not allowed, and the option name must not end
+with a dash.
+
+To use Getopt::Long from a Perl program, you must include the
+following line in your Perl program:
+
+ use Getopt::Long;
+
+This will load the core of the Getopt::Long module and prepare your
+program for using it. Most of the actual Getopt::Long code is not
+loaded until you really call one of its functions.
+
+In the default configuration, options names may be abbreviated to
+uniqueness, case does not matter, and a single dash is sufficient,
+even for long option names. Also, options may be placed between
+non-option arguments. See L<Configuring Getopt::Long> for more
+details on how to configure Getopt::Long.
+
+=head2 Simple options
+
+The most simple options are the ones that take no values. Their mere
+presence on the command line enables the option. Popular examples are:
+
+ --all --verbose --quiet --debug
+
+Handling simple options is straightforward:
+
+ my $verbose = ''; # option variable with default value (false)
+ my $all = ''; # option variable with default value (false)
+ GetOptions ('verbose' => \$verbose, 'all' => \$all);
+
+The call to GetOptions() parses the command line arguments that are
+present in C<@ARGV> and sets the option variable to the value C<1> if
+the option did occur on the command line. Otherwise, the option
+variable is not touched. Setting the option value to true is often
+called I<enabling> the option.
+
+The option name as specified to the GetOptions() function is called
+the option I<specification>. Later we'll see that this specification
+can contain more than just the option name. The reference to the
+variable is called the option I<destination>.
+
+GetOptions() will return a true value if the command line could be
+processed successfully. Otherwise, it will write error messages to
+STDERR, and return a false result.
+
+=head2 A little bit less simple options
+
+Getopt::Long supports two useful variants of simple options:
+I<negatable> options and I<incremental> options.
+
+A negatable option is specified with an exclamation mark C<!> after the
+option name:
+
+ my $verbose = ''; # option variable with default value (false)
+ GetOptions ('verbose!' => \$verbose);
+
+Now, using C<--verbose> on the command line will enable C<$verbose>,
+as expected. But it is also allowed to use C<--noverbose>, which will
+disable C<$verbose> by setting its value to C<0>. Using a suitable
+default value, the program can find out whether C<$verbose> is false
+by default, or disabled by using C<--noverbose>.
+
+An incremental option is specified with a plus C<+> after the
+option name:
+
+ my $verbose = ''; # option variable with default value (false)
+ GetOptions ('verbose+' => \$verbose);
+
+Using C<--verbose> on the command line will increment the value of
+C<$verbose>. This way the program can keep track of how many times the
+option occurred on the command line. For example, each occurrence of
+C<--verbose> could increase the verbosity level of the program.
+
+=head2 Mixing command line option with other arguments
+
+Usually programs take command line options as well as other arguments,
+for example, file names. It is good practice to always specify the
+options first, and the other arguments last. Getopt::Long will,
+however, allow the options and arguments to be mixed and 'filter out'
+all the options before passing the rest of the arguments to the
+program. To stop Getopt::Long from processing further arguments,
+insert a double dash C<--> on the command line:
+
+ --size 24 -- --all
+
+In this example, C<--all> will I<not> be treated as an option, but
+passed to the program unharmed, in C<@ARGV>.
+
+=head2 Options with values
+
+For options that take values it must be specified whether the option
+value is required or not, and what kind of value the option expects.
+
+Three kinds of values are supported: integer numbers, floating point
+numbers, and strings.
+
+If the option value is required, Getopt::Long will take the
+command line argument that follows the option and assign this to the
+option variable. If, however, the option value is specified as
+optional, this will only be done if that value does not look like a
+valid command line option itself.
+
+ my $tag = ''; # option variable with default value
+ GetOptions ('tag=s' => \$tag);
+
+In the option specification, the option name is followed by an equals
+sign C<=> and the letter C<s>. The equals sign indicates that this
+option requires a value. The letter C<s> indicates that this value is
+an arbitrary string. Other possible value types are C<i> for integer
+values, and C<f> for floating point values. Using a colon C<:> instead
+of the equals sign indicates that the option value is optional. In
+this case, if no suitable value is supplied, string valued options get
+an empty string C<''> assigned, while numeric options are set to C<0>.
+
+=head2 Options with multiple values
+
+Options sometimes take several values. For example, a program could
+use multiple directories to search for library files:
+
+ --library lib/stdlib --library lib/extlib
+
+To accomplish this behaviour, simply specify an array reference as the
+destination for the option:
+
+ GetOptions ("library=s" => \@libfiles);
+
+Alternatively, you can specify that the option can have multiple
+values by adding a "@", and pass a scalar reference as the
+destination:
+
+ GetOptions ("library=s@" => \$libfiles);
+
+Used with the example above, C<@libfiles> (or C<@$libfiles>) would
+contain two strings upon completion: C<"lib/srdlib"> and
+C<"lib/extlib">, in that order. It is also possible to specify that
+only integer or floating point numbers are acceptable values.
+
+Often it is useful to allow comma-separated lists of values as well as
+multiple occurrences of the options. This is easy using Perl's split()
+and join() operators:
+
+ GetOptions ("library=s" => \@libfiles);
+ @libfiles = split(/,/,join(',',@libfiles));
+
+Of course, it is important to choose the right separator string for
+each purpose.
+
+Warning: What follows is an experimental feature.
+
+Options can take multiple values at once, for example
+
+ --coordinates 52.2 16.4 --rgbcolor 255 255 149
+
+This can be accomplished by adding a repeat specifier to the option
+specification. Repeat specifiers are very similar to the C<{...}>
+repeat specifiers that can be used with regular expression patterns.
+For example, the above command line would be handled as follows:
+
+ GetOptions('coordinates=f{2}' => \@coor, 'rgbcolor=i{3}' => \@color);
+
+The destination for the option must be an array or array reference.
+
+It is also possible to specify the minimal and maximal number of
+arguments an option takes. C<foo=s{2,4}> indicates an option that
+takes at least two and at most 4 arguments. C<foo=s{,}> indicates one
+or more values; C<foo:s{,}> indicates zero or more option values.
+
+=head2 Options with hash values
+
+If the option destination is a reference to a hash, the option will
+take, as value, strings of the form I<key>C<=>I<value>. The value will
+be stored with the specified key in the hash.
+
+ GetOptions ("define=s" => \%defines);
+
+Alternatively you can use:
+
+ GetOptions ("define=s%" => \$defines);
+
+When used with command line options:
+
+ --define os=linux --define vendor=redhat
+
+the hash C<%defines> (or C<%$defines>) will contain two keys, C<"os">
+with value C<"linux> and C<"vendor"> with value C<"redhat">. It is
+also possible to specify that only integer or floating point numbers
+are acceptable values. The keys are always taken to be strings.
+
+=head2 User-defined subroutines to handle options
+
+Ultimate control over what should be done when (actually: each time)
+an option is encountered on the command line can be achieved by
+designating a reference to a subroutine (or an anonymous subroutine)
+as the option destination. When GetOptions() encounters the option, it
+will call the subroutine with two or three arguments. The first
+argument is the name of the option. For a scalar or array destination,
+the second argument is the value to be stored. For a hash destination,
+the second arguments is the key to the hash, and the third argument
+the value to be stored. It is up to the subroutine to store the value,
+or do whatever it thinks is appropriate.
+
+A trivial application of this mechanism is to implement options that
+are related to each other. For example:
+
+ my $verbose = ''; # option variable with default value (false)
+ GetOptions ('verbose' => \$verbose,
+ 'quiet' => sub { $verbose = 0 });
+
+Here C<--verbose> and C<--quiet> control the same variable
+C<$verbose>, but with opposite values.
+
+If the subroutine needs to signal an error, it should call die() with
+the desired error message as its argument. GetOptions() will catch the
+die(), issue the error message, and record that an error result must
+be returned upon completion.
+
+If the text of the error message starts with an exclamation mark C<!>
+it is interpreted specially by GetOptions(). There is currently one
+special command implemented: C<die("!FINISH")> will cause GetOptions()
+to stop processing options, as if it encountered a double dash C<-->.
+
+=head2 Options with multiple names
+
+Often it is user friendly to supply alternate mnemonic names for
+options. For example C<--height> could be an alternate name for
+C<--length>. Alternate names can be included in the option
+specification, separated by vertical bar C<|> characters. To implement
+the above example:
+
+ GetOptions ('length|height=f' => \$length);
+
+The first name is called the I<primary> name, the other names are
+called I<aliases>. When using a hash to store options, the key will
+always be the primary name.
+
+Multiple alternate names are possible.
+
+=head2 Case and abbreviations
+
+Without additional configuration, GetOptions() will ignore the case of
+option names, and allow the options to be abbreviated to uniqueness.
+
+ GetOptions ('length|height=f' => \$length, "head" => \$head);
+
+This call will allow C<--l> and C<--L> for the length option, but
+requires a least C<--hea> and C<--hei> for the head and height options.
+
+=head2 Summary of Option Specifications
+
+Each option specifier consists of two parts: the name specification
+and the argument specification.
+
+The name specification contains the name of the option, optionally
+followed by a list of alternative names separated by vertical bar
+characters.
+
+ length option name is "length"
+ length|size|l name is "length", aliases are "size" and "l"
+
+The argument specification is optional. If omitted, the option is
+considered boolean, a value of 1 will be assigned when the option is
+used on the command line.
+
+The argument specification can be
+
+=over 4
+
+=item !
+
+The option does not take an argument and may be negated by prefixing
+it with "no" or "no-". E.g. C<"foo!"> will allow C<--foo> (a value of
+1 will be assigned) as well as C<--nofoo> and C<--no-foo> (a value of
+0 will be assigned). If the option has aliases, this applies to the
+aliases as well.
+
+Using negation on a single letter option when bundling is in effect is
+pointless and will result in a warning.
+
+=item +
+
+The option does not take an argument and will be incremented by 1
+every time it appears on the command line. E.g. C<"more+">, when used
+with C<--more --more --more>, will increment the value three times,
+resulting in a value of 3 (provided it was 0 or undefined at first).
+
+The C<+> specifier is ignored if the option destination is not a scalar.
+
+=item = I<type> [ I<desttype> ] [ I<repeat> ]
+
+The option requires an argument of the given type. Supported types
+are:
+
+=over 4
+
+=item s
+
+String. An arbitrary sequence of characters. It is valid for the
+argument to start with C<-> or C<-->.
+
+=item i
+
+Integer. An optional leading plus or minus sign, followed by a
+sequence of digits.
+
+=item o
+
+Extended integer, Perl style. This can be either an optional leading
+plus or minus sign, followed by a sequence of digits, or an octal
+string (a zero, optionally followed by '0', '1', .. '7'), or a
+hexadecimal string (C<0x> followed by '0' .. '9', 'a' .. 'f', case
+insensitive), or a binary string (C<0b> followed by a series of '0'
+and '1').
+
+=item f
+
+Real number. For example C<3.14>, C<-6.23E24> and so on.
+
+=back
+
+The I<desttype> can be C<@> or C<%> to specify that the option is
+list or a hash valued. This is only needed when the destination for
+the option value is not otherwise specified. It should be omitted when
+not needed.
+
+The I<repeat> specifies the number of values this option takes per
+occurrence on the command line. It has the format C<{> [ I<min> ] [ C<,> [ I<max> ] ] C<}>.
+
+I<min> denotes the minimal number of arguments. It defaults to 1 for
+options with C<=> and to 0 for options with C<:>, see below. Note that
+I<min> overrules the C<=> / C<:> semantics.
+
+I<max> denotes the maximum number of arguments. It must be at least
+I<min>. If I<max> is omitted, I<but the comma is not>, there is no
+upper bound to the number of argument values taken.
+
+=item : I<type> [ I<desttype> ]
+
+Like C<=>, but designates the argument as optional.
+If omitted, an empty string will be assigned to string values options,
+and the value zero to numeric options.
+
+Note that if a string argument starts with C<-> or C<-->, it will be
+considered an option on itself.
+
+=item : I<number> [ I<desttype> ]
+
+Like C<:i>, but if the value is omitted, the I<number> will be assigned.
+
+=item : + [ I<desttype> ]
+
+Like C<:i>, but if the value is omitted, the current value for the
+option will be incremented.
+
+=back
+
+=head1 Advanced Possibilities
+
+=head2 Object oriented interface
+
+Getopt::Long can be used in an object oriented way as well:
+
+ use Getopt::Long;
+ $p = new Getopt::Long::Parser;
+ $p->configure(...configuration options...);
+ if ($p->getoptions(...options descriptions...)) ...
+
+Configuration options can be passed to the constructor:
+
+ $p = new Getopt::Long::Parser
+ config => [...configuration options...];
+
+=head2 Thread Safety
+
+Getopt::Long is thread safe when using ithreads as of Perl 5.8. It is
+I<not> thread safe when using the older (experimental and now
+obsolete) threads implementation that was added to Perl 5.005.
+
+=head2 Documentation and help texts
+
+Getopt::Long encourages the use of Pod::Usage to produce help
+messages. For example:
+
+ use Getopt::Long;
+ use Pod::Usage;
+
+ my $man = 0;
+ my $help = 0;
+
+ GetOptions('help|?' => \$help, man => \$man) or pod2usage(2);
+ pod2usage(1) if $help;
+ pod2usage(-exitstatus => 0, -verbose => 2) if $man;
+
+ __END__
+
+ =head1 NAME
+
+ sample - Using Getopt::Long and Pod::Usage
+
+ =head1 SYNOPSIS
+
+ sample [options] [file ...]
+
+ Options:
+ -help brief help message
+ -man full documentation
+
+ =head1 OPTIONS
+
+ =over 8
+
+ =item B<-help>
+
+ Print a brief help message and exits.
+
+ =item B<-man>
+
+ Prints the manual page and exits.
+
+ =back
+
+ =head1 DESCRIPTION
+
+ B<This program> will read the given input file(s) and do something
+ useful with the contents thereof.
+
+ =cut
+
+See L<Pod::Usage> for details.
+
+=head2 Storing option values in a hash
+
+Sometimes, for example when there are a lot of options, having a
+separate variable for each of them can be cumbersome. GetOptions()
+supports, as an alternative mechanism, storing options in a hash.
+
+To obtain this, a reference to a hash must be passed I<as the first
+argument> to GetOptions(). For each option that is specified on the
+command line, the option value will be stored in the hash with the
+option name as key. Options that are not actually used on the command
+line will not be put in the hash, on other words,
+C<exists($h{option})> (or defined()) can be used to test if an option
+was used. The drawback is that warnings will be issued if the program
+runs under C<use strict> and uses C<$h{option}> without testing with
+exists() or defined() first.
+
+ my %h = ();
+ GetOptions (\%h, 'length=i'); # will store in $h{length}
+
+For options that take list or hash values, it is necessary to indicate
+this by appending an C<@> or C<%> sign after the type:
+
+ GetOptions (\%h, 'colours=s@'); # will push to @{$h{colours}}
+
+To make things more complicated, the hash may contain references to
+the actual destinations, for example:
+
+ my $len = 0;
+ my %h = ('length' => \$len);
+ GetOptions (\%h, 'length=i'); # will store in $len
+
+This example is fully equivalent with:
+
+ my $len = 0;
+ GetOptions ('length=i' => \$len); # will store in $len
+
+Any mixture is possible. For example, the most frequently used options
+could be stored in variables while all other options get stored in the
+hash:
+
+ my $verbose = 0; # frequently referred
+ my $debug = 0; # frequently referred
+ my %h = ('verbose' => \$verbose, 'debug' => \$debug);
+ GetOptions (\%h, 'verbose', 'debug', 'filter', 'size=i');
+ if ( $verbose ) { ... }
+ if ( exists $h{filter} ) { ... option 'filter' was specified ... }
+
+=head2 Bundling
+
+With bundling it is possible to set several single-character options
+at once. For example if C<a>, C<v> and C<x> are all valid options,
+
+ -vax
+
+would set all three.
+
+Getopt::Long supports two levels of bundling. To enable bundling, a
+call to Getopt::Long::Configure is required.
+
+The first level of bundling can be enabled with:
+
+ Getopt::Long::Configure ("bundling");
+
+Configured this way, single-character options can be bundled but long
+options B<must> always start with a double dash C<--> to avoid
+ambiguity. For example, when C<vax>, C<a>, C<v> and C<x> are all valid
+options,
+
+ -vax
+
+would set C<a>, C<v> and C<x>, but
+
+ --vax
+
+would set C<vax>.
+
+The second level of bundling lifts this restriction. It can be enabled
+with:
+
+ Getopt::Long::Configure ("bundling_override");
+
+Now, C<-vax> would set the option C<vax>.
+
+When any level of bundling is enabled, option values may be inserted
+in the bundle. For example:
+
+ -h24w80
+
+is equivalent to
+
+ -h 24 -w 80
+
+When configured for bundling, single-character options are matched
+case sensitive while long options are matched case insensitive. To
+have the single-character options matched case insensitive as well,
+use:
+
+ Getopt::Long::Configure ("bundling", "ignorecase_always");
+
+It goes without saying that bundling can be quite confusing.
+
+=head2 The lonesome dash
+
+Normally, a lone dash C<-> on the command line will not be considered
+an option. Option processing will terminate (unless "permute" is
+configured) and the dash will be left in C<@ARGV>.
+
+It is possible to get special treatment for a lone dash. This can be
+achieved by adding an option specification with an empty name, for
+example:
+
+ GetOptions ('' => \$stdio);
+
+A lone dash on the command line will now be a legal option, and using
+it will set variable C<$stdio>.
+
+=head2 Argument callback
+
+A special option 'name' C<< <> >> can be used to designate a subroutine
+to handle non-option arguments. When GetOptions() encounters an
+argument that does not look like an option, it will immediately call this
+subroutine and passes it one parameter: the argument name.
+
+For example:
+
+ my $width = 80;
+ sub process { ... }
+ GetOptions ('width=i' => \$width, '<>' => \&process);
+
+When applied to the following command line:
+
+ arg1 --width=72 arg2 --width=60 arg3
+
+This will call
+C<process("arg1")> while C<$width> is C<80>,
+C<process("arg2")> while C<$width> is C<72>, and
+C<process("arg3")> while C<$width> is C<60>.
+
+This feature requires configuration option B<permute>, see section
+L<Configuring Getopt::Long>.
+
+=head1 Configuring Getopt::Long
+
+Getopt::Long can be configured by calling subroutine
+Getopt::Long::Configure(). This subroutine takes a list of quoted
+strings, each specifying a configuration option to be enabled, e.g.
+C<ignore_case>, or disabled, e.g. C<no_ignore_case>. Case does not
+matter. Multiple calls to Configure() are possible.
+
+Alternatively, as of version 2.24, the configuration options may be
+passed together with the C<use> statement:
+
+ use Getopt::Long qw(:config no_ignore_case bundling);
+
+The following options are available:
+
+=over 12
+
+=item default
+
+This option causes all configuration options to be reset to their
+default values.
+
+=item posix_default
+
+This option causes all configuration options to be reset to their
+default values as if the environment variable POSIXLY_CORRECT had
+been set.
+
+=item auto_abbrev
+
+Allow option names to be abbreviated to uniqueness.
+Default is enabled unless environment variable
+POSIXLY_CORRECT has been set, in which case C<auto_abbrev> is disabled.
+
+=item getopt_compat
+
+Allow C<+> to start options.
+Default is enabled unless environment variable
+POSIXLY_CORRECT has been set, in which case C<getopt_compat> is disabled.
+
+=item gnu_compat
+
+C<gnu_compat> controls whether C<--opt=> is allowed, and what it should
+do. Without C<gnu_compat>, C<--opt=> gives an error. With C<gnu_compat>,
+C<--opt=> will give option C<opt> and empty value.
+This is the way GNU getopt_long() does it.
+
+=item gnu_getopt
+
+This is a short way of setting C<gnu_compat> C<bundling> C<permute>
+C<no_getopt_compat>. With C<gnu_getopt>, command line handling should be
+fully compatible with GNU getopt_long().
+
+=item require_order
+
+Whether command line arguments are allowed to be mixed with options.
+Default is disabled unless environment variable
+POSIXLY_CORRECT has been set, in which case C<require_order> is enabled.
+
+See also C<permute>, which is the opposite of C<require_order>.
+
+=item permute
+
+Whether command line arguments are allowed to be mixed with options.
+Default is enabled unless environment variable
+POSIXLY_CORRECT has been set, in which case C<permute> is disabled.
+Note that C<permute> is the opposite of C<require_order>.
+
+If C<permute> is enabled, this means that
+
+ --foo arg1 --bar arg2 arg3
+
+is equivalent to
+
+ --foo --bar arg1 arg2 arg3
+
+If an argument callback routine is specified, C<@ARGV> will always be
+empty upon successful return of GetOptions() since all options have been
+processed. The only exception is when C<--> is used:
+
+ --foo arg1 --bar arg2 -- arg3
+
+This will call the callback routine for arg1 and arg2, and then
+terminate GetOptions() leaving C<"arg2"> in C<@ARGV>.
+
+If C<require_order> is enabled, options processing
+terminates when the first non-option is encountered.
+
+ --foo arg1 --bar arg2 arg3
+
+is equivalent to
+
+ --foo -- arg1 --bar arg2 arg3
+
+If C<pass_through> is also enabled, options processing will terminate
+at the first unrecognized option, or non-option, whichever comes
+first.
+
+=item bundling (default: disabled)
+
+Enabling this option will allow single-character options to be
+bundled. To distinguish bundles from long option names, long options
+I<must> be introduced with C<--> and bundles with C<->.
+
+Note that, if you have options C<a>, C<l> and C<all>, and
+auto_abbrev enabled, possible arguments and option settings are:
+
+ using argument sets option(s)
+ ------------------------------------------
+ -a, --a a
+ -l, --l l
+ -al, -la, -ala, -all,... a, l
+ --al, --all all
+
+The surprising part is that C<--a> sets option C<a> (due to auto
+completion), not C<all>.
+
+Note: disabling C<bundling> also disables C<bundling_override>.
+
+=item bundling_override (default: disabled)
+
+If C<bundling_override> is enabled, bundling is enabled as with
+C<bundling> but now long option names override option bundles.
+
+Note: disabling C<bundling_override> also disables C<bundling>.
+
+B<Note:> Using option bundling can easily lead to unexpected results,
+especially when mixing long options and bundles. Caveat emptor.
+
+=item ignore_case (default: enabled)
+
+If enabled, case is ignored when matching long option names. If,
+however, bundling is enabled as well, single character options will be
+treated case-sensitive.
+
+With C<ignore_case>, option specifications for options that only
+differ in case, e.g., C<"foo"> and C<"Foo">, will be flagged as
+duplicates.
+
+Note: disabling C<ignore_case> also disables C<ignore_case_always>.
+
+=item ignore_case_always (default: disabled)
+
+When bundling is in effect, case is ignored on single-character
+options also.
+
+Note: disabling C<ignore_case_always> also disables C<ignore_case>.
+
+=item auto_version (default:disabled)
+
+Automatically provide support for the B<--version> option if
+the application did not specify a handler for this option itself.
+
+Getopt::Long will provide a standard version message that includes the
+program name, its version (if $main::VERSION is defined), and the
+versions of Getopt::Long and Perl. The message will be written to
+standard output and processing will terminate.
+
+C<auto_version> will be enabled if the calling program explicitly
+specified a version number higher than 2.32 in the C<use> or
+C<require> statement.
+
+=item auto_help (default:disabled)
+
+Automatically provide support for the B<--help> and B<-?> options if
+the application did not specify a handler for this option itself.
+
+Getopt::Long will provide a help message using module L<Pod::Usage>. The
+message, derived from the SYNOPSIS POD section, will be written to
+standard output and processing will terminate.
+
+C<auto_help> will be enabled if the calling program explicitly
+specified a version number higher than 2.32 in the C<use> or
+C<require> statement.
+
+=item pass_through (default: disabled)
+
+Options that are unknown, ambiguous or supplied with an invalid option
+value are passed through in C<@ARGV> instead of being flagged as
+errors. This makes it possible to write wrapper scripts that process
+only part of the user supplied command line arguments, and pass the
+remaining options to some other program.
+
+If C<require_order> is enabled, options processing will terminate at
+the first unrecognized option, or non-option, whichever comes first.
+However, if C<permute> is enabled instead, results can become confusing.
+
+Note that the options terminator (default C<-->), if present, will
+also be passed through in C<@ARGV>.
+
+=item prefix
+
+The string that starts options. If a constant string is not
+sufficient, see C<prefix_pattern>.
+
+=item prefix_pattern
+
+A Perl pattern that identifies the strings that introduce options.
+Default is C<--|-|\+> unless environment variable
+POSIXLY_CORRECT has been set, in which case it is C<--|->.
+
+=item long_prefix_pattern
+
+A Perl pattern that allows the disambiguation of long and short
+prefixes. Default is C<-->.
+
+Typically you only need to set this if you are using nonstandard
+prefixes and want some or all of them to have the same semantics as
+'--' does under normal circumstances.
+
+For example, setting prefix_pattern to C<--|-|\+|\/> and
+long_prefix_pattern to C<--|\/> would add Win32 style argument
+handling.
+
+=item debug (default: disabled)
+
+Enable debugging output.
+
+=back
+
+=head1 Exportable Methods
+
+=over
+
+=item VersionMessage
+
+This subroutine provides a standard version message. Its argument can be:
+
+=over 4
+
+=item *
+
+A string containing the text of a message to print I<before> printing
+the standard message.
+
+=item *
+
+A numeric value corresponding to the desired exit status.
+
+=item *
+
+A reference to a hash.
+
+=back
+
+If more than one argument is given then the entire argument list is
+assumed to be a hash. If a hash is supplied (either as a reference or
+as a list) it should contain one or more elements with the following
+keys:
+
+=over 4
+
+=item C<-message>
+
+=item C<-msg>
+
+The text of a message to print immediately prior to printing the
+program's usage message.
+
+=item C<-exitval>
+
+The desired exit status to pass to the B<exit()> function.
+This should be an integer, or else the string "NOEXIT" to
+indicate that control should simply be returned without
+terminating the invoking process.
+
+=item C<-output>
+
+A reference to a filehandle, or the pathname of a file to which the
+usage message should be written. The default is C<\*STDERR> unless the
+exit value is less than 2 (in which case the default is C<\*STDOUT>).
+
+=back
+
+You cannot tie this routine directly to an option, e.g.:
+
+ GetOptions("version" => \&VersionMessage);
+
+Use this instead:
+
+ GetOptions("version" => sub { VersionMessage() });
+
+=item HelpMessage
+
+This subroutine produces a standard help message, derived from the
+program's POD section SYNOPSIS using L<Pod::Usage>. It takes the same
+arguments as VersionMessage(). In particular, you cannot tie it
+directly to an option, e.g.:
+
+ GetOptions("help" => \&HelpMessage);
+
+Use this instead:
+
+ GetOptions("help" => sub { HelpMessage() });
+
+=back
+
+=head1 Return values and Errors
+
+Configuration errors and errors in the option definitions are
+signalled using die() and will terminate the calling program unless
+the call to Getopt::Long::GetOptions() was embedded in C<eval { ...
+}>, or die() was trapped using C<$SIG{__DIE__}>.
+
+GetOptions returns true to indicate success.
+It returns false when the function detected one or more errors during
+option parsing. These errors are signalled using warn() and can be
+trapped with C<$SIG{__WARN__}>.
+
+=head1 Legacy
+
+The earliest development of C<newgetopt.pl> started in 1990, with Perl
+version 4. As a result, its development, and the development of
+Getopt::Long, has gone through several stages. Since backward
+compatibility has always been extremely important, the current version
+of Getopt::Long still supports a lot of constructs that nowadays are
+no longer necessary or otherwise unwanted. This section describes
+briefly some of these 'features'.
+
+=head2 Default destinations
+
+When no destination is specified for an option, GetOptions will store
+the resultant value in a global variable named C<opt_>I<XXX>, where
+I<XXX> is the primary name of this option. When a progam executes
+under C<use strict> (recommended), these variables must be
+pre-declared with our() or C<use vars>.
+
+ our $opt_length = 0;
+ GetOptions ('length=i'); # will store in $opt_length
+
+To yield a usable Perl variable, characters that are not part of the
+syntax for variables are translated to underscores. For example,
+C<--fpp-struct-return> will set the variable
+C<$opt_fpp_struct_return>. Note that this variable resides in the
+namespace of the calling program, not necessarily C<main>. For
+example:
+
+ GetOptions ("size=i", "sizes=i@");
+
+with command line "-size 10 -sizes 24 -sizes 48" will perform the
+equivalent of the assignments
+
+ $opt_size = 10;
+ @opt_sizes = (24, 48);
+
+=head2 Alternative option starters
+
+A string of alternative option starter characters may be passed as the
+first argument (or the first argument after a leading hash reference
+argument).
+
+ my $len = 0;
+ GetOptions ('/', 'length=i' => $len);
+
+Now the command line may look like:
+
+ /length 24 -- arg
+
+Note that to terminate options processing still requires a double dash
+C<-->.
+
+GetOptions() will not interpret a leading C<< "<>" >> as option starters
+if the next argument is a reference. To force C<< "<" >> and C<< ">" >> as
+option starters, use C<< "><" >>. Confusing? Well, B<using a starter
+argument is strongly deprecated> anyway.
+
+=head2 Configuration variables
+
+Previous versions of Getopt::Long used variables for the purpose of
+configuring. Although manipulating these variables still work, it is
+strongly encouraged to use the C<Configure> routine that was introduced
+in version 2.17. Besides, it is much easier.
+
+=head1 Trouble Shooting
+
+=head2 GetOptions does not return a false result when an option is not supplied
+
+That's why they're called 'options'.
+
+=head2 GetOptions does not split the command line correctly
+
+The command line is not split by GetOptions, but by the command line
+interpreter (CLI). On Unix, this is the shell. On Windows, it is
+COMMAND.COM or CMD.EXE. Other operating systems have other CLIs.
+
+It is important to know that these CLIs may behave different when the
+command line contains special characters, in particular quotes or
+backslashes. For example, with Unix shells you can use single quotes
+(C<'>) and double quotes (C<">) to group words together. The following
+alternatives are equivalent on Unix:
+
+ "two words"
+ 'two words'
+ two\ words
+
+In case of doubt, insert the following statement in front of your Perl
+program:
+
+ print STDERR (join("|",@ARGV),"\n");
+
+to verify how your CLI passes the arguments to the program.
+
+=head2 Undefined subroutine &main::GetOptions called
+
+Are you running Windows, and did you write
+
+ use GetOpt::Long;
+
+(note the capital 'O')?
+
+=head2 How do I put a "-?" option into a Getopt::Long?
+
+You can only obtain this using an alias, and Getopt::Long of at least
+version 2.13.
+
+ use Getopt::Long;
+ GetOptions ("help|?"); # -help and -? will both set $opt_help
+
+=head1 AUTHOR
+
+Johan Vromans <jvromans@squirrel.nl>
+
+=head1 COPYRIGHT AND DISCLAIMER
+
+This program is Copyright 1990,2005 by Johan Vromans.
+This program is free software; you can redistribute it and/or
+modify it under the terms of the Perl Artistic License or the
+GNU General Public License as published by the Free Software
+Foundation; either version 2 of the License, or (at your option) 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.
+
+If you do not have a copy of the GNU General Public License write to
+the Free Software Foundation, Inc., 675 Mass Ave, Cambridge,
+MA 02139, USA.
+
+=cut
+
diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/constant.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/constant.pm
new file mode 100644
index 00000000000..159c29978a5
--- /dev/null
+++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/constant.pm
@@ -0,0 +1,340 @@
+package constant;
+
+use strict;
+use 5.006_00;
+use warnings::register;
+
+our($VERSION, %declared);
+$VERSION = '1.05';
+
+#=======================================================================
+
+# Some names are evil choices.
+my %keywords = map +($_, 1), qw{ BEGIN INIT CHECK END DESTROY AUTOLOAD };
+
+my %forced_into_main = map +($_, 1),
+ qw{ STDIN STDOUT STDERR ARGV ARGVOUT ENV INC SIG };
+
+my %forbidden = (%keywords, %forced_into_main);
+
+#=======================================================================
+# import() - import symbols into user's namespace
+#
+# What we actually do is define a function in the caller's namespace
+# which returns the value. The function we create will normally
+# be inlined as a constant, thereby avoiding further sub calling
+# overhead.
+#=======================================================================
+sub import {
+ my $class = shift;
+ return unless @_; # Ignore 'use constant;'
+ my %constants = ();
+ my $multiple = ref $_[0];
+
+ if ( $multiple ) {
+ if (ref $_[0] ne 'HASH') {
+ require Carp;
+ Carp::croak("Invalid reference type '".ref(shift)."' not 'HASH'");
+ }
+ %constants = %{+shift};
+ } else {
+ $constants{+shift} = undef;
+ }
+
+ foreach my $name ( keys %constants ) {
+ unless (defined $name) {
+ require Carp;
+ Carp::croak("Can't use undef as constant name");
+ }
+ my $pkg = caller;
+
+ # Normal constant name
+ if ($name =~ /^_?[^\W_0-9]\w*\z/ and !$forbidden{$name}) {
+ # Everything is okay
+
+ # Name forced into main, but we're not in main. Fatal.
+ } elsif ($forced_into_main{$name} and $pkg ne 'main') {
+ require Carp;
+ Carp::croak("Constant name '$name' is forced into main::");
+
+ # Starts with double underscore. Fatal.
+ } elsif ($name =~ /^__/) {
+ require Carp;
+ Carp::croak("Constant name '$name' begins with '__'");
+
+ # Maybe the name is tolerable
+ } elsif ($name =~ /^[A-Za-z_]\w*\z/) {
+ # Then we'll warn only if you've asked for warnings
+ if (warnings::enabled()) {
+ if ($keywords{$name}) {
+ warnings::warn("Constant name '$name' is a Perl keyword");
+ } elsif ($forced_into_main{$name}) {
+ warnings::warn("Constant name '$name' is " .
+ "forced into package main::");
+ }
+ }
+
+ # Looks like a boolean
+ # use constant FRED == fred;
+ } elsif ($name =~ /^[01]?\z/) {
+ require Carp;
+ if (@_) {
+ Carp::croak("Constant name '$name' is invalid");
+ } else {
+ Carp::croak("Constant name looks like boolean value");
+ }
+
+ } else {
+ # Must have bad characters
+ require Carp;
+ Carp::croak("Constant name '$name' has invalid characters");
+ }
+
+ {
+ no strict 'refs';
+ my $full_name = "${pkg}::$name";
+ $declared{$full_name}++;
+ if ($multiple) {
+ my $scalar = $constants{$name};
+ *$full_name = sub () { $scalar };
+ } else {
+ if (@_ == 1) {
+ my $scalar = $_[0];
+ *$full_name = sub () { $scalar };
+ } elsif (@_) {
+ my @list = @_;
+ *$full_name = sub () { @list };
+ } else {
+ *$full_name = sub () { };
+ }
+ }
+ }
+ }
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+constant - Perl pragma to declare constants
+
+=head1 SYNOPSIS
+
+ use constant PI => 4 * atan2(1, 1);
+ use constant DEBUG => 0;
+
+ print "Pi equals ", PI, "...\n" if DEBUG;
+
+ use constant {
+ SEC => 0,
+ MIN => 1,
+ HOUR => 2,
+ MDAY => 3,
+ MON => 4,
+ YEAR => 5,
+ WDAY => 6,
+ YDAY => 7,
+ ISDST => 8,
+ };
+
+ use constant WEEKDAYS => qw(
+ Sunday Monday Tuesday Wednesday Thursday Friday Saturday
+ );
+
+ print "Today is ", (WEEKDAYS)[ (localtime)[WDAY] ], ".\n";
+
+=head1 DESCRIPTION
+
+This will declare a symbol to be a constant with the given value.
+
+When you declare a constant such as C<PI> using the method shown
+above, each machine your script runs upon can have as many digits
+of accuracy as it can use. Also, your program will be easier to
+read, more likely to be maintained (and maintained correctly), and
+far less likely to send a space probe to the wrong planet because
+nobody noticed the one equation in which you wrote C<3.14195>.
+
+When a constant is used in an expression, perl replaces it with its
+value at compile time, and may then optimize the expression further.
+In particular, any code in an C<if (CONSTANT)> block will be optimized
+away if the constant is false.
+
+=head1 NOTES
+
+As with all C<use> directives, defining a constant happens at
+compile time. Thus, it's probably not correct to put a constant
+declaration inside of a conditional statement (like C<if ($foo)
+{ use constant ... }>).
+
+Constants defined using this module cannot be interpolated into
+strings like variables. However, concatenation works just fine:
+
+ print "Pi equals PI...\n"; # WRONG: does not expand "PI"
+ print "Pi equals ".PI."...\n"; # right
+
+Even though a reference may be declared as a constant, the reference may
+point to data which may be changed, as this code shows.
+
+ use constant ARRAY => [ 1,2,3,4 ];
+ print ARRAY->[1];
+ ARRAY->[1] = " be changed";
+ print ARRAY->[1];
+
+Dereferencing constant references incorrectly (such as using an array
+subscript on a constant hash reference, or vice versa) will be trapped at
+compile time.
+
+Constants belong to the package they are defined in. To refer to a
+constant defined in another package, specify the full package name, as
+in C<Some::Package::CONSTANT>. Constants may be exported by modules,
+and may also be called as either class or instance methods, that is,
+as C<< Some::Package->CONSTANT >> or as C<< $obj->CONSTANT >> where
+C<$obj> is an instance of C<Some::Package>. Subclasses may define
+their own constants to override those in their base class.
+
+The use of all caps for constant names is merely a convention,
+although it is recommended in order to make constants stand out
+and to help avoid collisions with other barewords, keywords, and
+subroutine names. Constant names must begin with a letter or
+underscore. Names beginning with a double underscore are reserved. Some
+poor choices for names will generate warnings, if warnings are enabled at
+compile time.
+
+=head2 List constants
+
+Constants may be lists of more (or less) than one value. A constant
+with no values evaluates to C<undef> in scalar context. Note that
+constants with more than one value do I<not> return their last value in
+scalar context as one might expect. They currently return the number
+of values, but B<this may change in the future>. Do not use constants
+with multiple values in scalar context.
+
+B<NOTE:> This implies that the expression defining the value of a
+constant is evaluated in list context. This may produce surprises:
+
+ use constant TIMESTAMP => localtime; # WRONG!
+ use constant TIMESTAMP => scalar localtime; # right
+
+The first line above defines C<TIMESTAMP> as a 9-element list, as
+returned by localtime() in list context. To set it to the string
+returned by localtime() in scalar context, an explicit C<scalar>
+keyword is required.
+
+List constants are lists, not arrays. To index or slice them, they
+must be placed in parentheses.
+
+ my @workdays = WEEKDAYS[1 .. 5]; # WRONG!
+ my @workdays = (WEEKDAYS)[1 .. 5]; # right
+
+=head2 Defining multiple constants at once
+
+Instead of writing multiple C<use constant> statements, you may define
+multiple constants in a single statement by giving, instead of the
+constant name, a reference to a hash where the keys are the names of
+the constants to be defined. Obviously, all constants defined using
+this method must have a single value.
+
+ use constant {
+ FOO => "A single value",
+ BAR => "This", "won't", "work!", # Error!
+ };
+
+This is a fundamental limitation of the way hashes are constructed in
+Perl. The error messages produced when this happens will often be
+quite cryptic -- in the worst case there may be none at all, and
+you'll only later find that something is broken.
+
+When defining multiple constants, you cannot use the values of other
+constants defined in the same declaration. This is because the
+calling package doesn't know about any constant within that group
+until I<after> the C<use> statement is finished.
+
+ use constant {
+ BITMASK => 0xAFBAEBA8,
+ NEGMASK => ~BITMASK, # Error!
+ };
+
+=head2 Magic constants
+
+Magical values and references can be made into constants at compile
+time, allowing for way cool stuff like this. (These error numbers
+aren't totally portable, alas.)
+
+ use constant E2BIG => ($! = 7);
+ print E2BIG, "\n"; # something like "Arg list too long"
+ print 0+E2BIG, "\n"; # "7"
+
+You can't produce a tied constant by giving a tied scalar as the
+value. References to tied variables, however, can be used as
+constants without any problems.
+
+=head1 TECHNICAL NOTES
+
+In the current implementation, scalar constants are actually
+inlinable subroutines. As of version 5.004 of Perl, the appropriate
+scalar constant is inserted directly in place of some subroutine
+calls, thereby saving the overhead of a subroutine call. See
+L<perlsub/"Constant Functions"> for details about how and when this
+happens.
+
+In the rare case in which you need to discover at run time whether a
+particular constant has been declared via this module, you may use
+this function to examine the hash C<%constant::declared>. If the given
+constant name does not include a package name, the current package is
+used.
+
+ sub declared ($) {
+ use constant 1.01; # don't omit this!
+ my $name = shift;
+ $name =~ s/^::/main::/;
+ my $pkg = caller;
+ my $full_name = $name =~ /::/ ? $name : "${pkg}::$name";
+ $constant::declared{$full_name};
+ }
+
+=head1 BUGS
+
+In the current version of Perl, list constants are not inlined
+and some symbols may be redefined without generating a warning.
+
+It is not possible to have a subroutine or a keyword with the same
+name as a constant in the same package. This is probably a Good Thing.
+
+A constant with a name in the list C<STDIN STDOUT STDERR ARGV ARGVOUT
+ENV INC SIG> is not allowed anywhere but in package C<main::>, for
+technical reasons.
+
+Unlike constants in some languages, these cannot be overridden
+on the command line or via environment variables.
+
+You can get into trouble if you use constants in a context which
+automatically quotes barewords (as is true for any subroutine call).
+For example, you can't say C<$hash{CONSTANT}> because C<CONSTANT> will
+be interpreted as a string. Use C<$hash{CONSTANT()}> or
+C<$hash{+CONSTANT}> to prevent the bareword quoting mechanism from
+kicking in. Similarly, since the C<< => >> operator quotes a bareword
+immediately to its left, you have to say C<< CONSTANT() => 'value' >>
+(or simply use a comma in place of the big arrow) instead of
+C<< CONSTANT => 'value' >>.
+
+=head1 AUTHOR
+
+Tom Phoenix, E<lt>F<rootbeer@redcat.com>E<gt>, with help from
+many other folks.
+
+Multiple constant declarations at once added by Casey West,
+E<lt>F<casey@geeknest.com>E<gt>.
+
+Documentation mostly rewritten by Ilmari Karonen,
+E<lt>F<perl@itz.pp.sci.fi>E<gt>.
+
+=head1 COPYRIGHT
+
+Copyright (C) 1997, 1999 Tom Phoenix
+
+This module is free software; you can redistribute it or modify it
+under the same terms as Perl itself.
+
+=cut
diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/strict.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/strict.pm
new file mode 100644
index 00000000000..d14391add44
--- /dev/null
+++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/strict.pm
@@ -0,0 +1,136 @@
+package strict;
+
+$strict::VERSION = "1.03";
+
+my %bitmask = (
+refs => 0x00000002,
+subs => 0x00000200,
+vars => 0x00000400
+);
+
+sub bits {
+ my $bits = 0;
+ my @wrong;
+ foreach my $s (@_) {
+ push @wrong, $s unless exists $bitmask{$s};
+ $bits |= $bitmask{$s} || 0;
+ }
+ if (@wrong) {
+ require Carp;
+ Carp::croak("Unknown 'strict' tag(s) '@wrong'");
+ }
+ $bits;
+}
+
+my $default_bits = bits(qw(refs subs vars));
+
+sub import {
+ shift;
+ $^H |= @_ ? bits(@_) : $default_bits;
+}
+
+sub unimport {
+ shift;
+ $^H &= ~ (@_ ? bits(@_) : $default_bits);
+}
+
+1;
+__END__
+
+=head1 NAME
+
+strict - Perl pragma to restrict unsafe constructs
+
+=head1 SYNOPSIS
+
+ use strict;
+
+ use strict "vars";
+ use strict "refs";
+ use strict "subs";
+
+ use strict;
+ no strict "vars";
+
+=head1 DESCRIPTION
+
+If no import list is supplied, all possible restrictions are assumed.
+(This is the safest mode to operate in, but is sometimes too strict for
+casual programming.) Currently, there are three possible things to be
+strict about: "subs", "vars", and "refs".
+
+=over 6
+
+=item C<strict refs>
+
+This generates a runtime error if you
+use symbolic references (see L<perlref>).
+
+ use strict 'refs';
+ $ref = \$foo;
+ print $$ref; # ok
+ $ref = "foo";
+ print $$ref; # runtime error; normally ok
+ $file = "STDOUT";
+ print $file "Hi!"; # error; note: no comma after $file
+
+There is one exception to this rule:
+
+ $bar = \&{'foo'};
+ &$bar;
+
+is allowed so that C<goto &$AUTOLOAD> would not break under stricture.
+
+
+=item C<strict vars>
+
+This generates a compile-time error if you access a variable that wasn't
+declared via C<our> or C<use vars>,
+localized via C<my()>, or wasn't fully qualified. Because this is to avoid
+variable suicide problems and subtle dynamic scoping issues, a merely
+local() variable isn't good enough. See L<perlfunc/my> and
+L<perlfunc/local>.
+
+ use strict 'vars';
+ $X::foo = 1; # ok, fully qualified
+ my $foo = 10; # ok, my() var
+ local $foo = 9; # blows up
+
+ package Cinna;
+ our $bar; # Declares $bar in current package
+ $bar = 'HgS'; # ok, global declared via pragma
+
+The local() generated a compile-time error because you just touched a global
+name without fully qualifying it.
+
+Because of their special use by sort(), the variables $a and $b are
+exempted from this check.
+
+=item C<strict subs>
+
+This disables the poetry optimization, generating a compile-time error if
+you try to use a bareword identifier that's not a subroutine, unless it
+is a simple identifier (no colons) and that it appears in curly braces or
+on the left hand side of the C<< => >> symbol.
+
+ use strict 'subs';
+ $SIG{PIPE} = Plumber; # blows up
+ $SIG{PIPE} = "Plumber"; # just fine: quoted string is always ok
+ $SIG{PIPE} = \&Plumber; # preferred form
+
+=back
+
+See L<perlmodlib/Pragmatic Modules>.
+
+=head1 HISTORY
+
+C<strict 'subs'>, with Perl 5.6.1, erroneously permitted to use an unquoted
+compound identifier (e.g. C<Foo::Bar>) as a hash key (before C<< => >> or
+inside curlies), but without forcing it always to a literal string.
+
+Starting with Perl 5.8.1 strict is strict about its restrictions:
+if unknown restrictions are used, the strict pragma will abort with
+
+ Unknown 'strict' tag(s) '...'
+
+=cut
diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/vars.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/vars.pm
new file mode 100644
index 00000000000..a0151b84030
--- /dev/null
+++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/vars.pm
@@ -0,0 +1,82 @@
+package vars;
+
+use 5.006;
+
+our $VERSION = '1.01';
+
+use warnings::register;
+use strict qw(vars subs);
+
+sub import {
+ my $callpack = caller;
+ my ($pack, @imports) = @_;
+ my ($sym, $ch);
+ foreach (@imports) {
+ if (($ch, $sym) = /^([\$\@\%\*\&])(.+)/) {
+ if ($sym =~ /\W/) {
+ # time for a more-detailed check-up
+ if ($sym =~ /^\w+[[{].*[]}]$/) {
+ require Carp;
+ Carp::croak("Can't declare individual elements of hash or array");
+ } elsif (warnings::enabled() and length($sym) == 1 and $sym !~ tr/a-zA-Z//) {
+ warnings::warn("No need to declare built-in vars");
+ } elsif (($^H &= strict::bits('vars'))) {
+ require Carp;
+ Carp::croak("'$_' is not a valid variable name under strict vars");
+ }
+ }
+ $sym = "${callpack}::$sym" unless $sym =~ /::/;
+ *$sym =
+ ( $ch eq "\$" ? \$$sym
+ : $ch eq "\@" ? \@$sym
+ : $ch eq "\%" ? \%$sym
+ : $ch eq "\*" ? \*$sym
+ : $ch eq "\&" ? \&$sym
+ : do {
+ require Carp;
+ Carp::croak("'$_' is not a valid variable name");
+ });
+ } else {
+ require Carp;
+ Carp::croak("'$_' is not a valid variable name");
+ }
+ }
+};
+
+1;
+__END__
+
+=head1 NAME
+
+vars - Perl pragma to predeclare global variable names (obsolete)
+
+=head1 SYNOPSIS
+
+ use vars qw($frob @mung %seen);
+
+=head1 DESCRIPTION
+
+NOTE: For variables in the current package, the functionality provided
+by this pragma has been superseded by C<our> declarations, available
+in Perl v5.6.0 or later. See L<perlfunc/our>.
+
+This will predeclare all the variables whose names are
+in the list, allowing you to use them under "use strict", and
+disabling any typo warnings.
+
+Unlike pragmas that affect the C<$^H> hints variable, the C<use vars> and
+C<use subs> declarations are not BLOCK-scoped. They are thus effective
+for the entire file in which they appear. You may not rescind such
+declarations with C<no vars> or C<no subs>.
+
+Packages such as the B<AutoLoader> and B<SelfLoader> that delay
+loading of subroutines within packages can create problems with
+package lexicals defined using C<my()>. While the B<vars> pragma
+cannot duplicate the effect of package lexicals (total transparency
+outside of the package), it can act as an acceptable substitute by
+pre-declaring global symbols, ensuring their availability to the
+later-loaded routines.
+
+See L<perlmodlib/Pragmatic Modules>.
+
+=cut
diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/warnings.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/warnings.pm
new file mode 100644
index 00000000000..e43b686c908
--- /dev/null
+++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/warnings.pm
@@ -0,0 +1,497 @@
+# -*- buffer-read-only: t -*-
+# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+# This file was created by warnings.pl
+# Any changes made here will be lost.
+#
+
+package warnings;
+
+our $VERSION = '1.05';
+
+=head1 NAME
+
+warnings - Perl pragma to control optional warnings
+
+=head1 SYNOPSIS
+
+ use warnings;
+ no warnings;
+
+ use warnings "all";
+ no warnings "all";
+
+ use warnings::register;
+ if (warnings::enabled()) {
+ warnings::warn("some warning");
+ }
+
+ if (warnings::enabled("void")) {
+ warnings::warn("void", "some warning");
+ }
+
+ if (warnings::enabled($object)) {
+ warnings::warn($object, "some warning");
+ }
+
+ warnings::warnif("some warning");
+ warnings::warnif("void", "some warning");
+ warnings::warnif($object, "some warning");
+
+=head1 DESCRIPTION
+
+The C<warnings> pragma is a replacement for the command line flag C<-w>,
+but the pragma is limited to the enclosing block, while the flag is global.
+See L<perllexwarn> for more information.
+
+If no import list is supplied, all possible warnings are either enabled
+or disabled.
+
+A number of functions are provided to assist module authors.
+
+=over 4
+
+=item use warnings::register
+
+Creates a new warnings category with the same name as the package where
+the call to the pragma is used.
+
+=item warnings::enabled()
+
+Use the warnings category with the same name as the current package.
+
+Return TRUE if that warnings category is enabled in the calling module.
+Otherwise returns FALSE.
+
+=item warnings::enabled($category)
+
+Return TRUE if the warnings category, C<$category>, is enabled in the
+calling module.
+Otherwise returns FALSE.
+
+=item warnings::enabled($object)
+
+Use the name of the class for the object reference, C<$object>, as the
+warnings category.
+
+Return TRUE if that warnings category is enabled in the first scope
+where the object is used.
+Otherwise returns FALSE.
+
+=item warnings::warn($message)
+
+Print C<$message> to STDERR.
+
+Use the warnings category with the same name as the current package.
+
+If that warnings category has been set to "FATAL" in the calling module
+then die. Otherwise return.
+
+=item warnings::warn($category, $message)
+
+Print C<$message> to STDERR.
+
+If the warnings category, C<$category>, has been set to "FATAL" in the
+calling module then die. Otherwise return.
+
+=item warnings::warn($object, $message)
+
+Print C<$message> to STDERR.
+
+Use the name of the class for the object reference, C<$object>, as the
+warnings category.
+
+If that warnings category has been set to "FATAL" in the scope where C<$object>
+is first used then die. Otherwise return.
+
+
+=item warnings::warnif($message)
+
+Equivalent to:
+
+ if (warnings::enabled())
+ { warnings::warn($message) }
+
+=item warnings::warnif($category, $message)
+
+Equivalent to:
+
+ if (warnings::enabled($category))
+ { warnings::warn($category, $message) }
+
+=item warnings::warnif($object, $message)
+
+Equivalent to:
+
+ if (warnings::enabled($object))
+ { warnings::warn($object, $message) }
+
+=back
+
+See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
+
+=cut
+
+use Carp ();
+
+our %Offsets = (
+
+ # Warnings Categories added in Perl 5.008
+
+ 'all' => 0,
+ 'closure' => 2,
+ 'deprecated' => 4,
+ 'exiting' => 6,
+ 'glob' => 8,
+ 'io' => 10,
+ 'closed' => 12,
+ 'exec' => 14,
+ 'layer' => 16,
+ 'newline' => 18,
+ 'pipe' => 20,
+ 'unopened' => 22,
+ 'misc' => 24,
+ 'numeric' => 26,
+ 'once' => 28,
+ 'overflow' => 30,
+ 'pack' => 32,
+ 'portable' => 34,
+ 'recursion' => 36,
+ 'redefine' => 38,
+ 'regexp' => 40,
+ 'severe' => 42,
+ 'debugging' => 44,
+ 'inplace' => 46,
+ 'internal' => 48,
+ 'malloc' => 50,
+ 'signal' => 52,
+ 'substr' => 54,
+ 'syntax' => 56,
+ 'ambiguous' => 58,
+ 'bareword' => 60,
+ 'digit' => 62,
+ 'parenthesis' => 64,
+ 'precedence' => 66,
+ 'printf' => 68,
+ 'prototype' => 70,
+ 'qw' => 72,
+ 'reserved' => 74,
+ 'semicolon' => 76,
+ 'taint' => 78,
+ 'threads' => 80,
+ 'uninitialized' => 82,
+ 'unpack' => 84,
+ 'untie' => 86,
+ 'utf8' => 88,
+ 'void' => 90,
+ 'y2k' => 92,
+ );
+
+our %Bits = (
+ 'all' => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x15", # [0..46]
+ 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00", # [29]
+ 'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00", # [30]
+ 'closed' => "\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
+ 'closure' => "\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
+ 'debugging' => "\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00", # [22]
+ 'deprecated' => "\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
+ 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00", # [31]
+ 'exec' => "\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
+ 'exiting' => "\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
+ 'glob' => "\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
+ 'inplace' => "\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00", # [23]
+ 'internal' => "\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00", # [24]
+ 'io' => "\x00\x54\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..11]
+ 'layer' => "\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
+ 'malloc' => "\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00", # [25]
+ 'misc' => "\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
+ 'newline' => "\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
+ 'numeric' => "\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
+ 'once' => "\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
+ 'overflow' => "\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
+ 'pack' => "\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00", # [16]
+ 'parenthesis' => "\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00", # [32]
+ 'pipe' => "\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
+ 'portable' => "\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00", # [17]
+ 'precedence' => "\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00", # [33]
+ 'printf' => "\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00", # [34]
+ 'prototype' => "\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00", # [35]
+ 'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00", # [36]
+ 'recursion' => "\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00", # [18]
+ 'redefine' => "\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00", # [19]
+ 'regexp' => "\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00", # [20]
+ 'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00", # [37]
+ 'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00", # [38]
+ 'severe' => "\x00\x00\x00\x00\x00\x54\x05\x00\x00\x00\x00\x00", # [21..25]
+ 'signal' => "\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00", # [26]
+ 'substr' => "\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00", # [27]
+ 'syntax' => "\x00\x00\x00\x00\x00\x00\x00\x55\x55\x15\x00\x00", # [28..38]
+ 'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00", # [39]
+ 'threads' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00", # [40]
+ 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00", # [41]
+ 'unopened' => "\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
+ 'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00", # [42]
+ 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00", # [43]
+ 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01", # [44]
+ 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04", # [45]
+ 'y2k' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10", # [46]
+ );
+
+our %DeadBits = (
+ 'all' => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\x2a", # [0..46]
+ 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00", # [29]
+ 'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00", # [30]
+ 'closed' => "\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
+ 'closure' => "\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
+ 'debugging' => "\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00", # [22]
+ 'deprecated' => "\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
+ 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00", # [31]
+ 'exec' => "\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
+ 'exiting' => "\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
+ 'glob' => "\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
+ 'inplace' => "\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00", # [23]
+ 'internal' => "\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00", # [24]
+ 'io' => "\x00\xa8\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..11]
+ 'layer' => "\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
+ 'malloc' => "\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00", # [25]
+ 'misc' => "\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
+ 'newline' => "\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
+ 'numeric' => "\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
+ 'once' => "\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
+ 'overflow' => "\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
+ 'pack' => "\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00", # [16]
+ 'parenthesis' => "\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00", # [32]
+ 'pipe' => "\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
+ 'portable' => "\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00", # [17]
+ 'precedence' => "\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00", # [33]
+ 'printf' => "\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00", # [34]
+ 'prototype' => "\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00", # [35]
+ 'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00", # [36]
+ 'recursion' => "\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00", # [18]
+ 'redefine' => "\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00", # [19]
+ 'regexp' => "\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00", # [20]
+ 'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00", # [37]
+ 'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00", # [38]
+ 'severe' => "\x00\x00\x00\x00\x00\xa8\x0a\x00\x00\x00\x00\x00", # [21..25]
+ 'signal' => "\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00", # [26]
+ 'substr' => "\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00", # [27]
+ 'syntax' => "\x00\x00\x00\x00\x00\x00\x00\xaa\xaa\x2a\x00\x00", # [28..38]
+ 'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00", # [39]
+ 'threads' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00", # [40]
+ 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00", # [41]
+ 'unopened' => "\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
+ 'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00", # [42]
+ 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00", # [43]
+ 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02", # [44]
+ 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08", # [45]
+ 'y2k' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20", # [46]
+ );
+
+$NONE = "\0\0\0\0\0\0\0\0\0\0\0\0";
+$LAST_BIT = 94 ;
+$BYTES = 12 ;
+
+$All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
+
+sub Croaker
+{
+ local $Carp::CarpInternal{'warnings'};
+ delete $Carp::CarpInternal{'warnings'};
+ Carp::croak(@_);
+}
+
+sub bits
+{
+ # called from B::Deparse.pm
+
+ push @_, 'all' unless @_;
+
+ my $mask;
+ my $catmask ;
+ my $fatal = 0 ;
+ my $no_fatal = 0 ;
+
+ foreach my $word ( @_ ) {
+ if ($word eq 'FATAL') {
+ $fatal = 1;
+ $no_fatal = 0;
+ }
+ elsif ($word eq 'NONFATAL') {
+ $fatal = 0;
+ $no_fatal = 1;
+ }
+ elsif ($catmask = $Bits{$word}) {
+ $mask |= $catmask ;
+ $mask |= $DeadBits{$word} if $fatal ;
+ $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
+ }
+ else
+ { Croaker("Unknown warnings category '$word'")}
+ }
+
+ return $mask ;
+}
+
+sub import
+{
+ shift;
+
+ my $catmask ;
+ my $fatal = 0 ;
+ my $no_fatal = 0 ;
+
+ my $mask = ${^WARNING_BITS} ;
+
+ if (vec($mask, $Offsets{'all'}, 1)) {
+ $mask |= $Bits{'all'} ;
+ $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
+ }
+
+ push @_, 'all' unless @_;
+
+ foreach my $word ( @_ ) {
+ if ($word eq 'FATAL') {
+ $fatal = 1;
+ $no_fatal = 0;
+ }
+ elsif ($word eq 'NONFATAL') {
+ $fatal = 0;
+ $no_fatal = 1;
+ }
+ elsif ($catmask = $Bits{$word}) {
+ $mask |= $catmask ;
+ $mask |= $DeadBits{$word} if $fatal ;
+ $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
+ }
+ else
+ { Croaker("Unknown warnings category '$word'")}
+ }
+
+ ${^WARNING_BITS} = $mask ;
+}
+
+sub unimport
+{
+ shift;
+
+ my $catmask ;
+ my $mask = ${^WARNING_BITS} ;
+
+ if (vec($mask, $Offsets{'all'}, 1)) {
+ $mask |= $Bits{'all'} ;
+ $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
+ }
+
+ push @_, 'all' unless @_;
+
+ foreach my $word ( @_ ) {
+ if ($word eq 'FATAL') {
+ next;
+ }
+ elsif ($catmask = $Bits{$word}) {
+ $mask &= ~($catmask | $DeadBits{$word} | $All);
+ }
+ else
+ { Croaker("Unknown warnings category '$word'")}
+ }
+
+ ${^WARNING_BITS} = $mask ;
+}
+
+my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = ();
+
+sub __chk
+{
+ my $category ;
+ my $offset ;
+ my $isobj = 0 ;
+
+ if (@_) {
+ # check the category supplied.
+ $category = shift ;
+ if (my $type = ref $category) {
+ Croaker("not an object")
+ if exists $builtin_type{$type};
+ $category = $type;
+ $isobj = 1 ;
+ }
+ $offset = $Offsets{$category};
+ Croaker("Unknown warnings category '$category'")
+ unless defined $offset;
+ }
+ else {
+ $category = (caller(1))[0] ;
+ $offset = $Offsets{$category};
+ Croaker("package '$category' not registered for warnings")
+ unless defined $offset ;
+ }
+
+ my $this_pkg = (caller(1))[0] ;
+ my $i = 2 ;
+ my $pkg ;
+
+ if ($isobj) {
+ while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
+ last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
+ }
+ $i -= 2 ;
+ }
+ else {
+ for ($i = 2 ; $pkg = (caller($i))[0] ; ++ $i) {
+ last if $pkg ne $this_pkg ;
+ }
+ $i = 2
+ if !$pkg || $pkg eq $this_pkg ;
+ }
+
+ my $callers_bitmask = (caller($i))[9] ;
+ return ($callers_bitmask, $offset, $i) ;
+}
+
+sub enabled
+{
+ Croaker("Usage: warnings::enabled([category])")
+ unless @_ == 1 || @_ == 0 ;
+
+ my ($callers_bitmask, $offset, $i) = __chk(@_) ;
+
+ return 0 unless defined $callers_bitmask ;
+ return vec($callers_bitmask, $offset, 1) ||
+ vec($callers_bitmask, $Offsets{'all'}, 1) ;
+}
+
+
+sub warn
+{
+ Croaker("Usage: warnings::warn([category,] 'message')")
+ unless @_ == 2 || @_ == 1 ;
+
+ my $message = pop ;
+ my ($callers_bitmask, $offset, $i) = __chk(@_) ;
+ Carp::croak($message)
+ if vec($callers_bitmask, $offset+1, 1) ||
+ vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
+ Carp::carp($message) ;
+}
+
+sub warnif
+{
+ Croaker("Usage: warnings::warnif([category,] 'message')")
+ unless @_ == 2 || @_ == 1 ;
+
+ my $message = pop ;
+ my ($callers_bitmask, $offset, $i) = __chk(@_) ;
+
+ return
+ unless defined $callers_bitmask &&
+ (vec($callers_bitmask, $offset, 1) ||
+ vec($callers_bitmask, $Offsets{'all'}, 1)) ;
+
+ Carp::croak($message)
+ if vec($callers_bitmask, $offset+1, 1) ||
+ vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
+
+ Carp::carp($message) ;
+}
+
+1;
+# ex: set ro:
diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/warnings/register.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/warnings/register.pm
new file mode 100644
index 00000000000..57c865df522
--- /dev/null
+++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/warnings/register.pm
@@ -0,0 +1,51 @@
+package warnings::register;
+
+our $VERSION = '1.01';
+
+=pod
+
+=head1 NAME
+
+warnings::register - warnings import function
+
+=head1 SYNOPSIS
+
+ use warnings::register;
+
+=head1 DESCRIPTION
+
+Creates a warnings category with the same name as the current package.
+
+See L<warnings> and L<perllexwarn> for more information on this module's
+usage.
+
+=cut
+
+require warnings;
+
+sub mkMask
+{
+ my ($bit) = @_;
+ my $mask = "";
+
+ vec($mask, $bit, 1) = 1;
+ return $mask;
+}
+
+sub import
+{
+ shift;
+ my $package = (caller(0))[0];
+ if (! defined $warnings::Bits{$package}) {
+ $warnings::Bits{$package} = mkMask($warnings::LAST_BIT);
+ vec($warnings::Bits{'all'}, $warnings::LAST_BIT, 1) = 1;
+ $warnings::Offsets{$package} = $warnings::LAST_BIT ++;
+ foreach my $k (keys %warnings::Bits) {
+ vec($warnings::Bits{$k}, $warnings::LAST_BIT, 1) = 0;
+ }
+ $warnings::DeadBits{$package} = mkMask($warnings::LAST_BIT);
+ vec($warnings::DeadBits{'all'}, $warnings::LAST_BIT++, 1) = 1;
+ }
+}
+
+1;