diff options
author | Reinhard Kotucha <reinhard.kotucha@web.de> | 2008-01-13 07:32:42 +0000 |
---|---|---|
committer | Reinhard Kotucha <reinhard.kotucha@web.de> | 2008-01-13 07:32:42 +0000 |
commit | fd9ca8975520bac8e5cd6581ae75cd7d94233d7b (patch) | |
tree | 1d6a138de2b600d68fe583c71eded3ff5f819283 /Master/tlpkg/lib | |
parent | ef8b0a46e71789a03ca3e059dfc4441898978e63 (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')
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 Binary files differnew file mode 100755 index 00000000000..67f6d7baa57 --- /dev/null +++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Cwd/Cwd.dll 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 Binary files differnew file mode 100755 index 00000000000..88474ccb046 --- /dev/null +++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Encode/Byte/Byte.dll 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 Binary files differnew file mode 100755 index 00000000000..69c8ebf8acb --- /dev/null +++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Encode/Encode.dll 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 Binary files differnew file mode 100755 index 00000000000..71a757a6b64 --- /dev/null +++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Encode/Unicode/Unicode.dll 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 Binary files differnew file mode 100755 index 00000000000..5a9706cb92e --- /dev/null +++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Event/Event.dll 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 Binary files differnew file mode 100755 index 00000000000..8d80944808d --- /dev/null +++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Tk.dll 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; |