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