summaryrefslogtreecommitdiff
path: root/Master/tlpkg/lib
diff options
context:
space:
mode:
authorReinhard Kotucha <reinhard.kotucha@web.de>2008-01-13 07:32:42 +0000
committerReinhard Kotucha <reinhard.kotucha@web.de>2008-01-13 07:32:42 +0000
commitfd9ca8975520bac8e5cd6581ae75cd7d94233d7b (patch)
tree1d6a138de2b600d68fe583c71eded3ff5f819283 /Master/tlpkg/lib
parentef8b0a46e71789a03ca3e059dfc4441898978e63 (diff)
Perl5_lib-TL_inst: added Tk modules.
git-svn-id: svn://tug.org/texlive/trunk@6204 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/lib')
-rw-r--r--Master/tlpkg/lib/Perl5_lib-TL_inst/Cwd.pm710
-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/Symbol.pm170
-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/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/DummyEncode.pm46
-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/Pretty.pm93
-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/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.dllbin0 -> 10240 bytes
-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.dllbin0 -> 112640 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.dllbin0 -> 30208 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.dllbin0 -> 17920 bytes
-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.dllbin0 -> 56832 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/Tk.bs0
-rwxr-xr-xMaster/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Tk.dllbin0 -> 804864 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/autosplit.ix14
-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/base.pm226
-rw-r--r--Master/tlpkg/lib/Perl5_lib-TL_inst/bytes.pm88
-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/utf8.pm214
-rw-r--r--Master/tlpkg/lib/Perl5_lib-TL_inst/utf8_heavy.pl412
53 files changed, 13992 insertions, 0 deletions
diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Cwd.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Cwd.pm
new file mode 100644
index 00000000000..8d25af9f7cd
--- /dev/null
+++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/Cwd.pm
@@ -0,0 +1,710 @@
+package Cwd;
+
+=head1 NAME
+
+Cwd - get pathname of current working directory
+
+=head1 SYNOPSIS
+
+ use Cwd;
+ my $dir = getcwd;
+
+ use Cwd 'abs_path';
+ my $abs_path = abs_path($file);
+
+=head1 DESCRIPTION
+
+This module provides functions for determining the pathname of the
+current working directory. It is recommended that getcwd (or another
+*cwd() function) be used in I<all> code to ensure portability.
+
+By default, it exports the functions cwd(), getcwd(), fastcwd(), and
+fastgetcwd() (and, on Win32, getdcwd()) into the caller's namespace.
+
+
+=head2 getcwd and friends
+
+Each of these functions are called without arguments and return the
+absolute path of the current working directory.
+
+=over 4
+
+=item getcwd
+
+ my $cwd = getcwd();
+
+Returns the current working directory.
+
+Re-implements the getcwd(3) (or getwd(3)) functions in Perl.
+
+=item cwd
+
+ my $cwd = cwd();
+
+The cwd() is the most natural form for the current architecture. For
+most systems it is identical to `pwd` (but without the trailing line
+terminator).
+
+=item fastcwd
+
+ my $cwd = fastcwd();
+
+A more dangerous version of getcwd(), but potentially faster.
+
+It might conceivably chdir() you out of a directory that it can't
+chdir() you back into. If fastcwd encounters a problem it will return
+undef but will probably leave you in a different directory. For a
+measure of extra security, if everything appears to have worked, the
+fastcwd() function will check that it leaves you in the same directory
+that it started in. If it has changed it will C<die> with the message
+"Unstable directory path, current directory changed
+unexpectedly". That should never happen.
+
+=item fastgetcwd
+
+ my $cwd = fastgetcwd();
+
+The fastgetcwd() function is provided as a synonym for cwd().
+
+=item getdcwd
+
+ my $cwd = getdcwd();
+ my $cwd = getdcwd('C:');
+
+The getdcwd() function is also provided on Win32 to get the current working
+directory on the specified drive, since Windows maintains a separate current
+working directory for each drive. If no drive is specified then the current
+drive is assumed.
+
+This function simply calls the Microsoft C library _getdcwd() function.
+
+=back
+
+
+=head2 abs_path and friends
+
+These functions are exported only on request. They each take a single
+argument and return the absolute pathname for it. If no argument is
+given they'll use the current working directory.
+
+=over 4
+
+=item abs_path
+
+ my $abs_path = abs_path($file);
+
+Uses the same algorithm as getcwd(). Symbolic links and relative-path
+components ("." and "..") are resolved to return the canonical
+pathname, just like realpath(3).
+
+=item realpath
+
+ my $abs_path = realpath($file);
+
+A synonym for abs_path().
+
+=item fast_abs_path
+
+ my $abs_path = fast_abs_path($file);
+
+A more dangerous, but potentially faster version of abs_path.
+
+=back
+
+=head2 $ENV{PWD}
+
+If you ask to override your chdir() built-in function,
+
+ use Cwd qw(chdir);
+
+then your PWD environment variable will be kept up to date. Note that
+it will only be kept up to date if all packages which use chdir import
+it from Cwd.
+
+
+=head1 NOTES
+
+=over 4
+
+=item *
+
+Since the path seperators are different on some operating systems ('/'
+on Unix, ':' on MacPerl, etc...) we recommend you use the File::Spec
+modules wherever portability is a concern.
+
+=item *
+
+Actually, on Mac OS, the C<getcwd()>, C<fastgetcwd()> and C<fastcwd()>
+functions are all aliases for the C<cwd()> function, which, on Mac OS,
+calls `pwd`. Likewise, the C<abs_path()> function is an alias for
+C<fast_abs_path()>.
+
+=back
+
+=head1 AUTHOR
+
+Originally by the perl5-porters.
+
+Maintained by Ken Williams <KWILLIAMS@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2004 by the Perl 5 Porters. All rights reserved.
+
+This program is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+Portions of the C code in this library are copyright (c) 1994 by the
+Regents of the University of California. All rights reserved. The
+license on this code is compatible with the licensing of the rest of
+the distribution - please see the source code in F<Cwd.xs> for the
+details.
+
+=head1 SEE ALSO
+
+L<File::chdir>
+
+=cut
+
+use strict;
+use Exporter;
+use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION);
+
+$VERSION = '3.12';
+
+@ISA = qw/ Exporter /;
+@EXPORT = qw(cwd getcwd fastcwd fastgetcwd);
+push @EXPORT, qw(getdcwd) if $^O eq 'MSWin32';
+@EXPORT_OK = qw(chdir abs_path fast_abs_path realpath fast_realpath);
+
+# sys_cwd may keep the builtin command
+
+# All the functionality of this module may provided by builtins,
+# there is no sense to process the rest of the file.
+# The best choice may be to have this in BEGIN, but how to return from BEGIN?
+
+if ($^O eq 'os2') {
+ local $^W = 0;
+
+ *cwd = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd;
+ *getcwd = \&cwd;
+ *fastgetcwd = \&cwd;
+ *fastcwd = \&cwd;
+
+ *fast_abs_path = \&sys_abspath if defined &sys_abspath;
+ *abs_path = \&fast_abs_path;
+ *realpath = \&fast_abs_path;
+ *fast_realpath = \&fast_abs_path;
+
+ return 1;
+}
+
+# If loading the XS stuff doesn't work, we can fall back to pure perl
+eval {
+ if ( $] >= 5.006 ) {
+ require XSLoader;
+ XSLoader::load( __PACKAGE__, $VERSION );
+ } else {
+ require DynaLoader;
+ push @ISA, 'DynaLoader';
+ __PACKAGE__->bootstrap( $VERSION );
+ }
+};
+
+# Must be after the DynaLoader stuff:
+$VERSION = eval $VERSION;
+
+# Big nasty table of function aliases
+my %METHOD_MAP =
+ (
+ VMS =>
+ {
+ cwd => '_vms_cwd',
+ getcwd => '_vms_cwd',
+ fastcwd => '_vms_cwd',
+ fastgetcwd => '_vms_cwd',
+ abs_path => '_vms_abs_path',
+ fast_abs_path => '_vms_abs_path',
+ },
+
+ MSWin32 =>
+ {
+ # We assume that &_NT_cwd is defined as an XSUB or in the core.
+ cwd => '_NT_cwd',
+ getcwd => '_NT_cwd',
+ fastcwd => '_NT_cwd',
+ fastgetcwd => '_NT_cwd',
+ abs_path => 'fast_abs_path',
+ realpath => 'fast_abs_path',
+ },
+
+ dos =>
+ {
+ cwd => '_dos_cwd',
+ getcwd => '_dos_cwd',
+ fastgetcwd => '_dos_cwd',
+ fastcwd => '_dos_cwd',
+ abs_path => 'fast_abs_path',
+ },
+
+ qnx =>
+ {
+ cwd => '_qnx_cwd',
+ getcwd => '_qnx_cwd',
+ fastgetcwd => '_qnx_cwd',
+ fastcwd => '_qnx_cwd',
+ abs_path => '_qnx_abs_path',
+ fast_abs_path => '_qnx_abs_path',
+ },
+
+ cygwin =>
+ {
+ getcwd => 'cwd',
+ fastgetcwd => 'cwd',
+ fastcwd => 'cwd',
+ abs_path => 'fast_abs_path',
+ realpath => 'fast_abs_path',
+ },
+
+ epoc =>
+ {
+ cwd => '_epoc_cwd',
+ getcwd => '_epoc_cwd',
+ fastgetcwd => '_epoc_cwd',
+ fastcwd => '_epoc_cwd',
+ abs_path => 'fast_abs_path',
+ },
+
+ MacOS =>
+ {
+ getcwd => 'cwd',
+ fastgetcwd => 'cwd',
+ fastcwd => 'cwd',
+ abs_path => 'fast_abs_path',
+ },
+ );
+
+$METHOD_MAP{NT} = $METHOD_MAP{MSWin32};
+$METHOD_MAP{nto} = $METHOD_MAP{qnx};
+
+
+# Find the pwd command in the expected locations. We assume these
+# are safe. This prevents _backtick_pwd() consulting $ENV{PATH}
+# so everything works under taint mode.
+my $pwd_cmd;
+foreach my $try ('/bin/pwd',
+ '/usr/bin/pwd',
+ '/QOpenSys/bin/pwd', # OS/400 PASE.
+ ) {
+
+ if( -x $try ) {
+ $pwd_cmd = $try;
+ last;
+ }
+}
+unless ($pwd_cmd) {
+ # Isn't this wrong? _backtick_pwd() will fail if somenone has
+ # pwd in their path but it is not /bin/pwd or /usr/bin/pwd?
+ # See [perl #16774]. --jhi
+ $pwd_cmd = 'pwd';
+}
+
+# Lazy-load Carp
+sub _carp { require Carp; Carp::carp(@_) }
+sub _croak { require Carp; Carp::croak(@_) }
+
+# The 'natural and safe form' for UNIX (pwd may be setuid root)
+sub _backtick_pwd {
+ # Localize %ENV entries in a way that won't create new hash keys
+ my @localize = grep exists $ENV{$_}, qw(PATH IFS CDPATH ENV BASH_ENV);
+ local @ENV{@localize};
+
+ my $cwd = `$pwd_cmd`;
+ # Belt-and-suspenders in case someone said "undef $/".
+ local $/ = "\n";
+ # `pwd` may fail e.g. if the disk is full
+ chomp($cwd) if defined $cwd;
+ $cwd;
+}
+
+# Since some ports may predefine cwd internally (e.g., NT)
+# we take care not to override an existing definition for cwd().
+
+unless ($METHOD_MAP{$^O}{cwd} or defined &cwd) {
+ # The pwd command is not available in some chroot(2)'ed environments
+ my $sep = $Config::Config{path_sep} || ':';
+ my $os = $^O; # Protect $^O from tainting
+ if( $os eq 'MacOS' || (defined $ENV{PATH} &&
+ $os ne 'MSWin32' && # no pwd on Windows
+ grep { -x "$_/pwd" } split($sep, $ENV{PATH})) )
+ {
+ *cwd = \&_backtick_pwd;
+ }
+ else {
+ *cwd = \&getcwd;
+ }
+}
+
+# set a reasonable (and very safe) default for fastgetcwd, in case it
+# isn't redefined later (20001212 rspier)
+*fastgetcwd = \&cwd;
+
+# By Brandon S. Allbery
+#
+# Usage: $cwd = getcwd();
+
+sub getcwd
+{
+ abs_path('.');
+}
+
+
+# By John Bazik
+#
+# Usage: $cwd = &fastcwd;
+#
+# This is a faster version of getcwd. It's also more dangerous because
+# you might chdir out of a directory that you can't chdir back into.
+
+sub fastcwd_ {
+ my($odev, $oino, $cdev, $cino, $tdev, $tino);
+ my(@path, $path);
+ local(*DIR);
+
+ my($orig_cdev, $orig_cino) = stat('.');
+ ($cdev, $cino) = ($orig_cdev, $orig_cino);
+ for (;;) {
+ my $direntry;
+ ($odev, $oino) = ($cdev, $cino);
+ CORE::chdir('..') || return undef;
+ ($cdev, $cino) = stat('.');
+ last if $odev == $cdev && $oino == $cino;
+ opendir(DIR, '.') || return undef;
+ for (;;) {
+ $direntry = readdir(DIR);
+ last unless defined $direntry;
+ next if $direntry eq '.';
+ next if $direntry eq '..';
+
+ ($tdev, $tino) = lstat($direntry);
+ last unless $tdev != $odev || $tino != $oino;
+ }
+ closedir(DIR);
+ return undef unless defined $direntry; # should never happen
+ unshift(@path, $direntry);
+ }
+ $path = '/' . join('/', @path);
+ if ($^O eq 'apollo') { $path = "/".$path; }
+ # At this point $path may be tainted (if tainting) and chdir would fail.
+ # Untaint it then check that we landed where we started.
+ $path =~ /^(.*)\z/s # untaint
+ && CORE::chdir($1) or return undef;
+ ($cdev, $cino) = stat('.');
+ die "Unstable directory path, current directory changed unexpectedly"
+ if $cdev != $orig_cdev || $cino != $orig_cino;
+ $path;
+}
+if (not defined &fastcwd) { *fastcwd = \&fastcwd_ }
+
+
+# Keeps track of current working directory in PWD environment var
+# Usage:
+# use Cwd 'chdir';
+# chdir $newdir;
+
+my $chdir_init = 0;
+
+sub chdir_init {
+ if ($ENV{'PWD'} and $^O ne 'os2' and $^O ne 'dos' and $^O ne 'MSWin32') {
+ my($dd,$di) = stat('.');
+ my($pd,$pi) = stat($ENV{'PWD'});
+ if (!defined $dd or !defined $pd or $di != $pi or $dd != $pd) {
+ $ENV{'PWD'} = cwd();
+ }
+ }
+ else {
+ my $wd = cwd();
+ $wd = Win32::GetFullPathName($wd) if $^O eq 'MSWin32';
+ $ENV{'PWD'} = $wd;
+ }
+ # Strip an automounter prefix (where /tmp_mnt/foo/bar == /foo/bar)
+ if ($^O ne 'MSWin32' and $ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|s) {
+ my($pd,$pi) = stat($2);
+ my($dd,$di) = stat($1);
+ if (defined $pd and defined $dd and $di == $pi and $dd == $pd) {
+ $ENV{'PWD'}="$2$3";
+ }
+ }
+ $chdir_init = 1;
+}
+
+sub chdir {
+ my $newdir = @_ ? shift : ''; # allow for no arg (chdir to HOME dir)
+ $newdir =~ s|///*|/|g unless $^O eq 'MSWin32';
+ chdir_init() unless $chdir_init;
+ my $newpwd;
+ if ($^O eq 'MSWin32') {
+ # get the full path name *before* the chdir()
+ $newpwd = Win32::GetFullPathName($newdir);
+ }
+
+ return 0 unless CORE::chdir $newdir;
+
+ if ($^O eq 'VMS') {
+ return $ENV{'PWD'} = $ENV{'DEFAULT'}
+ }
+ elsif ($^O eq 'MacOS') {
+ return $ENV{'PWD'} = cwd();
+ }
+ elsif ($^O eq 'MSWin32') {
+ $ENV{'PWD'} = $newpwd;
+ return 1;
+ }
+
+ if ($newdir =~ m#^/#s) {
+ $ENV{'PWD'} = $newdir;
+ } else {
+ my @curdir = split(m#/#,$ENV{'PWD'});
+ @curdir = ('') unless @curdir;
+ my $component;
+ foreach $component (split(m#/#, $newdir)) {
+ next if $component eq '.';
+ pop(@curdir),next if $component eq '..';
+ push(@curdir,$component);
+ }
+ $ENV{'PWD'} = join('/',@curdir) || '/';
+ }
+ 1;
+}
+
+
+sub _perl_abs_path
+{
+ my $start = @_ ? shift : '.';
+ my($dotdots, $cwd, @pst, @cst, $dir, @tst);
+
+ unless (@cst = stat( $start ))
+ {
+ _carp("stat($start): $!");
+ return '';
+ }
+
+ unless (-d _) {
+ # Make sure we can be invoked on plain files, not just directories.
+ # NOTE that this routine assumes that '/' is the only directory separator.
+
+ my ($dir, $file) = $start =~ m{^(.*)/(.+)$}
+ or return cwd() . '/' . $start;
+
+ # Can't use "-l _" here, because the previous stat was a stat(), not an lstat().
+ if (-l $start) {
+ my $link_target = readlink($start);
+ die "Can't resolve link $start: $!" unless defined $link_target;
+
+ require File::Spec;
+ $link_target = $dir . '/' . $link_target
+ unless File::Spec->file_name_is_absolute($link_target);
+
+ return abs_path($link_target);
+ }
+
+ return $dir ? abs_path($dir) . "/$file" : "/$file";
+ }
+
+ $cwd = '';
+ $dotdots = $start;
+ do
+ {
+ $dotdots .= '/..';
+ @pst = @cst;
+ local *PARENT;
+ unless (opendir(PARENT, $dotdots))
+ {
+ _carp("opendir($dotdots): $!");
+ return '';
+ }
+ unless (@cst = stat($dotdots))
+ {
+ _carp("stat($dotdots): $!");
+ closedir(PARENT);
+ return '';
+ }
+ if ($pst[0] == $cst[0] && $pst[1] == $cst[1])
+ {
+ $dir = undef;
+ }
+ else
+ {
+ do
+ {
+ unless (defined ($dir = readdir(PARENT)))
+ {
+ _carp("readdir($dotdots): $!");
+ closedir(PARENT);
+ return '';
+ }
+ $tst[0] = $pst[0]+1 unless (@tst = lstat("$dotdots/$dir"))
+ }
+ while ($dir eq '.' || $dir eq '..' || $tst[0] != $pst[0] ||
+ $tst[1] != $pst[1]);
+ }
+ $cwd = (defined $dir ? "$dir" : "" ) . "/$cwd" ;
+ closedir(PARENT);
+ } while (defined $dir);
+ chop($cwd) unless $cwd eq '/'; # drop the trailing /
+ $cwd;
+}
+
+
+my $Curdir;
+sub fast_abs_path {
+ local $ENV{PWD} = $ENV{PWD} || ''; # Guard against clobberage
+ my $cwd = getcwd();
+ require File::Spec;
+ my $path = @_ ? shift : ($Curdir ||= File::Spec->curdir);
+
+ # Detaint else we'll explode in taint mode. This is safe because
+ # we're not doing anything dangerous with it.
+ ($path) = $path =~ /(.*)/;
+ ($cwd) = $cwd =~ /(.*)/;
+
+ unless (-e $path) {
+ _croak("$path: No such file or directory");
+ }
+
+ unless (-d _) {
+ # Make sure we can be invoked on plain files, not just directories.
+
+ my ($vol, $dir, $file) = File::Spec->splitpath($path);
+ return File::Spec->catfile($cwd, $path) unless length $dir;
+
+ if (-l $path) {
+ my $link_target = readlink($path);
+ die "Can't resolve link $path: $!" unless defined $link_target;
+
+ $link_target = File::Spec->catpath($vol, $dir, $link_target)
+ unless File::Spec->file_name_is_absolute($link_target);
+
+ return fast_abs_path($link_target);
+ }
+
+ return $dir eq File::Spec->rootdir
+ ? File::Spec->catpath($vol, $dir, $file)
+ : fast_abs_path(File::Spec->catpath($vol, $dir, '')) . '/' . $file;
+ }
+
+ if (!CORE::chdir($path)) {
+ _croak("Cannot chdir to $path: $!");
+ }
+ my $realpath = getcwd();
+ if (! ((-d $cwd) && (CORE::chdir($cwd)))) {
+ _croak("Cannot chdir back to $cwd: $!");
+ }
+ $realpath;
+}
+
+# added function alias to follow principle of least surprise
+# based on previous aliasing. --tchrist 27-Jan-00
+*fast_realpath = \&fast_abs_path;
+
+
+# --- PORTING SECTION ---
+
+# VMS: $ENV{'DEFAULT'} points to default directory at all times
+# 06-Mar-1996 Charles Bailey bailey@newman.upenn.edu
+# Note: Use of Cwd::chdir() causes the logical name PWD to be defined
+# in the process logical name table as the default device and directory
+# seen by Perl. This may not be the same as the default device
+# and directory seen by DCL after Perl exits, since the effects
+# the CRTL chdir() function persist only until Perl exits.
+
+sub _vms_cwd {
+ return $ENV{'DEFAULT'};
+}
+
+sub _vms_abs_path {
+ return $ENV{'DEFAULT'} unless @_;
+
+ # may need to turn foo.dir into [.foo]
+ my $path = VMS::Filespec::pathify($_[0]);
+ $path = $_[0] unless defined $path;
+
+ return VMS::Filespec::rmsexpand($path);
+}
+
+sub _os2_cwd {
+ $ENV{'PWD'} = `cmd /c cd`;
+ chomp $ENV{'PWD'};
+ $ENV{'PWD'} =~ s:\\:/:g ;
+ return $ENV{'PWD'};
+}
+
+sub _win32_cwd {
+ $ENV{'PWD'} = Win32::GetCwd();
+ $ENV{'PWD'} =~ s:\\:/:g ;
+ return $ENV{'PWD'};
+}
+
+*_NT_cwd = defined &Win32::GetCwd ? \&_win32_cwd : \&_os2_cwd;
+
+sub _dos_cwd {
+ if (!defined &Dos::GetCwd) {
+ $ENV{'PWD'} = `command /c cd`;
+ chomp $ENV{'PWD'};
+ $ENV{'PWD'} =~ s:\\:/:g ;
+ } else {
+ $ENV{'PWD'} = Dos::GetCwd();
+ }
+ return $ENV{'PWD'};
+}
+
+sub _qnx_cwd {
+ local $ENV{PATH} = '';
+ local $ENV{CDPATH} = '';
+ local $ENV{ENV} = '';
+ $ENV{'PWD'} = `/usr/bin/fullpath -t`;
+ chomp $ENV{'PWD'};
+ return $ENV{'PWD'};
+}
+
+sub _qnx_abs_path {
+ local $ENV{PATH} = '';
+ local $ENV{CDPATH} = '';
+ local $ENV{ENV} = '';
+ my $path = @_ ? shift : '.';
+ local *REALPATH;
+
+ defined( open(REALPATH, '-|') || exec '/usr/bin/fullpath', '-t', $path ) or
+ die "Can't open /usr/bin/fullpath: $!";
+ my $realpath = <REALPATH>;
+ close REALPATH;
+ chomp $realpath;
+ return $realpath;
+}
+
+sub _epoc_cwd {
+ $ENV{'PWD'} = EPOC::getcwd();
+ return $ENV{'PWD'};
+}
+
+
+# Now that all the base-level functions are set up, alias the
+# user-level functions to the right places
+
+if (exists $METHOD_MAP{$^O}) {
+ my $map = $METHOD_MAP{$^O};
+ foreach my $name (keys %$map) {
+ local $^W = 0; # assignments trigger 'subroutine redefined' warning
+ no strict 'refs';
+ *{$name} = \&{$map->{$name}};
+ }
+}
+
+# In case the XS version doesn't load.
+*abs_path = \&_perl_abs_path unless defined &abs_path;
+
+# added function alias for those of us more
+# used to the libc function. --tchrist 27-Jan-00
+*realpath = \&abs_path;
+
+1;
diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Encode.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Encode.pm
new file mode 100644
index 00000000000..ac0123c89ec
--- /dev/null
+++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/Encode.pm
@@ -0,0 +1,851 @@
+#
+# $Id: Encode.pm,v 2.12 2005/09/08 14:17:17 dankogai Exp dankogai $
+#
+package Encode;
+use strict;
+our $VERSION = sprintf "%d.%02d", q$Revision: 2.12 $ =~ /(\d+)/g;
+sub DEBUG () { 0 }
+use XSLoader ();
+XSLoader::load(__PACKAGE__, $VERSION);
+
+require Exporter;
+use base qw/Exporter/;
+
+# Public, encouraged API is exported by default
+
+our @EXPORT = qw(
+ decode decode_utf8 encode encode_utf8
+ encodings find_encoding clone_encoding
+);
+
+our @FB_FLAGS = qw(DIE_ON_ERR WARN_ON_ERR RETURN_ON_ERR LEAVE_SRC
+ PERLQQ HTMLCREF XMLCREF STOP_AT_PARTIAL);
+our @FB_CONSTS = qw(FB_DEFAULT FB_CROAK FB_QUIET FB_WARN
+ FB_PERLQQ FB_HTMLCREF FB_XMLCREF);
+
+our @EXPORT_OK =
+ (
+ qw(
+ _utf8_off _utf8_on define_encoding from_to is_16bit is_8bit
+ is_utf8 perlio_ok resolve_alias utf8_downgrade utf8_upgrade
+ ),
+ @FB_FLAGS, @FB_CONSTS,
+ );
+
+our %EXPORT_TAGS =
+ (
+ all => [ @EXPORT, @EXPORT_OK ],
+ fallbacks => [ @FB_CONSTS ],
+ fallback_all => [ @FB_CONSTS, @FB_FLAGS ],
+ );
+
+# Documentation moved after __END__ for speed - NI-S
+
+our $ON_EBCDIC = (ord("A") == 193);
+
+use Encode::Alias;
+
+# Make a %Encoding package variable to allow a certain amount of cheating
+our %Encoding;
+our %ExtModule;
+require Encode::Config;
+eval { require Encode::ConfigLocal };
+
+sub encodings
+{
+ my $class = shift;
+ my %enc;
+ if (@_ and $_[0] eq ":all"){
+ %enc = ( %Encoding, %ExtModule );
+ }else{
+ %enc = %Encoding;
+ for my $mod (map {m/::/o ? $_ : "Encode::$_" } @_){
+ DEBUG and warn $mod;
+ for my $enc (keys %ExtModule){
+ $ExtModule{$enc} eq $mod and $enc{$enc} = $mod;
+ }
+ }
+ }
+ return
+ sort { lc $a cmp lc $b }
+ grep {!/^(?:Internal|Unicode|Guess)$/o} keys %enc;
+}
+
+sub perlio_ok{
+ my $obj = ref($_[0]) ? $_[0] : find_encoding($_[0]);
+ $obj->can("perlio_ok") and return $obj->perlio_ok();
+ return 0; # safety net
+}
+
+sub define_encoding
+{
+ my $obj = shift;
+ my $name = shift;
+ $Encoding{$name} = $obj;
+ my $lc = lc($name);
+ define_alias($lc => $obj) unless $lc eq $name;
+ while (@_){
+ my $alias = shift;
+ define_alias($alias, $obj);
+ }
+ return $obj;
+}
+
+sub getEncoding
+{
+ my ($class, $name, $skip_external) = @_;
+
+ ref($name) && $name->can('renew') and return $name;
+ exists $Encoding{$name} and return $Encoding{$name};
+ my $lc = lc $name;
+ exists $Encoding{$lc} and return $Encoding{$lc};
+
+ my $oc = $class->find_alias($name);
+ defined($oc) and return $oc;
+ $lc ne $name and $oc = $class->find_alias($lc);
+ defined($oc) and return $oc;
+
+ unless ($skip_external)
+ {
+ if (my $mod = $ExtModule{$name} || $ExtModule{$lc}){
+ $mod =~ s,::,/,g ; $mod .= '.pm';
+ eval{ require $mod; };
+ exists $Encoding{$name} and return $Encoding{$name};
+ }
+ }
+ return;
+}
+
+sub find_encoding($;$)
+{
+ my ($name, $skip_external) = @_;
+ return __PACKAGE__->getEncoding($name,$skip_external);
+}
+
+sub resolve_alias($){
+ my $obj = find_encoding(shift);
+ defined $obj and return $obj->name;
+ return;
+}
+
+sub clone_encoding($){
+ my $obj = find_encoding(shift);
+ ref $obj or return;
+ eval { require Storable };
+ $@ and return;
+ return Storable::dclone($obj);
+}
+
+sub encode($$;$)
+{
+ my ($name, $string, $check) = @_;
+ return undef unless defined $string;
+ $string .= '' if ref $string; # stringify;
+ $check ||=0;
+ my $enc = find_encoding($name);
+ unless(defined $enc){
+ require Carp;
+ Carp::croak("Unknown encoding '$name'");
+ }
+ my $octets = $enc->encode($string,$check);
+ $_[1] = $string if $check and !($check & LEAVE_SRC());
+ return $octets;
+}
+
+sub decode($$;$)
+{
+ my ($name,$octets,$check) = @_;
+ return undef unless defined $octets;
+ $octets .= '' if ref $octets;
+ $check ||=0;
+ my $enc = find_encoding($name);
+ unless(defined $enc){
+ require Carp;
+ Carp::croak("Unknown encoding '$name'");
+ }
+ my $string = $enc->decode($octets,$check);
+ $_[1] = $octets if $check and !($check & LEAVE_SRC());
+ return $string;
+}
+
+sub from_to($$$;$)
+{
+ my ($string,$from,$to,$check) = @_;
+ return undef unless defined $string;
+ $check ||=0;
+ my $f = find_encoding($from);
+ unless (defined $f){
+ require Carp;
+ Carp::croak("Unknown encoding '$from'");
+ }
+ my $t = find_encoding($to);
+ unless (defined $t){
+ require Carp;
+ Carp::croak("Unknown encoding '$to'");
+ }
+ my $uni = $f->decode($string,$check);
+ return undef if ($check && length($string));
+ $string = $t->encode($uni,$check);
+ return undef if ($check && length($uni));
+ return defined($_[0] = $string) ? length($string) : undef ;
+}
+
+sub encode_utf8($)
+{
+ my ($str) = @_;
+ utf8::encode($str);
+ return $str;
+}
+
+sub decode_utf8($;$)
+{
+ my ($str, $check) = @_;
+ if ($check){
+ return decode("utf8", $str, $check);
+ }else{
+ return decode("utf8", $str);
+ return $str;
+ }
+}
+
+predefine_encodings(1);
+
+#
+# This is to restore %Encoding if really needed;
+#
+
+sub predefine_encodings{
+ use Encode::Encoding;
+ no warnings 'redefine';
+ my $use_xs = shift;
+ if ($ON_EBCDIC) {
+ # was in Encode::UTF_EBCDIC
+ package Encode::UTF_EBCDIC;
+ push @Encode::UTF_EBCDIC::ISA, 'Encode::Encoding';
+ *decode = sub{
+ my ($obj,$str,$chk) = @_;
+ my $res = '';
+ for (my $i = 0; $i < length($str); $i++) {
+ $res .=
+ chr(utf8::unicode_to_native(ord(substr($str,$i,1))));
+ }
+ $_[1] = '' if $chk;
+ return $res;
+ };
+ *encode = sub{
+ my ($obj,$str,$chk) = @_;
+ my $res = '';
+ for (my $i = 0; $i < length($str); $i++) {
+ $res .=
+ chr(utf8::native_to_unicode(ord(substr($str,$i,1))));
+ }
+ $_[1] = '' if $chk;
+ return $res;
+ };
+ $Encode::Encoding{Unicode} =
+ bless {Name => "UTF_EBCDIC"} => "Encode::UTF_EBCDIC";
+ } else {
+ package Encode::Internal;
+ push @Encode::Internal::ISA, 'Encode::Encoding';
+ *decode = sub{
+ my ($obj,$str,$chk) = @_;
+ utf8::upgrade($str);
+ $_[1] = '' if $chk;
+ return $str;
+ };
+ *encode = \&decode;
+ $Encode::Encoding{Unicode} =
+ bless {Name => "Internal"} => "Encode::Internal";
+ }
+
+ {
+ # was in Encode::utf8
+ package Encode::utf8;
+ push @Encode::utf8::ISA, 'Encode::Encoding';
+ #
+ if ($use_xs){
+ Encode::DEBUG and warn __PACKAGE__, " XS on";
+ *decode = \&decode_xs;
+ *encode = \&encode_xs;
+ }else{
+ Encode::DEBUG and warn __PACKAGE__, " XS off";
+ *decode = sub{
+ my ($obj,$octets,$chk) = @_;
+ my $str = Encode::decode_utf8($octets);
+ if (defined $str) {
+ $_[1] = '' if $chk;
+ return $str;
+ }
+ return undef;
+ };
+ *encode = sub {
+ my ($obj,$string,$chk) = @_;
+ my $octets = Encode::encode_utf8($string);
+ $_[1] = '' if $chk;
+ return $octets;
+ };
+ }
+ *cat_decode = sub{ # ($obj, $dst, $src, $pos, $trm, $chk)
+ my ($obj, undef, undef, $pos, $trm) = @_; # currently ignores $chk
+ my ($rdst, $rsrc, $rpos) = \@_[1,2,3];
+ use bytes;
+ if ((my $npos = index($$rsrc, $trm, $pos)) >= 0) {
+ $$rdst .= substr($$rsrc, $pos, $npos - $pos + length($trm));
+ $$rpos = $npos + length($trm);
+ return 1;
+ }
+ $$rdst .= substr($$rsrc, $pos);
+ $$rpos = length($$rsrc);
+ return '';
+ };
+ $Encode::Encoding{utf8} =
+ bless {Name => "utf8"} => "Encode::utf8";
+ $Encode::Encoding{"utf-8-strict"} =
+ bless {Name => "utf-8-strict", strict_utf8 => 1 } => "Encode::utf8";
+ }
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Encode - character encodings
+
+=head1 SYNOPSIS
+
+ use Encode;
+
+=head2 Table of Contents
+
+Encode consists of a collection of modules whose details are too big
+to fit in one document. This POD itself explains the top-level APIs
+and general topics at a glance. For other topics and more details,
+see the PODs below:
+
+ Name Description
+ --------------------------------------------------------
+ Encode::Alias Alias definitions to encodings
+ Encode::Encoding Encode Implementation Base Class
+ Encode::Supported List of Supported Encodings
+ Encode::CN Simplified Chinese Encodings
+ Encode::JP Japanese Encodings
+ Encode::KR Korean Encodings
+ Encode::TW Traditional Chinese Encodings
+ --------------------------------------------------------
+
+=head1 DESCRIPTION
+
+The C<Encode> module provides the interfaces between Perl's strings
+and the rest of the system. Perl strings are sequences of
+B<characters>.
+
+The repertoire of characters that Perl can represent is at least that
+defined by the Unicode Consortium. On most platforms the ordinal
+values of the characters (as returned by C<ord(ch)>) is the "Unicode
+codepoint" for the character (the exceptions are those platforms where
+the legacy encoding is some variant of EBCDIC rather than a super-set
+of ASCII - see L<perlebcdic>).
+
+Traditionally, computer data has been moved around in 8-bit chunks
+often called "bytes". These chunks are also known as "octets" in
+networking standards. Perl is widely used to manipulate data of many
+types - not only strings of characters representing human or computer
+languages but also "binary" data being the machine's representation of
+numbers, pixels in an image - or just about anything.
+
+When Perl is processing "binary data", the programmer wants Perl to
+process "sequences of bytes". This is not a problem for Perl - as a
+byte has 256 possible values, it easily fits in Perl's much larger
+"logical character".
+
+=head2 TERMINOLOGY
+
+=over 2
+
+=item *
+
+I<character>: a character in the range 0..(2**32-1) (or more).
+(What Perl's strings are made of.)
+
+=item *
+
+I<byte>: a character in the range 0..255
+(A special case of a Perl character.)
+
+=item *
+
+I<octet>: 8 bits of data, with ordinal values 0..255
+(Term for bytes passed to or from a non-Perl context, e.g. a disk file.)
+
+=back
+
+=head1 PERL ENCODING API
+
+=over 2
+
+=item $octets = encode(ENCODING, $string [, CHECK])
+
+Encodes a string from Perl's internal form into I<ENCODING> and returns
+a sequence of octets. ENCODING can be either a canonical name or
+an alias. For encoding names and aliases, see L</"Defining Aliases">.
+For CHECK, see L</"Handling Malformed Data">.
+
+For example, to convert a string from Perl's internal format to
+iso-8859-1 (also known as Latin1),
+
+ $octets = encode("iso-8859-1", $string);
+
+B<CAVEAT>: When you run C<$octets = encode("utf8", $string)>, then $octets
+B<may not be equal to> $string. Though they both contain the same data, the utf8 flag
+for $octets is B<always> off. When you encode anything, utf8 flag of
+the result is always off, even when it contains completely valid utf8
+string. See L</"The UTF-8 flag"> below.
+
+If the $string is C<undef> then C<undef> is returned.
+
+=item $string = decode(ENCODING, $octets [, CHECK])
+
+Decodes a sequence of octets assumed to be in I<ENCODING> into Perl's
+internal form and returns the resulting string. As in encode(),
+ENCODING can be either a canonical name or an alias. For encoding names
+and aliases, see L</"Defining Aliases">. For CHECK, see
+L</"Handling Malformed Data">.
+
+For example, to convert ISO-8859-1 data to a string in Perl's internal format:
+
+ $string = decode("iso-8859-1", $octets);
+
+B<CAVEAT>: When you run C<$string = decode("utf8", $octets)>, then $string
+B<may not be equal to> $octets. Though they both contain the same data,
+the utf8 flag for $string is on unless $octets entirely consists of
+ASCII data (or EBCDIC on EBCDIC machines). See L</"The UTF-8 flag">
+below.
+
+If the $string is C<undef> then C<undef> is returned.
+
+=item [$length =] from_to($octets, FROM_ENC, TO_ENC [, CHECK])
+
+Converts B<in-place> data between two encodings. The data in $octets
+must be encoded as octets and not as characters in Perl's internal
+format. For example, to convert ISO-8859-1 data to Microsoft's CP1250
+encoding:
+
+ from_to($octets, "iso-8859-1", "cp1250");
+
+and to convert it back:
+
+ from_to($octets, "cp1250", "iso-8859-1");
+
+Note that because the conversion happens in place, the data to be
+converted cannot be a string constant; it must be a scalar variable.
+
+from_to() returns the length of the converted string in octets on
+success, I<undef> on error.
+
+B<CAVEAT>: The following operations look the same but are not quite so;
+
+ from_to($data, "iso-8859-1", "utf8"); #1
+ $data = decode("iso-8859-1", $data); #2
+
+Both #1 and #2 make $data consist of a completely valid UTF-8 string
+but only #2 turns utf8 flag on. #1 is equivalent to
+
+ $data = encode("utf8", decode("iso-8859-1", $data));
+
+See L</"The UTF-8 flag"> below.
+
+=item $octets = encode_utf8($string);
+
+Equivalent to C<$octets = encode("utf8", $string);> The characters
+that comprise $string are encoded in Perl's internal format and the
+result is returned as a sequence of octets. All possible
+characters have a UTF-8 representation so this function cannot fail.
+
+
+=item $string = decode_utf8($octets [, CHECK]);
+
+equivalent to C<$string = decode("utf8", $octets [, CHECK])>.
+The sequence of octets represented by
+$octets is decoded from UTF-8 into a sequence of logical
+characters. Not all sequences of octets form valid UTF-8 encodings, so
+it is possible for this call to fail. For CHECK, see
+L</"Handling Malformed Data">.
+
+=back
+
+=head2 Listing available encodings
+
+ use Encode;
+ @list = Encode->encodings();
+
+Returns a list of the canonical names of the available encodings that
+are loaded. To get a list of all available encodings including the
+ones that are not loaded yet, say
+
+ @all_encodings = Encode->encodings(":all");
+
+Or you can give the name of a specific module.
+
+ @with_jp = Encode->encodings("Encode::JP");
+
+When "::" is not in the name, "Encode::" is assumed.
+
+ @ebcdic = Encode->encodings("EBCDIC");
+
+To find out in detail which encodings are supported by this package,
+see L<Encode::Supported>.
+
+=head2 Defining Aliases
+
+To add a new alias to a given encoding, use:
+
+ use Encode;
+ use Encode::Alias;
+ define_alias(newName => ENCODING);
+
+After that, newName can be used as an alias for ENCODING.
+ENCODING may be either the name of an encoding or an
+I<encoding object>
+
+But before you do so, make sure the alias is nonexistent with
+C<resolve_alias()>, which returns the canonical name thereof.
+i.e.
+
+ Encode::resolve_alias("latin1") eq "iso-8859-1" # true
+ Encode::resolve_alias("iso-8859-12") # false; nonexistent
+ Encode::resolve_alias($name) eq $name # true if $name is canonical
+
+resolve_alias() does not need C<use Encode::Alias>; it can be
+exported via C<use Encode qw(resolve_alias)>.
+
+See L<Encode::Alias> for details.
+
+=head1 Encoding via PerlIO
+
+If your perl supports I<PerlIO> (which is the default), you can use a PerlIO layer to decode
+and encode directly via a filehandle. The following two examples
+are totally identical in their functionality.
+
+ # via PerlIO
+ open my $in, "<:encoding(shiftjis)", $infile or die;
+ open my $out, ">:encoding(euc-jp)", $outfile or die;
+ while(<$in>){ print $out $_; }
+
+ # via from_to
+ open my $in, "<", $infile or die;
+ open my $out, ">", $outfile or die;
+ while(<$in>){
+ from_to($_, "shiftjis", "euc-jp", 1);
+ print $out $_;
+ }
+
+Unfortunately, it may be that encodings are PerlIO-savvy. You can check
+if your encoding is supported by PerlIO by calling the C<perlio_ok>
+method.
+
+ Encode::perlio_ok("hz"); # False
+ find_encoding("euc-cn")->perlio_ok; # True where PerlIO is available
+
+ use Encode qw(perlio_ok); # exported upon request
+ perlio_ok("euc-jp")
+
+Fortunately, all encodings that come with Encode core are PerlIO-savvy
+except for hz and ISO-2022-kr. For gory details, see
+L<Encode::Encoding> and L<Encode::PerlIO>.
+
+=head1 Handling Malformed Data
+
+The optional I<CHECK> argument tells Encode what to do when it
+encounters malformed data. Without CHECK, Encode::FB_DEFAULT ( == 0 )
+is assumed.
+
+As of version 2.12 Encode supports coderef values for CHECK. See below.
+
+=over 2
+
+=item B<NOTE:> Not all encoding support this feature
+
+Some encodings ignore I<CHECK> argument. For example,
+L<Encode::Unicode> ignores I<CHECK> and it always croaks on error.
+
+=back
+
+Now here is the list of I<CHECK> values available
+
+=over 2
+
+=item I<CHECK> = Encode::FB_DEFAULT ( == 0)
+
+If I<CHECK> is 0, (en|de)code will put a I<substitution character> in
+place of a malformed character. When you encode, E<lt>subcharE<gt>
+will be used. When you decode the code point C<0xFFFD> is used. If
+the data is supposed to be UTF-8, an optional lexical warning
+(category utf8) is given.
+
+=item I<CHECK> = Encode::FB_CROAK ( == 1)
+
+If I<CHECK> is 1, methods will die on error immediately with an error
+message. Therefore, when I<CHECK> is set to 1, you should trap the
+error with eval{} unless you really want to let it die.
+
+=item I<CHECK> = Encode::FB_QUIET
+
+If I<CHECK> is set to Encode::FB_QUIET, (en|de)code will immediately
+return the portion of the data that has been processed so far when an
+error occurs. The data argument will be overwritten with everything
+after that point (that is, the unprocessed part of data). This is
+handy when you have to call decode repeatedly in the case where your
+source data may contain partial multi-byte character sequences,
+(i.e. you are reading with a fixed-width buffer). Here is a sample
+code that does exactly this:
+
+ my $buffer = ''; my $string = '';
+ while(read $fh, $buffer, 256, length($buffer)){
+ $string .= decode($encoding, $buffer, Encode::FB_QUIET);
+ # $buffer now contains the unprocessed partial character
+ }
+
+=item I<CHECK> = Encode::FB_WARN
+
+This is the same as above, except that it warns on error. Handy when
+you are debugging the mode above.
+
+=item perlqq mode (I<CHECK> = Encode::FB_PERLQQ)
+
+=item HTML charref mode (I<CHECK> = Encode::FB_HTMLCREF)
+
+=item XML charref mode (I<CHECK> = Encode::FB_XMLCREF)
+
+For encodings that are implemented by Encode::XS, CHECK ==
+Encode::FB_PERLQQ turns (en|de)code into C<perlqq> fallback mode.
+
+When you decode, C<\xI<HH>> will be inserted for a malformed character,
+where I<HH> is the hex representation of the octet that could not be
+decoded to utf8. And when you encode, C<\x{I<HHHH>}> will be inserted,
+where I<HHHH> is the Unicode ID of the character that cannot be found
+in the character repertoire of the encoding.
+
+HTML/XML character reference modes are about the same, in place of
+C<\x{I<HHHH>}>, HTML uses C<&#I<NNN>;> where I<NNN> is a decimal number and
+XML uses C<&#xI<HHHH>;> where I<HHHH> is the hexadecimal number.
+
+In Encode 2.10 or later, C<LEAVE_SRC> is also implied.
+
+=item The bitmask
+
+These modes are actually set via a bitmask. Here is how the FB_XX
+constants are laid out. You can import the FB_XX constants via
+C<use Encode qw(:fallbacks)>; you can import the generic bitmask
+constants via C<use Encode qw(:fallback_all)>.
+
+ FB_DEFAULT FB_CROAK FB_QUIET FB_WARN FB_PERLQQ
+ DIE_ON_ERR 0x0001 X
+ WARN_ON_ERR 0x0002 X
+ RETURN_ON_ERR 0x0004 X X
+ LEAVE_SRC 0x0008 X
+ PERLQQ 0x0100 X
+ HTMLCREF 0x0200
+ XMLCREF 0x0400
+
+=back
+
+=head2 coderef for CHECK
+
+As of Encode 2.12 CHECK can also be a code reference which takes the
+ord value of unmapped caharacter as an argument and returns a string
+that represents the fallback character. For instance,
+
+ $ascii = encode("ascii", $utf8, sub{ sprintf "<U+%04X>", shift });
+
+Acts like FB_PERLQQ but E<lt>U+I<XXXX>E<gt> is used instead of
+\x{I<XXXX>}.
+
+=head1 Defining Encodings
+
+To define a new encoding, use:
+
+ use Encode qw(define_encoding);
+ define_encoding($object, 'canonicalName' [, alias...]);
+
+I<canonicalName> will be associated with I<$object>. The object
+should provide the interface described in L<Encode::Encoding>.
+If more than two arguments are provided then additional
+arguments are taken as aliases for I<$object>.
+
+See L<Encode::Encoding> for more details.
+
+=head1 The UTF-8 flag
+
+Before the introduction of utf8 support in perl, The C<eq> operator
+just compared the strings represented by two scalars. Beginning with
+perl 5.8, C<eq> compares two strings with simultaneous consideration
+of I<the utf8 flag>. To explain why we made it so, I will quote page
+402 of C<Programming Perl, 3rd ed.>
+
+=over 2
+
+=item Goal #1:
+
+Old byte-oriented programs should not spontaneously break on the old
+byte-oriented data they used to work on.
+
+=item Goal #2:
+
+Old byte-oriented programs should magically start working on the new
+character-oriented data when appropriate.
+
+=item Goal #3:
+
+Programs should run just as fast in the new character-oriented mode
+as in the old byte-oriented mode.
+
+=item Goal #4:
+
+Perl should remain one language, rather than forking into a
+byte-oriented Perl and a character-oriented Perl.
+
+=back
+
+Back when C<Programming Perl, 3rd ed.> was written, not even Perl 5.6.0
+was born and many features documented in the book remained
+unimplemented for a long time. Perl 5.8 corrected this and the introduction
+of the UTF-8 flag is one of them. You can think of this perl notion as of a
+byte-oriented mode (utf8 flag off) and a character-oriented mode (utf8
+flag on).
+
+Here is how Encode takes care of the utf8 flag.
+
+=over 2
+
+=item *
+
+When you encode, the resulting utf8 flag is always off.
+
+=item *
+
+When you decode, the resulting utf8 flag is on unless you can
+unambiguously represent data. Here is the definition of
+dis-ambiguity.
+
+After C<$utf8 = decode('foo', $octet);>,
+
+ When $octet is... The utf8 flag in $utf8 is
+ ---------------------------------------------
+ In ASCII only (or EBCDIC only) OFF
+ In ISO-8859-1 ON
+ In any other Encoding ON
+ ---------------------------------------------
+
+As you see, there is one exception, In ASCII. That way you can assume
+Goal #1. And with Encode Goal #2 is assumed but you still have to be
+careful in such cases mentioned in B<CAVEAT> paragraphs.
+
+This utf8 flag is not visible in perl scripts, exactly for the same
+reason you cannot (or you I<don't have to>) see if a scalar contains a
+string, integer, or floating point number. But you can still peek
+and poke these if you will. See the section below.
+
+=back
+
+=head2 Messing with Perl's Internals
+
+The following API uses parts of Perl's internals in the current
+implementation. As such, they are efficient but may change.
+
+=over 2
+
+=item is_utf8(STRING [, CHECK])
+
+[INTERNAL] Tests whether the UTF-8 flag is turned on in the STRING.
+If CHECK is true, also checks the data in STRING for being well-formed
+UTF-8. Returns true if successful, false otherwise.
+
+As of perl 5.8.1, L<utf8> also has utf8::is_utf8().
+
+=item _utf8_on(STRING)
+
+[INTERNAL] Turns on the UTF-8 flag in STRING. The data in STRING is
+B<not> checked for being well-formed UTF-8. Do not use unless you
+B<know> that the STRING is well-formed UTF-8. Returns the previous
+state of the UTF-8 flag (so please don't treat the return value as
+indicating success or failure), or C<undef> if STRING is not a string.
+
+=item _utf8_off(STRING)
+
+[INTERNAL] Turns off the UTF-8 flag in STRING. Do not use frivolously.
+Returns the previous state of the UTF-8 flag (so please don't treat the
+return value as indicating success or failure), or C<undef> if STRING is
+not a string.
+
+=back
+
+=head1 UTF-8 vs. utf8
+
+ ....We now view strings not as sequences of bytes, but as sequences
+ of numbers in the range 0 .. 2**32-1 (or in the case of 64-bit
+ computers, 0 .. 2**64-1) -- Programming Perl, 3rd ed.
+
+That has been the perl's notion of UTF-8 but official UTF-8 is more
+strict; Its ranges is much narrower (0 .. 10FFFF), some sequences are
+not allowed (i.e. Those used in the surrogate pair, 0xFFFE, et al).
+
+Now that is overruled by Larry Wall himself.
+
+ From: Larry Wall <larry@wall.org>
+ Date: December 04, 2004 11:51:58 JST
+ To: perl-unicode@perl.org
+ Subject: Re: Make Encode.pm support the real UTF-8
+ Message-Id: <20041204025158.GA28754@wall.org>
+
+ On Fri, Dec 03, 2004 at 10:12:12PM +0000, Tim Bunce wrote:
+ : I've no problem with 'utf8' being perl's unrestricted uft8 encoding,
+ : but "UTF-8" is the name of the standard and should give the
+ : corresponding behaviour.
+
+ For what it's worth, that's how I've always kept them straight in my
+ head.
+
+ Also for what it's worth, Perl 6 will mostly default to strict but
+ make it easy to switch back to lax.
+
+ Larry
+
+Do you copy? As of Perl 5.8.7, B<UTF-8> means strict, official UTF-8
+while B<utf8> means liberal, lax, version thereof. And Encode version
+2.10 or later thus groks the difference between C<UTF-8> and C"utf8".
+
+ encode("utf8", "\x{FFFF_FFFF}", 1); # okay
+ encode("UTF-8", "\x{FFFF_FFFF}", 1); # croaks
+
+C<UTF-8> in Encode is actually a canonical name for C<utf-8-strict>.
+Yes, the hyphen between "UTF" and "8" is important. Without it Encode
+goes "liberal"
+
+ find_encoding("UTF-8")->name # is 'utf-8-strict'
+ find_encoding("utf-8")->name # ditto. names are case insensitive
+ find_encoding("utf8")->name # ditto. "_" are treated as "-"
+ find_encoding("UTF8")->name # is 'utf8'.
+
+
+=head1 SEE ALSO
+
+L<Encode::Encoding>,
+L<Encode::Supported>,
+L<Encode::PerlIO>,
+L<encoding>,
+L<perlebcdic>,
+L<perlfunc/open>,
+L<perlunicode>,
+L<utf8>,
+the Perl Unicode Mailing List E<lt>perl-unicode@perl.orgE<gt>
+
+=head1 MAINTAINER
+
+This project was originated by Nick Ing-Simmons and later maintained
+by Dan Kogai E<lt>dankogai@dan.co.jpE<gt>. See AUTHORS for a full
+list of people involved. For any questions, use
+E<lt>perl-unicode@perl.orgE<gt> so we can all share.
+
+=cut
diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Encode/Alias.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Encode/Alias.pm
new file mode 100644
index 00000000000..c0bbf69f469
--- /dev/null
+++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/Encode/Alias.pm
@@ -0,0 +1,341 @@
+package Encode::Alias;
+use strict;
+no warnings 'redefine';
+use Encode;
+our $VERSION = do { my @r = (q$Revision: 2.4 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
+sub DEBUG () { 0 }
+
+use base qw(Exporter);
+
+# Public, encouraged API is exported by default
+
+our @EXPORT =
+ qw (
+ define_alias
+ find_alias
+ );
+
+our @Alias; # ordered matching list
+our %Alias; # cached known aliases
+
+sub find_alias{
+ my $class = shift;
+ my $find = shift;
+ unless (exists $Alias{$find}) {
+ $Alias{$find} = undef; # Recursion guard
+ for (my $i=0; $i < @Alias; $i += 2){
+ my $alias = $Alias[$i];
+ my $val = $Alias[$i+1];
+ my $new;
+ if (ref($alias) eq 'Regexp' && $find =~ $alias){
+ DEBUG and warn "eval $val";
+ $new = eval $val;
+ DEBUG and $@ and warn "$val, $@";
+ }elsif (ref($alias) eq 'CODE'){
+ DEBUG and warn "$alias", "->", "($find)";
+ $new = $alias->($find);
+ }elsif (lc($find) eq lc($alias)){
+ $new = $val;
+ }
+ if (defined($new)){
+ next if $new eq $find; # avoid (direct) recursion on bugs
+ DEBUG and warn "$alias, $new";
+ my $enc = (ref($new)) ? $new : Encode::find_encoding($new);
+ if ($enc){
+ $Alias{$find} = $enc;
+ last;
+ }
+ }
+ }
+ # case insensitive search when canonical is not in all lowercase
+ # RT ticket #7835
+ unless ($Alias{$find}){
+ my $lcfind = lc($find);
+ for my $name (keys %Encode::Encoding, keys %Encode::ExtModule){
+ $lcfind eq lc($name) or next;
+ $Alias{$find} = Encode::find_encoding($name);
+ DEBUG and warn "$find => $name";
+ }
+ }
+ }
+ if (DEBUG){
+ my $name;
+ if (my $e = $Alias{$find}){
+ $name = $e->name;
+ }else{
+ $name = "";
+ }
+ warn "find_alias($class, $find)->name = $name";
+ }
+ return $Alias{$find};
+}
+
+sub define_alias{
+ while (@_){
+ my ($alias,$name) = splice(@_,0,2);
+ unshift(@Alias, $alias => $name); # newer one has precedence
+ if (ref($alias)){
+ # clear %Alias cache to allow overrides
+ my @a = keys %Alias;
+ for my $k (@a){
+ if (ref($alias) eq 'Regexp' && $k =~ $alias){
+ DEBUG and warn "delete \$Alias\{$k\}";
+ delete $Alias{$k};
+ }
+ elsif (ref($alias) eq 'CODE'){
+ DEBUG and warn "delete \$Alias\{$k\}";
+ delete $Alias{$alias->($name)};
+ }
+ }
+ }else{
+ DEBUG and warn "delete \$Alias\{$alias\}";
+ delete $Alias{$alias};
+ }
+ }
+}
+
+# Allow latin-1 style names as well
+# 0 1 2 3 4 5 6 7 8 9 10
+our @Latin2iso = ( 0, 1, 2, 3, 4, 9, 10, 13, 14, 15, 16 );
+# Allow winlatin1 style names as well
+our %Winlatin2cp = (
+ 'latin1' => 1252,
+ 'latin2' => 1250,
+ 'cyrillic' => 1251,
+ 'greek' => 1253,
+ 'turkish' => 1254,
+ 'hebrew' => 1255,
+ 'arabic' => 1256,
+ 'baltic' => 1257,
+ 'vietnamese' => 1258,
+ );
+
+init_aliases();
+
+sub undef_aliases{
+ @Alias = ();
+ %Alias = ();
+}
+
+sub init_aliases
+{
+ undef_aliases();
+ # Try all-lower-case version should all else fails
+ define_alias( qr/^(.*)$/ => '"\L$1"' );
+
+ # UTF/UCS stuff
+ define_alias( qr/^UTF-?7$/i => '"UTF-7"');
+ define_alias( qr/^UCS-?2-?LE$/i => '"UCS-2LE"' );
+ define_alias( qr/^UCS-?2-?(BE)?$/i => '"UCS-2BE"',
+ qr/^UCS-?4-?(BE|LE)?$/i => 'uc("UTF-32$1")',
+ qr/^iso-10646-1$/i => '"UCS-2BE"' );
+ define_alias( qr/^UTF-?(16|32)-?BE$/i => '"UTF-$1BE"',
+ qr/^UTF-?(16|32)-?LE$/i => '"UTF-$1LE"',
+ qr/^UTF-?(16|32)$/i => '"UTF-$1"',
+ );
+ # ASCII
+ define_alias(qr/^(?:US-?)ascii$/i => '"ascii"');
+ define_alias('C' => 'ascii');
+ define_alias(qr/\bISO[-_]?646[-_]?US$/i => '"ascii"');
+ # Allow variants of iso-8859-1 etc.
+ define_alias( qr/\biso[-_]?(\d+)[-_](\d+)$/i => '"iso-$1-$2"' );
+
+ # At least HP-UX has these.
+ define_alias( qr/\biso8859(\d+)$/i => '"iso-8859-$1"' );
+
+ # More HP stuff.
+ define_alias( qr/\b(?:hp-)?(arabic|greek|hebrew|kana|roman|thai|turkish)8$/i => '"${1}8"' );
+
+ # The Official name of ASCII.
+ define_alias( qr/\bANSI[-_]?X3\.4[-_]?1968$/i => '"ascii"' );
+
+ # This is a font issue, not an encoding issue.
+ # (The currency symbol of the Latin 1 upper half
+ # has been redefined as the euro symbol.)
+ define_alias( qr/^(.+)\@euro$/i => '"$1"' );
+
+ define_alias( qr/\b(?:iso[-_]?)?latin[-_]?(\d+)$/i
+ => 'defined $Encode::Alias::Latin2iso[$1] ? "iso-8859-$Encode::Alias::Latin2iso[$1]" : undef' );
+
+ define_alias( qr/\bwin(latin[12]|cyrillic|baltic|greek|turkish|
+ hebrew|arabic|baltic|vietnamese)$/ix =>
+ '"cp" . $Encode::Alias::Winlatin2cp{lc($1)}' );
+
+ # Common names for non-latin preferred MIME names
+ define_alias( 'ascii' => 'US-ascii',
+ 'cyrillic' => 'iso-8859-5',
+ 'arabic' => 'iso-8859-6',
+ 'greek' => 'iso-8859-7',
+ 'hebrew' => 'iso-8859-8',
+ 'thai' => 'iso-8859-11',
+ 'tis620' => 'iso-8859-11',
+ );
+
+ # At least AIX has IBM-NNN (surprisingly...) instead of cpNNN.
+ # And Microsoft has their own naming (again, surprisingly).
+ # And windows-* is registered in IANA!
+ define_alias( qr/\b(?:cp|ibm|ms|windows)[-_ ]?(\d{2,4})$/i => '"cp$1"');
+
+ # Sometimes seen with a leading zero.
+ # define_alias( qr/\bcp037\b/i => '"cp37"');
+
+ # Mac Mappings
+ # predefined in *.ucm; unneeded
+ # define_alias( qr/\bmacIcelandic$/i => '"macIceland"');
+ define_alias( qr/^mac_(.*)$/i => '"mac$1"');
+ # Ououououou. gone. They are differente!
+ # define_alias( qr/\bmacRomanian$/i => '"macRumanian"');
+
+ # Standardize on the dashed versions.
+ define_alias( qr/\bkoi8[\s\-_]*([ru])$/i => '"koi8-$1"' );
+
+ unless ($Encode::ON_EBCDIC){
+ # for Encode::CN
+ define_alias( qr/\beuc.*cn$/i => '"euc-cn"' );
+ define_alias( qr/\bcn.*euc$/i => '"euc-cn"' );
+ # define_alias( qr/\bGB[- ]?(\d+)$/i => '"euc-cn"' )
+ # CP936 doesn't have vendor-addon for GBK, so they're identical.
+ define_alias( qr/^gbk$/i => '"cp936"');
+ # This fixes gb2312 vs. euc-cn confusion, practically
+ define_alias( qr/\bGB[-_ ]?2312(?!-?raw)/i => '"euc-cn"' );
+ # for Encode::JP
+ define_alias( qr/\bjis$/i => '"7bit-jis"' );
+ define_alias( qr/\beuc.*jp$/i => '"euc-jp"' );
+ define_alias( qr/\bjp.*euc$/i => '"euc-jp"' );
+ define_alias( qr/\bujis$/i => '"euc-jp"' );
+ define_alias( qr/\bshift.*jis$/i => '"shiftjis"' );
+ define_alias( qr/\bsjis$/i => '"shiftjis"' );
+ define_alias( qr/\bwindows-31j$/i => '"cp932"' );
+ # for Encode::KR
+ define_alias( qr/\beuc.*kr$/i => '"euc-kr"' );
+ define_alias( qr/\bkr.*euc$/i => '"euc-kr"' );
+ # This fixes ksc5601 vs. euc-kr confusion, practically
+ define_alias( qr/(?:x-)?uhc$/i => '"cp949"' );
+ define_alias( qr/(?:x-)?windows-949$/i => '"cp949"' );
+ define_alias( qr/\bks_c_5601-1987$/i => '"cp949"' );
+ # for Encode::TW
+ define_alias( qr/\bbig-?5$/i => '"big5-eten"' );
+ define_alias( qr/\bbig5-?et(?:en)?$/i => '"big5-eten"' );
+ define_alias( qr/\btca[-_]?big5$/i => '"big5-eten"' );
+ define_alias( qr/\bbig5-?hk(?:scs)?$/i => '"big5-hkscs"' );
+ define_alias( qr/\bhk(?:scs)?[-_]?big5$/i => '"big5-hkscs"' );
+ }
+ # utf8 is blessed :)
+ define_alias( qr/^UTF-8$/i => '"utf-8-strict"');
+ # At last, Map white space and _ to '-'
+ define_alias( qr/^(\S+)[\s_]+(.*)$/i => '"$1-$2"' );
+}
+
+1;
+__END__
+
+# TODO: HP-UX '8' encodings arabic8 greek8 hebrew8 kana8 thai8 turkish8
+# TODO: HP-UX '15' encodings japanese15 korean15 roi15
+# TODO: Cyrillic encoding ISO-IR-111 (useful?)
+# TODO: Armenian encoding ARMSCII-8
+# TODO: Hebrew encoding ISO-8859-8-1
+# TODO: Thai encoding TCVN
+# TODO: Vietnamese encodings VPS
+# TODO: Mac Asian+African encodings: Arabic Armenian Bengali Burmese
+# ChineseSimp ChineseTrad Devanagari Ethiopic ExtArabic
+# Farsi Georgian Gujarati Gurmukhi Hebrew Japanese
+# Kannada Khmer Korean Laotian Malayalam Mongolian
+# Oriya Sinhalese Symbol Tamil Telugu Tibetan Vietnamese
+
+=head1 NAME
+
+Encode::Alias - alias definitions to encodings
+
+=head1 SYNOPSIS
+
+ use Encode;
+ use Encode::Alias;
+ define_alias( newName => ENCODING);
+
+=head1 DESCRIPTION
+
+Allows newName to be used as an alias for ENCODING. ENCODING may be
+either the name of an encoding or an encoding object (as described
+in L<Encode>).
+
+Currently I<newName> can be specified in the following ways:
+
+=over 4
+
+=item As a simple string.
+
+=item As a qr// compiled regular expression, e.g.:
+
+ define_alias( qr/^iso8859-(\d+)$/i => '"iso-8859-$1"' );
+
+In this case, if I<ENCODING> is not a reference, it is C<eval>-ed
+in order to allow C<$1> etc. to be substituted. The example is one
+way to alias names as used in X11 fonts to the MIME names for the
+iso-8859-* family. Note the double quotes inside the single quotes.
+
+(or, you don't have to do this yourself because this example is predefined)
+
+If you are using a regex here, you have to use the quotes as shown or
+it won't work. Also note that regex handling is tricky even for the
+experienced. Use this feature with caution.
+
+=item As a code reference, e.g.:
+
+ define_alias( sub {shift =~ /^iso8859-(\d+)$/i ? "iso-8859-$1" : undef } );
+
+The same effect as the example above in a different way. The coderef
+takes the alias name as an argument and returns a canonical name on
+success or undef if not. Note the second argument is not required.
+Use this with even more caution than the regex version.
+
+=back
+
+=head3 Changes in code reference aliasing
+
+As of Encode 1.87, the older form
+
+ define_alias( sub { return /^iso8859-(\d+)$/i ? "iso-8859-$1" : undef } );
+
+no longer works.
+
+Encode up to 1.86 internally used "local $_" to implement ths older
+form. But consider the code below;
+
+ use Encode;
+ $_ = "eeeee" ;
+ while (/(e)/g) {
+ my $utf = decode('aliased-encoding-name', $1);
+ print "position:",pos,"\n";
+ }
+
+Prior to Encode 1.86 this fails because of "local $_".
+
+=head2 Alias overloading
+
+You can override predefined aliases by simply applying define_alias().
+The new alias is always evaluated first, and when necessary,
+define_alias() flushes the internal cache to make the new definition
+available.
+
+ # redirect SHIFT_JIS to MS/IBM Code Page 932, which is a
+ # superset of SHIFT_JIS
+
+ define_alias( qr/shift.*jis$/i => '"cp932"' );
+ define_alias( qr/sjis$/i => '"cp932"' );
+
+If you want to zap all predefined aliases, you can use
+
+ Encode::Alias->undef_aliases;
+
+to do so. And
+
+ Encode::Alias->init_aliases;
+
+gets the factory settings back.
+
+=head1 SEE ALSO
+
+L<Encode>, L<Encode::Supported>
+
+=cut
+
diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Encode/Byte.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Encode/Byte.pm
new file mode 100644
index 00000000000..d40c1c3d9d1
--- /dev/null
+++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/Encode/Byte.pm
@@ -0,0 +1,119 @@
+package Encode::Byte;
+use Encode;
+our $VERSION = do { my @r = (q$Revision: 2.0 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
+
+use XSLoader;
+XSLoader::load(__PACKAGE__,$VERSION);
+
+1;
+__END__
+
+=head1 NAME
+
+Encode::Byte - Single Byte Encodings
+
+=head1 SYNOPSIS
+
+ use Encode qw/encode decode/;
+ $greek = encode("iso-8859-7", $utf8); # loads Encode::Byte implicitly
+ $utf8 = decode("iso-8859-7", $greek); # ditto
+
+=head1 ABSTRACT
+
+This module implements various single byte encodings. For most cases it uses
+\x80-\xff (upper half) to map non-ASCII characters. Encodings
+supported are as follows.
+
+ Canonical Alias Description
+ --------------------------------------------------------------------
+ # ISO 8859 series
+ (iso-8859-1 is in built-in)
+ iso-8859-2 latin2 [ISO]
+ iso-8859-3 latin3 [ISO]
+ iso-8859-4 latin4 [ISO]
+ iso-8859-5 [ISO]
+ iso-8859-6 [ISO]
+ iso-8859-7 [ISO]
+ iso-8859-8 [ISO]
+ iso-8859-9 latin5 [ISO]
+ iso-8859-10 latin6 [ISO]
+ iso-8859-11
+ (iso-8859-12 is nonexistent)
+ iso-8859-13 latin7 [ISO]
+ iso-8859-14 latin8 [ISO]
+ iso-8859-15 latin9 [ISO]
+ iso-8859-16 latin10 [ISO]
+
+ # Cyrillic
+ koi8-f
+ koi8-r cp878 [RFC1489]
+ koi8-u [RFC2319]
+
+ # Vietnamese
+ viscii
+
+ # all cp* are also available as ibm-*, ms-*, and windows-*
+ # also see L<http://msdn.microsoft.com/workshop/author/dhtml/reference/charsets/charset4.asp>
+
+ cp424
+ cp437
+ cp737
+ cp775
+ cp850
+ cp852
+ cp855
+ cp856
+ cp857
+ cp860
+ cp861
+ cp862
+ cp863
+ cp864
+ cp865
+ cp866
+ cp869
+ cp874
+ cp1006
+ cp1250 WinLatin2
+ cp1251 WinCyrillic
+ cp1252 WinLatin1
+ cp1253 WinGreek
+ cp1254 WinTurkish
+ cp1255 WinHebrew
+ cp1256 WinArabic
+ cp1257 WinBaltic
+ cp1258 WinVietnamese
+
+ # Macintosh
+ # Also see L<http://developer.apple.com/technotes/tn/tn1150.html>
+ MacArabic
+ MacCentralEurRoman
+ MacCroatian
+ MacCyrillic
+ MacFarsi
+ MacGreek
+ MacHebrew
+ MacIcelandic
+ MacRoman
+ MacRomanian
+ MacRumanian
+ MacSami
+ MacThai
+ MacTurkish
+ MacUkrainian
+
+ # More vendor encodings
+ AdobeStandardEncoding
+ nextstep
+ gsm0338 # used in GSM handsets
+ hp-roman8
+
+=head1 DESCRIPTION
+
+To find how to use this module in detail, see L<Encode>.
+
+=head1 SEE ALSO
+
+L<Encode>
+
+=cut
diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Encode/Config.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Encode/Config.pm
new file mode 100644
index 00000000000..d69b92d8248
--- /dev/null
+++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/Encode/Config.pm
@@ -0,0 +1,166 @@
+#
+# Demand-load module list
+#
+package Encode::Config;
+our $VERSION = do { my @r = (q$Revision: 2.1 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
+
+use strict;
+
+our %ExtModule =
+ (
+ # Encode::Byte
+ #iso-8859-1 is in Encode.pm itself
+ 'iso-8859-2' => 'Encode::Byte',
+ 'iso-8859-3' => 'Encode::Byte',
+ 'iso-8859-4' => 'Encode::Byte',
+ 'iso-8859-5' => 'Encode::Byte',
+ 'iso-8859-6' => 'Encode::Byte',
+ 'iso-8859-7' => 'Encode::Byte',
+ 'iso-8859-8' => 'Encode::Byte',
+ 'iso-8859-9' => 'Encode::Byte',
+ 'iso-8859-10' => 'Encode::Byte',
+ 'iso-8859-11' => 'Encode::Byte',
+ 'iso-8859-13' => 'Encode::Byte',
+ 'iso-8859-14' => 'Encode::Byte',
+ 'iso-8859-15' => 'Encode::Byte',
+ 'iso-8859-16' => 'Encode::Byte',
+ 'koi8-f' => 'Encode::Byte',
+ 'koi8-r' => 'Encode::Byte',
+ 'koi8-u' => 'Encode::Byte',
+ 'viscii' => 'Encode::Byte',
+ 'cp424' => 'Encode::Byte',
+ 'cp437' => 'Encode::Byte',
+ 'cp737' => 'Encode::Byte',
+ 'cp775' => 'Encode::Byte',
+ 'cp850' => 'Encode::Byte',
+ 'cp852' => 'Encode::Byte',
+ 'cp855' => 'Encode::Byte',
+ 'cp856' => 'Encode::Byte',
+ 'cp857' => 'Encode::Byte',
+ 'cp860' => 'Encode::Byte',
+ 'cp861' => 'Encode::Byte',
+ 'cp862' => 'Encode::Byte',
+ 'cp863' => 'Encode::Byte',
+ 'cp864' => 'Encode::Byte',
+ 'cp865' => 'Encode::Byte',
+ 'cp866' => 'Encode::Byte',
+ 'cp869' => 'Encode::Byte',
+ 'cp874' => 'Encode::Byte',
+ 'cp1006' => 'Encode::Byte',
+ 'cp1250' => 'Encode::Byte',
+ 'cp1251' => 'Encode::Byte',
+ 'cp1252' => 'Encode::Byte',
+ 'cp1253' => 'Encode::Byte',
+ 'cp1254' => 'Encode::Byte',
+ 'cp1255' => 'Encode::Byte',
+ 'cp1256' => 'Encode::Byte',
+ 'cp1257' => 'Encode::Byte',
+ 'cp1258' => 'Encode::Byte',
+ 'AdobeStandardEncoding' => 'Encode::Byte',
+ 'MacArabic' => 'Encode::Byte',
+ 'MacCentralEurRoman' => 'Encode::Byte',
+ 'MacCroatian' => 'Encode::Byte',
+ 'MacCyrillic' => 'Encode::Byte',
+ 'MacFarsi' => 'Encode::Byte',
+ 'MacGreek' => 'Encode::Byte',
+ 'MacHebrew' => 'Encode::Byte',
+ 'MacIcelandic' => 'Encode::Byte',
+ 'MacRoman' => 'Encode::Byte',
+ 'MacRomanian' => 'Encode::Byte',
+ 'MacRumanian' => 'Encode::Byte',
+ 'MacSami' => 'Encode::Byte',
+ 'MacThai' => 'Encode::Byte',
+ 'MacTurkish' => 'Encode::Byte',
+ 'MacUkrainian' => 'Encode::Byte',
+ 'nextstep' => 'Encode::Byte',
+ 'hp-roman8' => 'Encode::Byte',
+ 'gsm0338' => 'Encode::Byte',
+ # Encode::EBCDIC
+ 'cp37' => 'Encode::EBCDIC',
+ 'cp500' => 'Encode::EBCDIC',
+ 'cp875' => 'Encode::EBCDIC',
+ 'cp1026' => 'Encode::EBCDIC',
+ 'cp1047' => 'Encode::EBCDIC',
+ 'posix-bc' => 'Encode::EBCDIC',
+ # Encode::Symbol
+ 'dingbats' => 'Encode::Symbol',
+ 'symbol' => 'Encode::Symbol',
+ 'AdobeSymbol' => 'Encode::Symbol',
+ 'AdobeZdingbat' => 'Encode::Symbol',
+ 'MacDingbats' => 'Encode::Symbol',
+ 'MacSymbol' => 'Encode::Symbol',
+ # Encode::Unicode
+ 'UCS-2BE' => 'Encode::Unicode',
+ 'UCS-2LE' => 'Encode::Unicode',
+ 'UTF-16' => 'Encode::Unicode',
+ 'UTF-16BE' => 'Encode::Unicode',
+ 'UTF-16LE' => 'Encode::Unicode',
+ 'UTF-32' => 'Encode::Unicode',
+ 'UTF-32BE' => 'Encode::Unicode',
+ 'UTF-32LE' => 'Encode::Unicode',
+ 'UTF-7' => 'Encode::Unicode::UTF7',
+ );
+
+unless (ord("A") == 193){
+ %ExtModule =
+ (
+ %ExtModule,
+ 'euc-cn' => 'Encode::CN',
+ 'gb12345-raw' => 'Encode::CN',
+ 'gb2312-raw' => 'Encode::CN',
+ 'hz' => 'Encode::CN',
+ 'iso-ir-165' => 'Encode::CN',
+ 'cp936' => 'Encode::CN',
+ 'MacChineseSimp' => 'Encode::CN',
+
+ '7bit-jis' => 'Encode::JP',
+ 'euc-jp' => 'Encode::JP',
+ 'iso-2022-jp' => 'Encode::JP',
+ 'iso-2022-jp-1' => 'Encode::JP',
+ 'jis0201-raw' => 'Encode::JP',
+ 'jis0208-raw' => 'Encode::JP',
+ 'jis0212-raw' => 'Encode::JP',
+ 'cp932' => 'Encode::JP',
+ 'MacJapanese' => 'Encode::JP',
+ 'shiftjis' => 'Encode::JP',
+
+
+ 'euc-kr' => 'Encode::KR',
+ 'iso-2022-kr' => 'Encode::KR',
+ 'johab' => 'Encode::KR',
+ 'ksc5601-raw' => 'Encode::KR',
+ 'cp949' => 'Encode::KR',
+ 'MacKorean' => 'Encode::KR',
+
+ 'big5-eten' => 'Encode::TW',
+ 'big5-hkscs' => 'Encode::TW',
+ 'cp950' => 'Encode::TW',
+ 'MacChineseTrad' => 'Encode::TW',
+
+ #'big5plus' => 'Encode::HanExtra',
+ #'euc-tw' => 'Encode::HanExtra',
+ #'gb18030' => 'Encode::HanExtra',
+
+ 'MIME-Header' => 'Encode::MIME::Header',
+ 'MIME-B' => 'Encode::MIME::Header',
+ 'MIME-Q' => 'Encode::MIME::Header',
+
+ 'MIME-Header-ISO_2022_JP' => 'Encode::MIME::Header::ISO_2022_JP',
+ );
+}
+
+#
+# Why not export ? to keep ConfigLocal Happy!
+#
+while (my ($enc,$mod) = each %ExtModule){
+ $Encode::ExtModule{$enc} = $mod;
+}
+
+1;
+__END__
+
+=head1 NAME
+
+Encode::Config -- internally used by Encode
+
+=cut
diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Encode/Encoding.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Encode/Encoding.pm
new file mode 100644
index 00000000000..06af9fb6994
--- /dev/null
+++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/Encode/Encoding.pm
@@ -0,0 +1,341 @@
+package Encode::Encoding;
+# Base class for classes which implement encodings
+use strict;
+our $VERSION = do { my @r = (q$Revision: 2.2 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
+
+require Encode;
+
+sub DEBUG { 0 }
+sub Define
+{
+ my $obj = shift;
+ my $canonical = shift;
+ $obj = bless { Name => $canonical },$obj unless ref $obj;
+ # warn "$canonical => $obj\n";
+ Encode::define_encoding($obj, $canonical, @_);
+}
+
+sub name { return shift->{'Name'} }
+
+# sub renew { return $_[0] }
+
+sub renew {
+ my $self = shift;
+ my $clone = bless { %$self } => ref($self);
+ $clone->{renewed}++; # so the caller can see it
+ DEBUG and warn $clone->{renewed};
+ return $clone;
+}
+
+sub renewed{ return $_[0]->{renewed} || 0 }
+
+*new_sequence = \&renew;
+
+sub needs_lines { 0 };
+
+sub perlio_ok {
+ eval{ require PerlIO::encoding };
+ return $@ ? 0 : 1;
+}
+
+# (Temporary|legacy) methods
+
+sub toUnicode { shift->decode(@_) }
+sub fromUnicode { shift->encode(@_) }
+
+#
+# Needs to be overloaded or just croak
+#
+
+sub encode {
+ require Carp;
+ my $obj = shift;
+ my $class = ref($obj) ? ref($obj) : $obj;
+ Carp::croak($class . "->encode() not defined!");
+}
+
+sub decode{
+ require Carp;
+ my $obj = shift;
+ my $class = ref($obj) ? ref($obj) : $obj;
+ Carp::croak($class . "->encode() not defined!");
+}
+
+sub DESTROY {}
+
+1;
+__END__
+
+=head1 NAME
+
+Encode::Encoding - Encode Implementation Base Class
+
+=head1 SYNOPSIS
+
+ package Encode::MyEncoding;
+ use base qw(Encode::Encoding);
+
+ __PACKAGE__->Define(qw(myCanonical myAlias));
+
+=head1 DESCRIPTION
+
+As mentioned in L<Encode>, encodings are (in the current
+implementation at least) defined as objects. The mapping of encoding
+name to object is via the C<%Encode::Encoding> hash. Though you can
+directly manipulate this hash, it is strongly encouraged to use this
+base class module and add encode() and decode() methods.
+
+=head2 Methods you should implement
+
+You are strongly encouraged to implement methods below, at least
+either encode() or decode().
+
+=over 4
+
+=item -E<gt>encode($string [,$check])
+
+MUST return the octet sequence representing I<$string>.
+
+=over 2
+
+=item *
+
+If I<$check> is true, it SHOULD modify I<$string> in place to remove
+the converted part (i.e. the whole string unless there is an error).
+If perlio_ok() is true, SHOULD becomes MUST.
+
+=item *
+
+If an error occurs, it SHOULD return the octet sequence for the
+fragment of string that has been converted and modify $string in-place
+to remove the converted part leaving it starting with the problem
+fragment. If perlio_ok() is true, SHOULD becomes MUST.
+
+=item *
+
+If I<$check> is is false then C<encode> MUST make a "best effort" to
+convert the string - for example, by using a replacement character.
+
+=back
+
+=item -E<gt>decode($octets [,$check])
+
+MUST return the string that I<$octets> represents.
+
+=over 2
+
+=item *
+
+If I<$check> is true, it SHOULD modify I<$octets> in place to remove
+the converted part (i.e. the whole sequence unless there is an
+error). If perlio_ok() is true, SHOULD becomes MUST.
+
+=item *
+
+If an error occurs, it SHOULD return the fragment of string that has
+been converted and modify $octets in-place to remove the converted
+part leaving it starting with the problem fragment. If perlio_ok() is
+true, SHOULD becomes MUST.
+
+=item *
+
+If I<$check> is false then C<decode> should make a "best effort" to
+convert the string - for example by using Unicode's "\x{FFFD}" as a
+replacement character.
+
+=back
+
+=back
+
+If you want your encoding to work with L<encoding> pragma, you should
+also implement the method below.
+
+=over 4
+
+=item -E<gt>cat_decode($destination, $octets, $offset, $terminator [,$check])
+
+MUST decode I<$octets> with I<$offset> and concatenate it to I<$destination>.
+Decoding will terminate when $terminator (a string) appears in output.
+I<$offset> will be modified to the last $octets position at end of decode.
+Returns true if $terminator appears output, else returns false.
+
+=back
+
+=head2 Other methods defined in Encode::Encodings
+
+You do not have to override methods shown below unless you have to.
+
+=over 4
+
+=item -E<gt>name
+
+Predefined As:
+
+ sub name { return shift->{'Name'} }
+
+MUST return the string representing the canonical name of the encoding.
+
+=item -E<gt>renew
+
+Predefined As:
+
+ sub renew {
+ my $self = shift;
+ my $clone = bless { %$self } => ref($self);
+ $clone->{renewed}++;
+ return $clone;
+ }
+
+This method reconstructs the encoding object if necessary. If you need
+to store the state during encoding, this is where you clone your object.
+
+PerlIO ALWAYS calls this method to make sure it has its own private
+encoding object.
+
+=item -E<gt>renewed
+
+Predefined As:
+
+ sub renewed { $_[0]->{renewed} || 0 }
+
+Tells whether the object is renewed (and how many times). Some
+modules emit C<Use of uninitialized value in null operation> warning
+unless the value is numeric so return 0 for false.
+
+=item -E<gt>perlio_ok()
+
+Predefined As:
+
+ sub perlio_ok {
+ eval{ require PerlIO::encoding };
+ return $@ ? 0 : 1;
+ }
+
+If your encoding does not support PerlIO for some reasons, just;
+
+ sub perlio_ok { 0 }
+
+=item -E<gt>needs_lines()
+
+Predefined As:
+
+ sub needs_lines { 0 };
+
+If your encoding can work with PerlIO but needs line buffering, you
+MUST define this method so it returns true. 7bit ISO-2022 encodings
+are one example that needs this. When this method is missing, false
+is assumed.
+
+=back
+
+=head2 Example: Encode::ROT13
+
+ package Encode::ROT13;
+ use strict;
+ use base qw(Encode::Encoding);
+
+ __PACKAGE__->Define('rot13');
+
+ sub encode($$;$){
+ my ($obj, $str, $chk) = @_;
+ $str =~ tr/A-Za-z/N-ZA-Mn-za-m/;
+ $_[1] = '' if $chk; # this is what in-place edit means
+ return $str;
+ }
+
+ # Jr pna or ynml yvxr guvf;
+ *decode = \&encode;
+
+ 1;
+
+=head1 Why the heck Encode API is different?
+
+It should be noted that the I<$check> behaviour is different from the
+outer public API. The logic is that the "unchecked" case is useful
+when the encoding is part of a stream which may be reporting errors
+(e.g. STDERR). In such cases, it is desirable to get everything
+through somehow without causing additional errors which obscure the
+original one. Also, the encoding is best placed to know what the
+correct replacement character is, so if that is the desired behaviour
+then letting low level code do it is the most efficient.
+
+By contrast, if I<$check> is true, the scheme above allows the
+encoding to do as much as it can and tell the layer above how much
+that was. What is lacking at present is a mechanism to report what
+went wrong. The most likely interface will be an additional method
+call to the object, or perhaps (to avoid forcing per-stream objects
+on otherwise stateless encodings) an additional parameter.
+
+It is also highly desirable that encoding classes inherit from
+C<Encode::Encoding> as a base class. This allows that class to define
+additional behaviour for all encoding objects.
+
+ package Encode::MyEncoding;
+ use base qw(Encode::Encoding);
+
+ __PACKAGE__->Define(qw(myCanonical myAlias));
+
+to create an object with C<< bless {Name => ...}, $class >>, and call
+define_encoding. They inherit their C<name> method from
+C<Encode::Encoding>.
+
+=head2 Compiled Encodings
+
+For the sake of speed and efficiency, most of the encodings are now
+supported via a I<compiled form>: XS modules generated from UCM
+files. Encode provides the enc2xs tool to achieve that. Please see
+L<enc2xs> for more details.
+
+=head1 SEE ALSO
+
+L<perlmod>, L<enc2xs>
+
+=begin future
+
+=over 4
+
+=item Scheme 1
+
+The fixup routine gets passed the remaining fragment of string being
+processed. It modifies it in place to remove bytes/characters it can
+understand and returns a string used to represent them. For example:
+
+ sub fixup {
+ my $ch = substr($_[0],0,1,'');
+ return sprintf("\x{%02X}",ord($ch);
+ }
+
+This scheme is close to how the underlying C code for Encode works,
+but gives the fixup routine very little context.
+
+=item Scheme 2
+
+The fixup routine gets passed the original string, an index into
+it of the problem area, and the output string so far. It appends
+what it wants to the output string and returns a new index into the
+original string. For example:
+
+ sub fixup {
+ # my ($s,$i,$d) = @_;
+ my $ch = substr($_[0],$_[1],1);
+ $_[2] .= sprintf("\x{%02X}",ord($ch);
+ return $_[1]+1;
+ }
+
+This scheme gives maximal control to the fixup routine but is more
+complicated to code, and may require that the internals of Encode be tweaked to
+keep the original string intact.
+
+=item Other Schemes
+
+Hybrids of the above.
+
+Multiple return values rather than in-place modifications.
+
+Index into the string could be C<pos($str)> allowing C<s/\G...//>.
+
+=back
+
+=end future
+
+=cut
diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Encode/Unicode.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Encode/Unicode.pm
new file mode 100644
index 00000000000..4d0c31d82d3
--- /dev/null
+++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/Encode/Unicode.pm
@@ -0,0 +1,268 @@
+package Encode::Unicode;
+
+use strict;
+use warnings;
+no warnings 'redefine';
+
+our $VERSION = do { my @r = (q$Revision: 2.2 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
+
+use XSLoader;
+XSLoader::load(__PACKAGE__,$VERSION);
+
+#
+# Object Generator 8 transcoders all at once!
+#
+
+require Encode;
+
+our %BOM_Unknown = map {$_ => 1} qw(UTF-16 UTF-32);
+
+for my $name (qw(UTF-16 UTF-16BE UTF-16LE
+ UTF-32 UTF-32BE UTF-32LE
+ UCS-2BE UCS-2LE))
+{
+ my ($size, $endian, $ucs2, $mask);
+ $name =~ /^(\w+)-(\d+)(\w*)$/o;
+ if ($ucs2 = ($1 eq 'UCS')){
+ $size = 2;
+ }else{
+ $size = $2/8;
+ }
+ $endian = ($3 eq 'BE') ? 'n' : ($3 eq 'LE') ? 'v' : '' ;
+ $size == 4 and $endian = uc($endian);
+
+ $Encode::Encoding{$name} =
+ bless {
+ Name => $name,
+ size => $size,
+ endian => $endian,
+ ucs2 => $ucs2,
+ } => __PACKAGE__;
+}
+
+use base qw(Encode::Encoding);
+
+sub renew {
+ my $self = shift;
+ $BOM_Unknown{$self->name} or return $self;
+ my $clone = bless { %$self } => ref($self);
+ $clone->{renewed}++; # so the caller knows it is renewed.
+ return $clone;
+}
+
+# There used to be a perl implemntation of (en|de)code but with
+# XS version is ripe, perl version is zapped for optimal speed
+
+*decode = \&decode_xs;
+*encode = \&encode_xs;
+
+1;
+__END__
+
+=head1 NAME
+
+Encode::Unicode -- Various Unicode Transformation Formats
+
+=cut
+
+=head1 SYNOPSIS
+
+ use Encode qw/encode decode/;
+ $ucs2 = encode("UCS-2BE", $utf8);
+ $utf8 = decode("UCS-2BE", $ucs2);
+
+=head1 ABSTRACT
+
+This module implements all Character Encoding Schemes of Unicode that
+are officially documented by Unicode Consortium (except, of course,
+for UTF-8, which is a native format in perl).
+
+=over 4
+
+=item L<http://www.unicode.org/glossary/> says:
+
+I<Character Encoding Scheme> A character encoding form plus byte
+serialization. There are Seven character encoding schemes in Unicode:
+UTF-8, UTF-16, UTF-16BE, UTF-16LE, UTF-32 (UCS-4), UTF-32BE (UCS-4BE) and
+UTF-32LE (UCS-4LE), and UTF-7.
+
+Since UTF-7 is a 7-bit (re)encoded version of UTF-16BE, It is not part of
+Unicode's Character Encoding Scheme. It is separately implemented in
+Encode::Unicode::UTF7. For details see L<Encode::Unicode::UTF7>.
+
+=item Quick Reference
+
+ Decodes from ord(N) Encodes chr(N) to...
+ octet/char BOM S.P d800-dfff ord > 0xffff \x{1abcd} ==
+ ---------------+-----------------+------------------------------
+ UCS-2BE 2 N N is bogus Not Available
+ UCS-2LE 2 N N bogus Not Available
+ UTF-16 2/4 Y Y is S.P S.P BE/LE
+ UTF-16BE 2/4 N Y S.P S.P 0xd82a,0xdfcd
+ UTF-16LE 2 N Y S.P S.P 0x2ad8,0xcddf
+ UTF-32 4 Y - is bogus As is BE/LE
+ UTF-32BE 4 N - bogus As is 0x0001abcd
+ UTF-32LE 4 N - bogus As is 0xcdab0100
+ UTF-8 1-4 - - bogus >= 4 octets \xf0\x9a\af\8d
+ ---------------+-----------------+------------------------------
+
+=back
+
+=head1 Size, Endianness, and BOM
+
+You can categorize these CES by 3 criteria: size of each character,
+endianness, and Byte Order Mark.
+
+=head2 by size
+
+UCS-2 is a fixed-length encoding with each character taking 16 bits.
+It B<does not> support I<surrogate pairs>. When a surrogate pair
+is encountered during decode(), its place is filled with \x{FFFD}
+if I<CHECK> is 0, or the routine croaks if I<CHECK> is 1. When a
+character whose ord value is larger than 0xFFFF is encountered,
+its place is filled with \x{FFFD} if I<CHECK> is 0, or the routine
+croaks if I<CHECK> is 1.
+
+UTF-16 is almost the same as UCS-2 but it supports I<surrogate pairs>.
+When it encounters a high surrogate (0xD800-0xDBFF), it fetches the
+following low surrogate (0xDC00-0xDFFF) and C<desurrogate>s them to
+form a character. Bogus surrogates result in death. When \x{10000}
+or above is encountered during encode(), it C<ensurrogate>s them and
+pushes the surrogate pair to the output stream.
+
+UTF-32 (UCS-4) is a fixed-length encoding with each character taking 32 bits.
+Since it is 32-bit, there is no need for I<surrogate pairs>.
+
+=head2 by endianness
+
+The first (and now failed) goal of Unicode was to map all character
+repertoires into a fixed-length integer so that programmers are happy.
+Since each character is either a I<short> or I<long> in C, you have to
+pay attention to the endianness of each platform when you pass data
+to one another.
+
+Anything marked as BE is Big Endian (or network byte order) and LE is
+Little Endian (aka VAX byte order). For anything not marked either
+BE or LE, a character called Byte Order Mark (BOM) indicating the
+endianness is prepended to the string.
+
+CAVEAT: Though BOM in utf8 (\xEF\xBB\xBF) is valid, it is meaningless
+and as of this writing Encode suite just leave it as is (\x{FeFF}).
+
+=over 4
+
+=item BOM as integer when fetched in network byte order
+
+ 16 32 bits/char
+ -------------------------
+ BE 0xFeFF 0x0000FeFF
+ LE 0xFFeF 0xFFFe0000
+ -------------------------
+
+=back
+
+This modules handles the BOM as follows.
+
+=over 4
+
+=item *
+
+When BE or LE is explicitly stated as the name of encoding, BOM is
+simply treated as a normal character (ZERO WIDTH NO-BREAK SPACE).
+
+=item *
+
+When BE or LE is omitted during decode(), it checks if BOM is at the
+beginning of the string; if one is found, the endianness is set to
+what the BOM says. If no BOM is found, the routine dies.
+
+=item *
+
+When BE or LE is omitted during encode(), it returns a BE-encoded
+string with BOM prepended. So when you want to encode a whole text
+file, make sure you encode() the whole text at once, not line by line
+or each line, not file, will have a BOM prepended.
+
+=item *
+
+C<UCS-2> is an exception. Unlike others, this is an alias of UCS-2BE.
+UCS-2 is already registered by IANA and others that way.
+
+=back
+
+=head1 Surrogate Pairs
+
+To say the least, surrogate pairs were the biggest mistake of the
+Unicode Consortium. But according to the late Douglas Adams in I<The
+Hitchhiker's Guide to the Galaxy> Trilogy, C<In the beginning the
+Universe was created. This has made a lot of people very angry and
+been widely regarded as a bad move>. Their mistake was not of this
+magnitude so let's forgive them.
+
+(I don't dare make any comparison with Unicode Consortium and the
+Vogons here ;) Or, comparing Encode to Babel Fish is completely
+appropriate -- if you can only stick this into your ear :)
+
+Surrogate pairs were born when the Unicode Consortium finally
+admitted that 16 bits were not big enough to hold all the world's
+character repertoires. But they already made UCS-2 16-bit. What
+do we do?
+
+Back then, the range 0xD800-0xDFFF was not allocated. Let's split
+that range in half and use the first half to represent the C<upper
+half of a character> and the second half to represent the C<lower
+half of a character>. That way, you can represent 1024 * 1024 =
+1048576 more characters. Now we can store character ranges up to
+\x{10ffff} even with 16-bit encodings. This pair of half-character is
+now called a I<surrogate pair> and UTF-16 is the name of the encoding
+that embraces them.
+
+Here is a formula to ensurrogate a Unicode character \x{10000} and
+above;
+
+ $hi = ($uni - 0x10000) / 0x400 + 0xD800;
+ $lo = ($uni - 0x10000) % 0x400 + 0xDC00;
+
+And to desurrogate;
+
+ $uni = 0x10000 + ($hi - 0xD800) * 0x400 + ($lo - 0xDC00);
+
+Note this move has made \x{D800}-\x{DFFF} into a forbidden zone but
+perl does not prohibit the use of characters within this range. To perl,
+every one of \x{0000_0000} up to \x{ffff_ffff} (*) is I<a character>.
+
+ (*) or \x{ffff_ffff_ffff_ffff} if your perl is compiled with 64-bit
+ integer support!
+
+=head1 Error Checking
+
+Unlike most encodings which accept various ways to handle errors,
+Unicode encodings simply croaks.
+
+ % perl -MEncode -e '$_ = "\xfe\xff\xd8\xd9\xda\xdb\0\n"' \
+ -e 'Encode::from_to($_, "utf16","shift_jis", 0); print'
+ UTF-16:Malformed LO surrogate d8d9 at /path/to/Encode.pm line 184.
+ % perl -MEncode -e '$a = "BOM missing"' \
+ -e ' Encode::from_to($a, "utf16", "shift_jis", 0); print'
+ UTF-16:Unrecognised BOM 424f at /path/to/Encode.pm line 184.
+
+Unlike other encodings where mappings are not one-to-one against
+Unicode, UTFs are supposed to map 100% against one another. So Encode
+is more strict on UTFs.
+
+Consider that "division by zero" of Encode :)
+
+=head1 SEE ALSO
+
+L<Encode>, L<Encode::Unicode::UTF7>, L<http://www.unicode.org/glossary/>,
+L<http://www.unicode.org/unicode/faq/utf_bom.html>,
+
+RFC 2781 L<http://rfc.net/rfc2781.html>,
+
+The whole Unicode standard L<http://www.unicode.org/unicode/uni2book/u2.html>
+
+Ch. 15, pp. 403 of C<Programming Perl (3rd Edition)>
+by Larry Wall, Tom Christiansen, Jon Orwant;
+O'Reilly & Associates; ISBN 0-596-00027-8
+
+=cut
diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Symbol.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Symbol.pm
new file mode 100644
index 00000000000..3bb5d9240c1
--- /dev/null
+++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/Symbol.pm
@@ -0,0 +1,170 @@
+package Symbol;
+
+=head1 NAME
+
+Symbol - manipulate Perl symbols and their names
+
+=head1 SYNOPSIS
+
+ use Symbol;
+
+ $sym = gensym;
+ open($sym, "filename");
+ $_ = <$sym>;
+ # etc.
+
+ ungensym $sym; # no effect
+
+ # replace *FOO{IO} handle but not $FOO, %FOO, etc.
+ *FOO = geniosym;
+
+ print qualify("x"), "\n"; # "Test::x"
+ print qualify("x", "FOO"), "\n" # "FOO::x"
+ print qualify("BAR::x"), "\n"; # "BAR::x"
+ print qualify("BAR::x", "FOO"), "\n"; # "BAR::x"
+ print qualify("STDOUT", "FOO"), "\n"; # "main::STDOUT" (global)
+ print qualify(\*x), "\n"; # returns \*x
+ print qualify(\*x, "FOO"), "\n"; # returns \*x
+
+ use strict refs;
+ print { qualify_to_ref $fh } "foo!\n";
+ $ref = qualify_to_ref $name, $pkg;
+
+ use Symbol qw(delete_package);
+ delete_package('Foo::Bar');
+ print "deleted\n" unless exists $Foo::{'Bar::'};
+
+=head1 DESCRIPTION
+
+C<Symbol::gensym> creates an anonymous glob and returns a reference
+to it. Such a glob reference can be used as a file or directory
+handle.
+
+For backward compatibility with older implementations that didn't
+support anonymous globs, C<Symbol::ungensym> is also provided.
+But it doesn't do anything.
+
+C<Symbol::geniosym> creates an anonymous IO handle. This can be
+assigned into an existing glob without affecting the non-IO portions
+of the glob.
+
+C<Symbol::qualify> turns unqualified symbol names into qualified
+variable names (e.g. "myvar" -E<gt> "MyPackage::myvar"). If it is given a
+second parameter, C<qualify> uses it as the default package;
+otherwise, it uses the package of its caller. Regardless, global
+variable names (e.g. "STDOUT", "ENV", "SIG") are always qualified with
+"main::".
+
+Qualification applies only to symbol names (strings). References are
+left unchanged under the assumption that they are glob references,
+which are qualified by their nature.
+
+C<Symbol::qualify_to_ref> is just like C<Symbol::qualify> except that it
+returns a glob ref rather than a symbol name, so you can use the result
+even if C<use strict 'refs'> is in effect.
+
+C<Symbol::delete_package> wipes out a whole package namespace. Note
+this routine is not exported by default--you may want to import it
+explicitly.
+
+=head1 BUGS
+
+C<Symbol::delete_package> is a bit too powerful. It undefines every symbol that
+lives in the specified package. Since perl, for performance reasons, does not
+perform a symbol table lookup each time a function is called or a global
+variable is accessed, some code that has already been loaded and that makes use
+of symbols in package C<Foo> may stop working after you delete C<Foo>, even if
+you reload the C<Foo> module afterwards.
+
+=cut
+
+BEGIN { require 5.005; }
+
+require Exporter;
+@ISA = qw(Exporter);
+@EXPORT = qw(gensym ungensym qualify qualify_to_ref);
+@EXPORT_OK = qw(delete_package geniosym);
+
+$VERSION = '1.06';
+
+my $genpkg = "Symbol::";
+my $genseq = 0;
+
+my %global = map {$_ => 1} qw(ARGV ARGVOUT ENV INC SIG STDERR STDIN STDOUT);
+
+#
+# Note that we never _copy_ the glob; we just make a ref to it.
+# If we did copy it, then SVf_FAKE would be set on the copy, and
+# glob-specific behaviors (e.g. C<*$ref = \&func>) wouldn't work.
+#
+sub gensym () {
+ my $name = "GEN" . $genseq++;
+ my $ref = \*{$genpkg . $name};
+ delete $$genpkg{$name};
+ $ref;
+}
+
+sub geniosym () {
+ my $sym = gensym();
+ # force the IO slot to be filled
+ select(select $sym);
+ *$sym{IO};
+}
+
+sub ungensym ($) {}
+
+sub qualify ($;$) {
+ my ($name) = @_;
+ if (!ref($name) && index($name, '::') == -1 && index($name, "'") == -1) {
+ my $pkg;
+ # Global names: special character, "^xyz", or other.
+ if ($name =~ /^(([^a-z])|(\^[a-z_]+))\z/i || $global{$name}) {
+ # RGS 2001-11-05 : translate leading ^X to control-char
+ $name =~ s/^\^([a-z_])/'qq(\c'.$1.')'/eei;
+ $pkg = "main";
+ }
+ else {
+ $pkg = (@_ > 1) ? $_[1] : caller;
+ }
+ $name = $pkg . "::" . $name;
+ }
+ $name;
+}
+
+sub qualify_to_ref ($;$) {
+ return \*{ qualify $_[0], @_ > 1 ? $_[1] : caller };
+}
+
+#
+# of Safe.pm lineage
+#
+sub delete_package ($) {
+ my $pkg = shift;
+
+ # expand to full symbol table name if needed
+
+ unless ($pkg =~ /^main::.*::$/) {
+ $pkg = "main$pkg" if $pkg =~ /^::/;
+ $pkg = "main::$pkg" unless $pkg =~ /^main::/;
+ $pkg .= '::' unless $pkg =~ /::$/;
+ }
+
+ my($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
+ my $stem_symtab = *{$stem}{HASH};
+ return unless defined $stem_symtab and exists $stem_symtab->{$leaf};
+
+
+ # free all the symbols in the package
+
+ my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
+ foreach my $name (keys %$leaf_symtab) {
+ undef *{$pkg . $name};
+ }
+
+ # delete the symbol table
+
+ %$leaf_symtab = ();
+ delete $stem_symtab->{$leaf};
+}
+
+1;
diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk.pm
new file mode 100644
index 00000000000..deb453172eb
--- /dev/null
+++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk.pm
@@ -0,0 +1,821 @@
+#
+# Copyright (c) 1992-1994 The Regents of the University of California.
+# Copyright (c) 1994 Sun Microsystems, Inc.
+# Copyright (c) 1995-2004 Nick Ing-Simmons. All rights reserved.
+# This program is free software; you can redistribute it and/or
+
+# modify it under the same terms as Perl itself, subject
+# to additional disclaimer in Tk/license.terms due to partial
+# derivation from Tk8.0 sources.
+#
+package Tk;
+require 5.007;
+use Tk::Event ();
+use AutoLoader qw(AUTOLOAD);
+use DynaLoader;
+use Cwd();
+use base qw(Exporter DynaLoader);
+
+*fileevent = \&Tk::Event::IO::fileevent;
+
+use Encode;
+$Tk::encodeStopOnError = Encode::FB_QUIET();
+$Tk::encodeFallback = Encode::FB_PERLQQ(); # Encode::FB_DEFAULT();
+
+our %font_encoding = ('jis0208' => 'jis0208-raw',
+ 'jis0212' => 'jis0212-raw',
+ 'ksc5601' => 'ksc5601-raw',
+ 'gb2312' => 'gb2312-raw',
+ 'unicode' => 'ucs-2le',
+ );
+
+BEGIN {
+ if($^O eq 'cygwin')
+ {
+ require Tk::Config;
+ $Tk::platform = $Tk::Config::win_arch;
+ $Tk::platform = 'unix' if $Tk::platform eq 'x';
+ }
+ else
+ {
+ $Tk::platform = ($^O eq 'MSWin32') ? $^O : 'unix';
+ }
+};
+
+$Tk::tearoff = 1 if ($Tk::platform eq 'unix');
+
+
+@EXPORT = qw(Exists Ev exit MainLoop DoOneEvent tkinit);
+@EXPORT_OK = qw(NoOp after *widget *event lsearch catch $XS_VERSION
+ DONT_WAIT WINDOW_EVENTS FILE_EVENTS TIMER_EVENTS
+ IDLE_EVENTS ALL_EVENTS
+ NORMAL_BG ACTIVE_BG SELECT_BG
+ SELECT_FG TROUGH INDICATOR DISABLED BLACK WHITE);
+%EXPORT_TAGS = (eventtypes => [qw(DONT_WAIT WINDOW_EVENTS FILE_EVENTS
+ TIMER_EVENTS IDLE_EVENTS ALL_EVENTS)],
+ variables => [qw(*widget *event)],
+ colors => [qw(NORMAL_BG ACTIVE_BG SELECT_BG SELECT_FG
+ TROUGH INDICATOR DISABLED BLACK WHITE)],
+ );
+
+use strict;
+use Carp;
+
+# Record author's perforce depot record
+$Tk::CHANGE = q$Change: 3279 $;
+
+# $tk_version and $tk_patchLevel are reset by pTk when a mainwindow
+# is created, $VERSION is checked by bootstrap
+$Tk::version = '8.4';
+$Tk::patchLevel = '8.4';
+$Tk::VERSION = '804.027';
+$Tk::XS_VERSION = $Tk::VERSION;
+$Tk::strictMotif = 0;
+
+
+{($Tk::library) = __FILE__ =~ /^(.*)\.pm$/;}
+$Tk::library = Tk->findINC('.') unless (defined($Tk::library) && -d $Tk::library);
+
+$Tk::widget = undef;
+$Tk::event = undef;
+
+use vars qw($inMainLoop);
+
+bootstrap Tk;
+
+my $boot_time = timeofday();
+
+# This is a workround for Solaris X11 locale handling
+Preload(DynaLoader::dl_findfile('-L/usr/openwin/lib','-lX11'))
+ if (NeedPreload() && -d '/usr/openwin/lib');
+
+use Tk::Submethods ('option' => [qw(add get clear readfile)],
+ 'clipboard' => [qw(clear append)]
+ );
+
+#
+# Next few routines are here as perl code as doing caller()
+# in XS code is very complicated - so instead C code calls BackTrace
+#
+sub _backTrace
+{
+ my $w = shift;
+ my $i = 1;
+ my ($pack,$file,$line,$sub) = caller($i++);
+ while (1)
+ {
+ my $loc = "at $file line $line";
+ ($pack,$file,$line,$sub) = caller($i++);
+ last unless defined($sub);
+ return 1 if $sub eq '(eval)';
+ $w->AddErrorInfo("$sub $loc");
+ }
+ return 0;
+}
+
+sub BackTrace
+{
+ my $w = shift;
+ return unless (@_ || $@);
+ my $mess = (@_) ? shift : "$@";
+ die "$mess\n" if $w->_backTrace;
+ # if we get here we are not in an eval so report now
+ $w->Fail($mess);
+ $w->idletasks;
+ die "$mess\n";
+}
+
+#
+# This is a $SIG{__DIE__} handler which does not change the $@
+# string in the way 'croak' does, but rather add to Tk's ErrorInfo.
+# It stops at 1st enclosing eval on assumption that the eval
+# is part of Tk call process and will add its own context to ErrorInfo
+# and then pass on the error.
+#
+sub __DIE__
+{
+ my $mess = shift;
+ my $w = $Tk::widget;
+ # Note that if a __DIE__ handler returns it re-dies up the chain.
+ return unless defined($w) && Exists($w);
+ # This special message is for exit() as an exception see pTkCallback.c
+ return if $mess =~/^_TK_EXIT_\(\d+\)/;
+ return if $w->_backTrace;
+ # Not in an eval - should not happen
+}
+
+sub XEvent::xy { shift->Info('xy') }
+
+sub XEvent::AUTOLOAD
+{
+ my ($meth) = $XEvent::AUTOLOAD =~ /(\w)$/;
+ no strict 'refs';
+ *{$XEvent::AUTOLOAD} = sub { shift->Info($meth) };
+ goto &$XEvent::AUTOLOAD;
+}
+
+sub NoOp { }
+
+sub Ev
+{
+ if (@_ == 1)
+ {
+ my $arg = $_[0];
+ return bless (((ref $arg) ? $arg : \$arg), 'Tk::Ev');
+ }
+ else
+ {
+ return bless [@_],'Tk::Ev';
+ }
+}
+
+sub InitClass
+{
+ my ($package,$parent) = @_;
+ croak "Unexpected type of parent $parent" unless(ref $parent);
+ croak "$parent is not a widget" unless($parent->IsWidget);
+ my $mw = $parent->MainWindow;
+ my $hash = $mw->TkHash('_ClassInit_');
+ unless (exists $hash->{$package})
+ {
+ $package->Install($mw);
+ $hash->{$package} = $package->ClassInit($mw);
+ }
+}
+
+require Tk::Widget;
+require Tk::Image;
+require Tk::MainWindow;
+
+sub Exists
+{my $w = shift;
+ return defined($w) && ref($w) && $w->IsWidget && $w->exists;
+}
+
+sub Time_So_Far
+{
+ return timeofday() - $boot_time;
+}
+
+# Selection* are not autoloaded as names are too long.
+
+sub SelectionOwn
+{my $widget = shift;
+ selection('own',(@_,$widget));
+}
+
+sub SelectionOwner
+{
+ selection('own','-displayof',@_);
+}
+
+sub SelectionClear
+{
+ selection('clear','-displayof',@_);
+}
+
+sub SelectionExists
+{
+ selection('exists','-displayof',@_);
+}
+
+sub SelectionHandle
+{my $widget = shift;
+ my $command = pop;
+ selection('handle',@_,$widget,$command);
+}
+
+sub SplitString
+{
+ local $_ = shift;
+ my (@arr, $tmp);
+ while (/\{([^{}]*)\}|((?:[^\s\\]|\\.)+)/gs) {
+ if (defined $1) { push @arr, $1 }
+ else { $tmp = $2 ; $tmp =~ s/\\([\s\\])/$1/g; push @arr, $tmp }
+ }
+ # carp '('.join(',',@arr).")";
+ return @arr;
+}
+
+sub Methods
+{
+ my ($package) = caller;
+ no strict 'refs';
+ foreach my $meth (@_)
+ {
+ my $name = $meth;
+ *{$package."::$meth"} = sub { shift->WidgetMethod($name,@_) };
+ }
+}
+
+my %dialog = ( tk_chooseColor => 'ColorDialog',
+ tk_messageBox => 'MessageBox',
+ tk_getOpenFile => 'FDialog',
+ tk_getSaveFile => 'FDialog',
+ tk_chooseDirectory => 'FDialog'
+# Slaven claims NI-S's version above does not work
+# and provides this
+# tk_chooseDirectory => 'DirDialog'
+ );
+
+foreach my $dialog (keys %dialog)
+ {
+ no strict 'refs';
+ unless (defined &$dialog)
+ {
+ my $kind = $dialog;
+ my $code = \&{"Tk::$dialog{$dialog}"};
+ *$dialog = sub { &$code($kind,@_) };
+ }
+ }
+
+sub MessageBox {
+ my ($kind,%args) = @_;
+ require Tk::Dialog;
+ my $parent = delete $args{'-parent'};
+ my $args = \%args;
+
+ $args->{-bitmap} = delete $args->{-icon} if defined $args->{-icon};
+ $args->{-text} = delete $args->{-message} if defined $args->{-message};
+ $args->{-type} = 'OK' unless defined $args->{-type};
+
+ my $type;
+ if (defined($type = delete $args->{-type})) {
+ delete $args->{-type};
+ my @buttons = grep($_,map(ucfirst($_),
+ split(/(abort|retry|ignore|yes|no|cancel|ok)/,
+ lc($type))));
+ $args->{-buttons} = [@buttons];
+ $args->{-default_button} = ucfirst(delete $args->{-default}) if
+ defined $args->{-default};
+ if (not defined $args->{-default_button} and scalar(@buttons) == 1) {
+ $args->{-default_button} = $buttons[0];
+ }
+ my $md = $parent->Dialog(%$args);
+ my $an = $md->Show;
+ $md->destroy;
+ return $an;
+ }
+} # end messageBox
+
+sub messageBox
+{
+ my ($widget,%args) = @_;
+ # remove in a later version:
+ if (exists $args{'-text'})
+ {
+ warn "The -text option is deprecated. Please use -message instead";
+ if (!exists $args{'-message'})
+ {
+ $args{'-message'} = delete $args{'-text'};
+ }
+ }
+ $args{'-type'} = (exists $args{'-type'}) ? lc($args{'-type'}) : 'ok';
+ $args{'-default'} = lc($args{'-default'}) if (exists $args{'-default'});
+ ucfirst tk_messageBox(-parent => $widget, %args);
+}
+
+sub getOpenFile
+{
+ tk_getOpenFile(-parent => shift,@_);
+}
+
+sub getSaveFile
+{
+ tk_getSaveFile(-parent => shift,@_);
+}
+
+sub chooseColor
+{
+ tk_chooseColor(-parent => shift,@_);
+}
+
+sub chooseDirectory
+{
+ tk_chooseDirectory(-parent => shift,@_);
+}
+
+sub DialogWrapper
+{
+ my ($method,$kind,%args) = @_;
+ my $created = 0;
+ my $w = delete $args{'-parent'};
+ if (defined $w)
+ {
+ $args{'-popover'} = $w;
+ }
+ else
+ {
+ $w = MainWindow->new;
+ $w->withdraw;
+ $created = 1;
+ }
+ my $mw = $w->toplevel;
+ my $fs = $mw->{$kind};
+ unless (defined $fs)
+ {
+ $mw->{$kind} = $fs = $mw->$method(%args);
+ }
+ else
+ {
+ $fs->configure(%args);
+ }
+ my $val = $fs->Show;
+ $w->destroy if $created;
+ return $val;
+}
+
+sub ColorDialog
+{
+ require Tk::ColorEditor;
+ DialogWrapper('ColorDialog',@_);
+}
+
+sub FDialog
+{
+ require Tk::FBox;
+ my $cmd = shift;
+ if ($cmd =~ /Save/)
+ {
+ push @_, -type => 'save';
+ }
+ elsif ($cmd =~ /Directory/)
+ {
+ push @_, -type => 'dir';
+ }
+ DialogWrapper('FBox', $cmd, @_);
+}
+
+sub DirDialog
+{
+ require Tk::DirTree;
+ DialogWrapper('DirTreeDialog',@_);
+}
+
+*MotifFDialog = \&FDialog;
+
+*CORE::GLOBAL::exit = \&exit;
+
+sub MainLoop
+{
+ unless ($inMainLoop)
+ {
+ local $inMainLoop = 1;
+ while (Tk::MainWindow->Count)
+ {
+ DoOneEvent(0);
+ }
+ }
+}
+
+sub tkinit { return MainWindow->new(@_) }
+
+# a wrapper on eval which turns off user $SIG{__DIE__}
+sub catch (&)
+{
+ my $sub = shift;
+ eval {local $SIG{'__DIE__'}; &$sub };
+}
+
+my $Home;
+
+sub TranslateFileName
+{
+ local $_ = shift;
+ unless (defined $Home)
+ {
+ $Home = $ENV{'HOME'} || (defined $ENV{'HOMEDRIVE'} && defined $ENV{'HOMEPATH'} ? $ENV{'HOMEDRIVE'}.$ENV{'HOMEPATH'} : "");
+ $Home =~ s#\\#/#g;
+ $Home .= '/' unless $Home =~ m#/$#;
+ }
+ s#~/#$Home#g;
+ # warn $_;
+ return $_;
+}
+
+sub findINC
+{
+ my $file = join('/',@_);
+ my $dir;
+ $file =~ s,::,/,g;
+ foreach $dir (@INC)
+ {
+ my $path;
+ return $path if (-e ($path = "$dir/$file"));
+ }
+ return undef;
+}
+
+sub idletasks
+{
+ shift->update('idletasks');
+}
+
+sub backtrace
+{
+ my ($self,$msg,$i) = @_;
+ $i = 1 if @_ < 3;
+ while (1)
+ {
+ my ($pack,$file,$line,$sub) = caller($i++);
+ last unless defined($sub);
+ $msg .= "\n $sub at $file line $line";
+ }
+ return "$msg\n";
+}
+
+sub die_with_trace
+{
+ my ($self,$msg) = @_;
+ die $self->backtrace($msg,1);
+}
+
+
+
+1;
+
+__END__
+
+sub Error
+{my $w = shift;
+ my $error = shift;
+ if (Exists($w))
+ {
+ my $grab = $w->grab('current');
+ $grab->Unbusy if (defined $grab);
+ }
+ chomp($error);
+ warn "Tk::Error: $error\n " . join("\n ",@_)."\n";
+}
+
+sub CancelRepeat
+{
+ my $w = shift->MainWindow;
+ my $id = delete $w->{_afterId_};
+ $w->after('cancel',$id) if (defined $id);
+}
+
+sub RepeatId
+{
+ my ($w,$id) = @_;
+ $w = $w->MainWindow;
+ $w->CancelRepeat;
+ $w->{_afterId_} = $id;
+}
+
+
+
+#----------------------------------------------------------------------------
+# focus.tcl --
+#
+# This file defines several procedures for managing the input
+# focus.
+#
+# @(#) focus.tcl 1.6 94/12/19 17:06:46
+#
+# Copyright (c) 1994 Sun Microsystems, Inc.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+sub FocusChildren { shift->children }
+
+#
+# focusNext --
+# This procedure is invoked to move the input focus to the next window
+# after a given one. "Next" is defined in terms of the window
+# stacking order, with all the windows underneath a given top-level
+# (no matter how deeply nested in the hierarchy) considered except
+# for frames and toplevels.
+#
+# Arguments:
+# w - Name of a window: the procedure will set the focus
+# to the next window after this one in the traversal
+# order.
+sub focusNext
+{
+ my $w = shift;
+ my $cur = $w;
+ while (1)
+ {
+ # Descend to just before the first child of the current widget.
+ my $parent = $cur;
+ my @children = $cur->FocusChildren();
+ my $i = -1;
+ # Look for the next sibling that isn't a top-level.
+ while (1)
+ {
+ $i += 1;
+ if ($i < @children)
+ {
+ $cur = $children[$i];
+ next if ($cur->toplevel == $cur);
+ last
+ }
+ # No more siblings, so go to the current widget's parent.
+ # If it's a top-level, break out of the loop, otherwise
+ # look for its next sibling.
+ $cur = $parent;
+ last if ($cur->toplevel() == $cur);
+ $parent = $parent->parent();
+ @children = $parent->FocusChildren();
+ $i = lsearch(\@children,$cur);
+ }
+ if ($cur == $w || $cur->FocusOK)
+ {
+ $cur->tabFocus;
+ return;
+ }
+ }
+}
+# focusPrev --
+# This procedure is invoked to move the input focus to the previous
+# window before a given one. "Previous" is defined in terms of the
+# window stacking order, with all the windows underneath a given
+# top-level (no matter how deeply nested in the hierarchy) considered.
+#
+# Arguments:
+# w - Name of a window: the procedure will set the focus
+# to the previous window before this one in the traversal
+# order.
+sub focusPrev
+{
+ my $w = shift;
+ my $cur = $w;
+ my @children;
+ my $i;
+ my $parent;
+ while (1)
+ {
+ # Collect information about the current window's position
+ # among its siblings. Also, if the window is a top-level,
+ # then reposition to just after the last child of the window.
+ if ($cur->toplevel() == $cur)
+ {
+ $parent = $cur;
+ @children = $cur->FocusChildren();
+ $i = @children;
+ }
+ else
+ {
+ $parent = $cur->parent();
+ @children = $parent->FocusChildren();
+ $i = lsearch(\@children,$cur);
+ }
+ # Go to the previous sibling, then descend to its last descendant
+ # (highest in stacking order. While doing this, ignore top-levels
+ # and their descendants. When we run out of descendants, go up
+ # one level to the parent.
+ while ($i > 0)
+ {
+ $i--;
+ $cur = $children[$i];
+ next if ($cur->toplevel() == $cur);
+ $parent = $cur;
+ @children = $parent->FocusChildren();
+ $i = @children;
+ }
+ $cur = $parent;
+ if ($cur == $w || $cur->FocusOK)
+ {
+ $cur->tabFocus;
+ return;
+ }
+ }
+
+}
+
+sub FocusOK
+{
+ my $w = shift;
+ my $value;
+ catch { $value = $w->cget('-takefocus') };
+ if (!$@ && defined($value))
+ {
+ return 0 if ($value eq '0');
+ return $w->viewable if ($value eq '1');
+ if ($value)
+ {
+ $value = $w->$value();
+ return $value if (defined $value);
+ }
+ }
+ if (!$w->viewable)
+ {
+ return 0;
+ }
+ catch { $value = $w->cget('-state') } ;
+ if (!$@ && defined($value) && $value eq 'disabled')
+ {
+ return 0;
+ }
+ $value = grep(/Key|Focus/,$w->Tk::bind(),$w->Tk::bind(ref($w)));
+ return $value;
+}
+
+
+# focusFollowsMouse
+#
+# If this procedure is invoked, Tk will enter "focus-follows-mouse"
+# mode, where the focus is always on whatever window contains the
+# mouse. If this procedure isn't invoked, then the user typically
+# has to click on a window to give it the focus.
+#
+# Arguments:
+# None.
+
+sub EnterFocus
+{
+ my $w = shift;
+ return unless $w;
+ my $Ev = $w->XEvent;
+ my $d = $Ev->d;
+ $w->Tk::focus() if ($d eq 'NotifyAncestor' || $d eq 'NotifyNonlinear' || $d eq 'NotifyInferior');
+}
+
+sub tabFocus
+{
+ shift->Tk::focus;
+}
+
+sub focusFollowsMouse
+{
+ my $widget = shift;
+ $widget->bind('all','<Enter>','EnterFocus');
+}
+
+# tkTraverseToMenu --
+# This procedure implements keyboard traversal of menus. Given an
+# ASCII character "char", it looks for a menubutton with that character
+# underlined. If one is found, it posts the menubutton's menu
+#
+# Arguments:
+# w - Window in which the key was typed (selects
+# a toplevel window).
+# char - Character that selects a menu. The case
+# is ignored. If an empty string, nothing
+# happens.
+sub TraverseToMenu
+{
+ my $w = shift;
+ my $char = shift;
+ return unless(defined $char && $char ne '');
+ $w = $w->toplevel->FindMenu($char);
+}
+# tkFirstMenu --
+# This procedure traverses to the first menubutton in the toplevel
+# for a given window, and posts that menubutton's menu.
+#
+# Arguments:
+# w - Name of a window. Selects which toplevel
+# to search for menubuttons.
+sub FirstMenu
+{
+ my $w = shift;
+ $w = $w->toplevel->FindMenu('');
+}
+
+# These wrappers don't use method syntax so need to live
+# in same package as raw Tk routines are newXS'ed into.
+
+sub Selection
+{my $widget = shift;
+ my $cmd = shift;
+ croak 'Use SelectionOwn/SelectionOwner' if ($cmd eq 'own');
+ croak "Use Selection\u$cmd()";
+}
+
+# If we have sub Clipboard in Tk then use base qw(Tk::Clipboard ....)
+# calls it when it does its eval "require $base"
+#sub Clipboard
+#{my $w = shift;
+# my $cmd = shift;
+# croak "Use clipboard\u$cmd()";
+#}
+
+sub Receive
+{
+ my $w = shift;
+ warn 'Receive(' . join(',',@_) .')';
+ die 'Tk rejects send(' . join(',',@_) .")\n";
+}
+
+sub break
+{
+ die "_TK_BREAK_\n";
+}
+
+sub updateWidgets
+{
+ my ($w) = @_;
+ while ($w->DoOneEvent(DONT_WAIT|IDLE_EVENTS|WINDOW_EVENTS))
+ {
+ }
+ $w;
+}
+
+sub ImageNames
+{
+ image('names');
+}
+
+sub ImageTypes
+{
+ image('types');
+}
+
+sub interps
+{
+ my $w = shift;
+ return $w->winfo('interps','-displayof');
+}
+
+sub lsearch
+{my $ar = shift;
+ my $x = shift;
+ my $i;
+ for ($i = 0; $i < scalar @$ar; $i++)
+ {
+ return $i if ($$ar[$i] eq $x);
+ }
+ return -1;
+}
+
+
+sub getEncoding
+{
+ my ($class,$name) = @_;
+ eval { require Encode };
+ if ($@)
+ {
+ require Tk::DummyEncode;
+ return Tk::DummyEncode->getEncoding($name);
+ }
+ $name = $Tk::font_encoding{$name} if exists $Tk::font_encoding{$name};
+ my $enc = Encode::find_encoding($name);
+
+ unless ($enc)
+ {
+ $enc = Encode::find_encoding($name) if ($name =~ s/[-_]\d+$//)
+ }
+# if ($enc)
+# {
+# print STDERR "Lookup '$name' => ".$enc->name."\n";
+# }
+# else
+# {
+# print STDERR "Failed '$name'\n";
+# }
+ unless ($enc)
+ {
+ if ($name eq 'X11ControlChars')
+ {
+ require Tk::DummyEncode;
+ $Encode::encoding{$name} = $enc = Tk::DummyEncode->getEncoding($name);
+ }
+ }
+ return $enc;
+}
+
+
+
diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/After.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/After.pm
new file mode 100644
index 00000000000..85a0e406ee5
--- /dev/null
+++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/After.pm
@@ -0,0 +1,104 @@
+# Copyright (c) 1995-2004 Nick Ing-Simmons. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+package Tk::After;
+use Carp;
+
+use vars qw($VERSION);
+$VERSION = '4.007'; # $Id: //depot/Tkutf8/Tk/After.pm#11 $
+
+sub _cancelAll
+{
+ my $w = shift;
+ my $h = delete $w->{_After_};
+ foreach my $obj (values %$h)
+ {
+ # carp "Auto cancel ".$obj->[1]." for ".$obj->[0]->PathName;
+ $obj->cancel;
+ bless $obj,"Tk::After::Cancelled";
+ }
+}
+
+sub Tk::After::Cancelled::once { }
+sub Tk::After::Cancelled::repeat { }
+
+sub submit
+{
+ my $obj = shift;
+ my $w = $obj->[0];
+ my $id = $obj->[1];
+ my $t = $obj->[2];
+ my $method = $obj->[3];
+ delete($w->{_After_}{$id}) if (defined $id);
+ $id = $w->Tk::after($t,[$method => $obj]);
+ unless (exists $w->{_After_})
+ {
+ $w->{_After_} = {};
+ $w->OnDestroy([\&_cancelAll, $w]);
+ }
+ $w->{_After_}{$id} = $obj;
+ $obj->[1] = $id;
+ return $obj;
+}
+
+sub DESTROY
+{
+ my $obj = shift;
+ $obj->cancel;
+ undef $obj->[0];
+ undef $obj->[4];
+}
+
+sub new
+{
+ my ($class,$w,$t,$method,@cb) = @_;
+ my $cb = (@cb == 1) ? shift(@cb) : [@cb];
+ my $obj = bless [$w,undef,$t,$method,Tk::Callback->new($cb)],$class;
+ return $obj->submit;
+}
+
+sub cancel
+{
+ my $obj = shift;
+ my $id = $obj->[1];
+ my $w = $obj->[0];
+ if ($id)
+ {
+ $w->Tk::after('cancel'=> $id) if Tk::Exists($w);
+ delete $w->{_After_}{$id} if exists $w->{_After_};
+ $obj->[1] = undef;
+ }
+ return $obj;
+}
+
+sub repeat
+{
+ my $obj = shift;
+ $obj->submit;
+ local $Tk::widget = $obj->[0];
+ $obj->[4]->Call;
+}
+
+sub once
+{
+ my $obj = shift;
+ my $w = $obj->[0];
+ my $id = $obj->[1];
+ delete $w->{_After_}{$id};
+ local $Tk::widget = $w;
+ $obj->[4]->Call;
+}
+
+sub time {
+ my $obj = shift;
+ my $delay = shift;
+ if (defined $delay) {
+ $obj->cancel if $delay == 0;
+ $obj->[2] = $delay;
+ }
+ $obj->[2];
+}
+
+1;
+__END__
+
diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Button.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Button.pm
new file mode 100644
index 00000000000..efa597dee14
--- /dev/null
+++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Button.pm
@@ -0,0 +1,148 @@
+package Tk::Button;
+# Conversion from Tk4.0 button.tcl competed.
+#
+# Copyright (c) 1992-1994 The Regents of the University of California.
+# Copyright (c) 1994 Sun Microsystems, Inc.
+# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved.
+# This program is free software; you can redistribute it and/or
+
+use vars qw($VERSION);
+$VERSION = '4.008'; # $Id: //depot/Tkutf8/Tk/Button.pm#8 $
+
+# modify it under the same terms as Perl itself, subject
+# to additional disclaimer in license.terms due to partial
+# derivation from Tk4.0 sources.
+
+use strict;
+
+require Tk::Widget;
+use base qw(Tk::Widget);
+
+use vars qw($buttonWindow $relief);
+
+Tk::Methods('deselect','flash','invoke','select','toggle');
+
+sub Tk_cmd { \&Tk::button }
+
+Construct Tk::Widget 'Button';
+
+sub ClassInit
+{
+ my ($class,$mw) = @_;
+ $mw->bind($class,'<Enter>', 'Enter');
+ $mw->bind($class,'<Leave>', 'Leave');
+ $mw->bind($class,'<1>', 'butDown');
+ $mw->bind($class,'<ButtonRelease-1>', 'butUp');
+ $mw->bind($class,'<space>', 'Invoke');
+ $mw->bind($class,'<Return>', 'Invoke');
+ return $class;
+}
+
+# tkButtonEnter --
+# The procedure below is invoked when the mouse pointer enters a
+# button widget. It records the button we're in and changes the
+# state of the button to active unless the button is disabled.
+#
+# Arguments:
+# w - The name of the widget.
+
+sub Enter
+{
+ my $w = shift;
+ my $E = shift;
+ if ($w->cget('-state') ne 'disabled')
+ {
+ $w->configure('-state' => 'active');
+ $w->configure('-state' => 'active', '-relief' => 'sunken') if (defined($buttonWindow) && $w == $buttonWindow)
+ }
+ $Tk::window = $w;
+}
+
+# tkButtonLeave --
+# The procedure below is invoked when the mouse pointer leaves a
+# button widget. It changes the state of the button back to
+# inactive. If we're leaving the button window with a mouse button
+# pressed (tkPriv(buttonWindow) == $w), restore the relief of the
+# button too.
+#
+# Arguments:
+# w - The name of the widget.
+sub Leave
+{
+ my $w = shift;
+ $w->configure('-state'=>'normal') if ($w->cget('-state') ne 'disabled');
+ $w->configure('-relief' => $relief) if (defined($buttonWindow) && $w == $buttonWindow);
+ undef $Tk::window;
+}
+
+# tkButtonDown --
+# The procedure below is invoked when the mouse button is pressed in
+# a button widget. It records the fact that the mouse is in the button,
+# saves the button's relief so it can be restored later, and changes
+# the relief to sunken.
+#
+# Arguments:
+# w - The name of the widget.
+sub butDown
+{
+ my $w = shift;
+ $relief = $w->cget('-relief');
+ if ($w->cget('-state') ne 'disabled')
+ {
+ $buttonWindow = $w;
+ $w->configure('-relief' => 'sunken')
+ }
+}
+
+# tkButtonUp --
+# The procedure below is invoked when the mouse button is released
+# in a button widget. It restores the button's relief and invokes
+# the command as long as the mouse hasn't left the button.
+#
+# Arguments:
+# w - The name of the widget.
+sub butUp
+{
+ my $w = shift;
+ if (defined($buttonWindow) && $buttonWindow == $w)
+ {
+ undef $buttonWindow;
+ $w->configure('-relief' => $relief);
+ if ($w->IS($Tk::window) && $w->cget('-state') ne 'disabled')
+ {
+ $w->invoke;
+ }
+ }
+}
+
+# tkButtonInvoke --
+# The procedure below is called when a button is invoked through
+# the keyboard. It simulate a press of the button via the mouse.
+#
+# Arguments:
+# w - The name of the widget.
+sub Invoke
+{
+ my $w = shift;
+ if ($w->cget('-state') ne 'disabled')
+ {
+ my $oldRelief = $w->cget('-relief');
+ my $oldState = $w->cget('-state');
+ $w->configure('-state' => 'active', '-relief' => 'sunken');
+ $w->idletasks;
+ $w->after(100);
+ $w->configure('-state' => $oldState, '-relief' => $oldRelief);
+ $w->invoke;
+ }
+}
+
+
+
+1;
+
+__END__
+
+
+
+
+
diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/CmdLine.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/CmdLine.pm
new file mode 100644
index 00000000000..2e821e826ae
--- /dev/null
+++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/CmdLine.pm
@@ -0,0 +1,954 @@
+package Tk::CmdLine; # -*-Perl-*-
+
+#/----------------------------------------------------------------------------//
+#/ Module: Tk/CmdLine.pm
+#/
+#/ Purpose:
+#/
+#/ Process standard X11 command line options and set initial resources.
+#/
+#/ Author: ???? Date: ????
+#/
+#/ History: SEE POD
+#/----------------------------------------------------------------------------//
+
+use vars qw($VERSION);
+$VERSION = '4.006'; # $Id: //depot/Tkutf8/Tk/CmdLine.pm#6 $
+
+use 5.004;
+
+use strict;
+
+use Config;
+
+my $OBJECT = undef; # define the current object
+
+#/----------------------------------------------------------------------------//
+#/ Constructor
+#/ Returns the object reference.
+#/----------------------------------------------------------------------------//
+
+sub new # Tk::CmdLine::new()
+{
+ my $this = shift(@_);
+ my $class = ref($this) || $this;
+
+ my $name = 'pTk';
+ $name = $1 if (($0 =~ m/(?:^|[\/\\])([\w-]+)(?:\.\w+)?$/) && ($1 ne '-e'));
+
+ my $self = {
+ name => $name,
+ config => { -name => $name },
+ options => {},
+ methods => {},
+ command => [],
+ synchronous => 0,
+ iconic => 0,
+ motif => ($Tk::strictMotif || 0),
+ resources => {} };
+
+ return bless($self, $class);
+}
+
+#/----------------------------------------------------------------------------//
+#/ Process the arguments in a given array or in @ARGV.
+#/ Returns the object reference.
+#/----------------------------------------------------------------------------//
+
+sub Argument_ # Tk::CmdLine::Argument_($flag) # private method
+{
+ my $self = shift(@_);
+ my $flag = shift(@_);
+ unless ($self->{offset} < @{$self->{argv}})
+ {
+ die 'Usage: ', $self->{name}, ' ... ', $flag, " <argument> ...\n";
+ }
+ return splice(@{$self->{argv}}, $self->{offset}, 1);
+}
+
+sub Config_ # Tk::CmdLine::Config_($flag, $name) # private method
+{
+ my $self = shift(@_);
+ my ($flag, $name) = @_;
+ my $val = $self->Argument_($flag);
+ push(@{$self->{command}}, $flag, $val);
+ $self->{config}->{"-$name"} = $val;
+}
+
+sub Flag_ # Tk::CmdLine::Flag_($flag, $name) # private method
+{
+ my $self = shift(@_);
+ my ($flag, $name) = @_;
+ push(@{$self->{command}}, $flag);
+ $self->{$name} = 1;
+}
+
+sub Option_ # Tk::CmdLine::Option_($flag, $name) # private method
+{
+ my $self = shift(@_);
+ my ($flag, $name) = @_;
+ my $val = $self->Argument_($flag);
+ push(@{$self->{command}}, $flag, $val);
+ $self->{options}->{"*$name"} = $val;
+}
+
+sub Method_ # Tk::CmdLine::Method_($flag, $name) # private method
+{
+ my $self = shift(@_);
+ my ($flag, $name) = @_;
+ my $val = $self->Argument_($flag);
+ push(@{$self->{command}}, $flag, $val);
+ $self->{methods}->{$name} = $val;
+}
+
+sub Resource_ # Tk::CmdLine::Resource_($flag, $name) # private method
+{
+ my $self = shift(@_);
+ my ($flag, $name) = @_;
+ my $val = $self->Argument_($flag);
+ if ($val =~ /^([^!:\s]+)*\s*:\s*(.*)$/)
+ {
+ push(@{$self->{command}}, $flag, $val);
+ $self->{options}->{$1} = $2;
+ }
+}
+
+my %Method = (
+ background => 'Option_',
+ bg => 'background', # alias
+ class => 'Config_',
+ display => 'screen', # alias
+ fg => 'foreground', # alias
+ fn => 'font', # alias
+ font => 'Option_',
+ foreground => 'Option_',
+ geometry => 'Method_',
+ iconic => 'Flag_',
+ iconposition => 'Method_',
+ motif => 'Flag_',
+ name => 'Config_',
+ screen => 'Config_',
+ synchronous => 'Flag_',
+ title => 'Config_',
+ xrm => 'Resource_'
+);
+
+sub SetArguments # Tk::CmdLine::SetArguments([@argument])
+{
+ my $self = (@_ # define the object as necessary
+ ? ((ref($_[0]) eq __PACKAGE__)
+ ? shift(@_)
+ : (($_[0] eq __PACKAGE__) ? shift(@_) : 1) && ($OBJECT ||= __PACKAGE__->new()))
+ : ($OBJECT ||= __PACKAGE__->new()));
+ $OBJECT = $self; # update the current object
+ $self->{argv} = (@_ ? [ @_ ] : \@ARGV);
+ $self->{offset} = 0; # its existence will denote that this method has been called
+
+ my @option = ();
+
+ while ($self->{offset} < @{$self->{argv}})
+ {
+ last if ($self->{argv}->[$self->{offset}] eq '--');
+ unless (
+ (($self->{argv}->[$self->{offset}] =~ /^-{1,2}(\w+)$/) && (@option = $1)) ||
+ (($self->{argv}->[$self->{offset}] =~ /^--(\w+)=(.*)$/) && (@option = ($1, $2))))
+ {
+ ++$self->{offset};
+ next;
+ }
+
+ next if (!exists($Method{$option[0]}) && ++$self->{offset});
+
+ $option[0] = $Method{$option[0]} if exists($Method{$Method{$option[0]}});
+
+ my $method = $Method{$option[0]};
+
+ if (@option > 1) # replace --<option>=<value> with <value>
+ {
+ $self->{argv}->[$self->{offset}] = $option[1];
+ }
+ else # remove the argument
+ {
+ splice(@{$self->{argv}}, $self->{offset}, 1);
+ }
+
+ $self->$method(('-' . $option[0]), $option[0]);
+ }
+
+ $self->{config}->{-class} ||= ucfirst($self->{config}->{-name});
+
+ delete($self->{argv}); # no longer needed
+
+ return $self;
+}
+
+use vars qw(&process); *process = \&SetArguments; # alias to keep old code happy
+
+#/----------------------------------------------------------------------------//
+#/ Get a list of the arguments that have been processed by SetArguments().
+#/ Returns an array.
+#/----------------------------------------------------------------------------//
+
+sub GetArguments # Tk::CmdLine::GetArguments()
+{
+ my $self = (@_ # define the object as necessary
+ ? ((ref($_[0]) eq __PACKAGE__)
+ ? shift(@_)
+ : (($_[0] eq __PACKAGE__) ? shift(@_) : 1) && ($OBJECT ||= __PACKAGE__->new()))
+ : ($OBJECT ||= __PACKAGE__->new()));
+ $OBJECT = $self; # update the current object
+
+ $self->SetArguments() unless exists($self->{offset}); # set arguments if not yet done
+
+ return @{$self->{command}};
+}
+
+#/----------------------------------------------------------------------------//
+#/ Get the value of a configuration option (default: -class).
+#/ Returns the option value.
+#/----------------------------------------------------------------------------//
+
+sub cget # Tk::CmdLine::cget([$option])
+{
+ my $self = (@_ # define the object as necessary
+ ? ((ref($_[0]) eq __PACKAGE__)
+ ? shift(@_)
+ : (($_[0] eq __PACKAGE__) ? shift(@_) : 1) && ($OBJECT ||= __PACKAGE__->new()))
+ : ($OBJECT ||= __PACKAGE__->new()));
+ $OBJECT = $self; # update the current object
+ my $option = shift(@_) || '-class';
+
+ $self->SetArguments() unless exists($self->{offset}); # set arguments if not yet done
+
+ return (exists($self->{config}->{$option}) ? $self->{config}->{$option} : undef);
+}
+
+#/----------------------------------------------------------------------------//
+
+sub CreateArgs # Tk::CmdLine::CreateArgs()
+{
+ my $self = (@_ # define the object as necessary
+ ? ((ref($_[0]) eq __PACKAGE__)
+ ? shift(@_)
+ : (($_[0] eq __PACKAGE__) ? shift(@_) : 1) && ($OBJECT ||= __PACKAGE__->new()))
+ : ($OBJECT ||= __PACKAGE__->new()));
+ $OBJECT = $self; # update the current object
+
+ $self->SetArguments() unless exists($self->{offset}); # set arguments if not yet done
+
+ return $self->{config};
+}
+
+#/----------------------------------------------------------------------------//
+
+sub Tk::MainWindow::apply_command_line
+{
+ my $mw = shift(@_);
+
+ my $self = ($OBJECT ||= __PACKAGE__->new());
+
+ $self->SetArguments() unless exists($self->{offset}); # set arguments if not yet done
+
+ foreach my $priority (keys(%{$self->{resources}}))
+ {
+ foreach my $resource (@{$self->{resources}->{$priority}})
+ {
+ $mw->optionAdd(@{$resource}, $priority);
+ }
+ }
+
+ foreach my $key (keys(%{$self->{options}}))
+ {
+ $mw->optionAdd($key => $self->{options}->{$key}, 'interactive');
+ }
+
+ foreach my $key (keys(%{$self->{methods}}))
+ {
+ $mw->$key($self->{methods}->{$key});
+ }
+
+ if ($self->{methods}->{geometry})
+ {
+ if ($self->{methods}->{geometry} =~ /[+-]\d+[+-]\d+/)
+ {
+ $mw->positionfrom('user');
+ }
+ if ($self->{methods}->{geometry} =~ /\d+x\d+/)
+ {
+ $mw->sizefrom('user');
+ }
+ delete $self->{methods}->{geometry}; # XXX needed?
+ }
+
+ $mw->Synchronize() if $self->{synchronous};
+
+ if ($self->{iconic})
+ {
+ $mw->iconify();
+ $self->{iconic} = 0;
+ }
+
+ $Tk::strictMotif = ($self->{motif} || 0);
+
+ # Both these are needed to reliably save state
+ # but 'hostname' is tricky to do portably.
+ # $mw->client(hostname());
+ $mw->protocol('WM_SAVE_YOURSELF' => ['WMSaveYourself',$mw]);
+ $mw->command([ $self->{name}, @{$self->{command}} ]);
+}
+
+#/----------------------------------------------------------------------------//
+#/ Set the initial resources.
+#/ Returns the object reference.
+#/----------------------------------------------------------------------------//
+
+sub SetResources # Tk::CmdLine::SetResources((\@resource | $resource) [, $priority])
+{
+ my $self = (@_ # define the object as necessary
+ ? ((ref($_[0]) eq __PACKAGE__)
+ ? shift(@_)
+ : (($_[0] eq __PACKAGE__) ? shift(@_) : 1) && ($OBJECT ||= __PACKAGE__->new()))
+ : ($OBJECT ||= __PACKAGE__->new()));
+ $OBJECT = $self; # update the current object
+
+ $self->SetArguments() unless exists($self->{offset}); # set arguments if not yet done
+ return $self unless @_;
+
+ my $data = shift(@_);
+ my $priority = shift(@_) || 'userDefault';
+
+ $self->{resources}->{$priority} = [] unless exists($self->{resources}->{$priority});
+
+ foreach my $resource ((ref($data) eq 'ARRAY') ? @{$data} : $data)
+ {
+ if (ref($resource) eq 'ARRAY') # resources in [ <pattern>, <value> ] format
+ {
+ push(@{$self->{resources}->{$priority}}, [ @{$resource} ])
+ if (@{$resource} == 2);
+ }
+ else # resources in resource file format
+ {
+ push(@{$self->{resources}->{$priority}}, [ $1, $2 ])
+ if ($resource =~ /^([^!:\s]+)*\s*:\s*(.*)$/);
+ }
+ }
+
+ return $self;
+}
+
+#/----------------------------------------------------------------------------//
+#/ Load initial resources from one or more files (default: $XFILESEARCHPATH with
+#/ priority 'startupFile' and $XUSERFILESEARCHPATH with priority 'userDefault').
+#/ Returns the object reference.
+#/----------------------------------------------------------------------------//
+
+sub LoadResources # Tk::CmdLine::LoadResources([%options])
+{
+ my $self = (@_ # define the object as necessary
+ ? ((ref($_[0]) eq __PACKAGE__)
+ ? shift(@_)
+ : (($_[0] eq __PACKAGE__) ? shift(@_) : 1) && ($OBJECT ||= __PACKAGE__->new()))
+ : ($OBJECT ||= __PACKAGE__->new()));
+ $OBJECT = $self; # update the current object
+
+ $self->SetArguments() unless exists($self->{offset}); # set arguments if not yet done
+
+ my %options = @_;
+
+ my @file = ();
+ my $echo = (exists($options{-echo})
+ ? (defined($options{-echo}) ? $options{-echo} : \*STDOUT) : undef);
+
+ unless (%options && (exists($options{-file}) || exists($options{-symbol})))
+ {
+ @file = (
+ { -symbol => 'XFILESEARCHPATH', -priority => 'startupFile' },
+ { -symbol => 'XUSERFILESEARCHPATH', -priority => 'userDefault' } );
+ }
+ else
+ {
+ @file = { %options };
+ }
+
+ my $delimiter = (($^O eq 'MSWin32') ? ';' : ':');
+
+ foreach my $file (@file)
+ {
+ my $fileSpec = $file->{-spec} = undef;
+ if (exists($file->{-symbol}))
+ {
+ my $xpath = undef;
+ if ($file->{-symbol} eq 'XUSERFILESEARCHPATH')
+ {
+ $file->{-priority} ||= 'userDefault';
+ foreach my $symbol (qw(XUSERFILESEARCHPATH XAPPLRESDIR HOME))
+ {
+ last if (exists($ENV{$symbol}) && ($xpath = $ENV{$symbol}));
+ }
+ next unless defined($xpath);
+ }
+ else
+ {
+ $file->{-priority} ||= (($file->{-symbol} eq 'XFILESEARCHPATH')
+ ? 'startupFile' : 'userDefault');
+ next unless (
+ exists($ENV{$file->{-symbol}}) && ($xpath = $ENV{$file->{-symbol}}));
+ }
+
+ unless (exists($self->{translation}))
+ {
+ $self->{translation} = {
+ '%l' => '', # ignored
+ '%C' => '', # ignored
+ '%S' => '', # ignored
+ '%L' => ($ENV{LANG} || 'C'), # language
+ '%T' => 'app-defaults', # type
+ '%N' => $self->{config}->{-class} # filename
+ };
+ }
+
+ my @postfix = map({ $_ . '/' . $self->{config}->{-class} }
+ ('/' . $self->{translation}->{'%L'}), '');
+
+ ITEM: foreach $fileSpec (split($Config{path_sep}, $xpath))
+ {
+ if ($fileSpec =~ s/(%[A-Za-z])/$self->{translation}->{$1}/g) # File Pattern
+ {
+ if (defined($echo) && ($file->{-symbol} ne 'XFILESEARCHPATH'))
+ {
+ print $echo 'Checking ', $fileSpec, "\n";
+ }
+ next unless ((-f $fileSpec) && (-r _) && (-s _));
+ $file->{-spec} = $fileSpec;
+ last;
+ }
+ else # Directory - Check for <Directory>/$LANG/<Class>, <Directory>/<CLASS>
+ {
+ foreach my $postfix (@postfix)
+ {
+ my $fileSpec2 = $fileSpec . $postfix;
+ if (defined($echo) && ($file->{-symbol} ne 'XFILESEARCHPATH'))
+ {
+ print $echo 'Checking ', $fileSpec2, "\n";
+ }
+ next unless ((-f $fileSpec2) && (-r _) && (-s _));
+ $file->{-spec} = $fileSpec2;
+ last ITEM;
+ }
+ }
+ }
+ }
+ elsif (exists($file->{-file}) && ($fileSpec = $file->{-file}))
+ {
+ print $echo 'Checking ', $fileSpec, "\n" if defined($echo);
+ next unless ((-f $fileSpec) && (-r _) && (-s _));
+ $file->{-spec} = $fileSpec;
+ }
+ }
+
+ foreach my $file (@file)
+ {
+ next unless defined($file->{-spec});
+ local *SPEC;
+ next unless open(SPEC,$file->{-spec});
+ print $echo ' Loading ', $file->{-spec}, "\n" if defined($echo);
+
+ my $resource = undef;
+ my @resource = ();
+ my $continuation = 0;
+
+ while (defined(my $line = <SPEC>))
+ {
+ chomp($line);
+ next if ($line =~ /^\s*$/); # skip blank lines
+ next if ($line =~ /^\s*!/); # skip comments
+ $continuation = ($line =~ s/\s*\\$/ /); # search for trailing backslash
+ unless (defined($resource)) # it is the first line
+ {
+ $resource = $line;
+ }
+ else # it is a continuation line
+ {
+ $line =~ s/^\s*//; # remove leading whitespace
+ $resource .= $line;
+ }
+ next if $continuation;
+ push(@resource, [ $1, $2 ]) if ($resource =~ /^([^:\s]+)*\s*:\s*(.*)$/);
+ $resource = undef;
+ }
+
+ close(SPEC);
+
+ if (defined($resource)) # special case - EOF after line with trailing backslash
+ {
+ push(@resource, [ $1, $2 ]) if ($resource =~ /^([^:\s]+)*\s*:\s*(.*)$/);
+ }
+
+ $self->SetResources(\@resource, $file->{-priority}) if @resource;
+ }
+
+ return $self;
+}
+
+#/----------------------------------------------------------------------------//
+
+1;
+
+__END__
+
+=cut
+
+=head1 NAME
+
+Tk::CmdLine - Process standard X11 command line options and set initial resources
+
+=for pm Tk/CmdLine.pm
+
+=for category Creating and Configuring Widgets
+
+=head1 SYNOPSIS
+
+ Tk::CmdLine::SetArguments([@argument]);
+
+ my $value = Tk::CmdLine::cget([$option]);
+
+ Tk::CmdLine::SetResources((\@resource | $resource) [, $priority]);
+
+ Tk::CmdLine::LoadResources(
+ [ -symbol => $symbol ]
+ [ -file => $fileSpec ]
+ [ -priority => $priority ]
+ [ -echo => $fileHandle ] );
+
+=head1 DESCRIPTION
+
+Process standard X11 command line options and set initial resources.
+
+The X11R5 man page for X11 says: "Most X programs attempt to use the same names
+for command line options and arguments. All applications written with the
+X Toolkit Intrinsics automatically accept the following options: ...".
+This module processes these command line options for perl/Tk applications
+using the C<SetArguments>() function.
+
+This module can optionally be used to load initial resources explicitly via
+function C<SetResources>(), or from specified files (default: the standard X11
+application-specific resource files) via function C<LoadResources>().
+
+=head2 Command Line Options
+
+=over 4
+
+=item B<-background> I<Color> | B<-bg> I<Color>
+
+Specifies the color to be used for the window background.
+
+=item B<-class> I<Class>
+
+Specifies the class under which resources for the application should be found.
+This option is useful in shell aliases to distinguish between invocations
+of an application, without resorting to creating links to alter the executable
+file name.
+
+=item B<-display> I<Display> | B<-screen> I<Display>
+
+Specifies the name of the X server to be used.
+
+=item B<-font> I<Font> | B<-fn> I<Font>
+
+Specifies the font to be used for displaying text.
+
+=item B<-foreground> I<Color> | B<-fg> I<Color>
+
+Specifies the color to be used for text or graphics.
+
+=item B<-geometry> I<Geometry>
+
+Specifies the initial size and location of the I<first>
+L<MainWindow|Tk::MainWindow>.
+
+=item B<-iconic>
+
+Indicates that the user would prefer that the application's windows initially
+not be visible as if the windows had been immediately iconified by the user.
+Window managers may choose not to honor the application's request.
+
+=item B<-motif>
+
+Specifies that the application should adhere as closely as possible to Motif
+look-and-feel standards. For example, active elements such as buttons and
+scrollbar sliders will not change color when the pointer passes over them.
+
+=item B<-name> I<Name>
+
+Specifies the name under which resources for the application should be found.
+This option is useful in shell aliases to distinguish between invocations
+of an application, without resorting to creating links to alter the executable
+file name.
+
+=item B<-synchronous>
+
+Indicates that requests to the X server should be sent synchronously, instead of
+asynchronously. Since Xlib normally buffers requests to the server, errors do
+do not necessarily get reported immediately after they occur. This option turns
+off the buffering so that the application can be debugged. It should never
+be used with a working program.
+
+=item B<-title> I<TitleString>
+
+This option specifies the title to be used for this window. This information is
+sometimes used by a window manager to provide some sort of header identifying
+the window.
+
+=item B<-xrm> I<ResourceString>
+
+Specifies a resource pattern and value to override any defaults. It is also
+very useful for setting resources that do not have explicit command line
+arguments.
+
+The I<ResourceString> is of the form E<lt>I<pattern>E<gt>:E<lt>I<value>E<gt>,
+that is (the first) ':' is used to determine which part is pattern and which
+part is value. The (E<lt>I<pattern>E<gt>, E<lt>I<value>E<gt>) pair is entered
+into the options database with B<optionAdd> (for each
+L<MainWindow|Tk::MainWindow> configured), with I<interactive> priority.
+
+=back
+
+=head2 Initial Resources
+
+There are several mechanism for initializing the resource database to be used
+by an X11 application. Resources may be defined in a $C<HOME>/.Xdefaults file,
+a system application defaults file (e.g.
+/usr/lib/X11/app-defaults/E<lt>B<CLASS>E<gt>),
+or a user application defaults file (e.g. $C<HOME>/E<lt>B<CLASS>E<gt>).
+The Tk::CmdLine functionality for setting initial resources concerns itself
+with the latter two.
+
+Resource files contain data lines of the form
+E<lt>I<pattern>E<gt>:E<lt>I<value>E<gt>.
+They may also contain blank lines and comment lines (denoted
+by a ! character as the first non-blank character). Refer to L<option|Tk::option>
+for a description of E<lt>I<pattern>E<gt>:E<lt>I<value>E<gt>.
+
+=over 4
+
+=item System Application Defaults Files
+
+System application defaults files may be specified via environment variable
+$C<XFILESEARCHPATH> which, if set, contains a list of file patterns
+(joined using the OS-dependent path delimiter, e.g. colon on B<UNIX>).
+
+=item User Application Defaults Files
+
+User application defaults files may be specified via environment variables
+$C<XUSERFILESEARCHPATH>, $C<XAPPLRESDIR> or $C<HOME>.
+
+=back
+
+=head1 METHODS
+
+=over 4
+
+=item B<SetArguments> - Tk::CmdLine::SetArguments([@argument])
+
+Extract the X11 options contained in a specified array (@ARGV by default).
+
+ Tk::CmdLine::SetArguments([@argument])
+
+The X11 options may be specified using a single dash I<-> as per the X11
+convention, or using two dashes I<--> as per the POSIX standard (e.g.
+B<-geometry> I<100x100>, B<-geometry> I<100x100> or B<-geometry=>I<100x100>).
+The options may be interspersed with other options or arguments.
+A I<--> by itself terminates option processing.
+
+By default, command line options are extracted from @ARGV the first time
+a MainWindow is created. The Tk::MainWindow constructor indirectly invokes
+C<SetArguments>() to do this.
+
+=item B<GetArguments> - Tk::CmdLine::GetArguments()
+
+Get a list of the X11 options that have been processed by C<SetArguments>().
+(C<GetArguments>() first invokes C<SetArguments>() if it has not already been invoked.)
+
+=item B<cget> - Tk::CmdLine::cget([$option])
+
+Get the value of a configuration option specified via C<SetArguments>().
+(C<cget>() first invokes C<SetArguments>() if it has not already been invoked.)
+
+ Tk::CmdLine::cget([$option])
+
+The valid options are: B<-class>, B<-name>, B<-screen> and B<-title>.
+If no option is specified, B<-class> is implied.
+
+A typical use of C<cget>() might be to obtain the application class in order
+to define the name of a resource file to be loaded in via C<LoadResources>().
+
+ my $class = Tk::CmdLine::cget(); # process command line and return class
+
+=item B<SetResources> - Tk::CmdLine::SetResources((\@resource | $resource) [, $priority])
+
+Set the initial resources.
+
+ Tk::CmdLine::SetResources((\@resource | $resource) [, $priority])
+
+A single resource may be specified using a string of the form
+'E<lt>I<pattern>E<gt>:E<lt>I<value>E<gt>'. Multiple resources may be specified
+by passing an array reference whose elements are either strings of the above
+form, and/or anonymous arrays of the form [ E<lt>I<pattern>E<gt>,
+E<lt>I<value>E<gt> ]. The optional second argument specifies the priority,
+as defined in L<option|Tk::option>, to be associated with the resources
+(default: I<userDefault>).
+
+Note that C<SetResources>() first invokes C<SetArguments>() if it has not already
+been invoked.
+
+=item B<LoadResources> - Tk::CmdLine::LoadResources([%options])
+
+Load initial resources from one or more files.
+
+ Tk::CmdLine::LoadResources(
+ [ -symbol => $symbol ]
+ [ -file => $fileSpec ]
+ [ -priority => $priority ]
+ [ -echo => $fileHandle ] );
+
+[ B<-symbol> =E<gt> $symbol ] specifies the name of an environment variable
+that, if set, defines a list of one or more directories and/or file patterns
+(joined using the OS-dependent path delimiter, e.g. colon on B<UNIX>).
+$C<XUSERFILESEARCHPATH> is a special case.
+If $C<XUSERFILESEARCHPATH> is not set, $C<XAPPLRESDIR> is checked instead.
+If $C<XAPPLRESDIR> is not set, $C<HOME> is checked instead.
+
+An item is identified as a file pattern if it contains one or more /%[A-Za-z]/
+patterns. Only patterns B<%L>, B<%T> and B<%N> are currently recognized. All
+others are replaced with the null string. Pattern B<%L> is translated into
+$C<LANG>. Pattern B<%T> is translated into I<app-defaults>. Pattern B<%N> is
+translated into the application class name.
+
+Each file pattern, after substitutions are applied, is assumed to define a
+FileSpec to be examined.
+
+When a directory is specified, FileSpecs
+E<lt>B<DIRECTORY>E<gt>/E<lt>B<LANG>E<gt>/E<lt>B<CLASS>E<gt>
+and E<lt>B<DIRECTORY>E<gt>/E<lt>B<CLASS>E<gt> are defined, in that order.
+
+[ B<-file> =E<gt> $fileSpec ] specifies a resource file to be loaded in.
+The file is silently skipped if if does not exist, or if it is not readable.
+
+[ B<-priority> =E<gt> $priority ] specifies the priority, as defined in
+L<option|Tk::option>, to be associated with the resources
+(default: I<userDefault>).
+
+[ B<-echo> =E<gt> $fileHandle ] may be used to specify that a line should be
+printed to the corresponding FileHandle (default: \*STDOUT) everytime a file
+is examined / loaded.
+
+If no B<-symbol> or B<-file> options are specified, C<LoadResources>()
+processes symbol $C<XFILESEARCHPATH> with priority I<startupFile> and
+$C<XUSERFILESEARCHPATH> with priority I<userDefault>.
+(Note that $C<XFILESEARCHPATH> and $C<XUSERFILESEARCHPATH> are supposed to
+contain only patterns. $C<XAPPLRESDIR> and $C<HOME> are supposed to be a single
+directory. C<LoadResources>() does not check/care whether this is the case.)
+
+For each set of FileSpecs, C<LoadResources>() examines each FileSpec to
+determine if the file exists and is readable. The first file that meets this
+criteria is read in and C<SetResources>() is invoked.
+
+Note that C<LoadResources>() first invokes C<SetArguments>() if it has not already
+been invoked.
+
+=back
+
+=head1 NOTES
+
+This module is an object-oriented module whose methods can be invoked as object
+methods, class methods or regular functions. This is accomplished via an
+internally-maintained object reference which is created as necessary, and which
+always points to the last object used. C<SetArguments>(), C<SetResources>() and
+C<LoadResources>() return the object reference.
+
+=head1 EXAMPLES
+
+=over
+
+=item 1
+
+@ARGV is processed by Tk::CmdLine at MainWindow creation.
+
+ use Tk;
+
+ # <Process @ARGV - ignoring all X11-specific options>
+
+ my $mw = MainWindow->new();
+
+ MainLoop();
+
+=item 2
+
+@ARGV is processed by Tk::CmdLine before MainWindow creation.
+An @ARGV of (--geometry=100x100 -opt1 a b c -bg red)
+is equal to (-opt1 a b c) after C<SetArguments>() is invoked.
+
+ use Tk;
+
+ Tk::CmdLine::SetArguments(); # Tk::CmdLine->SetArguments() works too
+
+ # <Process @ARGV - not worrying about X11-specific options>
+
+ my $mw = MainWindow->new();
+
+ MainLoop();
+
+=item 3
+
+Just like 2) except that default arguments are loaded first.
+
+ use Tk;
+
+ Tk::CmdLine::SetArguments(qw(-name test -iconic));
+ Tk::CmdLine::SetArguments();
+
+ # <Process @ARGV - not worrying about X11-specific options>
+
+ my $mw = MainWindow->new();
+
+ MainLoop();
+
+=item 4
+
+@ARGV is processed by Tk::CmdLine before MainWindow creation.
+Standard resource files are loaded in before MainWindow creation.
+
+ use Tk;
+
+ Tk::CmdLine::SetArguments();
+
+ # <Process @ARGV - not worrying about X11-specific options>
+
+ Tk::CmdLine::LoadResources();
+
+ my $mw = MainWindow->new();
+
+ MainLoop();
+
+=item 5
+
+@ARGV is processed by Tk::CmdLine before MainWindow creation.
+Standard resource files are loaded in before MainWindow creation
+using non-default priorities.
+
+ use Tk;
+
+ Tk::CmdLine::SetArguments();
+
+ # <Process @ARGV - not worrying about X11-specific options>
+
+ Tk::CmdLine::LoadResources(-echo => \*STDOUT,
+ -priority => 65, -symbol => 'XFILESEARCHPATH' );
+ Tk::CmdLine::LoadResources(-echo => \*STDOUT,
+ -priority => 75, -symbol => 'XUSERFILESEARCHPATH' );
+
+ my $mw = MainWindow->new();
+
+ MainLoop();
+
+=item 6
+
+@ARGV is processed by Tk::CmdLine before MainWindow creation.
+Standard resource files are loaded in before MainWindow creation.
+Individual resources are also loaded in before MainWindow creation.
+
+ use Tk;
+
+ Tk::CmdLine::SetArguments();
+
+ # <Process @ARGV - not worrying about X11-specific options>
+
+ Tk::CmdLine::LoadResources();
+
+ Tk::CmdLine::SetResources( # set a single resource
+ '*Button*background: red',
+ 'widgetDefault' );
+
+ Tk::CmdLine::SetResources( # set multiple resources
+ [ '*Button*background: red', '*Button*foreground: blue' ],
+ 'widgetDefault' );
+
+ my $mw = MainWindow->new();
+
+ MainLoop();
+
+=back
+
+=head1 ENVIRONMENT
+
+=over 4
+
+=item B<HOME> (optional)
+
+Home directory which may contain user application defaults files as
+$C<HOME>/$C<LANG>/E<lt>B<CLASS>E<gt> or $C<HOME>/E<lt>B<CLASS>E<gt>.
+
+=item B<LANG> (optional)
+
+The current language (default: I<C>).
+
+=item B<XFILESEARCHPATH> (optional)
+
+List of FileSpec patterns
+(joined using the OS-dependent path delimiter, e.g. colon on B<UNIX>)
+used in defining system application defaults files.
+
+=item B<XUSERFILESEARCHPATH> (optional)
+
+List of FileSpec patterns
+(joined using the OS-dependent path delimiter, e.g. colon on B<UNIX>)
+used in defining user application defaults files.
+
+=item B<XAPPLRESDIR> (optional)
+
+Directory containing user application defaults files as
+$C<XAPPLRESDIR>/$C<LANG>/E<lt>B<CLASS>E<gt> or
+$C<XAPPLRESDIR>/E<lt>B<CLASS>E<gt>.
+
+=back
+
+=head1 SEE ALSO
+
+L<MainWindow|Tk::MainWindow>
+L<option|Tk::option>
+
+=head1 HISTORY
+
+=over 4
+
+=item *
+
+1999.03.04 Ben Pavon E<lt>ben.pavon@hsc.hac.comE<gt>
+
+Rewritten as an object-oriented module.
+
+Allow one to process command line options in a specified array (@ARGV by default).
+Eliminate restrictions on the format and location of the options within the array
+(previously the X11 options could not be specified in POSIX format and had to be
+at the beginning of the array).
+
+Added the C<SetResources>() and C<LoadResources>() functions to allow the definition
+of resources prior to MainWindow creation.
+
+=item *
+
+2000.08.31 Ben Pavon E<lt>ben.pavon@hsc.hac.comE<gt>
+
+Added the C<GetArguments>() method which returns the list of arguments that
+have been processed by C<SetArguments>().
+
+Modified C<LoadResources>() to split the symbols using the OS-dependent
+path delimiter defined in the B<Config> module.
+
+Modified C<LoadResources>() to eliminate a warning message when processing
+patterns B<%l>, B<%C>, B<%S>.
+
+=back
+
+=cut
+
diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Configure.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Configure.pm
new file mode 100644
index 00000000000..26252ae4958
--- /dev/null
+++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Configure.pm
@@ -0,0 +1,69 @@
+package Tk::Configure;
+use vars qw($VERSION);
+$VERSION = '4.008'; # $Id: //depot/Tkutf8/Tk/Configure.pm#8 $
+
+use Carp;
+use Tk::Pretty;
+
+
+# Class that handles cget/configure for options that
+# need translating from public form
+# e.g. $cw->configure(-label => 'fred')
+# into $cw->subwiget('label')->configure(-text => 'fred')
+# Should probably do something clever with regexp's here
+
+
+sub new
+{
+ my ($class,@args) = @_;
+ unshift(@args,'configure','cget') if (@args < 3);
+ return bless \@args,$class;
+}
+
+sub cget
+{
+ croak('Wrong number of args to cget') unless (@_ == 2);
+ my ($alias,$key) = @_;
+ my ($set,$get,$widget,@args) = @$alias;
+ $widget->$get(@args);
+}
+
+sub configure
+{
+ my $alias = shift;
+ shift if (@_);
+ my ($set,$get,$widget,@args) = @$alias;
+ if (wantarray)
+ {
+ my @results;
+ eval { @results = $widget->$set(@args,@_) };
+ croak($@) if $@;
+ return @results;
+ }
+ else
+ {
+ my $results;
+ eval { $results = $widget->$set(@args,@_) };
+ croak($@) if $@;
+ return $results;
+ }
+}
+
+*TIESCALAR = \&new;
+*TIEHASH = \&new;
+
+sub FETCH
+{
+ my $alias = shift;
+ my ($set,$get,$widget,@args) = @$alias;
+ return $widget->$get(@args,@_);
+}
+
+sub STORE
+{
+ my $alias = shift;
+ my ($set,$get,$widget,@args) = @$alias;
+ $widget->$set(@args,@_);
+}
+
+1;
diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Derived.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Derived.pm
new file mode 100644
index 00000000000..c31c205d2fb
--- /dev/null
+++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Derived.pm
@@ -0,0 +1,512 @@
+# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+package Tk::Derived;
+require Tk::Widget;
+require Tk::Configure;
+use strict;
+use Carp;
+
+use vars qw($VERSION);
+$VERSION = sprintf '4.%03d', q$Revision: #10 $ =~ /\D(\d+)\s*$/;
+
+$Tk::Derived::Debug = 0;
+
+my $ENHANCED_CONFIGSPECS = 0; # disable for now
+
+use Tk qw(NORMAL_BG BLACK);
+
+sub Subwidget
+{
+ my $cw = shift;
+ my @result = ();
+ if (exists $cw->{SubWidget})
+ {
+ if (@_)
+ {
+ foreach my $name (@_)
+ {
+ push(@result,$cw->{SubWidget}{$name}) if (exists $cw->{SubWidget}{$name});
+ }
+ }
+ else
+ {
+ @result = values %{$cw->{SubWidget}};
+ }
+ }
+ return (wantarray) ? @result : $result[0];
+}
+
+sub _makelist
+{
+ my $widget = shift;
+ my (@specs) = (ref $widget && ref $widget eq 'ARRAY') ? (@$widget) : ($widget);
+ return @specs;
+}
+
+sub Subconfigure
+{
+ # This finds the widget or widgets to to which to apply a particular
+ # configure option
+ my ($cw,$opt) = @_;
+ my $config = $cw->ConfigSpecs;
+ my $widget;
+ my @subwidget = ();
+ my @arg = ();
+ if (defined $opt)
+ {
+ $widget = $config->{$opt};
+ unless (defined $widget)
+ {
+ $widget = ($opt =~ /^-(.*)$/) ? $config->{$1} : $config->{-$opt};
+ }
+ # Handle alias entries
+ if (defined($widget) && !ref($widget))
+ {
+ $opt = $widget;
+ $widget = $config->{$widget};
+ }
+ push(@arg,$opt) unless ($opt eq 'DEFAULT');
+ }
+ $widget = $config->{DEFAULT} unless (defined $widget);
+ if (defined $widget)
+ {
+ $cw->BackTrace("Invalid ConfigSpecs $widget") unless (ref($widget) && (ref $widget eq 'ARRAY'));
+ $widget = $widget->[0];
+ }
+ else
+ {
+ $widget = 'SELF';
+ }
+ foreach $widget (_makelist($widget))
+ {
+ $widget = 'SELF' if (ref($widget) && $widget == $cw);
+ if (ref $widget)
+ {
+ my $ref = ref $widget;
+ if ($ref eq 'ARRAY')
+ {
+ $widget = Tk::Configure->new(@$widget);
+ push(@subwidget,$widget)
+ }
+ elsif ($ref eq 'HASH')
+ {
+ foreach my $key (%$widget)
+ {
+ foreach my $sw (_makelist($widget->{$key}))
+ {
+ push(@subwidget,Tk::Configure->new($sw,$key));
+ }
+ }
+ }
+ else
+ {
+ push(@subwidget,$widget)
+ }
+ }
+ elsif ($widget eq 'ADVERTISED')
+ {
+ push(@subwidget,$cw->Subwidget)
+ }
+ elsif ($widget eq 'DESCENDANTS')
+ {
+ push(@subwidget,$cw->Descendants)
+ }
+ elsif ($widget eq 'CHILDREN')
+ {
+ push(@subwidget,$cw->children)
+ }
+ elsif ($widget eq 'METHOD')
+ {
+ my ($method) = ($opt =~ /^-?(.*)$/);
+ push(@subwidget,Tk::Configure->new($method,$method,$cw))
+ }
+ elsif ($widget eq 'SETMETHOD')
+ {
+ my ($method) = ($opt =~ /^-?(.*)$/);
+ push(@subwidget,Tk::Configure->new($method,'_cget',$cw,@arg))
+ }
+ elsif ($widget eq 'SELF')
+ {
+ push(@subwidget,Tk::Configure->new('Tk::configure', 'Tk::cget', $cw,@arg))
+ }
+ elsif ($widget eq 'PASSIVE')
+ {
+ push(@subwidget,Tk::Configure->new('_configure','_cget',$cw,@arg))
+ }
+ elsif ($widget eq 'CALLBACK')
+ {
+ push(@subwidget,Tk::Configure->new('_callback','_cget',$cw,@arg))
+ }
+ else
+ {
+ push(@subwidget,$cw->Subwidget($widget));
+ }
+ }
+ $cw->BackTrace("No delegate subwidget '$widget' for $opt") unless (@subwidget);
+ return (wantarray) ? @subwidget : $subwidget[0];
+}
+
+sub _cget
+{
+ my ($cw,$opt) = @_;
+ $cw->BackTrace('Wrong number of args to cget') unless (@_ == 2);
+ return $cw->{Configure}{$opt}
+}
+
+sub _configure
+{
+ my ($cw,$opt,$val) = @_;
+ $cw->BackTrace('Wrong number of args to configure') unless (@_ == 3);
+ $cw->{Configure}{$opt} = $val;
+}
+
+sub _callback
+{
+ my ($cw,$opt,$val) = @_;
+ $cw->BackTrace('Wrong number of args to configure') unless (@_ == 3);
+ $val = Tk::Callback->new($val) if defined($val) && ref($val);
+ $cw->{Configure}{$opt} = $val;
+}
+
+sub cget
+{my ($cw,$opt) = @_;
+ my @result;
+ local $SIG{'__DIE__'};
+ foreach my $sw ($cw->Subconfigure($opt))
+ {
+ if (wantarray)
+ {
+ eval { @result = $sw->cget($opt) };
+ }
+ else
+ {
+ eval { $result[0] = $sw->cget($opt) };
+ }
+ last unless $@;
+ }
+ return wantarray ? @result : $result[0];
+}
+
+sub Configured
+{
+ # Called whenever a derived widget is re-configured
+ my ($cw,$args,$changed) = @_;
+ if (@_ > 1)
+ {
+ $cw->afterIdle(['ConfigChanged',$cw,$changed]) if (%$changed);
+ }
+ return exists $cw->{'Configure'};
+}
+
+sub configure
+{
+ # The default composite widget configuration method uses hash stored
+ # in the widget's hash to map configuration options
+ # onto subwidgets.
+ #
+ my @results = ();
+ my $cw = shift;
+ if (@_ <= 1)
+ {
+ # Enquiry cases
+ my $spec = $cw->ConfigSpecs;
+ if (@_)
+ {
+ # Return info on the nominated option
+ my $opt = $_[0];
+ my $info = $spec->{$opt};
+ unless (defined $info)
+ {
+ $info = ($opt =~ /^-(.*)$/) ? $spec->{$1} : $spec->{-$opt};
+ }
+ if (defined $info)
+ {
+ if (ref $info)
+ {
+ # If the default slot is undef then ask subwidgets in turn
+ # for their default value until one accepts it.
+ if ($ENHANCED_CONFIGSPECS && !defined($info->[3]))
+ {local $SIG{'__DIE__'};
+ my @def;
+ foreach my $sw ($cw->Subconfigure($opt))
+ {
+ eval { @def = $sw->configure($opt) };
+ last unless $@;
+ }
+ $info->[3] = $def[3];
+ $info->[1] = $def[1] unless defined $info->[1];
+ $info->[2] = $def[2] unless defined $info->[2];
+ }
+ push(@results,$opt,$info->[1],$info->[2],$info->[3],$cw->cget($opt));
+ }
+ else
+ {
+ # Real (core) Tk widgets return db name rather than option name
+ # for aliases so recurse to get that ...
+ my @real = $cw->configure($info);
+ push(@results,$opt,$real[1]);
+ }
+ }
+ else
+ {
+ push(@results,$cw->Subconfigure($opt)->configure($opt));
+ }
+ }
+ else
+ {
+ my $opt;
+ my %results;
+ if (exists $spec->{'DEFAULT'})
+ {
+ foreach $opt ($cw->Subconfigure('DEFAULT')->configure)
+ {
+ $results{$opt->[0]} = $opt;
+ }
+ }
+ foreach $opt (keys %$spec)
+ {
+ $results{$opt} = [$cw->configure($opt)] if ($opt ne 'DEFAULT');
+ }
+ foreach $opt (sort keys %results)
+ {
+ push(@results,$results{$opt});
+ }
+ }
+ }
+ else
+ {
+ my (%args) = @_;
+ my %changed = ();
+ my ($opt,$val);
+ my $config = $cw->TkHash('Configure');
+
+ while (($opt,$val) = each %args)
+ {
+ my $var = \$config->{$opt};
+ my $old = $$var;
+ $$var = $val;
+ my $accepted = 0;
+ my $error = "No widget handles $opt";
+ foreach my $subwidget ($cw->Subconfigure($opt))
+ {
+ next unless (defined $subwidget);
+ eval {local $SIG{'__DIE__'}; $subwidget->configure($opt => $val) };
+ if ($@)
+ {
+ my $val2 = (defined $val) ? $val : 'undef';
+ $error = "Can't set $opt to `$val2' for $cw: " . $@;
+ undef $@;
+ }
+ else
+ {
+ $accepted = 1;
+ }
+ }
+ $cw->BackTrace($error) unless ($accepted);
+ $val = $$var;
+ $changed{$opt} = $val if (!defined $old || !defined $val || "$old" ne "$val");
+ }
+ $cw->Configured(\%args,\%changed);
+ }
+ return (wantarray) ? @results : \@results;
+}
+
+sub ConfigDefault
+{
+ my ($cw,$args) = @_;
+
+ $cw->BackTrace('Bad args') unless (defined $args && ref $args eq 'HASH');
+
+ my $specs = $cw->ConfigSpecs;
+ # Should we enforce a Delagates(DEFAULT => ) as well ?
+ $specs->{'DEFAULT'} = ['SELF'] unless (exists $specs->{'DEFAULT'});
+
+ #
+ # This is a pain with Text or Entry as core widget, they don't
+ # inherit SELF's cursor. So comment it out for Tk402.001
+ #
+ # $specs->{'-cursor'} = ['SELF',undef,undef,undef] unless (exists $specs->{'-cursor'});
+
+ # Now some hacks that cause colours to propogate down a composite widget
+ # tree - really needs more thought, other options adding such as active
+ # colours too and maybe fonts
+
+ my $child = ($cw->children)[0]; # 1st child window (if any)
+
+ unless (exists($specs->{'-background'}))
+ {
+ Tk::catch { $cw->Tk::cget('-background') };
+ my (@bg) = $@ ? ('PASSIVE') : ('SELF');
+ push(@bg,'CHILDREN') if $child;
+ $specs->{'-background'} = [\@bg,'background','Background',NORMAL_BG];
+ }
+ unless (exists($specs->{'-foreground'}))
+ {
+ Tk::catch { $cw->Tk::cget('-foreground') };
+ my (@fg) = $@ ? ('PASSIVE') : ('SELF');
+ push(@fg,'CHILDREN') if $child;
+ $specs->{'-foreground'} = [\@fg,'foreground','Foreground',BLACK];
+ }
+ $cw->ConfigAlias(-fg => '-foreground', -bg => '-background');
+
+ # Pre-scan args for aliases - this avoids defaulting
+ # options specified via alias
+ foreach my $opt (keys %$args)
+ {
+ my $info = $specs->{$opt};
+ if (defined($info) && !ref($info))
+ {
+ $args->{$info} = delete $args->{$opt};
+ }
+ }
+
+ # Now walk %$specs supplying defaults for all the options
+ # which have a defined default value, potentially looking up .Xdefaults database
+ # options for the name/class of the 'frame'
+
+ foreach my $opt (keys %$specs)
+ {
+ if ($opt ne 'DEFAULT')
+ {
+ unless (exists $args->{$opt})
+ {
+ my $info = $specs->{$opt};
+ if (ref $info)
+ {
+ # Not an alias
+ if ($ENHANCED_CONFIGSPECS && !defined $info->[3])
+ {
+ # configure inquire to fill in default slot from subwidget
+ $cw->configure($opt);
+ }
+ if (defined $info->[3])
+ {
+ if (defined $info->[1] && defined $info->[2])
+ {
+ # Should we do this on the Subconfigure widget instead?
+ # to match *Entry.Background
+ my $db = $cw->optionGet($info->[1],$info->[2]);
+ $info->[3] = $db if (defined $db);
+ }
+ $args->{$opt} = $info->[3];
+ }
+ }
+ }
+ }
+ }
+}
+
+sub ConfigSpecs
+{
+ my $cw = shift;
+ my $specs = $cw->TkHash('ConfigSpecs');
+ while (@_)
+ {
+ my $key = shift;
+ my $val = shift;
+ $specs->{$key} = $val;
+ }
+ return $specs;
+}
+
+sub _alias
+{
+ my ($specs,$opt,$main) = @_;
+ if (exists($specs->{$opt}))
+ {
+ unless (exists $specs->{$main})
+ {
+ my $targ = $specs->{$opt};
+ if (ref($targ))
+ {
+ # opt is a real option
+ $specs->{$main} = $opt
+ }
+ else
+ {
+ # opt is itself an alias
+ # make main point to same place
+ $specs->{$main} = $targ unless $targ eq $main;
+ }
+ }
+ return 1;
+ }
+ return 0;
+}
+
+sub ConfigAlias
+{
+ my $cw = shift;
+ my $specs = $cw->ConfigSpecs;
+ while (@_ >= 2)
+ {
+ my $opt = shift;
+ my $main = shift;
+ unless (_alias($specs,$opt,$main) || _alias($specs,$main,$opt))
+ {
+ $cw->BackTrace("Neither $opt nor $main exist");
+ }
+ }
+ $cw->BackTrace('Odd number of args to ConfigAlias') if (@_);
+}
+
+sub Delegate
+{
+ my ($cw,$method,@args) = @_;
+ my $widget = $cw->DelegateFor($method);
+ if ($widget == $cw)
+ {
+ $method = "Tk::Widget::$method"
+ }
+ my @result;
+ if (wantarray)
+ {
+ @result = $widget->$method(@args);
+ }
+ else
+ {
+ $result[0] = $widget->$method(@args);
+ }
+ return (wantarray) ? @result : $result[0];
+}
+
+sub InitObject
+{
+ my ($cw,$args) = @_;
+ $cw->Populate($args);
+ $cw->ConfigDefault($args);
+}
+
+sub ConfigChanged
+{
+ my ($cw,$args) = @_;
+}
+
+sub Advertise
+{
+ my ($cw,$name,$widget) = @_;
+ confess 'No name' unless (defined $name);
+ croak 'No widget' unless (defined $widget);
+ my $hash = $cw->TkHash('SubWidget');
+ $hash->{$name} = $widget; # advertise it
+ return $widget;
+}
+
+sub Component
+{
+ my ($cw,$kind,$name,%args) = @_;
+ $args{'Name'} = "\l$name" if (defined $name && !exists $args{'Name'});
+ # my $pack = delete $args{'-pack'};
+ my $delegate = delete $args{'-delegate'};
+ my $w = $cw->$kind(%args); # Create it
+ # $w->pack(@$pack) if (defined $pack);
+ $cw->Advertise($name,$w) if (defined $name);
+ $cw->Delegates(map(($_ => $w),@$delegate)) if (defined $delegate);
+ return $w; # and return it
+}
+
+1;
+__END__
+
+
diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/DummyEncode.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/DummyEncode.pm
new file mode 100644
index 00000000000..5ead808405d
--- /dev/null
+++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/DummyEncode.pm
@@ -0,0 +1,46 @@
+package Tk::DummyEncode;
+
+use vars qw($VERSION);
+$VERSION = '4.007'; # $Id: //depot/Tkutf8/Tk/DummyEncode.pm#7 $
+
+sub getEncoding
+{
+ my ($class,$name) = @_;
+ return undef unless ($name =~ /(iso8859-1|X11ControlChars)/);
+ my $pkg = $name;
+ $pkg =~ s/\W+/_/g;
+ return bless {Name => $name},$class.'::'.$pkg;
+}
+
+package Tk::DummyEncode::iso8859_1;
+sub encode
+{
+ my ($obj,$uni,$chk) = @_;
+ $_[1] = '' if $chk;
+ return $uni;
+}
+
+sub decode
+{
+ my ($obj,$byt,$chk) = @_;
+ $_[1]
+= '' if $chk;
+ return $byt;
+}
+
+package Tk::DummyEncode::X11ControlChars;
+sub encode
+{
+ my ($obj,$uni,$chk) = @_;
+ my $str = '';
+ foreach my $ch (split(//,$uni))
+ {
+ $str .= sprintf("\\x{%x}",ord($ch));
+ }
+ $_[1] = '' if $chk;
+ return $str;
+}
+
+1;
+
+__END__
diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Event.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Event.pm
new file mode 100644
index 00000000000..cecd57c54ae
--- /dev/null
+++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Event.pm
@@ -0,0 +1,13 @@
+package Tk::Event;
+use vars qw($VERSION $XS_VERSION @EXPORT_OK);
+END { CleanupGlue() }
+$VERSION = sprintf '4.%03d', q$Revision: #15 $ =~ /\D(\d+)\s*$/;
+$XS_VERSION = '804.027';
+use base qw(Exporter);
+use XSLoader;
+@EXPORT_OK = qw($XS_VERSION DONT_WAIT WINDOW_EVENTS FILE_EVENTS
+ TIMER_EVENTS IDLE_EVENTS ALL_EVENTS);
+XSLoader::load 'Tk::Event',$XS_VERSION;
+require Tk::Event::IO;
+1;
+__END__
diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Event/IO.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Event/IO.pm
new file mode 100644
index 00000000000..10b47e246ff
--- /dev/null
+++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Event/IO.pm
@@ -0,0 +1,132 @@
+package Tk::Event::IO;
+use strict;
+use Carp;
+
+use vars qw($VERSION @EXPORT_OK);
+$VERSION = sprintf '4.%03d', q$Revision: #8 $ =~ /\D(\d+)\s*$/;
+
+use base qw(Exporter);
+use Symbol ();
+
+@EXPORT_OK = qw(READABLE WRITABLE);
+
+sub PrintArgs
+{
+ my $func = (caller(1))[3];
+ print "$func(",join(',',@_),")\n";
+}
+
+sub PRINT
+{
+ my $obj = shift;
+ $obj->wait(WRITABLE);
+ my $h = $obj->handle;
+ return print $h @_;
+}
+
+sub PRINTF
+{
+ my $obj = shift;
+ $obj->wait(WRITABLE);
+ my $h = $obj->handle;
+ return printf $h @_;
+}
+
+sub WRITE
+{
+ my $obj = $_[0];
+ $obj->wait(WRITABLE);
+ return syswrite($obj->handle,$_[1],$_[2]);
+}
+
+my $depth = 0;
+sub READLINE
+{
+ my $obj = shift;
+ $obj->wait(READABLE);
+ my $h = $obj->handle;
+ my $w = <$h>;
+ return $w;
+}
+
+sub READ
+{
+ my $obj = $_[0];
+ $obj->wait(READABLE);
+ my $h = $obj->handle;
+ return sysread($h,$_[1],$_[2],defined $_[3] ? $_[3] : 0);
+}
+
+sub GETC
+{
+ my $obj = $_[0];
+ $obj->wait(READABLE);
+ my $h = $obj->handle;
+ return getc($h);
+}
+
+sub CLOSE
+{
+ my $obj = shift;
+ $obj->unwatch;
+ my $h = $obj->handle;
+ return close($h);
+}
+
+sub EOF
+{
+ my $obj = shift;
+ my $h = $obj->handle;
+ return eof($h);
+}
+
+sub FILENO
+{
+ my $obj = shift;
+ my $h = $obj->handle;
+ return fileno($h);
+}
+
+sub imode
+{
+ my $mode = shift;
+ my $imode = ${{'readable' => READABLE(),
+ 'writable' => WRITABLE()}}{$mode};
+ croak("Invalid handler type '$mode'") unless (defined $imode);
+ return $imode;
+}
+
+sub fileevent
+{
+ my ($widget,$file,$mode,$cb) = @_;
+ my $imode = imode($mode);
+ unless (ref $file)
+ {
+ no strict 'refs';
+ $file = Symbol::qualify($file,(caller)[0]);
+ $file = \*{$file};
+ }
+ my $obj = tied(*$file);
+ unless ($obj && $obj->isa('Tk::Event::IO'))
+ {
+ $obj = tie *$file,'Tk::Event::IO', $file;
+ }
+ if (@_ == 3)
+ {
+ # query return the handler
+ return $obj->handler($imode);
+ }
+ else
+ {
+ # set the handler
+ my $h = $obj->handler($imode,$cb);
+ undef $obj; # Prevent warnings about untie with ref to object
+ unless ($h)
+ {
+ untie *$file;
+ }
+ }
+}
+
+1;
+__END__
diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Frame.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Frame.pm
new file mode 100644
index 00000000000..a5716cdf9bd
--- /dev/null
+++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Frame.pm
@@ -0,0 +1,378 @@
+# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+package Tk::Frame;
+require Tk::Widget;
+require Tk::Derived;
+use AutoLoader;
+use strict qw(vars);
+use Carp;
+
+use base qw(Tk::Derived Tk::Widget);
+
+Construct Tk::Widget 'Frame';
+
+use vars qw($VERSION);
+$VERSION = '4.010'; # $Id: //depot/Tkutf8/Tk/Frame.pm#10 $
+
+sub Tk_cmd { \&Tk::frame }
+
+sub CreateOptions
+{
+ return (shift->SUPER::CreateOptions,'-colormap','-visual','-container')
+}
+
+sub Default
+{
+ my ($cw,$name,$widget) = @_;
+ confess 'No name' unless (defined $name);
+ croak 'No widget' unless (defined $widget);
+ $cw->Delegates(DEFAULT => $widget);
+ $cw->ConfigSpecs(DEFAULT => [$widget]);
+ $widget->pack('-expand' => 1, -fill => 'both') unless ($widget->manager); # Suspect
+ $cw->Advertise($name,$widget);
+}
+
+sub ConfigDelegate
+{
+ my ($cw,$name,@skip) = @_;
+ my $sw = $cw->Subwidget($name);
+ my $sc;
+ my %skip = ();
+ foreach $sc (@skip)
+ {
+ $skip{$sc} = 1;
+ }
+ foreach $sc ($sw->configure)
+ {
+ my (@info) = @$sc;
+ next if (@info == 2);
+ my $option = $info[0];
+ unless ($skip{$option})
+ {
+ $option =~ s/^-(.*)/-$name\u$1/;
+ $info[0] = Tk::Configure->new($sw,$info[0]);
+ pop(@info);
+ $cw->ConfigSpecs($option => \@info);
+ }
+ }
+}
+
+sub bind
+{my ($cw,@args) = @_;
+ $cw->Delegate('bind',@args);
+}
+
+sub menu
+{my ($cw,@args) = @_;
+ $cw->Delegate('menu',@args);
+}
+
+sub focus
+{my ($cw,@args) = @_;
+ $cw->Delegate('focus',@args);
+}
+
+#sub bindtags
+#{my ($cw,@args) = @_;
+# $cw->Delegate('bindtags',@args);
+#}
+
+sub selection
+{my ($cw,@args) = @_;
+ $cw->Delegate('selection',@args);
+}
+
+sub autoLabel { 1 }
+
+sub Populate
+{
+ my ($cw,$args) = @_;
+ if ($cw->autoLabel)
+ {
+ $cw->ConfigSpecs('-labelPack' => [ 'METHOD', undef, undef, undef]);
+ $cw->ConfigSpecs('-labelVariable' => [ 'METHOD', undef, undef, undef]);
+ $cw->ConfigSpecs('-label' => [ 'METHOD', undef, undef, undef]);
+ $cw->labelPack([]) if grep /^-label\w+/, keys %$args;
+ }
+}
+
+sub Menubar
+{
+ my $frame = shift;
+ my $menu = $frame->cget('-menu');
+ if (defined $menu)
+ {
+ $menu->configure(@_) if @_;
+ }
+ else
+ {
+ $menu = $frame->Menu(-type => 'menubar',@_);
+ $frame->configure('-menu' => $menu);
+ }
+ $frame->Advertise('menubar' => $menu);
+ return $menu;
+}
+
+1;
+
+__END__
+
+sub labelPack
+{
+ my ($cw,$val) = @_;
+ my $w = $cw->Subwidget('label');
+ my @result = ();
+ if (@_ > 1)
+ {
+ if (defined($w) && !defined($val))
+ {
+ $w->packForget;
+ }
+ elsif (defined($val) && !defined ($w))
+ {
+ require Tk::Label;
+ $w = Tk::Label->new($cw,-textvariable => $cw->labelVariable);
+ $cw->Advertise('label' => $w);
+ $cw->ConfigDelegate('label',qw(-text -textvariable));
+ }
+ if (defined($val) && defined($w))
+ {
+ my %pack = @$val;
+ unless (exists $pack{-side})
+ {
+ $pack{-side} = 'top' unless (exists $pack{-side});
+ }
+ unless (exists $pack{-fill})
+ {
+ $pack{-fill} = 'x' if ($pack{-side} =~ /(top|bottom)/);
+ $pack{-fill} = 'y' if ($pack{-side} =~ /(left|right)/);
+ }
+ unless (exists($pack{'-before'}) || exists($pack{'-after'}))
+ {
+ my $before = ($cw->packSlaves)[0];
+ $pack{'-before'} = $before if (defined $before);
+ }
+ $w->pack(%pack);
+ }
+ }
+ @result = $w->packInfo if (defined $w);
+ return (wantarray) ? @result : \@result;
+}
+
+sub labelVariable
+{
+ my ($cw,$val) = @_;
+ my $var = \$cw->{Configure}{'-labelVariable'};
+ if (@_ > 1 && defined $val)
+ {
+ $$var = $val;
+ $$val = '' unless (defined $$val);
+ my $w = $cw->Subwidget('label');
+ unless (defined $w)
+ {
+ $cw->labelPack([]);
+ $w = $cw->Subwidget('label');
+ }
+ $w->configure(-textvariable => $val);
+ }
+ return $$var;
+}
+
+sub label
+{
+ my ($cw,$val) = @_;
+ my $var = $cw->cget('-labelVariable');
+ if (@_ > 1 && defined $val)
+ {
+ if (!defined $var)
+ {
+ $var = \$cw->{Configure}{'-label'};
+ $cw->labelVariable($var);
+ }
+ $$var = $val;
+ }
+ return (defined $var) ? $$var : undef;;
+}
+
+sub queuePack
+{
+ my ($cw) = @_;
+ unless ($cw->{'pack_pending'})
+ {
+ $cw->{'pack_pending'} = 1;
+ $cw->afterIdle([$cw,'packscrollbars']);
+ }
+}
+
+sub sbset
+{
+ my ($cw,$sb,$ref,@args) = @_;
+ $sb->set(@args);
+ $cw->queuePack if (@args == 2 && $sb->Needed != $$ref);
+}
+
+sub freeze_on_map
+{
+ my ($w) = @_;
+ unless ($w->Tk::bind('Freeze','<Map>'))
+ {
+ $w->Tk::bind('Freeze','<Map>',['packPropagate' => 0])
+ }
+ $w->AddBindTag('Freeze');
+}
+
+sub AddScrollbars
+{
+ require Tk::Scrollbar;
+ my ($cw,$w) = @_;
+ my $def = '';
+ my ($x,$y) = ('','');
+ my $s = 0;
+ my $c;
+ $cw->freeze_on_map;
+ foreach $c ($w->configure)
+ {
+ my $opt = $c->[0];
+ if ($opt eq '-yscrollcommand')
+ {
+ my $slice = Tk::Frame->new($cw,Name => 'ysbslice');
+ my $ysb = Tk::Scrollbar->new($slice,-orient => 'vertical', -command => [ 'yview', $w ]);
+ my $size = $ysb->cget('-width');
+ my $corner = Tk::Frame->new($slice,Name=>'corner','-relief' => 'raised',
+ '-width' => $size, '-height' => $size);
+ $ysb->pack(-side => 'left', -fill => 'y');
+ $cw->Advertise('yscrollbar' => $ysb);
+ $cw->Advertise('corner' => $corner);
+ $cw->Advertise('ysbslice' => $slice);
+ $corner->{'before'} = $ysb->PathName;
+ $slice->{'before'} = $w->PathName;
+ $y = 'w';
+ $s = 1;
+ }
+ elsif ($opt eq '-xscrollcommand')
+ {
+ my $xsb = Tk::Scrollbar->new($cw,-orient => 'horizontal', -command => [ 'xview', $w ]);
+ $cw->Advertise('xscrollbar' => $xsb);
+ $xsb->{'before'} = $w->PathName;
+ $x = 's';
+ $s = 1;
+ }
+ }
+ if ($s)
+ {
+ $cw->Advertise('scrolled' => $w);
+ $cw->ConfigSpecs('-scrollbars' => ['METHOD','scrollbars','Scrollbars',$x.$y]);
+ }
+}
+
+sub packscrollbars
+{
+ my ($cw) = @_;
+ my $opt = $cw->cget('-scrollbars');
+ my $slice = $cw->Subwidget('ysbslice');
+ my $xsb = $cw->Subwidget('xscrollbar');
+ my $corner = $cw->Subwidget('corner');
+ my $w = $cw->Subwidget('scrolled');
+ my $xside = (($opt =~ /n/) ? 'top' : 'bottom');
+ my $havex = 0;
+ my $havey = 0;
+ $opt =~ s/r//;
+ $cw->{'pack_pending'} = 0;
+ if (defined $slice)
+ {
+ my $reqy;
+ my $ysb = $cw->Subwidget('yscrollbar');
+ if ($opt =~ /(o)?[we]/ && (($reqy = !defined($1)) || $ysb->Needed))
+ {
+ my $yside = (($opt =~ /w/) ? 'left' : 'right');
+ $slice->pack(-side => $yside, -fill => 'y',-before => $slice->{'before'});
+ $havey = 1;
+ if ($reqy)
+ {
+ $w->configure(-yscrollcommand => ['set', $ysb]);
+ }
+ else
+ {
+ $w->configure(-yscrollcommand => ['sbset', $cw, $ysb, \$cw->{'packysb'}]);
+ }
+ }
+ else
+ {
+ $w->configure(-yscrollcommand => undef) unless $opt =~ s/[we]//;
+ $slice->packForget;
+ }
+ $cw->{'packysb'} = $havey;
+ }
+ if (defined $xsb)
+ {
+ my $reqx;
+ if ($opt =~ /(o)?[ns]/ && (($reqx = !defined($1)) || $xsb->Needed))
+ {
+ $xsb->pack(-side => $xside, -fill => 'x',-before => $xsb->{'before'});
+ $havex = 1;
+ if ($reqx)
+ {
+ $w->configure(-xscrollcommand => ['set', $xsb]);
+ }
+ else
+ {
+ $w->configure(-xscrollcommand => ['sbset', $cw, $xsb, \$cw->{'packxsb'}]);
+ }
+ }
+ else
+ {
+ $w->configure(-xscrollcommand => undef) unless $opt =~ s/[ns]//;
+ $xsb->packForget;
+ }
+ $cw->{'packxsb'} = $havex;
+ }
+ if (defined $corner)
+ {
+ if ($havex && $havey && defined $corner->{'before'})
+ {
+ my $anchor = $opt;
+ $anchor =~ s/o//g;
+ $corner->configure(-height => $xsb->ReqHeight);
+ $corner->pack(-before => $corner->{'before'}, -side => $xside,
+ -anchor => $anchor, -fill => 'x');
+ }
+ else
+ {
+ $corner->packForget;
+ }
+ }
+}
+
+sub scrollbars
+{
+ my ($cw,$opt) = @_;
+ my $var = \$cw->{'-scrollbars'};
+ if (@_ > 1)
+ {
+ my $old = $$var;
+ if (!defined $old || $old ne $opt)
+ {
+ $$var = $opt;
+ $cw->queuePack;
+ }
+ }
+ return $$var;
+}
+
+sub FindMenu
+{
+ my ($w,$char) = @_;
+ my $child;
+ my $match;
+ foreach $child ($w->children)
+ {
+ next unless (ref $child);
+ $match = $child->FindMenu($char);
+ return $match if (defined $match);
+ }
+ return undef;
+}
+
+
+
diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Image.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Image.pm
new file mode 100644
index 00000000000..0f41c387fc2
--- /dev/null
+++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Image.pm
@@ -0,0 +1,74 @@
+# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+package Tk::Image;
+
+# This module does for images what Tk::Widget does for widgets:
+# provides a base class for them to inherit from.
+require DynaLoader;
+
+use base qw(DynaLoader Tk); # but are they ?
+
+use vars qw($VERSION);
+$VERSION = '4.011'; # $Id: //depot/Tkutf8/Tk/Image.pm#11 $
+
+sub new
+{
+ my $package = shift;
+ my $widget = shift;
+ $package->InitClass($widget);
+ my $leaf = $package->Tk_image;
+ my $obj = $widget->Tk::image('create',$leaf,@_);
+ $obj = $widget->_object($obj) unless (ref $obj);
+ return bless $obj,$package;
+}
+
+sub Install
+{
+ # Dynamically loaded image types can install standard images here
+ my ($class,$mw) = @_;
+}
+
+sub ClassInit
+{
+ # Carry out class bindings (or whatever)
+ my ($package,$mw) = @_;
+ return $package;
+}
+
+require Tk::Submethods;
+
+Direct Tk::Submethods ('image' => [qw(delete width height type)]);
+
+sub Tk::Widget::imageNames
+{
+ my $w = shift;
+ $w->image('names',@_);
+}
+
+sub Tk::Widget::imageTypes
+{
+ my $w = shift;
+ map("\u$_",$w->image('types',@_));
+}
+
+sub Construct
+{
+ my ($base,$name) = @_;
+ my $class = (caller(0))[0];
+
+ # Hack for broken ->isa in perl5.6.0
+ delete ${"$class\::"}{'::ISA::CACHE::'} if $] == 5.006;
+
+ *{"Tk::Widget::$name"} = sub { $class->new(@_) };
+}
+
+# This is here to prevent AUTOLOAD trying to find it.
+sub DESTROY
+{
+ my $i = shift;
+ # maybe do image delete ???
+}
+
+
+1;
diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Label.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Label.pm
new file mode 100644
index 00000000000..ebea1741c2f
--- /dev/null
+++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Label.pm
@@ -0,0 +1,21 @@
+# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package Tk::Label;
+require Tk;
+
+
+use vars qw($VERSION);
+$VERSION = '4.006'; # $Id: //depot/Tkutf8/Tk/Label.pm#6 $
+
+use base qw(Tk::Widget);
+
+Construct Tk::Widget 'Label';
+
+sub Tk_cmd { \&Tk::label }
+
+1;
+
+
+
diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/MainWindow.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/MainWindow.pm
new file mode 100644
index 00000000000..5384ccb560b
--- /dev/null
+++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/MainWindow.pm
@@ -0,0 +1,213 @@
+# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+package Tk::MainWindow;
+use base qw(Tk::Toplevel);
+BEGIN { @MainWindow::ISA = 'Tk::MainWindow' }
+
+use strict;
+
+use vars qw($VERSION);
+$VERSION = sprintf '4.%03d', q$Revision: #12 $ =~ /\D(\d+)\s*$/;
+
+use Tk::CmdLine;
+use Tk qw(catch);
+require Tk::Toplevel;
+
+use Carp;
+
+$| = 1;
+
+my $pid = $$;
+
+my %Windows = ();
+
+sub CreateArgs
+{
+ my ($class,$args) = @_;
+ my $cmd = Tk::CmdLine->CreateArgs();
+ my $key;
+ foreach $key (keys %$cmd)
+ {
+ $args->{$key} = $cmd->{$key} unless exists $args->{$key};
+ }
+ my %result = $class->SUPER::CreateArgs(undef,$args);
+ my $name = delete($args->{'-name'});
+ unless (Tk::tainting)
+ {
+ $ENV{'DISPLAY'} = ':0' unless (exists $ENV{'DISPLAY'});
+ $result{'-screen'} = $ENV{'DISPLAY'} unless exists $result{'-screen'};
+ }
+ return (-name => "\l$name",%result);
+}
+
+sub new
+{
+ my $package = shift;
+ if (@_ > 0 && $_[0] =~ /:\d+(\.\d+)?$/)
+ {
+ carp "Usage $package->new(-screen => '$_[0]' ...)" if $^W;
+ unshift(@_,'-screen');
+ }
+ croak('Odd number of args'."$package->new(" . join(',',@_) .')') if @_ % 2;
+ my %args = @_;
+
+ my $top = eval { bless Create($package->CreateArgs(\%args)), $package };
+ croak($@ . "$package->new(" . join(',',@_) .')') if ($@);
+ $top->apply_command_line;
+ $top->InitBindings;
+ $top->SetBindtags;
+ $top->InitObject(\%args);
+ eval { $top->configure(%args) };
+ croak "$@" if ($@);
+ if (($top->positionfrom||'') ne 'user' and ($top->sizefrom||'') ne 'user') {
+ my $geometry = $top->optionGet(qw(geometry Geometry));
+ if ($geometry) {
+ $top->geometry($geometry);
+ }
+ }
+ $Windows{$top} = $top;
+ return $top;
+}
+
+sub _Destroyed
+{
+ my $top = shift;
+ $top->SUPER::_Destroyed;
+ delete $Windows{$top};
+}
+
+sub InitBindings
+{
+ my $mw = shift;
+ $mw->bind('all','<Tab>','focusNext');
+ # <<LeftTab>> is named <<PrevWindow>> in Tcl/Tk
+ $mw->eventAdd(qw[<<LeftTab>> <Shift-Tab>]);
+ # This is needed for XFree86 systems
+ catch { $mw->eventAdd(qw[<<LeftTab>> <ISO_Left_Tab>]) };
+ # This seems to be correct on *some* HP systems.
+ catch { $mw->eventAdd(qw[<<LeftTab>> <hpBackTab>]) };
+ $mw->bind('all','<<LeftTab>>','focusPrev');
+ if ($mw->windowingsystem eq 'x11')
+ {
+ $mw->eventAdd(qw[<<Cut>> <Control-Key-x> <Key-F20> <Meta-Key-w>]);
+ $mw->eventAdd(qw[<<Copy>> <Control-Key-c> <Key-F16> <Control-Key-w>]);
+ $mw->eventAdd(qw[<<Paste>> <Control-Key-v> <Key-F18> <Control-Key-y>]);
+ $mw->eventAdd(qw[<<PasteSelection>> <ButtonRelease-2>]);
+ $mw->eventAdd(qw[<<Undo>> <Control-Key-z> <Key-Undo> <Key-F14>
+ <Control-Key-underscore>]);
+ $mw->eventAdd(qw[<<Redo>> <Control-Key-y> <Shift-Key-Undo> <Key-F12> <Shift-Key-F14>]);
+ }
+ elsif ($mw->windowingsystem eq 'win32')
+ {
+ $mw->eventAdd(qw[<<Cut>> <Control-Key-x> <Shift-Key-Delete>]);
+ $mw->eventAdd(qw[<<Copy>> <Control-Key-c> <Control-Key-Insert>]);
+ $mw->eventAdd(qw[<<Paste>> <Control-Key-v> <Shift-Key-Insert>]);
+ $mw->eventAdd(qw[<<Undo>> <Control-Key-z>]);
+ $mw->eventAdd(qw[<<Redo>> <Control-Key-y>]);
+ }
+ elsif ($mw->windowingsystem eq 'aqua')
+ {
+ $mw->eventAdd(qw[<<Cut>> <Command-Key-x> <Key-F2>]);
+ $mw->eventAdd(qw[<<Copy>> <Command-Key-c> <Key-F3>]);
+ $mw->eventAdd(qw[<<Paste>> <Command-Key-v> <Key-F4>]);
+ $mw->eventAdd(qw[<<PasteSelection>> <ButtonRelease-2>]);
+ $mw->eventAdd(qw[<<Clear>> <Clear>]);
+ $mw->eventAdd(qw[<<Undo>> <Command-Key-z>]);
+ $mw->eventAdd(qw[<<Redo>> <Command-Key-y>]);
+ }
+ elsif ($mw->windowingsystem eq 'classic')
+ {
+ $mw->eventAdd(qw[<<Cut>> <Control-Key-x> <Key-F2>]);
+ $mw->eventAdd(qw[<<Copy>> <Control-Key-c> <Key-F3>]);
+ $mw->eventAdd(qw[<<Paste>> <Control-Key-v> <Key-F4>]);
+ $mw->eventAdd(qw[<<PasteSelection>> <ButtonRelease-2>]);
+ $mw->eventAdd(qw[<<Clear>> <Clear>]);
+ $mw->eventAdd(qw[<<Undo>> <Control-Key-z> <Key-F1>]);
+ $mw->eventAdd(qw[<<Redo>> <Control-Key-Z>]);
+ }
+
+ # FIXME - Should these move to Menubutton ?
+ my $c = ($Tk::platform eq 'unix') ? 'all' : 'Tk::Menubutton';
+ $mw->bind($c,'<Alt-KeyPress>',['TraverseToMenu',Tk::Ev('K')]);
+ $mw->bind($c,'<F10>','FirstMenu');
+}
+
+sub Existing
+{
+ my @Windows;
+ foreach my $name (keys %Windows)
+ {
+ my $obj = $Windows{$name};
+ if (Tk::Exists($obj))
+ {
+ push(@Windows,$obj);
+ }
+ else
+ {
+ delete $Windows{$name};
+ }
+ }
+ return @Windows;
+}
+
+END
+{
+ if (Tk::IsParentProcess())
+ {
+ foreach my $top (values %Windows)
+ {
+ if ($top->IsWidget)
+ {
+ # Tk data structuctures are still in place
+ # this can occur if non-callback perl code did a 'die'.
+ # It will also handle some cases of non-Tk 'exit' being called
+ # Destroy this mainwindow and hence is descendants ...
+ $top->destroy;
+ }
+ }
+ }
+}
+
+sub CmdLine { return shift->command }
+
+sub WMSaveYourself
+{
+ my $mw = shift;
+ my @args = @{$mw->command};
+# warn 'preWMSaveYourself:'.join(' ',@args)."\n";
+ @args = ($0) unless (@args);
+ my $i = 1;
+ while ($i < @args)
+ {
+ if ($args[$i] eq '-iconic')
+ {
+ splice(@args,$i,1);
+ }
+ elsif ($args[$i] =~ /^-(geometry|iconposition)$/)
+ {
+ splice(@args,$i,2);
+ }
+ }
+
+ my @ip = $mw->wm('iconposition');
+# print 'ip ',join(',',@ip),"\n";
+ my $icon = $mw->iconwindow;
+ if (defined($icon))
+ {
+ @ip = $icon->geometry =~ /\d+x\d+([+-]\d+)([+-]\d+)/;
+ }
+ splice(@args,1,0,'-iconposition' => join(',',@ip)) if (@ip == 2);
+
+ splice(@args,1,0,'-iconic') if ($mw->state() eq 'iconic');
+
+ splice(@args,1,0,'-geometry' => $mw->geometry);
+# warn 'postWMSaveYourself:'.join(' ',@args)."\n";
+ $mw->command([@args]);
+}
+
+1;
+
+__END__
+
+=cut
diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Pretty.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Pretty.pm
new file mode 100644
index 00000000000..7e442a4bcbc
--- /dev/null
+++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Pretty.pm
@@ -0,0 +1,93 @@
+# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+package Tk::Pretty;
+require Exporter;
+
+use vars qw($VERSION @EXPORT);
+$VERSION = '4.006'; # $Id: //depot/Tkutf8/Tk/Pretty.pm#6 $
+
+use base qw(Exporter);
+
+@EXPORT = qw(Pretty PrintArgs);
+
+sub pretty_list
+{
+ join(',',map(&Pretty($_),@_));
+}
+
+sub Pretty
+{
+ return pretty_list(@_) if (@_ > 1);
+ my $obj = shift;
+ return 'undef' unless defined($obj);
+ my $type = "$obj";
+ return $type if ($type =~ /=HASH/ && exists($obj->{"_Tcl_CmdInfo_\0"}));
+ my $result = '';
+ if (ref $obj)
+ {
+ my $class;
+ if ($type =~ /^([^=]+)=(.*)$/)
+ {
+ $class = $1;
+ $type = $2;
+ $result .= 'bless(';
+ }
+ if ($type =~ /^ARRAY/)
+ {
+ $result .= '[';
+ $result .= pretty_list(@$obj);
+ $result .= ']';
+ }
+ elsif ($type =~ /^HASH/)
+ {
+ $result .= '{';
+ if (%$obj)
+ {
+ my ($key, $value);
+ while (($key,$value) = each %$obj)
+ {
+ $result .= $key . '=>' . Pretty($value) . ',';
+ }
+ chop($result);
+ }
+ $result .= '}';
+ }
+ elsif ($type =~ /^REF/)
+ {
+ $result .= "\\" . Pretty($$obj);
+ }
+ elsif ($type =~ /^SCALAR/)
+ {
+ $result .= Pretty($$obj);
+ }
+ else
+ {
+ $result .= $type;
+ }
+ $result .= ",$class)" if (defined $class);
+ }
+ else
+ {
+ if ($obj =~ /^-?[0-9]+(.[0-9]*(e[+-][0-9]+)?)?$/ ||
+ $obj =~ /^[A-Z_][A-Za-z_0-9]*$/ ||
+ $obj =~ /^[a-z_][A-Za-z_0-9]*[A-Z_][A-Za-z_0-9]*$/
+ )
+ {
+ $result .= $obj;
+ }
+ else
+ {
+ $result .= "'" . $obj . "'";
+ }
+ }
+ return $result;
+}
+
+sub PrintArgs
+{
+ my $name = (caller(1))[3];
+ print "$name(",Pretty(@_),")\n";
+}
+
+1;
diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Submethods.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Submethods.pm
new file mode 100644
index 00000000000..a2b8e3bd186
--- /dev/null
+++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Submethods.pm
@@ -0,0 +1,46 @@
+package Tk::Submethods;
+
+use vars qw($VERSION);
+$VERSION = '4.004'; # $Id: //depot/Tkutf8/Tk/Submethods.pm#4 $
+
+sub import
+{
+ my $class = shift;
+ no strict 'refs';
+ my $package = caller(0);
+ while (@_)
+ {
+ my $fn = shift;
+ my $sm = shift;
+ foreach my $sub (@{$sm})
+ {
+ my ($suffix) = $sub =~ /(\w+)$/;
+ my $pfn = $package.'::'.$fn;
+ *{$pfn."\u$suffix"} = sub { shift->$pfn($sub,@_) };
+ }
+ }
+}
+
+sub Direct
+{
+ my $class = shift;
+ no strict 'refs';
+ my $package = caller(0);
+ while (@_)
+ {
+ my $fn = shift;
+ my $sm = shift;
+ my $sub;
+ foreach $sub (@{$sm})
+ {
+ # eval "sub ${package}::${sub} { shift->$fn('$sub',\@_) }";
+ *{$package.'::'.$sub} = sub { shift->$fn($sub,@_) };
+ }
+ }
+}
+
+1;
+
+__END__
+
+=cut
diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Toplevel.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Toplevel.pm
new file mode 100644
index 00000000000..7bcd156d475
--- /dev/null
+++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Toplevel.pm
@@ -0,0 +1,211 @@
+# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+package Tk::Toplevel;
+use AutoLoader;
+
+use vars qw($VERSION);
+$VERSION = '4.006'; # $Id: //depot/Tkutf8/Tk/Toplevel.pm#6 $
+
+use base qw(Tk::Wm Tk::Frame);
+
+Construct Tk::Widget 'Toplevel';
+
+sub Tk_cmd { \&Tk::toplevel }
+
+sub CreateOptions
+{
+ return (shift->SUPER::CreateOptions,'-screen','-use')
+}
+
+sub Populate
+{
+ my ($cw,$arg) = @_;
+ $cw->SUPER::Populate($arg);
+ $cw->ConfigSpecs('-title',['METHOD',undef,undef,$cw->class]);
+}
+
+sub Icon
+{
+ my ($top,%args) = @_;
+ my $icon = $top->iconwindow;
+ my $state = $top->state;
+ if ($state ne 'withdrawn')
+ {
+ $top->withdraw;
+ $top->update; # Let attributes propogate
+ }
+ unless (defined $icon)
+ {
+ $icon = Tk::Toplevel->new($top,'-borderwidth' => 0,'-class'=>'Icon');
+ $icon->withdraw;
+ # Fake Populate
+ my $lab = $icon->Component('Label' => 'icon');
+ $lab->pack('-expand'=>1,'-fill' => 'both');
+ $icon->ConfigSpecs(DEFAULT => ['DESCENDANTS']);
+ # Now do tail of InitObject
+ $icon->ConfigDefault(\%args);
+ # And configure that new would have done
+ $top->iconwindow($icon);
+ $top->update;
+ $lab->DisableButtonEvents;
+ $lab->update;
+ }
+ $top->iconimage($args{'-image'}) if (exists $args{'-image'});
+ $icon->configure(%args);
+ $icon->idletasks; # Let size request propogate
+ $icon->geometry($icon->ReqWidth . 'x' . $icon->ReqHeight);
+ $icon->update; # Let attributes propogate
+ $top->deiconify if ($state eq 'normal');
+ $top->iconify if ($state eq 'iconic');
+}
+
+sub menu
+{
+ my $w = shift;
+ my $menu;
+ $menu = $w->cget('-menu');
+ unless (defined $menu)
+ {
+ $w->configure(-menu => ($menu = $w->SUPER::menu))
+ }
+ $menu->configure(@_) if @_;
+ return $menu;
+}
+
+
+1;
+__END__
+
+#----------------------------------------------------------------------
+#
+# Focus Group
+#
+# Focus groups are used to handle the user's focusing actions inside a
+# toplevel.
+#
+# One example of using focus groups is: when the user focuses on an
+# entry, the text in the entry is highlighted and the cursor is put to
+# the end of the text. When the user changes focus to another widget,
+# the text in the previously focused entry is validated.
+#
+
+#----------------------------------------------------------------------
+# tkFocusGroup_Create --
+#
+# Create a focus group. All the widgets in a focus group must be
+# within the same focus toplevel. Each toplevel can have only
+# one focus group, which is identified by the name of the
+# toplevel widget.
+#
+sub FG_Create {
+ my $t = shift;
+ unless (exists $t->{'_fg'}) {
+ $t->{'_fg'} = 1;
+ $t->bind('<FocusIn>', sub {
+ my $w = shift;
+ my $Ev = $w->XEvent;
+ $t->FG_In($w, $Ev->d);
+ }
+ );
+ $t->bind('<FocusOut>', sub {
+ my $w = shift;
+ my $Ev = $w->XEvent;
+ $t->FG_Out($w, $Ev->d);
+ }
+ );
+ $t->bind('<Destroy>', sub {
+ my $w = shift;
+ my $Ev = $w->XEvent;
+ $t->FG_Destroy($w);
+ }
+ );
+ # <Destroy> is not sufficient to break loops if never mapped.
+ $t->OnDestroy([$t,'FG_Destroy']);
+ }
+}
+
+# tkFocusGroup_BindIn --
+#
+# Add a widget into the "FocusIn" list of the focus group. The $cmd will be
+# called when the widget is focused on by the user.
+#
+sub FG_BindIn {
+ my($t, $w, $cmd) = @_;
+ $t->Error("focus group \"$t\" doesn't exist") unless (exists $t->{'_fg'});
+ $t->{'_FocusIn'}{$w} = Tk::Callback->new($cmd);
+}
+
+# tkFocusGroup_BindOut --
+#
+# Add a widget into the "FocusOut" list of the focus group. The
+# $cmd will be called when the widget loses the focus (User
+# types Tab or click on another widget).
+#
+sub FG_BindOut {
+ my($t, $w, $cmd) = @_;
+ $t->Error("focus group \"$t\" doesn't exist") unless (exists $t->{'_fg'});
+ $t->{'_FocusOut'}{$w} = Tk::Callback->new($cmd);
+}
+
+# tkFocusGroup_Destroy --
+#
+# Cleans up when members of the focus group is deleted, or when the
+# toplevel itself gets deleted.
+#
+sub FG_Destroy {
+ my($t, $w) = @_;
+ if (!defined($w) || $t == $w) {
+ delete $t->{'_fg'};
+ delete $t->{'_focus'};
+ delete $t->{'_FocusOut'};
+ delete $t->{'_FocusIn'};
+ } else {
+ if (exists $t->{'_focus'}) {
+ delete $t->{'_focus'} if ($t->{'_focus'} == $w);
+ }
+ delete $t->{'_FocusIn'}{$w};
+ delete $t->{'_FocusOut'}{$w};
+ }
+}
+
+# tkFocusGroup_In --
+#
+# Handles the <FocusIn> event. Calls the FocusIn command for the newly
+# focused widget in the focus group.
+#
+sub FG_In {
+ my($t, $w, $detail) = @_;
+ if (defined $t->{'_focus'} and $t->{'_focus'} eq $w) {
+ # This is already in focus
+ return;
+ } else {
+ $t->{'_focus'} = $w;
+ $t->{'_FocusIn'}{$w}->Call if exists $t->{'_FocusIn'}{$w};
+ }
+}
+
+# tkFocusGroup_Out --
+#
+# Handles the <FocusOut> event. Checks if this is really a lose
+# focus event, not one generated by the mouse moving out of the
+# toplevel window. Calls the FocusOut command for the widget
+# who loses its focus.
+#
+sub FG_Out {
+ my($t, $w, $detail) = @_;
+ if ($detail ne 'NotifyNonlinear' and $detail ne 'NotifyNonlinearVirtual') {
+ # This is caused by mouse moving out of the window
+ return;
+ }
+ unless (exists $t->{'_FocusOut'}{$w}) {
+ return;
+ } else {
+ $t->{'_FocusOut'}{$w}->Call;
+ delete $t->{'_focus'};
+ }
+}
+
+1;
+
+__END__
diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Widget.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Widget.pm
new file mode 100644
index 00000000000..e94c037e6fe
--- /dev/null
+++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Widget.pm
@@ -0,0 +1,1510 @@
+# Copyright (c) 1995-2004 Nick Ing-Simmons. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+package Tk::Widget;
+use vars qw($VERSION @DefaultMenuLabels);
+$VERSION = sprintf '4.%03d', q$Revision: #30 $ =~ /\D(\d+)\s*$/;
+
+require Tk;
+use AutoLoader;
+use strict;
+use Carp;
+use base qw(DynaLoader Tk);
+
+# stubs for 'autoloaded' widget classes
+sub Button;
+sub Canvas;
+sub Checkbutton;
+sub Entry;
+sub Frame;
+sub Label;
+sub Labelframe;
+sub Listbox;
+sub Menu;
+sub Menubutton;
+sub Message;
+sub Panedwindow;
+sub Radiobutton;
+sub Scale;
+sub Scrollbar;
+sub Spinbox;
+sub Text;
+sub Toplevel;
+
+sub Pixmap;
+sub Bitmap;
+sub Photo;
+
+sub ScrlListbox;
+sub Optionmenu;
+
+sub import
+{
+ my $package = shift;
+ carp 'use Tk::Widget () to pre-load widgets is deprecated' if (@_);
+ my $need;
+ foreach $need (@_)
+ {
+ unless (defined &{$need})
+ {
+ require "Tk/${need}.pm";
+ }
+ croak "Cannot locate $need" unless (defined &{$need});
+ }
+}
+
+@DefaultMenuLabels = qw[~File ~Help];
+
+# Some tidy-ness functions for winfo stuff
+
+sub True { 1 }
+sub False { 0 }
+
+use Tk::Submethods( 'grab' => [qw(current status release -global)],
+ 'focus' => [qw(-force -lastfor)],
+ 'pack' => [qw(configure forget info propagate slaves)],
+ 'grid' => [qw(bbox columnconfigure configure forget info location propagate rowconfigure size slaves)],
+ 'form' => [qw(check configure forget grid info slaves)],
+ 'event' => [qw(add delete generate info)],
+ 'place' => [qw(configure forget info slaves)],
+ 'wm' => [qw(capture release)],
+ 'font' => [qw(actual configure create delete families measure metrics names subfonts)]
+ );
+
+BEGIN {
+ # FIXME - these don't work in the compiler
+ *IsMenu = \&False;
+ *IsMenubutton = \&False;
+ *configure_self = \&Tk::configure;
+ *cget_self = \&Tk::cget;
+}
+
+
+
+Direct Tk::Submethods (
+ 'winfo' => [qw(cells class colormapfull depth exists
+ geometry height id ismapped manager name parent reqheight
+ reqwidth rootx rooty screen screencells screendepth screenheight
+ screenmmheight screenmmwidth screenvisual screenwidth visual
+ visualsavailable vrootheight viewable vrootwidth vrootx vrooty
+ width x y toplevel children pixels pointerx pointery pointerxy
+ server fpixels rgb )],
+ 'tk' => [qw(appname caret scaling useinputmethods windowingsystem)]);
+
+
+sub DESTROY
+{
+ my $w = shift;
+ $w->destroy if ($w->IsWidget);
+}
+
+sub Install
+{
+ # Dynamically loaded widgets add their core commands
+ # to the Tk base class here
+ my ($package,$mw) = @_;
+}
+
+sub ClassInit
+{
+ # Carry out class bindings (or whatever)
+ my ($package,$mw) = @_;
+ return $package;
+}
+
+sub CreateOptions
+{
+ return ();
+}
+
+sub CreateArgs
+{
+ my ($package,$parent,$args) = @_;
+ # Remove from hash %$args any configure-like
+ # options which only apply at create time (e.g. -colormap for Frame),
+ # or which may as well be applied right away
+ # return these as a list of -key => value pairs
+ # Augment same hash with default values for missing mandatory options,
+ # allthough this can be done later in InitObject.
+
+ # Honour -class => if present, we have hacked Tk_ConfigureWidget to
+ # allow -class to be passed to any widget.
+ my @result = ();
+ my $class = delete $args->{'-class'};
+ ($class) = $package =~ /([A-Z][A-Z0-9_]*)$/i unless (defined $class);
+ @result = (-class => "\u$class") if (defined $class);
+ foreach my $opt ($package->CreateOptions)
+ {
+ push(@result, $opt => delete $args->{$opt}) if exists $args->{$opt};
+ }
+ return @result;
+}
+
+sub InitObject
+{
+ my ($obj,$args) = @_;
+ # per object initialization, for example populating
+ # with sub-widgets, adding a few object bindings to augment
+ # inherited class bindings, changing binding tags.
+ # Also another chance to mess with %$args before configure...
+}
+
+sub SetBindtags
+{
+ my ($obj) = @_;
+ $obj->bindtags([ref($obj),$obj,$obj->toplevel,'all']);
+}
+
+sub new
+{
+ local $SIG{'__DIE__'} = \&Carp::croak;
+ my $package = shift;
+ my $parent = shift;
+ $package->InitClass($parent);
+ $parent->BackTrace("Odd number of args to $package->new(...)") unless ((@_ % 2) == 0);
+ my %args = @_;
+ my @args = $package->CreateArgs($parent,\%args);
+ my $cmd = $package->Tk_cmd;
+ my $pname = $parent->PathName;
+ $pname = '' if ($pname eq '.');
+ my $leaf = delete $args{'Name'};
+ if (defined $leaf)
+ {
+ $leaf =~ s/[^a-z0-9_#]+/_/ig;
+ $leaf = lcfirst($leaf);
+ }
+ else
+ {
+ ($leaf) = "\L$package" =~ /([a-z][a-z0-9_]*)$/;
+ }
+ my $lname = $pname . '.' . $leaf;
+ # create a hash indexed by leaf name to speed up
+ # creation of a lot of sub-widgets of the same type
+ # e.g. entries in Table
+ my $nhash = $parent->TkHash('_names_');
+ $nhash->{$leaf} = 0 unless (exists $nhash->{$leaf});
+ while (defined ($parent->Widget($lname)))
+ {
+ $lname = $pname . '.' . $leaf . ++$nhash->{$leaf};
+ }
+ my $obj = eval { &$cmd($parent, $lname, @args) };
+ confess $@ if $@;
+ unless (ref $obj)
+ {
+ die "No value from $cmd $lname" unless defined $obj;
+ warn "$cmd '$lname' returned '$obj'" unless $obj eq $lname;
+ $obj = $parent->Widget($lname = $obj);
+ die "$obj from $lname" unless ref $obj;
+ }
+ bless $obj,$package;
+ $obj->SetBindtags;
+ my $notice = $parent->can('NoticeChild');
+ $parent->$notice($obj,\%args) if $notice;
+ $obj->InitObject(\%args);
+# ASkludge(\%args,1);
+ $obj->configure(%args) if (%args);
+# ASkludge(\%args,0);
+ return $obj;
+}
+
+sub DelegateFor
+{
+ my ($w,$method) = @_;
+ while(exists $w->{'Delegates'})
+ {
+ my $delegate = $w->{'Delegates'};
+ my $widget = $delegate->{$method};
+ $widget = $delegate->{DEFAULT} unless (defined $widget);
+ $widget = $w->Subwidget($widget) if (defined $widget && !ref $widget);
+ last unless (defined $widget);
+ last if $widget == $w;
+ $w = $widget;
+ }
+ return $w;
+}
+
+sub Delegates
+{
+ my $cw = shift;
+ my $specs = $cw->TkHash('Delegates');
+ while (@_)
+ {
+ my $key = shift;
+ my $val = shift;
+ $specs->{$key} = $val;
+ }
+ return $specs;
+}
+
+sub Construct
+{
+ my ($base,$name) = @_;
+ my $class = (caller(0))[0];
+ no strict 'refs';
+
+ # Hack for broken ->isa in perl5.6.0
+ delete ${"$class\::"}{'::ISA::CACHE::'} if $] == 5.006;
+
+ # Pre ->isa scheme
+ *{$base.'::Is'.$name} = \&False;
+ *{$class.'::Is'.$name} = \&True;
+
+ # DelegateFor trickyness is to allow Frames and other derived things
+ # to force creation in a delegate e.g. a ScrlText with embeded windows
+ # need those windows to be children of the Text to get clipping right
+ # and not of the Frame which contains the Text and the scrollbars.
+ *{$base.'::'."$name"} = sub { $class->new(shift->DelegateFor('Construct'),@_) };
+}
+
+sub IS
+{
+ return (defined $_[1]) && $_[0] == $_[1];
+}
+
+sub _AutoloadTkWidget
+{
+ my ($self,$method) = @_;
+ my $what = "Tk::Widget::$method";
+ unless (defined &$what)
+ {
+ require "Tk/$method.pm";
+ }
+ return $what;
+}
+
+# require UNIVERSAL; don't load .pm use XS code from perl core though
+
+sub AUTOLOAD
+{
+ # Take a copy into a 'my' variable so we can recurse
+ my $what = $Tk::Widget::AUTOLOAD;
+ my $save = $@;
+ my $name;
+ # warn "AUTOLOAD $what ".(ref($_[0]) || $_[0])."\n";
+ # Braces used to preserve $1 et al.
+ {
+ my ($pkg,$func) = $what =~ /(.*)::([^:]+)$/;
+ confess("Attempt to load '$what'") unless defined($pkg) && $func =~ /^[\w:]+$/;
+ $pkg =~ s#::#/#g;
+ if (defined($name=$INC{"$pkg.pm"}))
+ {
+ $name =~ s#^(.*)$pkg\.pm$#$1auto/$pkg/$func.al#;
+ }
+ else
+ {
+ $name = "auto/$what.al";
+ $name =~ s#::#/#g;
+ }
+ }
+ # This may fail, catch error and prevent user's __DIE__ handler
+ # from triggering as well...
+ eval {local $SIG{'__DIE__'}; require $name};
+ if ($@)
+ {
+ croak $@ unless ($@ =~ /Can't locate\s+(?:file\s+)?'?\Q$name\E'?/);
+ my($package,$method) = ($what =~ /^(.*)::([^:]*)$/);
+ if (ref $_[0] && !$_[0]->can($method)
+ && $_[0]->can('Delegate')
+ && $method !~ /^(ConfigSpecs|Delegates)/ )
+ {
+ my $delegate = $_[0]->Delegates;
+ if (%$delegate || tied %$delegate)
+ {
+ my $widget = $delegate->{$method};
+ $widget = $delegate->{DEFAULT} unless (defined $widget);
+ if (defined $widget)
+ {
+ my $subwidget = (ref $widget) ? $widget : $_[0]->Subwidget($widget);
+ if (defined $subwidget)
+ {
+ no strict 'refs';
+ # print "AUTOLOAD: $what\n";
+ *{$what} = sub { shift->Delegate($method,@_) };
+ }
+ else
+ {
+ croak "No delegate subwidget '$widget' for $what";
+ }
+ }
+ }
+ }
+ if (!defined(&$what) && ref($_[0]) && $method =~ /^[A-Z]\w+$/)
+ {
+ # Use ->can as ->isa is broken in perl5.6.0
+ my $sub = UNIVERSAL::can($_[0],'_AutoloadTkWidget');
+ if ($sub)
+ {
+ carp "Assuming 'require Tk::$method;'" unless $_[0]->can($method);
+ $what = $_[0]->$sub($method)
+ }
+ }
+ }
+ $@ = $save;
+ $DB::sub = $what; # Tell debugger what is going on...
+ unless (defined &$what)
+ {
+ no strict 'refs';
+ *{$what} = sub { croak("Failed to AUTOLOAD '$what'") };
+ }
+ goto &$what;
+}
+
+sub _Destroyed
+{
+ my $w = shift;
+ my $a = delete $w->{'_Destroy_'};
+ if (ref($a))
+ {
+ while (@$a)
+ {
+ my $ent = pop(@$a);
+ if (ref $ent)
+ {
+ eval {local $SIG{'__DIE__'}; $ent->Call };
+ }
+ else
+ {
+ delete $w->{$ent};
+ }
+ }
+ }
+}
+
+sub _OnDestroy
+{
+ my $w = shift;
+ $w->{'_Destroy_'} = [] unless (exists $w->{'_Destroy_'});
+ push(@{$w->{'_Destroy_'}},@_);
+}
+
+sub OnDestroy
+{
+ my $w = shift;
+ $w->_OnDestroy(Tk::Callback->new(@_));
+}
+
+sub TkHash
+{
+ my ($w,$key) = @_;
+ return $w->{$key} if exists $w->{$key};
+ my $hash = $w->{$key} = {};
+ $w->_OnDestroy($key);
+ return $hash;
+}
+
+sub privateData
+{
+ my $w = shift;
+ my $p = shift || caller;
+ $w->{$p} ||= {};
+}
+
+my @image_types;
+my %image_method;
+
+sub ImageMethod
+{
+ shift if (@_ & 1);
+ while (@_)
+ {
+ my ($name,$method) = splice(@_,0,2);
+ push(@image_types,$name);
+ $image_method{$name} = $method;
+ }
+}
+
+sub Getimage
+{
+ my ($w, $name) = @_;
+ my $mw = $w->MainWindow;
+ croak "Usage \$widget->Getimage('name')" unless defined($name);
+ my $images = ($mw->{'__Images__'} ||= {});
+
+ return $images->{$name} if $images->{$name};
+
+ ImageMethod(xpm => 'Pixmap',
+ gif => 'Photo',
+ ppm => 'Photo',
+ xbm => 'Bitmap' ) unless @image_types;
+
+ foreach my $type (@image_types)
+ {
+ my $method = $image_method{$type};
+ my $file = Tk->findINC( "$name.$type" );
+ next unless( $file && $method );
+ my $sub = $w->can($method);
+ unless (defined &$sub)
+ {
+ require Tk::widgets;
+ Tk::widgets->import($method);
+ }
+ $images->{$name} = $w->$method( -file => $file );
+ return $images->{$name};
+ }
+
+ # Try built-in bitmaps
+ $images->{$name} = $w->Pixmap( -id => $name );
+ return $images->{$name};
+}
+
+sub SaveGrabInfo
+{
+ my $w = shift;
+ $Tk::oldGrab = $w->grabCurrent;
+ if (defined $Tk::oldGrab)
+ {
+ $Tk::grabStatus = $Tk::oldGrab->grabStatus;
+ }
+}
+
+sub grabSave
+{
+ my ($w) = @_;
+ my $grab = $w->grabCurrent;
+ return sub {} if (!defined $grab);
+ my $method = ($grab->grabStatus eq 'global') ? 'grabGlobal' : 'grab';
+ return sub { eval {local $SIG{'__DIE__'}; $grab->$method() } };
+}
+
+sub focusCurrent
+{
+ my ($w) = @_;
+ $w->Tk::focus('-displayof');
+}
+
+sub focusSave
+{
+ my ($w) = @_;
+ my $focus = $w->focusCurrent;
+ return sub {} if (!defined $focus);
+ return sub { eval {local $SIG{'__DIE__'}; $focus->focus } };
+}
+
+# This is supposed to replicate Tk::after behaviour,
+# but does auto-cancel when widget is deleted.
+require Tk::After;
+
+sub afterCancel
+{
+ my ($w,$what) = @_;
+ if (defined $what)
+ {
+ return $what->cancel if ref($what);
+ carp "dubious cancel of $what" if 0 && $^W;
+ $w->Tk::after('cancel' => $what);
+ }
+}
+
+sub afterIdle
+{
+ my $w = shift;
+ return Tk::After->new($w,'idle','once',@_);
+}
+
+sub afterInfo {
+ my ($w, $id) = @_;
+ if (defined $id) {
+ return ($id->[4], $id->[2], $id->[3]);
+ } else {
+ return sort( keys %{$w->{_After_}} );
+ }
+}
+
+sub after
+{
+ my $w = shift;
+ my $t = shift;
+ if (@_)
+ {
+ if ($t ne 'cancel')
+ {
+ require Tk::After;
+ return Tk::After->new($w,$t,'once',@_)
+ }
+ while (@_)
+ {
+ my $what = shift;
+ $w->afterCancel($what);
+ }
+ }
+ else
+ {
+ $w->Tk::after($t);
+ }
+}
+
+sub repeat
+{
+ require Tk::After;
+ my $w = shift;
+ my $t = shift;
+ return Tk::After->new($w,$t,'repeat',@_);
+}
+
+sub FindMenu
+{
+ # default FindMenu is that there is no menu.
+ return undef;
+}
+
+sub XEvent { shift->{'_XEvent_'} }
+
+sub propertyRoot
+{
+ my $w = shift;
+ return $w->property(@_,'root');
+}
+
+# atom, atomname, containing, interps, pathname
+# don't work this way - there is no window arg
+# So we pretend there was an call the C versions from Tk.xs
+
+sub atom { shift->InternAtom(@_) }
+sub atomname { shift->GetAtomName(@_) }
+sub containing { shift->Containing(@_) }
+
+# interps not done yet
+# pathname not done yet
+
+# walk and descendants adapted from Stephen's composite
+# versions as they only use core features they can go here.
+# hierachy is reversed in that descendants calls walk rather
+# than vice versa as this avoids building a list.
+# Walk should possibly be enhanced so allow early termination
+# like '-prune' of find.
+
+sub Walk
+{
+ # Traverse a widget hierarchy while executing a subroutine.
+ my($cw, $proc, @args) = @_;
+ my $subwidget;
+ foreach $subwidget ($cw->children)
+ {
+ $subwidget->Walk($proc,@args);
+ &$proc($subwidget, @args);
+ }
+} # end walk
+
+sub Descendants
+{
+ # Return a list of widgets derived from a parent widget and all its
+ # descendants of a particular class.
+ # If class is not passed returns the entire widget hierarchy.
+
+ my($widget, $class) = @_;
+ my(@widget_tree) = ();
+
+ $widget->Walk(
+ sub { my ($widget,$list,$class) = @_;
+ push(@$list, $widget) if (!defined($class) or $class eq $widget->class);
+ },
+ \@widget_tree, $class
+ );
+ return @widget_tree;
+}
+
+sub Palette
+{
+ my $w = shift->MainWindow;
+ unless (exists $w->{_Palette_})
+ {
+ my %Palette = ();
+ my $c = $w->Checkbutton();
+ my $e = $w->Entry();
+ my $s = $w->Scrollbar();
+ $Palette{'activeBackground'} = ($c->configure('-activebackground'))[3] ;
+ $Palette{'activeForeground'} = ($c->configure('-activeforeground'))[3];
+ $Palette{'background'} = ($c->configure('-background'))[3];
+ $Palette{'disabledForeground'} = ($c->configure('-disabledforeground'))[3];
+ $Palette{'foreground'} = ($c->configure('-foreground'))[3];
+ $Palette{'highlightBackground'} = ($c->configure('-highlightbackground'))[3];
+ $Palette{'highlightColor'} = ($c->configure('-highlightcolor'))[3];
+ $Palette{'insertBackground'} = ($e->configure('-insertbackground'))[3];
+ $Palette{'selectColor'} = ($c->configure('-selectcolor'))[3];
+ $Palette{'selectBackground'} = ($e->configure('-selectbackground'))[3];
+ $Palette{'selectForeground'} = ($e->configure('-selectforeground'))[3];
+ $Palette{'troughColor'} = ($s->configure('-troughcolor'))[3];
+ $c->destroy;
+ $e->destroy;
+ $s->destroy;
+ $w->{_Palette_} = \%Palette;
+ }
+ return $w->{_Palette_};
+}
+
+# tk_setPalette --
+# Changes the default color scheme for a Tk application by setting
+# default colors in the option database and by modifying all of the
+# color options for existing widgets that have the default value.
+#
+# Arguments:
+# The arguments consist of either a single color name, which
+# will be used as the new background color (all other colors will
+# be computed from this) or an even number of values consisting of
+# option names and values. The name for an option is the one used
+# for the option database, such as activeForeground, not -activeforeground.
+sub setPalette
+{
+ my $w = shift->MainWindow;
+ my %new = (@_ == 1) ? (background => $_[0]) : @_;
+ my $priority = delete($new{'priority'}) || 'widgetDefault';
+
+ # Create an array that has the complete new palette. If some colors
+ # aren't specified, compute them from other colors that are specified.
+
+ die 'must specify a background color' if (!exists $new{background});
+ $new{'foreground'} = 'black' unless (exists $new{foreground});
+ my @bg = $w->rgb($new{'background'});
+ my @fg = $w->rgb($new{'foreground'});
+ my $darkerBg = sprintf('#%02x%02x%02x',9*$bg[0]/2560,9*$bg[1]/2560,9*$bg[2]/2560);
+ foreach my $i ('activeForeground','insertBackground','selectForeground','highlightColor')
+ {
+ $new{$i} = $new{'foreground'} unless (exists $new{$i});
+ }
+ unless (exists $new{'disabledForeground'})
+ {
+ $new{'disabledForeground'} = sprintf('#%02x%02x%02x',(3*$bg[0]+$fg[0])/1024,(3*$bg[1]+$fg[1])/1024,(3*$bg[2]+$fg[2])/1024);
+ }
+ $new{'highlightBackground'} = $new{'background'} unless (exists $new{'highlightBackground'});
+
+ unless (exists $new{'activeBackground'})
+ {
+ my @light;
+ # Pick a default active background that is lighter than the
+ # normal background. To do this, round each color component
+ # up by 15% or 1/3 of the way to full white, whichever is
+ # greater.
+ foreach my $i (0, 1, 2)
+ {
+ $light[$i] = $bg[$i]/256;
+ my $inc1 = $light[$i]*15/100;
+ my $inc2 = (255-$light[$i])/3;
+ if ($inc1 > $inc2)
+ {
+ $light[$i] += $inc1
+ }
+ else
+ {
+ $light[$i] += $inc2
+ }
+ $light[$i] = 255 if ($light[$i] > 255);
+ }
+ $new{'activeBackground'} = sprintf('#%02x%02x%02x',@light);
+ }
+ $new{'selectBackground'} = $darkerBg unless (exists $new{'selectBackground'});
+ $new{'troughColor'} = $darkerBg unless (exists $new{'troughColor'});
+ $new{'selectColor'} = '#b03060' unless (exists $new{'selectColor'});
+
+ # Before doing this, make sure that the Tk::Palette variable holds
+ # the default values of all options, so that tkRecolorTree can
+ # be sure to only change options that have their default values.
+ # If the variable exists, then it is already correct (it was created
+ # the last time this procedure was invoked). If the variable
+ # doesn't exist, fill it in using the defaults from a few widgets.
+ my $Palette = $w->Palette;
+
+ # Walk the widget hierarchy, recoloring all existing windows.
+ $w->RecolorTree(\%new);
+ # Change the option database so that future windows will get the
+ # same colors.
+ foreach my $option (keys %new)
+ {
+ $w->option('add',"*$option",$new{$option},$priority);
+ # Save the options in the global variable Tk::Palette, for use the
+ # next time we change the options.
+ $Palette->{$option} = $new{$option};
+ }
+}
+
+# tkRecolorTree --
+# This procedure changes the colors in a window and all of its
+# descendants, according to information provided by the colors
+# argument. It only modifies colors that have their default values
+# as specified by the Tk::Palette variable.
+#
+# Arguments:
+# w - The name of a window. This window and all its
+# descendants are recolored.
+# colors - The name of an array variable in the caller,
+# which contains color information. Each element
+# is named after a widget configuration option, and
+# each value is the value for that option.
+sub RecolorTree
+{
+ my ($w,$colors) = @_;
+ local ($@);
+ my $Palette = $w->Palette;
+ foreach my $dbOption (keys %$colors)
+ {
+ my $option = "-\L$dbOption";
+ my $value;
+ eval {local $SIG{'__DIE__'}; $value = $w->cget($option) };
+ if (defined $value)
+ {
+ if ($value eq $Palette->{$dbOption})
+ {
+ $w->configure($option,$colors->{$dbOption});
+ }
+ }
+ }
+ foreach my $child ($w->children)
+ {
+ $child->RecolorTree($colors);
+ }
+}
+# tkDarken --
+# Given a color name, computes a new color value that darkens (or
+# brightens) the given color by a given percent.
+#
+# Arguments:
+# color - Name of starting color.
+# perecent - Integer telling how much to brighten or darken as a
+# percent: 50 means darken by 50%, 110 means brighten
+# by 10%.
+sub Darken
+{
+ my ($w,$color,$percent) = @_;
+ my @l = $w->rgb($color);
+ my $red = $l[0]/256;
+ my $green = $l[1]/256;
+ my $blue = $l[2]/256;
+ $red = int($red*$percent/100);
+ $red = 255 if ($red > 255);
+ $green = int($green*$percent/100);
+ $green = 255 if ($green > 255);
+ $blue = int($blue*$percent/100);
+ $blue = 255 if ($blue > 255);
+ sprintf('#%02x%02x%02x',$red,$green,$blue)
+}
+# tk_bisque --
+# Reset the Tk color palette to the old "bisque" colors.
+#
+# Arguments:
+# None.
+sub bisque
+{
+ shift->setPalette('activeBackground' => '#e6ceb1',
+ 'activeForeground' => 'black',
+ 'background' => '#ffe4c4',
+ 'disabledForeground' => '#b0b0b0',
+ 'foreground' => 'black',
+ 'highlightBackground' => '#ffe4c4',
+ 'highlightColor' => 'black',
+ 'insertBackground' => 'black',
+ 'selectColor' => '#b03060',
+ 'selectBackground' => '#e6ceb1',
+ 'selectForeground' => 'black',
+ 'troughColor' => '#cdb79e'
+ );
+}
+
+sub PrintConfig
+{
+ require Tk::Pretty;
+ my ($w) = (@_);
+ my $c;
+ foreach $c ($w->configure)
+ {
+ print Tk::Pretty::Pretty(@$c),"\n";
+ }
+}
+
+sub BusyRecurse
+{
+ my ($restore,$w,$cursor,$recurse,$top) = @_;
+ my $c = $w->cget('-cursor');
+ my @tags = $w->bindtags;
+ if ($top || defined($c))
+ {
+ push(@$restore, sub { return unless Tk::Exists($w); $w->configure(-cursor => $c); $w->bindtags(\@tags) });
+ $w->configure(-cursor => $cursor);
+ }
+ else
+ {
+ push(@$restore, sub { return unless Tk::Exists($w); $w->bindtags(\@tags) });
+ }
+ $w->bindtags(['Busy',@tags]);
+ if ($recurse)
+ {
+ foreach my $child ($w->children)
+ {
+ BusyRecurse($restore,$child,$cursor,1,0);
+ }
+ }
+ return $restore;
+}
+
+sub Busy
+{
+ my ($w,@args) = @_;
+ return unless $w->viewable;
+ my($sub, %args);
+ for(my $i=0; $i<=$#args; $i++)
+ {
+ if (ref $args[$i] eq 'CODE')
+ {
+ if (defined $sub)
+ {
+ croak "Multiple code definitions not allowed in Tk::Widget::Busy";
+ }
+ $sub = $args[$i];
+ }
+ else
+ {
+ $args{$args[$i]} = $args[$i+1]; $i++;
+ }
+ }
+ my $cursor = delete $args{'-cursor'};
+ my $recurse = delete $args{'-recurse'};
+ $cursor = 'watch' unless defined $cursor;
+ unless (exists $w->{'Busy'})
+ {
+ my @old = ($w->grabSave);
+ my $key;
+ my @config;
+ foreach $key (keys %args)
+ {
+ push(@config,$key => $w->Tk::cget($key));
+ }
+ if (@config)
+ {
+ push(@old, sub { $w->Tk::configure(@config) });
+ $w->Tk::configure(%args);
+ }
+ unless ($w->Tk::bind('Busy'))
+ {
+ $w->Tk::bind('Busy','<Any-KeyPress>',[_busy => 1]);
+ $w->Tk::bind('Busy','<Any-KeyRelease>',[_busy => 0]);
+ $w->Tk::bind('Busy','<Any-ButtonPress>',[_busy => 1]);
+ $w->Tk::bind('Busy','<Any-ButtonRelease>',[_busy => 0]);
+ $w->Tk::bind('Busy','<Any-Motion>',[_busy => 0]);
+ }
+ $w->{'Busy'} = BusyRecurse(\@old,$w,$cursor,$recurse,1);
+ }
+ my $g = $w->grabCurrent;
+ if (defined $g)
+ {
+ # warn "$g has the grab";
+ $g->grabRelease;
+ }
+ $w->update;
+ eval {local $SIG{'__DIE__'}; $w->grab };
+ $w->update;
+ if ($sub)
+ {
+ eval { $sub->() };
+ my $err = $@;
+ $w->Unbusy(-recurse => $recurse);
+ die $err if $err;
+ }
+}
+
+sub _busy
+{
+ my ($w,$f) = @_;
+ $w->bell if $f;
+ $w->break;
+}
+
+sub Unbusy
+{
+ my ($w) = @_;
+ $w->update;
+ $w->grabRelease if Tk::Exists($w);
+ my $old = delete $w->{'Busy'};
+ if (defined $old)
+ {
+ local $SIG{'__DIE__'};
+ eval { &{pop(@$old)} } while (@$old);
+ }
+ $w->update if Tk::Exists($w);
+}
+
+sub waitVisibility
+{
+ my ($w) = shift;
+ $w->tkwait('visibility',$w);
+}
+
+sub waitVariable
+{
+ my ($w) = shift;
+ $w->tkwait('variable',@_);
+}
+
+sub waitWindow
+{
+ my ($w) = shift;
+ $w->tkwait('window',$w);
+}
+
+sub EventWidget
+{
+ my ($w) = @_;
+ return $w->{'_EventWidget_'};
+}
+
+sub Popwidget
+{
+ my ($ew,$method,$w,@args) = @_;
+ $w->{'_EventWidget_'} = $ew;
+ $w->$method(@args);
+}
+
+sub ColorOptions
+{
+ my ($w,$args) = @_;
+ my $opt;
+ $args = {} unless (defined $args);
+ foreach $opt (qw(-foreground -background -disabledforeground
+ -activebackground -activeforeground
+ ))
+ {
+ $args->{$opt} = $w->cget($opt) unless (exists $args->{$opt})
+ }
+ return (wantarray) ? %$args : $args;
+}
+
+sub XscrollBind
+{
+ my ($mw,$class) = @_;
+ $mw->bind($class,'<Left>', ['xview','scroll',-1,'units']);
+ $mw->bind($class,'<Control-Left>', ['xview','scroll',-1,'pages']);
+ $mw->bind($class,'<Control-Prior>',['xview','scroll',-1,'pages']);
+ $mw->bind($class,'<Right>', ['xview','scroll',1,'units']);
+ $mw->bind($class,'<Control-Right>',['xview','scroll',1,'pages']);
+ $mw->bind($class,'<Control-Next>', ['xview','scroll',1,'pages']);
+
+ $mw->bind($class,'<Home>', ['xview','moveto',0]);
+ $mw->bind($class,'<End>', ['xview','moveto',1]);
+ $mw->XMouseWheelBind($class);
+}
+
+sub PriorNextBind
+{
+ my ($mw,$class) = @_;
+ $mw->bind($class,'<Next>', ['yview','scroll',1,'pages']);
+ $mw->bind($class,'<Prior>', ['yview','scroll',-1,'pages']);
+}
+
+sub XMouseWheelBind
+{
+ my ($mw,$class) = @_;
+ # <4> and <5> are how mousewheel looks on X
+ # <4> and <5> are how mousewheel looks on X
+ $mw->bind($class,'<Shift-4>', ['xview','scroll',-1,'units']);
+ $mw->bind($class,'<Shift-5>', ['xview','scroll',1,'units']);
+ $mw->bind($class,'<Button-6>', ['xview','scroll',-1,'units']);
+ $mw->bind($class,'<Button-7>', ['xview','scroll',1,'units']);
+}
+
+sub YMouseWheelBind
+{
+ my ($mw,$class) = @_;
+ # <4> and <5> are how mousewheel looks on X
+ $mw->bind($class,'<4>', ['yview','scroll',-1,'units']);
+ $mw->bind($class,'<5>', ['yview','scroll',1,'units']);
+}
+
+sub YscrollBind
+{
+ my ($mw,$class) = @_;
+ $mw->PriorNextBind($class);
+ $mw->bind($class,'<Up>', ['yview','scroll',-1,'units']);
+ $mw->bind($class,'<Down>', ['yview','scroll',1,'units']);
+ $mw->YMouseWheelBind($class);
+}
+
+sub XYscrollBind
+{
+ my ($mw,$class) = @_;
+ $mw->YscrollBind($class);
+ $mw->XscrollBind($class);
+ # <4> and <5> are how mousewheel looks on X
+}
+
+sub MouseWheelBind
+{
+ my($mw,$class) = @_;
+
+ # The MouseWheel will typically only fire on Windows. However, one
+ # could use the "event generate" command to produce MouseWheel
+ # events on other platforms.
+
+ $mw->Tk::bind($class, '<MouseWheel>',
+ [ sub { $_[0]->yview('scroll',-($_[1]/120)*3,'units') }, Tk::Ev("D")]);
+
+ if ($Tk::platform eq 'unix')
+ {
+ # Support for mousewheels on Linux/Unix commonly comes through mapping
+ # the wheel to the extended buttons. If you have a mousewheel, find
+ # Linux configuration info at:
+ # http://www.inria.fr/koala/colas/mouse-wheel-scroll/
+ $mw->Tk::bind($class, '<4>',
+ sub { $_[0]->yview('scroll', -3, 'units')
+ unless $Tk::strictMotif;
+ });
+ $mw->Tk::bind($class, '<5>',
+ sub { $_[0]->yview('scroll', 3, 'units')
+ unless $Tk::strictMotif;
+ });
+ }
+}
+
+sub ScrlListbox
+{
+ my $parent = shift;
+ return $parent->Scrolled('Listbox',-scrollbars => 'w', @_);
+}
+
+sub AddBindTag
+{
+ my ($w,$tag) = @_;
+ my $t;
+ my @tags = $w->bindtags;
+ foreach $t (@tags)
+ {
+ return if $t eq $tag;
+ }
+ $w->bindtags([@tags,$tag]);
+}
+
+sub Callback
+{
+ my $w = shift;
+ my $name = shift;
+ my $cb = $w->cget($name);
+ if (defined $cb)
+ {
+ return $cb->Call(@_) if (ref $cb);
+ return $w->$cb(@_);
+ }
+ return (wantarray) ? () : undef;
+}
+
+sub packAdjust
+{
+# print 'packAdjust(',join(',',@_),")\n";
+ require Tk::Adjuster;
+ my ($w,%args) = @_;
+ my $delay = delete($args{'-delay'});
+ $delay = 1 unless (defined $delay);
+ $w->pack(%args);
+ %args = $w->packInfo;
+ my $adj = Tk::Adjuster->new($args{'-in'},
+ -widget => $w, -delay => $delay, -side => $args{'-side'});
+ $adj->packed($w,%args);
+ return $w;
+}
+
+sub gridAdjust
+{
+ require Tk::Adjuster;
+ my ($w,%args) = @_;
+ my $delay = delete($args{'-delay'});
+ $delay = 1 unless (defined $delay);
+ $w->grid(%args);
+ %args = $w->gridInfo;
+ my $adj = Tk::Adjuster->new($args{'-in'},-widget => $w, -delay => $delay);
+ $adj->gridded($w,%args);
+ return $w;
+}
+
+sub place
+{
+ local $SIG{'__DIE__'} = \&Carp::croak;
+ my $w = shift;
+ if (@_ && $_[0] =~ /^(?:configure|forget|info|slaves)$/x)
+ {
+ $w->Tk::place(@_);
+ }
+ else
+ {
+ # Two things going on here:
+ # 1. Add configure on the front so that we can drop leading '-'
+ $w->Tk::place('configure',@_);
+ # 2. Return the widget rather than nothing
+ return $w;
+ }
+}
+
+sub pack
+{
+ local $SIG{'__DIE__'} = \&Carp::croak;
+ my $w = shift;
+ if (@_ && $_[0] =~ /^(?:configure|forget|info|propagate|slaves)$/x)
+ {
+ # maybe array/scalar context issue with slaves
+ $w->Tk::pack(@_);
+ }
+ else
+ {
+ # Two things going on here:
+ # 1. Add configure on the front so that we can drop leading '-'
+ $w->Tk::pack('configure',@_);
+ # 2. Return the widget rather than nothing
+ return $w;
+ }
+}
+
+sub grid
+{
+ local $SIG{'__DIE__'} = \&Carp::croak;
+ my $w = shift;
+ if (@_ && $_[0] =~ /^(?:bbox|columnconfigure|configure|forget|info|location|propagate|rowconfigure|size|slaves)$/x)
+ {
+ my $opt = shift;
+ Tk::grid($opt,$w,@_);
+ }
+ else
+ {
+ # Two things going on here:
+ # 1. Add configure on the front so that we can drop leading '-'
+ Tk::grid('configure',$w,@_);
+ # 2. Return the widget rather than nothing
+ return $w;
+ }
+}
+
+sub form
+{
+ local $SIG{'__DIE__'} = \&Carp::croak;
+ my $w = shift;
+ if (@_ && $_[0] =~ /^(?:configure|check|forget|grid|info|slaves)$/x)
+ {
+ $w->Tk::form(@_);
+ }
+ else
+ {
+ # Two things going on here:
+ # 1. Add configure on the front so that we can drop leading '-'
+ $w->Tk::form('configure',@_);
+ # 2. Return the widget rather than nothing
+ return $w;
+ }
+}
+
+sub Scrolled
+{
+ my ($parent,$kind,%args) = @_;
+ $kind = 'Pane' if $kind eq 'Frame';
+ # Find args that are Frame create time args
+ my @args = Tk::Frame->CreateArgs($parent,\%args);
+ my $name = delete $args{'Name'};
+ push(@args,'Name' => $name) if (defined $name);
+ my $cw = $parent->Frame(@args);
+ @args = ();
+ # Now remove any args that Frame can handle
+ foreach my $k ('-scrollbars',map($_->[0],$cw->configure))
+ {
+ push(@args,$k,delete($args{$k})) if (exists $args{$k})
+ }
+ # Anything else must be for target widget - pass at widget create time
+ my $w = $cw->$kind(%args);
+ # Now re-set %args to be ones Frame can handle
+ %args = @args;
+ $cw->ConfigSpecs('-scrollbars' => ['METHOD','scrollbars','Scrollbars','se'],
+ '-background' => [$w,'background','Background'],
+ '-foreground' => [$w,'foreground','Foreground'],
+ );
+ $cw->AddScrollbars($w);
+ $cw->Default("\L$kind" => $w);
+ $cw->Delegates('bind' => $w, 'bindtags' => $w, 'menu' => $w);
+ $cw->ConfigDefault(\%args);
+ $cw->configure(%args);
+ return $cw;
+}
+
+sub Populate
+{
+ my ($cw,$args) = @_;
+}
+
+sub ForwardEvent
+{
+ my $self = shift;
+ my $to = shift;
+ $to->PassEvent($self->XEvent);
+}
+
+# Save / Return abstract event type as in Tix.
+sub EventType
+{
+ my $w = shift;
+ $w->{'_EventType_'} = $_[0] if @_;
+ return $w->{'_EventType_'};
+}
+
+sub PostPopupMenu
+{
+ my ($w, $X, $Y) = @_;
+ if (@_ < 3)
+ {
+ my $e = $w->XEvent;
+ $X = $e->X;
+ $Y = $e->Y;
+ }
+ my $menu = $w->menu;
+ $menu->Post($X,$Y) if defined $menu;
+}
+
+sub FillMenu
+{
+ my ($w,$menu,@labels) = @_;
+ foreach my $lab (@labels)
+ {
+ my $method = $lab.'MenuItems';
+ $method =~ s/~//g;
+ $method =~ s/[\s-]+/_/g;
+ if ($w->can($method))
+ {
+ $menu->Menubutton(-label => $lab, -tearoff => 0, -menuitems => $w->$method());
+ }
+ }
+ return $menu;
+}
+
+sub menu
+{
+ my ($w,$menu) = @_;
+ if (@_ > 1)
+ {
+ $w->_OnDestroy('_MENU_') unless exists $w->{'_MENU_'};
+ $w->{'_MENU_'} = $menu;
+ }
+ return unless defined wantarray;
+ unless (exists $w->{'_MENU_'})
+ {
+ $w->_OnDestroy('_MENU_');
+ $w->{'_MENU_'} = $menu = $w->Menu(-tearoff => 0);
+ $w->FillMenu($menu,$w->MenuLabels);
+ }
+ return $w->{'_MENU_'};
+}
+
+sub MenuLabels
+{
+ return @DefaultMenuLabels;
+}
+
+sub FileMenuItems
+{
+ my ($w) = @_;
+ return [ ["command"=>'E~xit', -command => [ $w, 'WmDeleteWindow']]];
+}
+
+sub WmDeleteWindow
+{
+ shift->toplevel->WmDeleteWindow
+}
+
+sub BalloonInfo
+{
+ my ($widget,$balloon,$X,$Y,@opt) = @_;
+ foreach my $opt (@opt)
+ {
+ my $info = $balloon->GetOption($opt,$widget);
+ return $info if defined $info;
+ }
+}
+
+sub ConfigSpecs {
+
+ my $w = shift;
+
+ return map { ( $_->[0], [ $w, @$_[ 1 .. 4 ] ] ) } $w->configure;
+
+}
+
+*GetSelection =
+ ($Tk::platform eq 'unix'
+ ? sub
+ {
+ my $w = shift;
+ my $sel = @_ ? shift : "PRIMARY";
+ my $txt = eval { local $SIG{__DIE__};
+ $w->SelectionGet(-selection => $sel, -type => "UTF8_STRING")
+ };
+ if ($@)
+ {
+ $txt = eval { local $SIG{__DIE__};
+ $w->SelectionGet(-selection => $sel)
+ };
+ if ($@)
+ {
+ die "could not find default selection";
+ }
+ }
+ $txt;
+ }
+ : sub
+ {
+ my $w = shift;
+ my $sel = @_ ? shift : "PRIMARY";
+ my $txt = eval { local $SIG{__DIE__};
+ $w->SelectionGet(-selection => $sel)
+ };
+ if ($@)
+ {
+ die "could not find default selection";
+ }
+ $txt;
+ }
+ );
+
+1;
+__END__
+
+sub bindDump {
+
+ # Dump lots of good binding information. This pretty-print subroutine
+ # is, essentially, the following code in disguise:
+ #
+ # print "Binding information for $w\n";
+ # foreach my $tag ($w->bindtags) {
+ # printf "\n Binding tag '$tag' has these bindings:\n";
+ # foreach my $binding ($w->bind($tag)) {
+ # printf " $binding\n";
+ # }
+ # }
+
+ my ($w) = @_;
+
+ my (@bindtags) = $w->bindtags;
+ my $digits = length( scalar @bindtags );
+ my ($spc1, $spc2) = ($digits + 33, $digits + 35);
+ my $format1 = "%${digits}d.";
+ my $format2 = ' ' x ($digits + 2);
+ my $n = 0;
+
+ my @out;
+ push @out, sprintf( "\n## Binding information for '%s', %s ##", $w->PathName, $w );
+
+ foreach my $tag (@bindtags) {
+ my (@bindings) = $w->bind($tag);
+ $n++; # count this bindtag
+
+ if ($#bindings == -1) {
+ push @out, sprintf( "\n$format1 Binding tag '$tag' has no bindings.\n", $n );
+ } else {
+ push @out, sprintf( "\n$format1 Binding tag '$tag' has these bindings:\n", $n );
+
+ foreach my $binding ( @bindings ) {
+ my $callback = $w->bind($tag, $binding);
+ push @out, sprintf( "$format2%27s : %-40s\n", $binding, $callback );
+
+ if ($callback =~ /SCALAR/) {
+ if (ref $$callback) {
+ push @out, sprintf( "%s %s\n", ' ' x $spc1, $$callback );
+ } else {
+ push @out, sprintf( "%s '%s'\n", ' ' x $spc1, $$callback );
+ }
+ } elsif ($callback =~ /ARRAY/) {
+ if (ref $callback->[0]) {
+ push @out, sprintf( "%s %s\n", ' ' x $spc1, $callback->[0], "\n" );
+ } else {
+ push @out, sprintf( "%s '%s'\n", ' ' x $spc1, $callback->[0], "\n" );
+ }
+ foreach my $arg (@$callback[1 .. $#{@$callback}]) {
+ if (ref $arg) {
+ push @out, sprintf( "%s %-40s", ' ' x $spc2, $arg );
+ } else {
+ push @out, sprintf( "%s '%s'", ' ' x $spc2, $arg );
+ }
+
+ if (ref $arg eq 'Tk::Ev') {
+ if ($arg =~ /SCALAR/) {
+ push @out, sprintf( ": '$$arg'" );
+ } else {
+ push @out, sprintf( ": '%s'", join("' '", @$arg) );
+ }
+ }
+
+ push @out, sprintf( "\n" );
+ } # forend callback arguments
+ } # ifend callback
+
+ } # forend all bindings for one tag
+
+ } # ifend have bindings
+
+ } # forend all tags
+ push @out, sprintf( "\n" );
+ return @out;
+
+} # end bindDump
+
+
+sub ASkludge
+{
+ my ($hash,$sense) = @_;
+ foreach my $key (%$hash)
+ {
+ if ($key =~ /-.*variable/ && ref($hash->{$key}) eq 'SCALAR')
+ {
+ if ($sense)
+ {
+ my $val = ${$hash->{$key}};
+ require Tie::Scalar;
+ tie ${$hash->{$key}},'Tie::StdScalar';
+ ${$hash->{$key}} = $val;
+ }
+ else
+ {
+ untie ${$hash->{$key}};
+ }
+ }
+ }
+}
+
+
+
+# clipboardKeysyms --
+# This procedure is invoked to identify the keys that correspond to
+# the "copy", "cut", and "paste" functions for the clipboard.
+#
+# Arguments:
+# copy - Name of the key (keysym name plus modifiers, if any,
+# such as "Meta-y") used for the copy operation.
+# cut - Name of the key used for the cut operation.
+# paste - Name of the key used for the paste operation.
+#
+# This method is obsolete use clipboardOperations and abstract
+# event types instead. See Clipboard.pm and Mainwindow.pm
+
+sub clipboardKeysyms
+{
+ my @class = ();
+ my $mw = shift;
+ if (ref $mw)
+ {
+ $mw = $mw->DelegateFor('bind');
+ }
+ else
+ {
+ push(@class,$mw);
+ $mw = shift;
+ }
+ if (@_)
+ {
+ my $copy = shift;
+ $mw->Tk::bind(@class,"<$copy>",'clipboardCopy') if (defined $copy);
+ }
+ if (@_)
+ {
+ my $cut = shift;
+ $mw->Tk::bind(@class,"<$cut>",'clipboardCut') if (defined $cut);
+ }
+ if (@_)
+ {
+ my $paste = shift;
+ $mw->Tk::bind(@class,"<$paste>",'clipboardPaste') if (defined $paste);
+ }
+}
+
+sub pathname
+{
+ my ($w,$id) = @_;
+ my $x = $w->winfo('pathname',-displayof => oct($id));
+ return $x->PathName;
+}
diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Wm.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Wm.pm
new file mode 100644
index 00000000000..ffbe4877857
--- /dev/null
+++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Wm.pm
@@ -0,0 +1,174 @@
+# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+package Tk::Wm;
+use AutoLoader;
+
+require Tk::Widget;
+*AUTOLOAD = \&Tk::Widget::AUTOLOAD;
+
+use strict qw(vars);
+
+# There are issues with this stuff now we have Tix's wm release/capture
+# as toplevel-ness is now dynamic.
+
+
+use vars qw($VERSION);
+$VERSION = sprintf '4.%03d', q$Revision: #14 $ =~ /\D(\d+)\s*$/;
+
+use Tk::Submethods;
+
+*{Tk::Wm::wmGrid} = sub { shift->wm("grid", @_) };
+*{Tk::Wm::wmTracing} = sub { shift->wm("tracing", @_) };
+
+Direct Tk::Submethods ('wm' => [qw(aspect attributes client colormapwindows command
+ deiconify focusmodel frame geometry group
+ iconbitmap iconify iconimage iconmask iconname
+ iconwindow maxsize minsize overrideredirect positionfrom
+ protocol resizable sizefrom state title transient
+ withdraw wrapper)]);
+
+sub SetBindtags
+{
+ my ($obj) = @_;
+ $obj->bindtags([ref($obj),$obj,'all']);
+}
+
+sub Populate
+{
+ my ($cw,$args) = @_;
+ $cw->ConfigSpecs('-overanchor' => ['PASSIVE',undef,undef,undef],
+ '-popanchor' => ['PASSIVE',undef,undef,undef],
+ '-popover' => ['PASSIVE',undef,undef,undef]
+ );
+}
+
+sub MoveResizeWindow
+{
+ my ($w,$x,$y,$width,$height) = @_;
+ $w->withdraw;
+ $w->geometry($width.'x'.$height);
+ $w->MoveToplevelWindow($x,$y);
+ $w->deiconify;
+}
+
+sub WmDeleteWindow
+{
+ my ($w) = @_;
+ my $cb = $w->protocol('WM_DELETE_WINDOW');
+ if (defined $cb)
+ {
+ $cb->Call;
+ }
+ else
+ {
+ $w->destroy;
+ }
+}
+
+
+1;
+
+__END__
+
+
+sub Post
+{
+ my ($w,$X,$Y) = @_;
+ $X = int($X);
+ $Y = int($Y);
+ $w->positionfrom('user');
+ $w->geometry("+$X+$Y");
+ # $w->MoveToplevelWindow($X,$Y);
+ $w->deiconify;
+ $w->raise;
+}
+
+sub AnchorAdjust
+{
+ my ($anchor,$X,$Y,$w,$h) = @_;
+ $anchor = 'c' unless (defined $anchor);
+ $Y += ($anchor =~ /s/) ? $h : ($anchor =~ /n/) ? 0 : $h/2;
+ $X += ($anchor =~ /e/) ? $w : ($anchor =~ /w/) ? 0 : $w/2;
+ return ($X,$Y);
+}
+
+sub Popup
+{
+ my $w = shift;
+ $w->configure(@_) if @_;
+ $w->idletasks;
+ my ($mw,$mh) = ($w->reqwidth,$w->reqheight);
+ my ($rx,$ry,$rw,$rh) = (0,0,0,0);
+ my $base = $w->cget('-popover');
+ my $outside = 0;
+ if (defined $base)
+ {
+ if ($base eq 'cursor')
+ {
+ ($rx,$ry) = $w->pointerxy;
+ }
+ else
+ {
+ $rx = $base->rootx;
+ $ry = $base->rooty;
+ $rw = $base->Width;
+ $rh = $base->Height;
+ }
+ }
+ else
+ {
+ my $sc = ($w->parent) ? $w->parent->toplevel : $w;
+ $rx = -$sc->vrootx;
+ $ry = -$sc->vrooty;
+ $rw = $w->screenwidth;
+ $rh = $w->screenheight;
+ }
+ my ($X,$Y) = AnchorAdjust($w->cget('-overanchor'),$rx,$ry,$rw,$rh);
+ ($X,$Y) = AnchorAdjust($w->cget('-popanchor'),$X,$Y,-$mw,-$mh);
+ # adjust to not cross screen borders
+ if ($X < 0) { $X = 0 }
+ if ($Y < 0) { $Y = 0 }
+ if ($mw > $w->screenwidth) { $X = 0 }
+ if ($mh > $w->screenheight) { $Y = 0 }
+ $w->Post($X,$Y);
+ $w->waitVisibility;
+}
+
+sub FullScreen
+{
+ my $w = shift;
+ my $over = (@_) ? shift : 0;
+ my $width = $w->screenwidth;
+ my $height = $w->screenheight;
+ $w->GeometryRequest($width,$height);
+ $w->overrideredirect($over & 1);
+ $w->Post(0,0);
+ $w->update;
+ if ($over & 2)
+ {
+ my $x = $w->rootx;
+ my $y = $w->rooty;
+ $width -= 2*$x;
+ $height -= $x + $y;
+ $w->GeometryRequest($width,$height);
+ $w->update;
+ }
+}
+
+sub iconposition
+{
+ my $w = shift;
+ if (@_ == 1)
+ {
+ return $w->wm('iconposition',$1,$2) if $_[0] =~ /^(\d+),(\d+)$/;
+ if ($_[0] =~ /^([+-])(\d+)([+-])(\d+)$/)
+ {
+ my $x = ($1 eq '-') ? $w->screenwidth-$2 : $2;
+ my $y = ($3 eq '-') ? $w->screenheight-$4 : $4;
+ return $w->wm('iconposition',$x,$y);
+ }
+ }
+ $w->wm('iconposition',@_);
+}
+
diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/XSLoader.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/XSLoader.pm
new file mode 100644
index 00000000000..34172dcfa70
--- /dev/null
+++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/XSLoader.pm
@@ -0,0 +1,356 @@
+# Generated from XSLoader.pm.PL (resolved %Config::Config value)
+
+package XSLoader;
+
+$VERSION = "0.06";
+
+#use strict;
+
+# enable debug/trace messages from DynaLoader perl code
+# $dl_debug = $ENV{PERL_DL_DEBUG} || 0 unless defined $dl_debug;
+
+ my $dl_dlext = 'dll';
+
+package DynaLoader;
+
+# No prizes for guessing why we don't say 'bootstrap DynaLoader;' here.
+# NOTE: All dl_*.xs (including dl_none.xs) define a dl_error() XSUB
+boot_DynaLoader('DynaLoader') if defined(&boot_DynaLoader) &&
+ !defined(&dl_error);
+package XSLoader;
+
+sub load {
+ package DynaLoader;
+
+ die q{XSLoader::load('Your::Module', $Your::Module::VERSION)} unless @_;
+
+ my($module) = $_[0];
+
+ # work with static linking too
+ my $b = "$module\::bootstrap";
+ goto &$b if defined &$b;
+
+ goto retry unless $module and defined &dl_load_file;
+
+ my @modparts = split(/::/,$module);
+ my $modfname = $modparts[-1];
+
+ my $modpname = join('/',@modparts);
+ my $modlibname = (caller())[1];
+ my $c = @modparts;
+ $modlibname =~ s,[\\/][^\\/]+$,, while $c--; # Q&D basename
+ my $file = "$modlibname/auto/$modpname/$modfname.$dl_dlext";
+
+# print STDERR "XSLoader::load for $module ($file)\n" if $dl_debug;
+
+ my $bs = $file;
+ $bs =~ s/(\.\w+)?(;\d*)?$/\.bs/; # look for .bs 'beside' the library
+
+ goto retry if not -f $file or -s $bs;
+
+ my $bootname = "boot_$module";
+ $bootname =~ s/\W/_/g;
+ @DynaLoader::dl_require_symbols = ($bootname);
+
+ my $boot_symbol_ref;
+
+ if ($^O eq 'darwin') {
+ if ($boot_symbol_ref = dl_find_symbol(0, $bootname)) {
+ goto boot; #extension library has already been loaded, e.g. darwin
+ }
+ }
+
+ # Many dynamic extension loading problems will appear to come from
+ # this section of code: XYZ failed at line 123 of DynaLoader.pm.
+ # Often these errors are actually occurring in the initialisation
+ # C code of the extension XS file. Perl reports the error as being
+ # in this perl code simply because this was the last perl code
+ # it executed.
+
+ my $libref = dl_load_file($file, 0) or do {
+ require Carp;
+ Carp::croak("Can't load '$file' for module $module: " . dl_error());
+ };
+ push(@DynaLoader::dl_librefs,$libref); # record loaded object
+
+ my @unresolved = dl_undef_symbols();
+ if (@unresolved) {
+ require Carp;
+ Carp::carp("Undefined symbols present after loading $file: @unresolved\n");
+ }
+
+ $boot_symbol_ref = dl_find_symbol($libref, $bootname) or do {
+ require Carp;
+ Carp::croak("Can't find '$bootname' symbol in $file\n");
+ };
+
+ push(@DynaLoader::dl_modules, $module); # record loaded module
+
+ boot:
+ my $xs = dl_install_xsub("${module}::bootstrap", $boot_symbol_ref, $file);
+
+ # See comment block above
+ push(@DynaLoader::dl_shared_objects, $file); # record files loaded
+ return &$xs(@_);
+
+ retry:
+ my $bootstrap_inherit = DynaLoader->can('bootstrap_inherit') ||
+ XSLoader->can('bootstrap_inherit');
+ goto &$bootstrap_inherit;
+}
+
+# Versions of DynaLoader prior to 5.6.0 don't have this function.
+sub bootstrap_inherit {
+ package DynaLoader;
+
+ my $module = $_[0];
+ local *DynaLoader::isa = *{"$module\::ISA"};
+ local @DynaLoader::isa = (@DynaLoader::isa, 'DynaLoader');
+ # Cannot goto due to delocalization. Will report errors on a wrong line?
+ require DynaLoader;
+ DynaLoader::bootstrap(@_);
+}
+
+1;
+
+
+__END__
+
+=head1 NAME
+
+XSLoader - Dynamically load C libraries into Perl code
+
+=head1 VERSION
+
+Version 0.06
+
+=head1 SYNOPSIS
+
+ package YourPackage;
+ use XSLoader;
+
+ XSLoader::load 'YourPackage', $YourPackage::VERSION;
+
+=head1 DESCRIPTION
+
+This module defines a standard I<simplified> interface to the dynamic
+linking mechanisms available on many platforms. Its primary purpose is
+to implement cheap automatic dynamic loading of Perl modules.
+
+For a more complicated interface, see L<DynaLoader>. Many (most)
+features of C<DynaLoader> are not implemented in C<XSLoader>, like for
+example the C<dl_load_flags>, not honored by C<XSLoader>.
+
+=head2 Migration from C<DynaLoader>
+
+A typical module using L<DynaLoader|DynaLoader> starts like this:
+
+ package YourPackage;
+ require DynaLoader;
+
+ our @ISA = qw( OnePackage OtherPackage DynaLoader );
+ our $VERSION = '0.01';
+ bootstrap YourPackage $VERSION;
+
+Change this to
+
+ package YourPackage;
+ use XSLoader;
+
+ our @ISA = qw( OnePackage OtherPackage );
+ our $VERSION = '0.01';
+ XSLoader::load 'YourPackage', $VERSION;
+
+In other words: replace C<require DynaLoader> by C<use XSLoader>, remove
+C<DynaLoader> from C<@ISA>, change C<bootstrap> by C<XSLoader::load>. Do not
+forget to quote the name of your package on the C<XSLoader::load> line,
+and add comma (C<,>) before the arguments (C<$VERSION> above).
+
+Of course, if C<@ISA> contained only C<DynaLoader>, there is no need to have
+the C<@ISA> assignment at all; moreover, if instead of C<our> one uses the
+more backward-compatible
+
+ use vars qw($VERSION @ISA);
+
+one can remove this reference to C<@ISA> together with the C<@ISA> assignment.
+
+If no C<$VERSION> was specified on the C<bootstrap> line, the last line becomes
+
+ XSLoader::load 'YourPackage';
+
+=head2 Backward compatible boilerplate
+
+If you want to have your cake and eat it too, you need a more complicated
+boilerplate.
+
+ package YourPackage;
+ use vars qw($VERSION @ISA);
+
+ @ISA = qw( OnePackage OtherPackage );
+ $VERSION = '0.01';
+ eval {
+ require XSLoader;
+ XSLoader::load('YourPackage', $VERSION);
+ 1;
+ } or do {
+ require DynaLoader;
+ push @ISA, 'DynaLoader';
+ bootstrap YourPackage $VERSION;
+ };
+
+The parentheses about C<XSLoader::load()> arguments are needed since we replaced
+C<use XSLoader> by C<require>, so the compiler does not know that a function
+C<XSLoader::load()> is present.
+
+This boilerplate uses the low-overhead C<XSLoader> if present; if used with
+an antic Perl which has no C<XSLoader>, it falls back to using C<DynaLoader>.
+
+=head1 Order of initialization: early load()
+
+I<Skip this section if the XSUB functions are supposed to be called from other
+modules only; read it only if you call your XSUBs from the code in your module,
+or have a C<BOOT:> section in your XS file (see L<perlxs/"The BOOT: Keyword">).
+What is described here is equally applicable to the L<DynaLoader|DynaLoader>
+interface.>
+
+A sufficiently complicated module using XS would have both Perl code (defined
+in F<YourPackage.pm>) and XS code (defined in F<YourPackage.xs>). If this
+Perl code makes calls into this XS code, and/or this XS code makes calls to
+the Perl code, one should be careful with the order of initialization.
+
+The call to C<XSLoader::load()> (or C<bootstrap()>) has three side effects:
+
+=over
+
+=item *
+
+if C<$VERSION> was specified, a sanity check is done to ensure that the
+versions of the F<.pm> and the (compiled) F<.xs> parts are compatible;
+
+=item *
+
+the XSUBs are made accessible from Perl;
+
+=item *
+
+if a C<BOOT:> section was present in the F<.xs> file, the code there is called.
+
+=back
+
+Consequently, if the code in the F<.pm> file makes calls to these XSUBs, it is
+convenient to have XSUBs installed before the Perl code is defined; for
+example, this makes prototypes for XSUBs visible to this Perl code.
+Alternatively, if the C<BOOT:> section makes calls to Perl functions (or
+uses Perl variables) defined in the F<.pm> file, they must be defined prior to
+the call to C<XSLoader::load()> (or C<bootstrap()>).
+
+The first situation being much more frequent, it makes sense to rewrite the
+boilerplate as
+
+ package YourPackage;
+ use XSLoader;
+ use vars qw($VERSION @ISA);
+
+ BEGIN {
+ @ISA = qw( OnePackage OtherPackage );
+ $VERSION = '0.01';
+
+ # Put Perl code used in the BOOT: section here
+
+ XSLoader::load 'YourPackage', $VERSION;
+ }
+
+ # Put Perl code making calls into XSUBs here
+
+=head2 The most hairy case
+
+If the interdependence of your C<BOOT:> section and Perl code is
+more complicated than this (e.g., the C<BOOT:> section makes calls to Perl
+functions which make calls to XSUBs with prototypes), get rid of the C<BOOT:>
+section altogether. Replace it with a function C<onBOOT()>, and call it like
+this:
+
+ package YourPackage;
+ use XSLoader;
+ use vars qw($VERSION @ISA);
+
+ BEGIN {
+ @ISA = qw( OnePackage OtherPackage );
+ $VERSION = '0.01';
+ XSLoader::load 'YourPackage', $VERSION;
+ }
+
+ # Put Perl code used in onBOOT() function here; calls to XSUBs are
+ # prototype-checked.
+
+ onBOOT;
+
+ # Put Perl initialization code assuming that XS is initialized here
+
+
+=head1 DIAGNOSTICS
+
+=over 4
+
+=item Can't find '%s' symbol in %s
+
+B<(F)> The bootstrap symbol could not be found in the extension module.
+
+=item Can't load '%s' for module %s: %s
+
+B<(F)> The loading or initialisation of the extension module failed.
+The detailed error follows.
+
+=item Undefined symbols present after loading %s: %s
+
+B<(W)> As the message says, some symbols stay undefined although the
+extension module was correctly loaded and initialised. The list of undefined
+symbols follows.
+
+=item XSLoader::load('Your::Module', $Your::Module::VERSION)
+
+B<(F)> You tried to invoke C<load()> without any argument. You must supply
+a module name, and optionally its version.
+
+=back
+
+
+=head1 LIMITATIONS
+
+To reduce the overhead as much as possible, only one possible location
+is checked to find the extension DLL (this location is where C<make install>
+would put the DLL). If not found, the search for the DLL is transparently
+delegated to C<DynaLoader>, which looks for the DLL along the C<@INC> list.
+
+In particular, this is applicable to the structure of C<@INC> used for testing
+not-yet-installed extensions. This means that running uninstalled extensions
+may have much more overhead than running the same extensions after
+C<make install>.
+
+
+=head1 BUGS
+
+Please report any bugs or feature requests via the perlbug(1) utility.
+
+
+=head1 SEE ALSO
+
+L<DynaLoader>
+
+
+=head1 AUTHORS
+
+Ilya Zakharevich originally extracted C<XSLoader> from C<DynaLoader>.
+
+CPAN version is currently maintained by SE<eacute>bastien Aperghis-Tramoni
+E<lt>sebastien@aperghis.netE<gt>
+
+Previous maintainer was Michael G Schwern <schwern@pobox.com>
+
+
+=head1 COPYRIGHT
+
+This program is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Cwd/Cwd.bs b/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Cwd/Cwd.bs
new file mode 100644
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Cwd/Cwd.bs
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
new file mode 100755
index 00000000000..67f6d7baa57
--- /dev/null
+++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Cwd/Cwd.dll
Binary files differ
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
new file mode 100644
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Encode/Byte/Byte.bs
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
new file mode 100755
index 00000000000..88474ccb046
--- /dev/null
+++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Encode/Byte/Byte.dll
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
new file mode 100644
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Encode/Encode.bs
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
new file mode 100755
index 00000000000..69c8ebf8acb
--- /dev/null
+++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Encode/Encode.dll
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
new file mode 100644
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Encode/Unicode/Unicode.bs
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
new file mode 100755
index 00000000000..71a757a6b64
--- /dev/null
+++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Encode/Unicode/Unicode.dll
Binary files differ
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
new file mode 100644
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Event/Event.bs
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
new file mode 100755
index 00000000000..5a9706cb92e
--- /dev/null
+++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Event/Event.dll
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
new file mode 100644
index 00000000000..6e5b939fce1
--- /dev/null
+++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Frame/autosplit.ix
@@ -0,0 +1,24 @@
+# Index created by AutoSplit for blib\lib\Tk\Frame.pm
+# (file acts as timestamp)
+package Tk::Frame;
+sub labelPack
+;
+sub labelVariable
+;
+sub label
+;
+sub queuePack
+;
+sub sbset
+;
+sub freeze_on_map
+;
+sub AddScrollbars
+;
+sub packscrollbars
+;
+sub scrollbars
+;
+sub FindMenu
+;
+1;
diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Tk.bs b/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Tk.bs
new file mode 100644
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Tk.bs
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
new file mode 100755
index 00000000000..8d80944808d
--- /dev/null
+++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Tk.dll
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
new file mode 100644
index 00000000000..859b90d9a40
--- /dev/null
+++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Toplevel/autosplit.ix
@@ -0,0 +1,10 @@
+# Index created by AutoSplit for blib\lib\Tk\Toplevel.pm
+# (file acts as timestamp)
+package Tk::Toplevel;
+sub FG_Create ;
+sub FG_BindIn ;
+sub FG_BindOut ;
+sub FG_Destroy ;
+sub FG_In ;
+sub FG_Out ;
+1;
diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Widget/autosplit.ix b/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Widget/autosplit.ix
new file mode 100644
index 00000000000..b610773d4dc
--- /dev/null
+++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Widget/autosplit.ix
@@ -0,0 +1,11 @@
+# Index created by AutoSplit for blib\lib\Tk\Widget.pm
+# (file acts as timestamp)
+package Tk::Widget;
+sub bindDump ;
+sub ASkludge
+;
+sub clipboardKeysyms
+;
+sub pathname
+;
+1;
diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Wm/autosplit.ix b/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Wm/autosplit.ix
new file mode 100644
index 00000000000..201dbe8ba99
--- /dev/null
+++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Wm/autosplit.ix
@@ -0,0 +1,14 @@
+# Index created by AutoSplit for blib\lib\Tk\Wm.pm
+# (file acts as timestamp)
+package Tk::Wm;
+sub Post
+;
+sub AnchorAdjust
+;
+sub Popup
+;
+sub FullScreen
+;
+sub iconposition
+;
+1;
diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/autosplit.ix b/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/autosplit.ix
new file mode 100644
index 00000000000..7bd25b78a9a
--- /dev/null
+++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/autosplit.ix
@@ -0,0 +1,45 @@
+# Index created by AutoSplit for blib\lib\Tk.pm
+# (file acts as timestamp)
+package Tk;
+sub Error
+;
+sub CancelRepeat
+;
+sub RepeatId
+;
+sub FocusChildren ;
+sub focusNext
+;
+sub focusPrev
+;
+sub FocusOK
+;
+sub EnterFocus
+;
+sub tabFocus
+;
+sub focusFollowsMouse
+;
+sub TraverseToMenu
+;
+sub FirstMenu
+;
+sub Selection
+;
+sub Receive
+;
+sub break
+;
+sub updateWidgets
+;
+sub ImageNames
+;
+sub ImageTypes
+;
+sub interps
+;
+sub lsearch
+;
+sub getEncoding
+;
+1;
diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/getEncoding.al b/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/getEncoding.al
new file mode 100644
index 00000000000..b9e230edbf1
--- /dev/null
+++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/getEncoding.al
@@ -0,0 +1,43 @@
+# NOTE: Derived from blib\lib\Tk.pm.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package Tk;
+
+#line 785 "blib\lib\Tk.pm (autosplit into blib\lib\auto\Tk\getEncoding.al)"
+sub getEncoding
+{
+ my ($class,$name) = @_;
+ eval { require Encode };
+ if ($@)
+ {
+ require Tk::DummyEncode;
+ return Tk::DummyEncode->getEncoding($name);
+ }
+ $name = $Tk::font_encoding{$name} if exists $Tk::font_encoding{$name};
+ my $enc = Encode::find_encoding($name);
+
+ unless ($enc)
+ {
+ $enc = Encode::find_encoding($name) if ($name =~ s/[-_]\d+$//)
+ }
+# if ($enc)
+# {
+# print STDERR "Lookup '$name' => ".$enc->name."\n";
+# }
+# else
+# {
+# print STDERR "Failed '$name'\n";
+# }
+ unless ($enc)
+ {
+ if ($name eq 'X11ControlChars')
+ {
+ require Tk::DummyEncode;
+ $Encode::encoding{$name} = $enc = Tk::DummyEncode->getEncoding($name);
+ }
+ }
+ return $enc;
+}
+
+1;
+# end of Tk::getEncoding
diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/base.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/base.pm
new file mode 100644
index 00000000000..001914be4d3
--- /dev/null
+++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/base.pm
@@ -0,0 +1,226 @@
+package base;
+
+use strict 'vars';
+use vars qw($VERSION);
+$VERSION = '2.07';
+
+# constant.pm is slow
+sub SUCCESS () { 1 }
+
+sub PUBLIC () { 2**0 }
+sub PRIVATE () { 2**1 }
+sub INHERITED () { 2**2 }
+sub PROTECTED () { 2**3 }
+
+
+my $Fattr = \%fields::attr;
+
+sub has_fields {
+ my($base) = shift;
+ my $fglob = ${"$base\::"}{FIELDS};
+ return( ($fglob && *$fglob{HASH}) ? 1 : 0 );
+}
+
+sub has_version {
+ my($base) = shift;
+ my $vglob = ${$base.'::'}{VERSION};
+ return( ($vglob && *$vglob{SCALAR}) ? 1 : 0 );
+}
+
+sub has_attr {
+ my($proto) = shift;
+ my($class) = ref $proto || $proto;
+ return exists $Fattr->{$class};
+}
+
+sub get_attr {
+ $Fattr->{$_[0]} = [1] unless $Fattr->{$_[0]};
+ return $Fattr->{$_[0]};
+}
+
+if ($] < 5.009) {
+ *get_fields = sub {
+ # Shut up a possible typo warning.
+ () = \%{$_[0].'::FIELDS'};
+ my $f = \%{$_[0].'::FIELDS'};
+
+ # should be centralized in fields? perhaps
+ # fields::mk_FIELDS_be_OK. Peh. As long as %{ $package . '::FIELDS' }
+ # is used here anyway, it doesn't matter.
+ bless $f, 'pseudohash' if (ref($f) ne 'pseudohash');
+
+ return $f;
+ }
+}
+else {
+ *get_fields = sub {
+ # Shut up a possible typo warning.
+ () = \%{$_[0].'::FIELDS'};
+ return \%{$_[0].'::FIELDS'};
+ }
+}
+
+sub import {
+ my $class = shift;
+
+ return SUCCESS unless @_;
+
+ # List of base classes from which we will inherit %FIELDS.
+ my $fields_base;
+
+ my $inheritor = caller(0);
+
+ foreach my $base (@_) {
+ next if $inheritor->isa($base);
+
+ if (has_version($base)) {
+ ${$base.'::VERSION'} = '-1, set by base.pm'
+ unless defined ${$base.'::VERSION'};
+ }
+ else {
+ local $SIG{__DIE__};
+ eval "require $base";
+ # Only ignore "Can't locate" errors from our eval require.
+ # Other fatal errors (syntax etc) must be reported.
+ die if $@ && $@ !~ /^Can't locate .*? at \(eval /;
+ unless (%{"$base\::"}) {
+ require Carp;
+ Carp::croak(<<ERROR);
+Base class package "$base" is empty.
+ (Perhaps you need to 'use' the module which defines that package first.)
+ERROR
+
+ }
+ ${$base.'::VERSION'} = "-1, set by base.pm"
+ unless defined ${$base.'::VERSION'};
+ }
+ push @{"$inheritor\::ISA"}, $base;
+
+ if ( has_fields($base) || has_attr($base) ) {
+ # No multiple fields inheritence *suck*
+ if ($fields_base) {
+ require Carp;
+ Carp::croak("Can't multiply inherit %FIELDS");
+ } else {
+ $fields_base = $base;
+ }
+ }
+ }
+
+ if( defined $fields_base ) {
+ inherit_fields($inheritor, $fields_base);
+ }
+}
+
+
+sub inherit_fields {
+ my($derived, $base) = @_;
+
+ return SUCCESS unless $base;
+
+ my $battr = get_attr($base);
+ my $dattr = get_attr($derived);
+ my $dfields = get_fields($derived);
+ my $bfields = get_fields($base);
+
+ $dattr->[0] = @$battr;
+
+ if( keys %$dfields ) {
+ warn "$derived is inheriting from $base but already has its own ".
+ "fields!\n".
+ "This will cause problems.\n".
+ "Be sure you use base BEFORE declaring fields\n";
+ }
+
+ # Iterate through the base's fields adding all the non-private
+ # ones to the derived class. Hang on to the original attribute
+ # (Public, Private, etc...) and add Inherited.
+ # This is all too complicated to do efficiently with add_fields().
+ while (my($k,$v) = each %$bfields) {
+ my $fno;
+ if ($fno = $dfields->{$k} and $fno != $v) {
+ require Carp;
+ Carp::croak ("Inherited %FIELDS can't override existing %FIELDS");
+ }
+
+ if( $battr->[$v] & PRIVATE ) {
+ $dattr->[$v] = PRIVATE | INHERITED;
+ }
+ else {
+ $dattr->[$v] = INHERITED | $battr->[$v];
+ $dfields->{$k} = $v;
+ }
+ }
+
+ foreach my $idx (1..$#{$battr}) {
+ next if defined $dattr->[$idx];
+ $dattr->[$idx] = $battr->[$idx] & INHERITED;
+ }
+}
+
+
+1;
+
+__END__
+
+=head1 NAME
+
+base - Establish IS-A relationship with base classes at compile time
+
+=head1 SYNOPSIS
+
+ package Baz;
+ use base qw(Foo Bar);
+
+=head1 DESCRIPTION
+
+Allows you to both load one or more modules, while setting up inheritance from
+those modules at the same time. Roughly similar in effect to
+
+ package Baz;
+ BEGIN {
+ require Foo;
+ require Bar;
+ push @ISA, qw(Foo Bar);
+ }
+
+If any of the listed modules are not loaded yet, I<base> silently attempts to
+C<require> them (and silently continues if the C<require> failed). Whether to
+C<require> a base class module is determined by the absence of a global variable
+$VERSION in the base package. If $VERSION is not detected even after loading
+it, <base> will define $VERSION in the base package, setting it to the string
+C<-1, set by base.pm>.
+
+Will also initialize the fields if one of the base classes has it.
+Multiple inheritence of fields is B<NOT> supported, if two or more
+base classes each have inheritable fields the 'base' pragma will
+croak. See L<fields>, L<public> and L<protected> for a description of
+this feature.
+
+=head1 DIAGNOSTICS
+
+=over 4
+
+=item Base class package "%s" is empty.
+
+base.pm was unable to require the base package, because it was not
+found in your path.
+
+=back
+
+=head1 HISTORY
+
+This module was introduced with Perl 5.004_04.
+
+
+=head1 CAVEATS
+
+Due to the limitations of the implementation, you must use
+base I<before> you declare any of your own fields.
+
+
+=head1 SEE ALSO
+
+L<fields>
+
+=cut
diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/bytes.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/bytes.pm
new file mode 100644
index 00000000000..a8222794ddf
--- /dev/null
+++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/bytes.pm
@@ -0,0 +1,88 @@
+package bytes;
+
+our $VERSION = '1.02';
+
+$bytes::hint_bits = 0x00000008;
+
+sub import {
+ $^H |= $bytes::hint_bits;
+}
+
+sub unimport {
+ $^H &= ~$bytes::hint_bits;
+}
+
+sub AUTOLOAD {
+ require "bytes_heavy.pl";
+ goto &$AUTOLOAD if defined &$AUTOLOAD;
+ require Carp;
+ Carp::croak("Undefined subroutine $AUTOLOAD called");
+}
+
+sub length ($);
+sub chr ($);
+sub ord ($);
+sub substr ($$;$$);
+sub index ($$;$);
+sub rindex ($$;$);
+
+1;
+__END__
+
+=head1 NAME
+
+bytes - Perl pragma to force byte semantics rather than character semantics
+
+=head1 SYNOPSIS
+
+ use bytes;
+ ... chr(...); # or bytes::chr
+ ... index(...); # or bytes::index
+ ... length(...); # or bytes::length
+ ... ord(...); # or bytes::ord
+ ... rindex(...); # or bytes::rindex
+ ... substr(...); # or bytes::substr
+ no bytes;
+
+
+=head1 DESCRIPTION
+
+The C<use bytes> pragma disables character semantics for the rest of the
+lexical scope in which it appears. C<no bytes> can be used to reverse
+the effect of C<use bytes> within the current lexical scope.
+
+Perl normally assumes character semantics in the presence of character
+data (i.e. data that has come from a source that has been marked as
+being of a particular character encoding). When C<use bytes> is in
+effect, the encoding is temporarily ignored, and each string is treated
+as a series of bytes.
+
+As an example, when Perl sees C<$x = chr(400)>, it encodes the character
+in UTF-8 and stores it in $x. Then it is marked as character data, so,
+for instance, C<length $x> returns C<1>. However, in the scope of the
+C<bytes> pragma, $x is treated as a series of bytes - the bytes that make
+up the UTF8 encoding - and C<length $x> returns C<2>:
+
+ $x = chr(400);
+ print "Length is ", length $x, "\n"; # "Length is 1"
+ printf "Contents are %vd\n", $x; # "Contents are 400"
+ {
+ use bytes; # or "require bytes; bytes::length()"
+ print "Length is ", length $x, "\n"; # "Length is 2"
+ printf "Contents are %vd\n", $x; # "Contents are 198.144"
+ }
+
+chr(), ord(), substr(), index() and rindex() behave similarly.
+
+For more on the implications and differences between character
+semantics and byte semantics, see L<perluniintro> and L<perlunicode>.
+
+=head1 LIMITATIONS
+
+bytes::substr() does not work as an lvalue().
+
+=head1 SEE ALSO
+
+L<perluniintro>, L<perlunicode>, L<utf8>
+
+=cut
diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/unicore/Canonical.pl b/Master/tlpkg/lib/Perl5_lib-TL_inst/unicore/Canonical.pl
new file mode 100644
index 00000000000..fce1e219700
--- /dev/null
+++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/unicore/Canonical.pl
@@ -0,0 +1,1042 @@
+# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+# This file is built by mktables from e.g. UnicodeData.txt.
+# Any changes made here will be lost!
+
+##
+## Data in this file used by ../utf8_heavy.pl
+##
+
+## Mapping from lc(canonical name) to filename in ./lib
+%utf8::Canonical = (
+
+ # InAegeanNumbers
+ aegeannumbers => 'InAegean',
+
+ alphabetic => 'Alphabet',
+
+ # InAlphabeticPresentationForms
+ alphabeticpresentationforms => 'InAlphab',
+
+ # InAncientGreekMusicalNotation
+ ancientgreekmusicalnotation => 'InAncie2',
+
+ # InAncientGreekNumbers
+ ancientgreeknumbers => 'InAncien',
+
+ arabic => 'Arab',
+
+ # InArabicPresentationFormsA
+ arabicpresentationformsa => 'InArabi4',
+
+ # InArabicPresentationFormsB
+ arabicpresentationformsb => 'InArabi3',
+
+ # InArabicSupplement
+ arabicsupplement => 'InArabi2',
+
+ armenian => 'Armn',
+
+ # InArrows
+ arrows => 'InArrows',
+
+ # AsciiHexDigit
+ asciihexdigit => 'AsciiHex',
+
+ # InBasicLatin
+ basiclatin => 'InBasicL',
+
+ bengali => 'Beng',
+
+ # BidiControl
+ bidicontrol => 'BidiCont',
+
+ # InBlockElements
+ blockelements => 'InBlockE',
+
+ bopomofo => 'Bopo',
+
+ # InBopomofoExtended
+ bopomofoextended => 'InBopom2',
+
+ # InBoxDrawing
+ boxdrawing => 'InBoxDra',
+
+ braille => 'Brai',
+
+ # InBraillePatterns
+ braillepatterns => 'InBraill',
+
+ buginese => 'Bugi',
+ buhid => 'Buhd',
+
+ # InByzantineMusicalSymbols
+ byzantinemusicalsymbols => 'InByzant',
+
+ # CanadianAboriginal
+ canadianaboriginal => 'Canadian',
+
+ # CasedLetter
+ casedletter => 'LC',
+
+ cherokee => 'Cher',
+
+ # InCjkCompatibility
+ cjkcompatibility => 'InCjkCom',
+
+ # InCjkCompatibilityForms
+ cjkcompatibilityforms => 'InCjkCo2',
+
+ # InCjkCompatibilityIdeographs
+ cjkcompatibilityideographs => 'InCjkCo3',
+
+ # InCjkCompatibilityIdeographsSupplement
+ cjkcompatibilityideographssupplement => 'InCjkCo4',
+
+ # InCjkRadicalsSupplement
+ cjkradicalssupplement => 'InCjkRad',
+
+ # InCjkStrokes
+ cjkstrokes => 'InCjkStr',
+
+ # InCjkSymbolsAndPunctuation
+ cjksymbolsandpunctuation => 'InCjkSym',
+
+ # InCjkUnifiedIdeographs
+ cjkunifiedideographs => 'InCjkUni',
+
+ # InCjkUnifiedIdeographsExtensionA
+ cjkunifiedideographsextensiona => 'InCjkUn3',
+
+ # InCjkUnifiedIdeographsExtensionB
+ cjkunifiedideographsextensionb => 'InCjkUn2',
+
+ # ClosePunctuation
+ closepunctuation => 'Pe',
+
+ # InCombiningDiacriticalMarks
+ combiningdiacriticalmarks => 'InCombi2',
+
+ # InCombiningDiacriticalMarksForSymbols
+ combiningdiacriticalmarksforsymbols => 'InCombi4',
+
+ # InCombiningDiacriticalMarksSupplement
+ combiningdiacriticalmarkssupplement => 'InCombi3',
+
+ # InCombiningHalfMarks
+ combininghalfmarks => 'InCombin',
+
+ common => 'Zyyy',
+
+ # ConnectorPunctuation
+ connectorpunctuation => 'Pc',
+
+ control => 'Cc',
+
+ # InControlPictures
+ controlpictures => 'InContro',
+
+ coptic => 'Copt',
+
+ # CurrencySymbol
+ currencysymbol => 'Sc',
+
+ # InCurrencySymbols
+ currencysymbols => 'InCurren',
+
+ cypriot => 'Cprt',
+
+ # InCypriotSyllabary
+ cypriotsyllabary => 'InCyprio',
+
+ cyrillic => 'Cyrl',
+
+ # InCyrillicSupplement
+ cyrillicsupplement => 'InCyril2',
+
+ dash => 'Dash2',
+
+ # DashPunctuation
+ dashpunctuation => 'Pd',
+
+ # DecimalNumber
+ decimalnumber => 'Nd',
+
+ deprecated => 'Deprecat',
+ deseret => 'Dsrt',
+ devanagari => 'Deva',
+ diacritic => 'Diacriti',
+
+ # InDingbats
+ dingbats => 'InDingba',
+
+ # InEnclosedAlphanumerics
+ enclosedalphanumerics => 'InEnclos',
+
+ # InEnclosedCjkLettersAndMonths
+ enclosedcjklettersandmonths => 'InEnclo2',
+
+ # EnclosingMark
+ enclosingmark => 'Me',
+
+ ethiopic => 'Ethi',
+
+ # InEthiopicExtended
+ ethiopicextended => 'InEthio2',
+
+ # InEthiopicSupplement
+ ethiopicsupplement => 'InEthio3',
+
+ extender => 'Extender',
+
+ # FinalPunctuation
+ finalpunctuation => 'Pf',
+
+ format => 'Cf',
+
+ # InGeneralPunctuation
+ generalpunctuation => 'InGenera',
+
+ # InGeometricShapes
+ geometricshapes => 'InGeomet',
+
+ georgian => 'Geor',
+
+ # InGeorgianSupplement
+ georgiansupplement => 'InGeorg2',
+
+ glagolitic => 'Glag',
+ gothic => 'Goth',
+
+ # GraphemeLink
+ graphemelink => 'Grapheme',
+
+ greek => 'Grek',
+
+ # InGreekAndCoptic
+ greekandcoptic => 'InGreekA',
+
+ # InGreekExtended
+ greekextended => 'InGreekE',
+
+ gujarati => 'Gujr',
+ gurmukhi => 'Guru',
+
+ # InHalfwidthAndFullwidthForms
+ halfwidthandfullwidthforms => 'InHalfwi',
+
+ han => 'Hani',
+ hangul => 'Hang',
+
+ # InHangulCompatibilityJamo
+ hangulcompatibilityjamo => 'InHangu3',
+
+ # InHangulJamo
+ hanguljamo => 'InHangul',
+
+ # InHangulSyllables
+ hangulsyllables => 'InHangu2',
+
+ hanunoo => 'Hano',
+ hebrew => 'Hebr',
+
+ # HexDigit
+ hexdigit => 'HexDigit',
+
+ # InHighPrivateUseSurrogates
+ highprivateusesurrogates => 'InHighPr',
+
+ # InHighSurrogates
+ highsurrogates => 'InHighSu',
+
+ hiragana => 'Hira',
+ hyphen => 'Hyphen2',
+
+ # IdContinue
+ idcontinue => 'IdContin',
+
+ ideographic => 'Ideograp',
+
+ # InIdeographicDescriptionCharacters
+ ideographicdescriptioncharacters => 'InIdeogr',
+
+ # IdsBinaryOperator
+ idsbinaryoperator => 'IdsBinar',
+
+ # IdStart
+ idstart => 'IdStart',
+
+ # IdsTrinaryOperator
+ idstrinaryoperator => 'IdsTrina',
+
+ # InAegeanNumbers
+ inaegeannumbers => 'InAegean',
+
+ # InAlphabeticPresentationForms
+ inalphabeticpresentationforms => 'InAlphab',
+
+ # InAncientGreekMusicalNotation
+ inancientgreekmusicalnotation => 'InAncie2',
+
+ # InAncientGreekNumbers
+ inancientgreeknumbers => 'InAncien',
+
+ # InArabic
+ inarabic => 'InArabic',
+
+ # InArabicPresentationFormsA
+ inarabicpresentationformsa => 'InArabi4',
+
+ # InArabicPresentationFormsB
+ inarabicpresentationformsb => 'InArabi3',
+
+ # InArabicSupplement
+ inarabicsupplement => 'InArabi2',
+
+ # InArmenian
+ inarmenian => 'InArmeni',
+
+ # InArrows
+ inarrows => 'InArrows',
+
+ # InBasicLatin
+ inbasiclatin => 'InBasicL',
+
+ # InBengali
+ inbengali => 'InBengal',
+
+ # InBlockElements
+ inblockelements => 'InBlockE',
+
+ # InBopomofo
+ inbopomofo => 'InBopomo',
+
+ # InBopomofoExtended
+ inbopomofoextended => 'InBopom2',
+
+ # InBoxDrawing
+ inboxdrawing => 'InBoxDra',
+
+ # InBraillePatterns
+ inbraillepatterns => 'InBraill',
+
+ # InBuginese
+ inbuginese => 'InBugine',
+
+ # InBuhid
+ inbuhid => 'InBuhid',
+
+ # InByzantineMusicalSymbols
+ inbyzantinemusicalsymbols => 'InByzant',
+
+ # InCherokee
+ incherokee => 'InCherok',
+
+ # InCjkCompatibility
+ incjkcompatibility => 'InCjkCom',
+
+ # InCjkCompatibilityForms
+ incjkcompatibilityforms => 'InCjkCo2',
+
+ # InCjkCompatibilityIdeographs
+ incjkcompatibilityideographs => 'InCjkCo3',
+
+ # InCjkCompatibilityIdeographsSupplement
+ incjkcompatibilityideographssupplement => 'InCjkCo4',
+
+ # InCjkRadicalsSupplement
+ incjkradicalssupplement => 'InCjkRad',
+
+ # InCjkStrokes
+ incjkstrokes => 'InCjkStr',
+
+ # InCjkSymbolsAndPunctuation
+ incjksymbolsandpunctuation => 'InCjkSym',
+
+ # InCjkUnifiedIdeographs
+ incjkunifiedideographs => 'InCjkUni',
+
+ # InCjkUnifiedIdeographsExtensionA
+ incjkunifiedideographsextensiona => 'InCjkUn3',
+
+ # InCjkUnifiedIdeographsExtensionB
+ incjkunifiedideographsextensionb => 'InCjkUn2',
+
+ # InCombiningDiacriticalMarks
+ incombiningdiacriticalmarks => 'InCombi2',
+
+ # InCombiningDiacriticalMarksForSymbols
+ incombiningdiacriticalmarksforsymbols => 'InCombi4',
+
+ # InCombiningDiacriticalMarksSupplement
+ incombiningdiacriticalmarkssupplement => 'InCombi3',
+
+ # InCombiningHalfMarks
+ incombininghalfmarks => 'InCombin',
+
+ # InControlPictures
+ incontrolpictures => 'InContro',
+
+ # InCoptic
+ incoptic => 'InCoptic',
+
+ # InCurrencySymbols
+ incurrencysymbols => 'InCurren',
+
+ # InCypriotSyllabary
+ incypriotsyllabary => 'InCyprio',
+
+ # InCyrillic
+ incyrillic => 'InCyrill',
+
+ # InCyrillicSupplement
+ incyrillicsupplement => 'InCyril2',
+
+ # InDeseret
+ indeseret => 'InDesere',
+
+ # InDevanagari
+ indevanagari => 'InDevana',
+
+ # InDingbats
+ indingbats => 'InDingba',
+
+ # InEnclosedAlphanumerics
+ inenclosedalphanumerics => 'InEnclos',
+
+ # InEnclosedCjkLettersAndMonths
+ inenclosedcjklettersandmonths => 'InEnclo2',
+
+ # InEthiopic
+ inethiopic => 'InEthiop',
+
+ # InEthiopicExtended
+ inethiopicextended => 'InEthio2',
+
+ # InEthiopicSupplement
+ inethiopicsupplement => 'InEthio3',
+
+ # InGeneralPunctuation
+ ingeneralpunctuation => 'InGenera',
+
+ # InGeometricShapes
+ ingeometricshapes => 'InGeomet',
+
+ # InGeorgian
+ ingeorgian => 'InGeorgi',
+
+ # InGeorgianSupplement
+ ingeorgiansupplement => 'InGeorg2',
+
+ # InGlagolitic
+ inglagolitic => 'InGlagol',
+
+ # InGothic
+ ingothic => 'InGothic',
+
+ # InGreekAndCoptic
+ ingreekandcoptic => 'InGreekA',
+
+ # InGreekExtended
+ ingreekextended => 'InGreekE',
+
+ # InGujarati
+ ingujarati => 'InGujara',
+
+ # InGurmukhi
+ ingurmukhi => 'InGurmuk',
+
+ # InHalfwidthAndFullwidthForms
+ inhalfwidthandfullwidthforms => 'InHalfwi',
+
+ # InHangulCompatibilityJamo
+ inhangulcompatibilityjamo => 'InHangu3',
+
+ # InHangulJamo
+ inhanguljamo => 'InHangul',
+
+ # InHangulSyllables
+ inhangulsyllables => 'InHangu2',
+
+ # InHanunoo
+ inhanunoo => 'InHanuno',
+
+ # InHebrew
+ inhebrew => 'InHebrew',
+
+ inherited => 'Qaai',
+
+ # InHighPrivateUseSurrogates
+ inhighprivateusesurrogates => 'InHighPr',
+
+ # InHighSurrogates
+ inhighsurrogates => 'InHighSu',
+
+ # InHiragana
+ inhiragana => 'InHiraga',
+
+ # InIdeographicDescriptionCharacters
+ inideographicdescriptioncharacters => 'InIdeogr',
+
+ # InIpaExtensions
+ inipaextensions => 'InIpaExt',
+
+ # InitialPunctuation
+ initialpunctuation => 'Pi',
+
+ # InKanbun
+ inkanbun => 'InKanbun',
+
+ # InKangxiRadicals
+ inkangxiradicals => 'InKangxi',
+
+ # InKannada
+ inkannada => 'InKannad',
+
+ # InKatakana
+ inkatakana => 'InKataka',
+
+ # InKatakanaPhoneticExtensions
+ inkatakanaphoneticextensions => 'InKatak2',
+
+ # InKharoshthi
+ inkharoshthi => 'InKharos',
+
+ # InKhmer
+ inkhmer => 'InKhmer',
+
+ # InKhmerSymbols
+ inkhmersymbols => 'InKhmerS',
+
+ # InLao
+ inlao => 'InLao',
+
+ # InLatin1Supplement
+ inlatin1supplement => 'InLatin1',
+
+ # InLatinExtendedA
+ inlatinextendeda => 'InLatin2',
+
+ # InLatinExtendedAdditional
+ inlatinextendedadditional => 'InLatin3',
+
+ # InLatinExtendedB
+ inlatinextendedb => 'InLatinE',
+
+ # InLetterlikeSymbols
+ inletterlikesymbols => 'InLetter',
+
+ # InLimbu
+ inlimbu => 'InLimbu',
+
+ # InLinearBIdeograms
+ inlinearbideograms => 'InLinear',
+
+ # InLinearBSyllabary
+ inlinearbsyllabary => 'InLinea2',
+
+ # InLowSurrogates
+ inlowsurrogates => 'InLowSur',
+
+ # InMalayalam
+ inmalayalam => 'InMalaya',
+
+ # InMathematicalAlphanumericSymbols
+ inmathematicalalphanumericsymbols => 'InMathe2',
+
+ # InMathematicalOperators
+ inmathematicaloperators => 'InMathem',
+
+ # InMiscellaneousMathematicalSymbolsA
+ inmiscellaneousmathematicalsymbolsa => 'InMisce4',
+
+ # InMiscellaneousMathematicalSymbolsB
+ inmiscellaneousmathematicalsymbolsb => 'InMisce5',
+
+ # InMiscellaneousSymbols
+ inmiscellaneoussymbols => 'InMiscel',
+
+ # InMiscellaneousSymbolsAndArrows
+ inmiscellaneoussymbolsandarrows => 'InMisce3',
+
+ # InMiscellaneousTechnical
+ inmiscellaneoustechnical => 'InMisce2',
+
+ # InModifierToneLetters
+ inmodifiertoneletters => 'InModifi',
+
+ # InMongolian
+ inmongolian => 'InMongol',
+
+ # InMusicalSymbols
+ inmusicalsymbols => 'InMusica',
+
+ # InMyanmar
+ inmyanmar => 'InMyanma',
+
+ # InNewTaiLue
+ innewtailue => 'InNewTai',
+
+ # InNumberForms
+ innumberforms => 'InNumber',
+
+ # InOgham
+ inogham => 'InOgham',
+
+ # InOldItalic
+ inolditalic => 'InOldIta',
+
+ # InOldPersian
+ inoldpersian => 'InOldPer',
+
+ # InOpticalCharacterRecognition
+ inopticalcharacterrecognition => 'InOptica',
+
+ # InOriya
+ inoriya => 'InOriya',
+
+ # InOsmanya
+ inosmanya => 'InOsmany',
+
+ # InPhoneticExtensions
+ inphoneticextensions => 'InPhonet',
+
+ # InPhoneticExtensionsSupplement
+ inphoneticextensionssupplement => 'InPhone2',
+
+ # InPrivateUseArea
+ inprivateusearea => 'InPrivat',
+
+ # InRunic
+ inrunic => 'InRunic',
+
+ # InShavian
+ inshavian => 'InShavia',
+
+ # InSinhala
+ insinhala => 'InSinhal',
+
+ # InSmallFormVariants
+ insmallformvariants => 'InSmallF',
+
+ # InSpacingModifierLetters
+ inspacingmodifierletters => 'InSpacin',
+
+ # InSpecials
+ inspecials => 'InSpecia',
+
+ # InSuperscriptsAndSubscripts
+ insuperscriptsandsubscripts => 'InSupers',
+
+ # InSupplementalArrowsA
+ insupplementalarrowsa => 'InSuppl2',
+
+ # InSupplementalArrowsB
+ insupplementalarrowsb => 'InSupple',
+
+ # InSupplementalMathematicalOperators
+ insupplementalmathematicaloperators => 'InSuppl6',
+
+ # InSupplementalPunctuation
+ insupplementalpunctuation => 'InSuppl3',
+
+ # InSupplementaryPrivateUseAreaA
+ insupplementaryprivateuseareaa => 'InSuppl4',
+
+ # InSupplementaryPrivateUseAreaB
+ insupplementaryprivateuseareab => 'InSuppl5',
+
+ # InSylotiNagri
+ insylotinagri => 'InSyloti',
+
+ # InSyriac
+ insyriac => 'InSyriac',
+
+ # InTagalog
+ intagalog => 'InTagalo',
+
+ # InTagbanwa
+ intagbanwa => 'InTagban',
+
+ # InTags
+ intags => 'InTags',
+
+ # InTaiLe
+ intaile => 'InTaiLe',
+
+ # InTaiXuanJingSymbols
+ intaixuanjingsymbols => 'InTaiXua',
+
+ # InTamil
+ intamil => 'InTamil',
+
+ # InTelugu
+ intelugu => 'InTelugu',
+
+ # InThaana
+ inthaana => 'InThaana',
+
+ # InThai
+ inthai => 'InThai',
+
+ # InTibetan
+ intibetan => 'InTibeta',
+
+ # InTifinagh
+ intifinagh => 'InTifina',
+
+ # InUgaritic
+ inugaritic => 'InUgarit',
+
+ # InUnifiedCanadianAboriginalSyllabics
+ inunifiedcanadianaboriginalsyllabics => 'InUnifie',
+
+ # InVariationSelectors
+ invariationselectors => 'InVariat',
+
+ # InVariationSelectorsSupplement
+ invariationselectorssupplement => 'InVaria2',
+
+ # InVerticalForms
+ inverticalforms => 'InVertic',
+
+ # InYijingHexagramSymbols
+ inyijinghexagramsymbols => 'InYijing',
+
+ # InYiRadicals
+ inyiradicals => 'InYiRadi',
+
+ # InYiSyllables
+ inyisyllables => 'InYiSyll',
+
+ # InIpaExtensions
+ ipaextensions => 'InIpaExt',
+
+ # JoinControl
+ joincontrol => 'JoinCont',
+
+ # InKanbun
+ kanbun => 'InKanbun',
+
+ # InKangxiRadicals
+ kangxiradicals => 'InKangxi',
+
+ kannada => 'Knda',
+ katakana => 'Kana',
+
+ # InKatakanaPhoneticExtensions
+ katakanaphoneticextensions => 'InKatak2',
+
+ kharoshthi => 'Khar',
+ khmer => 'Khmr',
+
+ # InKhmerSymbols
+ khmersymbols => 'InKhmerS',
+
+ lao => 'Laoo',
+ latin => 'Latn',
+
+ # InLatin1Supplement
+ latin1supplement => 'InLatin1',
+
+ # InLatinExtendedA
+ latinextendeda => 'InLatin2',
+
+ # InLatinExtendedAdditional
+ latinextendedadditional => 'InLatin3',
+
+ # InLatinExtendedB
+ latinextendedb => 'InLatinE',
+
+ letter => 'L',
+
+ # InLetterlikeSymbols
+ letterlikesymbols => 'InLetter',
+
+ # LetterNumber
+ letternumber => 'Nl',
+
+ limbu => 'Limb',
+
+ # LinearB
+ linearb => 'LinearB',
+
+ # InLinearBIdeograms
+ linearbideograms => 'InLinear',
+
+ # InLinearBSyllabary
+ linearbsyllabary => 'InLinea2',
+
+ # LineSeparator
+ lineseparator => 'Zl',
+
+ # LogicalOrderException
+ logicalorderexception => 'LogicalO',
+
+ lowercase => 'Lowercas',
+
+ # LowercaseLetter
+ lowercaseletter => 'Ll',
+
+ # InLowSurrogates
+ lowsurrogates => 'InLowSur',
+
+ malayalam => 'Mlym',
+ mark => 'M',
+ math => 'Math',
+
+ # InMathematicalAlphanumericSymbols
+ mathematicalalphanumericsymbols => 'InMathe2',
+
+ # InMathematicalOperators
+ mathematicaloperators => 'InMathem',
+
+ # MathSymbol
+ mathsymbol => 'Sm',
+
+ # InMiscellaneousMathematicalSymbolsA
+ miscellaneousmathematicalsymbolsa => 'InMisce4',
+
+ # InMiscellaneousMathematicalSymbolsB
+ miscellaneousmathematicalsymbolsb => 'InMisce5',
+
+ # InMiscellaneousSymbols
+ miscellaneoussymbols => 'InMiscel',
+
+ # InMiscellaneousSymbolsAndArrows
+ miscellaneoussymbolsandarrows => 'InMisce3',
+
+ # InMiscellaneousTechnical
+ miscellaneoustechnical => 'InMisce2',
+
+ # ModifierLetter
+ modifierletter => 'Lm',
+
+ # ModifierSymbol
+ modifiersymbol => 'Sk',
+
+ # InModifierToneLetters
+ modifiertoneletters => 'InModifi',
+
+ mongolian => 'Mong',
+
+ # InMusicalSymbols
+ musicalsymbols => 'InMusica',
+
+ myanmar => 'Mymr',
+
+ # NewTaiLue
+ newtailue => 'NewTaiLu',
+
+ # NoncharacterCodePoint
+ noncharactercodepoint => 'Nonchara',
+
+ # NonspacingMark
+ nonspacingmark => 'Mn',
+
+ number => 'N',
+
+ # InNumberForms
+ numberforms => 'InNumber',
+
+ ogham => 'Ogam',
+
+ # OldItalic
+ olditalic => 'OldItali',
+
+ # OldPersian
+ oldpersian => 'OldPersi',
+
+ # OpenPunctuation
+ openpunctuation => 'Ps',
+
+ # InOpticalCharacterRecognition
+ opticalcharacterrecognition => 'InOptica',
+
+ oriya => 'Orya',
+ osmanya => 'Osma',
+ other => 'C',
+
+ # OtherAlphabetic
+ otheralphabetic => 'OtherAlp',
+
+ # OtherDefaultIgnorableCodePoint
+ otherdefaultignorablecodepoint => 'OtherDef',
+
+ # OtherGraphemeExtend
+ othergraphemeextend => 'OtherGra',
+
+ # OtherIdContinue
+ otheridcontinue => 'OtherIdC',
+
+ # OtherIdStart
+ otheridstart => 'OtherIdS',
+
+ # OtherLetter
+ otherletter => 'Lo',
+
+ # OtherLowercase
+ otherlowercase => 'OtherLow',
+
+ # OtherMath
+ othermath => 'OtherMat',
+
+ # OtherNumber
+ othernumber => 'No',
+
+ # OtherPunctuation
+ otherpunctuation => 'Po',
+
+ # OtherSymbol
+ othersymbol => 'So',
+
+ # OtherUppercase
+ otheruppercase => 'OtherUpp',
+
+ # ParagraphSeparator
+ paragraphseparator => 'Zp',
+
+ # PatternSyntax
+ patternsyntax => 'PatternS',
+
+ # PatternWhiteSpace
+ patternwhitespace => 'PatternW',
+
+ # InPhoneticExtensions
+ phoneticextensions => 'InPhonet',
+
+ # InPhoneticExtensionsSupplement
+ phoneticextensionssupplement => 'InPhone2',
+
+ # PrivateUse
+ privateuse => 'Co',
+
+ # InPrivateUseArea
+ privateusearea => 'InPrivat',
+
+ punctuation => 'P',
+
+ # QuotationMark
+ quotationmark => 'Quotatio',
+
+ radical => 'Radical2',
+ runic => 'Runr',
+ separator => 'Z',
+ shavian => 'Shaw',
+ sinhala => 'Sinh',
+
+ # InSmallFormVariants
+ smallformvariants => 'InSmallF',
+
+ # SoftDotted
+ softdotted => 'SoftDott',
+
+ # SpaceSeparator
+ spaceseparator => 'Zs',
+
+ # SpacingMark
+ spacingmark => 'Mc',
+
+ # InSpacingModifierLetters
+ spacingmodifierletters => 'InSpacin',
+
+ # InSpecials
+ specials => 'InSpecia',
+
+ sterm => 'Sterm2',
+
+ # InSuperscriptsAndSubscripts
+ superscriptsandsubscripts => 'InSupers',
+
+ # InSupplementalArrowsA
+ supplementalarrowsa => 'InSuppl2',
+
+ # InSupplementalArrowsB
+ supplementalarrowsb => 'InSupple',
+
+ # InSupplementalMathematicalOperators
+ supplementalmathematicaloperators => 'InSuppl6',
+
+ # InSupplementalPunctuation
+ supplementalpunctuation => 'InSuppl3',
+
+ # InSupplementaryPrivateUseAreaA
+ supplementaryprivateuseareaa => 'InSuppl4',
+
+ # InSupplementaryPrivateUseAreaB
+ supplementaryprivateuseareab => 'InSuppl5',
+
+ surrogate => 'Cs',
+
+ # SylotiNagri
+ sylotinagri => 'SylotiNa',
+
+ symbol => 'S',
+ syriac => 'Syrc',
+ tagalog => 'Tglg',
+ tagbanwa => 'Tagb',
+
+ # InTags
+ tags => 'InTags',
+
+ # TaiLe
+ taile => 'TaiLe',
+
+ # InTaiXuanJingSymbols
+ taixuanjingsymbols => 'InTaiXua',
+
+ tamil => 'Taml',
+ telugu => 'Telu',
+
+ # TerminalPunctuation
+ terminalpunctuation => 'Terminal',
+
+ thaana => 'Thaa',
+ thai => 'Thai',
+ tibetan => 'Tibt',
+ tifinagh => 'Tfng',
+
+ # TitlecaseLetter
+ titlecaseletter => 'Lt',
+
+ ugaritic => 'Ugar',
+ unassigned => 'Cn',
+
+ # InUnifiedCanadianAboriginalSyllabics
+ unifiedcanadianaboriginalsyllabics => 'InUnifie',
+
+ # UnifiedIdeograph
+ unifiedideograph => 'UnifiedI',
+
+ uppercase => 'Uppercas',
+
+ # UppercaseLetter
+ uppercaseletter => 'Lu',
+
+ # VariationSelector
+ variationselector => 'Variatio',
+
+ # InVariationSelectors
+ variationselectors => 'InVariat',
+
+ # InVariationSelectorsSupplement
+ variationselectorssupplement => 'InVaria2',
+
+ # InVerticalForms
+ verticalforms => 'InVertic',
+
+ # WhiteSpace
+ whitespace => 'WhiteSpa',
+
+ yi => 'Yiii',
+
+ # InYijingHexagramSymbols
+ yijinghexagramsymbols => 'InYijing',
+
+ # InYiRadicals
+ yiradicals => 'InYiRadi',
+
+ # InYiSyllables
+ yisyllables => 'InYiSyll',
+
+);
+1
diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/unicore/Exact.pl b/Master/tlpkg/lib/Perl5_lib-TL_inst/unicore/Exact.pl
new file mode 100644
index 00000000000..42312b054cc
--- /dev/null
+++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/unicore/Exact.pl
@@ -0,0 +1,73 @@
+# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+# This file is built by mktables from e.g. UnicodeData.txt.
+# Any changes made here will be lost!
+
+##
+## Data in this file used by ../utf8_heavy.pl
+##
+
+## Mapping from name to filename in ./lib/gc_sc
+%utf8::Exact = (
+ ASCII => 'ASCII',
+ All => 'Any',
+ Alnum => 'Alnum',
+ Alpha => 'Alpha',
+ Any => 'Any',
+ Assigned => 'Assigned',
+ Blank => 'Blank',
+ C => 'C',
+ Cc => 'Cc',
+ Cf => 'Cf',
+ Cn => 'Cn',
+ Cntrl => 'Cntrl',
+ Co => 'Co',
+ Cs => 'Cs',
+ Digit => 'Digit',
+ Graph => 'Graph',
+ InGreek => 'InGreekA',
+ L => 'L',
+ LC => 'LC',
+ Ll => 'Ll',
+ Lm => 'Lm',
+ Lo => 'Lo',
+ Lower => 'Lower',
+ Lt => 'Lt',
+ Lu => 'Lu',
+ M => 'M',
+ Mc => 'Mc',
+ Me => 'Me',
+ Mn => 'Mn',
+ N => 'N',
+ Nd => 'Nd',
+ Nl => 'Nl',
+ No => 'No',
+ P => 'P',
+ Pc => 'Pc',
+ Pd => 'Pd',
+ Pe => 'Pe',
+ Pf => 'Pf',
+ Pi => 'Pi',
+ Po => 'Po',
+ Print => 'Print',
+ Ps => 'Ps',
+ Punct => 'Punct',
+ S => 'S',
+ Sc => 'Sc',
+ Sk => 'Sk',
+ Sm => 'Sm',
+ So => 'So',
+ Space => 'Space',
+ SpacePerl => 'SpacePer',
+ Title => 'Title',
+ Upper => 'Upper',
+ Word => 'Word',
+ XDigit => 'XDigit',
+ Z => 'Z',
+ Zl => 'Zl',
+ Zp => 'Zp',
+ Zs => 'Zs',
+ _CanonDCIJ => '_CanonDC',
+ _CaseIgnorable => '_CaseIgn',
+ _CombAbove => '_CombAbo',
+);
+1;
diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/unicore/PVA.pl b/Master/tlpkg/lib/Perl5_lib-TL_inst/unicore/PVA.pl
new file mode 100644
index 00000000000..d836bdb7549
--- /dev/null
+++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/unicore/PVA.pl
@@ -0,0 +1,2044 @@
+# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+# This file is built by mktables from e.g. UnicodeData.txt.
+# Any changes made here will be lost!
+
+
+%utf8::PropertyAlias = (
+'sc',
+'Script',
+'xonfkd',
+'ExpandsOnNFKD',
+'patsyn',
+'PatternSyntax',
+'nfkcqc',
+'NFKCQuickCheck',
+'oalpha',
+'OtherAlphabetic',
+'gcb',
+'GraphemeClusterBreak',
+'nfcqc',
+'NFCQuickCheck',
+'ids',
+'IDStart',
+'lb',
+'LineBreak',
+'stc',
+'SimpleTitlecaseMapping',
+'xonfkc',
+'ExpandsOnNFKC',
+'patws',
+'PatternWhiteSpace',
+'tc',
+'TitlecaseMapping',
+'lower',
+'Lowercase',
+'idst',
+'IDSTrinaryOperator',
+'radical',
+'Radical',
+'fcnfkc',
+'FCNFKCClosure',
+'dm',
+'DecompositionMapping',
+'slc',
+'SimpleLowercaseMapping',
+'wspace',
+'WhiteSpace',
+'di',
+'DefaultIgnorableCodePoint',
+'nt',
+'NumericType',
+'ea',
+'EastAsianWidth',
+'ahex',
+'ASCIIHexDigit',
+'alpha',
+'Alphabetic',
+'uc',
+'UppercaseMapping',
+'dia',
+'Diacritic',
+'gc',
+'GeneralCategory',
+'xids',
+'XIDStart',
+'oupper',
+'OtherUppercase',
+'wb',
+'WordBreak',
+'math',
+'Math',
+'sb',
+'SentenceBreak',
+'qmark',
+'QuotationMark',
+'nfdqc',
+'NFDQuickCheck',
+'ideo',
+'Ideographic',
+'blk',
+'Block',
+'odi',
+'OtherDefaultIgnorableCodePoint',
+'hst',
+'HangulSyllableType',
+'bidim',
+'BidiMirrored',
+'olower',
+'OtherLowercase',
+'na',
+'Name',
+'hyphen',
+'Hyphen',
+'xidc',
+'XIDContinue',
+'oidc',
+'OtherIDContinue',
+'bidic',
+'BidiControl',
+'na1',
+'Unicode1Name',
+'compex',
+'FullCompositionExclusion',
+'ext',
+'Extender',
+'cf',
+'CaseFolding',
+'grlink',
+'GraphemeLink',
+'xonfc',
+'ExpandsOnNFC',
+'sd',
+'SoftDotted',
+'ccc',
+'CanonicalCombiningClass',
+'dash',
+'Dash',
+'hex',
+'HexDigit',
+'grbase',
+'GraphemeBase',
+'dt',
+'DecompositionType',
+'xonfd',
+'ExpandsOnNFD',
+'scc',
+'SpecialCaseCondition',
+'idsb',
+'IDSBinaryOperator',
+'age',
+'Age',
+'loe',
+'LogicalOrderException',
+'term',
+'TerminalPunctuation',
+'ce',
+'CompositionExclusion',
+'isc',
+'ISOComment',
+'dep',
+'Deprecated',
+'sfc',
+'SimpleCaseFolding',
+'bc',
+'BidiClass',
+'nchar',
+'NoncharacterCodePoint',
+'jt',
+'JoiningType',
+'upper',
+'Uppercase',
+'uideo',
+'UnifiedIdeograph',
+'sterm',
+'STerm',
+'nfkdqc',
+'NFKDQuickCheck',
+'oids',
+'OtherIDStart',
+'joinc',
+'JoinControl',
+'nv',
+'NumericValue',
+'suc',
+'SimpleUppercaseMapping',
+'urs',
+'UnicodeRadicalStroke',
+'bmg',
+'BidiMirroringGlyph',
+'grext',
+'GraphemeExtend',
+'idc',
+'IDContinue',
+'vs',
+'VariationSelector',
+'omath',
+'OtherMath',
+'lc',
+'LowercaseMapping',
+'ogrext',
+'OtherGraphemeExtend',
+'jg',
+'JoiningGroup',
+);
+
+%utf8::PA_reverse = (
+'linebreak',
+'lb',
+'bidiclass',
+'bc',
+'terminalpunctuation',
+'Term',
+'expandsonnfkc',
+'XONFKC',
+'extender',
+'Ext',
+'simplecasefolding',
+'sfc',
+'patternsyntax',
+'PatSyn',
+'sentencebreak',
+'SB',
+'numericvalue',
+'nv',
+'patternwhitespace',
+'PatWS',
+'softdotted',
+'SD',
+'logicalorderexception',
+'LOE',
+'idstart',
+'IDS',
+'generalcategory',
+'gc',
+'decompositiontype',
+'dt',
+'name',
+'na',
+'numerictype',
+'nt',
+'otherlowercase',
+'OLower',
+'joininggroup',
+'jg',
+'expandsonnfkd',
+'XONFKD',
+'deprecated',
+'Dep',
+'radical',
+'Radical',
+'idstrinaryoperator',
+'IDST',
+'xidstart',
+'XIDS',
+'lowercase',
+'Lower',
+'unifiedideograph',
+'UIdeo',
+'othergraphemeextend',
+'OGrExt',
+'eastasianwidth',
+'ea',
+'math',
+'Math',
+'graphemelink',
+'GrLink',
+'noncharactercodepoint',
+'NChar',
+'graphemebase',
+'GrBase',
+'bidimirrored',
+'BidiM',
+'casefolding',
+'cf',
+'simpleuppercasemapping',
+'suc',
+'fullcompositionexclusion',
+'CompEx',
+'compositionexclusion',
+'CE',
+'uppercasemapping',
+'uc',
+'decompositionmapping',
+'dm',
+'whitespace',
+'WSpace',
+'hyphen',
+'Hyphen',
+'ideographic',
+'Ideo',
+'idcontinue',
+'IDC',
+'idsbinaryoperator',
+'IDSB',
+'hangulsyllabletype',
+'hst',
+'asciihexdigit',
+'AHex',
+'otheruppercase',
+'OUpper',
+'nfkdquickcheck',
+'NFKDQC',
+'simpletitlecasemapping',
+'stc',
+'nfcquickcheck',
+'NFCQC',
+'bidicontrol',
+'BidiC',
+'diacritic',
+'Dia',
+'joiningtype',
+'jt',
+'otheralphabetic',
+'OAlpha',
+'canonicalcombiningclass',
+'ccc',
+'alphabetic',
+'Alpha',
+'titlecasemapping',
+'tc',
+'unicoderadicalstroke',
+'URS',
+'hexdigit',
+'Hex',
+'unicode1name',
+'na1',
+'dash',
+'Dash',
+'fcnfkcclosure',
+'FCNFKC',
+'graphemeextend',
+'GrExt',
+'joincontrol',
+'JoinC',
+'xidcontinue',
+'XIDC',
+'quotationmark',
+'QMark',
+'expandsonnfd',
+'XONFD',
+'age',
+'age',
+'otheridcontinue',
+'OIDC',
+'uppercase',
+'Upper',
+'expandsonnfc',
+'XONFC',
+'defaultignorablecodepoint',
+'DI',
+'nfdquickcheck',
+'NFDQC',
+'isocomment',
+'isc',
+'otherdefaultignorablecodepoint',
+'ODI',
+'variationselector',
+'VS',
+'specialcasecondition',
+'scc',
+'script',
+'sc',
+'otheridstart',
+'OIDS',
+'sterm',
+'STerm',
+'graphemeclusterbreak',
+'GCB',
+'nfkcquickcheck',
+'NFKCQC',
+'bidimirroringglyph',
+'bmg',
+'othermath',
+'OMath',
+'block',
+'blk',
+'wordbreak',
+'WB',
+'lowercasemapping',
+'lc',
+'simplelowercasemapping',
+'slc',
+);
+
+%utf8::PropValueAlias = (
+'sc',
+{
+'tglg',
+'Tagalog',
+'runr',
+'Runic',
+'osma',
+'Osmanya',
+'hano',
+'Hanunoo',
+'cans',
+'CanadianAboriginal',
+'tagb',
+'Tagbanwa',
+'mlym',
+'Malayalam',
+'knda',
+'Kannada',
+'grek',
+'Greek',
+'ethi',
+'Ethiopic',
+'orya',
+'Oriya',
+'cher',
+'Cherokee',
+'mong',
+'Mongolian',
+'khmr',
+'Khmer',
+'ogam',
+'Ogham',
+'hrkt',
+'KatakanaOrHiragana',
+'armn',
+'Armenian',
+'ital',
+'OldItalic',
+'hani',
+'Han',
+'shaw',
+'Shavian',
+'taml',
+'Tamil',
+'tibt',
+'Tibetan',
+'guru',
+'Gurmukhi',
+'ugar',
+'Ugaritic',
+'qaai',
+'Inherited',
+'kana',
+'Katakana',
+'gujr',
+'Gujarati',
+'thaa',
+'Thaana',
+'cyrl',
+'Cyrillic',
+'copt',
+'Coptic',
+'sylo',
+'SylotiNagri',
+'thai',
+'Thai',
+'talu',
+'NewTaiLue',
+'laoo',
+'Lao',
+'sinh',
+'Sinhala',
+'beng',
+'Bengali',
+'hira',
+'Hiragana',
+'brai',
+'Braille',
+'telu',
+'Telugu',
+'limb',
+'Limbu',
+'geor',
+'Georgian',
+'mymr',
+'Myanmar',
+'glag',
+'Glagolitic',
+'hang',
+'Hangul',
+'syrc',
+'Syriac',
+'tfng',
+'Tifinagh',
+'dsrt',
+'Deseret',
+'buhd',
+'Buhid',
+'yiii',
+'Yi',
+'arab',
+'Arabic',
+'bopo',
+'Bopomofo',
+'khar',
+'Kharoshthi',
+'linb',
+'LinearB',
+'deva',
+'Devanagari',
+'xpeo',
+'OldPersian',
+'goth',
+'Gothic',
+'cprt',
+'Cypriot',
+'tale',
+'TaiLe',
+'zyyy',
+'Common',
+'latn',
+'Latin',
+'bugi',
+'Buginese',
+'hebr',
+'Hebrew',
+},
+'dt',
+{
+'fra',
+'Fraction',
+'none',
+'None',
+'sml',
+'Small',
+'enc',
+'Circle',
+'font',
+'Font',
+'init',
+'Initial',
+'nb',
+'Nobreak',
+'iso',
+'Isolated',
+'sup',
+'Super',
+'fin',
+'Final',
+'wide',
+'Wide',
+'nar',
+'Narrow',
+'can',
+'Canonical',
+'med',
+'Medial',
+'sub',
+'Sub',
+'vert',
+'Vertical',
+'sqr',
+'Square',
+'com',
+'Compat',
+},
+'nt',
+{
+'none',
+'None',
+'di',
+'Digit',
+'de',
+'Decimal',
+'nu',
+'Numeric',
+},
+'ea',
+{
+'w',
+'Wide',
+'n',
+'Neutral',
+'h',
+'Halfwidth',
+'a',
+'Ambiguous',
+'f',
+'Fullwidth',
+'na',
+'Narrow',
+},
+'NFKC_QC',
+{
+'y',
+'Yes',
+'n',
+'No',
+'m',
+'Maybe',
+},
+'bc',
+{
+'r',
+'RightToLeft',
+'rlo',
+'RightToLeftOverride',
+'es',
+'EuropeanSeparator',
+'ws',
+'WhiteSpace',
+'rle',
+'RightToLeftEmbedding',
+'on',
+'OtherNeutral',
+'bn',
+'BoundaryNeutral',
+'et',
+'EuropeanTerminator',
+'pdf',
+'PopDirectionalFormat',
+'lro',
+'LeftToRightOverride',
+'s',
+'SegmentSeparator',
+'al',
+'ArabicLetter',
+'en',
+'EuropeanNumber',
+'l',
+'LeftToRight',
+'b',
+'ParagraphSeparator',
+'lre',
+'LeftToRightEmbedding',
+'cs',
+'CommonSeparator',
+'nsm',
+'NonspacingMark',
+'an',
+'ArabicNumber',
+},
+'gc',
+{
+'sc',
+'CurrencySymbol',
+'mc',
+'SpacingMark',
+'lm',
+'ModifierLetter',
+'cn',
+'Unassigned',
+'pf',
+'FinalPunctuation',
+'no',
+'OtherNumber',
+'cc',
+'Control',
+'lo',
+'OtherLetter',
+'po',
+'OtherPunctuation',
+'zs',
+'SpaceSeparator',
+'co',
+'PrivateUse',
+'so',
+'OtherSymbol',
+'ll',
+'LowercaseLetter',
+'nd',
+'DecimalNumber',
+'cf',
+'Format',
+'me',
+'EnclosingMark',
+'s',
+'Symbol',
+'zp',
+'ParagraphSeparator',
+'pd',
+'DashPunctuation',
+'c',
+'Other',
+'lt',
+'TitlecaseLetter',
+'cs',
+'Surrogate',
+'l&',
+'CasedLetter',
+'z',
+'Separator',
+'ps',
+'OpenPunctuation',
+'zl',
+'LineSeparator',
+'pc',
+'ConnectorPunctuation',
+'pi',
+'InitialPunctuation',
+'n',
+'Number',
+'m',
+'Mark',
+'nl',
+'LetterNumber',
+'sm',
+'MathSymbol',
+'l',
+'Letter',
+'mn',
+'NonspacingMark',
+'p',
+'Punctuation',
+'lc',
+'CasedLetter',
+'sk',
+'ModifierSymbol',
+'lu',
+'UppercaseLetter',
+'pe',
+'ClosePunctuation',
+},
+'GCB',
+{
+'cn',
+'Control',
+'ex',
+'Extend',
+'v',
+'V',
+'lv',
+'LV',
+'xx',
+'Other',
+'l',
+'L',
+'lvt',
+'LVT',
+'cr',
+'CR',
+'lf',
+'LF',
+'t',
+'T',
+},
+'lb',
+{
+'sp',
+'Space',
+'ba',
+'BreakAfter',
+'gl',
+'Glue',
+'xx',
+'Unknown',
+'nu',
+'Numeric',
+'cb',
+'ContingentBreak',
+'sy',
+'BreakSymbols',
+'cr',
+'CarriageReturn',
+'in',
+'Inseparable',
+'bb',
+'BreakBefore',
+'sg',
+'Surrogate',
+'sa',
+'ComplexContext',
+'po',
+'PostfixNumeric',
+'jl',
+'JL',
+'id',
+'Ideographic',
+'al',
+'Alphabetic',
+'bk',
+'MandatoryBreak',
+'pr',
+'PrefixNumeric',
+'b2',
+'BreakBoth',
+'op',
+'OpenPunctuation',
+'cl',
+'ClosePunctuation',
+'is',
+'InfixNumeric',
+'qu',
+'Quotation',
+'hy',
+'Hyphen',
+'wj',
+'WordJoiner',
+'zw',
+'ZWSpace',
+'jt',
+'JT',
+'ex',
+'Exclamation',
+'cm',
+'CombiningMark',
+'h2',
+'H2',
+'nl',
+'NextLine',
+'ns',
+'Nonstarter',
+'h3',
+'H3',
+'ai',
+'Ambiguous',
+'lf',
+'LineFeed',
+'jv',
+'JV',
+},
+'jt',
+{
+'l',
+'LeftJoining',
+'u',
+'NonJoining',
+'c',
+'JoinCausing',
+'r',
+'RightJoining',
+'d',
+'DualJoining',
+'t',
+'Transparent',
+},
+'NFKD_QC',
+{
+'y',
+'Yes',
+'n',
+'No',
+},
+'NFC_QC',
+{
+'y',
+'Yes',
+'n',
+'No',
+'m',
+'Maybe',
+},
+'hst',
+{
+'l',
+'LeadingJamo',
+'lvt',
+'LVTSyllable',
+'v',
+'VowelJamo',
+'lv',
+'LVSyllable',
+'t',
+'TrailingJamo',
+'na',
+'NotApplicable',
+},
+'NFD_QC',
+{
+'y',
+'Yes',
+'n',
+'No',
+},
+'WB',
+{
+'ml',
+'MidLetter',
+'le',
+'ALetter',
+'ex',
+'ExtendNumLet',
+'xx',
+'Other',
+'nu',
+'Numeric',
+'fo',
+'Format',
+'mn',
+'MidNum',
+'ka',
+'Katakana',
+},
+'SB',
+{
+'sp',
+'Sp',
+'cl',
+'Close',
+'le',
+'OLetter',
+'up',
+'Upper',
+'st',
+'STerm',
+'xx',
+'Other',
+'nu',
+'Numeric',
+'fo',
+'Format',
+'se',
+'Sep',
+'lo',
+'Lower',
+'at',
+'ATerm',
+},
+'ccc',
+{
+'atb',
+'AttachedBelow',
+'db',
+'DoubleBelow',
+'a',
+'Above',
+'r',
+'Right',
+'da',
+'DoubleAbove',
+'is',
+'IotaSubscript',
+'nr',
+'NotReordered',
+'ov',
+'Overlay',
+'br',
+'BelowRight',
+'nk',
+'Nukta',
+'atbl',
+'AttachedBelowLeft',
+'al',
+'AboveLeft',
+'ar',
+'AboveRight',
+'atar',
+'AttachedAboveRight',
+'l',
+'Left',
+'b',
+'Below',
+'vr',
+'Virama',
+'kv',
+'KanaVoicing',
+'bl',
+'BelowLeft',
+},
+);
+
+%utf8::PVA_reverse = (
+'sc',
+{
+'newtailue',
+'Talu',
+'canadianaboriginal',
+'Cans',
+'gujarati',
+'Gujr',
+'latin',
+'Latn',
+'hangul',
+'Hang',
+'deseret',
+'Dsrt',
+'hebrew',
+'Hebr',
+'inherited',
+'Qaai',
+'linearb',
+'Linb',
+'ugaritic',
+'Ugar',
+'taile',
+'Tale',
+'armenian',
+'Armn',
+'tifinagh',
+'Tfng',
+'myanmar',
+'Mymr',
+'gurmukhi',
+'Guru',
+'greek',
+'Grek',
+'coptic',
+'Copt',
+'cyrillic',
+'Cyrl',
+'thaana',
+'Thaa',
+'lao',
+'Laoo',
+'katakana',
+'Kana',
+'khmer',
+'Khmr',
+'tibetan',
+'Tibt',
+'hiragana',
+'Hira',
+'mongolian',
+'Mong',
+'thai',
+'Thai',
+'yi',
+'Yiii',
+'sylotinagri',
+'Sylo',
+'bopomofo',
+'Bopo',
+'malayalam',
+'Mlym',
+'telugu',
+'Telu',
+'limbu',
+'Limb',
+'oriya',
+'Orya',
+'buhid',
+'Buhd',
+'cypriot',
+'Cprt',
+'bengali',
+'Beng',
+'katakanaorhiragana',
+'Hrkt',
+'oldpersian',
+'Xpeo',
+'tagalog',
+'Tglg',
+'syriac',
+'Syrc',
+'cherokee',
+'Cher',
+'ogham',
+'Ogam',
+'hanunoo',
+'Hano',
+'braille',
+'Brai',
+'tamil',
+'Taml',
+'common',
+'Zyyy',
+'runic',
+'Runr',
+'georgian',
+'Geor',
+'ethiopic',
+'Ethi',
+'glagolitic',
+'Glag',
+'han',
+'Hani',
+'kharoshthi',
+'Khar',
+'kannada',
+'Knda',
+'tagbanwa',
+'Tagb',
+'arabic',
+'Arab',
+'sinhala',
+'Sinh',
+'gothic',
+'Goth',
+'osmanya',
+'Osma',
+'olditalic',
+'Ital',
+'devanagari',
+'Deva',
+'buginese',
+'Bugi',
+'shavian',
+'Shaw',
+},
+'dt',
+{
+'small',
+'sml',
+'none',
+'none',
+'isolated',
+'iso',
+'narrow',
+'nar',
+'square',
+'sqr',
+'nobreak',
+'nb',
+'fraction',
+'fra',
+'font',
+'font',
+'medial',
+'med',
+'wide',
+'wide',
+'canonical',
+'can',
+'circle',
+'enc',
+'super',
+'sup',
+'vertical',
+'vert',
+'final',
+'fin',
+'compat',
+'com',
+'sub',
+'sub',
+'initial',
+'init',
+},
+'nt',
+{
+'none',
+'None',
+'digit',
+'Di',
+'numeric',
+'Nu',
+'decimal',
+'De',
+},
+'ea',
+{
+'halfwidth',
+'H',
+'fullwidth',
+'F',
+'ambiguous',
+'A',
+'narrow',
+'Na',
+'wide',
+'W',
+'neutral',
+'N',
+},
+'NFKC_QC',
+{
+'yes',
+'Y',
+'maybe',
+'M',
+'no',
+'N',
+},
+'bc',
+{
+'nonspacingmark',
+'NSM',
+'whitespace',
+'WS',
+'righttoleft',
+'R',
+'lefttoright',
+'L',
+'boundaryneutral',
+'BN',
+'segmentseparator',
+'S',
+'lefttorightembedding',
+'LRE',
+'europeanterminator',
+'ET',
+'righttoleftembedding',
+'RLE',
+'righttoleftoverride',
+'RLO',
+'lefttorightoverride',
+'LRO',
+'europeanseparator',
+'ES',
+'europeannumber',
+'EN',
+'commonseparator',
+'CS',
+'arabicletter',
+'AL',
+'paragraphseparator',
+'B',
+'otherneutral',
+'ON',
+'popdirectionalformat',
+'PDF',
+'arabicnumber',
+'AN',
+},
+'gc',
+{
+'modifiersymbol',
+'Sk',
+'letternumber',
+'Nl',
+'connectorpunctuation',
+'Pc',
+'spacingmark',
+'Mc',
+'mark',
+'M',
+'unassigned',
+'Cn',
+'enclosingmark',
+'Me',
+'lineseparator',
+'Zl',
+'lowercaseletter',
+'Ll',
+'symbol',
+'S',
+'letter',
+'L',
+'othernumber',
+'No',
+'paragraphseparator',
+'Zp',
+'modifierletter',
+'Lm',
+'titlecaseletter',
+'Lt',
+'decimalnumber',
+'Nd',
+'other',
+'C',
+'mathsymbol',
+'Sm',
+'surrogate',
+'Cs',
+'otherletter',
+'Lo',
+'nonspacingmark',
+'Mn',
+'number',
+'N',
+'uppercaseletter',
+'Lu',
+'spaceseparator',
+'Zs',
+'privateuse',
+'Co',
+'openpunctuation',
+'Ps',
+'punctuation',
+'P',
+'control',
+'Cc',
+'casedletter',
+'LC',
+'closepunctuation',
+'Pe',
+'otherpunctuation',
+'Po',
+'finalpunctuation',
+'Pf',
+'format',
+'Cf',
+'initialpunctuation',
+'Pi',
+'separator',
+'Z',
+'othersymbol',
+'So',
+'dashpunctuation',
+'Pd',
+'currencysymbol',
+'Sc',
+},
+'GCB',
+{
+'extend',
+'EX',
+'v',
+'V',
+'lv',
+'LV',
+'l',
+'L',
+'lvt',
+'LVT',
+'cr',
+'CR',
+'other',
+'XX',
+'lf',
+'LF',
+'control',
+'CN',
+'t',
+'T',
+},
+'lb',
+{
+'carriagereturn',
+'CR',
+'ideographic',
+'ID',
+'hyphen',
+'HY',
+'ambiguous',
+'AI',
+'contingentbreak',
+'CB',
+'complexcontext',
+'SA',
+'prefixnumeric',
+'PR',
+'jl',
+'JL',
+'inseparable',
+'IN',
+'breaksymbols',
+'SY',
+'breakafter',
+'BA',
+'breakbefore',
+'BB',
+'postfixnumeric',
+'PO',
+'glue',
+'GL',
+'wordjoiner',
+'WJ',
+'breakboth',
+'B2',
+'quotation',
+'QU',
+'combiningmark',
+'CM',
+'nonstarter',
+'NS',
+'linefeed',
+'LF',
+'alphabetic',
+'AL',
+'surrogate',
+'SG',
+'mandatorybreak',
+'BK',
+'unknown',
+'XX',
+'exclamation',
+'EX',
+'openpunctuation',
+'OP',
+'jt',
+'JT',
+'closepunctuation',
+'CL',
+'space',
+'SP',
+'zwspace',
+'ZW',
+'h2',
+'H2',
+'infixnumeric',
+'IS',
+'nextline',
+'NL',
+'numeric',
+'NU',
+'h3',
+'H3',
+'jv',
+'JV',
+},
+'jt',
+{
+'leftjoining',
+'L',
+'transparent',
+'T',
+'nonjoining',
+'U',
+'rightjoining',
+'R',
+'dualjoining',
+'D',
+'joincausing',
+'C',
+},
+'NFKD_QC',
+{
+'yes',
+'Y',
+'no',
+'N',
+},
+'NFC_QC',
+{
+'yes',
+'Y',
+'maybe',
+'M',
+'no',
+'N',
+},
+'hst',
+{
+'lvtsyllable',
+'LVT',
+'lvsyllable',
+'LV',
+'leadingjamo',
+'L',
+'notapplicable',
+'NA',
+'voweljamo',
+'V',
+'trailingjamo',
+'T',
+},
+'NFD_QC',
+{
+'yes',
+'Y',
+'no',
+'N',
+},
+'WB',
+{
+'midletter',
+'ML',
+'format',
+'FO',
+'katakana',
+'KA',
+'other',
+'XX',
+'midnum',
+'MN',
+'numeric',
+'NU',
+'extendnumlet',
+'EX',
+'aletter',
+'LE',
+},
+'SB',
+{
+'sp',
+'SP',
+'upper',
+'UP',
+'sterm',
+'ST',
+'aterm',
+'AT',
+'close',
+'CL',
+'oletter',
+'LE',
+'sep',
+'SE',
+'format',
+'FO',
+'other',
+'XX',
+'lower',
+'LO',
+'numeric',
+'NU',
+},
+'ccc',
+{
+'left',
+'L',
+'attachedbelowleft',
+'ATBL',
+'belowleft',
+'BL',
+'aboveright',
+'AR',
+'kanavoicing',
+'KV',
+'above',
+'A',
+'aboveleft',
+'AL',
+'nukta',
+'NK',
+'below',
+'B',
+'doublebelow',
+'DB',
+'virama',
+'VR',
+'belowright',
+'BR',
+'notreordered',
+'NR',
+'attachedbelow',
+'ATB',
+'right',
+'R',
+'iotasubscript',
+'IS',
+'doubleabove',
+'DA',
+'attachedaboveright',
+'ATAR',
+'overlay',
+'OV',
+},
+);
+
+%utf8::PVA_abbr_map = (
+'jt',
+{
+'l',
+'L',
+'u',
+'U',
+'c',
+'C',
+'r',
+'R',
+'d',
+'D',
+'t',
+'T',
+},
+'dt',
+{
+'fra',
+'fra',
+'none',
+'none',
+'sml',
+'sml',
+'enc',
+'enc',
+'font',
+'font',
+'init',
+'init',
+'nb',
+'nb',
+'iso',
+'iso',
+'sup',
+'sup',
+'fin',
+'fin',
+'wide',
+'wide',
+'nar',
+'nar',
+'can',
+'can',
+'med',
+'med',
+'sub',
+'sub',
+'vert',
+'vert',
+'sqr',
+'sqr',
+'com',
+'com',
+},
+'nt',
+{
+'none',
+'None',
+'di',
+'Di',
+'de',
+'De',
+'nu',
+'Nu',
+},
+'NFKD_QC',
+{
+'y',
+'Y',
+'n',
+'N',
+},
+'ea',
+{
+'w',
+'W',
+'n',
+'N',
+'h',
+'H',
+'a',
+'A',
+'f',
+'F',
+'na',
+'Na',
+},
+'gc_sc',
+{
+'runr',
+'Runr',
+'osma',
+'Osma',
+'sc',
+'Sc',
+'mc',
+'Mc',
+'hano',
+'Hano',
+'cans',
+'Cans',
+'lm',
+'Lm',
+'cn',
+'Cn',
+'knda',
+'Knda',
+'orya',
+'Orya',
+'cher',
+'Cher',
+'khmr',
+'Khmr',
+'ogam',
+'Ogam',
+'lo',
+'Lo',
+'po',
+'Po',
+'co',
+'Co',
+'ital',
+'Ital',
+'ll',
+'Ll',
+'tibt',
+'Tibt',
+'kana',
+'Kana',
+'zp',
+'Zp',
+'gujr',
+'Gujr',
+'thaa',
+'Thaa',
+'cs',
+'Cs',
+'copt',
+'Copt',
+'z',
+'Z',
+'ps',
+'Ps',
+'sylo',
+'Sylo',
+'talu',
+'Talu',
+'laoo',
+'Laoo',
+'sinh',
+'Sinh',
+'zl',
+'Zl',
+'pc',
+'Pc',
+'hira',
+'Hira',
+'limb',
+'Limb',
+'mymr',
+'Mymr',
+'yiii',
+'Yiii',
+'arab',
+'Arab',
+'deva',
+'Deva',
+'xpeo',
+'Xpeo',
+'cprt',
+'Cprt',
+'bugi',
+'Bugi',
+'sk',
+'Sk',
+'hebr',
+'Hebr',
+'lu',
+'Lu',
+'pe',
+'Pe',
+'tglg',
+'Tglg',
+'tagb',
+'Tagb',
+'mlym',
+'Mlym',
+'pf',
+'Pf',
+'no',
+'No',
+'grek',
+'Grek',
+'ethi',
+'Ethi',
+'mong',
+'Mong',
+'cc',
+'Cc',
+'hrkt',
+'Hrkt',
+'armn',
+'Armn',
+'zs',
+'Zs',
+'so',
+'So',
+'hani',
+'Hani',
+'shaw',
+'Shaw',
+'taml',
+'Taml',
+'me',
+'Me',
+'cf',
+'Cf',
+'nd',
+'Nd',
+'s',
+'S',
+'guru',
+'Guru',
+'ugar',
+'Ugar',
+'qaai',
+'Qaai',
+'lt',
+'Lt',
+'c',
+'C',
+'pd',
+'Pd',
+'cyrl',
+'Cyrl',
+'l&',
+'LC',
+'thai',
+'Thai',
+'beng',
+'Beng',
+'brai',
+'Brai',
+'telu',
+'Telu',
+'pi',
+'Pi',
+'geor',
+'Geor',
+'glag',
+'Glag',
+'hang',
+'Hang',
+'syrc',
+'Syrc',
+'tfng',
+'Tfng',
+'n',
+'N',
+'dsrt',
+'Dsrt',
+'buhd',
+'Buhd',
+'m',
+'M',
+'khar',
+'Khar',
+'sm',
+'Sm',
+'nl',
+'Nl',
+'bopo',
+'Bopo',
+'linb',
+'Linb',
+'mn',
+'Mn',
+'l',
+'L',
+'p',
+'P',
+'goth',
+'Goth',
+'tale',
+'Tale',
+'lc',
+'LC',
+'zyyy',
+'Zyyy',
+'latn',
+'Latn',
+},
+'NFC_QC',
+{
+'y',
+'Y',
+'n',
+'N',
+'m',
+'M',
+},
+'NFD_QC',
+{
+'y',
+'Y',
+'n',
+'N',
+},
+'hst',
+{
+'l',
+'L',
+'lvt',
+'LVT',
+'v',
+'V',
+'lv',
+'LV',
+'t',
+'T',
+'na',
+'NA',
+},
+'NFKC_QC',
+{
+'y',
+'Y',
+'n',
+'N',
+'m',
+'M',
+},
+'WB',
+{
+'ml',
+'ML',
+'le',
+'LE',
+'ex',
+'EX',
+'xx',
+'XX',
+'nu',
+'NU',
+'fo',
+'FO',
+'mn',
+'MN',
+'ka',
+'KA',
+},
+'SB',
+{
+'sp',
+'SP',
+'cl',
+'CL',
+'le',
+'LE',
+'up',
+'UP',
+'st',
+'ST',
+'xx',
+'XX',
+'nu',
+'NU',
+'fo',
+'FO',
+'se',
+'SE',
+'lo',
+'LO',
+'at',
+'AT',
+},
+'bc',
+{
+'r',
+'R',
+'rlo',
+'RLO',
+'es',
+'ES',
+'ws',
+'WS',
+'rle',
+'RLE',
+'on',
+'ON',
+'bn',
+'BN',
+'et',
+'ET',
+'pdf',
+'PDF',
+'lro',
+'LRO',
+'s',
+'S',
+'al',
+'AL',
+'en',
+'EN',
+'l',
+'L',
+'b',
+'B',
+'lre',
+'LRE',
+'cs',
+'CS',
+'nsm',
+'NSM',
+'an',
+'AN',
+},
+'GCB',
+{
+'cn',
+'CN',
+'ex',
+'EX',
+'v',
+'V',
+'lv',
+'LV',
+'xx',
+'XX',
+'l',
+'L',
+'lvt',
+'LVT',
+'cr',
+'CR',
+'lf',
+'LF',
+'t',
+'T',
+},
+'ccc',
+{
+'atb',
+'ATB',
+'db',
+'DB',
+'a',
+'A',
+'r',
+'R',
+'da',
+'DA',
+'is',
+'IS',
+'nr',
+'NR',
+'ov',
+'OV',
+'br',
+'BR',
+'nk',
+'NK',
+'atbl',
+'ATBL',
+'al',
+'AL',
+'ar',
+'AR',
+'atar',
+'ATAR',
+'l',
+'L',
+'b',
+'B',
+'vr',
+'VR',
+'kv',
+'KV',
+'bl',
+'BL',
+},
+'lb',
+{
+'sp',
+'SP',
+'ba',
+'BA',
+'gl',
+'GL',
+'xx',
+'XX',
+'nu',
+'NU',
+'cb',
+'CB',
+'sy',
+'SY',
+'cr',
+'CR',
+'in',
+'IN',
+'bb',
+'BB',
+'sg',
+'SG',
+'sa',
+'SA',
+'po',
+'PO',
+'jl',
+'JL',
+'id',
+'ID',
+'al',
+'AL',
+'bk',
+'BK',
+'pr',
+'PR',
+'b2',
+'B2',
+'op',
+'OP',
+'cl',
+'CL',
+'is',
+'IS',
+'qu',
+'QU',
+'hy',
+'HY',
+'wj',
+'WJ',
+'zw',
+'ZW',
+'jt',
+'JT',
+'ex',
+'EX',
+'cm',
+'CM',
+'h2',
+'H2',
+'nl',
+'NL',
+'ns',
+'NS',
+'h3',
+'H3',
+'ai',
+'AI',
+'lf',
+'LF',
+'jv',
+'JV',
+},
+);
+1;
diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/unicore/To/Lower.pl b/Master/tlpkg/lib/Perl5_lib-TL_inst/unicore/To/Lower.pl
new file mode 100644
index 00000000000..77a7a7fb0e0
--- /dev/null
+++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/unicore/To/Lower.pl
@@ -0,0 +1,905 @@
+# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+# This file is built by mktables from e.g. UnicodeData.txt.
+# Any changes made here will be lost!
+
+
+# The key UTF-8 _bytes_, the value UTF-8 (speed hack)
+%utf8::ToSpecLower =
+(
+"\xC4\xB0" => "\x{0069}\x{0307}",
+"\xE1\xBE\x88" => "\x{1F80}",
+"\xE1\xBE\x89" => "\x{1F81}",
+"\xE1\xBE\x8A" => "\x{1F82}",
+"\xE1\xBE\x8B" => "\x{1F83}",
+"\xE1\xBE\x8C" => "\x{1F84}",
+"\xE1\xBE\x8D" => "\x{1F85}",
+"\xE1\xBE\x8E" => "\x{1F86}",
+"\xE1\xBE\x8F" => "\x{1F87}",
+"\xE1\xBE\x98" => "\x{1F90}",
+"\xE1\xBE\x99" => "\x{1F91}",
+"\xE1\xBE\x9A" => "\x{1F92}",
+"\xE1\xBE\x9B" => "\x{1F93}",
+"\xE1\xBE\x9C" => "\x{1F94}",
+"\xE1\xBE\x9D" => "\x{1F95}",
+"\xE1\xBE\x9E" => "\x{1F96}",
+"\xE1\xBE\x9F" => "\x{1F97}",
+"\xE1\xBE\xA8" => "\x{1FA0}",
+"\xE1\xBE\xA9" => "\x{1FA1}",
+"\xE1\xBE\xAA" => "\x{1FA2}",
+"\xE1\xBE\xAB" => "\x{1FA3}",
+"\xE1\xBE\xAC" => "\x{1FA4}",
+"\xE1\xBE\xAD" => "\x{1FA5}",
+"\xE1\xBE\xAE" => "\x{1FA6}",
+"\xE1\xBE\xAF" => "\x{1FA7}",
+"\xE1\xBE\xBC" => "\x{1FB3}",
+"\xE1\xBF\x8C" => "\x{1FC3}",
+"\xE1\xBF\xBC" => "\x{1FF3}",
+);
+
+return <<'END';
+0041 0061
+0042 0062
+0043 0063
+0044 0064
+0045 0065
+0046 0066
+0047 0067
+0048 0068
+0049 0069
+004A 006A
+004B 006B
+004C 006C
+004D 006D
+004E 006E
+004F 006F
+0050 0070
+0051 0071
+0052 0072
+0053 0073
+0054 0074
+0055 0075
+0056 0076
+0057 0077
+0058 0078
+0059 0079
+005A 007A
+00C0 00E0
+00C1 00E1
+00C2 00E2
+00C3 00E3
+00C4 00E4
+00C5 00E5
+00C6 00E6
+00C7 00E7
+00C8 00E8
+00C9 00E9
+00CA 00EA
+00CB 00EB
+00CC 00EC
+00CD 00ED
+00CE 00EE
+00CF 00EF
+00D0 00F0
+00D1 00F1
+00D2 00F2
+00D3 00F3
+00D4 00F4
+00D5 00F5
+00D6 00F6
+00D8 00F8
+00D9 00F9
+00DA 00FA
+00DB 00FB
+00DC 00FC
+00DD 00FD
+00DE 00FE
+0100 0101
+0102 0103
+0104 0105
+0106 0107
+0108 0109
+010A 010B
+010C 010D
+010E 010F
+0110 0111
+0112 0113
+0114 0115
+0116 0117
+0118 0119
+011A 011B
+011C 011D
+011E 011F
+0120 0121
+0122 0123
+0124 0125
+0126 0127
+0128 0129
+012A 012B
+012C 012D
+012E 012F
+0132 0133
+0134 0135
+0136 0137
+0139 013A
+013B 013C
+013D 013E
+013F 0140
+0141 0142
+0143 0144
+0145 0146
+0147 0148
+014A 014B
+014C 014D
+014E 014F
+0150 0151
+0152 0153
+0154 0155
+0156 0157
+0158 0159
+015A 015B
+015C 015D
+015E 015F
+0160 0161
+0162 0163
+0164 0165
+0166 0167
+0168 0169
+016A 016B
+016C 016D
+016E 016F
+0170 0171
+0172 0173
+0174 0175
+0176 0177
+0178 00FF
+0179 017A
+017B 017C
+017D 017E
+0181 0253
+0182 0183
+0184 0185
+0186 0254
+0187 0188
+0189 0256
+018A 0257
+018B 018C
+018E 01DD
+018F 0259
+0190 025B
+0191 0192
+0193 0260
+0194 0263
+0196 0269
+0197 0268
+0198 0199
+019C 026F
+019D 0272
+019F 0275
+01A0 01A1
+01A2 01A3
+01A4 01A5
+01A6 0280
+01A7 01A8
+01A9 0283
+01AC 01AD
+01AE 0288
+01AF 01B0
+01B1 028A
+01B2 028B
+01B3 01B4
+01B5 01B6
+01B7 0292
+01B8 01B9
+01BC 01BD
+01C4 01C6
+01C5 01C6
+01C7 01C9
+01C8 01C9
+01CA 01CC
+01CB 01CC
+01CD 01CE
+01CF 01D0
+01D1 01D2
+01D3 01D4
+01D5 01D6
+01D7 01D8
+01D9 01DA
+01DB 01DC
+01DE 01DF
+01E0 01E1
+01E2 01E3
+01E4 01E5
+01E6 01E7
+01E8 01E9
+01EA 01EB
+01EC 01ED
+01EE 01EF
+01F1 01F3
+01F2 01F3
+01F4 01F5
+01F6 0195
+01F7 01BF
+01F8 01F9
+01FA 01FB
+01FC 01FD
+01FE 01FF
+0200 0201
+0202 0203
+0204 0205
+0206 0207
+0208 0209
+020A 020B
+020C 020D
+020E 020F
+0210 0211
+0212 0213
+0214 0215
+0216 0217
+0218 0219
+021A 021B
+021C 021D
+021E 021F
+0220 019E
+0222 0223
+0224 0225
+0226 0227
+0228 0229
+022A 022B
+022C 022D
+022E 022F
+0230 0231
+0232 0233
+023B 023C
+023D 019A
+0241 0294
+0386 03AC
+0388 03AD
+0389 03AE
+038A 03AF
+038C 03CC
+038E 03CD
+038F 03CE
+0391 03B1
+0392 03B2
+0393 03B3
+0394 03B4
+0395 03B5
+0396 03B6
+0397 03B7
+0398 03B8
+0399 03B9
+039A 03BA
+039B 03BB
+039C 03BC
+039D 03BD
+039E 03BE
+039F 03BF
+03A0 03C0
+03A1 03C1
+03A3 03C3
+03A4 03C4
+03A5 03C5
+03A6 03C6
+03A7 03C7
+03A8 03C8
+03A9 03C9
+03AA 03CA
+03AB 03CB
+03D8 03D9
+03DA 03DB
+03DC 03DD
+03DE 03DF
+03E0 03E1
+03E2 03E3
+03E4 03E5
+03E6 03E7
+03E8 03E9
+03EA 03EB
+03EC 03ED
+03EE 03EF
+03F4 03B8
+03F7 03F8
+03F9 03F2
+03FA 03FB
+0400 0450
+0401 0451
+0402 0452
+0403 0453
+0404 0454
+0405 0455
+0406 0456
+0407 0457
+0408 0458
+0409 0459
+040A 045A
+040B 045B
+040C 045C
+040D 045D
+040E 045E
+040F 045F
+0410 0430
+0411 0431
+0412 0432
+0413 0433
+0414 0434
+0415 0435
+0416 0436
+0417 0437
+0418 0438
+0419 0439
+041A 043A
+041B 043B
+041C 043C
+041D 043D
+041E 043E
+041F 043F
+0420 0440
+0421 0441
+0422 0442
+0423 0443
+0424 0444
+0425 0445
+0426 0446
+0427 0447
+0428 0448
+0429 0449
+042A 044A
+042B 044B
+042C 044C
+042D 044D
+042E 044E
+042F 044F
+0460 0461
+0462 0463
+0464 0465
+0466 0467
+0468 0469
+046A 046B
+046C 046D
+046E 046F
+0470 0471
+0472 0473
+0474 0475
+0476 0477
+0478 0479
+047A 047B
+047C 047D
+047E 047F
+0480 0481
+048A 048B
+048C 048D
+048E 048F
+0490 0491
+0492 0493
+0494 0495
+0496 0497
+0498 0499
+049A 049B
+049C 049D
+049E 049F
+04A0 04A1
+04A2 04A3
+04A4 04A5
+04A6 04A7
+04A8 04A9
+04AA 04AB
+04AC 04AD
+04AE 04AF
+04B0 04B1
+04B2 04B3
+04B4 04B5
+04B6 04B7
+04B8 04B9
+04BA 04BB
+04BC 04BD
+04BE 04BF
+04C1 04C2
+04C3 04C4
+04C5 04C6
+04C7 04C8
+04C9 04CA
+04CB 04CC
+04CD 04CE
+04D0 04D1
+04D2 04D3
+04D4 04D5
+04D6 04D7
+04D8 04D9
+04DA 04DB
+04DC 04DD
+04DE 04DF
+04E0 04E1
+04E2 04E3
+04E4 04E5
+04E6 04E7
+04E8 04E9
+04EA 04EB
+04EC 04ED
+04EE 04EF
+04F0 04F1
+04F2 04F3
+04F4 04F5
+04F6 04F7
+04F8 04F9
+0500 0501
+0502 0503
+0504 0505
+0506 0507
+0508 0509
+050A 050B
+050C 050D
+050E 050F
+0531 0561
+0532 0562
+0533 0563
+0534 0564
+0535 0565
+0536 0566
+0537 0567
+0538 0568
+0539 0569
+053A 056A
+053B 056B
+053C 056C
+053D 056D
+053E 056E
+053F 056F
+0540 0570
+0541 0571
+0542 0572
+0543 0573
+0544 0574
+0545 0575
+0546 0576
+0547 0577
+0548 0578
+0549 0579
+054A 057A
+054B 057B
+054C 057C
+054D 057D
+054E 057E
+054F 057F
+0550 0580
+0551 0581
+0552 0582
+0553 0583
+0554 0584
+0555 0585
+0556 0586
+10A0 2D00
+10A1 2D01
+10A2 2D02
+10A3 2D03
+10A4 2D04
+10A5 2D05
+10A6 2D06
+10A7 2D07
+10A8 2D08
+10A9 2D09
+10AA 2D0A
+10AB 2D0B
+10AC 2D0C
+10AD 2D0D
+10AE 2D0E
+10AF 2D0F
+10B0 2D10
+10B1 2D11
+10B2 2D12
+10B3 2D13
+10B4 2D14
+10B5 2D15
+10B6 2D16
+10B7 2D17
+10B8 2D18
+10B9 2D19
+10BA 2D1A
+10BB 2D1B
+10BC 2D1C
+10BD 2D1D
+10BE 2D1E
+10BF 2D1F
+10C0 2D20
+10C1 2D21
+10C2 2D22
+10C3 2D23
+10C4 2D24
+10C5 2D25
+1E00 1E01
+1E02 1E03
+1E04 1E05
+1E06 1E07
+1E08 1E09
+1E0A 1E0B
+1E0C 1E0D
+1E0E 1E0F
+1E10 1E11
+1E12 1E13
+1E14 1E15
+1E16 1E17
+1E18 1E19
+1E1A 1E1B
+1E1C 1E1D
+1E1E 1E1F
+1E20 1E21
+1E22 1E23
+1E24 1E25
+1E26 1E27
+1E28 1E29
+1E2A 1E2B
+1E2C 1E2D
+1E2E 1E2F
+1E30 1E31
+1E32 1E33
+1E34 1E35
+1E36 1E37
+1E38 1E39
+1E3A 1E3B
+1E3C 1E3D
+1E3E 1E3F
+1E40 1E41
+1E42 1E43
+1E44 1E45
+1E46 1E47
+1E48 1E49
+1E4A 1E4B
+1E4C 1E4D
+1E4E 1E4F
+1E50 1E51
+1E52 1E53
+1E54 1E55
+1E56 1E57
+1E58 1E59
+1E5A 1E5B
+1E5C 1E5D
+1E5E 1E5F
+1E60 1E61
+1E62 1E63
+1E64 1E65
+1E66 1E67
+1E68 1E69
+1E6A 1E6B
+1E6C 1E6D
+1E6E 1E6F
+1E70 1E71
+1E72 1E73
+1E74 1E75
+1E76 1E77
+1E78 1E79
+1E7A 1E7B
+1E7C 1E7D
+1E7E 1E7F
+1E80 1E81
+1E82 1E83
+1E84 1E85
+1E86 1E87
+1E88 1E89
+1E8A 1E8B
+1E8C 1E8D
+1E8E 1E8F
+1E90 1E91
+1E92 1E93
+1E94 1E95
+1EA0 1EA1
+1EA2 1EA3
+1EA4 1EA5
+1EA6 1EA7
+1EA8 1EA9
+1EAA 1EAB
+1EAC 1EAD
+1EAE 1EAF
+1EB0 1EB1
+1EB2 1EB3
+1EB4 1EB5
+1EB6 1EB7
+1EB8 1EB9
+1EBA 1EBB
+1EBC 1EBD
+1EBE 1EBF
+1EC0 1EC1
+1EC2 1EC3
+1EC4 1EC5
+1EC6 1EC7
+1EC8 1EC9
+1ECA 1ECB
+1ECC 1ECD
+1ECE 1ECF
+1ED0 1ED1
+1ED2 1ED3
+1ED4 1ED5
+1ED6 1ED7
+1ED8 1ED9
+1EDA 1EDB
+1EDC 1EDD
+1EDE 1EDF
+1EE0 1EE1
+1EE2 1EE3
+1EE4 1EE5
+1EE6 1EE7
+1EE8 1EE9
+1EEA 1EEB
+1EEC 1EED
+1EEE 1EEF
+1EF0 1EF1
+1EF2 1EF3
+1EF4 1EF5
+1EF6 1EF7
+1EF8 1EF9
+1F08 1F00
+1F09 1F01
+1F0A 1F02
+1F0B 1F03
+1F0C 1F04
+1F0D 1F05
+1F0E 1F06
+1F0F 1F07
+1F18 1F10
+1F19 1F11
+1F1A 1F12
+1F1B 1F13
+1F1C 1F14
+1F1D 1F15
+1F28 1F20
+1F29 1F21
+1F2A 1F22
+1F2B 1F23
+1F2C 1F24
+1F2D 1F25
+1F2E 1F26
+1F2F 1F27
+1F38 1F30
+1F39 1F31
+1F3A 1F32
+1F3B 1F33
+1F3C 1F34
+1F3D 1F35
+1F3E 1F36
+1F3F 1F37
+1F48 1F40
+1F49 1F41
+1F4A 1F42
+1F4B 1F43
+1F4C 1F44
+1F4D 1F45
+1F59 1F51
+1F5B 1F53
+1F5D 1F55
+1F5F 1F57
+1F68 1F60
+1F69 1F61
+1F6A 1F62
+1F6B 1F63
+1F6C 1F64
+1F6D 1F65
+1F6E 1F66
+1F6F 1F67
+1FB8 1FB0
+1FB9 1FB1
+1FBA 1F70
+1FBB 1F71
+1FC8 1F72
+1FC9 1F73
+1FCA 1F74
+1FCB 1F75
+1FD8 1FD0
+1FD9 1FD1
+1FDA 1F76
+1FDB 1F77
+1FE8 1FE0
+1FE9 1FE1
+1FEA 1F7A
+1FEB 1F7B
+1FEC 1FE5
+1FF8 1F78
+1FF9 1F79
+1FFA 1F7C
+1FFB 1F7D
+2126 03C9
+212A 006B
+212B 00E5
+2160 2170
+2161 2171
+2162 2172
+2163 2173
+2164 2174
+2165 2175
+2166 2176
+2167 2177
+2168 2178
+2169 2179
+216A 217A
+216B 217B
+216C 217C
+216D 217D
+216E 217E
+216F 217F
+24B6 24D0
+24B7 24D1
+24B8 24D2
+24B9 24D3
+24BA 24D4
+24BB 24D5
+24BC 24D6
+24BD 24D7
+24BE 24D8
+24BF 24D9
+24C0 24DA
+24C1 24DB
+24C2 24DC
+24C3 24DD
+24C4 24DE
+24C5 24DF
+24C6 24E0
+24C7 24E1
+24C8 24E2
+24C9 24E3
+24CA 24E4
+24CB 24E5
+24CC 24E6
+24CD 24E7
+24CE 24E8
+24CF 24E9
+2C00 2C30
+2C01 2C31
+2C02 2C32
+2C03 2C33
+2C04 2C34
+2C05 2C35
+2C06 2C36
+2C07 2C37
+2C08 2C38
+2C09 2C39
+2C0A 2C3A
+2C0B 2C3B
+2C0C 2C3C
+2C0D 2C3D
+2C0E 2C3E
+2C0F 2C3F
+2C10 2C40
+2C11 2C41
+2C12 2C42
+2C13 2C43
+2C14 2C44
+2C15 2C45
+2C16 2C46
+2C17 2C47
+2C18 2C48
+2C19 2C49
+2C1A 2C4A
+2C1B 2C4B
+2C1C 2C4C
+2C1D 2C4D
+2C1E 2C4E
+2C1F 2C4F
+2C20 2C50
+2C21 2C51
+2C22 2C52
+2C23 2C53
+2C24 2C54
+2C25 2C55
+2C26 2C56
+2C27 2C57
+2C28 2C58
+2C29 2C59
+2C2A 2C5A
+2C2B 2C5B
+2C2C 2C5C
+2C2D 2C5D
+2C2E 2C5E
+2C80 2C81
+2C82 2C83
+2C84 2C85
+2C86 2C87
+2C88 2C89
+2C8A 2C8B
+2C8C 2C8D
+2C8E 2C8F
+2C90 2C91
+2C92 2C93
+2C94 2C95
+2C96 2C97
+2C98 2C99
+2C9A 2C9B
+2C9C 2C9D
+2C9E 2C9F
+2CA0 2CA1
+2CA2 2CA3
+2CA4 2CA5
+2CA6 2CA7
+2CA8 2CA9
+2CAA 2CAB
+2CAC 2CAD
+2CAE 2CAF
+2CB0 2CB1
+2CB2 2CB3
+2CB4 2CB5
+2CB6 2CB7
+2CB8 2CB9
+2CBA 2CBB
+2CBC 2CBD
+2CBE 2CBF
+2CC0 2CC1
+2CC2 2CC3
+2CC4 2CC5
+2CC6 2CC7
+2CC8 2CC9
+2CCA 2CCB
+2CCC 2CCD
+2CCE 2CCF
+2CD0 2CD1
+2CD2 2CD3
+2CD4 2CD5
+2CD6 2CD7
+2CD8 2CD9
+2CDA 2CDB
+2CDC 2CDD
+2CDE 2CDF
+2CE0 2CE1
+2CE2 2CE3
+FF21 FF41
+FF22 FF42
+FF23 FF43
+FF24 FF44
+FF25 FF45
+FF26 FF46
+FF27 FF47
+FF28 FF48
+FF29 FF49
+FF2A FF4A
+FF2B FF4B
+FF2C FF4C
+FF2D FF4D
+FF2E FF4E
+FF2F FF4F
+FF30 FF50
+FF31 FF51
+FF32 FF52
+FF33 FF53
+FF34 FF54
+FF35 FF55
+FF36 FF56
+FF37 FF57
+FF38 FF58
+FF39 FF59
+FF3A FF5A
+10400 10428
+10401 10429
+10402 1042A
+10403 1042B
+10404 1042C
+10405 1042D
+10406 1042E
+10407 1042F
+10408 10430
+10409 10431
+1040A 10432
+1040B 10433
+1040C 10434
+1040D 10435
+1040E 10436
+1040F 10437
+10410 10438
+10411 10439
+10412 1043A
+10413 1043B
+10414 1043C
+10415 1043D
+10416 1043E
+10417 1043F
+10418 10440
+10419 10441
+1041A 10442
+1041B 10443
+1041C 10444
+1041D 10445
+1041E 10446
+1041F 10447
+10420 10448
+10421 10449
+10422 1044A
+10423 1044B
+10424 1044C
+10425 1044D
+10426 1044E
+10427 1044F
+END
diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/utf8.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/utf8.pm
new file mode 100644
index 00000000000..56c991bef9a
--- /dev/null
+++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/utf8.pm
@@ -0,0 +1,214 @@
+package utf8;
+
+$utf8::hint_bits = 0x00800000;
+
+our $VERSION = '1.06';
+
+sub import {
+ $^H |= $utf8::hint_bits;
+ $enc{caller()} = $_[1] if $_[1];
+}
+
+sub unimport {
+ $^H &= ~$utf8::hint_bits;
+}
+
+sub AUTOLOAD {
+ require "utf8_heavy.pl";
+ goto &$AUTOLOAD if defined &$AUTOLOAD;
+ require Carp;
+ Carp::croak("Undefined subroutine $AUTOLOAD called");
+}
+
+1;
+__END__
+
+=head1 NAME
+
+utf8 - Perl pragma to enable/disable UTF-8 (or UTF-EBCDIC) in source code
+
+=head1 SYNOPSIS
+
+ use utf8;
+ no utf8;
+
+ # Convert a Perl scalar to/from UTF-8.
+ $num_octets = utf8::upgrade($string);
+ $success = utf8::downgrade($string[, FAIL_OK]);
+
+ # Change the native bytes of a Perl scalar to/from UTF-8 bytes.
+ utf8::encode($string);
+ utf8::decode($string);
+
+ $flag = utf8::is_utf8(STRING); # since Perl 5.8.1
+ $flag = utf8::valid(STRING);
+
+=head1 DESCRIPTION
+
+The C<use utf8> pragma tells the Perl parser to allow UTF-8 in the
+program text in the current lexical scope (allow UTF-EBCDIC on EBCDIC based
+platforms). The C<no utf8> pragma tells Perl to switch back to treating
+the source text as literal bytes in the current lexical scope.
+
+This pragma is primarily a compatibility device. Perl versions
+earlier than 5.6 allowed arbitrary bytes in source code, whereas
+in future we would like to standardize on the UTF-8 encoding for
+source text.
+
+B<Do not use this pragma for anything else than telling Perl that your
+script is written in UTF-8.> The utility functions described below are
+useful for their own purposes, but they are not really part of the
+"pragmatic" effect.
+
+Until UTF-8 becomes the default format for source text, either this
+pragma or the L<encoding> pragma should be used to recognize UTF-8
+in the source. When UTF-8 becomes the standard source format, this
+pragma will effectively become a no-op. For convenience in what
+follows the term I<UTF-X> is used to refer to UTF-8 on ASCII and ISO
+Latin based platforms and UTF-EBCDIC on EBCDIC based platforms.
+
+See also the effects of the C<-C> switch and its cousin, the
+C<$ENV{PERL_UNICODE}>, in L<perlrun>.
+
+Enabling the C<utf8> pragma has the following effect:
+
+=over 4
+
+=item *
+
+Bytes in the source text that have their high-bit set will be treated
+as being part of a literal UTF-8 character. This includes most
+literals such as identifier names, string constants, and constant
+regular expression patterns.
+
+On EBCDIC platforms characters in the Latin 1 character set are
+treated as being part of a literal UTF-EBCDIC character.
+
+=back
+
+Note that if you have bytes with the eighth bit on in your script
+(for example embedded Latin-1 in your string literals), C<use utf8>
+will be unhappy since the bytes are most probably not well-formed
+UTF-8. If you want to have such bytes and use utf8, you can disable
+utf8 until the end the block (or file, if at top level) by C<no utf8;>.
+
+If you want to automatically upgrade your 8-bit legacy bytes to UTF-8,
+use the L<encoding> pragma instead of this pragma. For example, if
+you want to implicitly upgrade your ISO 8859-1 (Latin-1) bytes to UTF-8
+as used in e.g. C<chr()> and C<\x{...}>, try this:
+
+ use encoding "latin-1";
+ my $c = chr(0xc4);
+ my $x = "\x{c5}";
+
+In case you are wondering: yes, C<use encoding 'utf8';> works much
+the same as C<use utf8;>.
+
+=head2 Utility functions
+
+The following functions are defined in the C<utf8::> package by the
+Perl core. You do not need to say C<use utf8> to use these and in fact
+you should not say that unless you really want to have UTF-8 source code.
+
+=over 4
+
+=item * $num_octets = utf8::upgrade($string)
+
+Converts in-place the octet sequence in the native encoding
+(Latin-1 or EBCDIC) to the equivalent character sequence in I<UTF-X>.
+I<$string> already encoded as characters does no harm.
+Returns the number of octets necessary to represent the string as I<UTF-X>.
+Can be used to make sure that the UTF-8 flag is on,
+so that C<\w> or C<lc()> work as Unicode on strings
+containing characters in the range 0x80-0xFF (on ASCII and
+derivatives).
+
+B<Note that this function does not handle arbitrary encodings.>
+Therefore I<Encode.pm> is recommended for the general purposes.
+
+Affected by the encoding pragma.
+
+=item * $success = utf8::downgrade($string[, FAIL_OK])
+
+Converts in-place the character sequence in I<UTF-X>
+to the equivalent octet sequence in the native encoding (Latin-1 or EBCDIC).
+I<$string> already encoded as octets does no harm.
+Returns true on success. On failure dies or, if the value of
+C<FAIL_OK> is true, returns false.
+Can be used to make sure that the UTF-8 flag is off,
+e.g. when you want to make sure that the substr() or length() function
+works with the usually faster byte algorithm.
+
+B<Note that this function does not handle arbitrary encodings.>
+Therefore I<Encode.pm> is recommended for the general purposes.
+
+B<Not> affected by the encoding pragma.
+
+B<NOTE:> this function is experimental and may change
+or be removed without notice.
+
+=item * utf8::encode($string)
+
+Converts in-place the character sequence to the corresponding octet sequence
+in I<UTF-X>. The UTF-8 flag is turned off. Returns nothing.
+
+B<Note that this function does not handle arbitrary encodings.>
+Therefore I<Encode.pm> is recommended for the general purposes.
+
+=item * utf8::decode($string)
+
+Attempts to convert in-place the octet sequence in I<UTF-X>
+to the corresponding character sequence. The UTF-8 flag is turned on
+only if the source string contains multiple-byte I<UTF-X> characters.
+If I<$string> is invalid as I<UTF-X>, returns false; otherwise returns true.
+
+B<Note that this function does not handle arbitrary encodings.>
+Therefore I<Encode.pm> is recommended for the general purposes.
+
+B<NOTE:> this function is experimental and may change
+or be removed without notice.
+
+=item * $flag = utf8::is_utf8(STRING)
+
+(Since Perl 5.8.1) Test whether STRING is in UTF-8. Functionally
+the same as Encode::is_utf8().
+
+=item * $flag = utf8::valid(STRING)
+
+[INTERNAL] Test whether STRING is in a consistent state regarding
+UTF-8. Will return true is well-formed UTF-8 and has the UTF-8 flag
+on B<or> if string is held as bytes (both these states are 'consistent').
+Main reason for this routine is to allow Perl's testsuite to check
+that operations have left strings in a consistent state. You most
+probably want to use utf8::is_utf8() instead.
+
+=back
+
+C<utf8::encode> is like C<utf8::upgrade>, but the UTF8 flag is
+cleared. See L<perlunicode> for more on the UTF8 flag and the C API
+functions C<sv_utf8_upgrade>, C<sv_utf8_downgrade>, C<sv_utf8_encode>,
+and C<sv_utf8_decode>, which are wrapped by the Perl functions
+C<utf8::upgrade>, C<utf8::downgrade>, C<utf8::encode> and
+C<utf8::decode>. Note that in the Perl 5.8.0 and 5.8.1 implementation
+the functions utf8::is_utf8, utf8::valid, utf8::encode, utf8::decode,
+utf8::upgrade, and utf8::downgrade are always available, without a
+C<require utf8> statement-- this may change in future releases.
+
+=head1 BUGS
+
+One can have Unicode in identifier names, but not in package/class or
+subroutine names. While some limited functionality towards this does
+exist as of Perl 5.8.0, that is more accidental than designed; use of
+Unicode for the said purposes is unsupported.
+
+One reason of this unfinishedness is its (currently) inherent
+unportability: since both package names and subroutine names may need
+to be mapped to file and directory names, the Unicode capability of
+the filesystem becomes important-- and there unfortunately aren't
+portable answers.
+
+=head1 SEE ALSO
+
+L<perluniintro>, L<encoding>, L<perlrun>, L<bytes>, L<perlunicode>
+
+=cut
diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/utf8_heavy.pl b/Master/tlpkg/lib/Perl5_lib-TL_inst/utf8_heavy.pl
new file mode 100644
index 00000000000..b6fdeb997b3
--- /dev/null
+++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/utf8_heavy.pl
@@ -0,0 +1,412 @@
+package utf8;
+use strict;
+use warnings;
+
+sub DEBUG () { 0 }
+
+sub DESTROY {}
+
+my %Cache;
+
+our (%PropertyAlias, %PA_reverse, %PropValueAlias, %PVA_reverse, %PVA_abbr_map);
+
+sub croak { require Carp; Carp::croak(@_) }
+
+##
+## "SWASH" == "SWATCH HASH". A "swatch" is a swatch of the Unicode landscape.
+## It's a data structure that encodes a set of Unicode characters.
+##
+
+sub SWASHNEW {
+ my ($class, $type, $list, $minbits, $none) = @_;
+ local $^D = 0 if $^D;
+
+ print STDERR "SWASHNEW @_\n" if DEBUG;
+
+ ##
+ ## Get the list of codepoints for the type.
+ ## Called from utf8.c
+ ##
+ ## Given a $type, our goal is to fill $list with the set of codepoint
+ ## ranges.
+ ##
+ ## To make the parsing of $type clear, this code takes the a rather
+ ## unorthodox approach of last'ing out of the block once we have the
+ ## info we need. Were this to be a subroutine, the 'last' would just
+ ## be a 'return'.
+ ##
+ my $file; ## file to load data from, and also part of the %Cache key.
+ my $ListSorted = 0;
+
+ if ($type)
+ {
+ $type =~ s/^\s+//;
+ $type =~ s/\s+$//;
+
+ print "type = $type\n" if DEBUG;
+
+ GETFILE:
+ {
+ ##
+ ## It could be a user-defined property.
+ ##
+
+ my $caller1 = $type =~ s/(.+)::// ? $1 : caller(1);
+
+ if (defined $caller1 && $type =~ /^(?:\w+)$/) {
+ my $prop = "${caller1}::$type";
+ if (exists &{$prop}) {
+ no strict 'refs';
+
+ $list = &{$prop};
+ last GETFILE;
+ }
+ }
+
+ my $wasIs;
+
+ ($wasIs = $type =~ s/^Is(?:\s+|[-_])?//i)
+ or
+ $type =~ s/^(?:(?:General(?:\s+|_)?)?Category|gc)\s*[:=]\s*//i
+ or
+ $type =~ s/^(?:Script|sc)\s*[:=]\s*//i
+ or
+ $type =~ s/^Block\s*[:=]\s*/In/i;
+
+
+ ##
+ ## See if it's in some enumeration.
+ ##
+ require "unicore/PVA.pl";
+ if ($type =~ /^([\w\s]+)[:=]\s*(.*)/) {
+ my ($enum, $val) = (lc $1, lc $2);
+ $enum =~ tr/ _-//d;
+ $val =~ tr/ _-//d;
+
+ my $pa = $PropertyAlias{$enum} ? $enum : $PA_reverse{$enum};
+ my $f = $PropValueAlias{$pa}{$val} ? $val : $PVA_reverse{$pa}{lc $val};
+
+ if ($pa and $f) {
+ $pa = "gc_sc" if $pa eq "gc" or $pa eq "sc";
+ $file = "unicore/lib/$pa/$PVA_abbr_map{$pa}{lc $f}.pl";
+ last GETFILE;
+ }
+ }
+ else {
+ my $t = lc $type;
+ $t =~ tr/ _-//d;
+
+ if ($PropValueAlias{gc}{$t} or $PropValueAlias{sc}{$t}) {
+ $file = "unicore/lib/gc_sc/$PVA_abbr_map{gc_sc}{$t}.pl";
+ last GETFILE;
+ }
+ }
+
+ ##
+ ## See if it's in the direct mapping table.
+ ##
+ require "unicore/Exact.pl";
+ if (my $base = $utf8::Exact{$type}) {
+ $file = "unicore/lib/gc_sc/$base.pl";
+ last GETFILE;
+ }
+
+ ##
+ ## If not there exactly, try the canonical form. The canonical
+ ## form is lowercased, with any separators (\s+|[-_]) removed.
+ ##
+ my $canonical = lc $type;
+ $canonical =~ s/(?<=[a-z\d])(?:\s+|[-_])(?=[a-z\d])//g;
+ print "canonical = $canonical\n" if DEBUG;
+
+ require "unicore/Canonical.pl";
+ if (my $base = ($utf8::Canonical{$canonical} || $utf8::Canonical{ lc $utf8::PropertyAlias{$canonical} })) {
+ $file = "unicore/lib/gc_sc/$base.pl";
+ last GETFILE;
+ }
+
+ ##
+ ## See if it's a user-level "To".
+ ##
+
+ my $caller0 = caller(0);
+
+ if (defined $caller0 && $type =~ /^To(?:\w+)$/) {
+ my $map = $caller0 . "::" . $type;
+
+ if (exists &{$map}) {
+ no strict 'refs';
+
+ $list = &{$map};
+ last GETFILE;
+ }
+ }
+
+ ##
+ ## Last attempt -- see if it's a standard "To" name
+ ## (e.g. "ToLower") ToTitle is used by ucfirst().
+ ## The user-level way to access ToDigit() and ToFold()
+ ## is to use Unicode::UCD.
+ ##
+ if ($type =~ /^To(Digit|Fold|Lower|Title|Upper)$/)
+ {
+ $file = "unicore/To/$1.pl";
+ ## would like to test to see if $file actually exists....
+ last GETFILE;
+ }
+
+ ##
+ ## If we reach this line, it's because we couldn't figure
+ ## out what to do with $type. Ouch.
+ ##
+
+ return $type;
+ }
+
+ if (defined $file) {
+ print "found it (file='$file')\n" if DEBUG;
+
+ ##
+ ## If we reach here, it was due to a 'last GETFILE' above
+ ## (exception: user-defined properties and mappings), so we
+ ## have a filename, so now we load it if we haven't already.
+ ## If we have, return the cached results. The cache key is the
+ ## file to load.
+ ##
+ if ($Cache{$file} and ref($Cache{$file}) eq $class)
+ {
+ print "Returning cached '$file' for \\p{$type}\n" if DEBUG;
+ return $Cache{$class, $file};
+ }
+
+ $list = do $file;
+ }
+
+ $ListSorted = 1; ## we know that these lists are sorted
+ }
+
+ my $extras;
+ my $bits = 0;
+
+ my $ORIG = $list;
+ if ($list) {
+ my @tmp = split(/^/m, $list);
+ my %seen;
+ no warnings;
+ $extras = join '', grep /^[^0-9a-fA-F]/, @tmp;
+ $list = join '',
+ map { $_->[1] }
+ sort { $a->[0] <=> $b->[0] }
+ map { /^([0-9a-fA-F]+)/; [ hex($1), $_ ] }
+ grep { /^([0-9a-fA-F]+)/ and not $seen{$1}++ } @tmp; # XXX doesn't do ranges right
+ }
+
+ if ($none) {
+ my $hextra = sprintf "%04x", $none + 1;
+ $list =~ s/\tXXXX$/\t$hextra/mg;
+ }
+
+ if ($minbits < 32) {
+ my $top = 0;
+ while ($list =~ /^([0-9a-fA-F]+)(?:[\t]([0-9a-fA-F]+)?)(?:[ \t]([0-9a-fA-F]+))?/mg) {
+ my $min = hex $1;
+ my $max = defined $2 ? hex $2 : $min;
+ my $val = defined $3 ? hex $3 : 0;
+ $val += $max - $min if defined $3;
+ $top = $val if $val > $top;
+ }
+ $bits =
+ $top > 0xffff ? 32 :
+ $top > 0xff ? 16 :
+ $top > 1 ? 8 : 1
+ }
+ $bits = $minbits if $bits < $minbits;
+
+ my @extras;
+ for my $x ($extras) {
+ pos $x = 0;
+ while ($x =~ /^([^0-9a-fA-F\n])(.*)/mg) {
+ my $char = $1;
+ my $name = $2;
+ print STDERR "$1 => $2\n" if DEBUG;
+ if ($char =~ /[-+!&]/) {
+ my ($c,$t) = split(/::/, $name, 2); # bogus use of ::, really
+ my $subobj;
+ if ($c eq 'utf8') {
+ $subobj = utf8->SWASHNEW($t, "", 0, 0, 0);
+ }
+ elsif (exists &$name) {
+ $subobj = utf8->SWASHNEW($name, "", 0, 0, 0);
+ }
+ elsif ($c =~ /^([0-9a-fA-F]+)/) {
+ $subobj = utf8->SWASHNEW("", $c, 0, 0, 0);
+ }
+ return $subobj unless ref $subobj;
+ push @extras, $name => $subobj;
+ $bits = $subobj->{BITS} if $bits < $subobj->{BITS};
+ }
+ }
+ }
+
+ print STDERR "CLASS = $class, TYPE => $type, BITS => $bits, NONE => $none\nEXTRAS =>\n$extras\nLIST =>\n$list\n" if DEBUG;
+
+ my $SWASH = bless {
+ TYPE => $type,
+ BITS => $bits,
+ EXTRAS => $extras,
+ LIST => $list,
+ NONE => $none,
+ @extras,
+ } => $class;
+
+ if ($file) {
+ $Cache{$class, $file} = $SWASH;
+ }
+
+ return $SWASH;
+}
+
+# NOTE: utf8.c:swash_init() assumes entries are never modified once generated.
+
+sub SWASHGET {
+ # See utf8.c:Perl_swash_fetch for problems with this interface.
+ my ($self, $start, $len) = @_;
+ local $^D = 0 if $^D;
+ my $type = $self->{TYPE};
+ my $bits = $self->{BITS};
+ my $none = $self->{NONE};
+ print STDERR "SWASHGET @_ [$type/$bits/$none]\n" if DEBUG;
+ my $end = $start + $len;
+ my $swatch = "";
+ my $key;
+ vec($swatch, $len - 1, $bits) = 0; # Extend to correct length.
+ if ($none) {
+ for $key (0 .. $len - 1) { vec($swatch, $key, $bits) = $none }
+ }
+
+ for ($self->{LIST}) {
+ pos $_ = 0;
+ if ($bits > 1) {
+ LINE:
+ while (/^([0-9a-fA-F]+)(?:[ \t]([0-9a-fA-F]+)?)?(?:[ \t]([0-9a-fA-F]+))?/mg) {
+ chomp;
+ my ($a, $b, $c) = ($1, $2, $3);
+ croak "$type: illegal mapping '$_'"
+ if $type =~ /^To/ &&
+ !(defined $a && defined $c);
+ my $min = hex $a;
+ my $max = defined $b ? hex $b : $min;
+ my $val = defined $c ? hex $c : 0;
+ next if $max < $start;
+ print "$min $max $val\n" if DEBUG;
+ if ($none) {
+ if ($min < $start) {
+ $val += $start - $min if $val < $none;
+ $min = $start;
+ }
+ for ($key = $min; $key <= $max; $key++) {
+ last LINE if $key >= $end;
+ print STDERR "$key => $val\n" if DEBUG;
+ vec($swatch, $key - $start, $bits) = $val;
+ ++$val if $val < $none;
+ }
+ }
+ else {
+ if ($min < $start) {
+ $val += $start - $min;
+ $min = $start;
+ }
+ for ($key = $min; $key <= $max; $key++, $val++) {
+ last LINE if $key >= $end;
+ print STDERR "$key => $val\n" if DEBUG;
+ vec($swatch, $key - $start, $bits) = $val;
+ }
+ }
+ }
+ }
+ else {
+ LINE:
+ while (/^([0-9a-fA-F]+)(?:[ \t]+([0-9a-fA-F]+))?/mg) {
+ chomp;
+ my $min = hex $1;
+ my $max = defined $2 ? hex $2 : $min;
+ next if $max < $start;
+ if ($min < $start) {
+ $min = $start;
+ }
+ for ($key = $min; $key <= $max; $key++) {
+ last LINE if $key >= $end;
+ print STDERR "$key => 1\n" if DEBUG;
+ vec($swatch, $key - $start, 1) = 1;
+ }
+ }
+ }
+ }
+ for my $x ($self->{EXTRAS}) {
+ pos $x = 0;
+ while ($x =~ /^([-+!&])(.*)/mg) {
+ my $char = $1;
+ my $name = $2;
+ print STDERR "INDIRECT $1 $2\n" if DEBUG;
+ my $otherbits = $self->{$name}->{BITS};
+ croak("SWASHGET size mismatch") if $bits < $otherbits;
+ my $other = $self->{$name}->SWASHGET($start, $len);
+ if ($char eq '+') {
+ if ($bits == 1 and $otherbits == 1) {
+ $swatch |= $other;
+ }
+ else {
+ for ($key = 0; $key < $len; $key++) {
+ vec($swatch, $key, $bits) = vec($other, $key, $otherbits);
+ }
+ }
+ }
+ elsif ($char eq '!') {
+ if ($bits == 1 and $otherbits == 1) {
+ $swatch |= ~$other;
+ }
+ else {
+ for ($key = 0; $key < $len; $key++) {
+ if (!vec($other, $key, $otherbits)) {
+ vec($swatch, $key, $bits) = 1;
+ }
+ }
+ }
+ }
+ elsif ($char eq '-') {
+ if ($bits == 1 and $otherbits == 1) {
+ $swatch &= ~$other;
+ }
+ else {
+ for ($key = 0; $key < $len; $key++) {
+ if (vec($other, $key, $otherbits)) {
+ vec($swatch, $key, $bits) = 0;
+ }
+ }
+ }
+ }
+ elsif ($char eq '&') {
+ if ($bits == 1 and $otherbits == 1) {
+ $swatch &= $other;
+ }
+ else {
+ for ($key = 0; $key < $len; $key++) {
+ if (!vec($other, $key, $otherbits)) {
+ vec($swatch, $key, $bits) = 0;
+ }
+ }
+ }
+ }
+ }
+ }
+ if (DEBUG) {
+ print STDERR "CELLS ";
+ for ($key = 0; $key < $len; $key++) {
+ print STDERR vec($swatch, $key, $bits), " ";
+ }
+ print STDERR "\n";
+ }
+ $swatch;
+}
+
+1;