summaryrefslogtreecommitdiff
path: root/Master/tlpkg/installer
diff options
context:
space:
mode:
authorNorbert Preining <preining@logic.at>2008-02-08 10:43:34 +0000
committerNorbert Preining <preining@logic.at>2008-02-08 10:43:34 +0000
commit89d71dbbefd096388626ed8196aac192402653a0 (patch)
tree936b8863cd93f150432fa4cf5ac85830031e3993 /Master/tlpkg/installer
parentadacd50612f3170de7ba006c8aba8c844f994872 (diff)
move the perl installer lib also to tlpkg/installer
git-svn-id: svn://tug.org/texlive/trunk@6547 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/installer')
-rw-r--r--Master/tlpkg/installer/perllib/AutoLoader.pm343
-rw-r--r--Master/tlpkg/installer/perllib/Carp.pm274
-rw-r--r--Master/tlpkg/installer/perllib/Carp/Heavy.pm241
-rw-r--r--Master/tlpkg/installer/perllib/Config.pm95
-rw-r--r--Master/tlpkg/installer/perllib/Cwd.pm710
-rw-r--r--Master/tlpkg/installer/perllib/DynaLoader.pm833
-rw-r--r--Master/tlpkg/installer/perllib/Encode.pm851
-rw-r--r--Master/tlpkg/installer/perllib/Encode/Alias.pm341
-rw-r--r--Master/tlpkg/installer/perllib/Encode/Byte.pm119
-rw-r--r--Master/tlpkg/installer/perllib/Encode/Config.pm166
-rw-r--r--Master/tlpkg/installer/perllib/Encode/Encoding.pm341
-rw-r--r--Master/tlpkg/installer/perllib/Encode/Unicode.pm268
-rw-r--r--Master/tlpkg/installer/perllib/Exporter.pm440
-rw-r--r--Master/tlpkg/installer/perllib/Exporter/Heavy.pm248
-rw-r--r--Master/tlpkg/installer/perllib/Getopt/Long.pm2504
-rw-r--r--Master/tlpkg/installer/perllib/List/Util.pm277
-rw-r--r--Master/tlpkg/installer/perllib/Scalar/Util.pm147
-rw-r--r--Master/tlpkg/installer/perllib/Symbol.pm170
-rw-r--r--Master/tlpkg/installer/perllib/Tie/Hash.pm257
-rw-r--r--Master/tlpkg/installer/perllib/Tk.pm821
-rw-r--r--Master/tlpkg/installer/perllib/Tk/After.pm104
-rw-r--r--Master/tlpkg/installer/perllib/Tk/Button.pm148
-rw-r--r--Master/tlpkg/installer/perllib/Tk/Checkbutton.pm42
-rw-r--r--Master/tlpkg/installer/perllib/Tk/Clipboard.pm122
-rw-r--r--Master/tlpkg/installer/perllib/Tk/CmdLine.pm954
-rw-r--r--Master/tlpkg/installer/perllib/Tk/Configure.pm69
-rw-r--r--Master/tlpkg/installer/perllib/Tk/Derived.pm512
-rw-r--r--Master/tlpkg/installer/perllib/Tk/Dialog.pm70
-rw-r--r--Master/tlpkg/installer/perllib/Tk/DialogBox.pm135
-rw-r--r--Master/tlpkg/installer/perllib/Tk/DummyEncode.pm46
-rw-r--r--Master/tlpkg/installer/perllib/Tk/Entry.pm615
-rw-r--r--Master/tlpkg/installer/perllib/Tk/Event.pm13
-rw-r--r--Master/tlpkg/installer/perllib/Tk/Event/IO.pm132
-rw-r--r--Master/tlpkg/installer/perllib/Tk/Frame.pm378
-rw-r--r--Master/tlpkg/installer/perllib/Tk/Image.pm74
-rw-r--r--Master/tlpkg/installer/perllib/Tk/Label.pm21
-rw-r--r--Master/tlpkg/installer/perllib/Tk/MainWindow.pm213
-rw-r--r--Master/tlpkg/installer/perllib/Tk/PNG.pm43
-rw-r--r--Master/tlpkg/installer/perllib/Tk/Photo.pm22
-rw-r--r--Master/tlpkg/installer/perllib/Tk/Pretty.pm93
-rw-r--r--Master/tlpkg/installer/perllib/Tk/Radiobutton.pm45
-rw-r--r--Master/tlpkg/installer/perllib/Tk/Submethods.pm46
-rw-r--r--Master/tlpkg/installer/perllib/Tk/Toplevel.pm211
-rw-r--r--Master/tlpkg/installer/perllib/Tk/Widget.pm1510
-rw-r--r--Master/tlpkg/installer/perllib/Tk/Wm.pm174
-rw-r--r--Master/tlpkg/installer/perllib/Win32/API.pm745
-rw-r--r--Master/tlpkg/installer/perllib/Win32/API.pm.orig741
-rw-r--r--Master/tlpkg/installer/perllib/Win32/API/Callback.pm174
-rw-r--r--Master/tlpkg/installer/perllib/Win32/API/Struct.pm532
-rw-r--r--Master/tlpkg/installer/perllib/Win32/API/Test.pm120
-rw-r--r--Master/tlpkg/installer/perllib/Win32/API/Type.pm446
-rw-r--r--Master/tlpkg/installer/perllib/Win32/Env.pm169
-rw-r--r--Master/tlpkg/installer/perllib/Win32/Registry.pm547
-rw-r--r--Master/tlpkg/installer/perllib/Win32/TieRegistry.pm3801
-rw-r--r--Master/tlpkg/installer/perllib/Win32API/Registry.pm1792
-rw-r--r--Master/tlpkg/installer/perllib/Win32API/Registry/cRegistry.pc87
-rw-r--r--Master/tlpkg/installer/perllib/XSLoader.pm356
-rw-r--r--Master/tlpkg/installer/perllib/auto/Cwd/Cwd.bs0
-rwxr-xr-xMaster/tlpkg/installer/perllib/auto/Cwd/Cwd.dllbin0 -> 10240 bytes
-rw-r--r--Master/tlpkg/installer/perllib/auto/DynaLoader/autosplit.ix8
-rw-r--r--Master/tlpkg/installer/perllib/auto/DynaLoader/dl_expandspec.al34
-rw-r--r--Master/tlpkg/installer/perllib/auto/DynaLoader/dl_find_symbol_anywhere.al19
-rw-r--r--Master/tlpkg/installer/perllib/auto/DynaLoader/dl_findfile.al115
-rw-r--r--Master/tlpkg/installer/perllib/auto/Encode/Byte/Byte.bs0
-rwxr-xr-xMaster/tlpkg/installer/perllib/auto/Encode/Byte/Byte.dllbin0 -> 112640 bytes
-rw-r--r--Master/tlpkg/installer/perllib/auto/Encode/Encode.bs0
-rwxr-xr-xMaster/tlpkg/installer/perllib/auto/Encode/Encode.dllbin0 -> 30208 bytes
-rw-r--r--Master/tlpkg/installer/perllib/auto/Encode/Unicode/Unicode.bs0
-rwxr-xr-xMaster/tlpkg/installer/perllib/auto/Encode/Unicode/Unicode.dllbin0 -> 17920 bytes
-rw-r--r--Master/tlpkg/installer/perllib/auto/Tk/CancelRepeat.al15
-rw-r--r--Master/tlpkg/installer/perllib/auto/Tk/Clipboard/autosplit.ix6
-rw-r--r--Master/tlpkg/installer/perllib/auto/Tk/Clipboard/getSelected.al15
-rw-r--r--Master/tlpkg/installer/perllib/auto/Tk/Entry/Entry.bs0
-rwxr-xr-xMaster/tlpkg/installer/perllib/auto/Tk/Entry/Entry.dllbin0 -> 41472 bytes
-rw-r--r--Master/tlpkg/installer/perllib/auto/Tk/Error.al20
-rw-r--r--Master/tlpkg/installer/perllib/auto/Tk/Event/Event.bs0
-rwxr-xr-xMaster/tlpkg/installer/perllib/auto/Tk/Event/Event.dllbin0 -> 56832 bytes
-rw-r--r--Master/tlpkg/installer/perllib/auto/Tk/Frame/autosplit.ix24
-rw-r--r--Master/tlpkg/installer/perllib/auto/Tk/PNG/PNG.bs0
-rwxr-xr-xMaster/tlpkg/installer/perllib/auto/Tk/PNG/PNG.dllbin0 -> 168960 bytes
-rw-r--r--Master/tlpkg/installer/perllib/auto/Tk/RepeatId.al16
-rw-r--r--Master/tlpkg/installer/perllib/auto/Tk/Tk.bs0
-rwxr-xr-xMaster/tlpkg/installer/perllib/auto/Tk/Tk.dllbin0 -> 804864 bytes
-rw-r--r--Master/tlpkg/installer/perllib/auto/Tk/Toplevel/autosplit.ix10
-rw-r--r--Master/tlpkg/installer/perllib/auto/Tk/Widget/autosplit.ix11
-rw-r--r--Master/tlpkg/installer/perllib/auto/Tk/Wm/AnchorAdjust.al17
-rw-r--r--Master/tlpkg/installer/perllib/auto/Tk/Wm/FullScreen.al29
-rw-r--r--Master/tlpkg/installer/perllib/auto/Tk/Wm/Popup.al50
-rw-r--r--Master/tlpkg/installer/perllib/auto/Tk/Wm/Post.al20
-rw-r--r--Master/tlpkg/installer/perllib/auto/Tk/Wm/autosplit.ix14
-rw-r--r--Master/tlpkg/installer/perllib/auto/Tk/Wm/iconposition.al24
-rw-r--r--Master/tlpkg/installer/perllib/auto/Tk/autosplit.ix45
-rw-r--r--Master/tlpkg/installer/perllib/auto/Tk/getEncoding.al43
-rw-r--r--Master/tlpkg/installer/perllib/auto/Win32/API/API.bs0
-rw-r--r--Master/tlpkg/installer/perllib/auto/Win32/API/API.dllbin0 -> 20480 bytes
-rw-r--r--Master/tlpkg/installer/perllib/auto/Win32/API/Callback/Callback.bs0
-rw-r--r--Master/tlpkg/installer/perllib/auto/Win32/API/Callback/Callback.dllbin0 -> 16384 bytes
-rw-r--r--Master/tlpkg/installer/perllib/auto/Win32API/Registry/Registry.bs0
-rwxr-xr-xMaster/tlpkg/installer/perllib/auto/Win32API/Registry/Registry.dllbin0 -> 181760 bytes
-rw-r--r--Master/tlpkg/installer/perllib/base.pm226
-rw-r--r--Master/tlpkg/installer/perllib/bytes.pm88
-rw-r--r--Master/tlpkg/installer/perllib/constant.pm340
-rw-r--r--Master/tlpkg/installer/perllib/newgetopt.pl75
-rw-r--r--Master/tlpkg/installer/perllib/overload.pm1434
-rw-r--r--Master/tlpkg/installer/perllib/strict.pm136
-rw-r--r--Master/tlpkg/installer/perllib/unicore/Canonical.pl1042
-rw-r--r--Master/tlpkg/installer/perllib/unicore/Exact.pl73
-rw-r--r--Master/tlpkg/installer/perllib/unicore/PVA.pl2044
-rw-r--r--Master/tlpkg/installer/perllib/unicore/To/Lower.pl905
-rw-r--r--Master/tlpkg/installer/perllib/unicore/lib/gc_sc/Uppercas.pl490
-rw-r--r--Master/tlpkg/installer/perllib/utf8.pm214
-rw-r--r--Master/tlpkg/installer/perllib/utf8_heavy.pl412
-rw-r--r--Master/tlpkg/installer/perllib/vars.pm82
-rw-r--r--Master/tlpkg/installer/perllib/warnings.pm497
-rw-r--r--Master/tlpkg/installer/perllib/warnings/register.pm51
115 files changed, 33392 insertions, 0 deletions
diff --git a/Master/tlpkg/installer/perllib/AutoLoader.pm b/Master/tlpkg/installer/perllib/AutoLoader.pm
new file mode 100644
index 00000000000..4352d8b1fbe
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/AutoLoader.pm
@@ -0,0 +1,343 @@
+package AutoLoader;
+
+use strict;
+use 5.006_001;
+
+our($VERSION, $AUTOLOAD);
+
+my $is_dosish;
+my $is_epoc;
+my $is_vms;
+my $is_macos;
+
+BEGIN {
+ $is_dosish = $^O eq 'dos' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'NetWare';
+ $is_epoc = $^O eq 'epoc';
+ $is_vms = $^O eq 'VMS';
+ $is_macos = $^O eq 'MacOS';
+ $VERSION = '5.60';
+}
+
+AUTOLOAD {
+ my $sub = $AUTOLOAD;
+ my $filename;
+ # Braces used to preserve $1 et al.
+ {
+ # Try to find the autoloaded file from the package-qualified
+ # name of the sub. e.g., if the sub needed is
+ # Getopt::Long::GetOptions(), then $INC{Getopt/Long.pm} is
+ # something like '/usr/lib/perl5/Getopt/Long.pm', and the
+ # autoload file is '/usr/lib/perl5/auto/Getopt/Long/GetOptions.al'.
+ #
+ # However, if @INC is a relative path, this might not work. If,
+ # for example, @INC = ('lib'), then $INC{Getopt/Long.pm} is
+ # 'lib/Getopt/Long.pm', and we want to require
+ # 'auto/Getopt/Long/GetOptions.al' (without the leading 'lib').
+ # In this case, we simple prepend the 'auto/' and let the
+ # C<require> take care of the searching for us.
+
+ my ($pkg,$func) = ($sub =~ /(.*)::([^:]+)$/);
+ $pkg =~ s#::#/#g;
+ if (defined($filename = $INC{"$pkg.pm"})) {
+ if ($is_macos) {
+ $pkg =~ tr#/#:#;
+ $filename =~ s#^(.*)$pkg\.pm\z#$1auto:$pkg:$func.al#s;
+ } else {
+ $filename =~ s#^(.*)$pkg\.pm\z#$1auto/$pkg/$func.al#s;
+ }
+
+ # if the file exists, then make sure that it is a
+ # a fully anchored path (i.e either '/usr/lib/auto/foo/bar.al',
+ # or './lib/auto/foo/bar.al'. This avoids C<require> searching
+ # (and failing) to find the 'lib/auto/foo/bar.al' because it
+ # looked for 'lib/lib/auto/foo/bar.al', given @INC = ('lib').
+
+ if (-r $filename) {
+ unless ($filename =~ m|^/|s) {
+ if ($is_dosish) {
+ unless ($filename =~ m{^([a-z]:)?[\\/]}is) {
+ if ($^O ne 'NetWare') {
+ $filename = "./$filename";
+ } else {
+ $filename = "$filename";
+ }
+ }
+ }
+ elsif ($is_epoc) {
+ unless ($filename =~ m{^([a-z?]:)?[\\/]}is) {
+ $filename = "./$filename";
+ }
+ }
+ elsif ($is_vms) {
+ # XXX todo by VMSmiths
+ $filename = "./$filename";
+ }
+ elsif (!$is_macos) {
+ $filename = "./$filename";
+ }
+ }
+ }
+ else {
+ $filename = undef;
+ }
+ }
+ unless (defined $filename) {
+ # let C<require> do the searching
+ $filename = "auto/$sub.al";
+ $filename =~ s#::#/#g;
+ }
+ }
+ my $save = $@;
+ local $!; # Do not munge the value.
+ eval { local $SIG{__DIE__}; require $filename };
+ if ($@) {
+ if (substr($sub,-9) eq '::DESTROY') {
+ no strict 'refs';
+ *$sub = sub {};
+ $@ = undef;
+ } elsif ($@ =~ /^Can't locate/) {
+ # The load might just have failed because the filename was too
+ # long for some old SVR3 systems which treat long names as errors.
+ # If we can successfully truncate a long name then it's worth a go.
+ # There is a slight risk that we could pick up the wrong file here
+ # but autosplit should have warned about that when splitting.
+ if ($filename =~ s/(\w{12,})\.al$/substr($1,0,11).".al"/e){
+ eval { local $SIG{__DIE__}; require $filename };
+ }
+ }
+ if ($@){
+ $@ =~ s/ at .*\n//;
+ my $error = $@;
+ require Carp;
+ Carp::croak($error);
+ }
+ }
+ $@ = $save;
+ goto &$sub;
+}
+
+sub import {
+ my $pkg = shift;
+ my $callpkg = caller;
+
+ #
+ # Export symbols, but not by accident of inheritance.
+ #
+
+ if ($pkg eq 'AutoLoader') {
+ no strict 'refs';
+ *{ $callpkg . '::AUTOLOAD' } = \&AUTOLOAD
+ if @_ and $_[0] =~ /^&?AUTOLOAD$/;
+ }
+
+ #
+ # Try to find the autosplit index file. Eg., if the call package
+ # is POSIX, then $INC{POSIX.pm} is something like
+ # '/usr/local/lib/perl5/POSIX.pm', and the autosplit index file is in
+ # '/usr/local/lib/perl5/auto/POSIX/autosplit.ix', so we require that.
+ #
+ # However, if @INC is a relative path, this might not work. If,
+ # for example, @INC = ('lib'), then
+ # $INC{POSIX.pm} is 'lib/POSIX.pm', and we want to require
+ # 'auto/POSIX/autosplit.ix' (without the leading 'lib').
+ #
+
+ (my $calldir = $callpkg) =~ s#::#/#g;
+ my $path = $INC{$calldir . '.pm'};
+ if (defined($path)) {
+ # Try absolute path name.
+ if ($is_macos) {
+ (my $malldir = $calldir) =~ tr#/#:#;
+ $path =~ s#^(.*)$malldir\.pm\z#$1auto:$malldir:autosplit.ix#s;
+ } else {
+ $path =~ s#^(.*)$calldir\.pm\z#$1auto/$calldir/autosplit.ix#;
+ }
+
+ eval { require $path; };
+ # If that failed, try relative path with normal @INC searching.
+ if ($@) {
+ $path ="auto/$calldir/autosplit.ix";
+ eval { require $path; };
+ }
+ if ($@) {
+ my $error = $@;
+ require Carp;
+ Carp::carp($error);
+ }
+ }
+}
+
+sub unimport {
+ my $callpkg = caller;
+
+ no strict 'refs';
+ my $symname = $callpkg . '::AUTOLOAD';
+ undef *{ $symname } if \&{ $symname } == \&AUTOLOAD;
+ *{ $symname } = \&{ $symname };
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+AutoLoader - load subroutines only on demand
+
+=head1 SYNOPSIS
+
+ package Foo;
+ use AutoLoader 'AUTOLOAD'; # import the default AUTOLOAD subroutine
+
+ package Bar;
+ use AutoLoader; # don't import AUTOLOAD, define our own
+ sub AUTOLOAD {
+ ...
+ $AutoLoader::AUTOLOAD = "...";
+ goto &AutoLoader::AUTOLOAD;
+ }
+
+=head1 DESCRIPTION
+
+The B<AutoLoader> module works with the B<AutoSplit> module and the
+C<__END__> token to defer the loading of some subroutines until they are
+used rather than loading them all at once.
+
+To use B<AutoLoader>, the author of a module has to place the
+definitions of subroutines to be autoloaded after an C<__END__> token.
+(See L<perldata>.) The B<AutoSplit> module can then be run manually to
+extract the definitions into individual files F<auto/funcname.al>.
+
+B<AutoLoader> implements an AUTOLOAD subroutine. When an undefined
+subroutine in is called in a client module of B<AutoLoader>,
+B<AutoLoader>'s AUTOLOAD subroutine attempts to locate the subroutine in a
+file with a name related to the location of the file from which the
+client module was read. As an example, if F<POSIX.pm> is located in
+F</usr/local/lib/perl5/POSIX.pm>, B<AutoLoader> will look for perl
+subroutines B<POSIX> in F</usr/local/lib/perl5/auto/POSIX/*.al>, where
+the C<.al> file has the same name as the subroutine, sans package. If
+such a file exists, AUTOLOAD will read and evaluate it,
+thus (presumably) defining the needed subroutine. AUTOLOAD will then
+C<goto> the newly defined subroutine.
+
+Once this process completes for a given function, it is defined, so
+future calls to the subroutine will bypass the AUTOLOAD mechanism.
+
+=head2 Subroutine Stubs
+
+In order for object method lookup and/or prototype checking to operate
+correctly even when methods have not yet been defined it is necessary to
+"forward declare" each subroutine (as in C<sub NAME;>). See
+L<perlsub/"SYNOPSIS">. Such forward declaration creates "subroutine
+stubs", which are place holders with no code.
+
+The AutoSplit and B<AutoLoader> modules automate the creation of forward
+declarations. The AutoSplit module creates an 'index' file containing
+forward declarations of all the AutoSplit subroutines. When the
+AutoLoader module is 'use'd it loads these declarations into its callers
+package.
+
+Because of this mechanism it is important that B<AutoLoader> is always
+C<use>d and not C<require>d.
+
+=head2 Using B<AutoLoader>'s AUTOLOAD Subroutine
+
+In order to use B<AutoLoader>'s AUTOLOAD subroutine you I<must>
+explicitly import it:
+
+ use AutoLoader 'AUTOLOAD';
+
+=head2 Overriding B<AutoLoader>'s AUTOLOAD Subroutine
+
+Some modules, mainly extensions, provide their own AUTOLOAD subroutines.
+They typically need to check for some special cases (such as constants)
+and then fallback to B<AutoLoader>'s AUTOLOAD for the rest.
+
+Such modules should I<not> import B<AutoLoader>'s AUTOLOAD subroutine.
+Instead, they should define their own AUTOLOAD subroutines along these
+lines:
+
+ use AutoLoader;
+ use Carp;
+
+ sub AUTOLOAD {
+ my $sub = $AUTOLOAD;
+ (my $constname = $sub) =~ s/.*:://;
+ my $val = constant($constname, @_ ? $_[0] : 0);
+ if ($! != 0) {
+ if ($! =~ /Invalid/ || $!{EINVAL}) {
+ $AutoLoader::AUTOLOAD = $sub;
+ goto &AutoLoader::AUTOLOAD;
+ }
+ else {
+ croak "Your vendor has not defined constant $constname";
+ }
+ }
+ *$sub = sub { $val }; # same as: eval "sub $sub { $val }";
+ goto &$sub;
+ }
+
+If any module's own AUTOLOAD subroutine has no need to fallback to the
+AutoLoader's AUTOLOAD subroutine (because it doesn't have any AutoSplit
+subroutines), then that module should not use B<AutoLoader> at all.
+
+=head2 Package Lexicals
+
+Package lexicals declared with C<my> in the main block of a package
+using B<AutoLoader> will not be visible to auto-loaded subroutines, due to
+the fact that the given scope ends at the C<__END__> marker. A module
+using such variables as package globals will not work properly under the
+B<AutoLoader>.
+
+The C<vars> pragma (see L<perlmod/"vars">) may be used in such
+situations as an alternative to explicitly qualifying all globals with
+the package namespace. Variables pre-declared with this pragma will be
+visible to any autoloaded routines (but will not be invisible outside
+the package, unfortunately).
+
+=head2 Not Using AutoLoader
+
+You can stop using AutoLoader by simply
+
+ no AutoLoader;
+
+=head2 B<AutoLoader> vs. B<SelfLoader>
+
+The B<AutoLoader> is similar in purpose to B<SelfLoader>: both delay the
+loading of subroutines.
+
+B<SelfLoader> uses the C<__DATA__> marker rather than C<__END__>.
+While this avoids the use of a hierarchy of disk files and the
+associated open/close for each routine loaded, B<SelfLoader> suffers a
+startup speed disadvantage in the one-time parsing of the lines after
+C<__DATA__>, after which routines are cached. B<SelfLoader> can also
+handle multiple packages in a file.
+
+B<AutoLoader> only reads code as it is requested, and in many cases
+should be faster, but requires a mechanism like B<AutoSplit> be used to
+create the individual files. L<ExtUtils::MakeMaker> will invoke
+B<AutoSplit> automatically if B<AutoLoader> is used in a module source
+file.
+
+=head1 CAVEATS
+
+AutoLoaders prior to Perl 5.002 had a slightly different interface. Any
+old modules which use B<AutoLoader> should be changed to the new calling
+style. Typically this just means changing a require to a use, adding
+the explicit C<'AUTOLOAD'> import if needed, and removing B<AutoLoader>
+from C<@ISA>.
+
+On systems with restrictions on file name length, the file corresponding
+to a subroutine may have a shorter name that the routine itself. This
+can lead to conflicting file names. The I<AutoSplit> package warns of
+these potential conflicts when used to split a module.
+
+AutoLoader may fail to find the autosplit files (or even find the wrong
+ones) in cases where C<@INC> contains relative paths, B<and> the program
+does C<chdir>.
+
+=head1 SEE ALSO
+
+L<SelfLoader> - an autoloader that doesn't use external files.
+
+=cut
diff --git a/Master/tlpkg/installer/perllib/Carp.pm b/Master/tlpkg/installer/perllib/Carp.pm
new file mode 100644
index 00000000000..1a814ead34f
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/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/installer/perllib/Carp/Heavy.pm b/Master/tlpkg/installer/perllib/Carp/Heavy.pm
new file mode 100644
index 00000000000..55bca2b421a
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/Carp/Heavy.pm
@@ -0,0 +1,241 @@
+# Carp::Heavy uses some variables in common with Carp.
+package Carp;
+
+=head1 NAME
+
+Carp::Heavy - heavy machinery, no user serviceable parts inside
+
+=cut
+
+# use strict; # not yet
+
+# On one line so MakeMaker will see it.
+use Carp; our $VERSION = $Carp::VERSION;
+
+our ($CarpLevel, $MaxArgNums, $MaxEvalLen, $MaxArgLen, $Verbose);
+
+sub caller_info {
+ my $i = shift(@_) + 1;
+ package DB;
+ my %call_info;
+ @call_info{
+ qw(pack file line sub has_args wantarray evaltext is_require)
+ } = caller($i);
+
+ unless (defined $call_info{pack}) {
+ return ();
+ }
+
+ my $sub_name = Carp::get_subname(\%call_info);
+ if ($call_info{has_args}) {
+ my @args = map {Carp::format_arg($_)} @DB::args;
+ if ($MaxArgNums and @args > $MaxArgNums) { # More than we want to show?
+ $#args = $MaxArgNums;
+ push @args, '...';
+ }
+ # Push the args onto the subroutine
+ $sub_name .= '(' . join (', ', @args) . ')';
+ }
+ $call_info{sub_name} = $sub_name;
+ return wantarray() ? %call_info : \%call_info;
+}
+
+# Transform an argument to a function into a string.
+sub format_arg {
+ my $arg = shift;
+ if (ref($arg)) {
+ $arg = defined($overload::VERSION) ? overload::StrVal($arg) : "$arg";
+ }elsif (not defined($arg)) {
+ $arg = 'undef';
+ }
+ $arg =~ s/'/\\'/g;
+ $arg = str_len_trim($arg, $MaxArgLen);
+
+ # Quote it?
+ $arg = "'$arg'" unless $arg =~ /^-?[\d.]+\z/;
+
+ # The following handling of "control chars" is direct from
+ # the original code - it is broken on Unicode though.
+ # Suggestions?
+ utf8::is_utf8($arg)
+ or $arg =~ s/([[:cntrl:]]|[[:^ascii:]])/sprintf("\\x{%x}",ord($1))/eg;
+ return $arg;
+}
+
+# Takes an inheritance cache and a package and returns
+# an anon hash of known inheritances and anon array of
+# inheritances which consequences have not been figured
+# for.
+sub get_status {
+ my $cache = shift;
+ my $pkg = shift;
+ $cache->{$pkg} ||= [{$pkg => $pkg}, [trusts_directly($pkg)]];
+ return @{$cache->{$pkg}};
+}
+
+# Takes the info from caller() and figures out the name of
+# the sub/require/eval
+sub get_subname {
+ my $info = shift;
+ if (defined($info->{evaltext})) {
+ my $eval = $info->{evaltext};
+ if ($info->{is_require}) {
+ return "require $eval";
+ }
+ else {
+ $eval =~ s/([\\\'])/\\$1/g;
+ return "eval '" . str_len_trim($eval, $MaxEvalLen) . "'";
+ }
+ }
+
+ return ($info->{sub} eq '(eval)') ? 'eval {...}' : $info->{sub};
+}
+
+# Figures out what call (from the point of view of the caller)
+# the long error backtrace should start at.
+sub long_error_loc {
+ my $i;
+ my $lvl = $CarpLevel;
+ {
+ my $pkg = caller(++$i);
+ unless(defined($pkg)) {
+ # This *shouldn't* happen.
+ if (%Internal) {
+ local %Internal;
+ $i = long_error_loc();
+ last;
+ }
+ else {
+ # OK, now I am irritated.
+ return 2;
+ }
+ }
+ redo if $CarpInternal{$pkg};
+ redo unless 0 > --$lvl;
+ redo if $Internal{$pkg};
+ }
+ return $i - 1;
+}
+
+
+sub longmess_heavy {
+ return @_ if ref($_[0]); # don't break references as exceptions
+ my $i = long_error_loc();
+ return ret_backtrace($i, @_);
+}
+
+# Returns a full stack backtrace starting from where it is
+# told.
+sub ret_backtrace {
+ my ($i, @error) = @_;
+ my $mess;
+ my $err = join '', @error;
+ $i++;
+
+ my $tid_msg = '';
+ if (defined &Thread::tid) {
+ my $tid = Thread->self->tid;
+ $tid_msg = " thread $tid" if $tid;
+ }
+
+ my %i = caller_info($i);
+ $mess = "$err at $i{file} line $i{line}$tid_msg\n";
+
+ while (my %i = caller_info(++$i)) {
+ $mess .= "\t$i{sub_name} called at $i{file} line $i{line}$tid_msg\n";
+ }
+
+ return $mess;
+}
+
+sub ret_summary {
+ my ($i, @error) = @_;
+ my $err = join '', @error;
+ $i++;
+
+ my $tid_msg = '';
+ if (defined &Thread::tid) {
+ my $tid = Thread->self->tid;
+ $tid_msg = " thread $tid" if $tid;
+ }
+
+ my %i = caller_info($i);
+ return "$err at $i{file} line $i{line}$tid_msg\n";
+}
+
+
+sub short_error_loc {
+ my $cache;
+ my $i = 1;
+ my $lvl = $CarpLevel;
+ {
+ my $called = caller($i++);
+ my $caller = caller($i);
+ return 0 unless defined($caller); # What happened?
+ redo if $Internal{$caller};
+ redo if $CarpInternal{$called};
+ redo if trusts($called, $caller, $cache);
+ redo if trusts($caller, $called, $cache);
+ redo unless 0 > --$lvl;
+ }
+ return $i - 1;
+}
+
+sub shortmess_heavy {
+ return longmess_heavy(@_) if $Verbose;
+ return @_ if ref($_[0]); # don't break references as exceptions
+ my $i = short_error_loc();
+ if ($i) {
+ ret_summary($i, @_);
+ }
+ else {
+ longmess_heavy(@_);
+ }
+}
+
+# If a string is too long, trims it with ...
+sub str_len_trim {
+ my $str = shift;
+ my $max = shift || 0;
+ if (2 < $max and $max < length($str)) {
+ substr($str, $max - 3) = '...';
+ }
+ return $str;
+}
+
+# Takes two packages and an optional cache. Says whether the
+# first inherits from the second.
+#
+# Recursive versions of this have to work to avoid certain
+# possible endless loops, and when following long chains of
+# inheritance are less efficient.
+sub trusts {
+ my $child = shift;
+ my $parent = shift;
+ my $cache = shift || {};
+ my ($known, $partial) = get_status($cache, $child);
+ # Figure out consequences until we have an answer
+ while (@$partial and not exists $known->{$parent}) {
+ my $anc = shift @$partial;
+ next if exists $known->{$anc};
+ $known->{$anc}++;
+ my ($anc_knows, $anc_partial) = get_status($cache, $anc);
+ my @found = keys %$anc_knows;
+ @$known{@found} = ();
+ push @$partial, @$anc_partial;
+ }
+ return exists $known->{$parent};
+}
+
+# Takes a package and gives a list of those trusted directly
+sub trusts_directly {
+ my $class = shift;
+ no strict 'refs';
+ no warnings 'once';
+ return @{"$class\::CARP_NOT"}
+ ? @{"$class\::CARP_NOT"}
+ : @{"$class\::ISA"};
+}
+
+1;
+
diff --git a/Master/tlpkg/installer/perllib/Config.pm b/Master/tlpkg/installer/perllib/Config.pm
new file mode 100644
index 00000000000..7e5ad77b30a
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/Config.pm
@@ -0,0 +1,95 @@
+# This file was created by configpm when Perl was built. Any changes
+# made to this file will be lost the next time perl is built.
+
+package Config;
+use strict;
+# use warnings; Pulls in Carp
+# use vars pulls in Carp
+@Config::EXPORT = qw(%Config);
+@Config::EXPORT_OK = qw(myconfig config_sh config_vars config_re);
+
+# Need to stub all the functions to make code such as print Config::config_sh
+# keep working
+
+sub myconfig;
+sub config_sh;
+sub config_vars;
+sub config_re;
+
+my %Export_Cache = map {($_ => 1)} (@Config::EXPORT, @Config::EXPORT_OK);
+
+our %Config;
+
+# Define our own import method to avoid pulling in the full Exporter:
+sub import {
+ my $pkg = shift;
+ @_ = @Config::EXPORT unless @_;
+
+ my @funcs = grep $_ ne '%Config', @_;
+ my $export_Config = @funcs < @_ ? 1 : 0;
+
+ no strict 'refs';
+ my $callpkg = caller(0);
+ foreach my $func (@funcs) {
+ die sprintf qq{"%s" is not exported by the %s module\n},
+ $func, __PACKAGE__ unless $Export_Cache{$func};
+ *{$callpkg.'::'.$func} = \&{$func};
+ }
+
+ *{"$callpkg\::Config"} = \%Config if $export_Config;
+ return;
+}
+
+die "Perl lib version (v5.8.8) doesn't match executable version ($])"
+ unless $^V;
+
+$^V eq v5.8.8
+ or die "Perl lib version (v5.8.8) doesn't match executable version (" .
+ sprintf("v%vd",$^V) . ")";
+
+
+sub FETCH {
+ my($self, $key) = @_;
+
+ # check for cached value (which may be undef so we use exists not defined)
+ return $self->{$key} if exists $self->{$key};
+
+ return $self->fetch_string($key);
+}
+sub TIEHASH {
+ bless $_[1], $_[0];
+}
+
+sub DESTROY { }
+
+sub AUTOLOAD {
+ require 'Config_heavy.pl';
+ goto \&launcher unless $Config::AUTOLOAD =~ /launcher$/;
+ die "&Config::AUTOLOAD failed on $Config::AUTOLOAD";
+}
+
+# tie returns the object, so the value returned to require will be true.
+tie %Config, 'Config', {
+ archlibexp => 'x:\\perl\\lib',
+ archname => 'MSWin32-x86-multi-thread',
+ cc => 'gcc',
+ d_readlink => undef,
+ d_symlink => undef,
+ dlsrc => 'dl_win32.xs',
+ dont_use_nlink => undef,
+ exe_ext => '.exe',
+ inc_version_list => '',
+ intsize => '4',
+ ldlibpthname => '',
+ libpth => 'x:\\msys\\mingw\\lib',
+ osname => 'MSWin32',
+ osvers => '5.1',
+ path_sep => ';',
+ privlibexp => 'x:\\perl\\lib',
+ scriptdir => 'x:\\perl\\bin',
+ sitearchexp => 'x:\\perl\\site\\lib',
+ sitelibexp => 'x:\\perl\\site\\lib',
+ useithreads => 'define',
+ usevendorprefix => undef,
+ version => '5.8.8',
+};
diff --git a/Master/tlpkg/installer/perllib/Cwd.pm b/Master/tlpkg/installer/perllib/Cwd.pm
new file mode 100644
index 00000000000..8d25af9f7cd
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/Cwd.pm
@@ -0,0 +1,710 @@
+package Cwd;
+
+=head1 NAME
+
+Cwd - get pathname of current working directory
+
+=head1 SYNOPSIS
+
+ use Cwd;
+ my $dir = getcwd;
+
+ use Cwd 'abs_path';
+ my $abs_path = abs_path($file);
+
+=head1 DESCRIPTION
+
+This module provides functions for determining the pathname of the
+current working directory. It is recommended that getcwd (or another
+*cwd() function) be used in I<all> code to ensure portability.
+
+By default, it exports the functions cwd(), getcwd(), fastcwd(), and
+fastgetcwd() (and, on Win32, getdcwd()) into the caller's namespace.
+
+
+=head2 getcwd and friends
+
+Each of these functions are called without arguments and return the
+absolute path of the current working directory.
+
+=over 4
+
+=item getcwd
+
+ my $cwd = getcwd();
+
+Returns the current working directory.
+
+Re-implements the getcwd(3) (or getwd(3)) functions in Perl.
+
+=item cwd
+
+ my $cwd = cwd();
+
+The cwd() is the most natural form for the current architecture. For
+most systems it is identical to `pwd` (but without the trailing line
+terminator).
+
+=item fastcwd
+
+ my $cwd = fastcwd();
+
+A more dangerous version of getcwd(), but potentially faster.
+
+It might conceivably chdir() you out of a directory that it can't
+chdir() you back into. If fastcwd encounters a problem it will return
+undef but will probably leave you in a different directory. For a
+measure of extra security, if everything appears to have worked, the
+fastcwd() function will check that it leaves you in the same directory
+that it started in. If it has changed it will C<die> with the message
+"Unstable directory path, current directory changed
+unexpectedly". That should never happen.
+
+=item fastgetcwd
+
+ my $cwd = fastgetcwd();
+
+The fastgetcwd() function is provided as a synonym for cwd().
+
+=item getdcwd
+
+ my $cwd = getdcwd();
+ my $cwd = getdcwd('C:');
+
+The getdcwd() function is also provided on Win32 to get the current working
+directory on the specified drive, since Windows maintains a separate current
+working directory for each drive. If no drive is specified then the current
+drive is assumed.
+
+This function simply calls the Microsoft C library _getdcwd() function.
+
+=back
+
+
+=head2 abs_path and friends
+
+These functions are exported only on request. They each take a single
+argument and return the absolute pathname for it. If no argument is
+given they'll use the current working directory.
+
+=over 4
+
+=item abs_path
+
+ my $abs_path = abs_path($file);
+
+Uses the same algorithm as getcwd(). Symbolic links and relative-path
+components ("." and "..") are resolved to return the canonical
+pathname, just like realpath(3).
+
+=item realpath
+
+ my $abs_path = realpath($file);
+
+A synonym for abs_path().
+
+=item fast_abs_path
+
+ my $abs_path = fast_abs_path($file);
+
+A more dangerous, but potentially faster version of abs_path.
+
+=back
+
+=head2 $ENV{PWD}
+
+If you ask to override your chdir() built-in function,
+
+ use Cwd qw(chdir);
+
+then your PWD environment variable will be kept up to date. Note that
+it will only be kept up to date if all packages which use chdir import
+it from Cwd.
+
+
+=head1 NOTES
+
+=over 4
+
+=item *
+
+Since the path seperators are different on some operating systems ('/'
+on Unix, ':' on MacPerl, etc...) we recommend you use the File::Spec
+modules wherever portability is a concern.
+
+=item *
+
+Actually, on Mac OS, the C<getcwd()>, C<fastgetcwd()> and C<fastcwd()>
+functions are all aliases for the C<cwd()> function, which, on Mac OS,
+calls `pwd`. Likewise, the C<abs_path()> function is an alias for
+C<fast_abs_path()>.
+
+=back
+
+=head1 AUTHOR
+
+Originally by the perl5-porters.
+
+Maintained by Ken Williams <KWILLIAMS@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2004 by the Perl 5 Porters. All rights reserved.
+
+This program is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+Portions of the C code in this library are copyright (c) 1994 by the
+Regents of the University of California. All rights reserved. The
+license on this code is compatible with the licensing of the rest of
+the distribution - please see the source code in F<Cwd.xs> for the
+details.
+
+=head1 SEE ALSO
+
+L<File::chdir>
+
+=cut
+
+use strict;
+use Exporter;
+use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION);
+
+$VERSION = '3.12';
+
+@ISA = qw/ Exporter /;
+@EXPORT = qw(cwd getcwd fastcwd fastgetcwd);
+push @EXPORT, qw(getdcwd) if $^O eq 'MSWin32';
+@EXPORT_OK = qw(chdir abs_path fast_abs_path realpath fast_realpath);
+
+# sys_cwd may keep the builtin command
+
+# All the functionality of this module may provided by builtins,
+# there is no sense to process the rest of the file.
+# The best choice may be to have this in BEGIN, but how to return from BEGIN?
+
+if ($^O eq 'os2') {
+ local $^W = 0;
+
+ *cwd = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd;
+ *getcwd = \&cwd;
+ *fastgetcwd = \&cwd;
+ *fastcwd = \&cwd;
+
+ *fast_abs_path = \&sys_abspath if defined &sys_abspath;
+ *abs_path = \&fast_abs_path;
+ *realpath = \&fast_abs_path;
+ *fast_realpath = \&fast_abs_path;
+
+ return 1;
+}
+
+# If loading the XS stuff doesn't work, we can fall back to pure perl
+eval {
+ if ( $] >= 5.006 ) {
+ require XSLoader;
+ XSLoader::load( __PACKAGE__, $VERSION );
+ } else {
+ require DynaLoader;
+ push @ISA, 'DynaLoader';
+ __PACKAGE__->bootstrap( $VERSION );
+ }
+};
+
+# Must be after the DynaLoader stuff:
+$VERSION = eval $VERSION;
+
+# Big nasty table of function aliases
+my %METHOD_MAP =
+ (
+ VMS =>
+ {
+ cwd => '_vms_cwd',
+ getcwd => '_vms_cwd',
+ fastcwd => '_vms_cwd',
+ fastgetcwd => '_vms_cwd',
+ abs_path => '_vms_abs_path',
+ fast_abs_path => '_vms_abs_path',
+ },
+
+ MSWin32 =>
+ {
+ # We assume that &_NT_cwd is defined as an XSUB or in the core.
+ cwd => '_NT_cwd',
+ getcwd => '_NT_cwd',
+ fastcwd => '_NT_cwd',
+ fastgetcwd => '_NT_cwd',
+ abs_path => 'fast_abs_path',
+ realpath => 'fast_abs_path',
+ },
+
+ dos =>
+ {
+ cwd => '_dos_cwd',
+ getcwd => '_dos_cwd',
+ fastgetcwd => '_dos_cwd',
+ fastcwd => '_dos_cwd',
+ abs_path => 'fast_abs_path',
+ },
+
+ qnx =>
+ {
+ cwd => '_qnx_cwd',
+ getcwd => '_qnx_cwd',
+ fastgetcwd => '_qnx_cwd',
+ fastcwd => '_qnx_cwd',
+ abs_path => '_qnx_abs_path',
+ fast_abs_path => '_qnx_abs_path',
+ },
+
+ cygwin =>
+ {
+ getcwd => 'cwd',
+ fastgetcwd => 'cwd',
+ fastcwd => 'cwd',
+ abs_path => 'fast_abs_path',
+ realpath => 'fast_abs_path',
+ },
+
+ epoc =>
+ {
+ cwd => '_epoc_cwd',
+ getcwd => '_epoc_cwd',
+ fastgetcwd => '_epoc_cwd',
+ fastcwd => '_epoc_cwd',
+ abs_path => 'fast_abs_path',
+ },
+
+ MacOS =>
+ {
+ getcwd => 'cwd',
+ fastgetcwd => 'cwd',
+ fastcwd => 'cwd',
+ abs_path => 'fast_abs_path',
+ },
+ );
+
+$METHOD_MAP{NT} = $METHOD_MAP{MSWin32};
+$METHOD_MAP{nto} = $METHOD_MAP{qnx};
+
+
+# Find the pwd command in the expected locations. We assume these
+# are safe. This prevents _backtick_pwd() consulting $ENV{PATH}
+# so everything works under taint mode.
+my $pwd_cmd;
+foreach my $try ('/bin/pwd',
+ '/usr/bin/pwd',
+ '/QOpenSys/bin/pwd', # OS/400 PASE.
+ ) {
+
+ if( -x $try ) {
+ $pwd_cmd = $try;
+ last;
+ }
+}
+unless ($pwd_cmd) {
+ # Isn't this wrong? _backtick_pwd() will fail if somenone has
+ # pwd in their path but it is not /bin/pwd or /usr/bin/pwd?
+ # See [perl #16774]. --jhi
+ $pwd_cmd = 'pwd';
+}
+
+# Lazy-load Carp
+sub _carp { require Carp; Carp::carp(@_) }
+sub _croak { require Carp; Carp::croak(@_) }
+
+# The 'natural and safe form' for UNIX (pwd may be setuid root)
+sub _backtick_pwd {
+ # Localize %ENV entries in a way that won't create new hash keys
+ my @localize = grep exists $ENV{$_}, qw(PATH IFS CDPATH ENV BASH_ENV);
+ local @ENV{@localize};
+
+ my $cwd = `$pwd_cmd`;
+ # Belt-and-suspenders in case someone said "undef $/".
+ local $/ = "\n";
+ # `pwd` may fail e.g. if the disk is full
+ chomp($cwd) if defined $cwd;
+ $cwd;
+}
+
+# Since some ports may predefine cwd internally (e.g., NT)
+# we take care not to override an existing definition for cwd().
+
+unless ($METHOD_MAP{$^O}{cwd} or defined &cwd) {
+ # The pwd command is not available in some chroot(2)'ed environments
+ my $sep = $Config::Config{path_sep} || ':';
+ my $os = $^O; # Protect $^O from tainting
+ if( $os eq 'MacOS' || (defined $ENV{PATH} &&
+ $os ne 'MSWin32' && # no pwd on Windows
+ grep { -x "$_/pwd" } split($sep, $ENV{PATH})) )
+ {
+ *cwd = \&_backtick_pwd;
+ }
+ else {
+ *cwd = \&getcwd;
+ }
+}
+
+# set a reasonable (and very safe) default for fastgetcwd, in case it
+# isn't redefined later (20001212 rspier)
+*fastgetcwd = \&cwd;
+
+# By Brandon S. Allbery
+#
+# Usage: $cwd = getcwd();
+
+sub getcwd
+{
+ abs_path('.');
+}
+
+
+# By John Bazik
+#
+# Usage: $cwd = &fastcwd;
+#
+# This is a faster version of getcwd. It's also more dangerous because
+# you might chdir out of a directory that you can't chdir back into.
+
+sub fastcwd_ {
+ my($odev, $oino, $cdev, $cino, $tdev, $tino);
+ my(@path, $path);
+ local(*DIR);
+
+ my($orig_cdev, $orig_cino) = stat('.');
+ ($cdev, $cino) = ($orig_cdev, $orig_cino);
+ for (;;) {
+ my $direntry;
+ ($odev, $oino) = ($cdev, $cino);
+ CORE::chdir('..') || return undef;
+ ($cdev, $cino) = stat('.');
+ last if $odev == $cdev && $oino == $cino;
+ opendir(DIR, '.') || return undef;
+ for (;;) {
+ $direntry = readdir(DIR);
+ last unless defined $direntry;
+ next if $direntry eq '.';
+ next if $direntry eq '..';
+
+ ($tdev, $tino) = lstat($direntry);
+ last unless $tdev != $odev || $tino != $oino;
+ }
+ closedir(DIR);
+ return undef unless defined $direntry; # should never happen
+ unshift(@path, $direntry);
+ }
+ $path = '/' . join('/', @path);
+ if ($^O eq 'apollo') { $path = "/".$path; }
+ # At this point $path may be tainted (if tainting) and chdir would fail.
+ # Untaint it then check that we landed where we started.
+ $path =~ /^(.*)\z/s # untaint
+ && CORE::chdir($1) or return undef;
+ ($cdev, $cino) = stat('.');
+ die "Unstable directory path, current directory changed unexpectedly"
+ if $cdev != $orig_cdev || $cino != $orig_cino;
+ $path;
+}
+if (not defined &fastcwd) { *fastcwd = \&fastcwd_ }
+
+
+# Keeps track of current working directory in PWD environment var
+# Usage:
+# use Cwd 'chdir';
+# chdir $newdir;
+
+my $chdir_init = 0;
+
+sub chdir_init {
+ if ($ENV{'PWD'} and $^O ne 'os2' and $^O ne 'dos' and $^O ne 'MSWin32') {
+ my($dd,$di) = stat('.');
+ my($pd,$pi) = stat($ENV{'PWD'});
+ if (!defined $dd or !defined $pd or $di != $pi or $dd != $pd) {
+ $ENV{'PWD'} = cwd();
+ }
+ }
+ else {
+ my $wd = cwd();
+ $wd = Win32::GetFullPathName($wd) if $^O eq 'MSWin32';
+ $ENV{'PWD'} = $wd;
+ }
+ # Strip an automounter prefix (where /tmp_mnt/foo/bar == /foo/bar)
+ if ($^O ne 'MSWin32' and $ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|s) {
+ my($pd,$pi) = stat($2);
+ my($dd,$di) = stat($1);
+ if (defined $pd and defined $dd and $di == $pi and $dd == $pd) {
+ $ENV{'PWD'}="$2$3";
+ }
+ }
+ $chdir_init = 1;
+}
+
+sub chdir {
+ my $newdir = @_ ? shift : ''; # allow for no arg (chdir to HOME dir)
+ $newdir =~ s|///*|/|g unless $^O eq 'MSWin32';
+ chdir_init() unless $chdir_init;
+ my $newpwd;
+ if ($^O eq 'MSWin32') {
+ # get the full path name *before* the chdir()
+ $newpwd = Win32::GetFullPathName($newdir);
+ }
+
+ return 0 unless CORE::chdir $newdir;
+
+ if ($^O eq 'VMS') {
+ return $ENV{'PWD'} = $ENV{'DEFAULT'}
+ }
+ elsif ($^O eq 'MacOS') {
+ return $ENV{'PWD'} = cwd();
+ }
+ elsif ($^O eq 'MSWin32') {
+ $ENV{'PWD'} = $newpwd;
+ return 1;
+ }
+
+ if ($newdir =~ m#^/#s) {
+ $ENV{'PWD'} = $newdir;
+ } else {
+ my @curdir = split(m#/#,$ENV{'PWD'});
+ @curdir = ('') unless @curdir;
+ my $component;
+ foreach $component (split(m#/#, $newdir)) {
+ next if $component eq '.';
+ pop(@curdir),next if $component eq '..';
+ push(@curdir,$component);
+ }
+ $ENV{'PWD'} = join('/',@curdir) || '/';
+ }
+ 1;
+}
+
+
+sub _perl_abs_path
+{
+ my $start = @_ ? shift : '.';
+ my($dotdots, $cwd, @pst, @cst, $dir, @tst);
+
+ unless (@cst = stat( $start ))
+ {
+ _carp("stat($start): $!");
+ return '';
+ }
+
+ unless (-d _) {
+ # Make sure we can be invoked on plain files, not just directories.
+ # NOTE that this routine assumes that '/' is the only directory separator.
+
+ my ($dir, $file) = $start =~ m{^(.*)/(.+)$}
+ or return cwd() . '/' . $start;
+
+ # Can't use "-l _" here, because the previous stat was a stat(), not an lstat().
+ if (-l $start) {
+ my $link_target = readlink($start);
+ die "Can't resolve link $start: $!" unless defined $link_target;
+
+ require File::Spec;
+ $link_target = $dir . '/' . $link_target
+ unless File::Spec->file_name_is_absolute($link_target);
+
+ return abs_path($link_target);
+ }
+
+ return $dir ? abs_path($dir) . "/$file" : "/$file";
+ }
+
+ $cwd = '';
+ $dotdots = $start;
+ do
+ {
+ $dotdots .= '/..';
+ @pst = @cst;
+ local *PARENT;
+ unless (opendir(PARENT, $dotdots))
+ {
+ _carp("opendir($dotdots): $!");
+ return '';
+ }
+ unless (@cst = stat($dotdots))
+ {
+ _carp("stat($dotdots): $!");
+ closedir(PARENT);
+ return '';
+ }
+ if ($pst[0] == $cst[0] && $pst[1] == $cst[1])
+ {
+ $dir = undef;
+ }
+ else
+ {
+ do
+ {
+ unless (defined ($dir = readdir(PARENT)))
+ {
+ _carp("readdir($dotdots): $!");
+ closedir(PARENT);
+ return '';
+ }
+ $tst[0] = $pst[0]+1 unless (@tst = lstat("$dotdots/$dir"))
+ }
+ while ($dir eq '.' || $dir eq '..' || $tst[0] != $pst[0] ||
+ $tst[1] != $pst[1]);
+ }
+ $cwd = (defined $dir ? "$dir" : "" ) . "/$cwd" ;
+ closedir(PARENT);
+ } while (defined $dir);
+ chop($cwd) unless $cwd eq '/'; # drop the trailing /
+ $cwd;
+}
+
+
+my $Curdir;
+sub fast_abs_path {
+ local $ENV{PWD} = $ENV{PWD} || ''; # Guard against clobberage
+ my $cwd = getcwd();
+ require File::Spec;
+ my $path = @_ ? shift : ($Curdir ||= File::Spec->curdir);
+
+ # Detaint else we'll explode in taint mode. This is safe because
+ # we're not doing anything dangerous with it.
+ ($path) = $path =~ /(.*)/;
+ ($cwd) = $cwd =~ /(.*)/;
+
+ unless (-e $path) {
+ _croak("$path: No such file or directory");
+ }
+
+ unless (-d _) {
+ # Make sure we can be invoked on plain files, not just directories.
+
+ my ($vol, $dir, $file) = File::Spec->splitpath($path);
+ return File::Spec->catfile($cwd, $path) unless length $dir;
+
+ if (-l $path) {
+ my $link_target = readlink($path);
+ die "Can't resolve link $path: $!" unless defined $link_target;
+
+ $link_target = File::Spec->catpath($vol, $dir, $link_target)
+ unless File::Spec->file_name_is_absolute($link_target);
+
+ return fast_abs_path($link_target);
+ }
+
+ return $dir eq File::Spec->rootdir
+ ? File::Spec->catpath($vol, $dir, $file)
+ : fast_abs_path(File::Spec->catpath($vol, $dir, '')) . '/' . $file;
+ }
+
+ if (!CORE::chdir($path)) {
+ _croak("Cannot chdir to $path: $!");
+ }
+ my $realpath = getcwd();
+ if (! ((-d $cwd) && (CORE::chdir($cwd)))) {
+ _croak("Cannot chdir back to $cwd: $!");
+ }
+ $realpath;
+}
+
+# added function alias to follow principle of least surprise
+# based on previous aliasing. --tchrist 27-Jan-00
+*fast_realpath = \&fast_abs_path;
+
+
+# --- PORTING SECTION ---
+
+# VMS: $ENV{'DEFAULT'} points to default directory at all times
+# 06-Mar-1996 Charles Bailey bailey@newman.upenn.edu
+# Note: Use of Cwd::chdir() causes the logical name PWD to be defined
+# in the process logical name table as the default device and directory
+# seen by Perl. This may not be the same as the default device
+# and directory seen by DCL after Perl exits, since the effects
+# the CRTL chdir() function persist only until Perl exits.
+
+sub _vms_cwd {
+ return $ENV{'DEFAULT'};
+}
+
+sub _vms_abs_path {
+ return $ENV{'DEFAULT'} unless @_;
+
+ # may need to turn foo.dir into [.foo]
+ my $path = VMS::Filespec::pathify($_[0]);
+ $path = $_[0] unless defined $path;
+
+ return VMS::Filespec::rmsexpand($path);
+}
+
+sub _os2_cwd {
+ $ENV{'PWD'} = `cmd /c cd`;
+ chomp $ENV{'PWD'};
+ $ENV{'PWD'} =~ s:\\:/:g ;
+ return $ENV{'PWD'};
+}
+
+sub _win32_cwd {
+ $ENV{'PWD'} = Win32::GetCwd();
+ $ENV{'PWD'} =~ s:\\:/:g ;
+ return $ENV{'PWD'};
+}
+
+*_NT_cwd = defined &Win32::GetCwd ? \&_win32_cwd : \&_os2_cwd;
+
+sub _dos_cwd {
+ if (!defined &Dos::GetCwd) {
+ $ENV{'PWD'} = `command /c cd`;
+ chomp $ENV{'PWD'};
+ $ENV{'PWD'} =~ s:\\:/:g ;
+ } else {
+ $ENV{'PWD'} = Dos::GetCwd();
+ }
+ return $ENV{'PWD'};
+}
+
+sub _qnx_cwd {
+ local $ENV{PATH} = '';
+ local $ENV{CDPATH} = '';
+ local $ENV{ENV} = '';
+ $ENV{'PWD'} = `/usr/bin/fullpath -t`;
+ chomp $ENV{'PWD'};
+ return $ENV{'PWD'};
+}
+
+sub _qnx_abs_path {
+ local $ENV{PATH} = '';
+ local $ENV{CDPATH} = '';
+ local $ENV{ENV} = '';
+ my $path = @_ ? shift : '.';
+ local *REALPATH;
+
+ defined( open(REALPATH, '-|') || exec '/usr/bin/fullpath', '-t', $path ) or
+ die "Can't open /usr/bin/fullpath: $!";
+ my $realpath = <REALPATH>;
+ close REALPATH;
+ chomp $realpath;
+ return $realpath;
+}
+
+sub _epoc_cwd {
+ $ENV{'PWD'} = EPOC::getcwd();
+ return $ENV{'PWD'};
+}
+
+
+# Now that all the base-level functions are set up, alias the
+# user-level functions to the right places
+
+if (exists $METHOD_MAP{$^O}) {
+ my $map = $METHOD_MAP{$^O};
+ foreach my $name (keys %$map) {
+ local $^W = 0; # assignments trigger 'subroutine redefined' warning
+ no strict 'refs';
+ *{$name} = \&{$map->{$name}};
+ }
+}
+
+# In case the XS version doesn't load.
+*abs_path = \&_perl_abs_path unless defined &abs_path;
+
+# added function alias for those of us more
+# used to the libc function. --tchrist 27-Jan-00
+*realpath = \&abs_path;
+
+1;
diff --git a/Master/tlpkg/installer/perllib/DynaLoader.pm b/Master/tlpkg/installer/perllib/DynaLoader.pm
new file mode 100644
index 00000000000..178e9b2616c
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/DynaLoader.pm
@@ -0,0 +1,833 @@
+
+# Generated from DynaLoader.pm.PL
+
+package DynaLoader;
+
+# And Gandalf said: 'Many folk like to know beforehand what is to
+# be set on the table; but those who have laboured to prepare the
+# feast like to keep their secret; for wonder makes the words of
+# praise louder.'
+
+# (Quote from Tolkien suggested by Anno Siegel.)
+#
+# See pod text at end of file for documentation.
+# See also ext/DynaLoader/README in source tree for other information.
+#
+# Tim.Bunce@ig.co.uk, August 1994
+
+use vars qw($VERSION *AUTOLOAD);
+
+$VERSION = '1.05'; # avoid typo warning
+
+require AutoLoader;
+*AUTOLOAD = \&AutoLoader::AUTOLOAD;
+
+use Config;
+
+# The following require can't be removed during maintenance
+# releases, sadly, because of the risk of buggy code that does
+# require Carp; Carp::croak "..."; without brackets dying
+# if Carp hasn't been loaded in earlier compile time. :-(
+# We'll let those bugs get found on the development track.
+require Carp if $] < 5.00450;
+
+# enable debug/trace messages from DynaLoader perl code
+$dl_debug = $ENV{PERL_DL_DEBUG} || 0 unless defined $dl_debug;
+
+#
+# Flags to alter dl_load_file behaviour. Assigned bits:
+# 0x01 make symbols available for linking later dl_load_file's.
+# (only known to work on Solaris 2 using dlopen(RTLD_GLOBAL))
+# (ignored under VMS; effect is built-in to image linking)
+#
+# This is called as a class method $module->dl_load_flags. The
+# definition here will be inherited and result on "default" loading
+# behaviour unless a sub-class of DynaLoader defines its own version.
+#
+
+sub dl_load_flags { 0x00 }
+
+# ($dl_dlext, $dlsrc)
+# = @Config::Config{'dlext', 'dlsrc'};
+ ($dl_dlext, $dlsrc) = ('dll','dl_win32.xs')
+;
+# Some systems need special handling to expand file specifications
+# (VMS support by Charles Bailey <bailey@HMIVAX.HUMGEN.UPENN.EDU>)
+# See dl_expandspec() for more details. Should be harmless but
+# inefficient to define on systems that don't need it.
+$Is_VMS = $^O eq 'VMS';
+$do_expand = $Is_VMS;
+$Is_MacOS = $^O eq 'MacOS';
+
+my $Mac_FS;
+$Mac_FS = eval { require Mac::FileSpec::Unixish } if $Is_MacOS;
+
+@dl_require_symbols = (); # names of symbols we need
+@dl_resolve_using = (); # names of files to link with
+@dl_library_path = (); # path to look for files
+
+#XSLoader.pm may have added elements before we were required
+#@dl_shared_objects = (); # shared objects for symbols we have
+#@dl_librefs = (); # things we have loaded
+#@dl_modules = (); # Modules we have loaded
+
+# This is a fix to support DLD's unfortunate desire to relink -lc
+@dl_resolve_using = dl_findfile('-lc') if $dlsrc eq "dl_dld.xs";
+
+# Initialise @dl_library_path with the 'standard' library path
+# for this platform as determined by Configure.
+
+push(@dl_library_path, split(' ', $Config::Config{libpth}));
+
+
+my $ldlibpthname = $Config::Config{ldlibpthname};
+my $ldlibpthname_defined = defined $Config::Config{ldlibpthname};
+my $pthsep = $Config::Config{path_sep};
+
+# Add to @dl_library_path any extra directories we can gather from environment
+# during runtime.
+
+if ($ldlibpthname_defined &&
+ exists $ENV{$ldlibpthname}) {
+ push(@dl_library_path, split(/$pthsep/, $ENV{$ldlibpthname}));
+}
+
+# E.g. HP-UX supports both its native SHLIB_PATH *and* LD_LIBRARY_PATH.
+
+if ($ldlibpthname_defined &&
+ $ldlibpthname ne 'LD_LIBRARY_PATH' &&
+ exists $ENV{LD_LIBRARY_PATH}) {
+ push(@dl_library_path, split(/$pthsep/, $ENV{LD_LIBRARY_PATH}));
+}
+
+
+# No prizes for guessing why we don't say 'bootstrap DynaLoader;' here.
+# NOTE: All dl_*.xs (including dl_none.xs) define a dl_error() XSUB
+boot_DynaLoader('DynaLoader') if defined(&boot_DynaLoader) &&
+ !defined(&dl_error);
+
+if ($dl_debug) {
+ print STDERR "DynaLoader.pm loaded (@INC, @dl_library_path)\n";
+ print STDERR "DynaLoader not linked into this perl\n"
+ unless defined(&boot_DynaLoader);
+}
+
+1; # End of main code
+
+
+sub croak { require Carp; Carp::croak(@_) }
+
+sub bootstrap_inherit {
+ my $module = $_[0];
+ local *isa = *{"$module\::ISA"};
+ local @isa = (@isa, 'DynaLoader');
+ # Cannot goto due to delocalization. Will report errors on a wrong line?
+ bootstrap(@_);
+}
+
+# The bootstrap function cannot be autoloaded (without complications)
+# so we define it here:
+
+sub bootstrap {
+ # use local vars to enable $module.bs script to edit values
+ local(@args) = @_;
+ local($module) = $args[0];
+ local(@dirs, $file);
+
+ unless ($module) {
+ require Carp;
+ Carp::confess("Usage: DynaLoader::bootstrap(module)");
+ }
+
+ # A common error on platforms which don't support dynamic loading.
+ # Since it's fatal and potentially confusing we give a detailed message.
+ croak("Can't load module $module, dynamic loading not available in this perl.\n".
+ " (You may need to build a new perl executable which either supports\n".
+ " dynamic loading or has the $module module statically linked into it.)\n")
+ unless defined(&dl_load_file);
+
+ my @modparts = split(/::/,$module);
+ my $modfname = $modparts[-1];
+
+ # Some systems have restrictions on files names for DLL's etc.
+ # mod2fname returns appropriate file base name (typically truncated)
+ # It may also edit @modparts if required.
+ $modfname = &mod2fname(\@modparts) if defined &mod2fname;
+
+ # Truncate the module name to 8.3 format for NetWare
+ if (($^O eq 'NetWare') && (length($modfname) > 8)) {
+ $modfname = substr($modfname, 0, 8);
+ }
+
+ my $modpname = join(($Is_MacOS ? ':' : '/'),@modparts);
+
+ print STDERR "DynaLoader::bootstrap for $module ",
+ ($Is_MacOS
+ ? "(:auto:$modpname:$modfname.$dl_dlext)\n" :
+ "(auto/$modpname/$modfname.$dl_dlext)\n")
+ if $dl_debug;
+
+ foreach (@INC) {
+ chop($_ = VMS::Filespec::unixpath($_)) if $Is_VMS;
+ my $dir;
+ if ($Is_MacOS) {
+ my $path = $_;
+ if ($Mac_FS && ! -d $path) {
+ $path = Mac::FileSpec::Unixish::nativize($path);
+ }
+ $path .= ":" unless /:$/;
+ $dir = "${path}auto:$modpname";
+ } else {
+ $dir = "$_/auto/$modpname";
+ }
+
+ next unless -d $dir; # skip over uninteresting directories
+
+ # check for common cases to avoid autoload of dl_findfile
+ my $try = $Is_MacOS ? "$dir:$modfname.$dl_dlext" : "$dir/$modfname.$dl_dlext";
+ last if $file = ($do_expand) ? dl_expandspec($try) : ((-f $try) && $try);
+
+ # no luck here, save dir for possible later dl_findfile search
+ push @dirs, $dir;
+ }
+ # last resort, let dl_findfile have a go in all known locations
+ $file = dl_findfile(map("-L$_",@dirs,@INC), $modfname) unless $file;
+
+ croak("Can't locate loadable object for module $module in \@INC (\@INC contains: @INC)")
+ unless $file; # wording similar to error from 'require'
+
+ $file = uc($file) if $Is_VMS && $Config::Config{d_vms_case_sensitive_symbols};
+ my $bootname = "boot_$module";
+ $bootname =~ s/\W/_/g;
+ @dl_require_symbols = ($bootname);
+
+ # Execute optional '.bootstrap' perl script for this module.
+ # The .bs file can be used to configure @dl_resolve_using etc to
+ # match the needs of the individual module on this architecture.
+ my $bs = $file;
+ $bs =~ s/(\.\w+)?(;\d*)?$/\.bs/; # look for .bs 'beside' the library
+ if (-s $bs) { # only read file if it's not empty
+ print STDERR "BS: $bs ($^O, $dlsrc)\n" if $dl_debug;
+ eval { do $bs; };
+ warn "$bs: $@\n" if $@;
+ }
+
+ my $boot_symbol_ref;
+
+ if ($^O eq 'darwin') {
+ if ($boot_symbol_ref = dl_find_symbol(0, $bootname)) {
+ goto boot; #extension library has already been loaded, e.g. darwin
+ }
+ }
+
+ # Many dynamic extension loading problems will appear to come from
+ # this section of code: XYZ failed at line 123 of DynaLoader.pm.
+ # Often these errors are actually occurring in the initialisation
+ # C code of the extension XS file. Perl reports the error as being
+ # in this perl code simply because this was the last perl code
+ # it executed.
+
+ my $libref = dl_load_file($file, $module->dl_load_flags) or
+ croak("Can't load '$file' for module $module: ".dl_error());
+
+ push(@dl_librefs,$libref); # record loaded object
+
+ my @unresolved = dl_undef_symbols();
+ if (@unresolved) {
+ require Carp;
+ Carp::carp("Undefined symbols present after loading $file: @unresolved\n");
+ }
+
+ $boot_symbol_ref = dl_find_symbol($libref, $bootname) or
+ croak("Can't find '$bootname' symbol in $file\n");
+
+ push(@dl_modules, $module); # record loaded module
+
+ boot:
+ my $xs = dl_install_xsub("${module}::bootstrap", $boot_symbol_ref, $file);
+
+ # See comment block above
+
+ push(@dl_shared_objects, $file); # record files loaded
+
+ &$xs(@args);
+}
+
+
+#sub _check_file { # private utility to handle dl_expandspec vs -f tests
+# my($file) = @_;
+# return $file if (!$do_expand && -f $file); # the common case
+# return $file if ( $do_expand && ($file=dl_expandspec($file)));
+# return undef;
+#}
+
+
+# Let autosplit and the autoloader deal with these functions:
+__END__
+
+
+sub dl_findfile {
+ # Read ext/DynaLoader/DynaLoader.doc for detailed information.
+ # This function does not automatically consider the architecture
+ # or the perl library auto directories.
+ my (@args) = @_;
+ my (@dirs, $dir); # which directories to search
+ my (@found); # full paths to real files we have found
+ my $dl_ext= 'dll'; # $Config::Config{'dlext'} suffix for perl extensions
+ my $dl_so = 'dll'; # $Config::Config{'so'} suffix for shared libraries
+
+ print STDERR "dl_findfile(@args)\n" if $dl_debug;
+
+ # accumulate directories but process files as they appear
+ arg: foreach(@args) {
+ # Special fast case: full filepath requires no search
+ if ($Is_VMS && m%[:>/\]]% && -f $_) {
+ push(@found,dl_expandspec(VMS::Filespec::vmsify($_)));
+ last arg unless wantarray;
+ next;
+ }
+ elsif ($Is_MacOS) {
+ if (m/:/ && -f $_) {
+ push(@found,$_);
+ last arg unless wantarray;
+ }
+ }
+ elsif (m:/: && -f $_ && !$do_expand) {
+ push(@found,$_);
+ last arg unless wantarray;
+ next;
+ }
+
+ # Deal with directories first:
+ # Using a -L prefix is the preferred option (faster and more robust)
+ if (m:^-L:) { s/^-L//; push(@dirs, $_); next; }
+
+ if ($Is_MacOS) {
+ # Otherwise we try to try to spot directories by a heuristic
+ # (this is a more complicated issue than it first appears)
+ if (m/:/ && -d $_) { push(@dirs, $_); next; }
+ # Only files should get this far...
+ my(@names, $name); # what filenames to look for
+ s/^-l//;
+ push(@names, $_);
+ foreach $dir (@dirs, @dl_library_path) {
+ next unless -d $dir;
+ $dir =~ s/^([^:]+)$/:$1/;
+ $dir =~ s/:$//;
+ foreach $name (@names) {
+ my($file) = "$dir:$name";
+ print STDERR " checking in $dir for $name\n" if $dl_debug;
+ if (-f $file) {
+ push(@found, $file);
+ next arg; # no need to look any further
+ }
+ }
+ }
+ next;
+ }
+
+ # Otherwise we try to try to spot directories by a heuristic
+ # (this is a more complicated issue than it first appears)
+ if (m:/: && -d $_) { push(@dirs, $_); next; }
+
+ # VMS: we may be using native VMS directory syntax instead of
+ # Unix emulation, so check this as well
+ if ($Is_VMS && /[:>\]]/ && -d $_) { push(@dirs, $_); next; }
+
+ # Only files should get this far...
+ my(@names, $name); # what filenames to look for
+ if (m:-l: ) { # convert -lname to appropriate library name
+ s/-l//;
+ push(@names,"lib$_.$dl_so");
+ push(@names,"lib$_.a");
+ } else { # Umm, a bare name. Try various alternatives:
+ # these should be ordered with the most likely first
+ push(@names,"$_.$dl_ext") unless m/\.$dl_ext$/o;
+ push(@names,"$_.$dl_so") unless m/\.$dl_so$/o;
+ push(@names,"lib$_.$dl_so") unless m:/:;
+ push(@names,"$_.a") if !m/\.a$/ and $dlsrc eq "dl_dld.xs";
+ push(@names, $_);
+ }
+ foreach $dir (@dirs, @dl_library_path) {
+ next unless -d $dir;
+ chop($dir = VMS::Filespec::unixpath($dir)) if $Is_VMS;
+ foreach $name (@names) {
+ my($file) = "$dir/$name";
+ print STDERR " checking in $dir for $name\n" if $dl_debug;
+ $file = ($do_expand) ? dl_expandspec($file) : (-f $file && $file);
+ #$file = _check_file($file);
+ if ($file) {
+ push(@found, $file);
+ next arg; # no need to look any further
+ }
+ }
+ }
+ }
+ if ($dl_debug) {
+ foreach(@dirs) {
+ print STDERR " dl_findfile ignored non-existent directory: $_\n" unless -d $_;
+ }
+ print STDERR "dl_findfile found: @found\n";
+ }
+ return $found[0] unless wantarray;
+ @found;
+}
+
+
+sub dl_expandspec {
+ my($spec) = @_;
+ # Optional function invoked if DynaLoader.pm sets $do_expand.
+ # Most systems do not require or use this function.
+ # Some systems may implement it in the dl_*.xs file in which case
+ # this autoload version will not be called but is harmless.
+
+ # This function is designed to deal with systems which treat some
+ # 'filenames' in a special way. For example VMS 'Logical Names'
+ # (something like unix environment variables - but different).
+ # This function should recognise such names and expand them into
+ # full file paths.
+ # Must return undef if $spec is invalid or file does not exist.
+
+ my $file = $spec; # default output to input
+
+ if ($Is_VMS) { # dl_expandspec should be defined in dl_vms.xs
+ require Carp;
+ Carp::croak("dl_expandspec: should be defined in XS file!\n");
+ } else {
+ return undef unless -f $file;
+ }
+ print STDERR "dl_expandspec($spec) => $file\n" if $dl_debug;
+ $file;
+}
+
+sub dl_find_symbol_anywhere
+{
+ my $sym = shift;
+ my $libref;
+ foreach $libref (@dl_librefs) {
+ my $symref = dl_find_symbol($libref,$sym);
+ return $symref if $symref;
+ }
+ return undef;
+}
+
+=head1 NAME
+
+DynaLoader - Dynamically load C libraries into Perl code
+
+=head1 SYNOPSIS
+
+ package YourPackage;
+ require DynaLoader;
+ @ISA = qw(... DynaLoader ...);
+ bootstrap YourPackage;
+
+ # optional method for 'global' loading
+ sub dl_load_flags { 0x01 }
+
+
+=head1 DESCRIPTION
+
+This document defines a standard generic interface to the dynamic
+linking mechanisms available on many platforms. Its primary purpose is
+to implement automatic dynamic loading of Perl modules.
+
+This document serves as both a specification for anyone wishing to
+implement the DynaLoader for a new platform and as a guide for
+anyone wishing to use the DynaLoader directly in an application.
+
+The DynaLoader is designed to be a very simple high-level
+interface that is sufficiently general to cover the requirements
+of SunOS, HP-UX, NeXT, Linux, VMS and other platforms.
+
+It is also hoped that the interface will cover the needs of OS/2, NT
+etc and also allow pseudo-dynamic linking (using C<ld -A> at runtime).
+
+It must be stressed that the DynaLoader, by itself, is practically
+useless for accessing non-Perl libraries because it provides almost no
+Perl-to-C 'glue'. There is, for example, no mechanism for calling a C
+library function or supplying arguments. A C::DynaLib module
+is available from CPAN sites which performs that function for some
+common system types. And since the year 2000, there's also Inline::C,
+a module that allows you to write Perl subroutines in C. Also available
+from your local CPAN site.
+
+DynaLoader Interface Summary
+
+ @dl_library_path
+ @dl_resolve_using
+ @dl_require_symbols
+ $dl_debug
+ @dl_librefs
+ @dl_modules
+ @dl_shared_objects
+ Implemented in:
+ bootstrap($modulename) Perl
+ @filepaths = dl_findfile(@names) Perl
+ $flags = $modulename->dl_load_flags Perl
+ $symref = dl_find_symbol_anywhere($symbol) Perl
+
+ $libref = dl_load_file($filename, $flags) C
+ $status = dl_unload_file($libref) C
+ $symref = dl_find_symbol($libref, $symbol) C
+ @symbols = dl_undef_symbols() C
+ dl_install_xsub($name, $symref [, $filename]) C
+ $message = dl_error C
+
+=over 4
+
+=item @dl_library_path
+
+The standard/default list of directories in which dl_findfile() will
+search for libraries etc. Directories are searched in order:
+$dl_library_path[0], [1], ... etc
+
+@dl_library_path is initialised to hold the list of 'normal' directories
+(F</usr/lib>, etc) determined by B<Configure> (C<$Config{'libpth'}>). This should
+ensure portability across a wide range of platforms.
+
+@dl_library_path should also be initialised with any other directories
+that can be determined from the environment at runtime (such as
+LD_LIBRARY_PATH for SunOS).
+
+After initialisation @dl_library_path can be manipulated by an
+application using push and unshift before calling dl_findfile().
+Unshift can be used to add directories to the front of the search order
+either to save search time or to override libraries with the same name
+in the 'normal' directories.
+
+The load function that dl_load_file() calls may require an absolute
+pathname. The dl_findfile() function and @dl_library_path can be
+used to search for and return the absolute pathname for the
+library/object that you wish to load.
+
+=item @dl_resolve_using
+
+A list of additional libraries or other shared objects which can be
+used to resolve any undefined symbols that might be generated by a
+later call to load_file().
+
+This is only required on some platforms which do not handle dependent
+libraries automatically. For example the Socket Perl extension
+library (F<auto/Socket/Socket.so>) contains references to many socket
+functions which need to be resolved when it's loaded. Most platforms
+will automatically know where to find the 'dependent' library (e.g.,
+F</usr/lib/libsocket.so>). A few platforms need to be told the
+location of the dependent library explicitly. Use @dl_resolve_using
+for this.
+
+Example usage:
+
+ @dl_resolve_using = dl_findfile('-lsocket');
+
+=item @dl_require_symbols
+
+A list of one or more symbol names that are in the library/object file
+to be dynamically loaded. This is only required on some platforms.
+
+=item @dl_librefs
+
+An array of the handles returned by successful calls to dl_load_file(),
+made by bootstrap, in the order in which they were loaded.
+Can be used with dl_find_symbol() to look for a symbol in any of
+the loaded files.
+
+=item @dl_modules
+
+An array of module (package) names that have been bootstrap'ed.
+
+=item @dl_shared_objects
+
+An array of file names for the shared objects that were loaded.
+
+=item dl_error()
+
+Syntax:
+
+ $message = dl_error();
+
+Error message text from the last failed DynaLoader function. Note
+that, similar to errno in unix, a successful function call does not
+reset this message.
+
+Implementations should detect the error as soon as it occurs in any of
+the other functions and save the corresponding message for later
+retrieval. This will avoid problems on some platforms (such as SunOS)
+where the error message is very temporary (e.g., dlerror()).
+
+=item $dl_debug
+
+Internal debugging messages are enabled when $dl_debug is set true.
+Currently setting $dl_debug only affects the Perl side of the
+DynaLoader. These messages should help an application developer to
+resolve any DynaLoader usage problems.
+
+$dl_debug is set to C<$ENV{'PERL_DL_DEBUG'}> if defined.
+
+For the DynaLoader developer/porter there is a similar debugging
+variable added to the C code (see dlutils.c) and enabled if Perl was
+built with the B<-DDEBUGGING> flag. This can also be set via the
+PERL_DL_DEBUG environment variable. Set to 1 for minimal information or
+higher for more.
+
+=item dl_findfile()
+
+Syntax:
+
+ @filepaths = dl_findfile(@names)
+
+Determine the full paths (including file suffix) of one or more
+loadable files given their generic names and optionally one or more
+directories. Searches directories in @dl_library_path by default and
+returns an empty list if no files were found.
+
+Names can be specified in a variety of platform independent forms. Any
+names in the form B<-lname> are converted into F<libname.*>, where F<.*> is
+an appropriate suffix for the platform.
+
+If a name does not already have a suitable prefix and/or suffix then
+the corresponding file will be searched for by trying combinations of
+prefix and suffix appropriate to the platform: "$name.o", "lib$name.*"
+and "$name".
+
+If any directories are included in @names they are searched before
+@dl_library_path. Directories may be specified as B<-Ldir>. Any other
+names are treated as filenames to be searched for.
+
+Using arguments of the form C<-Ldir> and C<-lname> is recommended.
+
+Example:
+
+ @dl_resolve_using = dl_findfile(qw(-L/usr/5lib -lposix));
+
+
+=item dl_expandspec()
+
+Syntax:
+
+ $filepath = dl_expandspec($spec)
+
+Some unusual systems, such as VMS, require special filename handling in
+order to deal with symbolic names for files (i.e., VMS's Logical Names).
+
+To support these systems a dl_expandspec() function can be implemented
+either in the F<dl_*.xs> file or code can be added to the autoloadable
+dl_expandspec() function in F<DynaLoader.pm>. See F<DynaLoader.pm> for
+more information.
+
+=item dl_load_file()
+
+Syntax:
+
+ $libref = dl_load_file($filename, $flags)
+
+Dynamically load $filename, which must be the path to a shared object
+or library. An opaque 'library reference' is returned as a handle for
+the loaded object. Returns undef on error.
+
+The $flags argument to alters dl_load_file behaviour.
+Assigned bits:
+
+ 0x01 make symbols available for linking later dl_load_file's.
+ (only known to work on Solaris 2 using dlopen(RTLD_GLOBAL))
+ (ignored under VMS; this is a normal part of image linking)
+
+(On systems that provide a handle for the loaded object such as SunOS
+and HPUX, $libref will be that handle. On other systems $libref will
+typically be $filename or a pointer to a buffer containing $filename.
+The application should not examine or alter $libref in any way.)
+
+This is the function that does the real work. It should use the
+current values of @dl_require_symbols and @dl_resolve_using if required.
+
+ SunOS: dlopen($filename)
+ HP-UX: shl_load($filename)
+ Linux: dld_create_reference(@dl_require_symbols); dld_link($filename)
+ NeXT: rld_load($filename, @dl_resolve_using)
+ VMS: lib$find_image_symbol($filename,$dl_require_symbols[0])
+
+(The dlopen() function is also used by Solaris and some versions of
+Linux, and is a common choice when providing a "wrapper" on other
+mechanisms as is done in the OS/2 port.)
+
+=item dl_unload_file()
+
+Syntax:
+
+ $status = dl_unload_file($libref)
+
+Dynamically unload $libref, which must be an opaque 'library reference' as
+returned from dl_load_file. Returns one on success and zero on failure.
+
+This function is optional and may not necessarily be provided on all platforms.
+If it is defined, it is called automatically when the interpreter exits for
+every shared object or library loaded by DynaLoader::bootstrap. All such
+library references are stored in @dl_librefs by DynaLoader::Bootstrap as it
+loads the libraries. The files are unloaded in last-in, first-out order.
+
+This unloading is usually necessary when embedding a shared-object perl (e.g.
+one configured with -Duseshrplib) within a larger application, and the perl
+interpreter is created and destroyed several times within the lifetime of the
+application. In this case it is possible that the system dynamic linker will
+unload and then subsequently reload the shared libperl without relocating any
+references to it from any files DynaLoaded by the previous incarnation of the
+interpreter. As a result, any shared objects opened by DynaLoader may point to
+a now invalid 'ghost' of the libperl shared object, causing apparently random
+memory corruption and crashes. This behaviour is most commonly seen when using
+Apache and mod_perl built with the APXS mechanism.
+
+ SunOS: dlclose($libref)
+ HP-UX: ???
+ Linux: ???
+ NeXT: ???
+ VMS: ???
+
+(The dlclose() function is also used by Solaris and some versions of
+Linux, and is a common choice when providing a "wrapper" on other
+mechanisms as is done in the OS/2 port.)
+
+=item dl_load_flags()
+
+Syntax:
+
+ $flags = dl_load_flags $modulename;
+
+Designed to be a method call, and to be overridden by a derived class
+(i.e. a class which has DynaLoader in its @ISA). The definition in
+DynaLoader itself returns 0, which produces standard behavior from
+dl_load_file().
+
+=item dl_find_symbol()
+
+Syntax:
+
+ $symref = dl_find_symbol($libref, $symbol)
+
+Return the address of the symbol $symbol or C<undef> if not found. If the
+target system has separate functions to search for symbols of different
+types then dl_find_symbol() should search for function symbols first and
+then other types.
+
+The exact manner in which the address is returned in $symref is not
+currently defined. The only initial requirement is that $symref can
+be passed to, and understood by, dl_install_xsub().
+
+ SunOS: dlsym($libref, $symbol)
+ HP-UX: shl_findsym($libref, $symbol)
+ Linux: dld_get_func($symbol) and/or dld_get_symbol($symbol)
+ NeXT: rld_lookup("_$symbol")
+ VMS: lib$find_image_symbol($libref,$symbol)
+
+
+=item dl_find_symbol_anywhere()
+
+Syntax:
+
+ $symref = dl_find_symbol_anywhere($symbol)
+
+Applies dl_find_symbol() to the members of @dl_librefs and returns
+the first match found.
+
+=item dl_undef_symbols()
+
+Example
+
+ @symbols = dl_undef_symbols()
+
+Return a list of symbol names which remain undefined after load_file().
+Returns C<()> if not known. Don't worry if your platform does not provide
+a mechanism for this. Most do not need it and hence do not provide it,
+they just return an empty list.
+
+
+=item dl_install_xsub()
+
+Syntax:
+
+ dl_install_xsub($perl_name, $symref [, $filename])
+
+Create a new Perl external subroutine named $perl_name using $symref as
+a pointer to the function which implements the routine. This is simply
+a direct call to newXSUB(). Returns a reference to the installed
+function.
+
+The $filename parameter is used by Perl to identify the source file for
+the function if required by die(), caller() or the debugger. If
+$filename is not defined then "DynaLoader" will be used.
+
+
+=item bootstrap()
+
+Syntax:
+
+bootstrap($module)
+
+This is the normal entry point for automatic dynamic loading in Perl.
+
+It performs the following actions:
+
+=over 8
+
+=item *
+
+locates an auto/$module directory by searching @INC
+
+=item *
+
+uses dl_findfile() to determine the filename to load
+
+=item *
+
+sets @dl_require_symbols to C<("boot_$module")>
+
+=item *
+
+executes an F<auto/$module/$module.bs> file if it exists
+(typically used to add to @dl_resolve_using any files which
+are required to load the module on the current platform)
+
+=item *
+
+calls dl_load_flags() to determine how to load the file.
+
+=item *
+
+calls dl_load_file() to load the file
+
+=item *
+
+calls dl_undef_symbols() and warns if any symbols are undefined
+
+=item *
+
+calls dl_find_symbol() for "boot_$module"
+
+=item *
+
+calls dl_install_xsub() to install it as "${module}::bootstrap"
+
+=item *
+
+calls &{"${module}::bootstrap"} to bootstrap the module (actually
+it uses the function reference returned by dl_install_xsub for speed)
+
+=back
+
+=back
+
+
+=head1 AUTHOR
+
+Tim Bunce, 11 August 1994.
+
+This interface is based on the work and comments of (in no particular
+order): Larry Wall, Robert Sanders, Dean Roehrich, Jeff Okamoto, Anno
+Siegel, Thomas Neumann, Paul Marquess, Charles Bailey, myself and others.
+
+Larry Wall designed the elegant inherited bootstrap mechanism and
+implemented the first Perl 5 dynamic loader using it.
+
+Solaris global loading added by Nick Ing-Simmons with design/coding
+assistance from Tim Bunce, January 1996.
+
+=cut
diff --git a/Master/tlpkg/installer/perllib/Encode.pm b/Master/tlpkg/installer/perllib/Encode.pm
new file mode 100644
index 00000000000..ac0123c89ec
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/Encode.pm
@@ -0,0 +1,851 @@
+#
+# $Id: Encode.pm,v 2.12 2005/09/08 14:17:17 dankogai Exp dankogai $
+#
+package Encode;
+use strict;
+our $VERSION = sprintf "%d.%02d", q$Revision: 2.12 $ =~ /(\d+)/g;
+sub DEBUG () { 0 }
+use XSLoader ();
+XSLoader::load(__PACKAGE__, $VERSION);
+
+require Exporter;
+use base qw/Exporter/;
+
+# Public, encouraged API is exported by default
+
+our @EXPORT = qw(
+ decode decode_utf8 encode encode_utf8
+ encodings find_encoding clone_encoding
+);
+
+our @FB_FLAGS = qw(DIE_ON_ERR WARN_ON_ERR RETURN_ON_ERR LEAVE_SRC
+ PERLQQ HTMLCREF XMLCREF STOP_AT_PARTIAL);
+our @FB_CONSTS = qw(FB_DEFAULT FB_CROAK FB_QUIET FB_WARN
+ FB_PERLQQ FB_HTMLCREF FB_XMLCREF);
+
+our @EXPORT_OK =
+ (
+ qw(
+ _utf8_off _utf8_on define_encoding from_to is_16bit is_8bit
+ is_utf8 perlio_ok resolve_alias utf8_downgrade utf8_upgrade
+ ),
+ @FB_FLAGS, @FB_CONSTS,
+ );
+
+our %EXPORT_TAGS =
+ (
+ all => [ @EXPORT, @EXPORT_OK ],
+ fallbacks => [ @FB_CONSTS ],
+ fallback_all => [ @FB_CONSTS, @FB_FLAGS ],
+ );
+
+# Documentation moved after __END__ for speed - NI-S
+
+our $ON_EBCDIC = (ord("A") == 193);
+
+use Encode::Alias;
+
+# Make a %Encoding package variable to allow a certain amount of cheating
+our %Encoding;
+our %ExtModule;
+require Encode::Config;
+eval { require Encode::ConfigLocal };
+
+sub encodings
+{
+ my $class = shift;
+ my %enc;
+ if (@_ and $_[0] eq ":all"){
+ %enc = ( %Encoding, %ExtModule );
+ }else{
+ %enc = %Encoding;
+ for my $mod (map {m/::/o ? $_ : "Encode::$_" } @_){
+ DEBUG and warn $mod;
+ for my $enc (keys %ExtModule){
+ $ExtModule{$enc} eq $mod and $enc{$enc} = $mod;
+ }
+ }
+ }
+ return
+ sort { lc $a cmp lc $b }
+ grep {!/^(?:Internal|Unicode|Guess)$/o} keys %enc;
+}
+
+sub perlio_ok{
+ my $obj = ref($_[0]) ? $_[0] : find_encoding($_[0]);
+ $obj->can("perlio_ok") and return $obj->perlio_ok();
+ return 0; # safety net
+}
+
+sub define_encoding
+{
+ my $obj = shift;
+ my $name = shift;
+ $Encoding{$name} = $obj;
+ my $lc = lc($name);
+ define_alias($lc => $obj) unless $lc eq $name;
+ while (@_){
+ my $alias = shift;
+ define_alias($alias, $obj);
+ }
+ return $obj;
+}
+
+sub getEncoding
+{
+ my ($class, $name, $skip_external) = @_;
+
+ ref($name) && $name->can('renew') and return $name;
+ exists $Encoding{$name} and return $Encoding{$name};
+ my $lc = lc $name;
+ exists $Encoding{$lc} and return $Encoding{$lc};
+
+ my $oc = $class->find_alias($name);
+ defined($oc) and return $oc;
+ $lc ne $name and $oc = $class->find_alias($lc);
+ defined($oc) and return $oc;
+
+ unless ($skip_external)
+ {
+ if (my $mod = $ExtModule{$name} || $ExtModule{$lc}){
+ $mod =~ s,::,/,g ; $mod .= '.pm';
+ eval{ require $mod; };
+ exists $Encoding{$name} and return $Encoding{$name};
+ }
+ }
+ return;
+}
+
+sub find_encoding($;$)
+{
+ my ($name, $skip_external) = @_;
+ return __PACKAGE__->getEncoding($name,$skip_external);
+}
+
+sub resolve_alias($){
+ my $obj = find_encoding(shift);
+ defined $obj and return $obj->name;
+ return;
+}
+
+sub clone_encoding($){
+ my $obj = find_encoding(shift);
+ ref $obj or return;
+ eval { require Storable };
+ $@ and return;
+ return Storable::dclone($obj);
+}
+
+sub encode($$;$)
+{
+ my ($name, $string, $check) = @_;
+ return undef unless defined $string;
+ $string .= '' if ref $string; # stringify;
+ $check ||=0;
+ my $enc = find_encoding($name);
+ unless(defined $enc){
+ require Carp;
+ Carp::croak("Unknown encoding '$name'");
+ }
+ my $octets = $enc->encode($string,$check);
+ $_[1] = $string if $check and !($check & LEAVE_SRC());
+ return $octets;
+}
+
+sub decode($$;$)
+{
+ my ($name,$octets,$check) = @_;
+ return undef unless defined $octets;
+ $octets .= '' if ref $octets;
+ $check ||=0;
+ my $enc = find_encoding($name);
+ unless(defined $enc){
+ require Carp;
+ Carp::croak("Unknown encoding '$name'");
+ }
+ my $string = $enc->decode($octets,$check);
+ $_[1] = $octets if $check and !($check & LEAVE_SRC());
+ return $string;
+}
+
+sub from_to($$$;$)
+{
+ my ($string,$from,$to,$check) = @_;
+ return undef unless defined $string;
+ $check ||=0;
+ my $f = find_encoding($from);
+ unless (defined $f){
+ require Carp;
+ Carp::croak("Unknown encoding '$from'");
+ }
+ my $t = find_encoding($to);
+ unless (defined $t){
+ require Carp;
+ Carp::croak("Unknown encoding '$to'");
+ }
+ my $uni = $f->decode($string,$check);
+ return undef if ($check && length($string));
+ $string = $t->encode($uni,$check);
+ return undef if ($check && length($uni));
+ return defined($_[0] = $string) ? length($string) : undef ;
+}
+
+sub encode_utf8($)
+{
+ my ($str) = @_;
+ utf8::encode($str);
+ return $str;
+}
+
+sub decode_utf8($;$)
+{
+ my ($str, $check) = @_;
+ if ($check){
+ return decode("utf8", $str, $check);
+ }else{
+ return decode("utf8", $str);
+ return $str;
+ }
+}
+
+predefine_encodings(1);
+
+#
+# This is to restore %Encoding if really needed;
+#
+
+sub predefine_encodings{
+ use Encode::Encoding;
+ no warnings 'redefine';
+ my $use_xs = shift;
+ if ($ON_EBCDIC) {
+ # was in Encode::UTF_EBCDIC
+ package Encode::UTF_EBCDIC;
+ push @Encode::UTF_EBCDIC::ISA, 'Encode::Encoding';
+ *decode = sub{
+ my ($obj,$str,$chk) = @_;
+ my $res = '';
+ for (my $i = 0; $i < length($str); $i++) {
+ $res .=
+ chr(utf8::unicode_to_native(ord(substr($str,$i,1))));
+ }
+ $_[1] = '' if $chk;
+ return $res;
+ };
+ *encode = sub{
+ my ($obj,$str,$chk) = @_;
+ my $res = '';
+ for (my $i = 0; $i < length($str); $i++) {
+ $res .=
+ chr(utf8::native_to_unicode(ord(substr($str,$i,1))));
+ }
+ $_[1] = '' if $chk;
+ return $res;
+ };
+ $Encode::Encoding{Unicode} =
+ bless {Name => "UTF_EBCDIC"} => "Encode::UTF_EBCDIC";
+ } else {
+ package Encode::Internal;
+ push @Encode::Internal::ISA, 'Encode::Encoding';
+ *decode = sub{
+ my ($obj,$str,$chk) = @_;
+ utf8::upgrade($str);
+ $_[1] = '' if $chk;
+ return $str;
+ };
+ *encode = \&decode;
+ $Encode::Encoding{Unicode} =
+ bless {Name => "Internal"} => "Encode::Internal";
+ }
+
+ {
+ # was in Encode::utf8
+ package Encode::utf8;
+ push @Encode::utf8::ISA, 'Encode::Encoding';
+ #
+ if ($use_xs){
+ Encode::DEBUG and warn __PACKAGE__, " XS on";
+ *decode = \&decode_xs;
+ *encode = \&encode_xs;
+ }else{
+ Encode::DEBUG and warn __PACKAGE__, " XS off";
+ *decode = sub{
+ my ($obj,$octets,$chk) = @_;
+ my $str = Encode::decode_utf8($octets);
+ if (defined $str) {
+ $_[1] = '' if $chk;
+ return $str;
+ }
+ return undef;
+ };
+ *encode = sub {
+ my ($obj,$string,$chk) = @_;
+ my $octets = Encode::encode_utf8($string);
+ $_[1] = '' if $chk;
+ return $octets;
+ };
+ }
+ *cat_decode = sub{ # ($obj, $dst, $src, $pos, $trm, $chk)
+ my ($obj, undef, undef, $pos, $trm) = @_; # currently ignores $chk
+ my ($rdst, $rsrc, $rpos) = \@_[1,2,3];
+ use bytes;
+ if ((my $npos = index($$rsrc, $trm, $pos)) >= 0) {
+ $$rdst .= substr($$rsrc, $pos, $npos - $pos + length($trm));
+ $$rpos = $npos + length($trm);
+ return 1;
+ }
+ $$rdst .= substr($$rsrc, $pos);
+ $$rpos = length($$rsrc);
+ return '';
+ };
+ $Encode::Encoding{utf8} =
+ bless {Name => "utf8"} => "Encode::utf8";
+ $Encode::Encoding{"utf-8-strict"} =
+ bless {Name => "utf-8-strict", strict_utf8 => 1 } => "Encode::utf8";
+ }
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Encode - character encodings
+
+=head1 SYNOPSIS
+
+ use Encode;
+
+=head2 Table of Contents
+
+Encode consists of a collection of modules whose details are too big
+to fit in one document. This POD itself explains the top-level APIs
+and general topics at a glance. For other topics and more details,
+see the PODs below:
+
+ Name Description
+ --------------------------------------------------------
+ Encode::Alias Alias definitions to encodings
+ Encode::Encoding Encode Implementation Base Class
+ Encode::Supported List of Supported Encodings
+ Encode::CN Simplified Chinese Encodings
+ Encode::JP Japanese Encodings
+ Encode::KR Korean Encodings
+ Encode::TW Traditional Chinese Encodings
+ --------------------------------------------------------
+
+=head1 DESCRIPTION
+
+The C<Encode> module provides the interfaces between Perl's strings
+and the rest of the system. Perl strings are sequences of
+B<characters>.
+
+The repertoire of characters that Perl can represent is at least that
+defined by the Unicode Consortium. On most platforms the ordinal
+values of the characters (as returned by C<ord(ch)>) is the "Unicode
+codepoint" for the character (the exceptions are those platforms where
+the legacy encoding is some variant of EBCDIC rather than a super-set
+of ASCII - see L<perlebcdic>).
+
+Traditionally, computer data has been moved around in 8-bit chunks
+often called "bytes". These chunks are also known as "octets" in
+networking standards. Perl is widely used to manipulate data of many
+types - not only strings of characters representing human or computer
+languages but also "binary" data being the machine's representation of
+numbers, pixels in an image - or just about anything.
+
+When Perl is processing "binary data", the programmer wants Perl to
+process "sequences of bytes". This is not a problem for Perl - as a
+byte has 256 possible values, it easily fits in Perl's much larger
+"logical character".
+
+=head2 TERMINOLOGY
+
+=over 2
+
+=item *
+
+I<character>: a character in the range 0..(2**32-1) (or more).
+(What Perl's strings are made of.)
+
+=item *
+
+I<byte>: a character in the range 0..255
+(A special case of a Perl character.)
+
+=item *
+
+I<octet>: 8 bits of data, with ordinal values 0..255
+(Term for bytes passed to or from a non-Perl context, e.g. a disk file.)
+
+=back
+
+=head1 PERL ENCODING API
+
+=over 2
+
+=item $octets = encode(ENCODING, $string [, CHECK])
+
+Encodes a string from Perl's internal form into I<ENCODING> and returns
+a sequence of octets. ENCODING can be either a canonical name or
+an alias. For encoding names and aliases, see L</"Defining Aliases">.
+For CHECK, see L</"Handling Malformed Data">.
+
+For example, to convert a string from Perl's internal format to
+iso-8859-1 (also known as Latin1),
+
+ $octets = encode("iso-8859-1", $string);
+
+B<CAVEAT>: When you run C<$octets = encode("utf8", $string)>, then $octets
+B<may not be equal to> $string. Though they both contain the same data, the utf8 flag
+for $octets is B<always> off. When you encode anything, utf8 flag of
+the result is always off, even when it contains completely valid utf8
+string. See L</"The UTF-8 flag"> below.
+
+If the $string is C<undef> then C<undef> is returned.
+
+=item $string = decode(ENCODING, $octets [, CHECK])
+
+Decodes a sequence of octets assumed to be in I<ENCODING> into Perl's
+internal form and returns the resulting string. As in encode(),
+ENCODING can be either a canonical name or an alias. For encoding names
+and aliases, see L</"Defining Aliases">. For CHECK, see
+L</"Handling Malformed Data">.
+
+For example, to convert ISO-8859-1 data to a string in Perl's internal format:
+
+ $string = decode("iso-8859-1", $octets);
+
+B<CAVEAT>: When you run C<$string = decode("utf8", $octets)>, then $string
+B<may not be equal to> $octets. Though they both contain the same data,
+the utf8 flag for $string is on unless $octets entirely consists of
+ASCII data (or EBCDIC on EBCDIC machines). See L</"The UTF-8 flag">
+below.
+
+If the $string is C<undef> then C<undef> is returned.
+
+=item [$length =] from_to($octets, FROM_ENC, TO_ENC [, CHECK])
+
+Converts B<in-place> data between two encodings. The data in $octets
+must be encoded as octets and not as characters in Perl's internal
+format. For example, to convert ISO-8859-1 data to Microsoft's CP1250
+encoding:
+
+ from_to($octets, "iso-8859-1", "cp1250");
+
+and to convert it back:
+
+ from_to($octets, "cp1250", "iso-8859-1");
+
+Note that because the conversion happens in place, the data to be
+converted cannot be a string constant; it must be a scalar variable.
+
+from_to() returns the length of the converted string in octets on
+success, I<undef> on error.
+
+B<CAVEAT>: The following operations look the same but are not quite so;
+
+ from_to($data, "iso-8859-1", "utf8"); #1
+ $data = decode("iso-8859-1", $data); #2
+
+Both #1 and #2 make $data consist of a completely valid UTF-8 string
+but only #2 turns utf8 flag on. #1 is equivalent to
+
+ $data = encode("utf8", decode("iso-8859-1", $data));
+
+See L</"The UTF-8 flag"> below.
+
+=item $octets = encode_utf8($string);
+
+Equivalent to C<$octets = encode("utf8", $string);> The characters
+that comprise $string are encoded in Perl's internal format and the
+result is returned as a sequence of octets. All possible
+characters have a UTF-8 representation so this function cannot fail.
+
+
+=item $string = decode_utf8($octets [, CHECK]);
+
+equivalent to C<$string = decode("utf8", $octets [, CHECK])>.
+The sequence of octets represented by
+$octets is decoded from UTF-8 into a sequence of logical
+characters. Not all sequences of octets form valid UTF-8 encodings, so
+it is possible for this call to fail. For CHECK, see
+L</"Handling Malformed Data">.
+
+=back
+
+=head2 Listing available encodings
+
+ use Encode;
+ @list = Encode->encodings();
+
+Returns a list of the canonical names of the available encodings that
+are loaded. To get a list of all available encodings including the
+ones that are not loaded yet, say
+
+ @all_encodings = Encode->encodings(":all");
+
+Or you can give the name of a specific module.
+
+ @with_jp = Encode->encodings("Encode::JP");
+
+When "::" is not in the name, "Encode::" is assumed.
+
+ @ebcdic = Encode->encodings("EBCDIC");
+
+To find out in detail which encodings are supported by this package,
+see L<Encode::Supported>.
+
+=head2 Defining Aliases
+
+To add a new alias to a given encoding, use:
+
+ use Encode;
+ use Encode::Alias;
+ define_alias(newName => ENCODING);
+
+After that, newName can be used as an alias for ENCODING.
+ENCODING may be either the name of an encoding or an
+I<encoding object>
+
+But before you do so, make sure the alias is nonexistent with
+C<resolve_alias()>, which returns the canonical name thereof.
+i.e.
+
+ Encode::resolve_alias("latin1") eq "iso-8859-1" # true
+ Encode::resolve_alias("iso-8859-12") # false; nonexistent
+ Encode::resolve_alias($name) eq $name # true if $name is canonical
+
+resolve_alias() does not need C<use Encode::Alias>; it can be
+exported via C<use Encode qw(resolve_alias)>.
+
+See L<Encode::Alias> for details.
+
+=head1 Encoding via PerlIO
+
+If your perl supports I<PerlIO> (which is the default), you can use a PerlIO layer to decode
+and encode directly via a filehandle. The following two examples
+are totally identical in their functionality.
+
+ # via PerlIO
+ open my $in, "<:encoding(shiftjis)", $infile or die;
+ open my $out, ">:encoding(euc-jp)", $outfile or die;
+ while(<$in>){ print $out $_; }
+
+ # via from_to
+ open my $in, "<", $infile or die;
+ open my $out, ">", $outfile or die;
+ while(<$in>){
+ from_to($_, "shiftjis", "euc-jp", 1);
+ print $out $_;
+ }
+
+Unfortunately, it may be that encodings are PerlIO-savvy. You can check
+if your encoding is supported by PerlIO by calling the C<perlio_ok>
+method.
+
+ Encode::perlio_ok("hz"); # False
+ find_encoding("euc-cn")->perlio_ok; # True where PerlIO is available
+
+ use Encode qw(perlio_ok); # exported upon request
+ perlio_ok("euc-jp")
+
+Fortunately, all encodings that come with Encode core are PerlIO-savvy
+except for hz and ISO-2022-kr. For gory details, see
+L<Encode::Encoding> and L<Encode::PerlIO>.
+
+=head1 Handling Malformed Data
+
+The optional I<CHECK> argument tells Encode what to do when it
+encounters malformed data. Without CHECK, Encode::FB_DEFAULT ( == 0 )
+is assumed.
+
+As of version 2.12 Encode supports coderef values for CHECK. See below.
+
+=over 2
+
+=item B<NOTE:> Not all encoding support this feature
+
+Some encodings ignore I<CHECK> argument. For example,
+L<Encode::Unicode> ignores I<CHECK> and it always croaks on error.
+
+=back
+
+Now here is the list of I<CHECK> values available
+
+=over 2
+
+=item I<CHECK> = Encode::FB_DEFAULT ( == 0)
+
+If I<CHECK> is 0, (en|de)code will put a I<substitution character> in
+place of a malformed character. When you encode, E<lt>subcharE<gt>
+will be used. When you decode the code point C<0xFFFD> is used. If
+the data is supposed to be UTF-8, an optional lexical warning
+(category utf8) is given.
+
+=item I<CHECK> = Encode::FB_CROAK ( == 1)
+
+If I<CHECK> is 1, methods will die on error immediately with an error
+message. Therefore, when I<CHECK> is set to 1, you should trap the
+error with eval{} unless you really want to let it die.
+
+=item I<CHECK> = Encode::FB_QUIET
+
+If I<CHECK> is set to Encode::FB_QUIET, (en|de)code will immediately
+return the portion of the data that has been processed so far when an
+error occurs. The data argument will be overwritten with everything
+after that point (that is, the unprocessed part of data). This is
+handy when you have to call decode repeatedly in the case where your
+source data may contain partial multi-byte character sequences,
+(i.e. you are reading with a fixed-width buffer). Here is a sample
+code that does exactly this:
+
+ my $buffer = ''; my $string = '';
+ while(read $fh, $buffer, 256, length($buffer)){
+ $string .= decode($encoding, $buffer, Encode::FB_QUIET);
+ # $buffer now contains the unprocessed partial character
+ }
+
+=item I<CHECK> = Encode::FB_WARN
+
+This is the same as above, except that it warns on error. Handy when
+you are debugging the mode above.
+
+=item perlqq mode (I<CHECK> = Encode::FB_PERLQQ)
+
+=item HTML charref mode (I<CHECK> = Encode::FB_HTMLCREF)
+
+=item XML charref mode (I<CHECK> = Encode::FB_XMLCREF)
+
+For encodings that are implemented by Encode::XS, CHECK ==
+Encode::FB_PERLQQ turns (en|de)code into C<perlqq> fallback mode.
+
+When you decode, C<\xI<HH>> will be inserted for a malformed character,
+where I<HH> is the hex representation of the octet that could not be
+decoded to utf8. And when you encode, C<\x{I<HHHH>}> will be inserted,
+where I<HHHH> is the Unicode ID of the character that cannot be found
+in the character repertoire of the encoding.
+
+HTML/XML character reference modes are about the same, in place of
+C<\x{I<HHHH>}>, HTML uses C<&#I<NNN>;> where I<NNN> is a decimal number and
+XML uses C<&#xI<HHHH>;> where I<HHHH> is the hexadecimal number.
+
+In Encode 2.10 or later, C<LEAVE_SRC> is also implied.
+
+=item The bitmask
+
+These modes are actually set via a bitmask. Here is how the FB_XX
+constants are laid out. You can import the FB_XX constants via
+C<use Encode qw(:fallbacks)>; you can import the generic bitmask
+constants via C<use Encode qw(:fallback_all)>.
+
+ FB_DEFAULT FB_CROAK FB_QUIET FB_WARN FB_PERLQQ
+ DIE_ON_ERR 0x0001 X
+ WARN_ON_ERR 0x0002 X
+ RETURN_ON_ERR 0x0004 X X
+ LEAVE_SRC 0x0008 X
+ PERLQQ 0x0100 X
+ HTMLCREF 0x0200
+ XMLCREF 0x0400
+
+=back
+
+=head2 coderef for CHECK
+
+As of Encode 2.12 CHECK can also be a code reference which takes the
+ord value of unmapped caharacter as an argument and returns a string
+that represents the fallback character. For instance,
+
+ $ascii = encode("ascii", $utf8, sub{ sprintf "<U+%04X>", shift });
+
+Acts like FB_PERLQQ but E<lt>U+I<XXXX>E<gt> is used instead of
+\x{I<XXXX>}.
+
+=head1 Defining Encodings
+
+To define a new encoding, use:
+
+ use Encode qw(define_encoding);
+ define_encoding($object, 'canonicalName' [, alias...]);
+
+I<canonicalName> will be associated with I<$object>. The object
+should provide the interface described in L<Encode::Encoding>.
+If more than two arguments are provided then additional
+arguments are taken as aliases for I<$object>.
+
+See L<Encode::Encoding> for more details.
+
+=head1 The UTF-8 flag
+
+Before the introduction of utf8 support in perl, The C<eq> operator
+just compared the strings represented by two scalars. Beginning with
+perl 5.8, C<eq> compares two strings with simultaneous consideration
+of I<the utf8 flag>. To explain why we made it so, I will quote page
+402 of C<Programming Perl, 3rd ed.>
+
+=over 2
+
+=item Goal #1:
+
+Old byte-oriented programs should not spontaneously break on the old
+byte-oriented data they used to work on.
+
+=item Goal #2:
+
+Old byte-oriented programs should magically start working on the new
+character-oriented data when appropriate.
+
+=item Goal #3:
+
+Programs should run just as fast in the new character-oriented mode
+as in the old byte-oriented mode.
+
+=item Goal #4:
+
+Perl should remain one language, rather than forking into a
+byte-oriented Perl and a character-oriented Perl.
+
+=back
+
+Back when C<Programming Perl, 3rd ed.> was written, not even Perl 5.6.0
+was born and many features documented in the book remained
+unimplemented for a long time. Perl 5.8 corrected this and the introduction
+of the UTF-8 flag is one of them. You can think of this perl notion as of a
+byte-oriented mode (utf8 flag off) and a character-oriented mode (utf8
+flag on).
+
+Here is how Encode takes care of the utf8 flag.
+
+=over 2
+
+=item *
+
+When you encode, the resulting utf8 flag is always off.
+
+=item *
+
+When you decode, the resulting utf8 flag is on unless you can
+unambiguously represent data. Here is the definition of
+dis-ambiguity.
+
+After C<$utf8 = decode('foo', $octet);>,
+
+ When $octet is... The utf8 flag in $utf8 is
+ ---------------------------------------------
+ In ASCII only (or EBCDIC only) OFF
+ In ISO-8859-1 ON
+ In any other Encoding ON
+ ---------------------------------------------
+
+As you see, there is one exception, In ASCII. That way you can assume
+Goal #1. And with Encode Goal #2 is assumed but you still have to be
+careful in such cases mentioned in B<CAVEAT> paragraphs.
+
+This utf8 flag is not visible in perl scripts, exactly for the same
+reason you cannot (or you I<don't have to>) see if a scalar contains a
+string, integer, or floating point number. But you can still peek
+and poke these if you will. See the section below.
+
+=back
+
+=head2 Messing with Perl's Internals
+
+The following API uses parts of Perl's internals in the current
+implementation. As such, they are efficient but may change.
+
+=over 2
+
+=item is_utf8(STRING [, CHECK])
+
+[INTERNAL] Tests whether the UTF-8 flag is turned on in the STRING.
+If CHECK is true, also checks the data in STRING for being well-formed
+UTF-8. Returns true if successful, false otherwise.
+
+As of perl 5.8.1, L<utf8> also has utf8::is_utf8().
+
+=item _utf8_on(STRING)
+
+[INTERNAL] Turns on the UTF-8 flag in STRING. The data in STRING is
+B<not> checked for being well-formed UTF-8. Do not use unless you
+B<know> that the STRING is well-formed UTF-8. Returns the previous
+state of the UTF-8 flag (so please don't treat the return value as
+indicating success or failure), or C<undef> if STRING is not a string.
+
+=item _utf8_off(STRING)
+
+[INTERNAL] Turns off the UTF-8 flag in STRING. Do not use frivolously.
+Returns the previous state of the UTF-8 flag (so please don't treat the
+return value as indicating success or failure), or C<undef> if STRING is
+not a string.
+
+=back
+
+=head1 UTF-8 vs. utf8
+
+ ....We now view strings not as sequences of bytes, but as sequences
+ of numbers in the range 0 .. 2**32-1 (or in the case of 64-bit
+ computers, 0 .. 2**64-1) -- Programming Perl, 3rd ed.
+
+That has been the perl's notion of UTF-8 but official UTF-8 is more
+strict; Its ranges is much narrower (0 .. 10FFFF), some sequences are
+not allowed (i.e. Those used in the surrogate pair, 0xFFFE, et al).
+
+Now that is overruled by Larry Wall himself.
+
+ From: Larry Wall <larry@wall.org>
+ Date: December 04, 2004 11:51:58 JST
+ To: perl-unicode@perl.org
+ Subject: Re: Make Encode.pm support the real UTF-8
+ Message-Id: <20041204025158.GA28754@wall.org>
+
+ On Fri, Dec 03, 2004 at 10:12:12PM +0000, Tim Bunce wrote:
+ : I've no problem with 'utf8' being perl's unrestricted uft8 encoding,
+ : but "UTF-8" is the name of the standard and should give the
+ : corresponding behaviour.
+
+ For what it's worth, that's how I've always kept them straight in my
+ head.
+
+ Also for what it's worth, Perl 6 will mostly default to strict but
+ make it easy to switch back to lax.
+
+ Larry
+
+Do you copy? As of Perl 5.8.7, B<UTF-8> means strict, official UTF-8
+while B<utf8> means liberal, lax, version thereof. And Encode version
+2.10 or later thus groks the difference between C<UTF-8> and C"utf8".
+
+ encode("utf8", "\x{FFFF_FFFF}", 1); # okay
+ encode("UTF-8", "\x{FFFF_FFFF}", 1); # croaks
+
+C<UTF-8> in Encode is actually a canonical name for C<utf-8-strict>.
+Yes, the hyphen between "UTF" and "8" is important. Without it Encode
+goes "liberal"
+
+ find_encoding("UTF-8")->name # is 'utf-8-strict'
+ find_encoding("utf-8")->name # ditto. names are case insensitive
+ find_encoding("utf8")->name # ditto. "_" are treated as "-"
+ find_encoding("UTF8")->name # is 'utf8'.
+
+
+=head1 SEE ALSO
+
+L<Encode::Encoding>,
+L<Encode::Supported>,
+L<Encode::PerlIO>,
+L<encoding>,
+L<perlebcdic>,
+L<perlfunc/open>,
+L<perlunicode>,
+L<utf8>,
+the Perl Unicode Mailing List E<lt>perl-unicode@perl.orgE<gt>
+
+=head1 MAINTAINER
+
+This project was originated by Nick Ing-Simmons and later maintained
+by Dan Kogai E<lt>dankogai@dan.co.jpE<gt>. See AUTHORS for a full
+list of people involved. For any questions, use
+E<lt>perl-unicode@perl.orgE<gt> so we can all share.
+
+=cut
diff --git a/Master/tlpkg/installer/perllib/Encode/Alias.pm b/Master/tlpkg/installer/perllib/Encode/Alias.pm
new file mode 100644
index 00000000000..c0bbf69f469
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/Encode/Alias.pm
@@ -0,0 +1,341 @@
+package Encode::Alias;
+use strict;
+no warnings 'redefine';
+use Encode;
+our $VERSION = do { my @r = (q$Revision: 2.4 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
+sub DEBUG () { 0 }
+
+use base qw(Exporter);
+
+# Public, encouraged API is exported by default
+
+our @EXPORT =
+ qw (
+ define_alias
+ find_alias
+ );
+
+our @Alias; # ordered matching list
+our %Alias; # cached known aliases
+
+sub find_alias{
+ my $class = shift;
+ my $find = shift;
+ unless (exists $Alias{$find}) {
+ $Alias{$find} = undef; # Recursion guard
+ for (my $i=0; $i < @Alias; $i += 2){
+ my $alias = $Alias[$i];
+ my $val = $Alias[$i+1];
+ my $new;
+ if (ref($alias) eq 'Regexp' && $find =~ $alias){
+ DEBUG and warn "eval $val";
+ $new = eval $val;
+ DEBUG and $@ and warn "$val, $@";
+ }elsif (ref($alias) eq 'CODE'){
+ DEBUG and warn "$alias", "->", "($find)";
+ $new = $alias->($find);
+ }elsif (lc($find) eq lc($alias)){
+ $new = $val;
+ }
+ if (defined($new)){
+ next if $new eq $find; # avoid (direct) recursion on bugs
+ DEBUG and warn "$alias, $new";
+ my $enc = (ref($new)) ? $new : Encode::find_encoding($new);
+ if ($enc){
+ $Alias{$find} = $enc;
+ last;
+ }
+ }
+ }
+ # case insensitive search when canonical is not in all lowercase
+ # RT ticket #7835
+ unless ($Alias{$find}){
+ my $lcfind = lc($find);
+ for my $name (keys %Encode::Encoding, keys %Encode::ExtModule){
+ $lcfind eq lc($name) or next;
+ $Alias{$find} = Encode::find_encoding($name);
+ DEBUG and warn "$find => $name";
+ }
+ }
+ }
+ if (DEBUG){
+ my $name;
+ if (my $e = $Alias{$find}){
+ $name = $e->name;
+ }else{
+ $name = "";
+ }
+ warn "find_alias($class, $find)->name = $name";
+ }
+ return $Alias{$find};
+}
+
+sub define_alias{
+ while (@_){
+ my ($alias,$name) = splice(@_,0,2);
+ unshift(@Alias, $alias => $name); # newer one has precedence
+ if (ref($alias)){
+ # clear %Alias cache to allow overrides
+ my @a = keys %Alias;
+ for my $k (@a){
+ if (ref($alias) eq 'Regexp' && $k =~ $alias){
+ DEBUG and warn "delete \$Alias\{$k\}";
+ delete $Alias{$k};
+ }
+ elsif (ref($alias) eq 'CODE'){
+ DEBUG and warn "delete \$Alias\{$k\}";
+ delete $Alias{$alias->($name)};
+ }
+ }
+ }else{
+ DEBUG and warn "delete \$Alias\{$alias\}";
+ delete $Alias{$alias};
+ }
+ }
+}
+
+# Allow latin-1 style names as well
+# 0 1 2 3 4 5 6 7 8 9 10
+our @Latin2iso = ( 0, 1, 2, 3, 4, 9, 10, 13, 14, 15, 16 );
+# Allow winlatin1 style names as well
+our %Winlatin2cp = (
+ 'latin1' => 1252,
+ 'latin2' => 1250,
+ 'cyrillic' => 1251,
+ 'greek' => 1253,
+ 'turkish' => 1254,
+ 'hebrew' => 1255,
+ 'arabic' => 1256,
+ 'baltic' => 1257,
+ 'vietnamese' => 1258,
+ );
+
+init_aliases();
+
+sub undef_aliases{
+ @Alias = ();
+ %Alias = ();
+}
+
+sub init_aliases
+{
+ undef_aliases();
+ # Try all-lower-case version should all else fails
+ define_alias( qr/^(.*)$/ => '"\L$1"' );
+
+ # UTF/UCS stuff
+ define_alias( qr/^UTF-?7$/i => '"UTF-7"');
+ define_alias( qr/^UCS-?2-?LE$/i => '"UCS-2LE"' );
+ define_alias( qr/^UCS-?2-?(BE)?$/i => '"UCS-2BE"',
+ qr/^UCS-?4-?(BE|LE)?$/i => 'uc("UTF-32$1")',
+ qr/^iso-10646-1$/i => '"UCS-2BE"' );
+ define_alias( qr/^UTF-?(16|32)-?BE$/i => '"UTF-$1BE"',
+ qr/^UTF-?(16|32)-?LE$/i => '"UTF-$1LE"',
+ qr/^UTF-?(16|32)$/i => '"UTF-$1"',
+ );
+ # ASCII
+ define_alias(qr/^(?:US-?)ascii$/i => '"ascii"');
+ define_alias('C' => 'ascii');
+ define_alias(qr/\bISO[-_]?646[-_]?US$/i => '"ascii"');
+ # Allow variants of iso-8859-1 etc.
+ define_alias( qr/\biso[-_]?(\d+)[-_](\d+)$/i => '"iso-$1-$2"' );
+
+ # At least HP-UX has these.
+ define_alias( qr/\biso8859(\d+)$/i => '"iso-8859-$1"' );
+
+ # More HP stuff.
+ define_alias( qr/\b(?:hp-)?(arabic|greek|hebrew|kana|roman|thai|turkish)8$/i => '"${1}8"' );
+
+ # The Official name of ASCII.
+ define_alias( qr/\bANSI[-_]?X3\.4[-_]?1968$/i => '"ascii"' );
+
+ # This is a font issue, not an encoding issue.
+ # (The currency symbol of the Latin 1 upper half
+ # has been redefined as the euro symbol.)
+ define_alias( qr/^(.+)\@euro$/i => '"$1"' );
+
+ define_alias( qr/\b(?:iso[-_]?)?latin[-_]?(\d+)$/i
+ => 'defined $Encode::Alias::Latin2iso[$1] ? "iso-8859-$Encode::Alias::Latin2iso[$1]" : undef' );
+
+ define_alias( qr/\bwin(latin[12]|cyrillic|baltic|greek|turkish|
+ hebrew|arabic|baltic|vietnamese)$/ix =>
+ '"cp" . $Encode::Alias::Winlatin2cp{lc($1)}' );
+
+ # Common names for non-latin preferred MIME names
+ define_alias( 'ascii' => 'US-ascii',
+ 'cyrillic' => 'iso-8859-5',
+ 'arabic' => 'iso-8859-6',
+ 'greek' => 'iso-8859-7',
+ 'hebrew' => 'iso-8859-8',
+ 'thai' => 'iso-8859-11',
+ 'tis620' => 'iso-8859-11',
+ );
+
+ # At least AIX has IBM-NNN (surprisingly...) instead of cpNNN.
+ # And Microsoft has their own naming (again, surprisingly).
+ # And windows-* is registered in IANA!
+ define_alias( qr/\b(?:cp|ibm|ms|windows)[-_ ]?(\d{2,4})$/i => '"cp$1"');
+
+ # Sometimes seen with a leading zero.
+ # define_alias( qr/\bcp037\b/i => '"cp37"');
+
+ # Mac Mappings
+ # predefined in *.ucm; unneeded
+ # define_alias( qr/\bmacIcelandic$/i => '"macIceland"');
+ define_alias( qr/^mac_(.*)$/i => '"mac$1"');
+ # Ououououou. gone. They are differente!
+ # define_alias( qr/\bmacRomanian$/i => '"macRumanian"');
+
+ # Standardize on the dashed versions.
+ define_alias( qr/\bkoi8[\s\-_]*([ru])$/i => '"koi8-$1"' );
+
+ unless ($Encode::ON_EBCDIC){
+ # for Encode::CN
+ define_alias( qr/\beuc.*cn$/i => '"euc-cn"' );
+ define_alias( qr/\bcn.*euc$/i => '"euc-cn"' );
+ # define_alias( qr/\bGB[- ]?(\d+)$/i => '"euc-cn"' )
+ # CP936 doesn't have vendor-addon for GBK, so they're identical.
+ define_alias( qr/^gbk$/i => '"cp936"');
+ # This fixes gb2312 vs. euc-cn confusion, practically
+ define_alias( qr/\bGB[-_ ]?2312(?!-?raw)/i => '"euc-cn"' );
+ # for Encode::JP
+ define_alias( qr/\bjis$/i => '"7bit-jis"' );
+ define_alias( qr/\beuc.*jp$/i => '"euc-jp"' );
+ define_alias( qr/\bjp.*euc$/i => '"euc-jp"' );
+ define_alias( qr/\bujis$/i => '"euc-jp"' );
+ define_alias( qr/\bshift.*jis$/i => '"shiftjis"' );
+ define_alias( qr/\bsjis$/i => '"shiftjis"' );
+ define_alias( qr/\bwindows-31j$/i => '"cp932"' );
+ # for Encode::KR
+ define_alias( qr/\beuc.*kr$/i => '"euc-kr"' );
+ define_alias( qr/\bkr.*euc$/i => '"euc-kr"' );
+ # This fixes ksc5601 vs. euc-kr confusion, practically
+ define_alias( qr/(?:x-)?uhc$/i => '"cp949"' );
+ define_alias( qr/(?:x-)?windows-949$/i => '"cp949"' );
+ define_alias( qr/\bks_c_5601-1987$/i => '"cp949"' );
+ # for Encode::TW
+ define_alias( qr/\bbig-?5$/i => '"big5-eten"' );
+ define_alias( qr/\bbig5-?et(?:en)?$/i => '"big5-eten"' );
+ define_alias( qr/\btca[-_]?big5$/i => '"big5-eten"' );
+ define_alias( qr/\bbig5-?hk(?:scs)?$/i => '"big5-hkscs"' );
+ define_alias( qr/\bhk(?:scs)?[-_]?big5$/i => '"big5-hkscs"' );
+ }
+ # utf8 is blessed :)
+ define_alias( qr/^UTF-8$/i => '"utf-8-strict"');
+ # At last, Map white space and _ to '-'
+ define_alias( qr/^(\S+)[\s_]+(.*)$/i => '"$1-$2"' );
+}
+
+1;
+__END__
+
+# TODO: HP-UX '8' encodings arabic8 greek8 hebrew8 kana8 thai8 turkish8
+# TODO: HP-UX '15' encodings japanese15 korean15 roi15
+# TODO: Cyrillic encoding ISO-IR-111 (useful?)
+# TODO: Armenian encoding ARMSCII-8
+# TODO: Hebrew encoding ISO-8859-8-1
+# TODO: Thai encoding TCVN
+# TODO: Vietnamese encodings VPS
+# TODO: Mac Asian+African encodings: Arabic Armenian Bengali Burmese
+# ChineseSimp ChineseTrad Devanagari Ethiopic ExtArabic
+# Farsi Georgian Gujarati Gurmukhi Hebrew Japanese
+# Kannada Khmer Korean Laotian Malayalam Mongolian
+# Oriya Sinhalese Symbol Tamil Telugu Tibetan Vietnamese
+
+=head1 NAME
+
+Encode::Alias - alias definitions to encodings
+
+=head1 SYNOPSIS
+
+ use Encode;
+ use Encode::Alias;
+ define_alias( newName => ENCODING);
+
+=head1 DESCRIPTION
+
+Allows newName to be used as an alias for ENCODING. ENCODING may be
+either the name of an encoding or an encoding object (as described
+in L<Encode>).
+
+Currently I<newName> can be specified in the following ways:
+
+=over 4
+
+=item As a simple string.
+
+=item As a qr// compiled regular expression, e.g.:
+
+ define_alias( qr/^iso8859-(\d+)$/i => '"iso-8859-$1"' );
+
+In this case, if I<ENCODING> is not a reference, it is C<eval>-ed
+in order to allow C<$1> etc. to be substituted. The example is one
+way to alias names as used in X11 fonts to the MIME names for the
+iso-8859-* family. Note the double quotes inside the single quotes.
+
+(or, you don't have to do this yourself because this example is predefined)
+
+If you are using a regex here, you have to use the quotes as shown or
+it won't work. Also note that regex handling is tricky even for the
+experienced. Use this feature with caution.
+
+=item As a code reference, e.g.:
+
+ define_alias( sub {shift =~ /^iso8859-(\d+)$/i ? "iso-8859-$1" : undef } );
+
+The same effect as the example above in a different way. The coderef
+takes the alias name as an argument and returns a canonical name on
+success or undef if not. Note the second argument is not required.
+Use this with even more caution than the regex version.
+
+=back
+
+=head3 Changes in code reference aliasing
+
+As of Encode 1.87, the older form
+
+ define_alias( sub { return /^iso8859-(\d+)$/i ? "iso-8859-$1" : undef } );
+
+no longer works.
+
+Encode up to 1.86 internally used "local $_" to implement ths older
+form. But consider the code below;
+
+ use Encode;
+ $_ = "eeeee" ;
+ while (/(e)/g) {
+ my $utf = decode('aliased-encoding-name', $1);
+ print "position:",pos,"\n";
+ }
+
+Prior to Encode 1.86 this fails because of "local $_".
+
+=head2 Alias overloading
+
+You can override predefined aliases by simply applying define_alias().
+The new alias is always evaluated first, and when necessary,
+define_alias() flushes the internal cache to make the new definition
+available.
+
+ # redirect SHIFT_JIS to MS/IBM Code Page 932, which is a
+ # superset of SHIFT_JIS
+
+ define_alias( qr/shift.*jis$/i => '"cp932"' );
+ define_alias( qr/sjis$/i => '"cp932"' );
+
+If you want to zap all predefined aliases, you can use
+
+ Encode::Alias->undef_aliases;
+
+to do so. And
+
+ Encode::Alias->init_aliases;
+
+gets the factory settings back.
+
+=head1 SEE ALSO
+
+L<Encode>, L<Encode::Supported>
+
+=cut
+
diff --git a/Master/tlpkg/installer/perllib/Encode/Byte.pm b/Master/tlpkg/installer/perllib/Encode/Byte.pm
new file mode 100644
index 00000000000..d40c1c3d9d1
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/Encode/Byte.pm
@@ -0,0 +1,119 @@
+package Encode::Byte;
+use Encode;
+our $VERSION = do { my @r = (q$Revision: 2.0 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
+
+use XSLoader;
+XSLoader::load(__PACKAGE__,$VERSION);
+
+1;
+__END__
+
+=head1 NAME
+
+Encode::Byte - Single Byte Encodings
+
+=head1 SYNOPSIS
+
+ use Encode qw/encode decode/;
+ $greek = encode("iso-8859-7", $utf8); # loads Encode::Byte implicitly
+ $utf8 = decode("iso-8859-7", $greek); # ditto
+
+=head1 ABSTRACT
+
+This module implements various single byte encodings. For most cases it uses
+\x80-\xff (upper half) to map non-ASCII characters. Encodings
+supported are as follows.
+
+ Canonical Alias Description
+ --------------------------------------------------------------------
+ # ISO 8859 series
+ (iso-8859-1 is in built-in)
+ iso-8859-2 latin2 [ISO]
+ iso-8859-3 latin3 [ISO]
+ iso-8859-4 latin4 [ISO]
+ iso-8859-5 [ISO]
+ iso-8859-6 [ISO]
+ iso-8859-7 [ISO]
+ iso-8859-8 [ISO]
+ iso-8859-9 latin5 [ISO]
+ iso-8859-10 latin6 [ISO]
+ iso-8859-11
+ (iso-8859-12 is nonexistent)
+ iso-8859-13 latin7 [ISO]
+ iso-8859-14 latin8 [ISO]
+ iso-8859-15 latin9 [ISO]
+ iso-8859-16 latin10 [ISO]
+
+ # Cyrillic
+ koi8-f
+ koi8-r cp878 [RFC1489]
+ koi8-u [RFC2319]
+
+ # Vietnamese
+ viscii
+
+ # all cp* are also available as ibm-*, ms-*, and windows-*
+ # also see L<http://msdn.microsoft.com/workshop/author/dhtml/reference/charsets/charset4.asp>
+
+ cp424
+ cp437
+ cp737
+ cp775
+ cp850
+ cp852
+ cp855
+ cp856
+ cp857
+ cp860
+ cp861
+ cp862
+ cp863
+ cp864
+ cp865
+ cp866
+ cp869
+ cp874
+ cp1006
+ cp1250 WinLatin2
+ cp1251 WinCyrillic
+ cp1252 WinLatin1
+ cp1253 WinGreek
+ cp1254 WinTurkish
+ cp1255 WinHebrew
+ cp1256 WinArabic
+ cp1257 WinBaltic
+ cp1258 WinVietnamese
+
+ # Macintosh
+ # Also see L<http://developer.apple.com/technotes/tn/tn1150.html>
+ MacArabic
+ MacCentralEurRoman
+ MacCroatian
+ MacCyrillic
+ MacFarsi
+ MacGreek
+ MacHebrew
+ MacIcelandic
+ MacRoman
+ MacRomanian
+ MacRumanian
+ MacSami
+ MacThai
+ MacTurkish
+ MacUkrainian
+
+ # More vendor encodings
+ AdobeStandardEncoding
+ nextstep
+ gsm0338 # used in GSM handsets
+ hp-roman8
+
+=head1 DESCRIPTION
+
+To find how to use this module in detail, see L<Encode>.
+
+=head1 SEE ALSO
+
+L<Encode>
+
+=cut
diff --git a/Master/tlpkg/installer/perllib/Encode/Config.pm b/Master/tlpkg/installer/perllib/Encode/Config.pm
new file mode 100644
index 00000000000..d69b92d8248
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/Encode/Config.pm
@@ -0,0 +1,166 @@
+#
+# Demand-load module list
+#
+package Encode::Config;
+our $VERSION = do { my @r = (q$Revision: 2.1 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
+
+use strict;
+
+our %ExtModule =
+ (
+ # Encode::Byte
+ #iso-8859-1 is in Encode.pm itself
+ 'iso-8859-2' => 'Encode::Byte',
+ 'iso-8859-3' => 'Encode::Byte',
+ 'iso-8859-4' => 'Encode::Byte',
+ 'iso-8859-5' => 'Encode::Byte',
+ 'iso-8859-6' => 'Encode::Byte',
+ 'iso-8859-7' => 'Encode::Byte',
+ 'iso-8859-8' => 'Encode::Byte',
+ 'iso-8859-9' => 'Encode::Byte',
+ 'iso-8859-10' => 'Encode::Byte',
+ 'iso-8859-11' => 'Encode::Byte',
+ 'iso-8859-13' => 'Encode::Byte',
+ 'iso-8859-14' => 'Encode::Byte',
+ 'iso-8859-15' => 'Encode::Byte',
+ 'iso-8859-16' => 'Encode::Byte',
+ 'koi8-f' => 'Encode::Byte',
+ 'koi8-r' => 'Encode::Byte',
+ 'koi8-u' => 'Encode::Byte',
+ 'viscii' => 'Encode::Byte',
+ 'cp424' => 'Encode::Byte',
+ 'cp437' => 'Encode::Byte',
+ 'cp737' => 'Encode::Byte',
+ 'cp775' => 'Encode::Byte',
+ 'cp850' => 'Encode::Byte',
+ 'cp852' => 'Encode::Byte',
+ 'cp855' => 'Encode::Byte',
+ 'cp856' => 'Encode::Byte',
+ 'cp857' => 'Encode::Byte',
+ 'cp860' => 'Encode::Byte',
+ 'cp861' => 'Encode::Byte',
+ 'cp862' => 'Encode::Byte',
+ 'cp863' => 'Encode::Byte',
+ 'cp864' => 'Encode::Byte',
+ 'cp865' => 'Encode::Byte',
+ 'cp866' => 'Encode::Byte',
+ 'cp869' => 'Encode::Byte',
+ 'cp874' => 'Encode::Byte',
+ 'cp1006' => 'Encode::Byte',
+ 'cp1250' => 'Encode::Byte',
+ 'cp1251' => 'Encode::Byte',
+ 'cp1252' => 'Encode::Byte',
+ 'cp1253' => 'Encode::Byte',
+ 'cp1254' => 'Encode::Byte',
+ 'cp1255' => 'Encode::Byte',
+ 'cp1256' => 'Encode::Byte',
+ 'cp1257' => 'Encode::Byte',
+ 'cp1258' => 'Encode::Byte',
+ 'AdobeStandardEncoding' => 'Encode::Byte',
+ 'MacArabic' => 'Encode::Byte',
+ 'MacCentralEurRoman' => 'Encode::Byte',
+ 'MacCroatian' => 'Encode::Byte',
+ 'MacCyrillic' => 'Encode::Byte',
+ 'MacFarsi' => 'Encode::Byte',
+ 'MacGreek' => 'Encode::Byte',
+ 'MacHebrew' => 'Encode::Byte',
+ 'MacIcelandic' => 'Encode::Byte',
+ 'MacRoman' => 'Encode::Byte',
+ 'MacRomanian' => 'Encode::Byte',
+ 'MacRumanian' => 'Encode::Byte',
+ 'MacSami' => 'Encode::Byte',
+ 'MacThai' => 'Encode::Byte',
+ 'MacTurkish' => 'Encode::Byte',
+ 'MacUkrainian' => 'Encode::Byte',
+ 'nextstep' => 'Encode::Byte',
+ 'hp-roman8' => 'Encode::Byte',
+ 'gsm0338' => 'Encode::Byte',
+ # Encode::EBCDIC
+ 'cp37' => 'Encode::EBCDIC',
+ 'cp500' => 'Encode::EBCDIC',
+ 'cp875' => 'Encode::EBCDIC',
+ 'cp1026' => 'Encode::EBCDIC',
+ 'cp1047' => 'Encode::EBCDIC',
+ 'posix-bc' => 'Encode::EBCDIC',
+ # Encode::Symbol
+ 'dingbats' => 'Encode::Symbol',
+ 'symbol' => 'Encode::Symbol',
+ 'AdobeSymbol' => 'Encode::Symbol',
+ 'AdobeZdingbat' => 'Encode::Symbol',
+ 'MacDingbats' => 'Encode::Symbol',
+ 'MacSymbol' => 'Encode::Symbol',
+ # Encode::Unicode
+ 'UCS-2BE' => 'Encode::Unicode',
+ 'UCS-2LE' => 'Encode::Unicode',
+ 'UTF-16' => 'Encode::Unicode',
+ 'UTF-16BE' => 'Encode::Unicode',
+ 'UTF-16LE' => 'Encode::Unicode',
+ 'UTF-32' => 'Encode::Unicode',
+ 'UTF-32BE' => 'Encode::Unicode',
+ 'UTF-32LE' => 'Encode::Unicode',
+ 'UTF-7' => 'Encode::Unicode::UTF7',
+ );
+
+unless (ord("A") == 193){
+ %ExtModule =
+ (
+ %ExtModule,
+ 'euc-cn' => 'Encode::CN',
+ 'gb12345-raw' => 'Encode::CN',
+ 'gb2312-raw' => 'Encode::CN',
+ 'hz' => 'Encode::CN',
+ 'iso-ir-165' => 'Encode::CN',
+ 'cp936' => 'Encode::CN',
+ 'MacChineseSimp' => 'Encode::CN',
+
+ '7bit-jis' => 'Encode::JP',
+ 'euc-jp' => 'Encode::JP',
+ 'iso-2022-jp' => 'Encode::JP',
+ 'iso-2022-jp-1' => 'Encode::JP',
+ 'jis0201-raw' => 'Encode::JP',
+ 'jis0208-raw' => 'Encode::JP',
+ 'jis0212-raw' => 'Encode::JP',
+ 'cp932' => 'Encode::JP',
+ 'MacJapanese' => 'Encode::JP',
+ 'shiftjis' => 'Encode::JP',
+
+
+ 'euc-kr' => 'Encode::KR',
+ 'iso-2022-kr' => 'Encode::KR',
+ 'johab' => 'Encode::KR',
+ 'ksc5601-raw' => 'Encode::KR',
+ 'cp949' => 'Encode::KR',
+ 'MacKorean' => 'Encode::KR',
+
+ 'big5-eten' => 'Encode::TW',
+ 'big5-hkscs' => 'Encode::TW',
+ 'cp950' => 'Encode::TW',
+ 'MacChineseTrad' => 'Encode::TW',
+
+ #'big5plus' => 'Encode::HanExtra',
+ #'euc-tw' => 'Encode::HanExtra',
+ #'gb18030' => 'Encode::HanExtra',
+
+ 'MIME-Header' => 'Encode::MIME::Header',
+ 'MIME-B' => 'Encode::MIME::Header',
+ 'MIME-Q' => 'Encode::MIME::Header',
+
+ 'MIME-Header-ISO_2022_JP' => 'Encode::MIME::Header::ISO_2022_JP',
+ );
+}
+
+#
+# Why not export ? to keep ConfigLocal Happy!
+#
+while (my ($enc,$mod) = each %ExtModule){
+ $Encode::ExtModule{$enc} = $mod;
+}
+
+1;
+__END__
+
+=head1 NAME
+
+Encode::Config -- internally used by Encode
+
+=cut
diff --git a/Master/tlpkg/installer/perllib/Encode/Encoding.pm b/Master/tlpkg/installer/perllib/Encode/Encoding.pm
new file mode 100644
index 00000000000..06af9fb6994
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/Encode/Encoding.pm
@@ -0,0 +1,341 @@
+package Encode::Encoding;
+# Base class for classes which implement encodings
+use strict;
+our $VERSION = do { my @r = (q$Revision: 2.2 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
+
+require Encode;
+
+sub DEBUG { 0 }
+sub Define
+{
+ my $obj = shift;
+ my $canonical = shift;
+ $obj = bless { Name => $canonical },$obj unless ref $obj;
+ # warn "$canonical => $obj\n";
+ Encode::define_encoding($obj, $canonical, @_);
+}
+
+sub name { return shift->{'Name'} }
+
+# sub renew { return $_[0] }
+
+sub renew {
+ my $self = shift;
+ my $clone = bless { %$self } => ref($self);
+ $clone->{renewed}++; # so the caller can see it
+ DEBUG and warn $clone->{renewed};
+ return $clone;
+}
+
+sub renewed{ return $_[0]->{renewed} || 0 }
+
+*new_sequence = \&renew;
+
+sub needs_lines { 0 };
+
+sub perlio_ok {
+ eval{ require PerlIO::encoding };
+ return $@ ? 0 : 1;
+}
+
+# (Temporary|legacy) methods
+
+sub toUnicode { shift->decode(@_) }
+sub fromUnicode { shift->encode(@_) }
+
+#
+# Needs to be overloaded or just croak
+#
+
+sub encode {
+ require Carp;
+ my $obj = shift;
+ my $class = ref($obj) ? ref($obj) : $obj;
+ Carp::croak($class . "->encode() not defined!");
+}
+
+sub decode{
+ require Carp;
+ my $obj = shift;
+ my $class = ref($obj) ? ref($obj) : $obj;
+ Carp::croak($class . "->encode() not defined!");
+}
+
+sub DESTROY {}
+
+1;
+__END__
+
+=head1 NAME
+
+Encode::Encoding - Encode Implementation Base Class
+
+=head1 SYNOPSIS
+
+ package Encode::MyEncoding;
+ use base qw(Encode::Encoding);
+
+ __PACKAGE__->Define(qw(myCanonical myAlias));
+
+=head1 DESCRIPTION
+
+As mentioned in L<Encode>, encodings are (in the current
+implementation at least) defined as objects. The mapping of encoding
+name to object is via the C<%Encode::Encoding> hash. Though you can
+directly manipulate this hash, it is strongly encouraged to use this
+base class module and add encode() and decode() methods.
+
+=head2 Methods you should implement
+
+You are strongly encouraged to implement methods below, at least
+either encode() or decode().
+
+=over 4
+
+=item -E<gt>encode($string [,$check])
+
+MUST return the octet sequence representing I<$string>.
+
+=over 2
+
+=item *
+
+If I<$check> is true, it SHOULD modify I<$string> in place to remove
+the converted part (i.e. the whole string unless there is an error).
+If perlio_ok() is true, SHOULD becomes MUST.
+
+=item *
+
+If an error occurs, it SHOULD return the octet sequence for the
+fragment of string that has been converted and modify $string in-place
+to remove the converted part leaving it starting with the problem
+fragment. If perlio_ok() is true, SHOULD becomes MUST.
+
+=item *
+
+If I<$check> is is false then C<encode> MUST make a "best effort" to
+convert the string - for example, by using a replacement character.
+
+=back
+
+=item -E<gt>decode($octets [,$check])
+
+MUST return the string that I<$octets> represents.
+
+=over 2
+
+=item *
+
+If I<$check> is true, it SHOULD modify I<$octets> in place to remove
+the converted part (i.e. the whole sequence unless there is an
+error). If perlio_ok() is true, SHOULD becomes MUST.
+
+=item *
+
+If an error occurs, it SHOULD return the fragment of string that has
+been converted and modify $octets in-place to remove the converted
+part leaving it starting with the problem fragment. If perlio_ok() is
+true, SHOULD becomes MUST.
+
+=item *
+
+If I<$check> is false then C<decode> should make a "best effort" to
+convert the string - for example by using Unicode's "\x{FFFD}" as a
+replacement character.
+
+=back
+
+=back
+
+If you want your encoding to work with L<encoding> pragma, you should
+also implement the method below.
+
+=over 4
+
+=item -E<gt>cat_decode($destination, $octets, $offset, $terminator [,$check])
+
+MUST decode I<$octets> with I<$offset> and concatenate it to I<$destination>.
+Decoding will terminate when $terminator (a string) appears in output.
+I<$offset> will be modified to the last $octets position at end of decode.
+Returns true if $terminator appears output, else returns false.
+
+=back
+
+=head2 Other methods defined in Encode::Encodings
+
+You do not have to override methods shown below unless you have to.
+
+=over 4
+
+=item -E<gt>name
+
+Predefined As:
+
+ sub name { return shift->{'Name'} }
+
+MUST return the string representing the canonical name of the encoding.
+
+=item -E<gt>renew
+
+Predefined As:
+
+ sub renew {
+ my $self = shift;
+ my $clone = bless { %$self } => ref($self);
+ $clone->{renewed}++;
+ return $clone;
+ }
+
+This method reconstructs the encoding object if necessary. If you need
+to store the state during encoding, this is where you clone your object.
+
+PerlIO ALWAYS calls this method to make sure it has its own private
+encoding object.
+
+=item -E<gt>renewed
+
+Predefined As:
+
+ sub renewed { $_[0]->{renewed} || 0 }
+
+Tells whether the object is renewed (and how many times). Some
+modules emit C<Use of uninitialized value in null operation> warning
+unless the value is numeric so return 0 for false.
+
+=item -E<gt>perlio_ok()
+
+Predefined As:
+
+ sub perlio_ok {
+ eval{ require PerlIO::encoding };
+ return $@ ? 0 : 1;
+ }
+
+If your encoding does not support PerlIO for some reasons, just;
+
+ sub perlio_ok { 0 }
+
+=item -E<gt>needs_lines()
+
+Predefined As:
+
+ sub needs_lines { 0 };
+
+If your encoding can work with PerlIO but needs line buffering, you
+MUST define this method so it returns true. 7bit ISO-2022 encodings
+are one example that needs this. When this method is missing, false
+is assumed.
+
+=back
+
+=head2 Example: Encode::ROT13
+
+ package Encode::ROT13;
+ use strict;
+ use base qw(Encode::Encoding);
+
+ __PACKAGE__->Define('rot13');
+
+ sub encode($$;$){
+ my ($obj, $str, $chk) = @_;
+ $str =~ tr/A-Za-z/N-ZA-Mn-za-m/;
+ $_[1] = '' if $chk; # this is what in-place edit means
+ return $str;
+ }
+
+ # Jr pna or ynml yvxr guvf;
+ *decode = \&encode;
+
+ 1;
+
+=head1 Why the heck Encode API is different?
+
+It should be noted that the I<$check> behaviour is different from the
+outer public API. The logic is that the "unchecked" case is useful
+when the encoding is part of a stream which may be reporting errors
+(e.g. STDERR). In such cases, it is desirable to get everything
+through somehow without causing additional errors which obscure the
+original one. Also, the encoding is best placed to know what the
+correct replacement character is, so if that is the desired behaviour
+then letting low level code do it is the most efficient.
+
+By contrast, if I<$check> is true, the scheme above allows the
+encoding to do as much as it can and tell the layer above how much
+that was. What is lacking at present is a mechanism to report what
+went wrong. The most likely interface will be an additional method
+call to the object, or perhaps (to avoid forcing per-stream objects
+on otherwise stateless encodings) an additional parameter.
+
+It is also highly desirable that encoding classes inherit from
+C<Encode::Encoding> as a base class. This allows that class to define
+additional behaviour for all encoding objects.
+
+ package Encode::MyEncoding;
+ use base qw(Encode::Encoding);
+
+ __PACKAGE__->Define(qw(myCanonical myAlias));
+
+to create an object with C<< bless {Name => ...}, $class >>, and call
+define_encoding. They inherit their C<name> method from
+C<Encode::Encoding>.
+
+=head2 Compiled Encodings
+
+For the sake of speed and efficiency, most of the encodings are now
+supported via a I<compiled form>: XS modules generated from UCM
+files. Encode provides the enc2xs tool to achieve that. Please see
+L<enc2xs> for more details.
+
+=head1 SEE ALSO
+
+L<perlmod>, L<enc2xs>
+
+=begin future
+
+=over 4
+
+=item Scheme 1
+
+The fixup routine gets passed the remaining fragment of string being
+processed. It modifies it in place to remove bytes/characters it can
+understand and returns a string used to represent them. For example:
+
+ sub fixup {
+ my $ch = substr($_[0],0,1,'');
+ return sprintf("\x{%02X}",ord($ch);
+ }
+
+This scheme is close to how the underlying C code for Encode works,
+but gives the fixup routine very little context.
+
+=item Scheme 2
+
+The fixup routine gets passed the original string, an index into
+it of the problem area, and the output string so far. It appends
+what it wants to the output string and returns a new index into the
+original string. For example:
+
+ sub fixup {
+ # my ($s,$i,$d) = @_;
+ my $ch = substr($_[0],$_[1],1);
+ $_[2] .= sprintf("\x{%02X}",ord($ch);
+ return $_[1]+1;
+ }
+
+This scheme gives maximal control to the fixup routine but is more
+complicated to code, and may require that the internals of Encode be tweaked to
+keep the original string intact.
+
+=item Other Schemes
+
+Hybrids of the above.
+
+Multiple return values rather than in-place modifications.
+
+Index into the string could be C<pos($str)> allowing C<s/\G...//>.
+
+=back
+
+=end future
+
+=cut
diff --git a/Master/tlpkg/installer/perllib/Encode/Unicode.pm b/Master/tlpkg/installer/perllib/Encode/Unicode.pm
new file mode 100644
index 00000000000..4d0c31d82d3
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/Encode/Unicode.pm
@@ -0,0 +1,268 @@
+package Encode::Unicode;
+
+use strict;
+use warnings;
+no warnings 'redefine';
+
+our $VERSION = do { my @r = (q$Revision: 2.2 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
+
+use XSLoader;
+XSLoader::load(__PACKAGE__,$VERSION);
+
+#
+# Object Generator 8 transcoders all at once!
+#
+
+require Encode;
+
+our %BOM_Unknown = map {$_ => 1} qw(UTF-16 UTF-32);
+
+for my $name (qw(UTF-16 UTF-16BE UTF-16LE
+ UTF-32 UTF-32BE UTF-32LE
+ UCS-2BE UCS-2LE))
+{
+ my ($size, $endian, $ucs2, $mask);
+ $name =~ /^(\w+)-(\d+)(\w*)$/o;
+ if ($ucs2 = ($1 eq 'UCS')){
+ $size = 2;
+ }else{
+ $size = $2/8;
+ }
+ $endian = ($3 eq 'BE') ? 'n' : ($3 eq 'LE') ? 'v' : '' ;
+ $size == 4 and $endian = uc($endian);
+
+ $Encode::Encoding{$name} =
+ bless {
+ Name => $name,
+ size => $size,
+ endian => $endian,
+ ucs2 => $ucs2,
+ } => __PACKAGE__;
+}
+
+use base qw(Encode::Encoding);
+
+sub renew {
+ my $self = shift;
+ $BOM_Unknown{$self->name} or return $self;
+ my $clone = bless { %$self } => ref($self);
+ $clone->{renewed}++; # so the caller knows it is renewed.
+ return $clone;
+}
+
+# There used to be a perl implemntation of (en|de)code but with
+# XS version is ripe, perl version is zapped for optimal speed
+
+*decode = \&decode_xs;
+*encode = \&encode_xs;
+
+1;
+__END__
+
+=head1 NAME
+
+Encode::Unicode -- Various Unicode Transformation Formats
+
+=cut
+
+=head1 SYNOPSIS
+
+ use Encode qw/encode decode/;
+ $ucs2 = encode("UCS-2BE", $utf8);
+ $utf8 = decode("UCS-2BE", $ucs2);
+
+=head1 ABSTRACT
+
+This module implements all Character Encoding Schemes of Unicode that
+are officially documented by Unicode Consortium (except, of course,
+for UTF-8, which is a native format in perl).
+
+=over 4
+
+=item L<http://www.unicode.org/glossary/> says:
+
+I<Character Encoding Scheme> A character encoding form plus byte
+serialization. There are Seven character encoding schemes in Unicode:
+UTF-8, UTF-16, UTF-16BE, UTF-16LE, UTF-32 (UCS-4), UTF-32BE (UCS-4BE) and
+UTF-32LE (UCS-4LE), and UTF-7.
+
+Since UTF-7 is a 7-bit (re)encoded version of UTF-16BE, It is not part of
+Unicode's Character Encoding Scheme. It is separately implemented in
+Encode::Unicode::UTF7. For details see L<Encode::Unicode::UTF7>.
+
+=item Quick Reference
+
+ Decodes from ord(N) Encodes chr(N) to...
+ octet/char BOM S.P d800-dfff ord > 0xffff \x{1abcd} ==
+ ---------------+-----------------+------------------------------
+ UCS-2BE 2 N N is bogus Not Available
+ UCS-2LE 2 N N bogus Not Available
+ UTF-16 2/4 Y Y is S.P S.P BE/LE
+ UTF-16BE 2/4 N Y S.P S.P 0xd82a,0xdfcd
+ UTF-16LE 2 N Y S.P S.P 0x2ad8,0xcddf
+ UTF-32 4 Y - is bogus As is BE/LE
+ UTF-32BE 4 N - bogus As is 0x0001abcd
+ UTF-32LE 4 N - bogus As is 0xcdab0100
+ UTF-8 1-4 - - bogus >= 4 octets \xf0\x9a\af\8d
+ ---------------+-----------------+------------------------------
+
+=back
+
+=head1 Size, Endianness, and BOM
+
+You can categorize these CES by 3 criteria: size of each character,
+endianness, and Byte Order Mark.
+
+=head2 by size
+
+UCS-2 is a fixed-length encoding with each character taking 16 bits.
+It B<does not> support I<surrogate pairs>. When a surrogate pair
+is encountered during decode(), its place is filled with \x{FFFD}
+if I<CHECK> is 0, or the routine croaks if I<CHECK> is 1. When a
+character whose ord value is larger than 0xFFFF is encountered,
+its place is filled with \x{FFFD} if I<CHECK> is 0, or the routine
+croaks if I<CHECK> is 1.
+
+UTF-16 is almost the same as UCS-2 but it supports I<surrogate pairs>.
+When it encounters a high surrogate (0xD800-0xDBFF), it fetches the
+following low surrogate (0xDC00-0xDFFF) and C<desurrogate>s them to
+form a character. Bogus surrogates result in death. When \x{10000}
+or above is encountered during encode(), it C<ensurrogate>s them and
+pushes the surrogate pair to the output stream.
+
+UTF-32 (UCS-4) is a fixed-length encoding with each character taking 32 bits.
+Since it is 32-bit, there is no need for I<surrogate pairs>.
+
+=head2 by endianness
+
+The first (and now failed) goal of Unicode was to map all character
+repertoires into a fixed-length integer so that programmers are happy.
+Since each character is either a I<short> or I<long> in C, you have to
+pay attention to the endianness of each platform when you pass data
+to one another.
+
+Anything marked as BE is Big Endian (or network byte order) and LE is
+Little Endian (aka VAX byte order). For anything not marked either
+BE or LE, a character called Byte Order Mark (BOM) indicating the
+endianness is prepended to the string.
+
+CAVEAT: Though BOM in utf8 (\xEF\xBB\xBF) is valid, it is meaningless
+and as of this writing Encode suite just leave it as is (\x{FeFF}).
+
+=over 4
+
+=item BOM as integer when fetched in network byte order
+
+ 16 32 bits/char
+ -------------------------
+ BE 0xFeFF 0x0000FeFF
+ LE 0xFFeF 0xFFFe0000
+ -------------------------
+
+=back
+
+This modules handles the BOM as follows.
+
+=over 4
+
+=item *
+
+When BE or LE is explicitly stated as the name of encoding, BOM is
+simply treated as a normal character (ZERO WIDTH NO-BREAK SPACE).
+
+=item *
+
+When BE or LE is omitted during decode(), it checks if BOM is at the
+beginning of the string; if one is found, the endianness is set to
+what the BOM says. If no BOM is found, the routine dies.
+
+=item *
+
+When BE or LE is omitted during encode(), it returns a BE-encoded
+string with BOM prepended. So when you want to encode a whole text
+file, make sure you encode() the whole text at once, not line by line
+or each line, not file, will have a BOM prepended.
+
+=item *
+
+C<UCS-2> is an exception. Unlike others, this is an alias of UCS-2BE.
+UCS-2 is already registered by IANA and others that way.
+
+=back
+
+=head1 Surrogate Pairs
+
+To say the least, surrogate pairs were the biggest mistake of the
+Unicode Consortium. But according to the late Douglas Adams in I<The
+Hitchhiker's Guide to the Galaxy> Trilogy, C<In the beginning the
+Universe was created. This has made a lot of people very angry and
+been widely regarded as a bad move>. Their mistake was not of this
+magnitude so let's forgive them.
+
+(I don't dare make any comparison with Unicode Consortium and the
+Vogons here ;) Or, comparing Encode to Babel Fish is completely
+appropriate -- if you can only stick this into your ear :)
+
+Surrogate pairs were born when the Unicode Consortium finally
+admitted that 16 bits were not big enough to hold all the world's
+character repertoires. But they already made UCS-2 16-bit. What
+do we do?
+
+Back then, the range 0xD800-0xDFFF was not allocated. Let's split
+that range in half and use the first half to represent the C<upper
+half of a character> and the second half to represent the C<lower
+half of a character>. That way, you can represent 1024 * 1024 =
+1048576 more characters. Now we can store character ranges up to
+\x{10ffff} even with 16-bit encodings. This pair of half-character is
+now called a I<surrogate pair> and UTF-16 is the name of the encoding
+that embraces them.
+
+Here is a formula to ensurrogate a Unicode character \x{10000} and
+above;
+
+ $hi = ($uni - 0x10000) / 0x400 + 0xD800;
+ $lo = ($uni - 0x10000) % 0x400 + 0xDC00;
+
+And to desurrogate;
+
+ $uni = 0x10000 + ($hi - 0xD800) * 0x400 + ($lo - 0xDC00);
+
+Note this move has made \x{D800}-\x{DFFF} into a forbidden zone but
+perl does not prohibit the use of characters within this range. To perl,
+every one of \x{0000_0000} up to \x{ffff_ffff} (*) is I<a character>.
+
+ (*) or \x{ffff_ffff_ffff_ffff} if your perl is compiled with 64-bit
+ integer support!
+
+=head1 Error Checking
+
+Unlike most encodings which accept various ways to handle errors,
+Unicode encodings simply croaks.
+
+ % perl -MEncode -e '$_ = "\xfe\xff\xd8\xd9\xda\xdb\0\n"' \
+ -e 'Encode::from_to($_, "utf16","shift_jis", 0); print'
+ UTF-16:Malformed LO surrogate d8d9 at /path/to/Encode.pm line 184.
+ % perl -MEncode -e '$a = "BOM missing"' \
+ -e ' Encode::from_to($a, "utf16", "shift_jis", 0); print'
+ UTF-16:Unrecognised BOM 424f at /path/to/Encode.pm line 184.
+
+Unlike other encodings where mappings are not one-to-one against
+Unicode, UTFs are supposed to map 100% against one another. So Encode
+is more strict on UTFs.
+
+Consider that "division by zero" of Encode :)
+
+=head1 SEE ALSO
+
+L<Encode>, L<Encode::Unicode::UTF7>, L<http://www.unicode.org/glossary/>,
+L<http://www.unicode.org/unicode/faq/utf_bom.html>,
+
+RFC 2781 L<http://rfc.net/rfc2781.html>,
+
+The whole Unicode standard L<http://www.unicode.org/unicode/uni2book/u2.html>
+
+Ch. 15, pp. 403 of C<Programming Perl (3rd Edition)>
+by Larry Wall, Tom Christiansen, Jon Orwant;
+O'Reilly & Associates; ISBN 0-596-00027-8
+
+=cut
diff --git a/Master/tlpkg/installer/perllib/Exporter.pm b/Master/tlpkg/installer/perllib/Exporter.pm
new file mode 100644
index 00000000000..d9c22049776
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/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/installer/perllib/Exporter/Heavy.pm b/Master/tlpkg/installer/perllib/Exporter/Heavy.pm
new file mode 100644
index 00000000000..2cc792288f0
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/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/installer/perllib/Getopt/Long.pm b/Master/tlpkg/installer/perllib/Getopt/Long.pm
new file mode 100644
index 00000000000..04038db58e3
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/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/installer/perllib/List/Util.pm b/Master/tlpkg/installer/perllib/List/Util.pm
new file mode 100644
index 00000000000..cfe31f70123
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/List/Util.pm
@@ -0,0 +1,277 @@
+# List::Util.pm
+#
+# Copyright (c) 1997-2005 Graham Barr <gbarr@pobox.com>. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package List::Util;
+
+use strict;
+use vars qw(@ISA @EXPORT_OK $VERSION $XS_VERSION $TESTING_PERL_ONLY);
+require Exporter;
+
+@ISA = qw(Exporter);
+@EXPORT_OK = qw(first min max minstr maxstr reduce sum shuffle);
+$VERSION = "1.18";
+$XS_VERSION = $VERSION;
+$VERSION = eval $VERSION;
+
+eval {
+ # PERL_DL_NONLAZY must be false, or any errors in loading will just
+ # cause the perl code to be tested
+ local $ENV{PERL_DL_NONLAZY} = 0 if $ENV{PERL_DL_NONLAZY};
+ eval {
+ require XSLoader;
+ XSLoader::load('List::Util', $XS_VERSION);
+ 1;
+ } or do {
+ require DynaLoader;
+ local @ISA = qw(DynaLoader);
+ bootstrap List::Util $XS_VERSION;
+ };
+} unless $TESTING_PERL_ONLY;
+
+
+# This code is only compiled if the XS did not load
+# of for perl < 5.6.0
+
+if (!defined &reduce) {
+eval <<'ESQ'
+
+sub reduce (&@) {
+ my $code = shift;
+ no strict 'refs';
+
+ return shift unless @_ > 1;
+
+ use vars qw($a $b);
+
+ my $caller = caller;
+ local(*{$caller."::a"}) = \my $a;
+ local(*{$caller."::b"}) = \my $b;
+
+ $a = shift;
+ foreach (@_) {
+ $b = $_;
+ $a = &{$code}();
+ }
+
+ $a;
+}
+
+sub first (&@) {
+ my $code = shift;
+
+ foreach (@_) {
+ return $_ if &{$code}();
+ }
+
+ undef;
+}
+
+ESQ
+}
+
+# This code is only compiled if the XS did not load
+eval <<'ESQ' if !defined &sum;
+
+use vars qw($a $b);
+
+sub sum (@) { reduce { $a + $b } @_ }
+
+sub min (@) { reduce { $a < $b ? $a : $b } @_ }
+
+sub max (@) { reduce { $a > $b ? $a : $b } @_ }
+
+sub minstr (@) { reduce { $a lt $b ? $a : $b } @_ }
+
+sub maxstr (@) { reduce { $a gt $b ? $a : $b } @_ }
+
+sub shuffle (@) {
+ my @a=\(@_);
+ my $n;
+ my $i=@_;
+ map {
+ $n = rand($i--);
+ (${$a[$n]}, $a[$n] = $a[$i])[0];
+ } @_;
+}
+
+ESQ
+
+1;
+
+__END__
+
+=head1 NAME
+
+List::Util - A selection of general-utility list subroutines
+
+=head1 SYNOPSIS
+
+ use List::Util qw(first max maxstr min minstr reduce shuffle sum);
+
+=head1 DESCRIPTION
+
+C<List::Util> contains a selection of subroutines that people have
+expressed would be nice to have in the perl core, but the usage would
+not really be high enough to warrant the use of a keyword, and the size
+so small such that being individual extensions would be wasteful.
+
+By default C<List::Util> does not export any subroutines. The
+subroutines defined are
+
+=over 4
+
+=item first BLOCK LIST
+
+Similar to C<grep> in that it evaluates BLOCK setting C<$_> to each element
+of LIST in turn. C<first> returns the first element where the result from
+BLOCK is a true value. If BLOCK never returns true or LIST was empty then
+C<undef> is returned.
+
+ $foo = first { defined($_) } @list # first defined value in @list
+ $foo = first { $_ > $value } @list # first value in @list which
+ # is greater than $value
+
+This function could be implemented using C<reduce> like this
+
+ $foo = reduce { defined($a) ? $a : wanted($b) ? $b : undef } undef, @list
+
+for example wanted() could be defined() which would return the first
+defined value in @list
+
+=item max LIST
+
+Returns the entry in the list with the highest numerical value. If the
+list is empty then C<undef> is returned.
+
+ $foo = max 1..10 # 10
+ $foo = max 3,9,12 # 12
+ $foo = max @bar, @baz # whatever
+
+This function could be implemented using C<reduce> like this
+
+ $foo = reduce { $a > $b ? $a : $b } 1..10
+
+=item maxstr LIST
+
+Similar to C<max>, but treats all the entries in the list as strings
+and returns the highest string as defined by the C<gt> operator.
+If the list is empty then C<undef> is returned.
+
+ $foo = maxstr 'A'..'Z' # 'Z'
+ $foo = maxstr "hello","world" # "world"
+ $foo = maxstr @bar, @baz # whatever
+
+This function could be implemented using C<reduce> like this
+
+ $foo = reduce { $a gt $b ? $a : $b } 'A'..'Z'
+
+=item min LIST
+
+Similar to C<max> but returns the entry in the list with the lowest
+numerical value. If the list is empty then C<undef> is returned.
+
+ $foo = min 1..10 # 1
+ $foo = min 3,9,12 # 3
+ $foo = min @bar, @baz # whatever
+
+This function could be implemented using C<reduce> like this
+
+ $foo = reduce { $a < $b ? $a : $b } 1..10
+
+=item minstr LIST
+
+Similar to C<min>, but treats all the entries in the list as strings
+and returns the lowest string as defined by the C<lt> operator.
+If the list is empty then C<undef> is returned.
+
+ $foo = minstr 'A'..'Z' # 'A'
+ $foo = minstr "hello","world" # "hello"
+ $foo = minstr @bar, @baz # whatever
+
+This function could be implemented using C<reduce> like this
+
+ $foo = reduce { $a lt $b ? $a : $b } 'A'..'Z'
+
+=item reduce BLOCK LIST
+
+Reduces LIST by calling BLOCK multiple times, setting C<$a> and C<$b>
+each time. The first call will be with C<$a> and C<$b> set to the first
+two elements of the list, subsequent calls will be done by
+setting C<$a> to the result of the previous call and C<$b> to the next
+element in the list.
+
+Returns the result of the last call to BLOCK. If LIST is empty then
+C<undef> is returned. If LIST only contains one element then that
+element is returned and BLOCK is not executed.
+
+ $foo = reduce { $a < $b ? $a : $b } 1..10 # min
+ $foo = reduce { $a lt $b ? $a : $b } 'aa'..'zz' # minstr
+ $foo = reduce { $a + $b } 1 .. 10 # sum
+ $foo = reduce { $a . $b } @bar # concat
+
+=item shuffle LIST
+
+Returns the elements of LIST in a random order
+
+ @cards = shuffle 0..51 # 0..51 in a random order
+
+=item sum LIST
+
+Returns the sum of all the elements in LIST. If LIST is empty then
+C<undef> is returned.
+
+ $foo = sum 1..10 # 55
+ $foo = sum 3,9,12 # 24
+ $foo = sum @bar, @baz # whatever
+
+This function could be implemented using C<reduce> like this
+
+ $foo = reduce { $a + $b } 1..10
+
+=back
+
+=head1 KNOWN BUGS
+
+With perl versions prior to 5.005 there are some cases where reduce
+will return an incorrect result. This will show up as test 7 of
+reduce.t failing.
+
+=head1 SUGGESTED ADDITIONS
+
+The following are additions that have been requested, but I have been reluctant
+to add due to them being very simple to implement in perl
+
+ # One argument is true
+
+ sub any { $_ && return 1 for @_; 0 }
+
+ # All arguments are true
+
+ sub all { $_ || return 0 for @_; 1 }
+
+ # All arguments are false
+
+ sub none { $_ && return 0 for @_; 1 }
+
+ # One argument is false
+
+ sub notall { $_ || return 1 for @_; 0 }
+
+ # How many elements are true
+
+ sub true { scalar grep { $_ } @_ }
+
+ # How many elements are false
+
+ sub false { scalar grep { !$_ } @_ }
+
+=head1 COPYRIGHT
+
+Copyright (c) 1997-2005 Graham Barr <gbarr@pobox.com>. All rights reserved.
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=cut
diff --git a/Master/tlpkg/installer/perllib/Scalar/Util.pm b/Master/tlpkg/installer/perllib/Scalar/Util.pm
new file mode 100644
index 00000000000..4ae525a17c0
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/Scalar/Util.pm
@@ -0,0 +1,147 @@
+# Scalar::Util.pm
+#
+# Copyright (c) 1997-2005 Graham Barr <gbarr@pobox.com>. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package Scalar::Util;
+
+use strict;
+use vars qw(@ISA @EXPORT_OK $VERSION);
+require Exporter;
+require List::Util; # List::Util loads the XS
+
+@ISA = qw(Exporter);
+@EXPORT_OK = qw(blessed dualvar reftype weaken isweak tainted readonly openhandle refaddr isvstring looks_like_number set_prototype);
+$VERSION = "1.18";
+$VERSION = eval $VERSION;
+
+sub export_fail {
+ if (grep { /^(weaken|isweak)$/ } @_ ) {
+ require Carp;
+ Carp::croak("Weak references are not implemented in the version of perl");
+ }
+ if (grep { /^(isvstring)$/ } @_ ) {
+ require Carp;
+ Carp::croak("Vstrings are not implemented in the version of perl");
+ }
+ if (grep { /^(dualvar|set_prototype)$/ } @_ ) {
+ require Carp;
+ Carp::croak("$1 is only avaliable with the XS version");
+ }
+
+ @_;
+}
+
+sub openhandle ($) {
+ my $fh = shift;
+ my $rt = reftype($fh) || '';
+
+ return defined(fileno($fh)) ? $fh : undef
+ if $rt eq 'IO';
+
+ if (reftype(\$fh) eq 'GLOB') { # handle openhandle(*DATA)
+ $fh = \(my $tmp=$fh);
+ }
+ elsif ($rt ne 'GLOB') {
+ return undef;
+ }
+
+ (tied(*$fh) or defined(fileno($fh)))
+ ? $fh : undef;
+}
+
+eval <<'ESQ' unless defined &dualvar;
+
+use vars qw(@EXPORT_FAIL);
+push @EXPORT_FAIL, qw(weaken isweak dualvar isvstring set_prototype);
+
+# The code beyond here is only used if the XS is not installed
+
+# Hope nobody defines a sub by this name
+sub UNIVERSAL::a_sub_not_likely_to_be_here { ref($_[0]) }
+
+sub blessed ($) {
+ local($@, $SIG{__DIE__}, $SIG{__WARN__});
+ length(ref($_[0]))
+ ? eval { $_[0]->a_sub_not_likely_to_be_here }
+ : undef
+}
+
+sub refaddr($) {
+ my $pkg = ref($_[0]) or return undef;
+ if (blessed($_[0])) {
+ bless $_[0], 'Scalar::Util::Fake';
+ }
+ else {
+ $pkg = undef;
+ }
+ "$_[0]" =~ /0x(\w+)/;
+ my $i = do { local $^W; hex $1 };
+ bless $_[0], $pkg if defined $pkg;
+ $i;
+}
+
+sub reftype ($) {
+ local($@, $SIG{__DIE__}, $SIG{__WARN__});
+ my $r = shift;
+ my $t;
+
+ length($t = ref($r)) or return undef;
+
+ # This eval will fail if the reference is not blessed
+ eval { $r->a_sub_not_likely_to_be_here; 1 }
+ ? do {
+ $t = eval {
+ # we have a GLOB or an IO. Stringify a GLOB gives it's name
+ my $q = *$r;
+ $q =~ /^\*/ ? "GLOB" : "IO";
+ }
+ or do {
+ # OK, if we don't have a GLOB what parts of
+ # a glob will it populate.
+ # NOTE: A glob always has a SCALAR
+ local *glob = $r;
+ defined *glob{ARRAY} && "ARRAY"
+ or defined *glob{HASH} && "HASH"
+ or defined *glob{CODE} && "CODE"
+ or length(ref(${$r})) ? "REF" : "SCALAR";
+ }
+ }
+ : $t
+}
+
+sub tainted {
+ local($@, $SIG{__DIE__}, $SIG{__WARN__});
+ local $^W = 0;
+ eval { kill 0 * $_[0] };
+ $@ =~ /^Insecure/;
+}
+
+sub readonly {
+ return 0 if tied($_[0]) || (ref(\($_[0])) ne "SCALAR");
+
+ local($@, $SIG{__DIE__}, $SIG{__WARN__});
+ my $tmp = $_[0];
+
+ !eval { $_[0] = $tmp; 1 };
+}
+
+sub looks_like_number {
+ local $_ = shift;
+
+ # checks from perlfaq4
+ return 0 if !defined($_) or ref($_);
+ return 1 if (/^[+-]?\d+$/); # is a +/- integer
+ return 1 if (/^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/); # a C float
+ return 1 if ($] >= 5.008 and /^(Inf(inity)?|NaN)$/i) or ($] >= 5.006001 and /^Inf$/i);
+
+ 0;
+}
+
+ESQ
+
+1;
+
+__END__
+
diff --git a/Master/tlpkg/installer/perllib/Symbol.pm b/Master/tlpkg/installer/perllib/Symbol.pm
new file mode 100644
index 00000000000..3bb5d9240c1
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/Symbol.pm
@@ -0,0 +1,170 @@
+package Symbol;
+
+=head1 NAME
+
+Symbol - manipulate Perl symbols and their names
+
+=head1 SYNOPSIS
+
+ use Symbol;
+
+ $sym = gensym;
+ open($sym, "filename");
+ $_ = <$sym>;
+ # etc.
+
+ ungensym $sym; # no effect
+
+ # replace *FOO{IO} handle but not $FOO, %FOO, etc.
+ *FOO = geniosym;
+
+ print qualify("x"), "\n"; # "Test::x"
+ print qualify("x", "FOO"), "\n" # "FOO::x"
+ print qualify("BAR::x"), "\n"; # "BAR::x"
+ print qualify("BAR::x", "FOO"), "\n"; # "BAR::x"
+ print qualify("STDOUT", "FOO"), "\n"; # "main::STDOUT" (global)
+ print qualify(\*x), "\n"; # returns \*x
+ print qualify(\*x, "FOO"), "\n"; # returns \*x
+
+ use strict refs;
+ print { qualify_to_ref $fh } "foo!\n";
+ $ref = qualify_to_ref $name, $pkg;
+
+ use Symbol qw(delete_package);
+ delete_package('Foo::Bar');
+ print "deleted\n" unless exists $Foo::{'Bar::'};
+
+=head1 DESCRIPTION
+
+C<Symbol::gensym> creates an anonymous glob and returns a reference
+to it. Such a glob reference can be used as a file or directory
+handle.
+
+For backward compatibility with older implementations that didn't
+support anonymous globs, C<Symbol::ungensym> is also provided.
+But it doesn't do anything.
+
+C<Symbol::geniosym> creates an anonymous IO handle. This can be
+assigned into an existing glob without affecting the non-IO portions
+of the glob.
+
+C<Symbol::qualify> turns unqualified symbol names into qualified
+variable names (e.g. "myvar" -E<gt> "MyPackage::myvar"). If it is given a
+second parameter, C<qualify> uses it as the default package;
+otherwise, it uses the package of its caller. Regardless, global
+variable names (e.g. "STDOUT", "ENV", "SIG") are always qualified with
+"main::".
+
+Qualification applies only to symbol names (strings). References are
+left unchanged under the assumption that they are glob references,
+which are qualified by their nature.
+
+C<Symbol::qualify_to_ref> is just like C<Symbol::qualify> except that it
+returns a glob ref rather than a symbol name, so you can use the result
+even if C<use strict 'refs'> is in effect.
+
+C<Symbol::delete_package> wipes out a whole package namespace. Note
+this routine is not exported by default--you may want to import it
+explicitly.
+
+=head1 BUGS
+
+C<Symbol::delete_package> is a bit too powerful. It undefines every symbol that
+lives in the specified package. Since perl, for performance reasons, does not
+perform a symbol table lookup each time a function is called or a global
+variable is accessed, some code that has already been loaded and that makes use
+of symbols in package C<Foo> may stop working after you delete C<Foo>, even if
+you reload the C<Foo> module afterwards.
+
+=cut
+
+BEGIN { require 5.005; }
+
+require Exporter;
+@ISA = qw(Exporter);
+@EXPORT = qw(gensym ungensym qualify qualify_to_ref);
+@EXPORT_OK = qw(delete_package geniosym);
+
+$VERSION = '1.06';
+
+my $genpkg = "Symbol::";
+my $genseq = 0;
+
+my %global = map {$_ => 1} qw(ARGV ARGVOUT ENV INC SIG STDERR STDIN STDOUT);
+
+#
+# Note that we never _copy_ the glob; we just make a ref to it.
+# If we did copy it, then SVf_FAKE would be set on the copy, and
+# glob-specific behaviors (e.g. C<*$ref = \&func>) wouldn't work.
+#
+sub gensym () {
+ my $name = "GEN" . $genseq++;
+ my $ref = \*{$genpkg . $name};
+ delete $$genpkg{$name};
+ $ref;
+}
+
+sub geniosym () {
+ my $sym = gensym();
+ # force the IO slot to be filled
+ select(select $sym);
+ *$sym{IO};
+}
+
+sub ungensym ($) {}
+
+sub qualify ($;$) {
+ my ($name) = @_;
+ if (!ref($name) && index($name, '::') == -1 && index($name, "'") == -1) {
+ my $pkg;
+ # Global names: special character, "^xyz", or other.
+ if ($name =~ /^(([^a-z])|(\^[a-z_]+))\z/i || $global{$name}) {
+ # RGS 2001-11-05 : translate leading ^X to control-char
+ $name =~ s/^\^([a-z_])/'qq(\c'.$1.')'/eei;
+ $pkg = "main";
+ }
+ else {
+ $pkg = (@_ > 1) ? $_[1] : caller;
+ }
+ $name = $pkg . "::" . $name;
+ }
+ $name;
+}
+
+sub qualify_to_ref ($;$) {
+ return \*{ qualify $_[0], @_ > 1 ? $_[1] : caller };
+}
+
+#
+# of Safe.pm lineage
+#
+sub delete_package ($) {
+ my $pkg = shift;
+
+ # expand to full symbol table name if needed
+
+ unless ($pkg =~ /^main::.*::$/) {
+ $pkg = "main$pkg" if $pkg =~ /^::/;
+ $pkg = "main::$pkg" unless $pkg =~ /^main::/;
+ $pkg .= '::' unless $pkg =~ /::$/;
+ }
+
+ my($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
+ my $stem_symtab = *{$stem}{HASH};
+ return unless defined $stem_symtab and exists $stem_symtab->{$leaf};
+
+
+ # free all the symbols in the package
+
+ my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
+ foreach my $name (keys %$leaf_symtab) {
+ undef *{$pkg . $name};
+ }
+
+ # delete the symbol table
+
+ %$leaf_symtab = ();
+ delete $stem_symtab->{$leaf};
+}
+
+1;
diff --git a/Master/tlpkg/installer/perllib/Tie/Hash.pm b/Master/tlpkg/installer/perllib/Tie/Hash.pm
new file mode 100644
index 00000000000..a838915482b
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/Tie/Hash.pm
@@ -0,0 +1,257 @@
+package Tie::Hash;
+
+our $VERSION = '1.02';
+
+=head1 NAME
+
+Tie::Hash, Tie::StdHash, Tie::ExtraHash - base class definitions for tied hashes
+
+=head1 SYNOPSIS
+
+ package NewHash;
+ require Tie::Hash;
+
+ @ISA = (Tie::Hash);
+
+ sub DELETE { ... } # Provides needed method
+ sub CLEAR { ... } # Overrides inherited method
+
+
+ package NewStdHash;
+ require Tie::Hash;
+
+ @ISA = (Tie::StdHash);
+
+ # All methods provided by default, define only those needing overrides
+ # Accessors access the storage in %{$_[0]};
+ # TIEHASH should return a reference to the actual storage
+ sub DELETE { ... }
+
+ package NewExtraHash;
+ require Tie::Hash;
+
+ @ISA = (Tie::ExtraHash);
+
+ # All methods provided by default, define only those needing overrides
+ # Accessors access the storage in %{$_[0][0]};
+ # TIEHASH should return an array reference with the first element being
+ # the reference to the actual storage
+ sub DELETE {
+ $_[0][1]->('del', $_[0][0], $_[1]); # Call the report writer
+ delete $_[0][0]->{$_[1]}; # $_[0]->SUPER::DELETE($_[1])
+ }
+
+
+ package main;
+
+ tie %new_hash, 'NewHash';
+ tie %new_std_hash, 'NewStdHash';
+ tie %new_extra_hash, 'NewExtraHash',
+ sub {warn "Doing \U$_[1]\E of $_[2].\n"};
+
+=head1 DESCRIPTION
+
+This module provides some skeletal methods for hash-tying classes. See
+L<perltie> for a list of the functions required in order to tie a hash
+to a package. The basic B<Tie::Hash> package provides a C<new> method, as well
+as methods C<TIEHASH>, C<EXISTS> and C<CLEAR>. The B<Tie::StdHash> and
+B<Tie::ExtraHash> packages
+provide most methods for hashes described in L<perltie> (the exceptions
+are C<UNTIE> and C<DESTROY>). They cause tied hashes to behave exactly like standard hashes,
+and allow for selective overwriting of methods. B<Tie::Hash> grandfathers the
+C<new> method: it is used if C<TIEHASH> is not defined
+in the case a class forgets to include a C<TIEHASH> method.
+
+For developers wishing to write their own tied hashes, the required methods
+are briefly defined below. See the L<perltie> section for more detailed
+descriptive, as well as example code:
+
+=over 4
+
+=item TIEHASH classname, LIST
+
+The method invoked by the command C<tie %hash, classname>. Associates a new
+hash instance with the specified class. C<LIST> would represent additional
+arguments (along the lines of L<AnyDBM_File> and compatriots) needed to
+complete the association.
+
+=item STORE this, key, value
+
+Store datum I<value> into I<key> for the tied hash I<this>.
+
+=item FETCH this, key
+
+Retrieve the datum in I<key> for the tied hash I<this>.
+
+=item FIRSTKEY this
+
+Return the first key in the hash.
+
+=item NEXTKEY this, lastkey
+
+Return the next key in the hash.
+
+=item EXISTS this, key
+
+Verify that I<key> exists with the tied hash I<this>.
+
+The B<Tie::Hash> implementation is a stub that simply croaks.
+
+=item DELETE this, key
+
+Delete the key I<key> from the tied hash I<this>.
+
+=item CLEAR this
+
+Clear all values from the tied hash I<this>.
+
+=item SCALAR this
+
+Returns what evaluating the hash in scalar context yields.
+
+B<Tie::Hash> does not implement this method (but B<Tie::StdHash>
+and B<Tie::ExtraHash> do).
+
+=back
+
+=head1 Inheriting from B<Tie::StdHash>
+
+The accessor methods assume that the actual storage for the data in the tied
+hash is in the hash referenced by C<tied(%tiedhash)>. Thus overwritten
+C<TIEHASH> method should return a hash reference, and the remaining methods
+should operate on the hash referenced by the first argument:
+
+ package ReportHash;
+ our @ISA = 'Tie::StdHash';
+
+ sub TIEHASH {
+ my $storage = bless {}, shift;
+ warn "New ReportHash created, stored in $storage.\n";
+ $storage
+ }
+ sub STORE {
+ warn "Storing data with key $_[1] at $_[0].\n";
+ $_[0]{$_[1]} = $_[2]
+ }
+
+
+=head1 Inheriting from B<Tie::ExtraHash>
+
+The accessor methods assume that the actual storage for the data in the tied
+hash is in the hash referenced by C<(tied(%tiedhash))-E<gt>[0]>. Thus overwritten
+C<TIEHASH> method should return an array reference with the first
+element being a hash reference, and the remaining methods should operate on the
+hash C<< %{ $_[0]->[0] } >>:
+
+ package ReportHash;
+ our @ISA = 'Tie::ExtraHash';
+
+ sub TIEHASH {
+ my $class = shift;
+ my $storage = bless [{}, @_], $class;
+ warn "New ReportHash created, stored in $storage.\n";
+ $storage;
+ }
+ sub STORE {
+ warn "Storing data with key $_[1] at $_[0].\n";
+ $_[0][0]{$_[1]} = $_[2]
+ }
+
+The default C<TIEHASH> method stores "extra" arguments to tie() starting
+from offset 1 in the array referenced by C<tied(%tiedhash)>; this is the
+same storage algorithm as in TIEHASH subroutine above. Hence, a typical
+package inheriting from B<Tie::ExtraHash> does not need to overwrite this
+method.
+
+=head1 C<SCALAR>, C<UNTIE> and C<DESTROY>
+
+The methods C<UNTIE> and C<DESTROY> are not defined in B<Tie::Hash>,
+B<Tie::StdHash>, or B<Tie::ExtraHash>. Tied hashes do not require
+presence of these methods, but if defined, the methods will be called in
+proper time, see L<perltie>.
+
+C<SCALAR> is only defined in B<Tie::StdHash> and B<Tie::ExtraHash>.
+
+If needed, these methods should be defined by the package inheriting from
+B<Tie::Hash>, B<Tie::StdHash>, or B<Tie::ExtraHash>. See L<pertie/"SCALAR">
+to find out what happens when C<SCALAR> does not exist.
+
+=head1 MORE INFORMATION
+
+The packages relating to various DBM-related implementations (F<DB_File>,
+F<NDBM_File>, etc.) show examples of general tied hashes, as does the
+L<Config> module. While these do not utilize B<Tie::Hash>, they serve as
+good working examples.
+
+=cut
+
+use Carp;
+use warnings::register;
+
+sub new {
+ my $pkg = shift;
+ $pkg->TIEHASH(@_);
+}
+
+# Grandfather "new"
+
+sub TIEHASH {
+ my $pkg = shift;
+ if (defined &{"${pkg}::new"}) {
+ warnings::warnif("WARNING: calling ${pkg}->new since ${pkg}->TIEHASH is missing");
+ $pkg->new(@_);
+ }
+ else {
+ croak "$pkg doesn't define a TIEHASH method";
+ }
+}
+
+sub EXISTS {
+ my $pkg = ref $_[0];
+ croak "$pkg doesn't define an EXISTS method";
+}
+
+sub CLEAR {
+ my $self = shift;
+ my $key = $self->FIRSTKEY(@_);
+ my @keys;
+
+ while (defined $key) {
+ push @keys, $key;
+ $key = $self->NEXTKEY(@_, $key);
+ }
+ foreach $key (@keys) {
+ $self->DELETE(@_, $key);
+ }
+}
+
+# The Tie::StdHash package implements standard perl hash behaviour.
+# It exists to act as a base class for classes which only wish to
+# alter some parts of their behaviour.
+
+package Tie::StdHash;
+# @ISA = qw(Tie::Hash); # would inherit new() only
+
+sub TIEHASH { bless {}, $_[0] }
+sub STORE { $_[0]->{$_[1]} = $_[2] }
+sub FETCH { $_[0]->{$_[1]} }
+sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} }
+sub NEXTKEY { each %{$_[0]} }
+sub EXISTS { exists $_[0]->{$_[1]} }
+sub DELETE { delete $_[0]->{$_[1]} }
+sub CLEAR { %{$_[0]} = () }
+sub SCALAR { scalar %{$_[0]} }
+
+package Tie::ExtraHash;
+
+sub TIEHASH { my $p = shift; bless [{}, @_], $p }
+sub STORE { $_[0][0]{$_[1]} = $_[2] }
+sub FETCH { $_[0][0]{$_[1]} }
+sub FIRSTKEY { my $a = scalar keys %{$_[0][0]}; each %{$_[0][0]} }
+sub NEXTKEY { each %{$_[0][0]} }
+sub EXISTS { exists $_[0][0]->{$_[1]} }
+sub DELETE { delete $_[0][0]->{$_[1]} }
+sub CLEAR { %{$_[0][0]} = () }
+sub SCALAR { scalar %{$_[0][0]} }
+
+1;
diff --git a/Master/tlpkg/installer/perllib/Tk.pm b/Master/tlpkg/installer/perllib/Tk.pm
new file mode 100644
index 00000000000..deb453172eb
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/Tk.pm
@@ -0,0 +1,821 @@
+#
+# Copyright (c) 1992-1994 The Regents of the University of California.
+# Copyright (c) 1994 Sun Microsystems, Inc.
+# Copyright (c) 1995-2004 Nick Ing-Simmons. All rights reserved.
+# This program is free software; you can redistribute it and/or
+
+# modify it under the same terms as Perl itself, subject
+# to additional disclaimer in Tk/license.terms due to partial
+# derivation from Tk8.0 sources.
+#
+package Tk;
+require 5.007;
+use Tk::Event ();
+use AutoLoader qw(AUTOLOAD);
+use DynaLoader;
+use Cwd();
+use base qw(Exporter DynaLoader);
+
+*fileevent = \&Tk::Event::IO::fileevent;
+
+use Encode;
+$Tk::encodeStopOnError = Encode::FB_QUIET();
+$Tk::encodeFallback = Encode::FB_PERLQQ(); # Encode::FB_DEFAULT();
+
+our %font_encoding = ('jis0208' => 'jis0208-raw',
+ 'jis0212' => 'jis0212-raw',
+ 'ksc5601' => 'ksc5601-raw',
+ 'gb2312' => 'gb2312-raw',
+ 'unicode' => 'ucs-2le',
+ );
+
+BEGIN {
+ if($^O eq 'cygwin')
+ {
+ require Tk::Config;
+ $Tk::platform = $Tk::Config::win_arch;
+ $Tk::platform = 'unix' if $Tk::platform eq 'x';
+ }
+ else
+ {
+ $Tk::platform = ($^O eq 'MSWin32') ? $^O : 'unix';
+ }
+};
+
+$Tk::tearoff = 1 if ($Tk::platform eq 'unix');
+
+
+@EXPORT = qw(Exists Ev exit MainLoop DoOneEvent tkinit);
+@EXPORT_OK = qw(NoOp after *widget *event lsearch catch $XS_VERSION
+ DONT_WAIT WINDOW_EVENTS FILE_EVENTS TIMER_EVENTS
+ IDLE_EVENTS ALL_EVENTS
+ NORMAL_BG ACTIVE_BG SELECT_BG
+ SELECT_FG TROUGH INDICATOR DISABLED BLACK WHITE);
+%EXPORT_TAGS = (eventtypes => [qw(DONT_WAIT WINDOW_EVENTS FILE_EVENTS
+ TIMER_EVENTS IDLE_EVENTS ALL_EVENTS)],
+ variables => [qw(*widget *event)],
+ colors => [qw(NORMAL_BG ACTIVE_BG SELECT_BG SELECT_FG
+ TROUGH INDICATOR DISABLED BLACK WHITE)],
+ );
+
+use strict;
+use Carp;
+
+# Record author's perforce depot record
+$Tk::CHANGE = q$Change: 3279 $;
+
+# $tk_version and $tk_patchLevel are reset by pTk when a mainwindow
+# is created, $VERSION is checked by bootstrap
+$Tk::version = '8.4';
+$Tk::patchLevel = '8.4';
+$Tk::VERSION = '804.027';
+$Tk::XS_VERSION = $Tk::VERSION;
+$Tk::strictMotif = 0;
+
+
+{($Tk::library) = __FILE__ =~ /^(.*)\.pm$/;}
+$Tk::library = Tk->findINC('.') unless (defined($Tk::library) && -d $Tk::library);
+
+$Tk::widget = undef;
+$Tk::event = undef;
+
+use vars qw($inMainLoop);
+
+bootstrap Tk;
+
+my $boot_time = timeofday();
+
+# This is a workround for Solaris X11 locale handling
+Preload(DynaLoader::dl_findfile('-L/usr/openwin/lib','-lX11'))
+ if (NeedPreload() && -d '/usr/openwin/lib');
+
+use Tk::Submethods ('option' => [qw(add get clear readfile)],
+ 'clipboard' => [qw(clear append)]
+ );
+
+#
+# Next few routines are here as perl code as doing caller()
+# in XS code is very complicated - so instead C code calls BackTrace
+#
+sub _backTrace
+{
+ my $w = shift;
+ my $i = 1;
+ my ($pack,$file,$line,$sub) = caller($i++);
+ while (1)
+ {
+ my $loc = "at $file line $line";
+ ($pack,$file,$line,$sub) = caller($i++);
+ last unless defined($sub);
+ return 1 if $sub eq '(eval)';
+ $w->AddErrorInfo("$sub $loc");
+ }
+ return 0;
+}
+
+sub BackTrace
+{
+ my $w = shift;
+ return unless (@_ || $@);
+ my $mess = (@_) ? shift : "$@";
+ die "$mess\n" if $w->_backTrace;
+ # if we get here we are not in an eval so report now
+ $w->Fail($mess);
+ $w->idletasks;
+ die "$mess\n";
+}
+
+#
+# This is a $SIG{__DIE__} handler which does not change the $@
+# string in the way 'croak' does, but rather add to Tk's ErrorInfo.
+# It stops at 1st enclosing eval on assumption that the eval
+# is part of Tk call process and will add its own context to ErrorInfo
+# and then pass on the error.
+#
+sub __DIE__
+{
+ my $mess = shift;
+ my $w = $Tk::widget;
+ # Note that if a __DIE__ handler returns it re-dies up the chain.
+ return unless defined($w) && Exists($w);
+ # This special message is for exit() as an exception see pTkCallback.c
+ return if $mess =~/^_TK_EXIT_\(\d+\)/;
+ return if $w->_backTrace;
+ # Not in an eval - should not happen
+}
+
+sub XEvent::xy { shift->Info('xy') }
+
+sub XEvent::AUTOLOAD
+{
+ my ($meth) = $XEvent::AUTOLOAD =~ /(\w)$/;
+ no strict 'refs';
+ *{$XEvent::AUTOLOAD} = sub { shift->Info($meth) };
+ goto &$XEvent::AUTOLOAD;
+}
+
+sub NoOp { }
+
+sub Ev
+{
+ if (@_ == 1)
+ {
+ my $arg = $_[0];
+ return bless (((ref $arg) ? $arg : \$arg), 'Tk::Ev');
+ }
+ else
+ {
+ return bless [@_],'Tk::Ev';
+ }
+}
+
+sub InitClass
+{
+ my ($package,$parent) = @_;
+ croak "Unexpected type of parent $parent" unless(ref $parent);
+ croak "$parent is not a widget" unless($parent->IsWidget);
+ my $mw = $parent->MainWindow;
+ my $hash = $mw->TkHash('_ClassInit_');
+ unless (exists $hash->{$package})
+ {
+ $package->Install($mw);
+ $hash->{$package} = $package->ClassInit($mw);
+ }
+}
+
+require Tk::Widget;
+require Tk::Image;
+require Tk::MainWindow;
+
+sub Exists
+{my $w = shift;
+ return defined($w) && ref($w) && $w->IsWidget && $w->exists;
+}
+
+sub Time_So_Far
+{
+ return timeofday() - $boot_time;
+}
+
+# Selection* are not autoloaded as names are too long.
+
+sub SelectionOwn
+{my $widget = shift;
+ selection('own',(@_,$widget));
+}
+
+sub SelectionOwner
+{
+ selection('own','-displayof',@_);
+}
+
+sub SelectionClear
+{
+ selection('clear','-displayof',@_);
+}
+
+sub SelectionExists
+{
+ selection('exists','-displayof',@_);
+}
+
+sub SelectionHandle
+{my $widget = shift;
+ my $command = pop;
+ selection('handle',@_,$widget,$command);
+}
+
+sub SplitString
+{
+ local $_ = shift;
+ my (@arr, $tmp);
+ while (/\{([^{}]*)\}|((?:[^\s\\]|\\.)+)/gs) {
+ if (defined $1) { push @arr, $1 }
+ else { $tmp = $2 ; $tmp =~ s/\\([\s\\])/$1/g; push @arr, $tmp }
+ }
+ # carp '('.join(',',@arr).")";
+ return @arr;
+}
+
+sub Methods
+{
+ my ($package) = caller;
+ no strict 'refs';
+ foreach my $meth (@_)
+ {
+ my $name = $meth;
+ *{$package."::$meth"} = sub { shift->WidgetMethod($name,@_) };
+ }
+}
+
+my %dialog = ( tk_chooseColor => 'ColorDialog',
+ tk_messageBox => 'MessageBox',
+ tk_getOpenFile => 'FDialog',
+ tk_getSaveFile => 'FDialog',
+ tk_chooseDirectory => 'FDialog'
+# Slaven claims NI-S's version above does not work
+# and provides this
+# tk_chooseDirectory => 'DirDialog'
+ );
+
+foreach my $dialog (keys %dialog)
+ {
+ no strict 'refs';
+ unless (defined &$dialog)
+ {
+ my $kind = $dialog;
+ my $code = \&{"Tk::$dialog{$dialog}"};
+ *$dialog = sub { &$code($kind,@_) };
+ }
+ }
+
+sub MessageBox {
+ my ($kind,%args) = @_;
+ require Tk::Dialog;
+ my $parent = delete $args{'-parent'};
+ my $args = \%args;
+
+ $args->{-bitmap} = delete $args->{-icon} if defined $args->{-icon};
+ $args->{-text} = delete $args->{-message} if defined $args->{-message};
+ $args->{-type} = 'OK' unless defined $args->{-type};
+
+ my $type;
+ if (defined($type = delete $args->{-type})) {
+ delete $args->{-type};
+ my @buttons = grep($_,map(ucfirst($_),
+ split(/(abort|retry|ignore|yes|no|cancel|ok)/,
+ lc($type))));
+ $args->{-buttons} = [@buttons];
+ $args->{-default_button} = ucfirst(delete $args->{-default}) if
+ defined $args->{-default};
+ if (not defined $args->{-default_button} and scalar(@buttons) == 1) {
+ $args->{-default_button} = $buttons[0];
+ }
+ my $md = $parent->Dialog(%$args);
+ my $an = $md->Show;
+ $md->destroy;
+ return $an;
+ }
+} # end messageBox
+
+sub messageBox
+{
+ my ($widget,%args) = @_;
+ # remove in a later version:
+ if (exists $args{'-text'})
+ {
+ warn "The -text option is deprecated. Please use -message instead";
+ if (!exists $args{'-message'})
+ {
+ $args{'-message'} = delete $args{'-text'};
+ }
+ }
+ $args{'-type'} = (exists $args{'-type'}) ? lc($args{'-type'}) : 'ok';
+ $args{'-default'} = lc($args{'-default'}) if (exists $args{'-default'});
+ ucfirst tk_messageBox(-parent => $widget, %args);
+}
+
+sub getOpenFile
+{
+ tk_getOpenFile(-parent => shift,@_);
+}
+
+sub getSaveFile
+{
+ tk_getSaveFile(-parent => shift,@_);
+}
+
+sub chooseColor
+{
+ tk_chooseColor(-parent => shift,@_);
+}
+
+sub chooseDirectory
+{
+ tk_chooseDirectory(-parent => shift,@_);
+}
+
+sub DialogWrapper
+{
+ my ($method,$kind,%args) = @_;
+ my $created = 0;
+ my $w = delete $args{'-parent'};
+ if (defined $w)
+ {
+ $args{'-popover'} = $w;
+ }
+ else
+ {
+ $w = MainWindow->new;
+ $w->withdraw;
+ $created = 1;
+ }
+ my $mw = $w->toplevel;
+ my $fs = $mw->{$kind};
+ unless (defined $fs)
+ {
+ $mw->{$kind} = $fs = $mw->$method(%args);
+ }
+ else
+ {
+ $fs->configure(%args);
+ }
+ my $val = $fs->Show;
+ $w->destroy if $created;
+ return $val;
+}
+
+sub ColorDialog
+{
+ require Tk::ColorEditor;
+ DialogWrapper('ColorDialog',@_);
+}
+
+sub FDialog
+{
+ require Tk::FBox;
+ my $cmd = shift;
+ if ($cmd =~ /Save/)
+ {
+ push @_, -type => 'save';
+ }
+ elsif ($cmd =~ /Directory/)
+ {
+ push @_, -type => 'dir';
+ }
+ DialogWrapper('FBox', $cmd, @_);
+}
+
+sub DirDialog
+{
+ require Tk::DirTree;
+ DialogWrapper('DirTreeDialog',@_);
+}
+
+*MotifFDialog = \&FDialog;
+
+*CORE::GLOBAL::exit = \&exit;
+
+sub MainLoop
+{
+ unless ($inMainLoop)
+ {
+ local $inMainLoop = 1;
+ while (Tk::MainWindow->Count)
+ {
+ DoOneEvent(0);
+ }
+ }
+}
+
+sub tkinit { return MainWindow->new(@_) }
+
+# a wrapper on eval which turns off user $SIG{__DIE__}
+sub catch (&)
+{
+ my $sub = shift;
+ eval {local $SIG{'__DIE__'}; &$sub };
+}
+
+my $Home;
+
+sub TranslateFileName
+{
+ local $_ = shift;
+ unless (defined $Home)
+ {
+ $Home = $ENV{'HOME'} || (defined $ENV{'HOMEDRIVE'} && defined $ENV{'HOMEPATH'} ? $ENV{'HOMEDRIVE'}.$ENV{'HOMEPATH'} : "");
+ $Home =~ s#\\#/#g;
+ $Home .= '/' unless $Home =~ m#/$#;
+ }
+ s#~/#$Home#g;
+ # warn $_;
+ return $_;
+}
+
+sub findINC
+{
+ my $file = join('/',@_);
+ my $dir;
+ $file =~ s,::,/,g;
+ foreach $dir (@INC)
+ {
+ my $path;
+ return $path if (-e ($path = "$dir/$file"));
+ }
+ return undef;
+}
+
+sub idletasks
+{
+ shift->update('idletasks');
+}
+
+sub backtrace
+{
+ my ($self,$msg,$i) = @_;
+ $i = 1 if @_ < 3;
+ while (1)
+ {
+ my ($pack,$file,$line,$sub) = caller($i++);
+ last unless defined($sub);
+ $msg .= "\n $sub at $file line $line";
+ }
+ return "$msg\n";
+}
+
+sub die_with_trace
+{
+ my ($self,$msg) = @_;
+ die $self->backtrace($msg,1);
+}
+
+
+
+1;
+
+__END__
+
+sub Error
+{my $w = shift;
+ my $error = shift;
+ if (Exists($w))
+ {
+ my $grab = $w->grab('current');
+ $grab->Unbusy if (defined $grab);
+ }
+ chomp($error);
+ warn "Tk::Error: $error\n " . join("\n ",@_)."\n";
+}
+
+sub CancelRepeat
+{
+ my $w = shift->MainWindow;
+ my $id = delete $w->{_afterId_};
+ $w->after('cancel',$id) if (defined $id);
+}
+
+sub RepeatId
+{
+ my ($w,$id) = @_;
+ $w = $w->MainWindow;
+ $w->CancelRepeat;
+ $w->{_afterId_} = $id;
+}
+
+
+
+#----------------------------------------------------------------------------
+# focus.tcl --
+#
+# This file defines several procedures for managing the input
+# focus.
+#
+# @(#) focus.tcl 1.6 94/12/19 17:06:46
+#
+# Copyright (c) 1994 Sun Microsystems, Inc.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+sub FocusChildren { shift->children }
+
+#
+# focusNext --
+# This procedure is invoked to move the input focus to the next window
+# after a given one. "Next" is defined in terms of the window
+# stacking order, with all the windows underneath a given top-level
+# (no matter how deeply nested in the hierarchy) considered except
+# for frames and toplevels.
+#
+# Arguments:
+# w - Name of a window: the procedure will set the focus
+# to the next window after this one in the traversal
+# order.
+sub focusNext
+{
+ my $w = shift;
+ my $cur = $w;
+ while (1)
+ {
+ # Descend to just before the first child of the current widget.
+ my $parent = $cur;
+ my @children = $cur->FocusChildren();
+ my $i = -1;
+ # Look for the next sibling that isn't a top-level.
+ while (1)
+ {
+ $i += 1;
+ if ($i < @children)
+ {
+ $cur = $children[$i];
+ next if ($cur->toplevel == $cur);
+ last
+ }
+ # No more siblings, so go to the current widget's parent.
+ # If it's a top-level, break out of the loop, otherwise
+ # look for its next sibling.
+ $cur = $parent;
+ last if ($cur->toplevel() == $cur);
+ $parent = $parent->parent();
+ @children = $parent->FocusChildren();
+ $i = lsearch(\@children,$cur);
+ }
+ if ($cur == $w || $cur->FocusOK)
+ {
+ $cur->tabFocus;
+ return;
+ }
+ }
+}
+# focusPrev --
+# This procedure is invoked to move the input focus to the previous
+# window before a given one. "Previous" is defined in terms of the
+# window stacking order, with all the windows underneath a given
+# top-level (no matter how deeply nested in the hierarchy) considered.
+#
+# Arguments:
+# w - Name of a window: the procedure will set the focus
+# to the previous window before this one in the traversal
+# order.
+sub focusPrev
+{
+ my $w = shift;
+ my $cur = $w;
+ my @children;
+ my $i;
+ my $parent;
+ while (1)
+ {
+ # Collect information about the current window's position
+ # among its siblings. Also, if the window is a top-level,
+ # then reposition to just after the last child of the window.
+ if ($cur->toplevel() == $cur)
+ {
+ $parent = $cur;
+ @children = $cur->FocusChildren();
+ $i = @children;
+ }
+ else
+ {
+ $parent = $cur->parent();
+ @children = $parent->FocusChildren();
+ $i = lsearch(\@children,$cur);
+ }
+ # Go to the previous sibling, then descend to its last descendant
+ # (highest in stacking order. While doing this, ignore top-levels
+ # and their descendants. When we run out of descendants, go up
+ # one level to the parent.
+ while ($i > 0)
+ {
+ $i--;
+ $cur = $children[$i];
+ next if ($cur->toplevel() == $cur);
+ $parent = $cur;
+ @children = $parent->FocusChildren();
+ $i = @children;
+ }
+ $cur = $parent;
+ if ($cur == $w || $cur->FocusOK)
+ {
+ $cur->tabFocus;
+ return;
+ }
+ }
+
+}
+
+sub FocusOK
+{
+ my $w = shift;
+ my $value;
+ catch { $value = $w->cget('-takefocus') };
+ if (!$@ && defined($value))
+ {
+ return 0 if ($value eq '0');
+ return $w->viewable if ($value eq '1');
+ if ($value)
+ {
+ $value = $w->$value();
+ return $value if (defined $value);
+ }
+ }
+ if (!$w->viewable)
+ {
+ return 0;
+ }
+ catch { $value = $w->cget('-state') } ;
+ if (!$@ && defined($value) && $value eq 'disabled')
+ {
+ return 0;
+ }
+ $value = grep(/Key|Focus/,$w->Tk::bind(),$w->Tk::bind(ref($w)));
+ return $value;
+}
+
+
+# focusFollowsMouse
+#
+# If this procedure is invoked, Tk will enter "focus-follows-mouse"
+# mode, where the focus is always on whatever window contains the
+# mouse. If this procedure isn't invoked, then the user typically
+# has to click on a window to give it the focus.
+#
+# Arguments:
+# None.
+
+sub EnterFocus
+{
+ my $w = shift;
+ return unless $w;
+ my $Ev = $w->XEvent;
+ my $d = $Ev->d;
+ $w->Tk::focus() if ($d eq 'NotifyAncestor' || $d eq 'NotifyNonlinear' || $d eq 'NotifyInferior');
+}
+
+sub tabFocus
+{
+ shift->Tk::focus;
+}
+
+sub focusFollowsMouse
+{
+ my $widget = shift;
+ $widget->bind('all','<Enter>','EnterFocus');
+}
+
+# tkTraverseToMenu --
+# This procedure implements keyboard traversal of menus. Given an
+# ASCII character "char", it looks for a menubutton with that character
+# underlined. If one is found, it posts the menubutton's menu
+#
+# Arguments:
+# w - Window in which the key was typed (selects
+# a toplevel window).
+# char - Character that selects a menu. The case
+# is ignored. If an empty string, nothing
+# happens.
+sub TraverseToMenu
+{
+ my $w = shift;
+ my $char = shift;
+ return unless(defined $char && $char ne '');
+ $w = $w->toplevel->FindMenu($char);
+}
+# tkFirstMenu --
+# This procedure traverses to the first menubutton in the toplevel
+# for a given window, and posts that menubutton's menu.
+#
+# Arguments:
+# w - Name of a window. Selects which toplevel
+# to search for menubuttons.
+sub FirstMenu
+{
+ my $w = shift;
+ $w = $w->toplevel->FindMenu('');
+}
+
+# These wrappers don't use method syntax so need to live
+# in same package as raw Tk routines are newXS'ed into.
+
+sub Selection
+{my $widget = shift;
+ my $cmd = shift;
+ croak 'Use SelectionOwn/SelectionOwner' if ($cmd eq 'own');
+ croak "Use Selection\u$cmd()";
+}
+
+# If we have sub Clipboard in Tk then use base qw(Tk::Clipboard ....)
+# calls it when it does its eval "require $base"
+#sub Clipboard
+#{my $w = shift;
+# my $cmd = shift;
+# croak "Use clipboard\u$cmd()";
+#}
+
+sub Receive
+{
+ my $w = shift;
+ warn 'Receive(' . join(',',@_) .')';
+ die 'Tk rejects send(' . join(',',@_) .")\n";
+}
+
+sub break
+{
+ die "_TK_BREAK_\n";
+}
+
+sub updateWidgets
+{
+ my ($w) = @_;
+ while ($w->DoOneEvent(DONT_WAIT|IDLE_EVENTS|WINDOW_EVENTS))
+ {
+ }
+ $w;
+}
+
+sub ImageNames
+{
+ image('names');
+}
+
+sub ImageTypes
+{
+ image('types');
+}
+
+sub interps
+{
+ my $w = shift;
+ return $w->winfo('interps','-displayof');
+}
+
+sub lsearch
+{my $ar = shift;
+ my $x = shift;
+ my $i;
+ for ($i = 0; $i < scalar @$ar; $i++)
+ {
+ return $i if ($$ar[$i] eq $x);
+ }
+ return -1;
+}
+
+
+sub getEncoding
+{
+ my ($class,$name) = @_;
+ eval { require Encode };
+ if ($@)
+ {
+ require Tk::DummyEncode;
+ return Tk::DummyEncode->getEncoding($name);
+ }
+ $name = $Tk::font_encoding{$name} if exists $Tk::font_encoding{$name};
+ my $enc = Encode::find_encoding($name);
+
+ unless ($enc)
+ {
+ $enc = Encode::find_encoding($name) if ($name =~ s/[-_]\d+$//)
+ }
+# if ($enc)
+# {
+# print STDERR "Lookup '$name' => ".$enc->name."\n";
+# }
+# else
+# {
+# print STDERR "Failed '$name'\n";
+# }
+ unless ($enc)
+ {
+ if ($name eq 'X11ControlChars')
+ {
+ require Tk::DummyEncode;
+ $Encode::encoding{$name} = $enc = Tk::DummyEncode->getEncoding($name);
+ }
+ }
+ return $enc;
+}
+
+
+
diff --git a/Master/tlpkg/installer/perllib/Tk/After.pm b/Master/tlpkg/installer/perllib/Tk/After.pm
new file mode 100644
index 00000000000..85a0e406ee5
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/Tk/After.pm
@@ -0,0 +1,104 @@
+# Copyright (c) 1995-2004 Nick Ing-Simmons. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+package Tk::After;
+use Carp;
+
+use vars qw($VERSION);
+$VERSION = '4.007'; # $Id: //depot/Tkutf8/Tk/After.pm#11 $
+
+sub _cancelAll
+{
+ my $w = shift;
+ my $h = delete $w->{_After_};
+ foreach my $obj (values %$h)
+ {
+ # carp "Auto cancel ".$obj->[1]." for ".$obj->[0]->PathName;
+ $obj->cancel;
+ bless $obj,"Tk::After::Cancelled";
+ }
+}
+
+sub Tk::After::Cancelled::once { }
+sub Tk::After::Cancelled::repeat { }
+
+sub submit
+{
+ my $obj = shift;
+ my $w = $obj->[0];
+ my $id = $obj->[1];
+ my $t = $obj->[2];
+ my $method = $obj->[3];
+ delete($w->{_After_}{$id}) if (defined $id);
+ $id = $w->Tk::after($t,[$method => $obj]);
+ unless (exists $w->{_After_})
+ {
+ $w->{_After_} = {};
+ $w->OnDestroy([\&_cancelAll, $w]);
+ }
+ $w->{_After_}{$id} = $obj;
+ $obj->[1] = $id;
+ return $obj;
+}
+
+sub DESTROY
+{
+ my $obj = shift;
+ $obj->cancel;
+ undef $obj->[0];
+ undef $obj->[4];
+}
+
+sub new
+{
+ my ($class,$w,$t,$method,@cb) = @_;
+ my $cb = (@cb == 1) ? shift(@cb) : [@cb];
+ my $obj = bless [$w,undef,$t,$method,Tk::Callback->new($cb)],$class;
+ return $obj->submit;
+}
+
+sub cancel
+{
+ my $obj = shift;
+ my $id = $obj->[1];
+ my $w = $obj->[0];
+ if ($id)
+ {
+ $w->Tk::after('cancel'=> $id) if Tk::Exists($w);
+ delete $w->{_After_}{$id} if exists $w->{_After_};
+ $obj->[1] = undef;
+ }
+ return $obj;
+}
+
+sub repeat
+{
+ my $obj = shift;
+ $obj->submit;
+ local $Tk::widget = $obj->[0];
+ $obj->[4]->Call;
+}
+
+sub once
+{
+ my $obj = shift;
+ my $w = $obj->[0];
+ my $id = $obj->[1];
+ delete $w->{_After_}{$id};
+ local $Tk::widget = $w;
+ $obj->[4]->Call;
+}
+
+sub time {
+ my $obj = shift;
+ my $delay = shift;
+ if (defined $delay) {
+ $obj->cancel if $delay == 0;
+ $obj->[2] = $delay;
+ }
+ $obj->[2];
+}
+
+1;
+__END__
+
diff --git a/Master/tlpkg/installer/perllib/Tk/Button.pm b/Master/tlpkg/installer/perllib/Tk/Button.pm
new file mode 100644
index 00000000000..efa597dee14
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/Tk/Button.pm
@@ -0,0 +1,148 @@
+package Tk::Button;
+# Conversion from Tk4.0 button.tcl competed.
+#
+# Copyright (c) 1992-1994 The Regents of the University of California.
+# Copyright (c) 1994 Sun Microsystems, Inc.
+# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved.
+# This program is free software; you can redistribute it and/or
+
+use vars qw($VERSION);
+$VERSION = '4.008'; # $Id: //depot/Tkutf8/Tk/Button.pm#8 $
+
+# modify it under the same terms as Perl itself, subject
+# to additional disclaimer in license.terms due to partial
+# derivation from Tk4.0 sources.
+
+use strict;
+
+require Tk::Widget;
+use base qw(Tk::Widget);
+
+use vars qw($buttonWindow $relief);
+
+Tk::Methods('deselect','flash','invoke','select','toggle');
+
+sub Tk_cmd { \&Tk::button }
+
+Construct Tk::Widget 'Button';
+
+sub ClassInit
+{
+ my ($class,$mw) = @_;
+ $mw->bind($class,'<Enter>', 'Enter');
+ $mw->bind($class,'<Leave>', 'Leave');
+ $mw->bind($class,'<1>', 'butDown');
+ $mw->bind($class,'<ButtonRelease-1>', 'butUp');
+ $mw->bind($class,'<space>', 'Invoke');
+ $mw->bind($class,'<Return>', 'Invoke');
+ return $class;
+}
+
+# tkButtonEnter --
+# The procedure below is invoked when the mouse pointer enters a
+# button widget. It records the button we're in and changes the
+# state of the button to active unless the button is disabled.
+#
+# Arguments:
+# w - The name of the widget.
+
+sub Enter
+{
+ my $w = shift;
+ my $E = shift;
+ if ($w->cget('-state') ne 'disabled')
+ {
+ $w->configure('-state' => 'active');
+ $w->configure('-state' => 'active', '-relief' => 'sunken') if (defined($buttonWindow) && $w == $buttonWindow)
+ }
+ $Tk::window = $w;
+}
+
+# tkButtonLeave --
+# The procedure below is invoked when the mouse pointer leaves a
+# button widget. It changes the state of the button back to
+# inactive. If we're leaving the button window with a mouse button
+# pressed (tkPriv(buttonWindow) == $w), restore the relief of the
+# button too.
+#
+# Arguments:
+# w - The name of the widget.
+sub Leave
+{
+ my $w = shift;
+ $w->configure('-state'=>'normal') if ($w->cget('-state') ne 'disabled');
+ $w->configure('-relief' => $relief) if (defined($buttonWindow) && $w == $buttonWindow);
+ undef $Tk::window;
+}
+
+# tkButtonDown --
+# The procedure below is invoked when the mouse button is pressed in
+# a button widget. It records the fact that the mouse is in the button,
+# saves the button's relief so it can be restored later, and changes
+# the relief to sunken.
+#
+# Arguments:
+# w - The name of the widget.
+sub butDown
+{
+ my $w = shift;
+ $relief = $w->cget('-relief');
+ if ($w->cget('-state') ne 'disabled')
+ {
+ $buttonWindow = $w;
+ $w->configure('-relief' => 'sunken')
+ }
+}
+
+# tkButtonUp --
+# The procedure below is invoked when the mouse button is released
+# in a button widget. It restores the button's relief and invokes
+# the command as long as the mouse hasn't left the button.
+#
+# Arguments:
+# w - The name of the widget.
+sub butUp
+{
+ my $w = shift;
+ if (defined($buttonWindow) && $buttonWindow == $w)
+ {
+ undef $buttonWindow;
+ $w->configure('-relief' => $relief);
+ if ($w->IS($Tk::window) && $w->cget('-state') ne 'disabled')
+ {
+ $w->invoke;
+ }
+ }
+}
+
+# tkButtonInvoke --
+# The procedure below is called when a button is invoked through
+# the keyboard. It simulate a press of the button via the mouse.
+#
+# Arguments:
+# w - The name of the widget.
+sub Invoke
+{
+ my $w = shift;
+ if ($w->cget('-state') ne 'disabled')
+ {
+ my $oldRelief = $w->cget('-relief');
+ my $oldState = $w->cget('-state');
+ $w->configure('-state' => 'active', '-relief' => 'sunken');
+ $w->idletasks;
+ $w->after(100);
+ $w->configure('-state' => $oldState, '-relief' => $oldRelief);
+ $w->invoke;
+ }
+}
+
+
+
+1;
+
+__END__
+
+
+
+
+
diff --git a/Master/tlpkg/installer/perllib/Tk/Checkbutton.pm b/Master/tlpkg/installer/perllib/Tk/Checkbutton.pm
new file mode 100644
index 00000000000..491d8cd2444
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/Tk/Checkbutton.pm
@@ -0,0 +1,42 @@
+package Tk::Checkbutton;
+# Conversion from Tk4.0 button.tcl competed.
+# Copyright (c) 1992-1994 The Regents of the University of California.
+# Copyright (c) 1994 Sun Microsystems, Inc.
+# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved.
+# This program is free software; you can redistribute it and/or
+
+
+use vars qw($VERSION);
+$VERSION = '4.006'; # $Id: //depot/Tkutf8/Tk/Checkbutton.pm#6 $
+
+# modify it under the same terms as Perl itself, subject
+# to additional disclaimer in license.terms due to partial
+# derivation from Tk4.0 sources.
+
+require Tk::Widget;
+require Tk::Button;
+
+use base qw(Tk::Button);
+
+Construct Tk::Widget 'Checkbutton';
+
+sub Tk_cmd { \&Tk::checkbutton }
+
+
+sub ClassInit
+{
+ my ($class,$mw) = @_;
+ $mw->bind($class,'<Enter>', 'Enter');
+ $mw->bind($class,'<Leave>', 'Leave');
+ $mw->bind($class,'<1>', 'Invoke');
+ $mw->bind($class,'<space>', 'Invoke');
+ return $class;
+}
+
+sub Invoke
+{
+ my $w = shift;
+ $w->invoke() unless($w->cget('-state') eq 'disabled');
+}
+
+1;
diff --git a/Master/tlpkg/installer/perllib/Tk/Clipboard.pm b/Master/tlpkg/installer/perllib/Tk/Clipboard.pm
new file mode 100644
index 00000000000..b0eb0ea2b07
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/Tk/Clipboard.pm
@@ -0,0 +1,122 @@
+# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+package Tk::Clipboard;
+use strict;
+
+use vars qw($VERSION);
+$VERSION = sprintf '4.%03d', q$Revision: #8 $ =~ /\D(\d+)\s*$/;
+
+use AutoLoader qw(AUTOLOAD);
+use Tk qw(catch);
+
+sub clipEvents
+{
+ return qw[Copy Cut Paste];
+}
+
+sub ClassInit
+{
+ my ($class,$mw) = @_;
+ foreach my $op ($class->clipEvents)
+ {
+ $mw->Tk::bind($class,"<<$op>>","clipboard$op");
+ }
+ return $class;
+}
+
+sub clipboardSet
+{
+ my $w = shift;
+ $w->clipboardClear;
+ $w->clipboardAppend(@_);
+}
+
+sub clipboardCopy
+{
+ my $w = shift;
+ my $val = $w->getSelected;
+ if (defined $val)
+ {
+ $w->clipboardSet('--',$val);
+ }
+ return $val;
+}
+
+sub clipboardCut
+{
+ my $w = shift;
+ my $val = $w->clipboardCopy;
+ if (defined $val)
+ {
+ $w->deleteSelected;
+ }
+ return $val;
+}
+
+sub clipboardGet
+{
+ my $w = shift;
+ $w->SelectionGet('-selection','CLIPBOARD',@_);
+}
+
+sub clipboardPaste
+{
+ my $w = shift;
+ local $@;
+ catch
+ {
+## Different from Tcl/Tk version:
+# if ($w->windowingsystem eq 'x11')
+# {
+# catch
+# {
+# $w->deleteSelected;
+# };
+# }
+ $w->insert("insert", $w->clipboardGet);
+ $w->SeeInsert if $w->can('SeeInsert');
+ };
+}
+
+sub clipboardOperations
+{
+ my @class = ();
+ my $mw = shift;
+ if (ref $mw)
+ {
+ $mw = $mw->DelegateFor('bind');
+ }
+ else
+ {
+ push(@class,$mw);
+ $mw = shift;
+ }
+ while (@_)
+ {
+ my $op = shift;
+ $mw->Tk::bind(@class,"<<$op>>","clipboard$op");
+ }
+}
+
+# These methods work for Entry and Text
+# and can be overridden where they don't work
+
+sub deleteSelected
+{
+ my $w = shift;
+ catch { $w->delete('sel.first','sel.last') };
+}
+
+
+1;
+__END__
+
+sub getSelected
+{
+ my $w = shift;
+ my $val = Tk::catch { $w->get('sel.first','sel.last') };
+ return $val;
+}
+
+
diff --git a/Master/tlpkg/installer/perllib/Tk/CmdLine.pm b/Master/tlpkg/installer/perllib/Tk/CmdLine.pm
new file mode 100644
index 00000000000..2e821e826ae
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/Tk/CmdLine.pm
@@ -0,0 +1,954 @@
+package Tk::CmdLine; # -*-Perl-*-
+
+#/----------------------------------------------------------------------------//
+#/ Module: Tk/CmdLine.pm
+#/
+#/ Purpose:
+#/
+#/ Process standard X11 command line options and set initial resources.
+#/
+#/ Author: ???? Date: ????
+#/
+#/ History: SEE POD
+#/----------------------------------------------------------------------------//
+
+use vars qw($VERSION);
+$VERSION = '4.006'; # $Id: //depot/Tkutf8/Tk/CmdLine.pm#6 $
+
+use 5.004;
+
+use strict;
+
+use Config;
+
+my $OBJECT = undef; # define the current object
+
+#/----------------------------------------------------------------------------//
+#/ Constructor
+#/ Returns the object reference.
+#/----------------------------------------------------------------------------//
+
+sub new # Tk::CmdLine::new()
+{
+ my $this = shift(@_);
+ my $class = ref($this) || $this;
+
+ my $name = 'pTk';
+ $name = $1 if (($0 =~ m/(?:^|[\/\\])([\w-]+)(?:\.\w+)?$/) && ($1 ne '-e'));
+
+ my $self = {
+ name => $name,
+ config => { -name => $name },
+ options => {},
+ methods => {},
+ command => [],
+ synchronous => 0,
+ iconic => 0,
+ motif => ($Tk::strictMotif || 0),
+ resources => {} };
+
+ return bless($self, $class);
+}
+
+#/----------------------------------------------------------------------------//
+#/ Process the arguments in a given array or in @ARGV.
+#/ Returns the object reference.
+#/----------------------------------------------------------------------------//
+
+sub Argument_ # Tk::CmdLine::Argument_($flag) # private method
+{
+ my $self = shift(@_);
+ my $flag = shift(@_);
+ unless ($self->{offset} < @{$self->{argv}})
+ {
+ die 'Usage: ', $self->{name}, ' ... ', $flag, " <argument> ...\n";
+ }
+ return splice(@{$self->{argv}}, $self->{offset}, 1);
+}
+
+sub Config_ # Tk::CmdLine::Config_($flag, $name) # private method
+{
+ my $self = shift(@_);
+ my ($flag, $name) = @_;
+ my $val = $self->Argument_($flag);
+ push(@{$self->{command}}, $flag, $val);
+ $self->{config}->{"-$name"} = $val;
+}
+
+sub Flag_ # Tk::CmdLine::Flag_($flag, $name) # private method
+{
+ my $self = shift(@_);
+ my ($flag, $name) = @_;
+ push(@{$self->{command}}, $flag);
+ $self->{$name} = 1;
+}
+
+sub Option_ # Tk::CmdLine::Option_($flag, $name) # private method
+{
+ my $self = shift(@_);
+ my ($flag, $name) = @_;
+ my $val = $self->Argument_($flag);
+ push(@{$self->{command}}, $flag, $val);
+ $self->{options}->{"*$name"} = $val;
+}
+
+sub Method_ # Tk::CmdLine::Method_($flag, $name) # private method
+{
+ my $self = shift(@_);
+ my ($flag, $name) = @_;
+ my $val = $self->Argument_($flag);
+ push(@{$self->{command}}, $flag, $val);
+ $self->{methods}->{$name} = $val;
+}
+
+sub Resource_ # Tk::CmdLine::Resource_($flag, $name) # private method
+{
+ my $self = shift(@_);
+ my ($flag, $name) = @_;
+ my $val = $self->Argument_($flag);
+ if ($val =~ /^([^!:\s]+)*\s*:\s*(.*)$/)
+ {
+ push(@{$self->{command}}, $flag, $val);
+ $self->{options}->{$1} = $2;
+ }
+}
+
+my %Method = (
+ background => 'Option_',
+ bg => 'background', # alias
+ class => 'Config_',
+ display => 'screen', # alias
+ fg => 'foreground', # alias
+ fn => 'font', # alias
+ font => 'Option_',
+ foreground => 'Option_',
+ geometry => 'Method_',
+ iconic => 'Flag_',
+ iconposition => 'Method_',
+ motif => 'Flag_',
+ name => 'Config_',
+ screen => 'Config_',
+ synchronous => 'Flag_',
+ title => 'Config_',
+ xrm => 'Resource_'
+);
+
+sub SetArguments # Tk::CmdLine::SetArguments([@argument])
+{
+ my $self = (@_ # define the object as necessary
+ ? ((ref($_[0]) eq __PACKAGE__)
+ ? shift(@_)
+ : (($_[0] eq __PACKAGE__) ? shift(@_) : 1) && ($OBJECT ||= __PACKAGE__->new()))
+ : ($OBJECT ||= __PACKAGE__->new()));
+ $OBJECT = $self; # update the current object
+ $self->{argv} = (@_ ? [ @_ ] : \@ARGV);
+ $self->{offset} = 0; # its existence will denote that this method has been called
+
+ my @option = ();
+
+ while ($self->{offset} < @{$self->{argv}})
+ {
+ last if ($self->{argv}->[$self->{offset}] eq '--');
+ unless (
+ (($self->{argv}->[$self->{offset}] =~ /^-{1,2}(\w+)$/) && (@option = $1)) ||
+ (($self->{argv}->[$self->{offset}] =~ /^--(\w+)=(.*)$/) && (@option = ($1, $2))))
+ {
+ ++$self->{offset};
+ next;
+ }
+
+ next if (!exists($Method{$option[0]}) && ++$self->{offset});
+
+ $option[0] = $Method{$option[0]} if exists($Method{$Method{$option[0]}});
+
+ my $method = $Method{$option[0]};
+
+ if (@option > 1) # replace --<option>=<value> with <value>
+ {
+ $self->{argv}->[$self->{offset}] = $option[1];
+ }
+ else # remove the argument
+ {
+ splice(@{$self->{argv}}, $self->{offset}, 1);
+ }
+
+ $self->$method(('-' . $option[0]), $option[0]);
+ }
+
+ $self->{config}->{-class} ||= ucfirst($self->{config}->{-name});
+
+ delete($self->{argv}); # no longer needed
+
+ return $self;
+}
+
+use vars qw(&process); *process = \&SetArguments; # alias to keep old code happy
+
+#/----------------------------------------------------------------------------//
+#/ Get a list of the arguments that have been processed by SetArguments().
+#/ Returns an array.
+#/----------------------------------------------------------------------------//
+
+sub GetArguments # Tk::CmdLine::GetArguments()
+{
+ my $self = (@_ # define the object as necessary
+ ? ((ref($_[0]) eq __PACKAGE__)
+ ? shift(@_)
+ : (($_[0] eq __PACKAGE__) ? shift(@_) : 1) && ($OBJECT ||= __PACKAGE__->new()))
+ : ($OBJECT ||= __PACKAGE__->new()));
+ $OBJECT = $self; # update the current object
+
+ $self->SetArguments() unless exists($self->{offset}); # set arguments if not yet done
+
+ return @{$self->{command}};
+}
+
+#/----------------------------------------------------------------------------//
+#/ Get the value of a configuration option (default: -class).
+#/ Returns the option value.
+#/----------------------------------------------------------------------------//
+
+sub cget # Tk::CmdLine::cget([$option])
+{
+ my $self = (@_ # define the object as necessary
+ ? ((ref($_[0]) eq __PACKAGE__)
+ ? shift(@_)
+ : (($_[0] eq __PACKAGE__) ? shift(@_) : 1) && ($OBJECT ||= __PACKAGE__->new()))
+ : ($OBJECT ||= __PACKAGE__->new()));
+ $OBJECT = $self; # update the current object
+ my $option = shift(@_) || '-class';
+
+ $self->SetArguments() unless exists($self->{offset}); # set arguments if not yet done
+
+ return (exists($self->{config}->{$option}) ? $self->{config}->{$option} : undef);
+}
+
+#/----------------------------------------------------------------------------//
+
+sub CreateArgs # Tk::CmdLine::CreateArgs()
+{
+ my $self = (@_ # define the object as necessary
+ ? ((ref($_[0]) eq __PACKAGE__)
+ ? shift(@_)
+ : (($_[0] eq __PACKAGE__) ? shift(@_) : 1) && ($OBJECT ||= __PACKAGE__->new()))
+ : ($OBJECT ||= __PACKAGE__->new()));
+ $OBJECT = $self; # update the current object
+
+ $self->SetArguments() unless exists($self->{offset}); # set arguments if not yet done
+
+ return $self->{config};
+}
+
+#/----------------------------------------------------------------------------//
+
+sub Tk::MainWindow::apply_command_line
+{
+ my $mw = shift(@_);
+
+ my $self = ($OBJECT ||= __PACKAGE__->new());
+
+ $self->SetArguments() unless exists($self->{offset}); # set arguments if not yet done
+
+ foreach my $priority (keys(%{$self->{resources}}))
+ {
+ foreach my $resource (@{$self->{resources}->{$priority}})
+ {
+ $mw->optionAdd(@{$resource}, $priority);
+ }
+ }
+
+ foreach my $key (keys(%{$self->{options}}))
+ {
+ $mw->optionAdd($key => $self->{options}->{$key}, 'interactive');
+ }
+
+ foreach my $key (keys(%{$self->{methods}}))
+ {
+ $mw->$key($self->{methods}->{$key});
+ }
+
+ if ($self->{methods}->{geometry})
+ {
+ if ($self->{methods}->{geometry} =~ /[+-]\d+[+-]\d+/)
+ {
+ $mw->positionfrom('user');
+ }
+ if ($self->{methods}->{geometry} =~ /\d+x\d+/)
+ {
+ $mw->sizefrom('user');
+ }
+ delete $self->{methods}->{geometry}; # XXX needed?
+ }
+
+ $mw->Synchronize() if $self->{synchronous};
+
+ if ($self->{iconic})
+ {
+ $mw->iconify();
+ $self->{iconic} = 0;
+ }
+
+ $Tk::strictMotif = ($self->{motif} || 0);
+
+ # Both these are needed to reliably save state
+ # but 'hostname' is tricky to do portably.
+ # $mw->client(hostname());
+ $mw->protocol('WM_SAVE_YOURSELF' => ['WMSaveYourself',$mw]);
+ $mw->command([ $self->{name}, @{$self->{command}} ]);
+}
+
+#/----------------------------------------------------------------------------//
+#/ Set the initial resources.
+#/ Returns the object reference.
+#/----------------------------------------------------------------------------//
+
+sub SetResources # Tk::CmdLine::SetResources((\@resource | $resource) [, $priority])
+{
+ my $self = (@_ # define the object as necessary
+ ? ((ref($_[0]) eq __PACKAGE__)
+ ? shift(@_)
+ : (($_[0] eq __PACKAGE__) ? shift(@_) : 1) && ($OBJECT ||= __PACKAGE__->new()))
+ : ($OBJECT ||= __PACKAGE__->new()));
+ $OBJECT = $self; # update the current object
+
+ $self->SetArguments() unless exists($self->{offset}); # set arguments if not yet done
+ return $self unless @_;
+
+ my $data = shift(@_);
+ my $priority = shift(@_) || 'userDefault';
+
+ $self->{resources}->{$priority} = [] unless exists($self->{resources}->{$priority});
+
+ foreach my $resource ((ref($data) eq 'ARRAY') ? @{$data} : $data)
+ {
+ if (ref($resource) eq 'ARRAY') # resources in [ <pattern>, <value> ] format
+ {
+ push(@{$self->{resources}->{$priority}}, [ @{$resource} ])
+ if (@{$resource} == 2);
+ }
+ else # resources in resource file format
+ {
+ push(@{$self->{resources}->{$priority}}, [ $1, $2 ])
+ if ($resource =~ /^([^!:\s]+)*\s*:\s*(.*)$/);
+ }
+ }
+
+ return $self;
+}
+
+#/----------------------------------------------------------------------------//
+#/ Load initial resources from one or more files (default: $XFILESEARCHPATH with
+#/ priority 'startupFile' and $XUSERFILESEARCHPATH with priority 'userDefault').
+#/ Returns the object reference.
+#/----------------------------------------------------------------------------//
+
+sub LoadResources # Tk::CmdLine::LoadResources([%options])
+{
+ my $self = (@_ # define the object as necessary
+ ? ((ref($_[0]) eq __PACKAGE__)
+ ? shift(@_)
+ : (($_[0] eq __PACKAGE__) ? shift(@_) : 1) && ($OBJECT ||= __PACKAGE__->new()))
+ : ($OBJECT ||= __PACKAGE__->new()));
+ $OBJECT = $self; # update the current object
+
+ $self->SetArguments() unless exists($self->{offset}); # set arguments if not yet done
+
+ my %options = @_;
+
+ my @file = ();
+ my $echo = (exists($options{-echo})
+ ? (defined($options{-echo}) ? $options{-echo} : \*STDOUT) : undef);
+
+ unless (%options && (exists($options{-file}) || exists($options{-symbol})))
+ {
+ @file = (
+ { -symbol => 'XFILESEARCHPATH', -priority => 'startupFile' },
+ { -symbol => 'XUSERFILESEARCHPATH', -priority => 'userDefault' } );
+ }
+ else
+ {
+ @file = { %options };
+ }
+
+ my $delimiter = (($^O eq 'MSWin32') ? ';' : ':');
+
+ foreach my $file (@file)
+ {
+ my $fileSpec = $file->{-spec} = undef;
+ if (exists($file->{-symbol}))
+ {
+ my $xpath = undef;
+ if ($file->{-symbol} eq 'XUSERFILESEARCHPATH')
+ {
+ $file->{-priority} ||= 'userDefault';
+ foreach my $symbol (qw(XUSERFILESEARCHPATH XAPPLRESDIR HOME))
+ {
+ last if (exists($ENV{$symbol}) && ($xpath = $ENV{$symbol}));
+ }
+ next unless defined($xpath);
+ }
+ else
+ {
+ $file->{-priority} ||= (($file->{-symbol} eq 'XFILESEARCHPATH')
+ ? 'startupFile' : 'userDefault');
+ next unless (
+ exists($ENV{$file->{-symbol}}) && ($xpath = $ENV{$file->{-symbol}}));
+ }
+
+ unless (exists($self->{translation}))
+ {
+ $self->{translation} = {
+ '%l' => '', # ignored
+ '%C' => '', # ignored
+ '%S' => '', # ignored
+ '%L' => ($ENV{LANG} || 'C'), # language
+ '%T' => 'app-defaults', # type
+ '%N' => $self->{config}->{-class} # filename
+ };
+ }
+
+ my @postfix = map({ $_ . '/' . $self->{config}->{-class} }
+ ('/' . $self->{translation}->{'%L'}), '');
+
+ ITEM: foreach $fileSpec (split($Config{path_sep}, $xpath))
+ {
+ if ($fileSpec =~ s/(%[A-Za-z])/$self->{translation}->{$1}/g) # File Pattern
+ {
+ if (defined($echo) && ($file->{-symbol} ne 'XFILESEARCHPATH'))
+ {
+ print $echo 'Checking ', $fileSpec, "\n";
+ }
+ next unless ((-f $fileSpec) && (-r _) && (-s _));
+ $file->{-spec} = $fileSpec;
+ last;
+ }
+ else # Directory - Check for <Directory>/$LANG/<Class>, <Directory>/<CLASS>
+ {
+ foreach my $postfix (@postfix)
+ {
+ my $fileSpec2 = $fileSpec . $postfix;
+ if (defined($echo) && ($file->{-symbol} ne 'XFILESEARCHPATH'))
+ {
+ print $echo 'Checking ', $fileSpec2, "\n";
+ }
+ next unless ((-f $fileSpec2) && (-r _) && (-s _));
+ $file->{-spec} = $fileSpec2;
+ last ITEM;
+ }
+ }
+ }
+ }
+ elsif (exists($file->{-file}) && ($fileSpec = $file->{-file}))
+ {
+ print $echo 'Checking ', $fileSpec, "\n" if defined($echo);
+ next unless ((-f $fileSpec) && (-r _) && (-s _));
+ $file->{-spec} = $fileSpec;
+ }
+ }
+
+ foreach my $file (@file)
+ {
+ next unless defined($file->{-spec});
+ local *SPEC;
+ next unless open(SPEC,$file->{-spec});
+ print $echo ' Loading ', $file->{-spec}, "\n" if defined($echo);
+
+ my $resource = undef;
+ my @resource = ();
+ my $continuation = 0;
+
+ while (defined(my $line = <SPEC>))
+ {
+ chomp($line);
+ next if ($line =~ /^\s*$/); # skip blank lines
+ next if ($line =~ /^\s*!/); # skip comments
+ $continuation = ($line =~ s/\s*\\$/ /); # search for trailing backslash
+ unless (defined($resource)) # it is the first line
+ {
+ $resource = $line;
+ }
+ else # it is a continuation line
+ {
+ $line =~ s/^\s*//; # remove leading whitespace
+ $resource .= $line;
+ }
+ next if $continuation;
+ push(@resource, [ $1, $2 ]) if ($resource =~ /^([^:\s]+)*\s*:\s*(.*)$/);
+ $resource = undef;
+ }
+
+ close(SPEC);
+
+ if (defined($resource)) # special case - EOF after line with trailing backslash
+ {
+ push(@resource, [ $1, $2 ]) if ($resource =~ /^([^:\s]+)*\s*:\s*(.*)$/);
+ }
+
+ $self->SetResources(\@resource, $file->{-priority}) if @resource;
+ }
+
+ return $self;
+}
+
+#/----------------------------------------------------------------------------//
+
+1;
+
+__END__
+
+=cut
+
+=head1 NAME
+
+Tk::CmdLine - Process standard X11 command line options and set initial resources
+
+=for pm Tk/CmdLine.pm
+
+=for category Creating and Configuring Widgets
+
+=head1 SYNOPSIS
+
+ Tk::CmdLine::SetArguments([@argument]);
+
+ my $value = Tk::CmdLine::cget([$option]);
+
+ Tk::CmdLine::SetResources((\@resource | $resource) [, $priority]);
+
+ Tk::CmdLine::LoadResources(
+ [ -symbol => $symbol ]
+ [ -file => $fileSpec ]
+ [ -priority => $priority ]
+ [ -echo => $fileHandle ] );
+
+=head1 DESCRIPTION
+
+Process standard X11 command line options and set initial resources.
+
+The X11R5 man page for X11 says: "Most X programs attempt to use the same names
+for command line options and arguments. All applications written with the
+X Toolkit Intrinsics automatically accept the following options: ...".
+This module processes these command line options for perl/Tk applications
+using the C<SetArguments>() function.
+
+This module can optionally be used to load initial resources explicitly via
+function C<SetResources>(), or from specified files (default: the standard X11
+application-specific resource files) via function C<LoadResources>().
+
+=head2 Command Line Options
+
+=over 4
+
+=item B<-background> I<Color> | B<-bg> I<Color>
+
+Specifies the color to be used for the window background.
+
+=item B<-class> I<Class>
+
+Specifies the class under which resources for the application should be found.
+This option is useful in shell aliases to distinguish between invocations
+of an application, without resorting to creating links to alter the executable
+file name.
+
+=item B<-display> I<Display> | B<-screen> I<Display>
+
+Specifies the name of the X server to be used.
+
+=item B<-font> I<Font> | B<-fn> I<Font>
+
+Specifies the font to be used for displaying text.
+
+=item B<-foreground> I<Color> | B<-fg> I<Color>
+
+Specifies the color to be used for text or graphics.
+
+=item B<-geometry> I<Geometry>
+
+Specifies the initial size and location of the I<first>
+L<MainWindow|Tk::MainWindow>.
+
+=item B<-iconic>
+
+Indicates that the user would prefer that the application's windows initially
+not be visible as if the windows had been immediately iconified by the user.
+Window managers may choose not to honor the application's request.
+
+=item B<-motif>
+
+Specifies that the application should adhere as closely as possible to Motif
+look-and-feel standards. For example, active elements such as buttons and
+scrollbar sliders will not change color when the pointer passes over them.
+
+=item B<-name> I<Name>
+
+Specifies the name under which resources for the application should be found.
+This option is useful in shell aliases to distinguish between invocations
+of an application, without resorting to creating links to alter the executable
+file name.
+
+=item B<-synchronous>
+
+Indicates that requests to the X server should be sent synchronously, instead of
+asynchronously. Since Xlib normally buffers requests to the server, errors do
+do not necessarily get reported immediately after they occur. This option turns
+off the buffering so that the application can be debugged. It should never
+be used with a working program.
+
+=item B<-title> I<TitleString>
+
+This option specifies the title to be used for this window. This information is
+sometimes used by a window manager to provide some sort of header identifying
+the window.
+
+=item B<-xrm> I<ResourceString>
+
+Specifies a resource pattern and value to override any defaults. It is also
+very useful for setting resources that do not have explicit command line
+arguments.
+
+The I<ResourceString> is of the form E<lt>I<pattern>E<gt>:E<lt>I<value>E<gt>,
+that is (the first) ':' is used to determine which part is pattern and which
+part is value. The (E<lt>I<pattern>E<gt>, E<lt>I<value>E<gt>) pair is entered
+into the options database with B<optionAdd> (for each
+L<MainWindow|Tk::MainWindow> configured), with I<interactive> priority.
+
+=back
+
+=head2 Initial Resources
+
+There are several mechanism for initializing the resource database to be used
+by an X11 application. Resources may be defined in a $C<HOME>/.Xdefaults file,
+a system application defaults file (e.g.
+/usr/lib/X11/app-defaults/E<lt>B<CLASS>E<gt>),
+or a user application defaults file (e.g. $C<HOME>/E<lt>B<CLASS>E<gt>).
+The Tk::CmdLine functionality for setting initial resources concerns itself
+with the latter two.
+
+Resource files contain data lines of the form
+E<lt>I<pattern>E<gt>:E<lt>I<value>E<gt>.
+They may also contain blank lines and comment lines (denoted
+by a ! character as the first non-blank character). Refer to L<option|Tk::option>
+for a description of E<lt>I<pattern>E<gt>:E<lt>I<value>E<gt>.
+
+=over 4
+
+=item System Application Defaults Files
+
+System application defaults files may be specified via environment variable
+$C<XFILESEARCHPATH> which, if set, contains a list of file patterns
+(joined using the OS-dependent path delimiter, e.g. colon on B<UNIX>).
+
+=item User Application Defaults Files
+
+User application defaults files may be specified via environment variables
+$C<XUSERFILESEARCHPATH>, $C<XAPPLRESDIR> or $C<HOME>.
+
+=back
+
+=head1 METHODS
+
+=over 4
+
+=item B<SetArguments> - Tk::CmdLine::SetArguments([@argument])
+
+Extract the X11 options contained in a specified array (@ARGV by default).
+
+ Tk::CmdLine::SetArguments([@argument])
+
+The X11 options may be specified using a single dash I<-> as per the X11
+convention, or using two dashes I<--> as per the POSIX standard (e.g.
+B<-geometry> I<100x100>, B<-geometry> I<100x100> or B<-geometry=>I<100x100>).
+The options may be interspersed with other options or arguments.
+A I<--> by itself terminates option processing.
+
+By default, command line options are extracted from @ARGV the first time
+a MainWindow is created. The Tk::MainWindow constructor indirectly invokes
+C<SetArguments>() to do this.
+
+=item B<GetArguments> - Tk::CmdLine::GetArguments()
+
+Get a list of the X11 options that have been processed by C<SetArguments>().
+(C<GetArguments>() first invokes C<SetArguments>() if it has not already been invoked.)
+
+=item B<cget> - Tk::CmdLine::cget([$option])
+
+Get the value of a configuration option specified via C<SetArguments>().
+(C<cget>() first invokes C<SetArguments>() if it has not already been invoked.)
+
+ Tk::CmdLine::cget([$option])
+
+The valid options are: B<-class>, B<-name>, B<-screen> and B<-title>.
+If no option is specified, B<-class> is implied.
+
+A typical use of C<cget>() might be to obtain the application class in order
+to define the name of a resource file to be loaded in via C<LoadResources>().
+
+ my $class = Tk::CmdLine::cget(); # process command line and return class
+
+=item B<SetResources> - Tk::CmdLine::SetResources((\@resource | $resource) [, $priority])
+
+Set the initial resources.
+
+ Tk::CmdLine::SetResources((\@resource | $resource) [, $priority])
+
+A single resource may be specified using a string of the form
+'E<lt>I<pattern>E<gt>:E<lt>I<value>E<gt>'. Multiple resources may be specified
+by passing an array reference whose elements are either strings of the above
+form, and/or anonymous arrays of the form [ E<lt>I<pattern>E<gt>,
+E<lt>I<value>E<gt> ]. The optional second argument specifies the priority,
+as defined in L<option|Tk::option>, to be associated with the resources
+(default: I<userDefault>).
+
+Note that C<SetResources>() first invokes C<SetArguments>() if it has not already
+been invoked.
+
+=item B<LoadResources> - Tk::CmdLine::LoadResources([%options])
+
+Load initial resources from one or more files.
+
+ Tk::CmdLine::LoadResources(
+ [ -symbol => $symbol ]
+ [ -file => $fileSpec ]
+ [ -priority => $priority ]
+ [ -echo => $fileHandle ] );
+
+[ B<-symbol> =E<gt> $symbol ] specifies the name of an environment variable
+that, if set, defines a list of one or more directories and/or file patterns
+(joined using the OS-dependent path delimiter, e.g. colon on B<UNIX>).
+$C<XUSERFILESEARCHPATH> is a special case.
+If $C<XUSERFILESEARCHPATH> is not set, $C<XAPPLRESDIR> is checked instead.
+If $C<XAPPLRESDIR> is not set, $C<HOME> is checked instead.
+
+An item is identified as a file pattern if it contains one or more /%[A-Za-z]/
+patterns. Only patterns B<%L>, B<%T> and B<%N> are currently recognized. All
+others are replaced with the null string. Pattern B<%L> is translated into
+$C<LANG>. Pattern B<%T> is translated into I<app-defaults>. Pattern B<%N> is
+translated into the application class name.
+
+Each file pattern, after substitutions are applied, is assumed to define a
+FileSpec to be examined.
+
+When a directory is specified, FileSpecs
+E<lt>B<DIRECTORY>E<gt>/E<lt>B<LANG>E<gt>/E<lt>B<CLASS>E<gt>
+and E<lt>B<DIRECTORY>E<gt>/E<lt>B<CLASS>E<gt> are defined, in that order.
+
+[ B<-file> =E<gt> $fileSpec ] specifies a resource file to be loaded in.
+The file is silently skipped if if does not exist, or if it is not readable.
+
+[ B<-priority> =E<gt> $priority ] specifies the priority, as defined in
+L<option|Tk::option>, to be associated with the resources
+(default: I<userDefault>).
+
+[ B<-echo> =E<gt> $fileHandle ] may be used to specify that a line should be
+printed to the corresponding FileHandle (default: \*STDOUT) everytime a file
+is examined / loaded.
+
+If no B<-symbol> or B<-file> options are specified, C<LoadResources>()
+processes symbol $C<XFILESEARCHPATH> with priority I<startupFile> and
+$C<XUSERFILESEARCHPATH> with priority I<userDefault>.
+(Note that $C<XFILESEARCHPATH> and $C<XUSERFILESEARCHPATH> are supposed to
+contain only patterns. $C<XAPPLRESDIR> and $C<HOME> are supposed to be a single
+directory. C<LoadResources>() does not check/care whether this is the case.)
+
+For each set of FileSpecs, C<LoadResources>() examines each FileSpec to
+determine if the file exists and is readable. The first file that meets this
+criteria is read in and C<SetResources>() is invoked.
+
+Note that C<LoadResources>() first invokes C<SetArguments>() if it has not already
+been invoked.
+
+=back
+
+=head1 NOTES
+
+This module is an object-oriented module whose methods can be invoked as object
+methods, class methods or regular functions. This is accomplished via an
+internally-maintained object reference which is created as necessary, and which
+always points to the last object used. C<SetArguments>(), C<SetResources>() and
+C<LoadResources>() return the object reference.
+
+=head1 EXAMPLES
+
+=over
+
+=item 1
+
+@ARGV is processed by Tk::CmdLine at MainWindow creation.
+
+ use Tk;
+
+ # <Process @ARGV - ignoring all X11-specific options>
+
+ my $mw = MainWindow->new();
+
+ MainLoop();
+
+=item 2
+
+@ARGV is processed by Tk::CmdLine before MainWindow creation.
+An @ARGV of (--geometry=100x100 -opt1 a b c -bg red)
+is equal to (-opt1 a b c) after C<SetArguments>() is invoked.
+
+ use Tk;
+
+ Tk::CmdLine::SetArguments(); # Tk::CmdLine->SetArguments() works too
+
+ # <Process @ARGV - not worrying about X11-specific options>
+
+ my $mw = MainWindow->new();
+
+ MainLoop();
+
+=item 3
+
+Just like 2) except that default arguments are loaded first.
+
+ use Tk;
+
+ Tk::CmdLine::SetArguments(qw(-name test -iconic));
+ Tk::CmdLine::SetArguments();
+
+ # <Process @ARGV - not worrying about X11-specific options>
+
+ my $mw = MainWindow->new();
+
+ MainLoop();
+
+=item 4
+
+@ARGV is processed by Tk::CmdLine before MainWindow creation.
+Standard resource files are loaded in before MainWindow creation.
+
+ use Tk;
+
+ Tk::CmdLine::SetArguments();
+
+ # <Process @ARGV - not worrying about X11-specific options>
+
+ Tk::CmdLine::LoadResources();
+
+ my $mw = MainWindow->new();
+
+ MainLoop();
+
+=item 5
+
+@ARGV is processed by Tk::CmdLine before MainWindow creation.
+Standard resource files are loaded in before MainWindow creation
+using non-default priorities.
+
+ use Tk;
+
+ Tk::CmdLine::SetArguments();
+
+ # <Process @ARGV - not worrying about X11-specific options>
+
+ Tk::CmdLine::LoadResources(-echo => \*STDOUT,
+ -priority => 65, -symbol => 'XFILESEARCHPATH' );
+ Tk::CmdLine::LoadResources(-echo => \*STDOUT,
+ -priority => 75, -symbol => 'XUSERFILESEARCHPATH' );
+
+ my $mw = MainWindow->new();
+
+ MainLoop();
+
+=item 6
+
+@ARGV is processed by Tk::CmdLine before MainWindow creation.
+Standard resource files are loaded in before MainWindow creation.
+Individual resources are also loaded in before MainWindow creation.
+
+ use Tk;
+
+ Tk::CmdLine::SetArguments();
+
+ # <Process @ARGV - not worrying about X11-specific options>
+
+ Tk::CmdLine::LoadResources();
+
+ Tk::CmdLine::SetResources( # set a single resource
+ '*Button*background: red',
+ 'widgetDefault' );
+
+ Tk::CmdLine::SetResources( # set multiple resources
+ [ '*Button*background: red', '*Button*foreground: blue' ],
+ 'widgetDefault' );
+
+ my $mw = MainWindow->new();
+
+ MainLoop();
+
+=back
+
+=head1 ENVIRONMENT
+
+=over 4
+
+=item B<HOME> (optional)
+
+Home directory which may contain user application defaults files as
+$C<HOME>/$C<LANG>/E<lt>B<CLASS>E<gt> or $C<HOME>/E<lt>B<CLASS>E<gt>.
+
+=item B<LANG> (optional)
+
+The current language (default: I<C>).
+
+=item B<XFILESEARCHPATH> (optional)
+
+List of FileSpec patterns
+(joined using the OS-dependent path delimiter, e.g. colon on B<UNIX>)
+used in defining system application defaults files.
+
+=item B<XUSERFILESEARCHPATH> (optional)
+
+List of FileSpec patterns
+(joined using the OS-dependent path delimiter, e.g. colon on B<UNIX>)
+used in defining user application defaults files.
+
+=item B<XAPPLRESDIR> (optional)
+
+Directory containing user application defaults files as
+$C<XAPPLRESDIR>/$C<LANG>/E<lt>B<CLASS>E<gt> or
+$C<XAPPLRESDIR>/E<lt>B<CLASS>E<gt>.
+
+=back
+
+=head1 SEE ALSO
+
+L<MainWindow|Tk::MainWindow>
+L<option|Tk::option>
+
+=head1 HISTORY
+
+=over 4
+
+=item *
+
+1999.03.04 Ben Pavon E<lt>ben.pavon@hsc.hac.comE<gt>
+
+Rewritten as an object-oriented module.
+
+Allow one to process command line options in a specified array (@ARGV by default).
+Eliminate restrictions on the format and location of the options within the array
+(previously the X11 options could not be specified in POSIX format and had to be
+at the beginning of the array).
+
+Added the C<SetResources>() and C<LoadResources>() functions to allow the definition
+of resources prior to MainWindow creation.
+
+=item *
+
+2000.08.31 Ben Pavon E<lt>ben.pavon@hsc.hac.comE<gt>
+
+Added the C<GetArguments>() method which returns the list of arguments that
+have been processed by C<SetArguments>().
+
+Modified C<LoadResources>() to split the symbols using the OS-dependent
+path delimiter defined in the B<Config> module.
+
+Modified C<LoadResources>() to eliminate a warning message when processing
+patterns B<%l>, B<%C>, B<%S>.
+
+=back
+
+=cut
+
diff --git a/Master/tlpkg/installer/perllib/Tk/Configure.pm b/Master/tlpkg/installer/perllib/Tk/Configure.pm
new file mode 100644
index 00000000000..26252ae4958
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/Tk/Configure.pm
@@ -0,0 +1,69 @@
+package Tk::Configure;
+use vars qw($VERSION);
+$VERSION = '4.008'; # $Id: //depot/Tkutf8/Tk/Configure.pm#8 $
+
+use Carp;
+use Tk::Pretty;
+
+
+# Class that handles cget/configure for options that
+# need translating from public form
+# e.g. $cw->configure(-label => 'fred')
+# into $cw->subwiget('label')->configure(-text => 'fred')
+# Should probably do something clever with regexp's here
+
+
+sub new
+{
+ my ($class,@args) = @_;
+ unshift(@args,'configure','cget') if (@args < 3);
+ return bless \@args,$class;
+}
+
+sub cget
+{
+ croak('Wrong number of args to cget') unless (@_ == 2);
+ my ($alias,$key) = @_;
+ my ($set,$get,$widget,@args) = @$alias;
+ $widget->$get(@args);
+}
+
+sub configure
+{
+ my $alias = shift;
+ shift if (@_);
+ my ($set,$get,$widget,@args) = @$alias;
+ if (wantarray)
+ {
+ my @results;
+ eval { @results = $widget->$set(@args,@_) };
+ croak($@) if $@;
+ return @results;
+ }
+ else
+ {
+ my $results;
+ eval { $results = $widget->$set(@args,@_) };
+ croak($@) if $@;
+ return $results;
+ }
+}
+
+*TIESCALAR = \&new;
+*TIEHASH = \&new;
+
+sub FETCH
+{
+ my $alias = shift;
+ my ($set,$get,$widget,@args) = @$alias;
+ return $widget->$get(@args,@_);
+}
+
+sub STORE
+{
+ my $alias = shift;
+ my ($set,$get,$widget,@args) = @$alias;
+ $widget->$set(@args,@_);
+}
+
+1;
diff --git a/Master/tlpkg/installer/perllib/Tk/Derived.pm b/Master/tlpkg/installer/perllib/Tk/Derived.pm
new file mode 100644
index 00000000000..c31c205d2fb
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/Tk/Derived.pm
@@ -0,0 +1,512 @@
+# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+package Tk::Derived;
+require Tk::Widget;
+require Tk::Configure;
+use strict;
+use Carp;
+
+use vars qw($VERSION);
+$VERSION = sprintf '4.%03d', q$Revision: #10 $ =~ /\D(\d+)\s*$/;
+
+$Tk::Derived::Debug = 0;
+
+my $ENHANCED_CONFIGSPECS = 0; # disable for now
+
+use Tk qw(NORMAL_BG BLACK);
+
+sub Subwidget
+{
+ my $cw = shift;
+ my @result = ();
+ if (exists $cw->{SubWidget})
+ {
+ if (@_)
+ {
+ foreach my $name (@_)
+ {
+ push(@result,$cw->{SubWidget}{$name}) if (exists $cw->{SubWidget}{$name});
+ }
+ }
+ else
+ {
+ @result = values %{$cw->{SubWidget}};
+ }
+ }
+ return (wantarray) ? @result : $result[0];
+}
+
+sub _makelist
+{
+ my $widget = shift;
+ my (@specs) = (ref $widget && ref $widget eq 'ARRAY') ? (@$widget) : ($widget);
+ return @specs;
+}
+
+sub Subconfigure
+{
+ # This finds the widget or widgets to to which to apply a particular
+ # configure option
+ my ($cw,$opt) = @_;
+ my $config = $cw->ConfigSpecs;
+ my $widget;
+ my @subwidget = ();
+ my @arg = ();
+ if (defined $opt)
+ {
+ $widget = $config->{$opt};
+ unless (defined $widget)
+ {
+ $widget = ($opt =~ /^-(.*)$/) ? $config->{$1} : $config->{-$opt};
+ }
+ # Handle alias entries
+ if (defined($widget) && !ref($widget))
+ {
+ $opt = $widget;
+ $widget = $config->{$widget};
+ }
+ push(@arg,$opt) unless ($opt eq 'DEFAULT');
+ }
+ $widget = $config->{DEFAULT} unless (defined $widget);
+ if (defined $widget)
+ {
+ $cw->BackTrace("Invalid ConfigSpecs $widget") unless (ref($widget) && (ref $widget eq 'ARRAY'));
+ $widget = $widget->[0];
+ }
+ else
+ {
+ $widget = 'SELF';
+ }
+ foreach $widget (_makelist($widget))
+ {
+ $widget = 'SELF' if (ref($widget) && $widget == $cw);
+ if (ref $widget)
+ {
+ my $ref = ref $widget;
+ if ($ref eq 'ARRAY')
+ {
+ $widget = Tk::Configure->new(@$widget);
+ push(@subwidget,$widget)
+ }
+ elsif ($ref eq 'HASH')
+ {
+ foreach my $key (%$widget)
+ {
+ foreach my $sw (_makelist($widget->{$key}))
+ {
+ push(@subwidget,Tk::Configure->new($sw,$key));
+ }
+ }
+ }
+ else
+ {
+ push(@subwidget,$widget)
+ }
+ }
+ elsif ($widget eq 'ADVERTISED')
+ {
+ push(@subwidget,$cw->Subwidget)
+ }
+ elsif ($widget eq 'DESCENDANTS')
+ {
+ push(@subwidget,$cw->Descendants)
+ }
+ elsif ($widget eq 'CHILDREN')
+ {
+ push(@subwidget,$cw->children)
+ }
+ elsif ($widget eq 'METHOD')
+ {
+ my ($method) = ($opt =~ /^-?(.*)$/);
+ push(@subwidget,Tk::Configure->new($method,$method,$cw))
+ }
+ elsif ($widget eq 'SETMETHOD')
+ {
+ my ($method) = ($opt =~ /^-?(.*)$/);
+ push(@subwidget,Tk::Configure->new($method,'_cget',$cw,@arg))
+ }
+ elsif ($widget eq 'SELF')
+ {
+ push(@subwidget,Tk::Configure->new('Tk::configure', 'Tk::cget', $cw,@arg))
+ }
+ elsif ($widget eq 'PASSIVE')
+ {
+ push(@subwidget,Tk::Configure->new('_configure','_cget',$cw,@arg))
+ }
+ elsif ($widget eq 'CALLBACK')
+ {
+ push(@subwidget,Tk::Configure->new('_callback','_cget',$cw,@arg))
+ }
+ else
+ {
+ push(@subwidget,$cw->Subwidget($widget));
+ }
+ }
+ $cw->BackTrace("No delegate subwidget '$widget' for $opt") unless (@subwidget);
+ return (wantarray) ? @subwidget : $subwidget[0];
+}
+
+sub _cget
+{
+ my ($cw,$opt) = @_;
+ $cw->BackTrace('Wrong number of args to cget') unless (@_ == 2);
+ return $cw->{Configure}{$opt}
+}
+
+sub _configure
+{
+ my ($cw,$opt,$val) = @_;
+ $cw->BackTrace('Wrong number of args to configure') unless (@_ == 3);
+ $cw->{Configure}{$opt} = $val;
+}
+
+sub _callback
+{
+ my ($cw,$opt,$val) = @_;
+ $cw->BackTrace('Wrong number of args to configure') unless (@_ == 3);
+ $val = Tk::Callback->new($val) if defined($val) && ref($val);
+ $cw->{Configure}{$opt} = $val;
+}
+
+sub cget
+{my ($cw,$opt) = @_;
+ my @result;
+ local $SIG{'__DIE__'};
+ foreach my $sw ($cw->Subconfigure($opt))
+ {
+ if (wantarray)
+ {
+ eval { @result = $sw->cget($opt) };
+ }
+ else
+ {
+ eval { $result[0] = $sw->cget($opt) };
+ }
+ last unless $@;
+ }
+ return wantarray ? @result : $result[0];
+}
+
+sub Configured
+{
+ # Called whenever a derived widget is re-configured
+ my ($cw,$args,$changed) = @_;
+ if (@_ > 1)
+ {
+ $cw->afterIdle(['ConfigChanged',$cw,$changed]) if (%$changed);
+ }
+ return exists $cw->{'Configure'};
+}
+
+sub configure
+{
+ # The default composite widget configuration method uses hash stored
+ # in the widget's hash to map configuration options
+ # onto subwidgets.
+ #
+ my @results = ();
+ my $cw = shift;
+ if (@_ <= 1)
+ {
+ # Enquiry cases
+ my $spec = $cw->ConfigSpecs;
+ if (@_)
+ {
+ # Return info on the nominated option
+ my $opt = $_[0];
+ my $info = $spec->{$opt};
+ unless (defined $info)
+ {
+ $info = ($opt =~ /^-(.*)$/) ? $spec->{$1} : $spec->{-$opt};
+ }
+ if (defined $info)
+ {
+ if (ref $info)
+ {
+ # If the default slot is undef then ask subwidgets in turn
+ # for their default value until one accepts it.
+ if ($ENHANCED_CONFIGSPECS && !defined($info->[3]))
+ {local $SIG{'__DIE__'};
+ my @def;
+ foreach my $sw ($cw->Subconfigure($opt))
+ {
+ eval { @def = $sw->configure($opt) };
+ last unless $@;
+ }
+ $info->[3] = $def[3];
+ $info->[1] = $def[1] unless defined $info->[1];
+ $info->[2] = $def[2] unless defined $info->[2];
+ }
+ push(@results,$opt,$info->[1],$info->[2],$info->[3],$cw->cget($opt));
+ }
+ else
+ {
+ # Real (core) Tk widgets return db name rather than option name
+ # for aliases so recurse to get that ...
+ my @real = $cw->configure($info);
+ push(@results,$opt,$real[1]);
+ }
+ }
+ else
+ {
+ push(@results,$cw->Subconfigure($opt)->configure($opt));
+ }
+ }
+ else
+ {
+ my $opt;
+ my %results;
+ if (exists $spec->{'DEFAULT'})
+ {
+ foreach $opt ($cw->Subconfigure('DEFAULT')->configure)
+ {
+ $results{$opt->[0]} = $opt;
+ }
+ }
+ foreach $opt (keys %$spec)
+ {
+ $results{$opt} = [$cw->configure($opt)] if ($opt ne 'DEFAULT');
+ }
+ foreach $opt (sort keys %results)
+ {
+ push(@results,$results{$opt});
+ }
+ }
+ }
+ else
+ {
+ my (%args) = @_;
+ my %changed = ();
+ my ($opt,$val);
+ my $config = $cw->TkHash('Configure');
+
+ while (($opt,$val) = each %args)
+ {
+ my $var = \$config->{$opt};
+ my $old = $$var;
+ $$var = $val;
+ my $accepted = 0;
+ my $error = "No widget handles $opt";
+ foreach my $subwidget ($cw->Subconfigure($opt))
+ {
+ next unless (defined $subwidget);
+ eval {local $SIG{'__DIE__'}; $subwidget->configure($opt => $val) };
+ if ($@)
+ {
+ my $val2 = (defined $val) ? $val : 'undef';
+ $error = "Can't set $opt to `$val2' for $cw: " . $@;
+ undef $@;
+ }
+ else
+ {
+ $accepted = 1;
+ }
+ }
+ $cw->BackTrace($error) unless ($accepted);
+ $val = $$var;
+ $changed{$opt} = $val if (!defined $old || !defined $val || "$old" ne "$val");
+ }
+ $cw->Configured(\%args,\%changed);
+ }
+ return (wantarray) ? @results : \@results;
+}
+
+sub ConfigDefault
+{
+ my ($cw,$args) = @_;
+
+ $cw->BackTrace('Bad args') unless (defined $args && ref $args eq 'HASH');
+
+ my $specs = $cw->ConfigSpecs;
+ # Should we enforce a Delagates(DEFAULT => ) as well ?
+ $specs->{'DEFAULT'} = ['SELF'] unless (exists $specs->{'DEFAULT'});
+
+ #
+ # This is a pain with Text or Entry as core widget, they don't
+ # inherit SELF's cursor. So comment it out for Tk402.001
+ #
+ # $specs->{'-cursor'} = ['SELF',undef,undef,undef] unless (exists $specs->{'-cursor'});
+
+ # Now some hacks that cause colours to propogate down a composite widget
+ # tree - really needs more thought, other options adding such as active
+ # colours too and maybe fonts
+
+ my $child = ($cw->children)[0]; # 1st child window (if any)
+
+ unless (exists($specs->{'-background'}))
+ {
+ Tk::catch { $cw->Tk::cget('-background') };
+ my (@bg) = $@ ? ('PASSIVE') : ('SELF');
+ push(@bg,'CHILDREN') if $child;
+ $specs->{'-background'} = [\@bg,'background','Background',NORMAL_BG];
+ }
+ unless (exists($specs->{'-foreground'}))
+ {
+ Tk::catch { $cw->Tk::cget('-foreground') };
+ my (@fg) = $@ ? ('PASSIVE') : ('SELF');
+ push(@fg,'CHILDREN') if $child;
+ $specs->{'-foreground'} = [\@fg,'foreground','Foreground',BLACK];
+ }
+ $cw->ConfigAlias(-fg => '-foreground', -bg => '-background');
+
+ # Pre-scan args for aliases - this avoids defaulting
+ # options specified via alias
+ foreach my $opt (keys %$args)
+ {
+ my $info = $specs->{$opt};
+ if (defined($info) && !ref($info))
+ {
+ $args->{$info} = delete $args->{$opt};
+ }
+ }
+
+ # Now walk %$specs supplying defaults for all the options
+ # which have a defined default value, potentially looking up .Xdefaults database
+ # options for the name/class of the 'frame'
+
+ foreach my $opt (keys %$specs)
+ {
+ if ($opt ne 'DEFAULT')
+ {
+ unless (exists $args->{$opt})
+ {
+ my $info = $specs->{$opt};
+ if (ref $info)
+ {
+ # Not an alias
+ if ($ENHANCED_CONFIGSPECS && !defined $info->[3])
+ {
+ # configure inquire to fill in default slot from subwidget
+ $cw->configure($opt);
+ }
+ if (defined $info->[3])
+ {
+ if (defined $info->[1] && defined $info->[2])
+ {
+ # Should we do this on the Subconfigure widget instead?
+ # to match *Entry.Background
+ my $db = $cw->optionGet($info->[1],$info->[2]);
+ $info->[3] = $db if (defined $db);
+ }
+ $args->{$opt} = $info->[3];
+ }
+ }
+ }
+ }
+ }
+}
+
+sub ConfigSpecs
+{
+ my $cw = shift;
+ my $specs = $cw->TkHash('ConfigSpecs');
+ while (@_)
+ {
+ my $key = shift;
+ my $val = shift;
+ $specs->{$key} = $val;
+ }
+ return $specs;
+}
+
+sub _alias
+{
+ my ($specs,$opt,$main) = @_;
+ if (exists($specs->{$opt}))
+ {
+ unless (exists $specs->{$main})
+ {
+ my $targ = $specs->{$opt};
+ if (ref($targ))
+ {
+ # opt is a real option
+ $specs->{$main} = $opt
+ }
+ else
+ {
+ # opt is itself an alias
+ # make main point to same place
+ $specs->{$main} = $targ unless $targ eq $main;
+ }
+ }
+ return 1;
+ }
+ return 0;
+}
+
+sub ConfigAlias
+{
+ my $cw = shift;
+ my $specs = $cw->ConfigSpecs;
+ while (@_ >= 2)
+ {
+ my $opt = shift;
+ my $main = shift;
+ unless (_alias($specs,$opt,$main) || _alias($specs,$main,$opt))
+ {
+ $cw->BackTrace("Neither $opt nor $main exist");
+ }
+ }
+ $cw->BackTrace('Odd number of args to ConfigAlias') if (@_);
+}
+
+sub Delegate
+{
+ my ($cw,$method,@args) = @_;
+ my $widget = $cw->DelegateFor($method);
+ if ($widget == $cw)
+ {
+ $method = "Tk::Widget::$method"
+ }
+ my @result;
+ if (wantarray)
+ {
+ @result = $widget->$method(@args);
+ }
+ else
+ {
+ $result[0] = $widget->$method(@args);
+ }
+ return (wantarray) ? @result : $result[0];
+}
+
+sub InitObject
+{
+ my ($cw,$args) = @_;
+ $cw->Populate($args);
+ $cw->ConfigDefault($args);
+}
+
+sub ConfigChanged
+{
+ my ($cw,$args) = @_;
+}
+
+sub Advertise
+{
+ my ($cw,$name,$widget) = @_;
+ confess 'No name' unless (defined $name);
+ croak 'No widget' unless (defined $widget);
+ my $hash = $cw->TkHash('SubWidget');
+ $hash->{$name} = $widget; # advertise it
+ return $widget;
+}
+
+sub Component
+{
+ my ($cw,$kind,$name,%args) = @_;
+ $args{'Name'} = "\l$name" if (defined $name && !exists $args{'Name'});
+ # my $pack = delete $args{'-pack'};
+ my $delegate = delete $args{'-delegate'};
+ my $w = $cw->$kind(%args); # Create it
+ # $w->pack(@$pack) if (defined $pack);
+ $cw->Advertise($name,$w) if (defined $name);
+ $cw->Delegates(map(($_ => $w),@$delegate)) if (defined $delegate);
+ return $w; # and return it
+}
+
+1;
+__END__
+
+
diff --git a/Master/tlpkg/installer/perllib/Tk/Dialog.pm b/Master/tlpkg/installer/perllib/Tk/Dialog.pm
new file mode 100644
index 00000000000..8173f4a5acc
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/Tk/Dialog.pm
@@ -0,0 +1,70 @@
+package Tk::Dialog;
+
+use vars qw($VERSION);
+$VERSION = '4.004'; # $Id: //depot/Tkutf8/Tk/Dialog.pm#4 $
+
+# Dialog - a translation of `tk_dialog' from Tcl/Tk to TkPerl (based on
+# John Stoffel's idea).
+#
+# Stephen O. Lidie, Lehigh University Computing Center. 94/12/27
+# lusol@Lehigh.EDU
+
+# Documentation after __END__
+
+use Carp;
+use strict;
+use base qw(Tk::DialogBox);
+
+Construct Tk::Widget 'Dialog';
+
+sub Populate
+{
+
+ # Dialog object constructor. Uses `new' method from base class
+ # to create object container then creates the dialog toplevel.
+
+ my($cw, $args) = @_;
+
+ $cw->SUPER::Populate($args);
+
+ my ($w_bitmap,$w_but,$pad1,$pad2);
+
+ # Create the Toplevel window and divide it into top and bottom parts.
+
+ my (@pl) = (-side => 'top', -fill => 'both');
+
+ ($pad1, $pad2) =
+ ([-padx => '3m', -pady => '3m'], [-padx => '3m', -pady => '2m']);
+
+
+ $cw->iconname('Dialog');
+
+ my $w_top = $cw->Subwidget('top');
+
+ # Fill the top part with the bitmap and message.
+
+ @pl = (-side => 'left');
+
+ $w_bitmap = $w_top->Label(Name => 'bitmap');
+ $w_bitmap->pack(@pl, @$pad1);
+
+ my $w_msg = $w_top->Label( -wraplength => '3i', -justify => 'left' );
+
+ $w_msg->pack(-side => 'right', -expand => 1, -fill => 'both', @$pad1);
+
+ $cw->Advertise(message => $w_msg);
+ $cw->Advertise(bitmap => $w_bitmap );
+
+ $cw->ConfigSpecs( -image => ['bitmap',undef,undef,undef],
+ -bitmap => ['bitmap',undef,undef,undef],
+ -font => ['message','font','Font', '-*-Times-Medium-R-Normal--*-180-*-*-*-*-*-*'],
+ DEFAULT => ['message',undef,undef,undef]
+ );
+}
+
+1;
+
+__END__
+
+=cut
+
diff --git a/Master/tlpkg/installer/perllib/Tk/DialogBox.pm b/Master/tlpkg/installer/perllib/Tk/DialogBox.pm
new file mode 100644
index 00000000000..13335404e15
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/Tk/DialogBox.pm
@@ -0,0 +1,135 @@
+#
+# DialogBox is similar to Dialog except that it allows any widget
+# in the top frame. Widgets can be added with the add method. Currently
+# there exists no way of deleting a widget once it has been added.
+
+package Tk::DialogBox;
+
+use strict;
+use Carp;
+
+use vars qw($VERSION);
+$VERSION = sprintf '4.%03d', q$Revision: #13 $ =~ /\D(\d+)\s*$/;
+
+use base qw(Tk::Toplevel);
+
+Tk::Widget->Construct('DialogBox');
+
+sub Populate {
+ my ($cw, $args) = @_;
+
+ $cw->SUPER::Populate($args);
+ my $buttons = delete $args->{'-buttons'};
+ $buttons = ['OK'] unless defined $buttons;
+ my $default_button = delete $args->{'-default_button'};
+ $default_button = $buttons->[0] unless defined $default_button;
+
+ $cw->{'selected_button'} = '';
+ $cw->transient($cw->Parent->toplevel);
+ $cw->withdraw;
+ if (@$buttons == 1) {
+ $cw->protocol('WM_DELETE_WINDOW' => sub { $cw->{'default_button'}->invoke });
+ } else {
+ $cw->protocol('WM_DELETE_WINDOW' => sub {});
+ }
+
+ # create the two frames
+ my $top = $cw->Component('Frame', 'top');
+ $top->configure(-relief => 'raised', -bd => 1) unless $Tk::platform eq 'MSWin32';
+ my $bot = $cw->Component('Frame', 'bottom');
+ $bot->configure(-relief => 'raised', -bd => 1) unless $Tk::platform eq 'MSWin32';
+ $bot->pack(qw/-side bottom -fill both -ipady 3 -ipadx 3/);
+ $top->pack(qw/-side top -fill both -ipady 3 -ipadx 3 -expand 1/);
+
+ # create a row of buttons in the bottom.
+ my $bl; # foreach my $var: perl > 5.003_08
+ foreach $bl (@$buttons)
+ {
+ my $b = $bot->Button(-text => $bl, -command => sub { $cw->{'selected_button'} = "$bl" } );
+ $b->bind('<Return>' => [ $b, 'Invoke']);
+ $cw->Advertise("B_$bl" => $b);
+ if ($Tk::platform eq 'MSWin32')
+ {
+ $b->configure(-width => 10, -pady => 0);
+ }
+ if ($bl eq $default_button) {
+ if ($Tk::platform eq 'MSWin32') {
+ $b->pack(-side => 'left', -expand => 1, -padx => 1, -pady => 1);
+ } else {
+ my $db = $bot->Frame(-relief => 'sunken', -bd => 1);
+ $b->raise($db);
+ $b->pack(-in => $db, -padx => '2', -pady => '2');
+ $db->pack(-side => 'left', -expand => 1, -padx => 1, -pady => 1);
+ }
+ $cw->{'default_button'} = $b;
+ $cw->bind('<Return>' => [ $b, 'Invoke']);
+ } else {
+ $b->pack(-side => 'left', -expand => 1, -padx => 1, -pady => 1);
+ }
+ }
+ $cw->ConfigSpecs(-command => ['CALLBACK', undef, undef, undef ],
+ -foreground => ['DESCENDANTS', 'foreground','Foreground', 'black'],
+ -background => ['DESCENDANTS', 'background','Background', undef],
+ -focus => ['PASSIVE', undef, undef, undef],
+ -showcommand => ['CALLBACK', undef, undef, undef],
+ );
+ $cw->Delegates('Construct',$top);
+}
+
+sub add {
+ my ($cw, $wnam, @args) = @_;
+ my $w = $cw->Subwidget('top')->$wnam(@args);
+ $cw->Advertise("\L$wnam" => $w);
+ return $w;
+}
+
+sub Wait
+{
+ my $cw = shift;
+ $cw->Callback(-showcommand => $cw);
+ $cw->waitVariable(\$cw->{'selected_button'});
+ $cw->grabRelease;
+ $cw->withdraw;
+ $cw->Callback(-command => $cw->{'selected_button'});
+}
+
+sub Show {
+
+ croak 'DialogBox: "Show" method requires at least 1 argument'
+ if scalar @_ < 1;
+ my $cw = shift;
+ my ($grab) = @_;
+ my $old_focus = $cw->focusSave;
+ my $old_grab = $cw->grabSave;
+
+ shift if defined $grab && length $grab && ($grab =~ /global/);
+ $cw->Popup(@_);
+
+ Tk::catch {
+ if (defined $grab && length $grab && ($grab =~ /global/)) {
+ $cw->grabGlobal;
+ } else {
+ $cw->grab;
+ }
+ };
+ if (my $focusw = $cw->cget(-focus)) {
+ $focusw->focus;
+ } elsif (defined $cw->{'default_button'}) {
+ $cw->{'default_button'}->focus;
+ } else {
+ $cw->focus;
+ }
+ $cw->Wait;
+ &$old_focus;
+ &$old_grab;
+ return $cw->{'selected_button'};
+}
+
+sub Exit
+{
+ my $cw = shift;
+ #kill the dialogbox, by faking a 'DONE'
+ $cw->{'selected_button'} = $cw->{'default_button'}->cget(-text);
+}
+
+1;
diff --git a/Master/tlpkg/installer/perllib/Tk/DummyEncode.pm b/Master/tlpkg/installer/perllib/Tk/DummyEncode.pm
new file mode 100644
index 00000000000..5ead808405d
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/Tk/DummyEncode.pm
@@ -0,0 +1,46 @@
+package Tk::DummyEncode;
+
+use vars qw($VERSION);
+$VERSION = '4.007'; # $Id: //depot/Tkutf8/Tk/DummyEncode.pm#7 $
+
+sub getEncoding
+{
+ my ($class,$name) = @_;
+ return undef unless ($name =~ /(iso8859-1|X11ControlChars)/);
+ my $pkg = $name;
+ $pkg =~ s/\W+/_/g;
+ return bless {Name => $name},$class.'::'.$pkg;
+}
+
+package Tk::DummyEncode::iso8859_1;
+sub encode
+{
+ my ($obj,$uni,$chk) = @_;
+ $_[1] = '' if $chk;
+ return $uni;
+}
+
+sub decode
+{
+ my ($obj,$byt,$chk) = @_;
+ $_[1]
+= '' if $chk;
+ return $byt;
+}
+
+package Tk::DummyEncode::X11ControlChars;
+sub encode
+{
+ my ($obj,$uni,$chk) = @_;
+ my $str = '';
+ foreach my $ch (split(//,$uni))
+ {
+ $str .= sprintf("\\x{%x}",ord($ch));
+ }
+ $_[1] = '' if $chk;
+ return $str;
+}
+
+1;
+
+__END__
diff --git a/Master/tlpkg/installer/perllib/Tk/Entry.pm b/Master/tlpkg/installer/perllib/Tk/Entry.pm
new file mode 100644
index 00000000000..51b3f0c6767
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/Tk/Entry.pm
@@ -0,0 +1,615 @@
+package Tk::Entry;
+
+# Converted from entry.tcl --
+#
+# This file defines the default bindings for Tk entry widgets.
+#
+# @(#) entry.tcl 1.22 94/12/17 16:05:14
+#
+# Copyright (c) 1992-1994 The Regents of the University of California.
+# Copyright (c) 1994 Sun Microsystems, Inc.
+# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved.
+# This program is free software; you can redistribute it and/or
+
+use vars qw($VERSION);
+use strict;
+$VERSION = sprintf '4.%03d',q$Revision: #17 $ =~ /#(\d+)/;
+
+# modify it under the same terms as Perl itself, subject
+# to additional disclaimer in license.terms due to partial
+# derivation from Tk4.0 sources.
+
+use Tk::Widget ();
+use Tk::Clipboard ();
+use base qw(Tk::Clipboard Tk::Widget);
+
+import Tk qw(Ev $XS_VERSION);
+
+Construct Tk::Widget 'Entry';
+
+bootstrap Tk::Entry;
+
+sub Tk_cmd { \&Tk::entry }
+
+Tk::Methods('bbox','delete','get','icursor','index','insert','scan',
+ 'selection','validate','xview');
+
+use Tk::Submethods ( 'selection' => [qw(clear range adjust present to from)],
+ 'xview' => [qw(moveto scroll)],
+ );
+
+sub wordstart
+{my ($w,$pos) = @_;
+ my $string = $w->get;
+ $pos = $w->index('insert')-1 unless(defined $pos);
+ $string = substr($string,0,$pos);
+ $string =~ s/\S*$//;
+ length $string;
+}
+
+sub wordend
+{my ($w,$pos) = @_;
+ my $string = $w->get;
+ my $anc = length $string;
+ $pos = $w->index('insert') unless(defined $pos);
+ $string = substr($string,$pos);
+ $string =~ s/^(?:((?=\s)\s*|(?=\S)\S*))//x;
+ $anc - length($string);
+}
+
+sub deltainsert
+{
+ my ($w,$d) = @_;
+ return $w->index('insert')+$d;
+}
+
+#
+# Bind --
+# This procedure is invoked the first time the mouse enters an
+# entry widget or an entry widget receives the input focus. It creates
+# all of the class bindings for entries.
+#
+# Arguments:
+# event - Indicates which event caused the procedure to be invoked
+# (Enter or FocusIn). It is used so that we can carry out
+# the functions of that event in addition to setting up
+# bindings.
+sub ClassInit
+{
+ my ($class,$mw) = @_;
+
+ $class->SUPER::ClassInit($mw);
+
+ # <<Cut>>, <<Copy>> and <<Paste>> defined in Tk::Clipboard
+ $mw->bind($class,'<<Clear>>' => sub {
+ my $w = shift;
+ $w->delete("sel.first", "sel.last");
+ });
+ $mw->bind($class,'<<PasteSelection>>' => [sub {
+ my($w, $x) = @_;
+ # XXX logic in Tcl/Tk version screwed up?
+ if (!$Tk::strictMotif && !$Tk::mouseMoved) {
+ $w->Paste($x);
+ }
+ }, Ev('x')]);
+
+ # Standard Motif bindings:
+ # The <Escape> binding is different from the Tcl/Tk version:
+ $mw->bind($class,'<Escape>','selectionClear');
+
+ $mw->bind($class,'<1>',['Button1',Ev('x'),Ev('y')]);
+ $mw->bind($class,'<ButtonRelease-1>',['Button1Release',Ev('x'),Ev('y')]);
+ $mw->bind($class,'<B1-Motion>',['Motion',Ev('x'),Ev('y')]);
+
+ $mw->bind($class,'<Double-1>',['MouseSelect',Ev('x'),'word','sel.first']);
+ $mw->bind($class,'<Double-Shift-1>',['MouseSelect',Ev('x'),'word']);
+ $mw->bind($class,'<Triple-1>',['MouseSelect',Ev('x'),'line',0]);
+ $mw->bind($class,'<Triple-Shift-1>',['MouseSelect',Ev('x'),'line']);
+
+ $mw->bind($class,'<Shift-1>','Shift_1');
+
+
+ $mw->bind($class,'<B1-Leave>',['AutoScan',Ev('x')]);
+ $mw->bind($class,'<B1-Enter>','CancelRepeat');
+ $mw->bind($class,'<Control-1>','Control_1');
+ $mw->bind($class,'<Left>', ['SetCursor',Ev('deltainsert',-1)]);
+ $mw->bind($class,'<Right>',['SetCursor',Ev('deltainsert',1)]);
+ $mw->bind($class,'<Shift-Left>',['KeySelect',Ev('deltainsert',-1)]);
+ $mw->bind($class,'<Shift-Right>',['KeySelect',Ev('deltainsert',1)]);
+ $mw->bind($class,'<Control-Left>',['SetCursor',Ev(['wordstart'])]);
+ $mw->bind($class,'<Control-Right>',['SetCursor',Ev(['wordend'])]);
+ $mw->bind($class,'<Shift-Control-Left>',['KeySelect',Ev(['wordstart'])]);
+ $mw->bind($class,'<Shift-Control-Right>',['KeySelect',Ev(['wordend'])]);
+ $mw->bind($class,'<Home>',['SetCursor',0]);
+ $mw->bind($class,'<Shift-Home>',['KeySelect',0]);
+ $mw->bind($class,'<End>',['SetCursor','end']);
+ $mw->bind($class,'<Shift-End>',['KeySelect','end']);
+ $mw->bind($class,'<Delete>','Delete');
+
+ $mw->bind($class,'<BackSpace>','Backspace');
+
+ $mw->bind($class,'<Control-space>',['selectionFrom','insert']);
+ $mw->bind($class,'<Select>',['selectionFrom','insert']);
+ $mw->bind($class,'<Control-Shift-space>',['selectionAdjust','insert']);
+ $mw->bind($class,'<Shift-Select>',['selectionAdjust','insert']);
+
+ $mw->bind($class,'<Control-slash>',['selectionRange',0,'end']);
+ $mw->bind($class,'<Control-backslash>','selectionClear');
+
+ # $class->clipboardOperations($mw,qw[Copy Cut Paste]);
+
+ $mw->bind($class,'<KeyPress>', ['Insert',Ev('A')]);
+
+ # Ignore all Alt, Meta, and Control keypresses unless explicitly bound.
+ # Otherwise, if a widget binding for one of these is defined, the
+ # <KeyPress> class binding will also fire and insert the character,
+ # which is wrong. Ditto for Return, and Tab.
+
+ $mw->bind($class,'<Alt-KeyPress>' ,'NoOp');
+ $mw->bind($class,'<Meta-KeyPress>' ,'NoOp');
+ $mw->bind($class,'<Control-KeyPress>' ,'NoOp');
+ $mw->bind($class,'<Return>' ,'NoOp');
+ $mw->bind($class,'<KP_Enter>' ,'NoOp');
+ $mw->bind($class,'<Tab>' ,'NoOp');
+ if ($mw->windowingsystem =~ /^(?:classic|aqua)$/)
+ {
+ $mw->bind($class,'<Command-KeyPress>', 'NoOp');
+ }
+
+ # On Windows, paste is done using Shift-Insert. Shift-Insert already
+ # generates the <<Paste>> event, so we don't need to do anything here.
+ if ($Tk::platform ne 'MSWin32')
+ {
+ $mw->bind($class,'<Insert>','InsertSelection');
+ }
+
+ if (!$Tk::strictMotif)
+ {
+ # Additional emacs-like bindings:
+ $mw->bind($class,'<Control-a>',['SetCursor',0]);
+ $mw->bind($class,'<Control-b>',['SetCursor',Ev('deltainsert',-1)]);
+ $mw->bind($class,'<Control-d>',['delete','insert']);
+ $mw->bind($class,'<Control-e>',['SetCursor','end']);
+ $mw->bind($class,'<Control-f>',['SetCursor',Ev('deltainsert',1)]);
+ $mw->bind($class,'<Control-h>','Backspace');
+ $mw->bind($class,'<Control-k>',['delete','insert','end']);
+
+ $mw->bind($class,'<Control-t>','Transpose');
+
+ # XXX The original Tcl/Tk bindings use NextWord/PreviousWord instead
+ $mw->bind($class,'<Meta-b>',['SetCursor',Ev(['wordstart'])]);
+ $mw->bind($class,'<Meta-d>',['delete','insert',Ev(['wordend'])]);
+ $mw->bind($class,'<Meta-f>',['SetCursor',Ev(['wordend'])]);
+ $mw->bind($class,'<Meta-BackSpace>',['delete',Ev(['wordstart']),'insert']);
+ $mw->bind($class,'<Meta-Delete>',['delete',Ev(['wordstart']),'insert']);
+
+ # A few additional bindings from John Ousterhout.
+# XXX conflicts with <<Copy>>: $mw->bind($class,'<Control-w>',['delete',Ev(['wordstart']),'insert']);
+ $mw->bind($class,'<2>','Button_2');
+ $mw->bind($class,'<B2-Motion>','B2_Motion');
+# XXX superseded by <<PasteSelection>>: $mw->bind($class,'<ButtonRelease-2>','ButtonRelease_2');
+ }
+ return $class;
+}
+
+
+sub Shift_1
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+ $Tk::selectMode = 'char';
+ $w->selectionAdjust('@' . $Ev->x)
+}
+
+
+sub Control_1
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+ $w->icursor('@' . $Ev->x)
+}
+
+
+sub Delete
+{
+ my $w = shift;
+ if ($w->selectionPresent)
+ {
+ $w->deleteSelected
+ }
+ else
+ {
+ $w->delete('insert')
+ }
+}
+
+
+sub InsertSelection
+{
+ my $w = shift;
+ eval {local $SIG{__DIE__}; $w->Insert($w->GetSelection)}
+}
+
+
+# Original is ::tk::EntryScanMark
+sub Button_2
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+ $w->scan('mark',$Ev->x);
+ $Tk::x = $Ev->x;
+ $Tk::y = $Ev->y;
+ $Tk::mouseMoved = 0
+}
+
+
+# Original is ::tk::EntryScanDrag
+sub B2_Motion
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+ # Make sure these exist, as some weird situations can trigger the
+ # motion binding without the initial press. [Tcl/Tk Bug #220269]
+ if (!defined $Tk::x) { $Tk::x = $Ev->x }
+ if (abs(($Ev->x-$Tk::x)) > 2)
+ {
+ $Tk::mouseMoved = 1
+ }
+ $w->scan('dragto',$Ev->x)
+}
+
+
+# XXX Not needed anymore
+sub ButtonRelease_2
+{
+ my $w = shift;
+ my $Ev = $w->XEvent;
+ if (!$Tk::mouseMoved)
+ {
+ eval
+ {local $SIG{__DIE__};
+ $w->insert('insert',$w->SelectionGet);
+ $w->SeeInsert;
+ }
+ }
+}
+
+sub Button1Release
+{
+ shift->CancelRepeat;
+}
+
+# ::tk::EntryClosestGap --
+# Given x and y coordinates, this procedure finds the closest boundary
+# between characters to the given coordinates and returns the index
+# of the character just after the boundary.
+#
+# Arguments:
+# w - The entry window.
+# x - X-coordinate within the window.
+sub ClosestGap
+{
+ my($w, $x) = @_;
+ my $pos = $w->index('@'.$x);
+ my @bbox = $w->bbox($pos);
+ if ($x - $bbox[0] < $bbox[2] / 2)
+ {
+ return $pos;
+ }
+ $pos + 1;
+}
+
+# Button1 --
+# This procedure is invoked to handle button-1 presses in entry
+# widgets. It moves the insertion cursor, sets the selection anchor,
+# and claims the input focus.
+#
+# Arguments:
+# w - The entry window in which the button was pressed.
+# x - The x-coordinate of the button press.
+sub Button1
+{
+ my $w = shift;
+ my $x = shift;
+ $Tk::selectMode = 'char';
+ $Tk::mouseMoved = 0;
+ $Tk::pressX = $x;
+ $w->icursor($w->ClosestGap($x));
+ $w->selectionFrom('insert');
+ $w->selectionClear;
+ if ($w->cget('-state') ne 'disabled')
+ {
+ $w->focus()
+ }
+}
+
+sub Motion
+{
+ my ($w,$x,$y) = @_;
+ $Tk::x = $x; # XXX ?
+ $w->MouseSelect($x);
+}
+
+# MouseSelect --
+# This procedure is invoked when dragging out a selection with
+# the mouse. Depending on the selection mode (character, word,
+# line) it selects in different-sized units. This procedure
+# ignores mouse motions initially until the mouse has moved from
+# one character to another or until there have been multiple clicks.
+#
+# Arguments:
+# w - The entry window in which the button was pressed.
+# x - The x-coordinate of the mouse.
+sub MouseSelect
+{
+
+ my $w = shift;
+ my $x = shift;
+ return if UNIVERSAL::isa($w, 'Tk::Spinbox') and $w->{_element} ne 'entry';
+ $Tk::selectMode = shift if (@_);
+ my $cur = $w->index($w->ClosestGap($x));
+ return unless defined $cur;
+ my $anchor = $w->index('anchor');
+ return unless defined $anchor;
+ $Tk::pressX ||= $x; # XXX Better use "if !defined $Tk::pressX"?
+ if (($cur != $anchor) || (abs($Tk::pressX - $x) >= 3))
+ {
+ $Tk::mouseMoved = 1
+ }
+ my $mode = $Tk::selectMode;
+ return unless $mode;
+ if ($mode eq 'char')
+ {
+ # The Tcl version uses selectionRange here XXX
+ if ($Tk::mouseMoved)
+ {
+ if ($cur < $anchor)
+ {
+ $w->selectionTo($cur)
+ }
+ else
+ {
+ $w->selectionTo($cur+1)
+ }
+ }
+ }
+ elsif ($mode eq 'word')
+ {
+ # The Tcl version uses tcl_wordBreakBefore/After here XXX
+ if ($cur < $w->index('anchor'))
+ {
+ $w->selectionRange($w->wordstart($cur),$w->wordend($anchor-1))
+ }
+ else
+ {
+ $w->selectionRange($w->wordstart($anchor),$w->wordend($cur))
+ }
+ }
+ elsif ($mode eq 'line')
+ {
+ $w->selectionRange(0,'end')
+ }
+ if (@_)
+ {
+ my $ipos = shift;
+ eval {local $SIG{__DIE__}; $w->icursor($ipos) };
+ }
+ $w->idletasks;
+}
+# ::tk::EntryPaste --
+# This procedure sets the insertion cursor to the current mouse position,
+# pastes the selection there, and sets the focus to the window.
+#
+# Arguments:
+# w - The entry window.
+# x - X position of the mouse.
+sub Paste
+{
+ my($w, $x) = @_;
+ $w->icursor($w->ClosestGap($x));
+ eval { local $SIG{__DIE__};
+ $w->insert("insert", $w->GetSelection);
+ $w->SeeInsert; # Perl/Tk extension
+ };
+ if ($w->cget(-state) ne 'disabled')
+ {
+ $w->focus;
+ }
+}
+# AutoScan --
+# This procedure is invoked when the mouse leaves an entry window
+# with button 1 down. It scrolls the window left or right,
+# depending on where the mouse is, and reschedules itself as an
+# 'after' command so that the window continues to scroll until the
+# mouse moves back into the window or the mouse button is released.
+#
+# Arguments:
+# w - The entry window.
+# x - The x-coordinate of the mouse when it left the window.
+sub AutoScan
+{
+ my $w = shift;
+ my $x = shift;
+ return if !Tk::Exists($w);
+ if ($x >= $w->width)
+ {
+ $w->xview('scroll',2,'units')
+ }
+ elsif ($x < 0)
+ {
+ $w->xview('scroll',-2,'units')
+ }
+ else
+ {
+ return;
+ }
+ $w->MouseSelect($x);
+ $w->RepeatId($w->after(50,['AutoScan',$w,$x]))
+}
+# KeySelect
+# This procedure is invoked when stroking out selections using the
+# keyboard. It moves the cursor to a new position, then extends
+# the selection to that position.
+#
+# Arguments:
+# w - The entry window.
+# new - A new position for the insertion cursor (the cursor hasn't
+# actually been moved to this position yet).
+sub KeySelect
+{
+ my $w = shift;
+ my $new = shift;
+ if (!$w->selectionPresent)
+ {
+ $w->selectionFrom('insert');
+ $w->selectionTo($new)
+ }
+ else
+ {
+ $w->selectionAdjust($new)
+ }
+ $w->icursor($new);
+ $w->SeeInsert;
+}
+# Insert --
+# Insert a string into an entry at the point of the insertion cursor.
+# If there is a selection in the entry, and it covers the point of the
+# insertion cursor, then delete the selection before inserting.
+#
+# Arguments:
+# w - The entry window in which to insert the string
+# s - The string to insert (usually just a single character)
+sub Insert
+{
+ my $w = shift;
+ my $s = shift;
+ return unless (defined $s && $s ne '');
+ eval
+ {local $SIG{__DIE__};
+ my $insert = $w->index('insert');
+ if ($w->index('sel.first') <= $insert && $w->index('sel.last') >= $insert)
+ {
+ $w->deleteSelected
+ }
+ };
+ $w->insert('insert',$s);
+ $w->SeeInsert
+}
+# Backspace --
+# Backspace over the character just before the insertion cursor.
+#
+# Arguments:
+# w - The entry window in which to backspace.
+sub Backspace
+{
+ my $w = shift;
+ if ($w->selectionPresent)
+ {
+ $w->deleteSelected
+ }
+ else
+ {
+ my $x = $w->index('insert')-1;
+ $w->delete($x) if ($x >= 0);
+ # XXX Missing repositioning part from Tcl/Tk source
+ }
+}
+# SeeInsert
+# Make sure that the insertion cursor is visible in the entry window.
+# If not, adjust the view so that it is.
+#
+# Arguments:
+# w - The entry window.
+sub SeeInsert
+{
+ my $w = shift;
+ my $c = $w->index('insert');
+#
+# Probably a bug in your version of tcl/tk (I've not this problem
+# when I test Entry in the widget demo for tcl/tk)
+# index('\@0') give always 0. Consequence :
+# if you make <Control-E> or <Control-F> view is adapted
+# but with <Control-A> or <Control-B> view is not adapted
+#
+ my $left = $w->index('@0');
+ if ($left > $c)
+ {
+ $w->xview($c);
+ return;
+ }
+ my $x = $w->width;
+ while ($w->index('@' . $x) <= $c && $left < $c)
+ {
+ $left += 1;
+ $w->xview($left)
+ }
+}
+# SetCursor
+# Move the insertion cursor to a given position in an entry. Also
+# clears the selection, if there is one in the entry, and makes sure
+# that the insertion cursor is visible.
+#
+# Arguments:
+# w - The entry window.
+# pos - The desired new position for the cursor in the window.
+sub SetCursor
+{
+ my $w = shift;
+ my $pos = shift;
+ $w->icursor($pos);
+ $w->selectionClear;
+ $w->SeeInsert;
+}
+# Transpose
+# This procedure implements the 'transpose' function for entry widgets.
+# It tranposes the characters on either side of the insertion cursor,
+# unless the cursor is at the end of the line. In this case it
+# transposes the two characters to the left of the cursor. In either
+# case, the cursor ends up to the right of the transposed characters.
+#
+# Arguments:
+# w - The entry window.
+sub Transpose
+{
+ my $w = shift;
+ my $i = $w->index('insert');
+ $i++ if ($i < $w->index('end'));
+ my $first = $i-2;
+ return if ($first < 0);
+ my $str = $w->get;
+ my $new = substr($str,$i-1,1) . substr($str,$first,1);
+ $w->delete($first,$i);
+ $w->insert('insert',$new);
+ $w->SeeInsert;
+}
+
+sub tabFocus
+{
+ my $w = shift;
+ $w->selectionRange(0,'end');
+ $w->icursor('end');
+ $w->SUPER::tabFocus;
+}
+
+# ::tk::EntryGetSelection --
+#
+# Returns the selected text of the entry with respect to the -show option.
+#
+# Arguments:
+# w - The entry window from which the text to get
+sub getSelected
+{
+ my $w = shift;
+ return undef unless $w->selectionPresent;
+ my $str = $w->get;
+ my $show = $w->cget('-show');
+ $str = $show x length($str) if (defined $show);
+ my $s = $w->index('sel.first');
+ my $e = $w->index('sel.last');
+ return substr($str,$s,$e-$s);
+}
+
+
+1;
+
+__END__
diff --git a/Master/tlpkg/installer/perllib/Tk/Event.pm b/Master/tlpkg/installer/perllib/Tk/Event.pm
new file mode 100644
index 00000000000..cecd57c54ae
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/Tk/Event.pm
@@ -0,0 +1,13 @@
+package Tk::Event;
+use vars qw($VERSION $XS_VERSION @EXPORT_OK);
+END { CleanupGlue() }
+$VERSION = sprintf '4.%03d', q$Revision: #15 $ =~ /\D(\d+)\s*$/;
+$XS_VERSION = '804.027';
+use base qw(Exporter);
+use XSLoader;
+@EXPORT_OK = qw($XS_VERSION DONT_WAIT WINDOW_EVENTS FILE_EVENTS
+ TIMER_EVENTS IDLE_EVENTS ALL_EVENTS);
+XSLoader::load 'Tk::Event',$XS_VERSION;
+require Tk::Event::IO;
+1;
+__END__
diff --git a/Master/tlpkg/installer/perllib/Tk/Event/IO.pm b/Master/tlpkg/installer/perllib/Tk/Event/IO.pm
new file mode 100644
index 00000000000..10b47e246ff
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/Tk/Event/IO.pm
@@ -0,0 +1,132 @@
+package Tk::Event::IO;
+use strict;
+use Carp;
+
+use vars qw($VERSION @EXPORT_OK);
+$VERSION = sprintf '4.%03d', q$Revision: #8 $ =~ /\D(\d+)\s*$/;
+
+use base qw(Exporter);
+use Symbol ();
+
+@EXPORT_OK = qw(READABLE WRITABLE);
+
+sub PrintArgs
+{
+ my $func = (caller(1))[3];
+ print "$func(",join(',',@_),")\n";
+}
+
+sub PRINT
+{
+ my $obj = shift;
+ $obj->wait(WRITABLE);
+ my $h = $obj->handle;
+ return print $h @_;
+}
+
+sub PRINTF
+{
+ my $obj = shift;
+ $obj->wait(WRITABLE);
+ my $h = $obj->handle;
+ return printf $h @_;
+}
+
+sub WRITE
+{
+ my $obj = $_[0];
+ $obj->wait(WRITABLE);
+ return syswrite($obj->handle,$_[1],$_[2]);
+}
+
+my $depth = 0;
+sub READLINE
+{
+ my $obj = shift;
+ $obj->wait(READABLE);
+ my $h = $obj->handle;
+ my $w = <$h>;
+ return $w;
+}
+
+sub READ
+{
+ my $obj = $_[0];
+ $obj->wait(READABLE);
+ my $h = $obj->handle;
+ return sysread($h,$_[1],$_[2],defined $_[3] ? $_[3] : 0);
+}
+
+sub GETC
+{
+ my $obj = $_[0];
+ $obj->wait(READABLE);
+ my $h = $obj->handle;
+ return getc($h);
+}
+
+sub CLOSE
+{
+ my $obj = shift;
+ $obj->unwatch;
+ my $h = $obj->handle;
+ return close($h);
+}
+
+sub EOF
+{
+ my $obj = shift;
+ my $h = $obj->handle;
+ return eof($h);
+}
+
+sub FILENO
+{
+ my $obj = shift;
+ my $h = $obj->handle;
+ return fileno($h);
+}
+
+sub imode
+{
+ my $mode = shift;
+ my $imode = ${{'readable' => READABLE(),
+ 'writable' => WRITABLE()}}{$mode};
+ croak("Invalid handler type '$mode'") unless (defined $imode);
+ return $imode;
+}
+
+sub fileevent
+{
+ my ($widget,$file,$mode,$cb) = @_;
+ my $imode = imode($mode);
+ unless (ref $file)
+ {
+ no strict 'refs';
+ $file = Symbol::qualify($file,(caller)[0]);
+ $file = \*{$file};
+ }
+ my $obj = tied(*$file);
+ unless ($obj && $obj->isa('Tk::Event::IO'))
+ {
+ $obj = tie *$file,'Tk::Event::IO', $file;
+ }
+ if (@_ == 3)
+ {
+ # query return the handler
+ return $obj->handler($imode);
+ }
+ else
+ {
+ # set the handler
+ my $h = $obj->handler($imode,$cb);
+ undef $obj; # Prevent warnings about untie with ref to object
+ unless ($h)
+ {
+ untie *$file;
+ }
+ }
+}
+
+1;
+__END__
diff --git a/Master/tlpkg/installer/perllib/Tk/Frame.pm b/Master/tlpkg/installer/perllib/Tk/Frame.pm
new file mode 100644
index 00000000000..a5716cdf9bd
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/Tk/Frame.pm
@@ -0,0 +1,378 @@
+# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+package Tk::Frame;
+require Tk::Widget;
+require Tk::Derived;
+use AutoLoader;
+use strict qw(vars);
+use Carp;
+
+use base qw(Tk::Derived Tk::Widget);
+
+Construct Tk::Widget 'Frame';
+
+use vars qw($VERSION);
+$VERSION = '4.010'; # $Id: //depot/Tkutf8/Tk/Frame.pm#10 $
+
+sub Tk_cmd { \&Tk::frame }
+
+sub CreateOptions
+{
+ return (shift->SUPER::CreateOptions,'-colormap','-visual','-container')
+}
+
+sub Default
+{
+ my ($cw,$name,$widget) = @_;
+ confess 'No name' unless (defined $name);
+ croak 'No widget' unless (defined $widget);
+ $cw->Delegates(DEFAULT => $widget);
+ $cw->ConfigSpecs(DEFAULT => [$widget]);
+ $widget->pack('-expand' => 1, -fill => 'both') unless ($widget->manager); # Suspect
+ $cw->Advertise($name,$widget);
+}
+
+sub ConfigDelegate
+{
+ my ($cw,$name,@skip) = @_;
+ my $sw = $cw->Subwidget($name);
+ my $sc;
+ my %skip = ();
+ foreach $sc (@skip)
+ {
+ $skip{$sc} = 1;
+ }
+ foreach $sc ($sw->configure)
+ {
+ my (@info) = @$sc;
+ next if (@info == 2);
+ my $option = $info[0];
+ unless ($skip{$option})
+ {
+ $option =~ s/^-(.*)/-$name\u$1/;
+ $info[0] = Tk::Configure->new($sw,$info[0]);
+ pop(@info);
+ $cw->ConfigSpecs($option => \@info);
+ }
+ }
+}
+
+sub bind
+{my ($cw,@args) = @_;
+ $cw->Delegate('bind',@args);
+}
+
+sub menu
+{my ($cw,@args) = @_;
+ $cw->Delegate('menu',@args);
+}
+
+sub focus
+{my ($cw,@args) = @_;
+ $cw->Delegate('focus',@args);
+}
+
+#sub bindtags
+#{my ($cw,@args) = @_;
+# $cw->Delegate('bindtags',@args);
+#}
+
+sub selection
+{my ($cw,@args) = @_;
+ $cw->Delegate('selection',@args);
+}
+
+sub autoLabel { 1 }
+
+sub Populate
+{
+ my ($cw,$args) = @_;
+ if ($cw->autoLabel)
+ {
+ $cw->ConfigSpecs('-labelPack' => [ 'METHOD', undef, undef, undef]);
+ $cw->ConfigSpecs('-labelVariable' => [ 'METHOD', undef, undef, undef]);
+ $cw->ConfigSpecs('-label' => [ 'METHOD', undef, undef, undef]);
+ $cw->labelPack([]) if grep /^-label\w+/, keys %$args;
+ }
+}
+
+sub Menubar
+{
+ my $frame = shift;
+ my $menu = $frame->cget('-menu');
+ if (defined $menu)
+ {
+ $menu->configure(@_) if @_;
+ }
+ else
+ {
+ $menu = $frame->Menu(-type => 'menubar',@_);
+ $frame->configure('-menu' => $menu);
+ }
+ $frame->Advertise('menubar' => $menu);
+ return $menu;
+}
+
+1;
+
+__END__
+
+sub labelPack
+{
+ my ($cw,$val) = @_;
+ my $w = $cw->Subwidget('label');
+ my @result = ();
+ if (@_ > 1)
+ {
+ if (defined($w) && !defined($val))
+ {
+ $w->packForget;
+ }
+ elsif (defined($val) && !defined ($w))
+ {
+ require Tk::Label;
+ $w = Tk::Label->new($cw,-textvariable => $cw->labelVariable);
+ $cw->Advertise('label' => $w);
+ $cw->ConfigDelegate('label',qw(-text -textvariable));
+ }
+ if (defined($val) && defined($w))
+ {
+ my %pack = @$val;
+ unless (exists $pack{-side})
+ {
+ $pack{-side} = 'top' unless (exists $pack{-side});
+ }
+ unless (exists $pack{-fill})
+ {
+ $pack{-fill} = 'x' if ($pack{-side} =~ /(top|bottom)/);
+ $pack{-fill} = 'y' if ($pack{-side} =~ /(left|right)/);
+ }
+ unless (exists($pack{'-before'}) || exists($pack{'-after'}))
+ {
+ my $before = ($cw->packSlaves)[0];
+ $pack{'-before'} = $before if (defined $before);
+ }
+ $w->pack(%pack);
+ }
+ }
+ @result = $w->packInfo if (defined $w);
+ return (wantarray) ? @result : \@result;
+}
+
+sub labelVariable
+{
+ my ($cw,$val) = @_;
+ my $var = \$cw->{Configure}{'-labelVariable'};
+ if (@_ > 1 && defined $val)
+ {
+ $$var = $val;
+ $$val = '' unless (defined $$val);
+ my $w = $cw->Subwidget('label');
+ unless (defined $w)
+ {
+ $cw->labelPack([]);
+ $w = $cw->Subwidget('label');
+ }
+ $w->configure(-textvariable => $val);
+ }
+ return $$var;
+}
+
+sub label
+{
+ my ($cw,$val) = @_;
+ my $var = $cw->cget('-labelVariable');
+ if (@_ > 1 && defined $val)
+ {
+ if (!defined $var)
+ {
+ $var = \$cw->{Configure}{'-label'};
+ $cw->labelVariable($var);
+ }
+ $$var = $val;
+ }
+ return (defined $var) ? $$var : undef;;
+}
+
+sub queuePack
+{
+ my ($cw) = @_;
+ unless ($cw->{'pack_pending'})
+ {
+ $cw->{'pack_pending'} = 1;
+ $cw->afterIdle([$cw,'packscrollbars']);
+ }
+}
+
+sub sbset
+{
+ my ($cw,$sb,$ref,@args) = @_;
+ $sb->set(@args);
+ $cw->queuePack if (@args == 2 && $sb->Needed != $$ref);
+}
+
+sub freeze_on_map
+{
+ my ($w) = @_;
+ unless ($w->Tk::bind('Freeze','<Map>'))
+ {
+ $w->Tk::bind('Freeze','<Map>',['packPropagate' => 0])
+ }
+ $w->AddBindTag('Freeze');
+}
+
+sub AddScrollbars
+{
+ require Tk::Scrollbar;
+ my ($cw,$w) = @_;
+ my $def = '';
+ my ($x,$y) = ('','');
+ my $s = 0;
+ my $c;
+ $cw->freeze_on_map;
+ foreach $c ($w->configure)
+ {
+ my $opt = $c->[0];
+ if ($opt eq '-yscrollcommand')
+ {
+ my $slice = Tk::Frame->new($cw,Name => 'ysbslice');
+ my $ysb = Tk::Scrollbar->new($slice,-orient => 'vertical', -command => [ 'yview', $w ]);
+ my $size = $ysb->cget('-width');
+ my $corner = Tk::Frame->new($slice,Name=>'corner','-relief' => 'raised',
+ '-width' => $size, '-height' => $size);
+ $ysb->pack(-side => 'left', -fill => 'y');
+ $cw->Advertise('yscrollbar' => $ysb);
+ $cw->Advertise('corner' => $corner);
+ $cw->Advertise('ysbslice' => $slice);
+ $corner->{'before'} = $ysb->PathName;
+ $slice->{'before'} = $w->PathName;
+ $y = 'w';
+ $s = 1;
+ }
+ elsif ($opt eq '-xscrollcommand')
+ {
+ my $xsb = Tk::Scrollbar->new($cw,-orient => 'horizontal', -command => [ 'xview', $w ]);
+ $cw->Advertise('xscrollbar' => $xsb);
+ $xsb->{'before'} = $w->PathName;
+ $x = 's';
+ $s = 1;
+ }
+ }
+ if ($s)
+ {
+ $cw->Advertise('scrolled' => $w);
+ $cw->ConfigSpecs('-scrollbars' => ['METHOD','scrollbars','Scrollbars',$x.$y]);
+ }
+}
+
+sub packscrollbars
+{
+ my ($cw) = @_;
+ my $opt = $cw->cget('-scrollbars');
+ my $slice = $cw->Subwidget('ysbslice');
+ my $xsb = $cw->Subwidget('xscrollbar');
+ my $corner = $cw->Subwidget('corner');
+ my $w = $cw->Subwidget('scrolled');
+ my $xside = (($opt =~ /n/) ? 'top' : 'bottom');
+ my $havex = 0;
+ my $havey = 0;
+ $opt =~ s/r//;
+ $cw->{'pack_pending'} = 0;
+ if (defined $slice)
+ {
+ my $reqy;
+ my $ysb = $cw->Subwidget('yscrollbar');
+ if ($opt =~ /(o)?[we]/ && (($reqy = !defined($1)) || $ysb->Needed))
+ {
+ my $yside = (($opt =~ /w/) ? 'left' : 'right');
+ $slice->pack(-side => $yside, -fill => 'y',-before => $slice->{'before'});
+ $havey = 1;
+ if ($reqy)
+ {
+ $w->configure(-yscrollcommand => ['set', $ysb]);
+ }
+ else
+ {
+ $w->configure(-yscrollcommand => ['sbset', $cw, $ysb, \$cw->{'packysb'}]);
+ }
+ }
+ else
+ {
+ $w->configure(-yscrollcommand => undef) unless $opt =~ s/[we]//;
+ $slice->packForget;
+ }
+ $cw->{'packysb'} = $havey;
+ }
+ if (defined $xsb)
+ {
+ my $reqx;
+ if ($opt =~ /(o)?[ns]/ && (($reqx = !defined($1)) || $xsb->Needed))
+ {
+ $xsb->pack(-side => $xside, -fill => 'x',-before => $xsb->{'before'});
+ $havex = 1;
+ if ($reqx)
+ {
+ $w->configure(-xscrollcommand => ['set', $xsb]);
+ }
+ else
+ {
+ $w->configure(-xscrollcommand => ['sbset', $cw, $xsb, \$cw->{'packxsb'}]);
+ }
+ }
+ else
+ {
+ $w->configure(-xscrollcommand => undef) unless $opt =~ s/[ns]//;
+ $xsb->packForget;
+ }
+ $cw->{'packxsb'} = $havex;
+ }
+ if (defined $corner)
+ {
+ if ($havex && $havey && defined $corner->{'before'})
+ {
+ my $anchor = $opt;
+ $anchor =~ s/o//g;
+ $corner->configure(-height => $xsb->ReqHeight);
+ $corner->pack(-before => $corner->{'before'}, -side => $xside,
+ -anchor => $anchor, -fill => 'x');
+ }
+ else
+ {
+ $corner->packForget;
+ }
+ }
+}
+
+sub scrollbars
+{
+ my ($cw,$opt) = @_;
+ my $var = \$cw->{'-scrollbars'};
+ if (@_ > 1)
+ {
+ my $old = $$var;
+ if (!defined $old || $old ne $opt)
+ {
+ $$var = $opt;
+ $cw->queuePack;
+ }
+ }
+ return $$var;
+}
+
+sub FindMenu
+{
+ my ($w,$char) = @_;
+ my $child;
+ my $match;
+ foreach $child ($w->children)
+ {
+ next unless (ref $child);
+ $match = $child->FindMenu($char);
+ return $match if (defined $match);
+ }
+ return undef;
+}
+
+
+
diff --git a/Master/tlpkg/installer/perllib/Tk/Image.pm b/Master/tlpkg/installer/perllib/Tk/Image.pm
new file mode 100644
index 00000000000..0f41c387fc2
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/Tk/Image.pm
@@ -0,0 +1,74 @@
+# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+package Tk::Image;
+
+# This module does for images what Tk::Widget does for widgets:
+# provides a base class for them to inherit from.
+require DynaLoader;
+
+use base qw(DynaLoader Tk); # but are they ?
+
+use vars qw($VERSION);
+$VERSION = '4.011'; # $Id: //depot/Tkutf8/Tk/Image.pm#11 $
+
+sub new
+{
+ my $package = shift;
+ my $widget = shift;
+ $package->InitClass($widget);
+ my $leaf = $package->Tk_image;
+ my $obj = $widget->Tk::image('create',$leaf,@_);
+ $obj = $widget->_object($obj) unless (ref $obj);
+ return bless $obj,$package;
+}
+
+sub Install
+{
+ # Dynamically loaded image types can install standard images here
+ my ($class,$mw) = @_;
+}
+
+sub ClassInit
+{
+ # Carry out class bindings (or whatever)
+ my ($package,$mw) = @_;
+ return $package;
+}
+
+require Tk::Submethods;
+
+Direct Tk::Submethods ('image' => [qw(delete width height type)]);
+
+sub Tk::Widget::imageNames
+{
+ my $w = shift;
+ $w->image('names',@_);
+}
+
+sub Tk::Widget::imageTypes
+{
+ my $w = shift;
+ map("\u$_",$w->image('types',@_));
+}
+
+sub Construct
+{
+ my ($base,$name) = @_;
+ my $class = (caller(0))[0];
+
+ # Hack for broken ->isa in perl5.6.0
+ delete ${"$class\::"}{'::ISA::CACHE::'} if $] == 5.006;
+
+ *{"Tk::Widget::$name"} = sub { $class->new(@_) };
+}
+
+# This is here to prevent AUTOLOAD trying to find it.
+sub DESTROY
+{
+ my $i = shift;
+ # maybe do image delete ???
+}
+
+
+1;
diff --git a/Master/tlpkg/installer/perllib/Tk/Label.pm b/Master/tlpkg/installer/perllib/Tk/Label.pm
new file mode 100644
index 00000000000..ebea1741c2f
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/Tk/Label.pm
@@ -0,0 +1,21 @@
+# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package Tk::Label;
+require Tk;
+
+
+use vars qw($VERSION);
+$VERSION = '4.006'; # $Id: //depot/Tkutf8/Tk/Label.pm#6 $
+
+use base qw(Tk::Widget);
+
+Construct Tk::Widget 'Label';
+
+sub Tk_cmd { \&Tk::label }
+
+1;
+
+
+
diff --git a/Master/tlpkg/installer/perllib/Tk/MainWindow.pm b/Master/tlpkg/installer/perllib/Tk/MainWindow.pm
new file mode 100644
index 00000000000..5384ccb560b
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/Tk/MainWindow.pm
@@ -0,0 +1,213 @@
+# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+package Tk::MainWindow;
+use base qw(Tk::Toplevel);
+BEGIN { @MainWindow::ISA = 'Tk::MainWindow' }
+
+use strict;
+
+use vars qw($VERSION);
+$VERSION = sprintf '4.%03d', q$Revision: #12 $ =~ /\D(\d+)\s*$/;
+
+use Tk::CmdLine;
+use Tk qw(catch);
+require Tk::Toplevel;
+
+use Carp;
+
+$| = 1;
+
+my $pid = $$;
+
+my %Windows = ();
+
+sub CreateArgs
+{
+ my ($class,$args) = @_;
+ my $cmd = Tk::CmdLine->CreateArgs();
+ my $key;
+ foreach $key (keys %$cmd)
+ {
+ $args->{$key} = $cmd->{$key} unless exists $args->{$key};
+ }
+ my %result = $class->SUPER::CreateArgs(undef,$args);
+ my $name = delete($args->{'-name'});
+ unless (Tk::tainting)
+ {
+ $ENV{'DISPLAY'} = ':0' unless (exists $ENV{'DISPLAY'});
+ $result{'-screen'} = $ENV{'DISPLAY'} unless exists $result{'-screen'};
+ }
+ return (-name => "\l$name",%result);
+}
+
+sub new
+{
+ my $package = shift;
+ if (@_ > 0 && $_[0] =~ /:\d+(\.\d+)?$/)
+ {
+ carp "Usage $package->new(-screen => '$_[0]' ...)" if $^W;
+ unshift(@_,'-screen');
+ }
+ croak('Odd number of args'."$package->new(" . join(',',@_) .')') if @_ % 2;
+ my %args = @_;
+
+ my $top = eval { bless Create($package->CreateArgs(\%args)), $package };
+ croak($@ . "$package->new(" . join(',',@_) .')') if ($@);
+ $top->apply_command_line;
+ $top->InitBindings;
+ $top->SetBindtags;
+ $top->InitObject(\%args);
+ eval { $top->configure(%args) };
+ croak "$@" if ($@);
+ if (($top->positionfrom||'') ne 'user' and ($top->sizefrom||'') ne 'user') {
+ my $geometry = $top->optionGet(qw(geometry Geometry));
+ if ($geometry) {
+ $top->geometry($geometry);
+ }
+ }
+ $Windows{$top} = $top;
+ return $top;
+}
+
+sub _Destroyed
+{
+ my $top = shift;
+ $top->SUPER::_Destroyed;
+ delete $Windows{$top};
+}
+
+sub InitBindings
+{
+ my $mw = shift;
+ $mw->bind('all','<Tab>','focusNext');
+ # <<LeftTab>> is named <<PrevWindow>> in Tcl/Tk
+ $mw->eventAdd(qw[<<LeftTab>> <Shift-Tab>]);
+ # This is needed for XFree86 systems
+ catch { $mw->eventAdd(qw[<<LeftTab>> <ISO_Left_Tab>]) };
+ # This seems to be correct on *some* HP systems.
+ catch { $mw->eventAdd(qw[<<LeftTab>> <hpBackTab>]) };
+ $mw->bind('all','<<LeftTab>>','focusPrev');
+ if ($mw->windowingsystem eq 'x11')
+ {
+ $mw->eventAdd(qw[<<Cut>> <Control-Key-x> <Key-F20> <Meta-Key-w>]);
+ $mw->eventAdd(qw[<<Copy>> <Control-Key-c> <Key-F16> <Control-Key-w>]);
+ $mw->eventAdd(qw[<<Paste>> <Control-Key-v> <Key-F18> <Control-Key-y>]);
+ $mw->eventAdd(qw[<<PasteSelection>> <ButtonRelease-2>]);
+ $mw->eventAdd(qw[<<Undo>> <Control-Key-z> <Key-Undo> <Key-F14>
+ <Control-Key-underscore>]);
+ $mw->eventAdd(qw[<<Redo>> <Control-Key-y> <Shift-Key-Undo> <Key-F12> <Shift-Key-F14>]);
+ }
+ elsif ($mw->windowingsystem eq 'win32')
+ {
+ $mw->eventAdd(qw[<<Cut>> <Control-Key-x> <Shift-Key-Delete>]);
+ $mw->eventAdd(qw[<<Copy>> <Control-Key-c> <Control-Key-Insert>]);
+ $mw->eventAdd(qw[<<Paste>> <Control-Key-v> <Shift-Key-Insert>]);
+ $mw->eventAdd(qw[<<Undo>> <Control-Key-z>]);
+ $mw->eventAdd(qw[<<Redo>> <Control-Key-y>]);
+ }
+ elsif ($mw->windowingsystem eq 'aqua')
+ {
+ $mw->eventAdd(qw[<<Cut>> <Command-Key-x> <Key-F2>]);
+ $mw->eventAdd(qw[<<Copy>> <Command-Key-c> <Key-F3>]);
+ $mw->eventAdd(qw[<<Paste>> <Command-Key-v> <Key-F4>]);
+ $mw->eventAdd(qw[<<PasteSelection>> <ButtonRelease-2>]);
+ $mw->eventAdd(qw[<<Clear>> <Clear>]);
+ $mw->eventAdd(qw[<<Undo>> <Command-Key-z>]);
+ $mw->eventAdd(qw[<<Redo>> <Command-Key-y>]);
+ }
+ elsif ($mw->windowingsystem eq 'classic')
+ {
+ $mw->eventAdd(qw[<<Cut>> <Control-Key-x> <Key-F2>]);
+ $mw->eventAdd(qw[<<Copy>> <Control-Key-c> <Key-F3>]);
+ $mw->eventAdd(qw[<<Paste>> <Control-Key-v> <Key-F4>]);
+ $mw->eventAdd(qw[<<PasteSelection>> <ButtonRelease-2>]);
+ $mw->eventAdd(qw[<<Clear>> <Clear>]);
+ $mw->eventAdd(qw[<<Undo>> <Control-Key-z> <Key-F1>]);
+ $mw->eventAdd(qw[<<Redo>> <Control-Key-Z>]);
+ }
+
+ # FIXME - Should these move to Menubutton ?
+ my $c = ($Tk::platform eq 'unix') ? 'all' : 'Tk::Menubutton';
+ $mw->bind($c,'<Alt-KeyPress>',['TraverseToMenu',Tk::Ev('K')]);
+ $mw->bind($c,'<F10>','FirstMenu');
+}
+
+sub Existing
+{
+ my @Windows;
+ foreach my $name (keys %Windows)
+ {
+ my $obj = $Windows{$name};
+ if (Tk::Exists($obj))
+ {
+ push(@Windows,$obj);
+ }
+ else
+ {
+ delete $Windows{$name};
+ }
+ }
+ return @Windows;
+}
+
+END
+{
+ if (Tk::IsParentProcess())
+ {
+ foreach my $top (values %Windows)
+ {
+ if ($top->IsWidget)
+ {
+ # Tk data structuctures are still in place
+ # this can occur if non-callback perl code did a 'die'.
+ # It will also handle some cases of non-Tk 'exit' being called
+ # Destroy this mainwindow and hence is descendants ...
+ $top->destroy;
+ }
+ }
+ }
+}
+
+sub CmdLine { return shift->command }
+
+sub WMSaveYourself
+{
+ my $mw = shift;
+ my @args = @{$mw->command};
+# warn 'preWMSaveYourself:'.join(' ',@args)."\n";
+ @args = ($0) unless (@args);
+ my $i = 1;
+ while ($i < @args)
+ {
+ if ($args[$i] eq '-iconic')
+ {
+ splice(@args,$i,1);
+ }
+ elsif ($args[$i] =~ /^-(geometry|iconposition)$/)
+ {
+ splice(@args,$i,2);
+ }
+ }
+
+ my @ip = $mw->wm('iconposition');
+# print 'ip ',join(',',@ip),"\n";
+ my $icon = $mw->iconwindow;
+ if (defined($icon))
+ {
+ @ip = $icon->geometry =~ /\d+x\d+([+-]\d+)([+-]\d+)/;
+ }
+ splice(@args,1,0,'-iconposition' => join(',',@ip)) if (@ip == 2);
+
+ splice(@args,1,0,'-iconic') if ($mw->state() eq 'iconic');
+
+ splice(@args,1,0,'-geometry' => $mw->geometry);
+# warn 'postWMSaveYourself:'.join(' ',@args)."\n";
+ $mw->command([@args]);
+}
+
+1;
+
+__END__
+
+=cut
diff --git a/Master/tlpkg/installer/perllib/Tk/PNG.pm b/Master/tlpkg/installer/perllib/Tk/PNG.pm
new file mode 100644
index 00000000000..1ecb4001d17
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/Tk/PNG.pm
@@ -0,0 +1,43 @@
+package Tk::PNG;
+require DynaLoader;
+
+use vars qw($VERSION);
+$VERSION = sprintf '4.%03d', q$Revision: #3 $ =~ /\D(\d+)\s*$/;
+
+use Tk 800.005;
+require Tk::Image;
+require Tk::Photo;
+
+use base qw(DynaLoader);
+
+bootstrap Tk::PNG $Tk::VERSION;
+
+1;
+
+__END__
+
+=head1 NAME
+
+Tk::PNG - PNG loader for Tk::Photo
+
+=head1 SYNOPSIS
+
+ use Tk;
+ use Tk::PNG;
+
+ my $image = $widget->Photo('-format' => 'png', -file => 'something.png');
+
+
+=head1 DESCRIPTION
+
+This is an extension for Tk800.* which supplies
+PNG format loader for Photo image type.
+
+
+=head1 AUTHOR
+
+Nick Ing-Simmons E<lt>nick@ing-simmons.netE<gt>
+
+=cut
+
+
diff --git a/Master/tlpkg/installer/perllib/Tk/Photo.pm b/Master/tlpkg/installer/perllib/Tk/Photo.pm
new file mode 100644
index 00000000000..a596dc4d78b
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/Tk/Photo.pm
@@ -0,0 +1,22 @@
+package Tk::Photo;
+
+use vars qw($VERSION);
+$VERSION = sprintf '4.%03d', 4+q$Revision: #4 $ =~ /\D(\d+)\s*$/;
+
+use Tk qw($XS_VERSION);
+
+use base qw(Tk::Image);
+
+Construct Tk::Image 'Photo';
+
+sub Tk_image { 'photo' }
+
+Tk::Methods('blank','copy','data','formats','get','put','read',
+ 'redither','transparency','write');
+
+use Tk::Submethods (
+ 'transparency' => [qw/get set/],
+);
+
+1;
+__END__
diff --git a/Master/tlpkg/installer/perllib/Tk/Pretty.pm b/Master/tlpkg/installer/perllib/Tk/Pretty.pm
new file mode 100644
index 00000000000..7e442a4bcbc
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/Tk/Pretty.pm
@@ -0,0 +1,93 @@
+# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+package Tk::Pretty;
+require Exporter;
+
+use vars qw($VERSION @EXPORT);
+$VERSION = '4.006'; # $Id: //depot/Tkutf8/Tk/Pretty.pm#6 $
+
+use base qw(Exporter);
+
+@EXPORT = qw(Pretty PrintArgs);
+
+sub pretty_list
+{
+ join(',',map(&Pretty($_),@_));
+}
+
+sub Pretty
+{
+ return pretty_list(@_) if (@_ > 1);
+ my $obj = shift;
+ return 'undef' unless defined($obj);
+ my $type = "$obj";
+ return $type if ($type =~ /=HASH/ && exists($obj->{"_Tcl_CmdInfo_\0"}));
+ my $result = '';
+ if (ref $obj)
+ {
+ my $class;
+ if ($type =~ /^([^=]+)=(.*)$/)
+ {
+ $class = $1;
+ $type = $2;
+ $result .= 'bless(';
+ }
+ if ($type =~ /^ARRAY/)
+ {
+ $result .= '[';
+ $result .= pretty_list(@$obj);
+ $result .= ']';
+ }
+ elsif ($type =~ /^HASH/)
+ {
+ $result .= '{';
+ if (%$obj)
+ {
+ my ($key, $value);
+ while (($key,$value) = each %$obj)
+ {
+ $result .= $key . '=>' . Pretty($value) . ',';
+ }
+ chop($result);
+ }
+ $result .= '}';
+ }
+ elsif ($type =~ /^REF/)
+ {
+ $result .= "\\" . Pretty($$obj);
+ }
+ elsif ($type =~ /^SCALAR/)
+ {
+ $result .= Pretty($$obj);
+ }
+ else
+ {
+ $result .= $type;
+ }
+ $result .= ",$class)" if (defined $class);
+ }
+ else
+ {
+ if ($obj =~ /^-?[0-9]+(.[0-9]*(e[+-][0-9]+)?)?$/ ||
+ $obj =~ /^[A-Z_][A-Za-z_0-9]*$/ ||
+ $obj =~ /^[a-z_][A-Za-z_0-9]*[A-Z_][A-Za-z_0-9]*$/
+ )
+ {
+ $result .= $obj;
+ }
+ else
+ {
+ $result .= "'" . $obj . "'";
+ }
+ }
+ return $result;
+}
+
+sub PrintArgs
+{
+ my $name = (caller(1))[3];
+ print "$name(",Pretty(@_),")\n";
+}
+
+1;
diff --git a/Master/tlpkg/installer/perllib/Tk/Radiobutton.pm b/Master/tlpkg/installer/perllib/Tk/Radiobutton.pm
new file mode 100644
index 00000000000..d09d41b4208
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/Tk/Radiobutton.pm
@@ -0,0 +1,45 @@
+# Conversion from Tk4.0 button.tcl competed.
+# Copyright (c) 1992-1994 The Regents of the University of California.
+# Copyright (c) 1994 Sun Microsystems, Inc.
+# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved.
+# This program is free software; you can redistribute it and/or
+
+package Tk::Radiobutton;
+
+use vars qw($VERSION);
+$VERSION = '4.006'; # $Id: //depot/Tkutf8/Tk/Radiobutton.pm#6 $
+
+# modify it under the same terms as Perl itself, subject
+# to additional disclaimer in license.terms due to partial
+# derivation from Tk4.0 sources.
+
+require Tk::Button;
+
+
+use base qw(Tk::Button);
+Construct Tk::Widget 'Radiobutton';
+
+sub Tk_cmd { \&Tk::radiobutton }
+
+sub CreateOptions
+{
+ return (shift->SUPER::CreateOptions,'-variable');
+}
+
+sub ClassInit
+{
+ my ($class,$mw) = @_;
+ $mw->bind($class,'<Enter>', 'Enter');
+ $mw->bind($class,'<Leave>', 'Leave');
+ $mw->bind($class,'<1>', 'Invoke');
+ $mw->bind($class,'<space>', 'Invoke');
+ return $class;
+}
+
+sub Invoke
+{
+ my $w = shift;
+ $w->invoke() unless($w->cget('-state') eq 'disabled');
+}
+
+1;
diff --git a/Master/tlpkg/installer/perllib/Tk/Submethods.pm b/Master/tlpkg/installer/perllib/Tk/Submethods.pm
new file mode 100644
index 00000000000..a2b8e3bd186
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/Tk/Submethods.pm
@@ -0,0 +1,46 @@
+package Tk::Submethods;
+
+use vars qw($VERSION);
+$VERSION = '4.004'; # $Id: //depot/Tkutf8/Tk/Submethods.pm#4 $
+
+sub import
+{
+ my $class = shift;
+ no strict 'refs';
+ my $package = caller(0);
+ while (@_)
+ {
+ my $fn = shift;
+ my $sm = shift;
+ foreach my $sub (@{$sm})
+ {
+ my ($suffix) = $sub =~ /(\w+)$/;
+ my $pfn = $package.'::'.$fn;
+ *{$pfn."\u$suffix"} = sub { shift->$pfn($sub,@_) };
+ }
+ }
+}
+
+sub Direct
+{
+ my $class = shift;
+ no strict 'refs';
+ my $package = caller(0);
+ while (@_)
+ {
+ my $fn = shift;
+ my $sm = shift;
+ my $sub;
+ foreach $sub (@{$sm})
+ {
+ # eval "sub ${package}::${sub} { shift->$fn('$sub',\@_) }";
+ *{$package.'::'.$sub} = sub { shift->$fn($sub,@_) };
+ }
+ }
+}
+
+1;
+
+__END__
+
+=cut
diff --git a/Master/tlpkg/installer/perllib/Tk/Toplevel.pm b/Master/tlpkg/installer/perllib/Tk/Toplevel.pm
new file mode 100644
index 00000000000..7bcd156d475
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/Tk/Toplevel.pm
@@ -0,0 +1,211 @@
+# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+package Tk::Toplevel;
+use AutoLoader;
+
+use vars qw($VERSION);
+$VERSION = '4.006'; # $Id: //depot/Tkutf8/Tk/Toplevel.pm#6 $
+
+use base qw(Tk::Wm Tk::Frame);
+
+Construct Tk::Widget 'Toplevel';
+
+sub Tk_cmd { \&Tk::toplevel }
+
+sub CreateOptions
+{
+ return (shift->SUPER::CreateOptions,'-screen','-use')
+}
+
+sub Populate
+{
+ my ($cw,$arg) = @_;
+ $cw->SUPER::Populate($arg);
+ $cw->ConfigSpecs('-title',['METHOD',undef,undef,$cw->class]);
+}
+
+sub Icon
+{
+ my ($top,%args) = @_;
+ my $icon = $top->iconwindow;
+ my $state = $top->state;
+ if ($state ne 'withdrawn')
+ {
+ $top->withdraw;
+ $top->update; # Let attributes propogate
+ }
+ unless (defined $icon)
+ {
+ $icon = Tk::Toplevel->new($top,'-borderwidth' => 0,'-class'=>'Icon');
+ $icon->withdraw;
+ # Fake Populate
+ my $lab = $icon->Component('Label' => 'icon');
+ $lab->pack('-expand'=>1,'-fill' => 'both');
+ $icon->ConfigSpecs(DEFAULT => ['DESCENDANTS']);
+ # Now do tail of InitObject
+ $icon->ConfigDefault(\%args);
+ # And configure that new would have done
+ $top->iconwindow($icon);
+ $top->update;
+ $lab->DisableButtonEvents;
+ $lab->update;
+ }
+ $top->iconimage($args{'-image'}) if (exists $args{'-image'});
+ $icon->configure(%args);
+ $icon->idletasks; # Let size request propogate
+ $icon->geometry($icon->ReqWidth . 'x' . $icon->ReqHeight);
+ $icon->update; # Let attributes propogate
+ $top->deiconify if ($state eq 'normal');
+ $top->iconify if ($state eq 'iconic');
+}
+
+sub menu
+{
+ my $w = shift;
+ my $menu;
+ $menu = $w->cget('-menu');
+ unless (defined $menu)
+ {
+ $w->configure(-menu => ($menu = $w->SUPER::menu))
+ }
+ $menu->configure(@_) if @_;
+ return $menu;
+}
+
+
+1;
+__END__
+
+#----------------------------------------------------------------------
+#
+# Focus Group
+#
+# Focus groups are used to handle the user's focusing actions inside a
+# toplevel.
+#
+# One example of using focus groups is: when the user focuses on an
+# entry, the text in the entry is highlighted and the cursor is put to
+# the end of the text. When the user changes focus to another widget,
+# the text in the previously focused entry is validated.
+#
+
+#----------------------------------------------------------------------
+# tkFocusGroup_Create --
+#
+# Create a focus group. All the widgets in a focus group must be
+# within the same focus toplevel. Each toplevel can have only
+# one focus group, which is identified by the name of the
+# toplevel widget.
+#
+sub FG_Create {
+ my $t = shift;
+ unless (exists $t->{'_fg'}) {
+ $t->{'_fg'} = 1;
+ $t->bind('<FocusIn>', sub {
+ my $w = shift;
+ my $Ev = $w->XEvent;
+ $t->FG_In($w, $Ev->d);
+ }
+ );
+ $t->bind('<FocusOut>', sub {
+ my $w = shift;
+ my $Ev = $w->XEvent;
+ $t->FG_Out($w, $Ev->d);
+ }
+ );
+ $t->bind('<Destroy>', sub {
+ my $w = shift;
+ my $Ev = $w->XEvent;
+ $t->FG_Destroy($w);
+ }
+ );
+ # <Destroy> is not sufficient to break loops if never mapped.
+ $t->OnDestroy([$t,'FG_Destroy']);
+ }
+}
+
+# tkFocusGroup_BindIn --
+#
+# Add a widget into the "FocusIn" list of the focus group. The $cmd will be
+# called when the widget is focused on by the user.
+#
+sub FG_BindIn {
+ my($t, $w, $cmd) = @_;
+ $t->Error("focus group \"$t\" doesn't exist") unless (exists $t->{'_fg'});
+ $t->{'_FocusIn'}{$w} = Tk::Callback->new($cmd);
+}
+
+# tkFocusGroup_BindOut --
+#
+# Add a widget into the "FocusOut" list of the focus group. The
+# $cmd will be called when the widget loses the focus (User
+# types Tab or click on another widget).
+#
+sub FG_BindOut {
+ my($t, $w, $cmd) = @_;
+ $t->Error("focus group \"$t\" doesn't exist") unless (exists $t->{'_fg'});
+ $t->{'_FocusOut'}{$w} = Tk::Callback->new($cmd);
+}
+
+# tkFocusGroup_Destroy --
+#
+# Cleans up when members of the focus group is deleted, or when the
+# toplevel itself gets deleted.
+#
+sub FG_Destroy {
+ my($t, $w) = @_;
+ if (!defined($w) || $t == $w) {
+ delete $t->{'_fg'};
+ delete $t->{'_focus'};
+ delete $t->{'_FocusOut'};
+ delete $t->{'_FocusIn'};
+ } else {
+ if (exists $t->{'_focus'}) {
+ delete $t->{'_focus'} if ($t->{'_focus'} == $w);
+ }
+ delete $t->{'_FocusIn'}{$w};
+ delete $t->{'_FocusOut'}{$w};
+ }
+}
+
+# tkFocusGroup_In --
+#
+# Handles the <FocusIn> event. Calls the FocusIn command for the newly
+# focused widget in the focus group.
+#
+sub FG_In {
+ my($t, $w, $detail) = @_;
+ if (defined $t->{'_focus'} and $t->{'_focus'} eq $w) {
+ # This is already in focus
+ return;
+ } else {
+ $t->{'_focus'} = $w;
+ $t->{'_FocusIn'}{$w}->Call if exists $t->{'_FocusIn'}{$w};
+ }
+}
+
+# tkFocusGroup_Out --
+#
+# Handles the <FocusOut> event. Checks if this is really a lose
+# focus event, not one generated by the mouse moving out of the
+# toplevel window. Calls the FocusOut command for the widget
+# who loses its focus.
+#
+sub FG_Out {
+ my($t, $w, $detail) = @_;
+ if ($detail ne 'NotifyNonlinear' and $detail ne 'NotifyNonlinearVirtual') {
+ # This is caused by mouse moving out of the window
+ return;
+ }
+ unless (exists $t->{'_FocusOut'}{$w}) {
+ return;
+ } else {
+ $t->{'_FocusOut'}{$w}->Call;
+ delete $t->{'_focus'};
+ }
+}
+
+1;
+
+__END__
diff --git a/Master/tlpkg/installer/perllib/Tk/Widget.pm b/Master/tlpkg/installer/perllib/Tk/Widget.pm
new file mode 100644
index 00000000000..e94c037e6fe
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/Tk/Widget.pm
@@ -0,0 +1,1510 @@
+# Copyright (c) 1995-2004 Nick Ing-Simmons. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+package Tk::Widget;
+use vars qw($VERSION @DefaultMenuLabels);
+$VERSION = sprintf '4.%03d', q$Revision: #30 $ =~ /\D(\d+)\s*$/;
+
+require Tk;
+use AutoLoader;
+use strict;
+use Carp;
+use base qw(DynaLoader Tk);
+
+# stubs for 'autoloaded' widget classes
+sub Button;
+sub Canvas;
+sub Checkbutton;
+sub Entry;
+sub Frame;
+sub Label;
+sub Labelframe;
+sub Listbox;
+sub Menu;
+sub Menubutton;
+sub Message;
+sub Panedwindow;
+sub Radiobutton;
+sub Scale;
+sub Scrollbar;
+sub Spinbox;
+sub Text;
+sub Toplevel;
+
+sub Pixmap;
+sub Bitmap;
+sub Photo;
+
+sub ScrlListbox;
+sub Optionmenu;
+
+sub import
+{
+ my $package = shift;
+ carp 'use Tk::Widget () to pre-load widgets is deprecated' if (@_);
+ my $need;
+ foreach $need (@_)
+ {
+ unless (defined &{$need})
+ {
+ require "Tk/${need}.pm";
+ }
+ croak "Cannot locate $need" unless (defined &{$need});
+ }
+}
+
+@DefaultMenuLabels = qw[~File ~Help];
+
+# Some tidy-ness functions for winfo stuff
+
+sub True { 1 }
+sub False { 0 }
+
+use Tk::Submethods( 'grab' => [qw(current status release -global)],
+ 'focus' => [qw(-force -lastfor)],
+ 'pack' => [qw(configure forget info propagate slaves)],
+ 'grid' => [qw(bbox columnconfigure configure forget info location propagate rowconfigure size slaves)],
+ 'form' => [qw(check configure forget grid info slaves)],
+ 'event' => [qw(add delete generate info)],
+ 'place' => [qw(configure forget info slaves)],
+ 'wm' => [qw(capture release)],
+ 'font' => [qw(actual configure create delete families measure metrics names subfonts)]
+ );
+
+BEGIN {
+ # FIXME - these don't work in the compiler
+ *IsMenu = \&False;
+ *IsMenubutton = \&False;
+ *configure_self = \&Tk::configure;
+ *cget_self = \&Tk::cget;
+}
+
+
+
+Direct Tk::Submethods (
+ 'winfo' => [qw(cells class colormapfull depth exists
+ geometry height id ismapped manager name parent reqheight
+ reqwidth rootx rooty screen screencells screendepth screenheight
+ screenmmheight screenmmwidth screenvisual screenwidth visual
+ visualsavailable vrootheight viewable vrootwidth vrootx vrooty
+ width x y toplevel children pixels pointerx pointery pointerxy
+ server fpixels rgb )],
+ 'tk' => [qw(appname caret scaling useinputmethods windowingsystem)]);
+
+
+sub DESTROY
+{
+ my $w = shift;
+ $w->destroy if ($w->IsWidget);
+}
+
+sub Install
+{
+ # Dynamically loaded widgets add their core commands
+ # to the Tk base class here
+ my ($package,$mw) = @_;
+}
+
+sub ClassInit
+{
+ # Carry out class bindings (or whatever)
+ my ($package,$mw) = @_;
+ return $package;
+}
+
+sub CreateOptions
+{
+ return ();
+}
+
+sub CreateArgs
+{
+ my ($package,$parent,$args) = @_;
+ # Remove from hash %$args any configure-like
+ # options which only apply at create time (e.g. -colormap for Frame),
+ # or which may as well be applied right away
+ # return these as a list of -key => value pairs
+ # Augment same hash with default values for missing mandatory options,
+ # allthough this can be done later in InitObject.
+
+ # Honour -class => if present, we have hacked Tk_ConfigureWidget to
+ # allow -class to be passed to any widget.
+ my @result = ();
+ my $class = delete $args->{'-class'};
+ ($class) = $package =~ /([A-Z][A-Z0-9_]*)$/i unless (defined $class);
+ @result = (-class => "\u$class") if (defined $class);
+ foreach my $opt ($package->CreateOptions)
+ {
+ push(@result, $opt => delete $args->{$opt}) if exists $args->{$opt};
+ }
+ return @result;
+}
+
+sub InitObject
+{
+ my ($obj,$args) = @_;
+ # per object initialization, for example populating
+ # with sub-widgets, adding a few object bindings to augment
+ # inherited class bindings, changing binding tags.
+ # Also another chance to mess with %$args before configure...
+}
+
+sub SetBindtags
+{
+ my ($obj) = @_;
+ $obj->bindtags([ref($obj),$obj,$obj->toplevel,'all']);
+}
+
+sub new
+{
+ local $SIG{'__DIE__'} = \&Carp::croak;
+ my $package = shift;
+ my $parent = shift;
+ $package->InitClass($parent);
+ $parent->BackTrace("Odd number of args to $package->new(...)") unless ((@_ % 2) == 0);
+ my %args = @_;
+ my @args = $package->CreateArgs($parent,\%args);
+ my $cmd = $package->Tk_cmd;
+ my $pname = $parent->PathName;
+ $pname = '' if ($pname eq '.');
+ my $leaf = delete $args{'Name'};
+ if (defined $leaf)
+ {
+ $leaf =~ s/[^a-z0-9_#]+/_/ig;
+ $leaf = lcfirst($leaf);
+ }
+ else
+ {
+ ($leaf) = "\L$package" =~ /([a-z][a-z0-9_]*)$/;
+ }
+ my $lname = $pname . '.' . $leaf;
+ # create a hash indexed by leaf name to speed up
+ # creation of a lot of sub-widgets of the same type
+ # e.g. entries in Table
+ my $nhash = $parent->TkHash('_names_');
+ $nhash->{$leaf} = 0 unless (exists $nhash->{$leaf});
+ while (defined ($parent->Widget($lname)))
+ {
+ $lname = $pname . '.' . $leaf . ++$nhash->{$leaf};
+ }
+ my $obj = eval { &$cmd($parent, $lname, @args) };
+ confess $@ if $@;
+ unless (ref $obj)
+ {
+ die "No value from $cmd $lname" unless defined $obj;
+ warn "$cmd '$lname' returned '$obj'" unless $obj eq $lname;
+ $obj = $parent->Widget($lname = $obj);
+ die "$obj from $lname" unless ref $obj;
+ }
+ bless $obj,$package;
+ $obj->SetBindtags;
+ my $notice = $parent->can('NoticeChild');
+ $parent->$notice($obj,\%args) if $notice;
+ $obj->InitObject(\%args);
+# ASkludge(\%args,1);
+ $obj->configure(%args) if (%args);
+# ASkludge(\%args,0);
+ return $obj;
+}
+
+sub DelegateFor
+{
+ my ($w,$method) = @_;
+ while(exists $w->{'Delegates'})
+ {
+ my $delegate = $w->{'Delegates'};
+ my $widget = $delegate->{$method};
+ $widget = $delegate->{DEFAULT} unless (defined $widget);
+ $widget = $w->Subwidget($widget) if (defined $widget && !ref $widget);
+ last unless (defined $widget);
+ last if $widget == $w;
+ $w = $widget;
+ }
+ return $w;
+}
+
+sub Delegates
+{
+ my $cw = shift;
+ my $specs = $cw->TkHash('Delegates');
+ while (@_)
+ {
+ my $key = shift;
+ my $val = shift;
+ $specs->{$key} = $val;
+ }
+ return $specs;
+}
+
+sub Construct
+{
+ my ($base,$name) = @_;
+ my $class = (caller(0))[0];
+ no strict 'refs';
+
+ # Hack for broken ->isa in perl5.6.0
+ delete ${"$class\::"}{'::ISA::CACHE::'} if $] == 5.006;
+
+ # Pre ->isa scheme
+ *{$base.'::Is'.$name} = \&False;
+ *{$class.'::Is'.$name} = \&True;
+
+ # DelegateFor trickyness is to allow Frames and other derived things
+ # to force creation in a delegate e.g. a ScrlText with embeded windows
+ # need those windows to be children of the Text to get clipping right
+ # and not of the Frame which contains the Text and the scrollbars.
+ *{$base.'::'."$name"} = sub { $class->new(shift->DelegateFor('Construct'),@_) };
+}
+
+sub IS
+{
+ return (defined $_[1]) && $_[0] == $_[1];
+}
+
+sub _AutoloadTkWidget
+{
+ my ($self,$method) = @_;
+ my $what = "Tk::Widget::$method";
+ unless (defined &$what)
+ {
+ require "Tk/$method.pm";
+ }
+ return $what;
+}
+
+# require UNIVERSAL; don't load .pm use XS code from perl core though
+
+sub AUTOLOAD
+{
+ # Take a copy into a 'my' variable so we can recurse
+ my $what = $Tk::Widget::AUTOLOAD;
+ my $save = $@;
+ my $name;
+ # warn "AUTOLOAD $what ".(ref($_[0]) || $_[0])."\n";
+ # Braces used to preserve $1 et al.
+ {
+ my ($pkg,$func) = $what =~ /(.*)::([^:]+)$/;
+ confess("Attempt to load '$what'") unless defined($pkg) && $func =~ /^[\w:]+$/;
+ $pkg =~ s#::#/#g;
+ if (defined($name=$INC{"$pkg.pm"}))
+ {
+ $name =~ s#^(.*)$pkg\.pm$#$1auto/$pkg/$func.al#;
+ }
+ else
+ {
+ $name = "auto/$what.al";
+ $name =~ s#::#/#g;
+ }
+ }
+ # This may fail, catch error and prevent user's __DIE__ handler
+ # from triggering as well...
+ eval {local $SIG{'__DIE__'}; require $name};
+ if ($@)
+ {
+ croak $@ unless ($@ =~ /Can't locate\s+(?:file\s+)?'?\Q$name\E'?/);
+ my($package,$method) = ($what =~ /^(.*)::([^:]*)$/);
+ if (ref $_[0] && !$_[0]->can($method)
+ && $_[0]->can('Delegate')
+ && $method !~ /^(ConfigSpecs|Delegates)/ )
+ {
+ my $delegate = $_[0]->Delegates;
+ if (%$delegate || tied %$delegate)
+ {
+ my $widget = $delegate->{$method};
+ $widget = $delegate->{DEFAULT} unless (defined $widget);
+ if (defined $widget)
+ {
+ my $subwidget = (ref $widget) ? $widget : $_[0]->Subwidget($widget);
+ if (defined $subwidget)
+ {
+ no strict 'refs';
+ # print "AUTOLOAD: $what\n";
+ *{$what} = sub { shift->Delegate($method,@_) };
+ }
+ else
+ {
+ croak "No delegate subwidget '$widget' for $what";
+ }
+ }
+ }
+ }
+ if (!defined(&$what) && ref($_[0]) && $method =~ /^[A-Z]\w+$/)
+ {
+ # Use ->can as ->isa is broken in perl5.6.0
+ my $sub = UNIVERSAL::can($_[0],'_AutoloadTkWidget');
+ if ($sub)
+ {
+ carp "Assuming 'require Tk::$method;'" unless $_[0]->can($method);
+ $what = $_[0]->$sub($method)
+ }
+ }
+ }
+ $@ = $save;
+ $DB::sub = $what; # Tell debugger what is going on...
+ unless (defined &$what)
+ {
+ no strict 'refs';
+ *{$what} = sub { croak("Failed to AUTOLOAD '$what'") };
+ }
+ goto &$what;
+}
+
+sub _Destroyed
+{
+ my $w = shift;
+ my $a = delete $w->{'_Destroy_'};
+ if (ref($a))
+ {
+ while (@$a)
+ {
+ my $ent = pop(@$a);
+ if (ref $ent)
+ {
+ eval {local $SIG{'__DIE__'}; $ent->Call };
+ }
+ else
+ {
+ delete $w->{$ent};
+ }
+ }
+ }
+}
+
+sub _OnDestroy
+{
+ my $w = shift;
+ $w->{'_Destroy_'} = [] unless (exists $w->{'_Destroy_'});
+ push(@{$w->{'_Destroy_'}},@_);
+}
+
+sub OnDestroy
+{
+ my $w = shift;
+ $w->_OnDestroy(Tk::Callback->new(@_));
+}
+
+sub TkHash
+{
+ my ($w,$key) = @_;
+ return $w->{$key} if exists $w->{$key};
+ my $hash = $w->{$key} = {};
+ $w->_OnDestroy($key);
+ return $hash;
+}
+
+sub privateData
+{
+ my $w = shift;
+ my $p = shift || caller;
+ $w->{$p} ||= {};
+}
+
+my @image_types;
+my %image_method;
+
+sub ImageMethod
+{
+ shift if (@_ & 1);
+ while (@_)
+ {
+ my ($name,$method) = splice(@_,0,2);
+ push(@image_types,$name);
+ $image_method{$name} = $method;
+ }
+}
+
+sub Getimage
+{
+ my ($w, $name) = @_;
+ my $mw = $w->MainWindow;
+ croak "Usage \$widget->Getimage('name')" unless defined($name);
+ my $images = ($mw->{'__Images__'} ||= {});
+
+ return $images->{$name} if $images->{$name};
+
+ ImageMethod(xpm => 'Pixmap',
+ gif => 'Photo',
+ ppm => 'Photo',
+ xbm => 'Bitmap' ) unless @image_types;
+
+ foreach my $type (@image_types)
+ {
+ my $method = $image_method{$type};
+ my $file = Tk->findINC( "$name.$type" );
+ next unless( $file && $method );
+ my $sub = $w->can($method);
+ unless (defined &$sub)
+ {
+ require Tk::widgets;
+ Tk::widgets->import($method);
+ }
+ $images->{$name} = $w->$method( -file => $file );
+ return $images->{$name};
+ }
+
+ # Try built-in bitmaps
+ $images->{$name} = $w->Pixmap( -id => $name );
+ return $images->{$name};
+}
+
+sub SaveGrabInfo
+{
+ my $w = shift;
+ $Tk::oldGrab = $w->grabCurrent;
+ if (defined $Tk::oldGrab)
+ {
+ $Tk::grabStatus = $Tk::oldGrab->grabStatus;
+ }
+}
+
+sub grabSave
+{
+ my ($w) = @_;
+ my $grab = $w->grabCurrent;
+ return sub {} if (!defined $grab);
+ my $method = ($grab->grabStatus eq 'global') ? 'grabGlobal' : 'grab';
+ return sub { eval {local $SIG{'__DIE__'}; $grab->$method() } };
+}
+
+sub focusCurrent
+{
+ my ($w) = @_;
+ $w->Tk::focus('-displayof');
+}
+
+sub focusSave
+{
+ my ($w) = @_;
+ my $focus = $w->focusCurrent;
+ return sub {} if (!defined $focus);
+ return sub { eval {local $SIG{'__DIE__'}; $focus->focus } };
+}
+
+# This is supposed to replicate Tk::after behaviour,
+# but does auto-cancel when widget is deleted.
+require Tk::After;
+
+sub afterCancel
+{
+ my ($w,$what) = @_;
+ if (defined $what)
+ {
+ return $what->cancel if ref($what);
+ carp "dubious cancel of $what" if 0 && $^W;
+ $w->Tk::after('cancel' => $what);
+ }
+}
+
+sub afterIdle
+{
+ my $w = shift;
+ return Tk::After->new($w,'idle','once',@_);
+}
+
+sub afterInfo {
+ my ($w, $id) = @_;
+ if (defined $id) {
+ return ($id->[4], $id->[2], $id->[3]);
+ } else {
+ return sort( keys %{$w->{_After_}} );
+ }
+}
+
+sub after
+{
+ my $w = shift;
+ my $t = shift;
+ if (@_)
+ {
+ if ($t ne 'cancel')
+ {
+ require Tk::After;
+ return Tk::After->new($w,$t,'once',@_)
+ }
+ while (@_)
+ {
+ my $what = shift;
+ $w->afterCancel($what);
+ }
+ }
+ else
+ {
+ $w->Tk::after($t);
+ }
+}
+
+sub repeat
+{
+ require Tk::After;
+ my $w = shift;
+ my $t = shift;
+ return Tk::After->new($w,$t,'repeat',@_);
+}
+
+sub FindMenu
+{
+ # default FindMenu is that there is no menu.
+ return undef;
+}
+
+sub XEvent { shift->{'_XEvent_'} }
+
+sub propertyRoot
+{
+ my $w = shift;
+ return $w->property(@_,'root');
+}
+
+# atom, atomname, containing, interps, pathname
+# don't work this way - there is no window arg
+# So we pretend there was an call the C versions from Tk.xs
+
+sub atom { shift->InternAtom(@_) }
+sub atomname { shift->GetAtomName(@_) }
+sub containing { shift->Containing(@_) }
+
+# interps not done yet
+# pathname not done yet
+
+# walk and descendants adapted from Stephen's composite
+# versions as they only use core features they can go here.
+# hierachy is reversed in that descendants calls walk rather
+# than vice versa as this avoids building a list.
+# Walk should possibly be enhanced so allow early termination
+# like '-prune' of find.
+
+sub Walk
+{
+ # Traverse a widget hierarchy while executing a subroutine.
+ my($cw, $proc, @args) = @_;
+ my $subwidget;
+ foreach $subwidget ($cw->children)
+ {
+ $subwidget->Walk($proc,@args);
+ &$proc($subwidget, @args);
+ }
+} # end walk
+
+sub Descendants
+{
+ # Return a list of widgets derived from a parent widget and all its
+ # descendants of a particular class.
+ # If class is not passed returns the entire widget hierarchy.
+
+ my($widget, $class) = @_;
+ my(@widget_tree) = ();
+
+ $widget->Walk(
+ sub { my ($widget,$list,$class) = @_;
+ push(@$list, $widget) if (!defined($class) or $class eq $widget->class);
+ },
+ \@widget_tree, $class
+ );
+ return @widget_tree;
+}
+
+sub Palette
+{
+ my $w = shift->MainWindow;
+ unless (exists $w->{_Palette_})
+ {
+ my %Palette = ();
+ my $c = $w->Checkbutton();
+ my $e = $w->Entry();
+ my $s = $w->Scrollbar();
+ $Palette{'activeBackground'} = ($c->configure('-activebackground'))[3] ;
+ $Palette{'activeForeground'} = ($c->configure('-activeforeground'))[3];
+ $Palette{'background'} = ($c->configure('-background'))[3];
+ $Palette{'disabledForeground'} = ($c->configure('-disabledforeground'))[3];
+ $Palette{'foreground'} = ($c->configure('-foreground'))[3];
+ $Palette{'highlightBackground'} = ($c->configure('-highlightbackground'))[3];
+ $Palette{'highlightColor'} = ($c->configure('-highlightcolor'))[3];
+ $Palette{'insertBackground'} = ($e->configure('-insertbackground'))[3];
+ $Palette{'selectColor'} = ($c->configure('-selectcolor'))[3];
+ $Palette{'selectBackground'} = ($e->configure('-selectbackground'))[3];
+ $Palette{'selectForeground'} = ($e->configure('-selectforeground'))[3];
+ $Palette{'troughColor'} = ($s->configure('-troughcolor'))[3];
+ $c->destroy;
+ $e->destroy;
+ $s->destroy;
+ $w->{_Palette_} = \%Palette;
+ }
+ return $w->{_Palette_};
+}
+
+# tk_setPalette --
+# Changes the default color scheme for a Tk application by setting
+# default colors in the option database and by modifying all of the
+# color options for existing widgets that have the default value.
+#
+# Arguments:
+# The arguments consist of either a single color name, which
+# will be used as the new background color (all other colors will
+# be computed from this) or an even number of values consisting of
+# option names and values. The name for an option is the one used
+# for the option database, such as activeForeground, not -activeforeground.
+sub setPalette
+{
+ my $w = shift->MainWindow;
+ my %new = (@_ == 1) ? (background => $_[0]) : @_;
+ my $priority = delete($new{'priority'}) || 'widgetDefault';
+
+ # Create an array that has the complete new palette. If some colors
+ # aren't specified, compute them from other colors that are specified.
+
+ die 'must specify a background color' if (!exists $new{background});
+ $new{'foreground'} = 'black' unless (exists $new{foreground});
+ my @bg = $w->rgb($new{'background'});
+ my @fg = $w->rgb($new{'foreground'});
+ my $darkerBg = sprintf('#%02x%02x%02x',9*$bg[0]/2560,9*$bg[1]/2560,9*$bg[2]/2560);
+ foreach my $i ('activeForeground','insertBackground','selectForeground','highlightColor')
+ {
+ $new{$i} = $new{'foreground'} unless (exists $new{$i});
+ }
+ unless (exists $new{'disabledForeground'})
+ {
+ $new{'disabledForeground'} = sprintf('#%02x%02x%02x',(3*$bg[0]+$fg[0])/1024,(3*$bg[1]+$fg[1])/1024,(3*$bg[2]+$fg[2])/1024);
+ }
+ $new{'highlightBackground'} = $new{'background'} unless (exists $new{'highlightBackground'});
+
+ unless (exists $new{'activeBackground'})
+ {
+ my @light;
+ # Pick a default active background that is lighter than the
+ # normal background. To do this, round each color component
+ # up by 15% or 1/3 of the way to full white, whichever is
+ # greater.
+ foreach my $i (0, 1, 2)
+ {
+ $light[$i] = $bg[$i]/256;
+ my $inc1 = $light[$i]*15/100;
+ my $inc2 = (255-$light[$i])/3;
+ if ($inc1 > $inc2)
+ {
+ $light[$i] += $inc1
+ }
+ else
+ {
+ $light[$i] += $inc2
+ }
+ $light[$i] = 255 if ($light[$i] > 255);
+ }
+ $new{'activeBackground'} = sprintf('#%02x%02x%02x',@light);
+ }
+ $new{'selectBackground'} = $darkerBg unless (exists $new{'selectBackground'});
+ $new{'troughColor'} = $darkerBg unless (exists $new{'troughColor'});
+ $new{'selectColor'} = '#b03060' unless (exists $new{'selectColor'});
+
+ # Before doing this, make sure that the Tk::Palette variable holds
+ # the default values of all options, so that tkRecolorTree can
+ # be sure to only change options that have their default values.
+ # If the variable exists, then it is already correct (it was created
+ # the last time this procedure was invoked). If the variable
+ # doesn't exist, fill it in using the defaults from a few widgets.
+ my $Palette = $w->Palette;
+
+ # Walk the widget hierarchy, recoloring all existing windows.
+ $w->RecolorTree(\%new);
+ # Change the option database so that future windows will get the
+ # same colors.
+ foreach my $option (keys %new)
+ {
+ $w->option('add',"*$option",$new{$option},$priority);
+ # Save the options in the global variable Tk::Palette, for use the
+ # next time we change the options.
+ $Palette->{$option} = $new{$option};
+ }
+}
+
+# tkRecolorTree --
+# This procedure changes the colors in a window and all of its
+# descendants, according to information provided by the colors
+# argument. It only modifies colors that have their default values
+# as specified by the Tk::Palette variable.
+#
+# Arguments:
+# w - The name of a window. This window and all its
+# descendants are recolored.
+# colors - The name of an array variable in the caller,
+# which contains color information. Each element
+# is named after a widget configuration option, and
+# each value is the value for that option.
+sub RecolorTree
+{
+ my ($w,$colors) = @_;
+ local ($@);
+ my $Palette = $w->Palette;
+ foreach my $dbOption (keys %$colors)
+ {
+ my $option = "-\L$dbOption";
+ my $value;
+ eval {local $SIG{'__DIE__'}; $value = $w->cget($option) };
+ if (defined $value)
+ {
+ if ($value eq $Palette->{$dbOption})
+ {
+ $w->configure($option,$colors->{$dbOption});
+ }
+ }
+ }
+ foreach my $child ($w->children)
+ {
+ $child->RecolorTree($colors);
+ }
+}
+# tkDarken --
+# Given a color name, computes a new color value that darkens (or
+# brightens) the given color by a given percent.
+#
+# Arguments:
+# color - Name of starting color.
+# perecent - Integer telling how much to brighten or darken as a
+# percent: 50 means darken by 50%, 110 means brighten
+# by 10%.
+sub Darken
+{
+ my ($w,$color,$percent) = @_;
+ my @l = $w->rgb($color);
+ my $red = $l[0]/256;
+ my $green = $l[1]/256;
+ my $blue = $l[2]/256;
+ $red = int($red*$percent/100);
+ $red = 255 if ($red > 255);
+ $green = int($green*$percent/100);
+ $green = 255 if ($green > 255);
+ $blue = int($blue*$percent/100);
+ $blue = 255 if ($blue > 255);
+ sprintf('#%02x%02x%02x',$red,$green,$blue)
+}
+# tk_bisque --
+# Reset the Tk color palette to the old "bisque" colors.
+#
+# Arguments:
+# None.
+sub bisque
+{
+ shift->setPalette('activeBackground' => '#e6ceb1',
+ 'activeForeground' => 'black',
+ 'background' => '#ffe4c4',
+ 'disabledForeground' => '#b0b0b0',
+ 'foreground' => 'black',
+ 'highlightBackground' => '#ffe4c4',
+ 'highlightColor' => 'black',
+ 'insertBackground' => 'black',
+ 'selectColor' => '#b03060',
+ 'selectBackground' => '#e6ceb1',
+ 'selectForeground' => 'black',
+ 'troughColor' => '#cdb79e'
+ );
+}
+
+sub PrintConfig
+{
+ require Tk::Pretty;
+ my ($w) = (@_);
+ my $c;
+ foreach $c ($w->configure)
+ {
+ print Tk::Pretty::Pretty(@$c),"\n";
+ }
+}
+
+sub BusyRecurse
+{
+ my ($restore,$w,$cursor,$recurse,$top) = @_;
+ my $c = $w->cget('-cursor');
+ my @tags = $w->bindtags;
+ if ($top || defined($c))
+ {
+ push(@$restore, sub { return unless Tk::Exists($w); $w->configure(-cursor => $c); $w->bindtags(\@tags) });
+ $w->configure(-cursor => $cursor);
+ }
+ else
+ {
+ push(@$restore, sub { return unless Tk::Exists($w); $w->bindtags(\@tags) });
+ }
+ $w->bindtags(['Busy',@tags]);
+ if ($recurse)
+ {
+ foreach my $child ($w->children)
+ {
+ BusyRecurse($restore,$child,$cursor,1,0);
+ }
+ }
+ return $restore;
+}
+
+sub Busy
+{
+ my ($w,@args) = @_;
+ return unless $w->viewable;
+ my($sub, %args);
+ for(my $i=0; $i<=$#args; $i++)
+ {
+ if (ref $args[$i] eq 'CODE')
+ {
+ if (defined $sub)
+ {
+ croak "Multiple code definitions not allowed in Tk::Widget::Busy";
+ }
+ $sub = $args[$i];
+ }
+ else
+ {
+ $args{$args[$i]} = $args[$i+1]; $i++;
+ }
+ }
+ my $cursor = delete $args{'-cursor'};
+ my $recurse = delete $args{'-recurse'};
+ $cursor = 'watch' unless defined $cursor;
+ unless (exists $w->{'Busy'})
+ {
+ my @old = ($w->grabSave);
+ my $key;
+ my @config;
+ foreach $key (keys %args)
+ {
+ push(@config,$key => $w->Tk::cget($key));
+ }
+ if (@config)
+ {
+ push(@old, sub { $w->Tk::configure(@config) });
+ $w->Tk::configure(%args);
+ }
+ unless ($w->Tk::bind('Busy'))
+ {
+ $w->Tk::bind('Busy','<Any-KeyPress>',[_busy => 1]);
+ $w->Tk::bind('Busy','<Any-KeyRelease>',[_busy => 0]);
+ $w->Tk::bind('Busy','<Any-ButtonPress>',[_busy => 1]);
+ $w->Tk::bind('Busy','<Any-ButtonRelease>',[_busy => 0]);
+ $w->Tk::bind('Busy','<Any-Motion>',[_busy => 0]);
+ }
+ $w->{'Busy'} = BusyRecurse(\@old,$w,$cursor,$recurse,1);
+ }
+ my $g = $w->grabCurrent;
+ if (defined $g)
+ {
+ # warn "$g has the grab";
+ $g->grabRelease;
+ }
+ $w->update;
+ eval {local $SIG{'__DIE__'}; $w->grab };
+ $w->update;
+ if ($sub)
+ {
+ eval { $sub->() };
+ my $err = $@;
+ $w->Unbusy(-recurse => $recurse);
+ die $err if $err;
+ }
+}
+
+sub _busy
+{
+ my ($w,$f) = @_;
+ $w->bell if $f;
+ $w->break;
+}
+
+sub Unbusy
+{
+ my ($w) = @_;
+ $w->update;
+ $w->grabRelease if Tk::Exists($w);
+ my $old = delete $w->{'Busy'};
+ if (defined $old)
+ {
+ local $SIG{'__DIE__'};
+ eval { &{pop(@$old)} } while (@$old);
+ }
+ $w->update if Tk::Exists($w);
+}
+
+sub waitVisibility
+{
+ my ($w) = shift;
+ $w->tkwait('visibility',$w);
+}
+
+sub waitVariable
+{
+ my ($w) = shift;
+ $w->tkwait('variable',@_);
+}
+
+sub waitWindow
+{
+ my ($w) = shift;
+ $w->tkwait('window',$w);
+}
+
+sub EventWidget
+{
+ my ($w) = @_;
+ return $w->{'_EventWidget_'};
+}
+
+sub Popwidget
+{
+ my ($ew,$method,$w,@args) = @_;
+ $w->{'_EventWidget_'} = $ew;
+ $w->$method(@args);
+}
+
+sub ColorOptions
+{
+ my ($w,$args) = @_;
+ my $opt;
+ $args = {} unless (defined $args);
+ foreach $opt (qw(-foreground -background -disabledforeground
+ -activebackground -activeforeground
+ ))
+ {
+ $args->{$opt} = $w->cget($opt) unless (exists $args->{$opt})
+ }
+ return (wantarray) ? %$args : $args;
+}
+
+sub XscrollBind
+{
+ my ($mw,$class) = @_;
+ $mw->bind($class,'<Left>', ['xview','scroll',-1,'units']);
+ $mw->bind($class,'<Control-Left>', ['xview','scroll',-1,'pages']);
+ $mw->bind($class,'<Control-Prior>',['xview','scroll',-1,'pages']);
+ $mw->bind($class,'<Right>', ['xview','scroll',1,'units']);
+ $mw->bind($class,'<Control-Right>',['xview','scroll',1,'pages']);
+ $mw->bind($class,'<Control-Next>', ['xview','scroll',1,'pages']);
+
+ $mw->bind($class,'<Home>', ['xview','moveto',0]);
+ $mw->bind($class,'<End>', ['xview','moveto',1]);
+ $mw->XMouseWheelBind($class);
+}
+
+sub PriorNextBind
+{
+ my ($mw,$class) = @_;
+ $mw->bind($class,'<Next>', ['yview','scroll',1,'pages']);
+ $mw->bind($class,'<Prior>', ['yview','scroll',-1,'pages']);
+}
+
+sub XMouseWheelBind
+{
+ my ($mw,$class) = @_;
+ # <4> and <5> are how mousewheel looks on X
+ # <4> and <5> are how mousewheel looks on X
+ $mw->bind($class,'<Shift-4>', ['xview','scroll',-1,'units']);
+ $mw->bind($class,'<Shift-5>', ['xview','scroll',1,'units']);
+ $mw->bind($class,'<Button-6>', ['xview','scroll',-1,'units']);
+ $mw->bind($class,'<Button-7>', ['xview','scroll',1,'units']);
+}
+
+sub YMouseWheelBind
+{
+ my ($mw,$class) = @_;
+ # <4> and <5> are how mousewheel looks on X
+ $mw->bind($class,'<4>', ['yview','scroll',-1,'units']);
+ $mw->bind($class,'<5>', ['yview','scroll',1,'units']);
+}
+
+sub YscrollBind
+{
+ my ($mw,$class) = @_;
+ $mw->PriorNextBind($class);
+ $mw->bind($class,'<Up>', ['yview','scroll',-1,'units']);
+ $mw->bind($class,'<Down>', ['yview','scroll',1,'units']);
+ $mw->YMouseWheelBind($class);
+}
+
+sub XYscrollBind
+{
+ my ($mw,$class) = @_;
+ $mw->YscrollBind($class);
+ $mw->XscrollBind($class);
+ # <4> and <5> are how mousewheel looks on X
+}
+
+sub MouseWheelBind
+{
+ my($mw,$class) = @_;
+
+ # The MouseWheel will typically only fire on Windows. However, one
+ # could use the "event generate" command to produce MouseWheel
+ # events on other platforms.
+
+ $mw->Tk::bind($class, '<MouseWheel>',
+ [ sub { $_[0]->yview('scroll',-($_[1]/120)*3,'units') }, Tk::Ev("D")]);
+
+ if ($Tk::platform eq 'unix')
+ {
+ # Support for mousewheels on Linux/Unix commonly comes through mapping
+ # the wheel to the extended buttons. If you have a mousewheel, find
+ # Linux configuration info at:
+ # http://www.inria.fr/koala/colas/mouse-wheel-scroll/
+ $mw->Tk::bind($class, '<4>',
+ sub { $_[0]->yview('scroll', -3, 'units')
+ unless $Tk::strictMotif;
+ });
+ $mw->Tk::bind($class, '<5>',
+ sub { $_[0]->yview('scroll', 3, 'units')
+ unless $Tk::strictMotif;
+ });
+ }
+}
+
+sub ScrlListbox
+{
+ my $parent = shift;
+ return $parent->Scrolled('Listbox',-scrollbars => 'w', @_);
+}
+
+sub AddBindTag
+{
+ my ($w,$tag) = @_;
+ my $t;
+ my @tags = $w->bindtags;
+ foreach $t (@tags)
+ {
+ return if $t eq $tag;
+ }
+ $w->bindtags([@tags,$tag]);
+}
+
+sub Callback
+{
+ my $w = shift;
+ my $name = shift;
+ my $cb = $w->cget($name);
+ if (defined $cb)
+ {
+ return $cb->Call(@_) if (ref $cb);
+ return $w->$cb(@_);
+ }
+ return (wantarray) ? () : undef;
+}
+
+sub packAdjust
+{
+# print 'packAdjust(',join(',',@_),")\n";
+ require Tk::Adjuster;
+ my ($w,%args) = @_;
+ my $delay = delete($args{'-delay'});
+ $delay = 1 unless (defined $delay);
+ $w->pack(%args);
+ %args = $w->packInfo;
+ my $adj = Tk::Adjuster->new($args{'-in'},
+ -widget => $w, -delay => $delay, -side => $args{'-side'});
+ $adj->packed($w,%args);
+ return $w;
+}
+
+sub gridAdjust
+{
+ require Tk::Adjuster;
+ my ($w,%args) = @_;
+ my $delay = delete($args{'-delay'});
+ $delay = 1 unless (defined $delay);
+ $w->grid(%args);
+ %args = $w->gridInfo;
+ my $adj = Tk::Adjuster->new($args{'-in'},-widget => $w, -delay => $delay);
+ $adj->gridded($w,%args);
+ return $w;
+}
+
+sub place
+{
+ local $SIG{'__DIE__'} = \&Carp::croak;
+ my $w = shift;
+ if (@_ && $_[0] =~ /^(?:configure|forget|info|slaves)$/x)
+ {
+ $w->Tk::place(@_);
+ }
+ else
+ {
+ # Two things going on here:
+ # 1. Add configure on the front so that we can drop leading '-'
+ $w->Tk::place('configure',@_);
+ # 2. Return the widget rather than nothing
+ return $w;
+ }
+}
+
+sub pack
+{
+ local $SIG{'__DIE__'} = \&Carp::croak;
+ my $w = shift;
+ if (@_ && $_[0] =~ /^(?:configure|forget|info|propagate|slaves)$/x)
+ {
+ # maybe array/scalar context issue with slaves
+ $w->Tk::pack(@_);
+ }
+ else
+ {
+ # Two things going on here:
+ # 1. Add configure on the front so that we can drop leading '-'
+ $w->Tk::pack('configure',@_);
+ # 2. Return the widget rather than nothing
+ return $w;
+ }
+}
+
+sub grid
+{
+ local $SIG{'__DIE__'} = \&Carp::croak;
+ my $w = shift;
+ if (@_ && $_[0] =~ /^(?:bbox|columnconfigure|configure|forget|info|location|propagate|rowconfigure|size|slaves)$/x)
+ {
+ my $opt = shift;
+ Tk::grid($opt,$w,@_);
+ }
+ else
+ {
+ # Two things going on here:
+ # 1. Add configure on the front so that we can drop leading '-'
+ Tk::grid('configure',$w,@_);
+ # 2. Return the widget rather than nothing
+ return $w;
+ }
+}
+
+sub form
+{
+ local $SIG{'__DIE__'} = \&Carp::croak;
+ my $w = shift;
+ if (@_ && $_[0] =~ /^(?:configure|check|forget|grid|info|slaves)$/x)
+ {
+ $w->Tk::form(@_);
+ }
+ else
+ {
+ # Two things going on here:
+ # 1. Add configure on the front so that we can drop leading '-'
+ $w->Tk::form('configure',@_);
+ # 2. Return the widget rather than nothing
+ return $w;
+ }
+}
+
+sub Scrolled
+{
+ my ($parent,$kind,%args) = @_;
+ $kind = 'Pane' if $kind eq 'Frame';
+ # Find args that are Frame create time args
+ my @args = Tk::Frame->CreateArgs($parent,\%args);
+ my $name = delete $args{'Name'};
+ push(@args,'Name' => $name) if (defined $name);
+ my $cw = $parent->Frame(@args);
+ @args = ();
+ # Now remove any args that Frame can handle
+ foreach my $k ('-scrollbars',map($_->[0],$cw->configure))
+ {
+ push(@args,$k,delete($args{$k})) if (exists $args{$k})
+ }
+ # Anything else must be for target widget - pass at widget create time
+ my $w = $cw->$kind(%args);
+ # Now re-set %args to be ones Frame can handle
+ %args = @args;
+ $cw->ConfigSpecs('-scrollbars' => ['METHOD','scrollbars','Scrollbars','se'],
+ '-background' => [$w,'background','Background'],
+ '-foreground' => [$w,'foreground','Foreground'],
+ );
+ $cw->AddScrollbars($w);
+ $cw->Default("\L$kind" => $w);
+ $cw->Delegates('bind' => $w, 'bindtags' => $w, 'menu' => $w);
+ $cw->ConfigDefault(\%args);
+ $cw->configure(%args);
+ return $cw;
+}
+
+sub Populate
+{
+ my ($cw,$args) = @_;
+}
+
+sub ForwardEvent
+{
+ my $self = shift;
+ my $to = shift;
+ $to->PassEvent($self->XEvent);
+}
+
+# Save / Return abstract event type as in Tix.
+sub EventType
+{
+ my $w = shift;
+ $w->{'_EventType_'} = $_[0] if @_;
+ return $w->{'_EventType_'};
+}
+
+sub PostPopupMenu
+{
+ my ($w, $X, $Y) = @_;
+ if (@_ < 3)
+ {
+ my $e = $w->XEvent;
+ $X = $e->X;
+ $Y = $e->Y;
+ }
+ my $menu = $w->menu;
+ $menu->Post($X,$Y) if defined $menu;
+}
+
+sub FillMenu
+{
+ my ($w,$menu,@labels) = @_;
+ foreach my $lab (@labels)
+ {
+ my $method = $lab.'MenuItems';
+ $method =~ s/~//g;
+ $method =~ s/[\s-]+/_/g;
+ if ($w->can($method))
+ {
+ $menu->Menubutton(-label => $lab, -tearoff => 0, -menuitems => $w->$method());
+ }
+ }
+ return $menu;
+}
+
+sub menu
+{
+ my ($w,$menu) = @_;
+ if (@_ > 1)
+ {
+ $w->_OnDestroy('_MENU_') unless exists $w->{'_MENU_'};
+ $w->{'_MENU_'} = $menu;
+ }
+ return unless defined wantarray;
+ unless (exists $w->{'_MENU_'})
+ {
+ $w->_OnDestroy('_MENU_');
+ $w->{'_MENU_'} = $menu = $w->Menu(-tearoff => 0);
+ $w->FillMenu($menu,$w->MenuLabels);
+ }
+ return $w->{'_MENU_'};
+}
+
+sub MenuLabels
+{
+ return @DefaultMenuLabels;
+}
+
+sub FileMenuItems
+{
+ my ($w) = @_;
+ return [ ["command"=>'E~xit', -command => [ $w, 'WmDeleteWindow']]];
+}
+
+sub WmDeleteWindow
+{
+ shift->toplevel->WmDeleteWindow
+}
+
+sub BalloonInfo
+{
+ my ($widget,$balloon,$X,$Y,@opt) = @_;
+ foreach my $opt (@opt)
+ {
+ my $info = $balloon->GetOption($opt,$widget);
+ return $info if defined $info;
+ }
+}
+
+sub ConfigSpecs {
+
+ my $w = shift;
+
+ return map { ( $_->[0], [ $w, @$_[ 1 .. 4 ] ] ) } $w->configure;
+
+}
+
+*GetSelection =
+ ($Tk::platform eq 'unix'
+ ? sub
+ {
+ my $w = shift;
+ my $sel = @_ ? shift : "PRIMARY";
+ my $txt = eval { local $SIG{__DIE__};
+ $w->SelectionGet(-selection => $sel, -type => "UTF8_STRING")
+ };
+ if ($@)
+ {
+ $txt = eval { local $SIG{__DIE__};
+ $w->SelectionGet(-selection => $sel)
+ };
+ if ($@)
+ {
+ die "could not find default selection";
+ }
+ }
+ $txt;
+ }
+ : sub
+ {
+ my $w = shift;
+ my $sel = @_ ? shift : "PRIMARY";
+ my $txt = eval { local $SIG{__DIE__};
+ $w->SelectionGet(-selection => $sel)
+ };
+ if ($@)
+ {
+ die "could not find default selection";
+ }
+ $txt;
+ }
+ );
+
+1;
+__END__
+
+sub bindDump {
+
+ # Dump lots of good binding information. This pretty-print subroutine
+ # is, essentially, the following code in disguise:
+ #
+ # print "Binding information for $w\n";
+ # foreach my $tag ($w->bindtags) {
+ # printf "\n Binding tag '$tag' has these bindings:\n";
+ # foreach my $binding ($w->bind($tag)) {
+ # printf " $binding\n";
+ # }
+ # }
+
+ my ($w) = @_;
+
+ my (@bindtags) = $w->bindtags;
+ my $digits = length( scalar @bindtags );
+ my ($spc1, $spc2) = ($digits + 33, $digits + 35);
+ my $format1 = "%${digits}d.";
+ my $format2 = ' ' x ($digits + 2);
+ my $n = 0;
+
+ my @out;
+ push @out, sprintf( "\n## Binding information for '%s', %s ##", $w->PathName, $w );
+
+ foreach my $tag (@bindtags) {
+ my (@bindings) = $w->bind($tag);
+ $n++; # count this bindtag
+
+ if ($#bindings == -1) {
+ push @out, sprintf( "\n$format1 Binding tag '$tag' has no bindings.\n", $n );
+ } else {
+ push @out, sprintf( "\n$format1 Binding tag '$tag' has these bindings:\n", $n );
+
+ foreach my $binding ( @bindings ) {
+ my $callback = $w->bind($tag, $binding);
+ push @out, sprintf( "$format2%27s : %-40s\n", $binding, $callback );
+
+ if ($callback =~ /SCALAR/) {
+ if (ref $$callback) {
+ push @out, sprintf( "%s %s\n", ' ' x $spc1, $$callback );
+ } else {
+ push @out, sprintf( "%s '%s'\n", ' ' x $spc1, $$callback );
+ }
+ } elsif ($callback =~ /ARRAY/) {
+ if (ref $callback->[0]) {
+ push @out, sprintf( "%s %s\n", ' ' x $spc1, $callback->[0], "\n" );
+ } else {
+ push @out, sprintf( "%s '%s'\n", ' ' x $spc1, $callback->[0], "\n" );
+ }
+ foreach my $arg (@$callback[1 .. $#{@$callback}]) {
+ if (ref $arg) {
+ push @out, sprintf( "%s %-40s", ' ' x $spc2, $arg );
+ } else {
+ push @out, sprintf( "%s '%s'", ' ' x $spc2, $arg );
+ }
+
+ if (ref $arg eq 'Tk::Ev') {
+ if ($arg =~ /SCALAR/) {
+ push @out, sprintf( ": '$$arg'" );
+ } else {
+ push @out, sprintf( ": '%s'", join("' '", @$arg) );
+ }
+ }
+
+ push @out, sprintf( "\n" );
+ } # forend callback arguments
+ } # ifend callback
+
+ } # forend all bindings for one tag
+
+ } # ifend have bindings
+
+ } # forend all tags
+ push @out, sprintf( "\n" );
+ return @out;
+
+} # end bindDump
+
+
+sub ASkludge
+{
+ my ($hash,$sense) = @_;
+ foreach my $key (%$hash)
+ {
+ if ($key =~ /-.*variable/ && ref($hash->{$key}) eq 'SCALAR')
+ {
+ if ($sense)
+ {
+ my $val = ${$hash->{$key}};
+ require Tie::Scalar;
+ tie ${$hash->{$key}},'Tie::StdScalar';
+ ${$hash->{$key}} = $val;
+ }
+ else
+ {
+ untie ${$hash->{$key}};
+ }
+ }
+ }
+}
+
+
+
+# clipboardKeysyms --
+# This procedure is invoked to identify the keys that correspond to
+# the "copy", "cut", and "paste" functions for the clipboard.
+#
+# Arguments:
+# copy - Name of the key (keysym name plus modifiers, if any,
+# such as "Meta-y") used for the copy operation.
+# cut - Name of the key used for the cut operation.
+# paste - Name of the key used for the paste operation.
+#
+# This method is obsolete use clipboardOperations and abstract
+# event types instead. See Clipboard.pm and Mainwindow.pm
+
+sub clipboardKeysyms
+{
+ my @class = ();
+ my $mw = shift;
+ if (ref $mw)
+ {
+ $mw = $mw->DelegateFor('bind');
+ }
+ else
+ {
+ push(@class,$mw);
+ $mw = shift;
+ }
+ if (@_)
+ {
+ my $copy = shift;
+ $mw->Tk::bind(@class,"<$copy>",'clipboardCopy') if (defined $copy);
+ }
+ if (@_)
+ {
+ my $cut = shift;
+ $mw->Tk::bind(@class,"<$cut>",'clipboardCut') if (defined $cut);
+ }
+ if (@_)
+ {
+ my $paste = shift;
+ $mw->Tk::bind(@class,"<$paste>",'clipboardPaste') if (defined $paste);
+ }
+}
+
+sub pathname
+{
+ my ($w,$id) = @_;
+ my $x = $w->winfo('pathname',-displayof => oct($id));
+ return $x->PathName;
+}
diff --git a/Master/tlpkg/installer/perllib/Tk/Wm.pm b/Master/tlpkg/installer/perllib/Tk/Wm.pm
new file mode 100644
index 00000000000..ffbe4877857
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/Tk/Wm.pm
@@ -0,0 +1,174 @@
+# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+package Tk::Wm;
+use AutoLoader;
+
+require Tk::Widget;
+*AUTOLOAD = \&Tk::Widget::AUTOLOAD;
+
+use strict qw(vars);
+
+# There are issues with this stuff now we have Tix's wm release/capture
+# as toplevel-ness is now dynamic.
+
+
+use vars qw($VERSION);
+$VERSION = sprintf '4.%03d', q$Revision: #14 $ =~ /\D(\d+)\s*$/;
+
+use Tk::Submethods;
+
+*{Tk::Wm::wmGrid} = sub { shift->wm("grid", @_) };
+*{Tk::Wm::wmTracing} = sub { shift->wm("tracing", @_) };
+
+Direct Tk::Submethods ('wm' => [qw(aspect attributes client colormapwindows command
+ deiconify focusmodel frame geometry group
+ iconbitmap iconify iconimage iconmask iconname
+ iconwindow maxsize minsize overrideredirect positionfrom
+ protocol resizable sizefrom state title transient
+ withdraw wrapper)]);
+
+sub SetBindtags
+{
+ my ($obj) = @_;
+ $obj->bindtags([ref($obj),$obj,'all']);
+}
+
+sub Populate
+{
+ my ($cw,$args) = @_;
+ $cw->ConfigSpecs('-overanchor' => ['PASSIVE',undef,undef,undef],
+ '-popanchor' => ['PASSIVE',undef,undef,undef],
+ '-popover' => ['PASSIVE',undef,undef,undef]
+ );
+}
+
+sub MoveResizeWindow
+{
+ my ($w,$x,$y,$width,$height) = @_;
+ $w->withdraw;
+ $w->geometry($width.'x'.$height);
+ $w->MoveToplevelWindow($x,$y);
+ $w->deiconify;
+}
+
+sub WmDeleteWindow
+{
+ my ($w) = @_;
+ my $cb = $w->protocol('WM_DELETE_WINDOW');
+ if (defined $cb)
+ {
+ $cb->Call;
+ }
+ else
+ {
+ $w->destroy;
+ }
+}
+
+
+1;
+
+__END__
+
+
+sub Post
+{
+ my ($w,$X,$Y) = @_;
+ $X = int($X);
+ $Y = int($Y);
+ $w->positionfrom('user');
+ $w->geometry("+$X+$Y");
+ # $w->MoveToplevelWindow($X,$Y);
+ $w->deiconify;
+ $w->raise;
+}
+
+sub AnchorAdjust
+{
+ my ($anchor,$X,$Y,$w,$h) = @_;
+ $anchor = 'c' unless (defined $anchor);
+ $Y += ($anchor =~ /s/) ? $h : ($anchor =~ /n/) ? 0 : $h/2;
+ $X += ($anchor =~ /e/) ? $w : ($anchor =~ /w/) ? 0 : $w/2;
+ return ($X,$Y);
+}
+
+sub Popup
+{
+ my $w = shift;
+ $w->configure(@_) if @_;
+ $w->idletasks;
+ my ($mw,$mh) = ($w->reqwidth,$w->reqheight);
+ my ($rx,$ry,$rw,$rh) = (0,0,0,0);
+ my $base = $w->cget('-popover');
+ my $outside = 0;
+ if (defined $base)
+ {
+ if ($base eq 'cursor')
+ {
+ ($rx,$ry) = $w->pointerxy;
+ }
+ else
+ {
+ $rx = $base->rootx;
+ $ry = $base->rooty;
+ $rw = $base->Width;
+ $rh = $base->Height;
+ }
+ }
+ else
+ {
+ my $sc = ($w->parent) ? $w->parent->toplevel : $w;
+ $rx = -$sc->vrootx;
+ $ry = -$sc->vrooty;
+ $rw = $w->screenwidth;
+ $rh = $w->screenheight;
+ }
+ my ($X,$Y) = AnchorAdjust($w->cget('-overanchor'),$rx,$ry,$rw,$rh);
+ ($X,$Y) = AnchorAdjust($w->cget('-popanchor'),$X,$Y,-$mw,-$mh);
+ # adjust to not cross screen borders
+ if ($X < 0) { $X = 0 }
+ if ($Y < 0) { $Y = 0 }
+ if ($mw > $w->screenwidth) { $X = 0 }
+ if ($mh > $w->screenheight) { $Y = 0 }
+ $w->Post($X,$Y);
+ $w->waitVisibility;
+}
+
+sub FullScreen
+{
+ my $w = shift;
+ my $over = (@_) ? shift : 0;
+ my $width = $w->screenwidth;
+ my $height = $w->screenheight;
+ $w->GeometryRequest($width,$height);
+ $w->overrideredirect($over & 1);
+ $w->Post(0,0);
+ $w->update;
+ if ($over & 2)
+ {
+ my $x = $w->rootx;
+ my $y = $w->rooty;
+ $width -= 2*$x;
+ $height -= $x + $y;
+ $w->GeometryRequest($width,$height);
+ $w->update;
+ }
+}
+
+sub iconposition
+{
+ my $w = shift;
+ if (@_ == 1)
+ {
+ return $w->wm('iconposition',$1,$2) if $_[0] =~ /^(\d+),(\d+)$/;
+ if ($_[0] =~ /^([+-])(\d+)([+-])(\d+)$/)
+ {
+ my $x = ($1 eq '-') ? $w->screenwidth-$2 : $2;
+ my $y = ($3 eq '-') ? $w->screenheight-$4 : $4;
+ return $w->wm('iconposition',$x,$y);
+ }
+ }
+ $w->wm('iconposition',@_);
+}
+
diff --git a/Master/tlpkg/installer/perllib/Win32/API.pm b/Master/tlpkg/installer/perllib/Win32/API.pm
new file mode 100644
index 00000000000..e1bac5cda48
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/Win32/API.pm
@@ -0,0 +1,745 @@
+package Win32::API;
+
+# See the bottom of this file for the POD documentation. Search for the
+# string '=head'.
+
+#######################################################################
+#
+# Win32::API - Perl Win32 API Import Facility
+#
+# Version: 0.47
+# Date: 12 Nov 2007
+# Author: Aldo Calpini <dada@perl.it>
+# Maintainer: Cosimo Streppone <cosimo@cpan.org>
+#
+# Changes for gcc/cygwin: Daniel Risacher <magnus@alum.mit.edu>
+# ported from 0.41 based on Daniel's patch by Reini Urban <rurban@x-ray.at>
+#
+# $Id: API.pm,v 1.0 2001/10/30 13:57:31 dada Exp $
+#
+#######################################################################
+
+require Exporter; # to export the constants to the main:: space
+require DynaLoader; # to dynuhlode the module.
+@ISA = qw( Exporter DynaLoader );
+
+use vars qw( $DEBUG );
+$DEBUG = 0;
+
+sub DEBUG {
+ if ($Win32::API::DEBUG) {
+ printf @_ if @_ or return 1;
+ } else {
+ return 0;
+ }
+}
+
+use Win32::API::Type;
+use Win32::API::Struct;
+BEGIN {
+ if ($^O eq 'cygwin') {
+ require File::Basename;
+ }
+}
+
+#######################################################################
+# STATIC OBJECT PROPERTIES
+#
+$VERSION = '0.47';
+
+#### some package-global hash to
+#### keep track of the imported
+#### libraries and procedures
+my %Libraries = ();
+my %Procedures = ();
+
+
+#######################################################################
+# dynamically load in the API extension module.
+#
+bootstrap Win32::API;
+
+#######################################################################
+# PUBLIC METHODS
+#
+sub new {
+ my($class, $dll, $proc, $in, $out) = @_;
+ my $hdll;
+ my $self = {};
+
+ if ($^O eq 'cygwin' and $dll ne File::Basename::basename($dll)) {
+ # need to convert $dll to win32 path
+ # isn't there an API for this?
+ my $newdll = `cygpath -w "$dll"`;
+ chomp $newdll;
+ DEBUG "(PM)new: converted '$dll' to\n '$newdll'\n";
+ $dll = $newdll;
+ }
+
+ #### avoid loading a library more than once
+ if(exists($Libraries{$dll})) {
+ DEBUG "Win32::API::new: Library '$dll' already loaded, handle=$Libraries{$dll}\n";
+ $hdll = $Libraries{$dll};
+ } else {
+ DEBUG "Win32::API::new: Loading library '$dll'\n";
+ $hdll = Win32::API::LoadLibrary($dll);
+# $Libraries{$dll} = $hdll;
+ }
+
+ #### if the dll can't be loaded, set $! to Win32's GetLastError()
+ if(!$hdll) {
+ $! = Win32::GetLastError();
+ DEBUG "FAILED Loading library '$dll': $!\n";
+ delete $Libraries{$dll};
+ return undef;
+ }
+
+ #### determine if we have a prototype or not
+ if( (not defined $in) and (not defined $out) ) {
+ ($proc, $self->{in}, $self->{intypes}, $self->{out}) = parse_prototype( $proc );
+ return undef unless $proc;
+ $self->{proto} = 1;
+ } else {
+ $self->{in} = [];
+ if(ref($in) eq 'ARRAY') {
+ foreach (@$in) {
+ push(@{ $self->{in} }, type_to_num($_));
+ }
+ } else {
+ my @in = split '', $in;
+ foreach (@in) {
+ push(@{ $self->{in} }, type_to_num($_));
+ }
+ }
+ $self->{out} = type_to_num($out);
+ }
+
+ #### first try to import the function of given name...
+ my $hproc = Win32::API::GetProcAddress($hdll, $proc);
+
+ #### ...then try appending either A or W (for ASCII or Unicode)
+ if(!$hproc) {
+ my $tproc = $proc;
+ $tproc .= (IsUnicode() ? "W" : "A");
+ # print "Win32::API::new: procedure not found, trying '$tproc'...\n";
+ $hproc = Win32::API::GetProcAddress($hdll, $tproc);
+ }
+
+ #### ...if all that fails, set $! accordingly
+ if(!$hproc) {
+ $! = Win32::GetLastError();
+ DEBUG "FAILED GetProcAddress for Proc '$proc': $!\n";
+ return undef;
+ }
+ DEBUG "GetProcAddress('$proc') = '$hproc'\n";
+
+ #### ok, let's stuff the object
+ $self->{procname} = $proc;
+ $self->{dll} = $hdll;
+ $self->{dllname} = $dll;
+ $self->{proc} = $hproc;
+
+ #### keep track of the imported function
+ $Libraries{$dll} = $hdll;
+ $Procedures{$dll}++;
+
+ DEBUG "Object blessed!\n";
+
+ #### cast the spell
+ bless($self, $class);
+ return $self;
+}
+
+sub Import {
+ my($class, $dll, $proc, $in, $out) = @_;
+ $Imported{"$dll:$proc"} = Win32::API->new($dll, $proc, $in, $out) or return 0;
+ my $P = (caller)[0];
+ eval qq(
+ sub ${P}::$Imported{"$dll:$proc"}->{procname} { \$Win32::API::Imported{"$dll:$proc"}->Call(\@_); }
+ );
+ return $@ ? 0 : 1;
+}
+
+
+#######################################################################
+# PRIVATE METHODS
+#
+sub DESTROY {
+ my($self) = @_;
+
+ #### decrease this library's procedures reference count
+ $Procedures{$self->{dllname}}--;
+
+ #### once it reaches 0, free it
+ if($Procedures{$self->{dllname}} == 0) {
+ DEBUG "Win32::API::DESTROY: Freeing library '$self->{dllname}'\n";
+ Win32::API::FreeLibrary($Libraries{$self->{dllname}});
+ delete($Libraries{$self->{dllname}});
+ }
+}
+
+sub type_to_num {
+ my $type = shift;
+ my $out = shift;
+ my $num;
+
+ if( $type eq 'N'
+ or $type eq 'n'
+ or $type eq 'l'
+ or $type eq 'L'
+ ) {
+ $num = 1;
+ } elsif($type eq 'P'
+ or $type eq 'p'
+ ) {
+ $num = 2;
+ } elsif($type eq 'I'
+ or $type eq 'i'
+ ) {
+ $num = 3;
+ } elsif($type eq 'f'
+ or $type eq 'F'
+ ) {
+ $num = 4;
+ } elsif($type eq 'D'
+ or $type eq 'd'
+ ) {
+ $num = 5;
+ } elsif($type eq 'c'
+ or $type eq 'C'
+ ) {
+ $num = 6;
+ } else {
+ $num = 0;
+ }
+ unless(defined $out) {
+ if( $type eq 's'
+ or $type eq 'S'
+ ) {
+ $num = 51;
+ } elsif($type eq 'b'
+ or $type eq 'B'
+ ) {
+ $num = 22;
+ } elsif($type eq 'k'
+ or $type eq 'K'
+ ) {
+ $num = 101;
+ }
+ }
+ return $num;
+}
+
+sub parse_prototype {
+ my($proto) = @_;
+
+ my @in_params = ();
+ my @in_types = ();
+ if($proto =~ /^\s*(\S+)\s+(\S+)\s*\(([^\)]*)\)/) {
+ my $ret = $1;
+ my $proc = $2;
+ my $params = $3;
+
+ $params =~ s/^\s+//;
+ $params =~ s/\s+$//;
+
+ DEBUG "(PM)parse_prototype: got PROC '%s'\n", $proc;
+ DEBUG "(PM)parse_prototype: got PARAMS '%s'\n", $params;
+
+ foreach my $param (split(/\s*,\s*/, $params)) {
+ my($type, $name);
+ if($param =~ /(\S+)\s+(\S+)/) {
+ ($type, $name) = ($1, $2);
+ }
+
+ if(Win32::API::Type::is_known($type)) {
+ if(Win32::API::Type::is_pointer($type)) {
+ DEBUG "(PM)parse_prototype: IN='%s' PACKING='%s' API_TYPE=%d\n",
+ $type,
+ Win32::API::Type->packing( $type ),
+ type_to_num('P');
+ push(@in_params, type_to_num('P'));
+ } else {
+ DEBUG "(PM)parse_prototype: IN='%s' PACKING='%s' API_TYPE=%d\n",
+ $type,
+ Win32::API::Type->packing( $type ),
+ type_to_num( Win32::API::Type->packing( $type ) );
+ push(@in_params, type_to_num( Win32::API::Type->packing( $type ) ));
+ }
+ } elsif( Win32::API::Struct::is_known( $type ) ) {
+ DEBUG "(PM)parse_prototype: IN='%s' PACKING='%s' API_TYPE=%d\n",
+ $type, 'S', type_to_num('S');
+ push(@in_params, type_to_num('S'));
+ } else {
+ warn "Win32::API::parse_prototype: WARNING unknown parameter type '$type'";
+ push(@in_params, type_to_num('I'));
+ }
+ push(@in_types, $type);
+
+ }
+ DEBUG "parse_prototype: IN=[ @in_params ]\n";
+
+
+
+ if(Win32::API::Type::is_known($ret)) {
+ if(Win32::API::Type::is_pointer($ret)) {
+ DEBUG "parse_prototype: OUT='%s' PACKING='%s' API_TYPE=%d\n",
+ $ret,
+ Win32::API::Type->packing( $ret ),
+ type_to_num('P');
+ return ( $proc, \@in_params, \@in_types, type_to_num('P') );
+ } else {
+ DEBUG "parse_prototype: OUT='%s' PACKING='%s' API_TYPE=%d\n",
+ $ret,
+ Win32::API::Type->packing( $ret ),
+ type_to_num( Win32::API::Type->packing( $ret ) );
+ return ( $proc, \@in_params, \@in_types, type_to_num(Win32::API::Type->packing($ret)) );
+ }
+ } else {
+ warn "Win32::API::parse_prototype: WARNING unknown output parameter type '$ret'";
+ return ( $proc, \@in_params, \@in_types, type_to_num('I') );
+ }
+
+ } else {
+ warn "Win32::API::parse_prototype: bad prototype '$proto'";
+ return undef;
+ }
+}
+
+1;
+
+__END__
+
+#######################################################################
+# DOCUMENTATION
+#
+
+=head1 NAME
+
+Win32::API - Perl Win32 API Import Facility
+
+=head1 SYNOPSIS
+
+ #### Method 1: with prototype
+
+ use Win32::API;
+ $function = Win32::API->new(
+ 'mydll, 'int sum_integers(int a, int b)',
+ );
+ $return = $function->Call(3, 2);
+
+ #### Method 2: with parameter list
+
+ use Win32::API;
+ $function = Win32::API->new(
+ 'mydll', 'sum_integers', 'II', 'I',
+ );
+ $return = $function->Call(3, 2);
+
+ #### Method 3: with Import
+
+ use Win32::API;
+ Win32::API->Import(
+ 'mydll', 'int sum_integers(int a, int b)',
+ );
+ $return = sum_integers(3, 2);
+
+
+=for LATER-UNIMPLEMENTED
+ #### or
+ use Win32::API mydll => 'int sum_integers(int a, int b)';
+ $return = sum_integers(3, 2);
+
+
+=head1 ABSTRACT
+
+With this module you can import and call arbitrary functions
+from Win32's Dynamic Link Libraries (DLL), without having
+to write an XS extension. Note, however, that this module
+can't do anything (parameters input and output is limited
+to simpler cases), and anyway a regular XS extension is
+always safer and faster.
+
+The current version of Win32::API is available at my website:
+
+ http://dada.perl.it/
+
+It's also available on your nearest CPAN mirror (but allow a few days
+for worldwide spreading of the latest version) reachable at:
+
+ http://www.perl.com/CPAN/authors/Aldo_Calpini/
+
+A short example of how you can use this module (it just gets the PID of
+the current process, eg. same as Perl's internal C<$$>):
+
+ use Win32::API;
+ Win32::API->Import("kernel32", "int GetCurrentProcessId()");
+ $PID = GetCurrentProcessId();
+
+The possibilities are nearly infinite (but not all are good :-).
+Enjoy it.
+
+
+=head1 CREDITS
+
+All the credits go to Andrea Frosini
+for the neat assembler trick that makes this thing work.
+I've also used some work by Dave Roth for the prototyping stuff.
+A big thank you also to Gurusamy Sarathy for his
+unvaluable help in XS development, and to all the Perl community for
+being what it is.
+
+
+=head1 DESCRIPTION
+
+To use this module put the following line at the beginning of your script:
+
+ use Win32::API;
+
+You can now use the C<new()> function of the Win32::API module to create a
+new Win32::API object (see L<IMPORTING A FUNCTION>) and then invoke the
+C<Call()> method on this object to perform a call to the imported API
+(see L<CALLING AN IMPORTED FUNCTION>).
+
+Starting from version 0.40, you can also avoid creating a Win32::API object
+and instead automatically define a Perl sub with the same name of the API
+function you're importing. The details of the API definitions are the same,
+just the call is different:
+
+ my $GetCurrentProcessId = Win32::API->new(
+ "kernel32", "int GetCurrentProcessId()"
+ );
+ my $PID = $GetCurrentProcessId->Call();
+
+ #### vs.
+
+ Win32::API->Import("kernel32", "int GetCurrentProcessId()");
+ $PID = GetCurrentProcessId();
+
+Note that C<Import> returns 1 on success and 0 on failure (in which case you
+can check the content of C<$^E>).
+
+=head2 IMPORTING A FUNCTION
+
+You can import a function from a 32 bit Dynamic Link Library (DLL) file
+with the C<new()> function. This will create a Perl object that contains the
+reference to that function, which you can later C<Call()>.
+
+What you need to know is the prototype of the function you're going to import
+(eg. the definition of the function expressed in C syntax).
+
+Starting from version 0.40, there are 2 different approaches for this step:
+(the preferred) one uses the prototype directly, while the other (now deprecated)
+one uses Win32::API's internal representation for parameters.
+
+=head2 IMPORTING A FUNCTION BY PROTOTYPE
+
+You need to pass 2 parameters:
+
+=over 4
+
+=item 1.
+The name of the library from which you want to import the function.
+
+=item 2.
+The C prototype of the function.
+
+=back
+
+See L<Win32::API::Type> for a list of the known parameter types and
+L<Win32::API::Struct> for information on how to define a structure.
+
+=head2 IMPORTING A FUNCTION WITH A PARAMETER LIST
+
+You need to pass 4 parameters:
+
+=over 4
+
+=item 1.
+The name of the library from which you want to import the function.
+
+=item 2.
+The name of the function (as exported by the library).
+
+=item 3.
+The number and types of the arguments the function expects as input.
+
+=item 4.
+The type of the value returned by the function.
+
+=back
+
+To better explain their meaning, let's suppose that we
+want to import and call the Win32 API C<GetTempPath()>.
+This function is defined in C as:
+
+ DWORD WINAPI GetTempPathA( DWORD nBufferLength, LPSTR lpBuffer );
+
+This is documented in the B<Win32 SDK Reference>; you can look
+for it on the Microsoft's WWW site, or in your C compiler's
+documentation, if you own one.
+
+=over 4
+
+=item B<1.>
+
+The first parameter is the name of the library file that
+exports this function; our function resides in the F<KERNEL32.DLL>
+system file.
+When specifying this name as parameter, the F<.DLL> extension
+is implicit, and if no path is given, the file is searched through
+a couple of directories, including:
+
+=over 4
+
+=item 1. The directory from which the application loaded.
+
+=item 2. The current directory.
+
+=item 3. The Windows system directory (eg. c:\windows\system or system32).
+
+=item 4. The Windows directory (eg. c:\windows).
+
+=item 5. The directories that are listed in the PATH environment variable.
+
+=back
+
+So, you don't have to write F<C:\windows\system\kernel32.dll>;
+only F<kernel32> is enough:
+
+ $GetTempPath = new Win32::API('kernel32', ...
+
+=item B<2.>
+
+Now for the second parameter: the name of the function.
+It must be written exactly as it is exported
+by the library (case is significant here).
+If you are using Windows 95 or NT 4.0, you can use the B<Quick View>
+command on the DLL file to see the function it exports.
+Remember that you can only import functions from 32 bit DLLs:
+in Quick View, the file's characteristics should report
+somewhere "32 bit word machine"; as a rule of thumb,
+when you see that all the exported functions are in upper case,
+the DLL is a 16 bit one and you can't use it.
+If their capitalization looks correct, then it's probably a 32 bit
+DLL.
+
+Also note that many Win32 APIs are exported twice, with the addition of
+a final B<A> or B<W> to their name, for - respectively - the ASCII
+and the Unicode version.
+When a function name is not found, Win32::API will actually append
+an B<A> to the name and try again; if the extension is built on a
+Unicode system, then it will try with the B<W> instead.
+So our function name will be:
+
+ $GetTempPath = new Win32::API('kernel32', 'GetTempPath', ...
+
+In our case C<GetTempPath> is really loaded as C<GetTempPathA>.
+
+=item B<3.>
+
+The third parameter, the input parameter list, specifies how many
+arguments the function wants, and their types. It can be passed as
+a single string, in which each character represents one parameter,
+or as a list reference. The following forms are valid:
+
+ "abcd"
+ [a, b, c, d]
+ \@LIST
+
+But those are not:
+
+ (a, b, c, d)
+ @LIST
+
+The number of characters, or elements in the list, specifies the number
+of parameters, and each character or element specifies the type of an
+argument; allowed types are:
+
+=over 4
+
+=item C<I>:
+value is an integer (int)
+
+=item C<N>:
+value is a number (long)
+
+=item C<F>:
+value is a floating point number (float)
+
+=item C<D>:
+value is a double precision number (double)
+
+=item C<C>:
+value is a char (char)
+
+=item C<P>:
+value is a pointer (to a string, structure, etc...)
+
+=item C<S>:
+value is a Win32::API::Struct object (see below)
+
+=item C<K>:
+value is a Win32::API::Callback object (see L<Win32::API::Callback>)
+
+=back
+
+Our function needs two parameters: a number (C<DWORD>) and a pointer to a
+string (C<LPSTR>):
+
+ $GetTempPath = new Win32::API('kernel32', 'GetTempPath', 'NP', ...
+
+=item B<4.>
+
+The fourth and final parameter is the type of the value returned by the
+function. It can be one of the types seen above, plus another type named B<V>
+(for C<void>), used for functions that do not return a value.
+In our example the value returned by GetTempPath() is a C<DWORD>, so
+our return type will be B<N>:
+
+ $GetTempPath = new Win32::API('kernel32', 'GetTempPath', 'NP', 'N');
+
+Now the line is complete, and the GetTempPath() API is ready to be used
+in Perl. Before calling it, you should test that $GetTempPath is
+C<defined>, otherwise either the function or the library could not be
+loaded; in this case, C<$!> will be set to the error message reported
+by Windows.
+Our definition, with error checking added, should then look like this:
+
+ $GetTempPath = new Win32::API('kernel32', 'GetTempPath', 'NP', 'N');
+ if(not defined $GetTempPath) {
+ die "Can't import API GetTempPath: $!\n";
+ }
+
+=back
+
+=head2 CALLING AN IMPORTED FUNCTION
+
+To effectively make a call to an imported function you must use the
+Call() method on the Win32::API object you created.
+Continuing with the example from the previous paragraph,
+the GetTempPath() API can be called using the method:
+
+ $GetTempPath->Call(...
+
+Of course, parameters have to be passed as defined in the import phase.
+In particular, if the number of parameters does not match (in the example,
+if GetTempPath() is called with more or less than two parameters),
+Perl will C<croak> an error message and C<die>.
+
+The two parameters needed here are the length of the buffer
+that will hold the returned temporary path, and a pointer to the
+buffer itself.
+For numerical parameters, you can use either a constant expression
+or a variable, while B<for pointers you must use a variable name> (no
+Perl references, just a plain variable name).
+Also note that B<memory must be allocated before calling the function>,
+just like in C.
+For example, to pass a buffer of 80 characters to GetTempPath(),
+it must be initialized before with:
+
+ $lpBuffer = " " x 80;
+
+This allocates a string of 80 characters. If you don't do so, you'll
+probably get C<Runtime exception> errors, and generally nothing will
+work. The call should therefore include:
+
+ $lpBuffer = " " x 80;
+ $GetTempPath->Call(80, $lpBuffer);
+
+And the result will be stored in the $lpBuffer variable.
+Note that you don't need to pass a reference to the variable
+(eg. you B<don't need> C<\$lpBuffer>), even if its value will be set
+by the function.
+
+A little problem here is that Perl does not trim the variable,
+so $lpBuffer will still contain 80 characters in return; the exceeding
+characters will be spaces, because we said C<" " x 80>.
+
+In this case we're lucky enough, because the value returned by
+the GetTempPath() function is the length of the string, so to get
+the actual temporary path we can write:
+
+ $lpBuffer = " " x 80;
+ $return = $GetTempPath->Call(80, $lpBuffer);
+ $TempPath = substr($lpBuffer, 0, $return);
+
+If you don't know the length of the string, you can usually
+cut it at the C<\0> (ASCII zero) character, which is the string
+delimiter in C:
+
+ $TempPath = ((split(/\0/, $lpBuffer))[0];
+ # or
+ $lpBuffer =~ s/\0.*$//;
+
+=head2 USING STRUCTURES
+
+Starting from version 0.40, Win32::API comes with a support package
+named Win32::API::Struct. The package is loaded automatically with
+Win32::API, so you don't need to use it explicitly.
+
+With this module you can conveniently define structures and use
+them as parameters to Win32::API functions. A short example follows:
+
+
+ # the 'POINT' structure is defined in C as:
+ # typedef struct {
+ # LONG x;
+ # LONG y;
+ # } POINT;
+
+
+ #### define the structure
+ Win32::API::Struct->typedef( POINT => qw{
+ LONG x;
+ LONG y;
+ });
+
+ #### import an API that uses this structure
+ Win32::API->Import('user32', 'BOOL GetCursorPos(LPPOINT lpPoint)');
+
+ #### create a 'POINT' object
+ my $pt = Win32::API::Struct->new('POINT');
+
+ #### call the function passing our structure object
+ GetCursorPos($pt);
+
+ #### and now, access its members
+ print "The cursor is at: $pt->{x}, $pt->{y}\n";
+
+Note that this works only when the function wants a
+B<pointer to a structure>: as you can see, our structure is named
+'POINT', but the API used 'LPPOINT'. 'LP' is automatically added at
+the beginning of the structure name when feeding it to a Win32::API
+call.
+
+For more information, see also L<Win32::API::Struct>.
+
+If you don't want (or can't) use the Win32::API::Struct facility,
+you can still use the low-level approach to use structures:
+
+
+=over 4
+
+=item 1.
+you have to pack() the required elements in a variable:
+
+ $lpPoint = pack('LL', 0, 0); # store two LONGs
+
+=item 2. to access the values stored in a structure, unpack() it as required:
+
+ ($x, $y) = unpack('LL', $lpPoint); # get the actual values
+
+=back
+
+The rest is left as an exercise to the reader...
+
+=head1 AUTHOR
+
+Aldo Calpini ( I<dada@perl.it> ).
+
+=head1 MAINTAINER
+
+Cosimo Streppone ( I<cosimo@cpan.org> )
+
+=cut
diff --git a/Master/tlpkg/installer/perllib/Win32/API.pm.orig b/Master/tlpkg/installer/perllib/Win32/API.pm.orig
new file mode 100644
index 00000000000..9e4accd8bf6
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/Win32/API.pm.orig
@@ -0,0 +1,741 @@
+package Win32::API;
+
+# See the bottom of this file for the POD documentation. Search for the
+# string '=head'.
+
+#######################################################################
+#
+# Win32::API - Perl Win32 API Import Facility
+#
+# Version: 0.47
+# Date: 12 Nov 2007
+# Author: Aldo Calpini <dada@perl.it>
+# Maintainer: Cosimo Streppone <cosimo@cpan.org>
+#
+# Changes for gcc/cygwin: Daniel Risacher <magnus@alum.mit.edu>
+# ported from 0.41 based on Daniel's patch by Reini Urban <rurban@x-ray.at>
+#
+# $Id: API.pm,v 1.0 2001/10/30 13:57:31 dada Exp $
+#
+#######################################################################
+
+require Exporter; # to export the constants to the main:: space
+require DynaLoader; # to dynuhlode the module.
+@ISA = qw( Exporter DynaLoader );
+
+use vars qw( $DEBUG );
+$DEBUG = 0;
+
+sub DEBUG {
+ if ($Win32::API::DEBUG) {
+ printf @_ if @_ or return 1;
+ } else {
+ return 0;
+ }
+}
+
+use Win32::API::Type;
+use Win32::API::Struct;
+use File::Basename ();
+
+#######################################################################
+# STATIC OBJECT PROPERTIES
+#
+$VERSION = '0.47';
+
+#### some package-global hash to
+#### keep track of the imported
+#### libraries and procedures
+my %Libraries = ();
+my %Procedures = ();
+
+
+#######################################################################
+# dynamically load in the API extension module.
+#
+bootstrap Win32::API;
+
+#######################################################################
+# PUBLIC METHODS
+#
+sub new {
+ my($class, $dll, $proc, $in, $out) = @_;
+ my $hdll;
+ my $self = {};
+
+ if ($^O eq 'cygwin' and $dll ne File::Basename::basename($dll)) {
+ # need to convert $dll to win32 path
+ # isn't there an API for this?
+ my $newdll = `cygpath -w "$dll"`;
+ chomp $newdll;
+ DEBUG "(PM)new: converted '$dll' to\n '$newdll'\n";
+ $dll = $newdll;
+ }
+
+ #### avoid loading a library more than once
+ if(exists($Libraries{$dll})) {
+ DEBUG "Win32::API::new: Library '$dll' already loaded, handle=$Libraries{$dll}\n";
+ $hdll = $Libraries{$dll};
+ } else {
+ DEBUG "Win32::API::new: Loading library '$dll'\n";
+ $hdll = Win32::API::LoadLibrary($dll);
+# $Libraries{$dll} = $hdll;
+ }
+
+ #### if the dll can't be loaded, set $! to Win32's GetLastError()
+ if(!$hdll) {
+ $! = Win32::GetLastError();
+ DEBUG "FAILED Loading library '$dll': $!\n";
+ delete $Libraries{$dll};
+ return undef;
+ }
+
+ #### determine if we have a prototype or not
+ if( (not defined $in) and (not defined $out) ) {
+ ($proc, $self->{in}, $self->{intypes}, $self->{out}) = parse_prototype( $proc );
+ return undef unless $proc;
+ $self->{proto} = 1;
+ } else {
+ $self->{in} = [];
+ if(ref($in) eq 'ARRAY') {
+ foreach (@$in) {
+ push(@{ $self->{in} }, type_to_num($_));
+ }
+ } else {
+ my @in = split '', $in;
+ foreach (@in) {
+ push(@{ $self->{in} }, type_to_num($_));
+ }
+ }
+ $self->{out} = type_to_num($out);
+ }
+
+ #### first try to import the function of given name...
+ my $hproc = Win32::API::GetProcAddress($hdll, $proc);
+
+ #### ...then try appending either A or W (for ASCII or Unicode)
+ if(!$hproc) {
+ my $tproc = $proc;
+ $tproc .= (IsUnicode() ? "W" : "A");
+ # print "Win32::API::new: procedure not found, trying '$tproc'...\n";
+ $hproc = Win32::API::GetProcAddress($hdll, $tproc);
+ }
+
+ #### ...if all that fails, set $! accordingly
+ if(!$hproc) {
+ $! = Win32::GetLastError();
+ DEBUG "FAILED GetProcAddress for Proc '$proc': $!\n";
+ return undef;
+ }
+ DEBUG "GetProcAddress('$proc') = '$hproc'\n";
+
+ #### ok, let's stuff the object
+ $self->{procname} = $proc;
+ $self->{dll} = $hdll;
+ $self->{dllname} = $dll;
+ $self->{proc} = $hproc;
+
+ #### keep track of the imported function
+ $Libraries{$dll} = $hdll;
+ $Procedures{$dll}++;
+
+ DEBUG "Object blessed!\n";
+
+ #### cast the spell
+ bless($self, $class);
+ return $self;
+}
+
+sub Import {
+ my($class, $dll, $proc, $in, $out) = @_;
+ $Imported{"$dll:$proc"} = Win32::API->new($dll, $proc, $in, $out) or return 0;
+ my $P = (caller)[0];
+ eval qq(
+ sub ${P}::$Imported{"$dll:$proc"}->{procname} { \$Win32::API::Imported{"$dll:$proc"}->Call(\@_); }
+ );
+ return $@ ? 0 : 1;
+}
+
+
+#######################################################################
+# PRIVATE METHODS
+#
+sub DESTROY {
+ my($self) = @_;
+
+ #### decrease this library's procedures reference count
+ $Procedures{$self->{dllname}}--;
+
+ #### once it reaches 0, free it
+ if($Procedures{$self->{dllname}} == 0) {
+ DEBUG "Win32::API::DESTROY: Freeing library '$self->{dllname}'\n";
+ Win32::API::FreeLibrary($Libraries{$self->{dllname}});
+ delete($Libraries{$self->{dllname}});
+ }
+}
+
+sub type_to_num {
+ my $type = shift;
+ my $out = shift;
+ my $num;
+
+ if( $type eq 'N'
+ or $type eq 'n'
+ or $type eq 'l'
+ or $type eq 'L'
+ ) {
+ $num = 1;
+ } elsif($type eq 'P'
+ or $type eq 'p'
+ ) {
+ $num = 2;
+ } elsif($type eq 'I'
+ or $type eq 'i'
+ ) {
+ $num = 3;
+ } elsif($type eq 'f'
+ or $type eq 'F'
+ ) {
+ $num = 4;
+ } elsif($type eq 'D'
+ or $type eq 'd'
+ ) {
+ $num = 5;
+ } elsif($type eq 'c'
+ or $type eq 'C'
+ ) {
+ $num = 6;
+ } else {
+ $num = 0;
+ }
+ unless(defined $out) {
+ if( $type eq 's'
+ or $type eq 'S'
+ ) {
+ $num = 51;
+ } elsif($type eq 'b'
+ or $type eq 'B'
+ ) {
+ $num = 22;
+ } elsif($type eq 'k'
+ or $type eq 'K'
+ ) {
+ $num = 101;
+ }
+ }
+ return $num;
+}
+
+sub parse_prototype {
+ my($proto) = @_;
+
+ my @in_params = ();
+ my @in_types = ();
+ if($proto =~ /^\s*(\S+)\s+(\S+)\s*\(([^\)]*)\)/) {
+ my $ret = $1;
+ my $proc = $2;
+ my $params = $3;
+
+ $params =~ s/^\s+//;
+ $params =~ s/\s+$//;
+
+ DEBUG "(PM)parse_prototype: got PROC '%s'\n", $proc;
+ DEBUG "(PM)parse_prototype: got PARAMS '%s'\n", $params;
+
+ foreach my $param (split(/\s*,\s*/, $params)) {
+ my($type, $name);
+ if($param =~ /(\S+)\s+(\S+)/) {
+ ($type, $name) = ($1, $2);
+ }
+
+ if(Win32::API::Type::is_known($type)) {
+ if(Win32::API::Type::is_pointer($type)) {
+ DEBUG "(PM)parse_prototype: IN='%s' PACKING='%s' API_TYPE=%d\n",
+ $type,
+ Win32::API::Type->packing( $type ),
+ type_to_num('P');
+ push(@in_params, type_to_num('P'));
+ } else {
+ DEBUG "(PM)parse_prototype: IN='%s' PACKING='%s' API_TYPE=%d\n",
+ $type,
+ Win32::API::Type->packing( $type ),
+ type_to_num( Win32::API::Type->packing( $type ) );
+ push(@in_params, type_to_num( Win32::API::Type->packing( $type ) ));
+ }
+ } elsif( Win32::API::Struct::is_known( $type ) ) {
+ DEBUG "(PM)parse_prototype: IN='%s' PACKING='%s' API_TYPE=%d\n",
+ $type, 'S', type_to_num('S');
+ push(@in_params, type_to_num('S'));
+ } else {
+ warn "Win32::API::parse_prototype: WARNING unknown parameter type '$type'";
+ push(@in_params, type_to_num('I'));
+ }
+ push(@in_types, $type);
+
+ }
+ DEBUG "parse_prototype: IN=[ @in_params ]\n";
+
+
+
+ if(Win32::API::Type::is_known($ret)) {
+ if(Win32::API::Type::is_pointer($ret)) {
+ DEBUG "parse_prototype: OUT='%s' PACKING='%s' API_TYPE=%d\n",
+ $ret,
+ Win32::API::Type->packing( $ret ),
+ type_to_num('P');
+ return ( $proc, \@in_params, \@in_types, type_to_num('P') );
+ } else {
+ DEBUG "parse_prototype: OUT='%s' PACKING='%s' API_TYPE=%d\n",
+ $ret,
+ Win32::API::Type->packing( $ret ),
+ type_to_num( Win32::API::Type->packing( $ret ) );
+ return ( $proc, \@in_params, \@in_types, type_to_num(Win32::API::Type->packing($ret)) );
+ }
+ } else {
+ warn "Win32::API::parse_prototype: WARNING unknown output parameter type '$ret'";
+ return ( $proc, \@in_params, \@in_types, type_to_num('I') );
+ }
+
+ } else {
+ warn "Win32::API::parse_prototype: bad prototype '$proto'";
+ return undef;
+ }
+}
+
+1;
+
+__END__
+
+#######################################################################
+# DOCUMENTATION
+#
+
+=head1 NAME
+
+Win32::API - Perl Win32 API Import Facility
+
+=head1 SYNOPSIS
+
+ #### Method 1: with prototype
+
+ use Win32::API;
+ $function = Win32::API->new(
+ 'mydll, 'int sum_integers(int a, int b)',
+ );
+ $return = $function->Call(3, 2);
+
+ #### Method 2: with parameter list
+
+ use Win32::API;
+ $function = Win32::API->new(
+ 'mydll', 'sum_integers', 'II', 'I',
+ );
+ $return = $function->Call(3, 2);
+
+ #### Method 3: with Import
+
+ use Win32::API;
+ Win32::API->Import(
+ 'mydll', 'int sum_integers(int a, int b)',
+ );
+ $return = sum_integers(3, 2);
+
+
+=for LATER-UNIMPLEMENTED
+ #### or
+ use Win32::API mydll => 'int sum_integers(int a, int b)';
+ $return = sum_integers(3, 2);
+
+
+=head1 ABSTRACT
+
+With this module you can import and call arbitrary functions
+from Win32's Dynamic Link Libraries (DLL), without having
+to write an XS extension. Note, however, that this module
+can't do anything (parameters input and output is limited
+to simpler cases), and anyway a regular XS extension is
+always safer and faster.
+
+The current version of Win32::API is available at my website:
+
+ http://dada.perl.it/
+
+It's also available on your nearest CPAN mirror (but allow a few days
+for worldwide spreading of the latest version) reachable at:
+
+ http://www.perl.com/CPAN/authors/Aldo_Calpini/
+
+A short example of how you can use this module (it just gets the PID of
+the current process, eg. same as Perl's internal C<$$>):
+
+ use Win32::API;
+ Win32::API->Import("kernel32", "int GetCurrentProcessId()");
+ $PID = GetCurrentProcessId();
+
+The possibilities are nearly infinite (but not all are good :-).
+Enjoy it.
+
+
+=head1 CREDITS
+
+All the credits go to Andrea Frosini
+for the neat assembler trick that makes this thing work.
+I've also used some work by Dave Roth for the prototyping stuff.
+A big thank you also to Gurusamy Sarathy for his
+unvaluable help in XS development, and to all the Perl community for
+being what it is.
+
+
+=head1 DESCRIPTION
+
+To use this module put the following line at the beginning of your script:
+
+ use Win32::API;
+
+You can now use the C<new()> function of the Win32::API module to create a
+new Win32::API object (see L<IMPORTING A FUNCTION>) and then invoke the
+C<Call()> method on this object to perform a call to the imported API
+(see L<CALLING AN IMPORTED FUNCTION>).
+
+Starting from version 0.40, you can also avoid creating a Win32::API object
+and instead automatically define a Perl sub with the same name of the API
+function you're importing. The details of the API definitions are the same,
+just the call is different:
+
+ my $GetCurrentProcessId = Win32::API->new(
+ "kernel32", "int GetCurrentProcessId()"
+ );
+ my $PID = $GetCurrentProcessId->Call();
+
+ #### vs.
+
+ Win32::API->Import("kernel32", "int GetCurrentProcessId()");
+ $PID = GetCurrentProcessId();
+
+Note that C<Import> returns 1 on success and 0 on failure (in which case you
+can check the content of C<$^E>).
+
+=head2 IMPORTING A FUNCTION
+
+You can import a function from a 32 bit Dynamic Link Library (DLL) file
+with the C<new()> function. This will create a Perl object that contains the
+reference to that function, which you can later C<Call()>.
+
+What you need to know is the prototype of the function you're going to import
+(eg. the definition of the function expressed in C syntax).
+
+Starting from version 0.40, there are 2 different approaches for this step:
+(the preferred) one uses the prototype directly, while the other (now deprecated)
+one uses Win32::API's internal representation for parameters.
+
+=head2 IMPORTING A FUNCTION BY PROTOTYPE
+
+You need to pass 2 parameters:
+
+=over 4
+
+=item 1.
+The name of the library from which you want to import the function.
+
+=item 2.
+The C prototype of the function.
+
+=back
+
+See L<Win32::API::Type> for a list of the known parameter types and
+L<Win32::API::Struct> for information on how to define a structure.
+
+=head2 IMPORTING A FUNCTION WITH A PARAMETER LIST
+
+You need to pass 4 parameters:
+
+=over 4
+
+=item 1.
+The name of the library from which you want to import the function.
+
+=item 2.
+The name of the function (as exported by the library).
+
+=item 3.
+The number and types of the arguments the function expects as input.
+
+=item 4.
+The type of the value returned by the function.
+
+=back
+
+To better explain their meaning, let's suppose that we
+want to import and call the Win32 API C<GetTempPath()>.
+This function is defined in C as:
+
+ DWORD WINAPI GetTempPathA( DWORD nBufferLength, LPSTR lpBuffer );
+
+This is documented in the B<Win32 SDK Reference>; you can look
+for it on the Microsoft's WWW site, or in your C compiler's
+documentation, if you own one.
+
+=over 4
+
+=item B<1.>
+
+The first parameter is the name of the library file that
+exports this function; our function resides in the F<KERNEL32.DLL>
+system file.
+When specifying this name as parameter, the F<.DLL> extension
+is implicit, and if no path is given, the file is searched through
+a couple of directories, including:
+
+=over 4
+
+=item 1. The directory from which the application loaded.
+
+=item 2. The current directory.
+
+=item 3. The Windows system directory (eg. c:\windows\system or system32).
+
+=item 4. The Windows directory (eg. c:\windows).
+
+=item 5. The directories that are listed in the PATH environment variable.
+
+=back
+
+So, you don't have to write F<C:\windows\system\kernel32.dll>;
+only F<kernel32> is enough:
+
+ $GetTempPath = new Win32::API('kernel32', ...
+
+=item B<2.>
+
+Now for the second parameter: the name of the function.
+It must be written exactly as it is exported
+by the library (case is significant here).
+If you are using Windows 95 or NT 4.0, you can use the B<Quick View>
+command on the DLL file to see the function it exports.
+Remember that you can only import functions from 32 bit DLLs:
+in Quick View, the file's characteristics should report
+somewhere "32 bit word machine"; as a rule of thumb,
+when you see that all the exported functions are in upper case,
+the DLL is a 16 bit one and you can't use it.
+If their capitalization looks correct, then it's probably a 32 bit
+DLL.
+
+Also note that many Win32 APIs are exported twice, with the addition of
+a final B<A> or B<W> to their name, for - respectively - the ASCII
+and the Unicode version.
+When a function name is not found, Win32::API will actually append
+an B<A> to the name and try again; if the extension is built on a
+Unicode system, then it will try with the B<W> instead.
+So our function name will be:
+
+ $GetTempPath = new Win32::API('kernel32', 'GetTempPath', ...
+
+In our case C<GetTempPath> is really loaded as C<GetTempPathA>.
+
+=item B<3.>
+
+The third parameter, the input parameter list, specifies how many
+arguments the function wants, and their types. It can be passed as
+a single string, in which each character represents one parameter,
+or as a list reference. The following forms are valid:
+
+ "abcd"
+ [a, b, c, d]
+ \@LIST
+
+But those are not:
+
+ (a, b, c, d)
+ @LIST
+
+The number of characters, or elements in the list, specifies the number
+of parameters, and each character or element specifies the type of an
+argument; allowed types are:
+
+=over 4
+
+=item C<I>:
+value is an integer (int)
+
+=item C<N>:
+value is a number (long)
+
+=item C<F>:
+value is a floating point number (float)
+
+=item C<D>:
+value is a double precision number (double)
+
+=item C<C>:
+value is a char (char)
+
+=item C<P>:
+value is a pointer (to a string, structure, etc...)
+
+=item C<S>:
+value is a Win32::API::Struct object (see below)
+
+=item C<K>:
+value is a Win32::API::Callback object (see L<Win32::API::Callback>)
+
+=back
+
+Our function needs two parameters: a number (C<DWORD>) and a pointer to a
+string (C<LPSTR>):
+
+ $GetTempPath = new Win32::API('kernel32', 'GetTempPath', 'NP', ...
+
+=item B<4.>
+
+The fourth and final parameter is the type of the value returned by the
+function. It can be one of the types seen above, plus another type named B<V>
+(for C<void>), used for functions that do not return a value.
+In our example the value returned by GetTempPath() is a C<DWORD>, so
+our return type will be B<N>:
+
+ $GetTempPath = new Win32::API('kernel32', 'GetTempPath', 'NP', 'N');
+
+Now the line is complete, and the GetTempPath() API is ready to be used
+in Perl. Before calling it, you should test that $GetTempPath is
+C<defined>, otherwise either the function or the library could not be
+loaded; in this case, C<$!> will be set to the error message reported
+by Windows.
+Our definition, with error checking added, should then look like this:
+
+ $GetTempPath = new Win32::API('kernel32', 'GetTempPath', 'NP', 'N');
+ if(not defined $GetTempPath) {
+ die "Can't import API GetTempPath: $!\n";
+ }
+
+=back
+
+=head2 CALLING AN IMPORTED FUNCTION
+
+To effectively make a call to an imported function you must use the
+Call() method on the Win32::API object you created.
+Continuing with the example from the previous paragraph,
+the GetTempPath() API can be called using the method:
+
+ $GetTempPath->Call(...
+
+Of course, parameters have to be passed as defined in the import phase.
+In particular, if the number of parameters does not match (in the example,
+if GetTempPath() is called with more or less than two parameters),
+Perl will C<croak> an error message and C<die>.
+
+The two parameters needed here are the length of the buffer
+that will hold the returned temporary path, and a pointer to the
+buffer itself.
+For numerical parameters, you can use either a constant expression
+or a variable, while B<for pointers you must use a variable name> (no
+Perl references, just a plain variable name).
+Also note that B<memory must be allocated before calling the function>,
+just like in C.
+For example, to pass a buffer of 80 characters to GetTempPath(),
+it must be initialized before with:
+
+ $lpBuffer = " " x 80;
+
+This allocates a string of 80 characters. If you don't do so, you'll
+probably get C<Runtime exception> errors, and generally nothing will
+work. The call should therefore include:
+
+ $lpBuffer = " " x 80;
+ $GetTempPath->Call(80, $lpBuffer);
+
+And the result will be stored in the $lpBuffer variable.
+Note that you don't need to pass a reference to the variable
+(eg. you B<don't need> C<\$lpBuffer>), even if its value will be set
+by the function.
+
+A little problem here is that Perl does not trim the variable,
+so $lpBuffer will still contain 80 characters in return; the exceeding
+characters will be spaces, because we said C<" " x 80>.
+
+In this case we're lucky enough, because the value returned by
+the GetTempPath() function is the length of the string, so to get
+the actual temporary path we can write:
+
+ $lpBuffer = " " x 80;
+ $return = $GetTempPath->Call(80, $lpBuffer);
+ $TempPath = substr($lpBuffer, 0, $return);
+
+If you don't know the length of the string, you can usually
+cut it at the C<\0> (ASCII zero) character, which is the string
+delimiter in C:
+
+ $TempPath = ((split(/\0/, $lpBuffer))[0];
+ # or
+ $lpBuffer =~ s/\0.*$//;
+
+=head2 USING STRUCTURES
+
+Starting from version 0.40, Win32::API comes with a support package
+named Win32::API::Struct. The package is loaded automatically with
+Win32::API, so you don't need to use it explicitly.
+
+With this module you can conveniently define structures and use
+them as parameters to Win32::API functions. A short example follows:
+
+
+ # the 'POINT' structure is defined in C as:
+ # typedef struct {
+ # LONG x;
+ # LONG y;
+ # } POINT;
+
+
+ #### define the structure
+ Win32::API::Struct->typedef( POINT => qw{
+ LONG x;
+ LONG y;
+ });
+
+ #### import an API that uses this structure
+ Win32::API->Import('user32', 'BOOL GetCursorPos(LPPOINT lpPoint)');
+
+ #### create a 'POINT' object
+ my $pt = Win32::API::Struct->new('POINT');
+
+ #### call the function passing our structure object
+ GetCursorPos($pt);
+
+ #### and now, access its members
+ print "The cursor is at: $pt->{x}, $pt->{y}\n";
+
+Note that this works only when the function wants a
+B<pointer to a structure>: as you can see, our structure is named
+'POINT', but the API used 'LPPOINT'. 'LP' is automatically added at
+the beginning of the structure name when feeding it to a Win32::API
+call.
+
+For more information, see also L<Win32::API::Struct>.
+
+If you don't want (or can't) use the Win32::API::Struct facility,
+you can still use the low-level approach to use structures:
+
+
+=over 4
+
+=item 1.
+you have to pack() the required elements in a variable:
+
+ $lpPoint = pack('LL', 0, 0); # store two LONGs
+
+=item 2. to access the values stored in a structure, unpack() it as required:
+
+ ($x, $y) = unpack('LL', $lpPoint); # get the actual values
+
+=back
+
+The rest is left as an exercise to the reader...
+
+=head1 AUTHOR
+
+Aldo Calpini ( I<dada@perl.it> ).
+
+=head1 MAINTAINER
+
+Cosimo Streppone ( I<cosimo@cpan.org> )
+
+=cut
diff --git a/Master/tlpkg/installer/perllib/Win32/API/Callback.pm b/Master/tlpkg/installer/perllib/Win32/API/Callback.pm
new file mode 100644
index 00000000000..22de9d4f46a
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/Win32/API/Callback.pm
@@ -0,0 +1,174 @@
+package Win32::API::Callback;
+
+# See the bottom of this file for the POD documentation. Search for the
+# string '=head'.
+
+#######################################################################
+#
+# Win32::API::Callback - Perl Win32 API Import Facility
+#
+# Author: Aldo Calpini <dada@perl.it>
+# Maintainer: Cosimo Streppone <cosimo@cpan.org>
+#
+# $Id: Callback.pm,v 1.0 2001/10/30 13:57:31 dada Exp $
+#
+#######################################################################
+
+$VERSION = '0.47';
+
+require Exporter; # to export the constants to the main:: space
+require DynaLoader; # to dynuhlode the module.
+@ISA = qw( Exporter DynaLoader );
+
+sub DEBUG {
+ if ($WIN32::API::DEBUG) {
+ printf @_ if @_ or return 1;
+ } else {
+ return 0;
+ }
+}
+
+use Win32::API;
+use Win32::API::Type;
+use Win32::API::Struct;
+
+#######################################################################
+# This AUTOLOAD is used to 'autoload' constants from the constant()
+# XS function. If a constant is not found then control is passed
+# to the AUTOLOAD in AutoLoader.
+#
+
+sub AUTOLOAD {
+ my($constname);
+ ($constname = $AUTOLOAD) =~ s/.*:://;
+ #reset $! to zero to reset any current errors.
+ $!=0;
+ my $val = constant($constname, @_ ? $_[0] : 0);
+ if ($! != 0) {
+ if ($! =~ /Invalid/) {
+ $AutoLoader::AUTOLOAD = $AUTOLOAD;
+ goto &AutoLoader::AUTOLOAD;
+ } else {
+ ($pack,$file,$line) = caller;
+ die "Your vendor has not defined Win32::API::Callback macro $constname, used at $file line $line.";
+ }
+ }
+ eval "sub $AUTOLOAD { $val }";
+ goto &$AUTOLOAD;
+}
+
+
+#######################################################################
+# dynamically load in the API extension module.
+#
+bootstrap Win32::API::Callback;
+
+#######################################################################
+# PUBLIC METHODS
+#
+sub new {
+ my($class, $proc, $in, $out) = @_;
+ my %self = ();
+
+ # printf "(PM)Callback::new: got proc='%s', in='%s', out='%s'\n", $proc, $in, $out;
+
+ $self{in} = [];
+ if(ref($in) eq 'ARRAY') {
+ foreach (@$in) {
+ push(@{ $self{in} }, Win32::API::type_to_num($_));
+ }
+ } else {
+ my @in = split '', $in;
+ foreach (@in) {
+ push(@{ $self{in} }, Win32::API::type_to_num($_));
+ }
+ }
+ $self{out} = Win32::API::type_to_num($out);
+ $self{sub} = $proc;
+ my $self = bless \%self, $class;
+
+ DEBUG "(PM)Callback::new: calling CallbackCreate($self)...\n";
+ my $hproc = CallbackCreate($self);
+
+ DEBUG "(PM)Callback::new: hproc=$hproc\n";
+
+ #### ...if that fails, set $! accordingly
+ if(!$hproc) {
+ $! = Win32::GetLastError();
+ return undef;
+ }
+
+ #### ok, let's stuff the object
+ $self->{code} = $hproc;
+ $self->{sub} = $proc;
+
+ #### cast the spell
+ return $self;
+}
+
+sub MakeStruct {
+ my($self, $n, $addr) = @_;
+ DEBUG "(PM)Win32::API::Callback::MakeStruct: got self='$self'\n";
+ my $struct = Win32::API::Struct->new($self->{intypes}->[$n]);
+ $struct->FromMemory($addr);
+ return $struct;
+}
+
+1;
+
+__END__
+
+#######################################################################
+# DOCUMENTATION
+#
+
+=head1 NAME
+
+Win32::API::Callback - Callback support for Win32::API
+
+=head1 SYNOPSIS
+
+ use Win32::API;
+ use Win32::API::Callback;
+
+ my $callback = Win32::API::Callback->new(
+ sub { my($a, $b) = @_; return $a+$b; },
+ "NN", "N",
+ );
+
+ Win32::API->Import(
+ 'mydll', 'two_integers_cb', 'KNN', 'N',
+ );
+
+ $sum = two_integers_cb( $callback, 3, 2 );
+
+
+=head1 FOREWORDS
+
+=over 4
+
+=item *
+Support for this module is B<highly experimental> at this point.
+
+=item *
+I won't be surprised if it doesn't work for you.
+
+=item *
+Feedback is very appreciated.
+
+=item *
+Documentation is in the work. Either see the SYNOPSIS above
+or the samples in the F<samples> directory.
+
+=back
+
+=head1 AUTHOR
+
+Aldo Calpini ( I<dada@perl.it> ).
+
+=head1 MAINTAINER
+
+Cosimo Streppone ( I<cosimo@cpan.org> ).
+
+=cut
+
diff --git a/Master/tlpkg/installer/perllib/Win32/API/Struct.pm b/Master/tlpkg/installer/perllib/Win32/API/Struct.pm
new file mode 100644
index 00000000000..05a4c8c60a5
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/Win32/API/Struct.pm
@@ -0,0 +1,532 @@
+package Win32::API::Struct;
+
+# See the bottom of this file for the POD documentation. Search for the
+# string '=head'.
+
+#######################################################################
+#
+# Win32::API::Struct - Perl Win32 API struct Facility
+#
+# Author: Aldo Calpini <dada@perl.it>
+# Maintainer: Cosimo Streppone <cosimo@cpan.org>
+#
+# $Id: Struct.pm,v 1.0 2001/10/30 13:57:31 dada Exp $
+#######################################################################
+
+$VERSION = '0.47';
+
+use Win32::API::Type;
+
+use Carp;
+
+require Exporter; # to export the constants to the main:: space
+require DynaLoader; # to dynuhlode the module.
+@ISA = qw( Exporter DynaLoader );
+
+my %Known = ();
+
+sub DEBUG {
+ if ($Win32::API::DEBUG) {
+ printf @_ if @_ or return 1;
+ } else {
+ return 0;
+ }
+}
+
+sub typedef {
+ my $class = shift;
+ my $struct = shift;
+ my($type, $name);
+ my $self = {
+ align => undef,
+ typedef => [],
+ };
+ while(defined($type = shift)) {
+ $name = shift;
+ $name =~ s/;$//;
+ push( @{ $self->{typedef} }, [ recognize($type, $name) ] );
+ }
+
+ $Known{$struct} = $self;
+ return 1;
+}
+
+
+sub recognize {
+ my($type, $name) = @_;
+ my($size, $packing);
+ if(exists $Known{$type}) {
+ $packing = ">";
+ return $name, $packing, $type;
+ } else {
+ $packing = Win32::API::Type::packing($type);
+ return undef unless defined $packing;
+ if($name =~ s/\[(.*)\]$//) {
+ $size = $1;
+ $packing = $packing."*".$size;
+ }
+ DEBUG "(PM)Struct::recognize got '$name', '$type' -> '$packing'\n";
+ return $name, $packing, $type;
+ }
+}
+
+sub new {
+ my $class = shift;
+ my($type, $name);
+ my $self = {
+ typedef => [],
+ };
+ if($#_ == 0) {
+ if(exists $Known{$_[0]}) {
+ DEBUG "(PM)Struct::new: got '$_[0]'\n";
+ $self->{typedef} = $Known{$_[0]}->{typedef};
+ foreach my $member (@{ $self->{typedef} }) {
+ ($name, $packing, $type) = @$member;
+ if($packing eq '>') {
+ $self->{$name} = Win32::API::Struct->new($type);
+ }
+ }
+ $self->{__typedef__} = $_[0];
+ } else {
+ carp "Unknown Win32::API::Struct '$_[0]'";
+ return undef;
+ }
+ } else {
+ while(defined($type = shift)) {
+ $name = shift;
+ # print "new: found member $name ($type)\n";
+ if(not exists $Win32::API::Type::Known{$type}) {
+ warn "Unknown Win32::API::Struct type '$type'";
+ return undef;
+ } else {
+ push( @{ $self->{typedef} }, [ $name, $Win32::API::Type::Known{$type}, $type ] );
+ }
+ }
+ }
+ return bless $self;
+}
+
+sub members {
+ my $self = shift;
+ return map {$_->[0]} @{ $self->{typedef} };
+}
+
+sub sizeof {
+ my $self = shift;
+ my $size = 0;
+ my $align = 0;
+ my $first = undef;
+ foreach my $member (@{ $self->{typedef} }) {
+ my($name, $packing, $type) = @$member;
+
+ if(ref( $self->{$name} ) eq "Win32::API::Struct") {
+ $size += $self->{$name}->sizeof();
+ # $align = $self->{$name}->sizeof() if $self->{$name}->sizeof() > $align;
+ } else {
+ if($packing =~ /\w\*(\d+)/) {
+ $size += Win32::API::Type::sizeof($type) * $1;
+ $first = Win32::API::Type::sizeof($type) * $1 unless defined $first;
+ DEBUG "(PM)Struct::sizeof: sizeof with member($name) now = ". $size. "\n";
+ } else {
+ $size += Win32::API::Type::sizeof($type);
+ $first = Win32::API::Type::sizeof($type) unless defined $first;
+ $align = Win32::API::Type::sizeof($type)
+ if Win32::API::Type::sizeof($type) > $align;
+ DEBUG "(PM)Struct::sizeof: sizeof with member($name) now = ". $size. "\n";
+ }
+ }
+ }
+ DEBUG "(PM)Struct::sizeof first=$first align=$align\n";
+ #DEBUG "(PM)Struct::sizeof returning %d\n", $first + (scalar(@{ $self->{typedef} })-1) * $align;
+ #return $first + (scalar(@{ $self->{typedef} })-1) * $align;
+ DEBUG "(PM)Struct::sizeof returning %d\n", scalar(@{ $self->{typedef} }) * $align;
+ if(defined $align and $align > 0) {
+ return scalar(@{ $self->{typedef} }) * $align;
+ } else {
+ return $size;
+ }
+ return $size;
+}
+
+sub align {
+ my $self = shift;
+ my $align = shift;
+
+ if(not defined $align) {
+ return $self->{align} unless $self->{align} eq 'auto';
+ $align = 0;
+ foreach my $member (@{ $self->{typedef} }) {
+ my($name, $packing, $type) = @$member;
+
+ if(ref( $self->{$name} ) eq "Win32::API::Struct") {
+ #### ????
+ } else {
+ if($packing =~ /\w\*(\d+)/) {
+ #### ????
+ } else {
+ $align = Win32::API::Type::sizeof($type)
+ if Win32::API::Type::sizeof($type) > $align;
+ }
+ }
+ }
+ return $align;
+ } else {
+ $self->{align} = $align;
+
+ }
+}
+
+sub getPack {
+ my $self = shift;
+ my $packing = "";
+ my($type, $name);
+ my @items = ();
+ my @recipients = ();
+
+ my $align = $self->align();
+
+ foreach my $member (@{ $self->{typedef} }) {
+ ($name, $type, $orig) = @$member;
+ if($type eq '>') {
+ my($subpacking, $subitems, $subrecipients) = $self->{$name}->getPack();
+
+ DEBUG "(PM)Struct::getPack($self->{__typedef__}) ++ $subpacking\n";
+
+ $packing .= $subpacking;
+ push(@items, @$subitems);
+ push(@recipients, @$subrecipients);
+ } else {
+ if($type =~ /\w\*(\d+)/) {
+ my $size = $1;
+ $type = "a$size";
+ }
+
+ DEBUG "(PM)Struct::getPack($self->{__typedef__}) ++ $type\n";
+
+ if($type eq 'p') {
+ $type = "L";
+ push(@items, Win32::API::PointerTo($self->{$name}));
+ } else {
+ push(@items, $self->{$name});
+ }
+ $packing .= $type;
+
+ if($Win32::API::Type::PackSize{$type} < $align) {
+ $packing .= ("x" x ($align - $Win32::API::Type::PackSize{$type}));
+ }
+
+ push(@recipients, $self);
+ }
+ }
+ DEBUG "(PM)Struct::getPack: $self->{__typedef__}(buffer) = pack($packing, @items)\n";
+ return($packing, [@items], [@recipients]);
+}
+
+
+sub Pack {
+ my $self = shift;
+ my($packing, $items, $recipients) = $self->getPack();
+ DEBUG "(PM)Struct::Pack: $self->{__typedef__}(buffer) = pack($packing, @$items)\n";
+ $self->{buffer} = pack($packing, @$items);
+ if(DEBUG) {
+ for my $i (0..$self->sizeof-1) {
+ printf " %3d: 0x%02x\n", $i, ord(substr($self->{buffer}, $i, 1));
+ }
+ }
+ $self->{buffer_recipients} = $recipients
+}
+
+sub getUnpack {
+ my $self = shift;
+ my $packing = "";
+ my($type, $name);
+ my @items = ();
+ my $align = $self->align();
+ foreach my $member (@{ $self->{typedef} }) {
+ ($name, $type, $orig) = @$member;
+ if($type eq '>') {
+ my($subpacking, @subitems) = $self->{$name}->getUnpack();
+
+ DEBUG "(PM)Struct::getUnpack($self->{__typedef__}) ++ $subpacking\n";
+ $packing .= $subpacking;
+
+
+ push(@items, @subitems);
+ } else {
+ if($type =~ /\w\*(\d+)/) {
+ my $size = $1;
+ $type = "Z$size";
+ }
+
+ #if($type eq 'p') {
+ # $packing .= 'Z*';
+ # DEBUG "(PM)Struct::getUnpack($self->{__typedef__}) ++ Z*\n";
+ #} else {
+ $packing .= $type;
+ DEBUG "(PM)Struct::getUnpack($self->{__typedef__}) ++ $type\n";
+ #}
+ if($type ne 'p' and $type !~ /^Z(\d+)/ and $Win32::API::Type::PackSize{$type} < $align) {
+ DEBUG "(PM)Struct::getUnpack %s(%d) < %d\n",
+ $type, $Win32::API::Type::PackSize{$type}, $align
+ ;
+ $packing .= ("x" x ($align - $Win32::API::Type::PackSize{$type}));
+ }
+
+ push(@items, $name);
+ }
+ }
+ DEBUG "(PM)Struct::getUnpack($self->{__typedef__}): unpack($packing, @items)\n";
+ return($packing, @items);
+}
+
+sub Unpack {
+ my $self = shift;
+ my($packing, @items) = $self->getUnpack();
+ my @itemvalue = unpack($packing, $self->{buffer});
+ DEBUG "(PM)Struct::Unpack: unpack($packing, buffer) = @itemvalue\n";
+ foreach my $i (0..$#items) {
+ my $recipient = $self->{buffer_recipients}->[$i];
+ DEBUG "(PM)Struct::Unpack: %s(%s) = '%s' (0x%08x)\n",
+ $recipient->{__typedef__},
+ $items[$i],
+ $itemvalue[$i],
+ $itemvalue[$i],
+ ;
+ $recipient->{$items[$i]} = $itemvalue[$i];
+ DEBUG "(PM)Struct::Unpack: self.$items[$i] = $self->{$items[$i]}\n";
+ }
+}
+
+sub FromMemory {
+ my($self, $addr) = @_;
+ DEBUG "(PM)Struct::FromMemory: doing Pack\n";
+ $self->Pack();
+ DEBUG "(PM)Struct::FromMemory: doing GetMemory( 0x%08x, %d )\n", $addr, $self->sizeof;
+ $self->{buffer} = Win32::API::ReadMemory( $addr, $self->sizeof );
+ $self->Unpack();
+ DEBUG "(PM)Struct::FromMemory: doing Unpack\n";
+ DEBUG "(PM)Struct::FromMemory: structure is now:\n";
+ $self->Dump() if DEBUG;
+ DEBUG "\n";
+}
+
+sub Dump {
+ my $self = shift;
+ my $prefix = shift;
+ foreach my $member (@{ $self->{typedef} }) {
+ ($name, $packing, $type) = @$member;
+ if( ref($self->{$name}) ) {
+ $self->{$name}->Dump($name);
+ } else {
+ printf "%-20s %-20s %-20s\n", $prefix, $name, $self->{$name};
+ }
+ }
+}
+
+
+sub is_known {
+ my $name = shift;
+ if(exists $Known{ $name }) {
+ return 1;
+ } else {
+ if($name =~ s/^LP//) {
+ return exists $Known{ $name };
+ }
+ return 0;
+ }
+}
+
+sub TIEHASH {
+ return Win32::API::Struct::new(@_);
+}
+
+sub EXISTS {
+
+}
+
+sub FETCH {
+ my $self = shift;
+ my $key = shift;
+
+ if($key eq 'sizeof') {
+ return $self->sizeof;
+ }
+ my @members = map { $_->[0] } @{ $self->{typedef} };
+ if(grep(/^\Q$key\E$/, @members)) {
+ return $self->{$key};
+ } else {
+ warn "'$key' is not a member of Win32::API::Struct $self->{__typedef__}";
+ }
+}
+
+sub STORE {
+ my $self = shift;
+ my($key, $val) = @_;
+ my @members = map { $_->[0] } @{ $self->{typedef} };
+ if(grep(/^\Q$key\E$/, @members)) {
+ $self->{$key} = $val;
+ } else {
+ warn "'$key' is not a member of Win32::API::Struct $self->{__typedef__}";
+ }
+}
+
+sub FIRSTKEY {
+ my $self = shift;
+ my @members = map { $_->[0] } @{ $self->{typedef} };
+ return $members[0];
+}
+
+sub NEXTKEY {
+ my $self = shift;
+ my $key = shift;
+ my @members = map { $_->[0] } @{ $self->{typedef} };
+ for my $i (0..$#members-1) {
+ return $members[$i+1] if $members[$i] eq $key;
+ }
+ return undef;
+}
+
+1;
+
+#######################################################################
+# DOCUMENTATION
+#
+
+=head1 NAME
+
+Win32::API::Struct - C struct support package for Win32::API
+
+=head1 SYNOPSIS
+
+ use Win32::API;
+
+ Win32::API::Struct->typedef( 'POINT', qw(
+ LONG x;
+ LONG y;
+ ));
+
+ my $Point = Win32::API::Struct->new( 'POINT' );
+ $Point->{x} = 1024;
+ $Point->{y} = 768;
+
+ #### alternatively
+
+ tie %Point, 'Win32::API::Struct', 'POINT';
+ $Point{x} = 1024;
+ $Point{y} = 768;
+
+
+=head1 ABSTRACT
+
+This module enables you to define C structs for use with
+Win32::API.
+
+See L<Win32::API> for more info about its usage.
+
+=head1 DESCRIPTION
+
+This module is automatically imported by Win32::API, so you don't
+need to 'use' it explicitly. The main methods are C<typedef> and
+C<new>, which are documented below.
+
+=over 4
+
+=item C<typedef NAME, TYPE, MEMBER, TYPE, MEMBER, ...>
+
+This method defines a structure named C<NAME>. The definition consists
+of types and member names, just like in C. In fact, most of the
+times you can cut the C definition for a structure and paste it
+verbatim to your script, enclosing it in a C<qw()> block. The
+function takes care of removing the semicolon after the member
+name.
+
+The synopsis example could be written like this:
+
+ Win32::API::Struct->typedef('POINT', 'LONG', 'x', 'LONG', 'y');
+
+But it could also be written like this (note the indirect object
+syntax), which is pretty cool:
+
+ typedef Win32::API::Struct POINT => qw{
+ LONG x;
+ LONG y;
+ };
+
+Also note that C<typedef> automatically defines an 'LPNAME' type,
+which holds a pointer to your structure. In the example above,
+'LPPOINT' is also defined and can be used in a call to a
+Win32::API (in fact, this is what you're really going to use when
+doing API calls).
+
+=item C<new NAME>
+
+This creates a structure (a Win32::API::Struct object) of the
+type C<NAME> (it must have been defined with C<typedef>). In Perl,
+when you create a structure, all the members are undefined. But
+when you use that structure in C (eg. a Win32::API call), you
+can safely assume that they will be treated as zero (or NULL).
+
+=item C<sizeof>
+
+This returns the size, in bytes, of the structure. Acts just like
+the C function of the same name. It is particularly useful for
+structures that need a member to be initialized to the structure's
+own size.
+
+=item C<align [SIZE]>
+
+Sets or returns the structure alignment (eg. how the structure is
+stored in memory). This is a very advanced option, and you normally
+don't need to mess with it.
+All structures in the Win32 Platform SDK should work without it.
+But if you define your own structure, you may need to give it an
+explicit alignment. In most cases, passing a C<SIZE> of 'auto'
+should keep the world happy.
+
+=back
+
+=head2 THE C<tie> INTERFACE
+
+Instead of creating an object with the C<new> method, you can
+tie a hash, which will hold the desired structure, using the
+C<tie> builtin function:
+
+ tie %structure, Win32::API::Struct => 'NAME';
+
+The differences between the tied and non-tied approaches are:
+
+=over 4
+
+=item *
+with tied structures, you can access members directly as
+hash lookups, eg.
+
+ # tied # non-tied
+ $Point{x} vs. $Point->{x}
+
+=item *
+with tied structures, when you try to fetch or store a
+member that is not part of the structure, it will result
+in a warning, eg.
+
+ print $Point{z};
+ # this will warn: 'z' is not a member of Win32::API::Struct POINT
+
+=item *
+when you pass a tied structure as a Win32::API parameter,
+remember to backslash it, eg.
+
+ # tied # non-tied
+ GetCursorPos( \%Point ) vs. GetCursorPos( $Point )
+
+=back
+
+=head1 AUTHOR
+
+Aldo Calpini ( I<dada@perl.it> ).
+
+=head1 MAINTAINER
+
+Cosimo Streppone ( I<cosimo@cpan.org> ).
+
+=cut
diff --git a/Master/tlpkg/installer/perllib/Win32/API/Test.pm b/Master/tlpkg/installer/perllib/Win32/API/Test.pm
new file mode 100644
index 00000000000..6cbeed6bfac
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/Win32/API/Test.pm
@@ -0,0 +1,120 @@
+#
+# Win32::API::Test - Test helper package for Win32::API
+#
+# Version: 0.01
+# Date: 23 Dec 2006
+# Author: Cosimo Streppone <cosimo@cpan.org>
+#
+# $Id: API.pm,v 1.0 2001/10/30 13:57:31 dada Exp $
+#
+package Win32::API::Test;
+
+sub compiler_name () {
+ use Config;
+ my $cc = $Config{ccname};
+ if($cc eq 'cl' || $cc eq 'cl.exe')
+ {
+ $cc = 'cl';
+ }
+ return($cc);
+}
+
+sub compiler_version () {
+ use Config;
+ my $ver = $Config{ccversion} || 0;
+ if( $ver =~ /^(\d+\.\d+)/ )
+ {
+ $ver = 0 + $1;
+ }
+ return($ver);
+}
+
+#
+# Run the compiler and get version from there...
+# User might be running a compiler different from
+# that used to build perl.
+# For example, Cosimo does. For testing, of course.
+#
+# ***
+# *** IT DOES NOT WORK NOW.
+# *** FOR REASONS I DON'T KNOW, CL.EXE OUTPUTS ITS
+# *** VERSION STRING IN THE FIRST TWO LINES THAT
+# *** I'M NOT ABLE TO CATCH...
+# ***
+#
+sub compiler_version_from_shell () {
+ my $cc = compiler_name();
+ my $ver;
+ # MSVC
+ if($cc eq 'cl')
+ {
+ my @ver = `$cc`;
+ my $ver = join('',@ver);
+ print 'VER:'.$ver.':'."\n";
+ if($ver =~ /Version (\d[\d\.]+)/ms )
+ {
+ $ver = $1;
+ }
+ }
+ # GCC
+ elsif($cc eq 'cc' || $cc eq 'gcc' || $cc eq 'winegcc' )
+ {
+ $ver = join('', `$cc --version`);
+ if($ver =~ /gcc.*(\d[\d+]+)/ms )
+ {
+ $ver = $1;
+ }
+ }
+ # Borland C
+ elsif($cc eq 'bcc32' || $cc eq 'bcc')
+ {
+ $ver = join('', `$cc`);
+ if($ver =~ /Borland C\+\+ (\d[\d\.]+)/ms )
+ {
+ $ver = $1;
+ }
+ }
+ return($ver);
+}
+
+sub find_test_dll () {
+ require File::Spec;
+ my $dll_name = $_[0];
+ my @paths = qw(.. ../t ../t/dll . ./dll ./t/dll);
+ while(my $path = shift @paths)
+ {
+ $dll = File::Spec->catfile($path, $dll_name);
+ return $dll if -s $dll;
+ }
+ return(undef);
+}
+
+1;
+
+__END__
+
+
+#######################################################################
+# DOCUMENTATION
+#
+
+=head1 NAME
+
+Win32::API::Test - Test helper package for Win32::API
+
+=head1 SYNOPSIS
+
+ my $test_dll = Win32::API::Test::find_test_dll('API_test.dll');
+
+Check the t/*.t test scripts for more details.
+
+=head1 DESCRIPTION
+
+Simple package to hold Win32::API test suite helper functions.
+No more, no less.
+
+=head1 AUTHOR
+
+Cosimo Streppone ( I<cosimo@cpan.org> )
+
+=cut
diff --git a/Master/tlpkg/installer/perllib/Win32/API/Type.pm b/Master/tlpkg/installer/perllib/Win32/API/Type.pm
new file mode 100644
index 00000000000..334b0b731e1
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/Win32/API/Type.pm
@@ -0,0 +1,446 @@
+package Win32::API::Type;
+
+# See the bottom of this file for the POD documentation. Search for the
+# string '=head'.
+
+#######################################################################
+#
+# Win32::API::Type - Perl Win32 API type definitions
+#
+# Author: Aldo Calpini <dada@perl.it>
+# Maintainer: Cosimo Streppone <cosimo@cpan.org>
+#
+# $Id: Type.pm,v 1.0 2001/10/30 13:57:31 dada Exp $
+#######################################################################
+
+$VERSION = '0.47';
+
+use Carp;
+
+require Exporter; # to export the constants to the main:: space
+require DynaLoader; # to dynuhlode the module.
+@ISA = qw( Exporter DynaLoader );
+
+use vars qw( %Known %PackSize %Modifier %Pointer );
+
+sub DEBUG {
+ if ($Win32::API::DEBUG) {
+ printf @_ if @_ or return 1;
+ } else {
+ return 0;
+ }
+}
+
+%Known = ();
+%PackSize = ();
+%Modifier = ();
+%Pointer = ();
+
+# Initialize data structures at startup.
+# Aldo wants to keep the <DATA> approach.
+#
+my $section = 'nothing';
+foreach (<DATA>) {
+ next if /^\s*#/ or /^\s*$/;
+ chomp;
+ if( /\[(.+)\]/) {
+ $section = $1;
+ next;
+ }
+ if($section eq 'TYPE') {
+ my($name, $packing) = split(/\s+/);
+ # DEBUG "(PM)Type::INIT: Known('$name') => '$packing'\n";
+ $Known{$name} = $packing;
+ } elsif($section eq 'PACKSIZE') {
+ my($packing, $size) = split(/\s+/);
+ # DEBUG "(PM)Type::INIT: PackSize('$packing') => '$size'\n";
+ $PackSize{$packing} = $size;
+ } elsif($section eq 'MODIFIER') {
+ my($modifier, $mapto) = split(/\s+/, $_, 2);
+ my %maps = ();
+ foreach my $item (split(/\s+/, $mapto)) {
+ my($k, $v) = split(/=/, $item);
+ $maps{$k} = $v;
+ }
+ # DEBUG "(PM)Type::INIT: Modifier('$modifier') => '%maps'\n";
+ $Modifier{$modifier} = { %maps };
+ } elsif($section eq 'POINTER') {
+ my($pointer, $pointto) = split(/\s+/);
+ # DEBUG "(PM)Type::INIT: Pointer('$pointer') => '$pointto'\n";
+ $Pointer{$pointer} = $pointto;
+ }
+}
+close(DATA);
+
+sub new {
+ my $class = shift;
+ my($type) = @_;
+ my $packing = packing($type);
+ my $size = sizeof($type);
+ my $self = {
+ type => $type,
+ packing => $packing,
+ size => $size,
+ };
+ return bless $self;
+}
+
+sub typedef {
+ my $class = shift;
+ my($name, $type) = @_;
+ my $packing = packing($type, $name);
+ DEBUG "(PM)Type::typedef: packing='$packing'\n";
+ my $size = sizeof($type);
+ $Known{$name} = $packing;
+ return 1;
+}
+
+
+sub is_known {
+ my $self = shift;
+ my $type = shift;
+ $type = $self unless defined $type;
+ if(ref($type) =~ /Win32::API::Type/) {
+ return 1;
+ } else {
+ return defined packing($type);
+ }
+}
+
+sub sizeof {
+ my $self = shift;
+ my $type = shift;
+ $type = $self unless defined $type;
+ if(ref($type) =~ /Win32::API::Type/) {
+ return $self->{size};
+ } else {
+ my $packing = packing($type);
+ if($packing =~ /(\w)\*(\d+)/) {
+ return $PackSize{ $1 } * $2;
+ } else {
+ return $PackSize{ $packing };
+ }
+ }
+}
+
+sub packing {
+ # DEBUG "(PM)Type::packing: called by ". join("::", (caller(1))[0,3]). "\n";
+ my $self = shift;
+ my $is_pointer = 0;
+ if(ref($self) =~ /Win32::API::Type/) {
+ # DEBUG "(PM)Type::packing: got an object\n";
+ return $self->{packing};
+ }
+ my $type = ($self eq 'Win32::API::Type') ? shift : $self;
+ my $name = shift;
+
+ # DEBUG "(PM)Type::packing: got '$type', '$name'\n";
+ my($modifier, $size, $packing);
+ if(exists $Pointer{$type}) {
+ # DEBUG "(PM)Type::packing: got '$type', is really '$Pointer{$type}'\n";
+ $type = $Pointer{$type};
+ $is_pointer = 1;
+ } elsif($type =~ /(\w+)\s+(\w+)/) {
+ $modifier = $1;
+ $type = $2;
+ # DEBUG "(PM)packing: got modifier '$modifier', type '$type'\n";
+ }
+
+ $type =~ s/\*$//;
+
+ if(exists $Known{$type}) {
+ if(defined $name and $name =~ s/\[(.*)\]$//) {
+ $size = $1;
+ $packing = $Known{$type}[0]."*".$size;
+ # DEBUG "(PM)Type::packing: composite packing: '$packing' '$size'\n";
+ } else {
+ $packing = $Known{$type};
+ if($is_pointer and $packing eq 'c') {
+ $packing = "p";
+ }
+ # DEBUG "(PM)Type::packing: simple packing: '$packing'\n";
+ }
+ if(defined $modifier and exists $Modifier{$modifier}->{$type}) {
+ # DEBUG "(PM)Type::packing: applying modifier '$modifier' -> '$Modifier{$modifier}->{$type}'\n";
+ $packing = $Modifier{$modifier}->{$type};
+ }
+ return $packing;
+ } else {
+ # DEBUG "(PM)Type::packing: NOT FOUND\n";
+ return undef;
+ }
+}
+
+
+sub is_pointer {
+ my $self = shift;
+ my $type = shift;
+ $type = $self unless defined $type;
+ if(ref($type) =~ /Win32::API::Type/) {
+ return 1;
+ } else {
+ if($type =~ /\*$/) {
+ return 1;
+ } else {
+ return exists $Pointer{$type};
+ }
+ }
+}
+
+sub Pack {
+ my $type = $_[0];
+
+ if(packing($type) eq 'c' and is_pointer($type)) {
+ $_[1] = pack("Z*", $_[1]);
+ return $_[1];
+ }
+ $_[1] = pack( packing($type), $_[1]);
+ return $_[1];
+}
+
+sub Unpack {
+ my $type = $_[0];
+ if(packing($type) eq 'c' and is_pointer($type)) {
+ DEBUG "(PM)Type::Unpack: got packing 'c', is a pointer, unpacking 'Z*' '$_[1]'\n";
+ $_[1] = unpack("Z*", $_[1]);
+ DEBUG "(PM)Type::Unpack: returning '$_[1]'\n";
+ return $_[1];
+ }
+ DEBUG "(PM)Type::Unpack: unpacking '".packing($type)."' '$_[1]'\n";
+ $_[1] = unpack( packing($type), $_[1]);
+ DEBUG "(PM)Type::Unpack: returning '$_[1]'\n";
+ return $_[1];
+}
+
+1;
+
+#######################################################################
+# DOCUMENTATION
+#
+
+=head1 NAME
+
+Win32::API::Type - C type support package for Win32::API
+
+=head1 SYNOPSIS
+
+ use Win32::API;
+
+ Win32::API::Type->typedef( 'my_number', 'LONG' );
+
+
+=head1 ABSTRACT
+
+This module is a support package for Win32::API that implements
+C types for the import with prototype functionality.
+
+See L<Win32::API> for more info about its usage.
+
+=head1 DESCRIPTION
+
+This module is automatically imported by Win32::API, so you don't
+need to 'use' it explicitly. These are the methods of this package:
+
+=over 4
+
+=item C<typedef NAME, TYPE>
+
+This method defines a new type named C<NAME>. This actually just
+creates an alias for the already-defined type C<TYPE>, which you
+can use as a parameter in a Win32::API call.
+
+=item C<sizeof TYPE>
+
+This returns the size, in bytes, of C<TYPE>. Acts just like
+the C function of the same name.
+
+=item C<is_known TYPE>
+
+Returns true if C<TYPE> is known by Win32::API::Type, false
+otherwise.
+
+=back
+
+=head2 SUPPORTED TYPES
+
+This module should recognize all the types defined in the
+Win32 Platform SDK header files.
+Please see the source for this module, in the C<__DATA__> section,
+for the full list.
+
+=head1 AUTHOR
+
+Aldo Calpini ( I<dada@perl.it> ).
+
+=head1 MAINTAINER
+
+Cosimo Streppone ( I<cosimo@cpan.org> ).
+
+=cut
+
+
+__DATA__
+
+[TYPE]
+ATOM s
+BOOL L
+BOOLEAN c
+BYTE C
+CHAR c
+COLORREF L
+DWORD L
+DWORD32 L
+DWORD64 Q
+FLOAT f
+HACCEL L
+HANDLE L
+HBITMAP L
+HBRUSH L
+HCOLORSPACE L
+HCONV L
+HCONVLIST L
+HCURSOR L
+HDC L
+HDDEDATA L
+HDESK L
+HDROP L
+HDWP L
+HENHMETAFILE L
+HFILE L
+HFONT L
+HGDIOBJ L
+HGLOBAL L
+HHOOK L
+HICON L
+HIMC L
+HINSTANCE L
+HKEY L
+HKL L
+HLOCAL L
+HMENU L
+HMETAFILE L
+HMODULE L
+HPALETTE L
+HPEN L
+HRGN L
+HRSRC L
+HSZ L
+HWINSTA L
+HWND L
+INT i
+INT32 i
+INT64 q
+LANGID s
+LCID L
+LCSCSTYPE L
+LCSGAMUTMATCH L
+LCTYPE L
+LONG l
+LONG32 l
+LONG64 q
+LONGLONG q
+LPARAM L
+LRESULT L
+REGSAM L
+SC_HANDLE L
+SC_LOCK L
+SERVICE_STATUS_HANDLE L
+SHORT s
+SIZE_T L
+SSIZE_T L
+TBYTE c
+TCHAR C
+UCHAR C
+UINT I
+UINT_PTR L
+UINT32 I
+UINT64 Q
+ULONG L
+ULONG32 L
+ULONG64 Q
+ULONGLONG Q
+USHORT S
+WCHAR S
+WORD S
+WPARAM L
+VOID c
+
+int i
+long l
+float f
+double d
+char c
+
+#CRITICAL_SECTION 24 -- a structure
+#LUID ? 8 -- a structure
+#VOID 0
+#CONST 4
+#FILE_SEGMENT_ELEMENT 8 -- a structure
+
+[PACKSIZE]
+c 1
+C 1
+d 8
+f 4
+i 4
+I 4
+l 4
+L 4
+q 8
+Q 8
+s 2
+S 2
+p 4
+
+[MODIFIER]
+unsigned int=I long=L short=S char=C
+
+[POINTER]
+INT_PTR INT
+LPBOOL BOOL
+LPBYTE BYTE
+LPCOLORREF COLORREF
+LPCSTR CHAR
+#LPCTSTR CHAR or WCHAR
+LPCTSTR CHAR
+LPCVOID any
+LPCWSTR WCHAR
+LPDWORD DWORD
+LPHANDLE HANDLE
+LPINT INT
+LPLONG LONG
+LPSTR CHAR
+#LPTSTR CHAR or WCHAR
+LPTSTR CHAR
+LPVOID VOID
+LPWORD WORD
+LPWSTR WCHAR
+
+PBOOL BOOL
+PBOOLEAN BOOL
+PBYTE BYTE
+PCHAR CHAR
+PCSTR CSTR
+PCWCH CWCH
+PCWSTR CWSTR
+PDWORD DWORD
+PFLOAT FLOAT
+PHANDLE HANDLE
+PHKEY HKEY
+PINT INT
+PLCID LCID
+PLONG LONG
+PSHORT SHORT
+PSTR CHAR
+#PTBYTE TBYTE --
+#PTCHAR TCHAR --
+#PTSTR CHAR or WCHAR
+PTSTR CHAR
+PUCHAR UCHAR
+PUINT UINT
+PULONG ULONG
+PUSHORT USHORT
+PVOID VOID
+PWCHAR WCHAR
+PWORD WORD
+PWSTR WCHAR
diff --git a/Master/tlpkg/installer/perllib/Win32/Env.pm b/Master/tlpkg/installer/perllib/Win32/Env.pm
new file mode 100644
index 00000000000..c5420718175
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/Win32/Env.pm
@@ -0,0 +1,169 @@
+package Win32::Env;
+our $VERSION='0.01';
+
+=head1 NAME
+
+Win32::Env - get and set global system and user enviroment varialbes under Win32.
+
+=head1 VERSION
+
+Version 0.01
+
+=head1 SYNOPSIS
+
+ use Win32::Env;
+
+ my $user_path=GetEnv(ENV_USER, 'PATH');
+ # Limit PATH for other programs to system path and specified directory for 10 seconds
+ SetEnv(ENV_USER, 'PATH', 'C:\\Perl\\bin');
+ BroadcastEnv();
+ sleep(10);
+ # Restore everything back
+ SetEnv(ENV_USER, 'PATH', $user_path);
+ BroadcastEnv();
+
+=cut
+
+
+use warnings;
+use strict;
+
+use Win32::TieRegistry(FixSzNulls=>1);
+
+use Exporter qw(import);
+our @EXPORT=qw(SetEnv GetEnv BroadcastEnv ENV_USER ENV_SYSTEM);
+
+use constant ENV_USER =>0;
+use constant ENV_SYSTEM =>1;
+
+use constant ENVKEY_USER => 'HKEY_CURRENT_USER\\Environment';
+use constant ENVKEY_SYSTEM => 'HKEY_LOCAL_MACHINE\\SYSTEM\\CurrentControlSet\\Control\\Session Manager\\Environment';
+
+=head1 EXPORT
+
+SetEnv GetEnv BroadcastEnv ENV_USER ENV_SYSTEM
+
+=head1 FUNCTIONS
+
+=cut
+
+sub _NWA{
+ my $lib=shift,
+ my @proto=@_;
+ require Win32::API;
+ return(new Win32::API($lib, @proto) or die "Can't import API $proto[0] from $lib: $^E\n");
+}
+
+# TODO: error/sanity checks for other args
+sub _num_to_key($){
+ my $sysusr=shift;
+ if($sysusr==ENV_USER) { $sysusr=ENVKEY_USER; }
+ elsif($sysusr==ENV_SYSTEM) { $sysusr=ENVKEY_SYSTEM; }
+ else { return; } # And Carp!
+ return $sysusr;
+}
+
+=head2 SetEnv($sys_or_usr, $variable, $value)
+
+Sets variable in enviroment to specified value. C<$sys_or_usr> specifies either
+current user's enviroment with exported constant C<ENV_USER> or system's global environment
+with C<ENV_SYSTEM>.
+
+=cut
+
+sub SetEnv($$$){
+ my ($sysusr, $var, $value)=@_;
+ $sysusr=(_num_to_key($sysusr) or return);
+ $Registry->{"$sysusr\\$var"}=$value;
+}
+
+=head2 GetEnv($sys_or_usr, $variable)
+
+Returns value of enviroment variable. Its difference from plain C<$ENV{$variable}> is that
+you can (and must) select current user's or system's global enviroment with C<$sys_or_usr>.
+It is selected with same constants as in L<#SetEnv>.
+
+=cut
+
+sub GetEnv($$){
+ my ($sysusr, $var, $value)=@_;
+ $sysusr=(_num_to_key($sysusr) or return);
+ return $Registry->{"$sysusr\\$var"};
+}
+
+=head2 BroadcastEnv()
+
+Broadcasts system message that enviroment has changed. This will make system processes responsible for
+enviroment aware of change, otherwise your changes will be noticed only on next reboot. Note that most
+user programs still won't see changes until next run and that your changes will not be available in C<%ENV>
+to either your process or any processes you spawn. Assign to C<%ENV> yourself in addition to C<SetEnv> if
+need it.
+
+=cut
+
+sub BroadcastEnv(){
+ use constant HWND_BROADCAST => 0xffff;
+ use constant WM_SETTINGCHANGE => 0x001A;
+ print "Broadcasting \"Enviroment settings changed\" message...\n";
+ # SendMessageTimeout(HWND_BROADCAST, WM_SETTINGCHANGE, 0, (LPARAM) "Environment", SMTO_ABORTIFHUNG, 5000, &dwReturnValue);
+ my $SendMessage=_NWA('user32', 'SendMessage', 'LLPP', 'L');
+ $SendMessage->Call(HWND_BROADCAST, WM_SETTINGCHANGE, 0, 'Environment');
+ print "Broadcast complete.\n";
+}
+
+1;
+
+=head1 AUTHOR
+
+Oleg "Rowaa[SR13]" V. Volkov, C<< <ROWAA at cpan.org> >>
+
+=head1 BUGS / TODO
+
+Only first argument to C<GetEnv>/C<SetEnv> is checked right now. Considering that functions work with
+Windows registry, more sanity checks should be added to other arguments.
+
+Any limitations of Win32::TieRegistry apply to this module too, because it is used to write all
+changes to the registry.
+
+Please report any bugs or feature requests to
+C<bug-win32-env at rt.cpan.org>, or through the web interface at
+L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Win32-Env>.
+I will be notified, and then you'll automatically be notified of progress on
+your bug as I make changes.
+
+=head1 SUPPORT
+
+You can find documentation for this module with the perldoc command.
+
+ perldoc Win32::Env
+
+You can also look for information at:
+
+=over 4
+
+=item * AnnoCPAN: Annotated CPAN documentation
+
+L<http://annocpan.org/dist/Win32-Env>
+
+=item * CPAN Ratings
+
+L<http://cpanratings.perl.org/d/Win32-Env>
+
+=item * RT: CPAN's request tracker
+
+L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Win32-Env>
+
+=item * Search CPAN
+
+L<http://search.cpan.org/dist/Win32-Env>
+
+=back
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright 2006 Oleg "Rowaa[SR13]" V. Volkov, all rights reserved.
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=cut
diff --git a/Master/tlpkg/installer/perllib/Win32/Registry.pm b/Master/tlpkg/installer/perllib/Win32/Registry.pm
new file mode 100644
index 00000000000..c83fca5a3b1
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/Win32/Registry.pm
@@ -0,0 +1,547 @@
+package Win32::Registry;
+
+=head1 NAME
+
+Win32::Registry - accessing the Windows registry [obsolete, use Win32::TieRegistry]
+
+=head1 SYNOPSIS
+
+ use Win32::Registry;
+ my $tips;
+ $::HKEY_LOCAL_MACHINE->Open("SOFTWARE\\Microsoft\\Windows"
+ ."\\CurrentVersion\\Explorer\\Tips", $tips)
+ or die "Can't open tips: $^E";
+ my ($type, $value);
+ $tips->QueryValueEx("18", $type, $value) or die "No tip #18: $^E";
+ print "Here's a tip: $value\n";
+
+=head1 DESCRIPTION
+
+ NOTE: This module provides a very klunky interface to access the
+ Windows registry, and is not currently being developed actively. It
+ only exists for backward compatibility with old code that uses it.
+ For more powerful and flexible ways to access the registry, use
+ Win32::TieRegistry.
+
+Win32::Registry provides an object oriented interface to the Windows
+Registry.
+
+The following "root" registry objects are exported to the main:: name
+space. Additional keys must be opened by calling the provided methods
+on one of these.
+
+ $HKEY_CLASSES_ROOT
+ $HKEY_CURRENT_USER
+ $HKEY_LOCAL_MACHINE
+ $HKEY_USERS
+ $HKEY_PERFORMANCE_DATA
+ $HKEY_CURRENT_CONFIG
+ $HKEY_DYN_DATA
+
+=cut
+
+use strict;
+require Exporter;
+require DynaLoader;
+use Win32::WinError;
+
+require Win32 unless defined &Win32::GetLastError;
+
+use vars qw($VERSION $AUTOLOAD @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
+
+$VERSION = '0.07';
+
+@ISA = qw( Exporter DynaLoader );
+@EXPORT = qw(
+ HKEY_CLASSES_ROOT
+ HKEY_CURRENT_USER
+ HKEY_LOCAL_MACHINE
+ HKEY_PERFORMANCE_DATA
+ HKEY_CURRENT_CONFIG
+ HKEY_DYN_DATA
+ HKEY_USERS
+ KEY_ALL_ACCESS
+ KEY_CREATE_LINK
+ KEY_CREATE_SUB_KEY
+ KEY_ENUMERATE_SUB_KEYS
+ KEY_EXECUTE
+ KEY_NOTIFY
+ KEY_QUERY_VALUE
+ KEY_READ
+ KEY_SET_VALUE
+ KEY_WRITE
+ REG_BINARY
+ REG_CREATED_NEW_KEY
+ REG_DWORD
+ REG_DWORD_BIG_ENDIAN
+ REG_DWORD_LITTLE_ENDIAN
+ REG_EXPAND_SZ
+ REG_FULL_RESOURCE_DESCRIPTOR
+ REG_LEGAL_CHANGE_FILTER
+ REG_LEGAL_OPTION
+ REG_LINK
+ REG_MULTI_SZ
+ REG_NONE
+ REG_NOTIFY_CHANGE_ATTRIBUTES
+ REG_NOTIFY_CHANGE_LAST_SET
+ REG_NOTIFY_CHANGE_NAME
+ REG_NOTIFY_CHANGE_SECURITY
+ REG_OPENED_EXISTING_KEY
+ REG_OPTION_BACKUP_RESTORE
+ REG_OPTION_CREATE_LINK
+ REG_OPTION_NON_VOLATILE
+ REG_OPTION_RESERVED
+ REG_OPTION_VOLATILE
+ REG_REFRESH_HIVE
+ REG_RESOURCE_LIST
+ REG_RESOURCE_REQUIREMENTS_LIST
+ REG_SZ
+ REG_WHOLE_HIVE_VOLATILE
+);
+
+@EXPORT_OK = qw(
+ RegCloseKey
+ RegConnectRegistry
+ RegCreateKey
+ RegCreateKeyEx
+ RegDeleteKey
+ RegDeleteValue
+ RegEnumKey
+ RegEnumValue
+ RegFlushKey
+ RegGetKeySecurity
+ RegLoadKey
+ RegNotifyChangeKeyValue
+ RegOpenKey
+ RegOpenKeyEx
+ RegQueryInfoKey
+ RegQueryValue
+ RegQueryValueEx
+ RegReplaceKey
+ RegRestoreKey
+ RegSaveKey
+ RegSetKeySecurity
+ RegSetValue
+ RegSetValueEx
+ RegUnLoadKey
+);
+$EXPORT_TAGS{ALL}= \@EXPORT_OK;
+
+bootstrap Win32::Registry;
+
+sub import {
+ my $pkg = shift;
+ if ($_[0] && "Win32" eq $_[0]) {
+ Exporter::export($pkg, "Win32", @EXPORT_OK);
+ shift;
+ }
+ Win32::Registry->export_to_level(1+$Exporter::ExportLevel, $pkg, @_);
+}
+
+#######################################################################
+# This AUTOLOAD is used to 'autoload' constants from the constant()
+# XS function. If a constant is not found then control is passed
+# to the AUTOLOAD in AutoLoader.
+
+sub AUTOLOAD {
+ my($constname);
+ ($constname = $AUTOLOAD) =~ s/.*:://;
+ #reset $! to zero to reset any current errors.
+ local $! = 0;
+ my $val = constant($constname, 0);
+ if ($! != 0) {
+ if ($! =~ /Invalid/) {
+ $AutoLoader::AUTOLOAD = $AUTOLOAD;
+ goto &AutoLoader::AUTOLOAD;
+ }
+ else {
+ my ($pack,$file,$line) = caller;
+ die "Unknown constant $constname in Win32::Registry "
+ . "at $file line $line.\n";
+ }
+ }
+ eval "sub $AUTOLOAD { $val }";
+ goto &$AUTOLOAD;
+}
+
+#######################################################################
+# _new is a private constructor, not intended for public use.
+#
+
+sub _new {
+ my $self;
+ if ($_[0]) {
+ $self->{'handle'} = $_[0];
+ bless $self;
+ }
+ $self;
+}
+
+#define the basic registry objects to be exported.
+#these had to be hardwired unfortunately.
+# XXX Yuck!
+
+{
+ package main;
+ use vars qw(
+ $HKEY_CLASSES_ROOT
+ $HKEY_CURRENT_USER
+ $HKEY_LOCAL_MACHINE
+ $HKEY_USERS
+ $HKEY_PERFORMANCE_DATA
+ $HKEY_CURRENT_CONFIG
+ $HKEY_DYN_DATA
+ );
+}
+
+$::HKEY_CLASSES_ROOT = _new(&HKEY_CLASSES_ROOT);
+$::HKEY_CURRENT_USER = _new(&HKEY_CURRENT_USER);
+$::HKEY_LOCAL_MACHINE = _new(&HKEY_LOCAL_MACHINE);
+$::HKEY_USERS = _new(&HKEY_USERS);
+$::HKEY_PERFORMANCE_DATA = _new(&HKEY_PERFORMANCE_DATA);
+$::HKEY_CURRENT_CONFIG = _new(&HKEY_CURRENT_CONFIG);
+$::HKEY_DYN_DATA = _new(&HKEY_DYN_DATA);
+
+=head2 Methods
+
+The following methods are supported. Note that subkeys can be
+specified as a path name, separated by backslashes (which may
+need to be doubled if you put them in double quotes).
+
+=over 8
+
+=item Open
+
+ $reg_obj->Open($sub_key_name, $sub_reg_obj);
+
+Opens a subkey of a registry object, returning the new registry object
+in $sub_reg_obj.
+
+=cut
+
+sub Open {
+ my $self = shift;
+ die 'usage: $obj->Open($sub_key_name, $sub_reg_obj)' if @_ != 2;
+
+ my ($subkey) = @_;
+ my ($result,$subhandle);
+
+ $result = RegOpenKey($self->{'handle'},$subkey,$subhandle);
+ $_[1] = _new($subhandle);
+
+ return 0 unless $_[1];
+ $! = Win32::GetLastError() unless $result;
+ return $result;
+}
+
+=item Close
+
+ $reg_obj->Close();
+
+Closes an open registry key.
+
+=cut
+
+sub Close {
+ my $self = shift;
+ die 'usage: $obj->Close()' if @_ != 0;
+
+ return unless exists $self->{'handle'};
+ my $result = RegCloseKey($self->{'handle'});
+ if ($result) {
+ delete $self->{'handle'};
+ }
+ else {
+ $! = Win32::GetLastError();
+ }
+ return $result;
+}
+
+sub DESTROY {
+ my $self = shift;
+ return unless exists $self->{'handle'};
+ RegCloseKey($self->{'handle'});
+ delete $self->{'handle'};
+}
+
+
+=item Connect
+
+ $reg_obj->Connect($node_name, $new_reg_obj);
+
+Connects to a remote Registry on the node specified by $node_name,
+returning it in $new_reg_obj. Returns false if it fails.
+
+=cut
+
+sub Connect {
+ my $self = shift;
+ die 'usage: $obj->Connect($node_name, $new_reg_obj)' if @_ != 2;
+
+ my ($node) = @_;
+ my ($result,$subhandle);
+
+ $result = RegConnectRegistry ($node, $self->{'handle'}, $subhandle);
+ $_[1] = _new($subhandle);
+
+ return 0 unless $_[1];
+ $! = Win32::GetLastError() unless $result;
+ return $result;
+}
+
+=item Create
+
+ $reg_obj->Create($sub_key_name, $new_reg_obj);
+
+Opens the subkey specified by $sub_key_name, returning the new registry
+object in $new_reg_obj. If the specified subkey doesn't exist, it is
+created.
+
+=cut
+
+sub Create {
+ my $self = shift;
+ die 'usage: $obj->Create($sub_key_name, $new_reg_obj)' if @_ != 2;
+
+ my ($subkey) = @_;
+ my ($result,$subhandle);
+
+ $result = RegCreateKey($self->{'handle'},$subkey,$subhandle);
+ $_[1] = _new ($subhandle);
+
+ return 0 unless $_[1];
+ $! = Win32::GetLastError() unless $result;
+ return $result;
+}
+
+=item SetValue
+
+ $reg_obj->SetValue($sub_key_name, $type, $value);
+
+Sets the default value for a subkey specified by $sub_key_name.
+
+=cut
+
+sub SetValue {
+ my $self = shift;
+ die 'usage: $obj->SetValue($subkey, $type, $value)' if @_ != 3;
+ my $result = RegSetValue($self->{'handle'}, @_);
+ $! = Win32::GetLastError() unless $result;
+ return $result;
+}
+
+=item SetValueEx
+
+ $reg_obj->SetValueEx($value_name, $reserved, $type, $value);
+
+Sets the value for the value name identified by $value_name
+in the key specified by $reg_obj.
+
+=cut
+
+sub SetValueEx {
+ my $self = shift;
+ die 'usage: $obj->SetValueEx($value_name, $reserved, $type, $value)' if @_ != 4;
+ my $result = RegSetValueEx($self->{'handle'}, @_);
+ $! = Win32::GetLastError() unless $result;
+ return $result;
+}
+
+=item QueryValue
+
+ $reg_obj->QueryValue($sub_key_name, $value);
+
+Gets the default value of the subkey specified by $sub_key_name.
+
+=cut
+
+sub QueryValue {
+ my $self = shift;
+ die 'usage: $obj->QueryValue($sub_key_name, $value)' if @_ != 2;
+ my $result = RegQueryValue($self->{'handle'}, $_[0], $_[1]);
+ $! = Win32::GetLastError() unless $result;
+ return $result;
+}
+
+=item QueryKey
+
+ $reg_obj->QueryKey($classref, $number_of_subkeys, $number_of_values);
+
+Gets information on a key specified by $reg_obj.
+
+=cut
+
+sub QueryKey {
+ my $garbage;
+ my $self = shift;
+ die 'usage: $obj->QueryKey($classref, $number_of_subkeys, $number_of_values)'
+ if @_ != 3;
+
+ my $result = RegQueryInfoKey($self->{'handle'}, $_[0],
+ $garbage, $garbage, $_[1],
+ $garbage, $garbage, $_[2],
+ $garbage, $garbage, $garbage, $garbage);
+
+ $! = Win32::GetLastError() unless $result;
+ return $result;
+}
+
+=item QueryValueEx
+
+ $reg_obj->QueryValueEx($value_name, $type, $value);
+
+Gets the value for the value name identified by $value_name
+in the key specified by $reg_obj.
+
+=cut
+
+sub QueryValueEx {
+ my $self = shift;
+ die 'usage: $obj->QueryValueEx($value_name, $type, $value)' if @_ != 3;
+ my $result = RegQueryValueEx($self->{'handle'}, $_[0], undef, $_[1], $_[2]);
+ $! = Win32::GetLastError() unless $result;
+ return $result;
+}
+
+=item GetKeys
+
+ my @keys;
+ $reg_obj->GetKeys(\@keys);
+
+Populates the supplied array reference with the names of all the keys
+within the registry object $reg_obj.
+
+=cut
+
+sub GetKeys {
+ my $self = shift;
+ die 'usage: $obj->GetKeys($arrayref)' if @_ != 1 or ref($_[0]) ne 'ARRAY';
+
+ my ($result, $i, $keyname);
+ $keyname = "DummyVal";
+ $i = 0;
+ $result = 1;
+
+ while ( $result ) {
+ $result = RegEnumKey( $self->{'handle'},$i++, $keyname );
+ if ($result) {
+ push( @{$_[0]}, $keyname );
+ }
+ }
+ return(1);
+}
+
+=item GetValues
+
+ my %values;
+ $reg_obj->GetValues(\%values);
+
+Populates the supplied hash reference with entries of the form
+
+ $value_name => [ $value_name, $type, $data ]
+
+for each value in the registry object $reg_obj.
+
+=cut
+
+sub GetValues {
+ my $self = shift;
+ die 'usage: $obj->GetValues($hashref)' if @_ != 1;
+
+ my ($result,$name,$type,$data,$i);
+ $name = "DummyVal";
+ $i = 0;
+ while ( $result=RegEnumValue( $self->{'handle'},
+ $i++,
+ $name,
+ undef,
+ $type,
+ $data ))
+ {
+ $_[0]->{$name} = [ $name, $type, $data ];
+ }
+ return(1);
+}
+
+=item DeleteKey
+
+ $reg_obj->DeleteKey($sub_key_name);
+
+Deletes a subkey specified by $sub_key_name from the registry.
+
+=cut
+
+sub DeleteKey {
+ my $self = shift;
+ die 'usage: $obj->DeleteKey($sub_key_name)' if @_ != 1;
+ my $result = RegDeleteKey($self->{'handle'}, @_);
+ $! = Win32::GetLastError() unless $result;
+ return $result;
+}
+
+=item DeleteValue
+
+ $reg_obj->DeleteValue($value_name);
+
+Deletes a value identified by $value_name from the registry.
+
+=cut
+
+sub DeleteValue {
+ my $self = shift;
+ die 'usage: $obj->DeleteValue($value_name)' if @_ != 1;
+ my $result = RegDeleteValue($self->{'handle'}, @_);
+ $! = Win32::GetLastError() unless $result;
+ return $result;
+}
+
+=item Save
+
+ $reg_obj->Save($filename);
+
+Saves the hive specified by $reg_obj to a file.
+
+=cut
+
+sub Save {
+ my $self = shift;
+ die 'usage: $obj->Save($filename)' if @_ != 1;
+ my $result = RegSaveKey($self->{'handle'}, @_);
+ $! = Win32::GetLastError() unless $result;
+ return $result;
+}
+
+=item Load
+
+ $reg_obj->Load($sub_key_name, $file_name);
+
+Loads a key specified by $sub_key_name from a file.
+
+=cut
+
+sub Load {
+ my $self = shift;
+ die 'usage: $obj->Load($sub_key_name, $file_name)' if @_ != 2;
+ my $result = RegLoadKey($self->{'handle'}, @_);
+ $! = Win32::GetLastError() unless $result;
+ return $result;
+}
+
+=item UnLoad
+
+ $reg_obj->Unload($sub_key_name);
+
+Unloads a registry hive.
+
+=cut
+
+sub UnLoad {
+ my $self = shift;
+ die 'usage: $obj->UnLoad($sub_key_name)' if @_ != 1;
+ my $result = RegUnLoadKey($self->{'handle'}, @_);
+ $! = Win32::GetLastError() unless $result;
+ return $result;
+}
+
+1;
+__END__
diff --git a/Master/tlpkg/installer/perllib/Win32/TieRegistry.pm b/Master/tlpkg/installer/perllib/Win32/TieRegistry.pm
new file mode 100644
index 00000000000..0abbbddb6b8
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/Win32/TieRegistry.pm
@@ -0,0 +1,3801 @@
+# Win32/TieRegistry.pm -- Perl module to easily use a Registry
+# (on Win32 systems so far).
+# by Tye McQueen, tye@metronet.com, see http://www.metronet.com/~tye/.
+
+#
+# Skip to "=head" line for user documentation.
+#
+
+
+package Win32::TieRegistry;
+
+
+use strict;
+use vars qw( $PACK $VERSION @ISA @EXPORT @EXPORT_OK );
+
+$PACK= "Win32::TieRegistry"; # Used in error messages.
+$VERSION= '0.26';
+
+
+use Carp;
+
+require Tie::Hash;
+@ISA= qw(Tie::Hash);
+
+# Required other modules:
+use Win32API::Registry 0.12 qw( :KEY_ :HKEY_ :REG_ );
+
+#Optional other modules:
+use vars qw( $_NoMoreItems $_FileNotFound $_TooSmall $_MoreData $_SetDualVar );
+
+if( eval { require Win32::WinError } ) {
+ $_NoMoreItems= Win32::WinError::constant("ERROR_NO_MORE_ITEMS",0);
+ $_FileNotFound= Win32::WinError::constant("ERROR_FILE_NOT_FOUND",0);
+ $_TooSmall= Win32::WinError::constant("ERROR_INSUFFICIENT_BUFFER",0);
+ $_MoreData= Win32::WinError::constant("ERROR_MORE_DATA",0);
+} else {
+ $_NoMoreItems= "^No more data";
+ $_FileNotFound= "cannot find the file";
+ $_TooSmall= " data area passed to ";
+ $_MoreData= "^more data is avail";
+}
+if( $_SetDualVar= eval { require SetDualVar } ) {
+ import SetDualVar;
+}
+
+
+#Implementation details:
+# When opened:
+# HANDLE long; actual handle value
+# MACHINE string; name of remote machine ("" if local)
+# PATH list ref; machine-relative full path for this key:
+# ["LMachine","System","Disk"]
+# ["HKEY_LOCAL_MACHINE","System","Disk"]
+# DELIM char; delimiter used to separate subkeys (def="\\")
+# OS_DELIM char; always "\\" for Win32
+# ACCESS long; usually KEY_ALL_ACCESS, perhaps KEY_READ, etc.
+# ROOTS string; var name for "Lmachine"->HKEY_LOCAL_MACHINE map
+# FLAGS int; bits to control certain options
+# Often:
+# VALUES ref to list of value names (data/type never cached)
+# SUBKEYS ref to list of subkey names
+# SUBCLASSES ref to list of subkey classes
+# SUBTIMES ref to list of subkey write times
+# MEMBERS ref to list of subkey_name.DELIM's, DELIM.value_name's
+# MEMBHASH hash ref to with MEMBERS as keys and 1's as values
+# Once Key "Info" requested:
+# Class CntSubKeys CntValues MaxSubKeyLen MaxSubClassLen
+# MaxValNameLen MaxValDataLen SecurityLen LastWrite
+# If is tied to a hash and iterating over key values:
+# PREVIDX int; index of last MEMBERS element return
+# If is the key object returned by Load():
+# UNLOADME list ref; information about Load()ed key
+# If is a subkey of a "loaded" key other than the one returned by Load():
+# DEPENDON obj ref; object that can't be destroyed before us
+
+
+#Package-local variables:
+
+# Option flag bits:
+use vars qw( $Flag_ArrVal $Flag_TieVal $Flag_DualTyp $Flag_DualBin
+ $Flag_FastDel $Flag_HexDWord $Flag_Split $Flag_FixNulls );
+$Flag_ArrVal= 0x0001;
+$Flag_TieVal= 0x0002;
+$Flag_FastDel= 0x0004;
+$Flag_HexDWord= 0x0008;
+$Flag_Split= 0x0010;
+$Flag_DualTyp= 0x0020;
+$Flag_DualBin= 0x0040;
+$Flag_FixNulls= 0x0080;
+
+
+use vars qw( $RegObj %_Roots %RegHash $Registry );
+
+# Short-hand for HKEY_* constants:
+%_Roots= (
+ "Classes" => HKEY_CLASSES_ROOT,
+ "CUser" => HKEY_CURRENT_USER,
+ "LMachine" => HKEY_LOCAL_MACHINE,
+ "Users" => HKEY_USERS,
+ "PerfData" => HKEY_PERFORMANCE_DATA, # Too picky to be useful
+ "CConfig" => HKEY_CURRENT_CONFIG,
+ "DynData" => HKEY_DYN_DATA, # Too picky to be useful
+);
+
+# Basic master Registry object:
+$RegObj= {};
+@$RegObj{qw( HANDLE MACHINE PATH DELIM OS_DELIM ACCESS FLAGS ROOTS )}= (
+ "NONE", "", [], "\\", "\\",
+ KEY_READ|KEY_WRITE, $Flag_HexDWord|$Flag_FixNulls, "${PACK}::_Roots" );
+$RegObj->{FLAGS} |= $Flag_DualTyp|$Flag_DualBin if $_SetDualVar;
+bless $RegObj;
+
+# Fill cache for master Registry object:
+@$RegObj{qw( VALUES SUBKEYS SUBCLASSES SUBTIMES )}= (
+ [], [ keys(%_Roots) ], [], [] );
+grep( s#$#$RegObj->{DELIM}#,
+ @{ $RegObj->{MEMBERS}= [ @{$RegObj->{SUBKEYS}} ] } );
+@$RegObj{qw( Class MaxSubKeyLen MaxSubClassLen MaxValNameLen
+ MaxValDataLen SecurityLen LastWrite CntSubKeys CntValues )}=
+ ( "", 0, 0, 0, 0, 0, 0, 0, 0 );
+
+# Create master Registry tied hash:
+$RegObj->Tie( \%RegHash );
+
+# Create master Registry combination object and tied hash reference:
+$Registry= \%RegHash;
+bless $Registry;
+
+
+# Preloaded methods go here.
+
+
+# Map option names to name of subroutine that controls that option:
+use vars qw( @_opt_subs %_opt_subs );
+@_opt_subs= qw( Delimiter ArrayValues TieValues SplitMultis DWordsToHex
+ FastDelete FixSzNulls DualTypes DualBinVals AllowLoad AllowSave );
+@_opt_subs{@_opt_subs}= @_opt_subs;
+
+sub import
+{
+ my $pkg= shift(@_);
+ my $level= $Exporter::ExportLevel;
+ my $expto= caller($level);
+ my @export= ();
+ my @consts= ();
+ my $registry= $Registry->Clone;
+ local( $_ );
+ while( @_ ) {
+ $_= shift(@_);
+ if( /^\$(\w+::)*\w+$/ ) {
+ push( @export, "ObjVar" ) if /^\$RegObj$/;
+ push( @export, $_ );
+ } elsif( /^\%(\w+::)*\w+$/ ) {
+ push( @export, $_ );
+ } elsif( /^[$%]/ ) {
+ croak "${PACK}->import: Invalid variable name ($_)";
+ } elsif( /^:/ || /^(H?KEY|REG)_/ ) {
+ push( @consts, $_ );
+ } elsif( ! @_ ) {
+ croak "${PACK}->import: Missing argument after option ($_)";
+ } elsif( exists $_opt_subs{$_} ) {
+ $_= $_opt_subs{$_};
+ $registry->$_( shift(@_) );
+ } elsif( /^TiedRef$/ ) {
+ $_= shift(@_);
+ if( ! ref($_) && /^(\$?)(\w+::)*\w+$/ ) {
+ $_= '$'.$_ unless '$' eq $1;
+ } elsif( "SCALAR" ne ref($_) ) {
+ croak "${PACK}->import: Invalid var after TiedRef ($_)";
+ }
+ push( @export, $_ );
+ } elsif( /^TiedHash$/ ) {
+ $_= shift(@_);
+ if( ! ref($_) && /^(\%?)(\w+::)*\w+$/ ) {
+ $_= '%'.$_ unless '%' eq $1;
+ } elsif( "HASH" ne ref($_) ) {
+ croak "${PACK}->import: Invalid var after TiedHash ($_)";
+ }
+ push( @export, $_ );
+ } elsif( /^ObjectRef$/ ) {
+ $_= shift(@_);
+ if( ! ref($_) && /^(\$?)(\w+::)*\w+$/ ) {
+ push( @export, "ObjVar" );
+ $_= '$'.$_ unless '$' eq $1;
+ } elsif( "SCALAR" eq ref($_) ) {
+ push( @export, "ObjRef" );
+ } else {
+ croak "${PACK}->import: Invalid var after ObjectRef ($_)";
+ }
+ push( @export, $_ );
+ } elsif( /^ExportLevel$/ ) {
+ $level= shift(@_);
+ $expto= caller($level);
+ } elsif( /^ExportTo$/ ) {
+ undef $level;
+ $expto= caller($level);
+ } else {
+ croak "${PACK}->import: Invalid option ($_)";
+ }
+ }
+ Win32API::Registry->export( $expto, @consts ) if @consts;
+ @export= ('$Registry') unless @export;
+ while( @export ) {
+ $_= shift( @export );
+ if( /^\$((?:\w+::)*)(\w+)$/ ) {
+ my( $pack, $sym )= ( $1, $2 );
+ $pack= $expto unless defined($pack) && "" ne $pack;
+ no strict 'refs';
+ *{"${pack}::$sym"}= \${"${pack}::$sym"};
+ ${"${pack}::$sym"}= $registry;
+ } elsif( /^\%((?:\w+::)*)(\w+)$/ ) {
+ my( $pack, $sym )= ( $1, $2 );
+ $pack= $expto unless defined($pack) && "" ne $pack;
+ no strict 'refs';
+ *{"${pack}::$sym"}= \%{"${pack}::$sym"};
+ $registry->Tie( \%{"${pack}::$sym"} );
+ } elsif( "SCALAR" eq ref($_) ) {
+ $$_= $registry;
+ } elsif( "HASH" eq ref($_) ) {
+ $registry->Tie( $_ );
+ } elsif( /^ObjVar$/ ) {
+ $_= shift( @_ );
+ /^\$((?:\w+::)*)(\w+)$/;
+ my( $pack, $sym )= ( $1, $2 );
+ $pack= $expto unless defined($pack) && "" ne $pack;
+ no strict 'refs';
+ *{"${pack}::$sym"}= \${"${pack}::$sym"};
+ ${"${pack}::$sym"}= $registry->ObjectRef;
+ } elsif( /^ObjRef$/ ) {
+ ${shift(@_)}= $registry->ObjectRef;
+ } else {
+ die "Impossible var to export ($_)";
+ }
+ }
+}
+
+
+use vars qw( @_new_Opts %_new_Opts );
+@_new_Opts= qw( ACCESS DELIM MACHINE DEPENDON );
+@_new_Opts{@_new_Opts}= (1) x @_new_Opts;
+
+sub _new
+{
+ my $this= shift( @_ );
+ $this= tied(%$this) if ref($this) && tied(%$this);
+ my $class= ref($this) || $this;
+ my $self= {};
+ my( $handle, $rpath, $opts )= @_;
+ if( @_ < 2 || "ARRAY" ne ref($rpath) || 3 < @_
+ || 3 == @_ && "HASH" ne ref($opts) ) {
+ croak "Usage: ${PACK}->_new( \$handle, \\\@path, {OPT=>VAL,...} );\n",
+ " options: @_new_Opts\nCalled";
+ }
+ @$self{qw( HANDLE PATH )}= ( $handle, $rpath );
+ @$self{qw( MACHINE ACCESS DELIM OS_DELIM ROOTS FLAGS )}=
+ ( $this->Machine, $this->Access, $this->Delimiter,
+ $this->OS_Delimiter, $this->_Roots, $this->_Flags );
+ if( ref($opts) ) {
+ my @err= grep( ! $_new_Opts{$_}, keys(%$opts) );
+ @err and croak "${PACK}->_new: Invalid options (@err)";
+ @$self{ keys(%$opts) }= values(%$opts);
+ }
+ bless $self, $class;
+ return $self;
+}
+
+
+sub _split
+{
+ my $self= shift( @_ );
+ $self= tied(%$self) if tied(%$self);
+ my $path= shift( @_ );
+ my $delim= @_ ? shift(@_) : $self->Delimiter;
+ my $list= [ split( /\Q$delim/, $path ) ];
+ return $list;
+}
+
+
+sub _rootKey
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ my $keyPath= shift(@_);
+ my $delim= @_ ? shift(@_) : $self->Delimiter;
+ my( $root, $subPath );
+ if( "ARRAY" eq ref($keyPath) ) {
+ $subPath= $keyPath;
+ } else {
+ $subPath= $self->_split( $keyPath, $delim );
+ }
+ $root= shift( @$subPath );
+ if( $root =~ /^HKEY_/ ) {
+ my $handle= Win32API::Registry::constant($root,0);
+ $handle or croak "Invalid HKEY_ constant ($root): $!";
+ return( $self->_new( $handle, [$root], {DELIM=>$delim} ),
+ $subPath );
+ } elsif( $root =~ /^([-+]|0x)?\d/ ) {
+ return( $self->_new( $root, [sprintf("0x%lX",$root)],
+ {DELIM=>$delim} ),
+ $subPath );
+ } else {
+ my $roots= $self->Roots;
+ if( $roots->{$root} ) {
+ return( $self->_new( $roots->{$root}, [$root], {DELIM=>$delim} ),
+ $subPath );
+ }
+ croak "No such root key ($root)";
+ }
+}
+
+
+sub _open
+{
+ my $this= shift(@_);
+ $this= tied(%$this) if ref($this) && tied(%$this);
+ my $subPath= shift(@_);
+ my $sam= @_ ? shift(@_) : $this->Access;
+ my $subKey= join( $this->OS_Delimiter, @$subPath );
+ my $handle= 0;
+ $this->RegOpenKeyEx( $subKey, 0, $sam, $handle )
+ or return ();
+ return $this->_new( $handle, [ @{$this->_Path}, @$subPath ],
+ { ACCESS=>$sam, ( defined($this->{UNLOADME}) ? ("DEPENDON",$this)
+ : defined($this->{DEPENDON}) ? ("DEPENDON",$this->{DEPENDON}) : () )
+ } );
+}
+
+
+sub ObjectRef
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ return $self;
+}
+
+
+sub _constant
+{
+ my( $name, $desc )= @_;
+ my $value= Win32API::Registry::constant( $name, 0 );
+ my $func= (caller(1))[3];
+ if( 0 == $value ) {
+ if( $! =~ /invalid/i ) {
+ croak "$func: Invalid $desc ($name)";
+ } elsif( 0 != $! ) {
+ croak "$func: \u$desc ($name) not support on this platform";
+ }
+ }
+ return $value;
+}
+
+
+sub _connect
+{
+ my $this= shift(@_);
+ $this= tied(%$this) if ref($this) && tied(%$this);
+ my $subPath= pop(@_);
+ $subPath= $this->_split( $subPath ) unless ref($subPath);
+ my $machine= @_ ? shift(@_) : shift(@$subPath);
+ my $handle= 0;
+ my( $temp )= $this->_rootKey( [@$subPath] );
+ $temp->RegConnectRegistry( $machine, $temp->Handle, $handle )
+ or return ();
+ my $self= $this->_new( $handle, [shift(@$subPath)], {MACHINE=>$machine} );
+ return( $self, $subPath );
+}
+
+
+use vars qw( @Connect_Opts %Connect_Opts );
+@Connect_Opts= qw(Access Delimiter);
+@Connect_Opts{@Connect_Opts}= (1) x @Connect_Opts;
+
+sub Connect
+{
+ my $this= shift(@_);
+ my $tied= ref($this) && tied(%$this);
+ $this= tied(%$this) if $tied;
+ my( $machine, $key, $opts )= @_;
+ my $delim= "";
+ my $sam;
+ my $subPath;
+ if( @_ < 2 || 3 < @_
+ || 3 == @_ && "HASH" ne ref($opts) ) {
+ croak "Usage: \$obj= ${PACK}->Connect(",
+ " \$Machine, \$subKey, { OPT=>VAL,... } );\n",
+ " options: @Connect_Opts\nCalled";
+ }
+ if( ref($opts) ) {
+ my @err= grep( ! $Connect_Opts{$_}, keys(%$opts) );
+ @err and croak "${PACK}->Connect: Invalid options (@err)";
+ }
+ $delim= "$opts->{Delimiter}" if defined($opts->{Delimiter});
+ $delim= $this->Delimiter if "" eq $delim;
+ $sam= defined($opts->{Access}) ? $opts->{Access} : $this->Access;
+ $sam= _constant($sam,"key access type") if $sam =~ /^KEY_/;
+ ( $this, $subPath )= $this->_connect( $machine, $key );
+ return () unless defined($this);
+ my $self= $this->_open( $subPath, $sam );
+ return () unless defined($self);
+ $self->Delimiter( $delim );
+ $self= $self->TiedRef if $tied;
+ return $self;
+}
+
+
+my @_newVirtual_keys= qw( MEMBERS VALUES SUBKEYS SUBTIMES SUBCLASSES
+ Class SecurityLen LastWrite CntValues CntSubKeys
+ MaxValNameLen MaxValDataLen MaxSubKeyLen MaxSubClassLen );
+
+sub _newVirtual
+{
+ my $self= shift(@_);
+ my( $rPath, $root, $opts )= @_;
+ my $new= $self->_new( "NONE", $rPath, $opts )
+ or return ();
+ @{$new}{@_newVirtual_keys}= @{$root->ObjectRef}{@_newVirtual_keys};
+ return $new;
+}
+
+
+#$key= new Win32::TieRegistry "LMachine/System/Disk";
+#$key= new Win32::TieRegistry "//Server1/LMachine/System/Disk";
+#Win32::TieRegistry->new( HKEY_LOCAL_MACHINE, {DELIM=>"/",ACCESS=>KEY_READ} );
+#Win32::TieRegistry->new( [ HKEY_LOCAL_MACHINE, ".../..." ], {DELIM=>$DELIM} );
+#$key->new( ... );
+
+use vars qw( @new_Opts %new_Opts );
+@new_Opts= qw(Access Delimiter);
+@new_Opts{@new_Opts}= (1) x @new_Opts;
+
+sub new
+{
+ my $this= shift( @_ );
+ $this= tied(%$this) if ref($this) && tied(%$this);
+ if( ! ref($this) ) {
+ no strict "refs";
+ my $self= ${"${this}::Registry"};
+ croak "${this}->new failed since ${PACK}::new sees that ",
+ "\$${this}::Registry is not an object."
+ if ! ref($self);
+ $this= $self->Clone;
+ }
+ my( $subKey, $opts )= @_;
+ my $delim= "";
+ my $dlen;
+ my $sam;
+ my $subPath;
+ if( @_ < 1 || 2 < @_
+ || 2 == @_ && "HASH" ne ref($opts) ) {
+ croak "Usage: \$obj= ${PACK}->new( \$subKey, { OPT=>VAL,... } );\n",
+ " options: @new_Opts\nCalled";
+ }
+ if( defined($opts) ) {
+ my @err= grep( ! $new_Opts{$_}, keys(%$opts) );
+ @err and die "${PACK}->new: Invalid options (@err)";
+ }
+ $delim= "$opts->{Delimiter}" if defined($opts->{Delimiter});
+ $delim= $this->Delimiter if "" eq $delim;
+ $dlen= length($delim);
+ $sam= defined($opts->{Access}) ? $opts->{Access} : $this->Access;
+ $sam= _constant($sam,"key access type") if $sam =~ /^KEY_/;
+ if( "ARRAY" eq ref($subKey) ) {
+ $subPath= $subKey;
+ if( "NONE" eq $this->Handle && @$subPath ) {
+ ( $this, $subPath )= $this->_rootKey( $subPath );
+ }
+ } elsif( $delim x 2 eq substr($subKey,0,2*$dlen) ) {
+ my $path= $this->_split( substr($subKey,2*$dlen), $delim );
+ my $mach= shift(@$path);
+ if( ! @$path ) {
+ return $this->_newVirtual( $path, $Registry,
+ {MACHINE=>$mach,DELIM=>$delim,ACCESS=>$sam} );
+ }
+ ( $this, $subPath )= $this->_connect( $mach, $path );
+ return () if ! defined($this);
+ if( 0 == @$subPath ) {
+ $this->Delimiter( $delim );
+ return $this;
+ }
+ } elsif( $delim eq substr($subKey,0,$dlen) ) {
+ ( $this, $subPath )= $this->_rootKey( substr($subKey,$dlen), $delim );
+ } elsif( "NONE" eq $this->Handle && "" ne $subKey ) {
+ my( $mach )= $this->Machine;
+ if( $mach ) {
+ ( $this, $subPath )= $this->_connect( $mach, $subKey );
+ } else {
+ ( $this, $subPath )= $this->_rootKey( $subKey, $delim );
+ }
+ } else {
+ $subPath= $this->_split( $subKey, $delim );
+ }
+ return () unless defined($this);
+ if( 0 == @$subPath && "NONE" eq $this->Handle ) {
+ return $this->_newVirtual( $this->_Path, $this,
+ { DELIM=>$delim, ACCESS=>$sam } );
+ }
+ my $self= $this->_open( $subPath, $sam );
+ return () unless defined($self);
+ $self->Delimiter( $delim );
+ return $self;
+}
+
+
+sub Open
+{
+ my $self= shift(@_);
+ my $tied= ref($self) && tied(%$self);
+ $self= tied(%$self) if $tied;
+ $self= $self->new( @_ );
+ $self= $self->TiedRef if defined($self) && $tied;
+ return $self;
+}
+
+
+sub Clone
+{
+ my $self= shift( @_ );
+ my $new= $self->Open("");
+ return $new;
+}
+
+
+{ my @flush;
+ sub Flush
+ {
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ my( $flush )= shift(@_);
+ @_ and croak "Usage: \$key->Flush( \$bFlush );";
+ return 0 if "NONE" eq $self->Handle;
+ @flush= qw( VALUES SUBKEYS SUBCLASSES SUBTIMES MEMBERS Class
+ CntSubKeys CntValues MaxSubKeyLen MaxSubClassLen
+ MaxValNameLen MaxValDataLen SecurityLen LastWrite PREVIDX )
+ unless @flush;
+ delete( @$self{@flush} );
+ if( defined($flush) && $flush ) {
+ return $self->RegFlushKey();
+ } else {
+ return 1;
+ }
+ }
+}
+
+
+sub _DualVal
+{
+ my( $hRef, $num )= @_;
+ if( $_SetDualVar && $$hRef{$num} ) {
+ &SetDualVar( $num, "$$hRef{$num}", 0+$num );
+ }
+ return $num;
+}
+
+
+use vars qw( @_RegDataTypes %_RegDataTypes );
+@_RegDataTypes= qw( REG_SZ REG_EXPAND_SZ REG_BINARY REG_LINK REG_MULTI_SZ
+ REG_DWORD_LITTLE_ENDIAN REG_DWORD_BIG_ENDIAN REG_DWORD
+ REG_RESOURCE_LIST REG_FULL_RESOURCE_DESCRIPTOR
+ REG_RESOURCE_REQUIREMENTS_LIST REG_NONE );
+# Make sure that REG_DWORD appears _after_ other REG_DWORD_*
+# items above and that REG_NONE appears _last_.
+foreach( @_RegDataTypes ) {
+ $_RegDataTypes{Win32API::Registry::constant($_,0)}= $_;
+}
+
+sub GetValue
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ 1 == @_ or croak "Usage: (\$data,\$type)= \$key->GetValue('ValName');";
+ my( $valName )= @_;
+ my( $valType, $valData, $dLen )= (0,"",0);
+ return () if "NONE" eq $self->Handle;
+ $self->RegQueryValueEx( $valName, [], $valType, $valData,
+ $dLen= ( defined($self->{MaxValDataLen}) ? $self->{MaxValDataLen} : 0 )
+ ) or return ();
+ if( REG_DWORD == $valType ) {
+ my $val= unpack("L",$valData);
+ $valData= sprintf "0x%08.8lX", $val if $self->DWordsToHex;
+ &SetDualVar( $valData, $valData, $val ) if $self->DualBinVals
+ } elsif( REG_BINARY == $valType && length($valData) <= 4 ) {
+ &SetDualVar( $valData, $valData, hex reverse unpack("h*",$valData) )
+ if $self->DualBinVals;
+ } elsif( ( REG_SZ == $valType || REG_EXPAND_SZ == $valType )
+ && $self->FixSzNulls ) {
+ substr($valData,-1)= "" if "\0" eq substr($valData,-1);
+ } elsif( REG_MULTI_SZ == $valType && $self->SplitMultis ) {
+ ## $valData =~ s/\0\0$//; # Why does this often fail??
+ substr($valData,-2)= "" if "\0\0" eq substr($valData,-2);
+ $valData= [ split( /\0/, $valData, -1 ) ]
+ }
+ if( ! wantarray ) {
+ return $valData;
+ } elsif( ! $self->DualTypes ) {
+ return( $valData, $valType );
+ } else {
+ return( $valData, _DualVal( \%_RegDataTypes, $valType ) );
+ }
+}
+
+
+sub _ErrNum
+{
+ # return $^E;
+ return Win32::GetLastError();
+}
+
+
+sub _ErrMsg
+{
+ # return $^E;
+ return Win32::FormatMessage( Win32::GetLastError() );
+}
+
+sub _Err
+{
+ my $err;
+ # return $^E;
+ return _ErrMsg if ! $_SetDualVar;
+ return &SetDualVar( $err, _ErrMsg, _ErrNum );
+}
+
+sub _NoMoreItems
+{
+ return
+ $_NoMoreItems =~ /^\d/
+ ? _ErrNum == $_NoMoreItems
+ : _ErrMsg =~ /$_NoMoreItems/io;
+}
+
+
+sub _FileNotFound
+{
+ return
+ $_FileNotFound =~ /^\d/
+ ? _ErrNum == $_FileNotFound
+ : _ErrMsg =~ /$_FileNotFound/io;
+}
+
+
+sub _TooSmall
+{
+ return
+ $_TooSmall =~ /^\d/
+ ? _ErrNum == $_TooSmall
+ : _ErrMsg =~ /$_TooSmall/io;
+}
+
+
+sub _MoreData
+{
+ return
+ $_MoreData =~ /^\d/
+ ? _ErrNum == $_MoreData
+ : _ErrMsg =~ /$_MoreData/io;
+}
+
+
+sub _enumValues
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ my( @names )= ();
+ my $pos= 0;
+ my $name= "";
+ my $nlen= 1+$self->Information("MaxValNameLen");
+ while( $self->RegEnumValue($pos++,$name,$nlen,[],[],[],[]) ) {
+ push( @names, $name );
+ }
+ if( ! _NoMoreItems() ) {
+ return ();
+ }
+ $self->{VALUES}= \@names;
+ return 1;
+}
+
+
+sub ValueNames
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ @_ and croak "Usage: \@names= \$key->ValueNames;";
+ $self->_enumValues unless $self->{VALUES};
+ return @{$self->{VALUES}};
+}
+
+
+sub _enumSubKeys
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ my( @subkeys, @classes, @times )= ();
+ my $pos= 0;
+ my( $subkey, $class, $time )= ("","","");
+ my( $namSiz, $clsSiz )= $self->Information(
+ qw( MaxSubKeyLen MaxSubClassLen ));
+ $namSiz++; $clsSiz++;
+ while( $self->RegEnumKeyEx(
+ $pos++, $subkey, $namSiz, [], $class, $clsSiz, $time ) ) {
+ push( @subkeys, $subkey );
+ push( @classes, $class );
+ push( @times, $time );
+ }
+ if( ! _NoMoreItems() ) {
+ return ();
+ }
+ $self->{SUBKEYS}= \@subkeys;
+ $self->{SUBCLASSES}= \@classes;
+ $self->{SUBTIMES}= \@times;
+ return 1;
+}
+
+
+sub SubKeyNames
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ @_ and croak "Usage: \@names= \$key->SubKeyNames;";
+ $self->_enumSubKeys unless $self->{SUBKEYS};
+ return @{$self->{SUBKEYS}};
+}
+
+
+sub SubKeyClasses
+{
+ my $self= shift(@_);
+ @_ and croak "Usage: \@classes= \$key->SubKeyClasses;";
+ $self->_enumSubKeys unless $self->{SUBCLASSES};
+ return @{$self->{SUBCLASSES}};
+}
+
+
+sub SubKeyTimes
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ @_ and croak "Usage: \@times= \$key->SubKeyTimes;";
+ $self->_enumSubKeys unless $self->{SUBTIMES};
+ return @{$self->{SUBTIMES}};
+}
+
+
+sub _MemberNames
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ @_ and croak "Usage: \$arrayRef= \$key->_MemberNames;";
+ if( ! $self->{MEMBERS} ) {
+ $self->_enumValues unless $self->{VALUES};
+ $self->_enumSubKeys unless $self->{SUBKEYS};
+ my( @members )= ( map( $_.$self->{DELIM}, @{$self->{SUBKEYS}} ),
+ map( $self->{DELIM}.$_, @{$self->{VALUES}} ) );
+ $self->{MEMBERS}= \@members;
+ }
+ return $self->{MEMBERS};
+}
+
+
+sub _MembersHash
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ @_ and croak "Usage: \$hashRef= \$key->_MembersHash;";
+ if( ! $self->{MEMBHASH} ) {
+ my $aRef= $self->_MemberNames;
+ $self->{MEMBHASH}= {};
+ @{$self->{MEMBHASH}}{@$aRef}= (1) x @$aRef;
+ }
+ return $self->{MEMBHASH};
+}
+
+
+sub MemberNames
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ @_ and croak "Usage: \@members= \$key->MemberNames;";
+ return @{$self->_MemberNames};
+}
+
+
+sub Information
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ my( $time, $nkeys, $nvals, $xsec, $xkey, $xcls, $xname, $xdata )=
+ ("",0,0,0,0,0,0,0);
+ my $clen= 8;
+ if( ! $self->RegQueryInfoKey( [], [], $nkeys, $xkey, $xcls,
+ $nvals, $xname, $xdata, $xsec, $time ) ) {
+ return ();
+ }
+ if( defined($self->{Class}) ) {
+ $clen= length($self->{Class});
+ } else {
+ $self->{Class}= "";
+ }
+ while( ! $self->RegQueryInfoKey( $self->{Class}, $clen,
+ [],[],[],[],[],[],[],[],[])
+ && _MoreData ) {
+ $clen *= 2;
+ }
+ my( %info );
+ @info{ qw( LastWrite CntSubKeys CntValues SecurityLen
+ MaxValDataLen MaxSubKeyLen MaxSubClassLen MaxValNameLen )
+ }= ( $time, $nkeys, $nvals, $xsec,
+ $xdata, $xkey, $xcls, $xname );
+ if( @_ ) {
+ my( %check );
+ @check{keys(%info)}= keys(%info);
+ my( @err )= grep( ! $check{$_}, @_ );
+ if( @err ) {
+ croak "${PACK}::Information- Invalid info requested (@err)";
+ }
+ return @info{@_};
+ } else {
+ return %info;
+ }
+}
+
+
+sub Delimiter
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ $self= $RegObj unless ref($self);
+ my( $oldDelim )= $self->{DELIM};
+ if( 1 == @_ && "" ne "$_[0]" ) {
+ delete $self->{MEMBERS};
+ delete $self->{MEMBHASH};
+ $self->{DELIM}= "$_[0]";
+ } elsif( 0 != @_ ) {
+ croak "Usage: \$oldDelim= \$key->Delimiter(\$newDelim);";
+ }
+ return $oldDelim;
+}
+
+
+sub Handle
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ @_ and croak "Usage: \$handle= \$key->Handle;";
+ $self= $RegObj unless ref($self);
+ return $self->{HANDLE};
+}
+
+
+sub Path
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ @_ and croak "Usage: \$path= \$key->Path;";
+ my $delim= $self->{DELIM};
+ $self= $RegObj unless ref($self);
+ if( "" eq $self->{MACHINE} ) {
+ return( $delim . join( $delim, @{$self->{PATH}} ) . $delim );
+ } else {
+ return( $delim x 2
+ . join( $delim, $self->{MACHINE}, @{$self->{PATH}} )
+ . $delim );
+ }
+}
+
+
+sub _Path
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ @_ and croak "Usage: \$arrRef= \$key->_Path;";
+ $self= $RegObj unless ref($self);
+ return $self->{PATH};
+}
+
+
+sub Machine
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ @_ and croak "Usage: \$machine= \$key->Machine;";
+ $self= $RegObj unless ref($self);
+ return $self->{MACHINE};
+}
+
+
+sub Access
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ @_ and croak "Usage: \$access= \$key->Access;";
+ $self= $RegObj unless ref($self);
+ return $self->{ACCESS};
+}
+
+
+sub OS_Delimiter
+{
+ my $self= shift(@_);
+ @_ and croak "Usage: \$backslash= \$key->OS_Delimiter;";
+ return $self->{OS_DELIM};
+}
+
+
+sub _Roots
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if ref($self) && tied(%$self);
+ @_ and croak "Usage: \$varName= \$key->_Roots;";
+ $self= $RegObj unless ref($self);
+ return $self->{ROOTS};
+}
+
+
+sub Roots
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if ref($self) && tied(%$self);
+ @_ and croak "Usage: \$hashRef= \$key->Roots;";
+ $self= $RegObj unless ref($self);
+ return eval "\\%$self->{ROOTS}";
+}
+
+
+sub TIEHASH
+{
+ my( $this )= shift(@_);
+ $this= tied(%$this) if ref($this) && tied(%$this);
+ my( $key )= @_;
+ if( 1 == @_ && ref($key) && "$key" =~ /=/ ) {
+ return $key; # $key is already an object (blessed reference).
+ }
+ return $this->new( @_ );
+}
+
+
+sub Tie
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ my( $hRef )= @_;
+ if( 1 != @_ || ! ref($hRef) || "$hRef" !~ /(^|=)HASH\(/ ) {
+ croak "Usage: \$key->Tie(\\\%hash);";
+ }
+ return tie %$hRef, ref($self), $self;
+}
+
+
+sub TiedRef
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ my $hRef= @_ ? shift(@_) : {};
+ return () if ! defined($self);
+ $self->Tie($hRef);
+ bless $hRef, ref($self);
+ return $hRef;
+}
+
+
+sub _Flags
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ my $oldFlags= $self->{FLAGS};
+ if( 1 == @_ ) {
+ $self->{FLAGS}= shift(@_);
+ } elsif( 0 != @_ ) {
+ croak "Usage: \$oldBits= \$key->_Flags(\$newBits);";
+ }
+ return $oldFlags;
+}
+
+
+sub ArrayValues
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ my $oldFlag= $Flag_ArrVal == ( $Flag_ArrVal & $self->{FLAGS} );
+ if( 1 == @_ ) {
+ my $bool= shift(@_);
+ if( $bool ) {
+ $self->{FLAGS} |= $Flag_ArrVal;
+ } else {
+ $self->{FLAGS} &= ~( $Flag_ArrVal | $Flag_TieVal );
+ }
+ } elsif( 0 != @_ ) {
+ croak "Usage: \$oldBool= \$key->ArrayValues(\$newBool);";
+ }
+ return $oldFlag;
+}
+
+
+sub TieValues
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ my $oldFlag= $Flag_TieVal == ( $Flag_TieVal & $self->{FLAGS} );
+ if( 1 == @_ ) {
+ my $bool= shift(@_);
+ if( $bool ) {
+ croak "${PACK}->TieValues cannot be enabled with this version";
+ $self->{FLAGS} |= $Flag_TieVal;
+ } else {
+ $self->{FLAGS} &= ~$Flag_TieVal;
+ }
+ } elsif( 0 != @_ ) {
+ croak "Usage: \$oldBool= \$key->TieValues(\$newBool);";
+ }
+ return $oldFlag;
+}
+
+
+sub FastDelete
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ my $oldFlag= $Flag_FastDel == ( $Flag_FastDel & $self->{FLAGS} );
+ if( 1 == @_ ) {
+ my $bool= shift(@_);
+ if( $bool ) {
+ $self->{FLAGS} |= $Flag_FastDel;
+ } else {
+ $self->{FLAGS} &= ~$Flag_FastDel;
+ }
+ } elsif( 0 != @_ ) {
+ croak "Usage: \$oldBool= \$key->FastDelete(\$newBool);";
+ }
+ return $oldFlag;
+}
+
+
+sub SplitMultis
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ my $oldFlag= $Flag_Split == ( $Flag_Split & $self->{FLAGS} );
+ if( 1 == @_ ) {
+ my $bool= shift(@_);
+ if( $bool ) {
+ $self->{FLAGS} |= $Flag_Split;
+ } else {
+ $self->{FLAGS} &= ~$Flag_Split;
+ }
+ } elsif( 0 != @_ ) {
+ croak "Usage: \$oldBool= \$key->SplitMultis(\$newBool);";
+ }
+ return $oldFlag;
+}
+
+
+sub DWordsToHex
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ my $oldFlag= $Flag_HexDWord == ( $Flag_HexDWord & $self->{FLAGS} );
+ if( 1 == @_ ) {
+ my $bool= shift(@_);
+ if( $bool ) {
+ $self->{FLAGS} |= $Flag_HexDWord;
+ } else {
+ $self->{FLAGS} &= ~$Flag_HexDWord;
+ }
+ } elsif( 0 != @_ ) {
+ croak "Usage: \$oldBool= \$key->DWordsToHex(\$newBool);";
+ }
+ return $oldFlag;
+}
+
+
+sub FixSzNulls
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ my $oldFlag= $Flag_FixNulls == ( $Flag_FixNulls & $self->{FLAGS} );
+ if( 1 == @_ ) {
+ my $bool= shift(@_);
+ if( $bool ) {
+ $self->{FLAGS} |= $Flag_FixNulls;
+ } else {
+ $self->{FLAGS} &= ~$Flag_FixNulls;
+ }
+ } elsif( 0 != @_ ) {
+ croak "Usage: \$oldBool= \$key->FixSzNulls(\$newBool);";
+ }
+ return $oldFlag;
+}
+
+
+sub DualTypes
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ my $oldFlag= $Flag_DualTyp == ( $Flag_DualTyp & $self->{FLAGS} );
+ if( 1 == @_ ) {
+ my $bool= shift(@_);
+ if( $bool ) {
+ croak "${PACK}->DualTypes cannot be enabled since ",
+ "SetDualVar module not installed"
+ unless $_SetDualVar;
+ $self->{FLAGS} |= $Flag_DualTyp;
+ } else {
+ $self->{FLAGS} &= ~$Flag_DualTyp;
+ }
+ } elsif( 0 != @_ ) {
+ croak "Usage: \$oldBool= \$key->DualTypes(\$newBool);";
+ }
+ return $oldFlag;
+}
+
+
+sub DualBinVals
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ my $oldFlag= $Flag_DualBin == ( $Flag_DualBin & $self->{FLAGS} );
+ if( 1 == @_ ) {
+ my $bool= shift(@_);
+ if( $bool ) {
+ croak "${PACK}->DualBinVals cannot be enabled since ",
+ "SetDualVar module not installed"
+ unless $_SetDualVar;
+ $self->{FLAGS} |= $Flag_DualBin;
+ } else {
+ $self->{FLAGS} &= ~$Flag_DualBin;
+ }
+ } elsif( 0 != @_ ) {
+ croak "Usage: \$oldBool= \$key->DualBinVals(\$newBool);";
+ }
+ return $oldFlag;
+}
+
+
+sub GetOptions
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ my( $opt, $meth );
+ if( ! @_ || 1 == @_ && "HASH" eq ref($_[0]) ) {
+ my $href= @_ ? $_[0] : {};
+ foreach $opt ( grep !/^Allow/, @_opt_subs ) {
+ $meth= $_opt_subs{$opt};
+ $href->{$opt}= $self->$meth();
+ }
+ return @_ ? $self : $href;
+ }
+ my @old;
+ foreach $opt ( @_ ) {
+ $meth= $_opt_subs{$opt};
+ if( defined $meth ) {
+ if( $opt eq "AllowLoad" || $opt eq "AllowSave" ) {
+ croak "${PACK}->GetOptions: Getting current setting of $opt ",
+ "not supported in this release";
+ }
+ push( @old, $self->$meth() );
+ } else {
+ croak "${PACK}->GetOptions: Invalid option ($opt) ",
+ "not one of ( ", join(" ",grep !/^Allow/, @_opt_subs), " )";
+ }
+ }
+ return wantarray ? @old : $old[-1];
+}
+
+
+sub SetOptions
+{
+ my $self= shift(@_);
+ # Don't get object if hash ref so "ref" returns original ref.
+ my( $opt, $meth, @old );
+ while( @_ ) {
+ $opt= shift(@_);
+ $meth= $_opt_subs{$opt};
+ if( ! @_ ) {
+ croak "${PACK}->SetOptions: Option value missing ",
+ "after option name ($opt)";
+ } elsif( defined $meth ) {
+ push( @old, $self->$meth( shift(@_) ) );
+ } elsif( $opt eq substr("reference",0,length($opt)) ) {
+ shift(@_) if @_;
+ push( @old, $self );
+ } else {
+ croak "${PACK}->SetOptions: Invalid option ($opt) ",
+ "not one of ( @_opt_subs )";
+ }
+ }
+ return wantarray ? @old : $old[-1];
+}
+
+
+sub _parseTiedEnt
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ my $ent= shift(@_);
+ my $delim= shift(@_);
+ my $dlen= length( $delim );
+ my $parent= @_ ? shift(@_) : 0;
+ my $off;
+ if( $delim x 2 eq substr($ent,0,2*$dlen) && "NONE" eq $self->Handle ) {
+ if( 0 <= ( $off= index( $ent, $delim x 2, 2*$dlen ) ) ) {
+ return( substr( $ent, 0, $off ), substr( $ent, 2*$dlen+$off ) );
+ } elsif( $delim eq substr($ent,-$dlen) ) {
+ return( substr($ent,0,-$dlen) );
+ } elsif( 2*$dlen <= ( $off= rindex( $ent, $delim ) ) ) {
+ return( substr( $ent, 0, $off ),
+ undef, substr( $ent, $dlen+$off ) );
+ } elsif( $parent ) {
+ return();
+ } else {
+ return( $ent );
+ }
+ } elsif( $delim eq substr($ent,0,$dlen) && "NONE" ne $self->Handle ) {
+ return( undef, substr($ent,$dlen) );
+ } elsif( $self->{MEMBERS} && $self->_MembersHash->{$ent} ) {
+ return( substr($ent,0,-$dlen) );
+ } elsif( 0 <= ( $off= index( $ent, $delim x 2 ) ) ) {
+ return( substr( $ent, 0, $off ), substr( $ent, 2*$dlen+$off ) );
+ } elsif( $delim eq substr($ent,-$dlen) ) {
+ if( $parent
+ && 0 <= ( $off= rindex( $ent, $delim, length($ent)-2*$dlen ) ) ) {
+ return( substr($ent,0,$off),
+ undef, undef, substr($ent,$dlen+$off,-$dlen) );
+ } else {
+ return( substr($ent,0,-$dlen) );
+ }
+ } elsif( 0 <= ( $off= rindex( $ent, $delim ) ) ) {
+ return(
+ substr( $ent, 0, $off ), undef, substr( $ent, $dlen+$off ) );
+ } else {
+ return( undef, undef, $ent );
+ }
+}
+
+
+sub _FetchValue
+{
+ my $self= shift( @_ );
+ my( $val, $createKey )= @_;
+ my( $data, $type );
+ if( ( $data, $type )= $self->GetValue( $val ) ) {
+ return $self->ArrayValues ? [ $data, $type ]
+ : wantarray ? ( $data, $type )
+ : $data;
+ } elsif( $createKey and $data= $self->new($val) ) {
+ return $data->TiedRef;
+ } else {
+ return ();
+ }
+}
+
+
+sub FETCH
+{
+ my $self= shift(@_);
+ my $ent= shift(@_);
+ my $delim= $self->Delimiter;
+ my( $key, $val, $ambig )= $self->_parseTiedEnt( $ent, $delim, 0 );
+ my $sub;
+ if( defined($key) ) {
+ if( defined($self->{MEMBHASH})
+ && $self->{MEMBHASH}->{$key.$delim}
+ && 0 <= index($key,$delim) ) {
+ return ()
+ unless $sub= $self->new( $key,
+ {"Delimiter"=>$self->OS_Delimiter} );
+ $sub->Delimiter($delim);
+ } else {
+ return ()
+ unless $sub= $self->new( $key );
+ }
+ } else {
+ $sub= $self;
+ }
+ if( defined($val) ) {
+ return $sub->_FetchValue( $val );
+ } elsif( ! defined($ambig) ) {
+ return $sub->TiedRef;
+ } elsif( defined($key) ) {
+ return $sub->FETCH( $ambig );
+ } else {
+ return $sub->_FetchValue( $ambig, "" ne $ambig );
+ }
+}
+
+
+sub _FetchOld
+{
+ my( $self, $key )= @_;
+ my $old= $self->FETCH($key);
+ if( $old ) {
+ my $copy= {};
+ %$copy= %$old;
+ return $copy;
+ }
+ # return $^E;
+ return _Err;
+}
+
+
+sub DELETE
+{
+ my $self= shift(@_);
+ my $ent= shift(@_);
+ my $delim= $self->Delimiter;
+ my( $key, $val, $ambig, $subkey )= $self->_parseTiedEnt( $ent, $delim, 1 );
+ my $sub;
+ my $fast= defined(wantarray) ? $self->FastDelete : 2;
+ my $old= 1; # Value returned if FastDelete is set.
+ if( defined($key)
+ && ( defined($val) || defined($ambig) || defined($subkey) ) ) {
+ return ()
+ unless $sub= $self->new( $key );
+ } else {
+ $sub= $self;
+ }
+ if( defined($val) ) {
+ $old= $sub->GetValue($val) || _Err unless 2 <= $fast;
+ $sub->RegDeleteValue( $val );
+ } elsif( defined($subkey) ) {
+ $old= $sub->_FetchOld( $subkey.$delim ) unless $fast;
+ $sub->RegDeleteKey( $subkey );
+ } elsif( defined($ambig) ) {
+ if( defined($key) ) {
+ $old= $sub->DELETE($ambig);
+ } else {
+ $old= $sub->GetValue($ambig) || _Err unless 2 <= $fast;
+ if( defined( $old ) ) {
+ $sub->RegDeleteValue( $ambig );
+ } else {
+ $old= $sub->_FetchOld( $ambig.$delim ) unless $fast;
+ $sub->RegDeleteKey( $ambig );
+ }
+ }
+ } elsif( defined($key) ) {
+ $old= $sub->_FetchOld( $key.$delim ) unless $fast;
+ $sub->RegDeleteKey( $key );
+ } else {
+ croak "${PACK}->DELETE: Key ($ent) can never be deleted";
+ }
+ return $old;
+}
+
+
+sub SetValue
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ my $name= shift(@_);
+ my $data= shift(@_);
+ my( $type )= @_;
+ my $size;
+ if( ! defined($type) ) {
+ if( "ARRAY" eq ref($data) ) {
+ croak "${PACK}->SetValue: Value is array reference but ",
+ "no data type given"
+ unless 2 == @$data;
+ ( $data, $type )= @$data;
+ } else {
+ $type= REG_SZ;
+ }
+ }
+ $type= _constant($type,"registry value data type") if $type =~ /^REG_/;
+ if( REG_MULTI_SZ == $type && "ARRAY" eq ref($data) ) {
+ $data= join( "\0", @$data ) . "\0\0";
+ ## $data= pack( "a*" x (1+@$data), map( $_."\0", @$data, "" ) );
+ } elsif( ( REG_SZ == $type || REG_EXPAND_SZ == $type )
+ && $self->FixSzNulls ) {
+ $data .= "\0" unless "\0" eq substr($data,0,-1);
+ } elsif( REG_DWORD == $type && $data =~ /^0x[0-9a-fA-F]{3,}$/ ) {
+ $data= pack( "L", hex($data) );
+ # We could to $data=pack("L",$data) for REG_DWORD but I see
+ # no nice way to always destinguish when to do this or not.
+ }
+ return $self->RegSetValueEx( $name, 0, $type, $data, length($data) );
+}
+
+
+sub StoreKey
+{
+ my $this= shift(@_);
+ $this= tied(%$this) if ref($this) && tied(%$this);
+ my $subKey= shift(@_);
+ my $data= shift(@_);
+ my $ent;
+ my $self;
+ if( ! ref($data) || "$data" !~ /(^|=)HASH/ ) {
+ croak "${PACK}->StoreKey: For ", $this->Path.$subKey, ",\n",
+ " subkey data must be a HASH reference";
+ }
+ if( defined( $$data{""} ) && "HASH" eq ref($$data{""}) ) {
+ $self= $this->CreateKey( $subKey, delete $$data{""} );
+ } else {
+ $self= $this->CreateKey( $subKey );
+ }
+ return () if ! defined($self);
+ foreach $ent ( keys(%$data) ) {
+ return ()
+ unless $self->STORE( $ent, $$data{$ent} );
+ }
+ return $self;
+}
+
+
+# = { "" => {OPT=>VAL}, "val"=>[], "key"=>{} } creates a new key
+# = "string" creates a new REG_SZ value
+# = [ data, type ] creates a new value
+sub STORE
+{
+ my $self= shift(@_);
+ my $ent= shift(@_);
+ my $data= shift(@_);
+ my $delim= $self->Delimiter;
+ my( $key, $val, $ambig, $subkey )= $self->_parseTiedEnt( $ent, $delim, 1 );
+ my $sub;
+ if( defined($key)
+ && ( defined($val) || defined($ambig) || defined($subkey) ) ) {
+ return ()
+ unless $sub= $self->new( $key );
+ } else {
+ $sub= $self;
+ }
+ if( defined($val) ) {
+ croak "${PACK}->STORE: For ", $sub->Path.$delim.$val, ",\n",
+ " value data cannot be a HASH reference"
+ if ref($data) && "$data" =~ /(^|=)HASH/;
+ $sub->SetValue( $val, $data );
+ } elsif( defined($subkey) ) {
+ croak "${PACK}->STORE: For ", $sub->Path.$subkey.$delim, ",\n",
+ " subkey data must be a HASH reference"
+ unless ref($data) && "$data" =~ /(^|=)HASH/;
+ $sub->StoreKey( $subkey, $data );
+ } elsif( defined($ambig) ) {
+ if( ref($data) && "$data" =~ /(^|=)HASH/ ) {
+ $sub->StoreKey( $ambig, $data );
+ } else {
+ $sub->SetValue( $ambig, $data );
+ }
+ } elsif( defined($key) ) {
+ croak "${PACK}->STORE: For ", $sub->Path.$key.$delim, ",\n",
+ " subkey data must be a HASH reference"
+ unless ref($data) && "$data" =~ /(^|=)HASH/;
+ $sub->StoreKey( $key, $data );
+ } else {
+ croak "${PACK}->STORE: Key ($ent) can never be created nor set";
+ }
+}
+
+
+sub EXISTS
+{
+ my $self= shift(@_);
+ my $ent= shift(@_);
+ return defined( $self->FETCH($ent) );
+}
+
+
+sub FIRSTKEY
+{
+ my $self= shift(@_);
+ my $members= $self->_MemberNames;
+ $self->{PREVIDX}= 0;
+ return @{$members} ? $members->[0] : undef;
+}
+
+
+sub NEXTKEY
+{
+ my $self= shift(@_);
+ my $prev= shift(@_);
+ my $idx= $self->{PREVIDX};
+ my $members= $self->_MemberNames;
+ if( ! defined($idx) || $prev ne $members->[$idx] ) {
+ $idx= 0;
+ while( $idx < @$members && $prev ne $members->[$idx] ) {
+ $idx++;
+ }
+ }
+ $self->{PREVIDX}= ++$idx;
+ return $members->[$idx];
+}
+
+
+sub DESTROY
+{
+ my $self= shift(@_);
+ return if tied(%$self);
+ my $unload;
+ local $@;
+ eval { $unload= $self->{UNLOADME}; 1 }
+ or return;
+ my $debug= $ENV{DEBUG_TIE_REGISTRY};
+ if( defined($debug) ) {
+ if( 1 < $debug ) {
+ my $hand= $self->Handle;
+ my $dep= $self->{DEPENDON};
+ carp "${PACK} destroying ", $self->Path, " (",
+ "NONE" eq $hand ? $hand : sprintf("0x%lX",$hand), ")",
+ defined($dep) ? (" [depends on ",$dep->Path,"]") : ();
+ } else {
+ warn "${PACK} destroying ", $self->Path, ".\n";
+ }
+ }
+ $self->RegCloseKey
+ unless "NONE" eq $self->Handle;
+ if( defined($unload) ) {
+ if( defined($debug) && 1 < $debug ) {
+ my( $obj, $subKey, $file )= @$unload;
+ warn "Unloading ", $self->Path,
+ " (from ", $obj->Path, ", $subKey)...\n";
+ }
+ $self->UnLoad
+ || warn "Couldn't unload ", $self->Path, ": ", _ErrMsg, "\n";
+ ## carp "Never unloaded ${PACK}::Load($$unload[2])";
+ }
+ #delete $self->{DEPENDON};
+}
+
+
+use vars qw( @CreateKey_Opts %CreateKey_Opts %_KeyDispNames );
+@CreateKey_Opts= qw( Access Class Options Delimiter
+ Disposition Security Volatile Backup );
+@CreateKey_Opts{@CreateKey_Opts}= (1) x @CreateKey_Opts;
+%_KeyDispNames= ( REG_CREATED_NEW_KEY() => "REG_CREATED_NEW_KEY",
+ REG_OPENED_EXISTING_KEY() => "REG_OPENED_EXISTING_KEY" );
+
+sub CreateKey
+{
+ my $self= shift(@_);
+ my $tied= tied(%$self);
+ $self= tied(%$self) if $tied;
+ my( $subKey, $opts )= @_;
+ my( $sam )= $self->Access;
+ my( $delim )= $self->Delimiter;
+ my( $class )= "";
+ my( $flags )= 0;
+ my( $secure )= [];
+ my( $garb )= [];
+ my( $result )= \$garb;
+ my( $handle )= 0;
+ if( @_ < 1 || 2 < @_
+ || 2 == @_ && "HASH" ne ref($opts) ) {
+ croak "Usage: \$new= \$old->CreateKey( \$subKey, {OPT=>VAL,...} );\n",
+ " options: @CreateKey_Opts\nCalled";
+ }
+ if( defined($opts) ) {
+ $sam= $opts->{"Access"} if defined($opts->{"Access"});
+ $class= $opts->{Class} if defined($opts->{Class});
+ $flags= $opts->{Options} if defined($opts->{Options});
+ $delim= $opts->{"Delimiter"} if defined($opts->{"Delimiter"});
+ $secure= $opts->{Security} if defined($opts->{Security});
+ if( defined($opts->{Disposition}) ) {
+ "SCALAR" eq ref($opts->{Disposition})
+ or croak "${PACK}->CreateKey option `Disposition'",
+ " must provide a scalar reference";
+ $result= $opts->{Disposition};
+ }
+ if( 0 == $flags ) {
+ $flags |= REG_OPTION_VOLATILE
+ if defined($opts->{Volatile}) && $opts->{Volatile};
+ $flags |= REG_OPTION_BACKUP_RESTORE
+ if defined($opts->{Backup}) && $opts->{Backup};
+ }
+ }
+ my $subPath= ref($subKey) ? $subKey : $self->_split($subKey,$delim);
+ $subKey= join( $self->OS_Delimiter, @$subPath );
+ $self->RegCreateKeyEx( $subKey, 0, $class, $flags, $sam,
+ $secure, $handle, $$result )
+ or return ();
+ if( ! ref($$result) && $self->DualTypes ) {
+ $$result= _DualVal( \%_KeyDispNames, $$result );
+ }
+ my $new= $self->_new( $handle, [ @{$self->_Path}, @{$subPath} ] );
+ $new->{ACCESS}= $sam;
+ $new->{DELIM}= $delim;
+ $new= $new->TiedRef if $tied;
+ return $new;
+}
+
+
+use vars qw( $Load_Cnt @Load_Opts %Load_Opts );
+$Load_Cnt= 0;
+@Load_Opts= qw(NewSubKey);
+@Load_Opts{@Load_Opts}= (1) x @Load_Opts;
+
+sub Load
+{
+ my $this= shift(@_);
+ my $tied= ref($this) && tied(%$this);
+ $this= tied(%$this) if $tied;
+ my( $file, $subKey, $opts )= @_;
+ if( 2 == @_ && "HASH" eq ref($subKey) ) {
+ $opts= $subKey;
+ undef $subKey;
+ }
+ @_ < 1 || 3 < @_ || defined($opts) && "HASH" ne ref($opts)
+ and croak "Usage: \$key= ",
+ "${PACK}->Load( \$fileName, [\$newSubKey,] {OPT=>VAL...} );\n",
+ " options: @Load_Opts @new_Opts\nCalled";
+ if( defined($opts) && exists($opts->{NewSubKey}) ) {
+ $subKey= delete $opts->{NewSubKey};
+ }
+ if( ! defined( $subKey ) ) {
+ if( "" ne $this->Machine ) {
+ ( $this )= $this->_connect( [$this->Machine,"LMachine"] );
+ } else {
+ ( $this )= $this->_rootKey( "LMachine" ); # Could also be "Users"
+ }
+ $subKey= "PerlTie:$$." . ++$Load_Cnt;
+ }
+ $this->RegLoadKey( $subKey, $file )
+ or return ();
+ my $self= $this->new( $subKey, defined($opts) ? $opts : () );
+ if( ! defined( $self ) ) {
+ { my $err= Win32::GetLastError();
+ #{ local( $^E ); #}
+ $this->RegUnLoadKey( $subKey ) or carp
+ "Can't unload $subKey from ", $this->Path, ": ", _ErrMsg, "\n";
+ Win32::SetLastError($err);
+ }
+ return ();
+ }
+ $self->{UNLOADME}= [ $this, $subKey, $file ];
+ $self= $self->TiedRef if $tied;
+ return $self;
+}
+
+
+sub UnLoad
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ @_ and croak "Usage: \$key->UnLoad;";
+ my $unload= $self->{UNLOADME};
+ "ARRAY" eq ref($unload)
+ or croak "${PACK}->UnLoad called on a key which was not Load()ed";
+ my( $obj, $subKey, $file )= @$unload;
+ $self->RegCloseKey;
+ return Win32API::Registry::RegUnLoadKey( $obj->Handle, $subKey );
+}
+
+
+sub AllowSave
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ return $self->AllowPriv( "SeBackupPrivilege", @_ );
+}
+
+
+sub AllowLoad
+{
+ my $self= shift(@_);
+ $self= tied(%$self) if tied(%$self);
+ return $self->AllowPriv( "SeRestorePrivilege", @_ );
+}
+
+
+# RegNotifyChangeKeyValue( hKey, bWatchSubtree, iNotifyFilter, hEvent, bAsync )
+
+
+sub RegCloseKey { my $self= shift(@_);
+ Win32API::Registry::RegCloseKey $self->Handle, @_; }
+sub RegConnectRegistry { my $self= shift(@_);
+ Win32API::Registry::RegConnectRegistry @_; }
+sub RegCreateKey { my $self= shift(@_);
+ Win32API::Registry::RegCreateKey $self->Handle, @_; }
+sub RegCreateKeyEx { my $self= shift(@_);
+ Win32API::Registry::RegCreateKeyEx $self->Handle, @_; }
+sub RegDeleteKey { my $self= shift(@_);
+ Win32API::Registry::RegDeleteKey $self->Handle, @_; }
+sub RegDeleteValue { my $self= shift(@_);
+ Win32API::Registry::RegDeleteValue $self->Handle, @_; }
+sub RegEnumKey { my $self= shift(@_);
+ Win32API::Registry::RegEnumKey $self->Handle, @_; }
+sub RegEnumKeyEx { my $self= shift(@_);
+ Win32API::Registry::RegEnumKeyEx $self->Handle, @_; }
+sub RegEnumValue { my $self= shift(@_);
+ Win32API::Registry::RegEnumValue $self->Handle, @_; }
+sub RegFlushKey { my $self= shift(@_);
+ Win32API::Registry::RegFlushKey $self->Handle, @_; }
+sub RegGetKeySecurity { my $self= shift(@_);
+ Win32API::Registry::RegGetKeySecurity $self->Handle, @_; }
+sub RegLoadKey { my $self= shift(@_);
+ Win32API::Registry::RegLoadKey $self->Handle, @_; }
+sub RegNotifyChangeKeyValue { my $self= shift(@_);
+ Win32API::Registry::RegNotifyChangeKeyValue $self->Handle, @_; }
+sub RegOpenKey { my $self= shift(@_);
+ Win32API::Registry::RegOpenKey $self->Handle, @_; }
+sub RegOpenKeyEx { my $self= shift(@_);
+ Win32API::Registry::RegOpenKeyEx $self->Handle, @_; }
+sub RegQueryInfoKey { my $self= shift(@_);
+ Win32API::Registry::RegQueryInfoKey $self->Handle, @_; }
+sub RegQueryMultipleValues { my $self= shift(@_);
+ Win32API::Registry::RegQueryMultipleValues $self->Handle, @_; }
+sub RegQueryValue { my $self= shift(@_);
+ Win32API::Registry::RegQueryValue $self->Handle, @_; }
+sub RegQueryValueEx { my $self= shift(@_);
+ Win32API::Registry::RegQueryValueEx $self->Handle, @_; }
+sub RegReplaceKey { my $self= shift(@_);
+ Win32API::Registry::RegReplaceKey $self->Handle, @_; }
+sub RegRestoreKey { my $self= shift(@_);
+ Win32API::Registry::RegRestoreKey $self->Handle, @_; }
+sub RegSaveKey { my $self= shift(@_);
+ Win32API::Registry::RegSaveKey $self->Handle, @_; }
+sub RegSetKeySecurity { my $self= shift(@_);
+ Win32API::Registry::RegSetKeySecurity $self->Handle, @_; }
+sub RegSetValue { my $self= shift(@_);
+ Win32API::Registry::RegSetValue $self->Handle, @_; }
+sub RegSetValueEx { my $self= shift(@_);
+ Win32API::Registry::RegSetValueEx $self->Handle, @_; }
+sub RegUnLoadKey { my $self= shift(@_);
+ Win32API::Registry::RegUnLoadKey $self->Handle, @_; }
+sub AllowPriv { my $self= shift(@_);
+ Win32API::Registry::AllowPriv @_; }
+
+
+# Autoload methods go after =cut, and are processed by the autosplit program.
+
+1;
+__END__
+
+=head1 NAME
+
+Win32::TieRegistry - Powerful and easy ways to manipulate a registry
+[on Win32 for now].
+
+=head1 SYNOPSIS
+
+ use Win32::TieRegistry 0.20 ( UseOptionName=>UseOptionValue[,...] );
+
+ $Registry->SomeMethodCall(arg1,...);
+
+ $subKey= $Registry->{"Key\\SubKey\\"};
+ $valueData= $Registry->{"Key\\SubKey\\\\ValueName"};
+ $Registry->{"Key\\SubKey\\"}= { "NewSubKey" => {...} };
+ $Registry->{"Key\\SubKey\\\\ValueName"}= "NewValueData";
+ $Registry->{"\\ValueName"}= [ pack("fmt",$data), REG_DATATYPE ];
+
+=head1 EXAMPLES
+
+ use Win32::TieRegistry( Delimiter=>"#", ArrayValues=>0 );
+ $pound= $Registry->Delimiter("/");
+ $diskKey= $Registry->{"LMachine/System/Disk/"}
+ or die "Can't read LMachine/System/Disk key: $^E\n";
+ $data= $key->{"/Information"}
+ or die "Can't read LMachine/System/Disk//Information value: $^E\n";
+ $remoteKey= $Registry->{"//ServerA/LMachine/System/"}
+ or die "Can't read //ServerA/LMachine/System/ key: $^E\n";
+ $remoteData= $remoteKey->{"Disk//Information"}
+ or die "Can't read ServerA's System/Disk//Information value: $^E\n";
+ foreach $entry ( keys(%$diskKey) ) {
+ ...
+ }
+ foreach $subKey ( $diskKey->SubKeyNames ) {
+ ...
+ }
+ $diskKey->AllowSave( 1 );
+ $diskKey->RegSaveKey( "C:/TEMP/DiskReg", [] );
+
+=head1 DESCRIPTION
+
+The I<Win32::TieRegistry> module lets you manipulate the Registry
+via objects [as in "object oriented"] or via tied hashes. But
+you will probably mostly use a combination reference, that is, a
+reference to a tied hash that has also been made an object so that
+you can mix both access methods [as shown above].
+
+If you did not get this module as part of L<libwin32>, you might
+want to get a recent version of L<libwin32> from CPAN which should
+include this module and the I<Win32API::Registry> module that it
+uses.
+
+Skip to the L<SUMMARY> section if you just want to dive in and start
+using the Registry from Perl.
+
+Accessing and manipulating the registry is extremely simple using
+I<Win32::TieRegistry>. A single, simple expression can return
+you almost any bit of information stored in the Registry.
+I<Win32::TieRegistry> also gives you full access to the "raw"
+underlying API calls so that you can do anything with the Registry
+in Perl that you could do in C. But the "simple" interface has
+been carefully designed to handle almost all operations itself
+without imposing arbitrary limits while providing sensible
+defaults so you can list only the parameters you care about.
+
+But first, an overview of the Registry itself.
+
+=head2 The Registry
+
+The Registry is a forest: a collection of several tree structures.
+The root of each tree is a key. These root keys are identified by
+predefined constants whose names start with "HKEY_". Although all
+keys have a few attributes associated with each [a class, a time
+stamp, and security information], the most important aspect of keys
+is that each can contain subkeys and can contain values.
+
+Each subkey has a name: a string which cannot be blank and cannot
+contain the delimiter character [backslash: C<'\\'>] nor nul
+[C<'\0'>]. Each subkey is also a key and so can contain subkeys
+and values [and has a class, time stamp, and security information].
+
+Each value has a name: a string which E<can> be blank and E<can>
+contain the delimiter character [backslash: C<'\\'>] and any
+character except for null, C<'\0'>. Each value also has data
+associated with it. Each value's data is a contiguous chunk of
+bytes, which is exactly what a Perl string value is so Perl
+strings will usually be used to represent value data.
+
+Each value also has a data type which says how to interpret the
+value data. The primary data types are:
+
+=over
+
+=item REG_SZ
+
+A null-terminated string.
+
+=item REG_EXPAND_SZ
+
+A null-terminated string which contains substrings consisting of a
+percent sign [C<'%'>], an environment variable name, then a percent
+sign, that should be replaced with the value associate with that
+environment variable. The system does I<not> automatically do this
+substitution.
+
+=item REG_BINARY
+
+Some arbitrary binary value. You can think of these as being
+"packed" into a string.
+
+If your system has the L<SetDualVar> module installed,
+the C<DualBinVals()> option wasn't turned off, and you
+fetch a C<REG_BINARY> value of 4 bytes or fewer, then
+you can use the returned value in a numeric context to
+get at the "unpacked" numeric value. See C<GetValue()>
+for more information.
+
+=item REG_MULTI_SZ
+
+Several null-terminated strings concatenated together with an
+extra trailing C<'\0'> at the end of the list. Note that the list
+can include empty strings so use the value's length to determine
+the end of the list, not the first occurrence of C<'\0\0'>.
+It is best to set the C<SplitMultis()> option so I<Win32::TieRegistry>
+will split these values into an array of strings for you.
+
+=item REG_DWORD
+
+A long [4-byte] integer value. These values are expected either
+packed into a 4-character string or as a hex string of E<more than>
+4 characters [but I<not> as a numeric value, unfortunately, as there is
+no sure way to tell a numeric value from a packed 4-byte string that
+just happens to be a string containing a valid numeric value].
+
+How such values are returned depends on the C<DualBinVals()> and
+C<DWordsToHex()> options. See C<GetValue()> for details.
+
+=back
+
+In the underlying Registry calls, most places which take a
+subkey name also allow you to pass in a subkey "path" -- a
+string of several subkey names separated by the delimiter
+character, backslash [C<'\\'>]. For example, doing
+C<RegOpenKeyEx(HKEY_LOCAL_MACHINE,"SYSTEM\\DISK",...)> is much
+like opening the C<"SYSTEM"> subkey of C<HKEY_LOCAL_MACHINE>,
+then opening its C<"DISK"> subkey, then closing the C<"SYSTEM">
+subkey.
+
+All of the I<Win32::TieRegistry> features allow you to use your
+own delimiter in place of the system's delimiter, [C<'\\'>]. In
+most of our examples we will use a forward slash [C<'/'>] as our
+delimiter as it is easier to read and less error prone to use when
+writing Perl code since you have to type two backslashes for each
+backslash you want in a string. Note that this is true even when
+using single quotes -- C<'\\HostName\LMachine\'> is an invalid
+string and must be written as C<'\\\\HostName\\LMachine\\'>.
+
+You can also connect to the registry of other computers on your
+network. This will be discussed more later.
+
+Although the Registry does not have a single root key, the
+I<Win32::TieRegistry> module creates a virtual root key for you
+which has all of the I<HKEY_*> keys as subkeys.
+
+=head2 Tied Hashes Documentation
+
+Before you can use a tied hash, you must create one. One way to
+do that is via:
+
+ use Win32::TieRegistry ( TiedHash => '%RegHash' );
+
+which exports a C<%RegHash> variable into your package and ties it
+to the virtual root key of the Registry. An alternate method is:
+
+ my %RegHash;
+ use Win32::TieRegistry ( TiedHash => \%RegHash );
+
+There are also several ways you can tie a hash variable to any
+other key of the Registry, which are discussed later.
+
+Note that you will most likely use C<$Registry> instead of using
+a tied hash. C<$Registry> is a reference to a hash that has
+been tied to the virtual root of your computer's Registry [as if,
+C<$Registry= \%RegHash>]. So you would use C<$Registry-E<gt>{Key}>
+rather than C<$RegHash{Key}> and use C<keys %{$Registry}> rather
+than C<keys %RegHash>, for example.
+
+For each hash which has been tied to a Registry key, the Perl
+C<keys> function will return a list containing the name of each
+of the key's subkeys with a delimiter character appended to it and
+containing the name of each of the key's values with a delimiter
+prepended to it. For example:
+
+ keys( %{ $Registry->{"HKEY_CLASSES_ROOT\\batfile\\"} } )
+
+might yield the following list value:
+
+ ( "DefaultIcon\\", # The subkey named "DefaultIcon"
+ "shell\\", # The subkey named "shell"
+ "shellex\\", # The subkey named "shellex"
+ "\\", # The default value [named ""]
+ "\\EditFlags" ) # The value named "EditFlags"
+
+For the virtual root key, short-hand subkey names are used as
+shown below. You can use the short-hand name, the regular
+I<HKEY_*> name, or any numeric value to access these keys, but
+the short-hand names are all that will be returned by the C<keys>
+function.
+
+=over
+
+=item "Classes" for HKEY_CLASSES_ROOT
+
+Contains mappings between file name extensions and the uses
+for such files along with configuration information for COM
+[MicroSoft's Common Object Model] objects. Usually a link to
+the C<"SOFTWARE\\Classes"> subkey of the C<HKEY_LOCAL_MACHINE>
+key.
+
+=item "CUser" for HKEY_CURRENT_USER
+
+Contains information specific to the currently logged-in user.
+Mostly software configuration information. Usually a link to
+a subkey of the C<HKEY_USERS> key.
+
+=item "LMachine" for HKEY_LOCAL_MACHINE
+
+Contains all manner of information about the computer.
+
+=item "Users" for HKEY_USERS
+
+Contains one subkey, C<".DEFAULT">, which gets copied to a new
+subkey whenever a new user is added. Also contains a subkey for
+each user of the system, though only those for active users
+[usually only one] are loaded at any given time.
+
+=item "PerfData" for HKEY_PERFORMANCE_DATA
+
+Used to access data about system performance. Access via this key
+is "special" and all but the most carefully constructed calls will
+fail, usually with C<ERROR_INSUFFICIENT_BUFFER>. For example, you
+can't enumerate key names without also enumerating values which
+require huge buffers but the exact buffer size required cannot be
+determined beforehand because C<RegQueryInfoKey()> E<always> fails
+with C<ERROR_INSUFFICIENT_BUFFER> for C<HKEY_PERFORMANCE_DATA> no
+matter how it is called. So it is currently not very useful to
+tie a hash to this key. You can use it to create an object to use
+for making carefully constructed calls to the underlying Reg*()
+routines.
+
+=item "CConfig" for HKEY_CURRENT_CONFIG
+
+Contains minimal information about the computer's current
+configuration that is required very early in the boot process.
+For example, setting for the display adapter such as screen
+resolution and refresh rate are found in here.
+
+=item "DynData" for HKEY_DYN_DATA
+
+Dynamic data. We have found no documentation for this key.
+
+=back
+
+A tied hash is much like a regular hash variable in Perl -- you give
+it a key string inside braces, [C<{> and C<}>], and it gives you
+back a value [or lets you set a value]. For I<Win32::TieRegistry>
+hashes, there are two types of values that will be returned.
+
+=over
+
+=item SubKeys
+
+If you give it a string which represents a subkey, then it will
+give you back a reference to a hash which has been tied to that
+subkey. It can't return the hash itself, so it returns a
+reference to it. It also blesses that reference so that it is
+also an object so you can use it to call method functions.
+
+=item Values
+
+If you give it a string which is a value name, then it will give
+you back a string which is the data for that value. Alternately,
+you can request that it give you both the data value string and
+the data value type [we discuss how to request this later]. In
+this case, it would return a reference to an array where the value
+data string is element C<[0]> and the value data type is element
+C<[1]>.
+
+=back
+
+The key string which you use in the tied hash must be interpreted
+to determine whether it is a value name or a key name or a path
+that combines several of these or even other things. There are
+two simple rules that make this interpretation easy and
+unambiguous:
+
+ Put a delimiter after each key name.
+ Put a delimiter in front of each value name.
+
+Exactly how the key string will be intepreted is governed by the
+following cases, in the order listed. These cases are designed
+to "do what you mean". Most of the time you won't have to think
+about them, especially if you follow the two simple rules above.
+After the list of cases we give several examples which should be
+clear enough so feel free to skip to them unless you are worried
+about the details.
+
+=over
+
+=item Remote machines
+
+If the hash is tied to the virtual root of the registry [or the
+virtual root of a remote machine's registry], then we treat hash
+key strings which start with the delimiter character specially.
+
+If the hash key string starts with two delimiters in a row, then
+those should be immediately followed by the name of a remote
+machine whose registry we wish to connect to. That can be
+followed by a delimiter and more subkey names, etc. If the
+machine name is not following by anything, then a virtual root
+for the remote machine's registry is created, a hash is tied to
+it, and a reference to that hash it is returned.
+
+=item Hash key string starts with the delimiter
+
+If the hash is tied to a virtual root key, then the leading
+delimiter is ignored. It should be followed by a valid Registry
+root key name [either a short-hand name like C<"LMachine">, an
+I<HKEY_*> value, or a numeric value]. This alternate notation is
+allowed in order to be more consistant with the C<Open()> method
+function.
+
+For all other Registry keys, the leading delimiter indicates
+that the rest of the string is a value name. The leading
+delimiter is stripped and the rest of the string [which can
+be empty and can contain more delimiters] is used as a value
+name with no further parsing.
+
+=item Exact match with direct subkey name followed by delimiter
+
+If you have already called the Perl C<keys> function on the tied
+hash [or have already called C<MemberNames> on the object] and the
+hash key string exactly matches one of the strings returned, then
+no further parsing is done. In other words, if the key string
+exactly matches the name of a direct subkey with a delimiter
+appended, then a reference to a hash tied to that subkey is
+returned [but only if C<keys> or C<MemberNames> has already
+been called for that tied hash].
+
+This is only important if you have selected a delimiter other than
+the system default delimiter and one of the subkey names contains
+the delimiter you have chosen. This rule allows you to deal with
+subkeys which contain your chosen delimiter in their name as long
+as you only traverse subkeys one level at a time and always
+enumerate the list of members before doing so.
+
+The main advantage of this is that Perl code which recursively
+traverses a hash will work on hashes tied to Registry keys even if
+a non-default delimiter has been selected.
+
+=item Hash key string contains two delimiters in a row
+
+If the hash key string contains two [or more] delimiters in a row,
+then the string is split between the first pair of delimiters.
+The first part is interpreted as a subkey name or a path of subkey
+names separated by delimiters and with a trailing delimiter. The
+second part is interpreted as a value name with one leading
+delimiter [any extra delimiters are considered part of the value
+name].
+
+=item Hash key string ends with a delimiter
+
+If the key string ends with a delimiter, then it is treated
+as a subkey name or path of subkey names separated by delimiters.
+
+=item Hash key string contains a delimiter
+
+If the key string contains a delimiter, then it is split after
+the last delimiter. The first part is treated as a subkey name or
+path of subkey names separated by delimiters. The second part
+is ambiguous and is treated as outlined in the next item.
+
+=item Hash key string contains no delimiters
+
+If the hash key string contains no delimiters, then it is ambiguous.
+
+If you are reading from the hash [fetching], then we first use the
+key string as a value name. If there is a value with a matching
+name in the Registry key which the hash is tied to, then the value
+data string [and possibly the value data type] is returned.
+Otherwise, we retry by using the hash key string as a subkey name.
+If there is a subkey with a matching name, then we return a
+reference to a hash tied to that subkey. Otherwise we return
+C<undef>.
+
+If you are writing to the hash [storing], then we use the key
+string as a subkey name only if the value you are storing is a
+reference to a hash value. Otherwise we use the key string as
+a value name.
+
+=back
+
+=head3 Examples
+
+Here are some examples showing different ways of accessing Registry
+information using references to tied hashes:
+
+=over
+
+=item Canonical value fetch
+
+ $tip18= $Registry->{"HKEY_LOCAL_MACHINE\\Software\\Microsoft\\"
+ . 'Windows\\CurrentVersion\\Explorer\\Tips\\\\18'};
+
+Should return the text of important tip number 18. Note that two
+backslashes, C<"\\">, are required to get a single backslash into
+a Perl double-quoted or single-qouted string. Note that C<"\\">
+is appended to each key name [C<"HKEY_LOCAL_MACHINE"> through
+C<"Tips">] and C<"\\"> is prepended to the value name, C<"18">.
+
+=item Changing your delimiter
+
+ $Registry->Delimiter("/");
+ $tip18= $Registry->{"HKEY_LOCAL_MACHINE/Software/Microsoft/"
+ . 'Windows/CurrentVersion/Explorer/Tips//18'};
+
+This usually makes things easier to read when working in Perl.
+All remaining examples will assume the delimiter has been changed
+as above.
+
+=item Using intermediate keys
+
+ $ms= $Registry->{"LMachine/Software/Microsoft/"};
+ $tips= $ms->{"Windows/CurrentVersion/Explorer/Tips/"};
+ $tip18= $winlogon->{"/18"};
+
+Same as above but opens more keys into the Registry which lets you
+efficiently re-access those intermediate keys. This is slightly
+less efficient if you never reuse those intermediate keys.
+
+=item Chaining in a single statement
+
+ $tip18= $Registry->{"LMachine/Software/Microsoft/"}->
+ {"Windows/CurrentVersion/Explorer/Tips/"}->{"/18"};
+
+Like above, this creates intermediate key objects then uses
+them to access other data. Once this statement finishes, the
+intermediate key objects are destroyed. Several handles into
+the Registry are opened and closed by this statement so it is
+less efficient but there are times when this will be useful.
+
+=item Even less efficient example of chaining
+
+ $tip18= $Registry->{"LMachine/Software/Microsoft"}->
+ {"Windows/CurrentVersion/Explorer/Tips"}->{"/18"};
+
+Because we left off the trailing delimiters, I<Win32::TieRegistry>
+doesn't know whether final names, C<"Microsoft"> and C<"Tips">,
+are subkey names or value names. So this statement ends up
+executing the same code as the next one.
+
+=item What the above really does
+
+ $tip18= $Registry->{"LMachine/Software/"}->{"Microsoft"}->
+ {"Windows/CurrentVersion/Explorer/"}->{"Tips"}->{"/18"};
+
+With more chains to go through, more temporary objects are created
+and later destroyed than in our first chaining example. Also,
+when C<"Microsoft"> is looked up, I<Win32::TieRegistry> first
+tries to open it as a value and fails then tries it as a subkey.
+The same is true for when it looks up C<"Tips">.
+
+=item Getting all of the tips
+
+ $tips= $Registry->{"LMachine/Software/Microsoft/"}->
+ {"Windows/CurrentVersion/Explorer/Tips/"}
+ or die "Can't find the Windows tips: $^E\n";
+ foreach( keys %$tips ) {
+ print "$_: ", $tips->{$_}, "\n";
+ }
+
+First notice that we actually check for failure for the first
+time. We are assuming that the C<"Tips"> key contains no subkeys.
+Otherwise the C<print> statement would show something like
+C<"Win32::TieRegistry=HASH(0xc03ebc)"> for each subkey.
+
+The output from the above code will start something like:
+
+ /0: If you don't know how to do something,[...]
+
+=back
+
+=head3 Deleting items
+
+You can use the Perl C<delete> function to delete a value from a
+Registry key or to delete a subkey as long that subkey contains
+no subkeys of its own. See L<More Examples>, below, for more
+information.
+
+=head3 Storing items
+
+You can use the Perl assignment operator [C<=>] to create new
+keys, create new values, or replace values. The values you store
+should be in the same format as the values you would fetch from a
+tied hash. For example, you can use a single assignment statement
+to copy an entire Registry tree. The following statement:
+
+ $Registry->{"LMachine/Software/Classes/Tie_Registry/"}=
+ $Registry->{"LMachine/Software/Classes/batfile/"};
+
+creates a C<"Tie_Registry"> subkey under the C<"Software\\Classes">
+subkey of the C<HKEY_LOCAL_MACHINE> key. Then it populates it
+with copies of all of the subkeys and values in the C<"batfile">
+subkey and all of its subkeys. Note that you need to have
+called C<$Registry-E<gt>ArrayValues(1)> for the proper value data
+type information to be copied. Note also that this release of
+I<Win32::TieRegistry> does not copy key attributes such as class
+name and security information [this is planned for a future release].
+
+The following statement creates a whole subtree in the Registry:
+
+ $Registry->{"LMachine/Software/FooCorp/"}= {
+ "FooWriter/" => {
+ "/Version" => "4.032",
+ "Startup/" => {
+ "/Title" => "Foo Writer Deluxe ][",
+ "/WindowSize" => [ pack("LL",$wid,$ht), "REG_BINARY" ],
+ "/TaskBarIcon" => [ "0x0001", "REG_DWORD" ],
+ },
+ "Compatibility/" => {
+ "/AutoConvert" => "Always",
+ "/Default Palette" => "Windows Colors",
+ },
+ },
+ "/License", => "0123-9C8EF1-09-FC",
+ };
+
+Note that all but the last Registry key used on the left-hand
+side of the assignment [that is, "LMachine/Software/" but not
+"FooCorp/"] must already exist for this statement to succeed.
+
+By using the leading a trailing delimiters on each subkey name and
+value name, I<Win32::TieRegistry> will tell you if you try to assign
+subkey information to a value or visa-versa.
+
+=head3 More examples
+
+=over
+
+=item Adding a new tip
+
+ $tips= $Registry->{"LMachine/Software/Microsoft/"}->
+ {"Windows/CurrentVersion/Explorer/Tips/"}
+ or die "Can't find the Windows tips: $^E\n";
+ $tips{'/186'}= "Be very careful when making changes to the Registry!";
+
+=item Deleting our new tip
+
+ $tips= $Registry->{"LMachine/Software/Microsoft/"}->
+ {"Windows/CurrentVersion/Explorer/Tips/"}
+ or die "Can't find the Windows tips: $^E\n";
+ $tip186= delete $tips{'/186'};
+
+Note that Perl's C<delete> function returns the value that was deleted.
+
+=item Adding a new tip differently
+
+ $Registry->{"LMachine/Software/Microsoft/" .
+ "Windows/CurrentVersion/Explorer/Tips//186"}=
+ "Be very careful when making changes to the Registry!";
+
+=item Deleting differently
+
+ $tip186= delete $Registry->{"LMachine/Software/Microsoft/Windows/" .
+ "CurrentVersion/Explorer/Tips//186"};
+
+Note that this only deletes the tail of what we looked up, the
+C<"186"> value, not any of the keys listed.
+
+=item Deleting a key
+
+WARNING: The following code will delete all information about the
+current user's tip preferences. Actually executing this command
+would probably cause the user to see the Welcome screen the next
+time they log in and may cause more serious problems. This
+statement is shown as an example only and should not be used when
+experimenting.
+
+ $tips= delete $Registry->{"CUser/Software/Microsoft/Windows/" .
+ "CurrentVersion/Explorer/Tips/"};
+
+This deletes the C<"Tips"> key and the values it contains. The
+C<delete> function will return a reference to a hash [not a tied
+hash] containing the value names and value data that were deleted.
+
+The information to be returned is copied from the Registry into a
+regular Perl hash before the key is deleted. If the key has many
+subkeys, this copying could take a significant amount of memory
+and/or processor time. So you can disable this process by calling
+the C<FastDelete> member function:
+
+ $prevSetting= $regKey->FastDelete(1);
+
+which will cause all subsequent delete operations via C<$regKey>
+to simply return a true value if they succeed. This optimization
+is automatically done if you use C<delete> in a void context.
+
+=item Technical notes on deleting
+
+If you use C<delete> to delete a Registry key or value and use
+the return value, then I<Win32::TieRegistry> usually looks up the
+current contents of that key or value so they can be returned if
+the deletion is successful. If the deletion succeeds but the
+attempt to lookup the old contents failed, then the return value
+of C<delete> will be C<$^E> from the failed part of the operation.
+
+=item Undeleting a key
+
+ $Registry->{"LMachine/Software/Microsoft/Windows/" .
+ "CurrentVersion/Explorer/Tips/"}= $tips;
+
+This adds back what we just deleted. Note that this version of
+I<Win32::TieRegistry> will use defaults for the key attributes
+[such as class name and security] and will not restore the
+previous attributes.
+
+=item Not deleting a key
+
+WARNING: Actually executing the following code could cause
+serious problems. This statement is shown as an example only and
+should not be used when experimenting.
+
+ $res= delete $Registry->{"CUser/Software/Microsoft/Windows/"}
+ defined($res) || die "Can't delete URL key: $^E\n";
+
+Since the "Windows" key should contain subkeys, that C<delete>
+statement should make no changes to the Registry, return C<undef>,
+and set C<$^E> to "Access is denied".
+
+=item Not deleting again
+
+ $tips= $Registry->{"CUser/Software/Microsoft/Windows/" .
+ "CurrentVersion/Explorer/Tips/"};
+ delete $tips;
+
+The Perl C<delete> function requires that its argument be an
+expression that ends in a hash element lookup [or hash slice],
+which is not the case here. The C<delete> function doesn't
+know which hash $tips came from and so can't delete it.
+
+=back
+
+=head2 Objects Documentation
+
+The following member functions are defined for use on
+I<Win32::TieRegistry> objects:
+
+=over
+
+=item new
+
+The C<new> method creates a new I<Win32::TieRegistry> object.
+C<new> is mostly a synonym for C<Open()> so see C<Open()> below for
+information on what arguments to pass in. Examples:
+
+ $machKey= new Win32::TieRegistry "LMachine"
+ or die "Can't access HKEY_LOCAL_MACHINE key: $^E\n";
+ $userKey= Win32::TieRegistry->new("CUser")
+ or die "Can't access HKEY_CURRENT_USER key: $^E\n";
+
+Note that calling C<new> via a reference to a tied hash returns
+a simple object, not a reference to a tied hash.
+
+=item Open
+
+=item $subKey= $key->Open( $sSubKey, $rhOptions )
+
+The C<Open> method opens a Registry key and returns a new
+I<Win32::TieRegistry> object associated with that Registry key.
+If C<Open> is called via a reference to a tied hash, then C<Open>
+returns another reference to a tied hash. Otherwise C<Open>
+returns a simple object and you should then use C<TiedRef> to get
+a reference to a tied hash.
+
+C<$sSubKey> is a string specifying a subkey to be opened.
+Alternately C<$sSubKey> can be a reference to an array value
+containing the list of increasingly deep subkeys specifying the
+path to the subkey to be opened.
+
+C<$rhOptions> is an optional reference to a hash containing extra
+options. The C<Open> method supports two options, C<"Delimiter">
+and C<"Access">, and C<$rhOptions> should have only have zero or
+more of these strings as keys. See the "Examples" section below
+for more information.
+
+The C<"Delimiter"> option specifies what string [usually a single
+character] will be used as the delimiter to be appended to subkey
+names and prepended to value names. If this option is not specified,
+the new key [C<$subKey>] inherits the delimiter of the old key
+[C<$key>].
+
+The C<"Access"> option specifies what level of access to the
+Registry key you wish to have once it has been opened. If this
+option is not specified, the new key [C<$subKey>] is opened with
+the same access level used when the old key [C<$key>] was opened.
+The virtual root of the Registry pretends it was opened with
+access C<KEY_READ()|KEY_WRITE()> so this is the default access when
+opening keys directory via C<$Registry>. If you don't plan on
+modifying a key, you should open it with C<KEY_READ> access as
+you may not have C<KEY_WRITE> access to it or some of its subkeys.
+
+If the C<"Access"> option value is a string that starts with
+C<"KEY_">, then it should match E<one> of the predefined access
+levels [probably C<"KEY_READ">, C<"KEY_WRITE">, or
+C<"KEY_ALL_ACCESS">] exported by the I<Win32API::Registry> module.
+Otherwise, a numeric value is expected. For maximum flexibility,
+include C<use Win32::TieRegistry qw(:KEY_);>, for example, near
+the top of your script so you can specify more complicated access
+levels such as C<KEY_READ()|KEY_WRITE()>.
+
+If C<$sSubKey> does not begin with the delimiter [or C<$sSubKey>
+is an array reference], then the path to the subkey to be opened
+will be relative to the path of the original key [C<$key>]. If
+C<$sSubKey> begins with a single delimiter, then the path to the
+subkey to be opened will be relative to the virtual root of the
+Registry on whichever machine the original key resides. If
+C<$sSubKey> begins with two consectutive delimiters, then those
+must be followed by a machine name which causes the C<Connect()>
+method function to be called.
+
+Examples:
+
+ $machKey= $Registry->Open( "LMachine", {Access=>KEY_READ(),Delimiter=>"/"} )
+ or die "Can't open HKEY_LOCAL_MACHINE key: $^E\n";
+ $swKey= $machKey->Open( "Software" );
+ $logonKey= $swKey->Open( "Microsoft/Windows NT/CurrentVersion/Winlogon/" );
+ $NTversKey= $swKey->Open( ["Microsoft","Windows NT","CurrentVersion"] );
+ $versKey= $swKey->Open( qw(Microsoft Windows CurrentVersion) );
+
+ $remoteKey= $Registry->Open( "//HostA/LMachine/System/", {Delimiter=>"/"} )
+ or die "Can't connect to HostA or can't open subkey: $^E\n";
+
+=item Clone
+
+=item $copy= $key->Clone
+
+Creates a new object that is associated with the same Registry key
+as the invoking object.
+
+=item Connect
+
+=item $remoteKey= $Registry->Connect( $sMachineName, $sKeyPath, $rhOptions )
+
+The C<Connect> method connects to the Registry of a remote machine,
+and opens a key within it, then returns a new I<Win32::TieRegistry>
+object associated with that remote Registry key. If C<Connect>
+was called using a reference to a tied hash, then the return value
+will also be a reference to a tied hash [or C<undef>]. Otherwise,
+if you wish to use the returned object as a tied hash [not just as
+an object], then use the C<TiedRef> method function after C<Connect>.
+
+C<$sMachineName> is the name of the remote machine. You don't have
+to preceed the machine name with two delimiter characters.
+
+C<$sKeyPath> is a string specifying the remote key to be opened.
+Alternately C<$sKeyPath> can be a reference to an array value
+containing the list of increasingly deep keys specifying the path
+to the key to be opened.
+
+C<$rhOptions> is an optional reference to a hash containing extra
+options. The C<Connect> method supports two options, C<"Delimiter">
+and C<"Access">. See the C<Open> method documentation for more
+information on these options.
+
+C<$sKeyPath> is already relative to the virtual root of the Registry
+of the remote machine. A single leading delimiter on C<sKeyPath>
+will be ignored and is not required.
+
+C<$sKeyPath> can be empty in which case C<Connect> will return an
+object representing the virtual root key of the remote Registry.
+Each subsequent use of C<Open> on this virtual root key will call
+the system C<RegConnectRegistry> function.
+
+The C<Connect> method can be called via any I<Win32::TieRegistry>
+object, not just C<$Registry>. Attributes such as the desired
+level of access and the delimiter will be inherited from the
+object used but the C<$sKeyPath> will always be relative to the
+virtual root of the remote machine's registry.
+
+Examples:
+
+ $remMachKey= $Registry->Connect( "HostA", "LMachine", {Delimiter->"/"} )
+ or die "Can't connect to HostA's HKEY_LOCAL_MACHINE key: $^E\n";
+
+ $remVersKey= $remMachKey->Connect( "www.microsoft.com",
+ "LMachine/Software/Microsoft/Inetsrv/CurrentVersion/",
+ { Access=>KEY_READ, Delimiter=>"/" } )
+ or die "Can't check what version of IIS Microsoft is running: $^E\n";
+
+ $remVersKey= $remMachKey->Connect( "www",
+ qw(LMachine Software Microsoft Inetsrv CurrentVersion) )
+ or die "Can't check what version of IIS we are running: $^E\n";
+
+=item ObjectRef
+
+=item $object_ref= $obj_or_hash_ref->ObjectRef
+
+For a simple object, just returns itself [C<$obj == $obj->ObjectRef>].
+
+For a reference to a tied hash [if it is also an object], C<ObjectRef>
+returns the simple object that the hash is tied to.
+
+This is primarilly useful when debugging since typing C<x $Registry>
+will try to display your I<entire> registry contents to your screen.
+But the debugger command C<x $Registry->ObjectRef> will just dump
+the implementation details of the underlying object to your screen.
+
+=item Flush( $bFlush )
+
+Flushes all cached information about the Registry key so that future
+uses will get fresh data from the Registry.
+
+If the optional C<$bFlush> is specified and a true value, then
+C<RegFlushKey()> will be called, which is almost never necessary.
+
+=item GetValue
+
+=item $ValueData= $key->GetValue( $sValueName )
+
+=item ($ValueData,$ValueType)= $key->GetValue( $sValueName )
+
+Gets a Registry value's data and data type.
+
+C<$ValueData> is usually just a Perl string that contains the
+value data [packed into it]. For certain types of data, however,
+C<$ValueData> may be processed as described below.
+
+C<$ValueType> is the C<REG_*> constant describing the type of value
+data stored in C<$ValueData>. If the C<DualTypes()> option is on,
+then C<$ValueType> will be a dual value. That is, when used in a
+numeric context, C<$ValueType> will give the numeric value of a
+C<REG_*> constant. However, when used in a non-numeric context,
+C<$ValueType> will return the name of the C<REG_*> constant, for
+example C<"REG_SZ"> [note the quotes]. So both of the following
+can be true at the same time:
+
+ $ValueType == REG_SZ()
+ $ValueType eq "REG_SZ"
+
+=over
+
+=item REG_SZ and REG_EXPAND_SZ
+
+If the C<FixSzNulls()> option is on, then the trailing C<'\0'> will be
+stripped [unless there isn't one] before values of type C<REG_SZ>
+and C<REG_EXPAND_SZ> are returned. Note that C<SetValue()> will add
+a trailing C<'\0'> under similar circumstances.
+
+=item REG_MULTI_SZ
+
+If the C<SplitMultis()> option is on, then values of this type are
+returned as a reference to an array containing the strings. For
+example, a value that, with C<SplitMultis()> off, would be returned as:
+
+ "Value1\000Value2\000\000"
+
+would be returned, with C<SplitMultis()> on, as:
+
+ [ "Value1", "Value2" ]
+
+=item REG_DWORD
+
+If the C<DualBinVals()> option is on, then the value is returned
+as a scalar containing both a string and a number [much like
+the C<$!> variable -- see the L<SetDualVar> module for more
+information] where the number part is the "unpacked" value.
+Use the returned value in a numeric context to access this part
+of the value. For example:
+
+ $num= 0 + $Registry->{"CUser/Console//ColorTable01"};
+
+If the C<DWordsToHex()> option is off, the string part of the
+returned value is a packed, 4-byte string [use C<unpack("L",$value)>
+to get the numeric value.
+
+If C<DWordsToHex()> is on, the string part of the returned value is
+a 10-character hex strings [with leading "0x"]. You can use
+C<hex($value)> to get the numeric value.
+
+Note that C<SetValue()> will properly understand each of these
+returned value formats no matter how C<DualBinVals()> is set.
+
+=back
+
+=item ValueNames
+
+=item @names= $key->ValueNames
+
+Returns the list of value names stored directly in a Registry key.
+Note that the names returned do I<not> have a delimiter prepended
+to them like with C<MemberNames()> and tied hashes.
+
+Once you request this information, it is cached in the object and
+future requests will always return the same list unless C<Flush()>
+has been called.
+
+=item SubKeyNames
+
+=item @key_names= $key->SubKeyNames
+
+Returns the list of subkey names stored directly in a Registry key.
+Note that the names returned do I<not> have a delimiter appended
+to them like with C<MemberNames()> and tied hashes.
+
+Once you request this information, it is cached in the object and
+future requests will always return the same list unless C<Flush()>
+has been called.
+
+=item SubKeyClasses
+
+=item @classes= $key->SubKeyClasses
+
+Returns the list of classes for subkeys stored directly in a
+Registry key. The classes are returned in the same order as
+the subkey names returned by C<SubKeyNames()>.
+
+=item SubKeyTimes
+
+=item @times= $key->SubKeyTimes
+
+Returns the list of last-modified times for subkeys stored
+directly in a Registry key. The times are returned in the same
+order as the subkey names returned by C<SubKeyNames()>. Each
+time is a C<FILETIME> structure packed into a Perl string.
+
+Once you request this information, it is cached in the object and
+future requests will always return the same list unless C<Flush()>
+has been called.
+
+=item MemberNames
+
+=item @members= $key->MemberNames
+
+Returns the list of subkey names and value names stored directly
+in a Registry key. Subkey names have a delimiter appended to the
+end and value names have a delimiter prepended to the front.
+
+Note that a value name could end in a delimiter [or could be C<"">
+so that the member name returned is just a delimiter] so the
+presence or absence of the leading delimiter is what should be
+used to determine whether a particular name is for a subkey or a
+value, not the presence or absence of a trailing delimiter.
+
+Once you request this information, it is cached in the object and
+future requests will always return the same list unless C<Flush()>
+has been called.
+
+=item Information
+
+=item %info= $key->Information
+
+=item @items= $key->Information( @itemNames );
+
+Returns the following information about a Registry key:
+
+=over
+
+=item LastWrite
+
+A C<FILETIME> structure indicating when the key was last modified
+and packed into a Perl string.
+
+=item CntSubKeys
+
+The number of subkeys stored directly in this key.
+
+=item CntValues
+
+The number of values stored directly in this key.
+
+=item SecurityLen
+
+The length [in bytes] of the largest[?] C<SECURITY_DESCRIPTOR>
+associated with the Registry key.
+
+=item MaxValDataLen
+
+The length [in bytes] of the longest value data associated with
+a value stored in this key.
+
+=item MaxSubKeyLen
+
+The length [in chars] of the longest subkey name associated with
+a subkey stored in this key.
+
+=item MaxSubClassLen
+
+The length [in chars] of the longest class name associated with
+a subkey stored directly in this key.
+
+=item MaxValNameLen
+
+The length [in chars] of the longest value name associated with
+a value stored in this key.
+
+=back
+
+With no arguments, returns a hash [not a reference to a hash] where
+the keys are the names for the items given above and the values
+are the information describe above. For example:
+
+ %info= ( "CntValues" => 25, # Key contains 25 values.
+ "MaxValNameLen" => 20, # One of which has a 20-char name.
+ "MaxValDataLen" => 42, # One of which has a 42-byte value.
+ "CntSubKeys" => 1, # Key has 1 immediate subkey.
+ "MaxSubKeyLen" => 13, # One of which has a 12-char name.
+ "MaxSubClassLen" => 0, # All of which have class names of "".
+ "SecurityLen" => 232, # One SECURITY_DESCRIPTOR is 232 bytes.
+ "LastWrite" => "\x90mZ\cX{\xA3\xBD\cA\c@\cA"
+ # Key was last modifed 1998/06/01 16:29:32 GMT
+ );
+
+With arguments, each one must be the name of a item given above.
+The return value is the information associated with the listed
+names. In other words:
+
+ return $key->Information( @names );
+
+returns the same list as:
+
+ %info= $key->Information;
+ return @info{@names};
+
+=item Delimiter
+
+=item $oldDelim= $key->Delimiter
+
+=item $oldDelim= $key->Delimiter( $newDelim )
+
+Gets and possibly changes the delimiter used for this object. The
+delimiter is appended to subkey names and prepended to value names
+in many return values. It is also used when parsing keys passed
+to tied hashes.
+
+The delimiter defaults to backslash (C<'\\'>) but is inherited from
+the object used to create a new object and can be specified by an
+option when a new object is created.
+
+=item Handle
+
+=item $handle= $key->Handle
+
+Returns the raw C<HKEY> handle for the associated Registry key as
+an integer value. This value can then be used to Reg*() calls
+from I<Win32API::Registry>. However, it is usually easier to just
+call the I<Win32API::Registry> calls directly via:
+
+ $key->RegNotifyChangeKeyValue( ... );
+
+For the virtual root of the local or a remote Registry,
+C<Handle()> return C<"NONE">.
+
+=item Path
+
+=item $path= $key->Path
+
+Returns a string describing the path of key names to this
+Registry key. The string is built so that if it were passed
+to C<$Registry->Open()>, it would reopen the same Registry key
+[except in the rare case where one of the key names contains
+C<$key->Delimiter>].
+
+=item Machine
+
+=item $computerName= $key->Machine
+
+Returns the name of the computer [or "machine"] on which this Registry
+key resides. Returns C<""> for local Registry keys.
+
+=item Access
+
+Returns the numeric value of the bit mask used to specify the
+types of access requested when this Registry key was opened. Can
+be compared to C<KEY_*> values.
+
+=item OS_Delimiter
+
+Returns the delimiter used by the operating system's RegOpenKeyEx()
+call. For Win32, this is always backslash (C<"\\">).
+
+=item Roots
+
+Returns the mapping from root key names like C<"LMachine"> to their
+associated C<HKEY_*> constants. Primarily for internal use and
+subject to change.
+
+=item Tie
+
+=item $key->Tie( \%hash );
+
+Ties the referenced hash to that Registry key. Pretty much the
+same as
+
+ tie %hash, ref($key), $key;
+
+Since C<ref($key)> is the class [package] to tie the hash to and
+C<TIEHASH()> just returns its argument, C<$key>, [without calling
+C<new()>] when it sees that it is already a blessed object.
+
+=item TiedRef
+
+=item $TiedHashRef= $hash_or_obj_ref->TiedRef
+
+For a simple object, returns a reference to a hash tied to the
+object. Used to promote a simple object into a combined object
+and hash ref.
+
+If already a reference to a tied hash [that is also an object],
+it just returns itself [C<$ref == $ref->TiedRef>].
+
+Mostly used internally.
+
+=item ArrayValues
+
+=item $oldBool= $key->ArrayValues
+
+=item $oldBool= $key->ArrayValues( $newBool )
+
+Gets the current setting of the C<ArrayValues> option and possibly
+turns it on or off.
+
+When off, Registry values fetched via a tied hash are returned as
+just a value scalar [the same as C<GetValue()> in a scalar context].
+When on, they are returned as a reference to an array containing
+the value data as the C<[0]> element and the data type as the C<[1]>
+element.
+
+=item TieValues
+
+=item $oldBool= TieValues
+
+=item $oldBool= TieValues( $newBool )
+
+Gets the current setting of the C<TieValues> option and possibly
+turns it on or off.
+
+Turning this option on is not yet supported in this release of
+I<Win32::TieRegistry>. In a future release, turning this option
+on will cause Registry values returned from a tied hash to be
+a tied array that you can use to modify the value in the Registry.
+
+=item FastDelete
+
+=item $oldBool= $key->FastDelete
+
+=item $oldBool= $key->FastDelete( $newBool )
+
+Gets the current setting of the C<FastDelete> option and possibly
+turns it on or off.
+
+When on, successfully deleting a Registry key [via a tied hash]
+simply returns C<1>.
+
+When off, successfully deleting a Registry key [via a tied hash
+and not in a void context] returns a reference to a hash that
+contains the values present in the key when it was deleted. This
+hash is just like that returned when referencing the key before it
+was deleted except that it is an ordinary hash, not one tied to
+the I<Win32::TieRegistry> package.
+
+Note that deleting either a Registry key or value via a tied hash
+I<in a void context> prevents any overhead in trying to build an
+appropriate return value.
+
+Note that deleting a Registry I<value> via a tied hash [not in
+a void context] returns the value data even if <FastDelete> is on.
+
+=item SplitMultis
+
+=item $oldBool= $key->SplitMultis
+
+=item $oldBool= $key->SplitMultis( $newBool )
+
+Gets the current setting of the C<SplitMultis> option and possibly
+turns it on or off.
+
+If on, Registry values of type C<REG_MULTI_SZ> are returned as
+a reference to an array of strings. See C<GetValue()> for more
+information.
+
+=item DWordsToHex
+
+=item $oldBool= $key->DWordsToHex
+
+=item $oldBool= $key->DWordsToHex( $newBool )
+
+Gets the current setting of the C<DWordsToHex> option and possibly
+turns it on or off.
+
+If on, Registry values of type C<REG_DWORD> are returned as a hex
+string with leading C<"0x"> and longer than 4 characters. See
+C<GetValue()> for more information.
+
+=item FixSzNulls
+
+=item $oldBool= $key->FixSzNulls
+
+=item $oldBool= $key->FixSzNulls( $newBool )
+
+Gets the current setting of the C<FixSzNulls> option and possibly
+turns it on or off.
+
+If on, Registry values of type C<REG_SZ> and C<REG_EXPAND_SZ> have
+trailing C<'\0'>s added before they are set and stripped before
+they are returned. See C<GetValue()> and C<SetValue()> for more
+information.
+
+=item DualTypes
+
+=item $oldBool= $key->DualTypes
+
+=item $oldBool= $key->DualTypes( $newBool )
+
+Gets the current setting of the C<DualTypes> option and possibly
+turns it on or off.
+
+If on, data types are returned as a combined numeric/string value
+holding both the numeric value of a C<REG_*> constant and the
+string value of the constant's name. See C<GetValue()> for
+more information.
+
+=item DualBinVals
+
+=item $oldBool= $key->DualBinVals
+
+=item $oldBool= $key->DualBinVals( $newBool )
+
+Gets the current setting of the C<DualBinVals> option and possibly
+turns it on or off.
+
+If on, Registry value data of type C<REG_BINARY> and no more than
+4 bytes long and Registry values of type C<REG_DWORD> are returned
+as a combined numeric/string value where the numeric value is the
+"unpacked" binary value as returned by:
+
+ hex reverse unpack( "h*", $valData )
+
+on a "little-endian" computer. [Would be C<hex unpack("H*",$valData)>
+on a "big-endian" computer if this module is ever ported to one.]
+
+See C<GetValue()> for more information.
+
+=item GetOptions
+
+=item @oldOptValues= $key->GetOptions( @optionNames )
+
+=item $refHashOfOldOpts= $key->GetOptions()
+
+=item $key->GetOptions( \%hashForOldOpts )
+
+Returns the current setting of any of the following options:
+
+ Delimiter FixSzNulls DWordsToHex
+ ArrayValues SplitMultis DualBinVals
+ TieValues FastDelete DualTypes
+
+Pass in one or more of the above names (as strings) to get back
+an array of the corresponding current settings in the same order:
+
+ my( $fastDel, $delim )= $key->GetOptions("FastDelete","Delimiter");
+
+Pass in no arguments to get back a reference to a hash where
+the above option names are the keys and the values are
+the corresponding current settings for each option:
+
+ my $href= $key->GetOptions();
+ my $delim= $href->{Delimiter};
+
+Pass in a single reference to a hash to have the above key/value
+pairs I<added> to the referenced hash. For this case, the
+return value is the original object so further methods can be
+chained after the call to GetOptions:
+
+ my %oldOpts;
+ $key->GetOptions( \%oldOpts )->SetOptions( Delimiter => "/" );
+
+=item SetOptions
+
+=item @oldOpts= $key->SetOptions( optNames=>$optValue,... )
+
+Changes the current setting of any of the following options,
+returning the previous setting(s):
+
+ Delimiter FixSzNulls DWordsToHex AllowLoad
+ ArrayValues SplitMultis DualBinVals AllowSave
+ TieValues FastDelete DualTypes
+
+For C<AllowLoad> and C<AllowSave>, instead of the previous
+setting, C<SetOptions> returns whether or not the change was
+successful.
+
+In a scalar context, returns only the last item. The last
+option can also be specified as C<"ref"> or C<"r"> [which doesn't
+need to be followed by a value] to allow chaining:
+
+ $key->SetOptions(AllowSave=>1,"ref")->RegSaveKey(...)
+
+=item SetValue
+
+=item $okay= $key->SetValue( $ValueName, $ValueData );
+
+=item $okay= $key->SetValue( $ValueName, $ValueData, $ValueType );
+
+Adds or replaces a Registry value. Returns a true value if
+successfully, false otherwise.
+
+C<$ValueName> is the name of the value to add or replace and
+should I<not> have a delimiter prepended to it. Case is ignored.
+
+C<$ValueType> is assumed to be C<REG_SZ> if it is omitted. Otherwise,
+it should be one the C<REG_*> constants.
+
+C<$ValueData> is the data to be stored in the value, probably packed
+into a Perl string. Other supported formats for value data are
+listed below for each posible C<$ValueType>.
+
+=over
+
+=item REG_SZ or REG_EXPAND_SZ
+
+The only special processing for these values is the addition of
+the required trailing C<'\0'> if it is missing. This can be
+turned off by disabling the C<FixSzNulls> option.
+
+=item REG_MULTI_SZ
+
+These values can also be specified as a reference to a list of
+strings. For example, the following two lines are equivalent:
+
+ $key->SetValue( "Val1\000Value2\000LastVal\000\000", "REG_MULTI_SZ" );
+ $key->SetValue( ["Val1","Value2","LastVal"], "REG_MULTI_SZ" );
+
+Note that if the required two trailing nulls (C<"\000\000">) are
+missing, then this release of C<SetValue()> will I<not> add them.
+
+=item REG_DWORD
+
+These values can also be specified as a hex value with the leading
+C<"0x"> included and totaling I<more than> 4 bytes. These will be
+packed into a 4-byte string via:
+
+ $data= pack( "L", hex($data) );
+
+=item REG_BINARY
+
+This value type is listed just to emphasize that no alternate
+format is supported for it. In particular, you should I<not> pass
+in a numeric value for this type of data. C<SetValue()> cannot
+distinguish such from a packed string that just happens to match
+a numeric value and so will treat it as a packed string.
+
+=back
+
+An alternate calling format:
+
+ $okay= $key->SetValue( $ValueName, [ $ValueData, $ValueType ] );
+
+[two arguments, the second of which is a reference to an array
+containing the value data and value type] is supported to ease
+using tied hashes with C<SetValue()>.
+
+=item CreateKey
+
+=item $newKey= $key->CreateKey( $subKey );
+
+=item $newKey= $key->CreateKey( $subKey, { Option=>OptVal,... } );
+
+Creates a Registry key or just updates attributes of one. Calls
+C<RegCreateKeyEx()> then, if it succeeded, creates an object
+associated with the [possibly new] subkey.
+
+C<$subKey> is the name of a subkey [or a path to one] to be
+created or updated. It can also be a reference to an array
+containing a list of subkey names.
+
+The second argument, if it exists, should be a reference to a
+hash specifying options either to be passed to C<RegCreateKeyEx()>
+or to be used when creating the associated object. The following
+items are the supported keys for this options hash:
+
+=over
+
+=item Delimiter
+
+Specifies the delimiter to be used to parse C<$subKey> and to be
+used in the new object. Defaults to C<$key->Delimiter>.
+
+=item Access
+
+Specifies the types of access requested when the subkey is opened.
+Should be a numeric bit mask that combines one or more C<KEY_*>
+constant values.
+
+=item Class
+
+The name to assign as the class of the new or updated subkey.
+Defaults to C<""> as we have never seen a use for this information.
+
+=item Disposition
+
+Lets you specify a reference to a scalar where, upon success, will be
+stored either C<REG_CREATED_NEW_KEY()> or C<REG_OPENED_EXISTING_KEY()>
+depending on whether a new key was created or an existing key was
+opened.
+
+If you, for example, did C<use Win32::TieRegistry qw(REG_CREATED_NEW_KEY)>
+then you can use C<REG_CREATED_NEW_KEY()> to compare against the numeric
+value stored in the referenced scalar.
+
+If the C<DualTypes> option is enabled, then in addition to the
+numeric value described above, the referenced scalar will also
+have a string value equal to either C<"REG_CREATED_NEW_KEY"> or
+C<"REG_OPENED_EXISTING_KEY">, as appropriate.
+
+=item Security
+
+Lets you specify a C<SECURITY_ATTRIBUTES> structure packed into a
+Perl string. See C<Win32API::Registry::RegCreateKeyEx()> for more
+information.
+
+=item Volatile
+
+If true, specifies that the new key should be volatile, that is,
+stored only in memory and not backed by a hive file [and not saved
+if the computer is rebooted]. This option is ignored under
+Windows 95. Specifying C<Volatile=E<GT>1> is the same as
+specifying C<Options=E<GT>REG_OPTION_VOLATILE>.
+
+=item Backup
+
+If true, specifies that the new key should be opened for
+backup/restore access. The C<Access> option is ignored. If the
+calling process has enabled C<"SeBackupPrivilege">, then the
+subkey is opened with C<KEY_READ> access as the C<"LocalSystem">
+user which should have access to all subkeys. If the calling
+process has enabled C<"SeRestorePrivilege">, then the subkey is
+opened with C<KEY_WRITE> access as the C<"LocalSystem"> user which
+should have access to all subkeys.
+
+This option is ignored under Windows 95. Specifying C<Backup=E<GT>1>
+is the same as specifying C<Options=E<GT>REG_OPTION_BACKUP_RESTORE>.
+
+=item Options
+
+Lets you specify options to the C<RegOpenKeyEx()> call. The value
+for this option should be a numeric value combining zero or more
+of the C<REG_OPTION_*> bit masks. You may with to used the
+C<Volatile> and/or C<Backup> options instead of this one.
+
+=back
+
+=item StoreKey
+
+=item $newKey= $key->StoreKey( $subKey, \%Contents );
+
+Primarily for internal use.
+
+Used to create or update a Registry key and any number of subkeys
+or values under it or its subkeys.
+
+C<$subKey> is the name of a subkey to be created [or a path of
+subkey names separated by delimiters]. If that subkey already
+exists, then it is updated.
+
+C<\%Contents> is a reference to a hash containing pairs of
+value names with value data and/or subkey names with hash
+references similar to C<\%Contents>. Each of these cause
+a value or subkey of C<$subKey> to be created or updated.
+
+If C<$Contents{""}> exists and is a reference to a hash, then
+it used as the options argument when C<CreateKey()> is called
+for C<$subKey>. This allows you to specify ...
+
+ if( defined( $$data{""} ) && "HASH" eq ref($$data{""}) ) {
+ $self= $this->CreateKey( $subKey, delete $$data{""} );
+
+=item Load
+
+=item $newKey= $key->Load( $file )
+
+=item $newKey= $key->Load( $file, $newSubKey )
+
+=item $newKey= $key->Load( $file, $newSubKey, { Option=>OptVal... } )
+
+=item $newKey= $key->Load( $file, { Option=>OptVal... } )
+
+Loads a hive file into a Registry. That is, creates a new subkey
+and associates a hive file with it.
+
+C<$file> is a hive file, that is a file created by calling
+C<RegSaveKey()>. The C<$file> path is interpreted relative to
+C<%SystemRoot%/System32/config> on the machine where C<$key>
+resides.
+
+C<$newSubKey> is the name to be given to the new subkey. If
+C<$newSubKey> is specified, then C<$key> must be
+C<HKEY_LOCAL_MACHINE> or C<HKEY_USERS> of the local computer
+or a remote computer and C<$newSubKey> should not contain any
+occurrences of either the delimiter or the OS delimiter.
+
+If C<$newSubKey> is not specified, then it is as if C<$key>
+was C<$Registry-E<GT>{LMachine}> and C<$newSubKey> is
+C<"PerlTie:999"> where C<"999"> is actually a sequence number
+incremented each time this process calls C<Load()>.
+
+You can specify as the last argument a reference to a hash
+containing options. You can specify the same options that you
+can specify to C<Open()>. See C<Open()> for more information on
+those. In addition, you can specify the option C<"NewSubKey">.
+The value of this option is interpretted exactly as if it was
+specified as the C<$newSubKey> parameter and overrides the
+C<$newSubKey> if one was specified.
+
+The hive is automatically unloaded when the returned object
+[C<$newKey>] is destroyed. Registry key objects opened within
+the hive will keep a reference to the C<$newKey> object so that
+it will not be destroyed before these keys are closed.
+
+=item UnLoad
+
+=item $okay= $key->UnLoad
+
+Unloads a hive that was loaded via C<Load()>. Cannot unload other
+hives. C<$key> must be the return from a previous call to C<Load()>.
+C<$key> is closed and then the hive is unloaded.
+
+=item AllowSave
+
+=item $okay= AllowSave( $bool )
+
+Enables or disables the C<"ReBackupPrivilege"> privilege for the
+current process. You will probably have to enable this privilege
+before you can use C<RegSaveKey()>.
+
+The return value indicates whether the operation succeeded, not
+whether the privilege was previously enabled.
+
+=item AllowLoad
+
+=item $okay= AllowLoad( $bool )
+
+Enables or disables the C<"ReRestorePrivilege"> privilege for the
+current process. You will probably have to enable this privilege
+before you can use C<RegLoadKey()>, C<RegUnLoadKey()>,
+C<RegReplaceKey()>, or C<RegRestoreKey> and thus C<Load()> and
+C<UnLoad()>.
+
+The return value indicates whether the operation succeeded, not
+whether the privilege was previously enabled.
+
+=back
+
+=head2 Exports [C<use> and C<import()>]
+
+To have nothing imported into your package, use something like:
+
+ use Win32::TieRegistry 0.20 ();
+
+which would verify that you have at least version 0.20 but wouldn't
+call C<import()>. The F<Changes> file can be useful in figuring out
+which, if any, prior versions of I<Win32::TieRegistry> you want to
+support in your script.
+
+The code
+
+ use Win32::TieRegistry;
+
+imports the variable C<$Registry> into your package and sets it
+to be a reference to a hash tied to a copy of the master Registry
+virtual root object with the default options. One disadvantage
+to this "default" usage is that Perl does not support checking
+the module version when you use it.
+
+Alternately, you can specify a list of arguments on the C<use>
+line that will be passed to the C<Win32::TieRegistry->import()>
+method to control what items to import into your package. These
+arguments fall into the following broad categories:
+
+=over
+
+=item Import a reference to a hash tied to a Registry virtual root
+
+You can request that a scalar variable be imported (possibly)
+and set to be a reference to a hash tied to a Registry virtual root
+using any of the following types of arguments or argument pairs:
+
+=over
+
+=item "TiedRef", '$scalar'
+
+=item "TiedRef", '$pack::scalar'
+
+=item "TiedRef", 'scalar'
+
+=item "TiedRef", 'pack::scalar'
+
+All of the above import a scalar named C<$scalar> into your package
+(or the package named "pack") and then sets it.
+
+=item '$scalar'
+
+=item '$pack::scalar'
+
+These are equivalent to the previous items to support a more
+traditional appearance to the list of exports. Note that the
+scalar name cannot be "RegObj" here.
+
+=item "TiedRef", \$scalar
+
+=item \$scalar
+
+These versions don't import anything but set the referenced C<$scalar>.
+
+=back
+
+=item Import a hash tied to the Registry virtual root
+
+You can request that a hash variable be imported (possibly)
+and tied to a Registry virtual root using any of the following
+types of arguments or argument pairs:
+
+=over
+
+=item "TiedHash", '%hash'
+
+=item "TiedHash", '%pack::hash'
+
+=item "TiedHash", 'hash'
+
+=item "TiedHash", 'pack::hash'
+
+All of the above import a hash named C<%hash> into your package
+(or the package named "pack") and then sets it.
+
+=item '%hash'
+
+=item '%pack::hash'
+
+These are equivalent to the previous items to support a more
+traditional appearance to the list of exports.
+
+=item "TiedHash", \%hash
+
+=item \%hash
+
+These versions don't import anything but set the referenced C<%hash>.
+
+=back
+
+=item Import a Registry virtual root object
+
+You can request that a scalar variable be imported (possibly)
+and set to be a Registry virtual root object using any of the
+following types of arguments or argument pairs:
+
+=over
+
+=item "ObjectRef", '$scalar'
+
+=item "ObjectRef", '$pack::scalar'
+
+=item "ObjectRef", 'scalar'
+
+=item "ObjectRef", 'pack::scalar'
+
+All of the above import a scalar named C<$scalar> into your package
+(or the package named "pack") and then sets it.
+
+=item '$RegObj'
+
+This is equivalent to the previous items for backward compatibility.
+
+=item "ObjectRef", \$scalar
+
+This version doesn't import anything but sets the referenced C<$scalar>.
+
+=back
+
+=item Import constant(s) exported by I<Win32API::Registry>
+
+You can list any constants that are exported by I<Win32API::Registry>
+to have them imported into your package. These constants have names
+starting with "KEY_" or "REG_" (or even "HKEY_").
+
+You can also specify C<":KEY_">, C<":REG_">, and even C<":HKEY_"> to
+import a whole set of constants.
+
+See I<Win32API::Registry> documentation for more information.
+
+=item Options
+
+You can list any option names that can be listed in the C<SetOptions()>
+method call, each folowed by the value to use for that option.
+A Registry virtual root object is created, all of these options are
+set for it, then each variable to be imported/set is associated with
+this object.
+
+In addition, the following special options are supported:
+
+=over
+
+=item ExportLevel
+
+Whether to import variables into your package or some
+package that uses your package. Defaults to the value of
+C<$Exporter::ExportLevel> and has the same meaning. See
+the L<Exporter> module for more information.
+
+=item ExportTo
+
+The name of the package to import variables and constants into.
+Overrides I<ExportLevel>.
+
+=back
+
+=back
+
+=head3 Specifying constants in your Perl code
+
+This module was written with a strong emphasis on the convenience of
+the module user. Therefore, most places where you can specify a
+constant like C<REG_SZ()> also allow you to specify a string
+containing the name of the constant, C<"REG_SZ">. This is convenient
+because you may not have imported that symbolic constant.
+
+Perl also emphasizes programmer convenience so the code C<REG_SZ>
+can be used to mean C<REG_SZ()> or C<"REG_SZ"> or be illegal.
+Note that using C<&REG_SZ> (as we've seen in much Win32 Perl code)
+is not a good idea since it passes the current C<@_> to the
+C<constant()> routine of the module which, at the least, can give
+you a warning under B<-w>.
+
+Although greatly a matter of style, the "safest" practice is probably
+to specifically list all constants in the C<use Win32::TieRegistry>
+statement, specify C<use strict> [or at least C<use strict qw(subs)>],
+and use bare constant names when you want the numeric value. This will
+detect mispelled constant names at compile time.
+
+ use strict;
+ my $Registry;
+ use Win32::TieRegistry 0.20 (
+ TiedRef => \$Registry, Delimiter => "/", ArrayValues => 1,
+ SplitMultis => 1, AllowLoad => 1,
+ qw( REG_SZ REG_EXPAND_SZ REG_DWORD REG_BINARY REG_MULTI_SZ
+ KEY_READ KEY_WRITE KEY_ALL_ACCESS ),
+ );
+ $Registry->{"LMachine/Software/FooCorp/"}= {
+ "FooWriter/" => {
+ "/Fonts" => [ ["Times","Courier","Lucinda"], REG_MULTI_SZ ],
+ "/WindowSize" => [ pack("LL",24,80), REG_BINARY ],
+ "/TaskBarIcon" => [ "0x0001", REG_DWORD ],
+ },
+ } or die "Can't create Software/FooCorp/: $^E\n";
+
+If you don't want to C<use strict qw(subs)>, the second safest practice
+is similar to the above but use the C<REG_SZ()> form for constants
+when possible and quoted constant names when required. Note that
+C<qw()> is a form of quoting.
+
+ use Win32::TieRegistry 0.20 qw(
+ TiedRef $Registry
+ Delimiter / ArrayValues 1 SplitMultis 1 AllowLoad 1
+ REG_SZ REG_EXPAND_SZ REG_DWORD REG_BINARY REG_MULTI_SZ
+ KEY_READ KEY_WRITE KEY_ALL_ACCESS
+ );
+ $Registry->{"LMachine/Software/FooCorp/"}= {
+ "FooWriter/" => {
+ "/Fonts" => [ ["Times","Courier","Lucinda"], REG_MULTI_SZ() ],
+ "/WindowSize" => [ pack("LL",24,80), REG_BINARY() ],
+ "/TaskBarIcon" => [ "0x0001", REG_DWORD() ],
+ },
+ } or die "Can't create Software/FooCorp/: $^E\n";
+
+The examples in this document mostly use quoted constant names
+(C<"REG_SZ">) since that works regardless of which constants
+you imported and whether or not you have C<use strict> in your
+script. It is not the best choice for you to use for real
+scripts (vs. examples) because it is less efficient and is not
+supported by most other similar modules.
+
+=head1 SUMMARY
+
+Most things can be done most easily via tied hashes. Skip down to the
+the L<Tied Hashes Summary> to get started quickly.
+
+=head2 Objects Summary
+
+Here are quick examples that document the most common functionality
+of all of the method functions [except for a few almost useless ones].
+
+ # Just another way of saying Open():
+ $key= new Win32::TieRegistry "LMachine\\Software\\",
+ { Access=>KEY_READ()|KEY_WRITE(), Delimiter=>"\\" };
+
+ # Open a Registry key:
+ $subKey= $key->Open( "SubKey/SubSubKey/",
+ { Access=>KEY_ALL_ACCESS, Delimiter=>"/" } );
+
+ # Connect to a remote Registry key:
+ $remKey= $Registry->Connect( "MachineName", "LMachine/",
+ { Access=>KEY_READ, Delimiter=>"/" } );
+
+ # Get value data:
+ $valueString= $key->GetValue("ValueName");
+ ( $valueString, $valueType )= $key->GetValue("ValueName");
+
+ # Get list of value names:
+ @valueNames= $key->ValueNames;
+
+ # Get list of subkey names:
+ @subKeyNames= $key->SubKeyNames;
+
+ # Get combined list of value names (with leading delimiters)
+ # and subkey names (with trailing delimiters):
+ @memberNames= $key->MemberNames;
+
+ # Get all information about a key:
+ %keyInfo= $key->Information;
+ # keys(%keyInfo)= qw( Class LastWrite SecurityLen
+ # CntSubKeys MaxSubKeyLen MaxSubClassLen
+ # CntValues MaxValNameLen MaxValDataLen );
+
+ # Get selected information about a key:
+ ( $class, $cntSubKeys )= $key->Information( "Class", "CntSubKeys" );
+
+ # Get and/or set delimiter:
+ $delim= $key->Delimiter;
+ $oldDelim= $key->Delimiter( $newDelim );
+
+ # Get "path" for an open key:
+ $path= $key->Path;
+ # For example, "/CUser/Control Panel/Mouse/"
+ # or "//HostName/LMachine/System/DISK/".
+
+ # Get name of machine where key is from:
+ $mach= $key->Machine;
+ # Will usually be "" indicating key is on local machine.
+
+ # Control different options (see main documentation for descriptions):
+ $oldBool= $key->ArrayValues( $newBool );
+ $oldBool= $key->FastDelete( $newBool );
+ $oldBool= $key->FixSzNulls( $newBool );
+ $oldBool= $key->SplitMultis( $newBool );
+ $oldBool= $key->DWordsToHex( $newBool );
+ $oldBool= $key->DualBinVals( $newBool );
+ $oldBool= $key->DualTypes( $newBool );
+ @oldBools= $key->SetOptions( ArrayValues=>1, FastDelete=>1, FixSzNulls=>0,
+ Delimiter=>"/", AllowLoad=>1, AllowSave=>1 );
+ @oldBools= $key->GetOptions( ArrayValues, FastDelete, FixSzNulls );
+
+ # Add or set a value:
+ $key->SetValue( "ValueName", $valueDataString );
+ $key->SetValue( "ValueName", pack($format,$valueData), "REG_BINARY" );
+
+ # Add or set a key:
+ $key->CreateKey( "SubKeyName" );
+ $key->CreateKey( "SubKeyName",
+ { Access=>"KEY_ALL_ACCESS", Class=>"ClassName",
+ Delimiter=>"/", Volatile=>1, Backup=>1 } );
+
+ # Load an off-line Registry hive file into the on-line Registry:
+ $newKey= $Registry->Load( "C:/Path/To/Hive/FileName" );
+ $newKey= $key->Load( "C:/Path/To/Hive/FileName", "NewSubKeyName",
+ { Access=>"KEY_READ" } );
+ # Unload a Registry hive file loaded via the Load() method:
+ $newKey->UnLoad;
+
+ # (Dis)Allow yourself to load Registry hive files:
+ $success= $Registry->AllowLoad( $bool );
+
+ # (Dis)Allow yourself to save a Registry key to a hive file:
+ $success= $Registry->AllowSave( $bool );
+
+ # Save a Registry key to a new hive file:
+ $key->RegSaveKey( "C:/Path/To/Hive/FileName", [] );
+
+=head3 Other Useful Methods
+
+See I<Win32API::Registry> for more information on these methods.
+These methods are provided for coding convenience and are
+identical to the I<Win32API::Registry> functions except that these
+don't take a handle to a Registry key, instead getting the handle
+from the invoking object [C<$key>].
+
+ $key->RegGetKeySecurity( $iSecInfo, $sSecDesc, $lenSecDesc );
+ $key->RegLoadKey( $sSubKeyName, $sPathToFile );
+ $key->RegNotifyChangeKeyValue(
+ $bWatchSubtree, $iNotifyFilter, $hEvent, $bAsync );
+ $key->RegQueryMultipleValues(
+ $structValueEnts, $cntValueEnts, $Buffer, $lenBuffer );
+ $key->RegReplaceKey( $sSubKeyName, $sPathToNewFile, $sPathToBackupFile );
+ $key->RegRestoreKey( $sPathToFile, $iFlags );
+ $key->RegSetKeySecurity( $iSecInfo, $sSecDesc );
+ $key->RegUnLoadKey( $sSubKeyName );
+
+=head2 Tied Hashes Summary
+
+For fast learners, this may be the only section you need to read.
+Always append one delimiter to the end of each Registry key name
+and prepend one delimiter to the front of each Registry value name.
+
+=head3 Opening keys
+
+ use Win32::TieRegistry ( Delimiter=>"/", ArrayValues=>1 );
+ $Registry->Delimiter("/"); # Set delimiter to "/".
+ $swKey= $Registry->{"LMachine/Software/"};
+ $winKey= $swKey->{"Microsoft/Windows/CurrentVersion/"};
+ $userKey= $Registry->
+ {"CUser/Software/Microsoft/Windows/CurrentVersion/"};
+ $remoteKey= $Registry->{"//HostName/LMachine/"};
+
+=head3 Reading values
+
+ $progDir= $winKey->{"/ProgramFilesDir"}; # "C:\\Program Files"
+ $tip21= $winKey->{"Explorer/Tips//21"}; # Text of tip #21.
+
+ $winKey->ArrayValues(1);
+ ( $devPath, $type )= $winKey->{"/DevicePath"};
+ # $devPath eq "%SystemRoot%\\inf"
+ # $type eq "REG_EXPAND_SZ" [if you have SetDualVar.pm installed]
+ # $type == REG_EXPAND_SZ() [if did C<use Win32::TieRegistry qw(:REG_)>]
+
+=head3 Setting values
+
+ $winKey->{"Setup//SourcePath"}= "\\\\SwServer\\SwShare\\Windows";
+ # Simple. Assumes data type of REG_SZ.
+
+ $winKey->{"Setup//Installation Sources"}=
+ [ "D:\x00\\\\SwServer\\SwShare\\Windows\0\0", "REG_MULTI_SZ" ];
+ # "\x00" and "\0" used to mark ends of each string and end of list.
+
+ $winKey->{"Setup//Installation Sources"}=
+ [ ["D:","\\\\SwServer\\SwShare\\Windows"], "REG_MULTI_SZ" ];
+ # Alternate method that is easier to read.
+
+ $userKey->{"Explorer/Tips//DisplayInitialTipWindow"}=
+ [ pack("L",0), "REG_DWORD" ];
+ $userKey->{"Explorer/Tips//Next"}= [ pack("S",3), "REG_BINARY" ];
+ $userKey->{"Explorer/Tips//Show"}= [ pack("L",0), "REG_BINARY" ];
+
+=head3 Adding keys
+
+ $swKey->{"FooCorp/"}= {
+ "FooWriter/" => {
+ "/Version" => "4.032",
+ "Startup/" => {
+ "/Title" => "Foo Writer Deluxe ][",
+ "/WindowSize" => [ pack("LL",$wid,$ht), "REG_BINARY" ],
+ "/TaskBarIcon" => [ "0x0001", "REG_DWORD" ],
+ },
+ "Compatibility/" => {
+ "/AutoConvert" => "Always",
+ "/Default Palette" => "Windows Colors",
+ },
+ },
+ "/License", => "0123-9C8EF1-09-FC",
+ };
+
+=head3 Listing all subkeys and values
+
+ @members= keys( %{$swKey} );
+ @subKeys= grep( m#^/#, keys( %{$swKey->{"Classes/batfile/"}} ) );
+ # @subKeys= ( "/", "/EditFlags" );
+ @valueNames= grep( ! m#^/#, keys( %{$swKey->{"Classes/batfile/"}} ) );
+ # @valueNames= ( "DefaultIcon/", "shell/", "shellex/" );
+
+=head3 Deleting values or keys with no subkeys
+
+ $oldValue= delete $userKey->{"Explorer/Tips//Next"};
+
+ $oldValues= delete $userKey->{"Explorer/Tips/"};
+ # $oldValues will be reference to hash containing deleted keys values.
+
+=head3 Closing keys
+
+ undef $swKey; # Explicit way to close a key.
+ $winKey= "Anything else"; # Implicitly closes a key.
+ exit 0; # Implicitly closes all keys.
+
+=head2 Tie::Registry
+
+This module was originally called I<Tie::Registry>. Changing code
+that used I<Tie::Registry> over to I<Win32::TieRegistry> is trivial
+as the module name should only be mentioned once, in the C<use>
+line. However, finding all of the places that used I<Tie::Registry>
+may not be completely trivial so we have included F<Tie/Registry.pm>
+which you can install to provide backward compatibility.
+
+=head1 AUTHOR
+
+Tye McQueen. See http://www.metronet.com/~tye/ or e-mail
+tye@metronet.com with bug reports.
+
+=head1 SEE ALSO
+
+I<Win32API::Registry> - Provides access to C<Reg*()>, C<HKEY_*>,
+C<KEY_*>, C<REG_*> [required].
+
+I<Win32::WinError> - Defines C<ERROR_*> values [optional].
+
+L<SetDualVar> - For returning C<REG_*> values as combined
+string/integer values [optional].
+
+=head1 BUGS
+
+Perl5.004_02 has bugs that make I<Win32::TieRegistry> fail in
+strange and subtle ways.
+
+Using I<Win32::TieRegistry> with versions of Perl prior to 5.005
+can be tricky or impossible. Most notes about this have been
+removed from the documentation (they get rather complicated
+and confusing). This includes references to C<$^E> perhaps not
+being meaningful.
+
+Because Perl hashes are case sensitive, certain lookups are also
+case sensistive. In particular, the root keys ("Classes", "CUser",
+"LMachine", "Users", "PerfData", "CConfig", "DynData", and HKEY_*)
+must always be entered without changing between upper and lower
+case letters. Also, the special rule for matching subkey names
+that contain the user-selected delimiter only works if case is
+matched. All other key name and value name lookups should be case
+insensitive because the underlying Reg*() calls ignore case.
+
+Information about each key is cached when using a tied hash.
+This cache is not flushed nor updated when changes are made,
+I<even when the same tied hash is used> to make the changes.
+
+Current implementations of Perl's "global destruction" phase can
+cause objects returned by C<Load()> to be destroyed while keys
+within the hive are still open, if the objects still exist when
+the script starts to exit. When this happens, the automatic
+C<UnLoad()> will report a failure and the hive will remain loaded
+in the Registry.
+
+Trying to C<Load()> a hive file that is located on a remote network
+share may silently delete all data from the hive. This is a bug
+in the Win32 APIs, not any Perl code or modules. This module does
+not try to protect you from this bug.
+
+There is no test suite.
+
+=head1 FUTURE DIRECTIONS
+
+The following items are desired by the author and may appear in a
+future release of this module.
+
+=over
+
+=item TieValues option
+
+Currently described in main documentation but no yet implemented.
+
+=item AutoRefresh option
+
+Trigger use of C<RegNotifyChangeKeyValue()> to keep tied hash
+caches up-to-date even when other programs make changes.
+
+=item Error options
+
+Allow the user to have unchecked calls (calls in a "void context")
+to automatically report errors via C<warn> or C<die>.
+
+For complex operations, such a copying an entire subtree, provide
+access to detailed information about errors (and perhaps some
+warnings) that were encountered. Let the user control whether
+the complex operation continues in spite of errors.
+
+=back
+
+=cut
+
+# Autoload not currently supported by Perl under Windows.
diff --git a/Master/tlpkg/installer/perllib/Win32API/Registry.pm b/Master/tlpkg/installer/perllib/Win32API/Registry.pm
new file mode 100644
index 00000000000..dbf98b4e2e9
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/Win32API/Registry.pm
@@ -0,0 +1,1792 @@
+# Registry.pm -- Low-level access to functions/constants from WINREG.h
+
+package Win32API::Registry;
+
+use strict;
+use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); #@EXPORT_FAIL);
+$VERSION= '0.24';
+
+require Exporter;
+require DynaLoader;
+@ISA= qw(Exporter DynaLoader);
+
+@EXPORT= qw();
+%EXPORT_TAGS= (
+ Func => [qw( regConstant regLastError
+ AllowPriv AbortSystemShutdown InitiateSystemShutdown
+ RegCloseKey RegConnectRegistry RegCreateKey
+ RegCreateKeyEx RegDeleteKey RegDeleteValue
+ RegEnumKey RegEnumKeyEx RegEnumValue
+ RegFlushKey RegGetKeySecurity RegLoadKey
+ RegNotifyChangeKeyValue RegOpenKey RegOpenKeyEx
+ RegQueryInfoKey RegQueryMultipleValues RegQueryValue
+ RegQueryValueEx RegReplaceKey RegRestoreKey
+ RegSaveKey RegSetKeySecurity RegSetValue
+ RegSetValueEx RegUnLoadKey )],
+ FuncA => [qw(
+ AbortSystemShutdownA InitiateSystemShutdownA
+ RegConnectRegistryA RegCreateKeyA RegCreateKeyExA
+ RegDeleteKeyA RegDeleteValueA RegEnumKeyA
+ RegEnumKeyExA RegEnumValueA RegLoadKeyA
+ RegOpenKeyA RegOpenKeyExA RegQueryInfoKeyA
+ RegQueryMultipleValuesA RegQueryValueA RegQueryValueExA
+ RegReplaceKeyA RegRestoreKeyA RegSaveKeyA
+ RegSetValueA RegSetValueExA RegUnLoadKeyA )],
+ FuncW => [qw(
+ AbortSystemShutdownW InitiateSystemShutdownW
+ RegConnectRegistryW RegCreateKeyW RegCreateKeyExW
+ RegDeleteKeyW RegDeleteValueW RegEnumKeyW
+ RegEnumKeyExW RegEnumValueW RegLoadKeyW
+ RegOpenKeyW RegOpenKeyExW RegQueryInfoKeyW
+ RegQueryMultipleValuesW RegQueryValueW RegQueryValueExW
+ RegReplaceKeyW RegRestoreKeyW RegSaveKeyW
+ RegSetValueW RegSetValueExW RegUnLoadKeyW )],
+ HKEY_ => [qw(
+ HKEY_CLASSES_ROOT HKEY_CURRENT_CONFIG HKEY_CURRENT_USER
+ HKEY_DYN_DATA HKEY_LOCAL_MACHINE HKEY_PERFORMANCE_DATA
+ HKEY_USERS )],
+ KEY_ => [qw(
+ KEY_QUERY_VALUE KEY_SET_VALUE KEY_CREATE_SUB_KEY
+ KEY_ENUMERATE_SUB_KEYS KEY_NOTIFY KEY_CREATE_LINK
+ KEY_READ KEY_WRITE KEY_EXECUTE
+ KEY_ALL_ACCESS),
+ 'KEY_DELETE', # DELETE (0x00010000L)
+ 'KEY_READ_CONTROL', # READ_CONTROL (0x00020000L)
+ 'KEY_WRITE_DAC', # WRITE_DAC (0x00040000L)
+ 'KEY_WRITE_OWNER', # WRITE_OWNER (0x00080000L)
+ 'KEY_SYNCHRONIZE', # SYNCHRONIZE (0x00100000L) (not used)
+ ],
+ REG_ => [qw(
+ REG_OPTION_RESERVED REG_OPTION_NON_VOLATILE REG_OPTION_VOLATILE
+ REG_OPTION_CREATE_LINK REG_OPTION_BACKUP_RESTORE
+ REG_OPTION_OPEN_LINK REG_LEGAL_OPTION REG_CREATED_NEW_KEY
+ REG_OPENED_EXISTING_KEY REG_WHOLE_HIVE_VOLATILE REG_REFRESH_HIVE
+ REG_NO_LAZY_FLUSH REG_NOTIFY_CHANGE_ATTRIBUTES
+ REG_NOTIFY_CHANGE_NAME REG_NOTIFY_CHANGE_LAST_SET
+ REG_NOTIFY_CHANGE_SECURITY REG_LEGAL_CHANGE_FILTER
+ REG_NONE REG_SZ REG_EXPAND_SZ
+ REG_BINARY REG_DWORD REG_DWORD_LITTLE_ENDIAN
+ REG_DWORD_BIG_ENDIAN REG_LINK REG_MULTI_SZ
+ REG_RESOURCE_LIST REG_FULL_RESOURCE_DESCRIPTOR
+ REG_RESOURCE_REQUIREMENTS_LIST )],
+ SE_ => [qw(
+ SE_ASSIGNPRIMARYTOKEN_NAME SE_AUDIT_NAME
+ SE_BACKUP_NAME SE_CHANGE_NOTIFY_NAME
+ SE_CREATE_PAGEFILE_NAME SE_CREATE_PERMANENT_NAME
+ SE_CREATE_TOKEN_NAME SE_DEBUG_NAME
+ SE_INCREASE_QUOTA_NAME SE_INC_BASE_PRIORITY_NAME
+ SE_LOAD_DRIVER_NAME SE_LOCK_MEMORY_NAME
+ SE_MACHINE_ACCOUNT_NAME SE_PROF_SINGLE_PROCESS_NAME
+ SE_REMOTE_SHUTDOWN_NAME SE_RESTORE_NAME
+ SE_SECURITY_NAME SE_SHUTDOWN_NAME
+ SE_SYSTEMTIME_NAME SE_SYSTEM_ENVIRONMENT_NAME
+ SE_SYSTEM_PROFILE_NAME SE_TAKE_OWNERSHIP_NAME
+ SE_TCB_NAME SE_UNSOLICITED_INPUT_NAME )],
+);
+@EXPORT_OK= ();
+{ my $ref;
+ foreach $ref ( values(%EXPORT_TAGS) ) {
+ push( @EXPORT_OK, @$ref ) unless $ref->[0] =~ /^SE_/;
+ }
+}
+$EXPORT_TAGS{ALL}= [ @EXPORT_OK ]; # \@EXPORT_OK once SE_* settles down.
+# push( @EXPORT_OK, "JHEREG_TACOSALAD" ); # Used to test Mkconst2perl
+push( @EXPORT_OK, @{$EXPORT_TAGS{SE_}} );
+
+bootstrap Win32API::Registry $VERSION;
+
+# Preloaded methods go here.
+
+# To convert C constants to Perl code in cRegistry.pc
+# [instead of C or C++ code in cRegistry.h]:
+# * Modify F<Makefile.PL> to add WriteMakeFile() =>
+# CONST2PERL/postamble => [[ "Win32API::Registry" => ]] WRITE_PERL => 1.
+# * Either comment out C<#include "cRegistry.h"> from F<Registry.xs>
+# or make F<cRegistry.h> an empty file.
+# * Make sure the following C<if> block is not commented out.
+# * "nmake clean", "perl Makefile.PL", "nmake"
+
+if( ! defined &REG_NONE ) {
+ require "Win32API/Registry/cRegistry.pc";
+}
+
+# This would be convenient but inconsistant and hard to explain:
+#push( @{$EXPORT_TAGS{ALL}}, @{$EXPORT_TAGS{SE_}} )
+# if defined &SE_TCB_NAME;
+
+sub regConstant
+{
+ my( $name )= @_;
+ if( 1 != @_ || ! $name || $name =~ /\W/ ) {
+ require Carp;
+ Carp::croak( 'Usage: ',__PACKAGE__,'::regConstant("CONST_NAME")' );
+ }
+ my $proto= prototype $name;
+ if( defined \&$name
+ && defined $proto
+ && "" eq $proto ) {
+ no strict 'refs';
+ return &$name;
+ }
+ return undef;
+}
+
+# We provide this for backwards compatibility:
+sub constant
+{
+ my( $name )= @_;
+ my $value= regConstant( $name );
+ if( defined $value ) {
+ $!= 0;
+ return $value;
+ }
+ $!= 11; # EINVAL
+ return 0;
+}
+
+# BEGIN {
+# my $code= 'return _regLastError(@_)';
+# local( $!, $^E )= ( 1, 1 );
+# if( $! ne $^E ) {
+# $code= '
+# local( $^E )= _regLastError(@_);
+# my $ret= $^E;
+# return $ret;
+# ';
+# }
+# eval "sub regLastError { $code }";
+# die "$@" if $@;
+# }
+
+package Win32API::Registry::_error;
+
+use overload
+ '""' => sub {
+ require Win32 unless defined &Win32::FormatMessage;
+ $_ = Win32::FormatMessage(Win32API::Registry::_regLastError());
+ tr/\r\n//d;
+ return $_;
+ },
+ '0+' => sub { Win32API::Registry::_regLastError() },
+ 'fallback' => 1;
+
+sub new { return bless {}, shift }
+sub set { Win32API::Registry::_regLastError($_[1]); return $_[0] }
+
+package Win32API::Registry;
+
+my $_error = new Win32API::Registry::_error;
+
+sub regLastError {
+ require Carp;
+ Carp::croak('Usage: ',__PACKAGE__,'::regLastError( [$setWin32ErrCode] )') if @_ > 1;
+ $_error->set($_[0]) if defined $_[0];
+ return $_error;
+}
+
+# Since we ISA DynaLoader which ISA AutoLoader, we ISA AutoLoader so we
+# need this next chunk to prevent Win32API::Registry->nonesuch() from
+# looking for "nonesuch.al" and producing confusing error messages:
+use vars qw($AUTOLOAD);
+sub AUTOLOAD {
+ require Carp;
+ Carp::croak(
+ "Can't locate method $AUTOLOAD via package Win32API::Registry" );
+}
+
+# Replace "&rout;" with "goto &rout;" when that is supported on Win32.
+
+# Let user omit all buffer sizes:
+sub RegEnumKeyExA {
+ if( 6 == @_ ) { splice(@_,4,0,[]); splice(@_,2,0,[]); }
+ &_RegEnumKeyExA;
+}
+sub RegEnumKeyExW {
+ if( 6 == @_ ) { splice(@_,4,0,[]); splice(@_,2,0,[]); }
+ &_RegEnumKeyExW;
+}
+sub RegEnumValueA {
+ if( 6 == @_ ) { splice(@_,2,0,[]); push(@_,[]); }
+ &_RegEnumValueA;
+}
+sub RegEnumValueW {
+ if( 6 == @_ ) { splice(@_,2,0,[]); push(@_,[]); }
+ &_RegEnumValueW;
+}
+sub RegQueryInfoKeyA {
+ if( 11 == @_ ) { splice(@_,2,0,[]); }
+ &_RegQueryInfoKeyA;
+}
+sub RegQueryInfoKeyW {
+ if( 11 == @_ ) { splice(@_,2,0,[]); }
+ &_RegQueryInfoKeyW;
+}
+
+sub RegEnumKeyA {
+ push(@_,[]) if 3 == @_;
+ &_RegEnumKeyA;
+}
+sub RegEnumKeyW {
+ push(@_,[]) if 3 == @_;
+ &_RegEnumKeyW;
+}
+sub RegGetKeySecurity {
+ push(@_,[]) if 3 == @_;
+ &_RegGetKeySecurity;
+}
+sub RegQueryMultipleValuesA {
+ push(@_,[]) if 4 == @_;
+ &_RegQueryMultipleValuesA;
+}
+sub RegQueryMultipleValuesW {
+ push(@_,[]) if 4 == @_;
+ &_RegQueryMultipleValuesW;
+}
+sub RegQueryValueA {
+ push(@_,[]) if 3 == @_;
+ &_RegQueryValueA;
+}
+sub RegQueryValueW {
+ push(@_,[]) if 3 == @_;
+ &_RegQueryValueW;
+}
+sub RegQueryValueExA {
+ push(@_,[]) if 5 == @_;
+ &_RegQueryValueExA;
+}
+sub RegQueryValueExW {
+ push(@_,[]) if 5 == @_;
+ &_RegQueryValueExW;
+}
+sub RegSetValueA {
+ push(@_,0) if 4 == @_;
+ &_RegSetValueA;
+}
+sub RegSetValueW {
+ push(@_,0) if 4 == @_;
+ &_RegSetValueW;
+}
+sub RegSetValueExA {
+ push(@_,0) if 5 == @_;
+ &_RegSetValueExA;
+}
+sub RegSetValueExW {
+ push(@_,0) if 5 == @_;
+ &_RegSetValueExW;
+}
+
+# Aliases for non-Unicode functions:
+sub AbortSystemShutdown { &AbortSystemShutdownA; }
+sub InitiateSystemShutdown { &InitiateSystemShutdownA; }
+sub RegConnectRegistry { &RegConnectRegistryA; }
+sub RegCreateKey { &RegCreateKeyA; }
+sub RegCreateKeyEx { &RegCreateKeyExA; }
+sub RegDeleteKey { &RegDeleteKeyA; }
+sub RegDeleteValue { &RegDeleteValueA; }
+sub RegEnumKey { &RegEnumKeyA; }
+sub RegEnumKeyEx { &RegEnumKeyExA; }
+sub RegEnumValue { &RegEnumValueA; }
+sub RegLoadKey { &RegLoadKeyA; }
+sub RegOpenKey { &RegOpenKeyA; }
+sub RegOpenKeyEx { &RegOpenKeyExA; }
+sub RegQueryInfoKey { &RegQueryInfoKeyA; }
+sub RegQueryMultipleValues { &RegQueryMultipleValuesA; }
+sub RegQueryValue { &RegQueryValueA; }
+sub RegQueryValueEx { &RegQueryValueExA; }
+sub RegReplaceKey { &RegReplaceKeyA; }
+sub RegRestoreKey { &RegRestoreKeyA; }
+sub RegSaveKey { &RegSaveKeyA; }
+sub RegSetValue { &RegSetValueA; }
+sub RegSetValueEx { &RegSetValueExA; }
+sub RegUnLoadKey { &RegUnLoadKeyA; }
+
+1;
+__END__
+
+=head1 NAME
+
+Win32API::Registry - Low-level access to Win32 system API calls from WINREG.H
+
+=head1 SYNOPSIS
+
+ use Win32API::Registry 0.21 qw( :ALL );
+
+ RegOpenKeyEx( HKEY_LOCAL_MACHINE, "SYSTEM\\Disk", 0, KEY_READ, $key );
+ or die "Can't open HKEY_LOCAL_MACHINE\\SYSTEM\\Disk: ",
+ regLastError(),"\n";
+ RegQueryValueEx( $key, "Information", [], $type, $data, [] );
+ or die "Can't read HKEY_L*MACHINE\\SYSTEM\\Disk\\Information: ",
+ regLastError(),"\n";
+ [...]
+ RegCloseKey( $key )
+ or die "Can't close HKEY_LOCAL_MACHINE\\SYSTEM\\Disk: ",
+ regLastError(),"\n";
+
+=head1 DESCRIPTION
+
+This provides fairly low-level access to the Win32 System API
+calls dealing with the Registry [mostly from WINREG.H]. This
+is mostly intended to be used by other modules such as
+C<Win32::TieRegistry> [which provides an extremely Perl-friendly
+method for using the Registry].
+
+For a description of the logical structure of the Registry, see
+the documentation for the C<Win32::TieRegistry> module.
+
+To pass in C<NULL> as the pointer to an optional buffer, pass in
+an empty list reference, C<[]>.
+
+Beyond raw access to the API calls and related constants, this module
+handles smart buffer allocation and translation of return codes.
+
+All calls return a true value for success and a false value for
+failure. After any failure, C<$^E> should automatically be set
+to indicate the reason. However, current versions of Perl often
+overwrite C<$^E> too quickly, so you can use C<regLastError()>
+instead, which is only set by Win32API::Registry routines.
+
+Note that C<$!> is not set by these routines except by
+C<Win32API::Registry::constant()> when a constant is not defined.
+
+=head2 Exports
+
+Nothing is exported by default. The following tags can be used to
+have sets of symbols exported.
+
+[Note that much of the following documentation refers to the
+behavior of the underlying API calls which may vary in current
+and future versions of the Win32 API without any changes to this
+module. Therefore you should check the Win32 API documentation
+directly when needed.]
+
+=over
+
+=item :Func
+
+The basic function names:
+
+=over
+
+=item AllowPriv
+
+=item C<AllowPriv( $sPrivName, $bEnable )>
+
+Not a Win32 API call. Enables or disables a specific privilege for
+the current process. Returns a true value if successful and a false
+value [and sets C<$^E>/C<regLastError()>] on failure. This routine
+does not provide a way to tell if a privilege is currently enabled.
+
+C<$sPrivname> is a Win32 privilege name [see L</:SE_>]. For example,
+C<"SeBackupPrivilege"> [a.k.a. C<SE_BACKUP_NAME>] controls whether
+you can use C<RegSaveKey()> and C<"SeRestorePrivilege"> [a.k.a.
+C<SE_RESTORE_NAME>] controls whether you can use C<RegLoadKey()>.
+
+If C<$bEnable> is true, then C<AllowPriv()> tries to enable the
+privilege. Otherwise it tries to disable the privilege.
+
+=item AbortSystemShutdown
+
+=item C<AbortSystemShutdown( $sComputerName )>
+
+Tries to abort a remote shutdown request previously made via
+C<InitiateSystemShutdown()>. Returns a true value if successful
+and a false value [and sets C<$^E>/C<regLastError()>] on failure.
+
+=item InitiateSystemShutdown
+
+=item C<InitiateSystemShutdown( $sComputer, $sMessage, $uTimeoutSecs, $bForce, $bReboot )>
+
+Requests that a [remote] computer be shutdown or rebooted.
+Returns a true value if successful and a false value [and
+sets C<$^E>/C<regLastError()>] on failure.
+
+C<$sComputer> is the name [or address] of the computer to be
+shutdown or rebooted. You can use C<[]> [for C<NULL>] or C<"">
+to indicate the local computer.
+
+C<$sMessage> is the message to be displayed in a pop-up window
+on the desktop of the computer to be shutdown or rebooted until
+the timeout expires or the shutdown is aborted via
+C<AbortSystemShutdown()>. With C<$iTimeoutSecs == 0>, the
+message will never be visible.
+
+C<$iTimeoutSecs> is the number of seconds to wait before starting
+the shutdown.
+
+If C<$bForce> is false, then any applications running on the remote
+computer get a chance to prompt the remote user whether they want
+to save changes. Also, for any applications that do not exit quickly
+enough, the operating system will prompt the user whether they wish
+to wait longer for the application to exit or force it to exit now.
+At any of these prompts the user can press B<CANCEL> to abort the
+shutdown but if no applications have unsaved data, they will likely
+all exit quickly and the shutdown will progress with the remote user
+having no option to cancel the shutdown.
+
+If C<$bForce> is true, all applications are told to exit immediately
+and so will not prompt the user even if there is unsaved data. Any
+applications that take too long to exit will be forcibly killed after
+a short time. The only way to abort the shutdown is to call
+C<AbortSystemShutdown()> before the timeout expires and there is no
+way to abort the shutdown once it has begun.
+
+If C<$bReboot> is true, the computer will automatically reboot once
+the shutdown is complete. If C<$bReboot> is false, then when the
+shutdown is complete the computer will halt at a screen indicating
+that the shutdown is complete and offering a way for the user to
+start to boot the computer.
+
+You must have the C<"SeRemoteShutdownPrivilege"> privilege
+on the remote computer for this call to succeed. If shutting
+down the local computer, then the calling process must have
+the C<"SeShutdownPrivilege"> privilege and have it enabled.
+
+=item RegCloseKey
+
+=item C<RegCloseKey( $hKey )>
+
+Closes the handle to a Registry key returned by C<RegOpenKeyEx()>,
+C<RegConnectRegistry()>, C<RegCreateKeyEx()>, or a few other
+routines. Returns a true value if successful and a false value
+[and sets C<$^E>/C<regLastError()>] on failure.
+
+=item RegConnectRegistry
+
+=item C<RegConnectRegistry( $sComputer, $hRootKey, $ohKey )>
+
+Connects to one of the root Registry keys of a remote computer.
+Returns a true value if successful and a false value [and
+sets C<$^E>/C<regLastError()>] on failure.
+
+C<$sComputer> is the name [or address] of a remote computer
+whose Registry you wish to access.
+
+C<$hKey> must be either C<HKEY_LOCAL_MACHINE> or C<HKEY_USERS>
+and specifies which root Registry key on the remote computer
+you wish to have access to.
+
+C<$phKey> will be set to the handle to be used to access the
+remote Registry key if the call succeeds.
+
+=item regConstant
+
+=item C<$value= regConstant( $sConstantName )>
+
+Fetch the value of a constant. Returns C<undef> if C<$sConstantName>
+is not the name of a constant supported by this module. Never sets
+C<$!> nor C<$^E>.
+
+This function is rarely used since you will usually get the value of a
+constant by having that constant imported into your package by listing
+the constant name in the C<use Win32API::Registry> statement and then
+simply using the constant name in your code [perhaps followed by
+C<()>]. This function is useful for verifying constant names not in
+Perl code, for example, after prompting a user to type in a constant
+name.
+
+=item RegCreateKey
+
+=item C<RegCreateKey( $hKey, $sSubKey, $ohSubKey )>
+
+This routine is meant only for compatibility with Windows version
+3.1. Use C<RegCreateKeyEx()> instead.
+
+=item RegCreateKeyEx
+
+=item C<RegCreateKeyEx( $hKey, $sSubKey, $uZero, $sClass, $uOpts, $uAccess, $pSecAttr, $ohNewKey, $ouDisp )>
+
+Creates a new Registry subkey. Returns a true value if successful and
+a false value [and sets C<$^E>/C<regLastError()>] on failure.
+
+C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from
+a previous call].
+
+C<$sSubKey> is the name of the new subkey to be created.
+
+C<$iZero> is reserved for future use and should always be specified
+as C<0>.
+
+C<$sClass> is a string to be used as the class for the new
+subkey. We are not aware of any current use for Registry key
+class information so the empty string, C<"">, should usually
+be used here.
+
+C<$iOpts> is a numeric value containing bits that control options
+used while creating the new subkey. C<REG_OPTION_NON_VOLATILE>
+is the default. C<REG_OPTION_VOLATILE> [which is ignored on
+Windows 95] means the data stored under this key is not kept
+in a file and will not be preserved when the system reboots.
+C<REG_OPTION_BACKUP_RESTORE> [also ignored on Windows 95] means
+ignore the C<$iAccess> parameter and try to open the new key with
+the access required to backup or restore the key.
+
+C<$iAccess> is a numeric mask of bits specifying what type of
+access is desired when opening the new subkey. See C<RegOpenKeyEx()>.
+
+C<$pSecAttr> is a C<SECURITY_ATTRIBUTES> structure packed into
+a Perl string which controls whether the returned handle can be
+inherited by child processes. Normally you would pass C<[]> for
+this parameter to have C<NULL> passed to the underlying API
+indicating that the handle cannot be inherited. If not under
+Windows95, then C<$pSecAttr> also allows you to specify
+C<SECURITY_DESCRIPTOR> that controls which users will have
+what type of access to the new key -- otherwise the new key
+inherits its security from its parent key.
+
+C<$phKey> will be set to the handle to be used to access the new
+subkey if the call succeeds.
+
+C<$piDisp> will be set to either C<REG_CREATED_NEW_KEY> or
+C<REG_OPENED_EXISTING_KEY> to indicate for which reason the
+call succeeded. Can be specified as C<[]> if you don't care.
+
+If C<$phKey> and C<$piDisp> start out as integers, then they will
+probably remain unchanged if the call fails.
+
+=item RegDeleteKey
+
+=item C<RegDeleteKey( $hKey, $sSubKey )>
+
+Deletes a subkey of an open Registry key provided that the subkey
+contains no subkeys of its own [but the subkey may contain values].
+Returns a true value if successful and a false value [and sets
+C<$^E>/C<regLastError()>] on failure.
+
+C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from
+a previous call].
+
+C<$sSubKey> is the name of the subkey to be deleted.
+
+=item RegDeleteValue
+
+=item C<RegDeleteValue( $hKey, $sValueName )>
+
+Deletes a value from an open Registry key. Returns a true value if
+successful and a false value [and sets C<$^E>/C<regLastError()>] on
+failure.
+
+C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from
+a previous call].
+
+C<$sValueKey> is the name of the value to be deleted.
+
+=item RegEnumKey
+
+=item C<RegEnumKey( $hKey, $uIndex, $osName, $ilNameSize )>
+
+This routine is meant only for compatibility with Windows version
+3.1. Use C<RegEnumKeyEx()> instead.
+
+=item RegEnumKeyEx
+
+=item C<RegEnumKeyEx( $hKey, $uIndex, $osName, $iolName, $pNull, $osClass, $iolClass, $opftLastWrite )>
+
+Lets you enumerate the names of all of the subkeys directly under
+an open Registry key. Returns a true value if successful and a false
+value [and sets C<$^E>/C<regLastError()>] on failure.
+
+C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from
+a previous call].
+
+C<$iIndex> is the sequence number of the immediate subkey that
+you want information on. Start with this value as C<0> then
+repeat the call incrementing this value each time until the
+call fails with C<$^E>/C<regLastError()> numerically equal to
+C<ERROR_NO_MORE_ITEMS>.
+
+C<$sName> will be set to the name of the subkey. Can be C<[]> if
+you don't care about the name.
+
+C<$plName> initially specifies the [minimum] buffer size to be
+allocated for C<$sName>. Will be set to the length of the subkey
+name if the requested subkey exists even if C<$sName> isn't
+successfully set to the subkey name. See L<Buffer sizes> for
+more information.
+
+C<$pNull> is reserved for future used and should be passed as C<[]>.
+
+C<$sClass> will be set to the class name for the subkey. Can be
+C<[]> if you don't care about the class.
+
+C<$plClass> initially specifies the [minimum] buffer size to be
+allocated for C<$sClass> and will be set to the length of the
+subkey class name if the requested subkey exists. See L<Buffer
+sizes> for more information.
+
+C<$pftLastWrite> will be set to a C<FILETIME> structure packed
+into a Perl string and indicating when the subkey was last changed.
+Can be C<[]>.
+
+You may omit both C<$plName> and C<$plClass> to get the same effect
+as passing in C<[]> for each of them.
+
+=item RegEnumValue
+
+=item C<RegEnumValue( $hKey, $uIndex, $osValName, $iolValName, $pNull, $ouType, $opValData, $iolValData )>
+
+Lets you enumerate the names of all of the values contained in an
+open Registry key. Returns a true value if successful and a false
+value [and sets C<$^E>/C<regLastError()>] on failure.
+
+C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from
+a previous call].
+
+C<$iIndex> is the sequence number of the value that you want
+information on. Start with this value as C<0> then repeat the
+call incrementing this value each time until the call fails with
+C<ERROR_NO_MORE_ITEMS>.
+
+C<$sValName> will be set to the name of the value. Can be C<[]>
+if you don't care about the name.
+
+C<$plValName> initially specifies the [minimum] buffer size to be
+allocated for C<$sValName>. Will be set to the length of the value
+name if the requested value exists even if C<$sValName> isn't
+successfully set to the value name. See L<Buffer sizes> for
+more information.
+
+C<$pNull> is reserved for future used and should be passed as C<[]>.
+
+C<$piType> will be set to the type of data stored in the value data.
+If the call succeeds, it will be set to a C<REG_*> value unless
+passed in as C<[]>.
+
+C<$pValData> will be set to the data [packed into a Perl string]
+that is stored in the requested value. Can be C<[]> if you don't
+care about the value data.
+
+C<$plValData> initially specifies the [minimum] buffer size to be
+allocated for C<$sValData> and will be set to the length of the
+value data if the requested value exists. See L<Buffer sizes> for
+more information.
+
+You may omit both C<$plValName> and C<$plValData> to get the same
+effect as passing in C<[]> for each of them.
+
+=item RegFlushKey
+
+=item C<RegFlushKey( $hKey )>
+
+Forces the data stored under an open Registry key to be flushed
+to the disk file where the data is preserved between reboots.
+Forced flushing is not guaranteed to be efficient so this routine
+should almost never be called. Returns a true value if successful
+and a false value [and sets C<$^E>/C<regLastError()>] on failure.
+
+C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from
+a previous call].
+
+=item RegGetKeySecurity
+
+=item C<RegGetKeySecurity( $hKey, $uSecInfo, $opSecDesc, $iolSecDesc )>
+
+Retrieves one of the C<SECURITY_DESCRIPTOR> structures describing
+part of the security for an open Registry key. Returns a true value
+if successful and a false value [and sets C<$^E>/C<regLastError()>]
+on failure.
+
+C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from
+a previous call].
+
+C<$iSecInfo> is a numeric C<SECURITY_INFORMATION> value that
+specifies which parts of the C<SECURITY_DESCRIPTOR> structure
+to retrieve. Should be C<OWNER_SECURITY_INFORMATION>,
+C<GROUP_SECURITY_INFORMATION>, C<DACL_SECURITY_INFORMATION>, or
+or C<SACL_SECURITY_INFORMATION> or two or more of these bits
+combined using C<|>.
+
+C<$pSecDesc> will be set to the requested C<SECURITY_DESCRIPTOR>
+structure [packed into a Perl string].
+
+C<$plSecDesc> initially specifies the [minimum] buffer size to be
+allocated for C<$sSecDesc> and will be set to the length of the
+security descriptor. See L<Buffer sizes> for more information.
+You may omit this parameter to get the same effect as passing in
+C<[]> for it.
+
+=item regLastError
+
+=item C<$svError= regLastError();>
+
+=item C<regLastError( $uError );>
+
+Returns the last error encountered by a routine from this module.
+It is just like C<$^E> except it isn't changed by anything except
+routines from this module. Ideally you could just use C<$^E>, but
+current versions of Perl often overwrite C<$^E> before you get a
+chance to check it and really old versions of Perl don't really
+support C<$^E> under Win32.
+
+Just like C<$^E>, in a numeric context C<regLastError()> returns
+the numeric error value while in a string context it returns a
+text description of the error [actually it returns a Perl scalar
+that contains both values so C<$x= regLastError()> causes C<$x>
+to give different values in string vs. numeric contexts].
+
+The last form sets the error returned by future calls to
+C<regLastError()> and should not be used often. C<$uError> must
+be a numeric error code. Also returns the dual-valued version
+of C<$uError>.
+
+=item RegLoadKey
+
+=item C<RegLoadKey( $hKey, $sSubKey, $sFileName )>
+
+Loads a hive file. That is, it creates a new subkey in the
+Registry and associates that subkey with a disk file that contains
+a Registry hive so that the new subkey can be used to access the
+keys and values stored in that hive. Hives are usually created
+via C<RegSaveKey()>. Returns a true value if successful and a
+false value [and sets C<$^E>/C<regLastError()>] on failure.
+
+C<$hKey> is the handle to a Registry key that can have hives
+loaded to it. This must be C<HKEY_LOCAL_MACHINE>, C<HKEY_USERS>,
+or a remote version of one of these from a call to
+C<RegConnectRegistry()>.
+
+C<$sSubKey> is the name of the new subkey to created and associated
+with the hive file.
+
+C<$sFileName> is the name of the hive file to be loaded. This
+file name is interpretted relative to the
+C<%SystemRoot%/System32/config> directory on the computer where
+the C<$hKey> key resides. If C<$sFileName> is on a FAT file
+system, then its name must not have an extension.
+
+You must have the C<SE_RESTORE_NAME> privilege to use this routine.
+
+WARNING: Loading of hive files via a network share may silently
+corrupt the hive and so should not be attempted [this is a problem
+in at least some versions of the underlying API which this module
+does not try to fix or avoid]. To access a hive file located on a
+remote computer, connect to the remote computer's Registry and load
+the hive via that.
+
+=item RegNotifyChangeKeyValue
+
+=item C<RegNotifyChangeKeyValue( $hKey, $bWatchSubtree, $uNotifyFilter, $hEvent, $bAsync )>
+
+Arranges for your process to be notified when part of the Registry
+is changed. Returns a true value if successful and a false value
+[and sets C<$^E>/C<regLastError()>] on failure.
+
+C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from
+a previous call] for which you wish to be notified when any changes
+are made to it.
+
+If C<$bWatchSubtree> is true, then changes to any subkey or
+descendant of C<$hKey> are also reported.
+
+C<$iNotifyFilter> controllers what types of changes are reported. It
+is a numeric value containing one or more of the following bit masks:
+
+=over
+
+=item C<REG_NOTIFY_CHANGE_NAME>
+
+Notify if a subkey is added or deleted to a monitored key.
+
+=item C<REG_NOTIFY_CHANGE_LAST_SET>
+
+Notify if a value in a monitored key is added, deleted, or modified.
+
+=item C<REG_NOTIFY_CHANGE_SECURITY>
+
+Notify if a security descriptor of a monitored key is changed.
+
+=item C<REG_NOTIFY_CHANGE_ATTRIBUTES>
+
+Notify if any attributes of a monitored key are changed [class
+name or security descriptors].
+
+=back
+
+C<$hEvent> is ignored unless C<$bAsync> is true. Otherwise, C<$hEvent>
+is a handle to a Win32 I<event> that will be signaled when changes are
+to be reported.
+
+If C<$bAsync> is true, then C<RegNotifyChangeKeyValue()> returns
+immediately and uses C<$hEvent> to notify your process of changes.
+If C<$bAsync> is false, then C<RegNotifyChangeKeyValue()> does
+not return until there is a change to be notified of.
+
+This routine does not work with Registry keys on remote computers.
+
+=item RegOpenKey
+
+=item C<RegOpenKey( $hKey, $sSubKey, $ohSubKey )>
+
+This routine is meant only for compatibility with Windows version
+3.1. Use C<RegOpenKeyEx()> instead.
+
+=item RegOpenKeyEx
+
+=item C<RegOpenKeyEx( $hKey, $sSubKey, $uOptions, $uAccess, $ohSubKey )>
+
+Opens an existing Registry key. Returns a true value if successful
+and a false value [and sets C<$^E>/C<regLastError()>] on failure.
+
+C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from
+a previous call].
+
+C<$sSubKey> is the name of an existing subkey to be opened.
+Can be C<""> or C<[]> to open an additional handle to the
+key specified by C<$hKey>.
+
+C<$iOptions> is a numeric value containing bits that control options
+used while opening the subkey. There are currently no supported
+options so this parameter should be specified as C<0>.
+
+C<$iAccess> is a numeric mask of bits specifying what type of
+access is desired when opening the new subkey. Should be a
+combination of one or more of the following bit masks:
+
+=over
+
+=item C<KEY_ALL_ACCESS>
+
+ KEY_READ | KEY_WRITE | KEY_CREATE_LINK
+
+=item C<KEY_READ>
+
+ KEY_QUERY_VALUE | KEY_ENUMERATE_SUBKEYS | KEY_NOTIFY | STANDARD_RIGHTS_READ
+
+=item C<KEY_WRITE>
+
+ KEY_SET_VALUE | KEY_CREATE_SUB_KEY | STANDARD_RIGHTS_WRITE
+
+=item C<KEY_QUERY_VALUE>
+
+=item C<KEY_SET_VALUE>
+
+=item C<KEY_ENUMERATE_SUB_KEYS>
+
+=item C<KEY_CREATE_SUB_KEY>
+
+=item C<KEY_NOTIFY>
+
+Allows you to use C<RegNotifyChangeKeyValue()> on the opened key.
+
+=item C<KEY_EXECUTE>
+
+Same as C<KEY_READ>.
+
+=item C<KEY_CREATE_LINK>
+
+Gives you permission to create a symbolic link like
+C<HKEY_CLASSES_ROOT> and C<HKEY_CURRENT_USER>, though the method for
+doing so is not documented [and probably requires use of the mostly
+undocumented "native" routines, C<Nt*()> a.k.a. C<Zw*()>].
+
+=back
+
+C<$phKey> will be set to the handle to be used to access the new subkey
+if the call succeeds.
+
+=item RegQueryInfoKey
+
+=item C<RegQueryInfoKey( $hKey, $osClass, $iolClass, $pNull, $ocSubKeys, $olSubKey, $olSubClass, $ocValues, $olValName, $olValData, $olSecDesc, $opftTime )>
+
+Gets miscellaneous information about an open Registry key.
+Returns a true value if successful and a false value [and
+sets C<$^E>/C<regLastError()>] on failure.
+
+C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from
+a previous call].
+
+C<$sClass> will be set to the class name for the key. Can be
+C<[]> if you don't care about the class.
+
+C<$plClass> initially specifies the [minimum] buffer size to be
+allocated for C<$sClass> and will be set to the length of the
+key's class name. See L<Buffer sizes> for more information.
+You may omit this parameter to get the same effect as passing in
+C<[]> for it.
+
+C<$pNull> is reserved for future use and should be passed as C<[]>.
+
+C<$pcSubKeys> will be set to the count of the number of subkeys
+directly under this key. Can be C<[]>.
+
+C<$plSubKey> will be set to the length of the longest subkey name.
+Can be C<[]>.
+
+C<$plSubClass> will be set to the length of the longest class name
+used with an immediate subkey of this key. Can be C<[]>.
+
+C<$pcValues> will be set to the count of the number of values in
+this key. Can be C<[]>.
+
+C<$plValName> will be set to the length of the longest value name
+in this key. Can be C<[]>.
+
+C<$plValData> will be set to the length of the longest value data
+in this key. Can be C<[]>.
+
+C<$plSecDesc> will be set to the length of this key's full security
+descriptor.
+
+C<$pftTime> will be set to a C<FILETIME> structure packed
+into a Perl string and indicating when this key was last changed.
+Can be C<[]>.
+
+=item RegQueryMultipleValues
+
+=item C<RegQueryMultipleValues( $hKey, $ioarValueEnts, $icValueEnts, $opBuffer, $iolBuffer )>
+
+Allows you to use a single call to query several values from a single
+open Registry key to maximize efficiency. Returns a true value if
+successful and a false value [and sets C<$^E>/C<regLastError()>] on
+failure.
+
+C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from
+a previous call].
+
+C<$pValueEnts> should contain a list of C<VALENT> structures packed
+into a single Perl string. Each C<VALENT> structure should have
+the C<ve_valuename> entry [the first 4 bytes] pointing to a string
+containing the name of a value stored in this key. The remaining
+fields are set if the function succeeds.
+
+C<$cValueEnts> should contain the count of the number of C<VALENT>
+structures contained in C<$pValueEnts>.
+
+C<$pBuffer> will be set to the data from all of the requested values
+concatenated into a single Perl string.
+
+C<$plBuffer> initially specifies the [minimum] buffer size to be
+allocated for C<$sBuffer> and will be set to the total length of
+the data to be written to C<$sBuffer>. See L<Buffer sizes> for
+more information. You may omit this parameter to get the same
+effect as passing in C<[]> for it.
+
+Here is sample code to populate C<$pValueEnts>:
+
+ # @ValueNames= ...list of value name strings...;
+ $cValueEnts= @ValueNames;
+ $pValueEnts= pack( " p x4 x4 x4 " x $cValueEnts, @ValueNames );
+
+Here is sample code to retrieve the data type and data length
+returned in C<$pValueEnts>:
+
+ @Lengths= unpack( " x4 L x4 x4 " x $cValueEnts, $pValueEnts );
+ @Types= unpack( " x4 x4 x4 L " x $cValueEnts, $pValueEnts );
+
+Given the above, and assuming you haven't modified C<$sBuffer> since
+the call, you can also extract the value data strings from C<$sBuffer>
+by using the pointers returned in C<$pValueEnts>:
+
+ @Data= unpack( join( "", map {" x4 x4 P$_ x4 "} @Lengths ),
+ $pValueEnts );
+
+Much better is to use the lengths and extract directly from
+C<$sBuffer> using C<unpack()> [or C<substr()>]:
+
+ @Data= unpack( join("",map("P$_",@Lengths)), $sBuffer );
+
+=item RegQueryValue
+
+=item C<RegQueryValue( $hKey, $sSubKey, $osValueData, $iolValueData )>
+
+This routine is meant only for compatibility with Windows version
+3.1. Use C<RegQueryValueEx()> instead. This routine can only
+query unamed values [a.k.a. "default values"], that is, values with
+a name of C<"">.
+
+=item RegQueryValueEx
+
+=item C<RegQueryValueEx( $hKey, $sValueName, $pNull, $ouType, $opValueData, $iolValueData )>
+
+Lets you look up value data stored in an open Registry key by
+specifying the value name. Returns a true value if successful
+and a false value [and sets C<$^E>/C<regLastError()>] on failure.
+
+C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from
+a previous call].
+
+C<$sValueName> is the name of the value whose data you wish to
+retrieve.
+
+C<$pNull> this parameter is reserved for future use and should be
+specified as C<[]>.
+
+C<$piType> will be set to indicate what type of data is stored in
+the named value. Will be set to a C<REG_*> value if the function
+succeeds.
+
+C<$pValueData> will be set to the value data [packed into a Perl
+string] that is stored in the named value. Can be C<[]> if you
+don't care about the value data.
+
+C<$plValueData> initially specifies the [minimum] buffer size to be
+allocated for C<$sValueData> and will be set to the size [always
+in bytes] of the data to be written to C<$sValueData>, even if
+C<$sValueData> is not successfully written to. See L<Buffer sizes>
+for more information.
+
+=item RegReplaceKey
+
+=item C<RegReplaceKey( $hKey, $sSubKey, $sNewFile, $sOldFile )>
+
+Lets you replace an entire hive when the system is next booted.
+Returns a true value if successful and a false value [and sets
+C<$^E>/C<regLastError()>] on failure.
+
+C<$hKey> is the handle to a Registry key that has hive(s)
+loaded in it. This must be C<HKEY_LOCAL_MACHINE>,
+C<HKEY_USERS>, or a remote version of one of these from
+a call to C<RegConnectRegistry()>.
+
+C<$sSubKey> is the name of the subkey of C<$hKey> whose hive
+you wish to have replaced on the next reboot.
+
+C<$sNewFile> is the name of a file that will replace the existing
+hive file when the system reboots.
+
+C<$sOldFile> is the file name to save the current hive file to
+when the system reboots.
+
+C<$sNewFile> and C<$sOldFile> are interpretted relative to the
+C<%SystemRoot%/System32/config> directory on the computer where
+the C<$hKey> key resides [I think]. If either file is [would be]
+on a FAT file system, then its name must not have an extension.
+
+You must have the C<SE_RESTORE_NAME> privilege to use this routine.
+
+=item RegRestoreKey
+
+=item C<RegRestoreKey( $hKey, $sFileName, $uFlags )>
+
+Reads in a hive file and copies its contents over an existing
+Registry tree. Returns a true value if successful and a false
+value [and sets C<$^E>/C<regLastError()>] on failure.
+
+C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from
+a previous call].
+
+C<$sFileName> is the name of the hive file to be read. For each
+value and subkey in this file, a value or subkey will be added
+or replaced in C<$hKey>.
+
+C<$uFlags> is usally C<0>. It can also be C<REG_WHOLE_HIVE_VOLATILE>
+which, rather than copying the hive over the existing key,
+replaces the existing key with a temporary, memory-only Registry
+key and then copies the hive contents into it. This option only
+works if C<$hKey> is C<HKEY_LOCAL_MACHINE>, C<HKEY_USERS>, or a
+remote version of one of these from a call to C<RegConnectRegistry()>.
+
+C<RegRestoreKey> does I<not> delete values nor keys from the
+existing Registry tree when there is no corresponding value/key
+in the hive file.
+
+=item RegSaveKey
+
+=item C<RegSaveKey( $hKey, $sFileName, $pSecAttr )>
+
+Dumps any open Registry key and all of its subkeys and values into
+a new hive file. Returns a true value if successful and a false
+value [and sets C<$^E>/C<regLastError()>] on failure.
+
+C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from
+a previous call].
+
+C<$sFileName> is the name of the file that the Registry tree
+should be saved to. It is interpretted relative to the
+C<%SystemRoot%/System32/config> directory on the computer where
+the C<$hKey> key resides. If C<$sFileName> is on a FAT file system,
+then it must not have an extension.
+
+C<$pSecAttr> contains a C<SECURITY_ATTRIBUTES> structure that specifies
+the permissions to be set on the new file that is created. This can
+be C<[]>.
+
+You must have the C<SE_RESTORE_NAME> privilege to use this routine.
+
+=item RegSetKeySecurity
+
+=item C<RegSetKeySecurity( $hKey, $uSecInfo, $pSecDesc )>
+
+Sets [part of] the C<SECURITY_DESCRIPTOR> structure describing part
+of the security for an open Registry key. Returns a true value if
+successful and a false value [and sets C<$^E>/C<regLastError()>] on
+failure.
+
+C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from
+a previous call].
+
+C<$uSecInfo> is a numeric C<SECURITY_INFORMATION> value that
+specifies which C<SECURITY_DESCRIPTOR> structure to set. Should
+be C<OWNER_SECURITY_INFORMATION>, C<GROUP_SECURITY_INFORMATION>,
+C<DACL_SECURITY_INFORMATION>, or C<SACL_SECURITY_INFORMATION>
+or two or more of these bits combined using C<|>.
+
+C<$pSecDesc> contains the new C<SECURITY_DESCRIPTOR> structure
+packed into a Perl string.
+
+=item RegSetValue
+
+=item C<RegSetValue( $hKey, $sSubKey, $uType, $sValueData, $lValueData )>
+
+This routine is meant only for compatibility with Windows version
+3.1. Use C<RegSetValueEx()> instead. This routine can only
+set unamed values [a.k.a. "default values"].
+
+=item RegSetValueEx
+
+=item C<RegSetValueEx( $hKey, $sName, $uZero, $uType, $pData, $lData )>
+
+Adds or replaces a value in an open Registry key. Returns
+a true value if successful and a false value [and sets
+C<$^E>/C<regLastError()>] on failure.
+
+C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from
+a previous call].
+
+C<$sName> is the name of the value to be set.
+
+C<$uZero> is reserved for future use and should be specified as C<0>.
+
+C<$uType> is the type of data stored in C<$pData>. It should
+be a C<REG_*> value.
+
+C<$pData> is the value data packed into a Perl string.
+
+C<$lData> is the length of the value data that is stored in C<$pData>.
+You will usually omit this parameter or pass in C<0> to have
+C<length($pData)> used. In both of these cases, if C<$iType> is
+C<REG_SZ> or C<REG_EXPAND_SZ>, C<RegSetValueEx()> will append a
+trailing C<'\0'> to the end of C<$pData> [unless there is already
+one].
+
+=item RegUnLoadKey
+
+=item C<RegUnLoadKey( $hKey, $sSubKey )>
+
+Unloads a previously loaded hive file. That is, closes the
+hive file then deletes the subkey that was providing access
+to it. Returns a true value if successful and a false value
+[and sets C<$^E>/C<regLastError()>] on failure.
+
+C<$hKey> is the handle to a Registry key that has hives
+loaded in it. This must be C<HKEY_LOCAL_MACHINE>, C<HKEY_USERS>,
+or a remote version of one of these from a call to
+C<RegConnectRegistry()>.
+
+C<$sSubKey> is the name of the subkey whose hive you wish to
+have unloaded.
+
+=item :FuncA
+
+The ASCII-specific function names.
+
+Each of these is identical to the version listed above without the
+trailing "A":
+
+ AbortSystemShutdownA InitiateSystemShutdownA
+ RegConnectRegistryA RegCreateKeyA RegCreateKeyExA
+ RegDeleteKeyA RegDeleteValueA RegEnumKeyA
+ RegEnumKeyExA RegEnumValueA RegLoadKeyA
+ RegOpenKeyA RegOpenKeyExA RegQueryInfoKeyA
+ RegQueryMultipleValuesA RegQueryValueA RegQueryValueExA
+ RegReplaceKeyA RegRestoreKeyA RegSaveKeyA
+ RegSetValueA RegSetValueExA RegUnLoadKeyA
+
+=item :FuncW
+
+The UNICODE-specific function names. These are the same as the
+versions listed above without the trailing "W" except that string
+parameters are UNICODE strings rather than ASCII strings, as
+indicated.
+
+=item AbortSystemShutdownW
+
+=item C<AbortSystemShutdownW( $swComputerName )>
+
+C<$swComputerName> is UNICODE.
+
+=item InitiateSystemShutdownW
+
+=item C<InitiateSystemShutdownW( $swComputer, $swMessage, $uTimeoutSecs, $bForce, $bReboot )>
+
+C<$swComputer> and C<$swMessage> are UNICODE.
+
+=item RegConnectRegistryW
+
+=item C<RegConnectRegistryW( $swComputer, $hRootKey, $ohKey )>
+
+C<$swComputer> is UNICODE.
+
+=item RegCreateKeyW
+
+=item C<RegCreateKeyW( $hKey, $swSubKey, $ohSubKey )>
+
+C<$swSubKey> is UNICODE.
+
+=item RegCreateKeyExW
+
+=item C<RegCreateKeyExW( $hKey, $swSubKey, $uZero, $swClass, $uOpts, $uAccess, $pSecAttr, $ohNewKey, $ouDisp )>
+
+C<$swSubKey> and C<$swClass> are UNICODE.
+
+=item RegDeleteKeyW
+
+=item C<RegDeleteKeyW( $hKey, $swSubKey )>
+
+C<$swSubKey> is UNICODE.
+
+=item RegDeleteValueW
+
+=item C<RegDeleteValueW( $hKey, $swValueName )>
+
+C<$swValueName> is UNICODE.
+
+=item RegEnumKeyW
+
+=item C<RegEnumKeyW( $hKey, $uIndex, $oswName, $ilwNameSize )>
+
+C<$oswName> is UNICODE and C<$ilwNameSize> is measured as number of
+C<WCHAR>s.
+
+=item RegEnumKeyExW
+
+=item C<RegEnumKeyExW( $hKey, $uIndex, $oswName, $iolwName, $pNull, $oswClass, $iolwClass, $opftLastWrite )>
+
+C<$swName> and C<$swClass> are UNICODE and C<$iolwName> and C<$iolwClass>
+are measured as number of C<WCHAR>s.
+
+=item RegEnumValueW
+
+=item C<RegEnumValueW( $hKey, $uIndex, $oswName, $iolwName, $pNull, $ouType, $opData, $iolData )>
+
+C<$oswName> is UNICODE and C<$iolwName> is measured as number
+of C<WCHAR>s.
+
+C<$opData> is UNICODE if C<$piType> is C<REG_SZ>, C<REG_EXPAND_SZ>,
+or C<REG_MULTI_SZ>. Note that C<$iolData> is measured as number
+of bytes even in these cases.
+
+=item RegLoadKeyW
+
+=item C<RegLoadKeyW( $hKey, $swSubKey, $swFileName )>
+
+C<$swSubKey> and C<$swFileName> are UNICODE.
+
+=item RegOpenKeyW
+
+=item C<RegOpenKeyW( $hKey, $swSubKey, $ohSubKey )>
+
+C<$swSubKey> is UNICODE.
+
+=item RegOpenKeyExW
+
+=item C<RegOpenKeyExW( $hKey, $swSubKey, $uOptions, $uAccess, $ohSubKey )>
+
+C<$swSubKey> is UNICODE.
+
+=item RegQueryInfoKeyW
+
+=item C<RegQueryInfoKeyW( $hKey, $oswClass, $iolwClass, $pNull, $ocSubKeys, $olwSubKey, $olwSubClass, $ocValues, $olwValName, $olValData, $olSecDesc, $opftTime )>
+
+C<$swClass> is UNICODE. C<$iolwClass>, C<$olwSubKey>, C<$olwSubClass>,
+and C<$olwValName> are measured as number of C<WCHAR>s. Note that
+C<$olValData> is measured as number of bytes.
+
+=item RegQueryMultipleValuesW
+
+=item C<RegQueryMultipleValuesW( $hKey, $ioarValueEnts, $icValueEnts, $opBuffer, $iolBuffer )>
+
+The C<ve_valuename> fields of the C<VALENT> [actually C<VALENTW>]
+structures in C<$ioarValueEnts> are UNICODE. Values of type C<REG_SZ>,
+C<REG_EXPAND_SZ>, and C<REG_MULTI_SZ> are written to C<$opBuffer>
+in UNICODE. Note that C<$iolBuffer> and the C<ve_valuelen> fields
+of the C<VALENT> [C<VALENTW>] structures are measured as number of
+bytes.
+
+=item RegQueryValueW
+
+=item C<RegQueryValueW( $hKey, $swSubKey, $oswValueData, $iolValueData )>
+
+C<$swSubKey> and C<$oswValueData> are UNICODE. Note that
+C<$iolValueData> is measured as number of bytes.
+
+=item RegQueryValueExW
+
+=item C<RegQueryValueExW( $hKey, $swName, $pNull, $ouType, $opData, $iolData )>
+
+C<$swName> is UNICODE.
+
+C<$opData> is UNICODE if C<$ouType> is C<REG_SZ>, C<REG_EXPAND_SZ>,
+or C<REG_MULTI_SZ>. Note that C<$iolData> is measured as number of
+bytes even in these cases.
+
+=item RegReplaceKeyW
+
+=item C<RegReplaceKeyW( $hKey, $swSubKey, $swNewFile, $swOldFile )>
+
+C<$swSubKey>, C<$swNewFile>, and C<$swOldFile> are UNICODE.
+
+=item RegRestoreKeyW
+
+=item C<RegRestoreKeyW( $hKey, $swFileName, $uFlags )>
+
+C<$swFileName> is UNICODE.
+
+=item RegSaveKeyW
+
+=item C<RegSaveKeyW( $hKey, $swFileName, $pSecAttr )>
+
+C<$swFileName> is UNICODE.
+
+=item RegSetValueW
+
+=item C<RegSetValueW( $hKey, $swSubKey, $uType, $swValueData, $lValueData )>
+
+C<$swSubKey> and C<$swValueData> are UNICODE. Note that
+C<$lValueData> is measured as number of bytes even though
+C<$swValueData> is always UNICODE.
+
+=item RegSetValueExW
+
+=item C<RegSetValueExW( $hKey, $swName, $uZero, $uType, $pData, $lData )>
+
+C<$swName> is UNICODE.
+
+C<$pData> is UNICODE if C<$uType> is C<REG_SZ>, C<REG_EXPAND_SZ>,
+or C<REG_MULTI_SZ>. Note that C<$lData> is measured as number of
+bytes even in these cases.
+
+=item RegUnLoadKeyW
+
+=item C<RegUnLoadKeyW( $hKey, $swSubKey )>
+
+C<$swSubKey> is UNICODE.
+
+=item :HKEY_
+
+All C<HKEY_*> constants:
+
+ HKEY_CLASSES_ROOT HKEY_CURRENT_CONFIG HKEY_CURRENT_USER
+ HKEY_DYN_DATA HKEY_LOCAL_MACHINE HKEY_PERFORMANCE_DATA
+ HKEY_USERS
+
+=item :KEY_
+
+All C<KEY_*> constants:
+
+ KEY_QUERY_VALUE KEY_SET_VALUE KEY_CREATE_SUB_KEY
+ KEY_ENUMERATE_SUB_KEYS KEY_NOTIFY KEY_CREATE_LINK
+ KEY_READ KEY_WRITE KEY_EXECUTE
+ KEY_ALL_ACCESS
+
+=item :REG_
+
+All C<REG_*> constants:
+
+ REG_CREATED_NEW_KEY REG_OPENED_EXISTING_KEY
+
+ REG_LEGAL_CHANGE_FILTER REG_NOTIFY_CHANGE_ATTRIBUTES
+ REG_NOTIFY_CHANGE_NAME REG_NOTIFY_CHANGE_LAST_SET
+ REG_NOTIFY_CHANGE_SECURITY REG_LEGAL_OPTION
+
+ REG_OPTION_BACKUP_RESTORE REG_OPTION_CREATE_LINK
+ REG_OPTION_NON_VOLATILE REG_OPTION_OPEN_LINK
+ REG_OPTION_RESERVED REG_OPTION_VOLATILE
+
+ REG_WHOLE_HIVE_VOLATILE REG_REFRESH_HIVE
+ REG_NO_LAZY_FLUSH
+
+ REG_NONE REG_SZ
+ REG_EXPAND_SZ REG_BINARY
+ REG_DWORD REG_DWORD_LITTLE_ENDIAN
+ REG_DWORD_BIG_ENDIAN REG_LINK
+ REG_MULTI_SZ REG_RESOURCE_LIST
+ REG_FULL_RESOURCE_DESCRIPTOR REG_RESOURCE_REQUIREMENTS_LIST
+
+=item :ALL
+
+All of the above.
+
+=item :SE_
+
+The strings for the following privilege names:
+
+ SE_ASSIGNPRIMARYTOKEN_NAME SE_AUDIT_NAME
+ SE_BACKUP_NAME SE_CHANGE_NOTIFY_NAME
+ SE_CREATE_PAGEFILE_NAME SE_CREATE_PERMANENT_NAME
+ SE_CREATE_TOKEN_NAME SE_DEBUG_NAME
+ SE_INCREASE_QUOTA_NAME SE_INC_BASE_PRIORITY_NAME
+ SE_LOAD_DRIVER_NAME SE_LOCK_MEMORY_NAME
+ SE_MACHINE_ACCOUNT_NAME SE_PROF_SINGLE_PROCESS_NAME
+ SE_REMOTE_SHUTDOWN_NAME SE_RESTORE_NAME
+ SE_SECURITY_NAME SE_SHUTDOWN_NAME
+ SE_SYSTEMTIME_NAME SE_SYSTEM_ENVIRONMENT_NAME
+ SE_SYSTEM_PROFILE_NAME SE_TAKE_OWNERSHIP_NAME
+ SE_TCB_NAME SE_UNSOLICITED_INPUT_NAME
+
+It can be difficult to successfully build this module in a way
+that makes these constants available. So some builds of this
+module may not make them available. For such builds, trying
+to export any of these constants will cause a fatal error.
+For this reason, none of these symbols are currently included
+in the C<":ALL"> grouping.
+
+=back
+
+=head2 The Win32API:: heirarchy
+
+This and the other Win32API:: modules are meant to expose the
+nearly raw API calls so they can be used from Perl code in any
+way they might be used from C code. This provides the following
+advantages:
+
+=over
+
+=item Many modules can be written by people that don't have a C compiler.
+
+=item Encourages more module code to be written in Perl [not C].
+
+Perl code is often much easier to inspect, debug, customize, and
+enhance than XS code.
+
+=item Allows those already familiar with the Win32 API to get
+off to a quick start.
+
+=item Provides an interactive tool for exploring even obscure
+details of the Win32 API.
+
+It can be very useful to interactively explore ad-hoc calls into
+parts of the Win32 API using:
+
+ perl -de 0
+
+=item Ensures that native Win32 data structures can be used.
+
+This allows maximum efficiency. It also allows data from one
+module [for example, time or security information from the
+C<Win32API::Registry> or C<Win32API::File> modules] to be used
+with other modules [for example, C<Win32API::Time> and
+C<Win32API::SecDesc>].
+
+=item Provides a single version of the XS interface to each API
+call where improvements can be collected.
+
+=back
+
+=head2 Buffer sizes
+
+For each parameter that specifies a buffer size, a value of C<0>
+can be passed. For parameter that are pointers to buffer sizes,
+you can also pass in C<NULL> by specifying an empty list reference,
+C<[]>. Both of these cases will ensure that the variable has
+I<some> buffer space allocated to it and pass in that buffer's
+allocated size. Many of the calls indicate, via C<ERROR_MORE_DATA>,
+that the buffer size was not sufficient and the F<Registry.xs>
+code will automatically enlarge the buffer to the required size
+and repeat the call.
+
+Numeric buffer sizes are used as minimum initial sizes for the
+buffers. The larger of this size and the size of space already
+allocated to the scalar will be passed to the underlying routine.
+If that size was insufficient, and the underlying call provides
+an easy method for determining the needed buffer size, then the
+buffer will be enlarged and the call repeated as above.
+
+The underlying calls define buffer size parameter as unsigned, so
+negative buffer sizes are treated as very large positive buffer
+sizes which usually cause C<malloc()> to fail.
+
+To force the F<Registry.xs> code to pass in a specific value for
+a buffer size, preceed the size with an equals sign via C<"=".>.
+Buffer sizes that are passed in as strings starting with an equals
+sign will have the equal sign stripped and the remainder of the string
+interpretted as a number [via C's C<strtoul()> using only base 10]
+which will be passed to the underlying routine [even if the allocated
+buffer is actually larger]. The F<Registry.xs> code will enlarge the
+buffer to the specified size, if needed, but will not enlarge the
+buffer based on the underlying routine requesting more space.
+
+Some Reg*() calls may not currently set the buffer size when they
+return C<ERROR_MORE_DATA>. But some that are not documented as
+doing so, currently do so anyway. So the code assumes that any
+routine I<might> do this and resizes any buffers and repeats the
+call. We hope that eventually all routines will provide this
+feature.
+
+When you use C<[]> for a buffer size, you can still find the
+length of the data returned by using C<length($buffer)>. Note
+that this length will be in bytes while a few of the buffer
+sizes would have been in units of wide characters.
+
+Note that the RegQueryValueEx*() and RegEnumValue*() calls
+will trim the trailing C<'\0'> [if present] from the returned data
+values of type C<REG_SZ> or C<REG_EXPAND_SZ> but only if the
+value data length parameter is omitted [or specified as C<[]>].
+
+The RegSetValueEx*() calls will add a trailing C<'\0'> [if
+missing] to the supplied data values of type C<REG_SZ> and
+C<REG_EXPAND_SZ> but only if the value data length parameter
+is omitted [or specified as C<0>].
+
+=head2 Hungarian Notation
+
+The following abbreviations are used at the start of each parameter
+name to hint at aspects of how the parameter is used. The prefix
+is always in lower case and followed by a capital letter that starts
+the descriptive part of the parameter name. Several of the following
+abbreviations can be combined into a single prefix.
+
+Probably not all of these prefix notations are used by this module.
+This document section may be included in any C<Win32API> module and
+so covers some notations not used by this specific module.
+
+=over
+
+=item s
+
+A string. In C, a C<'\0'>-terminated C<char *>. In Perl, just a
+string except that it will be truncated at the first C<"\0">, if
+it contains one.
+
+=item sw
+
+A wide [UNICODE] string. In C, a C<L'\0'>-terminated C<WCHAR *>.
+In Perl, a string that contains UNICODE data. You can convert a
+string to UNICODE in Perl via:
+
+ $string= "This is an example string";
+ $unicode= pack( "S*", unpack("C*",$string), 0 );
+
+Note how C<, 0> above causes an explicit C<L'\0'> to be added since
+Perl's implicit C<'\0'> that it puts after each of its strings is not
+wide enough to terminate a UNICODE string. So UNICODE strings are
+different than regular strings in that the Perl version of a regular
+string will not include the trialing C<'\0'> while the Perl version
+of a UNICODE string must include the trailing C<L'\0'>.
+
+If a UNICODE string contains no non-ASCII characters, then you
+can convert it back into a normal string via:
+
+ $string= pack( "C*", unpack("S*",$unicode) );
+ $string =~ s/\0$//;
+
+=item p
+
+A pointer to some buffer [usually containing some C<struct>]. In C,
+a C<void *> or some other pointer type. In Perl, a string that is
+usually manipulated using C<pack> and C<unpack>. The "p" is usually
+followed by more prefix character(s) to indicate what type of data is
+stored in the bufffer.
+
+=item a
+
+A packed array. In C, an array [usually of C<struct>s]. In Perl, a
+string containing the packed data. The "a" is usually followed by
+more prefix character(s) to indicate the data type of the elements.
+
+These packed arrays are also called "vectors" in places to avoid
+confusion with Perl arrays.
+
+=item n
+
+A generic number. In C, any of the integer or floating point data
+types. In Perl, a number; either an integer, unsigned, or double
+[IV, UV, or NV, respectively]. Usually an integer.
+
+=item iv
+
+A signed integral value. In C, any of the signed integer data types.
+In Perl, an integer [IV].
+
+=item u
+
+An unsigned integral value. In C, any of the unsigned integer data
+types. In Perl, an unsigned integer [UV].
+
+=item d
+
+A floating-point number. In C, a C<float> or C<double> or, perhaps,
+a C<long double>. In Perl, a double-precision floating-point number
+[NV].
+
+=item b
+
+A Boolean value. In C, any integer data type, though usually via
+a type alias of C<bool> or C<BOOL>, containing either a 0 [false] or
+non-zero [true] value. In Perl, a scalar containing a Boolean value
+[C<0>, C<"">, or C<undef> for "false" and anything else for "true"].
+
+=item c
+
+A count of items. In C, any integer data type. In Perl, an unsigned
+integer [UV]. Usually used in conjunction with a "vector" parameter
+[see L</a> above] to indicate the number of elements.
+
+=item l
+
+A length [in bytes]. In C, any integer data type. In Perl, an
+unsigned integer [UV]. Usually used in conjunction with a "string"
+or "pointer" parameter [see L</s> and L</p> above] to indicate the
+buffer size or the size of the value stored in the buffer.
+
+For strings, there is no general rule as to whether the trailing
+C<'\0'> is included in such sizes. For this reason, the C<Win32API>
+modules follow the Perl rule of always allocating one extra byte
+and reporting buffer sizes as being one smaller than allocated in
+case the C<'\0'> is not included in the size.
+
+=item lw
+
+A length measured as number of UNICODE characters. In C, a count
+of C<WCHAR>s. In Perl, an unsigned integer [UV] counting "shorts"
+[see "s" and "S" in C<pack> and C<unpack>].
+
+For UNICODE strings, the trailing C<L'\0'> may or may not be
+included in a length so, again, we always allocate extra room
+for one and don't report that extra space.
+
+=item h
+
+A handle. In C, a C<HANDLE> or more-specific handle data type.
+In Perl, an unsigned integer [UV]. In C, these handles are often
+actually some type of pointer, but Perl just treats them as opaque
+numbers, as it should. This prefix is also used for other pointers
+that are treated as integers in Perl code.
+
+=item r
+
+A record. In C, almost always a C<struct> or perhaps C<union>. Note
+that C C<struct>s are rarely passed by value so the "r" is almost
+always preceeded by a "p" or "a" [see L</p> and L</a> above]. For
+the very rare unadorned "r", Perl stores the record in the same way
+as a "pr", that is, in a string. For the very rare case where Perl
+explicitly stores a pointer to the C<struct> rather than storing the
+C<struct> directly in a Perl string, the prefix "pp" or "ppr" or even
+"par" is used.
+
+=item sv
+
+=item rv
+
+=item hv
+
+=item av
+
+=item cv
+
+A Perl data type. Respectively, a scalar value [SV], a reference
+[RV] [usually to a scalar], a hash [HV], a Perl array [AV], or a Perl
+code reference [PVCV]. For the "hv", "av", and "cv" prefixes, a
+leading "rv" is usually assumed. For a parameter to an XS subroutine,
+a prefix of "sv" means the parameter is a scalar and so may be a string
+or a number [or C<undef>] or even both at the same time. So "sv"
+doesn't imply a leading "rv".
+
+=item Input or Output
+
+Whether a parameter is for input data, output data, or both is usually
+not reflected by the data type prefix. In cases where this is not
+obvious nor reflected in the parameter name proper, we may use the
+following in front of the data type prefix.
+
+=over
+
+=item i
+
+An input parameter given to the API [usually omitted].
+
+=item o
+
+An output-only parameter taken from the API. You should not get a
+warning if such a parameter is C<undef> when you pass it into the
+function. You should get an error if such a parameter is read-only.
+You can [usually] pass in C<[]> for such a parameter to have the
+parameter silently ignored.
+
+The output may be written directly into the Perl variable passed
+to the subroutine, the same way the buffer parameter to Perl's
+C<sysread()>. This method is often avoided in Perl because
+the call then lacks any visual cue that some parameters are being
+overwritten. But this method closely matches the C API which is
+what we are trying to do.
+
+=item io
+
+Input given to the API then overwritten with output taken from the
+API. You should get a warning [if B<-w> is in effect] if such a
+parameter is C<undef> when you pass it into the function [unless it
+is a buffer or buffer length parameter]. If the value is read-only,
+then [for most parameters] the output is silently not written. This
+is because it is often convenient to pass in read-only constants for
+many such parameters. You can also usually pass in C<[]> for such
+parameters.
+
+=back
+
+=item pp
+
+=item ppr
+
+=item par
+
+=item pap
+
+These are just unusual combinations of prefix characters described above.
+
+For each, a pointer is stored in a [4-byte] Perl string. You can
+usually use C<unpack "P"> to access the real data from Perl.
+
+For "ppr" [and often for "pp"], the pointer points directly at a
+C C<struct>. For "par", the pointer points to the first element
+of a C [packed] array of C<struct>s. For "pap", the pointer points
+to a C [packed] array of pointers to other things.
+
+=item ap
+
+Here we have a list of pointers packed into a single Perl string.
+
+=back
+
+=head1 BUGS
+
+The old ActiveState ports of Perl for Win32 [but not, ActivePerl, the
+ActiveState distributions of standard Perl 5.004 and beyond] do not support
+the tools for building extensions and so do not support this extension.
+
+No routines are provided for using the data returned in the C<FILETIME>
+buffers. Those are in the C<Win32API::Time> module.
+
+No routines are provided for dealing with UNICODE data effectively.
+See L</:FuncW> above for some simple-minded UNICODE methods.
+
+Parts of the module test will fail if used on a version of Perl
+that does not yet set C<$^E> based on C<GetLastError()>.
+
+On NT 4.0 [at least], the RegEnum*() calls do not set the required
+buffer sizes when returning C<ERROR_MORE_DATA> so this module will
+not grow the buffers in such cases. C<Win32::TieRegistry> overcomes
+this by using values from C<RegQueryInfoKey()> for buffer sizes in
+RegEnum* calls.
+
+On NT 4.0 [at least], C<RegQueryInfoKey()> on C<HKEY_PERFORMANCE_DATA>
+never succeeds. Also, C<RegQueryValueEx()> on C<HKEY_PERFORMANCE_DATA>
+never returns the required buffer size. To access C<HKEY_PERFORMANCE_DATA>
+you will need to keep growing the data buffer until the call succeeds.
+
+Because C<goto &subroutine> seems to be buggy under Win32 Perl,
+it is not used in the stubs in F<Registry.pm>.
+
+=head1 AUTHOR
+
+Tye McQueen, tye@metronet.com, http://www.metronet.com/~tye/.
+
+=head1 SEE ALSO
+
+=over
+
+=item L<Win32::TieRegistry>
+
+=item L<Win32::Registry>
+
+=back
+
+=cut
diff --git a/Master/tlpkg/installer/perllib/Win32API/Registry/cRegistry.pc b/Master/tlpkg/installer/perllib/Win32API/Registry/cRegistry.pc
new file mode 100644
index 00000000000..9659d0c4361
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/Win32API/Registry/cRegistry.pc
@@ -0,0 +1,87 @@
+# Generated by cRegistry_pc.cxx.
+# Package Win32API::Registry with options:
+# CPLUSPLUS => q[1]
+# IFDEF => q[ /^SE_/ ? '__cplusplus' : /REG_/ ]
+# IMPORT_LIST => [q[/._/], q[!/[a-z]/]]
+# VALUES => { KEY_DELETE=>q[DELETE], KEY_READ_CONTROL=>q[READ_CONTROL], KEY_WRITE_OWNER=>q[WRITE_OWNER], KEY_SYNCHRONIZE=>q[SYNCHRONIZE], KEY_WRITE_DAC=>q[WRITE_DAC] }
+# WRITE_PERL => q[1]
+# Perl files eval'd:
+# Registry.pm => last if /^\s*(bootstrap|XSLoader::load)\b/
+# C files included:
+# Registry.xs => last if m#/[/*]\s*CONSTS_DEFINED\b|^\s*MODULE\b#
+sub HKEY_CLASSES_ROOT () { 0x80000000 }
+sub HKEY_CURRENT_CONFIG () { 0x80000005 }
+sub HKEY_CURRENT_USER () { 0x80000001 }
+sub HKEY_DYN_DATA () { 0x80000006 }
+sub HKEY_LOCAL_MACHINE () { 0x80000002 }
+sub HKEY_PERFORMANCE_DATA () { 0x80000004 }
+sub HKEY_USERS () { 0x80000003 }
+sub KEY_ALL_ACCESS () { 983103 }
+sub KEY_CREATE_LINK () { 32 }
+sub KEY_CREATE_SUB_KEY () { 4 }
+sub KEY_DELETE () { 65536 }
+sub KEY_ENUMERATE_SUB_KEYS () { 8 }
+sub KEY_EXECUTE () { 131097 }
+sub KEY_NOTIFY () { 16 }
+sub KEY_QUERY_VALUE () { 1 }
+sub KEY_READ () { 131097 }
+sub KEY_READ_CONTROL () { 131072 }
+sub KEY_SET_VALUE () { 2 }
+sub KEY_SYNCHRONIZE () { 1048576 }
+sub KEY_WRITE () { 131078 }
+sub KEY_WRITE_DAC () { 262144 }
+sub KEY_WRITE_OWNER () { 524288 }
+sub REG_BINARY () { 3 }
+sub REG_CREATED_NEW_KEY () { 1 }
+sub REG_DWORD () { 4 }
+sub REG_DWORD_BIG_ENDIAN () { 5 }
+sub REG_DWORD_LITTLE_ENDIAN () { 4 }
+sub REG_EXPAND_SZ () { 2 }
+sub REG_FULL_RESOURCE_DESCRIPTOR () { 9 }
+sub REG_LEGAL_CHANGE_FILTER () { 15 }
+sub REG_LEGAL_OPTION () { 15 }
+sub REG_LINK () { 6 }
+sub REG_MULTI_SZ () { 7 }
+sub REG_NONE () { 0 }
+sub REG_NOTIFY_CHANGE_ATTRIBUTES () { 2 }
+sub REG_NOTIFY_CHANGE_LAST_SET () { 4 }
+sub REG_NOTIFY_CHANGE_NAME () { 1 }
+sub REG_NOTIFY_CHANGE_SECURITY () { 8 }
+sub REG_NO_LAZY_FLUSH () { 4 }
+sub REG_OPENED_EXISTING_KEY () { 2 }
+sub REG_OPTION_BACKUP_RESTORE () { 4 }
+sub REG_OPTION_CREATE_LINK () { 2 }
+sub REG_OPTION_NON_VOLATILE () { 0 }
+sub REG_OPTION_OPEN_LINK () { 8 }
+sub REG_OPTION_RESERVED () { 0 }
+sub REG_OPTION_VOLATILE () { 1 }
+sub REG_REFRESH_HIVE () { 2 }
+sub REG_RESOURCE_LIST () { 8 }
+sub REG_RESOURCE_REQUIREMENTS_LIST () { 10 }
+sub REG_SZ () { 1 }
+sub REG_WHOLE_HIVE_VOLATILE () { 1 }
+sub SE_ASSIGNPRIMARYTOKEN_NAME () { 'SeAssignPrimaryTokenPrivilege' }
+sub SE_AUDIT_NAME () { 'SeAuditPrivilege' }
+sub SE_BACKUP_NAME () { 'SeBackupPrivilege' }
+sub SE_CHANGE_NOTIFY_NAME () { 'SeChangeNotifyPrivilege' }
+sub SE_CREATE_PAGEFILE_NAME () { 'SeCreatePagefilePrivilege' }
+sub SE_CREATE_PERMANENT_NAME () { 'SeCreatePermanentPrivilege' }
+sub SE_CREATE_TOKEN_NAME () { 'SeCreateTokenPrivilege' }
+sub SE_DEBUG_NAME () { 'SeDebugPrivilege' }
+sub SE_INCREASE_QUOTA_NAME () { 'SeIncreaseQuotaPrivilege' }
+sub SE_INC_BASE_PRIORITY_NAME () { 'SeIncreaseBasePriorityPrivilege' }
+sub SE_LOAD_DRIVER_NAME () { 'SeLoadDriverPrivilege' }
+sub SE_LOCK_MEMORY_NAME () { 'SeLockMemoryPrivilege' }
+sub SE_MACHINE_ACCOUNT_NAME () { 'SeMachineAccountPrivilege' }
+sub SE_PROF_SINGLE_PROCESS_NAME () { 'SeProfileSingleProcessPrivilege' }
+sub SE_REMOTE_SHUTDOWN_NAME () { 'SeRemoteShutdownPrivilege' }
+sub SE_RESTORE_NAME () { 'SeRestorePrivilege' }
+sub SE_SECURITY_NAME () { 'SeSecurityPrivilege' }
+sub SE_SHUTDOWN_NAME () { 'SeShutdownPrivilege' }
+sub SE_SYSTEMTIME_NAME () { 'SeSystemtimePrivilege' }
+sub SE_SYSTEM_ENVIRONMENT_NAME () { 'SeSystemEnvironmentPrivilege' }
+sub SE_SYSTEM_PROFILE_NAME () { 'SeSystemProfilePrivilege' }
+sub SE_TAKE_OWNERSHIP_NAME () { 'SeTakeOwnershipPrivilege' }
+sub SE_TCB_NAME () { 'SeTcbPrivilege' }
+sub SE_UNSOLICITED_INPUT_NAME () { 'SeUnsolicitedInputPrivilege' }
+1;
diff --git a/Master/tlpkg/installer/perllib/XSLoader.pm b/Master/tlpkg/installer/perllib/XSLoader.pm
new file mode 100644
index 00000000000..34172dcfa70
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/XSLoader.pm
@@ -0,0 +1,356 @@
+# Generated from XSLoader.pm.PL (resolved %Config::Config value)
+
+package XSLoader;
+
+$VERSION = "0.06";
+
+#use strict;
+
+# enable debug/trace messages from DynaLoader perl code
+# $dl_debug = $ENV{PERL_DL_DEBUG} || 0 unless defined $dl_debug;
+
+ my $dl_dlext = 'dll';
+
+package DynaLoader;
+
+# No prizes for guessing why we don't say 'bootstrap DynaLoader;' here.
+# NOTE: All dl_*.xs (including dl_none.xs) define a dl_error() XSUB
+boot_DynaLoader('DynaLoader') if defined(&boot_DynaLoader) &&
+ !defined(&dl_error);
+package XSLoader;
+
+sub load {
+ package DynaLoader;
+
+ die q{XSLoader::load('Your::Module', $Your::Module::VERSION)} unless @_;
+
+ my($module) = $_[0];
+
+ # work with static linking too
+ my $b = "$module\::bootstrap";
+ goto &$b if defined &$b;
+
+ goto retry unless $module and defined &dl_load_file;
+
+ my @modparts = split(/::/,$module);
+ my $modfname = $modparts[-1];
+
+ my $modpname = join('/',@modparts);
+ my $modlibname = (caller())[1];
+ my $c = @modparts;
+ $modlibname =~ s,[\\/][^\\/]+$,, while $c--; # Q&D basename
+ my $file = "$modlibname/auto/$modpname/$modfname.$dl_dlext";
+
+# print STDERR "XSLoader::load for $module ($file)\n" if $dl_debug;
+
+ my $bs = $file;
+ $bs =~ s/(\.\w+)?(;\d*)?$/\.bs/; # look for .bs 'beside' the library
+
+ goto retry if not -f $file or -s $bs;
+
+ my $bootname = "boot_$module";
+ $bootname =~ s/\W/_/g;
+ @DynaLoader::dl_require_symbols = ($bootname);
+
+ my $boot_symbol_ref;
+
+ if ($^O eq 'darwin') {
+ if ($boot_symbol_ref = dl_find_symbol(0, $bootname)) {
+ goto boot; #extension library has already been loaded, e.g. darwin
+ }
+ }
+
+ # Many dynamic extension loading problems will appear to come from
+ # this section of code: XYZ failed at line 123 of DynaLoader.pm.
+ # Often these errors are actually occurring in the initialisation
+ # C code of the extension XS file. Perl reports the error as being
+ # in this perl code simply because this was the last perl code
+ # it executed.
+
+ my $libref = dl_load_file($file, 0) or do {
+ require Carp;
+ Carp::croak("Can't load '$file' for module $module: " . dl_error());
+ };
+ push(@DynaLoader::dl_librefs,$libref); # record loaded object
+
+ my @unresolved = dl_undef_symbols();
+ if (@unresolved) {
+ require Carp;
+ Carp::carp("Undefined symbols present after loading $file: @unresolved\n");
+ }
+
+ $boot_symbol_ref = dl_find_symbol($libref, $bootname) or do {
+ require Carp;
+ Carp::croak("Can't find '$bootname' symbol in $file\n");
+ };
+
+ push(@DynaLoader::dl_modules, $module); # record loaded module
+
+ boot:
+ my $xs = dl_install_xsub("${module}::bootstrap", $boot_symbol_ref, $file);
+
+ # See comment block above
+ push(@DynaLoader::dl_shared_objects, $file); # record files loaded
+ return &$xs(@_);
+
+ retry:
+ my $bootstrap_inherit = DynaLoader->can('bootstrap_inherit') ||
+ XSLoader->can('bootstrap_inherit');
+ goto &$bootstrap_inherit;
+}
+
+# Versions of DynaLoader prior to 5.6.0 don't have this function.
+sub bootstrap_inherit {
+ package DynaLoader;
+
+ my $module = $_[0];
+ local *DynaLoader::isa = *{"$module\::ISA"};
+ local @DynaLoader::isa = (@DynaLoader::isa, 'DynaLoader');
+ # Cannot goto due to delocalization. Will report errors on a wrong line?
+ require DynaLoader;
+ DynaLoader::bootstrap(@_);
+}
+
+1;
+
+
+__END__
+
+=head1 NAME
+
+XSLoader - Dynamically load C libraries into Perl code
+
+=head1 VERSION
+
+Version 0.06
+
+=head1 SYNOPSIS
+
+ package YourPackage;
+ use XSLoader;
+
+ XSLoader::load 'YourPackage', $YourPackage::VERSION;
+
+=head1 DESCRIPTION
+
+This module defines a standard I<simplified> interface to the dynamic
+linking mechanisms available on many platforms. Its primary purpose is
+to implement cheap automatic dynamic loading of Perl modules.
+
+For a more complicated interface, see L<DynaLoader>. Many (most)
+features of C<DynaLoader> are not implemented in C<XSLoader>, like for
+example the C<dl_load_flags>, not honored by C<XSLoader>.
+
+=head2 Migration from C<DynaLoader>
+
+A typical module using L<DynaLoader|DynaLoader> starts like this:
+
+ package YourPackage;
+ require DynaLoader;
+
+ our @ISA = qw( OnePackage OtherPackage DynaLoader );
+ our $VERSION = '0.01';
+ bootstrap YourPackage $VERSION;
+
+Change this to
+
+ package YourPackage;
+ use XSLoader;
+
+ our @ISA = qw( OnePackage OtherPackage );
+ our $VERSION = '0.01';
+ XSLoader::load 'YourPackage', $VERSION;
+
+In other words: replace C<require DynaLoader> by C<use XSLoader>, remove
+C<DynaLoader> from C<@ISA>, change C<bootstrap> by C<XSLoader::load>. Do not
+forget to quote the name of your package on the C<XSLoader::load> line,
+and add comma (C<,>) before the arguments (C<$VERSION> above).
+
+Of course, if C<@ISA> contained only C<DynaLoader>, there is no need to have
+the C<@ISA> assignment at all; moreover, if instead of C<our> one uses the
+more backward-compatible
+
+ use vars qw($VERSION @ISA);
+
+one can remove this reference to C<@ISA> together with the C<@ISA> assignment.
+
+If no C<$VERSION> was specified on the C<bootstrap> line, the last line becomes
+
+ XSLoader::load 'YourPackage';
+
+=head2 Backward compatible boilerplate
+
+If you want to have your cake and eat it too, you need a more complicated
+boilerplate.
+
+ package YourPackage;
+ use vars qw($VERSION @ISA);
+
+ @ISA = qw( OnePackage OtherPackage );
+ $VERSION = '0.01';
+ eval {
+ require XSLoader;
+ XSLoader::load('YourPackage', $VERSION);
+ 1;
+ } or do {
+ require DynaLoader;
+ push @ISA, 'DynaLoader';
+ bootstrap YourPackage $VERSION;
+ };
+
+The parentheses about C<XSLoader::load()> arguments are needed since we replaced
+C<use XSLoader> by C<require>, so the compiler does not know that a function
+C<XSLoader::load()> is present.
+
+This boilerplate uses the low-overhead C<XSLoader> if present; if used with
+an antic Perl which has no C<XSLoader>, it falls back to using C<DynaLoader>.
+
+=head1 Order of initialization: early load()
+
+I<Skip this section if the XSUB functions are supposed to be called from other
+modules only; read it only if you call your XSUBs from the code in your module,
+or have a C<BOOT:> section in your XS file (see L<perlxs/"The BOOT: Keyword">).
+What is described here is equally applicable to the L<DynaLoader|DynaLoader>
+interface.>
+
+A sufficiently complicated module using XS would have both Perl code (defined
+in F<YourPackage.pm>) and XS code (defined in F<YourPackage.xs>). If this
+Perl code makes calls into this XS code, and/or this XS code makes calls to
+the Perl code, one should be careful with the order of initialization.
+
+The call to C<XSLoader::load()> (or C<bootstrap()>) has three side effects:
+
+=over
+
+=item *
+
+if C<$VERSION> was specified, a sanity check is done to ensure that the
+versions of the F<.pm> and the (compiled) F<.xs> parts are compatible;
+
+=item *
+
+the XSUBs are made accessible from Perl;
+
+=item *
+
+if a C<BOOT:> section was present in the F<.xs> file, the code there is called.
+
+=back
+
+Consequently, if the code in the F<.pm> file makes calls to these XSUBs, it is
+convenient to have XSUBs installed before the Perl code is defined; for
+example, this makes prototypes for XSUBs visible to this Perl code.
+Alternatively, if the C<BOOT:> section makes calls to Perl functions (or
+uses Perl variables) defined in the F<.pm> file, they must be defined prior to
+the call to C<XSLoader::load()> (or C<bootstrap()>).
+
+The first situation being much more frequent, it makes sense to rewrite the
+boilerplate as
+
+ package YourPackage;
+ use XSLoader;
+ use vars qw($VERSION @ISA);
+
+ BEGIN {
+ @ISA = qw( OnePackage OtherPackage );
+ $VERSION = '0.01';
+
+ # Put Perl code used in the BOOT: section here
+
+ XSLoader::load 'YourPackage', $VERSION;
+ }
+
+ # Put Perl code making calls into XSUBs here
+
+=head2 The most hairy case
+
+If the interdependence of your C<BOOT:> section and Perl code is
+more complicated than this (e.g., the C<BOOT:> section makes calls to Perl
+functions which make calls to XSUBs with prototypes), get rid of the C<BOOT:>
+section altogether. Replace it with a function C<onBOOT()>, and call it like
+this:
+
+ package YourPackage;
+ use XSLoader;
+ use vars qw($VERSION @ISA);
+
+ BEGIN {
+ @ISA = qw( OnePackage OtherPackage );
+ $VERSION = '0.01';
+ XSLoader::load 'YourPackage', $VERSION;
+ }
+
+ # Put Perl code used in onBOOT() function here; calls to XSUBs are
+ # prototype-checked.
+
+ onBOOT;
+
+ # Put Perl initialization code assuming that XS is initialized here
+
+
+=head1 DIAGNOSTICS
+
+=over 4
+
+=item Can't find '%s' symbol in %s
+
+B<(F)> The bootstrap symbol could not be found in the extension module.
+
+=item Can't load '%s' for module %s: %s
+
+B<(F)> The loading or initialisation of the extension module failed.
+The detailed error follows.
+
+=item Undefined symbols present after loading %s: %s
+
+B<(W)> As the message says, some symbols stay undefined although the
+extension module was correctly loaded and initialised. The list of undefined
+symbols follows.
+
+=item XSLoader::load('Your::Module', $Your::Module::VERSION)
+
+B<(F)> You tried to invoke C<load()> without any argument. You must supply
+a module name, and optionally its version.
+
+=back
+
+
+=head1 LIMITATIONS
+
+To reduce the overhead as much as possible, only one possible location
+is checked to find the extension DLL (this location is where C<make install>
+would put the DLL). If not found, the search for the DLL is transparently
+delegated to C<DynaLoader>, which looks for the DLL along the C<@INC> list.
+
+In particular, this is applicable to the structure of C<@INC> used for testing
+not-yet-installed extensions. This means that running uninstalled extensions
+may have much more overhead than running the same extensions after
+C<make install>.
+
+
+=head1 BUGS
+
+Please report any bugs or feature requests via the perlbug(1) utility.
+
+
+=head1 SEE ALSO
+
+L<DynaLoader>
+
+
+=head1 AUTHORS
+
+Ilya Zakharevich originally extracted C<XSLoader> from C<DynaLoader>.
+
+CPAN version is currently maintained by SE<eacute>bastien Aperghis-Tramoni
+E<lt>sebastien@aperghis.netE<gt>
+
+Previous maintainer was Michael G Schwern <schwern@pobox.com>
+
+
+=head1 COPYRIGHT
+
+This program is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
diff --git a/Master/tlpkg/installer/perllib/auto/Cwd/Cwd.bs b/Master/tlpkg/installer/perllib/auto/Cwd/Cwd.bs
new file mode 100644
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/auto/Cwd/Cwd.bs
diff --git a/Master/tlpkg/installer/perllib/auto/Cwd/Cwd.dll b/Master/tlpkg/installer/perllib/auto/Cwd/Cwd.dll
new file mode 100755
index 00000000000..67f6d7baa57
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/auto/Cwd/Cwd.dll
Binary files differ
diff --git a/Master/tlpkg/installer/perllib/auto/DynaLoader/autosplit.ix b/Master/tlpkg/installer/perllib/auto/DynaLoader/autosplit.ix
new file mode 100644
index 00000000000..d7605efa074
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/auto/DynaLoader/autosplit.ix
@@ -0,0 +1,8 @@
+# Index created by AutoSplit for ../LIB\DynaLoader.pm
+# (file acts as timestamp)
+package DynaLoader;
+sub dl_findfile ;
+sub dl_expandspec ;
+sub dl_find_symbol_anywhere
+;
+1;
diff --git a/Master/tlpkg/installer/perllib/auto/DynaLoader/dl_expandspec.al b/Master/tlpkg/installer/perllib/auto/DynaLoader/dl_expandspec.al
new file mode 100644
index 00000000000..0bea19a3e4d
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/auto/DynaLoader/dl_expandspec.al
@@ -0,0 +1,34 @@
+# NOTE: Derived from ../LIB\DynaLoader.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package DynaLoader;
+
+#line 377 "../LIB\DynaLoader.pm (autosplit into ..\lib\auto\DynaLoader\dl_expandspec.al)"
+sub dl_expandspec {
+ my($spec) = @_;
+ # Optional function invoked if DynaLoader.pm sets $do_expand.
+ # Most systems do not require or use this function.
+ # Some systems may implement it in the dl_*.xs file in which case
+ # this autoload version will not be called but is harmless.
+
+ # This function is designed to deal with systems which treat some
+ # 'filenames' in a special way. For example VMS 'Logical Names'
+ # (something like unix environment variables - but different).
+ # This function should recognise such names and expand them into
+ # full file paths.
+ # Must return undef if $spec is invalid or file does not exist.
+
+ my $file = $spec; # default output to input
+
+ if ($Is_VMS) { # dl_expandspec should be defined in dl_vms.xs
+ require Carp;
+ Carp::croak("dl_expandspec: should be defined in XS file!\n");
+ } else {
+ return undef unless -f $file;
+ }
+ print STDERR "dl_expandspec($spec) => $file\n" if $dl_debug;
+ $file;
+}
+
+# end of DynaLoader::dl_expandspec
+1;
diff --git a/Master/tlpkg/installer/perllib/auto/DynaLoader/dl_find_symbol_anywhere.al b/Master/tlpkg/installer/perllib/auto/DynaLoader/dl_find_symbol_anywhere.al
new file mode 100644
index 00000000000..2232454ba69
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/auto/DynaLoader/dl_find_symbol_anywhere.al
@@ -0,0 +1,19 @@
+# NOTE: Derived from ../LIB\DynaLoader.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package DynaLoader;
+
+#line 403 "../LIB\DynaLoader.pm (autosplit into ..\lib\auto\DynaLoader\dl_find_symbol_anywhere.al)"
+sub dl_find_symbol_anywhere
+{
+ my $sym = shift;
+ my $libref;
+ foreach $libref (@dl_librefs) {
+ my $symref = dl_find_symbol($libref,$sym);
+ return $symref if $symref;
+ }
+ return undef;
+}
+
+1;
+# end of DynaLoader::dl_find_symbol_anywhere
diff --git a/Master/tlpkg/installer/perllib/auto/DynaLoader/dl_findfile.al b/Master/tlpkg/installer/perllib/auto/DynaLoader/dl_findfile.al
new file mode 100644
index 00000000000..9f8df39d00c
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/auto/DynaLoader/dl_findfile.al
@@ -0,0 +1,115 @@
+# NOTE: Derived from ../LIB\DynaLoader.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package DynaLoader;
+
+#line 269 "../LIB\DynaLoader.pm (autosplit into ..\lib\auto\DynaLoader\dl_findfile.al)"
+sub dl_findfile {
+ # Read ext/DynaLoader/DynaLoader.doc for detailed information.
+ # This function does not automatically consider the architecture
+ # or the perl library auto directories.
+ my (@args) = @_;
+ my (@dirs, $dir); # which directories to search
+ my (@found); # full paths to real files we have found
+ my $dl_ext= 'dll'; # $Config::Config{'dlext'} suffix for perl extensions
+ my $dl_so = 'dll'; # $Config::Config{'so'} suffix for shared libraries
+
+ print STDERR "dl_findfile(@args)\n" if $dl_debug;
+
+ # accumulate directories but process files as they appear
+ arg: foreach(@args) {
+ # Special fast case: full filepath requires no search
+ if ($Is_VMS && m%[:>/\]]% && -f $_) {
+ push(@found,dl_expandspec(VMS::Filespec::vmsify($_)));
+ last arg unless wantarray;
+ next;
+ }
+ elsif ($Is_MacOS) {
+ if (m/:/ && -f $_) {
+ push(@found,$_);
+ last arg unless wantarray;
+ }
+ }
+ elsif (m:/: && -f $_ && !$do_expand) {
+ push(@found,$_);
+ last arg unless wantarray;
+ next;
+ }
+
+ # Deal with directories first:
+ # Using a -L prefix is the preferred option (faster and more robust)
+ if (m:^-L:) { s/^-L//; push(@dirs, $_); next; }
+
+ if ($Is_MacOS) {
+ # Otherwise we try to try to spot directories by a heuristic
+ # (this is a more complicated issue than it first appears)
+ if (m/:/ && -d $_) { push(@dirs, $_); next; }
+ # Only files should get this far...
+ my(@names, $name); # what filenames to look for
+ s/^-l//;
+ push(@names, $_);
+ foreach $dir (@dirs, @dl_library_path) {
+ next unless -d $dir;
+ $dir =~ s/^([^:]+)$/:$1/;
+ $dir =~ s/:$//;
+ foreach $name (@names) {
+ my($file) = "$dir:$name";
+ print STDERR " checking in $dir for $name\n" if $dl_debug;
+ if (-f $file) {
+ push(@found, $file);
+ next arg; # no need to look any further
+ }
+ }
+ }
+ next;
+ }
+
+ # Otherwise we try to try to spot directories by a heuristic
+ # (this is a more complicated issue than it first appears)
+ if (m:/: && -d $_) { push(@dirs, $_); next; }
+
+ # VMS: we may be using native VMS directory syntax instead of
+ # Unix emulation, so check this as well
+ if ($Is_VMS && /[:>\]]/ && -d $_) { push(@dirs, $_); next; }
+
+ # Only files should get this far...
+ my(@names, $name); # what filenames to look for
+ if (m:-l: ) { # convert -lname to appropriate library name
+ s/-l//;
+ push(@names,"lib$_.$dl_so");
+ push(@names,"lib$_.a");
+ } else { # Umm, a bare name. Try various alternatives:
+ # these should be ordered with the most likely first
+ push(@names,"$_.$dl_ext") unless m/\.$dl_ext$/o;
+ push(@names,"$_.$dl_so") unless m/\.$dl_so$/o;
+ push(@names,"lib$_.$dl_so") unless m:/:;
+ push(@names,"$_.a") if !m/\.a$/ and $dlsrc eq "dl_dld.xs";
+ push(@names, $_);
+ }
+ foreach $dir (@dirs, @dl_library_path) {
+ next unless -d $dir;
+ chop($dir = VMS::Filespec::unixpath($dir)) if $Is_VMS;
+ foreach $name (@names) {
+ my($file) = "$dir/$name";
+ print STDERR " checking in $dir for $name\n" if $dl_debug;
+ $file = ($do_expand) ? dl_expandspec($file) : (-f $file && $file);
+ #$file = _check_file($file);
+ if ($file) {
+ push(@found, $file);
+ next arg; # no need to look any further
+ }
+ }
+ }
+ }
+ if ($dl_debug) {
+ foreach(@dirs) {
+ print STDERR " dl_findfile ignored non-existent directory: $_\n" unless -d $_;
+ }
+ print STDERR "dl_findfile found: @found\n";
+ }
+ return $found[0] unless wantarray;
+ @found;
+}
+
+# end of DynaLoader::dl_findfile
+1;
diff --git a/Master/tlpkg/installer/perllib/auto/Encode/Byte/Byte.bs b/Master/tlpkg/installer/perllib/auto/Encode/Byte/Byte.bs
new file mode 100644
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/auto/Encode/Byte/Byte.bs
diff --git a/Master/tlpkg/installer/perllib/auto/Encode/Byte/Byte.dll b/Master/tlpkg/installer/perllib/auto/Encode/Byte/Byte.dll
new file mode 100755
index 00000000000..88474ccb046
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/auto/Encode/Byte/Byte.dll
Binary files differ
diff --git a/Master/tlpkg/installer/perllib/auto/Encode/Encode.bs b/Master/tlpkg/installer/perllib/auto/Encode/Encode.bs
new file mode 100644
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/auto/Encode/Encode.bs
diff --git a/Master/tlpkg/installer/perllib/auto/Encode/Encode.dll b/Master/tlpkg/installer/perllib/auto/Encode/Encode.dll
new file mode 100755
index 00000000000..69c8ebf8acb
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/auto/Encode/Encode.dll
Binary files differ
diff --git a/Master/tlpkg/installer/perllib/auto/Encode/Unicode/Unicode.bs b/Master/tlpkg/installer/perllib/auto/Encode/Unicode/Unicode.bs
new file mode 100644
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/auto/Encode/Unicode/Unicode.bs
diff --git a/Master/tlpkg/installer/perllib/auto/Encode/Unicode/Unicode.dll b/Master/tlpkg/installer/perllib/auto/Encode/Unicode/Unicode.dll
new file mode 100755
index 00000000000..71a757a6b64
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/auto/Encode/Unicode/Unicode.dll
Binary files differ
diff --git a/Master/tlpkg/installer/perllib/auto/Tk/CancelRepeat.al b/Master/tlpkg/installer/perllib/auto/Tk/CancelRepeat.al
new file mode 100644
index 00000000000..d0d6bb1b2a3
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/auto/Tk/CancelRepeat.al
@@ -0,0 +1,15 @@
+# NOTE: Derived from blib\lib\Tk.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk;
+
+#line 491 "blib\lib\Tk.pm (autosplit into blib\lib\auto\Tk\CancelRepeat.al)"
+sub CancelRepeat
+{
+ my $w = shift->MainWindow;
+ my $id = delete $w->{_afterId_};
+ $w->after('cancel',$id) if (defined $id);
+}
+
+# end of Tk::CancelRepeat
+1;
diff --git a/Master/tlpkg/installer/perllib/auto/Tk/Clipboard/autosplit.ix b/Master/tlpkg/installer/perllib/auto/Tk/Clipboard/autosplit.ix
new file mode 100644
index 00000000000..9831f74facb
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/auto/Tk/Clipboard/autosplit.ix
@@ -0,0 +1,6 @@
+# Index created by AutoSplit for blib\lib\Tk\Clipboard.pm
+# (file acts as timestamp)
+package Tk::Clipboard;
+sub getSelected
+;
+1;
diff --git a/Master/tlpkg/installer/perllib/auto/Tk/Clipboard/getSelected.al b/Master/tlpkg/installer/perllib/auto/Tk/Clipboard/getSelected.al
new file mode 100644
index 00000000000..44ba7b74bf0
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/auto/Tk/Clipboard/getSelected.al
@@ -0,0 +1,15 @@
+# NOTE: Derived from blib\lib\Tk\Clipboard.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Clipboard;
+
+#line 115 "blib\lib\Tk\Clipboard.pm (autosplit into blib\lib\auto\Tk\Clipboard\getSelected.al)"
+sub getSelected
+{
+ my $w = shift;
+ my $val = Tk::catch { $w->get('sel.first','sel.last') };
+ return $val;
+}
+
+1;
+# end of Tk::Clipboard::getSelected
diff --git a/Master/tlpkg/installer/perllib/auto/Tk/Entry/Entry.bs b/Master/tlpkg/installer/perllib/auto/Tk/Entry/Entry.bs
new file mode 100644
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/auto/Tk/Entry/Entry.bs
diff --git a/Master/tlpkg/installer/perllib/auto/Tk/Entry/Entry.dll b/Master/tlpkg/installer/perllib/auto/Tk/Entry/Entry.dll
new file mode 100755
index 00000000000..9b1c07a7792
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/auto/Tk/Entry/Entry.dll
Binary files differ
diff --git a/Master/tlpkg/installer/perllib/auto/Tk/Error.al b/Master/tlpkg/installer/perllib/auto/Tk/Error.al
new file mode 100644
index 00000000000..7efe2c7043d
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/auto/Tk/Error.al
@@ -0,0 +1,20 @@
+# NOTE: Derived from blib\lib\Tk.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk;
+
+#line 479 "blib\lib\Tk.pm (autosplit into blib\lib\auto\Tk\Error.al)"
+sub Error
+{my $w = shift;
+ my $error = shift;
+ if (Exists($w))
+ {
+ my $grab = $w->grab('current');
+ $grab->Unbusy if (defined $grab);
+ }
+ chomp($error);
+ warn "Tk::Error: $error\n " . join("\n ",@_)."\n";
+}
+
+# end of Tk::Error
+1;
diff --git a/Master/tlpkg/installer/perllib/auto/Tk/Event/Event.bs b/Master/tlpkg/installer/perllib/auto/Tk/Event/Event.bs
new file mode 100644
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/auto/Tk/Event/Event.bs
diff --git a/Master/tlpkg/installer/perllib/auto/Tk/Event/Event.dll b/Master/tlpkg/installer/perllib/auto/Tk/Event/Event.dll
new file mode 100755
index 00000000000..5a9706cb92e
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/auto/Tk/Event/Event.dll
Binary files differ
diff --git a/Master/tlpkg/installer/perllib/auto/Tk/Frame/autosplit.ix b/Master/tlpkg/installer/perllib/auto/Tk/Frame/autosplit.ix
new file mode 100644
index 00000000000..6e5b939fce1
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/auto/Tk/Frame/autosplit.ix
@@ -0,0 +1,24 @@
+# Index created by AutoSplit for blib\lib\Tk\Frame.pm
+# (file acts as timestamp)
+package Tk::Frame;
+sub labelPack
+;
+sub labelVariable
+;
+sub label
+;
+sub queuePack
+;
+sub sbset
+;
+sub freeze_on_map
+;
+sub AddScrollbars
+;
+sub packscrollbars
+;
+sub scrollbars
+;
+sub FindMenu
+;
+1;
diff --git a/Master/tlpkg/installer/perllib/auto/Tk/PNG/PNG.bs b/Master/tlpkg/installer/perllib/auto/Tk/PNG/PNG.bs
new file mode 100644
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/auto/Tk/PNG/PNG.bs
diff --git a/Master/tlpkg/installer/perllib/auto/Tk/PNG/PNG.dll b/Master/tlpkg/installer/perllib/auto/Tk/PNG/PNG.dll
new file mode 100755
index 00000000000..08bbbed4fcc
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/auto/Tk/PNG/PNG.dll
Binary files differ
diff --git a/Master/tlpkg/installer/perllib/auto/Tk/RepeatId.al b/Master/tlpkg/installer/perllib/auto/Tk/RepeatId.al
new file mode 100644
index 00000000000..e71d2a337a0
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/auto/Tk/RepeatId.al
@@ -0,0 +1,16 @@
+# NOTE: Derived from blib\lib\Tk.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk;
+
+#line 498 "blib\lib\Tk.pm (autosplit into blib\lib\auto\Tk\RepeatId.al)"
+sub RepeatId
+{
+ my ($w,$id) = @_;
+ $w = $w->MainWindow;
+ $w->CancelRepeat;
+ $w->{_afterId_} = $id;
+}
+
+# end of Tk::RepeatId
+1;
diff --git a/Master/tlpkg/installer/perllib/auto/Tk/Tk.bs b/Master/tlpkg/installer/perllib/auto/Tk/Tk.bs
new file mode 100644
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/auto/Tk/Tk.bs
diff --git a/Master/tlpkg/installer/perllib/auto/Tk/Tk.dll b/Master/tlpkg/installer/perllib/auto/Tk/Tk.dll
new file mode 100755
index 00000000000..8d80944808d
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/auto/Tk/Tk.dll
Binary files differ
diff --git a/Master/tlpkg/installer/perllib/auto/Tk/Toplevel/autosplit.ix b/Master/tlpkg/installer/perllib/auto/Tk/Toplevel/autosplit.ix
new file mode 100644
index 00000000000..859b90d9a40
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/auto/Tk/Toplevel/autosplit.ix
@@ -0,0 +1,10 @@
+# Index created by AutoSplit for blib\lib\Tk\Toplevel.pm
+# (file acts as timestamp)
+package Tk::Toplevel;
+sub FG_Create ;
+sub FG_BindIn ;
+sub FG_BindOut ;
+sub FG_Destroy ;
+sub FG_In ;
+sub FG_Out ;
+1;
diff --git a/Master/tlpkg/installer/perllib/auto/Tk/Widget/autosplit.ix b/Master/tlpkg/installer/perllib/auto/Tk/Widget/autosplit.ix
new file mode 100644
index 00000000000..b610773d4dc
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/auto/Tk/Widget/autosplit.ix
@@ -0,0 +1,11 @@
+# Index created by AutoSplit for blib\lib\Tk\Widget.pm
+# (file acts as timestamp)
+package Tk::Widget;
+sub bindDump ;
+sub ASkludge
+;
+sub clipboardKeysyms
+;
+sub pathname
+;
+1;
diff --git a/Master/tlpkg/installer/perllib/auto/Tk/Wm/AnchorAdjust.al b/Master/tlpkg/installer/perllib/auto/Tk/Wm/AnchorAdjust.al
new file mode 100644
index 00000000000..538612878ed
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/auto/Tk/Wm/AnchorAdjust.al
@@ -0,0 +1,17 @@
+# NOTE: Derived from blib\lib\Tk\Wm.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Wm;
+
+#line 87 "blib\lib\Tk\Wm.pm (autosplit into blib\lib\auto\Tk\Wm\AnchorAdjust.al)"
+sub AnchorAdjust
+{
+ my ($anchor,$X,$Y,$w,$h) = @_;
+ $anchor = 'c' unless (defined $anchor);
+ $Y += ($anchor =~ /s/) ? $h : ($anchor =~ /n/) ? 0 : $h/2;
+ $X += ($anchor =~ /e/) ? $w : ($anchor =~ /w/) ? 0 : $w/2;
+ return ($X,$Y);
+}
+
+# end of Tk::Wm::AnchorAdjust
+1;
diff --git a/Master/tlpkg/installer/perllib/auto/Tk/Wm/FullScreen.al b/Master/tlpkg/installer/perllib/auto/Tk/Wm/FullScreen.al
new file mode 100644
index 00000000000..4d5702cc60d
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/auto/Tk/Wm/FullScreen.al
@@ -0,0 +1,29 @@
+# NOTE: Derived from blib\lib\Tk\Wm.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Wm;
+
+#line 138 "blib\lib\Tk\Wm.pm (autosplit into blib\lib\auto\Tk\Wm\FullScreen.al)"
+sub FullScreen
+{
+ my $w = shift;
+ my $over = (@_) ? shift : 0;
+ my $width = $w->screenwidth;
+ my $height = $w->screenheight;
+ $w->GeometryRequest($width,$height);
+ $w->overrideredirect($over & 1);
+ $w->Post(0,0);
+ $w->update;
+ if ($over & 2)
+ {
+ my $x = $w->rootx;
+ my $y = $w->rooty;
+ $width -= 2*$x;
+ $height -= $x + $y;
+ $w->GeometryRequest($width,$height);
+ $w->update;
+ }
+}
+
+# end of Tk::Wm::FullScreen
+1;
diff --git a/Master/tlpkg/installer/perllib/auto/Tk/Wm/Popup.al b/Master/tlpkg/installer/perllib/auto/Tk/Wm/Popup.al
new file mode 100644
index 00000000000..3f460c5bac6
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/auto/Tk/Wm/Popup.al
@@ -0,0 +1,50 @@
+# NOTE: Derived from blib\lib\Tk\Wm.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Wm;
+
+#line 96 "blib\lib\Tk\Wm.pm (autosplit into blib\lib\auto\Tk\Wm\Popup.al)"
+sub Popup
+{
+ my $w = shift;
+ $w->configure(@_) if @_;
+ $w->idletasks;
+ my ($mw,$mh) = ($w->reqwidth,$w->reqheight);
+ my ($rx,$ry,$rw,$rh) = (0,0,0,0);
+ my $base = $w->cget('-popover');
+ my $outside = 0;
+ if (defined $base)
+ {
+ if ($base eq 'cursor')
+ {
+ ($rx,$ry) = $w->pointerxy;
+ }
+ else
+ {
+ $rx = $base->rootx;
+ $ry = $base->rooty;
+ $rw = $base->Width;
+ $rh = $base->Height;
+ }
+ }
+ else
+ {
+ my $sc = ($w->parent) ? $w->parent->toplevel : $w;
+ $rx = -$sc->vrootx;
+ $ry = -$sc->vrooty;
+ $rw = $w->screenwidth;
+ $rh = $w->screenheight;
+ }
+ my ($X,$Y) = AnchorAdjust($w->cget('-overanchor'),$rx,$ry,$rw,$rh);
+ ($X,$Y) = AnchorAdjust($w->cget('-popanchor'),$X,$Y,-$mw,-$mh);
+ # adjust to not cross screen borders
+ if ($X < 0) { $X = 0 }
+ if ($Y < 0) { $Y = 0 }
+ if ($mw > $w->screenwidth) { $X = 0 }
+ if ($mh > $w->screenheight) { $Y = 0 }
+ $w->Post($X,$Y);
+ $w->waitVisibility;
+}
+
+# end of Tk::Wm::Popup
+1;
diff --git a/Master/tlpkg/installer/perllib/auto/Tk/Wm/Post.al b/Master/tlpkg/installer/perllib/auto/Tk/Wm/Post.al
new file mode 100644
index 00000000000..f3f5c8e3e08
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/auto/Tk/Wm/Post.al
@@ -0,0 +1,20 @@
+# NOTE: Derived from blib\lib\Tk\Wm.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Wm;
+
+#line 75 "blib\lib\Tk\Wm.pm (autosplit into blib\lib\auto\Tk\Wm\Post.al)"
+sub Post
+{
+ my ($w,$X,$Y) = @_;
+ $X = int($X);
+ $Y = int($Y);
+ $w->positionfrom('user');
+ $w->geometry("+$X+$Y");
+ # $w->MoveToplevelWindow($X,$Y);
+ $w->deiconify;
+ $w->raise;
+}
+
+# end of Tk::Wm::Post
+1;
diff --git a/Master/tlpkg/installer/perllib/auto/Tk/Wm/autosplit.ix b/Master/tlpkg/installer/perllib/auto/Tk/Wm/autosplit.ix
new file mode 100644
index 00000000000..201dbe8ba99
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/auto/Tk/Wm/autosplit.ix
@@ -0,0 +1,14 @@
+# Index created by AutoSplit for blib\lib\Tk\Wm.pm
+# (file acts as timestamp)
+package Tk::Wm;
+sub Post
+;
+sub AnchorAdjust
+;
+sub Popup
+;
+sub FullScreen
+;
+sub iconposition
+;
+1;
diff --git a/Master/tlpkg/installer/perllib/auto/Tk/Wm/iconposition.al b/Master/tlpkg/installer/perllib/auto/Tk/Wm/iconposition.al
new file mode 100644
index 00000000000..9254968f61c
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/auto/Tk/Wm/iconposition.al
@@ -0,0 +1,24 @@
+# NOTE: Derived from blib\lib\Tk\Wm.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk::Wm;
+
+#line 159 "blib\lib\Tk\Wm.pm (autosplit into blib\lib\auto\Tk\Wm\iconposition.al)"
+sub iconposition
+{
+ my $w = shift;
+ if (@_ == 1)
+ {
+ return $w->wm('iconposition',$1,$2) if $_[0] =~ /^(\d+),(\d+)$/;
+ if ($_[0] =~ /^([+-])(\d+)([+-])(\d+)$/)
+ {
+ my $x = ($1 eq '-') ? $w->screenwidth-$2 : $2;
+ my $y = ($3 eq '-') ? $w->screenheight-$4 : $4;
+ return $w->wm('iconposition',$x,$y);
+ }
+ }
+ $w->wm('iconposition',@_);
+}
+
+1;
+# end of Tk::Wm::iconposition
diff --git a/Master/tlpkg/installer/perllib/auto/Tk/autosplit.ix b/Master/tlpkg/installer/perllib/auto/Tk/autosplit.ix
new file mode 100644
index 00000000000..7bd25b78a9a
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/auto/Tk/autosplit.ix
@@ -0,0 +1,45 @@
+# Index created by AutoSplit for blib\lib\Tk.pm
+# (file acts as timestamp)
+package Tk;
+sub Error
+;
+sub CancelRepeat
+;
+sub RepeatId
+;
+sub FocusChildren ;
+sub focusNext
+;
+sub focusPrev
+;
+sub FocusOK
+;
+sub EnterFocus
+;
+sub tabFocus
+;
+sub focusFollowsMouse
+;
+sub TraverseToMenu
+;
+sub FirstMenu
+;
+sub Selection
+;
+sub Receive
+;
+sub break
+;
+sub updateWidgets
+;
+sub ImageNames
+;
+sub ImageTypes
+;
+sub interps
+;
+sub lsearch
+;
+sub getEncoding
+;
+1;
diff --git a/Master/tlpkg/installer/perllib/auto/Tk/getEncoding.al b/Master/tlpkg/installer/perllib/auto/Tk/getEncoding.al
new file mode 100644
index 00000000000..b9e230edbf1
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/auto/Tk/getEncoding.al
@@ -0,0 +1,43 @@
+# NOTE: Derived from blib\lib\Tk.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk;
+
+#line 785 "blib\lib\Tk.pm (autosplit into blib\lib\auto\Tk\getEncoding.al)"
+sub getEncoding
+{
+ my ($class,$name) = @_;
+ eval { require Encode };
+ if ($@)
+ {
+ require Tk::DummyEncode;
+ return Tk::DummyEncode->getEncoding($name);
+ }
+ $name = $Tk::font_encoding{$name} if exists $Tk::font_encoding{$name};
+ my $enc = Encode::find_encoding($name);
+
+ unless ($enc)
+ {
+ $enc = Encode::find_encoding($name) if ($name =~ s/[-_]\d+$//)
+ }
+# if ($enc)
+# {
+# print STDERR "Lookup '$name' => ".$enc->name."\n";
+# }
+# else
+# {
+# print STDERR "Failed '$name'\n";
+# }
+ unless ($enc)
+ {
+ if ($name eq 'X11ControlChars')
+ {
+ require Tk::DummyEncode;
+ $Encode::encoding{$name} = $enc = Tk::DummyEncode->getEncoding($name);
+ }
+ }
+ return $enc;
+}
+
+1;
+# end of Tk::getEncoding
diff --git a/Master/tlpkg/installer/perllib/auto/Win32/API/API.bs b/Master/tlpkg/installer/perllib/auto/Win32/API/API.bs
new file mode 100644
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/auto/Win32/API/API.bs
diff --git a/Master/tlpkg/installer/perllib/auto/Win32/API/API.dll b/Master/tlpkg/installer/perllib/auto/Win32/API/API.dll
new file mode 100644
index 00000000000..3a7efc0adca
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/auto/Win32/API/API.dll
Binary files differ
diff --git a/Master/tlpkg/installer/perllib/auto/Win32/API/Callback/Callback.bs b/Master/tlpkg/installer/perllib/auto/Win32/API/Callback/Callback.bs
new file mode 100644
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/auto/Win32/API/Callback/Callback.bs
diff --git a/Master/tlpkg/installer/perllib/auto/Win32/API/Callback/Callback.dll b/Master/tlpkg/installer/perllib/auto/Win32/API/Callback/Callback.dll
new file mode 100644
index 00000000000..147c679d576
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/auto/Win32/API/Callback/Callback.dll
Binary files differ
diff --git a/Master/tlpkg/installer/perllib/auto/Win32API/Registry/Registry.bs b/Master/tlpkg/installer/perllib/auto/Win32API/Registry/Registry.bs
new file mode 100644
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/auto/Win32API/Registry/Registry.bs
diff --git a/Master/tlpkg/installer/perllib/auto/Win32API/Registry/Registry.dll b/Master/tlpkg/installer/perllib/auto/Win32API/Registry/Registry.dll
new file mode 100755
index 00000000000..45b7bc0688a
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/auto/Win32API/Registry/Registry.dll
Binary files differ
diff --git a/Master/tlpkg/installer/perllib/base.pm b/Master/tlpkg/installer/perllib/base.pm
new file mode 100644
index 00000000000..001914be4d3
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/base.pm
@@ -0,0 +1,226 @@
+package base;
+
+use strict 'vars';
+use vars qw($VERSION);
+$VERSION = '2.07';
+
+# constant.pm is slow
+sub SUCCESS () { 1 }
+
+sub PUBLIC () { 2**0 }
+sub PRIVATE () { 2**1 }
+sub INHERITED () { 2**2 }
+sub PROTECTED () { 2**3 }
+
+
+my $Fattr = \%fields::attr;
+
+sub has_fields {
+ my($base) = shift;
+ my $fglob = ${"$base\::"}{FIELDS};
+ return( ($fglob && *$fglob{HASH}) ? 1 : 0 );
+}
+
+sub has_version {
+ my($base) = shift;
+ my $vglob = ${$base.'::'}{VERSION};
+ return( ($vglob && *$vglob{SCALAR}) ? 1 : 0 );
+}
+
+sub has_attr {
+ my($proto) = shift;
+ my($class) = ref $proto || $proto;
+ return exists $Fattr->{$class};
+}
+
+sub get_attr {
+ $Fattr->{$_[0]} = [1] unless $Fattr->{$_[0]};
+ return $Fattr->{$_[0]};
+}
+
+if ($] < 5.009) {
+ *get_fields = sub {
+ # Shut up a possible typo warning.
+ () = \%{$_[0].'::FIELDS'};
+ my $f = \%{$_[0].'::FIELDS'};
+
+ # should be centralized in fields? perhaps
+ # fields::mk_FIELDS_be_OK. Peh. As long as %{ $package . '::FIELDS' }
+ # is used here anyway, it doesn't matter.
+ bless $f, 'pseudohash' if (ref($f) ne 'pseudohash');
+
+ return $f;
+ }
+}
+else {
+ *get_fields = sub {
+ # Shut up a possible typo warning.
+ () = \%{$_[0].'::FIELDS'};
+ return \%{$_[0].'::FIELDS'};
+ }
+}
+
+sub import {
+ my $class = shift;
+
+ return SUCCESS unless @_;
+
+ # List of base classes from which we will inherit %FIELDS.
+ my $fields_base;
+
+ my $inheritor = caller(0);
+
+ foreach my $base (@_) {
+ next if $inheritor->isa($base);
+
+ if (has_version($base)) {
+ ${$base.'::VERSION'} = '-1, set by base.pm'
+ unless defined ${$base.'::VERSION'};
+ }
+ else {
+ local $SIG{__DIE__};
+ eval "require $base";
+ # Only ignore "Can't locate" errors from our eval require.
+ # Other fatal errors (syntax etc) must be reported.
+ die if $@ && $@ !~ /^Can't locate .*? at \(eval /;
+ unless (%{"$base\::"}) {
+ require Carp;
+ Carp::croak(<<ERROR);
+Base class package "$base" is empty.
+ (Perhaps you need to 'use' the module which defines that package first.)
+ERROR
+
+ }
+ ${$base.'::VERSION'} = "-1, set by base.pm"
+ unless defined ${$base.'::VERSION'};
+ }
+ push @{"$inheritor\::ISA"}, $base;
+
+ if ( has_fields($base) || has_attr($base) ) {
+ # No multiple fields inheritence *suck*
+ if ($fields_base) {
+ require Carp;
+ Carp::croak("Can't multiply inherit %FIELDS");
+ } else {
+ $fields_base = $base;
+ }
+ }
+ }
+
+ if( defined $fields_base ) {
+ inherit_fields($inheritor, $fields_base);
+ }
+}
+
+
+sub inherit_fields {
+ my($derived, $base) = @_;
+
+ return SUCCESS unless $base;
+
+ my $battr = get_attr($base);
+ my $dattr = get_attr($derived);
+ my $dfields = get_fields($derived);
+ my $bfields = get_fields($base);
+
+ $dattr->[0] = @$battr;
+
+ if( keys %$dfields ) {
+ warn "$derived is inheriting from $base but already has its own ".
+ "fields!\n".
+ "This will cause problems.\n".
+ "Be sure you use base BEFORE declaring fields\n";
+ }
+
+ # Iterate through the base's fields adding all the non-private
+ # ones to the derived class. Hang on to the original attribute
+ # (Public, Private, etc...) and add Inherited.
+ # This is all too complicated to do efficiently with add_fields().
+ while (my($k,$v) = each %$bfields) {
+ my $fno;
+ if ($fno = $dfields->{$k} and $fno != $v) {
+ require Carp;
+ Carp::croak ("Inherited %FIELDS can't override existing %FIELDS");
+ }
+
+ if( $battr->[$v] & PRIVATE ) {
+ $dattr->[$v] = PRIVATE | INHERITED;
+ }
+ else {
+ $dattr->[$v] = INHERITED | $battr->[$v];
+ $dfields->{$k} = $v;
+ }
+ }
+
+ foreach my $idx (1..$#{$battr}) {
+ next if defined $dattr->[$idx];
+ $dattr->[$idx] = $battr->[$idx] & INHERITED;
+ }
+}
+
+
+1;
+
+__END__
+
+=head1 NAME
+
+base - Establish IS-A relationship with base classes at compile time
+
+=head1 SYNOPSIS
+
+ package Baz;
+ use base qw(Foo Bar);
+
+=head1 DESCRIPTION
+
+Allows you to both load one or more modules, while setting up inheritance from
+those modules at the same time. Roughly similar in effect to
+
+ package Baz;
+ BEGIN {
+ require Foo;
+ require Bar;
+ push @ISA, qw(Foo Bar);
+ }
+
+If any of the listed modules are not loaded yet, I<base> silently attempts to
+C<require> them (and silently continues if the C<require> failed). Whether to
+C<require> a base class module is determined by the absence of a global variable
+$VERSION in the base package. If $VERSION is not detected even after loading
+it, <base> will define $VERSION in the base package, setting it to the string
+C<-1, set by base.pm>.
+
+Will also initialize the fields if one of the base classes has it.
+Multiple inheritence of fields is B<NOT> supported, if two or more
+base classes each have inheritable fields the 'base' pragma will
+croak. See L<fields>, L<public> and L<protected> for a description of
+this feature.
+
+=head1 DIAGNOSTICS
+
+=over 4
+
+=item Base class package "%s" is empty.
+
+base.pm was unable to require the base package, because it was not
+found in your path.
+
+=back
+
+=head1 HISTORY
+
+This module was introduced with Perl 5.004_04.
+
+
+=head1 CAVEATS
+
+Due to the limitations of the implementation, you must use
+base I<before> you declare any of your own fields.
+
+
+=head1 SEE ALSO
+
+L<fields>
+
+=cut
diff --git a/Master/tlpkg/installer/perllib/bytes.pm b/Master/tlpkg/installer/perllib/bytes.pm
new file mode 100644
index 00000000000..a8222794ddf
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/bytes.pm
@@ -0,0 +1,88 @@
+package bytes;
+
+our $VERSION = '1.02';
+
+$bytes::hint_bits = 0x00000008;
+
+sub import {
+ $^H |= $bytes::hint_bits;
+}
+
+sub unimport {
+ $^H &= ~$bytes::hint_bits;
+}
+
+sub AUTOLOAD {
+ require "bytes_heavy.pl";
+ goto &$AUTOLOAD if defined &$AUTOLOAD;
+ require Carp;
+ Carp::croak("Undefined subroutine $AUTOLOAD called");
+}
+
+sub length ($);
+sub chr ($);
+sub ord ($);
+sub substr ($$;$$);
+sub index ($$;$);
+sub rindex ($$;$);
+
+1;
+__END__
+
+=head1 NAME
+
+bytes - Perl pragma to force byte semantics rather than character semantics
+
+=head1 SYNOPSIS
+
+ use bytes;
+ ... chr(...); # or bytes::chr
+ ... index(...); # or bytes::index
+ ... length(...); # or bytes::length
+ ... ord(...); # or bytes::ord
+ ... rindex(...); # or bytes::rindex
+ ... substr(...); # or bytes::substr
+ no bytes;
+
+
+=head1 DESCRIPTION
+
+The C<use bytes> pragma disables character semantics for the rest of the
+lexical scope in which it appears. C<no bytes> can be used to reverse
+the effect of C<use bytes> within the current lexical scope.
+
+Perl normally assumes character semantics in the presence of character
+data (i.e. data that has come from a source that has been marked as
+being of a particular character encoding). When C<use bytes> is in
+effect, the encoding is temporarily ignored, and each string is treated
+as a series of bytes.
+
+As an example, when Perl sees C<$x = chr(400)>, it encodes the character
+in UTF-8 and stores it in $x. Then it is marked as character data, so,
+for instance, C<length $x> returns C<1>. However, in the scope of the
+C<bytes> pragma, $x is treated as a series of bytes - the bytes that make
+up the UTF8 encoding - and C<length $x> returns C<2>:
+
+ $x = chr(400);
+ print "Length is ", length $x, "\n"; # "Length is 1"
+ printf "Contents are %vd\n", $x; # "Contents are 400"
+ {
+ use bytes; # or "require bytes; bytes::length()"
+ print "Length is ", length $x, "\n"; # "Length is 2"
+ printf "Contents are %vd\n", $x; # "Contents are 198.144"
+ }
+
+chr(), ord(), substr(), index() and rindex() behave similarly.
+
+For more on the implications and differences between character
+semantics and byte semantics, see L<perluniintro> and L<perlunicode>.
+
+=head1 LIMITATIONS
+
+bytes::substr() does not work as an lvalue().
+
+=head1 SEE ALSO
+
+L<perluniintro>, L<perlunicode>, L<utf8>
+
+=cut
diff --git a/Master/tlpkg/installer/perllib/constant.pm b/Master/tlpkg/installer/perllib/constant.pm
new file mode 100644
index 00000000000..159c29978a5
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/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/installer/perllib/newgetopt.pl b/Master/tlpkg/installer/perllib/newgetopt.pl
new file mode 100644
index 00000000000..95eef220fe7
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/newgetopt.pl
@@ -0,0 +1,75 @@
+# $Id: newgetopt.pl,v 1.18 2001-09-21 15:34:59+02 jv Exp $
+
+# This library is no longer being maintained, and is included for backward
+# compatibility with Perl 4 programs which may require it.
+# It is now just a wrapper around the Getopt::Long module.
+#
+# In particular, this should not be used as an example of modern Perl
+# programming techniques.
+#
+# Suggested alternative: Getopt::Long
+
+{ package newgetopt;
+
+ # Values for $order. See GNU getopt.c for details.
+ $REQUIRE_ORDER = 0;
+ $PERMUTE = 1;
+ $RETURN_IN_ORDER = 2;
+
+ # Handle POSIX compliancy.
+ if ( defined $ENV{"POSIXLY_CORRECT"} ) {
+ $autoabbrev = 0; # no automatic abbrev of options (???)
+ $getopt_compat = 0; # disallow '+' to start options
+ $option_start = "(--|-)";
+ $order = $REQUIRE_ORDER;
+ $bundling = 0;
+ $passthrough = 0;
+ }
+ else {
+ $autoabbrev = 1; # automatic abbrev of options
+ $getopt_compat = 1; # allow '+' to start options
+ $option_start = "(--|-|\\+)";
+ $order = $PERMUTE;
+ $bundling = 0;
+ $passthrough = 0;
+ }
+
+ # Other configurable settings.
+ $debug = 0; # for debugging
+ $ignorecase = 1; # ignore case when matching options
+ $argv_end = "--"; # don't change this!
+}
+
+use Getopt::Long;
+
+################ Subroutines ################
+
+sub NGetOpt {
+
+ $Getopt::Long::debug = $newgetopt::debug
+ if defined $newgetopt::debug;
+ $Getopt::Long::autoabbrev = $newgetopt::autoabbrev
+ if defined $newgetopt::autoabbrev;
+ $Getopt::Long::getopt_compat = $newgetopt::getopt_compat
+ if defined $newgetopt::getopt_compat;
+ $Getopt::Long::option_start = $newgetopt::option_start
+ if defined $newgetopt::option_start;
+ $Getopt::Long::order = $newgetopt::order
+ if defined $newgetopt::order;
+ $Getopt::Long::bundling = $newgetopt::bundling
+ if defined $newgetopt::bundling;
+ $Getopt::Long::ignorecase = $newgetopt::ignorecase
+ if defined $newgetopt::ignorecase;
+ $Getopt::Long::ignorecase = $newgetopt::ignorecase
+ if defined $newgetopt::ignorecase;
+ $Getopt::Long::passthrough = $newgetopt::passthrough
+ if defined $newgetopt::passthrough;
+
+ &GetOptions;
+}
+
+################ Package return ################
+
+1;
+
+################ End of newgetopt.pl ################
diff --git a/Master/tlpkg/installer/perllib/overload.pm b/Master/tlpkg/installer/perllib/overload.pm
new file mode 100644
index 00000000000..15b7e775e74
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/overload.pm
@@ -0,0 +1,1434 @@
+package overload;
+
+our $VERSION = '1.04';
+
+$overload::hint_bits = 0x20000; # HINT_LOCALIZE_HH
+
+sub nil {}
+
+sub OVERLOAD {
+ $package = shift;
+ my %arg = @_;
+ my ($sub, $fb);
+ $ {$package . "::OVERLOAD"}{dummy}++; # Register with magic by touching.
+ *{$package . "::()"} = \&nil; # Make it findable via fetchmethod.
+ for (keys %arg) {
+ if ($_ eq 'fallback') {
+ $fb = $arg{$_};
+ } else {
+ $sub = $arg{$_};
+ if (not ref $sub and $sub !~ /::/) {
+ $ {$package . "::(" . $_} = $sub;
+ $sub = \&nil;
+ }
+ #print STDERR "Setting `$ {'package'}::\cO$_' to \\&`$sub'.\n";
+ *{$package . "::(" . $_} = \&{ $sub };
+ }
+ }
+ ${$package . "::()"} = $fb; # Make it findable too (fallback only).
+}
+
+sub import {
+ $package = (caller())[0];
+ # *{$package . "::OVERLOAD"} = \&OVERLOAD;
+ shift;
+ $package->overload::OVERLOAD(@_);
+}
+
+sub unimport {
+ $package = (caller())[0];
+ ${$package . "::OVERLOAD"}{dummy}++; # Upgrade the table
+ shift;
+ for (@_) {
+ if ($_ eq 'fallback') {
+ undef $ {$package . "::()"};
+ } else {
+ delete $ {$package . "::"}{"(" . $_};
+ }
+ }
+}
+
+sub Overloaded {
+ my $package = shift;
+ $package = ref $package if ref $package;
+ $package->can('()');
+}
+
+sub ov_method {
+ my $globref = shift;
+ return undef unless $globref;
+ my $sub = \&{*$globref};
+ return $sub if $sub ne \&nil;
+ return shift->can($ {*$globref});
+}
+
+sub OverloadedStringify {
+ my $package = shift;
+ $package = ref $package if ref $package;
+ #$package->can('(""')
+ ov_method mycan($package, '(""'), $package
+ or ov_method mycan($package, '(0+'), $package
+ or ov_method mycan($package, '(bool'), $package
+ or ov_method mycan($package, '(nomethod'), $package;
+}
+
+sub Method {
+ my $package = shift;
+ $package = ref $package if ref $package;
+ #my $meth = $package->can('(' . shift);
+ ov_method mycan($package, '(' . shift), $package;
+ #return $meth if $meth ne \&nil;
+ #return $ {*{$meth}};
+}
+
+sub AddrRef {
+ my $package = ref $_[0];
+ return "$_[0]" unless $package;
+
+ require Scalar::Util;
+ my $class = Scalar::Util::blessed($_[0]);
+ my $class_prefix = defined($class) ? "$class=" : "";
+ my $type = Scalar::Util::reftype($_[0]);
+ my $addr = Scalar::Util::refaddr($_[0]);
+ return sprintf("$class_prefix$type(0x%x)", $addr);
+}
+
+*StrVal = *AddrRef;
+
+sub mycan { # Real can would leave stubs.
+ my ($package, $meth) = @_;
+ return \*{$package . "::$meth"} if defined &{$package . "::$meth"};
+ my $p;
+ foreach $p (@{$package . "::ISA"}) {
+ my $out = mycan($p, $meth);
+ return $out if $out;
+ }
+ return undef;
+}
+
+%constants = (
+ 'integer' => 0x1000, # HINT_NEW_INTEGER
+ 'float' => 0x2000, # HINT_NEW_FLOAT
+ 'binary' => 0x4000, # HINT_NEW_BINARY
+ 'q' => 0x8000, # HINT_NEW_STRING
+ 'qr' => 0x10000, # HINT_NEW_RE
+ );
+
+%ops = ( with_assign => "+ - * / % ** << >> x .",
+ assign => "+= -= *= /= %= **= <<= >>= x= .=",
+ num_comparison => "< <= > >= == !=",
+ '3way_comparison'=> "<=> cmp",
+ str_comparison => "lt le gt ge eq ne",
+ binary => "& | ^",
+ unary => "neg ! ~",
+ mutators => '++ --',
+ func => "atan2 cos sin exp abs log sqrt int",
+ conversion => 'bool "" 0+',
+ iterators => '<>',
+ dereferencing => '${} @{} %{} &{} *{}',
+ special => 'nomethod fallback =');
+
+use warnings::register;
+sub constant {
+ # Arguments: what, sub
+ while (@_) {
+ if (@_ == 1) {
+ warnings::warnif ("Odd number of arguments for overload::constant");
+ last;
+ }
+ elsif (!exists $constants {$_ [0]}) {
+ warnings::warnif ("`$_[0]' is not an overloadable type");
+ }
+ elsif (!ref $_ [1] || "$_[1]" !~ /CODE\(0x[\da-f]+\)$/) {
+ # Can't use C<ref $_[1] eq "CODE"> above as code references can be
+ # blessed, and C<ref> would return the package the ref is blessed into.
+ if (warnings::enabled) {
+ $_ [1] = "undef" unless defined $_ [1];
+ warnings::warn ("`$_[1]' is not a code reference");
+ }
+ }
+ else {
+ $^H{$_[0]} = $_[1];
+ $^H |= $constants{$_[0]} | $overload::hint_bits;
+ }
+ shift, shift;
+ }
+}
+
+sub remove_constant {
+ # Arguments: what, sub
+ while (@_) {
+ delete $^H{$_[0]};
+ $^H &= ~ $constants{$_[0]};
+ shift, shift;
+ }
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+overload - Package for overloading Perl operations
+
+=head1 SYNOPSIS
+
+ package SomeThing;
+
+ use overload
+ '+' => \&myadd,
+ '-' => \&mysub;
+ # etc
+ ...
+
+ package main;
+ $a = new SomeThing 57;
+ $b=5+$a;
+ ...
+ if (overload::Overloaded $b) {...}
+ ...
+ $strval = overload::StrVal $b;
+
+=head1 DESCRIPTION
+
+=head2 Declaration of overloaded functions
+
+The compilation directive
+
+ package Number;
+ use overload
+ "+" => \&add,
+ "*=" => "muas";
+
+declares function Number::add() for addition, and method muas() in
+the "class" C<Number> (or one of its base classes)
+for the assignment form C<*=> of multiplication.
+
+Arguments of this directive come in (key, value) pairs. Legal values
+are values legal inside a C<&{ ... }> call, so the name of a
+subroutine, a reference to a subroutine, or an anonymous subroutine
+will all work. Note that values specified as strings are
+interpreted as methods, not subroutines. Legal keys are listed below.
+
+The subroutine C<add> will be called to execute C<$a+$b> if $a
+is a reference to an object blessed into the package C<Number>, or if $a is
+not an object from a package with defined mathemagic addition, but $b is a
+reference to a C<Number>. It can also be called in other situations, like
+C<$a+=7>, or C<$a++>. See L<MAGIC AUTOGENERATION>. (Mathemagical
+methods refer to methods triggered by an overloaded mathematical
+operator.)
+
+Since overloading respects inheritance via the @ISA hierarchy, the
+above declaration would also trigger overloading of C<+> and C<*=> in
+all the packages which inherit from C<Number>.
+
+=head2 Calling Conventions for Binary Operations
+
+The functions specified in the C<use overload ...> directive are called
+with three (in one particular case with four, see L<Last Resort>)
+arguments. If the corresponding operation is binary, then the first
+two arguments are the two arguments of the operation. However, due to
+general object calling conventions, the first argument should always be
+an object in the package, so in the situation of C<7+$a>, the
+order of the arguments is interchanged. It probably does not matter
+when implementing the addition method, but whether the arguments
+are reversed is vital to the subtraction method. The method can
+query this information by examining the third argument, which can take
+three different values:
+
+=over 7
+
+=item FALSE
+
+the order of arguments is as in the current operation.
+
+=item TRUE
+
+the arguments are reversed.
+
+=item C<undef>
+
+the current operation is an assignment variant (as in
+C<$a+=7>), but the usual function is called instead. This additional
+information can be used to generate some optimizations. Compare
+L<Calling Conventions for Mutators>.
+
+=back
+
+=head2 Calling Conventions for Unary Operations
+
+Unary operation are considered binary operations with the second
+argument being C<undef>. Thus the functions that overloads C<{"++"}>
+is called with arguments C<($a,undef,'')> when $a++ is executed.
+
+=head2 Calling Conventions for Mutators
+
+Two types of mutators have different calling conventions:
+
+=over
+
+=item C<++> and C<-->
+
+The routines which implement these operators are expected to actually
+I<mutate> their arguments. So, assuming that $obj is a reference to a
+number,
+
+ sub incr { my $n = $ {$_[0]}; ++$n; $_[0] = bless \$n}
+
+is an appropriate implementation of overloaded C<++>. Note that
+
+ sub incr { ++$ {$_[0]} ; shift }
+
+is OK if used with preincrement and with postincrement. (In the case
+of postincrement a copying will be performed, see L<Copy Constructor>.)
+
+=item C<x=> and other assignment versions
+
+There is nothing special about these methods. They may change the
+value of their arguments, and may leave it as is. The result is going
+to be assigned to the value in the left-hand-side if different from
+this value.
+
+This allows for the same method to be used as overloaded C<+=> and
+C<+>. Note that this is I<allowed>, but not recommended, since by the
+semantic of L<"Fallback"> Perl will call the method for C<+> anyway,
+if C<+=> is not overloaded.
+
+=back
+
+B<Warning.> Due to the presence of assignment versions of operations,
+routines which may be called in assignment context may create
+self-referential structures. Currently Perl will not free self-referential
+structures until cycles are C<explicitly> broken. You may get problems
+when traversing your structures too.
+
+Say,
+
+ use overload '+' => sub { bless [ \$_[0], \$_[1] ] };
+
+is asking for trouble, since for code C<$obj += $foo> the subroutine
+is called as C<$obj = add($obj, $foo, undef)>, or C<$obj = [\$obj,
+\$foo]>. If using such a subroutine is an important optimization, one
+can overload C<+=> explicitly by a non-"optimized" version, or switch
+to non-optimized version if C<not defined $_[2]> (see
+L<Calling Conventions for Binary Operations>).
+
+Even if no I<explicit> assignment-variants of operators are present in
+the script, they may be generated by the optimizer. Say, C<",$obj,"> or
+C<',' . $obj . ','> may be both optimized to
+
+ my $tmp = ',' . $obj; $tmp .= ',';
+
+=head2 Overloadable Operations
+
+The following symbols can be specified in C<use overload> directive:
+
+=over 5
+
+=item * I<Arithmetic operations>
+
+ "+", "+=", "-", "-=", "*", "*=", "/", "/=", "%", "%=",
+ "**", "**=", "<<", "<<=", ">>", ">>=", "x", "x=", ".", ".=",
+
+For these operations a substituted non-assignment variant can be called if
+the assignment variant is not available. Methods for operations C<+>,
+C<->, C<+=>, and C<-=> can be called to automatically generate
+increment and decrement methods. The operation C<-> can be used to
+autogenerate missing methods for unary minus or C<abs>.
+
+See L<"MAGIC AUTOGENERATION">, L<"Calling Conventions for Mutators"> and
+L<"Calling Conventions for Binary Operations">) for details of these
+substitutions.
+
+=item * I<Comparison operations>
+
+ "<", "<=", ">", ">=", "==", "!=", "<=>",
+ "lt", "le", "gt", "ge", "eq", "ne", "cmp",
+
+If the corresponding "spaceship" variant is available, it can be
+used to substitute for the missing operation. During C<sort>ing
+arrays, C<cmp> is used to compare values subject to C<use overload>.
+
+=item * I<Bit operations>
+
+ "&", "^", "|", "neg", "!", "~",
+
+C<neg> stands for unary minus. If the method for C<neg> is not
+specified, it can be autogenerated using the method for
+subtraction. If the method for C<!> is not specified, it can be
+autogenerated using the methods for C<bool>, or C<"">, or C<0+>.
+
+=item * I<Increment and decrement>
+
+ "++", "--",
+
+If undefined, addition and subtraction methods can be
+used instead. These operations are called both in prefix and
+postfix form.
+
+=item * I<Transcendental functions>
+
+ "atan2", "cos", "sin", "exp", "abs", "log", "sqrt", "int"
+
+If C<abs> is unavailable, it can be autogenerated using methods
+for "E<lt>" or "E<lt>=E<gt>" combined with either unary minus or subtraction.
+
+Note that traditionally the Perl function L<int> rounds to 0, thus for
+floating-point-like types one should follow the same semantic. If
+C<int> is unavailable, it can be autogenerated using the overloading of
+C<0+>.
+
+=item * I<Boolean, string and numeric conversion>
+
+ 'bool', '""', '0+',
+
+If one or two of these operations are not overloaded, the remaining ones can
+be used instead. C<bool> is used in the flow control operators
+(like C<while>) and for the ternary C<?:> operation. These functions can
+return any arbitrary Perl value. If the corresponding operation for this value
+is overloaded too, that operation will be called again with this value.
+
+As a special case if the overload returns the object itself then it will
+be used directly. An overloaded conversion returning the object is
+probably a bug, because you're likely to get something that looks like
+C<YourPackage=HASH(0x8172b34)>.
+
+=item * I<Iteration>
+
+ "<>"
+
+If not overloaded, the argument will be converted to a filehandle or
+glob (which may require a stringification). The same overloading
+happens both for the I<read-filehandle> syntax C<E<lt>$varE<gt>> and
+I<globbing> syntax C<E<lt>${var}E<gt>>.
+
+B<BUGS> Even in list context, the iterator is currently called only
+once and with scalar context.
+
+=item * I<Dereferencing>
+
+ '${}', '@{}', '%{}', '&{}', '*{}'.
+
+If not overloaded, the argument will be dereferenced I<as is>, thus
+should be of correct type. These functions should return a reference
+of correct type, or another object with overloaded dereferencing.
+
+As a special case if the overload returns the object itself then it
+will be used directly (provided it is the correct type).
+
+The dereference operators must be specified explicitly they will not be passed to
+"nomethod".
+
+=item * I<Special>
+
+ "nomethod", "fallback", "=",
+
+see L<SPECIAL SYMBOLS FOR C<use overload>>.
+
+=back
+
+See L<"Fallback"> for an explanation of when a missing method can be
+autogenerated.
+
+A computer-readable form of the above table is available in the hash
+%overload::ops, with values being space-separated lists of names:
+
+ with_assign => '+ - * / % ** << >> x .',
+ assign => '+= -= *= /= %= **= <<= >>= x= .=',
+ num_comparison => '< <= > >= == !=',
+ '3way_comparison'=> '<=> cmp',
+ str_comparison => 'lt le gt ge eq ne',
+ binary => '& | ^',
+ unary => 'neg ! ~',
+ mutators => '++ --',
+ func => 'atan2 cos sin exp abs log sqrt',
+ conversion => 'bool "" 0+',
+ iterators => '<>',
+ dereferencing => '${} @{} %{} &{} *{}',
+ special => 'nomethod fallback ='
+
+=head2 Inheritance and overloading
+
+Inheritance interacts with overloading in two ways.
+
+=over
+
+=item Strings as values of C<use overload> directive
+
+If C<value> in
+
+ use overload key => value;
+
+is a string, it is interpreted as a method name.
+
+=item Overloading of an operation is inherited by derived classes
+
+Any class derived from an overloaded class is also overloaded. The
+set of overloaded methods is the union of overloaded methods of all
+the ancestors. If some method is overloaded in several ancestor, then
+which description will be used is decided by the usual inheritance
+rules:
+
+If C<A> inherits from C<B> and C<C> (in this order), C<B> overloads
+C<+> with C<\&D::plus_sub>, and C<C> overloads C<+> by C<"plus_meth">,
+then the subroutine C<D::plus_sub> will be called to implement
+operation C<+> for an object in package C<A>.
+
+=back
+
+Note that since the value of the C<fallback> key is not a subroutine,
+its inheritance is not governed by the above rules. In the current
+implementation, the value of C<fallback> in the first overloaded
+ancestor is used, but this is accidental and subject to change.
+
+=head1 SPECIAL SYMBOLS FOR C<use overload>
+
+Three keys are recognized by Perl that are not covered by the above
+description.
+
+=head2 Last Resort
+
+C<"nomethod"> should be followed by a reference to a function of four
+parameters. If defined, it is called when the overloading mechanism
+cannot find a method for some operation. The first three arguments of
+this function coincide with the arguments for the corresponding method if
+it were found, the fourth argument is the symbol
+corresponding to the missing method. If several methods are tried,
+the last one is used. Say, C<1-$a> can be equivalent to
+
+ &nomethodMethod($a,1,1,"-")
+
+if the pair C<"nomethod" =E<gt> "nomethodMethod"> was specified in the
+C<use overload> directive.
+
+The C<"nomethod"> mechanism is I<not> used for the dereference operators
+( ${} @{} %{} &{} *{} ).
+
+
+If some operation cannot be resolved, and there is no function
+assigned to C<"nomethod">, then an exception will be raised via die()--
+unless C<"fallback"> was specified as a key in C<use overload> directive.
+
+
+=head2 Fallback
+
+The key C<"fallback"> governs what to do if a method for a particular
+operation is not found. Three different cases are possible depending on
+the value of C<"fallback">:
+
+=over 16
+
+=item * C<undef>
+
+Perl tries to use a
+substituted method (see L<MAGIC AUTOGENERATION>). If this fails, it
+then tries to calls C<"nomethod"> value; if missing, an exception
+will be raised.
+
+=item * TRUE
+
+The same as for the C<undef> value, but no exception is raised. Instead,
+it silently reverts to what it would have done were there no C<use overload>
+present.
+
+=item * defined, but FALSE
+
+No autogeneration is tried. Perl tries to call
+C<"nomethod"> value, and if this is missing, raises an exception.
+
+=back
+
+B<Note.> C<"fallback"> inheritance via @ISA is not carved in stone
+yet, see L<"Inheritance and overloading">.
+
+=head2 Copy Constructor
+
+The value for C<"="> is a reference to a function with three
+arguments, i.e., it looks like the other values in C<use
+overload>. However, it does not overload the Perl assignment
+operator. This would go against Camel hair.
+
+This operation is called in the situations when a mutator is applied
+to a reference that shares its object with some other reference, such
+as
+
+ $a=$b;
+ ++$a;
+
+To make this change $a and not change $b, a copy of C<$$a> is made,
+and $a is assigned a reference to this new object. This operation is
+done during execution of the C<++$a>, and not during the assignment,
+(so before the increment C<$$a> coincides with C<$$b>). This is only
+done if C<++> is expressed via a method for C<'++'> or C<'+='> (or
+C<nomethod>). Note that if this operation is expressed via C<'+'>
+a nonmutator, i.e., as in
+
+ $a=$b;
+ $a=$a+1;
+
+then C<$a> does not reference a new copy of C<$$a>, since $$a does not
+appear as lvalue when the above code is executed.
+
+If the copy constructor is required during the execution of some mutator,
+but a method for C<'='> was not specified, it can be autogenerated as a
+string copy if the object is a plain scalar.
+
+=over 5
+
+=item B<Example>
+
+The actually executed code for
+
+ $a=$b;
+ Something else which does not modify $a or $b....
+ ++$a;
+
+may be
+
+ $a=$b;
+ Something else which does not modify $a or $b....
+ $a = $a->clone(undef,"");
+ $a->incr(undef,"");
+
+if $b was mathemagical, and C<'++'> was overloaded with C<\&incr>,
+C<'='> was overloaded with C<\&clone>.
+
+=back
+
+Same behaviour is triggered by C<$b = $a++>, which is consider a synonym for
+C<$b = $a; ++$a>.
+
+=head1 MAGIC AUTOGENERATION
+
+If a method for an operation is not found, and the value for C<"fallback"> is
+TRUE or undefined, Perl tries to autogenerate a substitute method for
+the missing operation based on the defined operations. Autogenerated method
+substitutions are possible for the following operations:
+
+=over 16
+
+=item I<Assignment forms of arithmetic operations>
+
+C<$a+=$b> can use the method for C<"+"> if the method for C<"+=">
+is not defined.
+
+=item I<Conversion operations>
+
+String, numeric, and boolean conversion are calculated in terms of one
+another if not all of them are defined.
+
+=item I<Increment and decrement>
+
+The C<++$a> operation can be expressed in terms of C<$a+=1> or C<$a+1>,
+and C<$a--> in terms of C<$a-=1> and C<$a-1>.
+
+=item C<abs($a)>
+
+can be expressed in terms of C<$aE<lt>0> and C<-$a> (or C<0-$a>).
+
+=item I<Unary minus>
+
+can be expressed in terms of subtraction.
+
+=item I<Negation>
+
+C<!> and C<not> can be expressed in terms of boolean conversion, or
+string or numerical conversion.
+
+=item I<Concatenation>
+
+can be expressed in terms of string conversion.
+
+=item I<Comparison operations>
+
+can be expressed in terms of its "spaceship" counterpart: either
+C<E<lt>=E<gt>> or C<cmp>:
+
+ <, >, <=, >=, ==, != in terms of <=>
+ lt, gt, le, ge, eq, ne in terms of cmp
+
+=item I<Iterator>
+
+ <> in terms of builtin operations
+
+=item I<Dereferencing>
+
+ ${} @{} %{} &{} *{} in terms of builtin operations
+
+=item I<Copy operator>
+
+can be expressed in terms of an assignment to the dereferenced value, if this
+value is a scalar and not a reference.
+
+=back
+
+=head1 Losing overloading
+
+The restriction for the comparison operation is that even if, for example,
+`C<cmp>' should return a blessed reference, the autogenerated `C<lt>'
+function will produce only a standard logical value based on the
+numerical value of the result of `C<cmp>'. In particular, a working
+numeric conversion is needed in this case (possibly expressed in terms of
+other conversions).
+
+Similarly, C<.=> and C<x=> operators lose their mathemagical properties
+if the string conversion substitution is applied.
+
+When you chop() a mathemagical object it is promoted to a string and its
+mathemagical properties are lost. The same can happen with other
+operations as well.
+
+=head1 Run-time Overloading
+
+Since all C<use> directives are executed at compile-time, the only way to
+change overloading during run-time is to
+
+ eval 'use overload "+" => \&addmethod';
+
+You can also use
+
+ eval 'no overload "+", "--", "<="';
+
+though the use of these constructs during run-time is questionable.
+
+=head1 Public functions
+
+Package C<overload.pm> provides the following public functions:
+
+=over 5
+
+=item overload::StrVal(arg)
+
+Gives string value of C<arg> as in absence of stringify overloading. If you
+are using this to get the address of a reference (useful for checking if two
+references point to the same thing) then you may be better off using
+C<Scalar::Util::refaddr()>, which is faster.
+
+=item overload::Overloaded(arg)
+
+Returns true if C<arg> is subject to overloading of some operations.
+
+=item overload::Method(obj,op)
+
+Returns C<undef> or a reference to the method that implements C<op>.
+
+=back
+
+=head1 Overloading constants
+
+For some applications, the Perl parser mangles constants too much.
+It is possible to hook into this process via C<overload::constant()>
+and C<overload::remove_constant()> functions.
+
+These functions take a hash as an argument. The recognized keys of this hash
+are:
+
+=over 8
+
+=item integer
+
+to overload integer constants,
+
+=item float
+
+to overload floating point constants,
+
+=item binary
+
+to overload octal and hexadecimal constants,
+
+=item q
+
+to overload C<q>-quoted strings, constant pieces of C<qq>- and C<qx>-quoted
+strings and here-documents,
+
+=item qr
+
+to overload constant pieces of regular expressions.
+
+=back
+
+The corresponding values are references to functions which take three arguments:
+the first one is the I<initial> string form of the constant, the second one
+is how Perl interprets this constant, the third one is how the constant is used.
+Note that the initial string form does not
+contain string delimiters, and has backslashes in backslash-delimiter
+combinations stripped (thus the value of delimiter is not relevant for
+processing of this string). The return value of this function is how this
+constant is going to be interpreted by Perl. The third argument is undefined
+unless for overloaded C<q>- and C<qr>- constants, it is C<q> in single-quote
+context (comes from strings, regular expressions, and single-quote HERE
+documents), it is C<tr> for arguments of C<tr>/C<y> operators,
+it is C<s> for right-hand side of C<s>-operator, and it is C<qq> otherwise.
+
+Since an expression C<"ab$cd,,"> is just a shortcut for C<'ab' . $cd . ',,'>,
+it is expected that overloaded constant strings are equipped with reasonable
+overloaded catenation operator, otherwise absurd results will result.
+Similarly, negative numbers are considered as negations of positive constants.
+
+Note that it is probably meaningless to call the functions overload::constant()
+and overload::remove_constant() from anywhere but import() and unimport() methods.
+From these methods they may be called as
+
+ sub import {
+ shift;
+ return unless @_;
+ die "unknown import: @_" unless @_ == 1 and $_[0] eq ':constant';
+ overload::constant integer => sub {Math::BigInt->new(shift)};
+ }
+
+B<BUGS> Currently overloaded-ness of constants does not propagate
+into C<eval '...'>.
+
+=head1 IMPLEMENTATION
+
+What follows is subject to change RSN.
+
+The table of methods for all operations is cached in magic for the
+symbol table hash for the package. The cache is invalidated during
+processing of C<use overload>, C<no overload>, new function
+definitions, and changes in @ISA. However, this invalidation remains
+unprocessed until the next C<bless>ing into the package. Hence if you
+want to change overloading structure dynamically, you'll need an
+additional (fake) C<bless>ing to update the table.
+
+(Every SVish thing has a magic queue, and magic is an entry in that
+queue. This is how a single variable may participate in multiple
+forms of magic simultaneously. For instance, environment variables
+regularly have two forms at once: their %ENV magic and their taint
+magic. However, the magic which implements overloading is applied to
+the stashes, which are rarely used directly, thus should not slow down
+Perl.)
+
+If an object belongs to a package using overload, it carries a special
+flag. Thus the only speed penalty during arithmetic operations without
+overloading is the checking of this flag.
+
+In fact, if C<use overload> is not present, there is almost no overhead
+for overloadable operations, so most programs should not suffer
+measurable performance penalties. A considerable effort was made to
+minimize the overhead when overload is used in some package, but the
+arguments in question do not belong to packages using overload. When
+in doubt, test your speed with C<use overload> and without it. So far
+there have been no reports of substantial speed degradation if Perl is
+compiled with optimization turned on.
+
+There is no size penalty for data if overload is not used. The only
+size penalty if overload is used in some package is that I<all> the
+packages acquire a magic during the next C<bless>ing into the
+package. This magic is three-words-long for packages without
+overloading, and carries the cache table if the package is overloaded.
+
+Copying (C<$a=$b>) is shallow; however, a one-level-deep copying is
+carried out before any operation that can imply an assignment to the
+object $a (or $b) refers to, like C<$a++>. You can override this
+behavior by defining your own copy constructor (see L<"Copy Constructor">).
+
+It is expected that arguments to methods that are not explicitly supposed
+to be changed are constant (but this is not enforced).
+
+=head1 Metaphor clash
+
+One may wonder why the semantic of overloaded C<=> is so counter intuitive.
+If it I<looks> counter intuitive to you, you are subject to a metaphor
+clash.
+
+Here is a Perl object metaphor:
+
+I< object is a reference to blessed data>
+
+and an arithmetic metaphor:
+
+I< object is a thing by itself>.
+
+The I<main> problem of overloading C<=> is the fact that these metaphors
+imply different actions on the assignment C<$a = $b> if $a and $b are
+objects. Perl-think implies that $a becomes a reference to whatever
+$b was referencing. Arithmetic-think implies that the value of "object"
+$a is changed to become the value of the object $b, preserving the fact
+that $a and $b are separate entities.
+
+The difference is not relevant in the absence of mutators. After
+a Perl-way assignment an operation which mutates the data referenced by $a
+would change the data referenced by $b too. Effectively, after
+C<$a = $b> values of $a and $b become I<indistinguishable>.
+
+On the other hand, anyone who has used algebraic notation knows the
+expressive power of the arithmetic metaphor. Overloading works hard
+to enable this metaphor while preserving the Perlian way as far as
+possible. Since it is not possible to freely mix two contradicting
+metaphors, overloading allows the arithmetic way to write things I<as
+far as all the mutators are called via overloaded access only>. The
+way it is done is described in L<Copy Constructor>.
+
+If some mutator methods are directly applied to the overloaded values,
+one may need to I<explicitly unlink> other values which references the
+same value:
+
+ $a = new Data 23;
+ ...
+ $b = $a; # $b is "linked" to $a
+ ...
+ $a = $a->clone; # Unlink $b from $a
+ $a->increment_by(4);
+
+Note that overloaded access makes this transparent:
+
+ $a = new Data 23;
+ $b = $a; # $b is "linked" to $a
+ $a += 4; # would unlink $b automagically
+
+However, it would not make
+
+ $a = new Data 23;
+ $a = 4; # Now $a is a plain 4, not 'Data'
+
+preserve "objectness" of $a. But Perl I<has> a way to make assignments
+to an object do whatever you want. It is just not the overload, but
+tie()ing interface (see L<perlfunc/tie>). Adding a FETCH() method
+which returns the object itself, and STORE() method which changes the
+value of the object, one can reproduce the arithmetic metaphor in its
+completeness, at least for variables which were tie()d from the start.
+
+(Note that a workaround for a bug may be needed, see L<"BUGS">.)
+
+=head1 Cookbook
+
+Please add examples to what follows!
+
+=head2 Two-face scalars
+
+Put this in F<two_face.pm> in your Perl library directory:
+
+ package two_face; # Scalars with separate string and
+ # numeric values.
+ sub new { my $p = shift; bless [@_], $p }
+ use overload '""' => \&str, '0+' => \&num, fallback => 1;
+ sub num {shift->[1]}
+ sub str {shift->[0]}
+
+Use it as follows:
+
+ require two_face;
+ my $seven = new two_face ("vii", 7);
+ printf "seven=$seven, seven=%d, eight=%d\n", $seven, $seven+1;
+ print "seven contains `i'\n" if $seven =~ /i/;
+
+(The second line creates a scalar which has both a string value, and a
+numeric value.) This prints:
+
+ seven=vii, seven=7, eight=8
+ seven contains `i'
+
+=head2 Two-face references
+
+Suppose you want to create an object which is accessible as both an
+array reference and a hash reference, similar to the
+L<pseudo-hash|perlref/"Pseudo-hashes: Using an array as a hash">
+builtin Perl type. Let's make it better than a pseudo-hash by
+allowing index 0 to be treated as a normal element.
+
+ package two_refs;
+ use overload '%{}' => \&gethash, '@{}' => sub { $ {shift()} };
+ sub new {
+ my $p = shift;
+ bless \ [@_], $p;
+ }
+ sub gethash {
+ my %h;
+ my $self = shift;
+ tie %h, ref $self, $self;
+ \%h;
+ }
+
+ sub TIEHASH { my $p = shift; bless \ shift, $p }
+ my %fields;
+ my $i = 0;
+ $fields{$_} = $i++ foreach qw{zero one two three};
+ sub STORE {
+ my $self = ${shift()};
+ my $key = $fields{shift()};
+ defined $key or die "Out of band access";
+ $$self->[$key] = shift;
+ }
+ sub FETCH {
+ my $self = ${shift()};
+ my $key = $fields{shift()};
+ defined $key or die "Out of band access";
+ $$self->[$key];
+ }
+
+Now one can access an object using both the array and hash syntax:
+
+ my $bar = new two_refs 3,4,5,6;
+ $bar->[2] = 11;
+ $bar->{two} == 11 or die 'bad hash fetch';
+
+Note several important features of this example. First of all, the
+I<actual> type of $bar is a scalar reference, and we do not overload
+the scalar dereference. Thus we can get the I<actual> non-overloaded
+contents of $bar by just using C<$$bar> (what we do in functions which
+overload dereference). Similarly, the object returned by the
+TIEHASH() method is a scalar reference.
+
+Second, we create a new tied hash each time the hash syntax is used.
+This allows us not to worry about a possibility of a reference loop,
+which would lead to a memory leak.
+
+Both these problems can be cured. Say, if we want to overload hash
+dereference on a reference to an object which is I<implemented> as a
+hash itself, the only problem one has to circumvent is how to access
+this I<actual> hash (as opposed to the I<virtual> hash exhibited by the
+overloaded dereference operator). Here is one possible fetching routine:
+
+ sub access_hash {
+ my ($self, $key) = (shift, shift);
+ my $class = ref $self;
+ bless $self, 'overload::dummy'; # Disable overloading of %{}
+ my $out = $self->{$key};
+ bless $self, $class; # Restore overloading
+ $out;
+ }
+
+To remove creation of the tied hash on each access, one may an extra
+level of indirection which allows a non-circular structure of references:
+
+ package two_refs1;
+ use overload '%{}' => sub { ${shift()}->[1] },
+ '@{}' => sub { ${shift()}->[0] };
+ sub new {
+ my $p = shift;
+ my $a = [@_];
+ my %h;
+ tie %h, $p, $a;
+ bless \ [$a, \%h], $p;
+ }
+ sub gethash {
+ my %h;
+ my $self = shift;
+ tie %h, ref $self, $self;
+ \%h;
+ }
+
+ sub TIEHASH { my $p = shift; bless \ shift, $p }
+ my %fields;
+ my $i = 0;
+ $fields{$_} = $i++ foreach qw{zero one two three};
+ sub STORE {
+ my $a = ${shift()};
+ my $key = $fields{shift()};
+ defined $key or die "Out of band access";
+ $a->[$key] = shift;
+ }
+ sub FETCH {
+ my $a = ${shift()};
+ my $key = $fields{shift()};
+ defined $key or die "Out of band access";
+ $a->[$key];
+ }
+
+Now if $baz is overloaded like this, then C<$baz> is a reference to a
+reference to the intermediate array, which keeps a reference to an
+actual array, and the access hash. The tie()ing object for the access
+hash is a reference to a reference to the actual array, so
+
+=over
+
+=item *
+
+There are no loops of references.
+
+=item *
+
+Both "objects" which are blessed into the class C<two_refs1> are
+references to a reference to an array, thus references to a I<scalar>.
+Thus the accessor expression C<$$foo-E<gt>[$ind]> involves no
+overloaded operations.
+
+=back
+
+=head2 Symbolic calculator
+
+Put this in F<symbolic.pm> in your Perl library directory:
+
+ package symbolic; # Primitive symbolic calculator
+ use overload nomethod => \&wrap;
+
+ sub new { shift; bless ['n', @_] }
+ sub wrap {
+ my ($obj, $other, $inv, $meth) = @_;
+ ($obj, $other) = ($other, $obj) if $inv;
+ bless [$meth, $obj, $other];
+ }
+
+This module is very unusual as overloaded modules go: it does not
+provide any usual overloaded operators, instead it provides the L<Last
+Resort> operator C<nomethod>. In this example the corresponding
+subroutine returns an object which encapsulates operations done over
+the objects: C<new symbolic 3> contains C<['n', 3]>, C<2 + new
+symbolic 3> contains C<['+', 2, ['n', 3]]>.
+
+Here is an example of the script which "calculates" the side of
+circumscribed octagon using the above package:
+
+ require symbolic;
+ my $iter = 1; # 2**($iter+2) = 8
+ my $side = new symbolic 1;
+ my $cnt = $iter;
+
+ while ($cnt--) {
+ $side = (sqrt(1 + $side**2) - 1)/$side;
+ }
+ print "OK\n";
+
+The value of $side is
+
+ ['/', ['-', ['sqrt', ['+', 1, ['**', ['n', 1], 2]],
+ undef], 1], ['n', 1]]
+
+Note that while we obtained this value using a nice little script,
+there is no simple way to I<use> this value. In fact this value may
+be inspected in debugger (see L<perldebug>), but ony if
+C<bareStringify> B<O>ption is set, and not via C<p> command.
+
+If one attempts to print this value, then the overloaded operator
+C<""> will be called, which will call C<nomethod> operator. The
+result of this operator will be stringified again, but this result is
+again of type C<symbolic>, which will lead to an infinite loop.
+
+Add a pretty-printer method to the module F<symbolic.pm>:
+
+ sub pretty {
+ my ($meth, $a, $b) = @{+shift};
+ $a = 'u' unless defined $a;
+ $b = 'u' unless defined $b;
+ $a = $a->pretty if ref $a;
+ $b = $b->pretty if ref $b;
+ "[$meth $a $b]";
+ }
+
+Now one can finish the script by
+
+ print "side = ", $side->pretty, "\n";
+
+The method C<pretty> is doing object-to-string conversion, so it
+is natural to overload the operator C<""> using this method. However,
+inside such a method it is not necessary to pretty-print the
+I<components> $a and $b of an object. In the above subroutine
+C<"[$meth $a $b]"> is a catenation of some strings and components $a
+and $b. If these components use overloading, the catenation operator
+will look for an overloaded operator C<.>; if not present, it will
+look for an overloaded operator C<"">. Thus it is enough to use
+
+ use overload nomethod => \&wrap, '""' => \&str;
+ sub str {
+ my ($meth, $a, $b) = @{+shift};
+ $a = 'u' unless defined $a;
+ $b = 'u' unless defined $b;
+ "[$meth $a $b]";
+ }
+
+Now one can change the last line of the script to
+
+ print "side = $side\n";
+
+which outputs
+
+ side = [/ [- [sqrt [+ 1 [** [n 1 u] 2]] u] 1] [n 1 u]]
+
+and one can inspect the value in debugger using all the possible
+methods.
+
+Something is still amiss: consider the loop variable $cnt of the
+script. It was a number, not an object. We cannot make this value of
+type C<symbolic>, since then the loop will not terminate.
+
+Indeed, to terminate the cycle, the $cnt should become false.
+However, the operator C<bool> for checking falsity is overloaded (this
+time via overloaded C<"">), and returns a long string, thus any object
+of type C<symbolic> is true. To overcome this, we need a way to
+compare an object to 0. In fact, it is easier to write a numeric
+conversion routine.
+
+Here is the text of F<symbolic.pm> with such a routine added (and
+slightly modified str()):
+
+ package symbolic; # Primitive symbolic calculator
+ use overload
+ nomethod => \&wrap, '""' => \&str, '0+' => \&num;
+
+ sub new { shift; bless ['n', @_] }
+ sub wrap {
+ my ($obj, $other, $inv, $meth) = @_;
+ ($obj, $other) = ($other, $obj) if $inv;
+ bless [$meth, $obj, $other];
+ }
+ sub str {
+ my ($meth, $a, $b) = @{+shift};
+ $a = 'u' unless defined $a;
+ if (defined $b) {
+ "[$meth $a $b]";
+ } else {
+ "[$meth $a]";
+ }
+ }
+ my %subr = ( n => sub {$_[0]},
+ sqrt => sub {sqrt $_[0]},
+ '-' => sub {shift() - shift()},
+ '+' => sub {shift() + shift()},
+ '/' => sub {shift() / shift()},
+ '*' => sub {shift() * shift()},
+ '**' => sub {shift() ** shift()},
+ );
+ sub num {
+ my ($meth, $a, $b) = @{+shift};
+ my $subr = $subr{$meth}
+ or die "Do not know how to ($meth) in symbolic";
+ $a = $a->num if ref $a eq __PACKAGE__;
+ $b = $b->num if ref $b eq __PACKAGE__;
+ $subr->($a,$b);
+ }
+
+All the work of numeric conversion is done in %subr and num(). Of
+course, %subr is not complete, it contains only operators used in the
+example below. Here is the extra-credit question: why do we need an
+explicit recursion in num()? (Answer is at the end of this section.)
+
+Use this module like this:
+
+ require symbolic;
+ my $iter = new symbolic 2; # 16-gon
+ my $side = new symbolic 1;
+ my $cnt = $iter;
+
+ while ($cnt) {
+ $cnt = $cnt - 1; # Mutator `--' not implemented
+ $side = (sqrt(1 + $side**2) - 1)/$side;
+ }
+ printf "%s=%f\n", $side, $side;
+ printf "pi=%f\n", $side*(2**($iter+2));
+
+It prints (without so many line breaks)
+
+ [/ [- [sqrt [+ 1 [** [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1]
+ [n 1]] 2]]] 1]
+ [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]]]=0.198912
+ pi=3.182598
+
+The above module is very primitive. It does not implement
+mutator methods (C<++>, C<-=> and so on), does not do deep copying
+(not required without mutators!), and implements only those arithmetic
+operations which are used in the example.
+
+To implement most arithmetic operations is easy; one should just use
+the tables of operations, and change the code which fills %subr to
+
+ my %subr = ( 'n' => sub {$_[0]} );
+ foreach my $op (split " ", $overload::ops{with_assign}) {
+ $subr{$op} = $subr{"$op="} = eval "sub {shift() $op shift()}";
+ }
+ my @bins = qw(binary 3way_comparison num_comparison str_comparison);
+ foreach my $op (split " ", "@overload::ops{ @bins }") {
+ $subr{$op} = eval "sub {shift() $op shift()}";
+ }
+ foreach my $op (split " ", "@overload::ops{qw(unary func)}") {
+ print "defining `$op'\n";
+ $subr{$op} = eval "sub {$op shift()}";
+ }
+
+Due to L<Calling Conventions for Mutators>, we do not need anything
+special to make C<+=> and friends work, except filling C<+=> entry of
+%subr, and defining a copy constructor (needed since Perl has no
+way to know that the implementation of C<'+='> does not mutate
+the argument, compare L<Copy Constructor>).
+
+To implement a copy constructor, add C<< '=' => \&cpy >> to C<use overload>
+line, and code (this code assumes that mutators change things one level
+deep only, so recursive copying is not needed):
+
+ sub cpy {
+ my $self = shift;
+ bless [@$self], ref $self;
+ }
+
+To make C<++> and C<--> work, we need to implement actual mutators,
+either directly, or in C<nomethod>. We continue to do things inside
+C<nomethod>, thus add
+
+ if ($meth eq '++' or $meth eq '--') {
+ @$obj = ($meth, (bless [@$obj]), 1); # Avoid circular reference
+ return $obj;
+ }
+
+after the first line of wrap(). This is not a most effective
+implementation, one may consider
+
+ sub inc { $_[0] = bless ['++', shift, 1]; }
+
+instead.
+
+As a final remark, note that one can fill %subr by
+
+ my %subr = ( 'n' => sub {$_[0]} );
+ foreach my $op (split " ", $overload::ops{with_assign}) {
+ $subr{$op} = $subr{"$op="} = eval "sub {shift() $op shift()}";
+ }
+ my @bins = qw(binary 3way_comparison num_comparison str_comparison);
+ foreach my $op (split " ", "@overload::ops{ @bins }") {
+ $subr{$op} = eval "sub {shift() $op shift()}";
+ }
+ foreach my $op (split " ", "@overload::ops{qw(unary func)}") {
+ $subr{$op} = eval "sub {$op shift()}";
+ }
+ $subr{'++'} = $subr{'+'};
+ $subr{'--'} = $subr{'-'};
+
+This finishes implementation of a primitive symbolic calculator in
+50 lines of Perl code. Since the numeric values of subexpressions
+are not cached, the calculator is very slow.
+
+Here is the answer for the exercise: In the case of str(), we need no
+explicit recursion since the overloaded C<.>-operator will fall back
+to an existing overloaded operator C<"">. Overloaded arithmetic
+operators I<do not> fall back to numeric conversion if C<fallback> is
+not explicitly requested. Thus without an explicit recursion num()
+would convert C<['+', $a, $b]> to C<$a + $b>, which would just rebuild
+the argument of num().
+
+If you wonder why defaults for conversion are different for str() and
+num(), note how easy it was to write the symbolic calculator. This
+simplicity is due to an appropriate choice of defaults. One extra
+note: due to the explicit recursion num() is more fragile than sym():
+we need to explicitly check for the type of $a and $b. If components
+$a and $b happen to be of some related type, this may lead to problems.
+
+=head2 I<Really> symbolic calculator
+
+One may wonder why we call the above calculator symbolic. The reason
+is that the actual calculation of the value of expression is postponed
+until the value is I<used>.
+
+To see it in action, add a method
+
+ sub STORE {
+ my $obj = shift;
+ $#$obj = 1;
+ @$obj->[0,1] = ('=', shift);
+ }
+
+to the package C<symbolic>. After this change one can do
+
+ my $a = new symbolic 3;
+ my $b = new symbolic 4;
+ my $c = sqrt($a**2 + $b**2);
+
+and the numeric value of $c becomes 5. However, after calling
+
+ $a->STORE(12); $b->STORE(5);
+
+the numeric value of $c becomes 13. There is no doubt now that the module
+symbolic provides a I<symbolic> calculator indeed.
+
+To hide the rough edges under the hood, provide a tie()d interface to the
+package C<symbolic> (compare with L<Metaphor clash>). Add methods
+
+ sub TIESCALAR { my $pack = shift; $pack->new(@_) }
+ sub FETCH { shift }
+ sub nop { } # Around a bug
+
+(the bug is described in L<"BUGS">). One can use this new interface as
+
+ tie $a, 'symbolic', 3;
+ tie $b, 'symbolic', 4;
+ $a->nop; $b->nop; # Around a bug
+
+ my $c = sqrt($a**2 + $b**2);
+
+Now numeric value of $c is 5. After C<$a = 12; $b = 5> the numeric value
+of $c becomes 13. To insulate the user of the module add a method
+
+ sub vars { my $p = shift; tie($_, $p), $_->nop foreach @_; }
+
+Now
+
+ my ($a, $b);
+ symbolic->vars($a, $b);
+ my $c = sqrt($a**2 + $b**2);
+
+ $a = 3; $b = 4;
+ printf "c5 %s=%f\n", $c, $c;
+
+ $a = 12; $b = 5;
+ printf "c13 %s=%f\n", $c, $c;
+
+shows that the numeric value of $c follows changes to the values of $a
+and $b.
+
+=head1 AUTHOR
+
+Ilya Zakharevich E<lt>F<ilya@math.mps.ohio-state.edu>E<gt>.
+
+=head1 DIAGNOSTICS
+
+When Perl is run with the B<-Do> switch or its equivalent, overloading
+induces diagnostic messages.
+
+Using the C<m> command of Perl debugger (see L<perldebug>) one can
+deduce which operations are overloaded (and which ancestor triggers
+this overloading). Say, if C<eq> is overloaded, then the method C<(eq>
+is shown by debugger. The method C<()> corresponds to the C<fallback>
+key (in fact a presence of this method shows that this package has
+overloading enabled, and it is what is used by the C<Overloaded>
+function of module C<overload>).
+
+The module might issue the following warnings:
+
+=over 4
+
+=item Odd number of arguments for overload::constant
+
+(W) The call to overload::constant contained an odd number of arguments.
+The arguments should come in pairs.
+
+=item `%s' is not an overloadable type
+
+(W) You tried to overload a constant type the overload package is unaware of.
+
+=item `%s' is not a code reference
+
+(W) The second (fourth, sixth, ...) argument of overload::constant needs
+to be a code reference. Either an anonymous subroutine, or a reference
+to a subroutine.
+
+=back
+
+=head1 BUGS
+
+Because it is used for overloading, the per-package hash %OVERLOAD now
+has a special meaning in Perl. The symbol table is filled with names
+looking like line-noise.
+
+For the purpose of inheritance every overloaded package behaves as if
+C<fallback> is present (possibly undefined). This may create
+interesting effects if some package is not overloaded, but inherits
+from two overloaded packages.
+
+Relation between overloading and tie()ing is broken. Overloading is
+triggered or not basing on the I<previous> class of tie()d value.
+
+This happens because the presence of overloading is checked too early,
+before any tie()d access is attempted. If the FETCH()ed class of the
+tie()d value does not change, a simple workaround is to access the value
+immediately after tie()ing, so that after this call the I<previous> class
+coincides with the current one.
+
+B<Needed:> a way to fix this without a speed penalty.
+
+Barewords are not covered by overloaded string constants.
+
+This document is confusing. There are grammos and misleading language
+used in places. It would seem a total rewrite is needed.
+
+=cut
+
diff --git a/Master/tlpkg/installer/perllib/strict.pm b/Master/tlpkg/installer/perllib/strict.pm
new file mode 100644
index 00000000000..d14391add44
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/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/installer/perllib/unicore/Canonical.pl b/Master/tlpkg/installer/perllib/unicore/Canonical.pl
new file mode 100644
index 00000000000..fce1e219700
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/unicore/Canonical.pl
@@ -0,0 +1,1042 @@
+# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+# This file is built by mktables from e.g. UnicodeData.txt.
+# Any changes made here will be lost!
+
+##
+## Data in this file used by ../utf8_heavy.pl
+##
+
+## Mapping from lc(canonical name) to filename in ./lib
+%utf8::Canonical = (
+
+ # InAegeanNumbers
+ aegeannumbers => 'InAegean',
+
+ alphabetic => 'Alphabet',
+
+ # InAlphabeticPresentationForms
+ alphabeticpresentationforms => 'InAlphab',
+
+ # InAncientGreekMusicalNotation
+ ancientgreekmusicalnotation => 'InAncie2',
+
+ # InAncientGreekNumbers
+ ancientgreeknumbers => 'InAncien',
+
+ arabic => 'Arab',
+
+ # InArabicPresentationFormsA
+ arabicpresentationformsa => 'InArabi4',
+
+ # InArabicPresentationFormsB
+ arabicpresentationformsb => 'InArabi3',
+
+ # InArabicSupplement
+ arabicsupplement => 'InArabi2',
+
+ armenian => 'Armn',
+
+ # InArrows
+ arrows => 'InArrows',
+
+ # AsciiHexDigit
+ asciihexdigit => 'AsciiHex',
+
+ # InBasicLatin
+ basiclatin => 'InBasicL',
+
+ bengali => 'Beng',
+
+ # BidiControl
+ bidicontrol => 'BidiCont',
+
+ # InBlockElements
+ blockelements => 'InBlockE',
+
+ bopomofo => 'Bopo',
+
+ # InBopomofoExtended
+ bopomofoextended => 'InBopom2',
+
+ # InBoxDrawing
+ boxdrawing => 'InBoxDra',
+
+ braille => 'Brai',
+
+ # InBraillePatterns
+ braillepatterns => 'InBraill',
+
+ buginese => 'Bugi',
+ buhid => 'Buhd',
+
+ # InByzantineMusicalSymbols
+ byzantinemusicalsymbols => 'InByzant',
+
+ # CanadianAboriginal
+ canadianaboriginal => 'Canadian',
+
+ # CasedLetter
+ casedletter => 'LC',
+
+ cherokee => 'Cher',
+
+ # InCjkCompatibility
+ cjkcompatibility => 'InCjkCom',
+
+ # InCjkCompatibilityForms
+ cjkcompatibilityforms => 'InCjkCo2',
+
+ # InCjkCompatibilityIdeographs
+ cjkcompatibilityideographs => 'InCjkCo3',
+
+ # InCjkCompatibilityIdeographsSupplement
+ cjkcompatibilityideographssupplement => 'InCjkCo4',
+
+ # InCjkRadicalsSupplement
+ cjkradicalssupplement => 'InCjkRad',
+
+ # InCjkStrokes
+ cjkstrokes => 'InCjkStr',
+
+ # InCjkSymbolsAndPunctuation
+ cjksymbolsandpunctuation => 'InCjkSym',
+
+ # InCjkUnifiedIdeographs
+ cjkunifiedideographs => 'InCjkUni',
+
+ # InCjkUnifiedIdeographsExtensionA
+ cjkunifiedideographsextensiona => 'InCjkUn3',
+
+ # InCjkUnifiedIdeographsExtensionB
+ cjkunifiedideographsextensionb => 'InCjkUn2',
+
+ # ClosePunctuation
+ closepunctuation => 'Pe',
+
+ # InCombiningDiacriticalMarks
+ combiningdiacriticalmarks => 'InCombi2',
+
+ # InCombiningDiacriticalMarksForSymbols
+ combiningdiacriticalmarksforsymbols => 'InCombi4',
+
+ # InCombiningDiacriticalMarksSupplement
+ combiningdiacriticalmarkssupplement => 'InCombi3',
+
+ # InCombiningHalfMarks
+ combininghalfmarks => 'InCombin',
+
+ common => 'Zyyy',
+
+ # ConnectorPunctuation
+ connectorpunctuation => 'Pc',
+
+ control => 'Cc',
+
+ # InControlPictures
+ controlpictures => 'InContro',
+
+ coptic => 'Copt',
+
+ # CurrencySymbol
+ currencysymbol => 'Sc',
+
+ # InCurrencySymbols
+ currencysymbols => 'InCurren',
+
+ cypriot => 'Cprt',
+
+ # InCypriotSyllabary
+ cypriotsyllabary => 'InCyprio',
+
+ cyrillic => 'Cyrl',
+
+ # InCyrillicSupplement
+ cyrillicsupplement => 'InCyril2',
+
+ dash => 'Dash2',
+
+ # DashPunctuation
+ dashpunctuation => 'Pd',
+
+ # DecimalNumber
+ decimalnumber => 'Nd',
+
+ deprecated => 'Deprecat',
+ deseret => 'Dsrt',
+ devanagari => 'Deva',
+ diacritic => 'Diacriti',
+
+ # InDingbats
+ dingbats => 'InDingba',
+
+ # InEnclosedAlphanumerics
+ enclosedalphanumerics => 'InEnclos',
+
+ # InEnclosedCjkLettersAndMonths
+ enclosedcjklettersandmonths => 'InEnclo2',
+
+ # EnclosingMark
+ enclosingmark => 'Me',
+
+ ethiopic => 'Ethi',
+
+ # InEthiopicExtended
+ ethiopicextended => 'InEthio2',
+
+ # InEthiopicSupplement
+ ethiopicsupplement => 'InEthio3',
+
+ extender => 'Extender',
+
+ # FinalPunctuation
+ finalpunctuation => 'Pf',
+
+ format => 'Cf',
+
+ # InGeneralPunctuation
+ generalpunctuation => 'InGenera',
+
+ # InGeometricShapes
+ geometricshapes => 'InGeomet',
+
+ georgian => 'Geor',
+
+ # InGeorgianSupplement
+ georgiansupplement => 'InGeorg2',
+
+ glagolitic => 'Glag',
+ gothic => 'Goth',
+
+ # GraphemeLink
+ graphemelink => 'Grapheme',
+
+ greek => 'Grek',
+
+ # InGreekAndCoptic
+ greekandcoptic => 'InGreekA',
+
+ # InGreekExtended
+ greekextended => 'InGreekE',
+
+ gujarati => 'Gujr',
+ gurmukhi => 'Guru',
+
+ # InHalfwidthAndFullwidthForms
+ halfwidthandfullwidthforms => 'InHalfwi',
+
+ han => 'Hani',
+ hangul => 'Hang',
+
+ # InHangulCompatibilityJamo
+ hangulcompatibilityjamo => 'InHangu3',
+
+ # InHangulJamo
+ hanguljamo => 'InHangul',
+
+ # InHangulSyllables
+ hangulsyllables => 'InHangu2',
+
+ hanunoo => 'Hano',
+ hebrew => 'Hebr',
+
+ # HexDigit
+ hexdigit => 'HexDigit',
+
+ # InHighPrivateUseSurrogates
+ highprivateusesurrogates => 'InHighPr',
+
+ # InHighSurrogates
+ highsurrogates => 'InHighSu',
+
+ hiragana => 'Hira',
+ hyphen => 'Hyphen2',
+
+ # IdContinue
+ idcontinue => 'IdContin',
+
+ ideographic => 'Ideograp',
+
+ # InIdeographicDescriptionCharacters
+ ideographicdescriptioncharacters => 'InIdeogr',
+
+ # IdsBinaryOperator
+ idsbinaryoperator => 'IdsBinar',
+
+ # IdStart
+ idstart => 'IdStart',
+
+ # IdsTrinaryOperator
+ idstrinaryoperator => 'IdsTrina',
+
+ # InAegeanNumbers
+ inaegeannumbers => 'InAegean',
+
+ # InAlphabeticPresentationForms
+ inalphabeticpresentationforms => 'InAlphab',
+
+ # InAncientGreekMusicalNotation
+ inancientgreekmusicalnotation => 'InAncie2',
+
+ # InAncientGreekNumbers
+ inancientgreeknumbers => 'InAncien',
+
+ # InArabic
+ inarabic => 'InArabic',
+
+ # InArabicPresentationFormsA
+ inarabicpresentationformsa => 'InArabi4',
+
+ # InArabicPresentationFormsB
+ inarabicpresentationformsb => 'InArabi3',
+
+ # InArabicSupplement
+ inarabicsupplement => 'InArabi2',
+
+ # InArmenian
+ inarmenian => 'InArmeni',
+
+ # InArrows
+ inarrows => 'InArrows',
+
+ # InBasicLatin
+ inbasiclatin => 'InBasicL',
+
+ # InBengali
+ inbengali => 'InBengal',
+
+ # InBlockElements
+ inblockelements => 'InBlockE',
+
+ # InBopomofo
+ inbopomofo => 'InBopomo',
+
+ # InBopomofoExtended
+ inbopomofoextended => 'InBopom2',
+
+ # InBoxDrawing
+ inboxdrawing => 'InBoxDra',
+
+ # InBraillePatterns
+ inbraillepatterns => 'InBraill',
+
+ # InBuginese
+ inbuginese => 'InBugine',
+
+ # InBuhid
+ inbuhid => 'InBuhid',
+
+ # InByzantineMusicalSymbols
+ inbyzantinemusicalsymbols => 'InByzant',
+
+ # InCherokee
+ incherokee => 'InCherok',
+
+ # InCjkCompatibility
+ incjkcompatibility => 'InCjkCom',
+
+ # InCjkCompatibilityForms
+ incjkcompatibilityforms => 'InCjkCo2',
+
+ # InCjkCompatibilityIdeographs
+ incjkcompatibilityideographs => 'InCjkCo3',
+
+ # InCjkCompatibilityIdeographsSupplement
+ incjkcompatibilityideographssupplement => 'InCjkCo4',
+
+ # InCjkRadicalsSupplement
+ incjkradicalssupplement => 'InCjkRad',
+
+ # InCjkStrokes
+ incjkstrokes => 'InCjkStr',
+
+ # InCjkSymbolsAndPunctuation
+ incjksymbolsandpunctuation => 'InCjkSym',
+
+ # InCjkUnifiedIdeographs
+ incjkunifiedideographs => 'InCjkUni',
+
+ # InCjkUnifiedIdeographsExtensionA
+ incjkunifiedideographsextensiona => 'InCjkUn3',
+
+ # InCjkUnifiedIdeographsExtensionB
+ incjkunifiedideographsextensionb => 'InCjkUn2',
+
+ # InCombiningDiacriticalMarks
+ incombiningdiacriticalmarks => 'InCombi2',
+
+ # InCombiningDiacriticalMarksForSymbols
+ incombiningdiacriticalmarksforsymbols => 'InCombi4',
+
+ # InCombiningDiacriticalMarksSupplement
+ incombiningdiacriticalmarkssupplement => 'InCombi3',
+
+ # InCombiningHalfMarks
+ incombininghalfmarks => 'InCombin',
+
+ # InControlPictures
+ incontrolpictures => 'InContro',
+
+ # InCoptic
+ incoptic => 'InCoptic',
+
+ # InCurrencySymbols
+ incurrencysymbols => 'InCurren',
+
+ # InCypriotSyllabary
+ incypriotsyllabary => 'InCyprio',
+
+ # InCyrillic
+ incyrillic => 'InCyrill',
+
+ # InCyrillicSupplement
+ incyrillicsupplement => 'InCyril2',
+
+ # InDeseret
+ indeseret => 'InDesere',
+
+ # InDevanagari
+ indevanagari => 'InDevana',
+
+ # InDingbats
+ indingbats => 'InDingba',
+
+ # InEnclosedAlphanumerics
+ inenclosedalphanumerics => 'InEnclos',
+
+ # InEnclosedCjkLettersAndMonths
+ inenclosedcjklettersandmonths => 'InEnclo2',
+
+ # InEthiopic
+ inethiopic => 'InEthiop',
+
+ # InEthiopicExtended
+ inethiopicextended => 'InEthio2',
+
+ # InEthiopicSupplement
+ inethiopicsupplement => 'InEthio3',
+
+ # InGeneralPunctuation
+ ingeneralpunctuation => 'InGenera',
+
+ # InGeometricShapes
+ ingeometricshapes => 'InGeomet',
+
+ # InGeorgian
+ ingeorgian => 'InGeorgi',
+
+ # InGeorgianSupplement
+ ingeorgiansupplement => 'InGeorg2',
+
+ # InGlagolitic
+ inglagolitic => 'InGlagol',
+
+ # InGothic
+ ingothic => 'InGothic',
+
+ # InGreekAndCoptic
+ ingreekandcoptic => 'InGreekA',
+
+ # InGreekExtended
+ ingreekextended => 'InGreekE',
+
+ # InGujarati
+ ingujarati => 'InGujara',
+
+ # InGurmukhi
+ ingurmukhi => 'InGurmuk',
+
+ # InHalfwidthAndFullwidthForms
+ inhalfwidthandfullwidthforms => 'InHalfwi',
+
+ # InHangulCompatibilityJamo
+ inhangulcompatibilityjamo => 'InHangu3',
+
+ # InHangulJamo
+ inhanguljamo => 'InHangul',
+
+ # InHangulSyllables
+ inhangulsyllables => 'InHangu2',
+
+ # InHanunoo
+ inhanunoo => 'InHanuno',
+
+ # InHebrew
+ inhebrew => 'InHebrew',
+
+ inherited => 'Qaai',
+
+ # InHighPrivateUseSurrogates
+ inhighprivateusesurrogates => 'InHighPr',
+
+ # InHighSurrogates
+ inhighsurrogates => 'InHighSu',
+
+ # InHiragana
+ inhiragana => 'InHiraga',
+
+ # InIdeographicDescriptionCharacters
+ inideographicdescriptioncharacters => 'InIdeogr',
+
+ # InIpaExtensions
+ inipaextensions => 'InIpaExt',
+
+ # InitialPunctuation
+ initialpunctuation => 'Pi',
+
+ # InKanbun
+ inkanbun => 'InKanbun',
+
+ # InKangxiRadicals
+ inkangxiradicals => 'InKangxi',
+
+ # InKannada
+ inkannada => 'InKannad',
+
+ # InKatakana
+ inkatakana => 'InKataka',
+
+ # InKatakanaPhoneticExtensions
+ inkatakanaphoneticextensions => 'InKatak2',
+
+ # InKharoshthi
+ inkharoshthi => 'InKharos',
+
+ # InKhmer
+ inkhmer => 'InKhmer',
+
+ # InKhmerSymbols
+ inkhmersymbols => 'InKhmerS',
+
+ # InLao
+ inlao => 'InLao',
+
+ # InLatin1Supplement
+ inlatin1supplement => 'InLatin1',
+
+ # InLatinExtendedA
+ inlatinextendeda => 'InLatin2',
+
+ # InLatinExtendedAdditional
+ inlatinextendedadditional => 'InLatin3',
+
+ # InLatinExtendedB
+ inlatinextendedb => 'InLatinE',
+
+ # InLetterlikeSymbols
+ inletterlikesymbols => 'InLetter',
+
+ # InLimbu
+ inlimbu => 'InLimbu',
+
+ # InLinearBIdeograms
+ inlinearbideograms => 'InLinear',
+
+ # InLinearBSyllabary
+ inlinearbsyllabary => 'InLinea2',
+
+ # InLowSurrogates
+ inlowsurrogates => 'InLowSur',
+
+ # InMalayalam
+ inmalayalam => 'InMalaya',
+
+ # InMathematicalAlphanumericSymbols
+ inmathematicalalphanumericsymbols => 'InMathe2',
+
+ # InMathematicalOperators
+ inmathematicaloperators => 'InMathem',
+
+ # InMiscellaneousMathematicalSymbolsA
+ inmiscellaneousmathematicalsymbolsa => 'InMisce4',
+
+ # InMiscellaneousMathematicalSymbolsB
+ inmiscellaneousmathematicalsymbolsb => 'InMisce5',
+
+ # InMiscellaneousSymbols
+ inmiscellaneoussymbols => 'InMiscel',
+
+ # InMiscellaneousSymbolsAndArrows
+ inmiscellaneoussymbolsandarrows => 'InMisce3',
+
+ # InMiscellaneousTechnical
+ inmiscellaneoustechnical => 'InMisce2',
+
+ # InModifierToneLetters
+ inmodifiertoneletters => 'InModifi',
+
+ # InMongolian
+ inmongolian => 'InMongol',
+
+ # InMusicalSymbols
+ inmusicalsymbols => 'InMusica',
+
+ # InMyanmar
+ inmyanmar => 'InMyanma',
+
+ # InNewTaiLue
+ innewtailue => 'InNewTai',
+
+ # InNumberForms
+ innumberforms => 'InNumber',
+
+ # InOgham
+ inogham => 'InOgham',
+
+ # InOldItalic
+ inolditalic => 'InOldIta',
+
+ # InOldPersian
+ inoldpersian => 'InOldPer',
+
+ # InOpticalCharacterRecognition
+ inopticalcharacterrecognition => 'InOptica',
+
+ # InOriya
+ inoriya => 'InOriya',
+
+ # InOsmanya
+ inosmanya => 'InOsmany',
+
+ # InPhoneticExtensions
+ inphoneticextensions => 'InPhonet',
+
+ # InPhoneticExtensionsSupplement
+ inphoneticextensionssupplement => 'InPhone2',
+
+ # InPrivateUseArea
+ inprivateusearea => 'InPrivat',
+
+ # InRunic
+ inrunic => 'InRunic',
+
+ # InShavian
+ inshavian => 'InShavia',
+
+ # InSinhala
+ insinhala => 'InSinhal',
+
+ # InSmallFormVariants
+ insmallformvariants => 'InSmallF',
+
+ # InSpacingModifierLetters
+ inspacingmodifierletters => 'InSpacin',
+
+ # InSpecials
+ inspecials => 'InSpecia',
+
+ # InSuperscriptsAndSubscripts
+ insuperscriptsandsubscripts => 'InSupers',
+
+ # InSupplementalArrowsA
+ insupplementalarrowsa => 'InSuppl2',
+
+ # InSupplementalArrowsB
+ insupplementalarrowsb => 'InSupple',
+
+ # InSupplementalMathematicalOperators
+ insupplementalmathematicaloperators => 'InSuppl6',
+
+ # InSupplementalPunctuation
+ insupplementalpunctuation => 'InSuppl3',
+
+ # InSupplementaryPrivateUseAreaA
+ insupplementaryprivateuseareaa => 'InSuppl4',
+
+ # InSupplementaryPrivateUseAreaB
+ insupplementaryprivateuseareab => 'InSuppl5',
+
+ # InSylotiNagri
+ insylotinagri => 'InSyloti',
+
+ # InSyriac
+ insyriac => 'InSyriac',
+
+ # InTagalog
+ intagalog => 'InTagalo',
+
+ # InTagbanwa
+ intagbanwa => 'InTagban',
+
+ # InTags
+ intags => 'InTags',
+
+ # InTaiLe
+ intaile => 'InTaiLe',
+
+ # InTaiXuanJingSymbols
+ intaixuanjingsymbols => 'InTaiXua',
+
+ # InTamil
+ intamil => 'InTamil',
+
+ # InTelugu
+ intelugu => 'InTelugu',
+
+ # InThaana
+ inthaana => 'InThaana',
+
+ # InThai
+ inthai => 'InThai',
+
+ # InTibetan
+ intibetan => 'InTibeta',
+
+ # InTifinagh
+ intifinagh => 'InTifina',
+
+ # InUgaritic
+ inugaritic => 'InUgarit',
+
+ # InUnifiedCanadianAboriginalSyllabics
+ inunifiedcanadianaboriginalsyllabics => 'InUnifie',
+
+ # InVariationSelectors
+ invariationselectors => 'InVariat',
+
+ # InVariationSelectorsSupplement
+ invariationselectorssupplement => 'InVaria2',
+
+ # InVerticalForms
+ inverticalforms => 'InVertic',
+
+ # InYijingHexagramSymbols
+ inyijinghexagramsymbols => 'InYijing',
+
+ # InYiRadicals
+ inyiradicals => 'InYiRadi',
+
+ # InYiSyllables
+ inyisyllables => 'InYiSyll',
+
+ # InIpaExtensions
+ ipaextensions => 'InIpaExt',
+
+ # JoinControl
+ joincontrol => 'JoinCont',
+
+ # InKanbun
+ kanbun => 'InKanbun',
+
+ # InKangxiRadicals
+ kangxiradicals => 'InKangxi',
+
+ kannada => 'Knda',
+ katakana => 'Kana',
+
+ # InKatakanaPhoneticExtensions
+ katakanaphoneticextensions => 'InKatak2',
+
+ kharoshthi => 'Khar',
+ khmer => 'Khmr',
+
+ # InKhmerSymbols
+ khmersymbols => 'InKhmerS',
+
+ lao => 'Laoo',
+ latin => 'Latn',
+
+ # InLatin1Supplement
+ latin1supplement => 'InLatin1',
+
+ # InLatinExtendedA
+ latinextendeda => 'InLatin2',
+
+ # InLatinExtendedAdditional
+ latinextendedadditional => 'InLatin3',
+
+ # InLatinExtendedB
+ latinextendedb => 'InLatinE',
+
+ letter => 'L',
+
+ # InLetterlikeSymbols
+ letterlikesymbols => 'InLetter',
+
+ # LetterNumber
+ letternumber => 'Nl',
+
+ limbu => 'Limb',
+
+ # LinearB
+ linearb => 'LinearB',
+
+ # InLinearBIdeograms
+ linearbideograms => 'InLinear',
+
+ # InLinearBSyllabary
+ linearbsyllabary => 'InLinea2',
+
+ # LineSeparator
+ lineseparator => 'Zl',
+
+ # LogicalOrderException
+ logicalorderexception => 'LogicalO',
+
+ lowercase => 'Lowercas',
+
+ # LowercaseLetter
+ lowercaseletter => 'Ll',
+
+ # InLowSurrogates
+ lowsurrogates => 'InLowSur',
+
+ malayalam => 'Mlym',
+ mark => 'M',
+ math => 'Math',
+
+ # InMathematicalAlphanumericSymbols
+ mathematicalalphanumericsymbols => 'InMathe2',
+
+ # InMathematicalOperators
+ mathematicaloperators => 'InMathem',
+
+ # MathSymbol
+ mathsymbol => 'Sm',
+
+ # InMiscellaneousMathematicalSymbolsA
+ miscellaneousmathematicalsymbolsa => 'InMisce4',
+
+ # InMiscellaneousMathematicalSymbolsB
+ miscellaneousmathematicalsymbolsb => 'InMisce5',
+
+ # InMiscellaneousSymbols
+ miscellaneoussymbols => 'InMiscel',
+
+ # InMiscellaneousSymbolsAndArrows
+ miscellaneoussymbolsandarrows => 'InMisce3',
+
+ # InMiscellaneousTechnical
+ miscellaneoustechnical => 'InMisce2',
+
+ # ModifierLetter
+ modifierletter => 'Lm',
+
+ # ModifierSymbol
+ modifiersymbol => 'Sk',
+
+ # InModifierToneLetters
+ modifiertoneletters => 'InModifi',
+
+ mongolian => 'Mong',
+
+ # InMusicalSymbols
+ musicalsymbols => 'InMusica',
+
+ myanmar => 'Mymr',
+
+ # NewTaiLue
+ newtailue => 'NewTaiLu',
+
+ # NoncharacterCodePoint
+ noncharactercodepoint => 'Nonchara',
+
+ # NonspacingMark
+ nonspacingmark => 'Mn',
+
+ number => 'N',
+
+ # InNumberForms
+ numberforms => 'InNumber',
+
+ ogham => 'Ogam',
+
+ # OldItalic
+ olditalic => 'OldItali',
+
+ # OldPersian
+ oldpersian => 'OldPersi',
+
+ # OpenPunctuation
+ openpunctuation => 'Ps',
+
+ # InOpticalCharacterRecognition
+ opticalcharacterrecognition => 'InOptica',
+
+ oriya => 'Orya',
+ osmanya => 'Osma',
+ other => 'C',
+
+ # OtherAlphabetic
+ otheralphabetic => 'OtherAlp',
+
+ # OtherDefaultIgnorableCodePoint
+ otherdefaultignorablecodepoint => 'OtherDef',
+
+ # OtherGraphemeExtend
+ othergraphemeextend => 'OtherGra',
+
+ # OtherIdContinue
+ otheridcontinue => 'OtherIdC',
+
+ # OtherIdStart
+ otheridstart => 'OtherIdS',
+
+ # OtherLetter
+ otherletter => 'Lo',
+
+ # OtherLowercase
+ otherlowercase => 'OtherLow',
+
+ # OtherMath
+ othermath => 'OtherMat',
+
+ # OtherNumber
+ othernumber => 'No',
+
+ # OtherPunctuation
+ otherpunctuation => 'Po',
+
+ # OtherSymbol
+ othersymbol => 'So',
+
+ # OtherUppercase
+ otheruppercase => 'OtherUpp',
+
+ # ParagraphSeparator
+ paragraphseparator => 'Zp',
+
+ # PatternSyntax
+ patternsyntax => 'PatternS',
+
+ # PatternWhiteSpace
+ patternwhitespace => 'PatternW',
+
+ # InPhoneticExtensions
+ phoneticextensions => 'InPhonet',
+
+ # InPhoneticExtensionsSupplement
+ phoneticextensionssupplement => 'InPhone2',
+
+ # PrivateUse
+ privateuse => 'Co',
+
+ # InPrivateUseArea
+ privateusearea => 'InPrivat',
+
+ punctuation => 'P',
+
+ # QuotationMark
+ quotationmark => 'Quotatio',
+
+ radical => 'Radical2',
+ runic => 'Runr',
+ separator => 'Z',
+ shavian => 'Shaw',
+ sinhala => 'Sinh',
+
+ # InSmallFormVariants
+ smallformvariants => 'InSmallF',
+
+ # SoftDotted
+ softdotted => 'SoftDott',
+
+ # SpaceSeparator
+ spaceseparator => 'Zs',
+
+ # SpacingMark
+ spacingmark => 'Mc',
+
+ # InSpacingModifierLetters
+ spacingmodifierletters => 'InSpacin',
+
+ # InSpecials
+ specials => 'InSpecia',
+
+ sterm => 'Sterm2',
+
+ # InSuperscriptsAndSubscripts
+ superscriptsandsubscripts => 'InSupers',
+
+ # InSupplementalArrowsA
+ supplementalarrowsa => 'InSuppl2',
+
+ # InSupplementalArrowsB
+ supplementalarrowsb => 'InSupple',
+
+ # InSupplementalMathematicalOperators
+ supplementalmathematicaloperators => 'InSuppl6',
+
+ # InSupplementalPunctuation
+ supplementalpunctuation => 'InSuppl3',
+
+ # InSupplementaryPrivateUseAreaA
+ supplementaryprivateuseareaa => 'InSuppl4',
+
+ # InSupplementaryPrivateUseAreaB
+ supplementaryprivateuseareab => 'InSuppl5',
+
+ surrogate => 'Cs',
+
+ # SylotiNagri
+ sylotinagri => 'SylotiNa',
+
+ symbol => 'S',
+ syriac => 'Syrc',
+ tagalog => 'Tglg',
+ tagbanwa => 'Tagb',
+
+ # InTags
+ tags => 'InTags',
+
+ # TaiLe
+ taile => 'TaiLe',
+
+ # InTaiXuanJingSymbols
+ taixuanjingsymbols => 'InTaiXua',
+
+ tamil => 'Taml',
+ telugu => 'Telu',
+
+ # TerminalPunctuation
+ terminalpunctuation => 'Terminal',
+
+ thaana => 'Thaa',
+ thai => 'Thai',
+ tibetan => 'Tibt',
+ tifinagh => 'Tfng',
+
+ # TitlecaseLetter
+ titlecaseletter => 'Lt',
+
+ ugaritic => 'Ugar',
+ unassigned => 'Cn',
+
+ # InUnifiedCanadianAboriginalSyllabics
+ unifiedcanadianaboriginalsyllabics => 'InUnifie',
+
+ # UnifiedIdeograph
+ unifiedideograph => 'UnifiedI',
+
+ uppercase => 'Uppercas',
+
+ # UppercaseLetter
+ uppercaseletter => 'Lu',
+
+ # VariationSelector
+ variationselector => 'Variatio',
+
+ # InVariationSelectors
+ variationselectors => 'InVariat',
+
+ # InVariationSelectorsSupplement
+ variationselectorssupplement => 'InVaria2',
+
+ # InVerticalForms
+ verticalforms => 'InVertic',
+
+ # WhiteSpace
+ whitespace => 'WhiteSpa',
+
+ yi => 'Yiii',
+
+ # InYijingHexagramSymbols
+ yijinghexagramsymbols => 'InYijing',
+
+ # InYiRadicals
+ yiradicals => 'InYiRadi',
+
+ # InYiSyllables
+ yisyllables => 'InYiSyll',
+
+);
+1
diff --git a/Master/tlpkg/installer/perllib/unicore/Exact.pl b/Master/tlpkg/installer/perllib/unicore/Exact.pl
new file mode 100644
index 00000000000..42312b054cc
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/unicore/Exact.pl
@@ -0,0 +1,73 @@
+# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+# This file is built by mktables from e.g. UnicodeData.txt.
+# Any changes made here will be lost!
+
+##
+## Data in this file used by ../utf8_heavy.pl
+##
+
+## Mapping from name to filename in ./lib/gc_sc
+%utf8::Exact = (
+ ASCII => 'ASCII',
+ All => 'Any',
+ Alnum => 'Alnum',
+ Alpha => 'Alpha',
+ Any => 'Any',
+ Assigned => 'Assigned',
+ Blank => 'Blank',
+ C => 'C',
+ Cc => 'Cc',
+ Cf => 'Cf',
+ Cn => 'Cn',
+ Cntrl => 'Cntrl',
+ Co => 'Co',
+ Cs => 'Cs',
+ Digit => 'Digit',
+ Graph => 'Graph',
+ InGreek => 'InGreekA',
+ L => 'L',
+ LC => 'LC',
+ Ll => 'Ll',
+ Lm => 'Lm',
+ Lo => 'Lo',
+ Lower => 'Lower',
+ Lt => 'Lt',
+ Lu => 'Lu',
+ M => 'M',
+ Mc => 'Mc',
+ Me => 'Me',
+ Mn => 'Mn',
+ N => 'N',
+ Nd => 'Nd',
+ Nl => 'Nl',
+ No => 'No',
+ P => 'P',
+ Pc => 'Pc',
+ Pd => 'Pd',
+ Pe => 'Pe',
+ Pf => 'Pf',
+ Pi => 'Pi',
+ Po => 'Po',
+ Print => 'Print',
+ Ps => 'Ps',
+ Punct => 'Punct',
+ S => 'S',
+ Sc => 'Sc',
+ Sk => 'Sk',
+ Sm => 'Sm',
+ So => 'So',
+ Space => 'Space',
+ SpacePerl => 'SpacePer',
+ Title => 'Title',
+ Upper => 'Upper',
+ Word => 'Word',
+ XDigit => 'XDigit',
+ Z => 'Z',
+ Zl => 'Zl',
+ Zp => 'Zp',
+ Zs => 'Zs',
+ _CanonDCIJ => '_CanonDC',
+ _CaseIgnorable => '_CaseIgn',
+ _CombAbove => '_CombAbo',
+);
+1;
diff --git a/Master/tlpkg/installer/perllib/unicore/PVA.pl b/Master/tlpkg/installer/perllib/unicore/PVA.pl
new file mode 100644
index 00000000000..d836bdb7549
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/unicore/PVA.pl
@@ -0,0 +1,2044 @@
+# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+# This file is built by mktables from e.g. UnicodeData.txt.
+# Any changes made here will be lost!
+
+
+%utf8::PropertyAlias = (
+'sc',
+'Script',
+'xonfkd',
+'ExpandsOnNFKD',
+'patsyn',
+'PatternSyntax',
+'nfkcqc',
+'NFKCQuickCheck',
+'oalpha',
+'OtherAlphabetic',
+'gcb',
+'GraphemeClusterBreak',
+'nfcqc',
+'NFCQuickCheck',
+'ids',
+'IDStart',
+'lb',
+'LineBreak',
+'stc',
+'SimpleTitlecaseMapping',
+'xonfkc',
+'ExpandsOnNFKC',
+'patws',
+'PatternWhiteSpace',
+'tc',
+'TitlecaseMapping',
+'lower',
+'Lowercase',
+'idst',
+'IDSTrinaryOperator',
+'radical',
+'Radical',
+'fcnfkc',
+'FCNFKCClosure',
+'dm',
+'DecompositionMapping',
+'slc',
+'SimpleLowercaseMapping',
+'wspace',
+'WhiteSpace',
+'di',
+'DefaultIgnorableCodePoint',
+'nt',
+'NumericType',
+'ea',
+'EastAsianWidth',
+'ahex',
+'ASCIIHexDigit',
+'alpha',
+'Alphabetic',
+'uc',
+'UppercaseMapping',
+'dia',
+'Diacritic',
+'gc',
+'GeneralCategory',
+'xids',
+'XIDStart',
+'oupper',
+'OtherUppercase',
+'wb',
+'WordBreak',
+'math',
+'Math',
+'sb',
+'SentenceBreak',
+'qmark',
+'QuotationMark',
+'nfdqc',
+'NFDQuickCheck',
+'ideo',
+'Ideographic',
+'blk',
+'Block',
+'odi',
+'OtherDefaultIgnorableCodePoint',
+'hst',
+'HangulSyllableType',
+'bidim',
+'BidiMirrored',
+'olower',
+'OtherLowercase',
+'na',
+'Name',
+'hyphen',
+'Hyphen',
+'xidc',
+'XIDContinue',
+'oidc',
+'OtherIDContinue',
+'bidic',
+'BidiControl',
+'na1',
+'Unicode1Name',
+'compex',
+'FullCompositionExclusion',
+'ext',
+'Extender',
+'cf',
+'CaseFolding',
+'grlink',
+'GraphemeLink',
+'xonfc',
+'ExpandsOnNFC',
+'sd',
+'SoftDotted',
+'ccc',
+'CanonicalCombiningClass',
+'dash',
+'Dash',
+'hex',
+'HexDigit',
+'grbase',
+'GraphemeBase',
+'dt',
+'DecompositionType',
+'xonfd',
+'ExpandsOnNFD',
+'scc',
+'SpecialCaseCondition',
+'idsb',
+'IDSBinaryOperator',
+'age',
+'Age',
+'loe',
+'LogicalOrderException',
+'term',
+'TerminalPunctuation',
+'ce',
+'CompositionExclusion',
+'isc',
+'ISOComment',
+'dep',
+'Deprecated',
+'sfc',
+'SimpleCaseFolding',
+'bc',
+'BidiClass',
+'nchar',
+'NoncharacterCodePoint',
+'jt',
+'JoiningType',
+'upper',
+'Uppercase',
+'uideo',
+'UnifiedIdeograph',
+'sterm',
+'STerm',
+'nfkdqc',
+'NFKDQuickCheck',
+'oids',
+'OtherIDStart',
+'joinc',
+'JoinControl',
+'nv',
+'NumericValue',
+'suc',
+'SimpleUppercaseMapping',
+'urs',
+'UnicodeRadicalStroke',
+'bmg',
+'BidiMirroringGlyph',
+'grext',
+'GraphemeExtend',
+'idc',
+'IDContinue',
+'vs',
+'VariationSelector',
+'omath',
+'OtherMath',
+'lc',
+'LowercaseMapping',
+'ogrext',
+'OtherGraphemeExtend',
+'jg',
+'JoiningGroup',
+);
+
+%utf8::PA_reverse = (
+'linebreak',
+'lb',
+'bidiclass',
+'bc',
+'terminalpunctuation',
+'Term',
+'expandsonnfkc',
+'XONFKC',
+'extender',
+'Ext',
+'simplecasefolding',
+'sfc',
+'patternsyntax',
+'PatSyn',
+'sentencebreak',
+'SB',
+'numericvalue',
+'nv',
+'patternwhitespace',
+'PatWS',
+'softdotted',
+'SD',
+'logicalorderexception',
+'LOE',
+'idstart',
+'IDS',
+'generalcategory',
+'gc',
+'decompositiontype',
+'dt',
+'name',
+'na',
+'numerictype',
+'nt',
+'otherlowercase',
+'OLower',
+'joininggroup',
+'jg',
+'expandsonnfkd',
+'XONFKD',
+'deprecated',
+'Dep',
+'radical',
+'Radical',
+'idstrinaryoperator',
+'IDST',
+'xidstart',
+'XIDS',
+'lowercase',
+'Lower',
+'unifiedideograph',
+'UIdeo',
+'othergraphemeextend',
+'OGrExt',
+'eastasianwidth',
+'ea',
+'math',
+'Math',
+'graphemelink',
+'GrLink',
+'noncharactercodepoint',
+'NChar',
+'graphemebase',
+'GrBase',
+'bidimirrored',
+'BidiM',
+'casefolding',
+'cf',
+'simpleuppercasemapping',
+'suc',
+'fullcompositionexclusion',
+'CompEx',
+'compositionexclusion',
+'CE',
+'uppercasemapping',
+'uc',
+'decompositionmapping',
+'dm',
+'whitespace',
+'WSpace',
+'hyphen',
+'Hyphen',
+'ideographic',
+'Ideo',
+'idcontinue',
+'IDC',
+'idsbinaryoperator',
+'IDSB',
+'hangulsyllabletype',
+'hst',
+'asciihexdigit',
+'AHex',
+'otheruppercase',
+'OUpper',
+'nfkdquickcheck',
+'NFKDQC',
+'simpletitlecasemapping',
+'stc',
+'nfcquickcheck',
+'NFCQC',
+'bidicontrol',
+'BidiC',
+'diacritic',
+'Dia',
+'joiningtype',
+'jt',
+'otheralphabetic',
+'OAlpha',
+'canonicalcombiningclass',
+'ccc',
+'alphabetic',
+'Alpha',
+'titlecasemapping',
+'tc',
+'unicoderadicalstroke',
+'URS',
+'hexdigit',
+'Hex',
+'unicode1name',
+'na1',
+'dash',
+'Dash',
+'fcnfkcclosure',
+'FCNFKC',
+'graphemeextend',
+'GrExt',
+'joincontrol',
+'JoinC',
+'xidcontinue',
+'XIDC',
+'quotationmark',
+'QMark',
+'expandsonnfd',
+'XONFD',
+'age',
+'age',
+'otheridcontinue',
+'OIDC',
+'uppercase',
+'Upper',
+'expandsonnfc',
+'XONFC',
+'defaultignorablecodepoint',
+'DI',
+'nfdquickcheck',
+'NFDQC',
+'isocomment',
+'isc',
+'otherdefaultignorablecodepoint',
+'ODI',
+'variationselector',
+'VS',
+'specialcasecondition',
+'scc',
+'script',
+'sc',
+'otheridstart',
+'OIDS',
+'sterm',
+'STerm',
+'graphemeclusterbreak',
+'GCB',
+'nfkcquickcheck',
+'NFKCQC',
+'bidimirroringglyph',
+'bmg',
+'othermath',
+'OMath',
+'block',
+'blk',
+'wordbreak',
+'WB',
+'lowercasemapping',
+'lc',
+'simplelowercasemapping',
+'slc',
+);
+
+%utf8::PropValueAlias = (
+'sc',
+{
+'tglg',
+'Tagalog',
+'runr',
+'Runic',
+'osma',
+'Osmanya',
+'hano',
+'Hanunoo',
+'cans',
+'CanadianAboriginal',
+'tagb',
+'Tagbanwa',
+'mlym',
+'Malayalam',
+'knda',
+'Kannada',
+'grek',
+'Greek',
+'ethi',
+'Ethiopic',
+'orya',
+'Oriya',
+'cher',
+'Cherokee',
+'mong',
+'Mongolian',
+'khmr',
+'Khmer',
+'ogam',
+'Ogham',
+'hrkt',
+'KatakanaOrHiragana',
+'armn',
+'Armenian',
+'ital',
+'OldItalic',
+'hani',
+'Han',
+'shaw',
+'Shavian',
+'taml',
+'Tamil',
+'tibt',
+'Tibetan',
+'guru',
+'Gurmukhi',
+'ugar',
+'Ugaritic',
+'qaai',
+'Inherited',
+'kana',
+'Katakana',
+'gujr',
+'Gujarati',
+'thaa',
+'Thaana',
+'cyrl',
+'Cyrillic',
+'copt',
+'Coptic',
+'sylo',
+'SylotiNagri',
+'thai',
+'Thai',
+'talu',
+'NewTaiLue',
+'laoo',
+'Lao',
+'sinh',
+'Sinhala',
+'beng',
+'Bengali',
+'hira',
+'Hiragana',
+'brai',
+'Braille',
+'telu',
+'Telugu',
+'limb',
+'Limbu',
+'geor',
+'Georgian',
+'mymr',
+'Myanmar',
+'glag',
+'Glagolitic',
+'hang',
+'Hangul',
+'syrc',
+'Syriac',
+'tfng',
+'Tifinagh',
+'dsrt',
+'Deseret',
+'buhd',
+'Buhid',
+'yiii',
+'Yi',
+'arab',
+'Arabic',
+'bopo',
+'Bopomofo',
+'khar',
+'Kharoshthi',
+'linb',
+'LinearB',
+'deva',
+'Devanagari',
+'xpeo',
+'OldPersian',
+'goth',
+'Gothic',
+'cprt',
+'Cypriot',
+'tale',
+'TaiLe',
+'zyyy',
+'Common',
+'latn',
+'Latin',
+'bugi',
+'Buginese',
+'hebr',
+'Hebrew',
+},
+'dt',
+{
+'fra',
+'Fraction',
+'none',
+'None',
+'sml',
+'Small',
+'enc',
+'Circle',
+'font',
+'Font',
+'init',
+'Initial',
+'nb',
+'Nobreak',
+'iso',
+'Isolated',
+'sup',
+'Super',
+'fin',
+'Final',
+'wide',
+'Wide',
+'nar',
+'Narrow',
+'can',
+'Canonical',
+'med',
+'Medial',
+'sub',
+'Sub',
+'vert',
+'Vertical',
+'sqr',
+'Square',
+'com',
+'Compat',
+},
+'nt',
+{
+'none',
+'None',
+'di',
+'Digit',
+'de',
+'Decimal',
+'nu',
+'Numeric',
+},
+'ea',
+{
+'w',
+'Wide',
+'n',
+'Neutral',
+'h',
+'Halfwidth',
+'a',
+'Ambiguous',
+'f',
+'Fullwidth',
+'na',
+'Narrow',
+},
+'NFKC_QC',
+{
+'y',
+'Yes',
+'n',
+'No',
+'m',
+'Maybe',
+},
+'bc',
+{
+'r',
+'RightToLeft',
+'rlo',
+'RightToLeftOverride',
+'es',
+'EuropeanSeparator',
+'ws',
+'WhiteSpace',
+'rle',
+'RightToLeftEmbedding',
+'on',
+'OtherNeutral',
+'bn',
+'BoundaryNeutral',
+'et',
+'EuropeanTerminator',
+'pdf',
+'PopDirectionalFormat',
+'lro',
+'LeftToRightOverride',
+'s',
+'SegmentSeparator',
+'al',
+'ArabicLetter',
+'en',
+'EuropeanNumber',
+'l',
+'LeftToRight',
+'b',
+'ParagraphSeparator',
+'lre',
+'LeftToRightEmbedding',
+'cs',
+'CommonSeparator',
+'nsm',
+'NonspacingMark',
+'an',
+'ArabicNumber',
+},
+'gc',
+{
+'sc',
+'CurrencySymbol',
+'mc',
+'SpacingMark',
+'lm',
+'ModifierLetter',
+'cn',
+'Unassigned',
+'pf',
+'FinalPunctuation',
+'no',
+'OtherNumber',
+'cc',
+'Control',
+'lo',
+'OtherLetter',
+'po',
+'OtherPunctuation',
+'zs',
+'SpaceSeparator',
+'co',
+'PrivateUse',
+'so',
+'OtherSymbol',
+'ll',
+'LowercaseLetter',
+'nd',
+'DecimalNumber',
+'cf',
+'Format',
+'me',
+'EnclosingMark',
+'s',
+'Symbol',
+'zp',
+'ParagraphSeparator',
+'pd',
+'DashPunctuation',
+'c',
+'Other',
+'lt',
+'TitlecaseLetter',
+'cs',
+'Surrogate',
+'l&',
+'CasedLetter',
+'z',
+'Separator',
+'ps',
+'OpenPunctuation',
+'zl',
+'LineSeparator',
+'pc',
+'ConnectorPunctuation',
+'pi',
+'InitialPunctuation',
+'n',
+'Number',
+'m',
+'Mark',
+'nl',
+'LetterNumber',
+'sm',
+'MathSymbol',
+'l',
+'Letter',
+'mn',
+'NonspacingMark',
+'p',
+'Punctuation',
+'lc',
+'CasedLetter',
+'sk',
+'ModifierSymbol',
+'lu',
+'UppercaseLetter',
+'pe',
+'ClosePunctuation',
+},
+'GCB',
+{
+'cn',
+'Control',
+'ex',
+'Extend',
+'v',
+'V',
+'lv',
+'LV',
+'xx',
+'Other',
+'l',
+'L',
+'lvt',
+'LVT',
+'cr',
+'CR',
+'lf',
+'LF',
+'t',
+'T',
+},
+'lb',
+{
+'sp',
+'Space',
+'ba',
+'BreakAfter',
+'gl',
+'Glue',
+'xx',
+'Unknown',
+'nu',
+'Numeric',
+'cb',
+'ContingentBreak',
+'sy',
+'BreakSymbols',
+'cr',
+'CarriageReturn',
+'in',
+'Inseparable',
+'bb',
+'BreakBefore',
+'sg',
+'Surrogate',
+'sa',
+'ComplexContext',
+'po',
+'PostfixNumeric',
+'jl',
+'JL',
+'id',
+'Ideographic',
+'al',
+'Alphabetic',
+'bk',
+'MandatoryBreak',
+'pr',
+'PrefixNumeric',
+'b2',
+'BreakBoth',
+'op',
+'OpenPunctuation',
+'cl',
+'ClosePunctuation',
+'is',
+'InfixNumeric',
+'qu',
+'Quotation',
+'hy',
+'Hyphen',
+'wj',
+'WordJoiner',
+'zw',
+'ZWSpace',
+'jt',
+'JT',
+'ex',
+'Exclamation',
+'cm',
+'CombiningMark',
+'h2',
+'H2',
+'nl',
+'NextLine',
+'ns',
+'Nonstarter',
+'h3',
+'H3',
+'ai',
+'Ambiguous',
+'lf',
+'LineFeed',
+'jv',
+'JV',
+},
+'jt',
+{
+'l',
+'LeftJoining',
+'u',
+'NonJoining',
+'c',
+'JoinCausing',
+'r',
+'RightJoining',
+'d',
+'DualJoining',
+'t',
+'Transparent',
+},
+'NFKD_QC',
+{
+'y',
+'Yes',
+'n',
+'No',
+},
+'NFC_QC',
+{
+'y',
+'Yes',
+'n',
+'No',
+'m',
+'Maybe',
+},
+'hst',
+{
+'l',
+'LeadingJamo',
+'lvt',
+'LVTSyllable',
+'v',
+'VowelJamo',
+'lv',
+'LVSyllable',
+'t',
+'TrailingJamo',
+'na',
+'NotApplicable',
+},
+'NFD_QC',
+{
+'y',
+'Yes',
+'n',
+'No',
+},
+'WB',
+{
+'ml',
+'MidLetter',
+'le',
+'ALetter',
+'ex',
+'ExtendNumLet',
+'xx',
+'Other',
+'nu',
+'Numeric',
+'fo',
+'Format',
+'mn',
+'MidNum',
+'ka',
+'Katakana',
+},
+'SB',
+{
+'sp',
+'Sp',
+'cl',
+'Close',
+'le',
+'OLetter',
+'up',
+'Upper',
+'st',
+'STerm',
+'xx',
+'Other',
+'nu',
+'Numeric',
+'fo',
+'Format',
+'se',
+'Sep',
+'lo',
+'Lower',
+'at',
+'ATerm',
+},
+'ccc',
+{
+'atb',
+'AttachedBelow',
+'db',
+'DoubleBelow',
+'a',
+'Above',
+'r',
+'Right',
+'da',
+'DoubleAbove',
+'is',
+'IotaSubscript',
+'nr',
+'NotReordered',
+'ov',
+'Overlay',
+'br',
+'BelowRight',
+'nk',
+'Nukta',
+'atbl',
+'AttachedBelowLeft',
+'al',
+'AboveLeft',
+'ar',
+'AboveRight',
+'atar',
+'AttachedAboveRight',
+'l',
+'Left',
+'b',
+'Below',
+'vr',
+'Virama',
+'kv',
+'KanaVoicing',
+'bl',
+'BelowLeft',
+},
+);
+
+%utf8::PVA_reverse = (
+'sc',
+{
+'newtailue',
+'Talu',
+'canadianaboriginal',
+'Cans',
+'gujarati',
+'Gujr',
+'latin',
+'Latn',
+'hangul',
+'Hang',
+'deseret',
+'Dsrt',
+'hebrew',
+'Hebr',
+'inherited',
+'Qaai',
+'linearb',
+'Linb',
+'ugaritic',
+'Ugar',
+'taile',
+'Tale',
+'armenian',
+'Armn',
+'tifinagh',
+'Tfng',
+'myanmar',
+'Mymr',
+'gurmukhi',
+'Guru',
+'greek',
+'Grek',
+'coptic',
+'Copt',
+'cyrillic',
+'Cyrl',
+'thaana',
+'Thaa',
+'lao',
+'Laoo',
+'katakana',
+'Kana',
+'khmer',
+'Khmr',
+'tibetan',
+'Tibt',
+'hiragana',
+'Hira',
+'mongolian',
+'Mong',
+'thai',
+'Thai',
+'yi',
+'Yiii',
+'sylotinagri',
+'Sylo',
+'bopomofo',
+'Bopo',
+'malayalam',
+'Mlym',
+'telugu',
+'Telu',
+'limbu',
+'Limb',
+'oriya',
+'Orya',
+'buhid',
+'Buhd',
+'cypriot',
+'Cprt',
+'bengali',
+'Beng',
+'katakanaorhiragana',
+'Hrkt',
+'oldpersian',
+'Xpeo',
+'tagalog',
+'Tglg',
+'syriac',
+'Syrc',
+'cherokee',
+'Cher',
+'ogham',
+'Ogam',
+'hanunoo',
+'Hano',
+'braille',
+'Brai',
+'tamil',
+'Taml',
+'common',
+'Zyyy',
+'runic',
+'Runr',
+'georgian',
+'Geor',
+'ethiopic',
+'Ethi',
+'glagolitic',
+'Glag',
+'han',
+'Hani',
+'kharoshthi',
+'Khar',
+'kannada',
+'Knda',
+'tagbanwa',
+'Tagb',
+'arabic',
+'Arab',
+'sinhala',
+'Sinh',
+'gothic',
+'Goth',
+'osmanya',
+'Osma',
+'olditalic',
+'Ital',
+'devanagari',
+'Deva',
+'buginese',
+'Bugi',
+'shavian',
+'Shaw',
+},
+'dt',
+{
+'small',
+'sml',
+'none',
+'none',
+'isolated',
+'iso',
+'narrow',
+'nar',
+'square',
+'sqr',
+'nobreak',
+'nb',
+'fraction',
+'fra',
+'font',
+'font',
+'medial',
+'med',
+'wide',
+'wide',
+'canonical',
+'can',
+'circle',
+'enc',
+'super',
+'sup',
+'vertical',
+'vert',
+'final',
+'fin',
+'compat',
+'com',
+'sub',
+'sub',
+'initial',
+'init',
+},
+'nt',
+{
+'none',
+'None',
+'digit',
+'Di',
+'numeric',
+'Nu',
+'decimal',
+'De',
+},
+'ea',
+{
+'halfwidth',
+'H',
+'fullwidth',
+'F',
+'ambiguous',
+'A',
+'narrow',
+'Na',
+'wide',
+'W',
+'neutral',
+'N',
+},
+'NFKC_QC',
+{
+'yes',
+'Y',
+'maybe',
+'M',
+'no',
+'N',
+},
+'bc',
+{
+'nonspacingmark',
+'NSM',
+'whitespace',
+'WS',
+'righttoleft',
+'R',
+'lefttoright',
+'L',
+'boundaryneutral',
+'BN',
+'segmentseparator',
+'S',
+'lefttorightembedding',
+'LRE',
+'europeanterminator',
+'ET',
+'righttoleftembedding',
+'RLE',
+'righttoleftoverride',
+'RLO',
+'lefttorightoverride',
+'LRO',
+'europeanseparator',
+'ES',
+'europeannumber',
+'EN',
+'commonseparator',
+'CS',
+'arabicletter',
+'AL',
+'paragraphseparator',
+'B',
+'otherneutral',
+'ON',
+'popdirectionalformat',
+'PDF',
+'arabicnumber',
+'AN',
+},
+'gc',
+{
+'modifiersymbol',
+'Sk',
+'letternumber',
+'Nl',
+'connectorpunctuation',
+'Pc',
+'spacingmark',
+'Mc',
+'mark',
+'M',
+'unassigned',
+'Cn',
+'enclosingmark',
+'Me',
+'lineseparator',
+'Zl',
+'lowercaseletter',
+'Ll',
+'symbol',
+'S',
+'letter',
+'L',
+'othernumber',
+'No',
+'paragraphseparator',
+'Zp',
+'modifierletter',
+'Lm',
+'titlecaseletter',
+'Lt',
+'decimalnumber',
+'Nd',
+'other',
+'C',
+'mathsymbol',
+'Sm',
+'surrogate',
+'Cs',
+'otherletter',
+'Lo',
+'nonspacingmark',
+'Mn',
+'number',
+'N',
+'uppercaseletter',
+'Lu',
+'spaceseparator',
+'Zs',
+'privateuse',
+'Co',
+'openpunctuation',
+'Ps',
+'punctuation',
+'P',
+'control',
+'Cc',
+'casedletter',
+'LC',
+'closepunctuation',
+'Pe',
+'otherpunctuation',
+'Po',
+'finalpunctuation',
+'Pf',
+'format',
+'Cf',
+'initialpunctuation',
+'Pi',
+'separator',
+'Z',
+'othersymbol',
+'So',
+'dashpunctuation',
+'Pd',
+'currencysymbol',
+'Sc',
+},
+'GCB',
+{
+'extend',
+'EX',
+'v',
+'V',
+'lv',
+'LV',
+'l',
+'L',
+'lvt',
+'LVT',
+'cr',
+'CR',
+'other',
+'XX',
+'lf',
+'LF',
+'control',
+'CN',
+'t',
+'T',
+},
+'lb',
+{
+'carriagereturn',
+'CR',
+'ideographic',
+'ID',
+'hyphen',
+'HY',
+'ambiguous',
+'AI',
+'contingentbreak',
+'CB',
+'complexcontext',
+'SA',
+'prefixnumeric',
+'PR',
+'jl',
+'JL',
+'inseparable',
+'IN',
+'breaksymbols',
+'SY',
+'breakafter',
+'BA',
+'breakbefore',
+'BB',
+'postfixnumeric',
+'PO',
+'glue',
+'GL',
+'wordjoiner',
+'WJ',
+'breakboth',
+'B2',
+'quotation',
+'QU',
+'combiningmark',
+'CM',
+'nonstarter',
+'NS',
+'linefeed',
+'LF',
+'alphabetic',
+'AL',
+'surrogate',
+'SG',
+'mandatorybreak',
+'BK',
+'unknown',
+'XX',
+'exclamation',
+'EX',
+'openpunctuation',
+'OP',
+'jt',
+'JT',
+'closepunctuation',
+'CL',
+'space',
+'SP',
+'zwspace',
+'ZW',
+'h2',
+'H2',
+'infixnumeric',
+'IS',
+'nextline',
+'NL',
+'numeric',
+'NU',
+'h3',
+'H3',
+'jv',
+'JV',
+},
+'jt',
+{
+'leftjoining',
+'L',
+'transparent',
+'T',
+'nonjoining',
+'U',
+'rightjoining',
+'R',
+'dualjoining',
+'D',
+'joincausing',
+'C',
+},
+'NFKD_QC',
+{
+'yes',
+'Y',
+'no',
+'N',
+},
+'NFC_QC',
+{
+'yes',
+'Y',
+'maybe',
+'M',
+'no',
+'N',
+},
+'hst',
+{
+'lvtsyllable',
+'LVT',
+'lvsyllable',
+'LV',
+'leadingjamo',
+'L',
+'notapplicable',
+'NA',
+'voweljamo',
+'V',
+'trailingjamo',
+'T',
+},
+'NFD_QC',
+{
+'yes',
+'Y',
+'no',
+'N',
+},
+'WB',
+{
+'midletter',
+'ML',
+'format',
+'FO',
+'katakana',
+'KA',
+'other',
+'XX',
+'midnum',
+'MN',
+'numeric',
+'NU',
+'extendnumlet',
+'EX',
+'aletter',
+'LE',
+},
+'SB',
+{
+'sp',
+'SP',
+'upper',
+'UP',
+'sterm',
+'ST',
+'aterm',
+'AT',
+'close',
+'CL',
+'oletter',
+'LE',
+'sep',
+'SE',
+'format',
+'FO',
+'other',
+'XX',
+'lower',
+'LO',
+'numeric',
+'NU',
+},
+'ccc',
+{
+'left',
+'L',
+'attachedbelowleft',
+'ATBL',
+'belowleft',
+'BL',
+'aboveright',
+'AR',
+'kanavoicing',
+'KV',
+'above',
+'A',
+'aboveleft',
+'AL',
+'nukta',
+'NK',
+'below',
+'B',
+'doublebelow',
+'DB',
+'virama',
+'VR',
+'belowright',
+'BR',
+'notreordered',
+'NR',
+'attachedbelow',
+'ATB',
+'right',
+'R',
+'iotasubscript',
+'IS',
+'doubleabove',
+'DA',
+'attachedaboveright',
+'ATAR',
+'overlay',
+'OV',
+},
+);
+
+%utf8::PVA_abbr_map = (
+'jt',
+{
+'l',
+'L',
+'u',
+'U',
+'c',
+'C',
+'r',
+'R',
+'d',
+'D',
+'t',
+'T',
+},
+'dt',
+{
+'fra',
+'fra',
+'none',
+'none',
+'sml',
+'sml',
+'enc',
+'enc',
+'font',
+'font',
+'init',
+'init',
+'nb',
+'nb',
+'iso',
+'iso',
+'sup',
+'sup',
+'fin',
+'fin',
+'wide',
+'wide',
+'nar',
+'nar',
+'can',
+'can',
+'med',
+'med',
+'sub',
+'sub',
+'vert',
+'vert',
+'sqr',
+'sqr',
+'com',
+'com',
+},
+'nt',
+{
+'none',
+'None',
+'di',
+'Di',
+'de',
+'De',
+'nu',
+'Nu',
+},
+'NFKD_QC',
+{
+'y',
+'Y',
+'n',
+'N',
+},
+'ea',
+{
+'w',
+'W',
+'n',
+'N',
+'h',
+'H',
+'a',
+'A',
+'f',
+'F',
+'na',
+'Na',
+},
+'gc_sc',
+{
+'runr',
+'Runr',
+'osma',
+'Osma',
+'sc',
+'Sc',
+'mc',
+'Mc',
+'hano',
+'Hano',
+'cans',
+'Cans',
+'lm',
+'Lm',
+'cn',
+'Cn',
+'knda',
+'Knda',
+'orya',
+'Orya',
+'cher',
+'Cher',
+'khmr',
+'Khmr',
+'ogam',
+'Ogam',
+'lo',
+'Lo',
+'po',
+'Po',
+'co',
+'Co',
+'ital',
+'Ital',
+'ll',
+'Ll',
+'tibt',
+'Tibt',
+'kana',
+'Kana',
+'zp',
+'Zp',
+'gujr',
+'Gujr',
+'thaa',
+'Thaa',
+'cs',
+'Cs',
+'copt',
+'Copt',
+'z',
+'Z',
+'ps',
+'Ps',
+'sylo',
+'Sylo',
+'talu',
+'Talu',
+'laoo',
+'Laoo',
+'sinh',
+'Sinh',
+'zl',
+'Zl',
+'pc',
+'Pc',
+'hira',
+'Hira',
+'limb',
+'Limb',
+'mymr',
+'Mymr',
+'yiii',
+'Yiii',
+'arab',
+'Arab',
+'deva',
+'Deva',
+'xpeo',
+'Xpeo',
+'cprt',
+'Cprt',
+'bugi',
+'Bugi',
+'sk',
+'Sk',
+'hebr',
+'Hebr',
+'lu',
+'Lu',
+'pe',
+'Pe',
+'tglg',
+'Tglg',
+'tagb',
+'Tagb',
+'mlym',
+'Mlym',
+'pf',
+'Pf',
+'no',
+'No',
+'grek',
+'Grek',
+'ethi',
+'Ethi',
+'mong',
+'Mong',
+'cc',
+'Cc',
+'hrkt',
+'Hrkt',
+'armn',
+'Armn',
+'zs',
+'Zs',
+'so',
+'So',
+'hani',
+'Hani',
+'shaw',
+'Shaw',
+'taml',
+'Taml',
+'me',
+'Me',
+'cf',
+'Cf',
+'nd',
+'Nd',
+'s',
+'S',
+'guru',
+'Guru',
+'ugar',
+'Ugar',
+'qaai',
+'Qaai',
+'lt',
+'Lt',
+'c',
+'C',
+'pd',
+'Pd',
+'cyrl',
+'Cyrl',
+'l&',
+'LC',
+'thai',
+'Thai',
+'beng',
+'Beng',
+'brai',
+'Brai',
+'telu',
+'Telu',
+'pi',
+'Pi',
+'geor',
+'Geor',
+'glag',
+'Glag',
+'hang',
+'Hang',
+'syrc',
+'Syrc',
+'tfng',
+'Tfng',
+'n',
+'N',
+'dsrt',
+'Dsrt',
+'buhd',
+'Buhd',
+'m',
+'M',
+'khar',
+'Khar',
+'sm',
+'Sm',
+'nl',
+'Nl',
+'bopo',
+'Bopo',
+'linb',
+'Linb',
+'mn',
+'Mn',
+'l',
+'L',
+'p',
+'P',
+'goth',
+'Goth',
+'tale',
+'Tale',
+'lc',
+'LC',
+'zyyy',
+'Zyyy',
+'latn',
+'Latn',
+},
+'NFC_QC',
+{
+'y',
+'Y',
+'n',
+'N',
+'m',
+'M',
+},
+'NFD_QC',
+{
+'y',
+'Y',
+'n',
+'N',
+},
+'hst',
+{
+'l',
+'L',
+'lvt',
+'LVT',
+'v',
+'V',
+'lv',
+'LV',
+'t',
+'T',
+'na',
+'NA',
+},
+'NFKC_QC',
+{
+'y',
+'Y',
+'n',
+'N',
+'m',
+'M',
+},
+'WB',
+{
+'ml',
+'ML',
+'le',
+'LE',
+'ex',
+'EX',
+'xx',
+'XX',
+'nu',
+'NU',
+'fo',
+'FO',
+'mn',
+'MN',
+'ka',
+'KA',
+},
+'SB',
+{
+'sp',
+'SP',
+'cl',
+'CL',
+'le',
+'LE',
+'up',
+'UP',
+'st',
+'ST',
+'xx',
+'XX',
+'nu',
+'NU',
+'fo',
+'FO',
+'se',
+'SE',
+'lo',
+'LO',
+'at',
+'AT',
+},
+'bc',
+{
+'r',
+'R',
+'rlo',
+'RLO',
+'es',
+'ES',
+'ws',
+'WS',
+'rle',
+'RLE',
+'on',
+'ON',
+'bn',
+'BN',
+'et',
+'ET',
+'pdf',
+'PDF',
+'lro',
+'LRO',
+'s',
+'S',
+'al',
+'AL',
+'en',
+'EN',
+'l',
+'L',
+'b',
+'B',
+'lre',
+'LRE',
+'cs',
+'CS',
+'nsm',
+'NSM',
+'an',
+'AN',
+},
+'GCB',
+{
+'cn',
+'CN',
+'ex',
+'EX',
+'v',
+'V',
+'lv',
+'LV',
+'xx',
+'XX',
+'l',
+'L',
+'lvt',
+'LVT',
+'cr',
+'CR',
+'lf',
+'LF',
+'t',
+'T',
+},
+'ccc',
+{
+'atb',
+'ATB',
+'db',
+'DB',
+'a',
+'A',
+'r',
+'R',
+'da',
+'DA',
+'is',
+'IS',
+'nr',
+'NR',
+'ov',
+'OV',
+'br',
+'BR',
+'nk',
+'NK',
+'atbl',
+'ATBL',
+'al',
+'AL',
+'ar',
+'AR',
+'atar',
+'ATAR',
+'l',
+'L',
+'b',
+'B',
+'vr',
+'VR',
+'kv',
+'KV',
+'bl',
+'BL',
+},
+'lb',
+{
+'sp',
+'SP',
+'ba',
+'BA',
+'gl',
+'GL',
+'xx',
+'XX',
+'nu',
+'NU',
+'cb',
+'CB',
+'sy',
+'SY',
+'cr',
+'CR',
+'in',
+'IN',
+'bb',
+'BB',
+'sg',
+'SG',
+'sa',
+'SA',
+'po',
+'PO',
+'jl',
+'JL',
+'id',
+'ID',
+'al',
+'AL',
+'bk',
+'BK',
+'pr',
+'PR',
+'b2',
+'B2',
+'op',
+'OP',
+'cl',
+'CL',
+'is',
+'IS',
+'qu',
+'QU',
+'hy',
+'HY',
+'wj',
+'WJ',
+'zw',
+'ZW',
+'jt',
+'JT',
+'ex',
+'EX',
+'cm',
+'CM',
+'h2',
+'H2',
+'nl',
+'NL',
+'ns',
+'NS',
+'h3',
+'H3',
+'ai',
+'AI',
+'lf',
+'LF',
+'jv',
+'JV',
+},
+);
+1;
diff --git a/Master/tlpkg/installer/perllib/unicore/To/Lower.pl b/Master/tlpkg/installer/perllib/unicore/To/Lower.pl
new file mode 100644
index 00000000000..77a7a7fb0e0
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/unicore/To/Lower.pl
@@ -0,0 +1,905 @@
+# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+# This file is built by mktables from e.g. UnicodeData.txt.
+# Any changes made here will be lost!
+
+
+# The key UTF-8 _bytes_, the value UTF-8 (speed hack)
+%utf8::ToSpecLower =
+(
+"\xC4\xB0" => "\x{0069}\x{0307}",
+"\xE1\xBE\x88" => "\x{1F80}",
+"\xE1\xBE\x89" => "\x{1F81}",
+"\xE1\xBE\x8A" => "\x{1F82}",
+"\xE1\xBE\x8B" => "\x{1F83}",
+"\xE1\xBE\x8C" => "\x{1F84}",
+"\xE1\xBE\x8D" => "\x{1F85}",
+"\xE1\xBE\x8E" => "\x{1F86}",
+"\xE1\xBE\x8F" => "\x{1F87}",
+"\xE1\xBE\x98" => "\x{1F90}",
+"\xE1\xBE\x99" => "\x{1F91}",
+"\xE1\xBE\x9A" => "\x{1F92}",
+"\xE1\xBE\x9B" => "\x{1F93}",
+"\xE1\xBE\x9C" => "\x{1F94}",
+"\xE1\xBE\x9D" => "\x{1F95}",
+"\xE1\xBE\x9E" => "\x{1F96}",
+"\xE1\xBE\x9F" => "\x{1F97}",
+"\xE1\xBE\xA8" => "\x{1FA0}",
+"\xE1\xBE\xA9" => "\x{1FA1}",
+"\xE1\xBE\xAA" => "\x{1FA2}",
+"\xE1\xBE\xAB" => "\x{1FA3}",
+"\xE1\xBE\xAC" => "\x{1FA4}",
+"\xE1\xBE\xAD" => "\x{1FA5}",
+"\xE1\xBE\xAE" => "\x{1FA6}",
+"\xE1\xBE\xAF" => "\x{1FA7}",
+"\xE1\xBE\xBC" => "\x{1FB3}",
+"\xE1\xBF\x8C" => "\x{1FC3}",
+"\xE1\xBF\xBC" => "\x{1FF3}",
+);
+
+return <<'END';
+0041 0061
+0042 0062
+0043 0063
+0044 0064
+0045 0065
+0046 0066
+0047 0067
+0048 0068
+0049 0069
+004A 006A
+004B 006B
+004C 006C
+004D 006D
+004E 006E
+004F 006F
+0050 0070
+0051 0071
+0052 0072
+0053 0073
+0054 0074
+0055 0075
+0056 0076
+0057 0077
+0058 0078
+0059 0079
+005A 007A
+00C0 00E0
+00C1 00E1
+00C2 00E2
+00C3 00E3
+00C4 00E4
+00C5 00E5
+00C6 00E6
+00C7 00E7
+00C8 00E8
+00C9 00E9
+00CA 00EA
+00CB 00EB
+00CC 00EC
+00CD 00ED
+00CE 00EE
+00CF 00EF
+00D0 00F0
+00D1 00F1
+00D2 00F2
+00D3 00F3
+00D4 00F4
+00D5 00F5
+00D6 00F6
+00D8 00F8
+00D9 00F9
+00DA 00FA
+00DB 00FB
+00DC 00FC
+00DD 00FD
+00DE 00FE
+0100 0101
+0102 0103
+0104 0105
+0106 0107
+0108 0109
+010A 010B
+010C 010D
+010E 010F
+0110 0111
+0112 0113
+0114 0115
+0116 0117
+0118 0119
+011A 011B
+011C 011D
+011E 011F
+0120 0121
+0122 0123
+0124 0125
+0126 0127
+0128 0129
+012A 012B
+012C 012D
+012E 012F
+0132 0133
+0134 0135
+0136 0137
+0139 013A
+013B 013C
+013D 013E
+013F 0140
+0141 0142
+0143 0144
+0145 0146
+0147 0148
+014A 014B
+014C 014D
+014E 014F
+0150 0151
+0152 0153
+0154 0155
+0156 0157
+0158 0159
+015A 015B
+015C 015D
+015E 015F
+0160 0161
+0162 0163
+0164 0165
+0166 0167
+0168 0169
+016A 016B
+016C 016D
+016E 016F
+0170 0171
+0172 0173
+0174 0175
+0176 0177
+0178 00FF
+0179 017A
+017B 017C
+017D 017E
+0181 0253
+0182 0183
+0184 0185
+0186 0254
+0187 0188
+0189 0256
+018A 0257
+018B 018C
+018E 01DD
+018F 0259
+0190 025B
+0191 0192
+0193 0260
+0194 0263
+0196 0269
+0197 0268
+0198 0199
+019C 026F
+019D 0272
+019F 0275
+01A0 01A1
+01A2 01A3
+01A4 01A5
+01A6 0280
+01A7 01A8
+01A9 0283
+01AC 01AD
+01AE 0288
+01AF 01B0
+01B1 028A
+01B2 028B
+01B3 01B4
+01B5 01B6
+01B7 0292
+01B8 01B9
+01BC 01BD
+01C4 01C6
+01C5 01C6
+01C7 01C9
+01C8 01C9
+01CA 01CC
+01CB 01CC
+01CD 01CE
+01CF 01D0
+01D1 01D2
+01D3 01D4
+01D5 01D6
+01D7 01D8
+01D9 01DA
+01DB 01DC
+01DE 01DF
+01E0 01E1
+01E2 01E3
+01E4 01E5
+01E6 01E7
+01E8 01E9
+01EA 01EB
+01EC 01ED
+01EE 01EF
+01F1 01F3
+01F2 01F3
+01F4 01F5
+01F6 0195
+01F7 01BF
+01F8 01F9
+01FA 01FB
+01FC 01FD
+01FE 01FF
+0200 0201
+0202 0203
+0204 0205
+0206 0207
+0208 0209
+020A 020B
+020C 020D
+020E 020F
+0210 0211
+0212 0213
+0214 0215
+0216 0217
+0218 0219
+021A 021B
+021C 021D
+021E 021F
+0220 019E
+0222 0223
+0224 0225
+0226 0227
+0228 0229
+022A 022B
+022C 022D
+022E 022F
+0230 0231
+0232 0233
+023B 023C
+023D 019A
+0241 0294
+0386 03AC
+0388 03AD
+0389 03AE
+038A 03AF
+038C 03CC
+038E 03CD
+038F 03CE
+0391 03B1
+0392 03B2
+0393 03B3
+0394 03B4
+0395 03B5
+0396 03B6
+0397 03B7
+0398 03B8
+0399 03B9
+039A 03BA
+039B 03BB
+039C 03BC
+039D 03BD
+039E 03BE
+039F 03BF
+03A0 03C0
+03A1 03C1
+03A3 03C3
+03A4 03C4
+03A5 03C5
+03A6 03C6
+03A7 03C7
+03A8 03C8
+03A9 03C9
+03AA 03CA
+03AB 03CB
+03D8 03D9
+03DA 03DB
+03DC 03DD
+03DE 03DF
+03E0 03E1
+03E2 03E3
+03E4 03E5
+03E6 03E7
+03E8 03E9
+03EA 03EB
+03EC 03ED
+03EE 03EF
+03F4 03B8
+03F7 03F8
+03F9 03F2
+03FA 03FB
+0400 0450
+0401 0451
+0402 0452
+0403 0453
+0404 0454
+0405 0455
+0406 0456
+0407 0457
+0408 0458
+0409 0459
+040A 045A
+040B 045B
+040C 045C
+040D 045D
+040E 045E
+040F 045F
+0410 0430
+0411 0431
+0412 0432
+0413 0433
+0414 0434
+0415 0435
+0416 0436
+0417 0437
+0418 0438
+0419 0439
+041A 043A
+041B 043B
+041C 043C
+041D 043D
+041E 043E
+041F 043F
+0420 0440
+0421 0441
+0422 0442
+0423 0443
+0424 0444
+0425 0445
+0426 0446
+0427 0447
+0428 0448
+0429 0449
+042A 044A
+042B 044B
+042C 044C
+042D 044D
+042E 044E
+042F 044F
+0460 0461
+0462 0463
+0464 0465
+0466 0467
+0468 0469
+046A 046B
+046C 046D
+046E 046F
+0470 0471
+0472 0473
+0474 0475
+0476 0477
+0478 0479
+047A 047B
+047C 047D
+047E 047F
+0480 0481
+048A 048B
+048C 048D
+048E 048F
+0490 0491
+0492 0493
+0494 0495
+0496 0497
+0498 0499
+049A 049B
+049C 049D
+049E 049F
+04A0 04A1
+04A2 04A3
+04A4 04A5
+04A6 04A7
+04A8 04A9
+04AA 04AB
+04AC 04AD
+04AE 04AF
+04B0 04B1
+04B2 04B3
+04B4 04B5
+04B6 04B7
+04B8 04B9
+04BA 04BB
+04BC 04BD
+04BE 04BF
+04C1 04C2
+04C3 04C4
+04C5 04C6
+04C7 04C8
+04C9 04CA
+04CB 04CC
+04CD 04CE
+04D0 04D1
+04D2 04D3
+04D4 04D5
+04D6 04D7
+04D8 04D9
+04DA 04DB
+04DC 04DD
+04DE 04DF
+04E0 04E1
+04E2 04E3
+04E4 04E5
+04E6 04E7
+04E8 04E9
+04EA 04EB
+04EC 04ED
+04EE 04EF
+04F0 04F1
+04F2 04F3
+04F4 04F5
+04F6 04F7
+04F8 04F9
+0500 0501
+0502 0503
+0504 0505
+0506 0507
+0508 0509
+050A 050B
+050C 050D
+050E 050F
+0531 0561
+0532 0562
+0533 0563
+0534 0564
+0535 0565
+0536 0566
+0537 0567
+0538 0568
+0539 0569
+053A 056A
+053B 056B
+053C 056C
+053D 056D
+053E 056E
+053F 056F
+0540 0570
+0541 0571
+0542 0572
+0543 0573
+0544 0574
+0545 0575
+0546 0576
+0547 0577
+0548 0578
+0549 0579
+054A 057A
+054B 057B
+054C 057C
+054D 057D
+054E 057E
+054F 057F
+0550 0580
+0551 0581
+0552 0582
+0553 0583
+0554 0584
+0555 0585
+0556 0586
+10A0 2D00
+10A1 2D01
+10A2 2D02
+10A3 2D03
+10A4 2D04
+10A5 2D05
+10A6 2D06
+10A7 2D07
+10A8 2D08
+10A9 2D09
+10AA 2D0A
+10AB 2D0B
+10AC 2D0C
+10AD 2D0D
+10AE 2D0E
+10AF 2D0F
+10B0 2D10
+10B1 2D11
+10B2 2D12
+10B3 2D13
+10B4 2D14
+10B5 2D15
+10B6 2D16
+10B7 2D17
+10B8 2D18
+10B9 2D19
+10BA 2D1A
+10BB 2D1B
+10BC 2D1C
+10BD 2D1D
+10BE 2D1E
+10BF 2D1F
+10C0 2D20
+10C1 2D21
+10C2 2D22
+10C3 2D23
+10C4 2D24
+10C5 2D25
+1E00 1E01
+1E02 1E03
+1E04 1E05
+1E06 1E07
+1E08 1E09
+1E0A 1E0B
+1E0C 1E0D
+1E0E 1E0F
+1E10 1E11
+1E12 1E13
+1E14 1E15
+1E16 1E17
+1E18 1E19
+1E1A 1E1B
+1E1C 1E1D
+1E1E 1E1F
+1E20 1E21
+1E22 1E23
+1E24 1E25
+1E26 1E27
+1E28 1E29
+1E2A 1E2B
+1E2C 1E2D
+1E2E 1E2F
+1E30 1E31
+1E32 1E33
+1E34 1E35
+1E36 1E37
+1E38 1E39
+1E3A 1E3B
+1E3C 1E3D
+1E3E 1E3F
+1E40 1E41
+1E42 1E43
+1E44 1E45
+1E46 1E47
+1E48 1E49
+1E4A 1E4B
+1E4C 1E4D
+1E4E 1E4F
+1E50 1E51
+1E52 1E53
+1E54 1E55
+1E56 1E57
+1E58 1E59
+1E5A 1E5B
+1E5C 1E5D
+1E5E 1E5F
+1E60 1E61
+1E62 1E63
+1E64 1E65
+1E66 1E67
+1E68 1E69
+1E6A 1E6B
+1E6C 1E6D
+1E6E 1E6F
+1E70 1E71
+1E72 1E73
+1E74 1E75
+1E76 1E77
+1E78 1E79
+1E7A 1E7B
+1E7C 1E7D
+1E7E 1E7F
+1E80 1E81
+1E82 1E83
+1E84 1E85
+1E86 1E87
+1E88 1E89
+1E8A 1E8B
+1E8C 1E8D
+1E8E 1E8F
+1E90 1E91
+1E92 1E93
+1E94 1E95
+1EA0 1EA1
+1EA2 1EA3
+1EA4 1EA5
+1EA6 1EA7
+1EA8 1EA9
+1EAA 1EAB
+1EAC 1EAD
+1EAE 1EAF
+1EB0 1EB1
+1EB2 1EB3
+1EB4 1EB5
+1EB6 1EB7
+1EB8 1EB9
+1EBA 1EBB
+1EBC 1EBD
+1EBE 1EBF
+1EC0 1EC1
+1EC2 1EC3
+1EC4 1EC5
+1EC6 1EC7
+1EC8 1EC9
+1ECA 1ECB
+1ECC 1ECD
+1ECE 1ECF
+1ED0 1ED1
+1ED2 1ED3
+1ED4 1ED5
+1ED6 1ED7
+1ED8 1ED9
+1EDA 1EDB
+1EDC 1EDD
+1EDE 1EDF
+1EE0 1EE1
+1EE2 1EE3
+1EE4 1EE5
+1EE6 1EE7
+1EE8 1EE9
+1EEA 1EEB
+1EEC 1EED
+1EEE 1EEF
+1EF0 1EF1
+1EF2 1EF3
+1EF4 1EF5
+1EF6 1EF7
+1EF8 1EF9
+1F08 1F00
+1F09 1F01
+1F0A 1F02
+1F0B 1F03
+1F0C 1F04
+1F0D 1F05
+1F0E 1F06
+1F0F 1F07
+1F18 1F10
+1F19 1F11
+1F1A 1F12
+1F1B 1F13
+1F1C 1F14
+1F1D 1F15
+1F28 1F20
+1F29 1F21
+1F2A 1F22
+1F2B 1F23
+1F2C 1F24
+1F2D 1F25
+1F2E 1F26
+1F2F 1F27
+1F38 1F30
+1F39 1F31
+1F3A 1F32
+1F3B 1F33
+1F3C 1F34
+1F3D 1F35
+1F3E 1F36
+1F3F 1F37
+1F48 1F40
+1F49 1F41
+1F4A 1F42
+1F4B 1F43
+1F4C 1F44
+1F4D 1F45
+1F59 1F51
+1F5B 1F53
+1F5D 1F55
+1F5F 1F57
+1F68 1F60
+1F69 1F61
+1F6A 1F62
+1F6B 1F63
+1F6C 1F64
+1F6D 1F65
+1F6E 1F66
+1F6F 1F67
+1FB8 1FB0
+1FB9 1FB1
+1FBA 1F70
+1FBB 1F71
+1FC8 1F72
+1FC9 1F73
+1FCA 1F74
+1FCB 1F75
+1FD8 1FD0
+1FD9 1FD1
+1FDA 1F76
+1FDB 1F77
+1FE8 1FE0
+1FE9 1FE1
+1FEA 1F7A
+1FEB 1F7B
+1FEC 1FE5
+1FF8 1F78
+1FF9 1F79
+1FFA 1F7C
+1FFB 1F7D
+2126 03C9
+212A 006B
+212B 00E5
+2160 2170
+2161 2171
+2162 2172
+2163 2173
+2164 2174
+2165 2175
+2166 2176
+2167 2177
+2168 2178
+2169 2179
+216A 217A
+216B 217B
+216C 217C
+216D 217D
+216E 217E
+216F 217F
+24B6 24D0
+24B7 24D1
+24B8 24D2
+24B9 24D3
+24BA 24D4
+24BB 24D5
+24BC 24D6
+24BD 24D7
+24BE 24D8
+24BF 24D9
+24C0 24DA
+24C1 24DB
+24C2 24DC
+24C3 24DD
+24C4 24DE
+24C5 24DF
+24C6 24E0
+24C7 24E1
+24C8 24E2
+24C9 24E3
+24CA 24E4
+24CB 24E5
+24CC 24E6
+24CD 24E7
+24CE 24E8
+24CF 24E9
+2C00 2C30
+2C01 2C31
+2C02 2C32
+2C03 2C33
+2C04 2C34
+2C05 2C35
+2C06 2C36
+2C07 2C37
+2C08 2C38
+2C09 2C39
+2C0A 2C3A
+2C0B 2C3B
+2C0C 2C3C
+2C0D 2C3D
+2C0E 2C3E
+2C0F 2C3F
+2C10 2C40
+2C11 2C41
+2C12 2C42
+2C13 2C43
+2C14 2C44
+2C15 2C45
+2C16 2C46
+2C17 2C47
+2C18 2C48
+2C19 2C49
+2C1A 2C4A
+2C1B 2C4B
+2C1C 2C4C
+2C1D 2C4D
+2C1E 2C4E
+2C1F 2C4F
+2C20 2C50
+2C21 2C51
+2C22 2C52
+2C23 2C53
+2C24 2C54
+2C25 2C55
+2C26 2C56
+2C27 2C57
+2C28 2C58
+2C29 2C59
+2C2A 2C5A
+2C2B 2C5B
+2C2C 2C5C
+2C2D 2C5D
+2C2E 2C5E
+2C80 2C81
+2C82 2C83
+2C84 2C85
+2C86 2C87
+2C88 2C89
+2C8A 2C8B
+2C8C 2C8D
+2C8E 2C8F
+2C90 2C91
+2C92 2C93
+2C94 2C95
+2C96 2C97
+2C98 2C99
+2C9A 2C9B
+2C9C 2C9D
+2C9E 2C9F
+2CA0 2CA1
+2CA2 2CA3
+2CA4 2CA5
+2CA6 2CA7
+2CA8 2CA9
+2CAA 2CAB
+2CAC 2CAD
+2CAE 2CAF
+2CB0 2CB1
+2CB2 2CB3
+2CB4 2CB5
+2CB6 2CB7
+2CB8 2CB9
+2CBA 2CBB
+2CBC 2CBD
+2CBE 2CBF
+2CC0 2CC1
+2CC2 2CC3
+2CC4 2CC5
+2CC6 2CC7
+2CC8 2CC9
+2CCA 2CCB
+2CCC 2CCD
+2CCE 2CCF
+2CD0 2CD1
+2CD2 2CD3
+2CD4 2CD5
+2CD6 2CD7
+2CD8 2CD9
+2CDA 2CDB
+2CDC 2CDD
+2CDE 2CDF
+2CE0 2CE1
+2CE2 2CE3
+FF21 FF41
+FF22 FF42
+FF23 FF43
+FF24 FF44
+FF25 FF45
+FF26 FF46
+FF27 FF47
+FF28 FF48
+FF29 FF49
+FF2A FF4A
+FF2B FF4B
+FF2C FF4C
+FF2D FF4D
+FF2E FF4E
+FF2F FF4F
+FF30 FF50
+FF31 FF51
+FF32 FF52
+FF33 FF53
+FF34 FF54
+FF35 FF55
+FF36 FF56
+FF37 FF57
+FF38 FF58
+FF39 FF59
+FF3A FF5A
+10400 10428
+10401 10429
+10402 1042A
+10403 1042B
+10404 1042C
+10405 1042D
+10406 1042E
+10407 1042F
+10408 10430
+10409 10431
+1040A 10432
+1040B 10433
+1040C 10434
+1040D 10435
+1040E 10436
+1040F 10437
+10410 10438
+10411 10439
+10412 1043A
+10413 1043B
+10414 1043C
+10415 1043D
+10416 1043E
+10417 1043F
+10418 10440
+10419 10441
+1041A 10442
+1041B 10443
+1041C 10444
+1041D 10445
+1041E 10446
+1041F 10447
+10420 10448
+10421 10449
+10422 1044A
+10423 1044B
+10424 1044C
+10425 1044D
+10426 1044E
+10427 1044F
+END
diff --git a/Master/tlpkg/installer/perllib/unicore/lib/gc_sc/Uppercas.pl b/Master/tlpkg/installer/perllib/unicore/lib/gc_sc/Uppercas.pl
new file mode 100644
index 00000000000..4778dc3ab52
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/unicore/lib/gc_sc/Uppercas.pl
@@ -0,0 +1,490 @@
+# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+# This file is built by mktables from e.g. UnicodeData.txt.
+# Any changes made here will be lost!
+
+#
+# This file supports:
+# \p{Uppercase} (and fuzzy permutations)
+#
+# Meaning: [\p{Lu}\p{Other_Uppercase}]
+#
+return <<'END';
+0041 005A
+00C0 00D6
+00D8 00DE
+0100
+0102
+0104
+0106
+0108
+010A
+010C
+010E
+0110
+0112
+0114
+0116
+0118
+011A
+011C
+011E
+0120
+0122
+0124
+0126
+0128
+012A
+012C
+012E
+0130
+0132
+0134
+0136
+0139
+013B
+013D
+013F
+0141
+0143
+0145
+0147
+014A
+014C
+014E
+0150
+0152
+0154
+0156
+0158
+015A
+015C
+015E
+0160
+0162
+0164
+0166
+0168
+016A
+016C
+016E
+0170
+0172
+0174
+0176
+0178 0179
+017B
+017D
+0181 0182
+0184
+0186 0187
+0189 018B
+018E 0191
+0193 0194
+0196 0198
+019C 019D
+019F 01A0
+01A2
+01A4
+01A6 01A7
+01A9
+01AC
+01AE 01AF
+01B1 01B3
+01B5
+01B7 01B8
+01BC
+01C4
+01C7
+01CA
+01CD
+01CF
+01D1
+01D3
+01D5
+01D7
+01D9
+01DB
+01DE
+01E0
+01E2
+01E4
+01E6
+01E8
+01EA
+01EC
+01EE
+01F1
+01F4
+01F6 01F8
+01FA
+01FC
+01FE
+0200
+0202
+0204
+0206
+0208
+020A
+020C
+020E
+0210
+0212
+0214
+0216
+0218
+021A
+021C
+021E
+0220
+0222
+0224
+0226
+0228
+022A
+022C
+022E
+0230
+0232
+023A 023B
+023D 023E
+0241
+0386
+0388 038A
+038C
+038E 038F
+0391 03A1
+03A3 03AB
+03D2 03D4
+03D8
+03DA
+03DC
+03DE
+03E0
+03E2
+03E4
+03E6
+03E8
+03EA
+03EC
+03EE
+03F4
+03F7
+03F9 03FA
+03FD 042F
+0460
+0462
+0464
+0466
+0468
+046A
+046C
+046E
+0470
+0472
+0474
+0476
+0478
+047A
+047C
+047E
+0480
+048A
+048C
+048E
+0490
+0492
+0494
+0496
+0498
+049A
+049C
+049E
+04A0
+04A2
+04A4
+04A6
+04A8
+04AA
+04AC
+04AE
+04B0
+04B2
+04B4
+04B6
+04B8
+04BA
+04BC
+04BE
+04C0 04C1
+04C3
+04C5
+04C7
+04C9
+04CB
+04CD
+04D0
+04D2
+04D4
+04D6
+04D8
+04DA
+04DC
+04DE
+04E0
+04E2
+04E4
+04E6
+04E8
+04EA
+04EC
+04EE
+04F0
+04F2
+04F4
+04F6
+04F8
+0500
+0502
+0504
+0506
+0508
+050A
+050C
+050E
+0531 0556
+10A0 10C5
+1E00
+1E02
+1E04
+1E06
+1E08
+1E0A
+1E0C
+1E0E
+1E10
+1E12
+1E14
+1E16
+1E18
+1E1A
+1E1C
+1E1E
+1E20
+1E22
+1E24
+1E26
+1E28
+1E2A
+1E2C
+1E2E
+1E30
+1E32
+1E34
+1E36
+1E38
+1E3A
+1E3C
+1E3E
+1E40
+1E42
+1E44
+1E46
+1E48
+1E4A
+1E4C
+1E4E
+1E50
+1E52
+1E54
+1E56
+1E58
+1E5A
+1E5C
+1E5E
+1E60
+1E62
+1E64
+1E66
+1E68
+1E6A
+1E6C
+1E6E
+1E70
+1E72
+1E74
+1E76
+1E78
+1E7A
+1E7C
+1E7E
+1E80
+1E82
+1E84
+1E86
+1E88
+1E8A
+1E8C
+1E8E
+1E90
+1E92
+1E94
+1EA0
+1EA2
+1EA4
+1EA6
+1EA8
+1EAA
+1EAC
+1EAE
+1EB0
+1EB2
+1EB4
+1EB6
+1EB8
+1EBA
+1EBC
+1EBE
+1EC0
+1EC2
+1EC4
+1EC6
+1EC8
+1ECA
+1ECC
+1ECE
+1ED0
+1ED2
+1ED4
+1ED6
+1ED8
+1EDA
+1EDC
+1EDE
+1EE0
+1EE2
+1EE4
+1EE6
+1EE8
+1EEA
+1EEC
+1EEE
+1EF0
+1EF2
+1EF4
+1EF6
+1EF8
+1F08 1F0F
+1F18 1F1D
+1F28 1F2F
+1F38 1F3F
+1F48 1F4D
+1F59
+1F5B
+1F5D
+1F5F
+1F68 1F6F
+1FB8 1FBB
+1FC8 1FCB
+1FD8 1FDB
+1FE8 1FEC
+1FF8 1FFB
+2102
+2107
+210B 210D
+2110 2112
+2115
+2119 211D
+2124
+2126
+2128
+212A 212D
+2130 2131
+2133
+213E 213F
+2145
+2160 216F
+24B6 24CF
+2C00 2C2E
+2C80
+2C82
+2C84
+2C86
+2C88
+2C8A
+2C8C
+2C8E
+2C90
+2C92
+2C94
+2C96
+2C98
+2C9A
+2C9C
+2C9E
+2CA0
+2CA2
+2CA4
+2CA6
+2CA8
+2CAA
+2CAC
+2CAE
+2CB0
+2CB2
+2CB4
+2CB6
+2CB8
+2CBA
+2CBC
+2CBE
+2CC0
+2CC2
+2CC4
+2CC6
+2CC8
+2CCA
+2CCC
+2CCE
+2CD0
+2CD2
+2CD4
+2CD6
+2CD8
+2CDA
+2CDC
+2CDE
+2CE0
+2CE2
+FF21 FF3A
+10400 10427
+1D400 1D419
+1D434 1D44D
+1D468 1D481
+1D49C
+1D49E 1D49F
+1D4A2
+1D4A5 1D4A6
+1D4A9 1D4AC
+1D4AE 1D4B5
+1D4D0 1D4E9
+1D504 1D505
+1D507 1D50A
+1D50D 1D514
+1D516 1D51C
+1D538 1D539
+1D53B 1D53E
+1D540 1D544
+1D546
+1D54A 1D550
+1D56C 1D585
+1D5A0 1D5B9
+1D5D4 1D5ED
+1D608 1D621
+1D63C 1D655
+1D670 1D689
+1D6A8 1D6C0
+1D6E2 1D6FA
+1D71C 1D734
+1D756 1D76E
+1D790 1D7A8
+END
diff --git a/Master/tlpkg/installer/perllib/utf8.pm b/Master/tlpkg/installer/perllib/utf8.pm
new file mode 100644
index 00000000000..56c991bef9a
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/utf8.pm
@@ -0,0 +1,214 @@
+package utf8;
+
+$utf8::hint_bits = 0x00800000;
+
+our $VERSION = '1.06';
+
+sub import {
+ $^H |= $utf8::hint_bits;
+ $enc{caller()} = $_[1] if $_[1];
+}
+
+sub unimport {
+ $^H &= ~$utf8::hint_bits;
+}
+
+sub AUTOLOAD {
+ require "utf8_heavy.pl";
+ goto &$AUTOLOAD if defined &$AUTOLOAD;
+ require Carp;
+ Carp::croak("Undefined subroutine $AUTOLOAD called");
+}
+
+1;
+__END__
+
+=head1 NAME
+
+utf8 - Perl pragma to enable/disable UTF-8 (or UTF-EBCDIC) in source code
+
+=head1 SYNOPSIS
+
+ use utf8;
+ no utf8;
+
+ # Convert a Perl scalar to/from UTF-8.
+ $num_octets = utf8::upgrade($string);
+ $success = utf8::downgrade($string[, FAIL_OK]);
+
+ # Change the native bytes of a Perl scalar to/from UTF-8 bytes.
+ utf8::encode($string);
+ utf8::decode($string);
+
+ $flag = utf8::is_utf8(STRING); # since Perl 5.8.1
+ $flag = utf8::valid(STRING);
+
+=head1 DESCRIPTION
+
+The C<use utf8> pragma tells the Perl parser to allow UTF-8 in the
+program text in the current lexical scope (allow UTF-EBCDIC on EBCDIC based
+platforms). The C<no utf8> pragma tells Perl to switch back to treating
+the source text as literal bytes in the current lexical scope.
+
+This pragma is primarily a compatibility device. Perl versions
+earlier than 5.6 allowed arbitrary bytes in source code, whereas
+in future we would like to standardize on the UTF-8 encoding for
+source text.
+
+B<Do not use this pragma for anything else than telling Perl that your
+script is written in UTF-8.> The utility functions described below are
+useful for their own purposes, but they are not really part of the
+"pragmatic" effect.
+
+Until UTF-8 becomes the default format for source text, either this
+pragma or the L<encoding> pragma should be used to recognize UTF-8
+in the source. When UTF-8 becomes the standard source format, this
+pragma will effectively become a no-op. For convenience in what
+follows the term I<UTF-X> is used to refer to UTF-8 on ASCII and ISO
+Latin based platforms and UTF-EBCDIC on EBCDIC based platforms.
+
+See also the effects of the C<-C> switch and its cousin, the
+C<$ENV{PERL_UNICODE}>, in L<perlrun>.
+
+Enabling the C<utf8> pragma has the following effect:
+
+=over 4
+
+=item *
+
+Bytes in the source text that have their high-bit set will be treated
+as being part of a literal UTF-8 character. This includes most
+literals such as identifier names, string constants, and constant
+regular expression patterns.
+
+On EBCDIC platforms characters in the Latin 1 character set are
+treated as being part of a literal UTF-EBCDIC character.
+
+=back
+
+Note that if you have bytes with the eighth bit on in your script
+(for example embedded Latin-1 in your string literals), C<use utf8>
+will be unhappy since the bytes are most probably not well-formed
+UTF-8. If you want to have such bytes and use utf8, you can disable
+utf8 until the end the block (or file, if at top level) by C<no utf8;>.
+
+If you want to automatically upgrade your 8-bit legacy bytes to UTF-8,
+use the L<encoding> pragma instead of this pragma. For example, if
+you want to implicitly upgrade your ISO 8859-1 (Latin-1) bytes to UTF-8
+as used in e.g. C<chr()> and C<\x{...}>, try this:
+
+ use encoding "latin-1";
+ my $c = chr(0xc4);
+ my $x = "\x{c5}";
+
+In case you are wondering: yes, C<use encoding 'utf8';> works much
+the same as C<use utf8;>.
+
+=head2 Utility functions
+
+The following functions are defined in the C<utf8::> package by the
+Perl core. You do not need to say C<use utf8> to use these and in fact
+you should not say that unless you really want to have UTF-8 source code.
+
+=over 4
+
+=item * $num_octets = utf8::upgrade($string)
+
+Converts in-place the octet sequence in the native encoding
+(Latin-1 or EBCDIC) to the equivalent character sequence in I<UTF-X>.
+I<$string> already encoded as characters does no harm.
+Returns the number of octets necessary to represent the string as I<UTF-X>.
+Can be used to make sure that the UTF-8 flag is on,
+so that C<\w> or C<lc()> work as Unicode on strings
+containing characters in the range 0x80-0xFF (on ASCII and
+derivatives).
+
+B<Note that this function does not handle arbitrary encodings.>
+Therefore I<Encode.pm> is recommended for the general purposes.
+
+Affected by the encoding pragma.
+
+=item * $success = utf8::downgrade($string[, FAIL_OK])
+
+Converts in-place the character sequence in I<UTF-X>
+to the equivalent octet sequence in the native encoding (Latin-1 or EBCDIC).
+I<$string> already encoded as octets does no harm.
+Returns true on success. On failure dies or, if the value of
+C<FAIL_OK> is true, returns false.
+Can be used to make sure that the UTF-8 flag is off,
+e.g. when you want to make sure that the substr() or length() function
+works with the usually faster byte algorithm.
+
+B<Note that this function does not handle arbitrary encodings.>
+Therefore I<Encode.pm> is recommended for the general purposes.
+
+B<Not> affected by the encoding pragma.
+
+B<NOTE:> this function is experimental and may change
+or be removed without notice.
+
+=item * utf8::encode($string)
+
+Converts in-place the character sequence to the corresponding octet sequence
+in I<UTF-X>. The UTF-8 flag is turned off. Returns nothing.
+
+B<Note that this function does not handle arbitrary encodings.>
+Therefore I<Encode.pm> is recommended for the general purposes.
+
+=item * utf8::decode($string)
+
+Attempts to convert in-place the octet sequence in I<UTF-X>
+to the corresponding character sequence. The UTF-8 flag is turned on
+only if the source string contains multiple-byte I<UTF-X> characters.
+If I<$string> is invalid as I<UTF-X>, returns false; otherwise returns true.
+
+B<Note that this function does not handle arbitrary encodings.>
+Therefore I<Encode.pm> is recommended for the general purposes.
+
+B<NOTE:> this function is experimental and may change
+or be removed without notice.
+
+=item * $flag = utf8::is_utf8(STRING)
+
+(Since Perl 5.8.1) Test whether STRING is in UTF-8. Functionally
+the same as Encode::is_utf8().
+
+=item * $flag = utf8::valid(STRING)
+
+[INTERNAL] Test whether STRING is in a consistent state regarding
+UTF-8. Will return true is well-formed UTF-8 and has the UTF-8 flag
+on B<or> if string is held as bytes (both these states are 'consistent').
+Main reason for this routine is to allow Perl's testsuite to check
+that operations have left strings in a consistent state. You most
+probably want to use utf8::is_utf8() instead.
+
+=back
+
+C<utf8::encode> is like C<utf8::upgrade>, but the UTF8 flag is
+cleared. See L<perlunicode> for more on the UTF8 flag and the C API
+functions C<sv_utf8_upgrade>, C<sv_utf8_downgrade>, C<sv_utf8_encode>,
+and C<sv_utf8_decode>, which are wrapped by the Perl functions
+C<utf8::upgrade>, C<utf8::downgrade>, C<utf8::encode> and
+C<utf8::decode>. Note that in the Perl 5.8.0 and 5.8.1 implementation
+the functions utf8::is_utf8, utf8::valid, utf8::encode, utf8::decode,
+utf8::upgrade, and utf8::downgrade are always available, without a
+C<require utf8> statement-- this may change in future releases.
+
+=head1 BUGS
+
+One can have Unicode in identifier names, but not in package/class or
+subroutine names. While some limited functionality towards this does
+exist as of Perl 5.8.0, that is more accidental than designed; use of
+Unicode for the said purposes is unsupported.
+
+One reason of this unfinishedness is its (currently) inherent
+unportability: since both package names and subroutine names may need
+to be mapped to file and directory names, the Unicode capability of
+the filesystem becomes important-- and there unfortunately aren't
+portable answers.
+
+=head1 SEE ALSO
+
+L<perluniintro>, L<encoding>, L<perlrun>, L<bytes>, L<perlunicode>
+
+=cut
diff --git a/Master/tlpkg/installer/perllib/utf8_heavy.pl b/Master/tlpkg/installer/perllib/utf8_heavy.pl
new file mode 100644
index 00000000000..b6fdeb997b3
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/utf8_heavy.pl
@@ -0,0 +1,412 @@
+package utf8;
+use strict;
+use warnings;
+
+sub DEBUG () { 0 }
+
+sub DESTROY {}
+
+my %Cache;
+
+our (%PropertyAlias, %PA_reverse, %PropValueAlias, %PVA_reverse, %PVA_abbr_map);
+
+sub croak { require Carp; Carp::croak(@_) }
+
+##
+## "SWASH" == "SWATCH HASH". A "swatch" is a swatch of the Unicode landscape.
+## It's a data structure that encodes a set of Unicode characters.
+##
+
+sub SWASHNEW {
+ my ($class, $type, $list, $minbits, $none) = @_;
+ local $^D = 0 if $^D;
+
+ print STDERR "SWASHNEW @_\n" if DEBUG;
+
+ ##
+ ## Get the list of codepoints for the type.
+ ## Called from utf8.c
+ ##
+ ## Given a $type, our goal is to fill $list with the set of codepoint
+ ## ranges.
+ ##
+ ## To make the parsing of $type clear, this code takes the a rather
+ ## unorthodox approach of last'ing out of the block once we have the
+ ## info we need. Were this to be a subroutine, the 'last' would just
+ ## be a 'return'.
+ ##
+ my $file; ## file to load data from, and also part of the %Cache key.
+ my $ListSorted = 0;
+
+ if ($type)
+ {
+ $type =~ s/^\s+//;
+ $type =~ s/\s+$//;
+
+ print "type = $type\n" if DEBUG;
+
+ GETFILE:
+ {
+ ##
+ ## It could be a user-defined property.
+ ##
+
+ my $caller1 = $type =~ s/(.+)::// ? $1 : caller(1);
+
+ if (defined $caller1 && $type =~ /^(?:\w+)$/) {
+ my $prop = "${caller1}::$type";
+ if (exists &{$prop}) {
+ no strict 'refs';
+
+ $list = &{$prop};
+ last GETFILE;
+ }
+ }
+
+ my $wasIs;
+
+ ($wasIs = $type =~ s/^Is(?:\s+|[-_])?//i)
+ or
+ $type =~ s/^(?:(?:General(?:\s+|_)?)?Category|gc)\s*[:=]\s*//i
+ or
+ $type =~ s/^(?:Script|sc)\s*[:=]\s*//i
+ or
+ $type =~ s/^Block\s*[:=]\s*/In/i;
+
+
+ ##
+ ## See if it's in some enumeration.
+ ##
+ require "unicore/PVA.pl";
+ if ($type =~ /^([\w\s]+)[:=]\s*(.*)/) {
+ my ($enum, $val) = (lc $1, lc $2);
+ $enum =~ tr/ _-//d;
+ $val =~ tr/ _-//d;
+
+ my $pa = $PropertyAlias{$enum} ? $enum : $PA_reverse{$enum};
+ my $f = $PropValueAlias{$pa}{$val} ? $val : $PVA_reverse{$pa}{lc $val};
+
+ if ($pa and $f) {
+ $pa = "gc_sc" if $pa eq "gc" or $pa eq "sc";
+ $file = "unicore/lib/$pa/$PVA_abbr_map{$pa}{lc $f}.pl";
+ last GETFILE;
+ }
+ }
+ else {
+ my $t = lc $type;
+ $t =~ tr/ _-//d;
+
+ if ($PropValueAlias{gc}{$t} or $PropValueAlias{sc}{$t}) {
+ $file = "unicore/lib/gc_sc/$PVA_abbr_map{gc_sc}{$t}.pl";
+ last GETFILE;
+ }
+ }
+
+ ##
+ ## See if it's in the direct mapping table.
+ ##
+ require "unicore/Exact.pl";
+ if (my $base = $utf8::Exact{$type}) {
+ $file = "unicore/lib/gc_sc/$base.pl";
+ last GETFILE;
+ }
+
+ ##
+ ## If not there exactly, try the canonical form. The canonical
+ ## form is lowercased, with any separators (\s+|[-_]) removed.
+ ##
+ my $canonical = lc $type;
+ $canonical =~ s/(?<=[a-z\d])(?:\s+|[-_])(?=[a-z\d])//g;
+ print "canonical = $canonical\n" if DEBUG;
+
+ require "unicore/Canonical.pl";
+ if (my $base = ($utf8::Canonical{$canonical} || $utf8::Canonical{ lc $utf8::PropertyAlias{$canonical} })) {
+ $file = "unicore/lib/gc_sc/$base.pl";
+ last GETFILE;
+ }
+
+ ##
+ ## See if it's a user-level "To".
+ ##
+
+ my $caller0 = caller(0);
+
+ if (defined $caller0 && $type =~ /^To(?:\w+)$/) {
+ my $map = $caller0 . "::" . $type;
+
+ if (exists &{$map}) {
+ no strict 'refs';
+
+ $list = &{$map};
+ last GETFILE;
+ }
+ }
+
+ ##
+ ## Last attempt -- see if it's a standard "To" name
+ ## (e.g. "ToLower") ToTitle is used by ucfirst().
+ ## The user-level way to access ToDigit() and ToFold()
+ ## is to use Unicode::UCD.
+ ##
+ if ($type =~ /^To(Digit|Fold|Lower|Title|Upper)$/)
+ {
+ $file = "unicore/To/$1.pl";
+ ## would like to test to see if $file actually exists....
+ last GETFILE;
+ }
+
+ ##
+ ## If we reach this line, it's because we couldn't figure
+ ## out what to do with $type. Ouch.
+ ##
+
+ return $type;
+ }
+
+ if (defined $file) {
+ print "found it (file='$file')\n" if DEBUG;
+
+ ##
+ ## If we reach here, it was due to a 'last GETFILE' above
+ ## (exception: user-defined properties and mappings), so we
+ ## have a filename, so now we load it if we haven't already.
+ ## If we have, return the cached results. The cache key is the
+ ## file to load.
+ ##
+ if ($Cache{$file} and ref($Cache{$file}) eq $class)
+ {
+ print "Returning cached '$file' for \\p{$type}\n" if DEBUG;
+ return $Cache{$class, $file};
+ }
+
+ $list = do $file;
+ }
+
+ $ListSorted = 1; ## we know that these lists are sorted
+ }
+
+ my $extras;
+ my $bits = 0;
+
+ my $ORIG = $list;
+ if ($list) {
+ my @tmp = split(/^/m, $list);
+ my %seen;
+ no warnings;
+ $extras = join '', grep /^[^0-9a-fA-F]/, @tmp;
+ $list = join '',
+ map { $_->[1] }
+ sort { $a->[0] <=> $b->[0] }
+ map { /^([0-9a-fA-F]+)/; [ hex($1), $_ ] }
+ grep { /^([0-9a-fA-F]+)/ and not $seen{$1}++ } @tmp; # XXX doesn't do ranges right
+ }
+
+ if ($none) {
+ my $hextra = sprintf "%04x", $none + 1;
+ $list =~ s/\tXXXX$/\t$hextra/mg;
+ }
+
+ if ($minbits < 32) {
+ my $top = 0;
+ while ($list =~ /^([0-9a-fA-F]+)(?:[\t]([0-9a-fA-F]+)?)(?:[ \t]([0-9a-fA-F]+))?/mg) {
+ my $min = hex $1;
+ my $max = defined $2 ? hex $2 : $min;
+ my $val = defined $3 ? hex $3 : 0;
+ $val += $max - $min if defined $3;
+ $top = $val if $val > $top;
+ }
+ $bits =
+ $top > 0xffff ? 32 :
+ $top > 0xff ? 16 :
+ $top > 1 ? 8 : 1
+ }
+ $bits = $minbits if $bits < $minbits;
+
+ my @extras;
+ for my $x ($extras) {
+ pos $x = 0;
+ while ($x =~ /^([^0-9a-fA-F\n])(.*)/mg) {
+ my $char = $1;
+ my $name = $2;
+ print STDERR "$1 => $2\n" if DEBUG;
+ if ($char =~ /[-+!&]/) {
+ my ($c,$t) = split(/::/, $name, 2); # bogus use of ::, really
+ my $subobj;
+ if ($c eq 'utf8') {
+ $subobj = utf8->SWASHNEW($t, "", 0, 0, 0);
+ }
+ elsif (exists &$name) {
+ $subobj = utf8->SWASHNEW($name, "", 0, 0, 0);
+ }
+ elsif ($c =~ /^([0-9a-fA-F]+)/) {
+ $subobj = utf8->SWASHNEW("", $c, 0, 0, 0);
+ }
+ return $subobj unless ref $subobj;
+ push @extras, $name => $subobj;
+ $bits = $subobj->{BITS} if $bits < $subobj->{BITS};
+ }
+ }
+ }
+
+ print STDERR "CLASS = $class, TYPE => $type, BITS => $bits, NONE => $none\nEXTRAS =>\n$extras\nLIST =>\n$list\n" if DEBUG;
+
+ my $SWASH = bless {
+ TYPE => $type,
+ BITS => $bits,
+ EXTRAS => $extras,
+ LIST => $list,
+ NONE => $none,
+ @extras,
+ } => $class;
+
+ if ($file) {
+ $Cache{$class, $file} = $SWASH;
+ }
+
+ return $SWASH;
+}
+
+# NOTE: utf8.c:swash_init() assumes entries are never modified once generated.
+
+sub SWASHGET {
+ # See utf8.c:Perl_swash_fetch for problems with this interface.
+ my ($self, $start, $len) = @_;
+ local $^D = 0 if $^D;
+ my $type = $self->{TYPE};
+ my $bits = $self->{BITS};
+ my $none = $self->{NONE};
+ print STDERR "SWASHGET @_ [$type/$bits/$none]\n" if DEBUG;
+ my $end = $start + $len;
+ my $swatch = "";
+ my $key;
+ vec($swatch, $len - 1, $bits) = 0; # Extend to correct length.
+ if ($none) {
+ for $key (0 .. $len - 1) { vec($swatch, $key, $bits) = $none }
+ }
+
+ for ($self->{LIST}) {
+ pos $_ = 0;
+ if ($bits > 1) {
+ LINE:
+ while (/^([0-9a-fA-F]+)(?:[ \t]([0-9a-fA-F]+)?)?(?:[ \t]([0-9a-fA-F]+))?/mg) {
+ chomp;
+ my ($a, $b, $c) = ($1, $2, $3);
+ croak "$type: illegal mapping '$_'"
+ if $type =~ /^To/ &&
+ !(defined $a && defined $c);
+ my $min = hex $a;
+ my $max = defined $b ? hex $b : $min;
+ my $val = defined $c ? hex $c : 0;
+ next if $max < $start;
+ print "$min $max $val\n" if DEBUG;
+ if ($none) {
+ if ($min < $start) {
+ $val += $start - $min if $val < $none;
+ $min = $start;
+ }
+ for ($key = $min; $key <= $max; $key++) {
+ last LINE if $key >= $end;
+ print STDERR "$key => $val\n" if DEBUG;
+ vec($swatch, $key - $start, $bits) = $val;
+ ++$val if $val < $none;
+ }
+ }
+ else {
+ if ($min < $start) {
+ $val += $start - $min;
+ $min = $start;
+ }
+ for ($key = $min; $key <= $max; $key++, $val++) {
+ last LINE if $key >= $end;
+ print STDERR "$key => $val\n" if DEBUG;
+ vec($swatch, $key - $start, $bits) = $val;
+ }
+ }
+ }
+ }
+ else {
+ LINE:
+ while (/^([0-9a-fA-F]+)(?:[ \t]+([0-9a-fA-F]+))?/mg) {
+ chomp;
+ my $min = hex $1;
+ my $max = defined $2 ? hex $2 : $min;
+ next if $max < $start;
+ if ($min < $start) {
+ $min = $start;
+ }
+ for ($key = $min; $key <= $max; $key++) {
+ last LINE if $key >= $end;
+ print STDERR "$key => 1\n" if DEBUG;
+ vec($swatch, $key - $start, 1) = 1;
+ }
+ }
+ }
+ }
+ for my $x ($self->{EXTRAS}) {
+ pos $x = 0;
+ while ($x =~ /^([-+!&])(.*)/mg) {
+ my $char = $1;
+ my $name = $2;
+ print STDERR "INDIRECT $1 $2\n" if DEBUG;
+ my $otherbits = $self->{$name}->{BITS};
+ croak("SWASHGET size mismatch") if $bits < $otherbits;
+ my $other = $self->{$name}->SWASHGET($start, $len);
+ if ($char eq '+') {
+ if ($bits == 1 and $otherbits == 1) {
+ $swatch |= $other;
+ }
+ else {
+ for ($key = 0; $key < $len; $key++) {
+ vec($swatch, $key, $bits) = vec($other, $key, $otherbits);
+ }
+ }
+ }
+ elsif ($char eq '!') {
+ if ($bits == 1 and $otherbits == 1) {
+ $swatch |= ~$other;
+ }
+ else {
+ for ($key = 0; $key < $len; $key++) {
+ if (!vec($other, $key, $otherbits)) {
+ vec($swatch, $key, $bits) = 1;
+ }
+ }
+ }
+ }
+ elsif ($char eq '-') {
+ if ($bits == 1 and $otherbits == 1) {
+ $swatch &= ~$other;
+ }
+ else {
+ for ($key = 0; $key < $len; $key++) {
+ if (vec($other, $key, $otherbits)) {
+ vec($swatch, $key, $bits) = 0;
+ }
+ }
+ }
+ }
+ elsif ($char eq '&') {
+ if ($bits == 1 and $otherbits == 1) {
+ $swatch &= $other;
+ }
+ else {
+ for ($key = 0; $key < $len; $key++) {
+ if (!vec($other, $key, $otherbits)) {
+ vec($swatch, $key, $bits) = 0;
+ }
+ }
+ }
+ }
+ }
+ }
+ if (DEBUG) {
+ print STDERR "CELLS ";
+ for ($key = 0; $key < $len; $key++) {
+ print STDERR vec($swatch, $key, $bits), " ";
+ }
+ print STDERR "\n";
+ }
+ $swatch;
+}
+
+1;
diff --git a/Master/tlpkg/installer/perllib/vars.pm b/Master/tlpkg/installer/perllib/vars.pm
new file mode 100644
index 00000000000..a0151b84030
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/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/installer/perllib/warnings.pm b/Master/tlpkg/installer/perllib/warnings.pm
new file mode 100644
index 00000000000..e43b686c908
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/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/installer/perllib/warnings/register.pm b/Master/tlpkg/installer/perllib/warnings/register.pm
new file mode 100644
index 00000000000..57c865df522
--- /dev/null
+++ b/Master/tlpkg/installer/perllib/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;