diff options
Diffstat (limited to 'Master/tlpkg/installer')
115 files changed, 33392 insertions, 0 deletions
diff --git a/Master/tlpkg/installer/perllib/AutoLoader.pm b/Master/tlpkg/installer/perllib/AutoLoader.pm new file mode 100644 index 00000000000..4352d8b1fbe --- /dev/null +++ b/Master/tlpkg/installer/perllib/AutoLoader.pm @@ -0,0 +1,343 @@ +package AutoLoader; + +use strict; +use 5.006_001; + +our($VERSION, $AUTOLOAD); + +my $is_dosish; +my $is_epoc; +my $is_vms; +my $is_macos; + +BEGIN { + $is_dosish = $^O eq 'dos' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'NetWare'; + $is_epoc = $^O eq 'epoc'; + $is_vms = $^O eq 'VMS'; + $is_macos = $^O eq 'MacOS'; + $VERSION = '5.60'; +} + +AUTOLOAD { + my $sub = $AUTOLOAD; + my $filename; + # Braces used to preserve $1 et al. + { + # Try to find the autoloaded file from the package-qualified + # name of the sub. e.g., if the sub needed is + # Getopt::Long::GetOptions(), then $INC{Getopt/Long.pm} is + # something like '/usr/lib/perl5/Getopt/Long.pm', and the + # autoload file is '/usr/lib/perl5/auto/Getopt/Long/GetOptions.al'. + # + # However, if @INC is a relative path, this might not work. If, + # for example, @INC = ('lib'), then $INC{Getopt/Long.pm} is + # 'lib/Getopt/Long.pm', and we want to require + # 'auto/Getopt/Long/GetOptions.al' (without the leading 'lib'). + # In this case, we simple prepend the 'auto/' and let the + # C<require> take care of the searching for us. + + my ($pkg,$func) = ($sub =~ /(.*)::([^:]+)$/); + $pkg =~ s#::#/#g; + if (defined($filename = $INC{"$pkg.pm"})) { + if ($is_macos) { + $pkg =~ tr#/#:#; + $filename =~ s#^(.*)$pkg\.pm\z#$1auto:$pkg:$func.al#s; + } else { + $filename =~ s#^(.*)$pkg\.pm\z#$1auto/$pkg/$func.al#s; + } + + # if the file exists, then make sure that it is a + # a fully anchored path (i.e either '/usr/lib/auto/foo/bar.al', + # or './lib/auto/foo/bar.al'. This avoids C<require> searching + # (and failing) to find the 'lib/auto/foo/bar.al' because it + # looked for 'lib/lib/auto/foo/bar.al', given @INC = ('lib'). + + if (-r $filename) { + unless ($filename =~ m|^/|s) { + if ($is_dosish) { + unless ($filename =~ m{^([a-z]:)?[\\/]}is) { + if ($^O ne 'NetWare') { + $filename = "./$filename"; + } else { + $filename = "$filename"; + } + } + } + elsif ($is_epoc) { + unless ($filename =~ m{^([a-z?]:)?[\\/]}is) { + $filename = "./$filename"; + } + } + elsif ($is_vms) { + # XXX todo by VMSmiths + $filename = "./$filename"; + } + elsif (!$is_macos) { + $filename = "./$filename"; + } + } + } + else { + $filename = undef; + } + } + unless (defined $filename) { + # let C<require> do the searching + $filename = "auto/$sub.al"; + $filename =~ s#::#/#g; + } + } + my $save = $@; + local $!; # Do not munge the value. + eval { local $SIG{__DIE__}; require $filename }; + if ($@) { + if (substr($sub,-9) eq '::DESTROY') { + no strict 'refs'; + *$sub = sub {}; + $@ = undef; + } elsif ($@ =~ /^Can't locate/) { + # The load might just have failed because the filename was too + # long for some old SVR3 systems which treat long names as errors. + # If we can successfully truncate a long name then it's worth a go. + # There is a slight risk that we could pick up the wrong file here + # but autosplit should have warned about that when splitting. + if ($filename =~ s/(\w{12,})\.al$/substr($1,0,11).".al"/e){ + eval { local $SIG{__DIE__}; require $filename }; + } + } + if ($@){ + $@ =~ s/ at .*\n//; + my $error = $@; + require Carp; + Carp::croak($error); + } + } + $@ = $save; + goto &$sub; +} + +sub import { + my $pkg = shift; + my $callpkg = caller; + + # + # Export symbols, but not by accident of inheritance. + # + + if ($pkg eq 'AutoLoader') { + no strict 'refs'; + *{ $callpkg . '::AUTOLOAD' } = \&AUTOLOAD + if @_ and $_[0] =~ /^&?AUTOLOAD$/; + } + + # + # Try to find the autosplit index file. Eg., if the call package + # is POSIX, then $INC{POSIX.pm} is something like + # '/usr/local/lib/perl5/POSIX.pm', and the autosplit index file is in + # '/usr/local/lib/perl5/auto/POSIX/autosplit.ix', so we require that. + # + # However, if @INC is a relative path, this might not work. If, + # for example, @INC = ('lib'), then + # $INC{POSIX.pm} is 'lib/POSIX.pm', and we want to require + # 'auto/POSIX/autosplit.ix' (without the leading 'lib'). + # + + (my $calldir = $callpkg) =~ s#::#/#g; + my $path = $INC{$calldir . '.pm'}; + if (defined($path)) { + # Try absolute path name. + if ($is_macos) { + (my $malldir = $calldir) =~ tr#/#:#; + $path =~ s#^(.*)$malldir\.pm\z#$1auto:$malldir:autosplit.ix#s; + } else { + $path =~ s#^(.*)$calldir\.pm\z#$1auto/$calldir/autosplit.ix#; + } + + eval { require $path; }; + # If that failed, try relative path with normal @INC searching. + if ($@) { + $path ="auto/$calldir/autosplit.ix"; + eval { require $path; }; + } + if ($@) { + my $error = $@; + require Carp; + Carp::carp($error); + } + } +} + +sub unimport { + my $callpkg = caller; + + no strict 'refs'; + my $symname = $callpkg . '::AUTOLOAD'; + undef *{ $symname } if \&{ $symname } == \&AUTOLOAD; + *{ $symname } = \&{ $symname }; +} + +1; + +__END__ + +=head1 NAME + +AutoLoader - load subroutines only on demand + +=head1 SYNOPSIS + + package Foo; + use AutoLoader 'AUTOLOAD'; # import the default AUTOLOAD subroutine + + package Bar; + use AutoLoader; # don't import AUTOLOAD, define our own + sub AUTOLOAD { + ... + $AutoLoader::AUTOLOAD = "..."; + goto &AutoLoader::AUTOLOAD; + } + +=head1 DESCRIPTION + +The B<AutoLoader> module works with the B<AutoSplit> module and the +C<__END__> token to defer the loading of some subroutines until they are +used rather than loading them all at once. + +To use B<AutoLoader>, the author of a module has to place the +definitions of subroutines to be autoloaded after an C<__END__> token. +(See L<perldata>.) The B<AutoSplit> module can then be run manually to +extract the definitions into individual files F<auto/funcname.al>. + +B<AutoLoader> implements an AUTOLOAD subroutine. When an undefined +subroutine in is called in a client module of B<AutoLoader>, +B<AutoLoader>'s AUTOLOAD subroutine attempts to locate the subroutine in a +file with a name related to the location of the file from which the +client module was read. As an example, if F<POSIX.pm> is located in +F</usr/local/lib/perl5/POSIX.pm>, B<AutoLoader> will look for perl +subroutines B<POSIX> in F</usr/local/lib/perl5/auto/POSIX/*.al>, where +the C<.al> file has the same name as the subroutine, sans package. If +such a file exists, AUTOLOAD will read and evaluate it, +thus (presumably) defining the needed subroutine. AUTOLOAD will then +C<goto> the newly defined subroutine. + +Once this process completes for a given function, it is defined, so +future calls to the subroutine will bypass the AUTOLOAD mechanism. + +=head2 Subroutine Stubs + +In order for object method lookup and/or prototype checking to operate +correctly even when methods have not yet been defined it is necessary to +"forward declare" each subroutine (as in C<sub NAME;>). See +L<perlsub/"SYNOPSIS">. Such forward declaration creates "subroutine +stubs", which are place holders with no code. + +The AutoSplit and B<AutoLoader> modules automate the creation of forward +declarations. The AutoSplit module creates an 'index' file containing +forward declarations of all the AutoSplit subroutines. When the +AutoLoader module is 'use'd it loads these declarations into its callers +package. + +Because of this mechanism it is important that B<AutoLoader> is always +C<use>d and not C<require>d. + +=head2 Using B<AutoLoader>'s AUTOLOAD Subroutine + +In order to use B<AutoLoader>'s AUTOLOAD subroutine you I<must> +explicitly import it: + + use AutoLoader 'AUTOLOAD'; + +=head2 Overriding B<AutoLoader>'s AUTOLOAD Subroutine + +Some modules, mainly extensions, provide their own AUTOLOAD subroutines. +They typically need to check for some special cases (such as constants) +and then fallback to B<AutoLoader>'s AUTOLOAD for the rest. + +Such modules should I<not> import B<AutoLoader>'s AUTOLOAD subroutine. +Instead, they should define their own AUTOLOAD subroutines along these +lines: + + use AutoLoader; + use Carp; + + sub AUTOLOAD { + my $sub = $AUTOLOAD; + (my $constname = $sub) =~ s/.*:://; + my $val = constant($constname, @_ ? $_[0] : 0); + if ($! != 0) { + if ($! =~ /Invalid/ || $!{EINVAL}) { + $AutoLoader::AUTOLOAD = $sub; + goto &AutoLoader::AUTOLOAD; + } + else { + croak "Your vendor has not defined constant $constname"; + } + } + *$sub = sub { $val }; # same as: eval "sub $sub { $val }"; + goto &$sub; + } + +If any module's own AUTOLOAD subroutine has no need to fallback to the +AutoLoader's AUTOLOAD subroutine (because it doesn't have any AutoSplit +subroutines), then that module should not use B<AutoLoader> at all. + +=head2 Package Lexicals + +Package lexicals declared with C<my> in the main block of a package +using B<AutoLoader> will not be visible to auto-loaded subroutines, due to +the fact that the given scope ends at the C<__END__> marker. A module +using such variables as package globals will not work properly under the +B<AutoLoader>. + +The C<vars> pragma (see L<perlmod/"vars">) may be used in such +situations as an alternative to explicitly qualifying all globals with +the package namespace. Variables pre-declared with this pragma will be +visible to any autoloaded routines (but will not be invisible outside +the package, unfortunately). + +=head2 Not Using AutoLoader + +You can stop using AutoLoader by simply + + no AutoLoader; + +=head2 B<AutoLoader> vs. B<SelfLoader> + +The B<AutoLoader> is similar in purpose to B<SelfLoader>: both delay the +loading of subroutines. + +B<SelfLoader> uses the C<__DATA__> marker rather than C<__END__>. +While this avoids the use of a hierarchy of disk files and the +associated open/close for each routine loaded, B<SelfLoader> suffers a +startup speed disadvantage in the one-time parsing of the lines after +C<__DATA__>, after which routines are cached. B<SelfLoader> can also +handle multiple packages in a file. + +B<AutoLoader> only reads code as it is requested, and in many cases +should be faster, but requires a mechanism like B<AutoSplit> be used to +create the individual files. L<ExtUtils::MakeMaker> will invoke +B<AutoSplit> automatically if B<AutoLoader> is used in a module source +file. + +=head1 CAVEATS + +AutoLoaders prior to Perl 5.002 had a slightly different interface. Any +old modules which use B<AutoLoader> should be changed to the new calling +style. Typically this just means changing a require to a use, adding +the explicit C<'AUTOLOAD'> import if needed, and removing B<AutoLoader> +from C<@ISA>. + +On systems with restrictions on file name length, the file corresponding +to a subroutine may have a shorter name that the routine itself. This +can lead to conflicting file names. The I<AutoSplit> package warns of +these potential conflicts when used to split a module. + +AutoLoader may fail to find the autosplit files (or even find the wrong +ones) in cases where C<@INC> contains relative paths, B<and> the program +does C<chdir>. + +=head1 SEE ALSO + +L<SelfLoader> - an autoloader that doesn't use external files. + +=cut diff --git a/Master/tlpkg/installer/perllib/Carp.pm b/Master/tlpkg/installer/perllib/Carp.pm new file mode 100644 index 00000000000..1a814ead34f --- /dev/null +++ b/Master/tlpkg/installer/perllib/Carp.pm @@ -0,0 +1,274 @@ +package Carp; + +our $VERSION = '1.04'; + +=head1 NAME + +carp - warn of errors (from perspective of caller) + +cluck - warn of errors with stack backtrace + (not exported by default) + +croak - die of errors (from perspective of caller) + +confess - die of errors with stack backtrace + +shortmess - return the message that carp and croak produce + +longmess - return the message that cluck and confess produce + +=head1 SYNOPSIS + + use Carp; + croak "We're outta here!"; + + use Carp qw(cluck); + cluck "This is how we got here!"; + + print FH Carp::shortmess("This will have caller's details added"); + print FH Carp::longmess("This will have stack backtrace added"); + +=head1 DESCRIPTION + +The Carp routines are useful in your own modules because +they act like die() or warn(), but with a message which is more +likely to be useful to a user of your module. In the case of +cluck, confess, and longmess that context is a summary of every +call in the call-stack. For a shorter message you can use carp, +croak or shortmess which report the error as being from where +your module was called. There is no guarantee that that is where +the error was, but it is a good educated guess. + +You can also alter the way the output and logic of C<Carp> works, by +changing some global variables in the C<Carp> namespace. See the +section on C<GLOBAL VARIABLES> below. + +Here is a more complete description of how shortmess works. What +it does is search the call-stack for a function call stack where +it hasn't been told that there shouldn't be an error. If every +call is marked safe, it then gives up and gives a full stack +backtrace instead. In other words it presumes that the first likely +looking potential suspect is guilty. Its rules for telling whether +a call shouldn't generate errors work as follows: + +=over 4 + +=item 1. + +Any call from a package to itself is safe. + +=item 2. + +Packages claim that there won't be errors on calls to or from +packages explicitly marked as safe by inclusion in @CARP_NOT, or +(if that array is empty) @ISA. The ability to override what +@ISA says is new in 5.8. + +=item 3. + +The trust in item 2 is transitive. If A trusts B, and B +trusts C, then A trusts C. So if you do not override @ISA +with @CARP_NOT, then this trust relationship is identical to, +"inherits from". + +=item 4. + +Any call from an internal Perl module is safe. (Nothing keeps +user modules from marking themselves as internal to Perl, but +this practice is discouraged.) + +=item 5. + +Any call to Carp is safe. (This rule is what keeps it from +reporting the error where you call carp/croak/shortmess.) + +=back + +=head2 Forcing a Stack Trace + +As a debugging aid, you can force Carp to treat a croak as a confess +and a carp as a cluck across I<all> modules. In other words, force a +detailed stack trace to be given. This can be very helpful when trying +to understand why, or from where, a warning or error is being generated. + +This feature is enabled by 'importing' the non-existent symbol +'verbose'. You would typically enable it by saying + + perl -MCarp=verbose script.pl + +or by including the string C<MCarp=verbose> in the PERL5OPT +environment variable. + +Alternately, you can set the global variable C<$Carp::Verbose> to true. +See the C<GLOBAL VARIABLES> section below. + +=cut + +# This package is heavily used. Be small. Be fast. Be good. + +# Comments added by Andy Wardley <abw@kfs.org> 09-Apr-98, based on an +# _almost_ complete understanding of the package. Corrections and +# comments are welcome. + +# The members of %Internal are packages that are internal to perl. +# Carp will not report errors from within these packages if it +# can. The members of %CarpInternal are internal to Perl's warning +# system. Carp will not report errors from within these packages +# either, and will not report calls *to* these packages for carp and +# croak. They replace $CarpLevel, which is deprecated. The +# $Max(EvalLen|(Arg(Len|Nums)) variables are used to specify how the eval +# text and function arguments should be formatted when printed. + +# Comments added by Jos I. Boumans <kane@dwim.org> 11-Aug-2004 +# I can not get %CarpInternal or %Internal to work as advertised, +# therefor leaving it out of the below documentation. +# $CarpLevel may be decprecated according to the last comment, but +# after 6 years, it's still around and in heavy use ;) + +=pod + +=head1 GLOBAL VARIABLES + +=head2 $Carp::CarpLevel + +This variable determines how many call frames are to be skipped when +reporting where an error occurred on a call to one of C<Carp>'s +functions. For example: + + $Carp::CarpLevel = 1; + sub bar { .... or _error('Wrong input') } + sub _error { Carp::carp(@_) } + +This would make Carp report the error as coming from C<bar>'s caller, +rather than from C<_error>'s caller, as it normally would. + +Defaults to C<0>. + +=head2 $Carp::MaxEvalLen + +This variable determines how many characters of a string-eval are to +be shown in the output. Use a value of C<0> to show all text. + +Defaults to C<0>. + +=head2 $Carp::MaxArgLen + +This variable determines how many characters of each argument to a +function to print. Use a value of C<0> to show the full length of the +argument. + +Defaults to C<64>. + +=head2 $Carp::MaxArgNums + +This variable determines how many arguments to each function to show. +Use a value of C<0> to show all arguments to a function call. + +Defaults to C<8>. + +=head2 $Carp::Verbose + +This variable makes C<Carp> use the C<longmess> function at all times. +This effectively means that all calls to C<carp> become C<cluck> and +all calls to C<croak> become C<confess>. + +Note, this is analogous to using C<use Carp 'verbose'>. + +Defaults to C<0>. + +=cut + + +$CarpInternal{Carp}++; +$CarpInternal{warnings}++; +$CarpLevel = 0; # How many extra package levels to skip on carp. + # How many calls to skip on confess. + # Reconciling these notions is hard, use + # %Internal and %CarpInternal instead. +$MaxEvalLen = 0; # How much eval '...text...' to show. 0 = all. +$MaxArgLen = 64; # How much of each argument to print. 0 = all. +$MaxArgNums = 8; # How many arguments to print. 0 = all. +$Verbose = 0; # If true then make shortmess call longmess instead + +require Exporter; +@ISA = ('Exporter'); +@EXPORT = qw(confess croak carp); +@EXPORT_OK = qw(cluck verbose longmess shortmess); +@EXPORT_FAIL = qw(verbose); # hook to enable verbose mode + +=head1 BUGS + +The Carp routines don't handle exception objects currently. +If called with a first argument that is a reference, they simply +call die() or warn(), as appropriate. + +=cut + +# if the caller specifies verbose usage ("perl -MCarp=verbose script.pl") +# then the following method will be called by the Exporter which knows +# to do this thanks to @EXPORT_FAIL, above. $_[1] will contain the word +# 'verbose'. + +sub export_fail { + shift; + $Verbose = shift if $_[0] eq 'verbose'; + return @_; +} + + +# longmess() crawls all the way up the stack reporting on all the function +# calls made. The error string, $error, is originally constructed from the +# arguments passed into longmess() via confess(), cluck() or shortmess(). +# This gets appended with the stack trace messages which are generated for +# each function call on the stack. + +sub longmess { + { + local($@, $!); + # XXX fix require to not clear $@ or $!? + # don't use require unless we need to (for Safe compartments) + require Carp::Heavy unless $INC{"Carp/Heavy.pm"}; + } + # Icky backwards compatibility wrapper. :-( + my $call_pack = caller(); + if ($Internal{$call_pack} or $CarpInternal{$call_pack}) { + return longmess_heavy(@_); + } + else { + local $CarpLevel = $CarpLevel + 1; + return longmess_heavy(@_); + } +} + + +# shortmess() is called by carp() and croak() to skip all the way up to +# the top-level caller's package and report the error from there. confess() +# and cluck() generate a full stack trace so they call longmess() to +# generate that. In verbose mode shortmess() calls longmess() so +# you always get a stack trace + +sub shortmess { # Short-circuit &longmess if called via multiple packages + { + local($@, $!); + # XXX fix require to not clear $@ or $!? + # don't use require unless we need to (for Safe compartments) + require Carp::Heavy unless $INC{"Carp/Heavy.pm"}; + } + # Icky backwards compatibility wrapper. :-( + my $call_pack = caller(); + local @CARP_NOT = caller(); + shortmess_heavy(@_); +} + + +# the following four functions call longmess() or shortmess() depending on +# whether they should generate a full stack trace (confess() and cluck()) +# or simply report the caller's package (croak() and carp()), respectively. +# confess() and croak() die, carp() and cluck() warn. + +sub croak { die shortmess @_ } +sub confess { die longmess @_ } +sub carp { warn shortmess @_ } +sub cluck { warn longmess @_ } + +1; diff --git a/Master/tlpkg/installer/perllib/Carp/Heavy.pm b/Master/tlpkg/installer/perllib/Carp/Heavy.pm new file mode 100644 index 00000000000..55bca2b421a --- /dev/null +++ b/Master/tlpkg/installer/perllib/Carp/Heavy.pm @@ -0,0 +1,241 @@ +# Carp::Heavy uses some variables in common with Carp. +package Carp; + +=head1 NAME + +Carp::Heavy - heavy machinery, no user serviceable parts inside + +=cut + +# use strict; # not yet + +# On one line so MakeMaker will see it. +use Carp; our $VERSION = $Carp::VERSION; + +our ($CarpLevel, $MaxArgNums, $MaxEvalLen, $MaxArgLen, $Verbose); + +sub caller_info { + my $i = shift(@_) + 1; + package DB; + my %call_info; + @call_info{ + qw(pack file line sub has_args wantarray evaltext is_require) + } = caller($i); + + unless (defined $call_info{pack}) { + return (); + } + + my $sub_name = Carp::get_subname(\%call_info); + if ($call_info{has_args}) { + my @args = map {Carp::format_arg($_)} @DB::args; + if ($MaxArgNums and @args > $MaxArgNums) { # More than we want to show? + $#args = $MaxArgNums; + push @args, '...'; + } + # Push the args onto the subroutine + $sub_name .= '(' . join (', ', @args) . ')'; + } + $call_info{sub_name} = $sub_name; + return wantarray() ? %call_info : \%call_info; +} + +# Transform an argument to a function into a string. +sub format_arg { + my $arg = shift; + if (ref($arg)) { + $arg = defined($overload::VERSION) ? overload::StrVal($arg) : "$arg"; + }elsif (not defined($arg)) { + $arg = 'undef'; + } + $arg =~ s/'/\\'/g; + $arg = str_len_trim($arg, $MaxArgLen); + + # Quote it? + $arg = "'$arg'" unless $arg =~ /^-?[\d.]+\z/; + + # The following handling of "control chars" is direct from + # the original code - it is broken on Unicode though. + # Suggestions? + utf8::is_utf8($arg) + or $arg =~ s/([[:cntrl:]]|[[:^ascii:]])/sprintf("\\x{%x}",ord($1))/eg; + return $arg; +} + +# Takes an inheritance cache and a package and returns +# an anon hash of known inheritances and anon array of +# inheritances which consequences have not been figured +# for. +sub get_status { + my $cache = shift; + my $pkg = shift; + $cache->{$pkg} ||= [{$pkg => $pkg}, [trusts_directly($pkg)]]; + return @{$cache->{$pkg}}; +} + +# Takes the info from caller() and figures out the name of +# the sub/require/eval +sub get_subname { + my $info = shift; + if (defined($info->{evaltext})) { + my $eval = $info->{evaltext}; + if ($info->{is_require}) { + return "require $eval"; + } + else { + $eval =~ s/([\\\'])/\\$1/g; + return "eval '" . str_len_trim($eval, $MaxEvalLen) . "'"; + } + } + + return ($info->{sub} eq '(eval)') ? 'eval {...}' : $info->{sub}; +} + +# Figures out what call (from the point of view of the caller) +# the long error backtrace should start at. +sub long_error_loc { + my $i; + my $lvl = $CarpLevel; + { + my $pkg = caller(++$i); + unless(defined($pkg)) { + # This *shouldn't* happen. + if (%Internal) { + local %Internal; + $i = long_error_loc(); + last; + } + else { + # OK, now I am irritated. + return 2; + } + } + redo if $CarpInternal{$pkg}; + redo unless 0 > --$lvl; + redo if $Internal{$pkg}; + } + return $i - 1; +} + + +sub longmess_heavy { + return @_ if ref($_[0]); # don't break references as exceptions + my $i = long_error_loc(); + return ret_backtrace($i, @_); +} + +# Returns a full stack backtrace starting from where it is +# told. +sub ret_backtrace { + my ($i, @error) = @_; + my $mess; + my $err = join '', @error; + $i++; + + my $tid_msg = ''; + if (defined &Thread::tid) { + my $tid = Thread->self->tid; + $tid_msg = " thread $tid" if $tid; + } + + my %i = caller_info($i); + $mess = "$err at $i{file} line $i{line}$tid_msg\n"; + + while (my %i = caller_info(++$i)) { + $mess .= "\t$i{sub_name} called at $i{file} line $i{line}$tid_msg\n"; + } + + return $mess; +} + +sub ret_summary { + my ($i, @error) = @_; + my $err = join '', @error; + $i++; + + my $tid_msg = ''; + if (defined &Thread::tid) { + my $tid = Thread->self->tid; + $tid_msg = " thread $tid" if $tid; + } + + my %i = caller_info($i); + return "$err at $i{file} line $i{line}$tid_msg\n"; +} + + +sub short_error_loc { + my $cache; + my $i = 1; + my $lvl = $CarpLevel; + { + my $called = caller($i++); + my $caller = caller($i); + return 0 unless defined($caller); # What happened? + redo if $Internal{$caller}; + redo if $CarpInternal{$called}; + redo if trusts($called, $caller, $cache); + redo if trusts($caller, $called, $cache); + redo unless 0 > --$lvl; + } + return $i - 1; +} + +sub shortmess_heavy { + return longmess_heavy(@_) if $Verbose; + return @_ if ref($_[0]); # don't break references as exceptions + my $i = short_error_loc(); + if ($i) { + ret_summary($i, @_); + } + else { + longmess_heavy(@_); + } +} + +# If a string is too long, trims it with ... +sub str_len_trim { + my $str = shift; + my $max = shift || 0; + if (2 < $max and $max < length($str)) { + substr($str, $max - 3) = '...'; + } + return $str; +} + +# Takes two packages and an optional cache. Says whether the +# first inherits from the second. +# +# Recursive versions of this have to work to avoid certain +# possible endless loops, and when following long chains of +# inheritance are less efficient. +sub trusts { + my $child = shift; + my $parent = shift; + my $cache = shift || {}; + my ($known, $partial) = get_status($cache, $child); + # Figure out consequences until we have an answer + while (@$partial and not exists $known->{$parent}) { + my $anc = shift @$partial; + next if exists $known->{$anc}; + $known->{$anc}++; + my ($anc_knows, $anc_partial) = get_status($cache, $anc); + my @found = keys %$anc_knows; + @$known{@found} = (); + push @$partial, @$anc_partial; + } + return exists $known->{$parent}; +} + +# Takes a package and gives a list of those trusted directly +sub trusts_directly { + my $class = shift; + no strict 'refs'; + no warnings 'once'; + return @{"$class\::CARP_NOT"} + ? @{"$class\::CARP_NOT"} + : @{"$class\::ISA"}; +} + +1; + diff --git a/Master/tlpkg/installer/perllib/Config.pm b/Master/tlpkg/installer/perllib/Config.pm new file mode 100644 index 00000000000..7e5ad77b30a --- /dev/null +++ b/Master/tlpkg/installer/perllib/Config.pm @@ -0,0 +1,95 @@ +# This file was created by configpm when Perl was built. Any changes +# made to this file will be lost the next time perl is built. + +package Config; +use strict; +# use warnings; Pulls in Carp +# use vars pulls in Carp +@Config::EXPORT = qw(%Config); +@Config::EXPORT_OK = qw(myconfig config_sh config_vars config_re); + +# Need to stub all the functions to make code such as print Config::config_sh +# keep working + +sub myconfig; +sub config_sh; +sub config_vars; +sub config_re; + +my %Export_Cache = map {($_ => 1)} (@Config::EXPORT, @Config::EXPORT_OK); + +our %Config; + +# Define our own import method to avoid pulling in the full Exporter: +sub import { + my $pkg = shift; + @_ = @Config::EXPORT unless @_; + + my @funcs = grep $_ ne '%Config', @_; + my $export_Config = @funcs < @_ ? 1 : 0; + + no strict 'refs'; + my $callpkg = caller(0); + foreach my $func (@funcs) { + die sprintf qq{"%s" is not exported by the %s module\n}, + $func, __PACKAGE__ unless $Export_Cache{$func}; + *{$callpkg.'::'.$func} = \&{$func}; + } + + *{"$callpkg\::Config"} = \%Config if $export_Config; + return; +} + +die "Perl lib version (v5.8.8) doesn't match executable version ($])" + unless $^V; + +$^V eq v5.8.8 + or die "Perl lib version (v5.8.8) doesn't match executable version (" . + sprintf("v%vd",$^V) . ")"; + + +sub FETCH { + my($self, $key) = @_; + + # check for cached value (which may be undef so we use exists not defined) + return $self->{$key} if exists $self->{$key}; + + return $self->fetch_string($key); +} +sub TIEHASH { + bless $_[1], $_[0]; +} + +sub DESTROY { } + +sub AUTOLOAD { + require 'Config_heavy.pl'; + goto \&launcher unless $Config::AUTOLOAD =~ /launcher$/; + die "&Config::AUTOLOAD failed on $Config::AUTOLOAD"; +} + +# tie returns the object, so the value returned to require will be true. +tie %Config, 'Config', { + archlibexp => 'x:\\perl\\lib', + archname => 'MSWin32-x86-multi-thread', + cc => 'gcc', + d_readlink => undef, + d_symlink => undef, + dlsrc => 'dl_win32.xs', + dont_use_nlink => undef, + exe_ext => '.exe', + inc_version_list => '', + intsize => '4', + ldlibpthname => '', + libpth => 'x:\\msys\\mingw\\lib', + osname => 'MSWin32', + osvers => '5.1', + path_sep => ';', + privlibexp => 'x:\\perl\\lib', + scriptdir => 'x:\\perl\\bin', + sitearchexp => 'x:\\perl\\site\\lib', + sitelibexp => 'x:\\perl\\site\\lib', + useithreads => 'define', + usevendorprefix => undef, + version => '5.8.8', +}; diff --git a/Master/tlpkg/installer/perllib/Cwd.pm b/Master/tlpkg/installer/perllib/Cwd.pm new file mode 100644 index 00000000000..8d25af9f7cd --- /dev/null +++ b/Master/tlpkg/installer/perllib/Cwd.pm @@ -0,0 +1,710 @@ +package Cwd; + +=head1 NAME + +Cwd - get pathname of current working directory + +=head1 SYNOPSIS + + use Cwd; + my $dir = getcwd; + + use Cwd 'abs_path'; + my $abs_path = abs_path($file); + +=head1 DESCRIPTION + +This module provides functions for determining the pathname of the +current working directory. It is recommended that getcwd (or another +*cwd() function) be used in I<all> code to ensure portability. + +By default, it exports the functions cwd(), getcwd(), fastcwd(), and +fastgetcwd() (and, on Win32, getdcwd()) into the caller's namespace. + + +=head2 getcwd and friends + +Each of these functions are called without arguments and return the +absolute path of the current working directory. + +=over 4 + +=item getcwd + + my $cwd = getcwd(); + +Returns the current working directory. + +Re-implements the getcwd(3) (or getwd(3)) functions in Perl. + +=item cwd + + my $cwd = cwd(); + +The cwd() is the most natural form for the current architecture. For +most systems it is identical to `pwd` (but without the trailing line +terminator). + +=item fastcwd + + my $cwd = fastcwd(); + +A more dangerous version of getcwd(), but potentially faster. + +It might conceivably chdir() you out of a directory that it can't +chdir() you back into. If fastcwd encounters a problem it will return +undef but will probably leave you in a different directory. For a +measure of extra security, if everything appears to have worked, the +fastcwd() function will check that it leaves you in the same directory +that it started in. If it has changed it will C<die> with the message +"Unstable directory path, current directory changed +unexpectedly". That should never happen. + +=item fastgetcwd + + my $cwd = fastgetcwd(); + +The fastgetcwd() function is provided as a synonym for cwd(). + +=item getdcwd + + my $cwd = getdcwd(); + my $cwd = getdcwd('C:'); + +The getdcwd() function is also provided on Win32 to get the current working +directory on the specified drive, since Windows maintains a separate current +working directory for each drive. If no drive is specified then the current +drive is assumed. + +This function simply calls the Microsoft C library _getdcwd() function. + +=back + + +=head2 abs_path and friends + +These functions are exported only on request. They each take a single +argument and return the absolute pathname for it. If no argument is +given they'll use the current working directory. + +=over 4 + +=item abs_path + + my $abs_path = abs_path($file); + +Uses the same algorithm as getcwd(). Symbolic links and relative-path +components ("." and "..") are resolved to return the canonical +pathname, just like realpath(3). + +=item realpath + + my $abs_path = realpath($file); + +A synonym for abs_path(). + +=item fast_abs_path + + my $abs_path = fast_abs_path($file); + +A more dangerous, but potentially faster version of abs_path. + +=back + +=head2 $ENV{PWD} + +If you ask to override your chdir() built-in function, + + use Cwd qw(chdir); + +then your PWD environment variable will be kept up to date. Note that +it will only be kept up to date if all packages which use chdir import +it from Cwd. + + +=head1 NOTES + +=over 4 + +=item * + +Since the path seperators are different on some operating systems ('/' +on Unix, ':' on MacPerl, etc...) we recommend you use the File::Spec +modules wherever portability is a concern. + +=item * + +Actually, on Mac OS, the C<getcwd()>, C<fastgetcwd()> and C<fastcwd()> +functions are all aliases for the C<cwd()> function, which, on Mac OS, +calls `pwd`. Likewise, the C<abs_path()> function is an alias for +C<fast_abs_path()>. + +=back + +=head1 AUTHOR + +Originally by the perl5-porters. + +Maintained by Ken Williams <KWILLIAMS@cpan.org> + +=head1 COPYRIGHT + +Copyright (c) 2004 by the Perl 5 Porters. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +Portions of the C code in this library are copyright (c) 1994 by the +Regents of the University of California. All rights reserved. The +license on this code is compatible with the licensing of the rest of +the distribution - please see the source code in F<Cwd.xs> for the +details. + +=head1 SEE ALSO + +L<File::chdir> + +=cut + +use strict; +use Exporter; +use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION); + +$VERSION = '3.12'; + +@ISA = qw/ Exporter /; +@EXPORT = qw(cwd getcwd fastcwd fastgetcwd); +push @EXPORT, qw(getdcwd) if $^O eq 'MSWin32'; +@EXPORT_OK = qw(chdir abs_path fast_abs_path realpath fast_realpath); + +# sys_cwd may keep the builtin command + +# All the functionality of this module may provided by builtins, +# there is no sense to process the rest of the file. +# The best choice may be to have this in BEGIN, but how to return from BEGIN? + +if ($^O eq 'os2') { + local $^W = 0; + + *cwd = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd; + *getcwd = \&cwd; + *fastgetcwd = \&cwd; + *fastcwd = \&cwd; + + *fast_abs_path = \&sys_abspath if defined &sys_abspath; + *abs_path = \&fast_abs_path; + *realpath = \&fast_abs_path; + *fast_realpath = \&fast_abs_path; + + return 1; +} + +# If loading the XS stuff doesn't work, we can fall back to pure perl +eval { + if ( $] >= 5.006 ) { + require XSLoader; + XSLoader::load( __PACKAGE__, $VERSION ); + } else { + require DynaLoader; + push @ISA, 'DynaLoader'; + __PACKAGE__->bootstrap( $VERSION ); + } +}; + +# Must be after the DynaLoader stuff: +$VERSION = eval $VERSION; + +# Big nasty table of function aliases +my %METHOD_MAP = + ( + VMS => + { + cwd => '_vms_cwd', + getcwd => '_vms_cwd', + fastcwd => '_vms_cwd', + fastgetcwd => '_vms_cwd', + abs_path => '_vms_abs_path', + fast_abs_path => '_vms_abs_path', + }, + + MSWin32 => + { + # We assume that &_NT_cwd is defined as an XSUB or in the core. + cwd => '_NT_cwd', + getcwd => '_NT_cwd', + fastcwd => '_NT_cwd', + fastgetcwd => '_NT_cwd', + abs_path => 'fast_abs_path', + realpath => 'fast_abs_path', + }, + + dos => + { + cwd => '_dos_cwd', + getcwd => '_dos_cwd', + fastgetcwd => '_dos_cwd', + fastcwd => '_dos_cwd', + abs_path => 'fast_abs_path', + }, + + qnx => + { + cwd => '_qnx_cwd', + getcwd => '_qnx_cwd', + fastgetcwd => '_qnx_cwd', + fastcwd => '_qnx_cwd', + abs_path => '_qnx_abs_path', + fast_abs_path => '_qnx_abs_path', + }, + + cygwin => + { + getcwd => 'cwd', + fastgetcwd => 'cwd', + fastcwd => 'cwd', + abs_path => 'fast_abs_path', + realpath => 'fast_abs_path', + }, + + epoc => + { + cwd => '_epoc_cwd', + getcwd => '_epoc_cwd', + fastgetcwd => '_epoc_cwd', + fastcwd => '_epoc_cwd', + abs_path => 'fast_abs_path', + }, + + MacOS => + { + getcwd => 'cwd', + fastgetcwd => 'cwd', + fastcwd => 'cwd', + abs_path => 'fast_abs_path', + }, + ); + +$METHOD_MAP{NT} = $METHOD_MAP{MSWin32}; +$METHOD_MAP{nto} = $METHOD_MAP{qnx}; + + +# Find the pwd command in the expected locations. We assume these +# are safe. This prevents _backtick_pwd() consulting $ENV{PATH} +# so everything works under taint mode. +my $pwd_cmd; +foreach my $try ('/bin/pwd', + '/usr/bin/pwd', + '/QOpenSys/bin/pwd', # OS/400 PASE. + ) { + + if( -x $try ) { + $pwd_cmd = $try; + last; + } +} +unless ($pwd_cmd) { + # Isn't this wrong? _backtick_pwd() will fail if somenone has + # pwd in their path but it is not /bin/pwd or /usr/bin/pwd? + # See [perl #16774]. --jhi + $pwd_cmd = 'pwd'; +} + +# Lazy-load Carp +sub _carp { require Carp; Carp::carp(@_) } +sub _croak { require Carp; Carp::croak(@_) } + +# The 'natural and safe form' for UNIX (pwd may be setuid root) +sub _backtick_pwd { + # Localize %ENV entries in a way that won't create new hash keys + my @localize = grep exists $ENV{$_}, qw(PATH IFS CDPATH ENV BASH_ENV); + local @ENV{@localize}; + + my $cwd = `$pwd_cmd`; + # Belt-and-suspenders in case someone said "undef $/". + local $/ = "\n"; + # `pwd` may fail e.g. if the disk is full + chomp($cwd) if defined $cwd; + $cwd; +} + +# Since some ports may predefine cwd internally (e.g., NT) +# we take care not to override an existing definition for cwd(). + +unless ($METHOD_MAP{$^O}{cwd} or defined &cwd) { + # The pwd command is not available in some chroot(2)'ed environments + my $sep = $Config::Config{path_sep} || ':'; + my $os = $^O; # Protect $^O from tainting + if( $os eq 'MacOS' || (defined $ENV{PATH} && + $os ne 'MSWin32' && # no pwd on Windows + grep { -x "$_/pwd" } split($sep, $ENV{PATH})) ) + { + *cwd = \&_backtick_pwd; + } + else { + *cwd = \&getcwd; + } +} + +# set a reasonable (and very safe) default for fastgetcwd, in case it +# isn't redefined later (20001212 rspier) +*fastgetcwd = \&cwd; + +# By Brandon S. Allbery +# +# Usage: $cwd = getcwd(); + +sub getcwd +{ + abs_path('.'); +} + + +# By John Bazik +# +# Usage: $cwd = &fastcwd; +# +# This is a faster version of getcwd. It's also more dangerous because +# you might chdir out of a directory that you can't chdir back into. + +sub fastcwd_ { + my($odev, $oino, $cdev, $cino, $tdev, $tino); + my(@path, $path); + local(*DIR); + + my($orig_cdev, $orig_cino) = stat('.'); + ($cdev, $cino) = ($orig_cdev, $orig_cino); + for (;;) { + my $direntry; + ($odev, $oino) = ($cdev, $cino); + CORE::chdir('..') || return undef; + ($cdev, $cino) = stat('.'); + last if $odev == $cdev && $oino == $cino; + opendir(DIR, '.') || return undef; + for (;;) { + $direntry = readdir(DIR); + last unless defined $direntry; + next if $direntry eq '.'; + next if $direntry eq '..'; + + ($tdev, $tino) = lstat($direntry); + last unless $tdev != $odev || $tino != $oino; + } + closedir(DIR); + return undef unless defined $direntry; # should never happen + unshift(@path, $direntry); + } + $path = '/' . join('/', @path); + if ($^O eq 'apollo') { $path = "/".$path; } + # At this point $path may be tainted (if tainting) and chdir would fail. + # Untaint it then check that we landed where we started. + $path =~ /^(.*)\z/s # untaint + && CORE::chdir($1) or return undef; + ($cdev, $cino) = stat('.'); + die "Unstable directory path, current directory changed unexpectedly" + if $cdev != $orig_cdev || $cino != $orig_cino; + $path; +} +if (not defined &fastcwd) { *fastcwd = \&fastcwd_ } + + +# Keeps track of current working directory in PWD environment var +# Usage: +# use Cwd 'chdir'; +# chdir $newdir; + +my $chdir_init = 0; + +sub chdir_init { + if ($ENV{'PWD'} and $^O ne 'os2' and $^O ne 'dos' and $^O ne 'MSWin32') { + my($dd,$di) = stat('.'); + my($pd,$pi) = stat($ENV{'PWD'}); + if (!defined $dd or !defined $pd or $di != $pi or $dd != $pd) { + $ENV{'PWD'} = cwd(); + } + } + else { + my $wd = cwd(); + $wd = Win32::GetFullPathName($wd) if $^O eq 'MSWin32'; + $ENV{'PWD'} = $wd; + } + # Strip an automounter prefix (where /tmp_mnt/foo/bar == /foo/bar) + if ($^O ne 'MSWin32' and $ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|s) { + my($pd,$pi) = stat($2); + my($dd,$di) = stat($1); + if (defined $pd and defined $dd and $di == $pi and $dd == $pd) { + $ENV{'PWD'}="$2$3"; + } + } + $chdir_init = 1; +} + +sub chdir { + my $newdir = @_ ? shift : ''; # allow for no arg (chdir to HOME dir) + $newdir =~ s|///*|/|g unless $^O eq 'MSWin32'; + chdir_init() unless $chdir_init; + my $newpwd; + if ($^O eq 'MSWin32') { + # get the full path name *before* the chdir() + $newpwd = Win32::GetFullPathName($newdir); + } + + return 0 unless CORE::chdir $newdir; + + if ($^O eq 'VMS') { + return $ENV{'PWD'} = $ENV{'DEFAULT'} + } + elsif ($^O eq 'MacOS') { + return $ENV{'PWD'} = cwd(); + } + elsif ($^O eq 'MSWin32') { + $ENV{'PWD'} = $newpwd; + return 1; + } + + if ($newdir =~ m#^/#s) { + $ENV{'PWD'} = $newdir; + } else { + my @curdir = split(m#/#,$ENV{'PWD'}); + @curdir = ('') unless @curdir; + my $component; + foreach $component (split(m#/#, $newdir)) { + next if $component eq '.'; + pop(@curdir),next if $component eq '..'; + push(@curdir,$component); + } + $ENV{'PWD'} = join('/',@curdir) || '/'; + } + 1; +} + + +sub _perl_abs_path +{ + my $start = @_ ? shift : '.'; + my($dotdots, $cwd, @pst, @cst, $dir, @tst); + + unless (@cst = stat( $start )) + { + _carp("stat($start): $!"); + return ''; + } + + unless (-d _) { + # Make sure we can be invoked on plain files, not just directories. + # NOTE that this routine assumes that '/' is the only directory separator. + + my ($dir, $file) = $start =~ m{^(.*)/(.+)$} + or return cwd() . '/' . $start; + + # Can't use "-l _" here, because the previous stat was a stat(), not an lstat(). + if (-l $start) { + my $link_target = readlink($start); + die "Can't resolve link $start: $!" unless defined $link_target; + + require File::Spec; + $link_target = $dir . '/' . $link_target + unless File::Spec->file_name_is_absolute($link_target); + + return abs_path($link_target); + } + + return $dir ? abs_path($dir) . "/$file" : "/$file"; + } + + $cwd = ''; + $dotdots = $start; + do + { + $dotdots .= '/..'; + @pst = @cst; + local *PARENT; + unless (opendir(PARENT, $dotdots)) + { + _carp("opendir($dotdots): $!"); + return ''; + } + unless (@cst = stat($dotdots)) + { + _carp("stat($dotdots): $!"); + closedir(PARENT); + return ''; + } + if ($pst[0] == $cst[0] && $pst[1] == $cst[1]) + { + $dir = undef; + } + else + { + do + { + unless (defined ($dir = readdir(PARENT))) + { + _carp("readdir($dotdots): $!"); + closedir(PARENT); + return ''; + } + $tst[0] = $pst[0]+1 unless (@tst = lstat("$dotdots/$dir")) + } + while ($dir eq '.' || $dir eq '..' || $tst[0] != $pst[0] || + $tst[1] != $pst[1]); + } + $cwd = (defined $dir ? "$dir" : "" ) . "/$cwd" ; + closedir(PARENT); + } while (defined $dir); + chop($cwd) unless $cwd eq '/'; # drop the trailing / + $cwd; +} + + +my $Curdir; +sub fast_abs_path { + local $ENV{PWD} = $ENV{PWD} || ''; # Guard against clobberage + my $cwd = getcwd(); + require File::Spec; + my $path = @_ ? shift : ($Curdir ||= File::Spec->curdir); + + # Detaint else we'll explode in taint mode. This is safe because + # we're not doing anything dangerous with it. + ($path) = $path =~ /(.*)/; + ($cwd) = $cwd =~ /(.*)/; + + unless (-e $path) { + _croak("$path: No such file or directory"); + } + + unless (-d _) { + # Make sure we can be invoked on plain files, not just directories. + + my ($vol, $dir, $file) = File::Spec->splitpath($path); + return File::Spec->catfile($cwd, $path) unless length $dir; + + if (-l $path) { + my $link_target = readlink($path); + die "Can't resolve link $path: $!" unless defined $link_target; + + $link_target = File::Spec->catpath($vol, $dir, $link_target) + unless File::Spec->file_name_is_absolute($link_target); + + return fast_abs_path($link_target); + } + + return $dir eq File::Spec->rootdir + ? File::Spec->catpath($vol, $dir, $file) + : fast_abs_path(File::Spec->catpath($vol, $dir, '')) . '/' . $file; + } + + if (!CORE::chdir($path)) { + _croak("Cannot chdir to $path: $!"); + } + my $realpath = getcwd(); + if (! ((-d $cwd) && (CORE::chdir($cwd)))) { + _croak("Cannot chdir back to $cwd: $!"); + } + $realpath; +} + +# added function alias to follow principle of least surprise +# based on previous aliasing. --tchrist 27-Jan-00 +*fast_realpath = \&fast_abs_path; + + +# --- PORTING SECTION --- + +# VMS: $ENV{'DEFAULT'} points to default directory at all times +# 06-Mar-1996 Charles Bailey bailey@newman.upenn.edu +# Note: Use of Cwd::chdir() causes the logical name PWD to be defined +# in the process logical name table as the default device and directory +# seen by Perl. This may not be the same as the default device +# and directory seen by DCL after Perl exits, since the effects +# the CRTL chdir() function persist only until Perl exits. + +sub _vms_cwd { + return $ENV{'DEFAULT'}; +} + +sub _vms_abs_path { + return $ENV{'DEFAULT'} unless @_; + + # may need to turn foo.dir into [.foo] + my $path = VMS::Filespec::pathify($_[0]); + $path = $_[0] unless defined $path; + + return VMS::Filespec::rmsexpand($path); +} + +sub _os2_cwd { + $ENV{'PWD'} = `cmd /c cd`; + chomp $ENV{'PWD'}; + $ENV{'PWD'} =~ s:\\:/:g ; + return $ENV{'PWD'}; +} + +sub _win32_cwd { + $ENV{'PWD'} = Win32::GetCwd(); + $ENV{'PWD'} =~ s:\\:/:g ; + return $ENV{'PWD'}; +} + +*_NT_cwd = defined &Win32::GetCwd ? \&_win32_cwd : \&_os2_cwd; + +sub _dos_cwd { + if (!defined &Dos::GetCwd) { + $ENV{'PWD'} = `command /c cd`; + chomp $ENV{'PWD'}; + $ENV{'PWD'} =~ s:\\:/:g ; + } else { + $ENV{'PWD'} = Dos::GetCwd(); + } + return $ENV{'PWD'}; +} + +sub _qnx_cwd { + local $ENV{PATH} = ''; + local $ENV{CDPATH} = ''; + local $ENV{ENV} = ''; + $ENV{'PWD'} = `/usr/bin/fullpath -t`; + chomp $ENV{'PWD'}; + return $ENV{'PWD'}; +} + +sub _qnx_abs_path { + local $ENV{PATH} = ''; + local $ENV{CDPATH} = ''; + local $ENV{ENV} = ''; + my $path = @_ ? shift : '.'; + local *REALPATH; + + defined( open(REALPATH, '-|') || exec '/usr/bin/fullpath', '-t', $path ) or + die "Can't open /usr/bin/fullpath: $!"; + my $realpath = <REALPATH>; + close REALPATH; + chomp $realpath; + return $realpath; +} + +sub _epoc_cwd { + $ENV{'PWD'} = EPOC::getcwd(); + return $ENV{'PWD'}; +} + + +# Now that all the base-level functions are set up, alias the +# user-level functions to the right places + +if (exists $METHOD_MAP{$^O}) { + my $map = $METHOD_MAP{$^O}; + foreach my $name (keys %$map) { + local $^W = 0; # assignments trigger 'subroutine redefined' warning + no strict 'refs'; + *{$name} = \&{$map->{$name}}; + } +} + +# In case the XS version doesn't load. +*abs_path = \&_perl_abs_path unless defined &abs_path; + +# added function alias for those of us more +# used to the libc function. --tchrist 27-Jan-00 +*realpath = \&abs_path; + +1; diff --git a/Master/tlpkg/installer/perllib/DynaLoader.pm b/Master/tlpkg/installer/perllib/DynaLoader.pm new file mode 100644 index 00000000000..178e9b2616c --- /dev/null +++ b/Master/tlpkg/installer/perllib/DynaLoader.pm @@ -0,0 +1,833 @@ + +# Generated from DynaLoader.pm.PL + +package DynaLoader; + +# And Gandalf said: 'Many folk like to know beforehand what is to +# be set on the table; but those who have laboured to prepare the +# feast like to keep their secret; for wonder makes the words of +# praise louder.' + +# (Quote from Tolkien suggested by Anno Siegel.) +# +# See pod text at end of file for documentation. +# See also ext/DynaLoader/README in source tree for other information. +# +# Tim.Bunce@ig.co.uk, August 1994 + +use vars qw($VERSION *AUTOLOAD); + +$VERSION = '1.05'; # avoid typo warning + +require AutoLoader; +*AUTOLOAD = \&AutoLoader::AUTOLOAD; + +use Config; + +# The following require can't be removed during maintenance +# releases, sadly, because of the risk of buggy code that does +# require Carp; Carp::croak "..."; without brackets dying +# if Carp hasn't been loaded in earlier compile time. :-( +# We'll let those bugs get found on the development track. +require Carp if $] < 5.00450; + +# enable debug/trace messages from DynaLoader perl code +$dl_debug = $ENV{PERL_DL_DEBUG} || 0 unless defined $dl_debug; + +# +# Flags to alter dl_load_file behaviour. Assigned bits: +# 0x01 make symbols available for linking later dl_load_file's. +# (only known to work on Solaris 2 using dlopen(RTLD_GLOBAL)) +# (ignored under VMS; effect is built-in to image linking) +# +# This is called as a class method $module->dl_load_flags. The +# definition here will be inherited and result on "default" loading +# behaviour unless a sub-class of DynaLoader defines its own version. +# + +sub dl_load_flags { 0x00 } + +# ($dl_dlext, $dlsrc) +# = @Config::Config{'dlext', 'dlsrc'}; + ($dl_dlext, $dlsrc) = ('dll','dl_win32.xs') +; +# Some systems need special handling to expand file specifications +# (VMS support by Charles Bailey <bailey@HMIVAX.HUMGEN.UPENN.EDU>) +# See dl_expandspec() for more details. Should be harmless but +# inefficient to define on systems that don't need it. +$Is_VMS = $^O eq 'VMS'; +$do_expand = $Is_VMS; +$Is_MacOS = $^O eq 'MacOS'; + +my $Mac_FS; +$Mac_FS = eval { require Mac::FileSpec::Unixish } if $Is_MacOS; + +@dl_require_symbols = (); # names of symbols we need +@dl_resolve_using = (); # names of files to link with +@dl_library_path = (); # path to look for files + +#XSLoader.pm may have added elements before we were required +#@dl_shared_objects = (); # shared objects for symbols we have +#@dl_librefs = (); # things we have loaded +#@dl_modules = (); # Modules we have loaded + +# This is a fix to support DLD's unfortunate desire to relink -lc +@dl_resolve_using = dl_findfile('-lc') if $dlsrc eq "dl_dld.xs"; + +# Initialise @dl_library_path with the 'standard' library path +# for this platform as determined by Configure. + +push(@dl_library_path, split(' ', $Config::Config{libpth})); + + +my $ldlibpthname = $Config::Config{ldlibpthname}; +my $ldlibpthname_defined = defined $Config::Config{ldlibpthname}; +my $pthsep = $Config::Config{path_sep}; + +# Add to @dl_library_path any extra directories we can gather from environment +# during runtime. + +if ($ldlibpthname_defined && + exists $ENV{$ldlibpthname}) { + push(@dl_library_path, split(/$pthsep/, $ENV{$ldlibpthname})); +} + +# E.g. HP-UX supports both its native SHLIB_PATH *and* LD_LIBRARY_PATH. + +if ($ldlibpthname_defined && + $ldlibpthname ne 'LD_LIBRARY_PATH' && + exists $ENV{LD_LIBRARY_PATH}) { + push(@dl_library_path, split(/$pthsep/, $ENV{LD_LIBRARY_PATH})); +} + + +# No prizes for guessing why we don't say 'bootstrap DynaLoader;' here. +# NOTE: All dl_*.xs (including dl_none.xs) define a dl_error() XSUB +boot_DynaLoader('DynaLoader') if defined(&boot_DynaLoader) && + !defined(&dl_error); + +if ($dl_debug) { + print STDERR "DynaLoader.pm loaded (@INC, @dl_library_path)\n"; + print STDERR "DynaLoader not linked into this perl\n" + unless defined(&boot_DynaLoader); +} + +1; # End of main code + + +sub croak { require Carp; Carp::croak(@_) } + +sub bootstrap_inherit { + my $module = $_[0]; + local *isa = *{"$module\::ISA"}; + local @isa = (@isa, 'DynaLoader'); + # Cannot goto due to delocalization. Will report errors on a wrong line? + bootstrap(@_); +} + +# The bootstrap function cannot be autoloaded (without complications) +# so we define it here: + +sub bootstrap { + # use local vars to enable $module.bs script to edit values + local(@args) = @_; + local($module) = $args[0]; + local(@dirs, $file); + + unless ($module) { + require Carp; + Carp::confess("Usage: DynaLoader::bootstrap(module)"); + } + + # A common error on platforms which don't support dynamic loading. + # Since it's fatal and potentially confusing we give a detailed message. + croak("Can't load module $module, dynamic loading not available in this perl.\n". + " (You may need to build a new perl executable which either supports\n". + " dynamic loading or has the $module module statically linked into it.)\n") + unless defined(&dl_load_file); + + my @modparts = split(/::/,$module); + my $modfname = $modparts[-1]; + + # Some systems have restrictions on files names for DLL's etc. + # mod2fname returns appropriate file base name (typically truncated) + # It may also edit @modparts if required. + $modfname = &mod2fname(\@modparts) if defined &mod2fname; + + # Truncate the module name to 8.3 format for NetWare + if (($^O eq 'NetWare') && (length($modfname) > 8)) { + $modfname = substr($modfname, 0, 8); + } + + my $modpname = join(($Is_MacOS ? ':' : '/'),@modparts); + + print STDERR "DynaLoader::bootstrap for $module ", + ($Is_MacOS + ? "(:auto:$modpname:$modfname.$dl_dlext)\n" : + "(auto/$modpname/$modfname.$dl_dlext)\n") + if $dl_debug; + + foreach (@INC) { + chop($_ = VMS::Filespec::unixpath($_)) if $Is_VMS; + my $dir; + if ($Is_MacOS) { + my $path = $_; + if ($Mac_FS && ! -d $path) { + $path = Mac::FileSpec::Unixish::nativize($path); + } + $path .= ":" unless /:$/; + $dir = "${path}auto:$modpname"; + } else { + $dir = "$_/auto/$modpname"; + } + + next unless -d $dir; # skip over uninteresting directories + + # check for common cases to avoid autoload of dl_findfile + my $try = $Is_MacOS ? "$dir:$modfname.$dl_dlext" : "$dir/$modfname.$dl_dlext"; + last if $file = ($do_expand) ? dl_expandspec($try) : ((-f $try) && $try); + + # no luck here, save dir for possible later dl_findfile search + push @dirs, $dir; + } + # last resort, let dl_findfile have a go in all known locations + $file = dl_findfile(map("-L$_",@dirs,@INC), $modfname) unless $file; + + croak("Can't locate loadable object for module $module in \@INC (\@INC contains: @INC)") + unless $file; # wording similar to error from 'require' + + $file = uc($file) if $Is_VMS && $Config::Config{d_vms_case_sensitive_symbols}; + my $bootname = "boot_$module"; + $bootname =~ s/\W/_/g; + @dl_require_symbols = ($bootname); + + # Execute optional '.bootstrap' perl script for this module. + # The .bs file can be used to configure @dl_resolve_using etc to + # match the needs of the individual module on this architecture. + my $bs = $file; + $bs =~ s/(\.\w+)?(;\d*)?$/\.bs/; # look for .bs 'beside' the library + if (-s $bs) { # only read file if it's not empty + print STDERR "BS: $bs ($^O, $dlsrc)\n" if $dl_debug; + eval { do $bs; }; + warn "$bs: $@\n" if $@; + } + + my $boot_symbol_ref; + + if ($^O eq 'darwin') { + if ($boot_symbol_ref = dl_find_symbol(0, $bootname)) { + goto boot; #extension library has already been loaded, e.g. darwin + } + } + + # Many dynamic extension loading problems will appear to come from + # this section of code: XYZ failed at line 123 of DynaLoader.pm. + # Often these errors are actually occurring in the initialisation + # C code of the extension XS file. Perl reports the error as being + # in this perl code simply because this was the last perl code + # it executed. + + my $libref = dl_load_file($file, $module->dl_load_flags) or + croak("Can't load '$file' for module $module: ".dl_error()); + + push(@dl_librefs,$libref); # record loaded object + + my @unresolved = dl_undef_symbols(); + if (@unresolved) { + require Carp; + Carp::carp("Undefined symbols present after loading $file: @unresolved\n"); + } + + $boot_symbol_ref = dl_find_symbol($libref, $bootname) or + croak("Can't find '$bootname' symbol in $file\n"); + + push(@dl_modules, $module); # record loaded module + + boot: + my $xs = dl_install_xsub("${module}::bootstrap", $boot_symbol_ref, $file); + + # See comment block above + + push(@dl_shared_objects, $file); # record files loaded + + &$xs(@args); +} + + +#sub _check_file { # private utility to handle dl_expandspec vs -f tests +# my($file) = @_; +# return $file if (!$do_expand && -f $file); # the common case +# return $file if ( $do_expand && ($file=dl_expandspec($file))); +# return undef; +#} + + +# Let autosplit and the autoloader deal with these functions: +__END__ + + +sub dl_findfile { + # Read ext/DynaLoader/DynaLoader.doc for detailed information. + # This function does not automatically consider the architecture + # or the perl library auto directories. + my (@args) = @_; + my (@dirs, $dir); # which directories to search + my (@found); # full paths to real files we have found + my $dl_ext= 'dll'; # $Config::Config{'dlext'} suffix for perl extensions + my $dl_so = 'dll'; # $Config::Config{'so'} suffix for shared libraries + + print STDERR "dl_findfile(@args)\n" if $dl_debug; + + # accumulate directories but process files as they appear + arg: foreach(@args) { + # Special fast case: full filepath requires no search + if ($Is_VMS && m%[:>/\]]% && -f $_) { + push(@found,dl_expandspec(VMS::Filespec::vmsify($_))); + last arg unless wantarray; + next; + } + elsif ($Is_MacOS) { + if (m/:/ && -f $_) { + push(@found,$_); + last arg unless wantarray; + } + } + elsif (m:/: && -f $_ && !$do_expand) { + push(@found,$_); + last arg unless wantarray; + next; + } + + # Deal with directories first: + # Using a -L prefix is the preferred option (faster and more robust) + if (m:^-L:) { s/^-L//; push(@dirs, $_); next; } + + if ($Is_MacOS) { + # Otherwise we try to try to spot directories by a heuristic + # (this is a more complicated issue than it first appears) + if (m/:/ && -d $_) { push(@dirs, $_); next; } + # Only files should get this far... + my(@names, $name); # what filenames to look for + s/^-l//; + push(@names, $_); + foreach $dir (@dirs, @dl_library_path) { + next unless -d $dir; + $dir =~ s/^([^:]+)$/:$1/; + $dir =~ s/:$//; + foreach $name (@names) { + my($file) = "$dir:$name"; + print STDERR " checking in $dir for $name\n" if $dl_debug; + if (-f $file) { + push(@found, $file); + next arg; # no need to look any further + } + } + } + next; + } + + # Otherwise we try to try to spot directories by a heuristic + # (this is a more complicated issue than it first appears) + if (m:/: && -d $_) { push(@dirs, $_); next; } + + # VMS: we may be using native VMS directory syntax instead of + # Unix emulation, so check this as well + if ($Is_VMS && /[:>\]]/ && -d $_) { push(@dirs, $_); next; } + + # Only files should get this far... + my(@names, $name); # what filenames to look for + if (m:-l: ) { # convert -lname to appropriate library name + s/-l//; + push(@names,"lib$_.$dl_so"); + push(@names,"lib$_.a"); + } else { # Umm, a bare name. Try various alternatives: + # these should be ordered with the most likely first + push(@names,"$_.$dl_ext") unless m/\.$dl_ext$/o; + push(@names,"$_.$dl_so") unless m/\.$dl_so$/o; + push(@names,"lib$_.$dl_so") unless m:/:; + push(@names,"$_.a") if !m/\.a$/ and $dlsrc eq "dl_dld.xs"; + push(@names, $_); + } + foreach $dir (@dirs, @dl_library_path) { + next unless -d $dir; + chop($dir = VMS::Filespec::unixpath($dir)) if $Is_VMS; + foreach $name (@names) { + my($file) = "$dir/$name"; + print STDERR " checking in $dir for $name\n" if $dl_debug; + $file = ($do_expand) ? dl_expandspec($file) : (-f $file && $file); + #$file = _check_file($file); + if ($file) { + push(@found, $file); + next arg; # no need to look any further + } + } + } + } + if ($dl_debug) { + foreach(@dirs) { + print STDERR " dl_findfile ignored non-existent directory: $_\n" unless -d $_; + } + print STDERR "dl_findfile found: @found\n"; + } + return $found[0] unless wantarray; + @found; +} + + +sub dl_expandspec { + my($spec) = @_; + # Optional function invoked if DynaLoader.pm sets $do_expand. + # Most systems do not require or use this function. + # Some systems may implement it in the dl_*.xs file in which case + # this autoload version will not be called but is harmless. + + # This function is designed to deal with systems which treat some + # 'filenames' in a special way. For example VMS 'Logical Names' + # (something like unix environment variables - but different). + # This function should recognise such names and expand them into + # full file paths. + # Must return undef if $spec is invalid or file does not exist. + + my $file = $spec; # default output to input + + if ($Is_VMS) { # dl_expandspec should be defined in dl_vms.xs + require Carp; + Carp::croak("dl_expandspec: should be defined in XS file!\n"); + } else { + return undef unless -f $file; + } + print STDERR "dl_expandspec($spec) => $file\n" if $dl_debug; + $file; +} + +sub dl_find_symbol_anywhere +{ + my $sym = shift; + my $libref; + foreach $libref (@dl_librefs) { + my $symref = dl_find_symbol($libref,$sym); + return $symref if $symref; + } + return undef; +} + +=head1 NAME + +DynaLoader - Dynamically load C libraries into Perl code + +=head1 SYNOPSIS + + package YourPackage; + require DynaLoader; + @ISA = qw(... DynaLoader ...); + bootstrap YourPackage; + + # optional method for 'global' loading + sub dl_load_flags { 0x01 } + + +=head1 DESCRIPTION + +This document defines a standard generic interface to the dynamic +linking mechanisms available on many platforms. Its primary purpose is +to implement automatic dynamic loading of Perl modules. + +This document serves as both a specification for anyone wishing to +implement the DynaLoader for a new platform and as a guide for +anyone wishing to use the DynaLoader directly in an application. + +The DynaLoader is designed to be a very simple high-level +interface that is sufficiently general to cover the requirements +of SunOS, HP-UX, NeXT, Linux, VMS and other platforms. + +It is also hoped that the interface will cover the needs of OS/2, NT +etc and also allow pseudo-dynamic linking (using C<ld -A> at runtime). + +It must be stressed that the DynaLoader, by itself, is practically +useless for accessing non-Perl libraries because it provides almost no +Perl-to-C 'glue'. There is, for example, no mechanism for calling a C +library function or supplying arguments. A C::DynaLib module +is available from CPAN sites which performs that function for some +common system types. And since the year 2000, there's also Inline::C, +a module that allows you to write Perl subroutines in C. Also available +from your local CPAN site. + +DynaLoader Interface Summary + + @dl_library_path + @dl_resolve_using + @dl_require_symbols + $dl_debug + @dl_librefs + @dl_modules + @dl_shared_objects + Implemented in: + bootstrap($modulename) Perl + @filepaths = dl_findfile(@names) Perl + $flags = $modulename->dl_load_flags Perl + $symref = dl_find_symbol_anywhere($symbol) Perl + + $libref = dl_load_file($filename, $flags) C + $status = dl_unload_file($libref) C + $symref = dl_find_symbol($libref, $symbol) C + @symbols = dl_undef_symbols() C + dl_install_xsub($name, $symref [, $filename]) C + $message = dl_error C + +=over 4 + +=item @dl_library_path + +The standard/default list of directories in which dl_findfile() will +search for libraries etc. Directories are searched in order: +$dl_library_path[0], [1], ... etc + +@dl_library_path is initialised to hold the list of 'normal' directories +(F</usr/lib>, etc) determined by B<Configure> (C<$Config{'libpth'}>). This should +ensure portability across a wide range of platforms. + +@dl_library_path should also be initialised with any other directories +that can be determined from the environment at runtime (such as +LD_LIBRARY_PATH for SunOS). + +After initialisation @dl_library_path can be manipulated by an +application using push and unshift before calling dl_findfile(). +Unshift can be used to add directories to the front of the search order +either to save search time or to override libraries with the same name +in the 'normal' directories. + +The load function that dl_load_file() calls may require an absolute +pathname. The dl_findfile() function and @dl_library_path can be +used to search for and return the absolute pathname for the +library/object that you wish to load. + +=item @dl_resolve_using + +A list of additional libraries or other shared objects which can be +used to resolve any undefined symbols that might be generated by a +later call to load_file(). + +This is only required on some platforms which do not handle dependent +libraries automatically. For example the Socket Perl extension +library (F<auto/Socket/Socket.so>) contains references to many socket +functions which need to be resolved when it's loaded. Most platforms +will automatically know where to find the 'dependent' library (e.g., +F</usr/lib/libsocket.so>). A few platforms need to be told the +location of the dependent library explicitly. Use @dl_resolve_using +for this. + +Example usage: + + @dl_resolve_using = dl_findfile('-lsocket'); + +=item @dl_require_symbols + +A list of one or more symbol names that are in the library/object file +to be dynamically loaded. This is only required on some platforms. + +=item @dl_librefs + +An array of the handles returned by successful calls to dl_load_file(), +made by bootstrap, in the order in which they were loaded. +Can be used with dl_find_symbol() to look for a symbol in any of +the loaded files. + +=item @dl_modules + +An array of module (package) names that have been bootstrap'ed. + +=item @dl_shared_objects + +An array of file names for the shared objects that were loaded. + +=item dl_error() + +Syntax: + + $message = dl_error(); + +Error message text from the last failed DynaLoader function. Note +that, similar to errno in unix, a successful function call does not +reset this message. + +Implementations should detect the error as soon as it occurs in any of +the other functions and save the corresponding message for later +retrieval. This will avoid problems on some platforms (such as SunOS) +where the error message is very temporary (e.g., dlerror()). + +=item $dl_debug + +Internal debugging messages are enabled when $dl_debug is set true. +Currently setting $dl_debug only affects the Perl side of the +DynaLoader. These messages should help an application developer to +resolve any DynaLoader usage problems. + +$dl_debug is set to C<$ENV{'PERL_DL_DEBUG'}> if defined. + +For the DynaLoader developer/porter there is a similar debugging +variable added to the C code (see dlutils.c) and enabled if Perl was +built with the B<-DDEBUGGING> flag. This can also be set via the +PERL_DL_DEBUG environment variable. Set to 1 for minimal information or +higher for more. + +=item dl_findfile() + +Syntax: + + @filepaths = dl_findfile(@names) + +Determine the full paths (including file suffix) of one or more +loadable files given their generic names and optionally one or more +directories. Searches directories in @dl_library_path by default and +returns an empty list if no files were found. + +Names can be specified in a variety of platform independent forms. Any +names in the form B<-lname> are converted into F<libname.*>, where F<.*> is +an appropriate suffix for the platform. + +If a name does not already have a suitable prefix and/or suffix then +the corresponding file will be searched for by trying combinations of +prefix and suffix appropriate to the platform: "$name.o", "lib$name.*" +and "$name". + +If any directories are included in @names they are searched before +@dl_library_path. Directories may be specified as B<-Ldir>. Any other +names are treated as filenames to be searched for. + +Using arguments of the form C<-Ldir> and C<-lname> is recommended. + +Example: + + @dl_resolve_using = dl_findfile(qw(-L/usr/5lib -lposix)); + + +=item dl_expandspec() + +Syntax: + + $filepath = dl_expandspec($spec) + +Some unusual systems, such as VMS, require special filename handling in +order to deal with symbolic names for files (i.e., VMS's Logical Names). + +To support these systems a dl_expandspec() function can be implemented +either in the F<dl_*.xs> file or code can be added to the autoloadable +dl_expandspec() function in F<DynaLoader.pm>. See F<DynaLoader.pm> for +more information. + +=item dl_load_file() + +Syntax: + + $libref = dl_load_file($filename, $flags) + +Dynamically load $filename, which must be the path to a shared object +or library. An opaque 'library reference' is returned as a handle for +the loaded object. Returns undef on error. + +The $flags argument to alters dl_load_file behaviour. +Assigned bits: + + 0x01 make symbols available for linking later dl_load_file's. + (only known to work on Solaris 2 using dlopen(RTLD_GLOBAL)) + (ignored under VMS; this is a normal part of image linking) + +(On systems that provide a handle for the loaded object such as SunOS +and HPUX, $libref will be that handle. On other systems $libref will +typically be $filename or a pointer to a buffer containing $filename. +The application should not examine or alter $libref in any way.) + +This is the function that does the real work. It should use the +current values of @dl_require_symbols and @dl_resolve_using if required. + + SunOS: dlopen($filename) + HP-UX: shl_load($filename) + Linux: dld_create_reference(@dl_require_symbols); dld_link($filename) + NeXT: rld_load($filename, @dl_resolve_using) + VMS: lib$find_image_symbol($filename,$dl_require_symbols[0]) + +(The dlopen() function is also used by Solaris and some versions of +Linux, and is a common choice when providing a "wrapper" on other +mechanisms as is done in the OS/2 port.) + +=item dl_unload_file() + +Syntax: + + $status = dl_unload_file($libref) + +Dynamically unload $libref, which must be an opaque 'library reference' as +returned from dl_load_file. Returns one on success and zero on failure. + +This function is optional and may not necessarily be provided on all platforms. +If it is defined, it is called automatically when the interpreter exits for +every shared object or library loaded by DynaLoader::bootstrap. All such +library references are stored in @dl_librefs by DynaLoader::Bootstrap as it +loads the libraries. The files are unloaded in last-in, first-out order. + +This unloading is usually necessary when embedding a shared-object perl (e.g. +one configured with -Duseshrplib) within a larger application, and the perl +interpreter is created and destroyed several times within the lifetime of the +application. In this case it is possible that the system dynamic linker will +unload and then subsequently reload the shared libperl without relocating any +references to it from any files DynaLoaded by the previous incarnation of the +interpreter. As a result, any shared objects opened by DynaLoader may point to +a now invalid 'ghost' of the libperl shared object, causing apparently random +memory corruption and crashes. This behaviour is most commonly seen when using +Apache and mod_perl built with the APXS mechanism. + + SunOS: dlclose($libref) + HP-UX: ??? + Linux: ??? + NeXT: ??? + VMS: ??? + +(The dlclose() function is also used by Solaris and some versions of +Linux, and is a common choice when providing a "wrapper" on other +mechanisms as is done in the OS/2 port.) + +=item dl_load_flags() + +Syntax: + + $flags = dl_load_flags $modulename; + +Designed to be a method call, and to be overridden by a derived class +(i.e. a class which has DynaLoader in its @ISA). The definition in +DynaLoader itself returns 0, which produces standard behavior from +dl_load_file(). + +=item dl_find_symbol() + +Syntax: + + $symref = dl_find_symbol($libref, $symbol) + +Return the address of the symbol $symbol or C<undef> if not found. If the +target system has separate functions to search for symbols of different +types then dl_find_symbol() should search for function symbols first and +then other types. + +The exact manner in which the address is returned in $symref is not +currently defined. The only initial requirement is that $symref can +be passed to, and understood by, dl_install_xsub(). + + SunOS: dlsym($libref, $symbol) + HP-UX: shl_findsym($libref, $symbol) + Linux: dld_get_func($symbol) and/or dld_get_symbol($symbol) + NeXT: rld_lookup("_$symbol") + VMS: lib$find_image_symbol($libref,$symbol) + + +=item dl_find_symbol_anywhere() + +Syntax: + + $symref = dl_find_symbol_anywhere($symbol) + +Applies dl_find_symbol() to the members of @dl_librefs and returns +the first match found. + +=item dl_undef_symbols() + +Example + + @symbols = dl_undef_symbols() + +Return a list of symbol names which remain undefined after load_file(). +Returns C<()> if not known. Don't worry if your platform does not provide +a mechanism for this. Most do not need it and hence do not provide it, +they just return an empty list. + + +=item dl_install_xsub() + +Syntax: + + dl_install_xsub($perl_name, $symref [, $filename]) + +Create a new Perl external subroutine named $perl_name using $symref as +a pointer to the function which implements the routine. This is simply +a direct call to newXSUB(). Returns a reference to the installed +function. + +The $filename parameter is used by Perl to identify the source file for +the function if required by die(), caller() or the debugger. If +$filename is not defined then "DynaLoader" will be used. + + +=item bootstrap() + +Syntax: + +bootstrap($module) + +This is the normal entry point for automatic dynamic loading in Perl. + +It performs the following actions: + +=over 8 + +=item * + +locates an auto/$module directory by searching @INC + +=item * + +uses dl_findfile() to determine the filename to load + +=item * + +sets @dl_require_symbols to C<("boot_$module")> + +=item * + +executes an F<auto/$module/$module.bs> file if it exists +(typically used to add to @dl_resolve_using any files which +are required to load the module on the current platform) + +=item * + +calls dl_load_flags() to determine how to load the file. + +=item * + +calls dl_load_file() to load the file + +=item * + +calls dl_undef_symbols() and warns if any symbols are undefined + +=item * + +calls dl_find_symbol() for "boot_$module" + +=item * + +calls dl_install_xsub() to install it as "${module}::bootstrap" + +=item * + +calls &{"${module}::bootstrap"} to bootstrap the module (actually +it uses the function reference returned by dl_install_xsub for speed) + +=back + +=back + + +=head1 AUTHOR + +Tim Bunce, 11 August 1994. + +This interface is based on the work and comments of (in no particular +order): Larry Wall, Robert Sanders, Dean Roehrich, Jeff Okamoto, Anno +Siegel, Thomas Neumann, Paul Marquess, Charles Bailey, myself and others. + +Larry Wall designed the elegant inherited bootstrap mechanism and +implemented the first Perl 5 dynamic loader using it. + +Solaris global loading added by Nick Ing-Simmons with design/coding +assistance from Tim Bunce, January 1996. + +=cut diff --git a/Master/tlpkg/installer/perllib/Encode.pm b/Master/tlpkg/installer/perllib/Encode.pm new file mode 100644 index 00000000000..ac0123c89ec --- /dev/null +++ b/Master/tlpkg/installer/perllib/Encode.pm @@ -0,0 +1,851 @@ +# +# $Id: Encode.pm,v 2.12 2005/09/08 14:17:17 dankogai Exp dankogai $ +# +package Encode; +use strict; +our $VERSION = sprintf "%d.%02d", q$Revision: 2.12 $ =~ /(\d+)/g; +sub DEBUG () { 0 } +use XSLoader (); +XSLoader::load(__PACKAGE__, $VERSION); + +require Exporter; +use base qw/Exporter/; + +# Public, encouraged API is exported by default + +our @EXPORT = qw( + decode decode_utf8 encode encode_utf8 + encodings find_encoding clone_encoding +); + +our @FB_FLAGS = qw(DIE_ON_ERR WARN_ON_ERR RETURN_ON_ERR LEAVE_SRC + PERLQQ HTMLCREF XMLCREF STOP_AT_PARTIAL); +our @FB_CONSTS = qw(FB_DEFAULT FB_CROAK FB_QUIET FB_WARN + FB_PERLQQ FB_HTMLCREF FB_XMLCREF); + +our @EXPORT_OK = + ( + qw( + _utf8_off _utf8_on define_encoding from_to is_16bit is_8bit + is_utf8 perlio_ok resolve_alias utf8_downgrade utf8_upgrade + ), + @FB_FLAGS, @FB_CONSTS, + ); + +our %EXPORT_TAGS = + ( + all => [ @EXPORT, @EXPORT_OK ], + fallbacks => [ @FB_CONSTS ], + fallback_all => [ @FB_CONSTS, @FB_FLAGS ], + ); + +# Documentation moved after __END__ for speed - NI-S + +our $ON_EBCDIC = (ord("A") == 193); + +use Encode::Alias; + +# Make a %Encoding package variable to allow a certain amount of cheating +our %Encoding; +our %ExtModule; +require Encode::Config; +eval { require Encode::ConfigLocal }; + +sub encodings +{ + my $class = shift; + my %enc; + if (@_ and $_[0] eq ":all"){ + %enc = ( %Encoding, %ExtModule ); + }else{ + %enc = %Encoding; + for my $mod (map {m/::/o ? $_ : "Encode::$_" } @_){ + DEBUG and warn $mod; + for my $enc (keys %ExtModule){ + $ExtModule{$enc} eq $mod and $enc{$enc} = $mod; + } + } + } + return + sort { lc $a cmp lc $b } + grep {!/^(?:Internal|Unicode|Guess)$/o} keys %enc; +} + +sub perlio_ok{ + my $obj = ref($_[0]) ? $_[0] : find_encoding($_[0]); + $obj->can("perlio_ok") and return $obj->perlio_ok(); + return 0; # safety net +} + +sub define_encoding +{ + my $obj = shift; + my $name = shift; + $Encoding{$name} = $obj; + my $lc = lc($name); + define_alias($lc => $obj) unless $lc eq $name; + while (@_){ + my $alias = shift; + define_alias($alias, $obj); + } + return $obj; +} + +sub getEncoding +{ + my ($class, $name, $skip_external) = @_; + + ref($name) && $name->can('renew') and return $name; + exists $Encoding{$name} and return $Encoding{$name}; + my $lc = lc $name; + exists $Encoding{$lc} and return $Encoding{$lc}; + + my $oc = $class->find_alias($name); + defined($oc) and return $oc; + $lc ne $name and $oc = $class->find_alias($lc); + defined($oc) and return $oc; + + unless ($skip_external) + { + if (my $mod = $ExtModule{$name} || $ExtModule{$lc}){ + $mod =~ s,::,/,g ; $mod .= '.pm'; + eval{ require $mod; }; + exists $Encoding{$name} and return $Encoding{$name}; + } + } + return; +} + +sub find_encoding($;$) +{ + my ($name, $skip_external) = @_; + return __PACKAGE__->getEncoding($name,$skip_external); +} + +sub resolve_alias($){ + my $obj = find_encoding(shift); + defined $obj and return $obj->name; + return; +} + +sub clone_encoding($){ + my $obj = find_encoding(shift); + ref $obj or return; + eval { require Storable }; + $@ and return; + return Storable::dclone($obj); +} + +sub encode($$;$) +{ + my ($name, $string, $check) = @_; + return undef unless defined $string; + $string .= '' if ref $string; # stringify; + $check ||=0; + my $enc = find_encoding($name); + unless(defined $enc){ + require Carp; + Carp::croak("Unknown encoding '$name'"); + } + my $octets = $enc->encode($string,$check); + $_[1] = $string if $check and !($check & LEAVE_SRC()); + return $octets; +} + +sub decode($$;$) +{ + my ($name,$octets,$check) = @_; + return undef unless defined $octets; + $octets .= '' if ref $octets; + $check ||=0; + my $enc = find_encoding($name); + unless(defined $enc){ + require Carp; + Carp::croak("Unknown encoding '$name'"); + } + my $string = $enc->decode($octets,$check); + $_[1] = $octets if $check and !($check & LEAVE_SRC()); + return $string; +} + +sub from_to($$$;$) +{ + my ($string,$from,$to,$check) = @_; + return undef unless defined $string; + $check ||=0; + my $f = find_encoding($from); + unless (defined $f){ + require Carp; + Carp::croak("Unknown encoding '$from'"); + } + my $t = find_encoding($to); + unless (defined $t){ + require Carp; + Carp::croak("Unknown encoding '$to'"); + } + my $uni = $f->decode($string,$check); + return undef if ($check && length($string)); + $string = $t->encode($uni,$check); + return undef if ($check && length($uni)); + return defined($_[0] = $string) ? length($string) : undef ; +} + +sub encode_utf8($) +{ + my ($str) = @_; + utf8::encode($str); + return $str; +} + +sub decode_utf8($;$) +{ + my ($str, $check) = @_; + if ($check){ + return decode("utf8", $str, $check); + }else{ + return decode("utf8", $str); + return $str; + } +} + +predefine_encodings(1); + +# +# This is to restore %Encoding if really needed; +# + +sub predefine_encodings{ + use Encode::Encoding; + no warnings 'redefine'; + my $use_xs = shift; + if ($ON_EBCDIC) { + # was in Encode::UTF_EBCDIC + package Encode::UTF_EBCDIC; + push @Encode::UTF_EBCDIC::ISA, 'Encode::Encoding'; + *decode = sub{ + my ($obj,$str,$chk) = @_; + my $res = ''; + for (my $i = 0; $i < length($str); $i++) { + $res .= + chr(utf8::unicode_to_native(ord(substr($str,$i,1)))); + } + $_[1] = '' if $chk; + return $res; + }; + *encode = sub{ + my ($obj,$str,$chk) = @_; + my $res = ''; + for (my $i = 0; $i < length($str); $i++) { + $res .= + chr(utf8::native_to_unicode(ord(substr($str,$i,1)))); + } + $_[1] = '' if $chk; + return $res; + }; + $Encode::Encoding{Unicode} = + bless {Name => "UTF_EBCDIC"} => "Encode::UTF_EBCDIC"; + } else { + package Encode::Internal; + push @Encode::Internal::ISA, 'Encode::Encoding'; + *decode = sub{ + my ($obj,$str,$chk) = @_; + utf8::upgrade($str); + $_[1] = '' if $chk; + return $str; + }; + *encode = \&decode; + $Encode::Encoding{Unicode} = + bless {Name => "Internal"} => "Encode::Internal"; + } + + { + # was in Encode::utf8 + package Encode::utf8; + push @Encode::utf8::ISA, 'Encode::Encoding'; + # + if ($use_xs){ + Encode::DEBUG and warn __PACKAGE__, " XS on"; + *decode = \&decode_xs; + *encode = \&encode_xs; + }else{ + Encode::DEBUG and warn __PACKAGE__, " XS off"; + *decode = sub{ + my ($obj,$octets,$chk) = @_; + my $str = Encode::decode_utf8($octets); + if (defined $str) { + $_[1] = '' if $chk; + return $str; + } + return undef; + }; + *encode = sub { + my ($obj,$string,$chk) = @_; + my $octets = Encode::encode_utf8($string); + $_[1] = '' if $chk; + return $octets; + }; + } + *cat_decode = sub{ # ($obj, $dst, $src, $pos, $trm, $chk) + my ($obj, undef, undef, $pos, $trm) = @_; # currently ignores $chk + my ($rdst, $rsrc, $rpos) = \@_[1,2,3]; + use bytes; + if ((my $npos = index($$rsrc, $trm, $pos)) >= 0) { + $$rdst .= substr($$rsrc, $pos, $npos - $pos + length($trm)); + $$rpos = $npos + length($trm); + return 1; + } + $$rdst .= substr($$rsrc, $pos); + $$rpos = length($$rsrc); + return ''; + }; + $Encode::Encoding{utf8} = + bless {Name => "utf8"} => "Encode::utf8"; + $Encode::Encoding{"utf-8-strict"} = + bless {Name => "utf-8-strict", strict_utf8 => 1 } => "Encode::utf8"; + } +} + +1; + +__END__ + +=head1 NAME + +Encode - character encodings + +=head1 SYNOPSIS + + use Encode; + +=head2 Table of Contents + +Encode consists of a collection of modules whose details are too big +to fit in one document. This POD itself explains the top-level APIs +and general topics at a glance. For other topics and more details, +see the PODs below: + + Name Description + -------------------------------------------------------- + Encode::Alias Alias definitions to encodings + Encode::Encoding Encode Implementation Base Class + Encode::Supported List of Supported Encodings + Encode::CN Simplified Chinese Encodings + Encode::JP Japanese Encodings + Encode::KR Korean Encodings + Encode::TW Traditional Chinese Encodings + -------------------------------------------------------- + +=head1 DESCRIPTION + +The C<Encode> module provides the interfaces between Perl's strings +and the rest of the system. Perl strings are sequences of +B<characters>. + +The repertoire of characters that Perl can represent is at least that +defined by the Unicode Consortium. On most platforms the ordinal +values of the characters (as returned by C<ord(ch)>) is the "Unicode +codepoint" for the character (the exceptions are those platforms where +the legacy encoding is some variant of EBCDIC rather than a super-set +of ASCII - see L<perlebcdic>). + +Traditionally, computer data has been moved around in 8-bit chunks +often called "bytes". These chunks are also known as "octets" in +networking standards. Perl is widely used to manipulate data of many +types - not only strings of characters representing human or computer +languages but also "binary" data being the machine's representation of +numbers, pixels in an image - or just about anything. + +When Perl is processing "binary data", the programmer wants Perl to +process "sequences of bytes". This is not a problem for Perl - as a +byte has 256 possible values, it easily fits in Perl's much larger +"logical character". + +=head2 TERMINOLOGY + +=over 2 + +=item * + +I<character>: a character in the range 0..(2**32-1) (or more). +(What Perl's strings are made of.) + +=item * + +I<byte>: a character in the range 0..255 +(A special case of a Perl character.) + +=item * + +I<octet>: 8 bits of data, with ordinal values 0..255 +(Term for bytes passed to or from a non-Perl context, e.g. a disk file.) + +=back + +=head1 PERL ENCODING API + +=over 2 + +=item $octets = encode(ENCODING, $string [, CHECK]) + +Encodes a string from Perl's internal form into I<ENCODING> and returns +a sequence of octets. ENCODING can be either a canonical name or +an alias. For encoding names and aliases, see L</"Defining Aliases">. +For CHECK, see L</"Handling Malformed Data">. + +For example, to convert a string from Perl's internal format to +iso-8859-1 (also known as Latin1), + + $octets = encode("iso-8859-1", $string); + +B<CAVEAT>: When you run C<$octets = encode("utf8", $string)>, then $octets +B<may not be equal to> $string. Though they both contain the same data, the utf8 flag +for $octets is B<always> off. When you encode anything, utf8 flag of +the result is always off, even when it contains completely valid utf8 +string. See L</"The UTF-8 flag"> below. + +If the $string is C<undef> then C<undef> is returned. + +=item $string = decode(ENCODING, $octets [, CHECK]) + +Decodes a sequence of octets assumed to be in I<ENCODING> into Perl's +internal form and returns the resulting string. As in encode(), +ENCODING can be either a canonical name or an alias. For encoding names +and aliases, see L</"Defining Aliases">. For CHECK, see +L</"Handling Malformed Data">. + +For example, to convert ISO-8859-1 data to a string in Perl's internal format: + + $string = decode("iso-8859-1", $octets); + +B<CAVEAT>: When you run C<$string = decode("utf8", $octets)>, then $string +B<may not be equal to> $octets. Though they both contain the same data, +the utf8 flag for $string is on unless $octets entirely consists of +ASCII data (or EBCDIC on EBCDIC machines). See L</"The UTF-8 flag"> +below. + +If the $string is C<undef> then C<undef> is returned. + +=item [$length =] from_to($octets, FROM_ENC, TO_ENC [, CHECK]) + +Converts B<in-place> data between two encodings. The data in $octets +must be encoded as octets and not as characters in Perl's internal +format. For example, to convert ISO-8859-1 data to Microsoft's CP1250 +encoding: + + from_to($octets, "iso-8859-1", "cp1250"); + +and to convert it back: + + from_to($octets, "cp1250", "iso-8859-1"); + +Note that because the conversion happens in place, the data to be +converted cannot be a string constant; it must be a scalar variable. + +from_to() returns the length of the converted string in octets on +success, I<undef> on error. + +B<CAVEAT>: The following operations look the same but are not quite so; + + from_to($data, "iso-8859-1", "utf8"); #1 + $data = decode("iso-8859-1", $data); #2 + +Both #1 and #2 make $data consist of a completely valid UTF-8 string +but only #2 turns utf8 flag on. #1 is equivalent to + + $data = encode("utf8", decode("iso-8859-1", $data)); + +See L</"The UTF-8 flag"> below. + +=item $octets = encode_utf8($string); + +Equivalent to C<$octets = encode("utf8", $string);> The characters +that comprise $string are encoded in Perl's internal format and the +result is returned as a sequence of octets. All possible +characters have a UTF-8 representation so this function cannot fail. + + +=item $string = decode_utf8($octets [, CHECK]); + +equivalent to C<$string = decode("utf8", $octets [, CHECK])>. +The sequence of octets represented by +$octets is decoded from UTF-8 into a sequence of logical +characters. Not all sequences of octets form valid UTF-8 encodings, so +it is possible for this call to fail. For CHECK, see +L</"Handling Malformed Data">. + +=back + +=head2 Listing available encodings + + use Encode; + @list = Encode->encodings(); + +Returns a list of the canonical names of the available encodings that +are loaded. To get a list of all available encodings including the +ones that are not loaded yet, say + + @all_encodings = Encode->encodings(":all"); + +Or you can give the name of a specific module. + + @with_jp = Encode->encodings("Encode::JP"); + +When "::" is not in the name, "Encode::" is assumed. + + @ebcdic = Encode->encodings("EBCDIC"); + +To find out in detail which encodings are supported by this package, +see L<Encode::Supported>. + +=head2 Defining Aliases + +To add a new alias to a given encoding, use: + + use Encode; + use Encode::Alias; + define_alias(newName => ENCODING); + +After that, newName can be used as an alias for ENCODING. +ENCODING may be either the name of an encoding or an +I<encoding object> + +But before you do so, make sure the alias is nonexistent with +C<resolve_alias()>, which returns the canonical name thereof. +i.e. + + Encode::resolve_alias("latin1") eq "iso-8859-1" # true + Encode::resolve_alias("iso-8859-12") # false; nonexistent + Encode::resolve_alias($name) eq $name # true if $name is canonical + +resolve_alias() does not need C<use Encode::Alias>; it can be +exported via C<use Encode qw(resolve_alias)>. + +See L<Encode::Alias> for details. + +=head1 Encoding via PerlIO + +If your perl supports I<PerlIO> (which is the default), you can use a PerlIO layer to decode +and encode directly via a filehandle. The following two examples +are totally identical in their functionality. + + # via PerlIO + open my $in, "<:encoding(shiftjis)", $infile or die; + open my $out, ">:encoding(euc-jp)", $outfile or die; + while(<$in>){ print $out $_; } + + # via from_to + open my $in, "<", $infile or die; + open my $out, ">", $outfile or die; + while(<$in>){ + from_to($_, "shiftjis", "euc-jp", 1); + print $out $_; + } + +Unfortunately, it may be that encodings are PerlIO-savvy. You can check +if your encoding is supported by PerlIO by calling the C<perlio_ok> +method. + + Encode::perlio_ok("hz"); # False + find_encoding("euc-cn")->perlio_ok; # True where PerlIO is available + + use Encode qw(perlio_ok); # exported upon request + perlio_ok("euc-jp") + +Fortunately, all encodings that come with Encode core are PerlIO-savvy +except for hz and ISO-2022-kr. For gory details, see +L<Encode::Encoding> and L<Encode::PerlIO>. + +=head1 Handling Malformed Data + +The optional I<CHECK> argument tells Encode what to do when it +encounters malformed data. Without CHECK, Encode::FB_DEFAULT ( == 0 ) +is assumed. + +As of version 2.12 Encode supports coderef values for CHECK. See below. + +=over 2 + +=item B<NOTE:> Not all encoding support this feature + +Some encodings ignore I<CHECK> argument. For example, +L<Encode::Unicode> ignores I<CHECK> and it always croaks on error. + +=back + +Now here is the list of I<CHECK> values available + +=over 2 + +=item I<CHECK> = Encode::FB_DEFAULT ( == 0) + +If I<CHECK> is 0, (en|de)code will put a I<substitution character> in +place of a malformed character. When you encode, E<lt>subcharE<gt> +will be used. When you decode the code point C<0xFFFD> is used. If +the data is supposed to be UTF-8, an optional lexical warning +(category utf8) is given. + +=item I<CHECK> = Encode::FB_CROAK ( == 1) + +If I<CHECK> is 1, methods will die on error immediately with an error +message. Therefore, when I<CHECK> is set to 1, you should trap the +error with eval{} unless you really want to let it die. + +=item I<CHECK> = Encode::FB_QUIET + +If I<CHECK> is set to Encode::FB_QUIET, (en|de)code will immediately +return the portion of the data that has been processed so far when an +error occurs. The data argument will be overwritten with everything +after that point (that is, the unprocessed part of data). This is +handy when you have to call decode repeatedly in the case where your +source data may contain partial multi-byte character sequences, +(i.e. you are reading with a fixed-width buffer). Here is a sample +code that does exactly this: + + my $buffer = ''; my $string = ''; + while(read $fh, $buffer, 256, length($buffer)){ + $string .= decode($encoding, $buffer, Encode::FB_QUIET); + # $buffer now contains the unprocessed partial character + } + +=item I<CHECK> = Encode::FB_WARN + +This is the same as above, except that it warns on error. Handy when +you are debugging the mode above. + +=item perlqq mode (I<CHECK> = Encode::FB_PERLQQ) + +=item HTML charref mode (I<CHECK> = Encode::FB_HTMLCREF) + +=item XML charref mode (I<CHECK> = Encode::FB_XMLCREF) + +For encodings that are implemented by Encode::XS, CHECK == +Encode::FB_PERLQQ turns (en|de)code into C<perlqq> fallback mode. + +When you decode, C<\xI<HH>> will be inserted for a malformed character, +where I<HH> is the hex representation of the octet that could not be +decoded to utf8. And when you encode, C<\x{I<HHHH>}> will be inserted, +where I<HHHH> is the Unicode ID of the character that cannot be found +in the character repertoire of the encoding. + +HTML/XML character reference modes are about the same, in place of +C<\x{I<HHHH>}>, HTML uses C<&#I<NNN>;> where I<NNN> is a decimal number and +XML uses C<&#xI<HHHH>;> where I<HHHH> is the hexadecimal number. + +In Encode 2.10 or later, C<LEAVE_SRC> is also implied. + +=item The bitmask + +These modes are actually set via a bitmask. Here is how the FB_XX +constants are laid out. You can import the FB_XX constants via +C<use Encode qw(:fallbacks)>; you can import the generic bitmask +constants via C<use Encode qw(:fallback_all)>. + + FB_DEFAULT FB_CROAK FB_QUIET FB_WARN FB_PERLQQ + DIE_ON_ERR 0x0001 X + WARN_ON_ERR 0x0002 X + RETURN_ON_ERR 0x0004 X X + LEAVE_SRC 0x0008 X + PERLQQ 0x0100 X + HTMLCREF 0x0200 + XMLCREF 0x0400 + +=back + +=head2 coderef for CHECK + +As of Encode 2.12 CHECK can also be a code reference which takes the +ord value of unmapped caharacter as an argument and returns a string +that represents the fallback character. For instance, + + $ascii = encode("ascii", $utf8, sub{ sprintf "<U+%04X>", shift }); + +Acts like FB_PERLQQ but E<lt>U+I<XXXX>E<gt> is used instead of +\x{I<XXXX>}. + +=head1 Defining Encodings + +To define a new encoding, use: + + use Encode qw(define_encoding); + define_encoding($object, 'canonicalName' [, alias...]); + +I<canonicalName> will be associated with I<$object>. The object +should provide the interface described in L<Encode::Encoding>. +If more than two arguments are provided then additional +arguments are taken as aliases for I<$object>. + +See L<Encode::Encoding> for more details. + +=head1 The UTF-8 flag + +Before the introduction of utf8 support in perl, The C<eq> operator +just compared the strings represented by two scalars. Beginning with +perl 5.8, C<eq> compares two strings with simultaneous consideration +of I<the utf8 flag>. To explain why we made it so, I will quote page +402 of C<Programming Perl, 3rd ed.> + +=over 2 + +=item Goal #1: + +Old byte-oriented programs should not spontaneously break on the old +byte-oriented data they used to work on. + +=item Goal #2: + +Old byte-oriented programs should magically start working on the new +character-oriented data when appropriate. + +=item Goal #3: + +Programs should run just as fast in the new character-oriented mode +as in the old byte-oriented mode. + +=item Goal #4: + +Perl should remain one language, rather than forking into a +byte-oriented Perl and a character-oriented Perl. + +=back + +Back when C<Programming Perl, 3rd ed.> was written, not even Perl 5.6.0 +was born and many features documented in the book remained +unimplemented for a long time. Perl 5.8 corrected this and the introduction +of the UTF-8 flag is one of them. You can think of this perl notion as of a +byte-oriented mode (utf8 flag off) and a character-oriented mode (utf8 +flag on). + +Here is how Encode takes care of the utf8 flag. + +=over 2 + +=item * + +When you encode, the resulting utf8 flag is always off. + +=item * + +When you decode, the resulting utf8 flag is on unless you can +unambiguously represent data. Here is the definition of +dis-ambiguity. + +After C<$utf8 = decode('foo', $octet);>, + + When $octet is... The utf8 flag in $utf8 is + --------------------------------------------- + In ASCII only (or EBCDIC only) OFF + In ISO-8859-1 ON + In any other Encoding ON + --------------------------------------------- + +As you see, there is one exception, In ASCII. That way you can assume +Goal #1. And with Encode Goal #2 is assumed but you still have to be +careful in such cases mentioned in B<CAVEAT> paragraphs. + +This utf8 flag is not visible in perl scripts, exactly for the same +reason you cannot (or you I<don't have to>) see if a scalar contains a +string, integer, or floating point number. But you can still peek +and poke these if you will. See the section below. + +=back + +=head2 Messing with Perl's Internals + +The following API uses parts of Perl's internals in the current +implementation. As such, they are efficient but may change. + +=over 2 + +=item is_utf8(STRING [, CHECK]) + +[INTERNAL] Tests whether the UTF-8 flag is turned on in the STRING. +If CHECK is true, also checks the data in STRING for being well-formed +UTF-8. Returns true if successful, false otherwise. + +As of perl 5.8.1, L<utf8> also has utf8::is_utf8(). + +=item _utf8_on(STRING) + +[INTERNAL] Turns on the UTF-8 flag in STRING. The data in STRING is +B<not> checked for being well-formed UTF-8. Do not use unless you +B<know> that the STRING is well-formed UTF-8. Returns the previous +state of the UTF-8 flag (so please don't treat the return value as +indicating success or failure), or C<undef> if STRING is not a string. + +=item _utf8_off(STRING) + +[INTERNAL] Turns off the UTF-8 flag in STRING. Do not use frivolously. +Returns the previous state of the UTF-8 flag (so please don't treat the +return value as indicating success or failure), or C<undef> if STRING is +not a string. + +=back + +=head1 UTF-8 vs. utf8 + + ....We now view strings not as sequences of bytes, but as sequences + of numbers in the range 0 .. 2**32-1 (or in the case of 64-bit + computers, 0 .. 2**64-1) -- Programming Perl, 3rd ed. + +That has been the perl's notion of UTF-8 but official UTF-8 is more +strict; Its ranges is much narrower (0 .. 10FFFF), some sequences are +not allowed (i.e. Those used in the surrogate pair, 0xFFFE, et al). + +Now that is overruled by Larry Wall himself. + + From: Larry Wall <larry@wall.org> + Date: December 04, 2004 11:51:58 JST + To: perl-unicode@perl.org + Subject: Re: Make Encode.pm support the real UTF-8 + Message-Id: <20041204025158.GA28754@wall.org> + + On Fri, Dec 03, 2004 at 10:12:12PM +0000, Tim Bunce wrote: + : I've no problem with 'utf8' being perl's unrestricted uft8 encoding, + : but "UTF-8" is the name of the standard and should give the + : corresponding behaviour. + + For what it's worth, that's how I've always kept them straight in my + head. + + Also for what it's worth, Perl 6 will mostly default to strict but + make it easy to switch back to lax. + + Larry + +Do you copy? As of Perl 5.8.7, B<UTF-8> means strict, official UTF-8 +while B<utf8> means liberal, lax, version thereof. And Encode version +2.10 or later thus groks the difference between C<UTF-8> and C"utf8". + + encode("utf8", "\x{FFFF_FFFF}", 1); # okay + encode("UTF-8", "\x{FFFF_FFFF}", 1); # croaks + +C<UTF-8> in Encode is actually a canonical name for C<utf-8-strict>. +Yes, the hyphen between "UTF" and "8" is important. Without it Encode +goes "liberal" + + find_encoding("UTF-8")->name # is 'utf-8-strict' + find_encoding("utf-8")->name # ditto. names are case insensitive + find_encoding("utf8")->name # ditto. "_" are treated as "-" + find_encoding("UTF8")->name # is 'utf8'. + + +=head1 SEE ALSO + +L<Encode::Encoding>, +L<Encode::Supported>, +L<Encode::PerlIO>, +L<encoding>, +L<perlebcdic>, +L<perlfunc/open>, +L<perlunicode>, +L<utf8>, +the Perl Unicode Mailing List E<lt>perl-unicode@perl.orgE<gt> + +=head1 MAINTAINER + +This project was originated by Nick Ing-Simmons and later maintained +by Dan Kogai E<lt>dankogai@dan.co.jpE<gt>. See AUTHORS for a full +list of people involved. For any questions, use +E<lt>perl-unicode@perl.orgE<gt> so we can all share. + +=cut diff --git a/Master/tlpkg/installer/perllib/Encode/Alias.pm b/Master/tlpkg/installer/perllib/Encode/Alias.pm new file mode 100644 index 00000000000..c0bbf69f469 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Encode/Alias.pm @@ -0,0 +1,341 @@ +package Encode::Alias; +use strict; +no warnings 'redefine'; +use Encode; +our $VERSION = do { my @r = (q$Revision: 2.4 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; +sub DEBUG () { 0 } + +use base qw(Exporter); + +# Public, encouraged API is exported by default + +our @EXPORT = + qw ( + define_alias + find_alias + ); + +our @Alias; # ordered matching list +our %Alias; # cached known aliases + +sub find_alias{ + my $class = shift; + my $find = shift; + unless (exists $Alias{$find}) { + $Alias{$find} = undef; # Recursion guard + for (my $i=0; $i < @Alias; $i += 2){ + my $alias = $Alias[$i]; + my $val = $Alias[$i+1]; + my $new; + if (ref($alias) eq 'Regexp' && $find =~ $alias){ + DEBUG and warn "eval $val"; + $new = eval $val; + DEBUG and $@ and warn "$val, $@"; + }elsif (ref($alias) eq 'CODE'){ + DEBUG and warn "$alias", "->", "($find)"; + $new = $alias->($find); + }elsif (lc($find) eq lc($alias)){ + $new = $val; + } + if (defined($new)){ + next if $new eq $find; # avoid (direct) recursion on bugs + DEBUG and warn "$alias, $new"; + my $enc = (ref($new)) ? $new : Encode::find_encoding($new); + if ($enc){ + $Alias{$find} = $enc; + last; + } + } + } + # case insensitive search when canonical is not in all lowercase + # RT ticket #7835 + unless ($Alias{$find}){ + my $lcfind = lc($find); + for my $name (keys %Encode::Encoding, keys %Encode::ExtModule){ + $lcfind eq lc($name) or next; + $Alias{$find} = Encode::find_encoding($name); + DEBUG and warn "$find => $name"; + } + } + } + if (DEBUG){ + my $name; + if (my $e = $Alias{$find}){ + $name = $e->name; + }else{ + $name = ""; + } + warn "find_alias($class, $find)->name = $name"; + } + return $Alias{$find}; +} + +sub define_alias{ + while (@_){ + my ($alias,$name) = splice(@_,0,2); + unshift(@Alias, $alias => $name); # newer one has precedence + if (ref($alias)){ + # clear %Alias cache to allow overrides + my @a = keys %Alias; + for my $k (@a){ + if (ref($alias) eq 'Regexp' && $k =~ $alias){ + DEBUG and warn "delete \$Alias\{$k\}"; + delete $Alias{$k}; + } + elsif (ref($alias) eq 'CODE'){ + DEBUG and warn "delete \$Alias\{$k\}"; + delete $Alias{$alias->($name)}; + } + } + }else{ + DEBUG and warn "delete \$Alias\{$alias\}"; + delete $Alias{$alias}; + } + } +} + +# Allow latin-1 style names as well +# 0 1 2 3 4 5 6 7 8 9 10 +our @Latin2iso = ( 0, 1, 2, 3, 4, 9, 10, 13, 14, 15, 16 ); +# Allow winlatin1 style names as well +our %Winlatin2cp = ( + 'latin1' => 1252, + 'latin2' => 1250, + 'cyrillic' => 1251, + 'greek' => 1253, + 'turkish' => 1254, + 'hebrew' => 1255, + 'arabic' => 1256, + 'baltic' => 1257, + 'vietnamese' => 1258, + ); + +init_aliases(); + +sub undef_aliases{ + @Alias = (); + %Alias = (); +} + +sub init_aliases +{ + undef_aliases(); + # Try all-lower-case version should all else fails + define_alias( qr/^(.*)$/ => '"\L$1"' ); + + # UTF/UCS stuff + define_alias( qr/^UTF-?7$/i => '"UTF-7"'); + define_alias( qr/^UCS-?2-?LE$/i => '"UCS-2LE"' ); + define_alias( qr/^UCS-?2-?(BE)?$/i => '"UCS-2BE"', + qr/^UCS-?4-?(BE|LE)?$/i => 'uc("UTF-32$1")', + qr/^iso-10646-1$/i => '"UCS-2BE"' ); + define_alias( qr/^UTF-?(16|32)-?BE$/i => '"UTF-$1BE"', + qr/^UTF-?(16|32)-?LE$/i => '"UTF-$1LE"', + qr/^UTF-?(16|32)$/i => '"UTF-$1"', + ); + # ASCII + define_alias(qr/^(?:US-?)ascii$/i => '"ascii"'); + define_alias('C' => 'ascii'); + define_alias(qr/\bISO[-_]?646[-_]?US$/i => '"ascii"'); + # Allow variants of iso-8859-1 etc. + define_alias( qr/\biso[-_]?(\d+)[-_](\d+)$/i => '"iso-$1-$2"' ); + + # At least HP-UX has these. + define_alias( qr/\biso8859(\d+)$/i => '"iso-8859-$1"' ); + + # More HP stuff. + define_alias( qr/\b(?:hp-)?(arabic|greek|hebrew|kana|roman|thai|turkish)8$/i => '"${1}8"' ); + + # The Official name of ASCII. + define_alias( qr/\bANSI[-_]?X3\.4[-_]?1968$/i => '"ascii"' ); + + # This is a font issue, not an encoding issue. + # (The currency symbol of the Latin 1 upper half + # has been redefined as the euro symbol.) + define_alias( qr/^(.+)\@euro$/i => '"$1"' ); + + define_alias( qr/\b(?:iso[-_]?)?latin[-_]?(\d+)$/i + => 'defined $Encode::Alias::Latin2iso[$1] ? "iso-8859-$Encode::Alias::Latin2iso[$1]" : undef' ); + + define_alias( qr/\bwin(latin[12]|cyrillic|baltic|greek|turkish| + hebrew|arabic|baltic|vietnamese)$/ix => + '"cp" . $Encode::Alias::Winlatin2cp{lc($1)}' ); + + # Common names for non-latin preferred MIME names + define_alias( 'ascii' => 'US-ascii', + 'cyrillic' => 'iso-8859-5', + 'arabic' => 'iso-8859-6', + 'greek' => 'iso-8859-7', + 'hebrew' => 'iso-8859-8', + 'thai' => 'iso-8859-11', + 'tis620' => 'iso-8859-11', + ); + + # At least AIX has IBM-NNN (surprisingly...) instead of cpNNN. + # And Microsoft has their own naming (again, surprisingly). + # And windows-* is registered in IANA! + define_alias( qr/\b(?:cp|ibm|ms|windows)[-_ ]?(\d{2,4})$/i => '"cp$1"'); + + # Sometimes seen with a leading zero. + # define_alias( qr/\bcp037\b/i => '"cp37"'); + + # Mac Mappings + # predefined in *.ucm; unneeded + # define_alias( qr/\bmacIcelandic$/i => '"macIceland"'); + define_alias( qr/^mac_(.*)$/i => '"mac$1"'); + # Ououououou. gone. They are differente! + # define_alias( qr/\bmacRomanian$/i => '"macRumanian"'); + + # Standardize on the dashed versions. + define_alias( qr/\bkoi8[\s\-_]*([ru])$/i => '"koi8-$1"' ); + + unless ($Encode::ON_EBCDIC){ + # for Encode::CN + define_alias( qr/\beuc.*cn$/i => '"euc-cn"' ); + define_alias( qr/\bcn.*euc$/i => '"euc-cn"' ); + # define_alias( qr/\bGB[- ]?(\d+)$/i => '"euc-cn"' ) + # CP936 doesn't have vendor-addon for GBK, so they're identical. + define_alias( qr/^gbk$/i => '"cp936"'); + # This fixes gb2312 vs. euc-cn confusion, practically + define_alias( qr/\bGB[-_ ]?2312(?!-?raw)/i => '"euc-cn"' ); + # for Encode::JP + define_alias( qr/\bjis$/i => '"7bit-jis"' ); + define_alias( qr/\beuc.*jp$/i => '"euc-jp"' ); + define_alias( qr/\bjp.*euc$/i => '"euc-jp"' ); + define_alias( qr/\bujis$/i => '"euc-jp"' ); + define_alias( qr/\bshift.*jis$/i => '"shiftjis"' ); + define_alias( qr/\bsjis$/i => '"shiftjis"' ); + define_alias( qr/\bwindows-31j$/i => '"cp932"' ); + # for Encode::KR + define_alias( qr/\beuc.*kr$/i => '"euc-kr"' ); + define_alias( qr/\bkr.*euc$/i => '"euc-kr"' ); + # This fixes ksc5601 vs. euc-kr confusion, practically + define_alias( qr/(?:x-)?uhc$/i => '"cp949"' ); + define_alias( qr/(?:x-)?windows-949$/i => '"cp949"' ); + define_alias( qr/\bks_c_5601-1987$/i => '"cp949"' ); + # for Encode::TW + define_alias( qr/\bbig-?5$/i => '"big5-eten"' ); + define_alias( qr/\bbig5-?et(?:en)?$/i => '"big5-eten"' ); + define_alias( qr/\btca[-_]?big5$/i => '"big5-eten"' ); + define_alias( qr/\bbig5-?hk(?:scs)?$/i => '"big5-hkscs"' ); + define_alias( qr/\bhk(?:scs)?[-_]?big5$/i => '"big5-hkscs"' ); + } + # utf8 is blessed :) + define_alias( qr/^UTF-8$/i => '"utf-8-strict"'); + # At last, Map white space and _ to '-' + define_alias( qr/^(\S+)[\s_]+(.*)$/i => '"$1-$2"' ); +} + +1; +__END__ + +# TODO: HP-UX '8' encodings arabic8 greek8 hebrew8 kana8 thai8 turkish8 +# TODO: HP-UX '15' encodings japanese15 korean15 roi15 +# TODO: Cyrillic encoding ISO-IR-111 (useful?) +# TODO: Armenian encoding ARMSCII-8 +# TODO: Hebrew encoding ISO-8859-8-1 +# TODO: Thai encoding TCVN +# TODO: Vietnamese encodings VPS +# TODO: Mac Asian+African encodings: Arabic Armenian Bengali Burmese +# ChineseSimp ChineseTrad Devanagari Ethiopic ExtArabic +# Farsi Georgian Gujarati Gurmukhi Hebrew Japanese +# Kannada Khmer Korean Laotian Malayalam Mongolian +# Oriya Sinhalese Symbol Tamil Telugu Tibetan Vietnamese + +=head1 NAME + +Encode::Alias - alias definitions to encodings + +=head1 SYNOPSIS + + use Encode; + use Encode::Alias; + define_alias( newName => ENCODING); + +=head1 DESCRIPTION + +Allows newName to be used as an alias for ENCODING. ENCODING may be +either the name of an encoding or an encoding object (as described +in L<Encode>). + +Currently I<newName> can be specified in the following ways: + +=over 4 + +=item As a simple string. + +=item As a qr// compiled regular expression, e.g.: + + define_alias( qr/^iso8859-(\d+)$/i => '"iso-8859-$1"' ); + +In this case, if I<ENCODING> is not a reference, it is C<eval>-ed +in order to allow C<$1> etc. to be substituted. The example is one +way to alias names as used in X11 fonts to the MIME names for the +iso-8859-* family. Note the double quotes inside the single quotes. + +(or, you don't have to do this yourself because this example is predefined) + +If you are using a regex here, you have to use the quotes as shown or +it won't work. Also note that regex handling is tricky even for the +experienced. Use this feature with caution. + +=item As a code reference, e.g.: + + define_alias( sub {shift =~ /^iso8859-(\d+)$/i ? "iso-8859-$1" : undef } ); + +The same effect as the example above in a different way. The coderef +takes the alias name as an argument and returns a canonical name on +success or undef if not. Note the second argument is not required. +Use this with even more caution than the regex version. + +=back + +=head3 Changes in code reference aliasing + +As of Encode 1.87, the older form + + define_alias( sub { return /^iso8859-(\d+)$/i ? "iso-8859-$1" : undef } ); + +no longer works. + +Encode up to 1.86 internally used "local $_" to implement ths older +form. But consider the code below; + + use Encode; + $_ = "eeeee" ; + while (/(e)/g) { + my $utf = decode('aliased-encoding-name', $1); + print "position:",pos,"\n"; + } + +Prior to Encode 1.86 this fails because of "local $_". + +=head2 Alias overloading + +You can override predefined aliases by simply applying define_alias(). +The new alias is always evaluated first, and when necessary, +define_alias() flushes the internal cache to make the new definition +available. + + # redirect SHIFT_JIS to MS/IBM Code Page 932, which is a + # superset of SHIFT_JIS + + define_alias( qr/shift.*jis$/i => '"cp932"' ); + define_alias( qr/sjis$/i => '"cp932"' ); + +If you want to zap all predefined aliases, you can use + + Encode::Alias->undef_aliases; + +to do so. And + + Encode::Alias->init_aliases; + +gets the factory settings back. + +=head1 SEE ALSO + +L<Encode>, L<Encode::Supported> + +=cut + diff --git a/Master/tlpkg/installer/perllib/Encode/Byte.pm b/Master/tlpkg/installer/perllib/Encode/Byte.pm new file mode 100644 index 00000000000..d40c1c3d9d1 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Encode/Byte.pm @@ -0,0 +1,119 @@ +package Encode::Byte; +use Encode; +our $VERSION = do { my @r = (q$Revision: 2.0 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; + +use XSLoader; +XSLoader::load(__PACKAGE__,$VERSION); + +1; +__END__ + +=head1 NAME + +Encode::Byte - Single Byte Encodings + +=head1 SYNOPSIS + + use Encode qw/encode decode/; + $greek = encode("iso-8859-7", $utf8); # loads Encode::Byte implicitly + $utf8 = decode("iso-8859-7", $greek); # ditto + +=head1 ABSTRACT + +This module implements various single byte encodings. For most cases it uses +\x80-\xff (upper half) to map non-ASCII characters. Encodings +supported are as follows. + + Canonical Alias Description + -------------------------------------------------------------------- + # ISO 8859 series + (iso-8859-1 is in built-in) + iso-8859-2 latin2 [ISO] + iso-8859-3 latin3 [ISO] + iso-8859-4 latin4 [ISO] + iso-8859-5 [ISO] + iso-8859-6 [ISO] + iso-8859-7 [ISO] + iso-8859-8 [ISO] + iso-8859-9 latin5 [ISO] + iso-8859-10 latin6 [ISO] + iso-8859-11 + (iso-8859-12 is nonexistent) + iso-8859-13 latin7 [ISO] + iso-8859-14 latin8 [ISO] + iso-8859-15 latin9 [ISO] + iso-8859-16 latin10 [ISO] + + # Cyrillic + koi8-f + koi8-r cp878 [RFC1489] + koi8-u [RFC2319] + + # Vietnamese + viscii + + # all cp* are also available as ibm-*, ms-*, and windows-* + # also see L<http://msdn.microsoft.com/workshop/author/dhtml/reference/charsets/charset4.asp> + + cp424 + cp437 + cp737 + cp775 + cp850 + cp852 + cp855 + cp856 + cp857 + cp860 + cp861 + cp862 + cp863 + cp864 + cp865 + cp866 + cp869 + cp874 + cp1006 + cp1250 WinLatin2 + cp1251 WinCyrillic + cp1252 WinLatin1 + cp1253 WinGreek + cp1254 WinTurkish + cp1255 WinHebrew + cp1256 WinArabic + cp1257 WinBaltic + cp1258 WinVietnamese + + # Macintosh + # Also see L<http://developer.apple.com/technotes/tn/tn1150.html> + MacArabic + MacCentralEurRoman + MacCroatian + MacCyrillic + MacFarsi + MacGreek + MacHebrew + MacIcelandic + MacRoman + MacRomanian + MacRumanian + MacSami + MacThai + MacTurkish + MacUkrainian + + # More vendor encodings + AdobeStandardEncoding + nextstep + gsm0338 # used in GSM handsets + hp-roman8 + +=head1 DESCRIPTION + +To find how to use this module in detail, see L<Encode>. + +=head1 SEE ALSO + +L<Encode> + +=cut diff --git a/Master/tlpkg/installer/perllib/Encode/Config.pm b/Master/tlpkg/installer/perllib/Encode/Config.pm new file mode 100644 index 00000000000..d69b92d8248 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Encode/Config.pm @@ -0,0 +1,166 @@ +# +# Demand-load module list +# +package Encode::Config; +our $VERSION = do { my @r = (q$Revision: 2.1 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; + +use strict; + +our %ExtModule = + ( + # Encode::Byte + #iso-8859-1 is in Encode.pm itself + 'iso-8859-2' => 'Encode::Byte', + 'iso-8859-3' => 'Encode::Byte', + 'iso-8859-4' => 'Encode::Byte', + 'iso-8859-5' => 'Encode::Byte', + 'iso-8859-6' => 'Encode::Byte', + 'iso-8859-7' => 'Encode::Byte', + 'iso-8859-8' => 'Encode::Byte', + 'iso-8859-9' => 'Encode::Byte', + 'iso-8859-10' => 'Encode::Byte', + 'iso-8859-11' => 'Encode::Byte', + 'iso-8859-13' => 'Encode::Byte', + 'iso-8859-14' => 'Encode::Byte', + 'iso-8859-15' => 'Encode::Byte', + 'iso-8859-16' => 'Encode::Byte', + 'koi8-f' => 'Encode::Byte', + 'koi8-r' => 'Encode::Byte', + 'koi8-u' => 'Encode::Byte', + 'viscii' => 'Encode::Byte', + 'cp424' => 'Encode::Byte', + 'cp437' => 'Encode::Byte', + 'cp737' => 'Encode::Byte', + 'cp775' => 'Encode::Byte', + 'cp850' => 'Encode::Byte', + 'cp852' => 'Encode::Byte', + 'cp855' => 'Encode::Byte', + 'cp856' => 'Encode::Byte', + 'cp857' => 'Encode::Byte', + 'cp860' => 'Encode::Byte', + 'cp861' => 'Encode::Byte', + 'cp862' => 'Encode::Byte', + 'cp863' => 'Encode::Byte', + 'cp864' => 'Encode::Byte', + 'cp865' => 'Encode::Byte', + 'cp866' => 'Encode::Byte', + 'cp869' => 'Encode::Byte', + 'cp874' => 'Encode::Byte', + 'cp1006' => 'Encode::Byte', + 'cp1250' => 'Encode::Byte', + 'cp1251' => 'Encode::Byte', + 'cp1252' => 'Encode::Byte', + 'cp1253' => 'Encode::Byte', + 'cp1254' => 'Encode::Byte', + 'cp1255' => 'Encode::Byte', + 'cp1256' => 'Encode::Byte', + 'cp1257' => 'Encode::Byte', + 'cp1258' => 'Encode::Byte', + 'AdobeStandardEncoding' => 'Encode::Byte', + 'MacArabic' => 'Encode::Byte', + 'MacCentralEurRoman' => 'Encode::Byte', + 'MacCroatian' => 'Encode::Byte', + 'MacCyrillic' => 'Encode::Byte', + 'MacFarsi' => 'Encode::Byte', + 'MacGreek' => 'Encode::Byte', + 'MacHebrew' => 'Encode::Byte', + 'MacIcelandic' => 'Encode::Byte', + 'MacRoman' => 'Encode::Byte', + 'MacRomanian' => 'Encode::Byte', + 'MacRumanian' => 'Encode::Byte', + 'MacSami' => 'Encode::Byte', + 'MacThai' => 'Encode::Byte', + 'MacTurkish' => 'Encode::Byte', + 'MacUkrainian' => 'Encode::Byte', + 'nextstep' => 'Encode::Byte', + 'hp-roman8' => 'Encode::Byte', + 'gsm0338' => 'Encode::Byte', + # Encode::EBCDIC + 'cp37' => 'Encode::EBCDIC', + 'cp500' => 'Encode::EBCDIC', + 'cp875' => 'Encode::EBCDIC', + 'cp1026' => 'Encode::EBCDIC', + 'cp1047' => 'Encode::EBCDIC', + 'posix-bc' => 'Encode::EBCDIC', + # Encode::Symbol + 'dingbats' => 'Encode::Symbol', + 'symbol' => 'Encode::Symbol', + 'AdobeSymbol' => 'Encode::Symbol', + 'AdobeZdingbat' => 'Encode::Symbol', + 'MacDingbats' => 'Encode::Symbol', + 'MacSymbol' => 'Encode::Symbol', + # Encode::Unicode + 'UCS-2BE' => 'Encode::Unicode', + 'UCS-2LE' => 'Encode::Unicode', + 'UTF-16' => 'Encode::Unicode', + 'UTF-16BE' => 'Encode::Unicode', + 'UTF-16LE' => 'Encode::Unicode', + 'UTF-32' => 'Encode::Unicode', + 'UTF-32BE' => 'Encode::Unicode', + 'UTF-32LE' => 'Encode::Unicode', + 'UTF-7' => 'Encode::Unicode::UTF7', + ); + +unless (ord("A") == 193){ + %ExtModule = + ( + %ExtModule, + 'euc-cn' => 'Encode::CN', + 'gb12345-raw' => 'Encode::CN', + 'gb2312-raw' => 'Encode::CN', + 'hz' => 'Encode::CN', + 'iso-ir-165' => 'Encode::CN', + 'cp936' => 'Encode::CN', + 'MacChineseSimp' => 'Encode::CN', + + '7bit-jis' => 'Encode::JP', + 'euc-jp' => 'Encode::JP', + 'iso-2022-jp' => 'Encode::JP', + 'iso-2022-jp-1' => 'Encode::JP', + 'jis0201-raw' => 'Encode::JP', + 'jis0208-raw' => 'Encode::JP', + 'jis0212-raw' => 'Encode::JP', + 'cp932' => 'Encode::JP', + 'MacJapanese' => 'Encode::JP', + 'shiftjis' => 'Encode::JP', + + + 'euc-kr' => 'Encode::KR', + 'iso-2022-kr' => 'Encode::KR', + 'johab' => 'Encode::KR', + 'ksc5601-raw' => 'Encode::KR', + 'cp949' => 'Encode::KR', + 'MacKorean' => 'Encode::KR', + + 'big5-eten' => 'Encode::TW', + 'big5-hkscs' => 'Encode::TW', + 'cp950' => 'Encode::TW', + 'MacChineseTrad' => 'Encode::TW', + + #'big5plus' => 'Encode::HanExtra', + #'euc-tw' => 'Encode::HanExtra', + #'gb18030' => 'Encode::HanExtra', + + 'MIME-Header' => 'Encode::MIME::Header', + 'MIME-B' => 'Encode::MIME::Header', + 'MIME-Q' => 'Encode::MIME::Header', + + 'MIME-Header-ISO_2022_JP' => 'Encode::MIME::Header::ISO_2022_JP', + ); +} + +# +# Why not export ? to keep ConfigLocal Happy! +# +while (my ($enc,$mod) = each %ExtModule){ + $Encode::ExtModule{$enc} = $mod; +} + +1; +__END__ + +=head1 NAME + +Encode::Config -- internally used by Encode + +=cut diff --git a/Master/tlpkg/installer/perllib/Encode/Encoding.pm b/Master/tlpkg/installer/perllib/Encode/Encoding.pm new file mode 100644 index 00000000000..06af9fb6994 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Encode/Encoding.pm @@ -0,0 +1,341 @@ +package Encode::Encoding; +# Base class for classes which implement encodings +use strict; +our $VERSION = do { my @r = (q$Revision: 2.2 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; + +require Encode; + +sub DEBUG { 0 } +sub Define +{ + my $obj = shift; + my $canonical = shift; + $obj = bless { Name => $canonical },$obj unless ref $obj; + # warn "$canonical => $obj\n"; + Encode::define_encoding($obj, $canonical, @_); +} + +sub name { return shift->{'Name'} } + +# sub renew { return $_[0] } + +sub renew { + my $self = shift; + my $clone = bless { %$self } => ref($self); + $clone->{renewed}++; # so the caller can see it + DEBUG and warn $clone->{renewed}; + return $clone; +} + +sub renewed{ return $_[0]->{renewed} || 0 } + +*new_sequence = \&renew; + +sub needs_lines { 0 }; + +sub perlio_ok { + eval{ require PerlIO::encoding }; + return $@ ? 0 : 1; +} + +# (Temporary|legacy) methods + +sub toUnicode { shift->decode(@_) } +sub fromUnicode { shift->encode(@_) } + +# +# Needs to be overloaded or just croak +# + +sub encode { + require Carp; + my $obj = shift; + my $class = ref($obj) ? ref($obj) : $obj; + Carp::croak($class . "->encode() not defined!"); +} + +sub decode{ + require Carp; + my $obj = shift; + my $class = ref($obj) ? ref($obj) : $obj; + Carp::croak($class . "->encode() not defined!"); +} + +sub DESTROY {} + +1; +__END__ + +=head1 NAME + +Encode::Encoding - Encode Implementation Base Class + +=head1 SYNOPSIS + + package Encode::MyEncoding; + use base qw(Encode::Encoding); + + __PACKAGE__->Define(qw(myCanonical myAlias)); + +=head1 DESCRIPTION + +As mentioned in L<Encode>, encodings are (in the current +implementation at least) defined as objects. The mapping of encoding +name to object is via the C<%Encode::Encoding> hash. Though you can +directly manipulate this hash, it is strongly encouraged to use this +base class module and add encode() and decode() methods. + +=head2 Methods you should implement + +You are strongly encouraged to implement methods below, at least +either encode() or decode(). + +=over 4 + +=item -E<gt>encode($string [,$check]) + +MUST return the octet sequence representing I<$string>. + +=over 2 + +=item * + +If I<$check> is true, it SHOULD modify I<$string> in place to remove +the converted part (i.e. the whole string unless there is an error). +If perlio_ok() is true, SHOULD becomes MUST. + +=item * + +If an error occurs, it SHOULD return the octet sequence for the +fragment of string that has been converted and modify $string in-place +to remove the converted part leaving it starting with the problem +fragment. If perlio_ok() is true, SHOULD becomes MUST. + +=item * + +If I<$check> is is false then C<encode> MUST make a "best effort" to +convert the string - for example, by using a replacement character. + +=back + +=item -E<gt>decode($octets [,$check]) + +MUST return the string that I<$octets> represents. + +=over 2 + +=item * + +If I<$check> is true, it SHOULD modify I<$octets> in place to remove +the converted part (i.e. the whole sequence unless there is an +error). If perlio_ok() is true, SHOULD becomes MUST. + +=item * + +If an error occurs, it SHOULD return the fragment of string that has +been converted and modify $octets in-place to remove the converted +part leaving it starting with the problem fragment. If perlio_ok() is +true, SHOULD becomes MUST. + +=item * + +If I<$check> is false then C<decode> should make a "best effort" to +convert the string - for example by using Unicode's "\x{FFFD}" as a +replacement character. + +=back + +=back + +If you want your encoding to work with L<encoding> pragma, you should +also implement the method below. + +=over 4 + +=item -E<gt>cat_decode($destination, $octets, $offset, $terminator [,$check]) + +MUST decode I<$octets> with I<$offset> and concatenate it to I<$destination>. +Decoding will terminate when $terminator (a string) appears in output. +I<$offset> will be modified to the last $octets position at end of decode. +Returns true if $terminator appears output, else returns false. + +=back + +=head2 Other methods defined in Encode::Encodings + +You do not have to override methods shown below unless you have to. + +=over 4 + +=item -E<gt>name + +Predefined As: + + sub name { return shift->{'Name'} } + +MUST return the string representing the canonical name of the encoding. + +=item -E<gt>renew + +Predefined As: + + sub renew { + my $self = shift; + my $clone = bless { %$self } => ref($self); + $clone->{renewed}++; + return $clone; + } + +This method reconstructs the encoding object if necessary. If you need +to store the state during encoding, this is where you clone your object. + +PerlIO ALWAYS calls this method to make sure it has its own private +encoding object. + +=item -E<gt>renewed + +Predefined As: + + sub renewed { $_[0]->{renewed} || 0 } + +Tells whether the object is renewed (and how many times). Some +modules emit C<Use of uninitialized value in null operation> warning +unless the value is numeric so return 0 for false. + +=item -E<gt>perlio_ok() + +Predefined As: + + sub perlio_ok { + eval{ require PerlIO::encoding }; + return $@ ? 0 : 1; + } + +If your encoding does not support PerlIO for some reasons, just; + + sub perlio_ok { 0 } + +=item -E<gt>needs_lines() + +Predefined As: + + sub needs_lines { 0 }; + +If your encoding can work with PerlIO but needs line buffering, you +MUST define this method so it returns true. 7bit ISO-2022 encodings +are one example that needs this. When this method is missing, false +is assumed. + +=back + +=head2 Example: Encode::ROT13 + + package Encode::ROT13; + use strict; + use base qw(Encode::Encoding); + + __PACKAGE__->Define('rot13'); + + sub encode($$;$){ + my ($obj, $str, $chk) = @_; + $str =~ tr/A-Za-z/N-ZA-Mn-za-m/; + $_[1] = '' if $chk; # this is what in-place edit means + return $str; + } + + # Jr pna or ynml yvxr guvf; + *decode = \&encode; + + 1; + +=head1 Why the heck Encode API is different? + +It should be noted that the I<$check> behaviour is different from the +outer public API. The logic is that the "unchecked" case is useful +when the encoding is part of a stream which may be reporting errors +(e.g. STDERR). In such cases, it is desirable to get everything +through somehow without causing additional errors which obscure the +original one. Also, the encoding is best placed to know what the +correct replacement character is, so if that is the desired behaviour +then letting low level code do it is the most efficient. + +By contrast, if I<$check> is true, the scheme above allows the +encoding to do as much as it can and tell the layer above how much +that was. What is lacking at present is a mechanism to report what +went wrong. The most likely interface will be an additional method +call to the object, or perhaps (to avoid forcing per-stream objects +on otherwise stateless encodings) an additional parameter. + +It is also highly desirable that encoding classes inherit from +C<Encode::Encoding> as a base class. This allows that class to define +additional behaviour for all encoding objects. + + package Encode::MyEncoding; + use base qw(Encode::Encoding); + + __PACKAGE__->Define(qw(myCanonical myAlias)); + +to create an object with C<< bless {Name => ...}, $class >>, and call +define_encoding. They inherit their C<name> method from +C<Encode::Encoding>. + +=head2 Compiled Encodings + +For the sake of speed and efficiency, most of the encodings are now +supported via a I<compiled form>: XS modules generated from UCM +files. Encode provides the enc2xs tool to achieve that. Please see +L<enc2xs> for more details. + +=head1 SEE ALSO + +L<perlmod>, L<enc2xs> + +=begin future + +=over 4 + +=item Scheme 1 + +The fixup routine gets passed the remaining fragment of string being +processed. It modifies it in place to remove bytes/characters it can +understand and returns a string used to represent them. For example: + + sub fixup { + my $ch = substr($_[0],0,1,''); + return sprintf("\x{%02X}",ord($ch); + } + +This scheme is close to how the underlying C code for Encode works, +but gives the fixup routine very little context. + +=item Scheme 2 + +The fixup routine gets passed the original string, an index into +it of the problem area, and the output string so far. It appends +what it wants to the output string and returns a new index into the +original string. For example: + + sub fixup { + # my ($s,$i,$d) = @_; + my $ch = substr($_[0],$_[1],1); + $_[2] .= sprintf("\x{%02X}",ord($ch); + return $_[1]+1; + } + +This scheme gives maximal control to the fixup routine but is more +complicated to code, and may require that the internals of Encode be tweaked to +keep the original string intact. + +=item Other Schemes + +Hybrids of the above. + +Multiple return values rather than in-place modifications. + +Index into the string could be C<pos($str)> allowing C<s/\G...//>. + +=back + +=end future + +=cut diff --git a/Master/tlpkg/installer/perllib/Encode/Unicode.pm b/Master/tlpkg/installer/perllib/Encode/Unicode.pm new file mode 100644 index 00000000000..4d0c31d82d3 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Encode/Unicode.pm @@ -0,0 +1,268 @@ +package Encode::Unicode; + +use strict; +use warnings; +no warnings 'redefine'; + +our $VERSION = do { my @r = (q$Revision: 2.2 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; + +use XSLoader; +XSLoader::load(__PACKAGE__,$VERSION); + +# +# Object Generator 8 transcoders all at once! +# + +require Encode; + +our %BOM_Unknown = map {$_ => 1} qw(UTF-16 UTF-32); + +for my $name (qw(UTF-16 UTF-16BE UTF-16LE + UTF-32 UTF-32BE UTF-32LE + UCS-2BE UCS-2LE)) +{ + my ($size, $endian, $ucs2, $mask); + $name =~ /^(\w+)-(\d+)(\w*)$/o; + if ($ucs2 = ($1 eq 'UCS')){ + $size = 2; + }else{ + $size = $2/8; + } + $endian = ($3 eq 'BE') ? 'n' : ($3 eq 'LE') ? 'v' : '' ; + $size == 4 and $endian = uc($endian); + + $Encode::Encoding{$name} = + bless { + Name => $name, + size => $size, + endian => $endian, + ucs2 => $ucs2, + } => __PACKAGE__; +} + +use base qw(Encode::Encoding); + +sub renew { + my $self = shift; + $BOM_Unknown{$self->name} or return $self; + my $clone = bless { %$self } => ref($self); + $clone->{renewed}++; # so the caller knows it is renewed. + return $clone; +} + +# There used to be a perl implemntation of (en|de)code but with +# XS version is ripe, perl version is zapped for optimal speed + +*decode = \&decode_xs; +*encode = \&encode_xs; + +1; +__END__ + +=head1 NAME + +Encode::Unicode -- Various Unicode Transformation Formats + +=cut + +=head1 SYNOPSIS + + use Encode qw/encode decode/; + $ucs2 = encode("UCS-2BE", $utf8); + $utf8 = decode("UCS-2BE", $ucs2); + +=head1 ABSTRACT + +This module implements all Character Encoding Schemes of Unicode that +are officially documented by Unicode Consortium (except, of course, +for UTF-8, which is a native format in perl). + +=over 4 + +=item L<http://www.unicode.org/glossary/> says: + +I<Character Encoding Scheme> A character encoding form plus byte +serialization. There are Seven character encoding schemes in Unicode: +UTF-8, UTF-16, UTF-16BE, UTF-16LE, UTF-32 (UCS-4), UTF-32BE (UCS-4BE) and +UTF-32LE (UCS-4LE), and UTF-7. + +Since UTF-7 is a 7-bit (re)encoded version of UTF-16BE, It is not part of +Unicode's Character Encoding Scheme. It is separately implemented in +Encode::Unicode::UTF7. For details see L<Encode::Unicode::UTF7>. + +=item Quick Reference + + Decodes from ord(N) Encodes chr(N) to... + octet/char BOM S.P d800-dfff ord > 0xffff \x{1abcd} == + ---------------+-----------------+------------------------------ + UCS-2BE 2 N N is bogus Not Available + UCS-2LE 2 N N bogus Not Available + UTF-16 2/4 Y Y is S.P S.P BE/LE + UTF-16BE 2/4 N Y S.P S.P 0xd82a,0xdfcd + UTF-16LE 2 N Y S.P S.P 0x2ad8,0xcddf + UTF-32 4 Y - is bogus As is BE/LE + UTF-32BE 4 N - bogus As is 0x0001abcd + UTF-32LE 4 N - bogus As is 0xcdab0100 + UTF-8 1-4 - - bogus >= 4 octets \xf0\x9a\af\8d + ---------------+-----------------+------------------------------ + +=back + +=head1 Size, Endianness, and BOM + +You can categorize these CES by 3 criteria: size of each character, +endianness, and Byte Order Mark. + +=head2 by size + +UCS-2 is a fixed-length encoding with each character taking 16 bits. +It B<does not> support I<surrogate pairs>. When a surrogate pair +is encountered during decode(), its place is filled with \x{FFFD} +if I<CHECK> is 0, or the routine croaks if I<CHECK> is 1. When a +character whose ord value is larger than 0xFFFF is encountered, +its place is filled with \x{FFFD} if I<CHECK> is 0, or the routine +croaks if I<CHECK> is 1. + +UTF-16 is almost the same as UCS-2 but it supports I<surrogate pairs>. +When it encounters a high surrogate (0xD800-0xDBFF), it fetches the +following low surrogate (0xDC00-0xDFFF) and C<desurrogate>s them to +form a character. Bogus surrogates result in death. When \x{10000} +or above is encountered during encode(), it C<ensurrogate>s them and +pushes the surrogate pair to the output stream. + +UTF-32 (UCS-4) is a fixed-length encoding with each character taking 32 bits. +Since it is 32-bit, there is no need for I<surrogate pairs>. + +=head2 by endianness + +The first (and now failed) goal of Unicode was to map all character +repertoires into a fixed-length integer so that programmers are happy. +Since each character is either a I<short> or I<long> in C, you have to +pay attention to the endianness of each platform when you pass data +to one another. + +Anything marked as BE is Big Endian (or network byte order) and LE is +Little Endian (aka VAX byte order). For anything not marked either +BE or LE, a character called Byte Order Mark (BOM) indicating the +endianness is prepended to the string. + +CAVEAT: Though BOM in utf8 (\xEF\xBB\xBF) is valid, it is meaningless +and as of this writing Encode suite just leave it as is (\x{FeFF}). + +=over 4 + +=item BOM as integer when fetched in network byte order + + 16 32 bits/char + ------------------------- + BE 0xFeFF 0x0000FeFF + LE 0xFFeF 0xFFFe0000 + ------------------------- + +=back + +This modules handles the BOM as follows. + +=over 4 + +=item * + +When BE or LE is explicitly stated as the name of encoding, BOM is +simply treated as a normal character (ZERO WIDTH NO-BREAK SPACE). + +=item * + +When BE or LE is omitted during decode(), it checks if BOM is at the +beginning of the string; if one is found, the endianness is set to +what the BOM says. If no BOM is found, the routine dies. + +=item * + +When BE or LE is omitted during encode(), it returns a BE-encoded +string with BOM prepended. So when you want to encode a whole text +file, make sure you encode() the whole text at once, not line by line +or each line, not file, will have a BOM prepended. + +=item * + +C<UCS-2> is an exception. Unlike others, this is an alias of UCS-2BE. +UCS-2 is already registered by IANA and others that way. + +=back + +=head1 Surrogate Pairs + +To say the least, surrogate pairs were the biggest mistake of the +Unicode Consortium. But according to the late Douglas Adams in I<The +Hitchhiker's Guide to the Galaxy> Trilogy, C<In the beginning the +Universe was created. This has made a lot of people very angry and +been widely regarded as a bad move>. Their mistake was not of this +magnitude so let's forgive them. + +(I don't dare make any comparison with Unicode Consortium and the +Vogons here ;) Or, comparing Encode to Babel Fish is completely +appropriate -- if you can only stick this into your ear :) + +Surrogate pairs were born when the Unicode Consortium finally +admitted that 16 bits were not big enough to hold all the world's +character repertoires. But they already made UCS-2 16-bit. What +do we do? + +Back then, the range 0xD800-0xDFFF was not allocated. Let's split +that range in half and use the first half to represent the C<upper +half of a character> and the second half to represent the C<lower +half of a character>. That way, you can represent 1024 * 1024 = +1048576 more characters. Now we can store character ranges up to +\x{10ffff} even with 16-bit encodings. This pair of half-character is +now called a I<surrogate pair> and UTF-16 is the name of the encoding +that embraces them. + +Here is a formula to ensurrogate a Unicode character \x{10000} and +above; + + $hi = ($uni - 0x10000) / 0x400 + 0xD800; + $lo = ($uni - 0x10000) % 0x400 + 0xDC00; + +And to desurrogate; + + $uni = 0x10000 + ($hi - 0xD800) * 0x400 + ($lo - 0xDC00); + +Note this move has made \x{D800}-\x{DFFF} into a forbidden zone but +perl does not prohibit the use of characters within this range. To perl, +every one of \x{0000_0000} up to \x{ffff_ffff} (*) is I<a character>. + + (*) or \x{ffff_ffff_ffff_ffff} if your perl is compiled with 64-bit + integer support! + +=head1 Error Checking + +Unlike most encodings which accept various ways to handle errors, +Unicode encodings simply croaks. + + % perl -MEncode -e '$_ = "\xfe\xff\xd8\xd9\xda\xdb\0\n"' \ + -e 'Encode::from_to($_, "utf16","shift_jis", 0); print' + UTF-16:Malformed LO surrogate d8d9 at /path/to/Encode.pm line 184. + % perl -MEncode -e '$a = "BOM missing"' \ + -e ' Encode::from_to($a, "utf16", "shift_jis", 0); print' + UTF-16:Unrecognised BOM 424f at /path/to/Encode.pm line 184. + +Unlike other encodings where mappings are not one-to-one against +Unicode, UTFs are supposed to map 100% against one another. So Encode +is more strict on UTFs. + +Consider that "division by zero" of Encode :) + +=head1 SEE ALSO + +L<Encode>, L<Encode::Unicode::UTF7>, L<http://www.unicode.org/glossary/>, +L<http://www.unicode.org/unicode/faq/utf_bom.html>, + +RFC 2781 L<http://rfc.net/rfc2781.html>, + +The whole Unicode standard L<http://www.unicode.org/unicode/uni2book/u2.html> + +Ch. 15, pp. 403 of C<Programming Perl (3rd Edition)> +by Larry Wall, Tom Christiansen, Jon Orwant; +O'Reilly & Associates; ISBN 0-596-00027-8 + +=cut diff --git a/Master/tlpkg/installer/perllib/Exporter.pm b/Master/tlpkg/installer/perllib/Exporter.pm new file mode 100644 index 00000000000..d9c22049776 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Exporter.pm @@ -0,0 +1,440 @@ +package Exporter; + +require 5.006; + +# Be lean. +#use strict; +#no strict 'refs'; + +our $Debug = 0; +our $ExportLevel = 0; +our $Verbose ||= 0; +our $VERSION = '5.58'; +our (%Cache); +$Carp::Internal{Exporter} = 1; + +sub as_heavy { + require Exporter::Heavy; + # Unfortunately, this does not work if the caller is aliased as *name = \&foo + # Thus the need to create a lot of identical subroutines + my $c = (caller(1))[3]; + $c =~ s/.*:://; + \&{"Exporter::Heavy::heavy_$c"}; +} + +sub export { + goto &{as_heavy()}; +} + +sub import { + my $pkg = shift; + my $callpkg = caller($ExportLevel); + + if ($pkg eq "Exporter" and @_ and $_[0] eq "import") { + *{$callpkg."::import"} = \&import; + return; + } + + # We *need* to treat @{"$pkg\::EXPORT_FAIL"} since Carp uses it :-( + my($exports, $fail) = (\@{"$pkg\::EXPORT"}, \@{"$pkg\::EXPORT_FAIL"}); + return export $pkg, $callpkg, @_ + if $Verbose or $Debug or @$fail > 1; + my $export_cache = ($Cache{$pkg} ||= {}); + my $args = @_ or @_ = @$exports; + + local $_; + if ($args and not %$export_cache) { + s/^&//, $export_cache->{$_} = 1 + foreach (@$exports, @{"$pkg\::EXPORT_OK"}); + } + my $heavy; + # Try very hard not to use {} and hence have to enter scope on the foreach + # We bomb out of the loop with last as soon as heavy is set. + if ($args or $fail) { + ($heavy = (/\W/ or $args and not exists $export_cache->{$_} + or @$fail and $_ eq $fail->[0])) and last + foreach (@_); + } else { + ($heavy = /\W/) and last + foreach (@_); + } + return export $pkg, $callpkg, ($args ? @_ : ()) if $heavy; + local $SIG{__WARN__} = + sub {require Carp; &Carp::carp}; + # shortcut for the common case of no type character + *{"$callpkg\::$_"} = \&{"$pkg\::$_"} foreach @_; +} + +# Default methods + +sub export_fail { + my $self = shift; + @_; +} + +# Unfortunately, caller(1)[3] "does not work" if the caller is aliased as +# *name = \&foo. Thus the need to create a lot of identical subroutines +# Otherwise we could have aliased them to export(). + +sub export_to_level { + goto &{as_heavy()}; +} + +sub export_tags { + goto &{as_heavy()}; +} + +sub export_ok_tags { + goto &{as_heavy()}; +} + +sub require_version { + goto &{as_heavy()}; +} + +1; +__END__ + +=head1 NAME + +Exporter - Implements default import method for modules + +=head1 SYNOPSIS + +In module YourModule.pm: + + package YourModule; + require Exporter; + @ISA = qw(Exporter); + @EXPORT_OK = qw(munge frobnicate); # symbols to export on request + +or + + package YourModule; + use Exporter 'import'; # gives you Exporter's import() method directly + @EXPORT_OK = qw(munge frobnicate); # symbols to export on request + +In other files which wish to use YourModule: + + use ModuleName qw(frobnicate); # import listed symbols + frobnicate ($left, $right) # calls YourModule::frobnicate + +=head1 DESCRIPTION + +The Exporter module implements an C<import> method which allows a module +to export functions and variables to its users' namespaces. Many modules +use Exporter rather than implementing their own C<import> method because +Exporter provides a highly flexible interface, with an implementation optimised +for the common case. + +Perl automatically calls the C<import> method when processing a +C<use> statement for a module. Modules and C<use> are documented +in L<perlfunc> and L<perlmod>. Understanding the concept of +modules and how the C<use> statement operates is important to +understanding the Exporter. + +=head2 How to Export + +The arrays C<@EXPORT> and C<@EXPORT_OK> in a module hold lists of +symbols that are going to be exported into the users name space by +default, or which they can request to be exported, respectively. The +symbols can represent functions, scalars, arrays, hashes, or typeglobs. +The symbols must be given by full name with the exception that the +ampersand in front of a function is optional, e.g. + + @EXPORT = qw(afunc $scalar @array); # afunc is a function + @EXPORT_OK = qw(&bfunc %hash *typeglob); # explicit prefix on &bfunc + +If you are only exporting function names it is recommended to omit the +ampersand, as the implementation is faster this way. + +=head2 Selecting What To Export + +Do B<not> export method names! + +Do B<not> export anything else by default without a good reason! + +Exports pollute the namespace of the module user. If you must export +try to use @EXPORT_OK in preference to @EXPORT and avoid short or +common symbol names to reduce the risk of name clashes. + +Generally anything not exported is still accessible from outside the +module using the ModuleName::item_name (or $blessed_ref-E<gt>method) +syntax. By convention you can use a leading underscore on names to +informally indicate that they are 'internal' and not for public use. + +(It is actually possible to get private functions by saying: + + my $subref = sub { ... }; + $subref->(@args); # Call it as a function + $obj->$subref(@args); # Use it as a method + +However if you use them for methods it is up to you to figure out +how to make inheritance work.) + +As a general rule, if the module is trying to be object oriented +then export nothing. If it's just a collection of functions then +@EXPORT_OK anything but use @EXPORT with caution. For function and +method names use barewords in preference to names prefixed with +ampersands for the export lists. + +Other module design guidelines can be found in L<perlmod>. + +=head2 How to Import + +In other files which wish to use your module there are three basic ways for +them to load your module and import its symbols: + +=over 4 + +=item C<use ModuleName;> + +This imports all the symbols from ModuleName's @EXPORT into the namespace +of the C<use> statement. + +=item C<use ModuleName ();> + +This causes perl to load your module but does not import any symbols. + +=item C<use ModuleName qw(...);> + +This imports only the symbols listed by the caller into their namespace. +All listed symbols must be in your @EXPORT or @EXPORT_OK, else an error +occurs. The advanced export features of Exporter are accessed like this, +but with list entries that are syntactically distinct from symbol names. + +=back + +Unless you want to use its advanced features, this is probably all you +need to know to use Exporter. + +=head1 Advanced features + +=head2 Specialised Import Lists + +If any of the entries in an import list begins with !, : or / then +the list is treated as a series of specifications which either add to +or delete from the list of names to import. They are processed left to +right. Specifications are in the form: + + [!]name This name only + [!]:DEFAULT All names in @EXPORT + [!]:tag All names in $EXPORT_TAGS{tag} anonymous list + [!]/pattern/ All names in @EXPORT and @EXPORT_OK which match + +A leading ! indicates that matching names should be deleted from the +list of names to import. If the first specification is a deletion it +is treated as though preceded by :DEFAULT. If you just want to import +extra names in addition to the default set you will still need to +include :DEFAULT explicitly. + +e.g., Module.pm defines: + + @EXPORT = qw(A1 A2 A3 A4 A5); + @EXPORT_OK = qw(B1 B2 B3 B4 B5); + %EXPORT_TAGS = (T1 => [qw(A1 A2 B1 B2)], T2 => [qw(A1 A2 B3 B4)]); + + Note that you cannot use tags in @EXPORT or @EXPORT_OK. + Names in EXPORT_TAGS must also appear in @EXPORT or @EXPORT_OK. + +An application using Module can say something like: + + use Module qw(:DEFAULT :T2 !B3 A3); + +Other examples include: + + use Socket qw(!/^[AP]F_/ !SOMAXCONN !SOL_SOCKET); + use POSIX qw(:errno_h :termios_h !TCSADRAIN !/^EXIT/); + +Remember that most patterns (using //) will need to be anchored +with a leading ^, e.g., C</^EXIT/> rather than C</EXIT/>. + +You can say C<BEGIN { $Exporter::Verbose=1 }> to see how the +specifications are being processed and what is actually being imported +into modules. + +=head2 Exporting without using Exporter's import method + +Exporter has a special method, 'export_to_level' which is used in situations +where you can't directly call Exporter's import method. The export_to_level +method looks like: + + MyPackage->export_to_level($where_to_export, $package, @what_to_export); + +where $where_to_export is an integer telling how far up the calling stack +to export your symbols, and @what_to_export is an array telling what +symbols *to* export (usually this is @_). The $package argument is +currently unused. + +For example, suppose that you have a module, A, which already has an +import function: + + package A; + + @ISA = qw(Exporter); + @EXPORT_OK = qw ($b); + + sub import + { + $A::b = 1; # not a very useful import method + } + +and you want to Export symbol $A::b back to the module that called +package A. Since Exporter relies on the import method to work, via +inheritance, as it stands Exporter::import() will never get called. +Instead, say the following: + + package A; + @ISA = qw(Exporter); + @EXPORT_OK = qw ($b); + + sub import + { + $A::b = 1; + A->export_to_level(1, @_); + } + +This will export the symbols one level 'above' the current package - ie: to +the program or module that used package A. + +Note: Be careful not to modify C<@_> at all before you call export_to_level +- or people using your package will get very unexplained results! + +=head2 Exporting without inheriting from Exporter + +By including Exporter in your @ISA you inherit an Exporter's import() method +but you also inherit several other helper methods which you probably don't +want. To avoid this you can do + + package YourModule; + use Exporter qw( import ); + +which will export Exporter's own import() method into YourModule. +Everything will work as before but you won't need to include Exporter in +@YourModule::ISA. + +=head2 Module Version Checking + +The Exporter module will convert an attempt to import a number from a +module into a call to $module_name-E<gt>require_version($value). This can +be used to validate that the version of the module being used is +greater than or equal to the required version. + +The Exporter module supplies a default require_version method which +checks the value of $VERSION in the exporting module. + +Since the default require_version method treats the $VERSION number as +a simple numeric value it will regard version 1.10 as lower than +1.9. For this reason it is strongly recommended that you use numbers +with at least two decimal places, e.g., 1.09. + +=head2 Managing Unknown Symbols + +In some situations you may want to prevent certain symbols from being +exported. Typically this applies to extensions which have functions +or constants that may not exist on some systems. + +The names of any symbols that cannot be exported should be listed +in the C<@EXPORT_FAIL> array. + +If a module attempts to import any of these symbols the Exporter +will give the module an opportunity to handle the situation before +generating an error. The Exporter will call an export_fail method +with a list of the failed symbols: + + @failed_symbols = $module_name->export_fail(@failed_symbols); + +If the export_fail method returns an empty list then no error is +recorded and all the requested symbols are exported. If the returned +list is not empty then an error is generated for each symbol and the +export fails. The Exporter provides a default export_fail method which +simply returns the list unchanged. + +Uses for the export_fail method include giving better error messages +for some symbols and performing lazy architectural checks (put more +symbols into @EXPORT_FAIL by default and then take them out if someone +actually tries to use them and an expensive check shows that they are +usable on that platform). + +=head2 Tag Handling Utility Functions + +Since the symbols listed within %EXPORT_TAGS must also appear in either +@EXPORT or @EXPORT_OK, two utility functions are provided which allow +you to easily add tagged sets of symbols to @EXPORT or @EXPORT_OK: + + %EXPORT_TAGS = (foo => [qw(aa bb cc)], bar => [qw(aa cc dd)]); + + Exporter::export_tags('foo'); # add aa, bb and cc to @EXPORT + Exporter::export_ok_tags('bar'); # add aa, cc and dd to @EXPORT_OK + +Any names which are not tags are added to @EXPORT or @EXPORT_OK +unchanged but will trigger a warning (with C<-w>) to avoid misspelt tags +names being silently added to @EXPORT or @EXPORT_OK. Future versions +may make this a fatal error. + +=head2 Generating combined tags + +If several symbol categories exist in %EXPORT_TAGS, it's usually +useful to create the utility ":all" to simplify "use" statements. + +The simplest way to do this is: + + %EXPORT_TAGS = (foo => [qw(aa bb cc)], bar => [qw(aa cc dd)]); + + # add all the other ":class" tags to the ":all" class, + # deleting duplicates + { + my %seen; + + push @{$EXPORT_TAGS{all}}, + grep {!$seen{$_}++} @{$EXPORT_TAGS{$_}} foreach keys %EXPORT_TAGS; + } + +CGI.pm creates an ":all" tag which contains some (but not really +all) of its categories. That could be done with one small +change: + + # add some of the other ":class" tags to the ":all" class, + # deleting duplicates + { + my %seen; + + push @{$EXPORT_TAGS{all}}, + grep {!$seen{$_}++} @{$EXPORT_TAGS{$_}} + foreach qw/html2 html3 netscape form cgi internal/; + } + +Note that the tag names in %EXPORT_TAGS don't have the leading ':'. + +=head2 C<AUTOLOAD>ed Constants + +Many modules make use of C<AUTOLOAD>ing for constant subroutines to +avoid having to compile and waste memory on rarely used values (see +L<perlsub> for details on constant subroutines). Calls to such +constant subroutines are not optimized away at compile time because +they can't be checked at compile time for constancy. + +Even if a prototype is available at compile time, the body of the +subroutine is not (it hasn't been C<AUTOLOAD>ed yet). perl needs to +examine both the C<()> prototype and the body of a subroutine at +compile time to detect that it can safely replace calls to that +subroutine with the constant value. + +A workaround for this is to call the constants once in a C<BEGIN> block: + + package My ; + + use Socket ; + + foo( SO_LINGER ); ## SO_LINGER NOT optimized away; called at runtime + BEGIN { SO_LINGER } + foo( SO_LINGER ); ## SO_LINGER optimized away at compile time. + +This forces the C<AUTOLOAD> for C<SO_LINGER> to take place before +SO_LINGER is encountered later in C<My> package. + +If you are writing a package that C<AUTOLOAD>s, consider forcing +an C<AUTOLOAD> for any constants explicitly imported by other packages +or which are usually used when your package is C<use>d. + +=cut diff --git a/Master/tlpkg/installer/perllib/Exporter/Heavy.pm b/Master/tlpkg/installer/perllib/Exporter/Heavy.pm new file mode 100644 index 00000000000..2cc792288f0 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Exporter/Heavy.pm @@ -0,0 +1,248 @@ +package Exporter::Heavy; + +use strict; +no strict 'refs'; + +# On one line so MakeMaker will see it. +require Exporter; our $VERSION = $Exporter::VERSION; +$Carp::Internal{"Exporter::Heavy"} = 1; + +=head1 NAME + +Exporter::Heavy - Exporter guts + +=head1 SYNOPSIS + +(internal use only) + +=head1 DESCRIPTION + +No user-serviceable parts inside. + +=cut + +# +# We go to a lot of trouble not to 'require Carp' at file scope, +# because Carp requires Exporter, and something has to give. +# + +sub _rebuild_cache { + my ($pkg, $exports, $cache) = @_; + s/^&// foreach @$exports; + @{$cache}{@$exports} = (1) x @$exports; + my $ok = \@{"${pkg}::EXPORT_OK"}; + if (@$ok) { + s/^&// foreach @$ok; + @{$cache}{@$ok} = (1) x @$ok; + } +} + +sub heavy_export { + + # First make import warnings look like they're coming from the "use". + local $SIG{__WARN__} = sub { + my $text = shift; + if ($text =~ s/ at \S*Exporter\S*.pm line \d+.*\n//) { + require Carp; + local $Carp::CarpLevel = 1; # ignore package calling us too. + Carp::carp($text); + } + else { + warn $text; + } + }; + local $SIG{__DIE__} = sub { + require Carp; + local $Carp::CarpLevel = 1; # ignore package calling us too. + Carp::croak("$_[0]Illegal null symbol in \@${1}::EXPORT") + if $_[0] =~ /^Unable to create sub named "(.*?)::"/; + }; + + my($pkg, $callpkg, @imports) = @_; + my($type, $sym, $cache_is_current, $oops); + my($exports, $export_cache) = (\@{"${pkg}::EXPORT"}, + $Exporter::Cache{$pkg} ||= {}); + + if (@imports) { + if (!%$export_cache) { + _rebuild_cache ($pkg, $exports, $export_cache); + $cache_is_current = 1; + } + + if (grep m{^[/!:]}, @imports) { + my $tagsref = \%{"${pkg}::EXPORT_TAGS"}; + my $tagdata; + my %imports; + my($remove, $spec, @names, @allexports); + # negated first item implies starting with default set: + unshift @imports, ':DEFAULT' if $imports[0] =~ m/^!/; + foreach $spec (@imports){ + $remove = $spec =~ s/^!//; + + if ($spec =~ s/^://){ + if ($spec eq 'DEFAULT'){ + @names = @$exports; + } + elsif ($tagdata = $tagsref->{$spec}) { + @names = @$tagdata; + } + else { + warn qq["$spec" is not defined in %${pkg}::EXPORT_TAGS]; + ++$oops; + next; + } + } + elsif ($spec =~ m:^/(.*)/$:){ + my $patn = $1; + @allexports = keys %$export_cache unless @allexports; # only do keys once + @names = grep(/$patn/, @allexports); # not anchored by default + } + else { + @names = ($spec); # is a normal symbol name + } + + warn "Import ".($remove ? "del":"add").": @names " + if $Exporter::Verbose; + + if ($remove) { + foreach $sym (@names) { delete $imports{$sym} } + } + else { + @imports{@names} = (1) x @names; + } + } + @imports = keys %imports; + } + + my @carp; + foreach $sym (@imports) { + if (!$export_cache->{$sym}) { + if ($sym =~ m/^\d/) { + $pkg->VERSION($sym); # inherit from UNIVERSAL + # If the version number was the only thing specified + # then we should act as if nothing was specified: + if (@imports == 1) { + @imports = @$exports; + last; + } + # We need a way to emulate 'use Foo ()' but still + # allow an easy version check: "use Foo 1.23, ''"; + if (@imports == 2 and !$imports[1]) { + @imports = (); + last; + } + } elsif ($sym !~ s/^&// || !$export_cache->{$sym}) { + # Last chance - see if they've updated EXPORT_OK since we + # cached it. + + unless ($cache_is_current) { + %$export_cache = (); + _rebuild_cache ($pkg, $exports, $export_cache); + $cache_is_current = 1; + } + + if (!$export_cache->{$sym}) { + # accumulate the non-exports + push @carp, + qq["$sym" is not exported by the $pkg module\n]; + $oops++; + } + } + } + } + if ($oops) { + require Carp; + Carp::croak("@{carp}Can't continue after import errors"); + } + } + else { + @imports = @$exports; + } + + my($fail, $fail_cache) = (\@{"${pkg}::EXPORT_FAIL"}, + $Exporter::FailCache{$pkg} ||= {}); + + if (@$fail) { + if (!%$fail_cache) { + # Build cache of symbols. Optimise the lookup by adding + # barewords twice... both with and without a leading &. + # (Technique could be applied to $export_cache at cost of memory) + my @expanded = map { /^\w/ ? ($_, '&'.$_) : $_ } @$fail; + warn "${pkg}::EXPORT_FAIL cached: @expanded" if $Exporter::Verbose; + @{$fail_cache}{@expanded} = (1) x @expanded; + } + my @failed; + foreach $sym (@imports) { push(@failed, $sym) if $fail_cache->{$sym} } + if (@failed) { + @failed = $pkg->export_fail(@failed); + foreach $sym (@failed) { + require Carp; + Carp::carp(qq["$sym" is not implemented by the $pkg module ], + "on this architecture"); + } + if (@failed) { + require Carp; + Carp::croak("Can't continue after import errors"); + } + } + } + + warn "Importing into $callpkg from $pkg: ", + join(", ",sort @imports) if $Exporter::Verbose; + + foreach $sym (@imports) { + # shortcut for the common case of no type character + (*{"${callpkg}::$sym"} = \&{"${pkg}::$sym"}, next) + unless $sym =~ s/^(\W)//; + $type = $1; + *{"${callpkg}::$sym"} = + $type eq '&' ? \&{"${pkg}::$sym"} : + $type eq '$' ? \${"${pkg}::$sym"} : + $type eq '@' ? \@{"${pkg}::$sym"} : + $type eq '%' ? \%{"${pkg}::$sym"} : + $type eq '*' ? *{"${pkg}::$sym"} : + do { require Carp; Carp::croak("Can't export symbol: $type$sym") }; + } +} + +sub heavy_export_to_level +{ + my $pkg = shift; + my $level = shift; + (undef) = shift; # XXX redundant arg + my $callpkg = caller($level); + $pkg->export($callpkg, @_); +} + +# Utility functions + +sub _push_tags { + my($pkg, $var, $syms) = @_; + my @nontag = (); + my $export_tags = \%{"${pkg}::EXPORT_TAGS"}; + push(@{"${pkg}::$var"}, + map { $export_tags->{$_} ? @{$export_tags->{$_}} + : scalar(push(@nontag,$_),$_) } + (@$syms) ? @$syms : keys %$export_tags); + if (@nontag and $^W) { + # This may change to a die one day + require Carp; + Carp::carp(join(", ", @nontag)." are not tags of $pkg"); + } +} + +sub heavy_require_version { + my($self, $wanted) = @_; + my $pkg = ref $self || $self; + return ${pkg}->VERSION($wanted); +} + +sub heavy_export_tags { + _push_tags((caller)[0], "EXPORT", \@_); +} + +sub heavy_export_ok_tags { + _push_tags((caller)[0], "EXPORT_OK", \@_); +} + +1; diff --git a/Master/tlpkg/installer/perllib/Getopt/Long.pm b/Master/tlpkg/installer/perllib/Getopt/Long.pm new file mode 100644 index 00000000000..04038db58e3 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Getopt/Long.pm @@ -0,0 +1,2504 @@ +# Getopt::Long.pm -- Universal options parsing + +package Getopt::Long; + +# RCS Status : $Id: GetoptLong.pm,v 2.72 2005-04-28 21:18:33+02 jv Exp $ +# Author : Johan Vromans +# Created On : Tue Sep 11 15:00:12 1990 +# Last Modified By: Johan Vromans +# Last Modified On: Wed Dec 14 21:17:21 2005 +# Update Count : 1458 +# Status : Released + +################ Copyright ################ + +# This program is Copyright 1990,2005 by Johan Vromans. +# This program is free software; you can redistribute it and/or +# modify it under the terms of the Perl Artistic License or the +# GNU General Public License as published by the Free Software +# Foundation; either version 2 of the License, or (at your option) any +# later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# If you do not have a copy of the GNU General Public License write to +# the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, +# MA 02139, USA. + +################ Module Preamble ################ + +use 5.004; + +use strict; + +use vars qw($VERSION); +$VERSION = 2.35; +# For testing versions only. +#use vars qw($VERSION_STRING); +#$VERSION_STRING = "2.35"; + +use Exporter; +use vars qw(@ISA @EXPORT @EXPORT_OK); +@ISA = qw(Exporter); + +# Exported subroutines. +sub GetOptions(@); # always +sub Configure(@); # on demand +sub HelpMessage(@); # on demand +sub VersionMessage(@); # in demand + +BEGIN { + # Init immediately so their contents can be used in the 'use vars' below. + @EXPORT = qw(&GetOptions $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER); + @EXPORT_OK = qw(&HelpMessage &VersionMessage &Configure); +} + +# User visible variables. +use vars @EXPORT, @EXPORT_OK; +use vars qw($error $debug $major_version $minor_version); +# Deprecated visible variables. +use vars qw($autoabbrev $getopt_compat $ignorecase $bundling $order + $passthrough); +# Official invisible variables. +use vars qw($genprefix $caller $gnu_compat $auto_help $auto_version $longprefix); + +# Public subroutines. +sub config(@); # deprecated name + +# Private subroutines. +sub ConfigDefaults(); +sub ParseOptionSpec($$); +sub OptCtl($); +sub FindOption($$$$); +sub ValidValue ($$$$$); + +################ Local Variables ################ + +# $requested_version holds the version that was mentioned in the 'use' +# or 'require', if any. It can be used to enable or disable specific +# features. +my $requested_version = 0; + +################ Resident subroutines ################ + +sub ConfigDefaults() { + # Handle POSIX compliancy. + if ( defined $ENV{"POSIXLY_CORRECT"} ) { + $genprefix = "(--|-)"; + $autoabbrev = 0; # no automatic abbrev of options + $bundling = 0; # no bundling of single letter switches + $getopt_compat = 0; # disallow '+' to start options + $order = $REQUIRE_ORDER; + } + else { + $genprefix = "(--|-|\\+)"; + $autoabbrev = 1; # automatic abbrev of options + $bundling = 0; # bundling off by default + $getopt_compat = 1; # allow '+' to start options + $order = $PERMUTE; + } + # Other configurable settings. + $debug = 0; # for debugging + $error = 0; # error tally + $ignorecase = 1; # ignore case when matching options + $passthrough = 0; # leave unrecognized options alone + $gnu_compat = 0; # require --opt=val if value is optional + $longprefix = "(--)"; # what does a long prefix look like +} + +# Override import. +sub import { + my $pkg = shift; # package + my @syms = (); # symbols to import + my @config = (); # configuration + my $dest = \@syms; # symbols first + for ( @_ ) { + if ( $_ eq ':config' ) { + $dest = \@config; # config next + next; + } + push(@$dest, $_); # push + } + # Hide one level and call super. + local $Exporter::ExportLevel = 1; + push(@syms, qw(&GetOptions)) if @syms; # always export GetOptions + $pkg->SUPER::import(@syms); + # And configure. + Configure(@config) if @config; +} + +################ Initialization ################ + +# Values for $order. See GNU getopt.c for details. +($REQUIRE_ORDER, $PERMUTE, $RETURN_IN_ORDER) = (0..2); +# Version major/minor numbers. +($major_version, $minor_version) = $VERSION =~ /^(\d+)\.(\d+)/; + +ConfigDefaults(); + +################ OO Interface ################ + +package Getopt::Long::Parser; + +# Store a copy of the default configuration. Since ConfigDefaults has +# just been called, what we get from Configure is the default. +my $default_config = do { + Getopt::Long::Configure () +}; + +sub new { + my $that = shift; + my $class = ref($that) || $that; + my %atts = @_; + + # Register the callers package. + my $self = { caller_pkg => (caller)[0] }; + + bless ($self, $class); + + # Process config attributes. + if ( defined $atts{config} ) { + my $save = Getopt::Long::Configure ($default_config, @{$atts{config}}); + $self->{settings} = Getopt::Long::Configure ($save); + delete ($atts{config}); + } + # Else use default config. + else { + $self->{settings} = $default_config; + } + + if ( %atts ) { # Oops + die(__PACKAGE__.": unhandled attributes: ". + join(" ", sort(keys(%atts)))."\n"); + } + + $self; +} + +sub configure { + my ($self) = shift; + + # Restore settings, merge new settings in. + my $save = Getopt::Long::Configure ($self->{settings}, @_); + + # Restore orig config and save the new config. + $self->{settings} = Getopt::Long::Configure ($save); +} + +sub getoptions { + my ($self) = shift; + + # Restore config settings. + my $save = Getopt::Long::Configure ($self->{settings}); + + # Call main routine. + my $ret = 0; + $Getopt::Long::caller = $self->{caller_pkg}; + + eval { + # Locally set exception handler to default, otherwise it will + # be called implicitly here, and again explicitly when we try + # to deliver the messages. + local ($SIG{__DIE__}) = '__DEFAULT__'; + $ret = Getopt::Long::GetOptions (@_); + }; + + # Restore saved settings. + Getopt::Long::Configure ($save); + + # Handle errors and return value. + die ($@) if $@; + return $ret; +} + +package Getopt::Long; + +################ Back to Normal ################ + +# Indices in option control info. +# Note that ParseOptions uses the fields directly. Search for 'hard-wired'. +use constant CTL_TYPE => 0; +#use constant CTL_TYPE_FLAG => ''; +#use constant CTL_TYPE_NEG => '!'; +#use constant CTL_TYPE_INCR => '+'; +#use constant CTL_TYPE_INT => 'i'; +#use constant CTL_TYPE_INTINC => 'I'; +#use constant CTL_TYPE_XINT => 'o'; +#use constant CTL_TYPE_FLOAT => 'f'; +#use constant CTL_TYPE_STRING => 's'; + +use constant CTL_CNAME => 1; + +use constant CTL_DEFAULT => 2; + +use constant CTL_DEST => 3; + use constant CTL_DEST_SCALAR => 0; + use constant CTL_DEST_ARRAY => 1; + use constant CTL_DEST_HASH => 2; + use constant CTL_DEST_CODE => 3; + +use constant CTL_AMIN => 4; +use constant CTL_AMAX => 5; + +# FFU. +#use constant CTL_RANGE => ; +#use constant CTL_REPEAT => ; + +sub GetOptions(@) { + + my @optionlist = @_; # local copy of the option descriptions + my $argend = '--'; # option list terminator + my %opctl = (); # table of option specs + my $pkg = $caller || (caller)[0]; # current context + # Needed if linkage is omitted. + my @ret = (); # accum for non-options + my %linkage; # linkage + my $userlinkage; # user supplied HASH + my $opt; # current option + my $prefix = $genprefix; # current prefix + + $error = ''; + + if ( $debug ) { + # Avoid some warnings if debugging. + local ($^W) = 0; + print STDERR + ("Getopt::Long $Getopt::Long::VERSION (", + '$Revision: 2.72 $', ") ", + "called from package \"$pkg\".", + "\n ", + "ARGV: (@ARGV)", + "\n ", + "autoabbrev=$autoabbrev,". + "bundling=$bundling,", + "getopt_compat=$getopt_compat,", + "gnu_compat=$gnu_compat,", + "order=$order,", + "\n ", + "ignorecase=$ignorecase,", + "requested_version=$requested_version,", + "passthrough=$passthrough,", + "genprefix=\"$genprefix\",", + "longprefix=\"$longprefix\".", + "\n"); + } + + # Check for ref HASH as first argument. + # First argument may be an object. It's OK to use this as long + # as it is really a hash underneath. + $userlinkage = undef; + if ( @optionlist && ref($optionlist[0]) and + UNIVERSAL::isa($optionlist[0],'HASH') ) { + $userlinkage = shift (@optionlist); + print STDERR ("=> user linkage: $userlinkage\n") if $debug; + } + + # See if the first element of the optionlist contains option + # starter characters. + # Be careful not to interpret '<>' as option starters. + if ( @optionlist && $optionlist[0] =~ /^\W+$/ + && !($optionlist[0] eq '<>' + && @optionlist > 0 + && ref($optionlist[1])) ) { + $prefix = shift (@optionlist); + # Turn into regexp. Needs to be parenthesized! + $prefix =~ s/(\W)/\\$1/g; + $prefix = "([" . $prefix . "])"; + print STDERR ("=> prefix=\"$prefix\"\n") if $debug; + } + + # Verify correctness of optionlist. + %opctl = (); + while ( @optionlist ) { + my $opt = shift (@optionlist); + + unless ( defined($opt) ) { + $error .= "Undefined argument in option spec\n"; + next; + } + + # Strip leading prefix so people can specify "--foo=i" if they like. + $opt = $+ if $opt =~ /^$prefix+(.*)$/s; + + if ( $opt eq '<>' ) { + if ( (defined $userlinkage) + && !(@optionlist > 0 && ref($optionlist[0])) + && (exists $userlinkage->{$opt}) + && ref($userlinkage->{$opt}) ) { + unshift (@optionlist, $userlinkage->{$opt}); + } + unless ( @optionlist > 0 + && ref($optionlist[0]) && ref($optionlist[0]) eq 'CODE' ) { + $error .= "Option spec <> requires a reference to a subroutine\n"; + # Kill the linkage (to avoid another error). + shift (@optionlist) + if @optionlist && ref($optionlist[0]); + next; + } + $linkage{'<>'} = shift (@optionlist); + next; + } + + # Parse option spec. + my ($name, $orig) = ParseOptionSpec ($opt, \%opctl); + unless ( defined $name ) { + # Failed. $orig contains the error message. Sorry for the abuse. + $error .= $orig; + # Kill the linkage (to avoid another error). + shift (@optionlist) + if @optionlist && ref($optionlist[0]); + next; + } + + # If no linkage is supplied in the @optionlist, copy it from + # the userlinkage if available. + if ( defined $userlinkage ) { + unless ( @optionlist > 0 && ref($optionlist[0]) ) { + if ( exists $userlinkage->{$orig} && + ref($userlinkage->{$orig}) ) { + print STDERR ("=> found userlinkage for \"$orig\": ", + "$userlinkage->{$orig}\n") + if $debug; + unshift (@optionlist, $userlinkage->{$orig}); + } + else { + # Do nothing. Being undefined will be handled later. + next; + } + } + } + + # Copy the linkage. If omitted, link to global variable. + if ( @optionlist > 0 && ref($optionlist[0]) ) { + print STDERR ("=> link \"$orig\" to $optionlist[0]\n") + if $debug; + my $rl = ref($linkage{$orig} = shift (@optionlist)); + + if ( $rl eq "ARRAY" ) { + $opctl{$name}[CTL_DEST] = CTL_DEST_ARRAY; + } + elsif ( $rl eq "HASH" ) { + $opctl{$name}[CTL_DEST] = CTL_DEST_HASH; + } + elsif ( $rl eq "SCALAR" ) { +# if ( $opctl{$name}[CTL_DEST] == CTL_DEST_ARRAY ) { +# my $t = $linkage{$orig}; +# $$t = $linkage{$orig} = []; +# } +# elsif ( $opctl{$name}[CTL_DEST] == CTL_DEST_HASH ) { +# } +# else { + # Ok. +# } + } + elsif ( $rl eq "CODE" ) { + # Ok. + } + else { + $error .= "Invalid option linkage for \"$opt\"\n"; + } + } + else { + # Link to global $opt_XXX variable. + # Make sure a valid perl identifier results. + my $ov = $orig; + $ov =~ s/\W/_/g; + if ( $opctl{$name}[CTL_DEST] == CTL_DEST_ARRAY ) { + print STDERR ("=> link \"$orig\" to \@$pkg","::opt_$ov\n") + if $debug; + eval ("\$linkage{\$orig} = \\\@".$pkg."::opt_$ov;"); + } + elsif ( $opctl{$name}[CTL_DEST] == CTL_DEST_HASH ) { + print STDERR ("=> link \"$orig\" to \%$pkg","::opt_$ov\n") + if $debug; + eval ("\$linkage{\$orig} = \\\%".$pkg."::opt_$ov;"); + } + else { + print STDERR ("=> link \"$orig\" to \$$pkg","::opt_$ov\n") + if $debug; + eval ("\$linkage{\$orig} = \\\$".$pkg."::opt_$ov;"); + } + } + } + + # Bail out if errors found. + die ($error) if $error; + $error = 0; + + # Supply --version and --help support, if needed and allowed. + if ( defined($auto_version) ? $auto_version : ($requested_version >= 2.3203) ) { + if ( !defined($opctl{version}) ) { + $opctl{version} = ['','version',0,CTL_DEST_CODE,undef]; + $linkage{version} = \&VersionMessage; + } + $auto_version = 1; + } + if ( defined($auto_help) ? $auto_help : ($requested_version >= 2.3203) ) { + if ( !defined($opctl{help}) && !defined($opctl{'?'}) ) { + $opctl{help} = $opctl{'?'} = ['','help',0,CTL_DEST_CODE,undef]; + $linkage{help} = \&HelpMessage; + } + $auto_help = 1; + } + + # Show the options tables if debugging. + if ( $debug ) { + my ($arrow, $k, $v); + $arrow = "=> "; + while ( ($k,$v) = each(%opctl) ) { + print STDERR ($arrow, "\$opctl{$k} = $v ", OptCtl($v), "\n"); + $arrow = " "; + } + } + + # Process argument list + my $goon = 1; + while ( $goon && @ARGV > 0 ) { + + # Get next argument. + $opt = shift (@ARGV); + print STDERR ("=> arg \"", $opt, "\"\n") if $debug; + + # Double dash is option list terminator. + if ( $opt eq $argend ) { + push (@ret, $argend) if $passthrough; + last; + } + + # Look it up. + my $tryopt = $opt; + my $found; # success status + my $key; # key (if hash type) + my $arg; # option argument + my $ctl; # the opctl entry + + ($found, $opt, $ctl, $arg, $key) = + FindOption ($prefix, $argend, $opt, \%opctl); + + if ( $found ) { + + # FindOption undefines $opt in case of errors. + next unless defined $opt; + + my $argcnt = 0; + while ( defined $arg ) { + + # Get the canonical name. + print STDERR ("=> cname for \"$opt\" is ") if $debug; + $opt = $ctl->[CTL_CNAME]; + print STDERR ("\"$ctl->[CTL_CNAME]\"\n") if $debug; + + if ( defined $linkage{$opt} ) { + print STDERR ("=> ref(\$L{$opt}) -> ", + ref($linkage{$opt}), "\n") if $debug; + + if ( ref($linkage{$opt}) eq 'SCALAR' ) { + if ( $ctl->[CTL_TYPE] eq '+' ) { + print STDERR ("=> \$\$L{$opt} += \"$arg\"\n") + if $debug; + if ( defined ${$linkage{$opt}} ) { + ${$linkage{$opt}} += $arg; + } + else { + ${$linkage{$opt}} = $arg; + } + } + elsif ( $ctl->[CTL_DEST] == CTL_DEST_ARRAY ) { + print STDERR ("=> ref(\$L{$opt}) auto-vivified", + " to ARRAY\n") + if $debug; + my $t = $linkage{$opt}; + $$t = $linkage{$opt} = []; + print STDERR ("=> push(\@{\$L{$opt}, \"$arg\")\n") + if $debug; + push (@{$linkage{$opt}}, $arg); + } + elsif ( $ctl->[CTL_DEST] == CTL_DEST_HASH ) { + print STDERR ("=> ref(\$L{$opt}) auto-vivified", + " to HASH\n") + if $debug; + my $t = $linkage{$opt}; + $$t = $linkage{$opt} = {}; + print STDERR ("=> \$\$L{$opt}->{$key} = \"$arg\"\n") + if $debug; + $linkage{$opt}->{$key} = $arg; + } + else { + print STDERR ("=> \$\$L{$opt} = \"$arg\"\n") + if $debug; + ${$linkage{$opt}} = $arg; + } + } + elsif ( ref($linkage{$opt}) eq 'ARRAY' ) { + print STDERR ("=> push(\@{\$L{$opt}, \"$arg\")\n") + if $debug; + push (@{$linkage{$opt}}, $arg); + } + elsif ( ref($linkage{$opt}) eq 'HASH' ) { + print STDERR ("=> \$\$L{$opt}->{$key} = \"$arg\"\n") + if $debug; + $linkage{$opt}->{$key} = $arg; + } + elsif ( ref($linkage{$opt}) eq 'CODE' ) { + print STDERR ("=> &L{$opt}(\"$opt\"", + $ctl->[CTL_DEST] == CTL_DEST_HASH ? ", \"$key\"" : "", + ", \"$arg\")\n") + if $debug; + my $eval_error = do { + local $@; + local $SIG{__DIE__} = '__DEFAULT__'; + eval { + &{$linkage{$opt}}($opt, + $ctl->[CTL_DEST] == CTL_DEST_HASH ? ($key) : (), + $arg); + }; + $@; + }; + print STDERR ("=> die($eval_error)\n") + if $debug && $eval_error ne ''; + if ( $eval_error =~ /^!/ ) { + if ( $eval_error =~ /^!FINISH\b/ ) { + $goon = 0; + } + } + elsif ( $eval_error ne '' ) { + warn ($eval_error); + $error++; + } + } + else { + print STDERR ("Invalid REF type \"", ref($linkage{$opt}), + "\" in linkage\n"); + die("Getopt::Long -- internal error!\n"); + } + } + # No entry in linkage means entry in userlinkage. + elsif ( $ctl->[CTL_DEST] == CTL_DEST_ARRAY ) { + if ( defined $userlinkage->{$opt} ) { + print STDERR ("=> push(\@{\$L{$opt}}, \"$arg\")\n") + if $debug; + push (@{$userlinkage->{$opt}}, $arg); + } + else { + print STDERR ("=>\$L{$opt} = [\"$arg\"]\n") + if $debug; + $userlinkage->{$opt} = [$arg]; + } + } + elsif ( $ctl->[CTL_DEST] == CTL_DEST_HASH ) { + if ( defined $userlinkage->{$opt} ) { + print STDERR ("=> \$L{$opt}->{$key} = \"$arg\"\n") + if $debug; + $userlinkage->{$opt}->{$key} = $arg; + } + else { + print STDERR ("=>\$L{$opt} = {$key => \"$arg\"}\n") + if $debug; + $userlinkage->{$opt} = {$key => $arg}; + } + } + else { + if ( $ctl->[CTL_TYPE] eq '+' ) { + print STDERR ("=> \$L{$opt} += \"$arg\"\n") + if $debug; + if ( defined $userlinkage->{$opt} ) { + $userlinkage->{$opt} += $arg; + } + else { + $userlinkage->{$opt} = $arg; + } + } + else { + print STDERR ("=>\$L{$opt} = \"$arg\"\n") if $debug; + $userlinkage->{$opt} = $arg; + } + } + + $argcnt++; + last if $argcnt >= $ctl->[CTL_AMAX] && $ctl->[CTL_AMAX] != -1; + undef($arg); + + # Need more args? + if ( $argcnt < $ctl->[CTL_AMIN] ) { + if ( @ARGV ) { + if ( ValidValue($ctl, $ARGV[0], 1, $argend, $prefix) ) { + $arg = shift(@ARGV); + ($key,$arg) = $arg =~ /^([^=]+)=(.*)/ + if $ctl->[CTL_DEST] == CTL_DEST_HASH; + next; + } + warn("Value \"$ARGV[0]\" invalid for option $opt\n"); + $error++; + } + else { + warn("Insufficient arguments for option $opt\n"); + $error++; + } + } + + # Any more args? + if ( @ARGV && ValidValue($ctl, $ARGV[0], 0, $argend, $prefix) ) { + $arg = shift(@ARGV); + ($key,$arg) = $arg =~ /^([^=]+)=(.*)/ + if $ctl->[CTL_DEST] == CTL_DEST_HASH; + next; + } + } + } + + # Not an option. Save it if we $PERMUTE and don't have a <>. + elsif ( $order == $PERMUTE ) { + # Try non-options call-back. + my $cb; + if ( (defined ($cb = $linkage{'<>'})) ) { + print STDERR ("=> &L{$tryopt}(\"$tryopt\")\n") + if $debug; + my $eval_error = do { + local $@; + local $SIG{__DIE__} = '__DEFAULT__'; + eval { &$cb ($tryopt) }; + $@; + }; + print STDERR ("=> die($eval_error)\n") + if $debug && $eval_error ne ''; + if ( $eval_error =~ /^!/ ) { + if ( $eval_error =~ /^!FINISH\b/ ) { + $goon = 0; + } + } + elsif ( $eval_error ne '' ) { + warn ($eval_error); + $error++; + } + } + else { + print STDERR ("=> saving \"$tryopt\" ", + "(not an option, may permute)\n") if $debug; + push (@ret, $tryopt); + } + next; + } + + # ...otherwise, terminate. + else { + # Push this one back and exit. + unshift (@ARGV, $tryopt); + return ($error == 0); + } + + } + + # Finish. + if ( @ret && $order == $PERMUTE ) { + # Push back accumulated arguments + print STDERR ("=> restoring \"", join('" "', @ret), "\"\n") + if $debug; + unshift (@ARGV, @ret); + } + + return ($error == 0); +} + +# A readable representation of what's in an optbl. +sub OptCtl ($) { + my ($v) = @_; + my @v = map { defined($_) ? ($_) : ("<undef>") } @$v; + "[". + join(",", + "\"$v[CTL_TYPE]\"", + "\"$v[CTL_CNAME]\"", + "\"$v[CTL_DEFAULT]\"", + ("\$","\@","\%","\&")[$v[CTL_DEST] || 0], + $v[CTL_AMIN] || '', + $v[CTL_AMAX] || '', +# $v[CTL_RANGE] || '', +# $v[CTL_REPEAT] || '', + ). "]"; +} + +# Parse an option specification and fill the tables. +sub ParseOptionSpec ($$) { + my ($opt, $opctl) = @_; + + # Match option spec. + if ( $opt !~ m;^ + ( + # Option name + (?: \w+[-\w]* ) + # Alias names, or "?" + (?: \| (?: \? | \w[-\w]* )? )* + )? + ( + # Either modifiers ... + [!+] + | + # ... or a value/dest/repeat specification + [=:] [ionfs] [@%]? (?: \{\d*,?\d*\} )? + | + # ... or an optional-with-default spec + : (?: -?\d+ | \+ ) [@%]? + )? + $;x ) { + return (undef, "Error in option spec: \"$opt\"\n"); + } + + my ($names, $spec) = ($1, $2); + $spec = '' unless defined $spec; + + # $orig keeps track of the primary name the user specified. + # This name will be used for the internal or external linkage. + # In other words, if the user specifies "FoO|BaR", it will + # match any case combinations of 'foo' and 'bar', but if a global + # variable needs to be set, it will be $opt_FoO in the exact case + # as specified. + my $orig; + + my @names; + if ( defined $names ) { + @names = split (/\|/, $names); + $orig = $names[0]; + } + else { + @names = (''); + $orig = ''; + } + + # Construct the opctl entries. + my $entry; + if ( $spec eq '' || $spec eq '+' || $spec eq '!' ) { + # Fields are hard-wired here. + $entry = [$spec,$orig,undef,CTL_DEST_SCALAR,0,0]; + } + elsif ( $spec =~ /^:(-?\d+|\+)([@%])?$/ ) { + my $def = $1; + my $dest = $2; + my $type = $def eq '+' ? 'I' : 'i'; + $dest ||= '$'; + $dest = $dest eq '@' ? CTL_DEST_ARRAY + : $dest eq '%' ? CTL_DEST_HASH : CTL_DEST_SCALAR; + # Fields are hard-wired here. + $entry = [$type,$orig,$def eq '+' ? undef : $def, + $dest,0,1]; + } + else { + my ($mand, $type, $dest) = + $spec =~ /^([=:])([ionfs])([@%])?(\{(\d+)?(,)?(\d+)?\})?$/; + return (undef, "Cannot repeat while bundling: \"$opt\"\n") + if $bundling && defined($4); + my ($mi, $cm, $ma) = ($5, $6, $7); + return (undef, "{0} is useless in option spec: \"$opt\"\n") + if defined($mi) && !$mi && !defined($ma) && !defined($cm); + + $type = 'i' if $type eq 'n'; + $dest ||= '$'; + $dest = $dest eq '@' ? CTL_DEST_ARRAY + : $dest eq '%' ? CTL_DEST_HASH : CTL_DEST_SCALAR; + # Default minargs to 1/0 depending on mand status. + $mi = $mand eq '=' ? 1 : 0 unless defined $mi; + # Adjust mand status according to minargs. + $mand = $mi ? '=' : ':'; + # Adjust maxargs. + $ma = $mi ? $mi : 1 unless defined $ma || defined $cm; + return (undef, "Max must be greater than zero in option spec: \"$opt\"\n") + if defined($ma) && !$ma; + return (undef, "Max less than min in option spec: \"$opt\"\n") + if defined($ma) && $ma < $mi; + + # Fields are hard-wired here. + $entry = [$type,$orig,undef,$dest,$mi,$ma||-1]; + } + + # Process all names. First is canonical, the rest are aliases. + my $dups = ''; + foreach ( @names ) { + + $_ = lc ($_) + if $ignorecase > (($bundling && length($_) == 1) ? 1 : 0); + + if ( exists $opctl->{$_} ) { + $dups .= "Duplicate specification \"$opt\" for option \"$_\"\n"; + } + + if ( $spec eq '!' ) { + $opctl->{"no$_"} = $entry; + $opctl->{"no-$_"} = $entry; + $opctl->{$_} = [@$entry]; + $opctl->{$_}->[CTL_TYPE] = ''; + } + else { + $opctl->{$_} = $entry; + } + } + + if ( $dups && $^W ) { + foreach ( split(/\n+/, $dups) ) { + warn($_."\n"); + } + } + ($names[0], $orig); +} + +# Option lookup. +sub FindOption ($$$$) { + + # returns (1, $opt, $ctl, $arg, $key) if okay, + # returns (1, undef) if option in error, + # returns (0) otherwise. + + my ($prefix, $argend, $opt, $opctl) = @_; + + print STDERR ("=> find \"$opt\"\n") if $debug; + + return (0) unless $opt =~ /^$prefix(.*)$/s; + return (0) if $opt eq "-" && !defined $opctl->{''}; + + $opt = $+; + my $starter = $1; + + print STDERR ("=> split \"$starter\"+\"$opt\"\n") if $debug; + + my $optarg; # value supplied with --opt=value + my $rest; # remainder from unbundling + + # If it is a long option, it may include the value. + # With getopt_compat, only if not bundling. + if ( ($starter=~/^$longprefix$/ + || ($getopt_compat && ($bundling == 0 || $bundling == 2))) + && $opt =~ /^([^=]+)=(.*)$/s ) { + $opt = $1; + $optarg = $2; + print STDERR ("=> option \"", $opt, + "\", optarg = \"$optarg\"\n") if $debug; + } + + #### Look it up ### + + my $tryopt = $opt; # option to try + + if ( $bundling && $starter eq '-' ) { + + # To try overrides, obey case ignore. + $tryopt = $ignorecase ? lc($opt) : $opt; + + # If bundling == 2, long options can override bundles. + if ( $bundling == 2 && length($tryopt) > 1 + && defined ($opctl->{$tryopt}) ) { + print STDERR ("=> $starter$tryopt overrides unbundling\n") + if $debug; + } + else { + $tryopt = $opt; + # Unbundle single letter option. + $rest = length ($tryopt) > 0 ? substr ($tryopt, 1) : ''; + $tryopt = substr ($tryopt, 0, 1); + $tryopt = lc ($tryopt) if $ignorecase > 1; + print STDERR ("=> $starter$tryopt unbundled from ", + "$starter$tryopt$rest\n") if $debug; + $rest = undef unless $rest ne ''; + } + } + + # Try auto-abbreviation. + elsif ( $autoabbrev ) { + # Sort the possible long option names. + my @names = sort(keys (%$opctl)); + # Downcase if allowed. + $opt = lc ($opt) if $ignorecase; + $tryopt = $opt; + # Turn option name into pattern. + my $pat = quotemeta ($opt); + # Look up in option names. + my @hits = grep (/^$pat/, @names); + print STDERR ("=> ", scalar(@hits), " hits (@hits) with \"$pat\" ", + "out of ", scalar(@names), "\n") if $debug; + + # Check for ambiguous results. + unless ( (@hits <= 1) || (grep ($_ eq $opt, @hits) == 1) ) { + # See if all matches are for the same option. + my %hit; + foreach ( @hits ) { + my $hit = $_; + $hit = $opctl->{$hit}->[CTL_CNAME] + if defined $opctl->{$hit}->[CTL_CNAME]; + $hit{$hit} = 1; + } + # Remove auto-supplied options (version, help). + if ( keys(%hit) == 2 ) { + if ( $auto_version && exists($hit{version}) ) { + delete $hit{version}; + } + elsif ( $auto_help && exists($hit{help}) ) { + delete $hit{help}; + } + } + # Now see if it really is ambiguous. + unless ( keys(%hit) == 1 ) { + return (0) if $passthrough; + warn ("Option ", $opt, " is ambiguous (", + join(", ", @hits), ")\n"); + $error++; + return (1, undef); + } + @hits = keys(%hit); + } + + # Complete the option name, if appropriate. + if ( @hits == 1 && $hits[0] ne $opt ) { + $tryopt = $hits[0]; + $tryopt = lc ($tryopt) if $ignorecase; + print STDERR ("=> option \"$opt\" -> \"$tryopt\"\n") + if $debug; + } + } + + # Map to all lowercase if ignoring case. + elsif ( $ignorecase ) { + $tryopt = lc ($opt); + } + + # Check validity by fetching the info. + my $ctl = $opctl->{$tryopt}; + unless ( defined $ctl ) { + return (0) if $passthrough; + # Pretend one char when bundling. + if ( $bundling == 1 && length($starter) == 1 ) { + $opt = substr($opt,0,1); + unshift (@ARGV, $starter.$rest) if defined $rest; + } + warn ("Unknown option: ", $opt, "\n"); + $error++; + return (1, undef); + } + # Apparently valid. + $opt = $tryopt; + print STDERR ("=> found ", OptCtl($ctl), + " for \"", $opt, "\"\n") if $debug; + + #### Determine argument status #### + + # If it is an option w/o argument, we're almost finished with it. + my $type = $ctl->[CTL_TYPE]; + my $arg; + + if ( $type eq '' || $type eq '!' || $type eq '+' ) { + if ( defined $optarg ) { + return (0) if $passthrough; + warn ("Option ", $opt, " does not take an argument\n"); + $error++; + undef $opt; + } + elsif ( $type eq '' || $type eq '+' ) { + # Supply explicit value. + $arg = 1; + } + else { + $opt =~ s/^no-?//i; # strip NO prefix + $arg = 0; # supply explicit value + } + unshift (@ARGV, $starter.$rest) if defined $rest; + return (1, $opt, $ctl, $arg); + } + + # Get mandatory status and type info. + my $mand = $ctl->[CTL_AMIN]; + + # Check if there is an option argument available. + if ( $gnu_compat && defined $optarg && $optarg eq '' ) { + return (1, $opt, $ctl, $type eq 's' ? '' : 0) unless $mand; + $optarg = 0 unless $type eq 's'; + } + + # Check if there is an option argument available. + if ( defined $optarg + ? ($optarg eq '') + : !(defined $rest || @ARGV > 0) ) { + # Complain if this option needs an argument. + if ( $mand ) { + return (0) if $passthrough; + warn ("Option ", $opt, " requires an argument\n"); + $error++; + return (1, undef); + } + if ( $type eq 'I' ) { + # Fake incremental type. + my @c = @$ctl; + $c[CTL_TYPE] = '+'; + return (1, $opt, \@c, 1); + } + return (1, $opt, $ctl, + defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] : + $type eq 's' ? '' : 0); + } + + # Get (possibly optional) argument. + $arg = (defined $rest ? $rest + : (defined $optarg ? $optarg : shift (@ARGV))); + + # Get key if this is a "name=value" pair for a hash option. + my $key; + if ($ctl->[CTL_DEST] == CTL_DEST_HASH && defined $arg) { + ($key, $arg) = ($arg =~ /^([^=]*)=(.*)$/s) ? ($1, $2) + : ($arg, defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] : + ($mand ? undef : ($type eq 's' ? "" : 1))); + if (! defined $arg) { + warn ("Option $opt, key \"$key\", requires a value\n"); + $error++; + # Push back. + unshift (@ARGV, $starter.$rest) if defined $rest; + return (1, undef); + } + } + + #### Check if the argument is valid for this option #### + + my $key_valid = $ctl->[CTL_DEST] == CTL_DEST_HASH ? "[^=]+=" : ""; + + if ( $type eq 's' ) { # string + # A mandatory string takes anything. + return (1, $opt, $ctl, $arg, $key) if $mand; + + # An optional string takes almost anything. + return (1, $opt, $ctl, $arg, $key) + if defined $optarg || defined $rest; + return (1, $opt, $ctl, $arg, $key) if $arg eq "-"; # ?? + + # Check for option or option list terminator. + if ($arg eq $argend || + $arg =~ /^$prefix.+/) { + # Push back. + unshift (@ARGV, $arg); + # Supply empty value. + $arg = ''; + } + } + + elsif ( $type eq 'i' # numeric/integer + || $type eq 'I' # numeric/integer w/ incr default + || $type eq 'o' ) { # dec/oct/hex/bin value + + my $o_valid = + $type eq 'o' ? "[-+]?[1-9][0-9]*|0x[0-9a-f]+|0b[01]+|0[0-7]*" + : "[-+]?[0-9]+"; + + if ( $bundling && defined $rest + && $rest =~ /^($key_valid)($o_valid)(.*)$/si ) { + ($key, $arg, $rest) = ($1, $2, $+); + chop($key) if $key; + $arg = ($type eq 'o' && $arg =~ /^0/) ? oct($arg) : 0+$arg; + unshift (@ARGV, $starter.$rest) if defined $rest && $rest ne ''; + } + elsif ( $arg =~ /^($o_valid)$/si ) { + $arg = ($type eq 'o' && $arg =~ /^0/) ? oct($arg) : 0+$arg; + } + else { + if ( defined $optarg || $mand ) { + if ( $passthrough ) { + unshift (@ARGV, defined $rest ? $starter.$rest : $arg) + unless defined $optarg; + return (0); + } + warn ("Value \"", $arg, "\" invalid for option ", + $opt, " (", + $type eq 'o' ? "extended " : '', + "number expected)\n"); + $error++; + # Push back. + unshift (@ARGV, $starter.$rest) if defined $rest; + return (1, undef); + } + else { + # Push back. + unshift (@ARGV, defined $rest ? $starter.$rest : $arg); + if ( $type eq 'I' ) { + # Fake incremental type. + my @c = @$ctl; + $c[CTL_TYPE] = '+'; + return (1, $opt, \@c, 1); + } + # Supply default value. + $arg = defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] : 0; + } + } + } + + elsif ( $type eq 'f' ) { # real number, int is also ok + # We require at least one digit before a point or 'e', + # and at least one digit following the point and 'e'. + # [-]NN[.NN][eNN] + if ( $bundling && defined $rest && + $rest =~ /^($key_valid)([-+]?[0-9]+(\.[0-9]+)?([eE][-+]?[0-9]+)?)(.*)$/s ) { + ($key, $arg, $rest) = ($1, $2, $+); + chop($key) if $key; + unshift (@ARGV, $starter.$rest) if defined $rest && $rest ne ''; + } + elsif ( $arg !~ /^[-+]?[0-9.]+(\.[0-9]+)?([eE][-+]?[0-9]+)?$/ ) { + if ( defined $optarg || $mand ) { + if ( $passthrough ) { + unshift (@ARGV, defined $rest ? $starter.$rest : $arg) + unless defined $optarg; + return (0); + } + warn ("Value \"", $arg, "\" invalid for option ", + $opt, " (real number expected)\n"); + $error++; + # Push back. + unshift (@ARGV, $starter.$rest) if defined $rest; + return (1, undef); + } + else { + # Push back. + unshift (@ARGV, defined $rest ? $starter.$rest : $arg); + # Supply default value. + $arg = 0.0; + } + } + } + else { + die("Getopt::Long internal error (Can't happen)\n"); + } + return (1, $opt, $ctl, $arg, $key); +} + +sub ValidValue ($$$$$) { + my ($ctl, $arg, $mand, $argend, $prefix) = @_; + + if ( $ctl->[CTL_DEST] == CTL_DEST_HASH ) { + return 0 unless $arg =~ /[^=]+=(.*)/; + $arg = $1; + } + + my $type = $ctl->[CTL_TYPE]; + + if ( $type eq 's' ) { # string + # A mandatory string takes anything. + return (1) if $mand; + + return (1) if $arg eq "-"; + + # Check for option or option list terminator. + return 0 if $arg eq $argend || $arg =~ /^$prefix.+/; + return 1; + } + + elsif ( $type eq 'i' # numeric/integer + || $type eq 'I' # numeric/integer w/ incr default + || $type eq 'o' ) { # dec/oct/hex/bin value + + my $o_valid = + $type eq 'o' ? "[-+]?[1-9][0-9]*|0x[0-9a-f]+|0b[01]+|0[0-7]*" + : "[-+]?[0-9]+"; + + return $arg =~ /^$o_valid$/si; + } + + elsif ( $type eq 'f' ) { # real number, int is also ok + # We require at least one digit before a point or 'e', + # and at least one digit following the point and 'e'. + # [-]NN[.NN][eNN] + return $arg =~ /^[-+]?[0-9.]+(\.[0-9]+)?([eE][-+]?[0-9]+)?$/; + } + die("ValidValue: Cannot happen\n"); +} + +# Getopt::Long Configuration. +sub Configure (@) { + my (@options) = @_; + + my $prevconfig = + [ $error, $debug, $major_version, $minor_version, + $autoabbrev, $getopt_compat, $ignorecase, $bundling, $order, + $gnu_compat, $passthrough, $genprefix, $auto_version, $auto_help, + $longprefix ]; + + if ( ref($options[0]) eq 'ARRAY' ) { + ( $error, $debug, $major_version, $minor_version, + $autoabbrev, $getopt_compat, $ignorecase, $bundling, $order, + $gnu_compat, $passthrough, $genprefix, $auto_version, $auto_help, + $longprefix ) = @{shift(@options)}; + } + + my $opt; + foreach $opt ( @options ) { + my $try = lc ($opt); + my $action = 1; + if ( $try =~ /^no_?(.*)$/s ) { + $action = 0; + $try = $+; + } + if ( ($try eq 'default' or $try eq 'defaults') && $action ) { + ConfigDefaults (); + } + elsif ( ($try eq 'posix_default' or $try eq 'posix_defaults') ) { + local $ENV{POSIXLY_CORRECT}; + $ENV{POSIXLY_CORRECT} = 1 if $action; + ConfigDefaults (); + } + elsif ( $try eq 'auto_abbrev' or $try eq 'autoabbrev' ) { + $autoabbrev = $action; + } + elsif ( $try eq 'getopt_compat' ) { + $getopt_compat = $action; + } + elsif ( $try eq 'gnu_getopt' ) { + if ( $action ) { + $gnu_compat = 1; + $bundling = 1; + $getopt_compat = 0; + $order = $PERMUTE; + } + } + elsif ( $try eq 'gnu_compat' ) { + $gnu_compat = $action; + } + elsif ( $try =~ /^(auto_?)?version$/ ) { + $auto_version = $action; + } + elsif ( $try =~ /^(auto_?)?help$/ ) { + $auto_help = $action; + } + elsif ( $try eq 'ignorecase' or $try eq 'ignore_case' ) { + $ignorecase = $action; + } + elsif ( $try eq 'ignore_case_always' ) { + $ignorecase = $action ? 2 : 0; + } + elsif ( $try eq 'bundling' ) { + $bundling = $action; + } + elsif ( $try eq 'bundling_override' ) { + $bundling = $action ? 2 : 0; + } + elsif ( $try eq 'require_order' ) { + $order = $action ? $REQUIRE_ORDER : $PERMUTE; + } + elsif ( $try eq 'permute' ) { + $order = $action ? $PERMUTE : $REQUIRE_ORDER; + } + elsif ( $try eq 'pass_through' or $try eq 'passthrough' ) { + $passthrough = $action; + } + elsif ( $try =~ /^prefix=(.+)$/ && $action ) { + $genprefix = $1; + # Turn into regexp. Needs to be parenthesized! + $genprefix = "(" . quotemeta($genprefix) . ")"; + eval { '' =~ /$genprefix/; }; + die("Getopt::Long: invalid pattern \"$genprefix\"") if $@; + } + elsif ( $try =~ /^prefix_pattern=(.+)$/ && $action ) { + $genprefix = $1; + # Parenthesize if needed. + $genprefix = "(" . $genprefix . ")" + unless $genprefix =~ /^\(.*\)$/; + eval { '' =~ m"$genprefix"; }; + die("Getopt::Long: invalid pattern \"$genprefix\"") if $@; + } + elsif ( $try =~ /^long_prefix_pattern=(.+)$/ && $action ) { + $longprefix = $1; + # Parenthesize if needed. + $longprefix = "(" . $longprefix . ")" + unless $longprefix =~ /^\(.*\)$/; + eval { '' =~ m"$longprefix"; }; + die("Getopt::Long: invalid long prefix pattern \"$longprefix\"") if $@; + } + elsif ( $try eq 'debug' ) { + $debug = $action; + } + else { + die("Getopt::Long: unknown config parameter \"$opt\"") + } + } + $prevconfig; +} + +# Deprecated name. +sub config (@) { + Configure (@_); +} + +# Issue a standard message for --version. +# +# The arguments are mostly the same as for Pod::Usage::pod2usage: +# +# - a number (exit value) +# - a string (lead in message) +# - a hash with options. See Pod::Usage for details. +# +sub VersionMessage(@) { + # Massage args. + my $pa = setup_pa_args("version", @_); + + my $v = $main::VERSION; + my $fh = $pa->{-output} || + ($pa->{-exitval} eq "NOEXIT" || $pa->{-exitval} < 2) ? \*STDOUT : \*STDERR; + + print $fh (defined($pa->{-message}) ? $pa->{-message} : (), + $0, defined $v ? " version $v" : (), + "\n", + "(", __PACKAGE__, "::", "GetOptions", + " version ", + defined($Getopt::Long::VERSION_STRING) + ? $Getopt::Long::VERSION_STRING : $VERSION, ";", + " Perl version ", + $] >= 5.006 ? sprintf("%vd", $^V) : $], + ")\n"); + exit($pa->{-exitval}) unless $pa->{-exitval} eq "NOEXIT"; +} + +# Issue a standard message for --help. +# +# The arguments are the same as for Pod::Usage::pod2usage: +# +# - a number (exit value) +# - a string (lead in message) +# - a hash with options. See Pod::Usage for details. +# +sub HelpMessage(@) { + eval { + require Pod::Usage; + import Pod::Usage; + 1; + } || die("Cannot provide help: cannot load Pod::Usage\n"); + + # Note that pod2usage will issue a warning if -exitval => NOEXIT. + pod2usage(setup_pa_args("help", @_)); + +} + +# Helper routine to set up a normalized hash ref to be used as +# argument to pod2usage. +sub setup_pa_args($@) { + my $tag = shift; # who's calling + + # If called by direct binding to an option, it will get the option + # name and value as arguments. Remove these, if so. + @_ = () if @_ == 2 && $_[0] eq $tag; + + my $pa; + if ( @_ > 1 ) { + $pa = { @_ }; + } + else { + $pa = shift || {}; + } + + # At this point, $pa can be a number (exit value), string + # (message) or hash with options. + + if ( UNIVERSAL::isa($pa, 'HASH') ) { + # Get rid of -msg vs. -message ambiguity. + $pa->{-message} = $pa->{-msg}; + delete($pa->{-msg}); + } + elsif ( $pa =~ /^-?\d+$/ ) { + $pa = { -exitval => $pa }; + } + else { + $pa = { -message => $pa }; + } + + # These are _our_ defaults. + $pa->{-verbose} = 0 unless exists($pa->{-verbose}); + $pa->{-exitval} = 0 unless exists($pa->{-exitval}); + $pa; +} + +# Sneak way to know what version the user requested. +sub VERSION { + $requested_version = $_[1]; + shift->SUPER::VERSION(@_); +} + +1; + +################ Documentation ################ + +=head1 NAME + +Getopt::Long - Extended processing of command line options + +=head1 SYNOPSIS + + use Getopt::Long; + my $data = "file.dat"; + my $length = 24; + my $verbose; + $result = GetOptions ("length=i" => \$length, # numeric + "file=s" => \$data, # string + "verbose" => \$verbose); # flag + +=head1 DESCRIPTION + +The Getopt::Long module implements an extended getopt function called +GetOptions(). This function adheres to the POSIX syntax for command +line options, with GNU extensions. In general, this means that options +have long names instead of single letters, and are introduced with a +double dash "--". Support for bundling of command line options, as was +the case with the more traditional single-letter approach, is provided +but not enabled by default. + +=head1 Command Line Options, an Introduction + +Command line operated programs traditionally take their arguments from +the command line, for example filenames or other information that the +program needs to know. Besides arguments, these programs often take +command line I<options> as well. Options are not necessary for the +program to work, hence the name 'option', but are used to modify its +default behaviour. For example, a program could do its job quietly, +but with a suitable option it could provide verbose information about +what it did. + +Command line options come in several flavours. Historically, they are +preceded by a single dash C<->, and consist of a single letter. + + -l -a -c + +Usually, these single-character options can be bundled: + + -lac + +Options can have values, the value is placed after the option +character. Sometimes with whitespace in between, sometimes not: + + -s 24 -s24 + +Due to the very cryptic nature of these options, another style was +developed that used long names. So instead of a cryptic C<-l> one +could use the more descriptive C<--long>. To distinguish between a +bundle of single-character options and a long one, two dashes are used +to precede the option name. Early implementations of long options used +a plus C<+> instead. Also, option values could be specified either +like + + --size=24 + +or + + --size 24 + +The C<+> form is now obsolete and strongly deprecated. + +=head1 Getting Started with Getopt::Long + +Getopt::Long is the Perl5 successor of C<newgetopt.pl>. This was the +first Perl module that provided support for handling the new style of +command line options, hence the name Getopt::Long. This module also +supports single-character options and bundling. Single character +options may be any alphabetic character, a question mark, and a dash. +Long options may consist of a series of letters, digits, and dashes. +Although this is currently not enforced by Getopt::Long, multiple +consecutive dashes are not allowed, and the option name must not end +with a dash. + +To use Getopt::Long from a Perl program, you must include the +following line in your Perl program: + + use Getopt::Long; + +This will load the core of the Getopt::Long module and prepare your +program for using it. Most of the actual Getopt::Long code is not +loaded until you really call one of its functions. + +In the default configuration, options names may be abbreviated to +uniqueness, case does not matter, and a single dash is sufficient, +even for long option names. Also, options may be placed between +non-option arguments. See L<Configuring Getopt::Long> for more +details on how to configure Getopt::Long. + +=head2 Simple options + +The most simple options are the ones that take no values. Their mere +presence on the command line enables the option. Popular examples are: + + --all --verbose --quiet --debug + +Handling simple options is straightforward: + + my $verbose = ''; # option variable with default value (false) + my $all = ''; # option variable with default value (false) + GetOptions ('verbose' => \$verbose, 'all' => \$all); + +The call to GetOptions() parses the command line arguments that are +present in C<@ARGV> and sets the option variable to the value C<1> if +the option did occur on the command line. Otherwise, the option +variable is not touched. Setting the option value to true is often +called I<enabling> the option. + +The option name as specified to the GetOptions() function is called +the option I<specification>. Later we'll see that this specification +can contain more than just the option name. The reference to the +variable is called the option I<destination>. + +GetOptions() will return a true value if the command line could be +processed successfully. Otherwise, it will write error messages to +STDERR, and return a false result. + +=head2 A little bit less simple options + +Getopt::Long supports two useful variants of simple options: +I<negatable> options and I<incremental> options. + +A negatable option is specified with an exclamation mark C<!> after the +option name: + + my $verbose = ''; # option variable with default value (false) + GetOptions ('verbose!' => \$verbose); + +Now, using C<--verbose> on the command line will enable C<$verbose>, +as expected. But it is also allowed to use C<--noverbose>, which will +disable C<$verbose> by setting its value to C<0>. Using a suitable +default value, the program can find out whether C<$verbose> is false +by default, or disabled by using C<--noverbose>. + +An incremental option is specified with a plus C<+> after the +option name: + + my $verbose = ''; # option variable with default value (false) + GetOptions ('verbose+' => \$verbose); + +Using C<--verbose> on the command line will increment the value of +C<$verbose>. This way the program can keep track of how many times the +option occurred on the command line. For example, each occurrence of +C<--verbose> could increase the verbosity level of the program. + +=head2 Mixing command line option with other arguments + +Usually programs take command line options as well as other arguments, +for example, file names. It is good practice to always specify the +options first, and the other arguments last. Getopt::Long will, +however, allow the options and arguments to be mixed and 'filter out' +all the options before passing the rest of the arguments to the +program. To stop Getopt::Long from processing further arguments, +insert a double dash C<--> on the command line: + + --size 24 -- --all + +In this example, C<--all> will I<not> be treated as an option, but +passed to the program unharmed, in C<@ARGV>. + +=head2 Options with values + +For options that take values it must be specified whether the option +value is required or not, and what kind of value the option expects. + +Three kinds of values are supported: integer numbers, floating point +numbers, and strings. + +If the option value is required, Getopt::Long will take the +command line argument that follows the option and assign this to the +option variable. If, however, the option value is specified as +optional, this will only be done if that value does not look like a +valid command line option itself. + + my $tag = ''; # option variable with default value + GetOptions ('tag=s' => \$tag); + +In the option specification, the option name is followed by an equals +sign C<=> and the letter C<s>. The equals sign indicates that this +option requires a value. The letter C<s> indicates that this value is +an arbitrary string. Other possible value types are C<i> for integer +values, and C<f> for floating point values. Using a colon C<:> instead +of the equals sign indicates that the option value is optional. In +this case, if no suitable value is supplied, string valued options get +an empty string C<''> assigned, while numeric options are set to C<0>. + +=head2 Options with multiple values + +Options sometimes take several values. For example, a program could +use multiple directories to search for library files: + + --library lib/stdlib --library lib/extlib + +To accomplish this behaviour, simply specify an array reference as the +destination for the option: + + GetOptions ("library=s" => \@libfiles); + +Alternatively, you can specify that the option can have multiple +values by adding a "@", and pass a scalar reference as the +destination: + + GetOptions ("library=s@" => \$libfiles); + +Used with the example above, C<@libfiles> (or C<@$libfiles>) would +contain two strings upon completion: C<"lib/srdlib"> and +C<"lib/extlib">, in that order. It is also possible to specify that +only integer or floating point numbers are acceptable values. + +Often it is useful to allow comma-separated lists of values as well as +multiple occurrences of the options. This is easy using Perl's split() +and join() operators: + + GetOptions ("library=s" => \@libfiles); + @libfiles = split(/,/,join(',',@libfiles)); + +Of course, it is important to choose the right separator string for +each purpose. + +Warning: What follows is an experimental feature. + +Options can take multiple values at once, for example + + --coordinates 52.2 16.4 --rgbcolor 255 255 149 + +This can be accomplished by adding a repeat specifier to the option +specification. Repeat specifiers are very similar to the C<{...}> +repeat specifiers that can be used with regular expression patterns. +For example, the above command line would be handled as follows: + + GetOptions('coordinates=f{2}' => \@coor, 'rgbcolor=i{3}' => \@color); + +The destination for the option must be an array or array reference. + +It is also possible to specify the minimal and maximal number of +arguments an option takes. C<foo=s{2,4}> indicates an option that +takes at least two and at most 4 arguments. C<foo=s{,}> indicates one +or more values; C<foo:s{,}> indicates zero or more option values. + +=head2 Options with hash values + +If the option destination is a reference to a hash, the option will +take, as value, strings of the form I<key>C<=>I<value>. The value will +be stored with the specified key in the hash. + + GetOptions ("define=s" => \%defines); + +Alternatively you can use: + + GetOptions ("define=s%" => \$defines); + +When used with command line options: + + --define os=linux --define vendor=redhat + +the hash C<%defines> (or C<%$defines>) will contain two keys, C<"os"> +with value C<"linux> and C<"vendor"> with value C<"redhat">. It is +also possible to specify that only integer or floating point numbers +are acceptable values. The keys are always taken to be strings. + +=head2 User-defined subroutines to handle options + +Ultimate control over what should be done when (actually: each time) +an option is encountered on the command line can be achieved by +designating a reference to a subroutine (or an anonymous subroutine) +as the option destination. When GetOptions() encounters the option, it +will call the subroutine with two or three arguments. The first +argument is the name of the option. For a scalar or array destination, +the second argument is the value to be stored. For a hash destination, +the second arguments is the key to the hash, and the third argument +the value to be stored. It is up to the subroutine to store the value, +or do whatever it thinks is appropriate. + +A trivial application of this mechanism is to implement options that +are related to each other. For example: + + my $verbose = ''; # option variable with default value (false) + GetOptions ('verbose' => \$verbose, + 'quiet' => sub { $verbose = 0 }); + +Here C<--verbose> and C<--quiet> control the same variable +C<$verbose>, but with opposite values. + +If the subroutine needs to signal an error, it should call die() with +the desired error message as its argument. GetOptions() will catch the +die(), issue the error message, and record that an error result must +be returned upon completion. + +If the text of the error message starts with an exclamation mark C<!> +it is interpreted specially by GetOptions(). There is currently one +special command implemented: C<die("!FINISH")> will cause GetOptions() +to stop processing options, as if it encountered a double dash C<-->. + +=head2 Options with multiple names + +Often it is user friendly to supply alternate mnemonic names for +options. For example C<--height> could be an alternate name for +C<--length>. Alternate names can be included in the option +specification, separated by vertical bar C<|> characters. To implement +the above example: + + GetOptions ('length|height=f' => \$length); + +The first name is called the I<primary> name, the other names are +called I<aliases>. When using a hash to store options, the key will +always be the primary name. + +Multiple alternate names are possible. + +=head2 Case and abbreviations + +Without additional configuration, GetOptions() will ignore the case of +option names, and allow the options to be abbreviated to uniqueness. + + GetOptions ('length|height=f' => \$length, "head" => \$head); + +This call will allow C<--l> and C<--L> for the length option, but +requires a least C<--hea> and C<--hei> for the head and height options. + +=head2 Summary of Option Specifications + +Each option specifier consists of two parts: the name specification +and the argument specification. + +The name specification contains the name of the option, optionally +followed by a list of alternative names separated by vertical bar +characters. + + length option name is "length" + length|size|l name is "length", aliases are "size" and "l" + +The argument specification is optional. If omitted, the option is +considered boolean, a value of 1 will be assigned when the option is +used on the command line. + +The argument specification can be + +=over 4 + +=item ! + +The option does not take an argument and may be negated by prefixing +it with "no" or "no-". E.g. C<"foo!"> will allow C<--foo> (a value of +1 will be assigned) as well as C<--nofoo> and C<--no-foo> (a value of +0 will be assigned). If the option has aliases, this applies to the +aliases as well. + +Using negation on a single letter option when bundling is in effect is +pointless and will result in a warning. + +=item + + +The option does not take an argument and will be incremented by 1 +every time it appears on the command line. E.g. C<"more+">, when used +with C<--more --more --more>, will increment the value three times, +resulting in a value of 3 (provided it was 0 or undefined at first). + +The C<+> specifier is ignored if the option destination is not a scalar. + +=item = I<type> [ I<desttype> ] [ I<repeat> ] + +The option requires an argument of the given type. Supported types +are: + +=over 4 + +=item s + +String. An arbitrary sequence of characters. It is valid for the +argument to start with C<-> or C<-->. + +=item i + +Integer. An optional leading plus or minus sign, followed by a +sequence of digits. + +=item o + +Extended integer, Perl style. This can be either an optional leading +plus or minus sign, followed by a sequence of digits, or an octal +string (a zero, optionally followed by '0', '1', .. '7'), or a +hexadecimal string (C<0x> followed by '0' .. '9', 'a' .. 'f', case +insensitive), or a binary string (C<0b> followed by a series of '0' +and '1'). + +=item f + +Real number. For example C<3.14>, C<-6.23E24> and so on. + +=back + +The I<desttype> can be C<@> or C<%> to specify that the option is +list or a hash valued. This is only needed when the destination for +the option value is not otherwise specified. It should be omitted when +not needed. + +The I<repeat> specifies the number of values this option takes per +occurrence on the command line. It has the format C<{> [ I<min> ] [ C<,> [ I<max> ] ] C<}>. + +I<min> denotes the minimal number of arguments. It defaults to 1 for +options with C<=> and to 0 for options with C<:>, see below. Note that +I<min> overrules the C<=> / C<:> semantics. + +I<max> denotes the maximum number of arguments. It must be at least +I<min>. If I<max> is omitted, I<but the comma is not>, there is no +upper bound to the number of argument values taken. + +=item : I<type> [ I<desttype> ] + +Like C<=>, but designates the argument as optional. +If omitted, an empty string will be assigned to string values options, +and the value zero to numeric options. + +Note that if a string argument starts with C<-> or C<-->, it will be +considered an option on itself. + +=item : I<number> [ I<desttype> ] + +Like C<:i>, but if the value is omitted, the I<number> will be assigned. + +=item : + [ I<desttype> ] + +Like C<:i>, but if the value is omitted, the current value for the +option will be incremented. + +=back + +=head1 Advanced Possibilities + +=head2 Object oriented interface + +Getopt::Long can be used in an object oriented way as well: + + use Getopt::Long; + $p = new Getopt::Long::Parser; + $p->configure(...configuration options...); + if ($p->getoptions(...options descriptions...)) ... + +Configuration options can be passed to the constructor: + + $p = new Getopt::Long::Parser + config => [...configuration options...]; + +=head2 Thread Safety + +Getopt::Long is thread safe when using ithreads as of Perl 5.8. It is +I<not> thread safe when using the older (experimental and now +obsolete) threads implementation that was added to Perl 5.005. + +=head2 Documentation and help texts + +Getopt::Long encourages the use of Pod::Usage to produce help +messages. For example: + + use Getopt::Long; + use Pod::Usage; + + my $man = 0; + my $help = 0; + + GetOptions('help|?' => \$help, man => \$man) or pod2usage(2); + pod2usage(1) if $help; + pod2usage(-exitstatus => 0, -verbose => 2) if $man; + + __END__ + + =head1 NAME + + sample - Using Getopt::Long and Pod::Usage + + =head1 SYNOPSIS + + sample [options] [file ...] + + Options: + -help brief help message + -man full documentation + + =head1 OPTIONS + + =over 8 + + =item B<-help> + + Print a brief help message and exits. + + =item B<-man> + + Prints the manual page and exits. + + =back + + =head1 DESCRIPTION + + B<This program> will read the given input file(s) and do something + useful with the contents thereof. + + =cut + +See L<Pod::Usage> for details. + +=head2 Storing option values in a hash + +Sometimes, for example when there are a lot of options, having a +separate variable for each of them can be cumbersome. GetOptions() +supports, as an alternative mechanism, storing options in a hash. + +To obtain this, a reference to a hash must be passed I<as the first +argument> to GetOptions(). For each option that is specified on the +command line, the option value will be stored in the hash with the +option name as key. Options that are not actually used on the command +line will not be put in the hash, on other words, +C<exists($h{option})> (or defined()) can be used to test if an option +was used. The drawback is that warnings will be issued if the program +runs under C<use strict> and uses C<$h{option}> without testing with +exists() or defined() first. + + my %h = (); + GetOptions (\%h, 'length=i'); # will store in $h{length} + +For options that take list or hash values, it is necessary to indicate +this by appending an C<@> or C<%> sign after the type: + + GetOptions (\%h, 'colours=s@'); # will push to @{$h{colours}} + +To make things more complicated, the hash may contain references to +the actual destinations, for example: + + my $len = 0; + my %h = ('length' => \$len); + GetOptions (\%h, 'length=i'); # will store in $len + +This example is fully equivalent with: + + my $len = 0; + GetOptions ('length=i' => \$len); # will store in $len + +Any mixture is possible. For example, the most frequently used options +could be stored in variables while all other options get stored in the +hash: + + my $verbose = 0; # frequently referred + my $debug = 0; # frequently referred + my %h = ('verbose' => \$verbose, 'debug' => \$debug); + GetOptions (\%h, 'verbose', 'debug', 'filter', 'size=i'); + if ( $verbose ) { ... } + if ( exists $h{filter} ) { ... option 'filter' was specified ... } + +=head2 Bundling + +With bundling it is possible to set several single-character options +at once. For example if C<a>, C<v> and C<x> are all valid options, + + -vax + +would set all three. + +Getopt::Long supports two levels of bundling. To enable bundling, a +call to Getopt::Long::Configure is required. + +The first level of bundling can be enabled with: + + Getopt::Long::Configure ("bundling"); + +Configured this way, single-character options can be bundled but long +options B<must> always start with a double dash C<--> to avoid +ambiguity. For example, when C<vax>, C<a>, C<v> and C<x> are all valid +options, + + -vax + +would set C<a>, C<v> and C<x>, but + + --vax + +would set C<vax>. + +The second level of bundling lifts this restriction. It can be enabled +with: + + Getopt::Long::Configure ("bundling_override"); + +Now, C<-vax> would set the option C<vax>. + +When any level of bundling is enabled, option values may be inserted +in the bundle. For example: + + -h24w80 + +is equivalent to + + -h 24 -w 80 + +When configured for bundling, single-character options are matched +case sensitive while long options are matched case insensitive. To +have the single-character options matched case insensitive as well, +use: + + Getopt::Long::Configure ("bundling", "ignorecase_always"); + +It goes without saying that bundling can be quite confusing. + +=head2 The lonesome dash + +Normally, a lone dash C<-> on the command line will not be considered +an option. Option processing will terminate (unless "permute" is +configured) and the dash will be left in C<@ARGV>. + +It is possible to get special treatment for a lone dash. This can be +achieved by adding an option specification with an empty name, for +example: + + GetOptions ('' => \$stdio); + +A lone dash on the command line will now be a legal option, and using +it will set variable C<$stdio>. + +=head2 Argument callback + +A special option 'name' C<< <> >> can be used to designate a subroutine +to handle non-option arguments. When GetOptions() encounters an +argument that does not look like an option, it will immediately call this +subroutine and passes it one parameter: the argument name. + +For example: + + my $width = 80; + sub process { ... } + GetOptions ('width=i' => \$width, '<>' => \&process); + +When applied to the following command line: + + arg1 --width=72 arg2 --width=60 arg3 + +This will call +C<process("arg1")> while C<$width> is C<80>, +C<process("arg2")> while C<$width> is C<72>, and +C<process("arg3")> while C<$width> is C<60>. + +This feature requires configuration option B<permute>, see section +L<Configuring Getopt::Long>. + +=head1 Configuring Getopt::Long + +Getopt::Long can be configured by calling subroutine +Getopt::Long::Configure(). This subroutine takes a list of quoted +strings, each specifying a configuration option to be enabled, e.g. +C<ignore_case>, or disabled, e.g. C<no_ignore_case>. Case does not +matter. Multiple calls to Configure() are possible. + +Alternatively, as of version 2.24, the configuration options may be +passed together with the C<use> statement: + + use Getopt::Long qw(:config no_ignore_case bundling); + +The following options are available: + +=over 12 + +=item default + +This option causes all configuration options to be reset to their +default values. + +=item posix_default + +This option causes all configuration options to be reset to their +default values as if the environment variable POSIXLY_CORRECT had +been set. + +=item auto_abbrev + +Allow option names to be abbreviated to uniqueness. +Default is enabled unless environment variable +POSIXLY_CORRECT has been set, in which case C<auto_abbrev> is disabled. + +=item getopt_compat + +Allow C<+> to start options. +Default is enabled unless environment variable +POSIXLY_CORRECT has been set, in which case C<getopt_compat> is disabled. + +=item gnu_compat + +C<gnu_compat> controls whether C<--opt=> is allowed, and what it should +do. Without C<gnu_compat>, C<--opt=> gives an error. With C<gnu_compat>, +C<--opt=> will give option C<opt> and empty value. +This is the way GNU getopt_long() does it. + +=item gnu_getopt + +This is a short way of setting C<gnu_compat> C<bundling> C<permute> +C<no_getopt_compat>. With C<gnu_getopt>, command line handling should be +fully compatible with GNU getopt_long(). + +=item require_order + +Whether command line arguments are allowed to be mixed with options. +Default is disabled unless environment variable +POSIXLY_CORRECT has been set, in which case C<require_order> is enabled. + +See also C<permute>, which is the opposite of C<require_order>. + +=item permute + +Whether command line arguments are allowed to be mixed with options. +Default is enabled unless environment variable +POSIXLY_CORRECT has been set, in which case C<permute> is disabled. +Note that C<permute> is the opposite of C<require_order>. + +If C<permute> is enabled, this means that + + --foo arg1 --bar arg2 arg3 + +is equivalent to + + --foo --bar arg1 arg2 arg3 + +If an argument callback routine is specified, C<@ARGV> will always be +empty upon successful return of GetOptions() since all options have been +processed. The only exception is when C<--> is used: + + --foo arg1 --bar arg2 -- arg3 + +This will call the callback routine for arg1 and arg2, and then +terminate GetOptions() leaving C<"arg2"> in C<@ARGV>. + +If C<require_order> is enabled, options processing +terminates when the first non-option is encountered. + + --foo arg1 --bar arg2 arg3 + +is equivalent to + + --foo -- arg1 --bar arg2 arg3 + +If C<pass_through> is also enabled, options processing will terminate +at the first unrecognized option, or non-option, whichever comes +first. + +=item bundling (default: disabled) + +Enabling this option will allow single-character options to be +bundled. To distinguish bundles from long option names, long options +I<must> be introduced with C<--> and bundles with C<->. + +Note that, if you have options C<a>, C<l> and C<all>, and +auto_abbrev enabled, possible arguments and option settings are: + + using argument sets option(s) + ------------------------------------------ + -a, --a a + -l, --l l + -al, -la, -ala, -all,... a, l + --al, --all all + +The surprising part is that C<--a> sets option C<a> (due to auto +completion), not C<all>. + +Note: disabling C<bundling> also disables C<bundling_override>. + +=item bundling_override (default: disabled) + +If C<bundling_override> is enabled, bundling is enabled as with +C<bundling> but now long option names override option bundles. + +Note: disabling C<bundling_override> also disables C<bundling>. + +B<Note:> Using option bundling can easily lead to unexpected results, +especially when mixing long options and bundles. Caveat emptor. + +=item ignore_case (default: enabled) + +If enabled, case is ignored when matching long option names. If, +however, bundling is enabled as well, single character options will be +treated case-sensitive. + +With C<ignore_case>, option specifications for options that only +differ in case, e.g., C<"foo"> and C<"Foo">, will be flagged as +duplicates. + +Note: disabling C<ignore_case> also disables C<ignore_case_always>. + +=item ignore_case_always (default: disabled) + +When bundling is in effect, case is ignored on single-character +options also. + +Note: disabling C<ignore_case_always> also disables C<ignore_case>. + +=item auto_version (default:disabled) + +Automatically provide support for the B<--version> option if +the application did not specify a handler for this option itself. + +Getopt::Long will provide a standard version message that includes the +program name, its version (if $main::VERSION is defined), and the +versions of Getopt::Long and Perl. The message will be written to +standard output and processing will terminate. + +C<auto_version> will be enabled if the calling program explicitly +specified a version number higher than 2.32 in the C<use> or +C<require> statement. + +=item auto_help (default:disabled) + +Automatically provide support for the B<--help> and B<-?> options if +the application did not specify a handler for this option itself. + +Getopt::Long will provide a help message using module L<Pod::Usage>. The +message, derived from the SYNOPSIS POD section, will be written to +standard output and processing will terminate. + +C<auto_help> will be enabled if the calling program explicitly +specified a version number higher than 2.32 in the C<use> or +C<require> statement. + +=item pass_through (default: disabled) + +Options that are unknown, ambiguous or supplied with an invalid option +value are passed through in C<@ARGV> instead of being flagged as +errors. This makes it possible to write wrapper scripts that process +only part of the user supplied command line arguments, and pass the +remaining options to some other program. + +If C<require_order> is enabled, options processing will terminate at +the first unrecognized option, or non-option, whichever comes first. +However, if C<permute> is enabled instead, results can become confusing. + +Note that the options terminator (default C<-->), if present, will +also be passed through in C<@ARGV>. + +=item prefix + +The string that starts options. If a constant string is not +sufficient, see C<prefix_pattern>. + +=item prefix_pattern + +A Perl pattern that identifies the strings that introduce options. +Default is C<--|-|\+> unless environment variable +POSIXLY_CORRECT has been set, in which case it is C<--|->. + +=item long_prefix_pattern + +A Perl pattern that allows the disambiguation of long and short +prefixes. Default is C<-->. + +Typically you only need to set this if you are using nonstandard +prefixes and want some or all of them to have the same semantics as +'--' does under normal circumstances. + +For example, setting prefix_pattern to C<--|-|\+|\/> and +long_prefix_pattern to C<--|\/> would add Win32 style argument +handling. + +=item debug (default: disabled) + +Enable debugging output. + +=back + +=head1 Exportable Methods + +=over + +=item VersionMessage + +This subroutine provides a standard version message. Its argument can be: + +=over 4 + +=item * + +A string containing the text of a message to print I<before> printing +the standard message. + +=item * + +A numeric value corresponding to the desired exit status. + +=item * + +A reference to a hash. + +=back + +If more than one argument is given then the entire argument list is +assumed to be a hash. If a hash is supplied (either as a reference or +as a list) it should contain one or more elements with the following +keys: + +=over 4 + +=item C<-message> + +=item C<-msg> + +The text of a message to print immediately prior to printing the +program's usage message. + +=item C<-exitval> + +The desired exit status to pass to the B<exit()> function. +This should be an integer, or else the string "NOEXIT" to +indicate that control should simply be returned without +terminating the invoking process. + +=item C<-output> + +A reference to a filehandle, or the pathname of a file to which the +usage message should be written. The default is C<\*STDERR> unless the +exit value is less than 2 (in which case the default is C<\*STDOUT>). + +=back + +You cannot tie this routine directly to an option, e.g.: + + GetOptions("version" => \&VersionMessage); + +Use this instead: + + GetOptions("version" => sub { VersionMessage() }); + +=item HelpMessage + +This subroutine produces a standard help message, derived from the +program's POD section SYNOPSIS using L<Pod::Usage>. It takes the same +arguments as VersionMessage(). In particular, you cannot tie it +directly to an option, e.g.: + + GetOptions("help" => \&HelpMessage); + +Use this instead: + + GetOptions("help" => sub { HelpMessage() }); + +=back + +=head1 Return values and Errors + +Configuration errors and errors in the option definitions are +signalled using die() and will terminate the calling program unless +the call to Getopt::Long::GetOptions() was embedded in C<eval { ... +}>, or die() was trapped using C<$SIG{__DIE__}>. + +GetOptions returns true to indicate success. +It returns false when the function detected one or more errors during +option parsing. These errors are signalled using warn() and can be +trapped with C<$SIG{__WARN__}>. + +=head1 Legacy + +The earliest development of C<newgetopt.pl> started in 1990, with Perl +version 4. As a result, its development, and the development of +Getopt::Long, has gone through several stages. Since backward +compatibility has always been extremely important, the current version +of Getopt::Long still supports a lot of constructs that nowadays are +no longer necessary or otherwise unwanted. This section describes +briefly some of these 'features'. + +=head2 Default destinations + +When no destination is specified for an option, GetOptions will store +the resultant value in a global variable named C<opt_>I<XXX>, where +I<XXX> is the primary name of this option. When a progam executes +under C<use strict> (recommended), these variables must be +pre-declared with our() or C<use vars>. + + our $opt_length = 0; + GetOptions ('length=i'); # will store in $opt_length + +To yield a usable Perl variable, characters that are not part of the +syntax for variables are translated to underscores. For example, +C<--fpp-struct-return> will set the variable +C<$opt_fpp_struct_return>. Note that this variable resides in the +namespace of the calling program, not necessarily C<main>. For +example: + + GetOptions ("size=i", "sizes=i@"); + +with command line "-size 10 -sizes 24 -sizes 48" will perform the +equivalent of the assignments + + $opt_size = 10; + @opt_sizes = (24, 48); + +=head2 Alternative option starters + +A string of alternative option starter characters may be passed as the +first argument (or the first argument after a leading hash reference +argument). + + my $len = 0; + GetOptions ('/', 'length=i' => $len); + +Now the command line may look like: + + /length 24 -- arg + +Note that to terminate options processing still requires a double dash +C<-->. + +GetOptions() will not interpret a leading C<< "<>" >> as option starters +if the next argument is a reference. To force C<< "<" >> and C<< ">" >> as +option starters, use C<< "><" >>. Confusing? Well, B<using a starter +argument is strongly deprecated> anyway. + +=head2 Configuration variables + +Previous versions of Getopt::Long used variables for the purpose of +configuring. Although manipulating these variables still work, it is +strongly encouraged to use the C<Configure> routine that was introduced +in version 2.17. Besides, it is much easier. + +=head1 Trouble Shooting + +=head2 GetOptions does not return a false result when an option is not supplied + +That's why they're called 'options'. + +=head2 GetOptions does not split the command line correctly + +The command line is not split by GetOptions, but by the command line +interpreter (CLI). On Unix, this is the shell. On Windows, it is +COMMAND.COM or CMD.EXE. Other operating systems have other CLIs. + +It is important to know that these CLIs may behave different when the +command line contains special characters, in particular quotes or +backslashes. For example, with Unix shells you can use single quotes +(C<'>) and double quotes (C<">) to group words together. The following +alternatives are equivalent on Unix: + + "two words" + 'two words' + two\ words + +In case of doubt, insert the following statement in front of your Perl +program: + + print STDERR (join("|",@ARGV),"\n"); + +to verify how your CLI passes the arguments to the program. + +=head2 Undefined subroutine &main::GetOptions called + +Are you running Windows, and did you write + + use GetOpt::Long; + +(note the capital 'O')? + +=head2 How do I put a "-?" option into a Getopt::Long? + +You can only obtain this using an alias, and Getopt::Long of at least +version 2.13. + + use Getopt::Long; + GetOptions ("help|?"); # -help and -? will both set $opt_help + +=head1 AUTHOR + +Johan Vromans <jvromans@squirrel.nl> + +=head1 COPYRIGHT AND DISCLAIMER + +This program is Copyright 1990,2005 by Johan Vromans. +This program is free software; you can redistribute it and/or +modify it under the terms of the Perl Artistic License or the +GNU General Public License as published by the Free Software +Foundation; either version 2 of the License, or (at your option) any +later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +If you do not have a copy of the GNU General Public License write to +the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, +MA 02139, USA. + +=cut + diff --git a/Master/tlpkg/installer/perllib/List/Util.pm b/Master/tlpkg/installer/perllib/List/Util.pm new file mode 100644 index 00000000000..cfe31f70123 --- /dev/null +++ b/Master/tlpkg/installer/perllib/List/Util.pm @@ -0,0 +1,277 @@ +# List::Util.pm +# +# Copyright (c) 1997-2005 Graham Barr <gbarr@pobox.com>. All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. + +package List::Util; + +use strict; +use vars qw(@ISA @EXPORT_OK $VERSION $XS_VERSION $TESTING_PERL_ONLY); +require Exporter; + +@ISA = qw(Exporter); +@EXPORT_OK = qw(first min max minstr maxstr reduce sum shuffle); +$VERSION = "1.18"; +$XS_VERSION = $VERSION; +$VERSION = eval $VERSION; + +eval { + # PERL_DL_NONLAZY must be false, or any errors in loading will just + # cause the perl code to be tested + local $ENV{PERL_DL_NONLAZY} = 0 if $ENV{PERL_DL_NONLAZY}; + eval { + require XSLoader; + XSLoader::load('List::Util', $XS_VERSION); + 1; + } or do { + require DynaLoader; + local @ISA = qw(DynaLoader); + bootstrap List::Util $XS_VERSION; + }; +} unless $TESTING_PERL_ONLY; + + +# This code is only compiled if the XS did not load +# of for perl < 5.6.0 + +if (!defined &reduce) { +eval <<'ESQ' + +sub reduce (&@) { + my $code = shift; + no strict 'refs'; + + return shift unless @_ > 1; + + use vars qw($a $b); + + my $caller = caller; + local(*{$caller."::a"}) = \my $a; + local(*{$caller."::b"}) = \my $b; + + $a = shift; + foreach (@_) { + $b = $_; + $a = &{$code}(); + } + + $a; +} + +sub first (&@) { + my $code = shift; + + foreach (@_) { + return $_ if &{$code}(); + } + + undef; +} + +ESQ +} + +# This code is only compiled if the XS did not load +eval <<'ESQ' if !defined ∑ + +use vars qw($a $b); + +sub sum (@) { reduce { $a + $b } @_ } + +sub min (@) { reduce { $a < $b ? $a : $b } @_ } + +sub max (@) { reduce { $a > $b ? $a : $b } @_ } + +sub minstr (@) { reduce { $a lt $b ? $a : $b } @_ } + +sub maxstr (@) { reduce { $a gt $b ? $a : $b } @_ } + +sub shuffle (@) { + my @a=\(@_); + my $n; + my $i=@_; + map { + $n = rand($i--); + (${$a[$n]}, $a[$n] = $a[$i])[0]; + } @_; +} + +ESQ + +1; + +__END__ + +=head1 NAME + +List::Util - A selection of general-utility list subroutines + +=head1 SYNOPSIS + + use List::Util qw(first max maxstr min minstr reduce shuffle sum); + +=head1 DESCRIPTION + +C<List::Util> contains a selection of subroutines that people have +expressed would be nice to have in the perl core, but the usage would +not really be high enough to warrant the use of a keyword, and the size +so small such that being individual extensions would be wasteful. + +By default C<List::Util> does not export any subroutines. The +subroutines defined are + +=over 4 + +=item first BLOCK LIST + +Similar to C<grep> in that it evaluates BLOCK setting C<$_> to each element +of LIST in turn. C<first> returns the first element where the result from +BLOCK is a true value. If BLOCK never returns true or LIST was empty then +C<undef> is returned. + + $foo = first { defined($_) } @list # first defined value in @list + $foo = first { $_ > $value } @list # first value in @list which + # is greater than $value + +This function could be implemented using C<reduce> like this + + $foo = reduce { defined($a) ? $a : wanted($b) ? $b : undef } undef, @list + +for example wanted() could be defined() which would return the first +defined value in @list + +=item max LIST + +Returns the entry in the list with the highest numerical value. If the +list is empty then C<undef> is returned. + + $foo = max 1..10 # 10 + $foo = max 3,9,12 # 12 + $foo = max @bar, @baz # whatever + +This function could be implemented using C<reduce> like this + + $foo = reduce { $a > $b ? $a : $b } 1..10 + +=item maxstr LIST + +Similar to C<max>, but treats all the entries in the list as strings +and returns the highest string as defined by the C<gt> operator. +If the list is empty then C<undef> is returned. + + $foo = maxstr 'A'..'Z' # 'Z' + $foo = maxstr "hello","world" # "world" + $foo = maxstr @bar, @baz # whatever + +This function could be implemented using C<reduce> like this + + $foo = reduce { $a gt $b ? $a : $b } 'A'..'Z' + +=item min LIST + +Similar to C<max> but returns the entry in the list with the lowest +numerical value. If the list is empty then C<undef> is returned. + + $foo = min 1..10 # 1 + $foo = min 3,9,12 # 3 + $foo = min @bar, @baz # whatever + +This function could be implemented using C<reduce> like this + + $foo = reduce { $a < $b ? $a : $b } 1..10 + +=item minstr LIST + +Similar to C<min>, but treats all the entries in the list as strings +and returns the lowest string as defined by the C<lt> operator. +If the list is empty then C<undef> is returned. + + $foo = minstr 'A'..'Z' # 'A' + $foo = minstr "hello","world" # "hello" + $foo = minstr @bar, @baz # whatever + +This function could be implemented using C<reduce> like this + + $foo = reduce { $a lt $b ? $a : $b } 'A'..'Z' + +=item reduce BLOCK LIST + +Reduces LIST by calling BLOCK multiple times, setting C<$a> and C<$b> +each time. The first call will be with C<$a> and C<$b> set to the first +two elements of the list, subsequent calls will be done by +setting C<$a> to the result of the previous call and C<$b> to the next +element in the list. + +Returns the result of the last call to BLOCK. If LIST is empty then +C<undef> is returned. If LIST only contains one element then that +element is returned and BLOCK is not executed. + + $foo = reduce { $a < $b ? $a : $b } 1..10 # min + $foo = reduce { $a lt $b ? $a : $b } 'aa'..'zz' # minstr + $foo = reduce { $a + $b } 1 .. 10 # sum + $foo = reduce { $a . $b } @bar # concat + +=item shuffle LIST + +Returns the elements of LIST in a random order + + @cards = shuffle 0..51 # 0..51 in a random order + +=item sum LIST + +Returns the sum of all the elements in LIST. If LIST is empty then +C<undef> is returned. + + $foo = sum 1..10 # 55 + $foo = sum 3,9,12 # 24 + $foo = sum @bar, @baz # whatever + +This function could be implemented using C<reduce> like this + + $foo = reduce { $a + $b } 1..10 + +=back + +=head1 KNOWN BUGS + +With perl versions prior to 5.005 there are some cases where reduce +will return an incorrect result. This will show up as test 7 of +reduce.t failing. + +=head1 SUGGESTED ADDITIONS + +The following are additions that have been requested, but I have been reluctant +to add due to them being very simple to implement in perl + + # One argument is true + + sub any { $_ && return 1 for @_; 0 } + + # All arguments are true + + sub all { $_ || return 0 for @_; 1 } + + # All arguments are false + + sub none { $_ && return 0 for @_; 1 } + + # One argument is false + + sub notall { $_ || return 1 for @_; 0 } + + # How many elements are true + + sub true { scalar grep { $_ } @_ } + + # How many elements are false + + sub false { scalar grep { !$_ } @_ } + +=head1 COPYRIGHT + +Copyright (c) 1997-2005 Graham Barr <gbarr@pobox.com>. All rights reserved. +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=cut diff --git a/Master/tlpkg/installer/perllib/Scalar/Util.pm b/Master/tlpkg/installer/perllib/Scalar/Util.pm new file mode 100644 index 00000000000..4ae525a17c0 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Scalar/Util.pm @@ -0,0 +1,147 @@ +# Scalar::Util.pm +# +# Copyright (c) 1997-2005 Graham Barr <gbarr@pobox.com>. All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. + +package Scalar::Util; + +use strict; +use vars qw(@ISA @EXPORT_OK $VERSION); +require Exporter; +require List::Util; # List::Util loads the XS + +@ISA = qw(Exporter); +@EXPORT_OK = qw(blessed dualvar reftype weaken isweak tainted readonly openhandle refaddr isvstring looks_like_number set_prototype); +$VERSION = "1.18"; +$VERSION = eval $VERSION; + +sub export_fail { + if (grep { /^(weaken|isweak)$/ } @_ ) { + require Carp; + Carp::croak("Weak references are not implemented in the version of perl"); + } + if (grep { /^(isvstring)$/ } @_ ) { + require Carp; + Carp::croak("Vstrings are not implemented in the version of perl"); + } + if (grep { /^(dualvar|set_prototype)$/ } @_ ) { + require Carp; + Carp::croak("$1 is only avaliable with the XS version"); + } + + @_; +} + +sub openhandle ($) { + my $fh = shift; + my $rt = reftype($fh) || ''; + + return defined(fileno($fh)) ? $fh : undef + if $rt eq 'IO'; + + if (reftype(\$fh) eq 'GLOB') { # handle openhandle(*DATA) + $fh = \(my $tmp=$fh); + } + elsif ($rt ne 'GLOB') { + return undef; + } + + (tied(*$fh) or defined(fileno($fh))) + ? $fh : undef; +} + +eval <<'ESQ' unless defined &dualvar; + +use vars qw(@EXPORT_FAIL); +push @EXPORT_FAIL, qw(weaken isweak dualvar isvstring set_prototype); + +# The code beyond here is only used if the XS is not installed + +# Hope nobody defines a sub by this name +sub UNIVERSAL::a_sub_not_likely_to_be_here { ref($_[0]) } + +sub blessed ($) { + local($@, $SIG{__DIE__}, $SIG{__WARN__}); + length(ref($_[0])) + ? eval { $_[0]->a_sub_not_likely_to_be_here } + : undef +} + +sub refaddr($) { + my $pkg = ref($_[0]) or return undef; + if (blessed($_[0])) { + bless $_[0], 'Scalar::Util::Fake'; + } + else { + $pkg = undef; + } + "$_[0]" =~ /0x(\w+)/; + my $i = do { local $^W; hex $1 }; + bless $_[0], $pkg if defined $pkg; + $i; +} + +sub reftype ($) { + local($@, $SIG{__DIE__}, $SIG{__WARN__}); + my $r = shift; + my $t; + + length($t = ref($r)) or return undef; + + # This eval will fail if the reference is not blessed + eval { $r->a_sub_not_likely_to_be_here; 1 } + ? do { + $t = eval { + # we have a GLOB or an IO. Stringify a GLOB gives it's name + my $q = *$r; + $q =~ /^\*/ ? "GLOB" : "IO"; + } + or do { + # OK, if we don't have a GLOB what parts of + # a glob will it populate. + # NOTE: A glob always has a SCALAR + local *glob = $r; + defined *glob{ARRAY} && "ARRAY" + or defined *glob{HASH} && "HASH" + or defined *glob{CODE} && "CODE" + or length(ref(${$r})) ? "REF" : "SCALAR"; + } + } + : $t +} + +sub tainted { + local($@, $SIG{__DIE__}, $SIG{__WARN__}); + local $^W = 0; + eval { kill 0 * $_[0] }; + $@ =~ /^Insecure/; +} + +sub readonly { + return 0 if tied($_[0]) || (ref(\($_[0])) ne "SCALAR"); + + local($@, $SIG{__DIE__}, $SIG{__WARN__}); + my $tmp = $_[0]; + + !eval { $_[0] = $tmp; 1 }; +} + +sub looks_like_number { + local $_ = shift; + + # checks from perlfaq4 + return 0 if !defined($_) or ref($_); + return 1 if (/^[+-]?\d+$/); # is a +/- integer + return 1 if (/^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/); # a C float + return 1 if ($] >= 5.008 and /^(Inf(inity)?|NaN)$/i) or ($] >= 5.006001 and /^Inf$/i); + + 0; +} + +ESQ + +1; + +__END__ + diff --git a/Master/tlpkg/installer/perllib/Symbol.pm b/Master/tlpkg/installer/perllib/Symbol.pm new file mode 100644 index 00000000000..3bb5d9240c1 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Symbol.pm @@ -0,0 +1,170 @@ +package Symbol; + +=head1 NAME + +Symbol - manipulate Perl symbols and their names + +=head1 SYNOPSIS + + use Symbol; + + $sym = gensym; + open($sym, "filename"); + $_ = <$sym>; + # etc. + + ungensym $sym; # no effect + + # replace *FOO{IO} handle but not $FOO, %FOO, etc. + *FOO = geniosym; + + print qualify("x"), "\n"; # "Test::x" + print qualify("x", "FOO"), "\n" # "FOO::x" + print qualify("BAR::x"), "\n"; # "BAR::x" + print qualify("BAR::x", "FOO"), "\n"; # "BAR::x" + print qualify("STDOUT", "FOO"), "\n"; # "main::STDOUT" (global) + print qualify(\*x), "\n"; # returns \*x + print qualify(\*x, "FOO"), "\n"; # returns \*x + + use strict refs; + print { qualify_to_ref $fh } "foo!\n"; + $ref = qualify_to_ref $name, $pkg; + + use Symbol qw(delete_package); + delete_package('Foo::Bar'); + print "deleted\n" unless exists $Foo::{'Bar::'}; + +=head1 DESCRIPTION + +C<Symbol::gensym> creates an anonymous glob and returns a reference +to it. Such a glob reference can be used as a file or directory +handle. + +For backward compatibility with older implementations that didn't +support anonymous globs, C<Symbol::ungensym> is also provided. +But it doesn't do anything. + +C<Symbol::geniosym> creates an anonymous IO handle. This can be +assigned into an existing glob without affecting the non-IO portions +of the glob. + +C<Symbol::qualify> turns unqualified symbol names into qualified +variable names (e.g. "myvar" -E<gt> "MyPackage::myvar"). If it is given a +second parameter, C<qualify> uses it as the default package; +otherwise, it uses the package of its caller. Regardless, global +variable names (e.g. "STDOUT", "ENV", "SIG") are always qualified with +"main::". + +Qualification applies only to symbol names (strings). References are +left unchanged under the assumption that they are glob references, +which are qualified by their nature. + +C<Symbol::qualify_to_ref> is just like C<Symbol::qualify> except that it +returns a glob ref rather than a symbol name, so you can use the result +even if C<use strict 'refs'> is in effect. + +C<Symbol::delete_package> wipes out a whole package namespace. Note +this routine is not exported by default--you may want to import it +explicitly. + +=head1 BUGS + +C<Symbol::delete_package> is a bit too powerful. It undefines every symbol that +lives in the specified package. Since perl, for performance reasons, does not +perform a symbol table lookup each time a function is called or a global +variable is accessed, some code that has already been loaded and that makes use +of symbols in package C<Foo> may stop working after you delete C<Foo>, even if +you reload the C<Foo> module afterwards. + +=cut + +BEGIN { require 5.005; } + +require Exporter; +@ISA = qw(Exporter); +@EXPORT = qw(gensym ungensym qualify qualify_to_ref); +@EXPORT_OK = qw(delete_package geniosym); + +$VERSION = '1.06'; + +my $genpkg = "Symbol::"; +my $genseq = 0; + +my %global = map {$_ => 1} qw(ARGV ARGVOUT ENV INC SIG STDERR STDIN STDOUT); + +# +# Note that we never _copy_ the glob; we just make a ref to it. +# If we did copy it, then SVf_FAKE would be set on the copy, and +# glob-specific behaviors (e.g. C<*$ref = \&func>) wouldn't work. +# +sub gensym () { + my $name = "GEN" . $genseq++; + my $ref = \*{$genpkg . $name}; + delete $$genpkg{$name}; + $ref; +} + +sub geniosym () { + my $sym = gensym(); + # force the IO slot to be filled + select(select $sym); + *$sym{IO}; +} + +sub ungensym ($) {} + +sub qualify ($;$) { + my ($name) = @_; + if (!ref($name) && index($name, '::') == -1 && index($name, "'") == -1) { + my $pkg; + # Global names: special character, "^xyz", or other. + if ($name =~ /^(([^a-z])|(\^[a-z_]+))\z/i || $global{$name}) { + # RGS 2001-11-05 : translate leading ^X to control-char + $name =~ s/^\^([a-z_])/'qq(\c'.$1.')'/eei; + $pkg = "main"; + } + else { + $pkg = (@_ > 1) ? $_[1] : caller; + } + $name = $pkg . "::" . $name; + } + $name; +} + +sub qualify_to_ref ($;$) { + return \*{ qualify $_[0], @_ > 1 ? $_[1] : caller }; +} + +# +# of Safe.pm lineage +# +sub delete_package ($) { + my $pkg = shift; + + # expand to full symbol table name if needed + + unless ($pkg =~ /^main::.*::$/) { + $pkg = "main$pkg" if $pkg =~ /^::/; + $pkg = "main::$pkg" unless $pkg =~ /^main::/; + $pkg .= '::' unless $pkg =~ /::$/; + } + + my($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/; + my $stem_symtab = *{$stem}{HASH}; + return unless defined $stem_symtab and exists $stem_symtab->{$leaf}; + + + # free all the symbols in the package + + my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH}; + foreach my $name (keys %$leaf_symtab) { + undef *{$pkg . $name}; + } + + # delete the symbol table + + %$leaf_symtab = (); + delete $stem_symtab->{$leaf}; +} + +1; diff --git a/Master/tlpkg/installer/perllib/Tie/Hash.pm b/Master/tlpkg/installer/perllib/Tie/Hash.pm new file mode 100644 index 00000000000..a838915482b --- /dev/null +++ b/Master/tlpkg/installer/perllib/Tie/Hash.pm @@ -0,0 +1,257 @@ +package Tie::Hash; + +our $VERSION = '1.02'; + +=head1 NAME + +Tie::Hash, Tie::StdHash, Tie::ExtraHash - base class definitions for tied hashes + +=head1 SYNOPSIS + + package NewHash; + require Tie::Hash; + + @ISA = (Tie::Hash); + + sub DELETE { ... } # Provides needed method + sub CLEAR { ... } # Overrides inherited method + + + package NewStdHash; + require Tie::Hash; + + @ISA = (Tie::StdHash); + + # All methods provided by default, define only those needing overrides + # Accessors access the storage in %{$_[0]}; + # TIEHASH should return a reference to the actual storage + sub DELETE { ... } + + package NewExtraHash; + require Tie::Hash; + + @ISA = (Tie::ExtraHash); + + # All methods provided by default, define only those needing overrides + # Accessors access the storage in %{$_[0][0]}; + # TIEHASH should return an array reference with the first element being + # the reference to the actual storage + sub DELETE { + $_[0][1]->('del', $_[0][0], $_[1]); # Call the report writer + delete $_[0][0]->{$_[1]}; # $_[0]->SUPER::DELETE($_[1]) + } + + + package main; + + tie %new_hash, 'NewHash'; + tie %new_std_hash, 'NewStdHash'; + tie %new_extra_hash, 'NewExtraHash', + sub {warn "Doing \U$_[1]\E of $_[2].\n"}; + +=head1 DESCRIPTION + +This module provides some skeletal methods for hash-tying classes. See +L<perltie> for a list of the functions required in order to tie a hash +to a package. The basic B<Tie::Hash> package provides a C<new> method, as well +as methods C<TIEHASH>, C<EXISTS> and C<CLEAR>. The B<Tie::StdHash> and +B<Tie::ExtraHash> packages +provide most methods for hashes described in L<perltie> (the exceptions +are C<UNTIE> and C<DESTROY>). They cause tied hashes to behave exactly like standard hashes, +and allow for selective overwriting of methods. B<Tie::Hash> grandfathers the +C<new> method: it is used if C<TIEHASH> is not defined +in the case a class forgets to include a C<TIEHASH> method. + +For developers wishing to write their own tied hashes, the required methods +are briefly defined below. See the L<perltie> section for more detailed +descriptive, as well as example code: + +=over 4 + +=item TIEHASH classname, LIST + +The method invoked by the command C<tie %hash, classname>. Associates a new +hash instance with the specified class. C<LIST> would represent additional +arguments (along the lines of L<AnyDBM_File> and compatriots) needed to +complete the association. + +=item STORE this, key, value + +Store datum I<value> into I<key> for the tied hash I<this>. + +=item FETCH this, key + +Retrieve the datum in I<key> for the tied hash I<this>. + +=item FIRSTKEY this + +Return the first key in the hash. + +=item NEXTKEY this, lastkey + +Return the next key in the hash. + +=item EXISTS this, key + +Verify that I<key> exists with the tied hash I<this>. + +The B<Tie::Hash> implementation is a stub that simply croaks. + +=item DELETE this, key + +Delete the key I<key> from the tied hash I<this>. + +=item CLEAR this + +Clear all values from the tied hash I<this>. + +=item SCALAR this + +Returns what evaluating the hash in scalar context yields. + +B<Tie::Hash> does not implement this method (but B<Tie::StdHash> +and B<Tie::ExtraHash> do). + +=back + +=head1 Inheriting from B<Tie::StdHash> + +The accessor methods assume that the actual storage for the data in the tied +hash is in the hash referenced by C<tied(%tiedhash)>. Thus overwritten +C<TIEHASH> method should return a hash reference, and the remaining methods +should operate on the hash referenced by the first argument: + + package ReportHash; + our @ISA = 'Tie::StdHash'; + + sub TIEHASH { + my $storage = bless {}, shift; + warn "New ReportHash created, stored in $storage.\n"; + $storage + } + sub STORE { + warn "Storing data with key $_[1] at $_[0].\n"; + $_[0]{$_[1]} = $_[2] + } + + +=head1 Inheriting from B<Tie::ExtraHash> + +The accessor methods assume that the actual storage for the data in the tied +hash is in the hash referenced by C<(tied(%tiedhash))-E<gt>[0]>. Thus overwritten +C<TIEHASH> method should return an array reference with the first +element being a hash reference, and the remaining methods should operate on the +hash C<< %{ $_[0]->[0] } >>: + + package ReportHash; + our @ISA = 'Tie::ExtraHash'; + + sub TIEHASH { + my $class = shift; + my $storage = bless [{}, @_], $class; + warn "New ReportHash created, stored in $storage.\n"; + $storage; + } + sub STORE { + warn "Storing data with key $_[1] at $_[0].\n"; + $_[0][0]{$_[1]} = $_[2] + } + +The default C<TIEHASH> method stores "extra" arguments to tie() starting +from offset 1 in the array referenced by C<tied(%tiedhash)>; this is the +same storage algorithm as in TIEHASH subroutine above. Hence, a typical +package inheriting from B<Tie::ExtraHash> does not need to overwrite this +method. + +=head1 C<SCALAR>, C<UNTIE> and C<DESTROY> + +The methods C<UNTIE> and C<DESTROY> are not defined in B<Tie::Hash>, +B<Tie::StdHash>, or B<Tie::ExtraHash>. Tied hashes do not require +presence of these methods, but if defined, the methods will be called in +proper time, see L<perltie>. + +C<SCALAR> is only defined in B<Tie::StdHash> and B<Tie::ExtraHash>. + +If needed, these methods should be defined by the package inheriting from +B<Tie::Hash>, B<Tie::StdHash>, or B<Tie::ExtraHash>. See L<pertie/"SCALAR"> +to find out what happens when C<SCALAR> does not exist. + +=head1 MORE INFORMATION + +The packages relating to various DBM-related implementations (F<DB_File>, +F<NDBM_File>, etc.) show examples of general tied hashes, as does the +L<Config> module. While these do not utilize B<Tie::Hash>, they serve as +good working examples. + +=cut + +use Carp; +use warnings::register; + +sub new { + my $pkg = shift; + $pkg->TIEHASH(@_); +} + +# Grandfather "new" + +sub TIEHASH { + my $pkg = shift; + if (defined &{"${pkg}::new"}) { + warnings::warnif("WARNING: calling ${pkg}->new since ${pkg}->TIEHASH is missing"); + $pkg->new(@_); + } + else { + croak "$pkg doesn't define a TIEHASH method"; + } +} + +sub EXISTS { + my $pkg = ref $_[0]; + croak "$pkg doesn't define an EXISTS method"; +} + +sub CLEAR { + my $self = shift; + my $key = $self->FIRSTKEY(@_); + my @keys; + + while (defined $key) { + push @keys, $key; + $key = $self->NEXTKEY(@_, $key); + } + foreach $key (@keys) { + $self->DELETE(@_, $key); + } +} + +# The Tie::StdHash package implements standard perl hash behaviour. +# It exists to act as a base class for classes which only wish to +# alter some parts of their behaviour. + +package Tie::StdHash; +# @ISA = qw(Tie::Hash); # would inherit new() only + +sub TIEHASH { bless {}, $_[0] } +sub STORE { $_[0]->{$_[1]} = $_[2] } +sub FETCH { $_[0]->{$_[1]} } +sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} } +sub NEXTKEY { each %{$_[0]} } +sub EXISTS { exists $_[0]->{$_[1]} } +sub DELETE { delete $_[0]->{$_[1]} } +sub CLEAR { %{$_[0]} = () } +sub SCALAR { scalar %{$_[0]} } + +package Tie::ExtraHash; + +sub TIEHASH { my $p = shift; bless [{}, @_], $p } +sub STORE { $_[0][0]{$_[1]} = $_[2] } +sub FETCH { $_[0][0]{$_[1]} } +sub FIRSTKEY { my $a = scalar keys %{$_[0][0]}; each %{$_[0][0]} } +sub NEXTKEY { each %{$_[0][0]} } +sub EXISTS { exists $_[0][0]->{$_[1]} } +sub DELETE { delete $_[0][0]->{$_[1]} } +sub CLEAR { %{$_[0][0]} = () } +sub SCALAR { scalar %{$_[0][0]} } + +1; diff --git a/Master/tlpkg/installer/perllib/Tk.pm b/Master/tlpkg/installer/perllib/Tk.pm new file mode 100644 index 00000000000..deb453172eb --- /dev/null +++ b/Master/tlpkg/installer/perllib/Tk.pm @@ -0,0 +1,821 @@ +# +# Copyright (c) 1992-1994 The Regents of the University of California. +# Copyright (c) 1994 Sun Microsystems, Inc. +# Copyright (c) 1995-2004 Nick Ing-Simmons. All rights reserved. +# This program is free software; you can redistribute it and/or + +# modify it under the same terms as Perl itself, subject +# to additional disclaimer in Tk/license.terms due to partial +# derivation from Tk8.0 sources. +# +package Tk; +require 5.007; +use Tk::Event (); +use AutoLoader qw(AUTOLOAD); +use DynaLoader; +use Cwd(); +use base qw(Exporter DynaLoader); + +*fileevent = \&Tk::Event::IO::fileevent; + +use Encode; +$Tk::encodeStopOnError = Encode::FB_QUIET(); +$Tk::encodeFallback = Encode::FB_PERLQQ(); # Encode::FB_DEFAULT(); + +our %font_encoding = ('jis0208' => 'jis0208-raw', + 'jis0212' => 'jis0212-raw', + 'ksc5601' => 'ksc5601-raw', + 'gb2312' => 'gb2312-raw', + 'unicode' => 'ucs-2le', + ); + +BEGIN { + if($^O eq 'cygwin') + { + require Tk::Config; + $Tk::platform = $Tk::Config::win_arch; + $Tk::platform = 'unix' if $Tk::platform eq 'x'; + } + else + { + $Tk::platform = ($^O eq 'MSWin32') ? $^O : 'unix'; + } +}; + +$Tk::tearoff = 1 if ($Tk::platform eq 'unix'); + + +@EXPORT = qw(Exists Ev exit MainLoop DoOneEvent tkinit); +@EXPORT_OK = qw(NoOp after *widget *event lsearch catch $XS_VERSION + DONT_WAIT WINDOW_EVENTS FILE_EVENTS TIMER_EVENTS + IDLE_EVENTS ALL_EVENTS + NORMAL_BG ACTIVE_BG SELECT_BG + SELECT_FG TROUGH INDICATOR DISABLED BLACK WHITE); +%EXPORT_TAGS = (eventtypes => [qw(DONT_WAIT WINDOW_EVENTS FILE_EVENTS + TIMER_EVENTS IDLE_EVENTS ALL_EVENTS)], + variables => [qw(*widget *event)], + colors => [qw(NORMAL_BG ACTIVE_BG SELECT_BG SELECT_FG + TROUGH INDICATOR DISABLED BLACK WHITE)], + ); + +use strict; +use Carp; + +# Record author's perforce depot record +$Tk::CHANGE = q$Change: 3279 $; + +# $tk_version and $tk_patchLevel are reset by pTk when a mainwindow +# is created, $VERSION is checked by bootstrap +$Tk::version = '8.4'; +$Tk::patchLevel = '8.4'; +$Tk::VERSION = '804.027'; +$Tk::XS_VERSION = $Tk::VERSION; +$Tk::strictMotif = 0; + + +{($Tk::library) = __FILE__ =~ /^(.*)\.pm$/;} +$Tk::library = Tk->findINC('.') unless (defined($Tk::library) && -d $Tk::library); + +$Tk::widget = undef; +$Tk::event = undef; + +use vars qw($inMainLoop); + +bootstrap Tk; + +my $boot_time = timeofday(); + +# This is a workround for Solaris X11 locale handling +Preload(DynaLoader::dl_findfile('-L/usr/openwin/lib','-lX11')) + if (NeedPreload() && -d '/usr/openwin/lib'); + +use Tk::Submethods ('option' => [qw(add get clear readfile)], + 'clipboard' => [qw(clear append)] + ); + +# +# Next few routines are here as perl code as doing caller() +# in XS code is very complicated - so instead C code calls BackTrace +# +sub _backTrace +{ + my $w = shift; + my $i = 1; + my ($pack,$file,$line,$sub) = caller($i++); + while (1) + { + my $loc = "at $file line $line"; + ($pack,$file,$line,$sub) = caller($i++); + last unless defined($sub); + return 1 if $sub eq '(eval)'; + $w->AddErrorInfo("$sub $loc"); + } + return 0; +} + +sub BackTrace +{ + my $w = shift; + return unless (@_ || $@); + my $mess = (@_) ? shift : "$@"; + die "$mess\n" if $w->_backTrace; + # if we get here we are not in an eval so report now + $w->Fail($mess); + $w->idletasks; + die "$mess\n"; +} + +# +# This is a $SIG{__DIE__} handler which does not change the $@ +# string in the way 'croak' does, but rather add to Tk's ErrorInfo. +# It stops at 1st enclosing eval on assumption that the eval +# is part of Tk call process and will add its own context to ErrorInfo +# and then pass on the error. +# +sub __DIE__ +{ + my $mess = shift; + my $w = $Tk::widget; + # Note that if a __DIE__ handler returns it re-dies up the chain. + return unless defined($w) && Exists($w); + # This special message is for exit() as an exception see pTkCallback.c + return if $mess =~/^_TK_EXIT_\(\d+\)/; + return if $w->_backTrace; + # Not in an eval - should not happen +} + +sub XEvent::xy { shift->Info('xy') } + +sub XEvent::AUTOLOAD +{ + my ($meth) = $XEvent::AUTOLOAD =~ /(\w)$/; + no strict 'refs'; + *{$XEvent::AUTOLOAD} = sub { shift->Info($meth) }; + goto &$XEvent::AUTOLOAD; +} + +sub NoOp { } + +sub Ev +{ + if (@_ == 1) + { + my $arg = $_[0]; + return bless (((ref $arg) ? $arg : \$arg), 'Tk::Ev'); + } + else + { + return bless [@_],'Tk::Ev'; + } +} + +sub InitClass +{ + my ($package,$parent) = @_; + croak "Unexpected type of parent $parent" unless(ref $parent); + croak "$parent is not a widget" unless($parent->IsWidget); + my $mw = $parent->MainWindow; + my $hash = $mw->TkHash('_ClassInit_'); + unless (exists $hash->{$package}) + { + $package->Install($mw); + $hash->{$package} = $package->ClassInit($mw); + } +} + +require Tk::Widget; +require Tk::Image; +require Tk::MainWindow; + +sub Exists +{my $w = shift; + return defined($w) && ref($w) && $w->IsWidget && $w->exists; +} + +sub Time_So_Far +{ + return timeofday() - $boot_time; +} + +# Selection* are not autoloaded as names are too long. + +sub SelectionOwn +{my $widget = shift; + selection('own',(@_,$widget)); +} + +sub SelectionOwner +{ + selection('own','-displayof',@_); +} + +sub SelectionClear +{ + selection('clear','-displayof',@_); +} + +sub SelectionExists +{ + selection('exists','-displayof',@_); +} + +sub SelectionHandle +{my $widget = shift; + my $command = pop; + selection('handle',@_,$widget,$command); +} + +sub SplitString +{ + local $_ = shift; + my (@arr, $tmp); + while (/\{([^{}]*)\}|((?:[^\s\\]|\\.)+)/gs) { + if (defined $1) { push @arr, $1 } + else { $tmp = $2 ; $tmp =~ s/\\([\s\\])/$1/g; push @arr, $tmp } + } + # carp '('.join(',',@arr).")"; + return @arr; +} + +sub Methods +{ + my ($package) = caller; + no strict 'refs'; + foreach my $meth (@_) + { + my $name = $meth; + *{$package."::$meth"} = sub { shift->WidgetMethod($name,@_) }; + } +} + +my %dialog = ( tk_chooseColor => 'ColorDialog', + tk_messageBox => 'MessageBox', + tk_getOpenFile => 'FDialog', + tk_getSaveFile => 'FDialog', + tk_chooseDirectory => 'FDialog' +# Slaven claims NI-S's version above does not work +# and provides this +# tk_chooseDirectory => 'DirDialog' + ); + +foreach my $dialog (keys %dialog) + { + no strict 'refs'; + unless (defined &$dialog) + { + my $kind = $dialog; + my $code = \&{"Tk::$dialog{$dialog}"}; + *$dialog = sub { &$code($kind,@_) }; + } + } + +sub MessageBox { + my ($kind,%args) = @_; + require Tk::Dialog; + my $parent = delete $args{'-parent'}; + my $args = \%args; + + $args->{-bitmap} = delete $args->{-icon} if defined $args->{-icon}; + $args->{-text} = delete $args->{-message} if defined $args->{-message}; + $args->{-type} = 'OK' unless defined $args->{-type}; + + my $type; + if (defined($type = delete $args->{-type})) { + delete $args->{-type}; + my @buttons = grep($_,map(ucfirst($_), + split(/(abort|retry|ignore|yes|no|cancel|ok)/, + lc($type)))); + $args->{-buttons} = [@buttons]; + $args->{-default_button} = ucfirst(delete $args->{-default}) if + defined $args->{-default}; + if (not defined $args->{-default_button} and scalar(@buttons) == 1) { + $args->{-default_button} = $buttons[0]; + } + my $md = $parent->Dialog(%$args); + my $an = $md->Show; + $md->destroy; + return $an; + } +} # end messageBox + +sub messageBox +{ + my ($widget,%args) = @_; + # remove in a later version: + if (exists $args{'-text'}) + { + warn "The -text option is deprecated. Please use -message instead"; + if (!exists $args{'-message'}) + { + $args{'-message'} = delete $args{'-text'}; + } + } + $args{'-type'} = (exists $args{'-type'}) ? lc($args{'-type'}) : 'ok'; + $args{'-default'} = lc($args{'-default'}) if (exists $args{'-default'}); + ucfirst tk_messageBox(-parent => $widget, %args); +} + +sub getOpenFile +{ + tk_getOpenFile(-parent => shift,@_); +} + +sub getSaveFile +{ + tk_getSaveFile(-parent => shift,@_); +} + +sub chooseColor +{ + tk_chooseColor(-parent => shift,@_); +} + +sub chooseDirectory +{ + tk_chooseDirectory(-parent => shift,@_); +} + +sub DialogWrapper +{ + my ($method,$kind,%args) = @_; + my $created = 0; + my $w = delete $args{'-parent'}; + if (defined $w) + { + $args{'-popover'} = $w; + } + else + { + $w = MainWindow->new; + $w->withdraw; + $created = 1; + } + my $mw = $w->toplevel; + my $fs = $mw->{$kind}; + unless (defined $fs) + { + $mw->{$kind} = $fs = $mw->$method(%args); + } + else + { + $fs->configure(%args); + } + my $val = $fs->Show; + $w->destroy if $created; + return $val; +} + +sub ColorDialog +{ + require Tk::ColorEditor; + DialogWrapper('ColorDialog',@_); +} + +sub FDialog +{ + require Tk::FBox; + my $cmd = shift; + if ($cmd =~ /Save/) + { + push @_, -type => 'save'; + } + elsif ($cmd =~ /Directory/) + { + push @_, -type => 'dir'; + } + DialogWrapper('FBox', $cmd, @_); +} + +sub DirDialog +{ + require Tk::DirTree; + DialogWrapper('DirTreeDialog',@_); +} + +*MotifFDialog = \&FDialog; + +*CORE::GLOBAL::exit = \&exit; + +sub MainLoop +{ + unless ($inMainLoop) + { + local $inMainLoop = 1; + while (Tk::MainWindow->Count) + { + DoOneEvent(0); + } + } +} + +sub tkinit { return MainWindow->new(@_) } + +# a wrapper on eval which turns off user $SIG{__DIE__} +sub catch (&) +{ + my $sub = shift; + eval {local $SIG{'__DIE__'}; &$sub }; +} + +my $Home; + +sub TranslateFileName +{ + local $_ = shift; + unless (defined $Home) + { + $Home = $ENV{'HOME'} || (defined $ENV{'HOMEDRIVE'} && defined $ENV{'HOMEPATH'} ? $ENV{'HOMEDRIVE'}.$ENV{'HOMEPATH'} : ""); + $Home =~ s#\\#/#g; + $Home .= '/' unless $Home =~ m#/$#; + } + s#~/#$Home#g; + # warn $_; + return $_; +} + +sub findINC +{ + my $file = join('/',@_); + my $dir; + $file =~ s,::,/,g; + foreach $dir (@INC) + { + my $path; + return $path if (-e ($path = "$dir/$file")); + } + return undef; +} + +sub idletasks +{ + shift->update('idletasks'); +} + +sub backtrace +{ + my ($self,$msg,$i) = @_; + $i = 1 if @_ < 3; + while (1) + { + my ($pack,$file,$line,$sub) = caller($i++); + last unless defined($sub); + $msg .= "\n $sub at $file line $line"; + } + return "$msg\n"; +} + +sub die_with_trace +{ + my ($self,$msg) = @_; + die $self->backtrace($msg,1); +} + + + +1; + +__END__ + +sub Error +{my $w = shift; + my $error = shift; + if (Exists($w)) + { + my $grab = $w->grab('current'); + $grab->Unbusy if (defined $grab); + } + chomp($error); + warn "Tk::Error: $error\n " . join("\n ",@_)."\n"; +} + +sub CancelRepeat +{ + my $w = shift->MainWindow; + my $id = delete $w->{_afterId_}; + $w->after('cancel',$id) if (defined $id); +} + +sub RepeatId +{ + my ($w,$id) = @_; + $w = $w->MainWindow; + $w->CancelRepeat; + $w->{_afterId_} = $id; +} + + + +#---------------------------------------------------------------------------- +# focus.tcl -- +# +# This file defines several procedures for managing the input +# focus. +# +# @(#) focus.tcl 1.6 94/12/19 17:06:46 +# +# Copyright (c) 1994 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +sub FocusChildren { shift->children } + +# +# focusNext -- +# This procedure is invoked to move the input focus to the next window +# after a given one. "Next" is defined in terms of the window +# stacking order, with all the windows underneath a given top-level +# (no matter how deeply nested in the hierarchy) considered except +# for frames and toplevels. +# +# Arguments: +# w - Name of a window: the procedure will set the focus +# to the next window after this one in the traversal +# order. +sub focusNext +{ + my $w = shift; + my $cur = $w; + while (1) + { + # Descend to just before the first child of the current widget. + my $parent = $cur; + my @children = $cur->FocusChildren(); + my $i = -1; + # Look for the next sibling that isn't a top-level. + while (1) + { + $i += 1; + if ($i < @children) + { + $cur = $children[$i]; + next if ($cur->toplevel == $cur); + last + } + # No more siblings, so go to the current widget's parent. + # If it's a top-level, break out of the loop, otherwise + # look for its next sibling. + $cur = $parent; + last if ($cur->toplevel() == $cur); + $parent = $parent->parent(); + @children = $parent->FocusChildren(); + $i = lsearch(\@children,$cur); + } + if ($cur == $w || $cur->FocusOK) + { + $cur->tabFocus; + return; + } + } +} +# focusPrev -- +# This procedure is invoked to move the input focus to the previous +# window before a given one. "Previous" is defined in terms of the +# window stacking order, with all the windows underneath a given +# top-level (no matter how deeply nested in the hierarchy) considered. +# +# Arguments: +# w - Name of a window: the procedure will set the focus +# to the previous window before this one in the traversal +# order. +sub focusPrev +{ + my $w = shift; + my $cur = $w; + my @children; + my $i; + my $parent; + while (1) + { + # Collect information about the current window's position + # among its siblings. Also, if the window is a top-level, + # then reposition to just after the last child of the window. + if ($cur->toplevel() == $cur) + { + $parent = $cur; + @children = $cur->FocusChildren(); + $i = @children; + } + else + { + $parent = $cur->parent(); + @children = $parent->FocusChildren(); + $i = lsearch(\@children,$cur); + } + # Go to the previous sibling, then descend to its last descendant + # (highest in stacking order. While doing this, ignore top-levels + # and their descendants. When we run out of descendants, go up + # one level to the parent. + while ($i > 0) + { + $i--; + $cur = $children[$i]; + next if ($cur->toplevel() == $cur); + $parent = $cur; + @children = $parent->FocusChildren(); + $i = @children; + } + $cur = $parent; + if ($cur == $w || $cur->FocusOK) + { + $cur->tabFocus; + return; + } + } + +} + +sub FocusOK +{ + my $w = shift; + my $value; + catch { $value = $w->cget('-takefocus') }; + if (!$@ && defined($value)) + { + return 0 if ($value eq '0'); + return $w->viewable if ($value eq '1'); + if ($value) + { + $value = $w->$value(); + return $value if (defined $value); + } + } + if (!$w->viewable) + { + return 0; + } + catch { $value = $w->cget('-state') } ; + if (!$@ && defined($value) && $value eq 'disabled') + { + return 0; + } + $value = grep(/Key|Focus/,$w->Tk::bind(),$w->Tk::bind(ref($w))); + return $value; +} + + +# focusFollowsMouse +# +# If this procedure is invoked, Tk will enter "focus-follows-mouse" +# mode, where the focus is always on whatever window contains the +# mouse. If this procedure isn't invoked, then the user typically +# has to click on a window to give it the focus. +# +# Arguments: +# None. + +sub EnterFocus +{ + my $w = shift; + return unless $w; + my $Ev = $w->XEvent; + my $d = $Ev->d; + $w->Tk::focus() if ($d eq 'NotifyAncestor' || $d eq 'NotifyNonlinear' || $d eq 'NotifyInferior'); +} + +sub tabFocus +{ + shift->Tk::focus; +} + +sub focusFollowsMouse +{ + my $widget = shift; + $widget->bind('all','<Enter>','EnterFocus'); +} + +# tkTraverseToMenu -- +# This procedure implements keyboard traversal of menus. Given an +# ASCII character "char", it looks for a menubutton with that character +# underlined. If one is found, it posts the menubutton's menu +# +# Arguments: +# w - Window in which the key was typed (selects +# a toplevel window). +# char - Character that selects a menu. The case +# is ignored. If an empty string, nothing +# happens. +sub TraverseToMenu +{ + my $w = shift; + my $char = shift; + return unless(defined $char && $char ne ''); + $w = $w->toplevel->FindMenu($char); +} +# tkFirstMenu -- +# This procedure traverses to the first menubutton in the toplevel +# for a given window, and posts that menubutton's menu. +# +# Arguments: +# w - Name of a window. Selects which toplevel +# to search for menubuttons. +sub FirstMenu +{ + my $w = shift; + $w = $w->toplevel->FindMenu(''); +} + +# These wrappers don't use method syntax so need to live +# in same package as raw Tk routines are newXS'ed into. + +sub Selection +{my $widget = shift; + my $cmd = shift; + croak 'Use SelectionOwn/SelectionOwner' if ($cmd eq 'own'); + croak "Use Selection\u$cmd()"; +} + +# If we have sub Clipboard in Tk then use base qw(Tk::Clipboard ....) +# calls it when it does its eval "require $base" +#sub Clipboard +#{my $w = shift; +# my $cmd = shift; +# croak "Use clipboard\u$cmd()"; +#} + +sub Receive +{ + my $w = shift; + warn 'Receive(' . join(',',@_) .')'; + die 'Tk rejects send(' . join(',',@_) .")\n"; +} + +sub break +{ + die "_TK_BREAK_\n"; +} + +sub updateWidgets +{ + my ($w) = @_; + while ($w->DoOneEvent(DONT_WAIT|IDLE_EVENTS|WINDOW_EVENTS)) + { + } + $w; +} + +sub ImageNames +{ + image('names'); +} + +sub ImageTypes +{ + image('types'); +} + +sub interps +{ + my $w = shift; + return $w->winfo('interps','-displayof'); +} + +sub lsearch +{my $ar = shift; + my $x = shift; + my $i; + for ($i = 0; $i < scalar @$ar; $i++) + { + return $i if ($$ar[$i] eq $x); + } + return -1; +} + + +sub getEncoding +{ + my ($class,$name) = @_; + eval { require Encode }; + if ($@) + { + require Tk::DummyEncode; + return Tk::DummyEncode->getEncoding($name); + } + $name = $Tk::font_encoding{$name} if exists $Tk::font_encoding{$name}; + my $enc = Encode::find_encoding($name); + + unless ($enc) + { + $enc = Encode::find_encoding($name) if ($name =~ s/[-_]\d+$//) + } +# if ($enc) +# { +# print STDERR "Lookup '$name' => ".$enc->name."\n"; +# } +# else +# { +# print STDERR "Failed '$name'\n"; +# } + unless ($enc) + { + if ($name eq 'X11ControlChars') + { + require Tk::DummyEncode; + $Encode::encoding{$name} = $enc = Tk::DummyEncode->getEncoding($name); + } + } + return $enc; +} + + + diff --git a/Master/tlpkg/installer/perllib/Tk/After.pm b/Master/tlpkg/installer/perllib/Tk/After.pm new file mode 100644 index 00000000000..85a0e406ee5 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Tk/After.pm @@ -0,0 +1,104 @@ +# Copyright (c) 1995-2004 Nick Ing-Simmons. All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +package Tk::After; +use Carp; + +use vars qw($VERSION); +$VERSION = '4.007'; # $Id: //depot/Tkutf8/Tk/After.pm#11 $ + +sub _cancelAll +{ + my $w = shift; + my $h = delete $w->{_After_}; + foreach my $obj (values %$h) + { + # carp "Auto cancel ".$obj->[1]." for ".$obj->[0]->PathName; + $obj->cancel; + bless $obj,"Tk::After::Cancelled"; + } +} + +sub Tk::After::Cancelled::once { } +sub Tk::After::Cancelled::repeat { } + +sub submit +{ + my $obj = shift; + my $w = $obj->[0]; + my $id = $obj->[1]; + my $t = $obj->[2]; + my $method = $obj->[3]; + delete($w->{_After_}{$id}) if (defined $id); + $id = $w->Tk::after($t,[$method => $obj]); + unless (exists $w->{_After_}) + { + $w->{_After_} = {}; + $w->OnDestroy([\&_cancelAll, $w]); + } + $w->{_After_}{$id} = $obj; + $obj->[1] = $id; + return $obj; +} + +sub DESTROY +{ + my $obj = shift; + $obj->cancel; + undef $obj->[0]; + undef $obj->[4]; +} + +sub new +{ + my ($class,$w,$t,$method,@cb) = @_; + my $cb = (@cb == 1) ? shift(@cb) : [@cb]; + my $obj = bless [$w,undef,$t,$method,Tk::Callback->new($cb)],$class; + return $obj->submit; +} + +sub cancel +{ + my $obj = shift; + my $id = $obj->[1]; + my $w = $obj->[0]; + if ($id) + { + $w->Tk::after('cancel'=> $id) if Tk::Exists($w); + delete $w->{_After_}{$id} if exists $w->{_After_}; + $obj->[1] = undef; + } + return $obj; +} + +sub repeat +{ + my $obj = shift; + $obj->submit; + local $Tk::widget = $obj->[0]; + $obj->[4]->Call; +} + +sub once +{ + my $obj = shift; + my $w = $obj->[0]; + my $id = $obj->[1]; + delete $w->{_After_}{$id}; + local $Tk::widget = $w; + $obj->[4]->Call; +} + +sub time { + my $obj = shift; + my $delay = shift; + if (defined $delay) { + $obj->cancel if $delay == 0; + $obj->[2] = $delay; + } + $obj->[2]; +} + +1; +__END__ + diff --git a/Master/tlpkg/installer/perllib/Tk/Button.pm b/Master/tlpkg/installer/perllib/Tk/Button.pm new file mode 100644 index 00000000000..efa597dee14 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Tk/Button.pm @@ -0,0 +1,148 @@ +package Tk::Button; +# Conversion from Tk4.0 button.tcl competed. +# +# Copyright (c) 1992-1994 The Regents of the University of California. +# Copyright (c) 1994 Sun Microsystems, Inc. +# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved. +# This program is free software; you can redistribute it and/or + +use vars qw($VERSION); +$VERSION = '4.008'; # $Id: //depot/Tkutf8/Tk/Button.pm#8 $ + +# modify it under the same terms as Perl itself, subject +# to additional disclaimer in license.terms due to partial +# derivation from Tk4.0 sources. + +use strict; + +require Tk::Widget; +use base qw(Tk::Widget); + +use vars qw($buttonWindow $relief); + +Tk::Methods('deselect','flash','invoke','select','toggle'); + +sub Tk_cmd { \&Tk::button } + +Construct Tk::Widget 'Button'; + +sub ClassInit +{ + my ($class,$mw) = @_; + $mw->bind($class,'<Enter>', 'Enter'); + $mw->bind($class,'<Leave>', 'Leave'); + $mw->bind($class,'<1>', 'butDown'); + $mw->bind($class,'<ButtonRelease-1>', 'butUp'); + $mw->bind($class,'<space>', 'Invoke'); + $mw->bind($class,'<Return>', 'Invoke'); + return $class; +} + +# tkButtonEnter -- +# The procedure below is invoked when the mouse pointer enters a +# button widget. It records the button we're in and changes the +# state of the button to active unless the button is disabled. +# +# Arguments: +# w - The name of the widget. + +sub Enter +{ + my $w = shift; + my $E = shift; + if ($w->cget('-state') ne 'disabled') + { + $w->configure('-state' => 'active'); + $w->configure('-state' => 'active', '-relief' => 'sunken') if (defined($buttonWindow) && $w == $buttonWindow) + } + $Tk::window = $w; +} + +# tkButtonLeave -- +# The procedure below is invoked when the mouse pointer leaves a +# button widget. It changes the state of the button back to +# inactive. If we're leaving the button window with a mouse button +# pressed (tkPriv(buttonWindow) == $w), restore the relief of the +# button too. +# +# Arguments: +# w - The name of the widget. +sub Leave +{ + my $w = shift; + $w->configure('-state'=>'normal') if ($w->cget('-state') ne 'disabled'); + $w->configure('-relief' => $relief) if (defined($buttonWindow) && $w == $buttonWindow); + undef $Tk::window; +} + +# tkButtonDown -- +# The procedure below is invoked when the mouse button is pressed in +# a button widget. It records the fact that the mouse is in the button, +# saves the button's relief so it can be restored later, and changes +# the relief to sunken. +# +# Arguments: +# w - The name of the widget. +sub butDown +{ + my $w = shift; + $relief = $w->cget('-relief'); + if ($w->cget('-state') ne 'disabled') + { + $buttonWindow = $w; + $w->configure('-relief' => 'sunken') + } +} + +# tkButtonUp -- +# The procedure below is invoked when the mouse button is released +# in a button widget. It restores the button's relief and invokes +# the command as long as the mouse hasn't left the button. +# +# Arguments: +# w - The name of the widget. +sub butUp +{ + my $w = shift; + if (defined($buttonWindow) && $buttonWindow == $w) + { + undef $buttonWindow; + $w->configure('-relief' => $relief); + if ($w->IS($Tk::window) && $w->cget('-state') ne 'disabled') + { + $w->invoke; + } + } +} + +# tkButtonInvoke -- +# The procedure below is called when a button is invoked through +# the keyboard. It simulate a press of the button via the mouse. +# +# Arguments: +# w - The name of the widget. +sub Invoke +{ + my $w = shift; + if ($w->cget('-state') ne 'disabled') + { + my $oldRelief = $w->cget('-relief'); + my $oldState = $w->cget('-state'); + $w->configure('-state' => 'active', '-relief' => 'sunken'); + $w->idletasks; + $w->after(100); + $w->configure('-state' => $oldState, '-relief' => $oldRelief); + $w->invoke; + } +} + + + +1; + +__END__ + + + + + diff --git a/Master/tlpkg/installer/perllib/Tk/Checkbutton.pm b/Master/tlpkg/installer/perllib/Tk/Checkbutton.pm new file mode 100644 index 00000000000..491d8cd2444 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Tk/Checkbutton.pm @@ -0,0 +1,42 @@ +package Tk::Checkbutton; +# Conversion from Tk4.0 button.tcl competed. +# Copyright (c) 1992-1994 The Regents of the University of California. +# Copyright (c) 1994 Sun Microsystems, Inc. +# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved. +# This program is free software; you can redistribute it and/or + + +use vars qw($VERSION); +$VERSION = '4.006'; # $Id: //depot/Tkutf8/Tk/Checkbutton.pm#6 $ + +# modify it under the same terms as Perl itself, subject +# to additional disclaimer in license.terms due to partial +# derivation from Tk4.0 sources. + +require Tk::Widget; +require Tk::Button; + +use base qw(Tk::Button); + +Construct Tk::Widget 'Checkbutton'; + +sub Tk_cmd { \&Tk::checkbutton } + + +sub ClassInit +{ + my ($class,$mw) = @_; + $mw->bind($class,'<Enter>', 'Enter'); + $mw->bind($class,'<Leave>', 'Leave'); + $mw->bind($class,'<1>', 'Invoke'); + $mw->bind($class,'<space>', 'Invoke'); + return $class; +} + +sub Invoke +{ + my $w = shift; + $w->invoke() unless($w->cget('-state') eq 'disabled'); +} + +1; diff --git a/Master/tlpkg/installer/perllib/Tk/Clipboard.pm b/Master/tlpkg/installer/perllib/Tk/Clipboard.pm new file mode 100644 index 00000000000..b0eb0ea2b07 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Tk/Clipboard.pm @@ -0,0 +1,122 @@ +# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +package Tk::Clipboard; +use strict; + +use vars qw($VERSION); +$VERSION = sprintf '4.%03d', q$Revision: #8 $ =~ /\D(\d+)\s*$/; + +use AutoLoader qw(AUTOLOAD); +use Tk qw(catch); + +sub clipEvents +{ + return qw[Copy Cut Paste]; +} + +sub ClassInit +{ + my ($class,$mw) = @_; + foreach my $op ($class->clipEvents) + { + $mw->Tk::bind($class,"<<$op>>","clipboard$op"); + } + return $class; +} + +sub clipboardSet +{ + my $w = shift; + $w->clipboardClear; + $w->clipboardAppend(@_); +} + +sub clipboardCopy +{ + my $w = shift; + my $val = $w->getSelected; + if (defined $val) + { + $w->clipboardSet('--',$val); + } + return $val; +} + +sub clipboardCut +{ + my $w = shift; + my $val = $w->clipboardCopy; + if (defined $val) + { + $w->deleteSelected; + } + return $val; +} + +sub clipboardGet +{ + my $w = shift; + $w->SelectionGet('-selection','CLIPBOARD',@_); +} + +sub clipboardPaste +{ + my $w = shift; + local $@; + catch + { +## Different from Tcl/Tk version: +# if ($w->windowingsystem eq 'x11') +# { +# catch +# { +# $w->deleteSelected; +# }; +# } + $w->insert("insert", $w->clipboardGet); + $w->SeeInsert if $w->can('SeeInsert'); + }; +} + +sub clipboardOperations +{ + my @class = (); + my $mw = shift; + if (ref $mw) + { + $mw = $mw->DelegateFor('bind'); + } + else + { + push(@class,$mw); + $mw = shift; + } + while (@_) + { + my $op = shift; + $mw->Tk::bind(@class,"<<$op>>","clipboard$op"); + } +} + +# These methods work for Entry and Text +# and can be overridden where they don't work + +sub deleteSelected +{ + my $w = shift; + catch { $w->delete('sel.first','sel.last') }; +} + + +1; +__END__ + +sub getSelected +{ + my $w = shift; + my $val = Tk::catch { $w->get('sel.first','sel.last') }; + return $val; +} + + diff --git a/Master/tlpkg/installer/perllib/Tk/CmdLine.pm b/Master/tlpkg/installer/perllib/Tk/CmdLine.pm new file mode 100644 index 00000000000..2e821e826ae --- /dev/null +++ b/Master/tlpkg/installer/perllib/Tk/CmdLine.pm @@ -0,0 +1,954 @@ +package Tk::CmdLine; # -*-Perl-*- + +#/----------------------------------------------------------------------------// +#/ Module: Tk/CmdLine.pm +#/ +#/ Purpose: +#/ +#/ Process standard X11 command line options and set initial resources. +#/ +#/ Author: ???? Date: ???? +#/ +#/ History: SEE POD +#/----------------------------------------------------------------------------// + +use vars qw($VERSION); +$VERSION = '4.006'; # $Id: //depot/Tkutf8/Tk/CmdLine.pm#6 $ + +use 5.004; + +use strict; + +use Config; + +my $OBJECT = undef; # define the current object + +#/----------------------------------------------------------------------------// +#/ Constructor +#/ Returns the object reference. +#/----------------------------------------------------------------------------// + +sub new # Tk::CmdLine::new() +{ + my $this = shift(@_); + my $class = ref($this) || $this; + + my $name = 'pTk'; + $name = $1 if (($0 =~ m/(?:^|[\/\\])([\w-]+)(?:\.\w+)?$/) && ($1 ne '-e')); + + my $self = { + name => $name, + config => { -name => $name }, + options => {}, + methods => {}, + command => [], + synchronous => 0, + iconic => 0, + motif => ($Tk::strictMotif || 0), + resources => {} }; + + return bless($self, $class); +} + +#/----------------------------------------------------------------------------// +#/ Process the arguments in a given array or in @ARGV. +#/ Returns the object reference. +#/----------------------------------------------------------------------------// + +sub Argument_ # Tk::CmdLine::Argument_($flag) # private method +{ + my $self = shift(@_); + my $flag = shift(@_); + unless ($self->{offset} < @{$self->{argv}}) + { + die 'Usage: ', $self->{name}, ' ... ', $flag, " <argument> ...\n"; + } + return splice(@{$self->{argv}}, $self->{offset}, 1); +} + +sub Config_ # Tk::CmdLine::Config_($flag, $name) # private method +{ + my $self = shift(@_); + my ($flag, $name) = @_; + my $val = $self->Argument_($flag); + push(@{$self->{command}}, $flag, $val); + $self->{config}->{"-$name"} = $val; +} + +sub Flag_ # Tk::CmdLine::Flag_($flag, $name) # private method +{ + my $self = shift(@_); + my ($flag, $name) = @_; + push(@{$self->{command}}, $flag); + $self->{$name} = 1; +} + +sub Option_ # Tk::CmdLine::Option_($flag, $name) # private method +{ + my $self = shift(@_); + my ($flag, $name) = @_; + my $val = $self->Argument_($flag); + push(@{$self->{command}}, $flag, $val); + $self->{options}->{"*$name"} = $val; +} + +sub Method_ # Tk::CmdLine::Method_($flag, $name) # private method +{ + my $self = shift(@_); + my ($flag, $name) = @_; + my $val = $self->Argument_($flag); + push(@{$self->{command}}, $flag, $val); + $self->{methods}->{$name} = $val; +} + +sub Resource_ # Tk::CmdLine::Resource_($flag, $name) # private method +{ + my $self = shift(@_); + my ($flag, $name) = @_; + my $val = $self->Argument_($flag); + if ($val =~ /^([^!:\s]+)*\s*:\s*(.*)$/) + { + push(@{$self->{command}}, $flag, $val); + $self->{options}->{$1} = $2; + } +} + +my %Method = ( + background => 'Option_', + bg => 'background', # alias + class => 'Config_', + display => 'screen', # alias + fg => 'foreground', # alias + fn => 'font', # alias + font => 'Option_', + foreground => 'Option_', + geometry => 'Method_', + iconic => 'Flag_', + iconposition => 'Method_', + motif => 'Flag_', + name => 'Config_', + screen => 'Config_', + synchronous => 'Flag_', + title => 'Config_', + xrm => 'Resource_' +); + +sub SetArguments # Tk::CmdLine::SetArguments([@argument]) +{ + my $self = (@_ # define the object as necessary + ? ((ref($_[0]) eq __PACKAGE__) + ? shift(@_) + : (($_[0] eq __PACKAGE__) ? shift(@_) : 1) && ($OBJECT ||= __PACKAGE__->new())) + : ($OBJECT ||= __PACKAGE__->new())); + $OBJECT = $self; # update the current object + $self->{argv} = (@_ ? [ @_ ] : \@ARGV); + $self->{offset} = 0; # its existence will denote that this method has been called + + my @option = (); + + while ($self->{offset} < @{$self->{argv}}) + { + last if ($self->{argv}->[$self->{offset}] eq '--'); + unless ( + (($self->{argv}->[$self->{offset}] =~ /^-{1,2}(\w+)$/) && (@option = $1)) || + (($self->{argv}->[$self->{offset}] =~ /^--(\w+)=(.*)$/) && (@option = ($1, $2)))) + { + ++$self->{offset}; + next; + } + + next if (!exists($Method{$option[0]}) && ++$self->{offset}); + + $option[0] = $Method{$option[0]} if exists($Method{$Method{$option[0]}}); + + my $method = $Method{$option[0]}; + + if (@option > 1) # replace --<option>=<value> with <value> + { + $self->{argv}->[$self->{offset}] = $option[1]; + } + else # remove the argument + { + splice(@{$self->{argv}}, $self->{offset}, 1); + } + + $self->$method(('-' . $option[0]), $option[0]); + } + + $self->{config}->{-class} ||= ucfirst($self->{config}->{-name}); + + delete($self->{argv}); # no longer needed + + return $self; +} + +use vars qw(&process); *process = \&SetArguments; # alias to keep old code happy + +#/----------------------------------------------------------------------------// +#/ Get a list of the arguments that have been processed by SetArguments(). +#/ Returns an array. +#/----------------------------------------------------------------------------// + +sub GetArguments # Tk::CmdLine::GetArguments() +{ + my $self = (@_ # define the object as necessary + ? ((ref($_[0]) eq __PACKAGE__) + ? shift(@_) + : (($_[0] eq __PACKAGE__) ? shift(@_) : 1) && ($OBJECT ||= __PACKAGE__->new())) + : ($OBJECT ||= __PACKAGE__->new())); + $OBJECT = $self; # update the current object + + $self->SetArguments() unless exists($self->{offset}); # set arguments if not yet done + + return @{$self->{command}}; +} + +#/----------------------------------------------------------------------------// +#/ Get the value of a configuration option (default: -class). +#/ Returns the option value. +#/----------------------------------------------------------------------------// + +sub cget # Tk::CmdLine::cget([$option]) +{ + my $self = (@_ # define the object as necessary + ? ((ref($_[0]) eq __PACKAGE__) + ? shift(@_) + : (($_[0] eq __PACKAGE__) ? shift(@_) : 1) && ($OBJECT ||= __PACKAGE__->new())) + : ($OBJECT ||= __PACKAGE__->new())); + $OBJECT = $self; # update the current object + my $option = shift(@_) || '-class'; + + $self->SetArguments() unless exists($self->{offset}); # set arguments if not yet done + + return (exists($self->{config}->{$option}) ? $self->{config}->{$option} : undef); +} + +#/----------------------------------------------------------------------------// + +sub CreateArgs # Tk::CmdLine::CreateArgs() +{ + my $self = (@_ # define the object as necessary + ? ((ref($_[0]) eq __PACKAGE__) + ? shift(@_) + : (($_[0] eq __PACKAGE__) ? shift(@_) : 1) && ($OBJECT ||= __PACKAGE__->new())) + : ($OBJECT ||= __PACKAGE__->new())); + $OBJECT = $self; # update the current object + + $self->SetArguments() unless exists($self->{offset}); # set arguments if not yet done + + return $self->{config}; +} + +#/----------------------------------------------------------------------------// + +sub Tk::MainWindow::apply_command_line +{ + my $mw = shift(@_); + + my $self = ($OBJECT ||= __PACKAGE__->new()); + + $self->SetArguments() unless exists($self->{offset}); # set arguments if not yet done + + foreach my $priority (keys(%{$self->{resources}})) + { + foreach my $resource (@{$self->{resources}->{$priority}}) + { + $mw->optionAdd(@{$resource}, $priority); + } + } + + foreach my $key (keys(%{$self->{options}})) + { + $mw->optionAdd($key => $self->{options}->{$key}, 'interactive'); + } + + foreach my $key (keys(%{$self->{methods}})) + { + $mw->$key($self->{methods}->{$key}); + } + + if ($self->{methods}->{geometry}) + { + if ($self->{methods}->{geometry} =~ /[+-]\d+[+-]\d+/) + { + $mw->positionfrom('user'); + } + if ($self->{methods}->{geometry} =~ /\d+x\d+/) + { + $mw->sizefrom('user'); + } + delete $self->{methods}->{geometry}; # XXX needed? + } + + $mw->Synchronize() if $self->{synchronous}; + + if ($self->{iconic}) + { + $mw->iconify(); + $self->{iconic} = 0; + } + + $Tk::strictMotif = ($self->{motif} || 0); + + # Both these are needed to reliably save state + # but 'hostname' is tricky to do portably. + # $mw->client(hostname()); + $mw->protocol('WM_SAVE_YOURSELF' => ['WMSaveYourself',$mw]); + $mw->command([ $self->{name}, @{$self->{command}} ]); +} + +#/----------------------------------------------------------------------------// +#/ Set the initial resources. +#/ Returns the object reference. +#/----------------------------------------------------------------------------// + +sub SetResources # Tk::CmdLine::SetResources((\@resource | $resource) [, $priority]) +{ + my $self = (@_ # define the object as necessary + ? ((ref($_[0]) eq __PACKAGE__) + ? shift(@_) + : (($_[0] eq __PACKAGE__) ? shift(@_) : 1) && ($OBJECT ||= __PACKAGE__->new())) + : ($OBJECT ||= __PACKAGE__->new())); + $OBJECT = $self; # update the current object + + $self->SetArguments() unless exists($self->{offset}); # set arguments if not yet done + return $self unless @_; + + my $data = shift(@_); + my $priority = shift(@_) || 'userDefault'; + + $self->{resources}->{$priority} = [] unless exists($self->{resources}->{$priority}); + + foreach my $resource ((ref($data) eq 'ARRAY') ? @{$data} : $data) + { + if (ref($resource) eq 'ARRAY') # resources in [ <pattern>, <value> ] format + { + push(@{$self->{resources}->{$priority}}, [ @{$resource} ]) + if (@{$resource} == 2); + } + else # resources in resource file format + { + push(@{$self->{resources}->{$priority}}, [ $1, $2 ]) + if ($resource =~ /^([^!:\s]+)*\s*:\s*(.*)$/); + } + } + + return $self; +} + +#/----------------------------------------------------------------------------// +#/ Load initial resources from one or more files (default: $XFILESEARCHPATH with +#/ priority 'startupFile' and $XUSERFILESEARCHPATH with priority 'userDefault'). +#/ Returns the object reference. +#/----------------------------------------------------------------------------// + +sub LoadResources # Tk::CmdLine::LoadResources([%options]) +{ + my $self = (@_ # define the object as necessary + ? ((ref($_[0]) eq __PACKAGE__) + ? shift(@_) + : (($_[0] eq __PACKAGE__) ? shift(@_) : 1) && ($OBJECT ||= __PACKAGE__->new())) + : ($OBJECT ||= __PACKAGE__->new())); + $OBJECT = $self; # update the current object + + $self->SetArguments() unless exists($self->{offset}); # set arguments if not yet done + + my %options = @_; + + my @file = (); + my $echo = (exists($options{-echo}) + ? (defined($options{-echo}) ? $options{-echo} : \*STDOUT) : undef); + + unless (%options && (exists($options{-file}) || exists($options{-symbol}))) + { + @file = ( + { -symbol => 'XFILESEARCHPATH', -priority => 'startupFile' }, + { -symbol => 'XUSERFILESEARCHPATH', -priority => 'userDefault' } ); + } + else + { + @file = { %options }; + } + + my $delimiter = (($^O eq 'MSWin32') ? ';' : ':'); + + foreach my $file (@file) + { + my $fileSpec = $file->{-spec} = undef; + if (exists($file->{-symbol})) + { + my $xpath = undef; + if ($file->{-symbol} eq 'XUSERFILESEARCHPATH') + { + $file->{-priority} ||= 'userDefault'; + foreach my $symbol (qw(XUSERFILESEARCHPATH XAPPLRESDIR HOME)) + { + last if (exists($ENV{$symbol}) && ($xpath = $ENV{$symbol})); + } + next unless defined($xpath); + } + else + { + $file->{-priority} ||= (($file->{-symbol} eq 'XFILESEARCHPATH') + ? 'startupFile' : 'userDefault'); + next unless ( + exists($ENV{$file->{-symbol}}) && ($xpath = $ENV{$file->{-symbol}})); + } + + unless (exists($self->{translation})) + { + $self->{translation} = { + '%l' => '', # ignored + '%C' => '', # ignored + '%S' => '', # ignored + '%L' => ($ENV{LANG} || 'C'), # language + '%T' => 'app-defaults', # type + '%N' => $self->{config}->{-class} # filename + }; + } + + my @postfix = map({ $_ . '/' . $self->{config}->{-class} } + ('/' . $self->{translation}->{'%L'}), ''); + + ITEM: foreach $fileSpec (split($Config{path_sep}, $xpath)) + { + if ($fileSpec =~ s/(%[A-Za-z])/$self->{translation}->{$1}/g) # File Pattern + { + if (defined($echo) && ($file->{-symbol} ne 'XFILESEARCHPATH')) + { + print $echo 'Checking ', $fileSpec, "\n"; + } + next unless ((-f $fileSpec) && (-r _) && (-s _)); + $file->{-spec} = $fileSpec; + last; + } + else # Directory - Check for <Directory>/$LANG/<Class>, <Directory>/<CLASS> + { + foreach my $postfix (@postfix) + { + my $fileSpec2 = $fileSpec . $postfix; + if (defined($echo) && ($file->{-symbol} ne 'XFILESEARCHPATH')) + { + print $echo 'Checking ', $fileSpec2, "\n"; + } + next unless ((-f $fileSpec2) && (-r _) && (-s _)); + $file->{-spec} = $fileSpec2; + last ITEM; + } + } + } + } + elsif (exists($file->{-file}) && ($fileSpec = $file->{-file})) + { + print $echo 'Checking ', $fileSpec, "\n" if defined($echo); + next unless ((-f $fileSpec) && (-r _) && (-s _)); + $file->{-spec} = $fileSpec; + } + } + + foreach my $file (@file) + { + next unless defined($file->{-spec}); + local *SPEC; + next unless open(SPEC,$file->{-spec}); + print $echo ' Loading ', $file->{-spec}, "\n" if defined($echo); + + my $resource = undef; + my @resource = (); + my $continuation = 0; + + while (defined(my $line = <SPEC>)) + { + chomp($line); + next if ($line =~ /^\s*$/); # skip blank lines + next if ($line =~ /^\s*!/); # skip comments + $continuation = ($line =~ s/\s*\\$/ /); # search for trailing backslash + unless (defined($resource)) # it is the first line + { + $resource = $line; + } + else # it is a continuation line + { + $line =~ s/^\s*//; # remove leading whitespace + $resource .= $line; + } + next if $continuation; + push(@resource, [ $1, $2 ]) if ($resource =~ /^([^:\s]+)*\s*:\s*(.*)$/); + $resource = undef; + } + + close(SPEC); + + if (defined($resource)) # special case - EOF after line with trailing backslash + { + push(@resource, [ $1, $2 ]) if ($resource =~ /^([^:\s]+)*\s*:\s*(.*)$/); + } + + $self->SetResources(\@resource, $file->{-priority}) if @resource; + } + + return $self; +} + +#/----------------------------------------------------------------------------// + +1; + +__END__ + +=cut + +=head1 NAME + +Tk::CmdLine - Process standard X11 command line options and set initial resources + +=for pm Tk/CmdLine.pm + +=for category Creating and Configuring Widgets + +=head1 SYNOPSIS + + Tk::CmdLine::SetArguments([@argument]); + + my $value = Tk::CmdLine::cget([$option]); + + Tk::CmdLine::SetResources((\@resource | $resource) [, $priority]); + + Tk::CmdLine::LoadResources( + [ -symbol => $symbol ] + [ -file => $fileSpec ] + [ -priority => $priority ] + [ -echo => $fileHandle ] ); + +=head1 DESCRIPTION + +Process standard X11 command line options and set initial resources. + +The X11R5 man page for X11 says: "Most X programs attempt to use the same names +for command line options and arguments. All applications written with the +X Toolkit Intrinsics automatically accept the following options: ...". +This module processes these command line options for perl/Tk applications +using the C<SetArguments>() function. + +This module can optionally be used to load initial resources explicitly via +function C<SetResources>(), or from specified files (default: the standard X11 +application-specific resource files) via function C<LoadResources>(). + +=head2 Command Line Options + +=over 4 + +=item B<-background> I<Color> | B<-bg> I<Color> + +Specifies the color to be used for the window background. + +=item B<-class> I<Class> + +Specifies the class under which resources for the application should be found. +This option is useful in shell aliases to distinguish between invocations +of an application, without resorting to creating links to alter the executable +file name. + +=item B<-display> I<Display> | B<-screen> I<Display> + +Specifies the name of the X server to be used. + +=item B<-font> I<Font> | B<-fn> I<Font> + +Specifies the font to be used for displaying text. + +=item B<-foreground> I<Color> | B<-fg> I<Color> + +Specifies the color to be used for text or graphics. + +=item B<-geometry> I<Geometry> + +Specifies the initial size and location of the I<first> +L<MainWindow|Tk::MainWindow>. + +=item B<-iconic> + +Indicates that the user would prefer that the application's windows initially +not be visible as if the windows had been immediately iconified by the user. +Window managers may choose not to honor the application's request. + +=item B<-motif> + +Specifies that the application should adhere as closely as possible to Motif +look-and-feel standards. For example, active elements such as buttons and +scrollbar sliders will not change color when the pointer passes over them. + +=item B<-name> I<Name> + +Specifies the name under which resources for the application should be found. +This option is useful in shell aliases to distinguish between invocations +of an application, without resorting to creating links to alter the executable +file name. + +=item B<-synchronous> + +Indicates that requests to the X server should be sent synchronously, instead of +asynchronously. Since Xlib normally buffers requests to the server, errors do +do not necessarily get reported immediately after they occur. This option turns +off the buffering so that the application can be debugged. It should never +be used with a working program. + +=item B<-title> I<TitleString> + +This option specifies the title to be used for this window. This information is +sometimes used by a window manager to provide some sort of header identifying +the window. + +=item B<-xrm> I<ResourceString> + +Specifies a resource pattern and value to override any defaults. It is also +very useful for setting resources that do not have explicit command line +arguments. + +The I<ResourceString> is of the form E<lt>I<pattern>E<gt>:E<lt>I<value>E<gt>, +that is (the first) ':' is used to determine which part is pattern and which +part is value. The (E<lt>I<pattern>E<gt>, E<lt>I<value>E<gt>) pair is entered +into the options database with B<optionAdd> (for each +L<MainWindow|Tk::MainWindow> configured), with I<interactive> priority. + +=back + +=head2 Initial Resources + +There are several mechanism for initializing the resource database to be used +by an X11 application. Resources may be defined in a $C<HOME>/.Xdefaults file, +a system application defaults file (e.g. +/usr/lib/X11/app-defaults/E<lt>B<CLASS>E<gt>), +or a user application defaults file (e.g. $C<HOME>/E<lt>B<CLASS>E<gt>). +The Tk::CmdLine functionality for setting initial resources concerns itself +with the latter two. + +Resource files contain data lines of the form +E<lt>I<pattern>E<gt>:E<lt>I<value>E<gt>. +They may also contain blank lines and comment lines (denoted +by a ! character as the first non-blank character). Refer to L<option|Tk::option> +for a description of E<lt>I<pattern>E<gt>:E<lt>I<value>E<gt>. + +=over 4 + +=item System Application Defaults Files + +System application defaults files may be specified via environment variable +$C<XFILESEARCHPATH> which, if set, contains a list of file patterns +(joined using the OS-dependent path delimiter, e.g. colon on B<UNIX>). + +=item User Application Defaults Files + +User application defaults files may be specified via environment variables +$C<XUSERFILESEARCHPATH>, $C<XAPPLRESDIR> or $C<HOME>. + +=back + +=head1 METHODS + +=over 4 + +=item B<SetArguments> - Tk::CmdLine::SetArguments([@argument]) + +Extract the X11 options contained in a specified array (@ARGV by default). + + Tk::CmdLine::SetArguments([@argument]) + +The X11 options may be specified using a single dash I<-> as per the X11 +convention, or using two dashes I<--> as per the POSIX standard (e.g. +B<-geometry> I<100x100>, B<-geometry> I<100x100> or B<-geometry=>I<100x100>). +The options may be interspersed with other options or arguments. +A I<--> by itself terminates option processing. + +By default, command line options are extracted from @ARGV the first time +a MainWindow is created. The Tk::MainWindow constructor indirectly invokes +C<SetArguments>() to do this. + +=item B<GetArguments> - Tk::CmdLine::GetArguments() + +Get a list of the X11 options that have been processed by C<SetArguments>(). +(C<GetArguments>() first invokes C<SetArguments>() if it has not already been invoked.) + +=item B<cget> - Tk::CmdLine::cget([$option]) + +Get the value of a configuration option specified via C<SetArguments>(). +(C<cget>() first invokes C<SetArguments>() if it has not already been invoked.) + + Tk::CmdLine::cget([$option]) + +The valid options are: B<-class>, B<-name>, B<-screen> and B<-title>. +If no option is specified, B<-class> is implied. + +A typical use of C<cget>() might be to obtain the application class in order +to define the name of a resource file to be loaded in via C<LoadResources>(). + + my $class = Tk::CmdLine::cget(); # process command line and return class + +=item B<SetResources> - Tk::CmdLine::SetResources((\@resource | $resource) [, $priority]) + +Set the initial resources. + + Tk::CmdLine::SetResources((\@resource | $resource) [, $priority]) + +A single resource may be specified using a string of the form +'E<lt>I<pattern>E<gt>:E<lt>I<value>E<gt>'. Multiple resources may be specified +by passing an array reference whose elements are either strings of the above +form, and/or anonymous arrays of the form [ E<lt>I<pattern>E<gt>, +E<lt>I<value>E<gt> ]. The optional second argument specifies the priority, +as defined in L<option|Tk::option>, to be associated with the resources +(default: I<userDefault>). + +Note that C<SetResources>() first invokes C<SetArguments>() if it has not already +been invoked. + +=item B<LoadResources> - Tk::CmdLine::LoadResources([%options]) + +Load initial resources from one or more files. + + Tk::CmdLine::LoadResources( + [ -symbol => $symbol ] + [ -file => $fileSpec ] + [ -priority => $priority ] + [ -echo => $fileHandle ] ); + +[ B<-symbol> =E<gt> $symbol ] specifies the name of an environment variable +that, if set, defines a list of one or more directories and/or file patterns +(joined using the OS-dependent path delimiter, e.g. colon on B<UNIX>). +$C<XUSERFILESEARCHPATH> is a special case. +If $C<XUSERFILESEARCHPATH> is not set, $C<XAPPLRESDIR> is checked instead. +If $C<XAPPLRESDIR> is not set, $C<HOME> is checked instead. + +An item is identified as a file pattern if it contains one or more /%[A-Za-z]/ +patterns. Only patterns B<%L>, B<%T> and B<%N> are currently recognized. All +others are replaced with the null string. Pattern B<%L> is translated into +$C<LANG>. Pattern B<%T> is translated into I<app-defaults>. Pattern B<%N> is +translated into the application class name. + +Each file pattern, after substitutions are applied, is assumed to define a +FileSpec to be examined. + +When a directory is specified, FileSpecs +E<lt>B<DIRECTORY>E<gt>/E<lt>B<LANG>E<gt>/E<lt>B<CLASS>E<gt> +and E<lt>B<DIRECTORY>E<gt>/E<lt>B<CLASS>E<gt> are defined, in that order. + +[ B<-file> =E<gt> $fileSpec ] specifies a resource file to be loaded in. +The file is silently skipped if if does not exist, or if it is not readable. + +[ B<-priority> =E<gt> $priority ] specifies the priority, as defined in +L<option|Tk::option>, to be associated with the resources +(default: I<userDefault>). + +[ B<-echo> =E<gt> $fileHandle ] may be used to specify that a line should be +printed to the corresponding FileHandle (default: \*STDOUT) everytime a file +is examined / loaded. + +If no B<-symbol> or B<-file> options are specified, C<LoadResources>() +processes symbol $C<XFILESEARCHPATH> with priority I<startupFile> and +$C<XUSERFILESEARCHPATH> with priority I<userDefault>. +(Note that $C<XFILESEARCHPATH> and $C<XUSERFILESEARCHPATH> are supposed to +contain only patterns. $C<XAPPLRESDIR> and $C<HOME> are supposed to be a single +directory. C<LoadResources>() does not check/care whether this is the case.) + +For each set of FileSpecs, C<LoadResources>() examines each FileSpec to +determine if the file exists and is readable. The first file that meets this +criteria is read in and C<SetResources>() is invoked. + +Note that C<LoadResources>() first invokes C<SetArguments>() if it has not already +been invoked. + +=back + +=head1 NOTES + +This module is an object-oriented module whose methods can be invoked as object +methods, class methods or regular functions. This is accomplished via an +internally-maintained object reference which is created as necessary, and which +always points to the last object used. C<SetArguments>(), C<SetResources>() and +C<LoadResources>() return the object reference. + +=head1 EXAMPLES + +=over + +=item 1 + +@ARGV is processed by Tk::CmdLine at MainWindow creation. + + use Tk; + + # <Process @ARGV - ignoring all X11-specific options> + + my $mw = MainWindow->new(); + + MainLoop(); + +=item 2 + +@ARGV is processed by Tk::CmdLine before MainWindow creation. +An @ARGV of (--geometry=100x100 -opt1 a b c -bg red) +is equal to (-opt1 a b c) after C<SetArguments>() is invoked. + + use Tk; + + Tk::CmdLine::SetArguments(); # Tk::CmdLine->SetArguments() works too + + # <Process @ARGV - not worrying about X11-specific options> + + my $mw = MainWindow->new(); + + MainLoop(); + +=item 3 + +Just like 2) except that default arguments are loaded first. + + use Tk; + + Tk::CmdLine::SetArguments(qw(-name test -iconic)); + Tk::CmdLine::SetArguments(); + + # <Process @ARGV - not worrying about X11-specific options> + + my $mw = MainWindow->new(); + + MainLoop(); + +=item 4 + +@ARGV is processed by Tk::CmdLine before MainWindow creation. +Standard resource files are loaded in before MainWindow creation. + + use Tk; + + Tk::CmdLine::SetArguments(); + + # <Process @ARGV - not worrying about X11-specific options> + + Tk::CmdLine::LoadResources(); + + my $mw = MainWindow->new(); + + MainLoop(); + +=item 5 + +@ARGV is processed by Tk::CmdLine before MainWindow creation. +Standard resource files are loaded in before MainWindow creation +using non-default priorities. + + use Tk; + + Tk::CmdLine::SetArguments(); + + # <Process @ARGV - not worrying about X11-specific options> + + Tk::CmdLine::LoadResources(-echo => \*STDOUT, + -priority => 65, -symbol => 'XFILESEARCHPATH' ); + Tk::CmdLine::LoadResources(-echo => \*STDOUT, + -priority => 75, -symbol => 'XUSERFILESEARCHPATH' ); + + my $mw = MainWindow->new(); + + MainLoop(); + +=item 6 + +@ARGV is processed by Tk::CmdLine before MainWindow creation. +Standard resource files are loaded in before MainWindow creation. +Individual resources are also loaded in before MainWindow creation. + + use Tk; + + Tk::CmdLine::SetArguments(); + + # <Process @ARGV - not worrying about X11-specific options> + + Tk::CmdLine::LoadResources(); + + Tk::CmdLine::SetResources( # set a single resource + '*Button*background: red', + 'widgetDefault' ); + + Tk::CmdLine::SetResources( # set multiple resources + [ '*Button*background: red', '*Button*foreground: blue' ], + 'widgetDefault' ); + + my $mw = MainWindow->new(); + + MainLoop(); + +=back + +=head1 ENVIRONMENT + +=over 4 + +=item B<HOME> (optional) + +Home directory which may contain user application defaults files as +$C<HOME>/$C<LANG>/E<lt>B<CLASS>E<gt> or $C<HOME>/E<lt>B<CLASS>E<gt>. + +=item B<LANG> (optional) + +The current language (default: I<C>). + +=item B<XFILESEARCHPATH> (optional) + +List of FileSpec patterns +(joined using the OS-dependent path delimiter, e.g. colon on B<UNIX>) +used in defining system application defaults files. + +=item B<XUSERFILESEARCHPATH> (optional) + +List of FileSpec patterns +(joined using the OS-dependent path delimiter, e.g. colon on B<UNIX>) +used in defining user application defaults files. + +=item B<XAPPLRESDIR> (optional) + +Directory containing user application defaults files as +$C<XAPPLRESDIR>/$C<LANG>/E<lt>B<CLASS>E<gt> or +$C<XAPPLRESDIR>/E<lt>B<CLASS>E<gt>. + +=back + +=head1 SEE ALSO + +L<MainWindow|Tk::MainWindow> +L<option|Tk::option> + +=head1 HISTORY + +=over 4 + +=item * + +1999.03.04 Ben Pavon E<lt>ben.pavon@hsc.hac.comE<gt> + +Rewritten as an object-oriented module. + +Allow one to process command line options in a specified array (@ARGV by default). +Eliminate restrictions on the format and location of the options within the array +(previously the X11 options could not be specified in POSIX format and had to be +at the beginning of the array). + +Added the C<SetResources>() and C<LoadResources>() functions to allow the definition +of resources prior to MainWindow creation. + +=item * + +2000.08.31 Ben Pavon E<lt>ben.pavon@hsc.hac.comE<gt> + +Added the C<GetArguments>() method which returns the list of arguments that +have been processed by C<SetArguments>(). + +Modified C<LoadResources>() to split the symbols using the OS-dependent +path delimiter defined in the B<Config> module. + +Modified C<LoadResources>() to eliminate a warning message when processing +patterns B<%l>, B<%C>, B<%S>. + +=back + +=cut + diff --git a/Master/tlpkg/installer/perllib/Tk/Configure.pm b/Master/tlpkg/installer/perllib/Tk/Configure.pm new file mode 100644 index 00000000000..26252ae4958 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Tk/Configure.pm @@ -0,0 +1,69 @@ +package Tk::Configure; +use vars qw($VERSION); +$VERSION = '4.008'; # $Id: //depot/Tkutf8/Tk/Configure.pm#8 $ + +use Carp; +use Tk::Pretty; + + +# Class that handles cget/configure for options that +# need translating from public form +# e.g. $cw->configure(-label => 'fred') +# into $cw->subwiget('label')->configure(-text => 'fred') +# Should probably do something clever with regexp's here + + +sub new +{ + my ($class,@args) = @_; + unshift(@args,'configure','cget') if (@args < 3); + return bless \@args,$class; +} + +sub cget +{ + croak('Wrong number of args to cget') unless (@_ == 2); + my ($alias,$key) = @_; + my ($set,$get,$widget,@args) = @$alias; + $widget->$get(@args); +} + +sub configure +{ + my $alias = shift; + shift if (@_); + my ($set,$get,$widget,@args) = @$alias; + if (wantarray) + { + my @results; + eval { @results = $widget->$set(@args,@_) }; + croak($@) if $@; + return @results; + } + else + { + my $results; + eval { $results = $widget->$set(@args,@_) }; + croak($@) if $@; + return $results; + } +} + +*TIESCALAR = \&new; +*TIEHASH = \&new; + +sub FETCH +{ + my $alias = shift; + my ($set,$get,$widget,@args) = @$alias; + return $widget->$get(@args,@_); +} + +sub STORE +{ + my $alias = shift; + my ($set,$get,$widget,@args) = @$alias; + $widget->$set(@args,@_); +} + +1; diff --git a/Master/tlpkg/installer/perllib/Tk/Derived.pm b/Master/tlpkg/installer/perllib/Tk/Derived.pm new file mode 100644 index 00000000000..c31c205d2fb --- /dev/null +++ b/Master/tlpkg/installer/perllib/Tk/Derived.pm @@ -0,0 +1,512 @@ +# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +package Tk::Derived; +require Tk::Widget; +require Tk::Configure; +use strict; +use Carp; + +use vars qw($VERSION); +$VERSION = sprintf '4.%03d', q$Revision: #10 $ =~ /\D(\d+)\s*$/; + +$Tk::Derived::Debug = 0; + +my $ENHANCED_CONFIGSPECS = 0; # disable for now + +use Tk qw(NORMAL_BG BLACK); + +sub Subwidget +{ + my $cw = shift; + my @result = (); + if (exists $cw->{SubWidget}) + { + if (@_) + { + foreach my $name (@_) + { + push(@result,$cw->{SubWidget}{$name}) if (exists $cw->{SubWidget}{$name}); + } + } + else + { + @result = values %{$cw->{SubWidget}}; + } + } + return (wantarray) ? @result : $result[0]; +} + +sub _makelist +{ + my $widget = shift; + my (@specs) = (ref $widget && ref $widget eq 'ARRAY') ? (@$widget) : ($widget); + return @specs; +} + +sub Subconfigure +{ + # This finds the widget or widgets to to which to apply a particular + # configure option + my ($cw,$opt) = @_; + my $config = $cw->ConfigSpecs; + my $widget; + my @subwidget = (); + my @arg = (); + if (defined $opt) + { + $widget = $config->{$opt}; + unless (defined $widget) + { + $widget = ($opt =~ /^-(.*)$/) ? $config->{$1} : $config->{-$opt}; + } + # Handle alias entries + if (defined($widget) && !ref($widget)) + { + $opt = $widget; + $widget = $config->{$widget}; + } + push(@arg,$opt) unless ($opt eq 'DEFAULT'); + } + $widget = $config->{DEFAULT} unless (defined $widget); + if (defined $widget) + { + $cw->BackTrace("Invalid ConfigSpecs $widget") unless (ref($widget) && (ref $widget eq 'ARRAY')); + $widget = $widget->[0]; + } + else + { + $widget = 'SELF'; + } + foreach $widget (_makelist($widget)) + { + $widget = 'SELF' if (ref($widget) && $widget == $cw); + if (ref $widget) + { + my $ref = ref $widget; + if ($ref eq 'ARRAY') + { + $widget = Tk::Configure->new(@$widget); + push(@subwidget,$widget) + } + elsif ($ref eq 'HASH') + { + foreach my $key (%$widget) + { + foreach my $sw (_makelist($widget->{$key})) + { + push(@subwidget,Tk::Configure->new($sw,$key)); + } + } + } + else + { + push(@subwidget,$widget) + } + } + elsif ($widget eq 'ADVERTISED') + { + push(@subwidget,$cw->Subwidget) + } + elsif ($widget eq 'DESCENDANTS') + { + push(@subwidget,$cw->Descendants) + } + elsif ($widget eq 'CHILDREN') + { + push(@subwidget,$cw->children) + } + elsif ($widget eq 'METHOD') + { + my ($method) = ($opt =~ /^-?(.*)$/); + push(@subwidget,Tk::Configure->new($method,$method,$cw)) + } + elsif ($widget eq 'SETMETHOD') + { + my ($method) = ($opt =~ /^-?(.*)$/); + push(@subwidget,Tk::Configure->new($method,'_cget',$cw,@arg)) + } + elsif ($widget eq 'SELF') + { + push(@subwidget,Tk::Configure->new('Tk::configure', 'Tk::cget', $cw,@arg)) + } + elsif ($widget eq 'PASSIVE') + { + push(@subwidget,Tk::Configure->new('_configure','_cget',$cw,@arg)) + } + elsif ($widget eq 'CALLBACK') + { + push(@subwidget,Tk::Configure->new('_callback','_cget',$cw,@arg)) + } + else + { + push(@subwidget,$cw->Subwidget($widget)); + } + } + $cw->BackTrace("No delegate subwidget '$widget' for $opt") unless (@subwidget); + return (wantarray) ? @subwidget : $subwidget[0]; +} + +sub _cget +{ + my ($cw,$opt) = @_; + $cw->BackTrace('Wrong number of args to cget') unless (@_ == 2); + return $cw->{Configure}{$opt} +} + +sub _configure +{ + my ($cw,$opt,$val) = @_; + $cw->BackTrace('Wrong number of args to configure') unless (@_ == 3); + $cw->{Configure}{$opt} = $val; +} + +sub _callback +{ + my ($cw,$opt,$val) = @_; + $cw->BackTrace('Wrong number of args to configure') unless (@_ == 3); + $val = Tk::Callback->new($val) if defined($val) && ref($val); + $cw->{Configure}{$opt} = $val; +} + +sub cget +{my ($cw,$opt) = @_; + my @result; + local $SIG{'__DIE__'}; + foreach my $sw ($cw->Subconfigure($opt)) + { + if (wantarray) + { + eval { @result = $sw->cget($opt) }; + } + else + { + eval { $result[0] = $sw->cget($opt) }; + } + last unless $@; + } + return wantarray ? @result : $result[0]; +} + +sub Configured +{ + # Called whenever a derived widget is re-configured + my ($cw,$args,$changed) = @_; + if (@_ > 1) + { + $cw->afterIdle(['ConfigChanged',$cw,$changed]) if (%$changed); + } + return exists $cw->{'Configure'}; +} + +sub configure +{ + # The default composite widget configuration method uses hash stored + # in the widget's hash to map configuration options + # onto subwidgets. + # + my @results = (); + my $cw = shift; + if (@_ <= 1) + { + # Enquiry cases + my $spec = $cw->ConfigSpecs; + if (@_) + { + # Return info on the nominated option + my $opt = $_[0]; + my $info = $spec->{$opt}; + unless (defined $info) + { + $info = ($opt =~ /^-(.*)$/) ? $spec->{$1} : $spec->{-$opt}; + } + if (defined $info) + { + if (ref $info) + { + # If the default slot is undef then ask subwidgets in turn + # for their default value until one accepts it. + if ($ENHANCED_CONFIGSPECS && !defined($info->[3])) + {local $SIG{'__DIE__'}; + my @def; + foreach my $sw ($cw->Subconfigure($opt)) + { + eval { @def = $sw->configure($opt) }; + last unless $@; + } + $info->[3] = $def[3]; + $info->[1] = $def[1] unless defined $info->[1]; + $info->[2] = $def[2] unless defined $info->[2]; + } + push(@results,$opt,$info->[1],$info->[2],$info->[3],$cw->cget($opt)); + } + else + { + # Real (core) Tk widgets return db name rather than option name + # for aliases so recurse to get that ... + my @real = $cw->configure($info); + push(@results,$opt,$real[1]); + } + } + else + { + push(@results,$cw->Subconfigure($opt)->configure($opt)); + } + } + else + { + my $opt; + my %results; + if (exists $spec->{'DEFAULT'}) + { + foreach $opt ($cw->Subconfigure('DEFAULT')->configure) + { + $results{$opt->[0]} = $opt; + } + } + foreach $opt (keys %$spec) + { + $results{$opt} = [$cw->configure($opt)] if ($opt ne 'DEFAULT'); + } + foreach $opt (sort keys %results) + { + push(@results,$results{$opt}); + } + } + } + else + { + my (%args) = @_; + my %changed = (); + my ($opt,$val); + my $config = $cw->TkHash('Configure'); + + while (($opt,$val) = each %args) + { + my $var = \$config->{$opt}; + my $old = $$var; + $$var = $val; + my $accepted = 0; + my $error = "No widget handles $opt"; + foreach my $subwidget ($cw->Subconfigure($opt)) + { + next unless (defined $subwidget); + eval {local $SIG{'__DIE__'}; $subwidget->configure($opt => $val) }; + if ($@) + { + my $val2 = (defined $val) ? $val : 'undef'; + $error = "Can't set $opt to `$val2' for $cw: " . $@; + undef $@; + } + else + { + $accepted = 1; + } + } + $cw->BackTrace($error) unless ($accepted); + $val = $$var; + $changed{$opt} = $val if (!defined $old || !defined $val || "$old" ne "$val"); + } + $cw->Configured(\%args,\%changed); + } + return (wantarray) ? @results : \@results; +} + +sub ConfigDefault +{ + my ($cw,$args) = @_; + + $cw->BackTrace('Bad args') unless (defined $args && ref $args eq 'HASH'); + + my $specs = $cw->ConfigSpecs; + # Should we enforce a Delagates(DEFAULT => ) as well ? + $specs->{'DEFAULT'} = ['SELF'] unless (exists $specs->{'DEFAULT'}); + + # + # This is a pain with Text or Entry as core widget, they don't + # inherit SELF's cursor. So comment it out for Tk402.001 + # + # $specs->{'-cursor'} = ['SELF',undef,undef,undef] unless (exists $specs->{'-cursor'}); + + # Now some hacks that cause colours to propogate down a composite widget + # tree - really needs more thought, other options adding such as active + # colours too and maybe fonts + + my $child = ($cw->children)[0]; # 1st child window (if any) + + unless (exists($specs->{'-background'})) + { + Tk::catch { $cw->Tk::cget('-background') }; + my (@bg) = $@ ? ('PASSIVE') : ('SELF'); + push(@bg,'CHILDREN') if $child; + $specs->{'-background'} = [\@bg,'background','Background',NORMAL_BG]; + } + unless (exists($specs->{'-foreground'})) + { + Tk::catch { $cw->Tk::cget('-foreground') }; + my (@fg) = $@ ? ('PASSIVE') : ('SELF'); + push(@fg,'CHILDREN') if $child; + $specs->{'-foreground'} = [\@fg,'foreground','Foreground',BLACK]; + } + $cw->ConfigAlias(-fg => '-foreground', -bg => '-background'); + + # Pre-scan args for aliases - this avoids defaulting + # options specified via alias + foreach my $opt (keys %$args) + { + my $info = $specs->{$opt}; + if (defined($info) && !ref($info)) + { + $args->{$info} = delete $args->{$opt}; + } + } + + # Now walk %$specs supplying defaults for all the options + # which have a defined default value, potentially looking up .Xdefaults database + # options for the name/class of the 'frame' + + foreach my $opt (keys %$specs) + { + if ($opt ne 'DEFAULT') + { + unless (exists $args->{$opt}) + { + my $info = $specs->{$opt}; + if (ref $info) + { + # Not an alias + if ($ENHANCED_CONFIGSPECS && !defined $info->[3]) + { + # configure inquire to fill in default slot from subwidget + $cw->configure($opt); + } + if (defined $info->[3]) + { + if (defined $info->[1] && defined $info->[2]) + { + # Should we do this on the Subconfigure widget instead? + # to match *Entry.Background + my $db = $cw->optionGet($info->[1],$info->[2]); + $info->[3] = $db if (defined $db); + } + $args->{$opt} = $info->[3]; + } + } + } + } + } +} + +sub ConfigSpecs +{ + my $cw = shift; + my $specs = $cw->TkHash('ConfigSpecs'); + while (@_) + { + my $key = shift; + my $val = shift; + $specs->{$key} = $val; + } + return $specs; +} + +sub _alias +{ + my ($specs,$opt,$main) = @_; + if (exists($specs->{$opt})) + { + unless (exists $specs->{$main}) + { + my $targ = $specs->{$opt}; + if (ref($targ)) + { + # opt is a real option + $specs->{$main} = $opt + } + else + { + # opt is itself an alias + # make main point to same place + $specs->{$main} = $targ unless $targ eq $main; + } + } + return 1; + } + return 0; +} + +sub ConfigAlias +{ + my $cw = shift; + my $specs = $cw->ConfigSpecs; + while (@_ >= 2) + { + my $opt = shift; + my $main = shift; + unless (_alias($specs,$opt,$main) || _alias($specs,$main,$opt)) + { + $cw->BackTrace("Neither $opt nor $main exist"); + } + } + $cw->BackTrace('Odd number of args to ConfigAlias') if (@_); +} + +sub Delegate +{ + my ($cw,$method,@args) = @_; + my $widget = $cw->DelegateFor($method); + if ($widget == $cw) + { + $method = "Tk::Widget::$method" + } + my @result; + if (wantarray) + { + @result = $widget->$method(@args); + } + else + { + $result[0] = $widget->$method(@args); + } + return (wantarray) ? @result : $result[0]; +} + +sub InitObject +{ + my ($cw,$args) = @_; + $cw->Populate($args); + $cw->ConfigDefault($args); +} + +sub ConfigChanged +{ + my ($cw,$args) = @_; +} + +sub Advertise +{ + my ($cw,$name,$widget) = @_; + confess 'No name' unless (defined $name); + croak 'No widget' unless (defined $widget); + my $hash = $cw->TkHash('SubWidget'); + $hash->{$name} = $widget; # advertise it + return $widget; +} + +sub Component +{ + my ($cw,$kind,$name,%args) = @_; + $args{'Name'} = "\l$name" if (defined $name && !exists $args{'Name'}); + # my $pack = delete $args{'-pack'}; + my $delegate = delete $args{'-delegate'}; + my $w = $cw->$kind(%args); # Create it + # $w->pack(@$pack) if (defined $pack); + $cw->Advertise($name,$w) if (defined $name); + $cw->Delegates(map(($_ => $w),@$delegate)) if (defined $delegate); + return $w; # and return it +} + +1; +__END__ + + diff --git a/Master/tlpkg/installer/perllib/Tk/Dialog.pm b/Master/tlpkg/installer/perllib/Tk/Dialog.pm new file mode 100644 index 00000000000..8173f4a5acc --- /dev/null +++ b/Master/tlpkg/installer/perllib/Tk/Dialog.pm @@ -0,0 +1,70 @@ +package Tk::Dialog; + +use vars qw($VERSION); +$VERSION = '4.004'; # $Id: //depot/Tkutf8/Tk/Dialog.pm#4 $ + +# Dialog - a translation of `tk_dialog' from Tcl/Tk to TkPerl (based on +# John Stoffel's idea). +# +# Stephen O. Lidie, Lehigh University Computing Center. 94/12/27 +# lusol@Lehigh.EDU + +# Documentation after __END__ + +use Carp; +use strict; +use base qw(Tk::DialogBox); + +Construct Tk::Widget 'Dialog'; + +sub Populate +{ + + # Dialog object constructor. Uses `new' method from base class + # to create object container then creates the dialog toplevel. + + my($cw, $args) = @_; + + $cw->SUPER::Populate($args); + + my ($w_bitmap,$w_but,$pad1,$pad2); + + # Create the Toplevel window and divide it into top and bottom parts. + + my (@pl) = (-side => 'top', -fill => 'both'); + + ($pad1, $pad2) = + ([-padx => '3m', -pady => '3m'], [-padx => '3m', -pady => '2m']); + + + $cw->iconname('Dialog'); + + my $w_top = $cw->Subwidget('top'); + + # Fill the top part with the bitmap and message. + + @pl = (-side => 'left'); + + $w_bitmap = $w_top->Label(Name => 'bitmap'); + $w_bitmap->pack(@pl, @$pad1); + + my $w_msg = $w_top->Label( -wraplength => '3i', -justify => 'left' ); + + $w_msg->pack(-side => 'right', -expand => 1, -fill => 'both', @$pad1); + + $cw->Advertise(message => $w_msg); + $cw->Advertise(bitmap => $w_bitmap ); + + $cw->ConfigSpecs( -image => ['bitmap',undef,undef,undef], + -bitmap => ['bitmap',undef,undef,undef], + -font => ['message','font','Font', '-*-Times-Medium-R-Normal--*-180-*-*-*-*-*-*'], + DEFAULT => ['message',undef,undef,undef] + ); +} + +1; + +__END__ + +=cut + diff --git a/Master/tlpkg/installer/perllib/Tk/DialogBox.pm b/Master/tlpkg/installer/perllib/Tk/DialogBox.pm new file mode 100644 index 00000000000..13335404e15 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Tk/DialogBox.pm @@ -0,0 +1,135 @@ +# +# DialogBox is similar to Dialog except that it allows any widget +# in the top frame. Widgets can be added with the add method. Currently +# there exists no way of deleting a widget once it has been added. + +package Tk::DialogBox; + +use strict; +use Carp; + +use vars qw($VERSION); +$VERSION = sprintf '4.%03d', q$Revision: #13 $ =~ /\D(\d+)\s*$/; + +use base qw(Tk::Toplevel); + +Tk::Widget->Construct('DialogBox'); + +sub Populate { + my ($cw, $args) = @_; + + $cw->SUPER::Populate($args); + my $buttons = delete $args->{'-buttons'}; + $buttons = ['OK'] unless defined $buttons; + my $default_button = delete $args->{'-default_button'}; + $default_button = $buttons->[0] unless defined $default_button; + + $cw->{'selected_button'} = ''; + $cw->transient($cw->Parent->toplevel); + $cw->withdraw; + if (@$buttons == 1) { + $cw->protocol('WM_DELETE_WINDOW' => sub { $cw->{'default_button'}->invoke }); + } else { + $cw->protocol('WM_DELETE_WINDOW' => sub {}); + } + + # create the two frames + my $top = $cw->Component('Frame', 'top'); + $top->configure(-relief => 'raised', -bd => 1) unless $Tk::platform eq 'MSWin32'; + my $bot = $cw->Component('Frame', 'bottom'); + $bot->configure(-relief => 'raised', -bd => 1) unless $Tk::platform eq 'MSWin32'; + $bot->pack(qw/-side bottom -fill both -ipady 3 -ipadx 3/); + $top->pack(qw/-side top -fill both -ipady 3 -ipadx 3 -expand 1/); + + # create a row of buttons in the bottom. + my $bl; # foreach my $var: perl > 5.003_08 + foreach $bl (@$buttons) + { + my $b = $bot->Button(-text => $bl, -command => sub { $cw->{'selected_button'} = "$bl" } ); + $b->bind('<Return>' => [ $b, 'Invoke']); + $cw->Advertise("B_$bl" => $b); + if ($Tk::platform eq 'MSWin32') + { + $b->configure(-width => 10, -pady => 0); + } + if ($bl eq $default_button) { + if ($Tk::platform eq 'MSWin32') { + $b->pack(-side => 'left', -expand => 1, -padx => 1, -pady => 1); + } else { + my $db = $bot->Frame(-relief => 'sunken', -bd => 1); + $b->raise($db); + $b->pack(-in => $db, -padx => '2', -pady => '2'); + $db->pack(-side => 'left', -expand => 1, -padx => 1, -pady => 1); + } + $cw->{'default_button'} = $b; + $cw->bind('<Return>' => [ $b, 'Invoke']); + } else { + $b->pack(-side => 'left', -expand => 1, -padx => 1, -pady => 1); + } + } + $cw->ConfigSpecs(-command => ['CALLBACK', undef, undef, undef ], + -foreground => ['DESCENDANTS', 'foreground','Foreground', 'black'], + -background => ['DESCENDANTS', 'background','Background', undef], + -focus => ['PASSIVE', undef, undef, undef], + -showcommand => ['CALLBACK', undef, undef, undef], + ); + $cw->Delegates('Construct',$top); +} + +sub add { + my ($cw, $wnam, @args) = @_; + my $w = $cw->Subwidget('top')->$wnam(@args); + $cw->Advertise("\L$wnam" => $w); + return $w; +} + +sub Wait +{ + my $cw = shift; + $cw->Callback(-showcommand => $cw); + $cw->waitVariable(\$cw->{'selected_button'}); + $cw->grabRelease; + $cw->withdraw; + $cw->Callback(-command => $cw->{'selected_button'}); +} + +sub Show { + + croak 'DialogBox: "Show" method requires at least 1 argument' + if scalar @_ < 1; + my $cw = shift; + my ($grab) = @_; + my $old_focus = $cw->focusSave; + my $old_grab = $cw->grabSave; + + shift if defined $grab && length $grab && ($grab =~ /global/); + $cw->Popup(@_); + + Tk::catch { + if (defined $grab && length $grab && ($grab =~ /global/)) { + $cw->grabGlobal; + } else { + $cw->grab; + } + }; + if (my $focusw = $cw->cget(-focus)) { + $focusw->focus; + } elsif (defined $cw->{'default_button'}) { + $cw->{'default_button'}->focus; + } else { + $cw->focus; + } + $cw->Wait; + &$old_focus; + &$old_grab; + return $cw->{'selected_button'}; +} + +sub Exit +{ + my $cw = shift; + #kill the dialogbox, by faking a 'DONE' + $cw->{'selected_button'} = $cw->{'default_button'}->cget(-text); +} + +1; diff --git a/Master/tlpkg/installer/perllib/Tk/DummyEncode.pm b/Master/tlpkg/installer/perllib/Tk/DummyEncode.pm new file mode 100644 index 00000000000..5ead808405d --- /dev/null +++ b/Master/tlpkg/installer/perllib/Tk/DummyEncode.pm @@ -0,0 +1,46 @@ +package Tk::DummyEncode; + +use vars qw($VERSION); +$VERSION = '4.007'; # $Id: //depot/Tkutf8/Tk/DummyEncode.pm#7 $ + +sub getEncoding +{ + my ($class,$name) = @_; + return undef unless ($name =~ /(iso8859-1|X11ControlChars)/); + my $pkg = $name; + $pkg =~ s/\W+/_/g; + return bless {Name => $name},$class.'::'.$pkg; +} + +package Tk::DummyEncode::iso8859_1; +sub encode +{ + my ($obj,$uni,$chk) = @_; + $_[1] = '' if $chk; + return $uni; +} + +sub decode +{ + my ($obj,$byt,$chk) = @_; + $_[1] += '' if $chk; + return $byt; +} + +package Tk::DummyEncode::X11ControlChars; +sub encode +{ + my ($obj,$uni,$chk) = @_; + my $str = ''; + foreach my $ch (split(//,$uni)) + { + $str .= sprintf("\\x{%x}",ord($ch)); + } + $_[1] = '' if $chk; + return $str; +} + +1; + +__END__ diff --git a/Master/tlpkg/installer/perllib/Tk/Entry.pm b/Master/tlpkg/installer/perllib/Tk/Entry.pm new file mode 100644 index 00000000000..51b3f0c6767 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Tk/Entry.pm @@ -0,0 +1,615 @@ +package Tk::Entry; + +# Converted from entry.tcl -- +# +# This file defines the default bindings for Tk entry widgets. +# +# @(#) entry.tcl 1.22 94/12/17 16:05:14 +# +# Copyright (c) 1992-1994 The Regents of the University of California. +# Copyright (c) 1994 Sun Microsystems, Inc. +# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved. +# This program is free software; you can redistribute it and/or + +use vars qw($VERSION); +use strict; +$VERSION = sprintf '4.%03d',q$Revision: #17 $ =~ /#(\d+)/; + +# modify it under the same terms as Perl itself, subject +# to additional disclaimer in license.terms due to partial +# derivation from Tk4.0 sources. + +use Tk::Widget (); +use Tk::Clipboard (); +use base qw(Tk::Clipboard Tk::Widget); + +import Tk qw(Ev $XS_VERSION); + +Construct Tk::Widget 'Entry'; + +bootstrap Tk::Entry; + +sub Tk_cmd { \&Tk::entry } + +Tk::Methods('bbox','delete','get','icursor','index','insert','scan', + 'selection','validate','xview'); + +use Tk::Submethods ( 'selection' => [qw(clear range adjust present to from)], + 'xview' => [qw(moveto scroll)], + ); + +sub wordstart +{my ($w,$pos) = @_; + my $string = $w->get; + $pos = $w->index('insert')-1 unless(defined $pos); + $string = substr($string,0,$pos); + $string =~ s/\S*$//; + length $string; +} + +sub wordend +{my ($w,$pos) = @_; + my $string = $w->get; + my $anc = length $string; + $pos = $w->index('insert') unless(defined $pos); + $string = substr($string,$pos); + $string =~ s/^(?:((?=\s)\s*|(?=\S)\S*))//x; + $anc - length($string); +} + +sub deltainsert +{ + my ($w,$d) = @_; + return $w->index('insert')+$d; +} + +# +# Bind -- +# This procedure is invoked the first time the mouse enters an +# entry widget or an entry widget receives the input focus. It creates +# all of the class bindings for entries. +# +# Arguments: +# event - Indicates which event caused the procedure to be invoked +# (Enter or FocusIn). It is used so that we can carry out +# the functions of that event in addition to setting up +# bindings. +sub ClassInit +{ + my ($class,$mw) = @_; + + $class->SUPER::ClassInit($mw); + + # <<Cut>>, <<Copy>> and <<Paste>> defined in Tk::Clipboard + $mw->bind($class,'<<Clear>>' => sub { + my $w = shift; + $w->delete("sel.first", "sel.last"); + }); + $mw->bind($class,'<<PasteSelection>>' => [sub { + my($w, $x) = @_; + # XXX logic in Tcl/Tk version screwed up? + if (!$Tk::strictMotif && !$Tk::mouseMoved) { + $w->Paste($x); + } + }, Ev('x')]); + + # Standard Motif bindings: + # The <Escape> binding is different from the Tcl/Tk version: + $mw->bind($class,'<Escape>','selectionClear'); + + $mw->bind($class,'<1>',['Button1',Ev('x'),Ev('y')]); + $mw->bind($class,'<ButtonRelease-1>',['Button1Release',Ev('x'),Ev('y')]); + $mw->bind($class,'<B1-Motion>',['Motion',Ev('x'),Ev('y')]); + + $mw->bind($class,'<Double-1>',['MouseSelect',Ev('x'),'word','sel.first']); + $mw->bind($class,'<Double-Shift-1>',['MouseSelect',Ev('x'),'word']); + $mw->bind($class,'<Triple-1>',['MouseSelect',Ev('x'),'line',0]); + $mw->bind($class,'<Triple-Shift-1>',['MouseSelect',Ev('x'),'line']); + + $mw->bind($class,'<Shift-1>','Shift_1'); + + + $mw->bind($class,'<B1-Leave>',['AutoScan',Ev('x')]); + $mw->bind($class,'<B1-Enter>','CancelRepeat'); + $mw->bind($class,'<Control-1>','Control_1'); + $mw->bind($class,'<Left>', ['SetCursor',Ev('deltainsert',-1)]); + $mw->bind($class,'<Right>',['SetCursor',Ev('deltainsert',1)]); + $mw->bind($class,'<Shift-Left>',['KeySelect',Ev('deltainsert',-1)]); + $mw->bind($class,'<Shift-Right>',['KeySelect',Ev('deltainsert',1)]); + $mw->bind($class,'<Control-Left>',['SetCursor',Ev(['wordstart'])]); + $mw->bind($class,'<Control-Right>',['SetCursor',Ev(['wordend'])]); + $mw->bind($class,'<Shift-Control-Left>',['KeySelect',Ev(['wordstart'])]); + $mw->bind($class,'<Shift-Control-Right>',['KeySelect',Ev(['wordend'])]); + $mw->bind($class,'<Home>',['SetCursor',0]); + $mw->bind($class,'<Shift-Home>',['KeySelect',0]); + $mw->bind($class,'<End>',['SetCursor','end']); + $mw->bind($class,'<Shift-End>',['KeySelect','end']); + $mw->bind($class,'<Delete>','Delete'); + + $mw->bind($class,'<BackSpace>','Backspace'); + + $mw->bind($class,'<Control-space>',['selectionFrom','insert']); + $mw->bind($class,'<Select>',['selectionFrom','insert']); + $mw->bind($class,'<Control-Shift-space>',['selectionAdjust','insert']); + $mw->bind($class,'<Shift-Select>',['selectionAdjust','insert']); + + $mw->bind($class,'<Control-slash>',['selectionRange',0,'end']); + $mw->bind($class,'<Control-backslash>','selectionClear'); + + # $class->clipboardOperations($mw,qw[Copy Cut Paste]); + + $mw->bind($class,'<KeyPress>', ['Insert',Ev('A')]); + + # Ignore all Alt, Meta, and Control keypresses unless explicitly bound. + # Otherwise, if a widget binding for one of these is defined, the + # <KeyPress> class binding will also fire and insert the character, + # which is wrong. Ditto for Return, and Tab. + + $mw->bind($class,'<Alt-KeyPress>' ,'NoOp'); + $mw->bind($class,'<Meta-KeyPress>' ,'NoOp'); + $mw->bind($class,'<Control-KeyPress>' ,'NoOp'); + $mw->bind($class,'<Return>' ,'NoOp'); + $mw->bind($class,'<KP_Enter>' ,'NoOp'); + $mw->bind($class,'<Tab>' ,'NoOp'); + if ($mw->windowingsystem =~ /^(?:classic|aqua)$/) + { + $mw->bind($class,'<Command-KeyPress>', 'NoOp'); + } + + # On Windows, paste is done using Shift-Insert. Shift-Insert already + # generates the <<Paste>> event, so we don't need to do anything here. + if ($Tk::platform ne 'MSWin32') + { + $mw->bind($class,'<Insert>','InsertSelection'); + } + + if (!$Tk::strictMotif) + { + # Additional emacs-like bindings: + $mw->bind($class,'<Control-a>',['SetCursor',0]); + $mw->bind($class,'<Control-b>',['SetCursor',Ev('deltainsert',-1)]); + $mw->bind($class,'<Control-d>',['delete','insert']); + $mw->bind($class,'<Control-e>',['SetCursor','end']); + $mw->bind($class,'<Control-f>',['SetCursor',Ev('deltainsert',1)]); + $mw->bind($class,'<Control-h>','Backspace'); + $mw->bind($class,'<Control-k>',['delete','insert','end']); + + $mw->bind($class,'<Control-t>','Transpose'); + + # XXX The original Tcl/Tk bindings use NextWord/PreviousWord instead + $mw->bind($class,'<Meta-b>',['SetCursor',Ev(['wordstart'])]); + $mw->bind($class,'<Meta-d>',['delete','insert',Ev(['wordend'])]); + $mw->bind($class,'<Meta-f>',['SetCursor',Ev(['wordend'])]); + $mw->bind($class,'<Meta-BackSpace>',['delete',Ev(['wordstart']),'insert']); + $mw->bind($class,'<Meta-Delete>',['delete',Ev(['wordstart']),'insert']); + + # A few additional bindings from John Ousterhout. +# XXX conflicts with <<Copy>>: $mw->bind($class,'<Control-w>',['delete',Ev(['wordstart']),'insert']); + $mw->bind($class,'<2>','Button_2'); + $mw->bind($class,'<B2-Motion>','B2_Motion'); +# XXX superseded by <<PasteSelection>>: $mw->bind($class,'<ButtonRelease-2>','ButtonRelease_2'); + } + return $class; +} + + +sub Shift_1 +{ + my $w = shift; + my $Ev = $w->XEvent; + $Tk::selectMode = 'char'; + $w->selectionAdjust('@' . $Ev->x) +} + + +sub Control_1 +{ + my $w = shift; + my $Ev = $w->XEvent; + $w->icursor('@' . $Ev->x) +} + + +sub Delete +{ + my $w = shift; + if ($w->selectionPresent) + { + $w->deleteSelected + } + else + { + $w->delete('insert') + } +} + + +sub InsertSelection +{ + my $w = shift; + eval {local $SIG{__DIE__}; $w->Insert($w->GetSelection)} +} + + +# Original is ::tk::EntryScanMark +sub Button_2 +{ + my $w = shift; + my $Ev = $w->XEvent; + $w->scan('mark',$Ev->x); + $Tk::x = $Ev->x; + $Tk::y = $Ev->y; + $Tk::mouseMoved = 0 +} + + +# Original is ::tk::EntryScanDrag +sub B2_Motion +{ + my $w = shift; + my $Ev = $w->XEvent; + # Make sure these exist, as some weird situations can trigger the + # motion binding without the initial press. [Tcl/Tk Bug #220269] + if (!defined $Tk::x) { $Tk::x = $Ev->x } + if (abs(($Ev->x-$Tk::x)) > 2) + { + $Tk::mouseMoved = 1 + } + $w->scan('dragto',$Ev->x) +} + + +# XXX Not needed anymore +sub ButtonRelease_2 +{ + my $w = shift; + my $Ev = $w->XEvent; + if (!$Tk::mouseMoved) + { + eval + {local $SIG{__DIE__}; + $w->insert('insert',$w->SelectionGet); + $w->SeeInsert; + } + } +} + +sub Button1Release +{ + shift->CancelRepeat; +} + +# ::tk::EntryClosestGap -- +# Given x and y coordinates, this procedure finds the closest boundary +# between characters to the given coordinates and returns the index +# of the character just after the boundary. +# +# Arguments: +# w - The entry window. +# x - X-coordinate within the window. +sub ClosestGap +{ + my($w, $x) = @_; + my $pos = $w->index('@'.$x); + my @bbox = $w->bbox($pos); + if ($x - $bbox[0] < $bbox[2] / 2) + { + return $pos; + } + $pos + 1; +} + +# Button1 -- +# This procedure is invoked to handle button-1 presses in entry +# widgets. It moves the insertion cursor, sets the selection anchor, +# and claims the input focus. +# +# Arguments: +# w - The entry window in which the button was pressed. +# x - The x-coordinate of the button press. +sub Button1 +{ + my $w = shift; + my $x = shift; + $Tk::selectMode = 'char'; + $Tk::mouseMoved = 0; + $Tk::pressX = $x; + $w->icursor($w->ClosestGap($x)); + $w->selectionFrom('insert'); + $w->selectionClear; + if ($w->cget('-state') ne 'disabled') + { + $w->focus() + } +} + +sub Motion +{ + my ($w,$x,$y) = @_; + $Tk::x = $x; # XXX ? + $w->MouseSelect($x); +} + +# MouseSelect -- +# This procedure is invoked when dragging out a selection with +# the mouse. Depending on the selection mode (character, word, +# line) it selects in different-sized units. This procedure +# ignores mouse motions initially until the mouse has moved from +# one character to another or until there have been multiple clicks. +# +# Arguments: +# w - The entry window in which the button was pressed. +# x - The x-coordinate of the mouse. +sub MouseSelect +{ + + my $w = shift; + my $x = shift; + return if UNIVERSAL::isa($w, 'Tk::Spinbox') and $w->{_element} ne 'entry'; + $Tk::selectMode = shift if (@_); + my $cur = $w->index($w->ClosestGap($x)); + return unless defined $cur; + my $anchor = $w->index('anchor'); + return unless defined $anchor; + $Tk::pressX ||= $x; # XXX Better use "if !defined $Tk::pressX"? + if (($cur != $anchor) || (abs($Tk::pressX - $x) >= 3)) + { + $Tk::mouseMoved = 1 + } + my $mode = $Tk::selectMode; + return unless $mode; + if ($mode eq 'char') + { + # The Tcl version uses selectionRange here XXX + if ($Tk::mouseMoved) + { + if ($cur < $anchor) + { + $w->selectionTo($cur) + } + else + { + $w->selectionTo($cur+1) + } + } + } + elsif ($mode eq 'word') + { + # The Tcl version uses tcl_wordBreakBefore/After here XXX + if ($cur < $w->index('anchor')) + { + $w->selectionRange($w->wordstart($cur),$w->wordend($anchor-1)) + } + else + { + $w->selectionRange($w->wordstart($anchor),$w->wordend($cur)) + } + } + elsif ($mode eq 'line') + { + $w->selectionRange(0,'end') + } + if (@_) + { + my $ipos = shift; + eval {local $SIG{__DIE__}; $w->icursor($ipos) }; + } + $w->idletasks; +} +# ::tk::EntryPaste -- +# This procedure sets the insertion cursor to the current mouse position, +# pastes the selection there, and sets the focus to the window. +# +# Arguments: +# w - The entry window. +# x - X position of the mouse. +sub Paste +{ + my($w, $x) = @_; + $w->icursor($w->ClosestGap($x)); + eval { local $SIG{__DIE__}; + $w->insert("insert", $w->GetSelection); + $w->SeeInsert; # Perl/Tk extension + }; + if ($w->cget(-state) ne 'disabled') + { + $w->focus; + } +} +# AutoScan -- +# This procedure is invoked when the mouse leaves an entry window +# with button 1 down. It scrolls the window left or right, +# depending on where the mouse is, and reschedules itself as an +# 'after' command so that the window continues to scroll until the +# mouse moves back into the window or the mouse button is released. +# +# Arguments: +# w - The entry window. +# x - The x-coordinate of the mouse when it left the window. +sub AutoScan +{ + my $w = shift; + my $x = shift; + return if !Tk::Exists($w); + if ($x >= $w->width) + { + $w->xview('scroll',2,'units') + } + elsif ($x < 0) + { + $w->xview('scroll',-2,'units') + } + else + { + return; + } + $w->MouseSelect($x); + $w->RepeatId($w->after(50,['AutoScan',$w,$x])) +} +# KeySelect +# This procedure is invoked when stroking out selections using the +# keyboard. It moves the cursor to a new position, then extends +# the selection to that position. +# +# Arguments: +# w - The entry window. +# new - A new position for the insertion cursor (the cursor hasn't +# actually been moved to this position yet). +sub KeySelect +{ + my $w = shift; + my $new = shift; + if (!$w->selectionPresent) + { + $w->selectionFrom('insert'); + $w->selectionTo($new) + } + else + { + $w->selectionAdjust($new) + } + $w->icursor($new); + $w->SeeInsert; +} +# Insert -- +# Insert a string into an entry at the point of the insertion cursor. +# If there is a selection in the entry, and it covers the point of the +# insertion cursor, then delete the selection before inserting. +# +# Arguments: +# w - The entry window in which to insert the string +# s - The string to insert (usually just a single character) +sub Insert +{ + my $w = shift; + my $s = shift; + return unless (defined $s && $s ne ''); + eval + {local $SIG{__DIE__}; + my $insert = $w->index('insert'); + if ($w->index('sel.first') <= $insert && $w->index('sel.last') >= $insert) + { + $w->deleteSelected + } + }; + $w->insert('insert',$s); + $w->SeeInsert +} +# Backspace -- +# Backspace over the character just before the insertion cursor. +# +# Arguments: +# w - The entry window in which to backspace. +sub Backspace +{ + my $w = shift; + if ($w->selectionPresent) + { + $w->deleteSelected + } + else + { + my $x = $w->index('insert')-1; + $w->delete($x) if ($x >= 0); + # XXX Missing repositioning part from Tcl/Tk source + } +} +# SeeInsert +# Make sure that the insertion cursor is visible in the entry window. +# If not, adjust the view so that it is. +# +# Arguments: +# w - The entry window. +sub SeeInsert +{ + my $w = shift; + my $c = $w->index('insert'); +# +# Probably a bug in your version of tcl/tk (I've not this problem +# when I test Entry in the widget demo for tcl/tk) +# index('\@0') give always 0. Consequence : +# if you make <Control-E> or <Control-F> view is adapted +# but with <Control-A> or <Control-B> view is not adapted +# + my $left = $w->index('@0'); + if ($left > $c) + { + $w->xview($c); + return; + } + my $x = $w->width; + while ($w->index('@' . $x) <= $c && $left < $c) + { + $left += 1; + $w->xview($left) + } +} +# SetCursor +# Move the insertion cursor to a given position in an entry. Also +# clears the selection, if there is one in the entry, and makes sure +# that the insertion cursor is visible. +# +# Arguments: +# w - The entry window. +# pos - The desired new position for the cursor in the window. +sub SetCursor +{ + my $w = shift; + my $pos = shift; + $w->icursor($pos); + $w->selectionClear; + $w->SeeInsert; +} +# Transpose +# This procedure implements the 'transpose' function for entry widgets. +# It tranposes the characters on either side of the insertion cursor, +# unless the cursor is at the end of the line. In this case it +# transposes the two characters to the left of the cursor. In either +# case, the cursor ends up to the right of the transposed characters. +# +# Arguments: +# w - The entry window. +sub Transpose +{ + my $w = shift; + my $i = $w->index('insert'); + $i++ if ($i < $w->index('end')); + my $first = $i-2; + return if ($first < 0); + my $str = $w->get; + my $new = substr($str,$i-1,1) . substr($str,$first,1); + $w->delete($first,$i); + $w->insert('insert',$new); + $w->SeeInsert; +} + +sub tabFocus +{ + my $w = shift; + $w->selectionRange(0,'end'); + $w->icursor('end'); + $w->SUPER::tabFocus; +} + +# ::tk::EntryGetSelection -- +# +# Returns the selected text of the entry with respect to the -show option. +# +# Arguments: +# w - The entry window from which the text to get +sub getSelected +{ + my $w = shift; + return undef unless $w->selectionPresent; + my $str = $w->get; + my $show = $w->cget('-show'); + $str = $show x length($str) if (defined $show); + my $s = $w->index('sel.first'); + my $e = $w->index('sel.last'); + return substr($str,$s,$e-$s); +} + + +1; + +__END__ diff --git a/Master/tlpkg/installer/perllib/Tk/Event.pm b/Master/tlpkg/installer/perllib/Tk/Event.pm new file mode 100644 index 00000000000..cecd57c54ae --- /dev/null +++ b/Master/tlpkg/installer/perllib/Tk/Event.pm @@ -0,0 +1,13 @@ +package Tk::Event; +use vars qw($VERSION $XS_VERSION @EXPORT_OK); +END { CleanupGlue() } +$VERSION = sprintf '4.%03d', q$Revision: #15 $ =~ /\D(\d+)\s*$/; +$XS_VERSION = '804.027'; +use base qw(Exporter); +use XSLoader; +@EXPORT_OK = qw($XS_VERSION DONT_WAIT WINDOW_EVENTS FILE_EVENTS + TIMER_EVENTS IDLE_EVENTS ALL_EVENTS); +XSLoader::load 'Tk::Event',$XS_VERSION; +require Tk::Event::IO; +1; +__END__ diff --git a/Master/tlpkg/installer/perllib/Tk/Event/IO.pm b/Master/tlpkg/installer/perllib/Tk/Event/IO.pm new file mode 100644 index 00000000000..10b47e246ff --- /dev/null +++ b/Master/tlpkg/installer/perllib/Tk/Event/IO.pm @@ -0,0 +1,132 @@ +package Tk::Event::IO; +use strict; +use Carp; + +use vars qw($VERSION @EXPORT_OK); +$VERSION = sprintf '4.%03d', q$Revision: #8 $ =~ /\D(\d+)\s*$/; + +use base qw(Exporter); +use Symbol (); + +@EXPORT_OK = qw(READABLE WRITABLE); + +sub PrintArgs +{ + my $func = (caller(1))[3]; + print "$func(",join(',',@_),")\n"; +} + +sub PRINT +{ + my $obj = shift; + $obj->wait(WRITABLE); + my $h = $obj->handle; + return print $h @_; +} + +sub PRINTF +{ + my $obj = shift; + $obj->wait(WRITABLE); + my $h = $obj->handle; + return printf $h @_; +} + +sub WRITE +{ + my $obj = $_[0]; + $obj->wait(WRITABLE); + return syswrite($obj->handle,$_[1],$_[2]); +} + +my $depth = 0; +sub READLINE +{ + my $obj = shift; + $obj->wait(READABLE); + my $h = $obj->handle; + my $w = <$h>; + return $w; +} + +sub READ +{ + my $obj = $_[0]; + $obj->wait(READABLE); + my $h = $obj->handle; + return sysread($h,$_[1],$_[2],defined $_[3] ? $_[3] : 0); +} + +sub GETC +{ + my $obj = $_[0]; + $obj->wait(READABLE); + my $h = $obj->handle; + return getc($h); +} + +sub CLOSE +{ + my $obj = shift; + $obj->unwatch; + my $h = $obj->handle; + return close($h); +} + +sub EOF +{ + my $obj = shift; + my $h = $obj->handle; + return eof($h); +} + +sub FILENO +{ + my $obj = shift; + my $h = $obj->handle; + return fileno($h); +} + +sub imode +{ + my $mode = shift; + my $imode = ${{'readable' => READABLE(), + 'writable' => WRITABLE()}}{$mode}; + croak("Invalid handler type '$mode'") unless (defined $imode); + return $imode; +} + +sub fileevent +{ + my ($widget,$file,$mode,$cb) = @_; + my $imode = imode($mode); + unless (ref $file) + { + no strict 'refs'; + $file = Symbol::qualify($file,(caller)[0]); + $file = \*{$file}; + } + my $obj = tied(*$file); + unless ($obj && $obj->isa('Tk::Event::IO')) + { + $obj = tie *$file,'Tk::Event::IO', $file; + } + if (@_ == 3) + { + # query return the handler + return $obj->handler($imode); + } + else + { + # set the handler + my $h = $obj->handler($imode,$cb); + undef $obj; # Prevent warnings about untie with ref to object + unless ($h) + { + untie *$file; + } + } +} + +1; +__END__ diff --git a/Master/tlpkg/installer/perllib/Tk/Frame.pm b/Master/tlpkg/installer/perllib/Tk/Frame.pm new file mode 100644 index 00000000000..a5716cdf9bd --- /dev/null +++ b/Master/tlpkg/installer/perllib/Tk/Frame.pm @@ -0,0 +1,378 @@ +# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +package Tk::Frame; +require Tk::Widget; +require Tk::Derived; +use AutoLoader; +use strict qw(vars); +use Carp; + +use base qw(Tk::Derived Tk::Widget); + +Construct Tk::Widget 'Frame'; + +use vars qw($VERSION); +$VERSION = '4.010'; # $Id: //depot/Tkutf8/Tk/Frame.pm#10 $ + +sub Tk_cmd { \&Tk::frame } + +sub CreateOptions +{ + return (shift->SUPER::CreateOptions,'-colormap','-visual','-container') +} + +sub Default +{ + my ($cw,$name,$widget) = @_; + confess 'No name' unless (defined $name); + croak 'No widget' unless (defined $widget); + $cw->Delegates(DEFAULT => $widget); + $cw->ConfigSpecs(DEFAULT => [$widget]); + $widget->pack('-expand' => 1, -fill => 'both') unless ($widget->manager); # Suspect + $cw->Advertise($name,$widget); +} + +sub ConfigDelegate +{ + my ($cw,$name,@skip) = @_; + my $sw = $cw->Subwidget($name); + my $sc; + my %skip = (); + foreach $sc (@skip) + { + $skip{$sc} = 1; + } + foreach $sc ($sw->configure) + { + my (@info) = @$sc; + next if (@info == 2); + my $option = $info[0]; + unless ($skip{$option}) + { + $option =~ s/^-(.*)/-$name\u$1/; + $info[0] = Tk::Configure->new($sw,$info[0]); + pop(@info); + $cw->ConfigSpecs($option => \@info); + } + } +} + +sub bind +{my ($cw,@args) = @_; + $cw->Delegate('bind',@args); +} + +sub menu +{my ($cw,@args) = @_; + $cw->Delegate('menu',@args); +} + +sub focus +{my ($cw,@args) = @_; + $cw->Delegate('focus',@args); +} + +#sub bindtags +#{my ($cw,@args) = @_; +# $cw->Delegate('bindtags',@args); +#} + +sub selection +{my ($cw,@args) = @_; + $cw->Delegate('selection',@args); +} + +sub autoLabel { 1 } + +sub Populate +{ + my ($cw,$args) = @_; + if ($cw->autoLabel) + { + $cw->ConfigSpecs('-labelPack' => [ 'METHOD', undef, undef, undef]); + $cw->ConfigSpecs('-labelVariable' => [ 'METHOD', undef, undef, undef]); + $cw->ConfigSpecs('-label' => [ 'METHOD', undef, undef, undef]); + $cw->labelPack([]) if grep /^-label\w+/, keys %$args; + } +} + +sub Menubar +{ + my $frame = shift; + my $menu = $frame->cget('-menu'); + if (defined $menu) + { + $menu->configure(@_) if @_; + } + else + { + $menu = $frame->Menu(-type => 'menubar',@_); + $frame->configure('-menu' => $menu); + } + $frame->Advertise('menubar' => $menu); + return $menu; +} + +1; + +__END__ + +sub labelPack +{ + my ($cw,$val) = @_; + my $w = $cw->Subwidget('label'); + my @result = (); + if (@_ > 1) + { + if (defined($w) && !defined($val)) + { + $w->packForget; + } + elsif (defined($val) && !defined ($w)) + { + require Tk::Label; + $w = Tk::Label->new($cw,-textvariable => $cw->labelVariable); + $cw->Advertise('label' => $w); + $cw->ConfigDelegate('label',qw(-text -textvariable)); + } + if (defined($val) && defined($w)) + { + my %pack = @$val; + unless (exists $pack{-side}) + { + $pack{-side} = 'top' unless (exists $pack{-side}); + } + unless (exists $pack{-fill}) + { + $pack{-fill} = 'x' if ($pack{-side} =~ /(top|bottom)/); + $pack{-fill} = 'y' if ($pack{-side} =~ /(left|right)/); + } + unless (exists($pack{'-before'}) || exists($pack{'-after'})) + { + my $before = ($cw->packSlaves)[0]; + $pack{'-before'} = $before if (defined $before); + } + $w->pack(%pack); + } + } + @result = $w->packInfo if (defined $w); + return (wantarray) ? @result : \@result; +} + +sub labelVariable +{ + my ($cw,$val) = @_; + my $var = \$cw->{Configure}{'-labelVariable'}; + if (@_ > 1 && defined $val) + { + $$var = $val; + $$val = '' unless (defined $$val); + my $w = $cw->Subwidget('label'); + unless (defined $w) + { + $cw->labelPack([]); + $w = $cw->Subwidget('label'); + } + $w->configure(-textvariable => $val); + } + return $$var; +} + +sub label +{ + my ($cw,$val) = @_; + my $var = $cw->cget('-labelVariable'); + if (@_ > 1 && defined $val) + { + if (!defined $var) + { + $var = \$cw->{Configure}{'-label'}; + $cw->labelVariable($var); + } + $$var = $val; + } + return (defined $var) ? $$var : undef;; +} + +sub queuePack +{ + my ($cw) = @_; + unless ($cw->{'pack_pending'}) + { + $cw->{'pack_pending'} = 1; + $cw->afterIdle([$cw,'packscrollbars']); + } +} + +sub sbset +{ + my ($cw,$sb,$ref,@args) = @_; + $sb->set(@args); + $cw->queuePack if (@args == 2 && $sb->Needed != $$ref); +} + +sub freeze_on_map +{ + my ($w) = @_; + unless ($w->Tk::bind('Freeze','<Map>')) + { + $w->Tk::bind('Freeze','<Map>',['packPropagate' => 0]) + } + $w->AddBindTag('Freeze'); +} + +sub AddScrollbars +{ + require Tk::Scrollbar; + my ($cw,$w) = @_; + my $def = ''; + my ($x,$y) = ('',''); + my $s = 0; + my $c; + $cw->freeze_on_map; + foreach $c ($w->configure) + { + my $opt = $c->[0]; + if ($opt eq '-yscrollcommand') + { + my $slice = Tk::Frame->new($cw,Name => 'ysbslice'); + my $ysb = Tk::Scrollbar->new($slice,-orient => 'vertical', -command => [ 'yview', $w ]); + my $size = $ysb->cget('-width'); + my $corner = Tk::Frame->new($slice,Name=>'corner','-relief' => 'raised', + '-width' => $size, '-height' => $size); + $ysb->pack(-side => 'left', -fill => 'y'); + $cw->Advertise('yscrollbar' => $ysb); + $cw->Advertise('corner' => $corner); + $cw->Advertise('ysbslice' => $slice); + $corner->{'before'} = $ysb->PathName; + $slice->{'before'} = $w->PathName; + $y = 'w'; + $s = 1; + } + elsif ($opt eq '-xscrollcommand') + { + my $xsb = Tk::Scrollbar->new($cw,-orient => 'horizontal', -command => [ 'xview', $w ]); + $cw->Advertise('xscrollbar' => $xsb); + $xsb->{'before'} = $w->PathName; + $x = 's'; + $s = 1; + } + } + if ($s) + { + $cw->Advertise('scrolled' => $w); + $cw->ConfigSpecs('-scrollbars' => ['METHOD','scrollbars','Scrollbars',$x.$y]); + } +} + +sub packscrollbars +{ + my ($cw) = @_; + my $opt = $cw->cget('-scrollbars'); + my $slice = $cw->Subwidget('ysbslice'); + my $xsb = $cw->Subwidget('xscrollbar'); + my $corner = $cw->Subwidget('corner'); + my $w = $cw->Subwidget('scrolled'); + my $xside = (($opt =~ /n/) ? 'top' : 'bottom'); + my $havex = 0; + my $havey = 0; + $opt =~ s/r//; + $cw->{'pack_pending'} = 0; + if (defined $slice) + { + my $reqy; + my $ysb = $cw->Subwidget('yscrollbar'); + if ($opt =~ /(o)?[we]/ && (($reqy = !defined($1)) || $ysb->Needed)) + { + my $yside = (($opt =~ /w/) ? 'left' : 'right'); + $slice->pack(-side => $yside, -fill => 'y',-before => $slice->{'before'}); + $havey = 1; + if ($reqy) + { + $w->configure(-yscrollcommand => ['set', $ysb]); + } + else + { + $w->configure(-yscrollcommand => ['sbset', $cw, $ysb, \$cw->{'packysb'}]); + } + } + else + { + $w->configure(-yscrollcommand => undef) unless $opt =~ s/[we]//; + $slice->packForget; + } + $cw->{'packysb'} = $havey; + } + if (defined $xsb) + { + my $reqx; + if ($opt =~ /(o)?[ns]/ && (($reqx = !defined($1)) || $xsb->Needed)) + { + $xsb->pack(-side => $xside, -fill => 'x',-before => $xsb->{'before'}); + $havex = 1; + if ($reqx) + { + $w->configure(-xscrollcommand => ['set', $xsb]); + } + else + { + $w->configure(-xscrollcommand => ['sbset', $cw, $xsb, \$cw->{'packxsb'}]); + } + } + else + { + $w->configure(-xscrollcommand => undef) unless $opt =~ s/[ns]//; + $xsb->packForget; + } + $cw->{'packxsb'} = $havex; + } + if (defined $corner) + { + if ($havex && $havey && defined $corner->{'before'}) + { + my $anchor = $opt; + $anchor =~ s/o//g; + $corner->configure(-height => $xsb->ReqHeight); + $corner->pack(-before => $corner->{'before'}, -side => $xside, + -anchor => $anchor, -fill => 'x'); + } + else + { + $corner->packForget; + } + } +} + +sub scrollbars +{ + my ($cw,$opt) = @_; + my $var = \$cw->{'-scrollbars'}; + if (@_ > 1) + { + my $old = $$var; + if (!defined $old || $old ne $opt) + { + $$var = $opt; + $cw->queuePack; + } + } + return $$var; +} + +sub FindMenu +{ + my ($w,$char) = @_; + my $child; + my $match; + foreach $child ($w->children) + { + next unless (ref $child); + $match = $child->FindMenu($char); + return $match if (defined $match); + } + return undef; +} + + + diff --git a/Master/tlpkg/installer/perllib/Tk/Image.pm b/Master/tlpkg/installer/perllib/Tk/Image.pm new file mode 100644 index 00000000000..0f41c387fc2 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Tk/Image.pm @@ -0,0 +1,74 @@ +# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +package Tk::Image; + +# This module does for images what Tk::Widget does for widgets: +# provides a base class for them to inherit from. +require DynaLoader; + +use base qw(DynaLoader Tk); # but are they ? + +use vars qw($VERSION); +$VERSION = '4.011'; # $Id: //depot/Tkutf8/Tk/Image.pm#11 $ + +sub new +{ + my $package = shift; + my $widget = shift; + $package->InitClass($widget); + my $leaf = $package->Tk_image; + my $obj = $widget->Tk::image('create',$leaf,@_); + $obj = $widget->_object($obj) unless (ref $obj); + return bless $obj,$package; +} + +sub Install +{ + # Dynamically loaded image types can install standard images here + my ($class,$mw) = @_; +} + +sub ClassInit +{ + # Carry out class bindings (or whatever) + my ($package,$mw) = @_; + return $package; +} + +require Tk::Submethods; + +Direct Tk::Submethods ('image' => [qw(delete width height type)]); + +sub Tk::Widget::imageNames +{ + my $w = shift; + $w->image('names',@_); +} + +sub Tk::Widget::imageTypes +{ + my $w = shift; + map("\u$_",$w->image('types',@_)); +} + +sub Construct +{ + my ($base,$name) = @_; + my $class = (caller(0))[0]; + + # Hack for broken ->isa in perl5.6.0 + delete ${"$class\::"}{'::ISA::CACHE::'} if $] == 5.006; + + *{"Tk::Widget::$name"} = sub { $class->new(@_) }; +} + +# This is here to prevent AUTOLOAD trying to find it. +sub DESTROY +{ + my $i = shift; + # maybe do image delete ??? +} + + +1; diff --git a/Master/tlpkg/installer/perllib/Tk/Label.pm b/Master/tlpkg/installer/perllib/Tk/Label.pm new file mode 100644 index 00000000000..ebea1741c2f --- /dev/null +++ b/Master/tlpkg/installer/perllib/Tk/Label.pm @@ -0,0 +1,21 @@ +# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. + +package Tk::Label; +require Tk; + + +use vars qw($VERSION); +$VERSION = '4.006'; # $Id: //depot/Tkutf8/Tk/Label.pm#6 $ + +use base qw(Tk::Widget); + +Construct Tk::Widget 'Label'; + +sub Tk_cmd { \&Tk::label } + +1; + + + diff --git a/Master/tlpkg/installer/perllib/Tk/MainWindow.pm b/Master/tlpkg/installer/perllib/Tk/MainWindow.pm new file mode 100644 index 00000000000..5384ccb560b --- /dev/null +++ b/Master/tlpkg/installer/perllib/Tk/MainWindow.pm @@ -0,0 +1,213 @@ +# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +package Tk::MainWindow; +use base qw(Tk::Toplevel); +BEGIN { @MainWindow::ISA = 'Tk::MainWindow' } + +use strict; + +use vars qw($VERSION); +$VERSION = sprintf '4.%03d', q$Revision: #12 $ =~ /\D(\d+)\s*$/; + +use Tk::CmdLine; +use Tk qw(catch); +require Tk::Toplevel; + +use Carp; + +$| = 1; + +my $pid = $$; + +my %Windows = (); + +sub CreateArgs +{ + my ($class,$args) = @_; + my $cmd = Tk::CmdLine->CreateArgs(); + my $key; + foreach $key (keys %$cmd) + { + $args->{$key} = $cmd->{$key} unless exists $args->{$key}; + } + my %result = $class->SUPER::CreateArgs(undef,$args); + my $name = delete($args->{'-name'}); + unless (Tk::tainting) + { + $ENV{'DISPLAY'} = ':0' unless (exists $ENV{'DISPLAY'}); + $result{'-screen'} = $ENV{'DISPLAY'} unless exists $result{'-screen'}; + } + return (-name => "\l$name",%result); +} + +sub new +{ + my $package = shift; + if (@_ > 0 && $_[0] =~ /:\d+(\.\d+)?$/) + { + carp "Usage $package->new(-screen => '$_[0]' ...)" if $^W; + unshift(@_,'-screen'); + } + croak('Odd number of args'."$package->new(" . join(',',@_) .')') if @_ % 2; + my %args = @_; + + my $top = eval { bless Create($package->CreateArgs(\%args)), $package }; + croak($@ . "$package->new(" . join(',',@_) .')') if ($@); + $top->apply_command_line; + $top->InitBindings; + $top->SetBindtags; + $top->InitObject(\%args); + eval { $top->configure(%args) }; + croak "$@" if ($@); + if (($top->positionfrom||'') ne 'user' and ($top->sizefrom||'') ne 'user') { + my $geometry = $top->optionGet(qw(geometry Geometry)); + if ($geometry) { + $top->geometry($geometry); + } + } + $Windows{$top} = $top; + return $top; +} + +sub _Destroyed +{ + my $top = shift; + $top->SUPER::_Destroyed; + delete $Windows{$top}; +} + +sub InitBindings +{ + my $mw = shift; + $mw->bind('all','<Tab>','focusNext'); + # <<LeftTab>> is named <<PrevWindow>> in Tcl/Tk + $mw->eventAdd(qw[<<LeftTab>> <Shift-Tab>]); + # This is needed for XFree86 systems + catch { $mw->eventAdd(qw[<<LeftTab>> <ISO_Left_Tab>]) }; + # This seems to be correct on *some* HP systems. + catch { $mw->eventAdd(qw[<<LeftTab>> <hpBackTab>]) }; + $mw->bind('all','<<LeftTab>>','focusPrev'); + if ($mw->windowingsystem eq 'x11') + { + $mw->eventAdd(qw[<<Cut>> <Control-Key-x> <Key-F20> <Meta-Key-w>]); + $mw->eventAdd(qw[<<Copy>> <Control-Key-c> <Key-F16> <Control-Key-w>]); + $mw->eventAdd(qw[<<Paste>> <Control-Key-v> <Key-F18> <Control-Key-y>]); + $mw->eventAdd(qw[<<PasteSelection>> <ButtonRelease-2>]); + $mw->eventAdd(qw[<<Undo>> <Control-Key-z> <Key-Undo> <Key-F14> + <Control-Key-underscore>]); + $mw->eventAdd(qw[<<Redo>> <Control-Key-y> <Shift-Key-Undo> <Key-F12> <Shift-Key-F14>]); + } + elsif ($mw->windowingsystem eq 'win32') + { + $mw->eventAdd(qw[<<Cut>> <Control-Key-x> <Shift-Key-Delete>]); + $mw->eventAdd(qw[<<Copy>> <Control-Key-c> <Control-Key-Insert>]); + $mw->eventAdd(qw[<<Paste>> <Control-Key-v> <Shift-Key-Insert>]); + $mw->eventAdd(qw[<<Undo>> <Control-Key-z>]); + $mw->eventAdd(qw[<<Redo>> <Control-Key-y>]); + } + elsif ($mw->windowingsystem eq 'aqua') + { + $mw->eventAdd(qw[<<Cut>> <Command-Key-x> <Key-F2>]); + $mw->eventAdd(qw[<<Copy>> <Command-Key-c> <Key-F3>]); + $mw->eventAdd(qw[<<Paste>> <Command-Key-v> <Key-F4>]); + $mw->eventAdd(qw[<<PasteSelection>> <ButtonRelease-2>]); + $mw->eventAdd(qw[<<Clear>> <Clear>]); + $mw->eventAdd(qw[<<Undo>> <Command-Key-z>]); + $mw->eventAdd(qw[<<Redo>> <Command-Key-y>]); + } + elsif ($mw->windowingsystem eq 'classic') + { + $mw->eventAdd(qw[<<Cut>> <Control-Key-x> <Key-F2>]); + $mw->eventAdd(qw[<<Copy>> <Control-Key-c> <Key-F3>]); + $mw->eventAdd(qw[<<Paste>> <Control-Key-v> <Key-F4>]); + $mw->eventAdd(qw[<<PasteSelection>> <ButtonRelease-2>]); + $mw->eventAdd(qw[<<Clear>> <Clear>]); + $mw->eventAdd(qw[<<Undo>> <Control-Key-z> <Key-F1>]); + $mw->eventAdd(qw[<<Redo>> <Control-Key-Z>]); + } + + # FIXME - Should these move to Menubutton ? + my $c = ($Tk::platform eq 'unix') ? 'all' : 'Tk::Menubutton'; + $mw->bind($c,'<Alt-KeyPress>',['TraverseToMenu',Tk::Ev('K')]); + $mw->bind($c,'<F10>','FirstMenu'); +} + +sub Existing +{ + my @Windows; + foreach my $name (keys %Windows) + { + my $obj = $Windows{$name}; + if (Tk::Exists($obj)) + { + push(@Windows,$obj); + } + else + { + delete $Windows{$name}; + } + } + return @Windows; +} + +END +{ + if (Tk::IsParentProcess()) + { + foreach my $top (values %Windows) + { + if ($top->IsWidget) + { + # Tk data structuctures are still in place + # this can occur if non-callback perl code did a 'die'. + # It will also handle some cases of non-Tk 'exit' being called + # Destroy this mainwindow and hence is descendants ... + $top->destroy; + } + } + } +} + +sub CmdLine { return shift->command } + +sub WMSaveYourself +{ + my $mw = shift; + my @args = @{$mw->command}; +# warn 'preWMSaveYourself:'.join(' ',@args)."\n"; + @args = ($0) unless (@args); + my $i = 1; + while ($i < @args) + { + if ($args[$i] eq '-iconic') + { + splice(@args,$i,1); + } + elsif ($args[$i] =~ /^-(geometry|iconposition)$/) + { + splice(@args,$i,2); + } + } + + my @ip = $mw->wm('iconposition'); +# print 'ip ',join(',',@ip),"\n"; + my $icon = $mw->iconwindow; + if (defined($icon)) + { + @ip = $icon->geometry =~ /\d+x\d+([+-]\d+)([+-]\d+)/; + } + splice(@args,1,0,'-iconposition' => join(',',@ip)) if (@ip == 2); + + splice(@args,1,0,'-iconic') if ($mw->state() eq 'iconic'); + + splice(@args,1,0,'-geometry' => $mw->geometry); +# warn 'postWMSaveYourself:'.join(' ',@args)."\n"; + $mw->command([@args]); +} + +1; + +__END__ + +=cut diff --git a/Master/tlpkg/installer/perllib/Tk/PNG.pm b/Master/tlpkg/installer/perllib/Tk/PNG.pm new file mode 100644 index 00000000000..1ecb4001d17 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Tk/PNG.pm @@ -0,0 +1,43 @@ +package Tk::PNG; +require DynaLoader; + +use vars qw($VERSION); +$VERSION = sprintf '4.%03d', q$Revision: #3 $ =~ /\D(\d+)\s*$/; + +use Tk 800.005; +require Tk::Image; +require Tk::Photo; + +use base qw(DynaLoader); + +bootstrap Tk::PNG $Tk::VERSION; + +1; + +__END__ + +=head1 NAME + +Tk::PNG - PNG loader for Tk::Photo + +=head1 SYNOPSIS + + use Tk; + use Tk::PNG; + + my $image = $widget->Photo('-format' => 'png', -file => 'something.png'); + + +=head1 DESCRIPTION + +This is an extension for Tk800.* which supplies +PNG format loader for Photo image type. + + +=head1 AUTHOR + +Nick Ing-Simmons E<lt>nick@ing-simmons.netE<gt> + +=cut + + diff --git a/Master/tlpkg/installer/perllib/Tk/Photo.pm b/Master/tlpkg/installer/perllib/Tk/Photo.pm new file mode 100644 index 00000000000..a596dc4d78b --- /dev/null +++ b/Master/tlpkg/installer/perllib/Tk/Photo.pm @@ -0,0 +1,22 @@ +package Tk::Photo; + +use vars qw($VERSION); +$VERSION = sprintf '4.%03d', 4+q$Revision: #4 $ =~ /\D(\d+)\s*$/; + +use Tk qw($XS_VERSION); + +use base qw(Tk::Image); + +Construct Tk::Image 'Photo'; + +sub Tk_image { 'photo' } + +Tk::Methods('blank','copy','data','formats','get','put','read', + 'redither','transparency','write'); + +use Tk::Submethods ( + 'transparency' => [qw/get set/], +); + +1; +__END__ diff --git a/Master/tlpkg/installer/perllib/Tk/Pretty.pm b/Master/tlpkg/installer/perllib/Tk/Pretty.pm new file mode 100644 index 00000000000..7e442a4bcbc --- /dev/null +++ b/Master/tlpkg/installer/perllib/Tk/Pretty.pm @@ -0,0 +1,93 @@ +# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +package Tk::Pretty; +require Exporter; + +use vars qw($VERSION @EXPORT); +$VERSION = '4.006'; # $Id: //depot/Tkutf8/Tk/Pretty.pm#6 $ + +use base qw(Exporter); + +@EXPORT = qw(Pretty PrintArgs); + +sub pretty_list +{ + join(',',map(&Pretty($_),@_)); +} + +sub Pretty +{ + return pretty_list(@_) if (@_ > 1); + my $obj = shift; + return 'undef' unless defined($obj); + my $type = "$obj"; + return $type if ($type =~ /=HASH/ && exists($obj->{"_Tcl_CmdInfo_\0"})); + my $result = ''; + if (ref $obj) + { + my $class; + if ($type =~ /^([^=]+)=(.*)$/) + { + $class = $1; + $type = $2; + $result .= 'bless('; + } + if ($type =~ /^ARRAY/) + { + $result .= '['; + $result .= pretty_list(@$obj); + $result .= ']'; + } + elsif ($type =~ /^HASH/) + { + $result .= '{'; + if (%$obj) + { + my ($key, $value); + while (($key,$value) = each %$obj) + { + $result .= $key . '=>' . Pretty($value) . ','; + } + chop($result); + } + $result .= '}'; + } + elsif ($type =~ /^REF/) + { + $result .= "\\" . Pretty($$obj); + } + elsif ($type =~ /^SCALAR/) + { + $result .= Pretty($$obj); + } + else + { + $result .= $type; + } + $result .= ",$class)" if (defined $class); + } + else + { + if ($obj =~ /^-?[0-9]+(.[0-9]*(e[+-][0-9]+)?)?$/ || + $obj =~ /^[A-Z_][A-Za-z_0-9]*$/ || + $obj =~ /^[a-z_][A-Za-z_0-9]*[A-Z_][A-Za-z_0-9]*$/ + ) + { + $result .= $obj; + } + else + { + $result .= "'" . $obj . "'"; + } + } + return $result; +} + +sub PrintArgs +{ + my $name = (caller(1))[3]; + print "$name(",Pretty(@_),")\n"; +} + +1; diff --git a/Master/tlpkg/installer/perllib/Tk/Radiobutton.pm b/Master/tlpkg/installer/perllib/Tk/Radiobutton.pm new file mode 100644 index 00000000000..d09d41b4208 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Tk/Radiobutton.pm @@ -0,0 +1,45 @@ +# Conversion from Tk4.0 button.tcl competed. +# Copyright (c) 1992-1994 The Regents of the University of California. +# Copyright (c) 1994 Sun Microsystems, Inc. +# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved. +# This program is free software; you can redistribute it and/or + +package Tk::Radiobutton; + +use vars qw($VERSION); +$VERSION = '4.006'; # $Id: //depot/Tkutf8/Tk/Radiobutton.pm#6 $ + +# modify it under the same terms as Perl itself, subject +# to additional disclaimer in license.terms due to partial +# derivation from Tk4.0 sources. + +require Tk::Button; + + +use base qw(Tk::Button); +Construct Tk::Widget 'Radiobutton'; + +sub Tk_cmd { \&Tk::radiobutton } + +sub CreateOptions +{ + return (shift->SUPER::CreateOptions,'-variable'); +} + +sub ClassInit +{ + my ($class,$mw) = @_; + $mw->bind($class,'<Enter>', 'Enter'); + $mw->bind($class,'<Leave>', 'Leave'); + $mw->bind($class,'<1>', 'Invoke'); + $mw->bind($class,'<space>', 'Invoke'); + return $class; +} + +sub Invoke +{ + my $w = shift; + $w->invoke() unless($w->cget('-state') eq 'disabled'); +} + +1; diff --git a/Master/tlpkg/installer/perllib/Tk/Submethods.pm b/Master/tlpkg/installer/perllib/Tk/Submethods.pm new file mode 100644 index 00000000000..a2b8e3bd186 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Tk/Submethods.pm @@ -0,0 +1,46 @@ +package Tk::Submethods; + +use vars qw($VERSION); +$VERSION = '4.004'; # $Id: //depot/Tkutf8/Tk/Submethods.pm#4 $ + +sub import +{ + my $class = shift; + no strict 'refs'; + my $package = caller(0); + while (@_) + { + my $fn = shift; + my $sm = shift; + foreach my $sub (@{$sm}) + { + my ($suffix) = $sub =~ /(\w+)$/; + my $pfn = $package.'::'.$fn; + *{$pfn."\u$suffix"} = sub { shift->$pfn($sub,@_) }; + } + } +} + +sub Direct +{ + my $class = shift; + no strict 'refs'; + my $package = caller(0); + while (@_) + { + my $fn = shift; + my $sm = shift; + my $sub; + foreach $sub (@{$sm}) + { + # eval "sub ${package}::${sub} { shift->$fn('$sub',\@_) }"; + *{$package.'::'.$sub} = sub { shift->$fn($sub,@_) }; + } + } +} + +1; + +__END__ + +=cut diff --git a/Master/tlpkg/installer/perllib/Tk/Toplevel.pm b/Master/tlpkg/installer/perllib/Tk/Toplevel.pm new file mode 100644 index 00000000000..7bcd156d475 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Tk/Toplevel.pm @@ -0,0 +1,211 @@ +# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +package Tk::Toplevel; +use AutoLoader; + +use vars qw($VERSION); +$VERSION = '4.006'; # $Id: //depot/Tkutf8/Tk/Toplevel.pm#6 $ + +use base qw(Tk::Wm Tk::Frame); + +Construct Tk::Widget 'Toplevel'; + +sub Tk_cmd { \&Tk::toplevel } + +sub CreateOptions +{ + return (shift->SUPER::CreateOptions,'-screen','-use') +} + +sub Populate +{ + my ($cw,$arg) = @_; + $cw->SUPER::Populate($arg); + $cw->ConfigSpecs('-title',['METHOD',undef,undef,$cw->class]); +} + +sub Icon +{ + my ($top,%args) = @_; + my $icon = $top->iconwindow; + my $state = $top->state; + if ($state ne 'withdrawn') + { + $top->withdraw; + $top->update; # Let attributes propogate + } + unless (defined $icon) + { + $icon = Tk::Toplevel->new($top,'-borderwidth' => 0,'-class'=>'Icon'); + $icon->withdraw; + # Fake Populate + my $lab = $icon->Component('Label' => 'icon'); + $lab->pack('-expand'=>1,'-fill' => 'both'); + $icon->ConfigSpecs(DEFAULT => ['DESCENDANTS']); + # Now do tail of InitObject + $icon->ConfigDefault(\%args); + # And configure that new would have done + $top->iconwindow($icon); + $top->update; + $lab->DisableButtonEvents; + $lab->update; + } + $top->iconimage($args{'-image'}) if (exists $args{'-image'}); + $icon->configure(%args); + $icon->idletasks; # Let size request propogate + $icon->geometry($icon->ReqWidth . 'x' . $icon->ReqHeight); + $icon->update; # Let attributes propogate + $top->deiconify if ($state eq 'normal'); + $top->iconify if ($state eq 'iconic'); +} + +sub menu +{ + my $w = shift; + my $menu; + $menu = $w->cget('-menu'); + unless (defined $menu) + { + $w->configure(-menu => ($menu = $w->SUPER::menu)) + } + $menu->configure(@_) if @_; + return $menu; +} + + +1; +__END__ + +#---------------------------------------------------------------------- +# +# Focus Group +# +# Focus groups are used to handle the user's focusing actions inside a +# toplevel. +# +# One example of using focus groups is: when the user focuses on an +# entry, the text in the entry is highlighted and the cursor is put to +# the end of the text. When the user changes focus to another widget, +# the text in the previously focused entry is validated. +# + +#---------------------------------------------------------------------- +# tkFocusGroup_Create -- +# +# Create a focus group. All the widgets in a focus group must be +# within the same focus toplevel. Each toplevel can have only +# one focus group, which is identified by the name of the +# toplevel widget. +# +sub FG_Create { + my $t = shift; + unless (exists $t->{'_fg'}) { + $t->{'_fg'} = 1; + $t->bind('<FocusIn>', sub { + my $w = shift; + my $Ev = $w->XEvent; + $t->FG_In($w, $Ev->d); + } + ); + $t->bind('<FocusOut>', sub { + my $w = shift; + my $Ev = $w->XEvent; + $t->FG_Out($w, $Ev->d); + } + ); + $t->bind('<Destroy>', sub { + my $w = shift; + my $Ev = $w->XEvent; + $t->FG_Destroy($w); + } + ); + # <Destroy> is not sufficient to break loops if never mapped. + $t->OnDestroy([$t,'FG_Destroy']); + } +} + +# tkFocusGroup_BindIn -- +# +# Add a widget into the "FocusIn" list of the focus group. The $cmd will be +# called when the widget is focused on by the user. +# +sub FG_BindIn { + my($t, $w, $cmd) = @_; + $t->Error("focus group \"$t\" doesn't exist") unless (exists $t->{'_fg'}); + $t->{'_FocusIn'}{$w} = Tk::Callback->new($cmd); +} + +# tkFocusGroup_BindOut -- +# +# Add a widget into the "FocusOut" list of the focus group. The +# $cmd will be called when the widget loses the focus (User +# types Tab or click on another widget). +# +sub FG_BindOut { + my($t, $w, $cmd) = @_; + $t->Error("focus group \"$t\" doesn't exist") unless (exists $t->{'_fg'}); + $t->{'_FocusOut'}{$w} = Tk::Callback->new($cmd); +} + +# tkFocusGroup_Destroy -- +# +# Cleans up when members of the focus group is deleted, or when the +# toplevel itself gets deleted. +# +sub FG_Destroy { + my($t, $w) = @_; + if (!defined($w) || $t == $w) { + delete $t->{'_fg'}; + delete $t->{'_focus'}; + delete $t->{'_FocusOut'}; + delete $t->{'_FocusIn'}; + } else { + if (exists $t->{'_focus'}) { + delete $t->{'_focus'} if ($t->{'_focus'} == $w); + } + delete $t->{'_FocusIn'}{$w}; + delete $t->{'_FocusOut'}{$w}; + } +} + +# tkFocusGroup_In -- +# +# Handles the <FocusIn> event. Calls the FocusIn command for the newly +# focused widget in the focus group. +# +sub FG_In { + my($t, $w, $detail) = @_; + if (defined $t->{'_focus'} and $t->{'_focus'} eq $w) { + # This is already in focus + return; + } else { + $t->{'_focus'} = $w; + $t->{'_FocusIn'}{$w}->Call if exists $t->{'_FocusIn'}{$w}; + } +} + +# tkFocusGroup_Out -- +# +# Handles the <FocusOut> event. Checks if this is really a lose +# focus event, not one generated by the mouse moving out of the +# toplevel window. Calls the FocusOut command for the widget +# who loses its focus. +# +sub FG_Out { + my($t, $w, $detail) = @_; + if ($detail ne 'NotifyNonlinear' and $detail ne 'NotifyNonlinearVirtual') { + # This is caused by mouse moving out of the window + return; + } + unless (exists $t->{'_FocusOut'}{$w}) { + return; + } else { + $t->{'_FocusOut'}{$w}->Call; + delete $t->{'_focus'}; + } +} + +1; + +__END__ diff --git a/Master/tlpkg/installer/perllib/Tk/Widget.pm b/Master/tlpkg/installer/perllib/Tk/Widget.pm new file mode 100644 index 00000000000..e94c037e6fe --- /dev/null +++ b/Master/tlpkg/installer/perllib/Tk/Widget.pm @@ -0,0 +1,1510 @@ +# Copyright (c) 1995-2004 Nick Ing-Simmons. All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +package Tk::Widget; +use vars qw($VERSION @DefaultMenuLabels); +$VERSION = sprintf '4.%03d', q$Revision: #30 $ =~ /\D(\d+)\s*$/; + +require Tk; +use AutoLoader; +use strict; +use Carp; +use base qw(DynaLoader Tk); + +# stubs for 'autoloaded' widget classes +sub Button; +sub Canvas; +sub Checkbutton; +sub Entry; +sub Frame; +sub Label; +sub Labelframe; +sub Listbox; +sub Menu; +sub Menubutton; +sub Message; +sub Panedwindow; +sub Radiobutton; +sub Scale; +sub Scrollbar; +sub Spinbox; +sub Text; +sub Toplevel; + +sub Pixmap; +sub Bitmap; +sub Photo; + +sub ScrlListbox; +sub Optionmenu; + +sub import +{ + my $package = shift; + carp 'use Tk::Widget () to pre-load widgets is deprecated' if (@_); + my $need; + foreach $need (@_) + { + unless (defined &{$need}) + { + require "Tk/${need}.pm"; + } + croak "Cannot locate $need" unless (defined &{$need}); + } +} + +@DefaultMenuLabels = qw[~File ~Help]; + +# Some tidy-ness functions for winfo stuff + +sub True { 1 } +sub False { 0 } + +use Tk::Submethods( 'grab' => [qw(current status release -global)], + 'focus' => [qw(-force -lastfor)], + 'pack' => [qw(configure forget info propagate slaves)], + 'grid' => [qw(bbox columnconfigure configure forget info location propagate rowconfigure size slaves)], + 'form' => [qw(check configure forget grid info slaves)], + 'event' => [qw(add delete generate info)], + 'place' => [qw(configure forget info slaves)], + 'wm' => [qw(capture release)], + 'font' => [qw(actual configure create delete families measure metrics names subfonts)] + ); + +BEGIN { + # FIXME - these don't work in the compiler + *IsMenu = \&False; + *IsMenubutton = \&False; + *configure_self = \&Tk::configure; + *cget_self = \&Tk::cget; +} + + + +Direct Tk::Submethods ( + 'winfo' => [qw(cells class colormapfull depth exists + geometry height id ismapped manager name parent reqheight + reqwidth rootx rooty screen screencells screendepth screenheight + screenmmheight screenmmwidth screenvisual screenwidth visual + visualsavailable vrootheight viewable vrootwidth vrootx vrooty + width x y toplevel children pixels pointerx pointery pointerxy + server fpixels rgb )], + 'tk' => [qw(appname caret scaling useinputmethods windowingsystem)]); + + +sub DESTROY +{ + my $w = shift; + $w->destroy if ($w->IsWidget); +} + +sub Install +{ + # Dynamically loaded widgets add their core commands + # to the Tk base class here + my ($package,$mw) = @_; +} + +sub ClassInit +{ + # Carry out class bindings (or whatever) + my ($package,$mw) = @_; + return $package; +} + +sub CreateOptions +{ + return (); +} + +sub CreateArgs +{ + my ($package,$parent,$args) = @_; + # Remove from hash %$args any configure-like + # options which only apply at create time (e.g. -colormap for Frame), + # or which may as well be applied right away + # return these as a list of -key => value pairs + # Augment same hash with default values for missing mandatory options, + # allthough this can be done later in InitObject. + + # Honour -class => if present, we have hacked Tk_ConfigureWidget to + # allow -class to be passed to any widget. + my @result = (); + my $class = delete $args->{'-class'}; + ($class) = $package =~ /([A-Z][A-Z0-9_]*)$/i unless (defined $class); + @result = (-class => "\u$class") if (defined $class); + foreach my $opt ($package->CreateOptions) + { + push(@result, $opt => delete $args->{$opt}) if exists $args->{$opt}; + } + return @result; +} + +sub InitObject +{ + my ($obj,$args) = @_; + # per object initialization, for example populating + # with sub-widgets, adding a few object bindings to augment + # inherited class bindings, changing binding tags. + # Also another chance to mess with %$args before configure... +} + +sub SetBindtags +{ + my ($obj) = @_; + $obj->bindtags([ref($obj),$obj,$obj->toplevel,'all']); +} + +sub new +{ + local $SIG{'__DIE__'} = \&Carp::croak; + my $package = shift; + my $parent = shift; + $package->InitClass($parent); + $parent->BackTrace("Odd number of args to $package->new(...)") unless ((@_ % 2) == 0); + my %args = @_; + my @args = $package->CreateArgs($parent,\%args); + my $cmd = $package->Tk_cmd; + my $pname = $parent->PathName; + $pname = '' if ($pname eq '.'); + my $leaf = delete $args{'Name'}; + if (defined $leaf) + { + $leaf =~ s/[^a-z0-9_#]+/_/ig; + $leaf = lcfirst($leaf); + } + else + { + ($leaf) = "\L$package" =~ /([a-z][a-z0-9_]*)$/; + } + my $lname = $pname . '.' . $leaf; + # create a hash indexed by leaf name to speed up + # creation of a lot of sub-widgets of the same type + # e.g. entries in Table + my $nhash = $parent->TkHash('_names_'); + $nhash->{$leaf} = 0 unless (exists $nhash->{$leaf}); + while (defined ($parent->Widget($lname))) + { + $lname = $pname . '.' . $leaf . ++$nhash->{$leaf}; + } + my $obj = eval { &$cmd($parent, $lname, @args) }; + confess $@ if $@; + unless (ref $obj) + { + die "No value from $cmd $lname" unless defined $obj; + warn "$cmd '$lname' returned '$obj'" unless $obj eq $lname; + $obj = $parent->Widget($lname = $obj); + die "$obj from $lname" unless ref $obj; + } + bless $obj,$package; + $obj->SetBindtags; + my $notice = $parent->can('NoticeChild'); + $parent->$notice($obj,\%args) if $notice; + $obj->InitObject(\%args); +# ASkludge(\%args,1); + $obj->configure(%args) if (%args); +# ASkludge(\%args,0); + return $obj; +} + +sub DelegateFor +{ + my ($w,$method) = @_; + while(exists $w->{'Delegates'}) + { + my $delegate = $w->{'Delegates'}; + my $widget = $delegate->{$method}; + $widget = $delegate->{DEFAULT} unless (defined $widget); + $widget = $w->Subwidget($widget) if (defined $widget && !ref $widget); + last unless (defined $widget); + last if $widget == $w; + $w = $widget; + } + return $w; +} + +sub Delegates +{ + my $cw = shift; + my $specs = $cw->TkHash('Delegates'); + while (@_) + { + my $key = shift; + my $val = shift; + $specs->{$key} = $val; + } + return $specs; +} + +sub Construct +{ + my ($base,$name) = @_; + my $class = (caller(0))[0]; + no strict 'refs'; + + # Hack for broken ->isa in perl5.6.0 + delete ${"$class\::"}{'::ISA::CACHE::'} if $] == 5.006; + + # Pre ->isa scheme + *{$base.'::Is'.$name} = \&False; + *{$class.'::Is'.$name} = \&True; + + # DelegateFor trickyness is to allow Frames and other derived things + # to force creation in a delegate e.g. a ScrlText with embeded windows + # need those windows to be children of the Text to get clipping right + # and not of the Frame which contains the Text and the scrollbars. + *{$base.'::'."$name"} = sub { $class->new(shift->DelegateFor('Construct'),@_) }; +} + +sub IS +{ + return (defined $_[1]) && $_[0] == $_[1]; +} + +sub _AutoloadTkWidget +{ + my ($self,$method) = @_; + my $what = "Tk::Widget::$method"; + unless (defined &$what) + { + require "Tk/$method.pm"; + } + return $what; +} + +# require UNIVERSAL; don't load .pm use XS code from perl core though + +sub AUTOLOAD +{ + # Take a copy into a 'my' variable so we can recurse + my $what = $Tk::Widget::AUTOLOAD; + my $save = $@; + my $name; + # warn "AUTOLOAD $what ".(ref($_[0]) || $_[0])."\n"; + # Braces used to preserve $1 et al. + { + my ($pkg,$func) = $what =~ /(.*)::([^:]+)$/; + confess("Attempt to load '$what'") unless defined($pkg) && $func =~ /^[\w:]+$/; + $pkg =~ s#::#/#g; + if (defined($name=$INC{"$pkg.pm"})) + { + $name =~ s#^(.*)$pkg\.pm$#$1auto/$pkg/$func.al#; + } + else + { + $name = "auto/$what.al"; + $name =~ s#::#/#g; + } + } + # This may fail, catch error and prevent user's __DIE__ handler + # from triggering as well... + eval {local $SIG{'__DIE__'}; require $name}; + if ($@) + { + croak $@ unless ($@ =~ /Can't locate\s+(?:file\s+)?'?\Q$name\E'?/); + my($package,$method) = ($what =~ /^(.*)::([^:]*)$/); + if (ref $_[0] && !$_[0]->can($method) + && $_[0]->can('Delegate') + && $method !~ /^(ConfigSpecs|Delegates)/ ) + { + my $delegate = $_[0]->Delegates; + if (%$delegate || tied %$delegate) + { + my $widget = $delegate->{$method}; + $widget = $delegate->{DEFAULT} unless (defined $widget); + if (defined $widget) + { + my $subwidget = (ref $widget) ? $widget : $_[0]->Subwidget($widget); + if (defined $subwidget) + { + no strict 'refs'; + # print "AUTOLOAD: $what\n"; + *{$what} = sub { shift->Delegate($method,@_) }; + } + else + { + croak "No delegate subwidget '$widget' for $what"; + } + } + } + } + if (!defined(&$what) && ref($_[0]) && $method =~ /^[A-Z]\w+$/) + { + # Use ->can as ->isa is broken in perl5.6.0 + my $sub = UNIVERSAL::can($_[0],'_AutoloadTkWidget'); + if ($sub) + { + carp "Assuming 'require Tk::$method;'" unless $_[0]->can($method); + $what = $_[0]->$sub($method) + } + } + } + $@ = $save; + $DB::sub = $what; # Tell debugger what is going on... + unless (defined &$what) + { + no strict 'refs'; + *{$what} = sub { croak("Failed to AUTOLOAD '$what'") }; + } + goto &$what; +} + +sub _Destroyed +{ + my $w = shift; + my $a = delete $w->{'_Destroy_'}; + if (ref($a)) + { + while (@$a) + { + my $ent = pop(@$a); + if (ref $ent) + { + eval {local $SIG{'__DIE__'}; $ent->Call }; + } + else + { + delete $w->{$ent}; + } + } + } +} + +sub _OnDestroy +{ + my $w = shift; + $w->{'_Destroy_'} = [] unless (exists $w->{'_Destroy_'}); + push(@{$w->{'_Destroy_'}},@_); +} + +sub OnDestroy +{ + my $w = shift; + $w->_OnDestroy(Tk::Callback->new(@_)); +} + +sub TkHash +{ + my ($w,$key) = @_; + return $w->{$key} if exists $w->{$key}; + my $hash = $w->{$key} = {}; + $w->_OnDestroy($key); + return $hash; +} + +sub privateData +{ + my $w = shift; + my $p = shift || caller; + $w->{$p} ||= {}; +} + +my @image_types; +my %image_method; + +sub ImageMethod +{ + shift if (@_ & 1); + while (@_) + { + my ($name,$method) = splice(@_,0,2); + push(@image_types,$name); + $image_method{$name} = $method; + } +} + +sub Getimage +{ + my ($w, $name) = @_; + my $mw = $w->MainWindow; + croak "Usage \$widget->Getimage('name')" unless defined($name); + my $images = ($mw->{'__Images__'} ||= {}); + + return $images->{$name} if $images->{$name}; + + ImageMethod(xpm => 'Pixmap', + gif => 'Photo', + ppm => 'Photo', + xbm => 'Bitmap' ) unless @image_types; + + foreach my $type (@image_types) + { + my $method = $image_method{$type}; + my $file = Tk->findINC( "$name.$type" ); + next unless( $file && $method ); + my $sub = $w->can($method); + unless (defined &$sub) + { + require Tk::widgets; + Tk::widgets->import($method); + } + $images->{$name} = $w->$method( -file => $file ); + return $images->{$name}; + } + + # Try built-in bitmaps + $images->{$name} = $w->Pixmap( -id => $name ); + return $images->{$name}; +} + +sub SaveGrabInfo +{ + my $w = shift; + $Tk::oldGrab = $w->grabCurrent; + if (defined $Tk::oldGrab) + { + $Tk::grabStatus = $Tk::oldGrab->grabStatus; + } +} + +sub grabSave +{ + my ($w) = @_; + my $grab = $w->grabCurrent; + return sub {} if (!defined $grab); + my $method = ($grab->grabStatus eq 'global') ? 'grabGlobal' : 'grab'; + return sub { eval {local $SIG{'__DIE__'}; $grab->$method() } }; +} + +sub focusCurrent +{ + my ($w) = @_; + $w->Tk::focus('-displayof'); +} + +sub focusSave +{ + my ($w) = @_; + my $focus = $w->focusCurrent; + return sub {} if (!defined $focus); + return sub { eval {local $SIG{'__DIE__'}; $focus->focus } }; +} + +# This is supposed to replicate Tk::after behaviour, +# but does auto-cancel when widget is deleted. +require Tk::After; + +sub afterCancel +{ + my ($w,$what) = @_; + if (defined $what) + { + return $what->cancel if ref($what); + carp "dubious cancel of $what" if 0 && $^W; + $w->Tk::after('cancel' => $what); + } +} + +sub afterIdle +{ + my $w = shift; + return Tk::After->new($w,'idle','once',@_); +} + +sub afterInfo { + my ($w, $id) = @_; + if (defined $id) { + return ($id->[4], $id->[2], $id->[3]); + } else { + return sort( keys %{$w->{_After_}} ); + } +} + +sub after +{ + my $w = shift; + my $t = shift; + if (@_) + { + if ($t ne 'cancel') + { + require Tk::After; + return Tk::After->new($w,$t,'once',@_) + } + while (@_) + { + my $what = shift; + $w->afterCancel($what); + } + } + else + { + $w->Tk::after($t); + } +} + +sub repeat +{ + require Tk::After; + my $w = shift; + my $t = shift; + return Tk::After->new($w,$t,'repeat',@_); +} + +sub FindMenu +{ + # default FindMenu is that there is no menu. + return undef; +} + +sub XEvent { shift->{'_XEvent_'} } + +sub propertyRoot +{ + my $w = shift; + return $w->property(@_,'root'); +} + +# atom, atomname, containing, interps, pathname +# don't work this way - there is no window arg +# So we pretend there was an call the C versions from Tk.xs + +sub atom { shift->InternAtom(@_) } +sub atomname { shift->GetAtomName(@_) } +sub containing { shift->Containing(@_) } + +# interps not done yet +# pathname not done yet + +# walk and descendants adapted from Stephen's composite +# versions as they only use core features they can go here. +# hierachy is reversed in that descendants calls walk rather +# than vice versa as this avoids building a list. +# Walk should possibly be enhanced so allow early termination +# like '-prune' of find. + +sub Walk +{ + # Traverse a widget hierarchy while executing a subroutine. + my($cw, $proc, @args) = @_; + my $subwidget; + foreach $subwidget ($cw->children) + { + $subwidget->Walk($proc,@args); + &$proc($subwidget, @args); + } +} # end walk + +sub Descendants +{ + # Return a list of widgets derived from a parent widget and all its + # descendants of a particular class. + # If class is not passed returns the entire widget hierarchy. + + my($widget, $class) = @_; + my(@widget_tree) = (); + + $widget->Walk( + sub { my ($widget,$list,$class) = @_; + push(@$list, $widget) if (!defined($class) or $class eq $widget->class); + }, + \@widget_tree, $class + ); + return @widget_tree; +} + +sub Palette +{ + my $w = shift->MainWindow; + unless (exists $w->{_Palette_}) + { + my %Palette = (); + my $c = $w->Checkbutton(); + my $e = $w->Entry(); + my $s = $w->Scrollbar(); + $Palette{'activeBackground'} = ($c->configure('-activebackground'))[3] ; + $Palette{'activeForeground'} = ($c->configure('-activeforeground'))[3]; + $Palette{'background'} = ($c->configure('-background'))[3]; + $Palette{'disabledForeground'} = ($c->configure('-disabledforeground'))[3]; + $Palette{'foreground'} = ($c->configure('-foreground'))[3]; + $Palette{'highlightBackground'} = ($c->configure('-highlightbackground'))[3]; + $Palette{'highlightColor'} = ($c->configure('-highlightcolor'))[3]; + $Palette{'insertBackground'} = ($e->configure('-insertbackground'))[3]; + $Palette{'selectColor'} = ($c->configure('-selectcolor'))[3]; + $Palette{'selectBackground'} = ($e->configure('-selectbackground'))[3]; + $Palette{'selectForeground'} = ($e->configure('-selectforeground'))[3]; + $Palette{'troughColor'} = ($s->configure('-troughcolor'))[3]; + $c->destroy; + $e->destroy; + $s->destroy; + $w->{_Palette_} = \%Palette; + } + return $w->{_Palette_}; +} + +# tk_setPalette -- +# Changes the default color scheme for a Tk application by setting +# default colors in the option database and by modifying all of the +# color options for existing widgets that have the default value. +# +# Arguments: +# The arguments consist of either a single color name, which +# will be used as the new background color (all other colors will +# be computed from this) or an even number of values consisting of +# option names and values. The name for an option is the one used +# for the option database, such as activeForeground, not -activeforeground. +sub setPalette +{ + my $w = shift->MainWindow; + my %new = (@_ == 1) ? (background => $_[0]) : @_; + my $priority = delete($new{'priority'}) || 'widgetDefault'; + + # Create an array that has the complete new palette. If some colors + # aren't specified, compute them from other colors that are specified. + + die 'must specify a background color' if (!exists $new{background}); + $new{'foreground'} = 'black' unless (exists $new{foreground}); + my @bg = $w->rgb($new{'background'}); + my @fg = $w->rgb($new{'foreground'}); + my $darkerBg = sprintf('#%02x%02x%02x',9*$bg[0]/2560,9*$bg[1]/2560,9*$bg[2]/2560); + foreach my $i ('activeForeground','insertBackground','selectForeground','highlightColor') + { + $new{$i} = $new{'foreground'} unless (exists $new{$i}); + } + unless (exists $new{'disabledForeground'}) + { + $new{'disabledForeground'} = sprintf('#%02x%02x%02x',(3*$bg[0]+$fg[0])/1024,(3*$bg[1]+$fg[1])/1024,(3*$bg[2]+$fg[2])/1024); + } + $new{'highlightBackground'} = $new{'background'} unless (exists $new{'highlightBackground'}); + + unless (exists $new{'activeBackground'}) + { + my @light; + # Pick a default active background that is lighter than the + # normal background. To do this, round each color component + # up by 15% or 1/3 of the way to full white, whichever is + # greater. + foreach my $i (0, 1, 2) + { + $light[$i] = $bg[$i]/256; + my $inc1 = $light[$i]*15/100; + my $inc2 = (255-$light[$i])/3; + if ($inc1 > $inc2) + { + $light[$i] += $inc1 + } + else + { + $light[$i] += $inc2 + } + $light[$i] = 255 if ($light[$i] > 255); + } + $new{'activeBackground'} = sprintf('#%02x%02x%02x',@light); + } + $new{'selectBackground'} = $darkerBg unless (exists $new{'selectBackground'}); + $new{'troughColor'} = $darkerBg unless (exists $new{'troughColor'}); + $new{'selectColor'} = '#b03060' unless (exists $new{'selectColor'}); + + # Before doing this, make sure that the Tk::Palette variable holds + # the default values of all options, so that tkRecolorTree can + # be sure to only change options that have their default values. + # If the variable exists, then it is already correct (it was created + # the last time this procedure was invoked). If the variable + # doesn't exist, fill it in using the defaults from a few widgets. + my $Palette = $w->Palette; + + # Walk the widget hierarchy, recoloring all existing windows. + $w->RecolorTree(\%new); + # Change the option database so that future windows will get the + # same colors. + foreach my $option (keys %new) + { + $w->option('add',"*$option",$new{$option},$priority); + # Save the options in the global variable Tk::Palette, for use the + # next time we change the options. + $Palette->{$option} = $new{$option}; + } +} + +# tkRecolorTree -- +# This procedure changes the colors in a window and all of its +# descendants, according to information provided by the colors +# argument. It only modifies colors that have their default values +# as specified by the Tk::Palette variable. +# +# Arguments: +# w - The name of a window. This window and all its +# descendants are recolored. +# colors - The name of an array variable in the caller, +# which contains color information. Each element +# is named after a widget configuration option, and +# each value is the value for that option. +sub RecolorTree +{ + my ($w,$colors) = @_; + local ($@); + my $Palette = $w->Palette; + foreach my $dbOption (keys %$colors) + { + my $option = "-\L$dbOption"; + my $value; + eval {local $SIG{'__DIE__'}; $value = $w->cget($option) }; + if (defined $value) + { + if ($value eq $Palette->{$dbOption}) + { + $w->configure($option,$colors->{$dbOption}); + } + } + } + foreach my $child ($w->children) + { + $child->RecolorTree($colors); + } +} +# tkDarken -- +# Given a color name, computes a new color value that darkens (or +# brightens) the given color by a given percent. +# +# Arguments: +# color - Name of starting color. +# perecent - Integer telling how much to brighten or darken as a +# percent: 50 means darken by 50%, 110 means brighten +# by 10%. +sub Darken +{ + my ($w,$color,$percent) = @_; + my @l = $w->rgb($color); + my $red = $l[0]/256; + my $green = $l[1]/256; + my $blue = $l[2]/256; + $red = int($red*$percent/100); + $red = 255 if ($red > 255); + $green = int($green*$percent/100); + $green = 255 if ($green > 255); + $blue = int($blue*$percent/100); + $blue = 255 if ($blue > 255); + sprintf('#%02x%02x%02x',$red,$green,$blue) +} +# tk_bisque -- +# Reset the Tk color palette to the old "bisque" colors. +# +# Arguments: +# None. +sub bisque +{ + shift->setPalette('activeBackground' => '#e6ceb1', + 'activeForeground' => 'black', + 'background' => '#ffe4c4', + 'disabledForeground' => '#b0b0b0', + 'foreground' => 'black', + 'highlightBackground' => '#ffe4c4', + 'highlightColor' => 'black', + 'insertBackground' => 'black', + 'selectColor' => '#b03060', + 'selectBackground' => '#e6ceb1', + 'selectForeground' => 'black', + 'troughColor' => '#cdb79e' + ); +} + +sub PrintConfig +{ + require Tk::Pretty; + my ($w) = (@_); + my $c; + foreach $c ($w->configure) + { + print Tk::Pretty::Pretty(@$c),"\n"; + } +} + +sub BusyRecurse +{ + my ($restore,$w,$cursor,$recurse,$top) = @_; + my $c = $w->cget('-cursor'); + my @tags = $w->bindtags; + if ($top || defined($c)) + { + push(@$restore, sub { return unless Tk::Exists($w); $w->configure(-cursor => $c); $w->bindtags(\@tags) }); + $w->configure(-cursor => $cursor); + } + else + { + push(@$restore, sub { return unless Tk::Exists($w); $w->bindtags(\@tags) }); + } + $w->bindtags(['Busy',@tags]); + if ($recurse) + { + foreach my $child ($w->children) + { + BusyRecurse($restore,$child,$cursor,1,0); + } + } + return $restore; +} + +sub Busy +{ + my ($w,@args) = @_; + return unless $w->viewable; + my($sub, %args); + for(my $i=0; $i<=$#args; $i++) + { + if (ref $args[$i] eq 'CODE') + { + if (defined $sub) + { + croak "Multiple code definitions not allowed in Tk::Widget::Busy"; + } + $sub = $args[$i]; + } + else + { + $args{$args[$i]} = $args[$i+1]; $i++; + } + } + my $cursor = delete $args{'-cursor'}; + my $recurse = delete $args{'-recurse'}; + $cursor = 'watch' unless defined $cursor; + unless (exists $w->{'Busy'}) + { + my @old = ($w->grabSave); + my $key; + my @config; + foreach $key (keys %args) + { + push(@config,$key => $w->Tk::cget($key)); + } + if (@config) + { + push(@old, sub { $w->Tk::configure(@config) }); + $w->Tk::configure(%args); + } + unless ($w->Tk::bind('Busy')) + { + $w->Tk::bind('Busy','<Any-KeyPress>',[_busy => 1]); + $w->Tk::bind('Busy','<Any-KeyRelease>',[_busy => 0]); + $w->Tk::bind('Busy','<Any-ButtonPress>',[_busy => 1]); + $w->Tk::bind('Busy','<Any-ButtonRelease>',[_busy => 0]); + $w->Tk::bind('Busy','<Any-Motion>',[_busy => 0]); + } + $w->{'Busy'} = BusyRecurse(\@old,$w,$cursor,$recurse,1); + } + my $g = $w->grabCurrent; + if (defined $g) + { + # warn "$g has the grab"; + $g->grabRelease; + } + $w->update; + eval {local $SIG{'__DIE__'}; $w->grab }; + $w->update; + if ($sub) + { + eval { $sub->() }; + my $err = $@; + $w->Unbusy(-recurse => $recurse); + die $err if $err; + } +} + +sub _busy +{ + my ($w,$f) = @_; + $w->bell if $f; + $w->break; +} + +sub Unbusy +{ + my ($w) = @_; + $w->update; + $w->grabRelease if Tk::Exists($w); + my $old = delete $w->{'Busy'}; + if (defined $old) + { + local $SIG{'__DIE__'}; + eval { &{pop(@$old)} } while (@$old); + } + $w->update if Tk::Exists($w); +} + +sub waitVisibility +{ + my ($w) = shift; + $w->tkwait('visibility',$w); +} + +sub waitVariable +{ + my ($w) = shift; + $w->tkwait('variable',@_); +} + +sub waitWindow +{ + my ($w) = shift; + $w->tkwait('window',$w); +} + +sub EventWidget +{ + my ($w) = @_; + return $w->{'_EventWidget_'}; +} + +sub Popwidget +{ + my ($ew,$method,$w,@args) = @_; + $w->{'_EventWidget_'} = $ew; + $w->$method(@args); +} + +sub ColorOptions +{ + my ($w,$args) = @_; + my $opt; + $args = {} unless (defined $args); + foreach $opt (qw(-foreground -background -disabledforeground + -activebackground -activeforeground + )) + { + $args->{$opt} = $w->cget($opt) unless (exists $args->{$opt}) + } + return (wantarray) ? %$args : $args; +} + +sub XscrollBind +{ + my ($mw,$class) = @_; + $mw->bind($class,'<Left>', ['xview','scroll',-1,'units']); + $mw->bind($class,'<Control-Left>', ['xview','scroll',-1,'pages']); + $mw->bind($class,'<Control-Prior>',['xview','scroll',-1,'pages']); + $mw->bind($class,'<Right>', ['xview','scroll',1,'units']); + $mw->bind($class,'<Control-Right>',['xview','scroll',1,'pages']); + $mw->bind($class,'<Control-Next>', ['xview','scroll',1,'pages']); + + $mw->bind($class,'<Home>', ['xview','moveto',0]); + $mw->bind($class,'<End>', ['xview','moveto',1]); + $mw->XMouseWheelBind($class); +} + +sub PriorNextBind +{ + my ($mw,$class) = @_; + $mw->bind($class,'<Next>', ['yview','scroll',1,'pages']); + $mw->bind($class,'<Prior>', ['yview','scroll',-1,'pages']); +} + +sub XMouseWheelBind +{ + my ($mw,$class) = @_; + # <4> and <5> are how mousewheel looks on X + # <4> and <5> are how mousewheel looks on X + $mw->bind($class,'<Shift-4>', ['xview','scroll',-1,'units']); + $mw->bind($class,'<Shift-5>', ['xview','scroll',1,'units']); + $mw->bind($class,'<Button-6>', ['xview','scroll',-1,'units']); + $mw->bind($class,'<Button-7>', ['xview','scroll',1,'units']); +} + +sub YMouseWheelBind +{ + my ($mw,$class) = @_; + # <4> and <5> are how mousewheel looks on X + $mw->bind($class,'<4>', ['yview','scroll',-1,'units']); + $mw->bind($class,'<5>', ['yview','scroll',1,'units']); +} + +sub YscrollBind +{ + my ($mw,$class) = @_; + $mw->PriorNextBind($class); + $mw->bind($class,'<Up>', ['yview','scroll',-1,'units']); + $mw->bind($class,'<Down>', ['yview','scroll',1,'units']); + $mw->YMouseWheelBind($class); +} + +sub XYscrollBind +{ + my ($mw,$class) = @_; + $mw->YscrollBind($class); + $mw->XscrollBind($class); + # <4> and <5> are how mousewheel looks on X +} + +sub MouseWheelBind +{ + my($mw,$class) = @_; + + # The MouseWheel will typically only fire on Windows. However, one + # could use the "event generate" command to produce MouseWheel + # events on other platforms. + + $mw->Tk::bind($class, '<MouseWheel>', + [ sub { $_[0]->yview('scroll',-($_[1]/120)*3,'units') }, Tk::Ev("D")]); + + if ($Tk::platform eq 'unix') + { + # Support for mousewheels on Linux/Unix commonly comes through mapping + # the wheel to the extended buttons. If you have a mousewheel, find + # Linux configuration info at: + # http://www.inria.fr/koala/colas/mouse-wheel-scroll/ + $mw->Tk::bind($class, '<4>', + sub { $_[0]->yview('scroll', -3, 'units') + unless $Tk::strictMotif; + }); + $mw->Tk::bind($class, '<5>', + sub { $_[0]->yview('scroll', 3, 'units') + unless $Tk::strictMotif; + }); + } +} + +sub ScrlListbox +{ + my $parent = shift; + return $parent->Scrolled('Listbox',-scrollbars => 'w', @_); +} + +sub AddBindTag +{ + my ($w,$tag) = @_; + my $t; + my @tags = $w->bindtags; + foreach $t (@tags) + { + return if $t eq $tag; + } + $w->bindtags([@tags,$tag]); +} + +sub Callback +{ + my $w = shift; + my $name = shift; + my $cb = $w->cget($name); + if (defined $cb) + { + return $cb->Call(@_) if (ref $cb); + return $w->$cb(@_); + } + return (wantarray) ? () : undef; +} + +sub packAdjust +{ +# print 'packAdjust(',join(',',@_),")\n"; + require Tk::Adjuster; + my ($w,%args) = @_; + my $delay = delete($args{'-delay'}); + $delay = 1 unless (defined $delay); + $w->pack(%args); + %args = $w->packInfo; + my $adj = Tk::Adjuster->new($args{'-in'}, + -widget => $w, -delay => $delay, -side => $args{'-side'}); + $adj->packed($w,%args); + return $w; +} + +sub gridAdjust +{ + require Tk::Adjuster; + my ($w,%args) = @_; + my $delay = delete($args{'-delay'}); + $delay = 1 unless (defined $delay); + $w->grid(%args); + %args = $w->gridInfo; + my $adj = Tk::Adjuster->new($args{'-in'},-widget => $w, -delay => $delay); + $adj->gridded($w,%args); + return $w; +} + +sub place +{ + local $SIG{'__DIE__'} = \&Carp::croak; + my $w = shift; + if (@_ && $_[0] =~ /^(?:configure|forget|info|slaves)$/x) + { + $w->Tk::place(@_); + } + else + { + # Two things going on here: + # 1. Add configure on the front so that we can drop leading '-' + $w->Tk::place('configure',@_); + # 2. Return the widget rather than nothing + return $w; + } +} + +sub pack +{ + local $SIG{'__DIE__'} = \&Carp::croak; + my $w = shift; + if (@_ && $_[0] =~ /^(?:configure|forget|info|propagate|slaves)$/x) + { + # maybe array/scalar context issue with slaves + $w->Tk::pack(@_); + } + else + { + # Two things going on here: + # 1. Add configure on the front so that we can drop leading '-' + $w->Tk::pack('configure',@_); + # 2. Return the widget rather than nothing + return $w; + } +} + +sub grid +{ + local $SIG{'__DIE__'} = \&Carp::croak; + my $w = shift; + if (@_ && $_[0] =~ /^(?:bbox|columnconfigure|configure|forget|info|location|propagate|rowconfigure|size|slaves)$/x) + { + my $opt = shift; + Tk::grid($opt,$w,@_); + } + else + { + # Two things going on here: + # 1. Add configure on the front so that we can drop leading '-' + Tk::grid('configure',$w,@_); + # 2. Return the widget rather than nothing + return $w; + } +} + +sub form +{ + local $SIG{'__DIE__'} = \&Carp::croak; + my $w = shift; + if (@_ && $_[0] =~ /^(?:configure|check|forget|grid|info|slaves)$/x) + { + $w->Tk::form(@_); + } + else + { + # Two things going on here: + # 1. Add configure on the front so that we can drop leading '-' + $w->Tk::form('configure',@_); + # 2. Return the widget rather than nothing + return $w; + } +} + +sub Scrolled +{ + my ($parent,$kind,%args) = @_; + $kind = 'Pane' if $kind eq 'Frame'; + # Find args that are Frame create time args + my @args = Tk::Frame->CreateArgs($parent,\%args); + my $name = delete $args{'Name'}; + push(@args,'Name' => $name) if (defined $name); + my $cw = $parent->Frame(@args); + @args = (); + # Now remove any args that Frame can handle + foreach my $k ('-scrollbars',map($_->[0],$cw->configure)) + { + push(@args,$k,delete($args{$k})) if (exists $args{$k}) + } + # Anything else must be for target widget - pass at widget create time + my $w = $cw->$kind(%args); + # Now re-set %args to be ones Frame can handle + %args = @args; + $cw->ConfigSpecs('-scrollbars' => ['METHOD','scrollbars','Scrollbars','se'], + '-background' => [$w,'background','Background'], + '-foreground' => [$w,'foreground','Foreground'], + ); + $cw->AddScrollbars($w); + $cw->Default("\L$kind" => $w); + $cw->Delegates('bind' => $w, 'bindtags' => $w, 'menu' => $w); + $cw->ConfigDefault(\%args); + $cw->configure(%args); + return $cw; +} + +sub Populate +{ + my ($cw,$args) = @_; +} + +sub ForwardEvent +{ + my $self = shift; + my $to = shift; + $to->PassEvent($self->XEvent); +} + +# Save / Return abstract event type as in Tix. +sub EventType +{ + my $w = shift; + $w->{'_EventType_'} = $_[0] if @_; + return $w->{'_EventType_'}; +} + +sub PostPopupMenu +{ + my ($w, $X, $Y) = @_; + if (@_ < 3) + { + my $e = $w->XEvent; + $X = $e->X; + $Y = $e->Y; + } + my $menu = $w->menu; + $menu->Post($X,$Y) if defined $menu; +} + +sub FillMenu +{ + my ($w,$menu,@labels) = @_; + foreach my $lab (@labels) + { + my $method = $lab.'MenuItems'; + $method =~ s/~//g; + $method =~ s/[\s-]+/_/g; + if ($w->can($method)) + { + $menu->Menubutton(-label => $lab, -tearoff => 0, -menuitems => $w->$method()); + } + } + return $menu; +} + +sub menu +{ + my ($w,$menu) = @_; + if (@_ > 1) + { + $w->_OnDestroy('_MENU_') unless exists $w->{'_MENU_'}; + $w->{'_MENU_'} = $menu; + } + return unless defined wantarray; + unless (exists $w->{'_MENU_'}) + { + $w->_OnDestroy('_MENU_'); + $w->{'_MENU_'} = $menu = $w->Menu(-tearoff => 0); + $w->FillMenu($menu,$w->MenuLabels); + } + return $w->{'_MENU_'}; +} + +sub MenuLabels +{ + return @DefaultMenuLabels; +} + +sub FileMenuItems +{ + my ($w) = @_; + return [ ["command"=>'E~xit', -command => [ $w, 'WmDeleteWindow']]]; +} + +sub WmDeleteWindow +{ + shift->toplevel->WmDeleteWindow +} + +sub BalloonInfo +{ + my ($widget,$balloon,$X,$Y,@opt) = @_; + foreach my $opt (@opt) + { + my $info = $balloon->GetOption($opt,$widget); + return $info if defined $info; + } +} + +sub ConfigSpecs { + + my $w = shift; + + return map { ( $_->[0], [ $w, @$_[ 1 .. 4 ] ] ) } $w->configure; + +} + +*GetSelection = + ($Tk::platform eq 'unix' + ? sub + { + my $w = shift; + my $sel = @_ ? shift : "PRIMARY"; + my $txt = eval { local $SIG{__DIE__}; + $w->SelectionGet(-selection => $sel, -type => "UTF8_STRING") + }; + if ($@) + { + $txt = eval { local $SIG{__DIE__}; + $w->SelectionGet(-selection => $sel) + }; + if ($@) + { + die "could not find default selection"; + } + } + $txt; + } + : sub + { + my $w = shift; + my $sel = @_ ? shift : "PRIMARY"; + my $txt = eval { local $SIG{__DIE__}; + $w->SelectionGet(-selection => $sel) + }; + if ($@) + { + die "could not find default selection"; + } + $txt; + } + ); + +1; +__END__ + +sub bindDump { + + # Dump lots of good binding information. This pretty-print subroutine + # is, essentially, the following code in disguise: + # + # print "Binding information for $w\n"; + # foreach my $tag ($w->bindtags) { + # printf "\n Binding tag '$tag' has these bindings:\n"; + # foreach my $binding ($w->bind($tag)) { + # printf " $binding\n"; + # } + # } + + my ($w) = @_; + + my (@bindtags) = $w->bindtags; + my $digits = length( scalar @bindtags ); + my ($spc1, $spc2) = ($digits + 33, $digits + 35); + my $format1 = "%${digits}d."; + my $format2 = ' ' x ($digits + 2); + my $n = 0; + + my @out; + push @out, sprintf( "\n## Binding information for '%s', %s ##", $w->PathName, $w ); + + foreach my $tag (@bindtags) { + my (@bindings) = $w->bind($tag); + $n++; # count this bindtag + + if ($#bindings == -1) { + push @out, sprintf( "\n$format1 Binding tag '$tag' has no bindings.\n", $n ); + } else { + push @out, sprintf( "\n$format1 Binding tag '$tag' has these bindings:\n", $n ); + + foreach my $binding ( @bindings ) { + my $callback = $w->bind($tag, $binding); + push @out, sprintf( "$format2%27s : %-40s\n", $binding, $callback ); + + if ($callback =~ /SCALAR/) { + if (ref $$callback) { + push @out, sprintf( "%s %s\n", ' ' x $spc1, $$callback ); + } else { + push @out, sprintf( "%s '%s'\n", ' ' x $spc1, $$callback ); + } + } elsif ($callback =~ /ARRAY/) { + if (ref $callback->[0]) { + push @out, sprintf( "%s %s\n", ' ' x $spc1, $callback->[0], "\n" ); + } else { + push @out, sprintf( "%s '%s'\n", ' ' x $spc1, $callback->[0], "\n" ); + } + foreach my $arg (@$callback[1 .. $#{@$callback}]) { + if (ref $arg) { + push @out, sprintf( "%s %-40s", ' ' x $spc2, $arg ); + } else { + push @out, sprintf( "%s '%s'", ' ' x $spc2, $arg ); + } + + if (ref $arg eq 'Tk::Ev') { + if ($arg =~ /SCALAR/) { + push @out, sprintf( ": '$$arg'" ); + } else { + push @out, sprintf( ": '%s'", join("' '", @$arg) ); + } + } + + push @out, sprintf( "\n" ); + } # forend callback arguments + } # ifend callback + + } # forend all bindings for one tag + + } # ifend have bindings + + } # forend all tags + push @out, sprintf( "\n" ); + return @out; + +} # end bindDump + + +sub ASkludge +{ + my ($hash,$sense) = @_; + foreach my $key (%$hash) + { + if ($key =~ /-.*variable/ && ref($hash->{$key}) eq 'SCALAR') + { + if ($sense) + { + my $val = ${$hash->{$key}}; + require Tie::Scalar; + tie ${$hash->{$key}},'Tie::StdScalar'; + ${$hash->{$key}} = $val; + } + else + { + untie ${$hash->{$key}}; + } + } + } +} + + + +# clipboardKeysyms -- +# This procedure is invoked to identify the keys that correspond to +# the "copy", "cut", and "paste" functions for the clipboard. +# +# Arguments: +# copy - Name of the key (keysym name plus modifiers, if any, +# such as "Meta-y") used for the copy operation. +# cut - Name of the key used for the cut operation. +# paste - Name of the key used for the paste operation. +# +# This method is obsolete use clipboardOperations and abstract +# event types instead. See Clipboard.pm and Mainwindow.pm + +sub clipboardKeysyms +{ + my @class = (); + my $mw = shift; + if (ref $mw) + { + $mw = $mw->DelegateFor('bind'); + } + else + { + push(@class,$mw); + $mw = shift; + } + if (@_) + { + my $copy = shift; + $mw->Tk::bind(@class,"<$copy>",'clipboardCopy') if (defined $copy); + } + if (@_) + { + my $cut = shift; + $mw->Tk::bind(@class,"<$cut>",'clipboardCut') if (defined $cut); + } + if (@_) + { + my $paste = shift; + $mw->Tk::bind(@class,"<$paste>",'clipboardPaste') if (defined $paste); + } +} + +sub pathname +{ + my ($w,$id) = @_; + my $x = $w->winfo('pathname',-displayof => oct($id)); + return $x->PathName; +} diff --git a/Master/tlpkg/installer/perllib/Tk/Wm.pm b/Master/tlpkg/installer/perllib/Tk/Wm.pm new file mode 100644 index 00000000000..ffbe4877857 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Tk/Wm.pm @@ -0,0 +1,174 @@ +# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +package Tk::Wm; +use AutoLoader; + +require Tk::Widget; +*AUTOLOAD = \&Tk::Widget::AUTOLOAD; + +use strict qw(vars); + +# There are issues with this stuff now we have Tix's wm release/capture +# as toplevel-ness is now dynamic. + + +use vars qw($VERSION); +$VERSION = sprintf '4.%03d', q$Revision: #14 $ =~ /\D(\d+)\s*$/; + +use Tk::Submethods; + +*{Tk::Wm::wmGrid} = sub { shift->wm("grid", @_) }; +*{Tk::Wm::wmTracing} = sub { shift->wm("tracing", @_) }; + +Direct Tk::Submethods ('wm' => [qw(aspect attributes client colormapwindows command + deiconify focusmodel frame geometry group + iconbitmap iconify iconimage iconmask iconname + iconwindow maxsize minsize overrideredirect positionfrom + protocol resizable sizefrom state title transient + withdraw wrapper)]); + +sub SetBindtags +{ + my ($obj) = @_; + $obj->bindtags([ref($obj),$obj,'all']); +} + +sub Populate +{ + my ($cw,$args) = @_; + $cw->ConfigSpecs('-overanchor' => ['PASSIVE',undef,undef,undef], + '-popanchor' => ['PASSIVE',undef,undef,undef], + '-popover' => ['PASSIVE',undef,undef,undef] + ); +} + +sub MoveResizeWindow +{ + my ($w,$x,$y,$width,$height) = @_; + $w->withdraw; + $w->geometry($width.'x'.$height); + $w->MoveToplevelWindow($x,$y); + $w->deiconify; +} + +sub WmDeleteWindow +{ + my ($w) = @_; + my $cb = $w->protocol('WM_DELETE_WINDOW'); + if (defined $cb) + { + $cb->Call; + } + else + { + $w->destroy; + } +} + + +1; + +__END__ + + +sub Post +{ + my ($w,$X,$Y) = @_; + $X = int($X); + $Y = int($Y); + $w->positionfrom('user'); + $w->geometry("+$X+$Y"); + # $w->MoveToplevelWindow($X,$Y); + $w->deiconify; + $w->raise; +} + +sub AnchorAdjust +{ + my ($anchor,$X,$Y,$w,$h) = @_; + $anchor = 'c' unless (defined $anchor); + $Y += ($anchor =~ /s/) ? $h : ($anchor =~ /n/) ? 0 : $h/2; + $X += ($anchor =~ /e/) ? $w : ($anchor =~ /w/) ? 0 : $w/2; + return ($X,$Y); +} + +sub Popup +{ + my $w = shift; + $w->configure(@_) if @_; + $w->idletasks; + my ($mw,$mh) = ($w->reqwidth,$w->reqheight); + my ($rx,$ry,$rw,$rh) = (0,0,0,0); + my $base = $w->cget('-popover'); + my $outside = 0; + if (defined $base) + { + if ($base eq 'cursor') + { + ($rx,$ry) = $w->pointerxy; + } + else + { + $rx = $base->rootx; + $ry = $base->rooty; + $rw = $base->Width; + $rh = $base->Height; + } + } + else + { + my $sc = ($w->parent) ? $w->parent->toplevel : $w; + $rx = -$sc->vrootx; + $ry = -$sc->vrooty; + $rw = $w->screenwidth; + $rh = $w->screenheight; + } + my ($X,$Y) = AnchorAdjust($w->cget('-overanchor'),$rx,$ry,$rw,$rh); + ($X,$Y) = AnchorAdjust($w->cget('-popanchor'),$X,$Y,-$mw,-$mh); + # adjust to not cross screen borders + if ($X < 0) { $X = 0 } + if ($Y < 0) { $Y = 0 } + if ($mw > $w->screenwidth) { $X = 0 } + if ($mh > $w->screenheight) { $Y = 0 } + $w->Post($X,$Y); + $w->waitVisibility; +} + +sub FullScreen +{ + my $w = shift; + my $over = (@_) ? shift : 0; + my $width = $w->screenwidth; + my $height = $w->screenheight; + $w->GeometryRequest($width,$height); + $w->overrideredirect($over & 1); + $w->Post(0,0); + $w->update; + if ($over & 2) + { + my $x = $w->rootx; + my $y = $w->rooty; + $width -= 2*$x; + $height -= $x + $y; + $w->GeometryRequest($width,$height); + $w->update; + } +} + +sub iconposition +{ + my $w = shift; + if (@_ == 1) + { + return $w->wm('iconposition',$1,$2) if $_[0] =~ /^(\d+),(\d+)$/; + if ($_[0] =~ /^([+-])(\d+)([+-])(\d+)$/) + { + my $x = ($1 eq '-') ? $w->screenwidth-$2 : $2; + my $y = ($3 eq '-') ? $w->screenheight-$4 : $4; + return $w->wm('iconposition',$x,$y); + } + } + $w->wm('iconposition',@_); +} + diff --git a/Master/tlpkg/installer/perllib/Win32/API.pm b/Master/tlpkg/installer/perllib/Win32/API.pm new file mode 100644 index 00000000000..e1bac5cda48 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Win32/API.pm @@ -0,0 +1,745 @@ +package Win32::API; + +# See the bottom of this file for the POD documentation. Search for the +# string '=head'. + +####################################################################### +# +# Win32::API - Perl Win32 API Import Facility +# +# Version: 0.47 +# Date: 12 Nov 2007 +# Author: Aldo Calpini <dada@perl.it> +# Maintainer: Cosimo Streppone <cosimo@cpan.org> +# +# Changes for gcc/cygwin: Daniel Risacher <magnus@alum.mit.edu> +# ported from 0.41 based on Daniel's patch by Reini Urban <rurban@x-ray.at> +# +# $Id: API.pm,v 1.0 2001/10/30 13:57:31 dada Exp $ +# +####################################################################### + +require Exporter; # to export the constants to the main:: space +require DynaLoader; # to dynuhlode the module. +@ISA = qw( Exporter DynaLoader ); + +use vars qw( $DEBUG ); +$DEBUG = 0; + +sub DEBUG { + if ($Win32::API::DEBUG) { + printf @_ if @_ or return 1; + } else { + return 0; + } +} + +use Win32::API::Type; +use Win32::API::Struct; +BEGIN { + if ($^O eq 'cygwin') { + require File::Basename; + } +} + +####################################################################### +# STATIC OBJECT PROPERTIES +# +$VERSION = '0.47'; + +#### some package-global hash to +#### keep track of the imported +#### libraries and procedures +my %Libraries = (); +my %Procedures = (); + + +####################################################################### +# dynamically load in the API extension module. +# +bootstrap Win32::API; + +####################################################################### +# PUBLIC METHODS +# +sub new { + my($class, $dll, $proc, $in, $out) = @_; + my $hdll; + my $self = {}; + + if ($^O eq 'cygwin' and $dll ne File::Basename::basename($dll)) { + # need to convert $dll to win32 path + # isn't there an API for this? + my $newdll = `cygpath -w "$dll"`; + chomp $newdll; + DEBUG "(PM)new: converted '$dll' to\n '$newdll'\n"; + $dll = $newdll; + } + + #### avoid loading a library more than once + if(exists($Libraries{$dll})) { + DEBUG "Win32::API::new: Library '$dll' already loaded, handle=$Libraries{$dll}\n"; + $hdll = $Libraries{$dll}; + } else { + DEBUG "Win32::API::new: Loading library '$dll'\n"; + $hdll = Win32::API::LoadLibrary($dll); +# $Libraries{$dll} = $hdll; + } + + #### if the dll can't be loaded, set $! to Win32's GetLastError() + if(!$hdll) { + $! = Win32::GetLastError(); + DEBUG "FAILED Loading library '$dll': $!\n"; + delete $Libraries{$dll}; + return undef; + } + + #### determine if we have a prototype or not + if( (not defined $in) and (not defined $out) ) { + ($proc, $self->{in}, $self->{intypes}, $self->{out}) = parse_prototype( $proc ); + return undef unless $proc; + $self->{proto} = 1; + } else { + $self->{in} = []; + if(ref($in) eq 'ARRAY') { + foreach (@$in) { + push(@{ $self->{in} }, type_to_num($_)); + } + } else { + my @in = split '', $in; + foreach (@in) { + push(@{ $self->{in} }, type_to_num($_)); + } + } + $self->{out} = type_to_num($out); + } + + #### first try to import the function of given name... + my $hproc = Win32::API::GetProcAddress($hdll, $proc); + + #### ...then try appending either A or W (for ASCII or Unicode) + if(!$hproc) { + my $tproc = $proc; + $tproc .= (IsUnicode() ? "W" : "A"); + # print "Win32::API::new: procedure not found, trying '$tproc'...\n"; + $hproc = Win32::API::GetProcAddress($hdll, $tproc); + } + + #### ...if all that fails, set $! accordingly + if(!$hproc) { + $! = Win32::GetLastError(); + DEBUG "FAILED GetProcAddress for Proc '$proc': $!\n"; + return undef; + } + DEBUG "GetProcAddress('$proc') = '$hproc'\n"; + + #### ok, let's stuff the object + $self->{procname} = $proc; + $self->{dll} = $hdll; + $self->{dllname} = $dll; + $self->{proc} = $hproc; + + #### keep track of the imported function + $Libraries{$dll} = $hdll; + $Procedures{$dll}++; + + DEBUG "Object blessed!\n"; + + #### cast the spell + bless($self, $class); + return $self; +} + +sub Import { + my($class, $dll, $proc, $in, $out) = @_; + $Imported{"$dll:$proc"} = Win32::API->new($dll, $proc, $in, $out) or return 0; + my $P = (caller)[0]; + eval qq( + sub ${P}::$Imported{"$dll:$proc"}->{procname} { \$Win32::API::Imported{"$dll:$proc"}->Call(\@_); } + ); + return $@ ? 0 : 1; +} + + +####################################################################### +# PRIVATE METHODS +# +sub DESTROY { + my($self) = @_; + + #### decrease this library's procedures reference count + $Procedures{$self->{dllname}}--; + + #### once it reaches 0, free it + if($Procedures{$self->{dllname}} == 0) { + DEBUG "Win32::API::DESTROY: Freeing library '$self->{dllname}'\n"; + Win32::API::FreeLibrary($Libraries{$self->{dllname}}); + delete($Libraries{$self->{dllname}}); + } +} + +sub type_to_num { + my $type = shift; + my $out = shift; + my $num; + + if( $type eq 'N' + or $type eq 'n' + or $type eq 'l' + or $type eq 'L' + ) { + $num = 1; + } elsif($type eq 'P' + or $type eq 'p' + ) { + $num = 2; + } elsif($type eq 'I' + or $type eq 'i' + ) { + $num = 3; + } elsif($type eq 'f' + or $type eq 'F' + ) { + $num = 4; + } elsif($type eq 'D' + or $type eq 'd' + ) { + $num = 5; + } elsif($type eq 'c' + or $type eq 'C' + ) { + $num = 6; + } else { + $num = 0; + } + unless(defined $out) { + if( $type eq 's' + or $type eq 'S' + ) { + $num = 51; + } elsif($type eq 'b' + or $type eq 'B' + ) { + $num = 22; + } elsif($type eq 'k' + or $type eq 'K' + ) { + $num = 101; + } + } + return $num; +} + +sub parse_prototype { + my($proto) = @_; + + my @in_params = (); + my @in_types = (); + if($proto =~ /^\s*(\S+)\s+(\S+)\s*\(([^\)]*)\)/) { + my $ret = $1; + my $proc = $2; + my $params = $3; + + $params =~ s/^\s+//; + $params =~ s/\s+$//; + + DEBUG "(PM)parse_prototype: got PROC '%s'\n", $proc; + DEBUG "(PM)parse_prototype: got PARAMS '%s'\n", $params; + + foreach my $param (split(/\s*,\s*/, $params)) { + my($type, $name); + if($param =~ /(\S+)\s+(\S+)/) { + ($type, $name) = ($1, $2); + } + + if(Win32::API::Type::is_known($type)) { + if(Win32::API::Type::is_pointer($type)) { + DEBUG "(PM)parse_prototype: IN='%s' PACKING='%s' API_TYPE=%d\n", + $type, + Win32::API::Type->packing( $type ), + type_to_num('P'); + push(@in_params, type_to_num('P')); + } else { + DEBUG "(PM)parse_prototype: IN='%s' PACKING='%s' API_TYPE=%d\n", + $type, + Win32::API::Type->packing( $type ), + type_to_num( Win32::API::Type->packing( $type ) ); + push(@in_params, type_to_num( Win32::API::Type->packing( $type ) )); + } + } elsif( Win32::API::Struct::is_known( $type ) ) { + DEBUG "(PM)parse_prototype: IN='%s' PACKING='%s' API_TYPE=%d\n", + $type, 'S', type_to_num('S'); + push(@in_params, type_to_num('S')); + } else { + warn "Win32::API::parse_prototype: WARNING unknown parameter type '$type'"; + push(@in_params, type_to_num('I')); + } + push(@in_types, $type); + + } + DEBUG "parse_prototype: IN=[ @in_params ]\n"; + + + + if(Win32::API::Type::is_known($ret)) { + if(Win32::API::Type::is_pointer($ret)) { + DEBUG "parse_prototype: OUT='%s' PACKING='%s' API_TYPE=%d\n", + $ret, + Win32::API::Type->packing( $ret ), + type_to_num('P'); + return ( $proc, \@in_params, \@in_types, type_to_num('P') ); + } else { + DEBUG "parse_prototype: OUT='%s' PACKING='%s' API_TYPE=%d\n", + $ret, + Win32::API::Type->packing( $ret ), + type_to_num( Win32::API::Type->packing( $ret ) ); + return ( $proc, \@in_params, \@in_types, type_to_num(Win32::API::Type->packing($ret)) ); + } + } else { + warn "Win32::API::parse_prototype: WARNING unknown output parameter type '$ret'"; + return ( $proc, \@in_params, \@in_types, type_to_num('I') ); + } + + } else { + warn "Win32::API::parse_prototype: bad prototype '$proto'"; + return undef; + } +} + +1; + +__END__ + +####################################################################### +# DOCUMENTATION +# + +=head1 NAME + +Win32::API - Perl Win32 API Import Facility + +=head1 SYNOPSIS + + #### Method 1: with prototype + + use Win32::API; + $function = Win32::API->new( + 'mydll, 'int sum_integers(int a, int b)', + ); + $return = $function->Call(3, 2); + + #### Method 2: with parameter list + + use Win32::API; + $function = Win32::API->new( + 'mydll', 'sum_integers', 'II', 'I', + ); + $return = $function->Call(3, 2); + + #### Method 3: with Import + + use Win32::API; + Win32::API->Import( + 'mydll', 'int sum_integers(int a, int b)', + ); + $return = sum_integers(3, 2); + + +=for LATER-UNIMPLEMENTED + #### or + use Win32::API mydll => 'int sum_integers(int a, int b)'; + $return = sum_integers(3, 2); + + +=head1 ABSTRACT + +With this module you can import and call arbitrary functions +from Win32's Dynamic Link Libraries (DLL), without having +to write an XS extension. Note, however, that this module +can't do anything (parameters input and output is limited +to simpler cases), and anyway a regular XS extension is +always safer and faster. + +The current version of Win32::API is available at my website: + + http://dada.perl.it/ + +It's also available on your nearest CPAN mirror (but allow a few days +for worldwide spreading of the latest version) reachable at: + + http://www.perl.com/CPAN/authors/Aldo_Calpini/ + +A short example of how you can use this module (it just gets the PID of +the current process, eg. same as Perl's internal C<$$>): + + use Win32::API; + Win32::API->Import("kernel32", "int GetCurrentProcessId()"); + $PID = GetCurrentProcessId(); + +The possibilities are nearly infinite (but not all are good :-). +Enjoy it. + + +=head1 CREDITS + +All the credits go to Andrea Frosini +for the neat assembler trick that makes this thing work. +I've also used some work by Dave Roth for the prototyping stuff. +A big thank you also to Gurusamy Sarathy for his +unvaluable help in XS development, and to all the Perl community for +being what it is. + + +=head1 DESCRIPTION + +To use this module put the following line at the beginning of your script: + + use Win32::API; + +You can now use the C<new()> function of the Win32::API module to create a +new Win32::API object (see L<IMPORTING A FUNCTION>) and then invoke the +C<Call()> method on this object to perform a call to the imported API +(see L<CALLING AN IMPORTED FUNCTION>). + +Starting from version 0.40, you can also avoid creating a Win32::API object +and instead automatically define a Perl sub with the same name of the API +function you're importing. The details of the API definitions are the same, +just the call is different: + + my $GetCurrentProcessId = Win32::API->new( + "kernel32", "int GetCurrentProcessId()" + ); + my $PID = $GetCurrentProcessId->Call(); + + #### vs. + + Win32::API->Import("kernel32", "int GetCurrentProcessId()"); + $PID = GetCurrentProcessId(); + +Note that C<Import> returns 1 on success and 0 on failure (in which case you +can check the content of C<$^E>). + +=head2 IMPORTING A FUNCTION + +You can import a function from a 32 bit Dynamic Link Library (DLL) file +with the C<new()> function. This will create a Perl object that contains the +reference to that function, which you can later C<Call()>. + +What you need to know is the prototype of the function you're going to import +(eg. the definition of the function expressed in C syntax). + +Starting from version 0.40, there are 2 different approaches for this step: +(the preferred) one uses the prototype directly, while the other (now deprecated) +one uses Win32::API's internal representation for parameters. + +=head2 IMPORTING A FUNCTION BY PROTOTYPE + +You need to pass 2 parameters: + +=over 4 + +=item 1. +The name of the library from which you want to import the function. + +=item 2. +The C prototype of the function. + +=back + +See L<Win32::API::Type> for a list of the known parameter types and +L<Win32::API::Struct> for information on how to define a structure. + +=head2 IMPORTING A FUNCTION WITH A PARAMETER LIST + +You need to pass 4 parameters: + +=over 4 + +=item 1. +The name of the library from which you want to import the function. + +=item 2. +The name of the function (as exported by the library). + +=item 3. +The number and types of the arguments the function expects as input. + +=item 4. +The type of the value returned by the function. + +=back + +To better explain their meaning, let's suppose that we +want to import and call the Win32 API C<GetTempPath()>. +This function is defined in C as: + + DWORD WINAPI GetTempPathA( DWORD nBufferLength, LPSTR lpBuffer ); + +This is documented in the B<Win32 SDK Reference>; you can look +for it on the Microsoft's WWW site, or in your C compiler's +documentation, if you own one. + +=over 4 + +=item B<1.> + +The first parameter is the name of the library file that +exports this function; our function resides in the F<KERNEL32.DLL> +system file. +When specifying this name as parameter, the F<.DLL> extension +is implicit, and if no path is given, the file is searched through +a couple of directories, including: + +=over 4 + +=item 1. The directory from which the application loaded. + +=item 2. The current directory. + +=item 3. The Windows system directory (eg. c:\windows\system or system32). + +=item 4. The Windows directory (eg. c:\windows). + +=item 5. The directories that are listed in the PATH environment variable. + +=back + +So, you don't have to write F<C:\windows\system\kernel32.dll>; +only F<kernel32> is enough: + + $GetTempPath = new Win32::API('kernel32', ... + +=item B<2.> + +Now for the second parameter: the name of the function. +It must be written exactly as it is exported +by the library (case is significant here). +If you are using Windows 95 or NT 4.0, you can use the B<Quick View> +command on the DLL file to see the function it exports. +Remember that you can only import functions from 32 bit DLLs: +in Quick View, the file's characteristics should report +somewhere "32 bit word machine"; as a rule of thumb, +when you see that all the exported functions are in upper case, +the DLL is a 16 bit one and you can't use it. +If their capitalization looks correct, then it's probably a 32 bit +DLL. + +Also note that many Win32 APIs are exported twice, with the addition of +a final B<A> or B<W> to their name, for - respectively - the ASCII +and the Unicode version. +When a function name is not found, Win32::API will actually append +an B<A> to the name and try again; if the extension is built on a +Unicode system, then it will try with the B<W> instead. +So our function name will be: + + $GetTempPath = new Win32::API('kernel32', 'GetTempPath', ... + +In our case C<GetTempPath> is really loaded as C<GetTempPathA>. + +=item B<3.> + +The third parameter, the input parameter list, specifies how many +arguments the function wants, and their types. It can be passed as +a single string, in which each character represents one parameter, +or as a list reference. The following forms are valid: + + "abcd" + [a, b, c, d] + \@LIST + +But those are not: + + (a, b, c, d) + @LIST + +The number of characters, or elements in the list, specifies the number +of parameters, and each character or element specifies the type of an +argument; allowed types are: + +=over 4 + +=item C<I>: +value is an integer (int) + +=item C<N>: +value is a number (long) + +=item C<F>: +value is a floating point number (float) + +=item C<D>: +value is a double precision number (double) + +=item C<C>: +value is a char (char) + +=item C<P>: +value is a pointer (to a string, structure, etc...) + +=item C<S>: +value is a Win32::API::Struct object (see below) + +=item C<K>: +value is a Win32::API::Callback object (see L<Win32::API::Callback>) + +=back + +Our function needs two parameters: a number (C<DWORD>) and a pointer to a +string (C<LPSTR>): + + $GetTempPath = new Win32::API('kernel32', 'GetTempPath', 'NP', ... + +=item B<4.> + +The fourth and final parameter is the type of the value returned by the +function. It can be one of the types seen above, plus another type named B<V> +(for C<void>), used for functions that do not return a value. +In our example the value returned by GetTempPath() is a C<DWORD>, so +our return type will be B<N>: + + $GetTempPath = new Win32::API('kernel32', 'GetTempPath', 'NP', 'N'); + +Now the line is complete, and the GetTempPath() API is ready to be used +in Perl. Before calling it, you should test that $GetTempPath is +C<defined>, otherwise either the function or the library could not be +loaded; in this case, C<$!> will be set to the error message reported +by Windows. +Our definition, with error checking added, should then look like this: + + $GetTempPath = new Win32::API('kernel32', 'GetTempPath', 'NP', 'N'); + if(not defined $GetTempPath) { + die "Can't import API GetTempPath: $!\n"; + } + +=back + +=head2 CALLING AN IMPORTED FUNCTION + +To effectively make a call to an imported function you must use the +Call() method on the Win32::API object you created. +Continuing with the example from the previous paragraph, +the GetTempPath() API can be called using the method: + + $GetTempPath->Call(... + +Of course, parameters have to be passed as defined in the import phase. +In particular, if the number of parameters does not match (in the example, +if GetTempPath() is called with more or less than two parameters), +Perl will C<croak> an error message and C<die>. + +The two parameters needed here are the length of the buffer +that will hold the returned temporary path, and a pointer to the +buffer itself. +For numerical parameters, you can use either a constant expression +or a variable, while B<for pointers you must use a variable name> (no +Perl references, just a plain variable name). +Also note that B<memory must be allocated before calling the function>, +just like in C. +For example, to pass a buffer of 80 characters to GetTempPath(), +it must be initialized before with: + + $lpBuffer = " " x 80; + +This allocates a string of 80 characters. If you don't do so, you'll +probably get C<Runtime exception> errors, and generally nothing will +work. The call should therefore include: + + $lpBuffer = " " x 80; + $GetTempPath->Call(80, $lpBuffer); + +And the result will be stored in the $lpBuffer variable. +Note that you don't need to pass a reference to the variable +(eg. you B<don't need> C<\$lpBuffer>), even if its value will be set +by the function. + +A little problem here is that Perl does not trim the variable, +so $lpBuffer will still contain 80 characters in return; the exceeding +characters will be spaces, because we said C<" " x 80>. + +In this case we're lucky enough, because the value returned by +the GetTempPath() function is the length of the string, so to get +the actual temporary path we can write: + + $lpBuffer = " " x 80; + $return = $GetTempPath->Call(80, $lpBuffer); + $TempPath = substr($lpBuffer, 0, $return); + +If you don't know the length of the string, you can usually +cut it at the C<\0> (ASCII zero) character, which is the string +delimiter in C: + + $TempPath = ((split(/\0/, $lpBuffer))[0]; + # or + $lpBuffer =~ s/\0.*$//; + +=head2 USING STRUCTURES + +Starting from version 0.40, Win32::API comes with a support package +named Win32::API::Struct. The package is loaded automatically with +Win32::API, so you don't need to use it explicitly. + +With this module you can conveniently define structures and use +them as parameters to Win32::API functions. A short example follows: + + + # the 'POINT' structure is defined in C as: + # typedef struct { + # LONG x; + # LONG y; + # } POINT; + + + #### define the structure + Win32::API::Struct->typedef( POINT => qw{ + LONG x; + LONG y; + }); + + #### import an API that uses this structure + Win32::API->Import('user32', 'BOOL GetCursorPos(LPPOINT lpPoint)'); + + #### create a 'POINT' object + my $pt = Win32::API::Struct->new('POINT'); + + #### call the function passing our structure object + GetCursorPos($pt); + + #### and now, access its members + print "The cursor is at: $pt->{x}, $pt->{y}\n"; + +Note that this works only when the function wants a +B<pointer to a structure>: as you can see, our structure is named +'POINT', but the API used 'LPPOINT'. 'LP' is automatically added at +the beginning of the structure name when feeding it to a Win32::API +call. + +For more information, see also L<Win32::API::Struct>. + +If you don't want (or can't) use the Win32::API::Struct facility, +you can still use the low-level approach to use structures: + + +=over 4 + +=item 1. +you have to pack() the required elements in a variable: + + $lpPoint = pack('LL', 0, 0); # store two LONGs + +=item 2. to access the values stored in a structure, unpack() it as required: + + ($x, $y) = unpack('LL', $lpPoint); # get the actual values + +=back + +The rest is left as an exercise to the reader... + +=head1 AUTHOR + +Aldo Calpini ( I<dada@perl.it> ). + +=head1 MAINTAINER + +Cosimo Streppone ( I<cosimo@cpan.org> ) + +=cut diff --git a/Master/tlpkg/installer/perllib/Win32/API.pm.orig b/Master/tlpkg/installer/perllib/Win32/API.pm.orig new file mode 100644 index 00000000000..9e4accd8bf6 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Win32/API.pm.orig @@ -0,0 +1,741 @@ +package Win32::API;
+
+# See the bottom of this file for the POD documentation. Search for the
+# string '=head'.
+
+#######################################################################
+#
+# Win32::API - Perl Win32 API Import Facility
+#
+# Version: 0.47
+# Date: 12 Nov 2007
+# Author: Aldo Calpini <dada@perl.it>
+# Maintainer: Cosimo Streppone <cosimo@cpan.org>
+#
+# Changes for gcc/cygwin: Daniel Risacher <magnus@alum.mit.edu>
+# ported from 0.41 based on Daniel's patch by Reini Urban <rurban@x-ray.at>
+#
+# $Id: API.pm,v 1.0 2001/10/30 13:57:31 dada Exp $
+#
+#######################################################################
+
+require Exporter; # to export the constants to the main:: space
+require DynaLoader; # to dynuhlode the module.
+@ISA = qw( Exporter DynaLoader );
+
+use vars qw( $DEBUG );
+$DEBUG = 0;
+
+sub DEBUG {
+ if ($Win32::API::DEBUG) {
+ printf @_ if @_ or return 1;
+ } else {
+ return 0;
+ }
+}
+
+use Win32::API::Type;
+use Win32::API::Struct;
+use File::Basename ();
+
+#######################################################################
+# STATIC OBJECT PROPERTIES
+#
+$VERSION = '0.47';
+
+#### some package-global hash to
+#### keep track of the imported
+#### libraries and procedures
+my %Libraries = ();
+my %Procedures = ();
+
+
+#######################################################################
+# dynamically load in the API extension module.
+#
+bootstrap Win32::API;
+
+#######################################################################
+# PUBLIC METHODS
+#
+sub new {
+ my($class, $dll, $proc, $in, $out) = @_;
+ my $hdll;
+ my $self = {};
+
+ if ($^O eq 'cygwin' and $dll ne File::Basename::basename($dll)) {
+ # need to convert $dll to win32 path
+ # isn't there an API for this?
+ my $newdll = `cygpath -w "$dll"`;
+ chomp $newdll;
+ DEBUG "(PM)new: converted '$dll' to\n '$newdll'\n";
+ $dll = $newdll;
+ }
+
+ #### avoid loading a library more than once
+ if(exists($Libraries{$dll})) {
+ DEBUG "Win32::API::new: Library '$dll' already loaded, handle=$Libraries{$dll}\n";
+ $hdll = $Libraries{$dll};
+ } else {
+ DEBUG "Win32::API::new: Loading library '$dll'\n";
+ $hdll = Win32::API::LoadLibrary($dll);
+# $Libraries{$dll} = $hdll;
+ }
+
+ #### if the dll can't be loaded, set $! to Win32's GetLastError()
+ if(!$hdll) {
+ $! = Win32::GetLastError();
+ DEBUG "FAILED Loading library '$dll': $!\n";
+ delete $Libraries{$dll};
+ return undef;
+ }
+
+ #### determine if we have a prototype or not
+ if( (not defined $in) and (not defined $out) ) {
+ ($proc, $self->{in}, $self->{intypes}, $self->{out}) = parse_prototype( $proc );
+ return undef unless $proc;
+ $self->{proto} = 1;
+ } else {
+ $self->{in} = [];
+ if(ref($in) eq 'ARRAY') {
+ foreach (@$in) {
+ push(@{ $self->{in} }, type_to_num($_));
+ }
+ } else {
+ my @in = split '', $in;
+ foreach (@in) {
+ push(@{ $self->{in} }, type_to_num($_));
+ }
+ }
+ $self->{out} = type_to_num($out);
+ }
+
+ #### first try to import the function of given name...
+ my $hproc = Win32::API::GetProcAddress($hdll, $proc);
+
+ #### ...then try appending either A or W (for ASCII or Unicode)
+ if(!$hproc) {
+ my $tproc = $proc;
+ $tproc .= (IsUnicode() ? "W" : "A");
+ # print "Win32::API::new: procedure not found, trying '$tproc'...\n";
+ $hproc = Win32::API::GetProcAddress($hdll, $tproc);
+ }
+
+ #### ...if all that fails, set $! accordingly
+ if(!$hproc) {
+ $! = Win32::GetLastError();
+ DEBUG "FAILED GetProcAddress for Proc '$proc': $!\n";
+ return undef;
+ }
+ DEBUG "GetProcAddress('$proc') = '$hproc'\n";
+
+ #### ok, let's stuff the object
+ $self->{procname} = $proc;
+ $self->{dll} = $hdll;
+ $self->{dllname} = $dll;
+ $self->{proc} = $hproc;
+
+ #### keep track of the imported function
+ $Libraries{$dll} = $hdll;
+ $Procedures{$dll}++;
+
+ DEBUG "Object blessed!\n";
+
+ #### cast the spell
+ bless($self, $class);
+ return $self;
+}
+
+sub Import {
+ my($class, $dll, $proc, $in, $out) = @_;
+ $Imported{"$dll:$proc"} = Win32::API->new($dll, $proc, $in, $out) or return 0;
+ my $P = (caller)[0];
+ eval qq(
+ sub ${P}::$Imported{"$dll:$proc"}->{procname} { \$Win32::API::Imported{"$dll:$proc"}->Call(\@_); }
+ );
+ return $@ ? 0 : 1;
+}
+
+
+#######################################################################
+# PRIVATE METHODS
+#
+sub DESTROY {
+ my($self) = @_;
+
+ #### decrease this library's procedures reference count
+ $Procedures{$self->{dllname}}--;
+
+ #### once it reaches 0, free it
+ if($Procedures{$self->{dllname}} == 0) {
+ DEBUG "Win32::API::DESTROY: Freeing library '$self->{dllname}'\n";
+ Win32::API::FreeLibrary($Libraries{$self->{dllname}});
+ delete($Libraries{$self->{dllname}});
+ }
+}
+
+sub type_to_num {
+ my $type = shift;
+ my $out = shift;
+ my $num;
+
+ if( $type eq 'N'
+ or $type eq 'n'
+ or $type eq 'l'
+ or $type eq 'L'
+ ) {
+ $num = 1;
+ } elsif($type eq 'P'
+ or $type eq 'p'
+ ) {
+ $num = 2;
+ } elsif($type eq 'I'
+ or $type eq 'i'
+ ) {
+ $num = 3;
+ } elsif($type eq 'f'
+ or $type eq 'F'
+ ) {
+ $num = 4;
+ } elsif($type eq 'D'
+ or $type eq 'd'
+ ) {
+ $num = 5;
+ } elsif($type eq 'c'
+ or $type eq 'C'
+ ) {
+ $num = 6;
+ } else {
+ $num = 0;
+ }
+ unless(defined $out) {
+ if( $type eq 's'
+ or $type eq 'S'
+ ) {
+ $num = 51;
+ } elsif($type eq 'b'
+ or $type eq 'B'
+ ) {
+ $num = 22;
+ } elsif($type eq 'k'
+ or $type eq 'K'
+ ) {
+ $num = 101;
+ }
+ }
+ return $num;
+}
+
+sub parse_prototype {
+ my($proto) = @_;
+
+ my @in_params = ();
+ my @in_types = ();
+ if($proto =~ /^\s*(\S+)\s+(\S+)\s*\(([^\)]*)\)/) {
+ my $ret = $1;
+ my $proc = $2;
+ my $params = $3;
+
+ $params =~ s/^\s+//;
+ $params =~ s/\s+$//;
+
+ DEBUG "(PM)parse_prototype: got PROC '%s'\n", $proc;
+ DEBUG "(PM)parse_prototype: got PARAMS '%s'\n", $params;
+
+ foreach my $param (split(/\s*,\s*/, $params)) {
+ my($type, $name);
+ if($param =~ /(\S+)\s+(\S+)/) {
+ ($type, $name) = ($1, $2);
+ }
+
+ if(Win32::API::Type::is_known($type)) {
+ if(Win32::API::Type::is_pointer($type)) {
+ DEBUG "(PM)parse_prototype: IN='%s' PACKING='%s' API_TYPE=%d\n",
+ $type,
+ Win32::API::Type->packing( $type ),
+ type_to_num('P');
+ push(@in_params, type_to_num('P'));
+ } else {
+ DEBUG "(PM)parse_prototype: IN='%s' PACKING='%s' API_TYPE=%d\n",
+ $type,
+ Win32::API::Type->packing( $type ),
+ type_to_num( Win32::API::Type->packing( $type ) );
+ push(@in_params, type_to_num( Win32::API::Type->packing( $type ) ));
+ }
+ } elsif( Win32::API::Struct::is_known( $type ) ) {
+ DEBUG "(PM)parse_prototype: IN='%s' PACKING='%s' API_TYPE=%d\n",
+ $type, 'S', type_to_num('S');
+ push(@in_params, type_to_num('S'));
+ } else {
+ warn "Win32::API::parse_prototype: WARNING unknown parameter type '$type'";
+ push(@in_params, type_to_num('I'));
+ }
+ push(@in_types, $type);
+
+ }
+ DEBUG "parse_prototype: IN=[ @in_params ]\n";
+
+
+
+ if(Win32::API::Type::is_known($ret)) {
+ if(Win32::API::Type::is_pointer($ret)) {
+ DEBUG "parse_prototype: OUT='%s' PACKING='%s' API_TYPE=%d\n",
+ $ret,
+ Win32::API::Type->packing( $ret ),
+ type_to_num('P');
+ return ( $proc, \@in_params, \@in_types, type_to_num('P') );
+ } else {
+ DEBUG "parse_prototype: OUT='%s' PACKING='%s' API_TYPE=%d\n",
+ $ret,
+ Win32::API::Type->packing( $ret ),
+ type_to_num( Win32::API::Type->packing( $ret ) );
+ return ( $proc, \@in_params, \@in_types, type_to_num(Win32::API::Type->packing($ret)) );
+ }
+ } else {
+ warn "Win32::API::parse_prototype: WARNING unknown output parameter type '$ret'";
+ return ( $proc, \@in_params, \@in_types, type_to_num('I') );
+ }
+
+ } else {
+ warn "Win32::API::parse_prototype: bad prototype '$proto'";
+ return undef;
+ }
+}
+
+1;
+
+__END__
+
+#######################################################################
+# DOCUMENTATION
+#
+
+=head1 NAME
+
+Win32::API - Perl Win32 API Import Facility
+
+=head1 SYNOPSIS
+
+ #### Method 1: with prototype
+
+ use Win32::API;
+ $function = Win32::API->new(
+ 'mydll, 'int sum_integers(int a, int b)',
+ );
+ $return = $function->Call(3, 2);
+
+ #### Method 2: with parameter list
+
+ use Win32::API;
+ $function = Win32::API->new(
+ 'mydll', 'sum_integers', 'II', 'I',
+ );
+ $return = $function->Call(3, 2);
+
+ #### Method 3: with Import
+
+ use Win32::API;
+ Win32::API->Import(
+ 'mydll', 'int sum_integers(int a, int b)',
+ );
+ $return = sum_integers(3, 2);
+
+
+=for LATER-UNIMPLEMENTED
+ #### or
+ use Win32::API mydll => 'int sum_integers(int a, int b)';
+ $return = sum_integers(3, 2);
+
+
+=head1 ABSTRACT
+
+With this module you can import and call arbitrary functions
+from Win32's Dynamic Link Libraries (DLL), without having
+to write an XS extension. Note, however, that this module
+can't do anything (parameters input and output is limited
+to simpler cases), and anyway a regular XS extension is
+always safer and faster.
+
+The current version of Win32::API is available at my website:
+
+ http://dada.perl.it/
+
+It's also available on your nearest CPAN mirror (but allow a few days
+for worldwide spreading of the latest version) reachable at:
+
+ http://www.perl.com/CPAN/authors/Aldo_Calpini/
+
+A short example of how you can use this module (it just gets the PID of
+the current process, eg. same as Perl's internal C<$$>):
+
+ use Win32::API;
+ Win32::API->Import("kernel32", "int GetCurrentProcessId()");
+ $PID = GetCurrentProcessId();
+
+The possibilities are nearly infinite (but not all are good :-).
+Enjoy it.
+
+
+=head1 CREDITS
+
+All the credits go to Andrea Frosini
+for the neat assembler trick that makes this thing work.
+I've also used some work by Dave Roth for the prototyping stuff.
+A big thank you also to Gurusamy Sarathy for his
+unvaluable help in XS development, and to all the Perl community for
+being what it is.
+
+
+=head1 DESCRIPTION
+
+To use this module put the following line at the beginning of your script:
+
+ use Win32::API;
+
+You can now use the C<new()> function of the Win32::API module to create a
+new Win32::API object (see L<IMPORTING A FUNCTION>) and then invoke the
+C<Call()> method on this object to perform a call to the imported API
+(see L<CALLING AN IMPORTED FUNCTION>).
+
+Starting from version 0.40, you can also avoid creating a Win32::API object
+and instead automatically define a Perl sub with the same name of the API
+function you're importing. The details of the API definitions are the same,
+just the call is different:
+
+ my $GetCurrentProcessId = Win32::API->new(
+ "kernel32", "int GetCurrentProcessId()"
+ );
+ my $PID = $GetCurrentProcessId->Call();
+
+ #### vs.
+
+ Win32::API->Import("kernel32", "int GetCurrentProcessId()");
+ $PID = GetCurrentProcessId();
+
+Note that C<Import> returns 1 on success and 0 on failure (in which case you
+can check the content of C<$^E>).
+
+=head2 IMPORTING A FUNCTION
+
+You can import a function from a 32 bit Dynamic Link Library (DLL) file
+with the C<new()> function. This will create a Perl object that contains the
+reference to that function, which you can later C<Call()>.
+
+What you need to know is the prototype of the function you're going to import
+(eg. the definition of the function expressed in C syntax).
+
+Starting from version 0.40, there are 2 different approaches for this step:
+(the preferred) one uses the prototype directly, while the other (now deprecated)
+one uses Win32::API's internal representation for parameters.
+
+=head2 IMPORTING A FUNCTION BY PROTOTYPE
+
+You need to pass 2 parameters:
+
+=over 4
+
+=item 1.
+The name of the library from which you want to import the function.
+
+=item 2.
+The C prototype of the function.
+
+=back
+
+See L<Win32::API::Type> for a list of the known parameter types and
+L<Win32::API::Struct> for information on how to define a structure.
+
+=head2 IMPORTING A FUNCTION WITH A PARAMETER LIST
+
+You need to pass 4 parameters:
+
+=over 4
+
+=item 1.
+The name of the library from which you want to import the function.
+
+=item 2.
+The name of the function (as exported by the library).
+
+=item 3.
+The number and types of the arguments the function expects as input.
+
+=item 4.
+The type of the value returned by the function.
+
+=back
+
+To better explain their meaning, let's suppose that we
+want to import and call the Win32 API C<GetTempPath()>.
+This function is defined in C as:
+
+ DWORD WINAPI GetTempPathA( DWORD nBufferLength, LPSTR lpBuffer );
+
+This is documented in the B<Win32 SDK Reference>; you can look
+for it on the Microsoft's WWW site, or in your C compiler's
+documentation, if you own one.
+
+=over 4
+
+=item B<1.>
+
+The first parameter is the name of the library file that
+exports this function; our function resides in the F<KERNEL32.DLL>
+system file.
+When specifying this name as parameter, the F<.DLL> extension
+is implicit, and if no path is given, the file is searched through
+a couple of directories, including:
+
+=over 4
+
+=item 1. The directory from which the application loaded.
+
+=item 2. The current directory.
+
+=item 3. The Windows system directory (eg. c:\windows\system or system32).
+
+=item 4. The Windows directory (eg. c:\windows).
+
+=item 5. The directories that are listed in the PATH environment variable.
+
+=back
+
+So, you don't have to write F<C:\windows\system\kernel32.dll>;
+only F<kernel32> is enough:
+
+ $GetTempPath = new Win32::API('kernel32', ...
+
+=item B<2.>
+
+Now for the second parameter: the name of the function.
+It must be written exactly as it is exported
+by the library (case is significant here).
+If you are using Windows 95 or NT 4.0, you can use the B<Quick View>
+command on the DLL file to see the function it exports.
+Remember that you can only import functions from 32 bit DLLs:
+in Quick View, the file's characteristics should report
+somewhere "32 bit word machine"; as a rule of thumb,
+when you see that all the exported functions are in upper case,
+the DLL is a 16 bit one and you can't use it.
+If their capitalization looks correct, then it's probably a 32 bit
+DLL.
+
+Also note that many Win32 APIs are exported twice, with the addition of
+a final B<A> or B<W> to their name, for - respectively - the ASCII
+and the Unicode version.
+When a function name is not found, Win32::API will actually append
+an B<A> to the name and try again; if the extension is built on a
+Unicode system, then it will try with the B<W> instead.
+So our function name will be:
+
+ $GetTempPath = new Win32::API('kernel32', 'GetTempPath', ...
+
+In our case C<GetTempPath> is really loaded as C<GetTempPathA>.
+
+=item B<3.>
+
+The third parameter, the input parameter list, specifies how many
+arguments the function wants, and their types. It can be passed as
+a single string, in which each character represents one parameter,
+or as a list reference. The following forms are valid:
+
+ "abcd"
+ [a, b, c, d]
+ \@LIST
+
+But those are not:
+
+ (a, b, c, d)
+ @LIST
+
+The number of characters, or elements in the list, specifies the number
+of parameters, and each character or element specifies the type of an
+argument; allowed types are:
+
+=over 4
+
+=item C<I>:
+value is an integer (int)
+
+=item C<N>:
+value is a number (long)
+
+=item C<F>:
+value is a floating point number (float)
+
+=item C<D>:
+value is a double precision number (double)
+
+=item C<C>:
+value is a char (char)
+
+=item C<P>:
+value is a pointer (to a string, structure, etc...)
+
+=item C<S>:
+value is a Win32::API::Struct object (see below)
+
+=item C<K>:
+value is a Win32::API::Callback object (see L<Win32::API::Callback>)
+
+=back
+
+Our function needs two parameters: a number (C<DWORD>) and a pointer to a
+string (C<LPSTR>):
+
+ $GetTempPath = new Win32::API('kernel32', 'GetTempPath', 'NP', ...
+
+=item B<4.>
+
+The fourth and final parameter is the type of the value returned by the
+function. It can be one of the types seen above, plus another type named B<V>
+(for C<void>), used for functions that do not return a value.
+In our example the value returned by GetTempPath() is a C<DWORD>, so
+our return type will be B<N>:
+
+ $GetTempPath = new Win32::API('kernel32', 'GetTempPath', 'NP', 'N');
+
+Now the line is complete, and the GetTempPath() API is ready to be used
+in Perl. Before calling it, you should test that $GetTempPath is
+C<defined>, otherwise either the function or the library could not be
+loaded; in this case, C<$!> will be set to the error message reported
+by Windows.
+Our definition, with error checking added, should then look like this:
+
+ $GetTempPath = new Win32::API('kernel32', 'GetTempPath', 'NP', 'N');
+ if(not defined $GetTempPath) {
+ die "Can't import API GetTempPath: $!\n";
+ }
+
+=back
+
+=head2 CALLING AN IMPORTED FUNCTION
+
+To effectively make a call to an imported function you must use the
+Call() method on the Win32::API object you created.
+Continuing with the example from the previous paragraph,
+the GetTempPath() API can be called using the method:
+
+ $GetTempPath->Call(...
+
+Of course, parameters have to be passed as defined in the import phase.
+In particular, if the number of parameters does not match (in the example,
+if GetTempPath() is called with more or less than two parameters),
+Perl will C<croak> an error message and C<die>.
+
+The two parameters needed here are the length of the buffer
+that will hold the returned temporary path, and a pointer to the
+buffer itself.
+For numerical parameters, you can use either a constant expression
+or a variable, while B<for pointers you must use a variable name> (no
+Perl references, just a plain variable name).
+Also note that B<memory must be allocated before calling the function>,
+just like in C.
+For example, to pass a buffer of 80 characters to GetTempPath(),
+it must be initialized before with:
+
+ $lpBuffer = " " x 80;
+
+This allocates a string of 80 characters. If you don't do so, you'll
+probably get C<Runtime exception> errors, and generally nothing will
+work. The call should therefore include:
+
+ $lpBuffer = " " x 80;
+ $GetTempPath->Call(80, $lpBuffer);
+
+And the result will be stored in the $lpBuffer variable.
+Note that you don't need to pass a reference to the variable
+(eg. you B<don't need> C<\$lpBuffer>), even if its value will be set
+by the function.
+
+A little problem here is that Perl does not trim the variable,
+so $lpBuffer will still contain 80 characters in return; the exceeding
+characters will be spaces, because we said C<" " x 80>.
+
+In this case we're lucky enough, because the value returned by
+the GetTempPath() function is the length of the string, so to get
+the actual temporary path we can write:
+
+ $lpBuffer = " " x 80;
+ $return = $GetTempPath->Call(80, $lpBuffer);
+ $TempPath = substr($lpBuffer, 0, $return);
+
+If you don't know the length of the string, you can usually
+cut it at the C<\0> (ASCII zero) character, which is the string
+delimiter in C:
+
+ $TempPath = ((split(/\0/, $lpBuffer))[0];
+ # or
+ $lpBuffer =~ s/\0.*$//;
+
+=head2 USING STRUCTURES
+
+Starting from version 0.40, Win32::API comes with a support package
+named Win32::API::Struct. The package is loaded automatically with
+Win32::API, so you don't need to use it explicitly.
+
+With this module you can conveniently define structures and use
+them as parameters to Win32::API functions. A short example follows:
+
+
+ # the 'POINT' structure is defined in C as:
+ # typedef struct {
+ # LONG x;
+ # LONG y;
+ # } POINT;
+
+
+ #### define the structure
+ Win32::API::Struct->typedef( POINT => qw{
+ LONG x;
+ LONG y;
+ });
+
+ #### import an API that uses this structure
+ Win32::API->Import('user32', 'BOOL GetCursorPos(LPPOINT lpPoint)');
+
+ #### create a 'POINT' object
+ my $pt = Win32::API::Struct->new('POINT');
+
+ #### call the function passing our structure object
+ GetCursorPos($pt);
+
+ #### and now, access its members
+ print "The cursor is at: $pt->{x}, $pt->{y}\n";
+
+Note that this works only when the function wants a
+B<pointer to a structure>: as you can see, our structure is named
+'POINT', but the API used 'LPPOINT'. 'LP' is automatically added at
+the beginning of the structure name when feeding it to a Win32::API
+call.
+
+For more information, see also L<Win32::API::Struct>.
+
+If you don't want (or can't) use the Win32::API::Struct facility,
+you can still use the low-level approach to use structures:
+
+
+=over 4
+
+=item 1.
+you have to pack() the required elements in a variable:
+
+ $lpPoint = pack('LL', 0, 0); # store two LONGs
+
+=item 2. to access the values stored in a structure, unpack() it as required:
+
+ ($x, $y) = unpack('LL', $lpPoint); # get the actual values
+
+=back
+
+The rest is left as an exercise to the reader...
+
+=head1 AUTHOR
+
+Aldo Calpini ( I<dada@perl.it> ).
+
+=head1 MAINTAINER
+
+Cosimo Streppone ( I<cosimo@cpan.org> )
+
+=cut
diff --git a/Master/tlpkg/installer/perllib/Win32/API/Callback.pm b/Master/tlpkg/installer/perllib/Win32/API/Callback.pm new file mode 100644 index 00000000000..22de9d4f46a --- /dev/null +++ b/Master/tlpkg/installer/perllib/Win32/API/Callback.pm @@ -0,0 +1,174 @@ +package Win32::API::Callback; + +# See the bottom of this file for the POD documentation. Search for the +# string '=head'. + +####################################################################### +# +# Win32::API::Callback - Perl Win32 API Import Facility +# +# Author: Aldo Calpini <dada@perl.it> +# Maintainer: Cosimo Streppone <cosimo@cpan.org> +# +# $Id: Callback.pm,v 1.0 2001/10/30 13:57:31 dada Exp $ +# +####################################################################### + +$VERSION = '0.47'; + +require Exporter; # to export the constants to the main:: space +require DynaLoader; # to dynuhlode the module. +@ISA = qw( Exporter DynaLoader ); + +sub DEBUG { + if ($WIN32::API::DEBUG) { + printf @_ if @_ or return 1; + } else { + return 0; + } +} + +use Win32::API; +use Win32::API::Type; +use Win32::API::Struct; + +####################################################################### +# This AUTOLOAD is used to 'autoload' constants from the constant() +# XS function. If a constant is not found then control is passed +# to the AUTOLOAD in AutoLoader. +# + +sub AUTOLOAD { + my($constname); + ($constname = $AUTOLOAD) =~ s/.*:://; + #reset $! to zero to reset any current errors. + $!=0; + my $val = constant($constname, @_ ? $_[0] : 0); + if ($! != 0) { + if ($! =~ /Invalid/) { + $AutoLoader::AUTOLOAD = $AUTOLOAD; + goto &AutoLoader::AUTOLOAD; + } else { + ($pack,$file,$line) = caller; + die "Your vendor has not defined Win32::API::Callback macro $constname, used at $file line $line."; + } + } + eval "sub $AUTOLOAD { $val }"; + goto &$AUTOLOAD; +} + + +####################################################################### +# dynamically load in the API extension module. +# +bootstrap Win32::API::Callback; + +####################################################################### +# PUBLIC METHODS +# +sub new { + my($class, $proc, $in, $out) = @_; + my %self = (); + + # printf "(PM)Callback::new: got proc='%s', in='%s', out='%s'\n", $proc, $in, $out; + + $self{in} = []; + if(ref($in) eq 'ARRAY') { + foreach (@$in) { + push(@{ $self{in} }, Win32::API::type_to_num($_)); + } + } else { + my @in = split '', $in; + foreach (@in) { + push(@{ $self{in} }, Win32::API::type_to_num($_)); + } + } + $self{out} = Win32::API::type_to_num($out); + $self{sub} = $proc; + my $self = bless \%self, $class; + + DEBUG "(PM)Callback::new: calling CallbackCreate($self)...\n"; + my $hproc = CallbackCreate($self); + + DEBUG "(PM)Callback::new: hproc=$hproc\n"; + + #### ...if that fails, set $! accordingly + if(!$hproc) { + $! = Win32::GetLastError(); + return undef; + } + + #### ok, let's stuff the object + $self->{code} = $hproc; + $self->{sub} = $proc; + + #### cast the spell + return $self; +} + +sub MakeStruct { + my($self, $n, $addr) = @_; + DEBUG "(PM)Win32::API::Callback::MakeStruct: got self='$self'\n"; + my $struct = Win32::API::Struct->new($self->{intypes}->[$n]); + $struct->FromMemory($addr); + return $struct; +} + +1; + +__END__ + +####################################################################### +# DOCUMENTATION +# + +=head1 NAME + +Win32::API::Callback - Callback support for Win32::API + +=head1 SYNOPSIS + + use Win32::API; + use Win32::API::Callback; + + my $callback = Win32::API::Callback->new( + sub { my($a, $b) = @_; return $a+$b; }, + "NN", "N", + ); + + Win32::API->Import( + 'mydll', 'two_integers_cb', 'KNN', 'N', + ); + + $sum = two_integers_cb( $callback, 3, 2 ); + + +=head1 FOREWORDS + +=over 4 + +=item * +Support for this module is B<highly experimental> at this point. + +=item * +I won't be surprised if it doesn't work for you. + +=item * +Feedback is very appreciated. + +=item * +Documentation is in the work. Either see the SYNOPSIS above +or the samples in the F<samples> directory. + +=back + +=head1 AUTHOR + +Aldo Calpini ( I<dada@perl.it> ). + +=head1 MAINTAINER + +Cosimo Streppone ( I<cosimo@cpan.org> ). + +=cut + diff --git a/Master/tlpkg/installer/perllib/Win32/API/Struct.pm b/Master/tlpkg/installer/perllib/Win32/API/Struct.pm new file mode 100644 index 00000000000..05a4c8c60a5 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Win32/API/Struct.pm @@ -0,0 +1,532 @@ +package Win32::API::Struct; + +# See the bottom of this file for the POD documentation. Search for the +# string '=head'. + +####################################################################### +# +# Win32::API::Struct - Perl Win32 API struct Facility +# +# Author: Aldo Calpini <dada@perl.it> +# Maintainer: Cosimo Streppone <cosimo@cpan.org> +# +# $Id: Struct.pm,v 1.0 2001/10/30 13:57:31 dada Exp $ +####################################################################### + +$VERSION = '0.47'; + +use Win32::API::Type; + +use Carp; + +require Exporter; # to export the constants to the main:: space +require DynaLoader; # to dynuhlode the module. +@ISA = qw( Exporter DynaLoader ); + +my %Known = (); + +sub DEBUG { + if ($Win32::API::DEBUG) { + printf @_ if @_ or return 1; + } else { + return 0; + } +} + +sub typedef { + my $class = shift; + my $struct = shift; + my($type, $name); + my $self = { + align => undef, + typedef => [], + }; + while(defined($type = shift)) { + $name = shift; + $name =~ s/;$//; + push( @{ $self->{typedef} }, [ recognize($type, $name) ] ); + } + + $Known{$struct} = $self; + return 1; +} + + +sub recognize { + my($type, $name) = @_; + my($size, $packing); + if(exists $Known{$type}) { + $packing = ">"; + return $name, $packing, $type; + } else { + $packing = Win32::API::Type::packing($type); + return undef unless defined $packing; + if($name =~ s/\[(.*)\]$//) { + $size = $1; + $packing = $packing."*".$size; + } + DEBUG "(PM)Struct::recognize got '$name', '$type' -> '$packing'\n"; + return $name, $packing, $type; + } +} + +sub new { + my $class = shift; + my($type, $name); + my $self = { + typedef => [], + }; + if($#_ == 0) { + if(exists $Known{$_[0]}) { + DEBUG "(PM)Struct::new: got '$_[0]'\n"; + $self->{typedef} = $Known{$_[0]}->{typedef}; + foreach my $member (@{ $self->{typedef} }) { + ($name, $packing, $type) = @$member; + if($packing eq '>') { + $self->{$name} = Win32::API::Struct->new($type); + } + } + $self->{__typedef__} = $_[0]; + } else { + carp "Unknown Win32::API::Struct '$_[0]'"; + return undef; + } + } else { + while(defined($type = shift)) { + $name = shift; + # print "new: found member $name ($type)\n"; + if(not exists $Win32::API::Type::Known{$type}) { + warn "Unknown Win32::API::Struct type '$type'"; + return undef; + } else { + push( @{ $self->{typedef} }, [ $name, $Win32::API::Type::Known{$type}, $type ] ); + } + } + } + return bless $self; +} + +sub members { + my $self = shift; + return map {$_->[0]} @{ $self->{typedef} }; +} + +sub sizeof { + my $self = shift; + my $size = 0; + my $align = 0; + my $first = undef; + foreach my $member (@{ $self->{typedef} }) { + my($name, $packing, $type) = @$member; + + if(ref( $self->{$name} ) eq "Win32::API::Struct") { + $size += $self->{$name}->sizeof(); + # $align = $self->{$name}->sizeof() if $self->{$name}->sizeof() > $align; + } else { + if($packing =~ /\w\*(\d+)/) { + $size += Win32::API::Type::sizeof($type) * $1; + $first = Win32::API::Type::sizeof($type) * $1 unless defined $first; + DEBUG "(PM)Struct::sizeof: sizeof with member($name) now = ". $size. "\n"; + } else { + $size += Win32::API::Type::sizeof($type); + $first = Win32::API::Type::sizeof($type) unless defined $first; + $align = Win32::API::Type::sizeof($type) + if Win32::API::Type::sizeof($type) > $align; + DEBUG "(PM)Struct::sizeof: sizeof with member($name) now = ". $size. "\n"; + } + } + } + DEBUG "(PM)Struct::sizeof first=$first align=$align\n"; + #DEBUG "(PM)Struct::sizeof returning %d\n", $first + (scalar(@{ $self->{typedef} })-1) * $align; + #return $first + (scalar(@{ $self->{typedef} })-1) * $align; + DEBUG "(PM)Struct::sizeof returning %d\n", scalar(@{ $self->{typedef} }) * $align; + if(defined $align and $align > 0) { + return scalar(@{ $self->{typedef} }) * $align; + } else { + return $size; + } + return $size; +} + +sub align { + my $self = shift; + my $align = shift; + + if(not defined $align) { + return $self->{align} unless $self->{align} eq 'auto'; + $align = 0; + foreach my $member (@{ $self->{typedef} }) { + my($name, $packing, $type) = @$member; + + if(ref( $self->{$name} ) eq "Win32::API::Struct") { + #### ???? + } else { + if($packing =~ /\w\*(\d+)/) { + #### ???? + } else { + $align = Win32::API::Type::sizeof($type) + if Win32::API::Type::sizeof($type) > $align; + } + } + } + return $align; + } else { + $self->{align} = $align; + + } +} + +sub getPack { + my $self = shift; + my $packing = ""; + my($type, $name); + my @items = (); + my @recipients = (); + + my $align = $self->align(); + + foreach my $member (@{ $self->{typedef} }) { + ($name, $type, $orig) = @$member; + if($type eq '>') { + my($subpacking, $subitems, $subrecipients) = $self->{$name}->getPack(); + + DEBUG "(PM)Struct::getPack($self->{__typedef__}) ++ $subpacking\n"; + + $packing .= $subpacking; + push(@items, @$subitems); + push(@recipients, @$subrecipients); + } else { + if($type =~ /\w\*(\d+)/) { + my $size = $1; + $type = "a$size"; + } + + DEBUG "(PM)Struct::getPack($self->{__typedef__}) ++ $type\n"; + + if($type eq 'p') { + $type = "L"; + push(@items, Win32::API::PointerTo($self->{$name})); + } else { + push(@items, $self->{$name}); + } + $packing .= $type; + + if($Win32::API::Type::PackSize{$type} < $align) { + $packing .= ("x" x ($align - $Win32::API::Type::PackSize{$type})); + } + + push(@recipients, $self); + } + } + DEBUG "(PM)Struct::getPack: $self->{__typedef__}(buffer) = pack($packing, @items)\n"; + return($packing, [@items], [@recipients]); +} + + +sub Pack { + my $self = shift; + my($packing, $items, $recipients) = $self->getPack(); + DEBUG "(PM)Struct::Pack: $self->{__typedef__}(buffer) = pack($packing, @$items)\n"; + $self->{buffer} = pack($packing, @$items); + if(DEBUG) { + for my $i (0..$self->sizeof-1) { + printf " %3d: 0x%02x\n", $i, ord(substr($self->{buffer}, $i, 1)); + } + } + $self->{buffer_recipients} = $recipients +} + +sub getUnpack { + my $self = shift; + my $packing = ""; + my($type, $name); + my @items = (); + my $align = $self->align(); + foreach my $member (@{ $self->{typedef} }) { + ($name, $type, $orig) = @$member; + if($type eq '>') { + my($subpacking, @subitems) = $self->{$name}->getUnpack(); + + DEBUG "(PM)Struct::getUnpack($self->{__typedef__}) ++ $subpacking\n"; + $packing .= $subpacking; + + + push(@items, @subitems); + } else { + if($type =~ /\w\*(\d+)/) { + my $size = $1; + $type = "Z$size"; + } + + #if($type eq 'p') { + # $packing .= 'Z*'; + # DEBUG "(PM)Struct::getUnpack($self->{__typedef__}) ++ Z*\n"; + #} else { + $packing .= $type; + DEBUG "(PM)Struct::getUnpack($self->{__typedef__}) ++ $type\n"; + #} + if($type ne 'p' and $type !~ /^Z(\d+)/ and $Win32::API::Type::PackSize{$type} < $align) { + DEBUG "(PM)Struct::getUnpack %s(%d) < %d\n", + $type, $Win32::API::Type::PackSize{$type}, $align + ; + $packing .= ("x" x ($align - $Win32::API::Type::PackSize{$type})); + } + + push(@items, $name); + } + } + DEBUG "(PM)Struct::getUnpack($self->{__typedef__}): unpack($packing, @items)\n"; + return($packing, @items); +} + +sub Unpack { + my $self = shift; + my($packing, @items) = $self->getUnpack(); + my @itemvalue = unpack($packing, $self->{buffer}); + DEBUG "(PM)Struct::Unpack: unpack($packing, buffer) = @itemvalue\n"; + foreach my $i (0..$#items) { + my $recipient = $self->{buffer_recipients}->[$i]; + DEBUG "(PM)Struct::Unpack: %s(%s) = '%s' (0x%08x)\n", + $recipient->{__typedef__}, + $items[$i], + $itemvalue[$i], + $itemvalue[$i], + ; + $recipient->{$items[$i]} = $itemvalue[$i]; + DEBUG "(PM)Struct::Unpack: self.$items[$i] = $self->{$items[$i]}\n"; + } +} + +sub FromMemory { + my($self, $addr) = @_; + DEBUG "(PM)Struct::FromMemory: doing Pack\n"; + $self->Pack(); + DEBUG "(PM)Struct::FromMemory: doing GetMemory( 0x%08x, %d )\n", $addr, $self->sizeof; + $self->{buffer} = Win32::API::ReadMemory( $addr, $self->sizeof ); + $self->Unpack(); + DEBUG "(PM)Struct::FromMemory: doing Unpack\n"; + DEBUG "(PM)Struct::FromMemory: structure is now:\n"; + $self->Dump() if DEBUG; + DEBUG "\n"; +} + +sub Dump { + my $self = shift; + my $prefix = shift; + foreach my $member (@{ $self->{typedef} }) { + ($name, $packing, $type) = @$member; + if( ref($self->{$name}) ) { + $self->{$name}->Dump($name); + } else { + printf "%-20s %-20s %-20s\n", $prefix, $name, $self->{$name}; + } + } +} + + +sub is_known { + my $name = shift; + if(exists $Known{ $name }) { + return 1; + } else { + if($name =~ s/^LP//) { + return exists $Known{ $name }; + } + return 0; + } +} + +sub TIEHASH { + return Win32::API::Struct::new(@_); +} + +sub EXISTS { + +} + +sub FETCH { + my $self = shift; + my $key = shift; + + if($key eq 'sizeof') { + return $self->sizeof; + } + my @members = map { $_->[0] } @{ $self->{typedef} }; + if(grep(/^\Q$key\E$/, @members)) { + return $self->{$key}; + } else { + warn "'$key' is not a member of Win32::API::Struct $self->{__typedef__}"; + } +} + +sub STORE { + my $self = shift; + my($key, $val) = @_; + my @members = map { $_->[0] } @{ $self->{typedef} }; + if(grep(/^\Q$key\E$/, @members)) { + $self->{$key} = $val; + } else { + warn "'$key' is not a member of Win32::API::Struct $self->{__typedef__}"; + } +} + +sub FIRSTKEY { + my $self = shift; + my @members = map { $_->[0] } @{ $self->{typedef} }; + return $members[0]; +} + +sub NEXTKEY { + my $self = shift; + my $key = shift; + my @members = map { $_->[0] } @{ $self->{typedef} }; + for my $i (0..$#members-1) { + return $members[$i+1] if $members[$i] eq $key; + } + return undef; +} + +1; + +####################################################################### +# DOCUMENTATION +# + +=head1 NAME + +Win32::API::Struct - C struct support package for Win32::API + +=head1 SYNOPSIS + + use Win32::API; + + Win32::API::Struct->typedef( 'POINT', qw( + LONG x; + LONG y; + )); + + my $Point = Win32::API::Struct->new( 'POINT' ); + $Point->{x} = 1024; + $Point->{y} = 768; + + #### alternatively + + tie %Point, 'Win32::API::Struct', 'POINT'; + $Point{x} = 1024; + $Point{y} = 768; + + +=head1 ABSTRACT + +This module enables you to define C structs for use with +Win32::API. + +See L<Win32::API> for more info about its usage. + +=head1 DESCRIPTION + +This module is automatically imported by Win32::API, so you don't +need to 'use' it explicitly. The main methods are C<typedef> and +C<new>, which are documented below. + +=over 4 + +=item C<typedef NAME, TYPE, MEMBER, TYPE, MEMBER, ...> + +This method defines a structure named C<NAME>. The definition consists +of types and member names, just like in C. In fact, most of the +times you can cut the C definition for a structure and paste it +verbatim to your script, enclosing it in a C<qw()> block. The +function takes care of removing the semicolon after the member +name. + +The synopsis example could be written like this: + + Win32::API::Struct->typedef('POINT', 'LONG', 'x', 'LONG', 'y'); + +But it could also be written like this (note the indirect object +syntax), which is pretty cool: + + typedef Win32::API::Struct POINT => qw{ + LONG x; + LONG y; + }; + +Also note that C<typedef> automatically defines an 'LPNAME' type, +which holds a pointer to your structure. In the example above, +'LPPOINT' is also defined and can be used in a call to a +Win32::API (in fact, this is what you're really going to use when +doing API calls). + +=item C<new NAME> + +This creates a structure (a Win32::API::Struct object) of the +type C<NAME> (it must have been defined with C<typedef>). In Perl, +when you create a structure, all the members are undefined. But +when you use that structure in C (eg. a Win32::API call), you +can safely assume that they will be treated as zero (or NULL). + +=item C<sizeof> + +This returns the size, in bytes, of the structure. Acts just like +the C function of the same name. It is particularly useful for +structures that need a member to be initialized to the structure's +own size. + +=item C<align [SIZE]> + +Sets or returns the structure alignment (eg. how the structure is +stored in memory). This is a very advanced option, and you normally +don't need to mess with it. +All structures in the Win32 Platform SDK should work without it. +But if you define your own structure, you may need to give it an +explicit alignment. In most cases, passing a C<SIZE> of 'auto' +should keep the world happy. + +=back + +=head2 THE C<tie> INTERFACE + +Instead of creating an object with the C<new> method, you can +tie a hash, which will hold the desired structure, using the +C<tie> builtin function: + + tie %structure, Win32::API::Struct => 'NAME'; + +The differences between the tied and non-tied approaches are: + +=over 4 + +=item * +with tied structures, you can access members directly as +hash lookups, eg. + + # tied # non-tied + $Point{x} vs. $Point->{x} + +=item * +with tied structures, when you try to fetch or store a +member that is not part of the structure, it will result +in a warning, eg. + + print $Point{z}; + # this will warn: 'z' is not a member of Win32::API::Struct POINT + +=item * +when you pass a tied structure as a Win32::API parameter, +remember to backslash it, eg. + + # tied # non-tied + GetCursorPos( \%Point ) vs. GetCursorPos( $Point ) + +=back + +=head1 AUTHOR + +Aldo Calpini ( I<dada@perl.it> ). + +=head1 MAINTAINER + +Cosimo Streppone ( I<cosimo@cpan.org> ). + +=cut diff --git a/Master/tlpkg/installer/perllib/Win32/API/Test.pm b/Master/tlpkg/installer/perllib/Win32/API/Test.pm new file mode 100644 index 00000000000..6cbeed6bfac --- /dev/null +++ b/Master/tlpkg/installer/perllib/Win32/API/Test.pm @@ -0,0 +1,120 @@ +# +# Win32::API::Test - Test helper package for Win32::API +# +# Version: 0.01 +# Date: 23 Dec 2006 +# Author: Cosimo Streppone <cosimo@cpan.org> +# +# $Id: API.pm,v 1.0 2001/10/30 13:57:31 dada Exp $ +# +package Win32::API::Test; + +sub compiler_name () { + use Config; + my $cc = $Config{ccname}; + if($cc eq 'cl' || $cc eq 'cl.exe') + { + $cc = 'cl'; + } + return($cc); +} + +sub compiler_version () { + use Config; + my $ver = $Config{ccversion} || 0; + if( $ver =~ /^(\d+\.\d+)/ ) + { + $ver = 0 + $1; + } + return($ver); +} + +# +# Run the compiler and get version from there... +# User might be running a compiler different from +# that used to build perl. +# For example, Cosimo does. For testing, of course. +# +# *** +# *** IT DOES NOT WORK NOW. +# *** FOR REASONS I DON'T KNOW, CL.EXE OUTPUTS ITS +# *** VERSION STRING IN THE FIRST TWO LINES THAT +# *** I'M NOT ABLE TO CATCH... +# *** +# +sub compiler_version_from_shell () { + my $cc = compiler_name(); + my $ver; + # MSVC + if($cc eq 'cl') + { + my @ver = `$cc`; + my $ver = join('',@ver); + print 'VER:'.$ver.':'."\n"; + if($ver =~ /Version (\d[\d\.]+)/ms ) + { + $ver = $1; + } + } + # GCC + elsif($cc eq 'cc' || $cc eq 'gcc' || $cc eq 'winegcc' ) + { + $ver = join('', `$cc --version`); + if($ver =~ /gcc.*(\d[\d+]+)/ms ) + { + $ver = $1; + } + } + # Borland C + elsif($cc eq 'bcc32' || $cc eq 'bcc') + { + $ver = join('', `$cc`); + if($ver =~ /Borland C\+\+ (\d[\d\.]+)/ms ) + { + $ver = $1; + } + } + return($ver); +} + +sub find_test_dll () { + require File::Spec; + my $dll_name = $_[0]; + my @paths = qw(.. ../t ../t/dll . ./dll ./t/dll); + while(my $path = shift @paths) + { + $dll = File::Spec->catfile($path, $dll_name); + return $dll if -s $dll; + } + return(undef); +} + +1; + +__END__ + + +####################################################################### +# DOCUMENTATION +# + +=head1 NAME + +Win32::API::Test - Test helper package for Win32::API + +=head1 SYNOPSIS + + my $test_dll = Win32::API::Test::find_test_dll('API_test.dll'); + +Check the t/*.t test scripts for more details. + +=head1 DESCRIPTION + +Simple package to hold Win32::API test suite helper functions. +No more, no less. + +=head1 AUTHOR + +Cosimo Streppone ( I<cosimo@cpan.org> ) + +=cut diff --git a/Master/tlpkg/installer/perllib/Win32/API/Type.pm b/Master/tlpkg/installer/perllib/Win32/API/Type.pm new file mode 100644 index 00000000000..334b0b731e1 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Win32/API/Type.pm @@ -0,0 +1,446 @@ +package Win32::API::Type; + +# See the bottom of this file for the POD documentation. Search for the +# string '=head'. + +####################################################################### +# +# Win32::API::Type - Perl Win32 API type definitions +# +# Author: Aldo Calpini <dada@perl.it> +# Maintainer: Cosimo Streppone <cosimo@cpan.org> +# +# $Id: Type.pm,v 1.0 2001/10/30 13:57:31 dada Exp $ +####################################################################### + +$VERSION = '0.47'; + +use Carp; + +require Exporter; # to export the constants to the main:: space +require DynaLoader; # to dynuhlode the module. +@ISA = qw( Exporter DynaLoader ); + +use vars qw( %Known %PackSize %Modifier %Pointer ); + +sub DEBUG { + if ($Win32::API::DEBUG) { + printf @_ if @_ or return 1; + } else { + return 0; + } +} + +%Known = (); +%PackSize = (); +%Modifier = (); +%Pointer = (); + +# Initialize data structures at startup. +# Aldo wants to keep the <DATA> approach. +# +my $section = 'nothing'; +foreach (<DATA>) { + next if /^\s*#/ or /^\s*$/; + chomp; + if( /\[(.+)\]/) { + $section = $1; + next; + } + if($section eq 'TYPE') { + my($name, $packing) = split(/\s+/); + # DEBUG "(PM)Type::INIT: Known('$name') => '$packing'\n"; + $Known{$name} = $packing; + } elsif($section eq 'PACKSIZE') { + my($packing, $size) = split(/\s+/); + # DEBUG "(PM)Type::INIT: PackSize('$packing') => '$size'\n"; + $PackSize{$packing} = $size; + } elsif($section eq 'MODIFIER') { + my($modifier, $mapto) = split(/\s+/, $_, 2); + my %maps = (); + foreach my $item (split(/\s+/, $mapto)) { + my($k, $v) = split(/=/, $item); + $maps{$k} = $v; + } + # DEBUG "(PM)Type::INIT: Modifier('$modifier') => '%maps'\n"; + $Modifier{$modifier} = { %maps }; + } elsif($section eq 'POINTER') { + my($pointer, $pointto) = split(/\s+/); + # DEBUG "(PM)Type::INIT: Pointer('$pointer') => '$pointto'\n"; + $Pointer{$pointer} = $pointto; + } +} +close(DATA); + +sub new { + my $class = shift; + my($type) = @_; + my $packing = packing($type); + my $size = sizeof($type); + my $self = { + type => $type, + packing => $packing, + size => $size, + }; + return bless $self; +} + +sub typedef { + my $class = shift; + my($name, $type) = @_; + my $packing = packing($type, $name); + DEBUG "(PM)Type::typedef: packing='$packing'\n"; + my $size = sizeof($type); + $Known{$name} = $packing; + return 1; +} + + +sub is_known { + my $self = shift; + my $type = shift; + $type = $self unless defined $type; + if(ref($type) =~ /Win32::API::Type/) { + return 1; + } else { + return defined packing($type); + } +} + +sub sizeof { + my $self = shift; + my $type = shift; + $type = $self unless defined $type; + if(ref($type) =~ /Win32::API::Type/) { + return $self->{size}; + } else { + my $packing = packing($type); + if($packing =~ /(\w)\*(\d+)/) { + return $PackSize{ $1 } * $2; + } else { + return $PackSize{ $packing }; + } + } +} + +sub packing { + # DEBUG "(PM)Type::packing: called by ". join("::", (caller(1))[0,3]). "\n"; + my $self = shift; + my $is_pointer = 0; + if(ref($self) =~ /Win32::API::Type/) { + # DEBUG "(PM)Type::packing: got an object\n"; + return $self->{packing}; + } + my $type = ($self eq 'Win32::API::Type') ? shift : $self; + my $name = shift; + + # DEBUG "(PM)Type::packing: got '$type', '$name'\n"; + my($modifier, $size, $packing); + if(exists $Pointer{$type}) { + # DEBUG "(PM)Type::packing: got '$type', is really '$Pointer{$type}'\n"; + $type = $Pointer{$type}; + $is_pointer = 1; + } elsif($type =~ /(\w+)\s+(\w+)/) { + $modifier = $1; + $type = $2; + # DEBUG "(PM)packing: got modifier '$modifier', type '$type'\n"; + } + + $type =~ s/\*$//; + + if(exists $Known{$type}) { + if(defined $name and $name =~ s/\[(.*)\]$//) { + $size = $1; + $packing = $Known{$type}[0]."*".$size; + # DEBUG "(PM)Type::packing: composite packing: '$packing' '$size'\n"; + } else { + $packing = $Known{$type}; + if($is_pointer and $packing eq 'c') { + $packing = "p"; + } + # DEBUG "(PM)Type::packing: simple packing: '$packing'\n"; + } + if(defined $modifier and exists $Modifier{$modifier}->{$type}) { + # DEBUG "(PM)Type::packing: applying modifier '$modifier' -> '$Modifier{$modifier}->{$type}'\n"; + $packing = $Modifier{$modifier}->{$type}; + } + return $packing; + } else { + # DEBUG "(PM)Type::packing: NOT FOUND\n"; + return undef; + } +} + + +sub is_pointer { + my $self = shift; + my $type = shift; + $type = $self unless defined $type; + if(ref($type) =~ /Win32::API::Type/) { + return 1; + } else { + if($type =~ /\*$/) { + return 1; + } else { + return exists $Pointer{$type}; + } + } +} + +sub Pack { + my $type = $_[0]; + + if(packing($type) eq 'c' and is_pointer($type)) { + $_[1] = pack("Z*", $_[1]); + return $_[1]; + } + $_[1] = pack( packing($type), $_[1]); + return $_[1]; +} + +sub Unpack { + my $type = $_[0]; + if(packing($type) eq 'c' and is_pointer($type)) { + DEBUG "(PM)Type::Unpack: got packing 'c', is a pointer, unpacking 'Z*' '$_[1]'\n"; + $_[1] = unpack("Z*", $_[1]); + DEBUG "(PM)Type::Unpack: returning '$_[1]'\n"; + return $_[1]; + } + DEBUG "(PM)Type::Unpack: unpacking '".packing($type)."' '$_[1]'\n"; + $_[1] = unpack( packing($type), $_[1]); + DEBUG "(PM)Type::Unpack: returning '$_[1]'\n"; + return $_[1]; +} + +1; + +####################################################################### +# DOCUMENTATION +# + +=head1 NAME + +Win32::API::Type - C type support package for Win32::API + +=head1 SYNOPSIS + + use Win32::API; + + Win32::API::Type->typedef( 'my_number', 'LONG' ); + + +=head1 ABSTRACT + +This module is a support package for Win32::API that implements +C types for the import with prototype functionality. + +See L<Win32::API> for more info about its usage. + +=head1 DESCRIPTION + +This module is automatically imported by Win32::API, so you don't +need to 'use' it explicitly. These are the methods of this package: + +=over 4 + +=item C<typedef NAME, TYPE> + +This method defines a new type named C<NAME>. This actually just +creates an alias for the already-defined type C<TYPE>, which you +can use as a parameter in a Win32::API call. + +=item C<sizeof TYPE> + +This returns the size, in bytes, of C<TYPE>. Acts just like +the C function of the same name. + +=item C<is_known TYPE> + +Returns true if C<TYPE> is known by Win32::API::Type, false +otherwise. + +=back + +=head2 SUPPORTED TYPES + +This module should recognize all the types defined in the +Win32 Platform SDK header files. +Please see the source for this module, in the C<__DATA__> section, +for the full list. + +=head1 AUTHOR + +Aldo Calpini ( I<dada@perl.it> ). + +=head1 MAINTAINER + +Cosimo Streppone ( I<cosimo@cpan.org> ). + +=cut + + +__DATA__ + +[TYPE] +ATOM s +BOOL L +BOOLEAN c +BYTE C +CHAR c +COLORREF L +DWORD L +DWORD32 L +DWORD64 Q +FLOAT f +HACCEL L +HANDLE L +HBITMAP L +HBRUSH L +HCOLORSPACE L +HCONV L +HCONVLIST L +HCURSOR L +HDC L +HDDEDATA L +HDESK L +HDROP L +HDWP L +HENHMETAFILE L +HFILE L +HFONT L +HGDIOBJ L +HGLOBAL L +HHOOK L +HICON L +HIMC L +HINSTANCE L +HKEY L +HKL L +HLOCAL L +HMENU L +HMETAFILE L +HMODULE L +HPALETTE L +HPEN L +HRGN L +HRSRC L +HSZ L +HWINSTA L +HWND L +INT i +INT32 i +INT64 q +LANGID s +LCID L +LCSCSTYPE L +LCSGAMUTMATCH L +LCTYPE L +LONG l +LONG32 l +LONG64 q +LONGLONG q +LPARAM L +LRESULT L +REGSAM L +SC_HANDLE L +SC_LOCK L +SERVICE_STATUS_HANDLE L +SHORT s +SIZE_T L +SSIZE_T L +TBYTE c +TCHAR C +UCHAR C +UINT I +UINT_PTR L +UINT32 I +UINT64 Q +ULONG L +ULONG32 L +ULONG64 Q +ULONGLONG Q +USHORT S +WCHAR S +WORD S +WPARAM L +VOID c + +int i +long l +float f +double d +char c + +#CRITICAL_SECTION 24 -- a structure +#LUID ? 8 -- a structure +#VOID 0 +#CONST 4 +#FILE_SEGMENT_ELEMENT 8 -- a structure + +[PACKSIZE] +c 1 +C 1 +d 8 +f 4 +i 4 +I 4 +l 4 +L 4 +q 8 +Q 8 +s 2 +S 2 +p 4 + +[MODIFIER] +unsigned int=I long=L short=S char=C + +[POINTER] +INT_PTR INT +LPBOOL BOOL +LPBYTE BYTE +LPCOLORREF COLORREF +LPCSTR CHAR +#LPCTSTR CHAR or WCHAR +LPCTSTR CHAR +LPCVOID any +LPCWSTR WCHAR +LPDWORD DWORD +LPHANDLE HANDLE +LPINT INT +LPLONG LONG +LPSTR CHAR +#LPTSTR CHAR or WCHAR +LPTSTR CHAR +LPVOID VOID +LPWORD WORD +LPWSTR WCHAR + +PBOOL BOOL +PBOOLEAN BOOL +PBYTE BYTE +PCHAR CHAR +PCSTR CSTR +PCWCH CWCH +PCWSTR CWSTR +PDWORD DWORD +PFLOAT FLOAT +PHANDLE HANDLE +PHKEY HKEY +PINT INT +PLCID LCID +PLONG LONG +PSHORT SHORT +PSTR CHAR +#PTBYTE TBYTE -- +#PTCHAR TCHAR -- +#PTSTR CHAR or WCHAR +PTSTR CHAR +PUCHAR UCHAR +PUINT UINT +PULONG ULONG +PUSHORT USHORT +PVOID VOID +PWCHAR WCHAR +PWORD WORD +PWSTR WCHAR diff --git a/Master/tlpkg/installer/perllib/Win32/Env.pm b/Master/tlpkg/installer/perllib/Win32/Env.pm new file mode 100644 index 00000000000..c5420718175 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Win32/Env.pm @@ -0,0 +1,169 @@ +package Win32::Env; +our $VERSION='0.01'; + +=head1 NAME + +Win32::Env - get and set global system and user enviroment varialbes under Win32. + +=head1 VERSION + +Version 0.01 + +=head1 SYNOPSIS + + use Win32::Env; + + my $user_path=GetEnv(ENV_USER, 'PATH'); + # Limit PATH for other programs to system path and specified directory for 10 seconds + SetEnv(ENV_USER, 'PATH', 'C:\\Perl\\bin'); + BroadcastEnv(); + sleep(10); + # Restore everything back + SetEnv(ENV_USER, 'PATH', $user_path); + BroadcastEnv(); + +=cut + + +use warnings; +use strict; + +use Win32::TieRegistry(FixSzNulls=>1); + +use Exporter qw(import); +our @EXPORT=qw(SetEnv GetEnv BroadcastEnv ENV_USER ENV_SYSTEM); + +use constant ENV_USER =>0; +use constant ENV_SYSTEM =>1; + +use constant ENVKEY_USER => 'HKEY_CURRENT_USER\\Environment'; +use constant ENVKEY_SYSTEM => 'HKEY_LOCAL_MACHINE\\SYSTEM\\CurrentControlSet\\Control\\Session Manager\\Environment'; + +=head1 EXPORT + +SetEnv GetEnv BroadcastEnv ENV_USER ENV_SYSTEM + +=head1 FUNCTIONS + +=cut + +sub _NWA{ + my $lib=shift, + my @proto=@_; + require Win32::API; + return(new Win32::API($lib, @proto) or die "Can't import API $proto[0] from $lib: $^E\n"); +} + +# TODO: error/sanity checks for other args +sub _num_to_key($){ + my $sysusr=shift; + if($sysusr==ENV_USER) { $sysusr=ENVKEY_USER; } + elsif($sysusr==ENV_SYSTEM) { $sysusr=ENVKEY_SYSTEM; } + else { return; } # And Carp! + return $sysusr; +} + +=head2 SetEnv($sys_or_usr, $variable, $value) + +Sets variable in enviroment to specified value. C<$sys_or_usr> specifies either +current user's enviroment with exported constant C<ENV_USER> or system's global environment +with C<ENV_SYSTEM>. + +=cut + +sub SetEnv($$$){ + my ($sysusr, $var, $value)=@_; + $sysusr=(_num_to_key($sysusr) or return); + $Registry->{"$sysusr\\$var"}=$value; +} + +=head2 GetEnv($sys_or_usr, $variable) + +Returns value of enviroment variable. Its difference from plain C<$ENV{$variable}> is that +you can (and must) select current user's or system's global enviroment with C<$sys_or_usr>. +It is selected with same constants as in L<#SetEnv>. + +=cut + +sub GetEnv($$){ + my ($sysusr, $var, $value)=@_; + $sysusr=(_num_to_key($sysusr) or return); + return $Registry->{"$sysusr\\$var"}; +} + +=head2 BroadcastEnv() + +Broadcasts system message that enviroment has changed. This will make system processes responsible for +enviroment aware of change, otherwise your changes will be noticed only on next reboot. Note that most +user programs still won't see changes until next run and that your changes will not be available in C<%ENV> +to either your process or any processes you spawn. Assign to C<%ENV> yourself in addition to C<SetEnv> if +need it. + +=cut + +sub BroadcastEnv(){ + use constant HWND_BROADCAST => 0xffff; + use constant WM_SETTINGCHANGE => 0x001A; + print "Broadcasting \"Enviroment settings changed\" message...\n"; + # SendMessageTimeout(HWND_BROADCAST, WM_SETTINGCHANGE, 0, (LPARAM) "Environment", SMTO_ABORTIFHUNG, 5000, &dwReturnValue); + my $SendMessage=_NWA('user32', 'SendMessage', 'LLPP', 'L'); + $SendMessage->Call(HWND_BROADCAST, WM_SETTINGCHANGE, 0, 'Environment'); + print "Broadcast complete.\n"; +} + +1; + +=head1 AUTHOR + +Oleg "Rowaa[SR13]" V. Volkov, C<< <ROWAA at cpan.org> >> + +=head1 BUGS / TODO + +Only first argument to C<GetEnv>/C<SetEnv> is checked right now. Considering that functions work with +Windows registry, more sanity checks should be added to other arguments. + +Any limitations of Win32::TieRegistry apply to this module too, because it is used to write all +changes to the registry. + +Please report any bugs or feature requests to +C<bug-win32-env at rt.cpan.org>, or through the web interface at +L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Win32-Env>. +I will be notified, and then you'll automatically be notified of progress on +your bug as I make changes. + +=head1 SUPPORT + +You can find documentation for this module with the perldoc command. + + perldoc Win32::Env + +You can also look for information at: + +=over 4 + +=item * AnnoCPAN: Annotated CPAN documentation + +L<http://annocpan.org/dist/Win32-Env> + +=item * CPAN Ratings + +L<http://cpanratings.perl.org/d/Win32-Env> + +=item * RT: CPAN's request tracker + +L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Win32-Env> + +=item * Search CPAN + +L<http://search.cpan.org/dist/Win32-Env> + +=back + +=head1 COPYRIGHT & LICENSE + +Copyright 2006 Oleg "Rowaa[SR13]" V. Volkov, all rights reserved. + +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +=cut diff --git a/Master/tlpkg/installer/perllib/Win32/Registry.pm b/Master/tlpkg/installer/perllib/Win32/Registry.pm new file mode 100644 index 00000000000..c83fca5a3b1 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Win32/Registry.pm @@ -0,0 +1,547 @@ +package Win32::Registry; + +=head1 NAME + +Win32::Registry - accessing the Windows registry [obsolete, use Win32::TieRegistry] + +=head1 SYNOPSIS + + use Win32::Registry; + my $tips; + $::HKEY_LOCAL_MACHINE->Open("SOFTWARE\\Microsoft\\Windows" + ."\\CurrentVersion\\Explorer\\Tips", $tips) + or die "Can't open tips: $^E"; + my ($type, $value); + $tips->QueryValueEx("18", $type, $value) or die "No tip #18: $^E"; + print "Here's a tip: $value\n"; + +=head1 DESCRIPTION + + NOTE: This module provides a very klunky interface to access the + Windows registry, and is not currently being developed actively. It + only exists for backward compatibility with old code that uses it. + For more powerful and flexible ways to access the registry, use + Win32::TieRegistry. + +Win32::Registry provides an object oriented interface to the Windows +Registry. + +The following "root" registry objects are exported to the main:: name +space. Additional keys must be opened by calling the provided methods +on one of these. + + $HKEY_CLASSES_ROOT + $HKEY_CURRENT_USER + $HKEY_LOCAL_MACHINE + $HKEY_USERS + $HKEY_PERFORMANCE_DATA + $HKEY_CURRENT_CONFIG + $HKEY_DYN_DATA + +=cut + +use strict; +require Exporter; +require DynaLoader; +use Win32::WinError; + +require Win32 unless defined &Win32::GetLastError; + +use vars qw($VERSION $AUTOLOAD @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); + +$VERSION = '0.07'; + +@ISA = qw( Exporter DynaLoader ); +@EXPORT = qw( + HKEY_CLASSES_ROOT + HKEY_CURRENT_USER + HKEY_LOCAL_MACHINE + HKEY_PERFORMANCE_DATA + HKEY_CURRENT_CONFIG + HKEY_DYN_DATA + HKEY_USERS + KEY_ALL_ACCESS + KEY_CREATE_LINK + KEY_CREATE_SUB_KEY + KEY_ENUMERATE_SUB_KEYS + KEY_EXECUTE + KEY_NOTIFY + KEY_QUERY_VALUE + KEY_READ + KEY_SET_VALUE + KEY_WRITE + REG_BINARY + REG_CREATED_NEW_KEY + REG_DWORD + REG_DWORD_BIG_ENDIAN + REG_DWORD_LITTLE_ENDIAN + REG_EXPAND_SZ + REG_FULL_RESOURCE_DESCRIPTOR + REG_LEGAL_CHANGE_FILTER + REG_LEGAL_OPTION + REG_LINK + REG_MULTI_SZ + REG_NONE + REG_NOTIFY_CHANGE_ATTRIBUTES + REG_NOTIFY_CHANGE_LAST_SET + REG_NOTIFY_CHANGE_NAME + REG_NOTIFY_CHANGE_SECURITY + REG_OPENED_EXISTING_KEY + REG_OPTION_BACKUP_RESTORE + REG_OPTION_CREATE_LINK + REG_OPTION_NON_VOLATILE + REG_OPTION_RESERVED + REG_OPTION_VOLATILE + REG_REFRESH_HIVE + REG_RESOURCE_LIST + REG_RESOURCE_REQUIREMENTS_LIST + REG_SZ + REG_WHOLE_HIVE_VOLATILE +); + +@EXPORT_OK = qw( + RegCloseKey + RegConnectRegistry + RegCreateKey + RegCreateKeyEx + RegDeleteKey + RegDeleteValue + RegEnumKey + RegEnumValue + RegFlushKey + RegGetKeySecurity + RegLoadKey + RegNotifyChangeKeyValue + RegOpenKey + RegOpenKeyEx + RegQueryInfoKey + RegQueryValue + RegQueryValueEx + RegReplaceKey + RegRestoreKey + RegSaveKey + RegSetKeySecurity + RegSetValue + RegSetValueEx + RegUnLoadKey +); +$EXPORT_TAGS{ALL}= \@EXPORT_OK; + +bootstrap Win32::Registry; + +sub import { + my $pkg = shift; + if ($_[0] && "Win32" eq $_[0]) { + Exporter::export($pkg, "Win32", @EXPORT_OK); + shift; + } + Win32::Registry->export_to_level(1+$Exporter::ExportLevel, $pkg, @_); +} + +####################################################################### +# This AUTOLOAD is used to 'autoload' constants from the constant() +# XS function. If a constant is not found then control is passed +# to the AUTOLOAD in AutoLoader. + +sub AUTOLOAD { + my($constname); + ($constname = $AUTOLOAD) =~ s/.*:://; + #reset $! to zero to reset any current errors. + local $! = 0; + my $val = constant($constname, 0); + if ($! != 0) { + if ($! =~ /Invalid/) { + $AutoLoader::AUTOLOAD = $AUTOLOAD; + goto &AutoLoader::AUTOLOAD; + } + else { + my ($pack,$file,$line) = caller; + die "Unknown constant $constname in Win32::Registry " + . "at $file line $line.\n"; + } + } + eval "sub $AUTOLOAD { $val }"; + goto &$AUTOLOAD; +} + +####################################################################### +# _new is a private constructor, not intended for public use. +# + +sub _new { + my $self; + if ($_[0]) { + $self->{'handle'} = $_[0]; + bless $self; + } + $self; +} + +#define the basic registry objects to be exported. +#these had to be hardwired unfortunately. +# XXX Yuck! + +{ + package main; + use vars qw( + $HKEY_CLASSES_ROOT + $HKEY_CURRENT_USER + $HKEY_LOCAL_MACHINE + $HKEY_USERS + $HKEY_PERFORMANCE_DATA + $HKEY_CURRENT_CONFIG + $HKEY_DYN_DATA + ); +} + +$::HKEY_CLASSES_ROOT = _new(&HKEY_CLASSES_ROOT); +$::HKEY_CURRENT_USER = _new(&HKEY_CURRENT_USER); +$::HKEY_LOCAL_MACHINE = _new(&HKEY_LOCAL_MACHINE); +$::HKEY_USERS = _new(&HKEY_USERS); +$::HKEY_PERFORMANCE_DATA = _new(&HKEY_PERFORMANCE_DATA); +$::HKEY_CURRENT_CONFIG = _new(&HKEY_CURRENT_CONFIG); +$::HKEY_DYN_DATA = _new(&HKEY_DYN_DATA); + +=head2 Methods + +The following methods are supported. Note that subkeys can be +specified as a path name, separated by backslashes (which may +need to be doubled if you put them in double quotes). + +=over 8 + +=item Open + + $reg_obj->Open($sub_key_name, $sub_reg_obj); + +Opens a subkey of a registry object, returning the new registry object +in $sub_reg_obj. + +=cut + +sub Open { + my $self = shift; + die 'usage: $obj->Open($sub_key_name, $sub_reg_obj)' if @_ != 2; + + my ($subkey) = @_; + my ($result,$subhandle); + + $result = RegOpenKey($self->{'handle'},$subkey,$subhandle); + $_[1] = _new($subhandle); + + return 0 unless $_[1]; + $! = Win32::GetLastError() unless $result; + return $result; +} + +=item Close + + $reg_obj->Close(); + +Closes an open registry key. + +=cut + +sub Close { + my $self = shift; + die 'usage: $obj->Close()' if @_ != 0; + + return unless exists $self->{'handle'}; + my $result = RegCloseKey($self->{'handle'}); + if ($result) { + delete $self->{'handle'}; + } + else { + $! = Win32::GetLastError(); + } + return $result; +} + +sub DESTROY { + my $self = shift; + return unless exists $self->{'handle'}; + RegCloseKey($self->{'handle'}); + delete $self->{'handle'}; +} + + +=item Connect + + $reg_obj->Connect($node_name, $new_reg_obj); + +Connects to a remote Registry on the node specified by $node_name, +returning it in $new_reg_obj. Returns false if it fails. + +=cut + +sub Connect { + my $self = shift; + die 'usage: $obj->Connect($node_name, $new_reg_obj)' if @_ != 2; + + my ($node) = @_; + my ($result,$subhandle); + + $result = RegConnectRegistry ($node, $self->{'handle'}, $subhandle); + $_[1] = _new($subhandle); + + return 0 unless $_[1]; + $! = Win32::GetLastError() unless $result; + return $result; +} + +=item Create + + $reg_obj->Create($sub_key_name, $new_reg_obj); + +Opens the subkey specified by $sub_key_name, returning the new registry +object in $new_reg_obj. If the specified subkey doesn't exist, it is +created. + +=cut + +sub Create { + my $self = shift; + die 'usage: $obj->Create($sub_key_name, $new_reg_obj)' if @_ != 2; + + my ($subkey) = @_; + my ($result,$subhandle); + + $result = RegCreateKey($self->{'handle'},$subkey,$subhandle); + $_[1] = _new ($subhandle); + + return 0 unless $_[1]; + $! = Win32::GetLastError() unless $result; + return $result; +} + +=item SetValue + + $reg_obj->SetValue($sub_key_name, $type, $value); + +Sets the default value for a subkey specified by $sub_key_name. + +=cut + +sub SetValue { + my $self = shift; + die 'usage: $obj->SetValue($subkey, $type, $value)' if @_ != 3; + my $result = RegSetValue($self->{'handle'}, @_); + $! = Win32::GetLastError() unless $result; + return $result; +} + +=item SetValueEx + + $reg_obj->SetValueEx($value_name, $reserved, $type, $value); + +Sets the value for the value name identified by $value_name +in the key specified by $reg_obj. + +=cut + +sub SetValueEx { + my $self = shift; + die 'usage: $obj->SetValueEx($value_name, $reserved, $type, $value)' if @_ != 4; + my $result = RegSetValueEx($self->{'handle'}, @_); + $! = Win32::GetLastError() unless $result; + return $result; +} + +=item QueryValue + + $reg_obj->QueryValue($sub_key_name, $value); + +Gets the default value of the subkey specified by $sub_key_name. + +=cut + +sub QueryValue { + my $self = shift; + die 'usage: $obj->QueryValue($sub_key_name, $value)' if @_ != 2; + my $result = RegQueryValue($self->{'handle'}, $_[0], $_[1]); + $! = Win32::GetLastError() unless $result; + return $result; +} + +=item QueryKey + + $reg_obj->QueryKey($classref, $number_of_subkeys, $number_of_values); + +Gets information on a key specified by $reg_obj. + +=cut + +sub QueryKey { + my $garbage; + my $self = shift; + die 'usage: $obj->QueryKey($classref, $number_of_subkeys, $number_of_values)' + if @_ != 3; + + my $result = RegQueryInfoKey($self->{'handle'}, $_[0], + $garbage, $garbage, $_[1], + $garbage, $garbage, $_[2], + $garbage, $garbage, $garbage, $garbage); + + $! = Win32::GetLastError() unless $result; + return $result; +} + +=item QueryValueEx + + $reg_obj->QueryValueEx($value_name, $type, $value); + +Gets the value for the value name identified by $value_name +in the key specified by $reg_obj. + +=cut + +sub QueryValueEx { + my $self = shift; + die 'usage: $obj->QueryValueEx($value_name, $type, $value)' if @_ != 3; + my $result = RegQueryValueEx($self->{'handle'}, $_[0], undef, $_[1], $_[2]); + $! = Win32::GetLastError() unless $result; + return $result; +} + +=item GetKeys + + my @keys; + $reg_obj->GetKeys(\@keys); + +Populates the supplied array reference with the names of all the keys +within the registry object $reg_obj. + +=cut + +sub GetKeys { + my $self = shift; + die 'usage: $obj->GetKeys($arrayref)' if @_ != 1 or ref($_[0]) ne 'ARRAY'; + + my ($result, $i, $keyname); + $keyname = "DummyVal"; + $i = 0; + $result = 1; + + while ( $result ) { + $result = RegEnumKey( $self->{'handle'},$i++, $keyname ); + if ($result) { + push( @{$_[0]}, $keyname ); + } + } + return(1); +} + +=item GetValues + + my %values; + $reg_obj->GetValues(\%values); + +Populates the supplied hash reference with entries of the form + + $value_name => [ $value_name, $type, $data ] + +for each value in the registry object $reg_obj. + +=cut + +sub GetValues { + my $self = shift; + die 'usage: $obj->GetValues($hashref)' if @_ != 1; + + my ($result,$name,$type,$data,$i); + $name = "DummyVal"; + $i = 0; + while ( $result=RegEnumValue( $self->{'handle'}, + $i++, + $name, + undef, + $type, + $data )) + { + $_[0]->{$name} = [ $name, $type, $data ]; + } + return(1); +} + +=item DeleteKey + + $reg_obj->DeleteKey($sub_key_name); + +Deletes a subkey specified by $sub_key_name from the registry. + +=cut + +sub DeleteKey { + my $self = shift; + die 'usage: $obj->DeleteKey($sub_key_name)' if @_ != 1; + my $result = RegDeleteKey($self->{'handle'}, @_); + $! = Win32::GetLastError() unless $result; + return $result; +} + +=item DeleteValue + + $reg_obj->DeleteValue($value_name); + +Deletes a value identified by $value_name from the registry. + +=cut + +sub DeleteValue { + my $self = shift; + die 'usage: $obj->DeleteValue($value_name)' if @_ != 1; + my $result = RegDeleteValue($self->{'handle'}, @_); + $! = Win32::GetLastError() unless $result; + return $result; +} + +=item Save + + $reg_obj->Save($filename); + +Saves the hive specified by $reg_obj to a file. + +=cut + +sub Save { + my $self = shift; + die 'usage: $obj->Save($filename)' if @_ != 1; + my $result = RegSaveKey($self->{'handle'}, @_); + $! = Win32::GetLastError() unless $result; + return $result; +} + +=item Load + + $reg_obj->Load($sub_key_name, $file_name); + +Loads a key specified by $sub_key_name from a file. + +=cut + +sub Load { + my $self = shift; + die 'usage: $obj->Load($sub_key_name, $file_name)' if @_ != 2; + my $result = RegLoadKey($self->{'handle'}, @_); + $! = Win32::GetLastError() unless $result; + return $result; +} + +=item UnLoad + + $reg_obj->Unload($sub_key_name); + +Unloads a registry hive. + +=cut + +sub UnLoad { + my $self = shift; + die 'usage: $obj->UnLoad($sub_key_name)' if @_ != 1; + my $result = RegUnLoadKey($self->{'handle'}, @_); + $! = Win32::GetLastError() unless $result; + return $result; +} + +1; +__END__ diff --git a/Master/tlpkg/installer/perllib/Win32/TieRegistry.pm b/Master/tlpkg/installer/perllib/Win32/TieRegistry.pm new file mode 100644 index 00000000000..0abbbddb6b8 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Win32/TieRegistry.pm @@ -0,0 +1,3801 @@ +# Win32/TieRegistry.pm -- Perl module to easily use a Registry +# (on Win32 systems so far). +# by Tye McQueen, tye@metronet.com, see http://www.metronet.com/~tye/. + +# +# Skip to "=head" line for user documentation. +# + + +package Win32::TieRegistry; + + +use strict; +use vars qw( $PACK $VERSION @ISA @EXPORT @EXPORT_OK ); + +$PACK= "Win32::TieRegistry"; # Used in error messages. +$VERSION= '0.26'; + + +use Carp; + +require Tie::Hash; +@ISA= qw(Tie::Hash); + +# Required other modules: +use Win32API::Registry 0.12 qw( :KEY_ :HKEY_ :REG_ ); + +#Optional other modules: +use vars qw( $_NoMoreItems $_FileNotFound $_TooSmall $_MoreData $_SetDualVar ); + +if( eval { require Win32::WinError } ) { + $_NoMoreItems= Win32::WinError::constant("ERROR_NO_MORE_ITEMS",0); + $_FileNotFound= Win32::WinError::constant("ERROR_FILE_NOT_FOUND",0); + $_TooSmall= Win32::WinError::constant("ERROR_INSUFFICIENT_BUFFER",0); + $_MoreData= Win32::WinError::constant("ERROR_MORE_DATA",0); +} else { + $_NoMoreItems= "^No more data"; + $_FileNotFound= "cannot find the file"; + $_TooSmall= " data area passed to "; + $_MoreData= "^more data is avail"; +} +if( $_SetDualVar= eval { require SetDualVar } ) { + import SetDualVar; +} + + +#Implementation details: +# When opened: +# HANDLE long; actual handle value +# MACHINE string; name of remote machine ("" if local) +# PATH list ref; machine-relative full path for this key: +# ["LMachine","System","Disk"] +# ["HKEY_LOCAL_MACHINE","System","Disk"] +# DELIM char; delimiter used to separate subkeys (def="\\") +# OS_DELIM char; always "\\" for Win32 +# ACCESS long; usually KEY_ALL_ACCESS, perhaps KEY_READ, etc. +# ROOTS string; var name for "Lmachine"->HKEY_LOCAL_MACHINE map +# FLAGS int; bits to control certain options +# Often: +# VALUES ref to list of value names (data/type never cached) +# SUBKEYS ref to list of subkey names +# SUBCLASSES ref to list of subkey classes +# SUBTIMES ref to list of subkey write times +# MEMBERS ref to list of subkey_name.DELIM's, DELIM.value_name's +# MEMBHASH hash ref to with MEMBERS as keys and 1's as values +# Once Key "Info" requested: +# Class CntSubKeys CntValues MaxSubKeyLen MaxSubClassLen +# MaxValNameLen MaxValDataLen SecurityLen LastWrite +# If is tied to a hash and iterating over key values: +# PREVIDX int; index of last MEMBERS element return +# If is the key object returned by Load(): +# UNLOADME list ref; information about Load()ed key +# If is a subkey of a "loaded" key other than the one returned by Load(): +# DEPENDON obj ref; object that can't be destroyed before us + + +#Package-local variables: + +# Option flag bits: +use vars qw( $Flag_ArrVal $Flag_TieVal $Flag_DualTyp $Flag_DualBin + $Flag_FastDel $Flag_HexDWord $Flag_Split $Flag_FixNulls ); +$Flag_ArrVal= 0x0001; +$Flag_TieVal= 0x0002; +$Flag_FastDel= 0x0004; +$Flag_HexDWord= 0x0008; +$Flag_Split= 0x0010; +$Flag_DualTyp= 0x0020; +$Flag_DualBin= 0x0040; +$Flag_FixNulls= 0x0080; + + +use vars qw( $RegObj %_Roots %RegHash $Registry ); + +# Short-hand for HKEY_* constants: +%_Roots= ( + "Classes" => HKEY_CLASSES_ROOT, + "CUser" => HKEY_CURRENT_USER, + "LMachine" => HKEY_LOCAL_MACHINE, + "Users" => HKEY_USERS, + "PerfData" => HKEY_PERFORMANCE_DATA, # Too picky to be useful + "CConfig" => HKEY_CURRENT_CONFIG, + "DynData" => HKEY_DYN_DATA, # Too picky to be useful +); + +# Basic master Registry object: +$RegObj= {}; +@$RegObj{qw( HANDLE MACHINE PATH DELIM OS_DELIM ACCESS FLAGS ROOTS )}= ( + "NONE", "", [], "\\", "\\", + KEY_READ|KEY_WRITE, $Flag_HexDWord|$Flag_FixNulls, "${PACK}::_Roots" ); +$RegObj->{FLAGS} |= $Flag_DualTyp|$Flag_DualBin if $_SetDualVar; +bless $RegObj; + +# Fill cache for master Registry object: +@$RegObj{qw( VALUES SUBKEYS SUBCLASSES SUBTIMES )}= ( + [], [ keys(%_Roots) ], [], [] ); +grep( s#$#$RegObj->{DELIM}#, + @{ $RegObj->{MEMBERS}= [ @{$RegObj->{SUBKEYS}} ] } ); +@$RegObj{qw( Class MaxSubKeyLen MaxSubClassLen MaxValNameLen + MaxValDataLen SecurityLen LastWrite CntSubKeys CntValues )}= + ( "", 0, 0, 0, 0, 0, 0, 0, 0 ); + +# Create master Registry tied hash: +$RegObj->Tie( \%RegHash ); + +# Create master Registry combination object and tied hash reference: +$Registry= \%RegHash; +bless $Registry; + + +# Preloaded methods go here. + + +# Map option names to name of subroutine that controls that option: +use vars qw( @_opt_subs %_opt_subs ); +@_opt_subs= qw( Delimiter ArrayValues TieValues SplitMultis DWordsToHex + FastDelete FixSzNulls DualTypes DualBinVals AllowLoad AllowSave ); +@_opt_subs{@_opt_subs}= @_opt_subs; + +sub import +{ + my $pkg= shift(@_); + my $level= $Exporter::ExportLevel; + my $expto= caller($level); + my @export= (); + my @consts= (); + my $registry= $Registry->Clone; + local( $_ ); + while( @_ ) { + $_= shift(@_); + if( /^\$(\w+::)*\w+$/ ) { + push( @export, "ObjVar" ) if /^\$RegObj$/; + push( @export, $_ ); + } elsif( /^\%(\w+::)*\w+$/ ) { + push( @export, $_ ); + } elsif( /^[$%]/ ) { + croak "${PACK}->import: Invalid variable name ($_)"; + } elsif( /^:/ || /^(H?KEY|REG)_/ ) { + push( @consts, $_ ); + } elsif( ! @_ ) { + croak "${PACK}->import: Missing argument after option ($_)"; + } elsif( exists $_opt_subs{$_} ) { + $_= $_opt_subs{$_}; + $registry->$_( shift(@_) ); + } elsif( /^TiedRef$/ ) { + $_= shift(@_); + if( ! ref($_) && /^(\$?)(\w+::)*\w+$/ ) { + $_= '$'.$_ unless '$' eq $1; + } elsif( "SCALAR" ne ref($_) ) { + croak "${PACK}->import: Invalid var after TiedRef ($_)"; + } + push( @export, $_ ); + } elsif( /^TiedHash$/ ) { + $_= shift(@_); + if( ! ref($_) && /^(\%?)(\w+::)*\w+$/ ) { + $_= '%'.$_ unless '%' eq $1; + } elsif( "HASH" ne ref($_) ) { + croak "${PACK}->import: Invalid var after TiedHash ($_)"; + } + push( @export, $_ ); + } elsif( /^ObjectRef$/ ) { + $_= shift(@_); + if( ! ref($_) && /^(\$?)(\w+::)*\w+$/ ) { + push( @export, "ObjVar" ); + $_= '$'.$_ unless '$' eq $1; + } elsif( "SCALAR" eq ref($_) ) { + push( @export, "ObjRef" ); + } else { + croak "${PACK}->import: Invalid var after ObjectRef ($_)"; + } + push( @export, $_ ); + } elsif( /^ExportLevel$/ ) { + $level= shift(@_); + $expto= caller($level); + } elsif( /^ExportTo$/ ) { + undef $level; + $expto= caller($level); + } else { + croak "${PACK}->import: Invalid option ($_)"; + } + } + Win32API::Registry->export( $expto, @consts ) if @consts; + @export= ('$Registry') unless @export; + while( @export ) { + $_= shift( @export ); + if( /^\$((?:\w+::)*)(\w+)$/ ) { + my( $pack, $sym )= ( $1, $2 ); + $pack= $expto unless defined($pack) && "" ne $pack; + no strict 'refs'; + *{"${pack}::$sym"}= \${"${pack}::$sym"}; + ${"${pack}::$sym"}= $registry; + } elsif( /^\%((?:\w+::)*)(\w+)$/ ) { + my( $pack, $sym )= ( $1, $2 ); + $pack= $expto unless defined($pack) && "" ne $pack; + no strict 'refs'; + *{"${pack}::$sym"}= \%{"${pack}::$sym"}; + $registry->Tie( \%{"${pack}::$sym"} ); + } elsif( "SCALAR" eq ref($_) ) { + $$_= $registry; + } elsif( "HASH" eq ref($_) ) { + $registry->Tie( $_ ); + } elsif( /^ObjVar$/ ) { + $_= shift( @_ ); + /^\$((?:\w+::)*)(\w+)$/; + my( $pack, $sym )= ( $1, $2 ); + $pack= $expto unless defined($pack) && "" ne $pack; + no strict 'refs'; + *{"${pack}::$sym"}= \${"${pack}::$sym"}; + ${"${pack}::$sym"}= $registry->ObjectRef; + } elsif( /^ObjRef$/ ) { + ${shift(@_)}= $registry->ObjectRef; + } else { + die "Impossible var to export ($_)"; + } + } +} + + +use vars qw( @_new_Opts %_new_Opts ); +@_new_Opts= qw( ACCESS DELIM MACHINE DEPENDON ); +@_new_Opts{@_new_Opts}= (1) x @_new_Opts; + +sub _new +{ + my $this= shift( @_ ); + $this= tied(%$this) if ref($this) && tied(%$this); + my $class= ref($this) || $this; + my $self= {}; + my( $handle, $rpath, $opts )= @_; + if( @_ < 2 || "ARRAY" ne ref($rpath) || 3 < @_ + || 3 == @_ && "HASH" ne ref($opts) ) { + croak "Usage: ${PACK}->_new( \$handle, \\\@path, {OPT=>VAL,...} );\n", + " options: @_new_Opts\nCalled"; + } + @$self{qw( HANDLE PATH )}= ( $handle, $rpath ); + @$self{qw( MACHINE ACCESS DELIM OS_DELIM ROOTS FLAGS )}= + ( $this->Machine, $this->Access, $this->Delimiter, + $this->OS_Delimiter, $this->_Roots, $this->_Flags ); + if( ref($opts) ) { + my @err= grep( ! $_new_Opts{$_}, keys(%$opts) ); + @err and croak "${PACK}->_new: Invalid options (@err)"; + @$self{ keys(%$opts) }= values(%$opts); + } + bless $self, $class; + return $self; +} + + +sub _split +{ + my $self= shift( @_ ); + $self= tied(%$self) if tied(%$self); + my $path= shift( @_ ); + my $delim= @_ ? shift(@_) : $self->Delimiter; + my $list= [ split( /\Q$delim/, $path ) ]; + return $list; +} + + +sub _rootKey +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + my $keyPath= shift(@_); + my $delim= @_ ? shift(@_) : $self->Delimiter; + my( $root, $subPath ); + if( "ARRAY" eq ref($keyPath) ) { + $subPath= $keyPath; + } else { + $subPath= $self->_split( $keyPath, $delim ); + } + $root= shift( @$subPath ); + if( $root =~ /^HKEY_/ ) { + my $handle= Win32API::Registry::constant($root,0); + $handle or croak "Invalid HKEY_ constant ($root): $!"; + return( $self->_new( $handle, [$root], {DELIM=>$delim} ), + $subPath ); + } elsif( $root =~ /^([-+]|0x)?\d/ ) { + return( $self->_new( $root, [sprintf("0x%lX",$root)], + {DELIM=>$delim} ), + $subPath ); + } else { + my $roots= $self->Roots; + if( $roots->{$root} ) { + return( $self->_new( $roots->{$root}, [$root], {DELIM=>$delim} ), + $subPath ); + } + croak "No such root key ($root)"; + } +} + + +sub _open +{ + my $this= shift(@_); + $this= tied(%$this) if ref($this) && tied(%$this); + my $subPath= shift(@_); + my $sam= @_ ? shift(@_) : $this->Access; + my $subKey= join( $this->OS_Delimiter, @$subPath ); + my $handle= 0; + $this->RegOpenKeyEx( $subKey, 0, $sam, $handle ) + or return (); + return $this->_new( $handle, [ @{$this->_Path}, @$subPath ], + { ACCESS=>$sam, ( defined($this->{UNLOADME}) ? ("DEPENDON",$this) + : defined($this->{DEPENDON}) ? ("DEPENDON",$this->{DEPENDON}) : () ) + } ); +} + + +sub ObjectRef +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + return $self; +} + + +sub _constant +{ + my( $name, $desc )= @_; + my $value= Win32API::Registry::constant( $name, 0 ); + my $func= (caller(1))[3]; + if( 0 == $value ) { + if( $! =~ /invalid/i ) { + croak "$func: Invalid $desc ($name)"; + } elsif( 0 != $! ) { + croak "$func: \u$desc ($name) not support on this platform"; + } + } + return $value; +} + + +sub _connect +{ + my $this= shift(@_); + $this= tied(%$this) if ref($this) && tied(%$this); + my $subPath= pop(@_); + $subPath= $this->_split( $subPath ) unless ref($subPath); + my $machine= @_ ? shift(@_) : shift(@$subPath); + my $handle= 0; + my( $temp )= $this->_rootKey( [@$subPath] ); + $temp->RegConnectRegistry( $machine, $temp->Handle, $handle ) + or return (); + my $self= $this->_new( $handle, [shift(@$subPath)], {MACHINE=>$machine} ); + return( $self, $subPath ); +} + + +use vars qw( @Connect_Opts %Connect_Opts ); +@Connect_Opts= qw(Access Delimiter); +@Connect_Opts{@Connect_Opts}= (1) x @Connect_Opts; + +sub Connect +{ + my $this= shift(@_); + my $tied= ref($this) && tied(%$this); + $this= tied(%$this) if $tied; + my( $machine, $key, $opts )= @_; + my $delim= ""; + my $sam; + my $subPath; + if( @_ < 2 || 3 < @_ + || 3 == @_ && "HASH" ne ref($opts) ) { + croak "Usage: \$obj= ${PACK}->Connect(", + " \$Machine, \$subKey, { OPT=>VAL,... } );\n", + " options: @Connect_Opts\nCalled"; + } + if( ref($opts) ) { + my @err= grep( ! $Connect_Opts{$_}, keys(%$opts) ); + @err and croak "${PACK}->Connect: Invalid options (@err)"; + } + $delim= "$opts->{Delimiter}" if defined($opts->{Delimiter}); + $delim= $this->Delimiter if "" eq $delim; + $sam= defined($opts->{Access}) ? $opts->{Access} : $this->Access; + $sam= _constant($sam,"key access type") if $sam =~ /^KEY_/; + ( $this, $subPath )= $this->_connect( $machine, $key ); + return () unless defined($this); + my $self= $this->_open( $subPath, $sam ); + return () unless defined($self); + $self->Delimiter( $delim ); + $self= $self->TiedRef if $tied; + return $self; +} + + +my @_newVirtual_keys= qw( MEMBERS VALUES SUBKEYS SUBTIMES SUBCLASSES + Class SecurityLen LastWrite CntValues CntSubKeys + MaxValNameLen MaxValDataLen MaxSubKeyLen MaxSubClassLen ); + +sub _newVirtual +{ + my $self= shift(@_); + my( $rPath, $root, $opts )= @_; + my $new= $self->_new( "NONE", $rPath, $opts ) + or return (); + @{$new}{@_newVirtual_keys}= @{$root->ObjectRef}{@_newVirtual_keys}; + return $new; +} + + +#$key= new Win32::TieRegistry "LMachine/System/Disk"; +#$key= new Win32::TieRegistry "//Server1/LMachine/System/Disk"; +#Win32::TieRegistry->new( HKEY_LOCAL_MACHINE, {DELIM=>"/",ACCESS=>KEY_READ} ); +#Win32::TieRegistry->new( [ HKEY_LOCAL_MACHINE, ".../..." ], {DELIM=>$DELIM} ); +#$key->new( ... ); + +use vars qw( @new_Opts %new_Opts ); +@new_Opts= qw(Access Delimiter); +@new_Opts{@new_Opts}= (1) x @new_Opts; + +sub new +{ + my $this= shift( @_ ); + $this= tied(%$this) if ref($this) && tied(%$this); + if( ! ref($this) ) { + no strict "refs"; + my $self= ${"${this}::Registry"}; + croak "${this}->new failed since ${PACK}::new sees that ", + "\$${this}::Registry is not an object." + if ! ref($self); + $this= $self->Clone; + } + my( $subKey, $opts )= @_; + my $delim= ""; + my $dlen; + my $sam; + my $subPath; + if( @_ < 1 || 2 < @_ + || 2 == @_ && "HASH" ne ref($opts) ) { + croak "Usage: \$obj= ${PACK}->new( \$subKey, { OPT=>VAL,... } );\n", + " options: @new_Opts\nCalled"; + } + if( defined($opts) ) { + my @err= grep( ! $new_Opts{$_}, keys(%$opts) ); + @err and die "${PACK}->new: Invalid options (@err)"; + } + $delim= "$opts->{Delimiter}" if defined($opts->{Delimiter}); + $delim= $this->Delimiter if "" eq $delim; + $dlen= length($delim); + $sam= defined($opts->{Access}) ? $opts->{Access} : $this->Access; + $sam= _constant($sam,"key access type") if $sam =~ /^KEY_/; + if( "ARRAY" eq ref($subKey) ) { + $subPath= $subKey; + if( "NONE" eq $this->Handle && @$subPath ) { + ( $this, $subPath )= $this->_rootKey( $subPath ); + } + } elsif( $delim x 2 eq substr($subKey,0,2*$dlen) ) { + my $path= $this->_split( substr($subKey,2*$dlen), $delim ); + my $mach= shift(@$path); + if( ! @$path ) { + return $this->_newVirtual( $path, $Registry, + {MACHINE=>$mach,DELIM=>$delim,ACCESS=>$sam} ); + } + ( $this, $subPath )= $this->_connect( $mach, $path ); + return () if ! defined($this); + if( 0 == @$subPath ) { + $this->Delimiter( $delim ); + return $this; + } + } elsif( $delim eq substr($subKey,0,$dlen) ) { + ( $this, $subPath )= $this->_rootKey( substr($subKey,$dlen), $delim ); + } elsif( "NONE" eq $this->Handle && "" ne $subKey ) { + my( $mach )= $this->Machine; + if( $mach ) { + ( $this, $subPath )= $this->_connect( $mach, $subKey ); + } else { + ( $this, $subPath )= $this->_rootKey( $subKey, $delim ); + } + } else { + $subPath= $this->_split( $subKey, $delim ); + } + return () unless defined($this); + if( 0 == @$subPath && "NONE" eq $this->Handle ) { + return $this->_newVirtual( $this->_Path, $this, + { DELIM=>$delim, ACCESS=>$sam } ); + } + my $self= $this->_open( $subPath, $sam ); + return () unless defined($self); + $self->Delimiter( $delim ); + return $self; +} + + +sub Open +{ + my $self= shift(@_); + my $tied= ref($self) && tied(%$self); + $self= tied(%$self) if $tied; + $self= $self->new( @_ ); + $self= $self->TiedRef if defined($self) && $tied; + return $self; +} + + +sub Clone +{ + my $self= shift( @_ ); + my $new= $self->Open(""); + return $new; +} + + +{ my @flush; + sub Flush + { + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + my( $flush )= shift(@_); + @_ and croak "Usage: \$key->Flush( \$bFlush );"; + return 0 if "NONE" eq $self->Handle; + @flush= qw( VALUES SUBKEYS SUBCLASSES SUBTIMES MEMBERS Class + CntSubKeys CntValues MaxSubKeyLen MaxSubClassLen + MaxValNameLen MaxValDataLen SecurityLen LastWrite PREVIDX ) + unless @flush; + delete( @$self{@flush} ); + if( defined($flush) && $flush ) { + return $self->RegFlushKey(); + } else { + return 1; + } + } +} + + +sub _DualVal +{ + my( $hRef, $num )= @_; + if( $_SetDualVar && $$hRef{$num} ) { + &SetDualVar( $num, "$$hRef{$num}", 0+$num ); + } + return $num; +} + + +use vars qw( @_RegDataTypes %_RegDataTypes ); +@_RegDataTypes= qw( REG_SZ REG_EXPAND_SZ REG_BINARY REG_LINK REG_MULTI_SZ + REG_DWORD_LITTLE_ENDIAN REG_DWORD_BIG_ENDIAN REG_DWORD + REG_RESOURCE_LIST REG_FULL_RESOURCE_DESCRIPTOR + REG_RESOURCE_REQUIREMENTS_LIST REG_NONE ); +# Make sure that REG_DWORD appears _after_ other REG_DWORD_* +# items above and that REG_NONE appears _last_. +foreach( @_RegDataTypes ) { + $_RegDataTypes{Win32API::Registry::constant($_,0)}= $_; +} + +sub GetValue +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + 1 == @_ or croak "Usage: (\$data,\$type)= \$key->GetValue('ValName');"; + my( $valName )= @_; + my( $valType, $valData, $dLen )= (0,"",0); + return () if "NONE" eq $self->Handle; + $self->RegQueryValueEx( $valName, [], $valType, $valData, + $dLen= ( defined($self->{MaxValDataLen}) ? $self->{MaxValDataLen} : 0 ) + ) or return (); + if( REG_DWORD == $valType ) { + my $val= unpack("L",$valData); + $valData= sprintf "0x%08.8lX", $val if $self->DWordsToHex; + &SetDualVar( $valData, $valData, $val ) if $self->DualBinVals + } elsif( REG_BINARY == $valType && length($valData) <= 4 ) { + &SetDualVar( $valData, $valData, hex reverse unpack("h*",$valData) ) + if $self->DualBinVals; + } elsif( ( REG_SZ == $valType || REG_EXPAND_SZ == $valType ) + && $self->FixSzNulls ) { + substr($valData,-1)= "" if "\0" eq substr($valData,-1); + } elsif( REG_MULTI_SZ == $valType && $self->SplitMultis ) { + ## $valData =~ s/\0\0$//; # Why does this often fail?? + substr($valData,-2)= "" if "\0\0" eq substr($valData,-2); + $valData= [ split( /\0/, $valData, -1 ) ] + } + if( ! wantarray ) { + return $valData; + } elsif( ! $self->DualTypes ) { + return( $valData, $valType ); + } else { + return( $valData, _DualVal( \%_RegDataTypes, $valType ) ); + } +} + + +sub _ErrNum +{ + # return $^E; + return Win32::GetLastError(); +} + + +sub _ErrMsg +{ + # return $^E; + return Win32::FormatMessage( Win32::GetLastError() ); +} + +sub _Err +{ + my $err; + # return $^E; + return _ErrMsg if ! $_SetDualVar; + return &SetDualVar( $err, _ErrMsg, _ErrNum ); +} + +sub _NoMoreItems +{ + return + $_NoMoreItems =~ /^\d/ + ? _ErrNum == $_NoMoreItems + : _ErrMsg =~ /$_NoMoreItems/io; +} + + +sub _FileNotFound +{ + return + $_FileNotFound =~ /^\d/ + ? _ErrNum == $_FileNotFound + : _ErrMsg =~ /$_FileNotFound/io; +} + + +sub _TooSmall +{ + return + $_TooSmall =~ /^\d/ + ? _ErrNum == $_TooSmall + : _ErrMsg =~ /$_TooSmall/io; +} + + +sub _MoreData +{ + return + $_MoreData =~ /^\d/ + ? _ErrNum == $_MoreData + : _ErrMsg =~ /$_MoreData/io; +} + + +sub _enumValues +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + my( @names )= (); + my $pos= 0; + my $name= ""; + my $nlen= 1+$self->Information("MaxValNameLen"); + while( $self->RegEnumValue($pos++,$name,$nlen,[],[],[],[]) ) { + push( @names, $name ); + } + if( ! _NoMoreItems() ) { + return (); + } + $self->{VALUES}= \@names; + return 1; +} + + +sub ValueNames +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + @_ and croak "Usage: \@names= \$key->ValueNames;"; + $self->_enumValues unless $self->{VALUES}; + return @{$self->{VALUES}}; +} + + +sub _enumSubKeys +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + my( @subkeys, @classes, @times )= (); + my $pos= 0; + my( $subkey, $class, $time )= ("","",""); + my( $namSiz, $clsSiz )= $self->Information( + qw( MaxSubKeyLen MaxSubClassLen )); + $namSiz++; $clsSiz++; + while( $self->RegEnumKeyEx( + $pos++, $subkey, $namSiz, [], $class, $clsSiz, $time ) ) { + push( @subkeys, $subkey ); + push( @classes, $class ); + push( @times, $time ); + } + if( ! _NoMoreItems() ) { + return (); + } + $self->{SUBKEYS}= \@subkeys; + $self->{SUBCLASSES}= \@classes; + $self->{SUBTIMES}= \@times; + return 1; +} + + +sub SubKeyNames +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + @_ and croak "Usage: \@names= \$key->SubKeyNames;"; + $self->_enumSubKeys unless $self->{SUBKEYS}; + return @{$self->{SUBKEYS}}; +} + + +sub SubKeyClasses +{ + my $self= shift(@_); + @_ and croak "Usage: \@classes= \$key->SubKeyClasses;"; + $self->_enumSubKeys unless $self->{SUBCLASSES}; + return @{$self->{SUBCLASSES}}; +} + + +sub SubKeyTimes +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + @_ and croak "Usage: \@times= \$key->SubKeyTimes;"; + $self->_enumSubKeys unless $self->{SUBTIMES}; + return @{$self->{SUBTIMES}}; +} + + +sub _MemberNames +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + @_ and croak "Usage: \$arrayRef= \$key->_MemberNames;"; + if( ! $self->{MEMBERS} ) { + $self->_enumValues unless $self->{VALUES}; + $self->_enumSubKeys unless $self->{SUBKEYS}; + my( @members )= ( map( $_.$self->{DELIM}, @{$self->{SUBKEYS}} ), + map( $self->{DELIM}.$_, @{$self->{VALUES}} ) ); + $self->{MEMBERS}= \@members; + } + return $self->{MEMBERS}; +} + + +sub _MembersHash +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + @_ and croak "Usage: \$hashRef= \$key->_MembersHash;"; + if( ! $self->{MEMBHASH} ) { + my $aRef= $self->_MemberNames; + $self->{MEMBHASH}= {}; + @{$self->{MEMBHASH}}{@$aRef}= (1) x @$aRef; + } + return $self->{MEMBHASH}; +} + + +sub MemberNames +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + @_ and croak "Usage: \@members= \$key->MemberNames;"; + return @{$self->_MemberNames}; +} + + +sub Information +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + my( $time, $nkeys, $nvals, $xsec, $xkey, $xcls, $xname, $xdata )= + ("",0,0,0,0,0,0,0); + my $clen= 8; + if( ! $self->RegQueryInfoKey( [], [], $nkeys, $xkey, $xcls, + $nvals, $xname, $xdata, $xsec, $time ) ) { + return (); + } + if( defined($self->{Class}) ) { + $clen= length($self->{Class}); + } else { + $self->{Class}= ""; + } + while( ! $self->RegQueryInfoKey( $self->{Class}, $clen, + [],[],[],[],[],[],[],[],[]) + && _MoreData ) { + $clen *= 2; + } + my( %info ); + @info{ qw( LastWrite CntSubKeys CntValues SecurityLen + MaxValDataLen MaxSubKeyLen MaxSubClassLen MaxValNameLen ) + }= ( $time, $nkeys, $nvals, $xsec, + $xdata, $xkey, $xcls, $xname ); + if( @_ ) { + my( %check ); + @check{keys(%info)}= keys(%info); + my( @err )= grep( ! $check{$_}, @_ ); + if( @err ) { + croak "${PACK}::Information- Invalid info requested (@err)"; + } + return @info{@_}; + } else { + return %info; + } +} + + +sub Delimiter +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + $self= $RegObj unless ref($self); + my( $oldDelim )= $self->{DELIM}; + if( 1 == @_ && "" ne "$_[0]" ) { + delete $self->{MEMBERS}; + delete $self->{MEMBHASH}; + $self->{DELIM}= "$_[0]"; + } elsif( 0 != @_ ) { + croak "Usage: \$oldDelim= \$key->Delimiter(\$newDelim);"; + } + return $oldDelim; +} + + +sub Handle +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + @_ and croak "Usage: \$handle= \$key->Handle;"; + $self= $RegObj unless ref($self); + return $self->{HANDLE}; +} + + +sub Path +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + @_ and croak "Usage: \$path= \$key->Path;"; + my $delim= $self->{DELIM}; + $self= $RegObj unless ref($self); + if( "" eq $self->{MACHINE} ) { + return( $delim . join( $delim, @{$self->{PATH}} ) . $delim ); + } else { + return( $delim x 2 + . join( $delim, $self->{MACHINE}, @{$self->{PATH}} ) + . $delim ); + } +} + + +sub _Path +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + @_ and croak "Usage: \$arrRef= \$key->_Path;"; + $self= $RegObj unless ref($self); + return $self->{PATH}; +} + + +sub Machine +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + @_ and croak "Usage: \$machine= \$key->Machine;"; + $self= $RegObj unless ref($self); + return $self->{MACHINE}; +} + + +sub Access +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + @_ and croak "Usage: \$access= \$key->Access;"; + $self= $RegObj unless ref($self); + return $self->{ACCESS}; +} + + +sub OS_Delimiter +{ + my $self= shift(@_); + @_ and croak "Usage: \$backslash= \$key->OS_Delimiter;"; + return $self->{OS_DELIM}; +} + + +sub _Roots +{ + my $self= shift(@_); + $self= tied(%$self) if ref($self) && tied(%$self); + @_ and croak "Usage: \$varName= \$key->_Roots;"; + $self= $RegObj unless ref($self); + return $self->{ROOTS}; +} + + +sub Roots +{ + my $self= shift(@_); + $self= tied(%$self) if ref($self) && tied(%$self); + @_ and croak "Usage: \$hashRef= \$key->Roots;"; + $self= $RegObj unless ref($self); + return eval "\\%$self->{ROOTS}"; +} + + +sub TIEHASH +{ + my( $this )= shift(@_); + $this= tied(%$this) if ref($this) && tied(%$this); + my( $key )= @_; + if( 1 == @_ && ref($key) && "$key" =~ /=/ ) { + return $key; # $key is already an object (blessed reference). + } + return $this->new( @_ ); +} + + +sub Tie +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + my( $hRef )= @_; + if( 1 != @_ || ! ref($hRef) || "$hRef" !~ /(^|=)HASH\(/ ) { + croak "Usage: \$key->Tie(\\\%hash);"; + } + return tie %$hRef, ref($self), $self; +} + + +sub TiedRef +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + my $hRef= @_ ? shift(@_) : {}; + return () if ! defined($self); + $self->Tie($hRef); + bless $hRef, ref($self); + return $hRef; +} + + +sub _Flags +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + my $oldFlags= $self->{FLAGS}; + if( 1 == @_ ) { + $self->{FLAGS}= shift(@_); + } elsif( 0 != @_ ) { + croak "Usage: \$oldBits= \$key->_Flags(\$newBits);"; + } + return $oldFlags; +} + + +sub ArrayValues +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + my $oldFlag= $Flag_ArrVal == ( $Flag_ArrVal & $self->{FLAGS} ); + if( 1 == @_ ) { + my $bool= shift(@_); + if( $bool ) { + $self->{FLAGS} |= $Flag_ArrVal; + } else { + $self->{FLAGS} &= ~( $Flag_ArrVal | $Flag_TieVal ); + } + } elsif( 0 != @_ ) { + croak "Usage: \$oldBool= \$key->ArrayValues(\$newBool);"; + } + return $oldFlag; +} + + +sub TieValues +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + my $oldFlag= $Flag_TieVal == ( $Flag_TieVal & $self->{FLAGS} ); + if( 1 == @_ ) { + my $bool= shift(@_); + if( $bool ) { + croak "${PACK}->TieValues cannot be enabled with this version"; + $self->{FLAGS} |= $Flag_TieVal; + } else { + $self->{FLAGS} &= ~$Flag_TieVal; + } + } elsif( 0 != @_ ) { + croak "Usage: \$oldBool= \$key->TieValues(\$newBool);"; + } + return $oldFlag; +} + + +sub FastDelete +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + my $oldFlag= $Flag_FastDel == ( $Flag_FastDel & $self->{FLAGS} ); + if( 1 == @_ ) { + my $bool= shift(@_); + if( $bool ) { + $self->{FLAGS} |= $Flag_FastDel; + } else { + $self->{FLAGS} &= ~$Flag_FastDel; + } + } elsif( 0 != @_ ) { + croak "Usage: \$oldBool= \$key->FastDelete(\$newBool);"; + } + return $oldFlag; +} + + +sub SplitMultis +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + my $oldFlag= $Flag_Split == ( $Flag_Split & $self->{FLAGS} ); + if( 1 == @_ ) { + my $bool= shift(@_); + if( $bool ) { + $self->{FLAGS} |= $Flag_Split; + } else { + $self->{FLAGS} &= ~$Flag_Split; + } + } elsif( 0 != @_ ) { + croak "Usage: \$oldBool= \$key->SplitMultis(\$newBool);"; + } + return $oldFlag; +} + + +sub DWordsToHex +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + my $oldFlag= $Flag_HexDWord == ( $Flag_HexDWord & $self->{FLAGS} ); + if( 1 == @_ ) { + my $bool= shift(@_); + if( $bool ) { + $self->{FLAGS} |= $Flag_HexDWord; + } else { + $self->{FLAGS} &= ~$Flag_HexDWord; + } + } elsif( 0 != @_ ) { + croak "Usage: \$oldBool= \$key->DWordsToHex(\$newBool);"; + } + return $oldFlag; +} + + +sub FixSzNulls +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + my $oldFlag= $Flag_FixNulls == ( $Flag_FixNulls & $self->{FLAGS} ); + if( 1 == @_ ) { + my $bool= shift(@_); + if( $bool ) { + $self->{FLAGS} |= $Flag_FixNulls; + } else { + $self->{FLAGS} &= ~$Flag_FixNulls; + } + } elsif( 0 != @_ ) { + croak "Usage: \$oldBool= \$key->FixSzNulls(\$newBool);"; + } + return $oldFlag; +} + + +sub DualTypes +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + my $oldFlag= $Flag_DualTyp == ( $Flag_DualTyp & $self->{FLAGS} ); + if( 1 == @_ ) { + my $bool= shift(@_); + if( $bool ) { + croak "${PACK}->DualTypes cannot be enabled since ", + "SetDualVar module not installed" + unless $_SetDualVar; + $self->{FLAGS} |= $Flag_DualTyp; + } else { + $self->{FLAGS} &= ~$Flag_DualTyp; + } + } elsif( 0 != @_ ) { + croak "Usage: \$oldBool= \$key->DualTypes(\$newBool);"; + } + return $oldFlag; +} + + +sub DualBinVals +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + my $oldFlag= $Flag_DualBin == ( $Flag_DualBin & $self->{FLAGS} ); + if( 1 == @_ ) { + my $bool= shift(@_); + if( $bool ) { + croak "${PACK}->DualBinVals cannot be enabled since ", + "SetDualVar module not installed" + unless $_SetDualVar; + $self->{FLAGS} |= $Flag_DualBin; + } else { + $self->{FLAGS} &= ~$Flag_DualBin; + } + } elsif( 0 != @_ ) { + croak "Usage: \$oldBool= \$key->DualBinVals(\$newBool);"; + } + return $oldFlag; +} + + +sub GetOptions +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + my( $opt, $meth ); + if( ! @_ || 1 == @_ && "HASH" eq ref($_[0]) ) { + my $href= @_ ? $_[0] : {}; + foreach $opt ( grep !/^Allow/, @_opt_subs ) { + $meth= $_opt_subs{$opt}; + $href->{$opt}= $self->$meth(); + } + return @_ ? $self : $href; + } + my @old; + foreach $opt ( @_ ) { + $meth= $_opt_subs{$opt}; + if( defined $meth ) { + if( $opt eq "AllowLoad" || $opt eq "AllowSave" ) { + croak "${PACK}->GetOptions: Getting current setting of $opt ", + "not supported in this release"; + } + push( @old, $self->$meth() ); + } else { + croak "${PACK}->GetOptions: Invalid option ($opt) ", + "not one of ( ", join(" ",grep !/^Allow/, @_opt_subs), " )"; + } + } + return wantarray ? @old : $old[-1]; +} + + +sub SetOptions +{ + my $self= shift(@_); + # Don't get object if hash ref so "ref" returns original ref. + my( $opt, $meth, @old ); + while( @_ ) { + $opt= shift(@_); + $meth= $_opt_subs{$opt}; + if( ! @_ ) { + croak "${PACK}->SetOptions: Option value missing ", + "after option name ($opt)"; + } elsif( defined $meth ) { + push( @old, $self->$meth( shift(@_) ) ); + } elsif( $opt eq substr("reference",0,length($opt)) ) { + shift(@_) if @_; + push( @old, $self ); + } else { + croak "${PACK}->SetOptions: Invalid option ($opt) ", + "not one of ( @_opt_subs )"; + } + } + return wantarray ? @old : $old[-1]; +} + + +sub _parseTiedEnt +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + my $ent= shift(@_); + my $delim= shift(@_); + my $dlen= length( $delim ); + my $parent= @_ ? shift(@_) : 0; + my $off; + if( $delim x 2 eq substr($ent,0,2*$dlen) && "NONE" eq $self->Handle ) { + if( 0 <= ( $off= index( $ent, $delim x 2, 2*$dlen ) ) ) { + return( substr( $ent, 0, $off ), substr( $ent, 2*$dlen+$off ) ); + } elsif( $delim eq substr($ent,-$dlen) ) { + return( substr($ent,0,-$dlen) ); + } elsif( 2*$dlen <= ( $off= rindex( $ent, $delim ) ) ) { + return( substr( $ent, 0, $off ), + undef, substr( $ent, $dlen+$off ) ); + } elsif( $parent ) { + return(); + } else { + return( $ent ); + } + } elsif( $delim eq substr($ent,0,$dlen) && "NONE" ne $self->Handle ) { + return( undef, substr($ent,$dlen) ); + } elsif( $self->{MEMBERS} && $self->_MembersHash->{$ent} ) { + return( substr($ent,0,-$dlen) ); + } elsif( 0 <= ( $off= index( $ent, $delim x 2 ) ) ) { + return( substr( $ent, 0, $off ), substr( $ent, 2*$dlen+$off ) ); + } elsif( $delim eq substr($ent,-$dlen) ) { + if( $parent + && 0 <= ( $off= rindex( $ent, $delim, length($ent)-2*$dlen ) ) ) { + return( substr($ent,0,$off), + undef, undef, substr($ent,$dlen+$off,-$dlen) ); + } else { + return( substr($ent,0,-$dlen) ); + } + } elsif( 0 <= ( $off= rindex( $ent, $delim ) ) ) { + return( + substr( $ent, 0, $off ), undef, substr( $ent, $dlen+$off ) ); + } else { + return( undef, undef, $ent ); + } +} + + +sub _FetchValue +{ + my $self= shift( @_ ); + my( $val, $createKey )= @_; + my( $data, $type ); + if( ( $data, $type )= $self->GetValue( $val ) ) { + return $self->ArrayValues ? [ $data, $type ] + : wantarray ? ( $data, $type ) + : $data; + } elsif( $createKey and $data= $self->new($val) ) { + return $data->TiedRef; + } else { + return (); + } +} + + +sub FETCH +{ + my $self= shift(@_); + my $ent= shift(@_); + my $delim= $self->Delimiter; + my( $key, $val, $ambig )= $self->_parseTiedEnt( $ent, $delim, 0 ); + my $sub; + if( defined($key) ) { + if( defined($self->{MEMBHASH}) + && $self->{MEMBHASH}->{$key.$delim} + && 0 <= index($key,$delim) ) { + return () + unless $sub= $self->new( $key, + {"Delimiter"=>$self->OS_Delimiter} ); + $sub->Delimiter($delim); + } else { + return () + unless $sub= $self->new( $key ); + } + } else { + $sub= $self; + } + if( defined($val) ) { + return $sub->_FetchValue( $val ); + } elsif( ! defined($ambig) ) { + return $sub->TiedRef; + } elsif( defined($key) ) { + return $sub->FETCH( $ambig ); + } else { + return $sub->_FetchValue( $ambig, "" ne $ambig ); + } +} + + +sub _FetchOld +{ + my( $self, $key )= @_; + my $old= $self->FETCH($key); + if( $old ) { + my $copy= {}; + %$copy= %$old; + return $copy; + } + # return $^E; + return _Err; +} + + +sub DELETE +{ + my $self= shift(@_); + my $ent= shift(@_); + my $delim= $self->Delimiter; + my( $key, $val, $ambig, $subkey )= $self->_parseTiedEnt( $ent, $delim, 1 ); + my $sub; + my $fast= defined(wantarray) ? $self->FastDelete : 2; + my $old= 1; # Value returned if FastDelete is set. + if( defined($key) + && ( defined($val) || defined($ambig) || defined($subkey) ) ) { + return () + unless $sub= $self->new( $key ); + } else { + $sub= $self; + } + if( defined($val) ) { + $old= $sub->GetValue($val) || _Err unless 2 <= $fast; + $sub->RegDeleteValue( $val ); + } elsif( defined($subkey) ) { + $old= $sub->_FetchOld( $subkey.$delim ) unless $fast; + $sub->RegDeleteKey( $subkey ); + } elsif( defined($ambig) ) { + if( defined($key) ) { + $old= $sub->DELETE($ambig); + } else { + $old= $sub->GetValue($ambig) || _Err unless 2 <= $fast; + if( defined( $old ) ) { + $sub->RegDeleteValue( $ambig ); + } else { + $old= $sub->_FetchOld( $ambig.$delim ) unless $fast; + $sub->RegDeleteKey( $ambig ); + } + } + } elsif( defined($key) ) { + $old= $sub->_FetchOld( $key.$delim ) unless $fast; + $sub->RegDeleteKey( $key ); + } else { + croak "${PACK}->DELETE: Key ($ent) can never be deleted"; + } + return $old; +} + + +sub SetValue +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + my $name= shift(@_); + my $data= shift(@_); + my( $type )= @_; + my $size; + if( ! defined($type) ) { + if( "ARRAY" eq ref($data) ) { + croak "${PACK}->SetValue: Value is array reference but ", + "no data type given" + unless 2 == @$data; + ( $data, $type )= @$data; + } else { + $type= REG_SZ; + } + } + $type= _constant($type,"registry value data type") if $type =~ /^REG_/; + if( REG_MULTI_SZ == $type && "ARRAY" eq ref($data) ) { + $data= join( "\0", @$data ) . "\0\0"; + ## $data= pack( "a*" x (1+@$data), map( $_."\0", @$data, "" ) ); + } elsif( ( REG_SZ == $type || REG_EXPAND_SZ == $type ) + && $self->FixSzNulls ) { + $data .= "\0" unless "\0" eq substr($data,0,-1); + } elsif( REG_DWORD == $type && $data =~ /^0x[0-9a-fA-F]{3,}$/ ) { + $data= pack( "L", hex($data) ); + # We could to $data=pack("L",$data) for REG_DWORD but I see + # no nice way to always destinguish when to do this or not. + } + return $self->RegSetValueEx( $name, 0, $type, $data, length($data) ); +} + + +sub StoreKey +{ + my $this= shift(@_); + $this= tied(%$this) if ref($this) && tied(%$this); + my $subKey= shift(@_); + my $data= shift(@_); + my $ent; + my $self; + if( ! ref($data) || "$data" !~ /(^|=)HASH/ ) { + croak "${PACK}->StoreKey: For ", $this->Path.$subKey, ",\n", + " subkey data must be a HASH reference"; + } + if( defined( $$data{""} ) && "HASH" eq ref($$data{""}) ) { + $self= $this->CreateKey( $subKey, delete $$data{""} ); + } else { + $self= $this->CreateKey( $subKey ); + } + return () if ! defined($self); + foreach $ent ( keys(%$data) ) { + return () + unless $self->STORE( $ent, $$data{$ent} ); + } + return $self; +} + + +# = { "" => {OPT=>VAL}, "val"=>[], "key"=>{} } creates a new key +# = "string" creates a new REG_SZ value +# = [ data, type ] creates a new value +sub STORE +{ + my $self= shift(@_); + my $ent= shift(@_); + my $data= shift(@_); + my $delim= $self->Delimiter; + my( $key, $val, $ambig, $subkey )= $self->_parseTiedEnt( $ent, $delim, 1 ); + my $sub; + if( defined($key) + && ( defined($val) || defined($ambig) || defined($subkey) ) ) { + return () + unless $sub= $self->new( $key ); + } else { + $sub= $self; + } + if( defined($val) ) { + croak "${PACK}->STORE: For ", $sub->Path.$delim.$val, ",\n", + " value data cannot be a HASH reference" + if ref($data) && "$data" =~ /(^|=)HASH/; + $sub->SetValue( $val, $data ); + } elsif( defined($subkey) ) { + croak "${PACK}->STORE: For ", $sub->Path.$subkey.$delim, ",\n", + " subkey data must be a HASH reference" + unless ref($data) && "$data" =~ /(^|=)HASH/; + $sub->StoreKey( $subkey, $data ); + } elsif( defined($ambig) ) { + if( ref($data) && "$data" =~ /(^|=)HASH/ ) { + $sub->StoreKey( $ambig, $data ); + } else { + $sub->SetValue( $ambig, $data ); + } + } elsif( defined($key) ) { + croak "${PACK}->STORE: For ", $sub->Path.$key.$delim, ",\n", + " subkey data must be a HASH reference" + unless ref($data) && "$data" =~ /(^|=)HASH/; + $sub->StoreKey( $key, $data ); + } else { + croak "${PACK}->STORE: Key ($ent) can never be created nor set"; + } +} + + +sub EXISTS +{ + my $self= shift(@_); + my $ent= shift(@_); + return defined( $self->FETCH($ent) ); +} + + +sub FIRSTKEY +{ + my $self= shift(@_); + my $members= $self->_MemberNames; + $self->{PREVIDX}= 0; + return @{$members} ? $members->[0] : undef; +} + + +sub NEXTKEY +{ + my $self= shift(@_); + my $prev= shift(@_); + my $idx= $self->{PREVIDX}; + my $members= $self->_MemberNames; + if( ! defined($idx) || $prev ne $members->[$idx] ) { + $idx= 0; + while( $idx < @$members && $prev ne $members->[$idx] ) { + $idx++; + } + } + $self->{PREVIDX}= ++$idx; + return $members->[$idx]; +} + + +sub DESTROY +{ + my $self= shift(@_); + return if tied(%$self); + my $unload; + local $@; + eval { $unload= $self->{UNLOADME}; 1 } + or return; + my $debug= $ENV{DEBUG_TIE_REGISTRY}; + if( defined($debug) ) { + if( 1 < $debug ) { + my $hand= $self->Handle; + my $dep= $self->{DEPENDON}; + carp "${PACK} destroying ", $self->Path, " (", + "NONE" eq $hand ? $hand : sprintf("0x%lX",$hand), ")", + defined($dep) ? (" [depends on ",$dep->Path,"]") : (); + } else { + warn "${PACK} destroying ", $self->Path, ".\n"; + } + } + $self->RegCloseKey + unless "NONE" eq $self->Handle; + if( defined($unload) ) { + if( defined($debug) && 1 < $debug ) { + my( $obj, $subKey, $file )= @$unload; + warn "Unloading ", $self->Path, + " (from ", $obj->Path, ", $subKey)...\n"; + } + $self->UnLoad + || warn "Couldn't unload ", $self->Path, ": ", _ErrMsg, "\n"; + ## carp "Never unloaded ${PACK}::Load($$unload[2])"; + } + #delete $self->{DEPENDON}; +} + + +use vars qw( @CreateKey_Opts %CreateKey_Opts %_KeyDispNames ); +@CreateKey_Opts= qw( Access Class Options Delimiter + Disposition Security Volatile Backup ); +@CreateKey_Opts{@CreateKey_Opts}= (1) x @CreateKey_Opts; +%_KeyDispNames= ( REG_CREATED_NEW_KEY() => "REG_CREATED_NEW_KEY", + REG_OPENED_EXISTING_KEY() => "REG_OPENED_EXISTING_KEY" ); + +sub CreateKey +{ + my $self= shift(@_); + my $tied= tied(%$self); + $self= tied(%$self) if $tied; + my( $subKey, $opts )= @_; + my( $sam )= $self->Access; + my( $delim )= $self->Delimiter; + my( $class )= ""; + my( $flags )= 0; + my( $secure )= []; + my( $garb )= []; + my( $result )= \$garb; + my( $handle )= 0; + if( @_ < 1 || 2 < @_ + || 2 == @_ && "HASH" ne ref($opts) ) { + croak "Usage: \$new= \$old->CreateKey( \$subKey, {OPT=>VAL,...} );\n", + " options: @CreateKey_Opts\nCalled"; + } + if( defined($opts) ) { + $sam= $opts->{"Access"} if defined($opts->{"Access"}); + $class= $opts->{Class} if defined($opts->{Class}); + $flags= $opts->{Options} if defined($opts->{Options}); + $delim= $opts->{"Delimiter"} if defined($opts->{"Delimiter"}); + $secure= $opts->{Security} if defined($opts->{Security}); + if( defined($opts->{Disposition}) ) { + "SCALAR" eq ref($opts->{Disposition}) + or croak "${PACK}->CreateKey option `Disposition'", + " must provide a scalar reference"; + $result= $opts->{Disposition}; + } + if( 0 == $flags ) { + $flags |= REG_OPTION_VOLATILE + if defined($opts->{Volatile}) && $opts->{Volatile}; + $flags |= REG_OPTION_BACKUP_RESTORE + if defined($opts->{Backup}) && $opts->{Backup}; + } + } + my $subPath= ref($subKey) ? $subKey : $self->_split($subKey,$delim); + $subKey= join( $self->OS_Delimiter, @$subPath ); + $self->RegCreateKeyEx( $subKey, 0, $class, $flags, $sam, + $secure, $handle, $$result ) + or return (); + if( ! ref($$result) && $self->DualTypes ) { + $$result= _DualVal( \%_KeyDispNames, $$result ); + } + my $new= $self->_new( $handle, [ @{$self->_Path}, @{$subPath} ] ); + $new->{ACCESS}= $sam; + $new->{DELIM}= $delim; + $new= $new->TiedRef if $tied; + return $new; +} + + +use vars qw( $Load_Cnt @Load_Opts %Load_Opts ); +$Load_Cnt= 0; +@Load_Opts= qw(NewSubKey); +@Load_Opts{@Load_Opts}= (1) x @Load_Opts; + +sub Load +{ + my $this= shift(@_); + my $tied= ref($this) && tied(%$this); + $this= tied(%$this) if $tied; + my( $file, $subKey, $opts )= @_; + if( 2 == @_ && "HASH" eq ref($subKey) ) { + $opts= $subKey; + undef $subKey; + } + @_ < 1 || 3 < @_ || defined($opts) && "HASH" ne ref($opts) + and croak "Usage: \$key= ", + "${PACK}->Load( \$fileName, [\$newSubKey,] {OPT=>VAL...} );\n", + " options: @Load_Opts @new_Opts\nCalled"; + if( defined($opts) && exists($opts->{NewSubKey}) ) { + $subKey= delete $opts->{NewSubKey}; + } + if( ! defined( $subKey ) ) { + if( "" ne $this->Machine ) { + ( $this )= $this->_connect( [$this->Machine,"LMachine"] ); + } else { + ( $this )= $this->_rootKey( "LMachine" ); # Could also be "Users" + } + $subKey= "PerlTie:$$." . ++$Load_Cnt; + } + $this->RegLoadKey( $subKey, $file ) + or return (); + my $self= $this->new( $subKey, defined($opts) ? $opts : () ); + if( ! defined( $self ) ) { + { my $err= Win32::GetLastError(); + #{ local( $^E ); #} + $this->RegUnLoadKey( $subKey ) or carp + "Can't unload $subKey from ", $this->Path, ": ", _ErrMsg, "\n"; + Win32::SetLastError($err); + } + return (); + } + $self->{UNLOADME}= [ $this, $subKey, $file ]; + $self= $self->TiedRef if $tied; + return $self; +} + + +sub UnLoad +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + @_ and croak "Usage: \$key->UnLoad;"; + my $unload= $self->{UNLOADME}; + "ARRAY" eq ref($unload) + or croak "${PACK}->UnLoad called on a key which was not Load()ed"; + my( $obj, $subKey, $file )= @$unload; + $self->RegCloseKey; + return Win32API::Registry::RegUnLoadKey( $obj->Handle, $subKey ); +} + + +sub AllowSave +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + return $self->AllowPriv( "SeBackupPrivilege", @_ ); +} + + +sub AllowLoad +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + return $self->AllowPriv( "SeRestorePrivilege", @_ ); +} + + +# RegNotifyChangeKeyValue( hKey, bWatchSubtree, iNotifyFilter, hEvent, bAsync ) + + +sub RegCloseKey { my $self= shift(@_); + Win32API::Registry::RegCloseKey $self->Handle, @_; } +sub RegConnectRegistry { my $self= shift(@_); + Win32API::Registry::RegConnectRegistry @_; } +sub RegCreateKey { my $self= shift(@_); + Win32API::Registry::RegCreateKey $self->Handle, @_; } +sub RegCreateKeyEx { my $self= shift(@_); + Win32API::Registry::RegCreateKeyEx $self->Handle, @_; } +sub RegDeleteKey { my $self= shift(@_); + Win32API::Registry::RegDeleteKey $self->Handle, @_; } +sub RegDeleteValue { my $self= shift(@_); + Win32API::Registry::RegDeleteValue $self->Handle, @_; } +sub RegEnumKey { my $self= shift(@_); + Win32API::Registry::RegEnumKey $self->Handle, @_; } +sub RegEnumKeyEx { my $self= shift(@_); + Win32API::Registry::RegEnumKeyEx $self->Handle, @_; } +sub RegEnumValue { my $self= shift(@_); + Win32API::Registry::RegEnumValue $self->Handle, @_; } +sub RegFlushKey { my $self= shift(@_); + Win32API::Registry::RegFlushKey $self->Handle, @_; } +sub RegGetKeySecurity { my $self= shift(@_); + Win32API::Registry::RegGetKeySecurity $self->Handle, @_; } +sub RegLoadKey { my $self= shift(@_); + Win32API::Registry::RegLoadKey $self->Handle, @_; } +sub RegNotifyChangeKeyValue { my $self= shift(@_); + Win32API::Registry::RegNotifyChangeKeyValue $self->Handle, @_; } +sub RegOpenKey { my $self= shift(@_); + Win32API::Registry::RegOpenKey $self->Handle, @_; } +sub RegOpenKeyEx { my $self= shift(@_); + Win32API::Registry::RegOpenKeyEx $self->Handle, @_; } +sub RegQueryInfoKey { my $self= shift(@_); + Win32API::Registry::RegQueryInfoKey $self->Handle, @_; } +sub RegQueryMultipleValues { my $self= shift(@_); + Win32API::Registry::RegQueryMultipleValues $self->Handle, @_; } +sub RegQueryValue { my $self= shift(@_); + Win32API::Registry::RegQueryValue $self->Handle, @_; } +sub RegQueryValueEx { my $self= shift(@_); + Win32API::Registry::RegQueryValueEx $self->Handle, @_; } +sub RegReplaceKey { my $self= shift(@_); + Win32API::Registry::RegReplaceKey $self->Handle, @_; } +sub RegRestoreKey { my $self= shift(@_); + Win32API::Registry::RegRestoreKey $self->Handle, @_; } +sub RegSaveKey { my $self= shift(@_); + Win32API::Registry::RegSaveKey $self->Handle, @_; } +sub RegSetKeySecurity { my $self= shift(@_); + Win32API::Registry::RegSetKeySecurity $self->Handle, @_; } +sub RegSetValue { my $self= shift(@_); + Win32API::Registry::RegSetValue $self->Handle, @_; } +sub RegSetValueEx { my $self= shift(@_); + Win32API::Registry::RegSetValueEx $self->Handle, @_; } +sub RegUnLoadKey { my $self= shift(@_); + Win32API::Registry::RegUnLoadKey $self->Handle, @_; } +sub AllowPriv { my $self= shift(@_); + Win32API::Registry::AllowPriv @_; } + + +# Autoload methods go after =cut, and are processed by the autosplit program. + +1; +__END__ + +=head1 NAME + +Win32::TieRegistry - Powerful and easy ways to manipulate a registry +[on Win32 for now]. + +=head1 SYNOPSIS + + use Win32::TieRegistry 0.20 ( UseOptionName=>UseOptionValue[,...] ); + + $Registry->SomeMethodCall(arg1,...); + + $subKey= $Registry->{"Key\\SubKey\\"}; + $valueData= $Registry->{"Key\\SubKey\\\\ValueName"}; + $Registry->{"Key\\SubKey\\"}= { "NewSubKey" => {...} }; + $Registry->{"Key\\SubKey\\\\ValueName"}= "NewValueData"; + $Registry->{"\\ValueName"}= [ pack("fmt",$data), REG_DATATYPE ]; + +=head1 EXAMPLES + + use Win32::TieRegistry( Delimiter=>"#", ArrayValues=>0 ); + $pound= $Registry->Delimiter("/"); + $diskKey= $Registry->{"LMachine/System/Disk/"} + or die "Can't read LMachine/System/Disk key: $^E\n"; + $data= $key->{"/Information"} + or die "Can't read LMachine/System/Disk//Information value: $^E\n"; + $remoteKey= $Registry->{"//ServerA/LMachine/System/"} + or die "Can't read //ServerA/LMachine/System/ key: $^E\n"; + $remoteData= $remoteKey->{"Disk//Information"} + or die "Can't read ServerA's System/Disk//Information value: $^E\n"; + foreach $entry ( keys(%$diskKey) ) { + ... + } + foreach $subKey ( $diskKey->SubKeyNames ) { + ... + } + $diskKey->AllowSave( 1 ); + $diskKey->RegSaveKey( "C:/TEMP/DiskReg", [] ); + +=head1 DESCRIPTION + +The I<Win32::TieRegistry> module lets you manipulate the Registry +via objects [as in "object oriented"] or via tied hashes. But +you will probably mostly use a combination reference, that is, a +reference to a tied hash that has also been made an object so that +you can mix both access methods [as shown above]. + +If you did not get this module as part of L<libwin32>, you might +want to get a recent version of L<libwin32> from CPAN which should +include this module and the I<Win32API::Registry> module that it +uses. + +Skip to the L<SUMMARY> section if you just want to dive in and start +using the Registry from Perl. + +Accessing and manipulating the registry is extremely simple using +I<Win32::TieRegistry>. A single, simple expression can return +you almost any bit of information stored in the Registry. +I<Win32::TieRegistry> also gives you full access to the "raw" +underlying API calls so that you can do anything with the Registry +in Perl that you could do in C. But the "simple" interface has +been carefully designed to handle almost all operations itself +without imposing arbitrary limits while providing sensible +defaults so you can list only the parameters you care about. + +But first, an overview of the Registry itself. + +=head2 The Registry + +The Registry is a forest: a collection of several tree structures. +The root of each tree is a key. These root keys are identified by +predefined constants whose names start with "HKEY_". Although all +keys have a few attributes associated with each [a class, a time +stamp, and security information], the most important aspect of keys +is that each can contain subkeys and can contain values. + +Each subkey has a name: a string which cannot be blank and cannot +contain the delimiter character [backslash: C<'\\'>] nor nul +[C<'\0'>]. Each subkey is also a key and so can contain subkeys +and values [and has a class, time stamp, and security information]. + +Each value has a name: a string which E<can> be blank and E<can> +contain the delimiter character [backslash: C<'\\'>] and any +character except for null, C<'\0'>. Each value also has data +associated with it. Each value's data is a contiguous chunk of +bytes, which is exactly what a Perl string value is so Perl +strings will usually be used to represent value data. + +Each value also has a data type which says how to interpret the +value data. The primary data types are: + +=over + +=item REG_SZ + +A null-terminated string. + +=item REG_EXPAND_SZ + +A null-terminated string which contains substrings consisting of a +percent sign [C<'%'>], an environment variable name, then a percent +sign, that should be replaced with the value associate with that +environment variable. The system does I<not> automatically do this +substitution. + +=item REG_BINARY + +Some arbitrary binary value. You can think of these as being +"packed" into a string. + +If your system has the L<SetDualVar> module installed, +the C<DualBinVals()> option wasn't turned off, and you +fetch a C<REG_BINARY> value of 4 bytes or fewer, then +you can use the returned value in a numeric context to +get at the "unpacked" numeric value. See C<GetValue()> +for more information. + +=item REG_MULTI_SZ + +Several null-terminated strings concatenated together with an +extra trailing C<'\0'> at the end of the list. Note that the list +can include empty strings so use the value's length to determine +the end of the list, not the first occurrence of C<'\0\0'>. +It is best to set the C<SplitMultis()> option so I<Win32::TieRegistry> +will split these values into an array of strings for you. + +=item REG_DWORD + +A long [4-byte] integer value. These values are expected either +packed into a 4-character string or as a hex string of E<more than> +4 characters [but I<not> as a numeric value, unfortunately, as there is +no sure way to tell a numeric value from a packed 4-byte string that +just happens to be a string containing a valid numeric value]. + +How such values are returned depends on the C<DualBinVals()> and +C<DWordsToHex()> options. See C<GetValue()> for details. + +=back + +In the underlying Registry calls, most places which take a +subkey name also allow you to pass in a subkey "path" -- a +string of several subkey names separated by the delimiter +character, backslash [C<'\\'>]. For example, doing +C<RegOpenKeyEx(HKEY_LOCAL_MACHINE,"SYSTEM\\DISK",...)> is much +like opening the C<"SYSTEM"> subkey of C<HKEY_LOCAL_MACHINE>, +then opening its C<"DISK"> subkey, then closing the C<"SYSTEM"> +subkey. + +All of the I<Win32::TieRegistry> features allow you to use your +own delimiter in place of the system's delimiter, [C<'\\'>]. In +most of our examples we will use a forward slash [C<'/'>] as our +delimiter as it is easier to read and less error prone to use when +writing Perl code since you have to type two backslashes for each +backslash you want in a string. Note that this is true even when +using single quotes -- C<'\\HostName\LMachine\'> is an invalid +string and must be written as C<'\\\\HostName\\LMachine\\'>. + +You can also connect to the registry of other computers on your +network. This will be discussed more later. + +Although the Registry does not have a single root key, the +I<Win32::TieRegistry> module creates a virtual root key for you +which has all of the I<HKEY_*> keys as subkeys. + +=head2 Tied Hashes Documentation + +Before you can use a tied hash, you must create one. One way to +do that is via: + + use Win32::TieRegistry ( TiedHash => '%RegHash' ); + +which exports a C<%RegHash> variable into your package and ties it +to the virtual root key of the Registry. An alternate method is: + + my %RegHash; + use Win32::TieRegistry ( TiedHash => \%RegHash ); + +There are also several ways you can tie a hash variable to any +other key of the Registry, which are discussed later. + +Note that you will most likely use C<$Registry> instead of using +a tied hash. C<$Registry> is a reference to a hash that has +been tied to the virtual root of your computer's Registry [as if, +C<$Registry= \%RegHash>]. So you would use C<$Registry-E<gt>{Key}> +rather than C<$RegHash{Key}> and use C<keys %{$Registry}> rather +than C<keys %RegHash>, for example. + +For each hash which has been tied to a Registry key, the Perl +C<keys> function will return a list containing the name of each +of the key's subkeys with a delimiter character appended to it and +containing the name of each of the key's values with a delimiter +prepended to it. For example: + + keys( %{ $Registry->{"HKEY_CLASSES_ROOT\\batfile\\"} } ) + +might yield the following list value: + + ( "DefaultIcon\\", # The subkey named "DefaultIcon" + "shell\\", # The subkey named "shell" + "shellex\\", # The subkey named "shellex" + "\\", # The default value [named ""] + "\\EditFlags" ) # The value named "EditFlags" + +For the virtual root key, short-hand subkey names are used as +shown below. You can use the short-hand name, the regular +I<HKEY_*> name, or any numeric value to access these keys, but +the short-hand names are all that will be returned by the C<keys> +function. + +=over + +=item "Classes" for HKEY_CLASSES_ROOT + +Contains mappings between file name extensions and the uses +for such files along with configuration information for COM +[MicroSoft's Common Object Model] objects. Usually a link to +the C<"SOFTWARE\\Classes"> subkey of the C<HKEY_LOCAL_MACHINE> +key. + +=item "CUser" for HKEY_CURRENT_USER + +Contains information specific to the currently logged-in user. +Mostly software configuration information. Usually a link to +a subkey of the C<HKEY_USERS> key. + +=item "LMachine" for HKEY_LOCAL_MACHINE + +Contains all manner of information about the computer. + +=item "Users" for HKEY_USERS + +Contains one subkey, C<".DEFAULT">, which gets copied to a new +subkey whenever a new user is added. Also contains a subkey for +each user of the system, though only those for active users +[usually only one] are loaded at any given time. + +=item "PerfData" for HKEY_PERFORMANCE_DATA + +Used to access data about system performance. Access via this key +is "special" and all but the most carefully constructed calls will +fail, usually with C<ERROR_INSUFFICIENT_BUFFER>. For example, you +can't enumerate key names without also enumerating values which +require huge buffers but the exact buffer size required cannot be +determined beforehand because C<RegQueryInfoKey()> E<always> fails +with C<ERROR_INSUFFICIENT_BUFFER> for C<HKEY_PERFORMANCE_DATA> no +matter how it is called. So it is currently not very useful to +tie a hash to this key. You can use it to create an object to use +for making carefully constructed calls to the underlying Reg*() +routines. + +=item "CConfig" for HKEY_CURRENT_CONFIG + +Contains minimal information about the computer's current +configuration that is required very early in the boot process. +For example, setting for the display adapter such as screen +resolution and refresh rate are found in here. + +=item "DynData" for HKEY_DYN_DATA + +Dynamic data. We have found no documentation for this key. + +=back + +A tied hash is much like a regular hash variable in Perl -- you give +it a key string inside braces, [C<{> and C<}>], and it gives you +back a value [or lets you set a value]. For I<Win32::TieRegistry> +hashes, there are two types of values that will be returned. + +=over + +=item SubKeys + +If you give it a string which represents a subkey, then it will +give you back a reference to a hash which has been tied to that +subkey. It can't return the hash itself, so it returns a +reference to it. It also blesses that reference so that it is +also an object so you can use it to call method functions. + +=item Values + +If you give it a string which is a value name, then it will give +you back a string which is the data for that value. Alternately, +you can request that it give you both the data value string and +the data value type [we discuss how to request this later]. In +this case, it would return a reference to an array where the value +data string is element C<[0]> and the value data type is element +C<[1]>. + +=back + +The key string which you use in the tied hash must be interpreted +to determine whether it is a value name or a key name or a path +that combines several of these or even other things. There are +two simple rules that make this interpretation easy and +unambiguous: + + Put a delimiter after each key name. + Put a delimiter in front of each value name. + +Exactly how the key string will be intepreted is governed by the +following cases, in the order listed. These cases are designed +to "do what you mean". Most of the time you won't have to think +about them, especially if you follow the two simple rules above. +After the list of cases we give several examples which should be +clear enough so feel free to skip to them unless you are worried +about the details. + +=over + +=item Remote machines + +If the hash is tied to the virtual root of the registry [or the +virtual root of a remote machine's registry], then we treat hash +key strings which start with the delimiter character specially. + +If the hash key string starts with two delimiters in a row, then +those should be immediately followed by the name of a remote +machine whose registry we wish to connect to. That can be +followed by a delimiter and more subkey names, etc. If the +machine name is not following by anything, then a virtual root +for the remote machine's registry is created, a hash is tied to +it, and a reference to that hash it is returned. + +=item Hash key string starts with the delimiter + +If the hash is tied to a virtual root key, then the leading +delimiter is ignored. It should be followed by a valid Registry +root key name [either a short-hand name like C<"LMachine">, an +I<HKEY_*> value, or a numeric value]. This alternate notation is +allowed in order to be more consistant with the C<Open()> method +function. + +For all other Registry keys, the leading delimiter indicates +that the rest of the string is a value name. The leading +delimiter is stripped and the rest of the string [which can +be empty and can contain more delimiters] is used as a value +name with no further parsing. + +=item Exact match with direct subkey name followed by delimiter + +If you have already called the Perl C<keys> function on the tied +hash [or have already called C<MemberNames> on the object] and the +hash key string exactly matches one of the strings returned, then +no further parsing is done. In other words, if the key string +exactly matches the name of a direct subkey with a delimiter +appended, then a reference to a hash tied to that subkey is +returned [but only if C<keys> or C<MemberNames> has already +been called for that tied hash]. + +This is only important if you have selected a delimiter other than +the system default delimiter and one of the subkey names contains +the delimiter you have chosen. This rule allows you to deal with +subkeys which contain your chosen delimiter in their name as long +as you only traverse subkeys one level at a time and always +enumerate the list of members before doing so. + +The main advantage of this is that Perl code which recursively +traverses a hash will work on hashes tied to Registry keys even if +a non-default delimiter has been selected. + +=item Hash key string contains two delimiters in a row + +If the hash key string contains two [or more] delimiters in a row, +then the string is split between the first pair of delimiters. +The first part is interpreted as a subkey name or a path of subkey +names separated by delimiters and with a trailing delimiter. The +second part is interpreted as a value name with one leading +delimiter [any extra delimiters are considered part of the value +name]. + +=item Hash key string ends with a delimiter + +If the key string ends with a delimiter, then it is treated +as a subkey name or path of subkey names separated by delimiters. + +=item Hash key string contains a delimiter + +If the key string contains a delimiter, then it is split after +the last delimiter. The first part is treated as a subkey name or +path of subkey names separated by delimiters. The second part +is ambiguous and is treated as outlined in the next item. + +=item Hash key string contains no delimiters + +If the hash key string contains no delimiters, then it is ambiguous. + +If you are reading from the hash [fetching], then we first use the +key string as a value name. If there is a value with a matching +name in the Registry key which the hash is tied to, then the value +data string [and possibly the value data type] is returned. +Otherwise, we retry by using the hash key string as a subkey name. +If there is a subkey with a matching name, then we return a +reference to a hash tied to that subkey. Otherwise we return +C<undef>. + +If you are writing to the hash [storing], then we use the key +string as a subkey name only if the value you are storing is a +reference to a hash value. Otherwise we use the key string as +a value name. + +=back + +=head3 Examples + +Here are some examples showing different ways of accessing Registry +information using references to tied hashes: + +=over + +=item Canonical value fetch + + $tip18= $Registry->{"HKEY_LOCAL_MACHINE\\Software\\Microsoft\\" + . 'Windows\\CurrentVersion\\Explorer\\Tips\\\\18'}; + +Should return the text of important tip number 18. Note that two +backslashes, C<"\\">, are required to get a single backslash into +a Perl double-quoted or single-qouted string. Note that C<"\\"> +is appended to each key name [C<"HKEY_LOCAL_MACHINE"> through +C<"Tips">] and C<"\\"> is prepended to the value name, C<"18">. + +=item Changing your delimiter + + $Registry->Delimiter("/"); + $tip18= $Registry->{"HKEY_LOCAL_MACHINE/Software/Microsoft/" + . 'Windows/CurrentVersion/Explorer/Tips//18'}; + +This usually makes things easier to read when working in Perl. +All remaining examples will assume the delimiter has been changed +as above. + +=item Using intermediate keys + + $ms= $Registry->{"LMachine/Software/Microsoft/"}; + $tips= $ms->{"Windows/CurrentVersion/Explorer/Tips/"}; + $tip18= $winlogon->{"/18"}; + +Same as above but opens more keys into the Registry which lets you +efficiently re-access those intermediate keys. This is slightly +less efficient if you never reuse those intermediate keys. + +=item Chaining in a single statement + + $tip18= $Registry->{"LMachine/Software/Microsoft/"}-> + {"Windows/CurrentVersion/Explorer/Tips/"}->{"/18"}; + +Like above, this creates intermediate key objects then uses +them to access other data. Once this statement finishes, the +intermediate key objects are destroyed. Several handles into +the Registry are opened and closed by this statement so it is +less efficient but there are times when this will be useful. + +=item Even less efficient example of chaining + + $tip18= $Registry->{"LMachine/Software/Microsoft"}-> + {"Windows/CurrentVersion/Explorer/Tips"}->{"/18"}; + +Because we left off the trailing delimiters, I<Win32::TieRegistry> +doesn't know whether final names, C<"Microsoft"> and C<"Tips">, +are subkey names or value names. So this statement ends up +executing the same code as the next one. + +=item What the above really does + + $tip18= $Registry->{"LMachine/Software/"}->{"Microsoft"}-> + {"Windows/CurrentVersion/Explorer/"}->{"Tips"}->{"/18"}; + +With more chains to go through, more temporary objects are created +and later destroyed than in our first chaining example. Also, +when C<"Microsoft"> is looked up, I<Win32::TieRegistry> first +tries to open it as a value and fails then tries it as a subkey. +The same is true for when it looks up C<"Tips">. + +=item Getting all of the tips + + $tips= $Registry->{"LMachine/Software/Microsoft/"}-> + {"Windows/CurrentVersion/Explorer/Tips/"} + or die "Can't find the Windows tips: $^E\n"; + foreach( keys %$tips ) { + print "$_: ", $tips->{$_}, "\n"; + } + +First notice that we actually check for failure for the first +time. We are assuming that the C<"Tips"> key contains no subkeys. +Otherwise the C<print> statement would show something like +C<"Win32::TieRegistry=HASH(0xc03ebc)"> for each subkey. + +The output from the above code will start something like: + + /0: If you don't know how to do something,[...] + +=back + +=head3 Deleting items + +You can use the Perl C<delete> function to delete a value from a +Registry key or to delete a subkey as long that subkey contains +no subkeys of its own. See L<More Examples>, below, for more +information. + +=head3 Storing items + +You can use the Perl assignment operator [C<=>] to create new +keys, create new values, or replace values. The values you store +should be in the same format as the values you would fetch from a +tied hash. For example, you can use a single assignment statement +to copy an entire Registry tree. The following statement: + + $Registry->{"LMachine/Software/Classes/Tie_Registry/"}= + $Registry->{"LMachine/Software/Classes/batfile/"}; + +creates a C<"Tie_Registry"> subkey under the C<"Software\\Classes"> +subkey of the C<HKEY_LOCAL_MACHINE> key. Then it populates it +with copies of all of the subkeys and values in the C<"batfile"> +subkey and all of its subkeys. Note that you need to have +called C<$Registry-E<gt>ArrayValues(1)> for the proper value data +type information to be copied. Note also that this release of +I<Win32::TieRegistry> does not copy key attributes such as class +name and security information [this is planned for a future release]. + +The following statement creates a whole subtree in the Registry: + + $Registry->{"LMachine/Software/FooCorp/"}= { + "FooWriter/" => { + "/Version" => "4.032", + "Startup/" => { + "/Title" => "Foo Writer Deluxe ][", + "/WindowSize" => [ pack("LL",$wid,$ht), "REG_BINARY" ], + "/TaskBarIcon" => [ "0x0001", "REG_DWORD" ], + }, + "Compatibility/" => { + "/AutoConvert" => "Always", + "/Default Palette" => "Windows Colors", + }, + }, + "/License", => "0123-9C8EF1-09-FC", + }; + +Note that all but the last Registry key used on the left-hand +side of the assignment [that is, "LMachine/Software/" but not +"FooCorp/"] must already exist for this statement to succeed. + +By using the leading a trailing delimiters on each subkey name and +value name, I<Win32::TieRegistry> will tell you if you try to assign +subkey information to a value or visa-versa. + +=head3 More examples + +=over + +=item Adding a new tip + + $tips= $Registry->{"LMachine/Software/Microsoft/"}-> + {"Windows/CurrentVersion/Explorer/Tips/"} + or die "Can't find the Windows tips: $^E\n"; + $tips{'/186'}= "Be very careful when making changes to the Registry!"; + +=item Deleting our new tip + + $tips= $Registry->{"LMachine/Software/Microsoft/"}-> + {"Windows/CurrentVersion/Explorer/Tips/"} + or die "Can't find the Windows tips: $^E\n"; + $tip186= delete $tips{'/186'}; + +Note that Perl's C<delete> function returns the value that was deleted. + +=item Adding a new tip differently + + $Registry->{"LMachine/Software/Microsoft/" . + "Windows/CurrentVersion/Explorer/Tips//186"}= + "Be very careful when making changes to the Registry!"; + +=item Deleting differently + + $tip186= delete $Registry->{"LMachine/Software/Microsoft/Windows/" . + "CurrentVersion/Explorer/Tips//186"}; + +Note that this only deletes the tail of what we looked up, the +C<"186"> value, not any of the keys listed. + +=item Deleting a key + +WARNING: The following code will delete all information about the +current user's tip preferences. Actually executing this command +would probably cause the user to see the Welcome screen the next +time they log in and may cause more serious problems. This +statement is shown as an example only and should not be used when +experimenting. + + $tips= delete $Registry->{"CUser/Software/Microsoft/Windows/" . + "CurrentVersion/Explorer/Tips/"}; + +This deletes the C<"Tips"> key and the values it contains. The +C<delete> function will return a reference to a hash [not a tied +hash] containing the value names and value data that were deleted. + +The information to be returned is copied from the Registry into a +regular Perl hash before the key is deleted. If the key has many +subkeys, this copying could take a significant amount of memory +and/or processor time. So you can disable this process by calling +the C<FastDelete> member function: + + $prevSetting= $regKey->FastDelete(1); + +which will cause all subsequent delete operations via C<$regKey> +to simply return a true value if they succeed. This optimization +is automatically done if you use C<delete> in a void context. + +=item Technical notes on deleting + +If you use C<delete> to delete a Registry key or value and use +the return value, then I<Win32::TieRegistry> usually looks up the +current contents of that key or value so they can be returned if +the deletion is successful. If the deletion succeeds but the +attempt to lookup the old contents failed, then the return value +of C<delete> will be C<$^E> from the failed part of the operation. + +=item Undeleting a key + + $Registry->{"LMachine/Software/Microsoft/Windows/" . + "CurrentVersion/Explorer/Tips/"}= $tips; + +This adds back what we just deleted. Note that this version of +I<Win32::TieRegistry> will use defaults for the key attributes +[such as class name and security] and will not restore the +previous attributes. + +=item Not deleting a key + +WARNING: Actually executing the following code could cause +serious problems. This statement is shown as an example only and +should not be used when experimenting. + + $res= delete $Registry->{"CUser/Software/Microsoft/Windows/"} + defined($res) || die "Can't delete URL key: $^E\n"; + +Since the "Windows" key should contain subkeys, that C<delete> +statement should make no changes to the Registry, return C<undef>, +and set C<$^E> to "Access is denied". + +=item Not deleting again + + $tips= $Registry->{"CUser/Software/Microsoft/Windows/" . + "CurrentVersion/Explorer/Tips/"}; + delete $tips; + +The Perl C<delete> function requires that its argument be an +expression that ends in a hash element lookup [or hash slice], +which is not the case here. The C<delete> function doesn't +know which hash $tips came from and so can't delete it. + +=back + +=head2 Objects Documentation + +The following member functions are defined for use on +I<Win32::TieRegistry> objects: + +=over + +=item new + +The C<new> method creates a new I<Win32::TieRegistry> object. +C<new> is mostly a synonym for C<Open()> so see C<Open()> below for +information on what arguments to pass in. Examples: + + $machKey= new Win32::TieRegistry "LMachine" + or die "Can't access HKEY_LOCAL_MACHINE key: $^E\n"; + $userKey= Win32::TieRegistry->new("CUser") + or die "Can't access HKEY_CURRENT_USER key: $^E\n"; + +Note that calling C<new> via a reference to a tied hash returns +a simple object, not a reference to a tied hash. + +=item Open + +=item $subKey= $key->Open( $sSubKey, $rhOptions ) + +The C<Open> method opens a Registry key and returns a new +I<Win32::TieRegistry> object associated with that Registry key. +If C<Open> is called via a reference to a tied hash, then C<Open> +returns another reference to a tied hash. Otherwise C<Open> +returns a simple object and you should then use C<TiedRef> to get +a reference to a tied hash. + +C<$sSubKey> is a string specifying a subkey to be opened. +Alternately C<$sSubKey> can be a reference to an array value +containing the list of increasingly deep subkeys specifying the +path to the subkey to be opened. + +C<$rhOptions> is an optional reference to a hash containing extra +options. The C<Open> method supports two options, C<"Delimiter"> +and C<"Access">, and C<$rhOptions> should have only have zero or +more of these strings as keys. See the "Examples" section below +for more information. + +The C<"Delimiter"> option specifies what string [usually a single +character] will be used as the delimiter to be appended to subkey +names and prepended to value names. If this option is not specified, +the new key [C<$subKey>] inherits the delimiter of the old key +[C<$key>]. + +The C<"Access"> option specifies what level of access to the +Registry key you wish to have once it has been opened. If this +option is not specified, the new key [C<$subKey>] is opened with +the same access level used when the old key [C<$key>] was opened. +The virtual root of the Registry pretends it was opened with +access C<KEY_READ()|KEY_WRITE()> so this is the default access when +opening keys directory via C<$Registry>. If you don't plan on +modifying a key, you should open it with C<KEY_READ> access as +you may not have C<KEY_WRITE> access to it or some of its subkeys. + +If the C<"Access"> option value is a string that starts with +C<"KEY_">, then it should match E<one> of the predefined access +levels [probably C<"KEY_READ">, C<"KEY_WRITE">, or +C<"KEY_ALL_ACCESS">] exported by the I<Win32API::Registry> module. +Otherwise, a numeric value is expected. For maximum flexibility, +include C<use Win32::TieRegistry qw(:KEY_);>, for example, near +the top of your script so you can specify more complicated access +levels such as C<KEY_READ()|KEY_WRITE()>. + +If C<$sSubKey> does not begin with the delimiter [or C<$sSubKey> +is an array reference], then the path to the subkey to be opened +will be relative to the path of the original key [C<$key>]. If +C<$sSubKey> begins with a single delimiter, then the path to the +subkey to be opened will be relative to the virtual root of the +Registry on whichever machine the original key resides. If +C<$sSubKey> begins with two consectutive delimiters, then those +must be followed by a machine name which causes the C<Connect()> +method function to be called. + +Examples: + + $machKey= $Registry->Open( "LMachine", {Access=>KEY_READ(),Delimiter=>"/"} ) + or die "Can't open HKEY_LOCAL_MACHINE key: $^E\n"; + $swKey= $machKey->Open( "Software" ); + $logonKey= $swKey->Open( "Microsoft/Windows NT/CurrentVersion/Winlogon/" ); + $NTversKey= $swKey->Open( ["Microsoft","Windows NT","CurrentVersion"] ); + $versKey= $swKey->Open( qw(Microsoft Windows CurrentVersion) ); + + $remoteKey= $Registry->Open( "//HostA/LMachine/System/", {Delimiter=>"/"} ) + or die "Can't connect to HostA or can't open subkey: $^E\n"; + +=item Clone + +=item $copy= $key->Clone + +Creates a new object that is associated with the same Registry key +as the invoking object. + +=item Connect + +=item $remoteKey= $Registry->Connect( $sMachineName, $sKeyPath, $rhOptions ) + +The C<Connect> method connects to the Registry of a remote machine, +and opens a key within it, then returns a new I<Win32::TieRegistry> +object associated with that remote Registry key. If C<Connect> +was called using a reference to a tied hash, then the return value +will also be a reference to a tied hash [or C<undef>]. Otherwise, +if you wish to use the returned object as a tied hash [not just as +an object], then use the C<TiedRef> method function after C<Connect>. + +C<$sMachineName> is the name of the remote machine. You don't have +to preceed the machine name with two delimiter characters. + +C<$sKeyPath> is a string specifying the remote key to be opened. +Alternately C<$sKeyPath> can be a reference to an array value +containing the list of increasingly deep keys specifying the path +to the key to be opened. + +C<$rhOptions> is an optional reference to a hash containing extra +options. The C<Connect> method supports two options, C<"Delimiter"> +and C<"Access">. See the C<Open> method documentation for more +information on these options. + +C<$sKeyPath> is already relative to the virtual root of the Registry +of the remote machine. A single leading delimiter on C<sKeyPath> +will be ignored and is not required. + +C<$sKeyPath> can be empty in which case C<Connect> will return an +object representing the virtual root key of the remote Registry. +Each subsequent use of C<Open> on this virtual root key will call +the system C<RegConnectRegistry> function. + +The C<Connect> method can be called via any I<Win32::TieRegistry> +object, not just C<$Registry>. Attributes such as the desired +level of access and the delimiter will be inherited from the +object used but the C<$sKeyPath> will always be relative to the +virtual root of the remote machine's registry. + +Examples: + + $remMachKey= $Registry->Connect( "HostA", "LMachine", {Delimiter->"/"} ) + or die "Can't connect to HostA's HKEY_LOCAL_MACHINE key: $^E\n"; + + $remVersKey= $remMachKey->Connect( "www.microsoft.com", + "LMachine/Software/Microsoft/Inetsrv/CurrentVersion/", + { Access=>KEY_READ, Delimiter=>"/" } ) + or die "Can't check what version of IIS Microsoft is running: $^E\n"; + + $remVersKey= $remMachKey->Connect( "www", + qw(LMachine Software Microsoft Inetsrv CurrentVersion) ) + or die "Can't check what version of IIS we are running: $^E\n"; + +=item ObjectRef + +=item $object_ref= $obj_or_hash_ref->ObjectRef + +For a simple object, just returns itself [C<$obj == $obj->ObjectRef>]. + +For a reference to a tied hash [if it is also an object], C<ObjectRef> +returns the simple object that the hash is tied to. + +This is primarilly useful when debugging since typing C<x $Registry> +will try to display your I<entire> registry contents to your screen. +But the debugger command C<x $Registry->ObjectRef> will just dump +the implementation details of the underlying object to your screen. + +=item Flush( $bFlush ) + +Flushes all cached information about the Registry key so that future +uses will get fresh data from the Registry. + +If the optional C<$bFlush> is specified and a true value, then +C<RegFlushKey()> will be called, which is almost never necessary. + +=item GetValue + +=item $ValueData= $key->GetValue( $sValueName ) + +=item ($ValueData,$ValueType)= $key->GetValue( $sValueName ) + +Gets a Registry value's data and data type. + +C<$ValueData> is usually just a Perl string that contains the +value data [packed into it]. For certain types of data, however, +C<$ValueData> may be processed as described below. + +C<$ValueType> is the C<REG_*> constant describing the type of value +data stored in C<$ValueData>. If the C<DualTypes()> option is on, +then C<$ValueType> will be a dual value. That is, when used in a +numeric context, C<$ValueType> will give the numeric value of a +C<REG_*> constant. However, when used in a non-numeric context, +C<$ValueType> will return the name of the C<REG_*> constant, for +example C<"REG_SZ"> [note the quotes]. So both of the following +can be true at the same time: + + $ValueType == REG_SZ() + $ValueType eq "REG_SZ" + +=over + +=item REG_SZ and REG_EXPAND_SZ + +If the C<FixSzNulls()> option is on, then the trailing C<'\0'> will be +stripped [unless there isn't one] before values of type C<REG_SZ> +and C<REG_EXPAND_SZ> are returned. Note that C<SetValue()> will add +a trailing C<'\0'> under similar circumstances. + +=item REG_MULTI_SZ + +If the C<SplitMultis()> option is on, then values of this type are +returned as a reference to an array containing the strings. For +example, a value that, with C<SplitMultis()> off, would be returned as: + + "Value1\000Value2\000\000" + +would be returned, with C<SplitMultis()> on, as: + + [ "Value1", "Value2" ] + +=item REG_DWORD + +If the C<DualBinVals()> option is on, then the value is returned +as a scalar containing both a string and a number [much like +the C<$!> variable -- see the L<SetDualVar> module for more +information] where the number part is the "unpacked" value. +Use the returned value in a numeric context to access this part +of the value. For example: + + $num= 0 + $Registry->{"CUser/Console//ColorTable01"}; + +If the C<DWordsToHex()> option is off, the string part of the +returned value is a packed, 4-byte string [use C<unpack("L",$value)> +to get the numeric value. + +If C<DWordsToHex()> is on, the string part of the returned value is +a 10-character hex strings [with leading "0x"]. You can use +C<hex($value)> to get the numeric value. + +Note that C<SetValue()> will properly understand each of these +returned value formats no matter how C<DualBinVals()> is set. + +=back + +=item ValueNames + +=item @names= $key->ValueNames + +Returns the list of value names stored directly in a Registry key. +Note that the names returned do I<not> have a delimiter prepended +to them like with C<MemberNames()> and tied hashes. + +Once you request this information, it is cached in the object and +future requests will always return the same list unless C<Flush()> +has been called. + +=item SubKeyNames + +=item @key_names= $key->SubKeyNames + +Returns the list of subkey names stored directly in a Registry key. +Note that the names returned do I<not> have a delimiter appended +to them like with C<MemberNames()> and tied hashes. + +Once you request this information, it is cached in the object and +future requests will always return the same list unless C<Flush()> +has been called. + +=item SubKeyClasses + +=item @classes= $key->SubKeyClasses + +Returns the list of classes for subkeys stored directly in a +Registry key. The classes are returned in the same order as +the subkey names returned by C<SubKeyNames()>. + +=item SubKeyTimes + +=item @times= $key->SubKeyTimes + +Returns the list of last-modified times for subkeys stored +directly in a Registry key. The times are returned in the same +order as the subkey names returned by C<SubKeyNames()>. Each +time is a C<FILETIME> structure packed into a Perl string. + +Once you request this information, it is cached in the object and +future requests will always return the same list unless C<Flush()> +has been called. + +=item MemberNames + +=item @members= $key->MemberNames + +Returns the list of subkey names and value names stored directly +in a Registry key. Subkey names have a delimiter appended to the +end and value names have a delimiter prepended to the front. + +Note that a value name could end in a delimiter [or could be C<""> +so that the member name returned is just a delimiter] so the +presence or absence of the leading delimiter is what should be +used to determine whether a particular name is for a subkey or a +value, not the presence or absence of a trailing delimiter. + +Once you request this information, it is cached in the object and +future requests will always return the same list unless C<Flush()> +has been called. + +=item Information + +=item %info= $key->Information + +=item @items= $key->Information( @itemNames ); + +Returns the following information about a Registry key: + +=over + +=item LastWrite + +A C<FILETIME> structure indicating when the key was last modified +and packed into a Perl string. + +=item CntSubKeys + +The number of subkeys stored directly in this key. + +=item CntValues + +The number of values stored directly in this key. + +=item SecurityLen + +The length [in bytes] of the largest[?] C<SECURITY_DESCRIPTOR> +associated with the Registry key. + +=item MaxValDataLen + +The length [in bytes] of the longest value data associated with +a value stored in this key. + +=item MaxSubKeyLen + +The length [in chars] of the longest subkey name associated with +a subkey stored in this key. + +=item MaxSubClassLen + +The length [in chars] of the longest class name associated with +a subkey stored directly in this key. + +=item MaxValNameLen + +The length [in chars] of the longest value name associated with +a value stored in this key. + +=back + +With no arguments, returns a hash [not a reference to a hash] where +the keys are the names for the items given above and the values +are the information describe above. For example: + + %info= ( "CntValues" => 25, # Key contains 25 values. + "MaxValNameLen" => 20, # One of which has a 20-char name. + "MaxValDataLen" => 42, # One of which has a 42-byte value. + "CntSubKeys" => 1, # Key has 1 immediate subkey. + "MaxSubKeyLen" => 13, # One of which has a 12-char name. + "MaxSubClassLen" => 0, # All of which have class names of "". + "SecurityLen" => 232, # One SECURITY_DESCRIPTOR is 232 bytes. + "LastWrite" => "\x90mZ\cX{\xA3\xBD\cA\c@\cA" + # Key was last modifed 1998/06/01 16:29:32 GMT + ); + +With arguments, each one must be the name of a item given above. +The return value is the information associated with the listed +names. In other words: + + return $key->Information( @names ); + +returns the same list as: + + %info= $key->Information; + return @info{@names}; + +=item Delimiter + +=item $oldDelim= $key->Delimiter + +=item $oldDelim= $key->Delimiter( $newDelim ) + +Gets and possibly changes the delimiter used for this object. The +delimiter is appended to subkey names and prepended to value names +in many return values. It is also used when parsing keys passed +to tied hashes. + +The delimiter defaults to backslash (C<'\\'>) but is inherited from +the object used to create a new object and can be specified by an +option when a new object is created. + +=item Handle + +=item $handle= $key->Handle + +Returns the raw C<HKEY> handle for the associated Registry key as +an integer value. This value can then be used to Reg*() calls +from I<Win32API::Registry>. However, it is usually easier to just +call the I<Win32API::Registry> calls directly via: + + $key->RegNotifyChangeKeyValue( ... ); + +For the virtual root of the local or a remote Registry, +C<Handle()> return C<"NONE">. + +=item Path + +=item $path= $key->Path + +Returns a string describing the path of key names to this +Registry key. The string is built so that if it were passed +to C<$Registry->Open()>, it would reopen the same Registry key +[except in the rare case where one of the key names contains +C<$key->Delimiter>]. + +=item Machine + +=item $computerName= $key->Machine + +Returns the name of the computer [or "machine"] on which this Registry +key resides. Returns C<""> for local Registry keys. + +=item Access + +Returns the numeric value of the bit mask used to specify the +types of access requested when this Registry key was opened. Can +be compared to C<KEY_*> values. + +=item OS_Delimiter + +Returns the delimiter used by the operating system's RegOpenKeyEx() +call. For Win32, this is always backslash (C<"\\">). + +=item Roots + +Returns the mapping from root key names like C<"LMachine"> to their +associated C<HKEY_*> constants. Primarily for internal use and +subject to change. + +=item Tie + +=item $key->Tie( \%hash ); + +Ties the referenced hash to that Registry key. Pretty much the +same as + + tie %hash, ref($key), $key; + +Since C<ref($key)> is the class [package] to tie the hash to and +C<TIEHASH()> just returns its argument, C<$key>, [without calling +C<new()>] when it sees that it is already a blessed object. + +=item TiedRef + +=item $TiedHashRef= $hash_or_obj_ref->TiedRef + +For a simple object, returns a reference to a hash tied to the +object. Used to promote a simple object into a combined object +and hash ref. + +If already a reference to a tied hash [that is also an object], +it just returns itself [C<$ref == $ref->TiedRef>]. + +Mostly used internally. + +=item ArrayValues + +=item $oldBool= $key->ArrayValues + +=item $oldBool= $key->ArrayValues( $newBool ) + +Gets the current setting of the C<ArrayValues> option and possibly +turns it on or off. + +When off, Registry values fetched via a tied hash are returned as +just a value scalar [the same as C<GetValue()> in a scalar context]. +When on, they are returned as a reference to an array containing +the value data as the C<[0]> element and the data type as the C<[1]> +element. + +=item TieValues + +=item $oldBool= TieValues + +=item $oldBool= TieValues( $newBool ) + +Gets the current setting of the C<TieValues> option and possibly +turns it on or off. + +Turning this option on is not yet supported in this release of +I<Win32::TieRegistry>. In a future release, turning this option +on will cause Registry values returned from a tied hash to be +a tied array that you can use to modify the value in the Registry. + +=item FastDelete + +=item $oldBool= $key->FastDelete + +=item $oldBool= $key->FastDelete( $newBool ) + +Gets the current setting of the C<FastDelete> option and possibly +turns it on or off. + +When on, successfully deleting a Registry key [via a tied hash] +simply returns C<1>. + +When off, successfully deleting a Registry key [via a tied hash +and not in a void context] returns a reference to a hash that +contains the values present in the key when it was deleted. This +hash is just like that returned when referencing the key before it +was deleted except that it is an ordinary hash, not one tied to +the I<Win32::TieRegistry> package. + +Note that deleting either a Registry key or value via a tied hash +I<in a void context> prevents any overhead in trying to build an +appropriate return value. + +Note that deleting a Registry I<value> via a tied hash [not in +a void context] returns the value data even if <FastDelete> is on. + +=item SplitMultis + +=item $oldBool= $key->SplitMultis + +=item $oldBool= $key->SplitMultis( $newBool ) + +Gets the current setting of the C<SplitMultis> option and possibly +turns it on or off. + +If on, Registry values of type C<REG_MULTI_SZ> are returned as +a reference to an array of strings. See C<GetValue()> for more +information. + +=item DWordsToHex + +=item $oldBool= $key->DWordsToHex + +=item $oldBool= $key->DWordsToHex( $newBool ) + +Gets the current setting of the C<DWordsToHex> option and possibly +turns it on or off. + +If on, Registry values of type C<REG_DWORD> are returned as a hex +string with leading C<"0x"> and longer than 4 characters. See +C<GetValue()> for more information. + +=item FixSzNulls + +=item $oldBool= $key->FixSzNulls + +=item $oldBool= $key->FixSzNulls( $newBool ) + +Gets the current setting of the C<FixSzNulls> option and possibly +turns it on or off. + +If on, Registry values of type C<REG_SZ> and C<REG_EXPAND_SZ> have +trailing C<'\0'>s added before they are set and stripped before +they are returned. See C<GetValue()> and C<SetValue()> for more +information. + +=item DualTypes + +=item $oldBool= $key->DualTypes + +=item $oldBool= $key->DualTypes( $newBool ) + +Gets the current setting of the C<DualTypes> option and possibly +turns it on or off. + +If on, data types are returned as a combined numeric/string value +holding both the numeric value of a C<REG_*> constant and the +string value of the constant's name. See C<GetValue()> for +more information. + +=item DualBinVals + +=item $oldBool= $key->DualBinVals + +=item $oldBool= $key->DualBinVals( $newBool ) + +Gets the current setting of the C<DualBinVals> option and possibly +turns it on or off. + +If on, Registry value data of type C<REG_BINARY> and no more than +4 bytes long and Registry values of type C<REG_DWORD> are returned +as a combined numeric/string value where the numeric value is the +"unpacked" binary value as returned by: + + hex reverse unpack( "h*", $valData ) + +on a "little-endian" computer. [Would be C<hex unpack("H*",$valData)> +on a "big-endian" computer if this module is ever ported to one.] + +See C<GetValue()> for more information. + +=item GetOptions + +=item @oldOptValues= $key->GetOptions( @optionNames ) + +=item $refHashOfOldOpts= $key->GetOptions() + +=item $key->GetOptions( \%hashForOldOpts ) + +Returns the current setting of any of the following options: + + Delimiter FixSzNulls DWordsToHex + ArrayValues SplitMultis DualBinVals + TieValues FastDelete DualTypes + +Pass in one or more of the above names (as strings) to get back +an array of the corresponding current settings in the same order: + + my( $fastDel, $delim )= $key->GetOptions("FastDelete","Delimiter"); + +Pass in no arguments to get back a reference to a hash where +the above option names are the keys and the values are +the corresponding current settings for each option: + + my $href= $key->GetOptions(); + my $delim= $href->{Delimiter}; + +Pass in a single reference to a hash to have the above key/value +pairs I<added> to the referenced hash. For this case, the +return value is the original object so further methods can be +chained after the call to GetOptions: + + my %oldOpts; + $key->GetOptions( \%oldOpts )->SetOptions( Delimiter => "/" ); + +=item SetOptions + +=item @oldOpts= $key->SetOptions( optNames=>$optValue,... ) + +Changes the current setting of any of the following options, +returning the previous setting(s): + + Delimiter FixSzNulls DWordsToHex AllowLoad + ArrayValues SplitMultis DualBinVals AllowSave + TieValues FastDelete DualTypes + +For C<AllowLoad> and C<AllowSave>, instead of the previous +setting, C<SetOptions> returns whether or not the change was +successful. + +In a scalar context, returns only the last item. The last +option can also be specified as C<"ref"> or C<"r"> [which doesn't +need to be followed by a value] to allow chaining: + + $key->SetOptions(AllowSave=>1,"ref")->RegSaveKey(...) + +=item SetValue + +=item $okay= $key->SetValue( $ValueName, $ValueData ); + +=item $okay= $key->SetValue( $ValueName, $ValueData, $ValueType ); + +Adds or replaces a Registry value. Returns a true value if +successfully, false otherwise. + +C<$ValueName> is the name of the value to add or replace and +should I<not> have a delimiter prepended to it. Case is ignored. + +C<$ValueType> is assumed to be C<REG_SZ> if it is omitted. Otherwise, +it should be one the C<REG_*> constants. + +C<$ValueData> is the data to be stored in the value, probably packed +into a Perl string. Other supported formats for value data are +listed below for each posible C<$ValueType>. + +=over + +=item REG_SZ or REG_EXPAND_SZ + +The only special processing for these values is the addition of +the required trailing C<'\0'> if it is missing. This can be +turned off by disabling the C<FixSzNulls> option. + +=item REG_MULTI_SZ + +These values can also be specified as a reference to a list of +strings. For example, the following two lines are equivalent: + + $key->SetValue( "Val1\000Value2\000LastVal\000\000", "REG_MULTI_SZ" ); + $key->SetValue( ["Val1","Value2","LastVal"], "REG_MULTI_SZ" ); + +Note that if the required two trailing nulls (C<"\000\000">) are +missing, then this release of C<SetValue()> will I<not> add them. + +=item REG_DWORD + +These values can also be specified as a hex value with the leading +C<"0x"> included and totaling I<more than> 4 bytes. These will be +packed into a 4-byte string via: + + $data= pack( "L", hex($data) ); + +=item REG_BINARY + +This value type is listed just to emphasize that no alternate +format is supported for it. In particular, you should I<not> pass +in a numeric value for this type of data. C<SetValue()> cannot +distinguish such from a packed string that just happens to match +a numeric value and so will treat it as a packed string. + +=back + +An alternate calling format: + + $okay= $key->SetValue( $ValueName, [ $ValueData, $ValueType ] ); + +[two arguments, the second of which is a reference to an array +containing the value data and value type] is supported to ease +using tied hashes with C<SetValue()>. + +=item CreateKey + +=item $newKey= $key->CreateKey( $subKey ); + +=item $newKey= $key->CreateKey( $subKey, { Option=>OptVal,... } ); + +Creates a Registry key or just updates attributes of one. Calls +C<RegCreateKeyEx()> then, if it succeeded, creates an object +associated with the [possibly new] subkey. + +C<$subKey> is the name of a subkey [or a path to one] to be +created or updated. It can also be a reference to an array +containing a list of subkey names. + +The second argument, if it exists, should be a reference to a +hash specifying options either to be passed to C<RegCreateKeyEx()> +or to be used when creating the associated object. The following +items are the supported keys for this options hash: + +=over + +=item Delimiter + +Specifies the delimiter to be used to parse C<$subKey> and to be +used in the new object. Defaults to C<$key->Delimiter>. + +=item Access + +Specifies the types of access requested when the subkey is opened. +Should be a numeric bit mask that combines one or more C<KEY_*> +constant values. + +=item Class + +The name to assign as the class of the new or updated subkey. +Defaults to C<""> as we have never seen a use for this information. + +=item Disposition + +Lets you specify a reference to a scalar where, upon success, will be +stored either C<REG_CREATED_NEW_KEY()> or C<REG_OPENED_EXISTING_KEY()> +depending on whether a new key was created or an existing key was +opened. + +If you, for example, did C<use Win32::TieRegistry qw(REG_CREATED_NEW_KEY)> +then you can use C<REG_CREATED_NEW_KEY()> to compare against the numeric +value stored in the referenced scalar. + +If the C<DualTypes> option is enabled, then in addition to the +numeric value described above, the referenced scalar will also +have a string value equal to either C<"REG_CREATED_NEW_KEY"> or +C<"REG_OPENED_EXISTING_KEY">, as appropriate. + +=item Security + +Lets you specify a C<SECURITY_ATTRIBUTES> structure packed into a +Perl string. See C<Win32API::Registry::RegCreateKeyEx()> for more +information. + +=item Volatile + +If true, specifies that the new key should be volatile, that is, +stored only in memory and not backed by a hive file [and not saved +if the computer is rebooted]. This option is ignored under +Windows 95. Specifying C<Volatile=E<GT>1> is the same as +specifying C<Options=E<GT>REG_OPTION_VOLATILE>. + +=item Backup + +If true, specifies that the new key should be opened for +backup/restore access. The C<Access> option is ignored. If the +calling process has enabled C<"SeBackupPrivilege">, then the +subkey is opened with C<KEY_READ> access as the C<"LocalSystem"> +user which should have access to all subkeys. If the calling +process has enabled C<"SeRestorePrivilege">, then the subkey is +opened with C<KEY_WRITE> access as the C<"LocalSystem"> user which +should have access to all subkeys. + +This option is ignored under Windows 95. Specifying C<Backup=E<GT>1> +is the same as specifying C<Options=E<GT>REG_OPTION_BACKUP_RESTORE>. + +=item Options + +Lets you specify options to the C<RegOpenKeyEx()> call. The value +for this option should be a numeric value combining zero or more +of the C<REG_OPTION_*> bit masks. You may with to used the +C<Volatile> and/or C<Backup> options instead of this one. + +=back + +=item StoreKey + +=item $newKey= $key->StoreKey( $subKey, \%Contents ); + +Primarily for internal use. + +Used to create or update a Registry key and any number of subkeys +or values under it or its subkeys. + +C<$subKey> is the name of a subkey to be created [or a path of +subkey names separated by delimiters]. If that subkey already +exists, then it is updated. + +C<\%Contents> is a reference to a hash containing pairs of +value names with value data and/or subkey names with hash +references similar to C<\%Contents>. Each of these cause +a value or subkey of C<$subKey> to be created or updated. + +If C<$Contents{""}> exists and is a reference to a hash, then +it used as the options argument when C<CreateKey()> is called +for C<$subKey>. This allows you to specify ... + + if( defined( $$data{""} ) && "HASH" eq ref($$data{""}) ) { + $self= $this->CreateKey( $subKey, delete $$data{""} ); + +=item Load + +=item $newKey= $key->Load( $file ) + +=item $newKey= $key->Load( $file, $newSubKey ) + +=item $newKey= $key->Load( $file, $newSubKey, { Option=>OptVal... } ) + +=item $newKey= $key->Load( $file, { Option=>OptVal... } ) + +Loads a hive file into a Registry. That is, creates a new subkey +and associates a hive file with it. + +C<$file> is a hive file, that is a file created by calling +C<RegSaveKey()>. The C<$file> path is interpreted relative to +C<%SystemRoot%/System32/config> on the machine where C<$key> +resides. + +C<$newSubKey> is the name to be given to the new subkey. If +C<$newSubKey> is specified, then C<$key> must be +C<HKEY_LOCAL_MACHINE> or C<HKEY_USERS> of the local computer +or a remote computer and C<$newSubKey> should not contain any +occurrences of either the delimiter or the OS delimiter. + +If C<$newSubKey> is not specified, then it is as if C<$key> +was C<$Registry-E<GT>{LMachine}> and C<$newSubKey> is +C<"PerlTie:999"> where C<"999"> is actually a sequence number +incremented each time this process calls C<Load()>. + +You can specify as the last argument a reference to a hash +containing options. You can specify the same options that you +can specify to C<Open()>. See C<Open()> for more information on +those. In addition, you can specify the option C<"NewSubKey">. +The value of this option is interpretted exactly as if it was +specified as the C<$newSubKey> parameter and overrides the +C<$newSubKey> if one was specified. + +The hive is automatically unloaded when the returned object +[C<$newKey>] is destroyed. Registry key objects opened within +the hive will keep a reference to the C<$newKey> object so that +it will not be destroyed before these keys are closed. + +=item UnLoad + +=item $okay= $key->UnLoad + +Unloads a hive that was loaded via C<Load()>. Cannot unload other +hives. C<$key> must be the return from a previous call to C<Load()>. +C<$key> is closed and then the hive is unloaded. + +=item AllowSave + +=item $okay= AllowSave( $bool ) + +Enables or disables the C<"ReBackupPrivilege"> privilege for the +current process. You will probably have to enable this privilege +before you can use C<RegSaveKey()>. + +The return value indicates whether the operation succeeded, not +whether the privilege was previously enabled. + +=item AllowLoad + +=item $okay= AllowLoad( $bool ) + +Enables or disables the C<"ReRestorePrivilege"> privilege for the +current process. You will probably have to enable this privilege +before you can use C<RegLoadKey()>, C<RegUnLoadKey()>, +C<RegReplaceKey()>, or C<RegRestoreKey> and thus C<Load()> and +C<UnLoad()>. + +The return value indicates whether the operation succeeded, not +whether the privilege was previously enabled. + +=back + +=head2 Exports [C<use> and C<import()>] + +To have nothing imported into your package, use something like: + + use Win32::TieRegistry 0.20 (); + +which would verify that you have at least version 0.20 but wouldn't +call C<import()>. The F<Changes> file can be useful in figuring out +which, if any, prior versions of I<Win32::TieRegistry> you want to +support in your script. + +The code + + use Win32::TieRegistry; + +imports the variable C<$Registry> into your package and sets it +to be a reference to a hash tied to a copy of the master Registry +virtual root object with the default options. One disadvantage +to this "default" usage is that Perl does not support checking +the module version when you use it. + +Alternately, you can specify a list of arguments on the C<use> +line that will be passed to the C<Win32::TieRegistry->import()> +method to control what items to import into your package. These +arguments fall into the following broad categories: + +=over + +=item Import a reference to a hash tied to a Registry virtual root + +You can request that a scalar variable be imported (possibly) +and set to be a reference to a hash tied to a Registry virtual root +using any of the following types of arguments or argument pairs: + +=over + +=item "TiedRef", '$scalar' + +=item "TiedRef", '$pack::scalar' + +=item "TiedRef", 'scalar' + +=item "TiedRef", 'pack::scalar' + +All of the above import a scalar named C<$scalar> into your package +(or the package named "pack") and then sets it. + +=item '$scalar' + +=item '$pack::scalar' + +These are equivalent to the previous items to support a more +traditional appearance to the list of exports. Note that the +scalar name cannot be "RegObj" here. + +=item "TiedRef", \$scalar + +=item \$scalar + +These versions don't import anything but set the referenced C<$scalar>. + +=back + +=item Import a hash tied to the Registry virtual root + +You can request that a hash variable be imported (possibly) +and tied to a Registry virtual root using any of the following +types of arguments or argument pairs: + +=over + +=item "TiedHash", '%hash' + +=item "TiedHash", '%pack::hash' + +=item "TiedHash", 'hash' + +=item "TiedHash", 'pack::hash' + +All of the above import a hash named C<%hash> into your package +(or the package named "pack") and then sets it. + +=item '%hash' + +=item '%pack::hash' + +These are equivalent to the previous items to support a more +traditional appearance to the list of exports. + +=item "TiedHash", \%hash + +=item \%hash + +These versions don't import anything but set the referenced C<%hash>. + +=back + +=item Import a Registry virtual root object + +You can request that a scalar variable be imported (possibly) +and set to be a Registry virtual root object using any of the +following types of arguments or argument pairs: + +=over + +=item "ObjectRef", '$scalar' + +=item "ObjectRef", '$pack::scalar' + +=item "ObjectRef", 'scalar' + +=item "ObjectRef", 'pack::scalar' + +All of the above import a scalar named C<$scalar> into your package +(or the package named "pack") and then sets it. + +=item '$RegObj' + +This is equivalent to the previous items for backward compatibility. + +=item "ObjectRef", \$scalar + +This version doesn't import anything but sets the referenced C<$scalar>. + +=back + +=item Import constant(s) exported by I<Win32API::Registry> + +You can list any constants that are exported by I<Win32API::Registry> +to have them imported into your package. These constants have names +starting with "KEY_" or "REG_" (or even "HKEY_"). + +You can also specify C<":KEY_">, C<":REG_">, and even C<":HKEY_"> to +import a whole set of constants. + +See I<Win32API::Registry> documentation for more information. + +=item Options + +You can list any option names that can be listed in the C<SetOptions()> +method call, each folowed by the value to use for that option. +A Registry virtual root object is created, all of these options are +set for it, then each variable to be imported/set is associated with +this object. + +In addition, the following special options are supported: + +=over + +=item ExportLevel + +Whether to import variables into your package or some +package that uses your package. Defaults to the value of +C<$Exporter::ExportLevel> and has the same meaning. See +the L<Exporter> module for more information. + +=item ExportTo + +The name of the package to import variables and constants into. +Overrides I<ExportLevel>. + +=back + +=back + +=head3 Specifying constants in your Perl code + +This module was written with a strong emphasis on the convenience of +the module user. Therefore, most places where you can specify a +constant like C<REG_SZ()> also allow you to specify a string +containing the name of the constant, C<"REG_SZ">. This is convenient +because you may not have imported that symbolic constant. + +Perl also emphasizes programmer convenience so the code C<REG_SZ> +can be used to mean C<REG_SZ()> or C<"REG_SZ"> or be illegal. +Note that using C<®_SZ> (as we've seen in much Win32 Perl code) +is not a good idea since it passes the current C<@_> to the +C<constant()> routine of the module which, at the least, can give +you a warning under B<-w>. + +Although greatly a matter of style, the "safest" practice is probably +to specifically list all constants in the C<use Win32::TieRegistry> +statement, specify C<use strict> [or at least C<use strict qw(subs)>], +and use bare constant names when you want the numeric value. This will +detect mispelled constant names at compile time. + + use strict; + my $Registry; + use Win32::TieRegistry 0.20 ( + TiedRef => \$Registry, Delimiter => "/", ArrayValues => 1, + SplitMultis => 1, AllowLoad => 1, + qw( REG_SZ REG_EXPAND_SZ REG_DWORD REG_BINARY REG_MULTI_SZ + KEY_READ KEY_WRITE KEY_ALL_ACCESS ), + ); + $Registry->{"LMachine/Software/FooCorp/"}= { + "FooWriter/" => { + "/Fonts" => [ ["Times","Courier","Lucinda"], REG_MULTI_SZ ], + "/WindowSize" => [ pack("LL",24,80), REG_BINARY ], + "/TaskBarIcon" => [ "0x0001", REG_DWORD ], + }, + } or die "Can't create Software/FooCorp/: $^E\n"; + +If you don't want to C<use strict qw(subs)>, the second safest practice +is similar to the above but use the C<REG_SZ()> form for constants +when possible and quoted constant names when required. Note that +C<qw()> is a form of quoting. + + use Win32::TieRegistry 0.20 qw( + TiedRef $Registry + Delimiter / ArrayValues 1 SplitMultis 1 AllowLoad 1 + REG_SZ REG_EXPAND_SZ REG_DWORD REG_BINARY REG_MULTI_SZ + KEY_READ KEY_WRITE KEY_ALL_ACCESS + ); + $Registry->{"LMachine/Software/FooCorp/"}= { + "FooWriter/" => { + "/Fonts" => [ ["Times","Courier","Lucinda"], REG_MULTI_SZ() ], + "/WindowSize" => [ pack("LL",24,80), REG_BINARY() ], + "/TaskBarIcon" => [ "0x0001", REG_DWORD() ], + }, + } or die "Can't create Software/FooCorp/: $^E\n"; + +The examples in this document mostly use quoted constant names +(C<"REG_SZ">) since that works regardless of which constants +you imported and whether or not you have C<use strict> in your +script. It is not the best choice for you to use for real +scripts (vs. examples) because it is less efficient and is not +supported by most other similar modules. + +=head1 SUMMARY + +Most things can be done most easily via tied hashes. Skip down to the +the L<Tied Hashes Summary> to get started quickly. + +=head2 Objects Summary + +Here are quick examples that document the most common functionality +of all of the method functions [except for a few almost useless ones]. + + # Just another way of saying Open(): + $key= new Win32::TieRegistry "LMachine\\Software\\", + { Access=>KEY_READ()|KEY_WRITE(), Delimiter=>"\\" }; + + # Open a Registry key: + $subKey= $key->Open( "SubKey/SubSubKey/", + { Access=>KEY_ALL_ACCESS, Delimiter=>"/" } ); + + # Connect to a remote Registry key: + $remKey= $Registry->Connect( "MachineName", "LMachine/", + { Access=>KEY_READ, Delimiter=>"/" } ); + + # Get value data: + $valueString= $key->GetValue("ValueName"); + ( $valueString, $valueType )= $key->GetValue("ValueName"); + + # Get list of value names: + @valueNames= $key->ValueNames; + + # Get list of subkey names: + @subKeyNames= $key->SubKeyNames; + + # Get combined list of value names (with leading delimiters) + # and subkey names (with trailing delimiters): + @memberNames= $key->MemberNames; + + # Get all information about a key: + %keyInfo= $key->Information; + # keys(%keyInfo)= qw( Class LastWrite SecurityLen + # CntSubKeys MaxSubKeyLen MaxSubClassLen + # CntValues MaxValNameLen MaxValDataLen ); + + # Get selected information about a key: + ( $class, $cntSubKeys )= $key->Information( "Class", "CntSubKeys" ); + + # Get and/or set delimiter: + $delim= $key->Delimiter; + $oldDelim= $key->Delimiter( $newDelim ); + + # Get "path" for an open key: + $path= $key->Path; + # For example, "/CUser/Control Panel/Mouse/" + # or "//HostName/LMachine/System/DISK/". + + # Get name of machine where key is from: + $mach= $key->Machine; + # Will usually be "" indicating key is on local machine. + + # Control different options (see main documentation for descriptions): + $oldBool= $key->ArrayValues( $newBool ); + $oldBool= $key->FastDelete( $newBool ); + $oldBool= $key->FixSzNulls( $newBool ); + $oldBool= $key->SplitMultis( $newBool ); + $oldBool= $key->DWordsToHex( $newBool ); + $oldBool= $key->DualBinVals( $newBool ); + $oldBool= $key->DualTypes( $newBool ); + @oldBools= $key->SetOptions( ArrayValues=>1, FastDelete=>1, FixSzNulls=>0, + Delimiter=>"/", AllowLoad=>1, AllowSave=>1 ); + @oldBools= $key->GetOptions( ArrayValues, FastDelete, FixSzNulls ); + + # Add or set a value: + $key->SetValue( "ValueName", $valueDataString ); + $key->SetValue( "ValueName", pack($format,$valueData), "REG_BINARY" ); + + # Add or set a key: + $key->CreateKey( "SubKeyName" ); + $key->CreateKey( "SubKeyName", + { Access=>"KEY_ALL_ACCESS", Class=>"ClassName", + Delimiter=>"/", Volatile=>1, Backup=>1 } ); + + # Load an off-line Registry hive file into the on-line Registry: + $newKey= $Registry->Load( "C:/Path/To/Hive/FileName" ); + $newKey= $key->Load( "C:/Path/To/Hive/FileName", "NewSubKeyName", + { Access=>"KEY_READ" } ); + # Unload a Registry hive file loaded via the Load() method: + $newKey->UnLoad; + + # (Dis)Allow yourself to load Registry hive files: + $success= $Registry->AllowLoad( $bool ); + + # (Dis)Allow yourself to save a Registry key to a hive file: + $success= $Registry->AllowSave( $bool ); + + # Save a Registry key to a new hive file: + $key->RegSaveKey( "C:/Path/To/Hive/FileName", [] ); + +=head3 Other Useful Methods + +See I<Win32API::Registry> for more information on these methods. +These methods are provided for coding convenience and are +identical to the I<Win32API::Registry> functions except that these +don't take a handle to a Registry key, instead getting the handle +from the invoking object [C<$key>]. + + $key->RegGetKeySecurity( $iSecInfo, $sSecDesc, $lenSecDesc ); + $key->RegLoadKey( $sSubKeyName, $sPathToFile ); + $key->RegNotifyChangeKeyValue( + $bWatchSubtree, $iNotifyFilter, $hEvent, $bAsync ); + $key->RegQueryMultipleValues( + $structValueEnts, $cntValueEnts, $Buffer, $lenBuffer ); + $key->RegReplaceKey( $sSubKeyName, $sPathToNewFile, $sPathToBackupFile ); + $key->RegRestoreKey( $sPathToFile, $iFlags ); + $key->RegSetKeySecurity( $iSecInfo, $sSecDesc ); + $key->RegUnLoadKey( $sSubKeyName ); + +=head2 Tied Hashes Summary + +For fast learners, this may be the only section you need to read. +Always append one delimiter to the end of each Registry key name +and prepend one delimiter to the front of each Registry value name. + +=head3 Opening keys + + use Win32::TieRegistry ( Delimiter=>"/", ArrayValues=>1 ); + $Registry->Delimiter("/"); # Set delimiter to "/". + $swKey= $Registry->{"LMachine/Software/"}; + $winKey= $swKey->{"Microsoft/Windows/CurrentVersion/"}; + $userKey= $Registry-> + {"CUser/Software/Microsoft/Windows/CurrentVersion/"}; + $remoteKey= $Registry->{"//HostName/LMachine/"}; + +=head3 Reading values + + $progDir= $winKey->{"/ProgramFilesDir"}; # "C:\\Program Files" + $tip21= $winKey->{"Explorer/Tips//21"}; # Text of tip #21. + + $winKey->ArrayValues(1); + ( $devPath, $type )= $winKey->{"/DevicePath"}; + # $devPath eq "%SystemRoot%\\inf" + # $type eq "REG_EXPAND_SZ" [if you have SetDualVar.pm installed] + # $type == REG_EXPAND_SZ() [if did C<use Win32::TieRegistry qw(:REG_)>] + +=head3 Setting values + + $winKey->{"Setup//SourcePath"}= "\\\\SwServer\\SwShare\\Windows"; + # Simple. Assumes data type of REG_SZ. + + $winKey->{"Setup//Installation Sources"}= + [ "D:\x00\\\\SwServer\\SwShare\\Windows\0\0", "REG_MULTI_SZ" ]; + # "\x00" and "\0" used to mark ends of each string and end of list. + + $winKey->{"Setup//Installation Sources"}= + [ ["D:","\\\\SwServer\\SwShare\\Windows"], "REG_MULTI_SZ" ]; + # Alternate method that is easier to read. + + $userKey->{"Explorer/Tips//DisplayInitialTipWindow"}= + [ pack("L",0), "REG_DWORD" ]; + $userKey->{"Explorer/Tips//Next"}= [ pack("S",3), "REG_BINARY" ]; + $userKey->{"Explorer/Tips//Show"}= [ pack("L",0), "REG_BINARY" ]; + +=head3 Adding keys + + $swKey->{"FooCorp/"}= { + "FooWriter/" => { + "/Version" => "4.032", + "Startup/" => { + "/Title" => "Foo Writer Deluxe ][", + "/WindowSize" => [ pack("LL",$wid,$ht), "REG_BINARY" ], + "/TaskBarIcon" => [ "0x0001", "REG_DWORD" ], + }, + "Compatibility/" => { + "/AutoConvert" => "Always", + "/Default Palette" => "Windows Colors", + }, + }, + "/License", => "0123-9C8EF1-09-FC", + }; + +=head3 Listing all subkeys and values + + @members= keys( %{$swKey} ); + @subKeys= grep( m#^/#, keys( %{$swKey->{"Classes/batfile/"}} ) ); + # @subKeys= ( "/", "/EditFlags" ); + @valueNames= grep( ! m#^/#, keys( %{$swKey->{"Classes/batfile/"}} ) ); + # @valueNames= ( "DefaultIcon/", "shell/", "shellex/" ); + +=head3 Deleting values or keys with no subkeys + + $oldValue= delete $userKey->{"Explorer/Tips//Next"}; + + $oldValues= delete $userKey->{"Explorer/Tips/"}; + # $oldValues will be reference to hash containing deleted keys values. + +=head3 Closing keys + + undef $swKey; # Explicit way to close a key. + $winKey= "Anything else"; # Implicitly closes a key. + exit 0; # Implicitly closes all keys. + +=head2 Tie::Registry + +This module was originally called I<Tie::Registry>. Changing code +that used I<Tie::Registry> over to I<Win32::TieRegistry> is trivial +as the module name should only be mentioned once, in the C<use> +line. However, finding all of the places that used I<Tie::Registry> +may not be completely trivial so we have included F<Tie/Registry.pm> +which you can install to provide backward compatibility. + +=head1 AUTHOR + +Tye McQueen. See http://www.metronet.com/~tye/ or e-mail +tye@metronet.com with bug reports. + +=head1 SEE ALSO + +I<Win32API::Registry> - Provides access to C<Reg*()>, C<HKEY_*>, +C<KEY_*>, C<REG_*> [required]. + +I<Win32::WinError> - Defines C<ERROR_*> values [optional]. + +L<SetDualVar> - For returning C<REG_*> values as combined +string/integer values [optional]. + +=head1 BUGS + +Perl5.004_02 has bugs that make I<Win32::TieRegistry> fail in +strange and subtle ways. + +Using I<Win32::TieRegistry> with versions of Perl prior to 5.005 +can be tricky or impossible. Most notes about this have been +removed from the documentation (they get rather complicated +and confusing). This includes references to C<$^E> perhaps not +being meaningful. + +Because Perl hashes are case sensitive, certain lookups are also +case sensistive. In particular, the root keys ("Classes", "CUser", +"LMachine", "Users", "PerfData", "CConfig", "DynData", and HKEY_*) +must always be entered without changing between upper and lower +case letters. Also, the special rule for matching subkey names +that contain the user-selected delimiter only works if case is +matched. All other key name and value name lookups should be case +insensitive because the underlying Reg*() calls ignore case. + +Information about each key is cached when using a tied hash. +This cache is not flushed nor updated when changes are made, +I<even when the same tied hash is used> to make the changes. + +Current implementations of Perl's "global destruction" phase can +cause objects returned by C<Load()> to be destroyed while keys +within the hive are still open, if the objects still exist when +the script starts to exit. When this happens, the automatic +C<UnLoad()> will report a failure and the hive will remain loaded +in the Registry. + +Trying to C<Load()> a hive file that is located on a remote network +share may silently delete all data from the hive. This is a bug +in the Win32 APIs, not any Perl code or modules. This module does +not try to protect you from this bug. + +There is no test suite. + +=head1 FUTURE DIRECTIONS + +The following items are desired by the author and may appear in a +future release of this module. + +=over + +=item TieValues option + +Currently described in main documentation but no yet implemented. + +=item AutoRefresh option + +Trigger use of C<RegNotifyChangeKeyValue()> to keep tied hash +caches up-to-date even when other programs make changes. + +=item Error options + +Allow the user to have unchecked calls (calls in a "void context") +to automatically report errors via C<warn> or C<die>. + +For complex operations, such a copying an entire subtree, provide +access to detailed information about errors (and perhaps some +warnings) that were encountered. Let the user control whether +the complex operation continues in spite of errors. + +=back + +=cut + +# Autoload not currently supported by Perl under Windows. diff --git a/Master/tlpkg/installer/perllib/Win32API/Registry.pm b/Master/tlpkg/installer/perllib/Win32API/Registry.pm new file mode 100644 index 00000000000..dbf98b4e2e9 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Win32API/Registry.pm @@ -0,0 +1,1792 @@ +# Registry.pm -- Low-level access to functions/constants from WINREG.h + +package Win32API::Registry; + +use strict; +use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); #@EXPORT_FAIL); +$VERSION= '0.24'; + +require Exporter; +require DynaLoader; +@ISA= qw(Exporter DynaLoader); + +@EXPORT= qw(); +%EXPORT_TAGS= ( + Func => [qw( regConstant regLastError + AllowPriv AbortSystemShutdown InitiateSystemShutdown + RegCloseKey RegConnectRegistry RegCreateKey + RegCreateKeyEx RegDeleteKey RegDeleteValue + RegEnumKey RegEnumKeyEx RegEnumValue + RegFlushKey RegGetKeySecurity RegLoadKey + RegNotifyChangeKeyValue RegOpenKey RegOpenKeyEx + RegQueryInfoKey RegQueryMultipleValues RegQueryValue + RegQueryValueEx RegReplaceKey RegRestoreKey + RegSaveKey RegSetKeySecurity RegSetValue + RegSetValueEx RegUnLoadKey )], + FuncA => [qw( + AbortSystemShutdownA InitiateSystemShutdownA + RegConnectRegistryA RegCreateKeyA RegCreateKeyExA + RegDeleteKeyA RegDeleteValueA RegEnumKeyA + RegEnumKeyExA RegEnumValueA RegLoadKeyA + RegOpenKeyA RegOpenKeyExA RegQueryInfoKeyA + RegQueryMultipleValuesA RegQueryValueA RegQueryValueExA + RegReplaceKeyA RegRestoreKeyA RegSaveKeyA + RegSetValueA RegSetValueExA RegUnLoadKeyA )], + FuncW => [qw( + AbortSystemShutdownW InitiateSystemShutdownW + RegConnectRegistryW RegCreateKeyW RegCreateKeyExW + RegDeleteKeyW RegDeleteValueW RegEnumKeyW + RegEnumKeyExW RegEnumValueW RegLoadKeyW + RegOpenKeyW RegOpenKeyExW RegQueryInfoKeyW + RegQueryMultipleValuesW RegQueryValueW RegQueryValueExW + RegReplaceKeyW RegRestoreKeyW RegSaveKeyW + RegSetValueW RegSetValueExW RegUnLoadKeyW )], + HKEY_ => [qw( + HKEY_CLASSES_ROOT HKEY_CURRENT_CONFIG HKEY_CURRENT_USER + HKEY_DYN_DATA HKEY_LOCAL_MACHINE HKEY_PERFORMANCE_DATA + HKEY_USERS )], + KEY_ => [qw( + KEY_QUERY_VALUE KEY_SET_VALUE KEY_CREATE_SUB_KEY + KEY_ENUMERATE_SUB_KEYS KEY_NOTIFY KEY_CREATE_LINK + KEY_READ KEY_WRITE KEY_EXECUTE + KEY_ALL_ACCESS), + 'KEY_DELETE', # DELETE (0x00010000L) + 'KEY_READ_CONTROL', # READ_CONTROL (0x00020000L) + 'KEY_WRITE_DAC', # WRITE_DAC (0x00040000L) + 'KEY_WRITE_OWNER', # WRITE_OWNER (0x00080000L) + 'KEY_SYNCHRONIZE', # SYNCHRONIZE (0x00100000L) (not used) + ], + REG_ => [qw( + REG_OPTION_RESERVED REG_OPTION_NON_VOLATILE REG_OPTION_VOLATILE + REG_OPTION_CREATE_LINK REG_OPTION_BACKUP_RESTORE + REG_OPTION_OPEN_LINK REG_LEGAL_OPTION REG_CREATED_NEW_KEY + REG_OPENED_EXISTING_KEY REG_WHOLE_HIVE_VOLATILE REG_REFRESH_HIVE + REG_NO_LAZY_FLUSH REG_NOTIFY_CHANGE_ATTRIBUTES + REG_NOTIFY_CHANGE_NAME REG_NOTIFY_CHANGE_LAST_SET + REG_NOTIFY_CHANGE_SECURITY REG_LEGAL_CHANGE_FILTER + REG_NONE REG_SZ REG_EXPAND_SZ + REG_BINARY REG_DWORD REG_DWORD_LITTLE_ENDIAN + REG_DWORD_BIG_ENDIAN REG_LINK REG_MULTI_SZ + REG_RESOURCE_LIST REG_FULL_RESOURCE_DESCRIPTOR + REG_RESOURCE_REQUIREMENTS_LIST )], + SE_ => [qw( + SE_ASSIGNPRIMARYTOKEN_NAME SE_AUDIT_NAME + SE_BACKUP_NAME SE_CHANGE_NOTIFY_NAME + SE_CREATE_PAGEFILE_NAME SE_CREATE_PERMANENT_NAME + SE_CREATE_TOKEN_NAME SE_DEBUG_NAME + SE_INCREASE_QUOTA_NAME SE_INC_BASE_PRIORITY_NAME + SE_LOAD_DRIVER_NAME SE_LOCK_MEMORY_NAME + SE_MACHINE_ACCOUNT_NAME SE_PROF_SINGLE_PROCESS_NAME + SE_REMOTE_SHUTDOWN_NAME SE_RESTORE_NAME + SE_SECURITY_NAME SE_SHUTDOWN_NAME + SE_SYSTEMTIME_NAME SE_SYSTEM_ENVIRONMENT_NAME + SE_SYSTEM_PROFILE_NAME SE_TAKE_OWNERSHIP_NAME + SE_TCB_NAME SE_UNSOLICITED_INPUT_NAME )], +); +@EXPORT_OK= (); +{ my $ref; + foreach $ref ( values(%EXPORT_TAGS) ) { + push( @EXPORT_OK, @$ref ) unless $ref->[0] =~ /^SE_/; + } +} +$EXPORT_TAGS{ALL}= [ @EXPORT_OK ]; # \@EXPORT_OK once SE_* settles down. +# push( @EXPORT_OK, "JHEREG_TACOSALAD" ); # Used to test Mkconst2perl +push( @EXPORT_OK, @{$EXPORT_TAGS{SE_}} ); + +bootstrap Win32API::Registry $VERSION; + +# Preloaded methods go here. + +# To convert C constants to Perl code in cRegistry.pc +# [instead of C or C++ code in cRegistry.h]: +# * Modify F<Makefile.PL> to add WriteMakeFile() => +# CONST2PERL/postamble => [[ "Win32API::Registry" => ]] WRITE_PERL => 1. +# * Either comment out C<#include "cRegistry.h"> from F<Registry.xs> +# or make F<cRegistry.h> an empty file. +# * Make sure the following C<if> block is not commented out. +# * "nmake clean", "perl Makefile.PL", "nmake" + +if( ! defined ®_NONE ) { + require "Win32API/Registry/cRegistry.pc"; +} + +# This would be convenient but inconsistant and hard to explain: +#push( @{$EXPORT_TAGS{ALL}}, @{$EXPORT_TAGS{SE_}} ) +# if defined &SE_TCB_NAME; + +sub regConstant +{ + my( $name )= @_; + if( 1 != @_ || ! $name || $name =~ /\W/ ) { + require Carp; + Carp::croak( 'Usage: ',__PACKAGE__,'::regConstant("CONST_NAME")' ); + } + my $proto= prototype $name; + if( defined \&$name + && defined $proto + && "" eq $proto ) { + no strict 'refs'; + return &$name; + } + return undef; +} + +# We provide this for backwards compatibility: +sub constant +{ + my( $name )= @_; + my $value= regConstant( $name ); + if( defined $value ) { + $!= 0; + return $value; + } + $!= 11; # EINVAL + return 0; +} + +# BEGIN { +# my $code= 'return _regLastError(@_)'; +# local( $!, $^E )= ( 1, 1 ); +# if( $! ne $^E ) { +# $code= ' +# local( $^E )= _regLastError(@_); +# my $ret= $^E; +# return $ret; +# '; +# } +# eval "sub regLastError { $code }"; +# die "$@" if $@; +# } + +package Win32API::Registry::_error; + +use overload + '""' => sub { + require Win32 unless defined &Win32::FormatMessage; + $_ = Win32::FormatMessage(Win32API::Registry::_regLastError()); + tr/\r\n//d; + return $_; + }, + '0+' => sub { Win32API::Registry::_regLastError() }, + 'fallback' => 1; + +sub new { return bless {}, shift } +sub set { Win32API::Registry::_regLastError($_[1]); return $_[0] } + +package Win32API::Registry; + +my $_error = new Win32API::Registry::_error; + +sub regLastError { + require Carp; + Carp::croak('Usage: ',__PACKAGE__,'::regLastError( [$setWin32ErrCode] )') if @_ > 1; + $_error->set($_[0]) if defined $_[0]; + return $_error; +} + +# Since we ISA DynaLoader which ISA AutoLoader, we ISA AutoLoader so we +# need this next chunk to prevent Win32API::Registry->nonesuch() from +# looking for "nonesuch.al" and producing confusing error messages: +use vars qw($AUTOLOAD); +sub AUTOLOAD { + require Carp; + Carp::croak( + "Can't locate method $AUTOLOAD via package Win32API::Registry" ); +} + +# Replace "&rout;" with "goto &rout;" when that is supported on Win32. + +# Let user omit all buffer sizes: +sub RegEnumKeyExA { + if( 6 == @_ ) { splice(@_,4,0,[]); splice(@_,2,0,[]); } + &_RegEnumKeyExA; +} +sub RegEnumKeyExW { + if( 6 == @_ ) { splice(@_,4,0,[]); splice(@_,2,0,[]); } + &_RegEnumKeyExW; +} +sub RegEnumValueA { + if( 6 == @_ ) { splice(@_,2,0,[]); push(@_,[]); } + &_RegEnumValueA; +} +sub RegEnumValueW { + if( 6 == @_ ) { splice(@_,2,0,[]); push(@_,[]); } + &_RegEnumValueW; +} +sub RegQueryInfoKeyA { + if( 11 == @_ ) { splice(@_,2,0,[]); } + &_RegQueryInfoKeyA; +} +sub RegQueryInfoKeyW { + if( 11 == @_ ) { splice(@_,2,0,[]); } + &_RegQueryInfoKeyW; +} + +sub RegEnumKeyA { + push(@_,[]) if 3 == @_; + &_RegEnumKeyA; +} +sub RegEnumKeyW { + push(@_,[]) if 3 == @_; + &_RegEnumKeyW; +} +sub RegGetKeySecurity { + push(@_,[]) if 3 == @_; + &_RegGetKeySecurity; +} +sub RegQueryMultipleValuesA { + push(@_,[]) if 4 == @_; + &_RegQueryMultipleValuesA; +} +sub RegQueryMultipleValuesW { + push(@_,[]) if 4 == @_; + &_RegQueryMultipleValuesW; +} +sub RegQueryValueA { + push(@_,[]) if 3 == @_; + &_RegQueryValueA; +} +sub RegQueryValueW { + push(@_,[]) if 3 == @_; + &_RegQueryValueW; +} +sub RegQueryValueExA { + push(@_,[]) if 5 == @_; + &_RegQueryValueExA; +} +sub RegQueryValueExW { + push(@_,[]) if 5 == @_; + &_RegQueryValueExW; +} +sub RegSetValueA { + push(@_,0) if 4 == @_; + &_RegSetValueA; +} +sub RegSetValueW { + push(@_,0) if 4 == @_; + &_RegSetValueW; +} +sub RegSetValueExA { + push(@_,0) if 5 == @_; + &_RegSetValueExA; +} +sub RegSetValueExW { + push(@_,0) if 5 == @_; + &_RegSetValueExW; +} + +# Aliases for non-Unicode functions: +sub AbortSystemShutdown { &AbortSystemShutdownA; } +sub InitiateSystemShutdown { &InitiateSystemShutdownA; } +sub RegConnectRegistry { &RegConnectRegistryA; } +sub RegCreateKey { &RegCreateKeyA; } +sub RegCreateKeyEx { &RegCreateKeyExA; } +sub RegDeleteKey { &RegDeleteKeyA; } +sub RegDeleteValue { &RegDeleteValueA; } +sub RegEnumKey { &RegEnumKeyA; } +sub RegEnumKeyEx { &RegEnumKeyExA; } +sub RegEnumValue { &RegEnumValueA; } +sub RegLoadKey { &RegLoadKeyA; } +sub RegOpenKey { &RegOpenKeyA; } +sub RegOpenKeyEx { &RegOpenKeyExA; } +sub RegQueryInfoKey { &RegQueryInfoKeyA; } +sub RegQueryMultipleValues { &RegQueryMultipleValuesA; } +sub RegQueryValue { &RegQueryValueA; } +sub RegQueryValueEx { &RegQueryValueExA; } +sub RegReplaceKey { &RegReplaceKeyA; } +sub RegRestoreKey { &RegRestoreKeyA; } +sub RegSaveKey { &RegSaveKeyA; } +sub RegSetValue { &RegSetValueA; } +sub RegSetValueEx { &RegSetValueExA; } +sub RegUnLoadKey { &RegUnLoadKeyA; } + +1; +__END__ + +=head1 NAME + +Win32API::Registry - Low-level access to Win32 system API calls from WINREG.H + +=head1 SYNOPSIS + + use Win32API::Registry 0.21 qw( :ALL ); + + RegOpenKeyEx( HKEY_LOCAL_MACHINE, "SYSTEM\\Disk", 0, KEY_READ, $key ); + or die "Can't open HKEY_LOCAL_MACHINE\\SYSTEM\\Disk: ", + regLastError(),"\n"; + RegQueryValueEx( $key, "Information", [], $type, $data, [] ); + or die "Can't read HKEY_L*MACHINE\\SYSTEM\\Disk\\Information: ", + regLastError(),"\n"; + [...] + RegCloseKey( $key ) + or die "Can't close HKEY_LOCAL_MACHINE\\SYSTEM\\Disk: ", + regLastError(),"\n"; + +=head1 DESCRIPTION + +This provides fairly low-level access to the Win32 System API +calls dealing with the Registry [mostly from WINREG.H]. This +is mostly intended to be used by other modules such as +C<Win32::TieRegistry> [which provides an extremely Perl-friendly +method for using the Registry]. + +For a description of the logical structure of the Registry, see +the documentation for the C<Win32::TieRegistry> module. + +To pass in C<NULL> as the pointer to an optional buffer, pass in +an empty list reference, C<[]>. + +Beyond raw access to the API calls and related constants, this module +handles smart buffer allocation and translation of return codes. + +All calls return a true value for success and a false value for +failure. After any failure, C<$^E> should automatically be set +to indicate the reason. However, current versions of Perl often +overwrite C<$^E> too quickly, so you can use C<regLastError()> +instead, which is only set by Win32API::Registry routines. + +Note that C<$!> is not set by these routines except by +C<Win32API::Registry::constant()> when a constant is not defined. + +=head2 Exports + +Nothing is exported by default. The following tags can be used to +have sets of symbols exported. + +[Note that much of the following documentation refers to the +behavior of the underlying API calls which may vary in current +and future versions of the Win32 API without any changes to this +module. Therefore you should check the Win32 API documentation +directly when needed.] + +=over + +=item :Func + +The basic function names: + +=over + +=item AllowPriv + +=item C<AllowPriv( $sPrivName, $bEnable )> + +Not a Win32 API call. Enables or disables a specific privilege for +the current process. Returns a true value if successful and a false +value [and sets C<$^E>/C<regLastError()>] on failure. This routine +does not provide a way to tell if a privilege is currently enabled. + +C<$sPrivname> is a Win32 privilege name [see L</:SE_>]. For example, +C<"SeBackupPrivilege"> [a.k.a. C<SE_BACKUP_NAME>] controls whether +you can use C<RegSaveKey()> and C<"SeRestorePrivilege"> [a.k.a. +C<SE_RESTORE_NAME>] controls whether you can use C<RegLoadKey()>. + +If C<$bEnable> is true, then C<AllowPriv()> tries to enable the +privilege. Otherwise it tries to disable the privilege. + +=item AbortSystemShutdown + +=item C<AbortSystemShutdown( $sComputerName )> + +Tries to abort a remote shutdown request previously made via +C<InitiateSystemShutdown()>. Returns a true value if successful +and a false value [and sets C<$^E>/C<regLastError()>] on failure. + +=item InitiateSystemShutdown + +=item C<InitiateSystemShutdown( $sComputer, $sMessage, $uTimeoutSecs, $bForce, $bReboot )> + +Requests that a [remote] computer be shutdown or rebooted. +Returns a true value if successful and a false value [and +sets C<$^E>/C<regLastError()>] on failure. + +C<$sComputer> is the name [or address] of the computer to be +shutdown or rebooted. You can use C<[]> [for C<NULL>] or C<""> +to indicate the local computer. + +C<$sMessage> is the message to be displayed in a pop-up window +on the desktop of the computer to be shutdown or rebooted until +the timeout expires or the shutdown is aborted via +C<AbortSystemShutdown()>. With C<$iTimeoutSecs == 0>, the +message will never be visible. + +C<$iTimeoutSecs> is the number of seconds to wait before starting +the shutdown. + +If C<$bForce> is false, then any applications running on the remote +computer get a chance to prompt the remote user whether they want +to save changes. Also, for any applications that do not exit quickly +enough, the operating system will prompt the user whether they wish +to wait longer for the application to exit or force it to exit now. +At any of these prompts the user can press B<CANCEL> to abort the +shutdown but if no applications have unsaved data, they will likely +all exit quickly and the shutdown will progress with the remote user +having no option to cancel the shutdown. + +If C<$bForce> is true, all applications are told to exit immediately +and so will not prompt the user even if there is unsaved data. Any +applications that take too long to exit will be forcibly killed after +a short time. The only way to abort the shutdown is to call +C<AbortSystemShutdown()> before the timeout expires and there is no +way to abort the shutdown once it has begun. + +If C<$bReboot> is true, the computer will automatically reboot once +the shutdown is complete. If C<$bReboot> is false, then when the +shutdown is complete the computer will halt at a screen indicating +that the shutdown is complete and offering a way for the user to +start to boot the computer. + +You must have the C<"SeRemoteShutdownPrivilege"> privilege +on the remote computer for this call to succeed. If shutting +down the local computer, then the calling process must have +the C<"SeShutdownPrivilege"> privilege and have it enabled. + +=item RegCloseKey + +=item C<RegCloseKey( $hKey )> + +Closes the handle to a Registry key returned by C<RegOpenKeyEx()>, +C<RegConnectRegistry()>, C<RegCreateKeyEx()>, or a few other +routines. Returns a true value if successful and a false value +[and sets C<$^E>/C<regLastError()>] on failure. + +=item RegConnectRegistry + +=item C<RegConnectRegistry( $sComputer, $hRootKey, $ohKey )> + +Connects to one of the root Registry keys of a remote computer. +Returns a true value if successful and a false value [and +sets C<$^E>/C<regLastError()>] on failure. + +C<$sComputer> is the name [or address] of a remote computer +whose Registry you wish to access. + +C<$hKey> must be either C<HKEY_LOCAL_MACHINE> or C<HKEY_USERS> +and specifies which root Registry key on the remote computer +you wish to have access to. + +C<$phKey> will be set to the handle to be used to access the +remote Registry key if the call succeeds. + +=item regConstant + +=item C<$value= regConstant( $sConstantName )> + +Fetch the value of a constant. Returns C<undef> if C<$sConstantName> +is not the name of a constant supported by this module. Never sets +C<$!> nor C<$^E>. + +This function is rarely used since you will usually get the value of a +constant by having that constant imported into your package by listing +the constant name in the C<use Win32API::Registry> statement and then +simply using the constant name in your code [perhaps followed by +C<()>]. This function is useful for verifying constant names not in +Perl code, for example, after prompting a user to type in a constant +name. + +=item RegCreateKey + +=item C<RegCreateKey( $hKey, $sSubKey, $ohSubKey )> + +This routine is meant only for compatibility with Windows version +3.1. Use C<RegCreateKeyEx()> instead. + +=item RegCreateKeyEx + +=item C<RegCreateKeyEx( $hKey, $sSubKey, $uZero, $sClass, $uOpts, $uAccess, $pSecAttr, $ohNewKey, $ouDisp )> + +Creates a new Registry subkey. Returns a true value if successful and +a false value [and sets C<$^E>/C<regLastError()>] on failure. + +C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from +a previous call]. + +C<$sSubKey> is the name of the new subkey to be created. + +C<$iZero> is reserved for future use and should always be specified +as C<0>. + +C<$sClass> is a string to be used as the class for the new +subkey. We are not aware of any current use for Registry key +class information so the empty string, C<"">, should usually +be used here. + +C<$iOpts> is a numeric value containing bits that control options +used while creating the new subkey. C<REG_OPTION_NON_VOLATILE> +is the default. C<REG_OPTION_VOLATILE> [which is ignored on +Windows 95] means the data stored under this key is not kept +in a file and will not be preserved when the system reboots. +C<REG_OPTION_BACKUP_RESTORE> [also ignored on Windows 95] means +ignore the C<$iAccess> parameter and try to open the new key with +the access required to backup or restore the key. + +C<$iAccess> is a numeric mask of bits specifying what type of +access is desired when opening the new subkey. See C<RegOpenKeyEx()>. + +C<$pSecAttr> is a C<SECURITY_ATTRIBUTES> structure packed into +a Perl string which controls whether the returned handle can be +inherited by child processes. Normally you would pass C<[]> for +this parameter to have C<NULL> passed to the underlying API +indicating that the handle cannot be inherited. If not under +Windows95, then C<$pSecAttr> also allows you to specify +C<SECURITY_DESCRIPTOR> that controls which users will have +what type of access to the new key -- otherwise the new key +inherits its security from its parent key. + +C<$phKey> will be set to the handle to be used to access the new +subkey if the call succeeds. + +C<$piDisp> will be set to either C<REG_CREATED_NEW_KEY> or +C<REG_OPENED_EXISTING_KEY> to indicate for which reason the +call succeeded. Can be specified as C<[]> if you don't care. + +If C<$phKey> and C<$piDisp> start out as integers, then they will +probably remain unchanged if the call fails. + +=item RegDeleteKey + +=item C<RegDeleteKey( $hKey, $sSubKey )> + +Deletes a subkey of an open Registry key provided that the subkey +contains no subkeys of its own [but the subkey may contain values]. +Returns a true value if successful and a false value [and sets +C<$^E>/C<regLastError()>] on failure. + +C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from +a previous call]. + +C<$sSubKey> is the name of the subkey to be deleted. + +=item RegDeleteValue + +=item C<RegDeleteValue( $hKey, $sValueName )> + +Deletes a value from an open Registry key. Returns a true value if +successful and a false value [and sets C<$^E>/C<regLastError()>] on +failure. + +C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from +a previous call]. + +C<$sValueKey> is the name of the value to be deleted. + +=item RegEnumKey + +=item C<RegEnumKey( $hKey, $uIndex, $osName, $ilNameSize )> + +This routine is meant only for compatibility with Windows version +3.1. Use C<RegEnumKeyEx()> instead. + +=item RegEnumKeyEx + +=item C<RegEnumKeyEx( $hKey, $uIndex, $osName, $iolName, $pNull, $osClass, $iolClass, $opftLastWrite )> + +Lets you enumerate the names of all of the subkeys directly under +an open Registry key. Returns a true value if successful and a false +value [and sets C<$^E>/C<regLastError()>] on failure. + +C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from +a previous call]. + +C<$iIndex> is the sequence number of the immediate subkey that +you want information on. Start with this value as C<0> then +repeat the call incrementing this value each time until the +call fails with C<$^E>/C<regLastError()> numerically equal to +C<ERROR_NO_MORE_ITEMS>. + +C<$sName> will be set to the name of the subkey. Can be C<[]> if +you don't care about the name. + +C<$plName> initially specifies the [minimum] buffer size to be +allocated for C<$sName>. Will be set to the length of the subkey +name if the requested subkey exists even if C<$sName> isn't +successfully set to the subkey name. See L<Buffer sizes> for +more information. + +C<$pNull> is reserved for future used and should be passed as C<[]>. + +C<$sClass> will be set to the class name for the subkey. Can be +C<[]> if you don't care about the class. + +C<$plClass> initially specifies the [minimum] buffer size to be +allocated for C<$sClass> and will be set to the length of the +subkey class name if the requested subkey exists. See L<Buffer +sizes> for more information. + +C<$pftLastWrite> will be set to a C<FILETIME> structure packed +into a Perl string and indicating when the subkey was last changed. +Can be C<[]>. + +You may omit both C<$plName> and C<$plClass> to get the same effect +as passing in C<[]> for each of them. + +=item RegEnumValue + +=item C<RegEnumValue( $hKey, $uIndex, $osValName, $iolValName, $pNull, $ouType, $opValData, $iolValData )> + +Lets you enumerate the names of all of the values contained in an +open Registry key. Returns a true value if successful and a false +value [and sets C<$^E>/C<regLastError()>] on failure. + +C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from +a previous call]. + +C<$iIndex> is the sequence number of the value that you want +information on. Start with this value as C<0> then repeat the +call incrementing this value each time until the call fails with +C<ERROR_NO_MORE_ITEMS>. + +C<$sValName> will be set to the name of the value. Can be C<[]> +if you don't care about the name. + +C<$plValName> initially specifies the [minimum] buffer size to be +allocated for C<$sValName>. Will be set to the length of the value +name if the requested value exists even if C<$sValName> isn't +successfully set to the value name. See L<Buffer sizes> for +more information. + +C<$pNull> is reserved for future used and should be passed as C<[]>. + +C<$piType> will be set to the type of data stored in the value data. +If the call succeeds, it will be set to a C<REG_*> value unless +passed in as C<[]>. + +C<$pValData> will be set to the data [packed into a Perl string] +that is stored in the requested value. Can be C<[]> if you don't +care about the value data. + +C<$plValData> initially specifies the [minimum] buffer size to be +allocated for C<$sValData> and will be set to the length of the +value data if the requested value exists. See L<Buffer sizes> for +more information. + +You may omit both C<$plValName> and C<$plValData> to get the same +effect as passing in C<[]> for each of them. + +=item RegFlushKey + +=item C<RegFlushKey( $hKey )> + +Forces the data stored under an open Registry key to be flushed +to the disk file where the data is preserved between reboots. +Forced flushing is not guaranteed to be efficient so this routine +should almost never be called. Returns a true value if successful +and a false value [and sets C<$^E>/C<regLastError()>] on failure. + +C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from +a previous call]. + +=item RegGetKeySecurity + +=item C<RegGetKeySecurity( $hKey, $uSecInfo, $opSecDesc, $iolSecDesc )> + +Retrieves one of the C<SECURITY_DESCRIPTOR> structures describing +part of the security for an open Registry key. Returns a true value +if successful and a false value [and sets C<$^E>/C<regLastError()>] +on failure. + +C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from +a previous call]. + +C<$iSecInfo> is a numeric C<SECURITY_INFORMATION> value that +specifies which parts of the C<SECURITY_DESCRIPTOR> structure +to retrieve. Should be C<OWNER_SECURITY_INFORMATION>, +C<GROUP_SECURITY_INFORMATION>, C<DACL_SECURITY_INFORMATION>, or +or C<SACL_SECURITY_INFORMATION> or two or more of these bits +combined using C<|>. + +C<$pSecDesc> will be set to the requested C<SECURITY_DESCRIPTOR> +structure [packed into a Perl string]. + +C<$plSecDesc> initially specifies the [minimum] buffer size to be +allocated for C<$sSecDesc> and will be set to the length of the +security descriptor. See L<Buffer sizes> for more information. +You may omit this parameter to get the same effect as passing in +C<[]> for it. + +=item regLastError + +=item C<$svError= regLastError();> + +=item C<regLastError( $uError );> + +Returns the last error encountered by a routine from this module. +It is just like C<$^E> except it isn't changed by anything except +routines from this module. Ideally you could just use C<$^E>, but +current versions of Perl often overwrite C<$^E> before you get a +chance to check it and really old versions of Perl don't really +support C<$^E> under Win32. + +Just like C<$^E>, in a numeric context C<regLastError()> returns +the numeric error value while in a string context it returns a +text description of the error [actually it returns a Perl scalar +that contains both values so C<$x= regLastError()> causes C<$x> +to give different values in string vs. numeric contexts]. + +The last form sets the error returned by future calls to +C<regLastError()> and should not be used often. C<$uError> must +be a numeric error code. Also returns the dual-valued version +of C<$uError>. + +=item RegLoadKey + +=item C<RegLoadKey( $hKey, $sSubKey, $sFileName )> + +Loads a hive file. That is, it creates a new subkey in the +Registry and associates that subkey with a disk file that contains +a Registry hive so that the new subkey can be used to access the +keys and values stored in that hive. Hives are usually created +via C<RegSaveKey()>. Returns a true value if successful and a +false value [and sets C<$^E>/C<regLastError()>] on failure. + +C<$hKey> is the handle to a Registry key that can have hives +loaded to it. This must be C<HKEY_LOCAL_MACHINE>, C<HKEY_USERS>, +or a remote version of one of these from a call to +C<RegConnectRegistry()>. + +C<$sSubKey> is the name of the new subkey to created and associated +with the hive file. + +C<$sFileName> is the name of the hive file to be loaded. This +file name is interpretted relative to the +C<%SystemRoot%/System32/config> directory on the computer where +the C<$hKey> key resides. If C<$sFileName> is on a FAT file +system, then its name must not have an extension. + +You must have the C<SE_RESTORE_NAME> privilege to use this routine. + +WARNING: Loading of hive files via a network share may silently +corrupt the hive and so should not be attempted [this is a problem +in at least some versions of the underlying API which this module +does not try to fix or avoid]. To access a hive file located on a +remote computer, connect to the remote computer's Registry and load +the hive via that. + +=item RegNotifyChangeKeyValue + +=item C<RegNotifyChangeKeyValue( $hKey, $bWatchSubtree, $uNotifyFilter, $hEvent, $bAsync )> + +Arranges for your process to be notified when part of the Registry +is changed. Returns a true value if successful and a false value +[and sets C<$^E>/C<regLastError()>] on failure. + +C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from +a previous call] for which you wish to be notified when any changes +are made to it. + +If C<$bWatchSubtree> is true, then changes to any subkey or +descendant of C<$hKey> are also reported. + +C<$iNotifyFilter> controllers what types of changes are reported. It +is a numeric value containing one or more of the following bit masks: + +=over + +=item C<REG_NOTIFY_CHANGE_NAME> + +Notify if a subkey is added or deleted to a monitored key. + +=item C<REG_NOTIFY_CHANGE_LAST_SET> + +Notify if a value in a monitored key is added, deleted, or modified. + +=item C<REG_NOTIFY_CHANGE_SECURITY> + +Notify if a security descriptor of a monitored key is changed. + +=item C<REG_NOTIFY_CHANGE_ATTRIBUTES> + +Notify if any attributes of a monitored key are changed [class +name or security descriptors]. + +=back + +C<$hEvent> is ignored unless C<$bAsync> is true. Otherwise, C<$hEvent> +is a handle to a Win32 I<event> that will be signaled when changes are +to be reported. + +If C<$bAsync> is true, then C<RegNotifyChangeKeyValue()> returns +immediately and uses C<$hEvent> to notify your process of changes. +If C<$bAsync> is false, then C<RegNotifyChangeKeyValue()> does +not return until there is a change to be notified of. + +This routine does not work with Registry keys on remote computers. + +=item RegOpenKey + +=item C<RegOpenKey( $hKey, $sSubKey, $ohSubKey )> + +This routine is meant only for compatibility with Windows version +3.1. Use C<RegOpenKeyEx()> instead. + +=item RegOpenKeyEx + +=item C<RegOpenKeyEx( $hKey, $sSubKey, $uOptions, $uAccess, $ohSubKey )> + +Opens an existing Registry key. Returns a true value if successful +and a false value [and sets C<$^E>/C<regLastError()>] on failure. + +C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from +a previous call]. + +C<$sSubKey> is the name of an existing subkey to be opened. +Can be C<""> or C<[]> to open an additional handle to the +key specified by C<$hKey>. + +C<$iOptions> is a numeric value containing bits that control options +used while opening the subkey. There are currently no supported +options so this parameter should be specified as C<0>. + +C<$iAccess> is a numeric mask of bits specifying what type of +access is desired when opening the new subkey. Should be a +combination of one or more of the following bit masks: + +=over + +=item C<KEY_ALL_ACCESS> + + KEY_READ | KEY_WRITE | KEY_CREATE_LINK + +=item C<KEY_READ> + + KEY_QUERY_VALUE | KEY_ENUMERATE_SUBKEYS | KEY_NOTIFY | STANDARD_RIGHTS_READ + +=item C<KEY_WRITE> + + KEY_SET_VALUE | KEY_CREATE_SUB_KEY | STANDARD_RIGHTS_WRITE + +=item C<KEY_QUERY_VALUE> + +=item C<KEY_SET_VALUE> + +=item C<KEY_ENUMERATE_SUB_KEYS> + +=item C<KEY_CREATE_SUB_KEY> + +=item C<KEY_NOTIFY> + +Allows you to use C<RegNotifyChangeKeyValue()> on the opened key. + +=item C<KEY_EXECUTE> + +Same as C<KEY_READ>. + +=item C<KEY_CREATE_LINK> + +Gives you permission to create a symbolic link like +C<HKEY_CLASSES_ROOT> and C<HKEY_CURRENT_USER>, though the method for +doing so is not documented [and probably requires use of the mostly +undocumented "native" routines, C<Nt*()> a.k.a. C<Zw*()>]. + +=back + +C<$phKey> will be set to the handle to be used to access the new subkey +if the call succeeds. + +=item RegQueryInfoKey + +=item C<RegQueryInfoKey( $hKey, $osClass, $iolClass, $pNull, $ocSubKeys, $olSubKey, $olSubClass, $ocValues, $olValName, $olValData, $olSecDesc, $opftTime )> + +Gets miscellaneous information about an open Registry key. +Returns a true value if successful and a false value [and +sets C<$^E>/C<regLastError()>] on failure. + +C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from +a previous call]. + +C<$sClass> will be set to the class name for the key. Can be +C<[]> if you don't care about the class. + +C<$plClass> initially specifies the [minimum] buffer size to be +allocated for C<$sClass> and will be set to the length of the +key's class name. See L<Buffer sizes> for more information. +You may omit this parameter to get the same effect as passing in +C<[]> for it. + +C<$pNull> is reserved for future use and should be passed as C<[]>. + +C<$pcSubKeys> will be set to the count of the number of subkeys +directly under this key. Can be C<[]>. + +C<$plSubKey> will be set to the length of the longest subkey name. +Can be C<[]>. + +C<$plSubClass> will be set to the length of the longest class name +used with an immediate subkey of this key. Can be C<[]>. + +C<$pcValues> will be set to the count of the number of values in +this key. Can be C<[]>. + +C<$plValName> will be set to the length of the longest value name +in this key. Can be C<[]>. + +C<$plValData> will be set to the length of the longest value data +in this key. Can be C<[]>. + +C<$plSecDesc> will be set to the length of this key's full security +descriptor. + +C<$pftTime> will be set to a C<FILETIME> structure packed +into a Perl string and indicating when this key was last changed. +Can be C<[]>. + +=item RegQueryMultipleValues + +=item C<RegQueryMultipleValues( $hKey, $ioarValueEnts, $icValueEnts, $opBuffer, $iolBuffer )> + +Allows you to use a single call to query several values from a single +open Registry key to maximize efficiency. Returns a true value if +successful and a false value [and sets C<$^E>/C<regLastError()>] on +failure. + +C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from +a previous call]. + +C<$pValueEnts> should contain a list of C<VALENT> structures packed +into a single Perl string. Each C<VALENT> structure should have +the C<ve_valuename> entry [the first 4 bytes] pointing to a string +containing the name of a value stored in this key. The remaining +fields are set if the function succeeds. + +C<$cValueEnts> should contain the count of the number of C<VALENT> +structures contained in C<$pValueEnts>. + +C<$pBuffer> will be set to the data from all of the requested values +concatenated into a single Perl string. + +C<$plBuffer> initially specifies the [minimum] buffer size to be +allocated for C<$sBuffer> and will be set to the total length of +the data to be written to C<$sBuffer>. See L<Buffer sizes> for +more information. You may omit this parameter to get the same +effect as passing in C<[]> for it. + +Here is sample code to populate C<$pValueEnts>: + + # @ValueNames= ...list of value name strings...; + $cValueEnts= @ValueNames; + $pValueEnts= pack( " p x4 x4 x4 " x $cValueEnts, @ValueNames ); + +Here is sample code to retrieve the data type and data length +returned in C<$pValueEnts>: + + @Lengths= unpack( " x4 L x4 x4 " x $cValueEnts, $pValueEnts ); + @Types= unpack( " x4 x4 x4 L " x $cValueEnts, $pValueEnts ); + +Given the above, and assuming you haven't modified C<$sBuffer> since +the call, you can also extract the value data strings from C<$sBuffer> +by using the pointers returned in C<$pValueEnts>: + + @Data= unpack( join( "", map {" x4 x4 P$_ x4 "} @Lengths ), + $pValueEnts ); + +Much better is to use the lengths and extract directly from +C<$sBuffer> using C<unpack()> [or C<substr()>]: + + @Data= unpack( join("",map("P$_",@Lengths)), $sBuffer ); + +=item RegQueryValue + +=item C<RegQueryValue( $hKey, $sSubKey, $osValueData, $iolValueData )> + +This routine is meant only for compatibility with Windows version +3.1. Use C<RegQueryValueEx()> instead. This routine can only +query unamed values [a.k.a. "default values"], that is, values with +a name of C<"">. + +=item RegQueryValueEx + +=item C<RegQueryValueEx( $hKey, $sValueName, $pNull, $ouType, $opValueData, $iolValueData )> + +Lets you look up value data stored in an open Registry key by +specifying the value name. Returns a true value if successful +and a false value [and sets C<$^E>/C<regLastError()>] on failure. + +C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from +a previous call]. + +C<$sValueName> is the name of the value whose data you wish to +retrieve. + +C<$pNull> this parameter is reserved for future use and should be +specified as C<[]>. + +C<$piType> will be set to indicate what type of data is stored in +the named value. Will be set to a C<REG_*> value if the function +succeeds. + +C<$pValueData> will be set to the value data [packed into a Perl +string] that is stored in the named value. Can be C<[]> if you +don't care about the value data. + +C<$plValueData> initially specifies the [minimum] buffer size to be +allocated for C<$sValueData> and will be set to the size [always +in bytes] of the data to be written to C<$sValueData>, even if +C<$sValueData> is not successfully written to. See L<Buffer sizes> +for more information. + +=item RegReplaceKey + +=item C<RegReplaceKey( $hKey, $sSubKey, $sNewFile, $sOldFile )> + +Lets you replace an entire hive when the system is next booted. +Returns a true value if successful and a false value [and sets +C<$^E>/C<regLastError()>] on failure. + +C<$hKey> is the handle to a Registry key that has hive(s) +loaded in it. This must be C<HKEY_LOCAL_MACHINE>, +C<HKEY_USERS>, or a remote version of one of these from +a call to C<RegConnectRegistry()>. + +C<$sSubKey> is the name of the subkey of C<$hKey> whose hive +you wish to have replaced on the next reboot. + +C<$sNewFile> is the name of a file that will replace the existing +hive file when the system reboots. + +C<$sOldFile> is the file name to save the current hive file to +when the system reboots. + +C<$sNewFile> and C<$sOldFile> are interpretted relative to the +C<%SystemRoot%/System32/config> directory on the computer where +the C<$hKey> key resides [I think]. If either file is [would be] +on a FAT file system, then its name must not have an extension. + +You must have the C<SE_RESTORE_NAME> privilege to use this routine. + +=item RegRestoreKey + +=item C<RegRestoreKey( $hKey, $sFileName, $uFlags )> + +Reads in a hive file and copies its contents over an existing +Registry tree. Returns a true value if successful and a false +value [and sets C<$^E>/C<regLastError()>] on failure. + +C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from +a previous call]. + +C<$sFileName> is the name of the hive file to be read. For each +value and subkey in this file, a value or subkey will be added +or replaced in C<$hKey>. + +C<$uFlags> is usally C<0>. It can also be C<REG_WHOLE_HIVE_VOLATILE> +which, rather than copying the hive over the existing key, +replaces the existing key with a temporary, memory-only Registry +key and then copies the hive contents into it. This option only +works if C<$hKey> is C<HKEY_LOCAL_MACHINE>, C<HKEY_USERS>, or a +remote version of one of these from a call to C<RegConnectRegistry()>. + +C<RegRestoreKey> does I<not> delete values nor keys from the +existing Registry tree when there is no corresponding value/key +in the hive file. + +=item RegSaveKey + +=item C<RegSaveKey( $hKey, $sFileName, $pSecAttr )> + +Dumps any open Registry key and all of its subkeys and values into +a new hive file. Returns a true value if successful and a false +value [and sets C<$^E>/C<regLastError()>] on failure. + +C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from +a previous call]. + +C<$sFileName> is the name of the file that the Registry tree +should be saved to. It is interpretted relative to the +C<%SystemRoot%/System32/config> directory on the computer where +the C<$hKey> key resides. If C<$sFileName> is on a FAT file system, +then it must not have an extension. + +C<$pSecAttr> contains a C<SECURITY_ATTRIBUTES> structure that specifies +the permissions to be set on the new file that is created. This can +be C<[]>. + +You must have the C<SE_RESTORE_NAME> privilege to use this routine. + +=item RegSetKeySecurity + +=item C<RegSetKeySecurity( $hKey, $uSecInfo, $pSecDesc )> + +Sets [part of] the C<SECURITY_DESCRIPTOR> structure describing part +of the security for an open Registry key. Returns a true value if +successful and a false value [and sets C<$^E>/C<regLastError()>] on +failure. + +C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from +a previous call]. + +C<$uSecInfo> is a numeric C<SECURITY_INFORMATION> value that +specifies which C<SECURITY_DESCRIPTOR> structure to set. Should +be C<OWNER_SECURITY_INFORMATION>, C<GROUP_SECURITY_INFORMATION>, +C<DACL_SECURITY_INFORMATION>, or C<SACL_SECURITY_INFORMATION> +or two or more of these bits combined using C<|>. + +C<$pSecDesc> contains the new C<SECURITY_DESCRIPTOR> structure +packed into a Perl string. + +=item RegSetValue + +=item C<RegSetValue( $hKey, $sSubKey, $uType, $sValueData, $lValueData )> + +This routine is meant only for compatibility with Windows version +3.1. Use C<RegSetValueEx()> instead. This routine can only +set unamed values [a.k.a. "default values"]. + +=item RegSetValueEx + +=item C<RegSetValueEx( $hKey, $sName, $uZero, $uType, $pData, $lData )> + +Adds or replaces a value in an open Registry key. Returns +a true value if successful and a false value [and sets +C<$^E>/C<regLastError()>] on failure. + +C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from +a previous call]. + +C<$sName> is the name of the value to be set. + +C<$uZero> is reserved for future use and should be specified as C<0>. + +C<$uType> is the type of data stored in C<$pData>. It should +be a C<REG_*> value. + +C<$pData> is the value data packed into a Perl string. + +C<$lData> is the length of the value data that is stored in C<$pData>. +You will usually omit this parameter or pass in C<0> to have +C<length($pData)> used. In both of these cases, if C<$iType> is +C<REG_SZ> or C<REG_EXPAND_SZ>, C<RegSetValueEx()> will append a +trailing C<'\0'> to the end of C<$pData> [unless there is already +one]. + +=item RegUnLoadKey + +=item C<RegUnLoadKey( $hKey, $sSubKey )> + +Unloads a previously loaded hive file. That is, closes the +hive file then deletes the subkey that was providing access +to it. Returns a true value if successful and a false value +[and sets C<$^E>/C<regLastError()>] on failure. + +C<$hKey> is the handle to a Registry key that has hives +loaded in it. This must be C<HKEY_LOCAL_MACHINE>, C<HKEY_USERS>, +or a remote version of one of these from a call to +C<RegConnectRegistry()>. + +C<$sSubKey> is the name of the subkey whose hive you wish to +have unloaded. + +=item :FuncA + +The ASCII-specific function names. + +Each of these is identical to the version listed above without the +trailing "A": + + AbortSystemShutdownA InitiateSystemShutdownA + RegConnectRegistryA RegCreateKeyA RegCreateKeyExA + RegDeleteKeyA RegDeleteValueA RegEnumKeyA + RegEnumKeyExA RegEnumValueA RegLoadKeyA + RegOpenKeyA RegOpenKeyExA RegQueryInfoKeyA + RegQueryMultipleValuesA RegQueryValueA RegQueryValueExA + RegReplaceKeyA RegRestoreKeyA RegSaveKeyA + RegSetValueA RegSetValueExA RegUnLoadKeyA + +=item :FuncW + +The UNICODE-specific function names. These are the same as the +versions listed above without the trailing "W" except that string +parameters are UNICODE strings rather than ASCII strings, as +indicated. + +=item AbortSystemShutdownW + +=item C<AbortSystemShutdownW( $swComputerName )> + +C<$swComputerName> is UNICODE. + +=item InitiateSystemShutdownW + +=item C<InitiateSystemShutdownW( $swComputer, $swMessage, $uTimeoutSecs, $bForce, $bReboot )> + +C<$swComputer> and C<$swMessage> are UNICODE. + +=item RegConnectRegistryW + +=item C<RegConnectRegistryW( $swComputer, $hRootKey, $ohKey )> + +C<$swComputer> is UNICODE. + +=item RegCreateKeyW + +=item C<RegCreateKeyW( $hKey, $swSubKey, $ohSubKey )> + +C<$swSubKey> is UNICODE. + +=item RegCreateKeyExW + +=item C<RegCreateKeyExW( $hKey, $swSubKey, $uZero, $swClass, $uOpts, $uAccess, $pSecAttr, $ohNewKey, $ouDisp )> + +C<$swSubKey> and C<$swClass> are UNICODE. + +=item RegDeleteKeyW + +=item C<RegDeleteKeyW( $hKey, $swSubKey )> + +C<$swSubKey> is UNICODE. + +=item RegDeleteValueW + +=item C<RegDeleteValueW( $hKey, $swValueName )> + +C<$swValueName> is UNICODE. + +=item RegEnumKeyW + +=item C<RegEnumKeyW( $hKey, $uIndex, $oswName, $ilwNameSize )> + +C<$oswName> is UNICODE and C<$ilwNameSize> is measured as number of +C<WCHAR>s. + +=item RegEnumKeyExW + +=item C<RegEnumKeyExW( $hKey, $uIndex, $oswName, $iolwName, $pNull, $oswClass, $iolwClass, $opftLastWrite )> + +C<$swName> and C<$swClass> are UNICODE and C<$iolwName> and C<$iolwClass> +are measured as number of C<WCHAR>s. + +=item RegEnumValueW + +=item C<RegEnumValueW( $hKey, $uIndex, $oswName, $iolwName, $pNull, $ouType, $opData, $iolData )> + +C<$oswName> is UNICODE and C<$iolwName> is measured as number +of C<WCHAR>s. + +C<$opData> is UNICODE if C<$piType> is C<REG_SZ>, C<REG_EXPAND_SZ>, +or C<REG_MULTI_SZ>. Note that C<$iolData> is measured as number +of bytes even in these cases. + +=item RegLoadKeyW + +=item C<RegLoadKeyW( $hKey, $swSubKey, $swFileName )> + +C<$swSubKey> and C<$swFileName> are UNICODE. + +=item RegOpenKeyW + +=item C<RegOpenKeyW( $hKey, $swSubKey, $ohSubKey )> + +C<$swSubKey> is UNICODE. + +=item RegOpenKeyExW + +=item C<RegOpenKeyExW( $hKey, $swSubKey, $uOptions, $uAccess, $ohSubKey )> + +C<$swSubKey> is UNICODE. + +=item RegQueryInfoKeyW + +=item C<RegQueryInfoKeyW( $hKey, $oswClass, $iolwClass, $pNull, $ocSubKeys, $olwSubKey, $olwSubClass, $ocValues, $olwValName, $olValData, $olSecDesc, $opftTime )> + +C<$swClass> is UNICODE. C<$iolwClass>, C<$olwSubKey>, C<$olwSubClass>, +and C<$olwValName> are measured as number of C<WCHAR>s. Note that +C<$olValData> is measured as number of bytes. + +=item RegQueryMultipleValuesW + +=item C<RegQueryMultipleValuesW( $hKey, $ioarValueEnts, $icValueEnts, $opBuffer, $iolBuffer )> + +The C<ve_valuename> fields of the C<VALENT> [actually C<VALENTW>] +structures in C<$ioarValueEnts> are UNICODE. Values of type C<REG_SZ>, +C<REG_EXPAND_SZ>, and C<REG_MULTI_SZ> are written to C<$opBuffer> +in UNICODE. Note that C<$iolBuffer> and the C<ve_valuelen> fields +of the C<VALENT> [C<VALENTW>] structures are measured as number of +bytes. + +=item RegQueryValueW + +=item C<RegQueryValueW( $hKey, $swSubKey, $oswValueData, $iolValueData )> + +C<$swSubKey> and C<$oswValueData> are UNICODE. Note that +C<$iolValueData> is measured as number of bytes. + +=item RegQueryValueExW + +=item C<RegQueryValueExW( $hKey, $swName, $pNull, $ouType, $opData, $iolData )> + +C<$swName> is UNICODE. + +C<$opData> is UNICODE if C<$ouType> is C<REG_SZ>, C<REG_EXPAND_SZ>, +or C<REG_MULTI_SZ>. Note that C<$iolData> is measured as number of +bytes even in these cases. + +=item RegReplaceKeyW + +=item C<RegReplaceKeyW( $hKey, $swSubKey, $swNewFile, $swOldFile )> + +C<$swSubKey>, C<$swNewFile>, and C<$swOldFile> are UNICODE. + +=item RegRestoreKeyW + +=item C<RegRestoreKeyW( $hKey, $swFileName, $uFlags )> + +C<$swFileName> is UNICODE. + +=item RegSaveKeyW + +=item C<RegSaveKeyW( $hKey, $swFileName, $pSecAttr )> + +C<$swFileName> is UNICODE. + +=item RegSetValueW + +=item C<RegSetValueW( $hKey, $swSubKey, $uType, $swValueData, $lValueData )> + +C<$swSubKey> and C<$swValueData> are UNICODE. Note that +C<$lValueData> is measured as number of bytes even though +C<$swValueData> is always UNICODE. + +=item RegSetValueExW + +=item C<RegSetValueExW( $hKey, $swName, $uZero, $uType, $pData, $lData )> + +C<$swName> is UNICODE. + +C<$pData> is UNICODE if C<$uType> is C<REG_SZ>, C<REG_EXPAND_SZ>, +or C<REG_MULTI_SZ>. Note that C<$lData> is measured as number of +bytes even in these cases. + +=item RegUnLoadKeyW + +=item C<RegUnLoadKeyW( $hKey, $swSubKey )> + +C<$swSubKey> is UNICODE. + +=item :HKEY_ + +All C<HKEY_*> constants: + + HKEY_CLASSES_ROOT HKEY_CURRENT_CONFIG HKEY_CURRENT_USER + HKEY_DYN_DATA HKEY_LOCAL_MACHINE HKEY_PERFORMANCE_DATA + HKEY_USERS + +=item :KEY_ + +All C<KEY_*> constants: + + KEY_QUERY_VALUE KEY_SET_VALUE KEY_CREATE_SUB_KEY + KEY_ENUMERATE_SUB_KEYS KEY_NOTIFY KEY_CREATE_LINK + KEY_READ KEY_WRITE KEY_EXECUTE + KEY_ALL_ACCESS + +=item :REG_ + +All C<REG_*> constants: + + REG_CREATED_NEW_KEY REG_OPENED_EXISTING_KEY + + REG_LEGAL_CHANGE_FILTER REG_NOTIFY_CHANGE_ATTRIBUTES + REG_NOTIFY_CHANGE_NAME REG_NOTIFY_CHANGE_LAST_SET + REG_NOTIFY_CHANGE_SECURITY REG_LEGAL_OPTION + + REG_OPTION_BACKUP_RESTORE REG_OPTION_CREATE_LINK + REG_OPTION_NON_VOLATILE REG_OPTION_OPEN_LINK + REG_OPTION_RESERVED REG_OPTION_VOLATILE + + REG_WHOLE_HIVE_VOLATILE REG_REFRESH_HIVE + REG_NO_LAZY_FLUSH + + REG_NONE REG_SZ + REG_EXPAND_SZ REG_BINARY + REG_DWORD REG_DWORD_LITTLE_ENDIAN + REG_DWORD_BIG_ENDIAN REG_LINK + REG_MULTI_SZ REG_RESOURCE_LIST + REG_FULL_RESOURCE_DESCRIPTOR REG_RESOURCE_REQUIREMENTS_LIST + +=item :ALL + +All of the above. + +=item :SE_ + +The strings for the following privilege names: + + SE_ASSIGNPRIMARYTOKEN_NAME SE_AUDIT_NAME + SE_BACKUP_NAME SE_CHANGE_NOTIFY_NAME + SE_CREATE_PAGEFILE_NAME SE_CREATE_PERMANENT_NAME + SE_CREATE_TOKEN_NAME SE_DEBUG_NAME + SE_INCREASE_QUOTA_NAME SE_INC_BASE_PRIORITY_NAME + SE_LOAD_DRIVER_NAME SE_LOCK_MEMORY_NAME + SE_MACHINE_ACCOUNT_NAME SE_PROF_SINGLE_PROCESS_NAME + SE_REMOTE_SHUTDOWN_NAME SE_RESTORE_NAME + SE_SECURITY_NAME SE_SHUTDOWN_NAME + SE_SYSTEMTIME_NAME SE_SYSTEM_ENVIRONMENT_NAME + SE_SYSTEM_PROFILE_NAME SE_TAKE_OWNERSHIP_NAME + SE_TCB_NAME SE_UNSOLICITED_INPUT_NAME + +It can be difficult to successfully build this module in a way +that makes these constants available. So some builds of this +module may not make them available. For such builds, trying +to export any of these constants will cause a fatal error. +For this reason, none of these symbols are currently included +in the C<":ALL"> grouping. + +=back + +=head2 The Win32API:: heirarchy + +This and the other Win32API:: modules are meant to expose the +nearly raw API calls so they can be used from Perl code in any +way they might be used from C code. This provides the following +advantages: + +=over + +=item Many modules can be written by people that don't have a C compiler. + +=item Encourages more module code to be written in Perl [not C]. + +Perl code is often much easier to inspect, debug, customize, and +enhance than XS code. + +=item Allows those already familiar with the Win32 API to get +off to a quick start. + +=item Provides an interactive tool for exploring even obscure +details of the Win32 API. + +It can be very useful to interactively explore ad-hoc calls into +parts of the Win32 API using: + + perl -de 0 + +=item Ensures that native Win32 data structures can be used. + +This allows maximum efficiency. It also allows data from one +module [for example, time or security information from the +C<Win32API::Registry> or C<Win32API::File> modules] to be used +with other modules [for example, C<Win32API::Time> and +C<Win32API::SecDesc>]. + +=item Provides a single version of the XS interface to each API +call where improvements can be collected. + +=back + +=head2 Buffer sizes + +For each parameter that specifies a buffer size, a value of C<0> +can be passed. For parameter that are pointers to buffer sizes, +you can also pass in C<NULL> by specifying an empty list reference, +C<[]>. Both of these cases will ensure that the variable has +I<some> buffer space allocated to it and pass in that buffer's +allocated size. Many of the calls indicate, via C<ERROR_MORE_DATA>, +that the buffer size was not sufficient and the F<Registry.xs> +code will automatically enlarge the buffer to the required size +and repeat the call. + +Numeric buffer sizes are used as minimum initial sizes for the +buffers. The larger of this size and the size of space already +allocated to the scalar will be passed to the underlying routine. +If that size was insufficient, and the underlying call provides +an easy method for determining the needed buffer size, then the +buffer will be enlarged and the call repeated as above. + +The underlying calls define buffer size parameter as unsigned, so +negative buffer sizes are treated as very large positive buffer +sizes which usually cause C<malloc()> to fail. + +To force the F<Registry.xs> code to pass in a specific value for +a buffer size, preceed the size with an equals sign via C<"=".>. +Buffer sizes that are passed in as strings starting with an equals +sign will have the equal sign stripped and the remainder of the string +interpretted as a number [via C's C<strtoul()> using only base 10] +which will be passed to the underlying routine [even if the allocated +buffer is actually larger]. The F<Registry.xs> code will enlarge the +buffer to the specified size, if needed, but will not enlarge the +buffer based on the underlying routine requesting more space. + +Some Reg*() calls may not currently set the buffer size when they +return C<ERROR_MORE_DATA>. But some that are not documented as +doing so, currently do so anyway. So the code assumes that any +routine I<might> do this and resizes any buffers and repeats the +call. We hope that eventually all routines will provide this +feature. + +When you use C<[]> for a buffer size, you can still find the +length of the data returned by using C<length($buffer)>. Note +that this length will be in bytes while a few of the buffer +sizes would have been in units of wide characters. + +Note that the RegQueryValueEx*() and RegEnumValue*() calls +will trim the trailing C<'\0'> [if present] from the returned data +values of type C<REG_SZ> or C<REG_EXPAND_SZ> but only if the +value data length parameter is omitted [or specified as C<[]>]. + +The RegSetValueEx*() calls will add a trailing C<'\0'> [if +missing] to the supplied data values of type C<REG_SZ> and +C<REG_EXPAND_SZ> but only if the value data length parameter +is omitted [or specified as C<0>]. + +=head2 Hungarian Notation + +The following abbreviations are used at the start of each parameter +name to hint at aspects of how the parameter is used. The prefix +is always in lower case and followed by a capital letter that starts +the descriptive part of the parameter name. Several of the following +abbreviations can be combined into a single prefix. + +Probably not all of these prefix notations are used by this module. +This document section may be included in any C<Win32API> module and +so covers some notations not used by this specific module. + +=over + +=item s + +A string. In C, a C<'\0'>-terminated C<char *>. In Perl, just a +string except that it will be truncated at the first C<"\0">, if +it contains one. + +=item sw + +A wide [UNICODE] string. In C, a C<L'\0'>-terminated C<WCHAR *>. +In Perl, a string that contains UNICODE data. You can convert a +string to UNICODE in Perl via: + + $string= "This is an example string"; + $unicode= pack( "S*", unpack("C*",$string), 0 ); + +Note how C<, 0> above causes an explicit C<L'\0'> to be added since +Perl's implicit C<'\0'> that it puts after each of its strings is not +wide enough to terminate a UNICODE string. So UNICODE strings are +different than regular strings in that the Perl version of a regular +string will not include the trialing C<'\0'> while the Perl version +of a UNICODE string must include the trailing C<L'\0'>. + +If a UNICODE string contains no non-ASCII characters, then you +can convert it back into a normal string via: + + $string= pack( "C*", unpack("S*",$unicode) ); + $string =~ s/\0$//; + +=item p + +A pointer to some buffer [usually containing some C<struct>]. In C, +a C<void *> or some other pointer type. In Perl, a string that is +usually manipulated using C<pack> and C<unpack>. The "p" is usually +followed by more prefix character(s) to indicate what type of data is +stored in the bufffer. + +=item a + +A packed array. In C, an array [usually of C<struct>s]. In Perl, a +string containing the packed data. The "a" is usually followed by +more prefix character(s) to indicate the data type of the elements. + +These packed arrays are also called "vectors" in places to avoid +confusion with Perl arrays. + +=item n + +A generic number. In C, any of the integer or floating point data +types. In Perl, a number; either an integer, unsigned, or double +[IV, UV, or NV, respectively]. Usually an integer. + +=item iv + +A signed integral value. In C, any of the signed integer data types. +In Perl, an integer [IV]. + +=item u + +An unsigned integral value. In C, any of the unsigned integer data +types. In Perl, an unsigned integer [UV]. + +=item d + +A floating-point number. In C, a C<float> or C<double> or, perhaps, +a C<long double>. In Perl, a double-precision floating-point number +[NV]. + +=item b + +A Boolean value. In C, any integer data type, though usually via +a type alias of C<bool> or C<BOOL>, containing either a 0 [false] or +non-zero [true] value. In Perl, a scalar containing a Boolean value +[C<0>, C<"">, or C<undef> for "false" and anything else for "true"]. + +=item c + +A count of items. In C, any integer data type. In Perl, an unsigned +integer [UV]. Usually used in conjunction with a "vector" parameter +[see L</a> above] to indicate the number of elements. + +=item l + +A length [in bytes]. In C, any integer data type. In Perl, an +unsigned integer [UV]. Usually used in conjunction with a "string" +or "pointer" parameter [see L</s> and L</p> above] to indicate the +buffer size or the size of the value stored in the buffer. + +For strings, there is no general rule as to whether the trailing +C<'\0'> is included in such sizes. For this reason, the C<Win32API> +modules follow the Perl rule of always allocating one extra byte +and reporting buffer sizes as being one smaller than allocated in +case the C<'\0'> is not included in the size. + +=item lw + +A length measured as number of UNICODE characters. In C, a count +of C<WCHAR>s. In Perl, an unsigned integer [UV] counting "shorts" +[see "s" and "S" in C<pack> and C<unpack>]. + +For UNICODE strings, the trailing C<L'\0'> may or may not be +included in a length so, again, we always allocate extra room +for one and don't report that extra space. + +=item h + +A handle. In C, a C<HANDLE> or more-specific handle data type. +In Perl, an unsigned integer [UV]. In C, these handles are often +actually some type of pointer, but Perl just treats them as opaque +numbers, as it should. This prefix is also used for other pointers +that are treated as integers in Perl code. + +=item r + +A record. In C, almost always a C<struct> or perhaps C<union>. Note +that C C<struct>s are rarely passed by value so the "r" is almost +always preceeded by a "p" or "a" [see L</p> and L</a> above]. For +the very rare unadorned "r", Perl stores the record in the same way +as a "pr", that is, in a string. For the very rare case where Perl +explicitly stores a pointer to the C<struct> rather than storing the +C<struct> directly in a Perl string, the prefix "pp" or "ppr" or even +"par" is used. + +=item sv + +=item rv + +=item hv + +=item av + +=item cv + +A Perl data type. Respectively, a scalar value [SV], a reference +[RV] [usually to a scalar], a hash [HV], a Perl array [AV], or a Perl +code reference [PVCV]. For the "hv", "av", and "cv" prefixes, a +leading "rv" is usually assumed. For a parameter to an XS subroutine, +a prefix of "sv" means the parameter is a scalar and so may be a string +or a number [or C<undef>] or even both at the same time. So "sv" +doesn't imply a leading "rv". + +=item Input or Output + +Whether a parameter is for input data, output data, or both is usually +not reflected by the data type prefix. In cases where this is not +obvious nor reflected in the parameter name proper, we may use the +following in front of the data type prefix. + +=over + +=item i + +An input parameter given to the API [usually omitted]. + +=item o + +An output-only parameter taken from the API. You should not get a +warning if such a parameter is C<undef> when you pass it into the +function. You should get an error if such a parameter is read-only. +You can [usually] pass in C<[]> for such a parameter to have the +parameter silently ignored. + +The output may be written directly into the Perl variable passed +to the subroutine, the same way the buffer parameter to Perl's +C<sysread()>. This method is often avoided in Perl because +the call then lacks any visual cue that some parameters are being +overwritten. But this method closely matches the C API which is +what we are trying to do. + +=item io + +Input given to the API then overwritten with output taken from the +API. You should get a warning [if B<-w> is in effect] if such a +parameter is C<undef> when you pass it into the function [unless it +is a buffer or buffer length parameter]. If the value is read-only, +then [for most parameters] the output is silently not written. This +is because it is often convenient to pass in read-only constants for +many such parameters. You can also usually pass in C<[]> for such +parameters. + +=back + +=item pp + +=item ppr + +=item par + +=item pap + +These are just unusual combinations of prefix characters described above. + +For each, a pointer is stored in a [4-byte] Perl string. You can +usually use C<unpack "P"> to access the real data from Perl. + +For "ppr" [and often for "pp"], the pointer points directly at a +C C<struct>. For "par", the pointer points to the first element +of a C [packed] array of C<struct>s. For "pap", the pointer points +to a C [packed] array of pointers to other things. + +=item ap + +Here we have a list of pointers packed into a single Perl string. + +=back + +=head1 BUGS + +The old ActiveState ports of Perl for Win32 [but not, ActivePerl, the +ActiveState distributions of standard Perl 5.004 and beyond] do not support +the tools for building extensions and so do not support this extension. + +No routines are provided for using the data returned in the C<FILETIME> +buffers. Those are in the C<Win32API::Time> module. + +No routines are provided for dealing with UNICODE data effectively. +See L</:FuncW> above for some simple-minded UNICODE methods. + +Parts of the module test will fail if used on a version of Perl +that does not yet set C<$^E> based on C<GetLastError()>. + +On NT 4.0 [at least], the RegEnum*() calls do not set the required +buffer sizes when returning C<ERROR_MORE_DATA> so this module will +not grow the buffers in such cases. C<Win32::TieRegistry> overcomes +this by using values from C<RegQueryInfoKey()> for buffer sizes in +RegEnum* calls. + +On NT 4.0 [at least], C<RegQueryInfoKey()> on C<HKEY_PERFORMANCE_DATA> +never succeeds. Also, C<RegQueryValueEx()> on C<HKEY_PERFORMANCE_DATA> +never returns the required buffer size. To access C<HKEY_PERFORMANCE_DATA> +you will need to keep growing the data buffer until the call succeeds. + +Because C<goto &subroutine> seems to be buggy under Win32 Perl, +it is not used in the stubs in F<Registry.pm>. + +=head1 AUTHOR + +Tye McQueen, tye@metronet.com, http://www.metronet.com/~tye/. + +=head1 SEE ALSO + +=over + +=item L<Win32::TieRegistry> + +=item L<Win32::Registry> + +=back + +=cut diff --git a/Master/tlpkg/installer/perllib/Win32API/Registry/cRegistry.pc b/Master/tlpkg/installer/perllib/Win32API/Registry/cRegistry.pc new file mode 100644 index 00000000000..9659d0c4361 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Win32API/Registry/cRegistry.pc @@ -0,0 +1,87 @@ +# Generated by cRegistry_pc.cxx. +# Package Win32API::Registry with options: +# CPLUSPLUS => q[1] +# IFDEF => q[ /^SE_/ ? '__cplusplus' : /REG_/ ] +# IMPORT_LIST => [q[/._/], q[!/[a-z]/]] +# VALUES => { KEY_DELETE=>q[DELETE], KEY_READ_CONTROL=>q[READ_CONTROL], KEY_WRITE_OWNER=>q[WRITE_OWNER], KEY_SYNCHRONIZE=>q[SYNCHRONIZE], KEY_WRITE_DAC=>q[WRITE_DAC] } +# WRITE_PERL => q[1] +# Perl files eval'd: +# Registry.pm => last if /^\s*(bootstrap|XSLoader::load)\b/ +# C files included: +# Registry.xs => last if m#/[/*]\s*CONSTS_DEFINED\b|^\s*MODULE\b# +sub HKEY_CLASSES_ROOT () { 0x80000000 } +sub HKEY_CURRENT_CONFIG () { 0x80000005 } +sub HKEY_CURRENT_USER () { 0x80000001 } +sub HKEY_DYN_DATA () { 0x80000006 } +sub HKEY_LOCAL_MACHINE () { 0x80000002 } +sub HKEY_PERFORMANCE_DATA () { 0x80000004 } +sub HKEY_USERS () { 0x80000003 } +sub KEY_ALL_ACCESS () { 983103 } +sub KEY_CREATE_LINK () { 32 } +sub KEY_CREATE_SUB_KEY () { 4 } +sub KEY_DELETE () { 65536 } +sub KEY_ENUMERATE_SUB_KEYS () { 8 } +sub KEY_EXECUTE () { 131097 } +sub KEY_NOTIFY () { 16 } +sub KEY_QUERY_VALUE () { 1 } +sub KEY_READ () { 131097 } +sub KEY_READ_CONTROL () { 131072 } +sub KEY_SET_VALUE () { 2 } +sub KEY_SYNCHRONIZE () { 1048576 } +sub KEY_WRITE () { 131078 } +sub KEY_WRITE_DAC () { 262144 } +sub KEY_WRITE_OWNER () { 524288 } +sub REG_BINARY () { 3 } +sub REG_CREATED_NEW_KEY () { 1 } +sub REG_DWORD () { 4 } +sub REG_DWORD_BIG_ENDIAN () { 5 } +sub REG_DWORD_LITTLE_ENDIAN () { 4 } +sub REG_EXPAND_SZ () { 2 } +sub REG_FULL_RESOURCE_DESCRIPTOR () { 9 } +sub REG_LEGAL_CHANGE_FILTER () { 15 } +sub REG_LEGAL_OPTION () { 15 } +sub REG_LINK () { 6 } +sub REG_MULTI_SZ () { 7 } +sub REG_NONE () { 0 } +sub REG_NOTIFY_CHANGE_ATTRIBUTES () { 2 } +sub REG_NOTIFY_CHANGE_LAST_SET () { 4 } +sub REG_NOTIFY_CHANGE_NAME () { 1 } +sub REG_NOTIFY_CHANGE_SECURITY () { 8 } +sub REG_NO_LAZY_FLUSH () { 4 } +sub REG_OPENED_EXISTING_KEY () { 2 } +sub REG_OPTION_BACKUP_RESTORE () { 4 } +sub REG_OPTION_CREATE_LINK () { 2 } +sub REG_OPTION_NON_VOLATILE () { 0 } +sub REG_OPTION_OPEN_LINK () { 8 } +sub REG_OPTION_RESERVED () { 0 } +sub REG_OPTION_VOLATILE () { 1 } +sub REG_REFRESH_HIVE () { 2 } +sub REG_RESOURCE_LIST () { 8 } +sub REG_RESOURCE_REQUIREMENTS_LIST () { 10 } +sub REG_SZ () { 1 } +sub REG_WHOLE_HIVE_VOLATILE () { 1 } +sub SE_ASSIGNPRIMARYTOKEN_NAME () { 'SeAssignPrimaryTokenPrivilege' } +sub SE_AUDIT_NAME () { 'SeAuditPrivilege' } +sub SE_BACKUP_NAME () { 'SeBackupPrivilege' } +sub SE_CHANGE_NOTIFY_NAME () { 'SeChangeNotifyPrivilege' } +sub SE_CREATE_PAGEFILE_NAME () { 'SeCreatePagefilePrivilege' } +sub SE_CREATE_PERMANENT_NAME () { 'SeCreatePermanentPrivilege' } +sub SE_CREATE_TOKEN_NAME () { 'SeCreateTokenPrivilege' } +sub SE_DEBUG_NAME () { 'SeDebugPrivilege' } +sub SE_INCREASE_QUOTA_NAME () { 'SeIncreaseQuotaPrivilege' } +sub SE_INC_BASE_PRIORITY_NAME () { 'SeIncreaseBasePriorityPrivilege' } +sub SE_LOAD_DRIVER_NAME () { 'SeLoadDriverPrivilege' } +sub SE_LOCK_MEMORY_NAME () { 'SeLockMemoryPrivilege' } +sub SE_MACHINE_ACCOUNT_NAME () { 'SeMachineAccountPrivilege' } +sub SE_PROF_SINGLE_PROCESS_NAME () { 'SeProfileSingleProcessPrivilege' } +sub SE_REMOTE_SHUTDOWN_NAME () { 'SeRemoteShutdownPrivilege' } +sub SE_RESTORE_NAME () { 'SeRestorePrivilege' } +sub SE_SECURITY_NAME () { 'SeSecurityPrivilege' } +sub SE_SHUTDOWN_NAME () { 'SeShutdownPrivilege' } +sub SE_SYSTEMTIME_NAME () { 'SeSystemtimePrivilege' } +sub SE_SYSTEM_ENVIRONMENT_NAME () { 'SeSystemEnvironmentPrivilege' } +sub SE_SYSTEM_PROFILE_NAME () { 'SeSystemProfilePrivilege' } +sub SE_TAKE_OWNERSHIP_NAME () { 'SeTakeOwnershipPrivilege' } +sub SE_TCB_NAME () { 'SeTcbPrivilege' } +sub SE_UNSOLICITED_INPUT_NAME () { 'SeUnsolicitedInputPrivilege' } +1; diff --git a/Master/tlpkg/installer/perllib/XSLoader.pm b/Master/tlpkg/installer/perllib/XSLoader.pm new file mode 100644 index 00000000000..34172dcfa70 --- /dev/null +++ b/Master/tlpkg/installer/perllib/XSLoader.pm @@ -0,0 +1,356 @@ +# Generated from XSLoader.pm.PL (resolved %Config::Config value) + +package XSLoader; + +$VERSION = "0.06"; + +#use strict; + +# enable debug/trace messages from DynaLoader perl code +# $dl_debug = $ENV{PERL_DL_DEBUG} || 0 unless defined $dl_debug; + + my $dl_dlext = 'dll'; + +package DynaLoader; + +# No prizes for guessing why we don't say 'bootstrap DynaLoader;' here. +# NOTE: All dl_*.xs (including dl_none.xs) define a dl_error() XSUB +boot_DynaLoader('DynaLoader') if defined(&boot_DynaLoader) && + !defined(&dl_error); +package XSLoader; + +sub load { + package DynaLoader; + + die q{XSLoader::load('Your::Module', $Your::Module::VERSION)} unless @_; + + my($module) = $_[0]; + + # work with static linking too + my $b = "$module\::bootstrap"; + goto &$b if defined &$b; + + goto retry unless $module and defined &dl_load_file; + + my @modparts = split(/::/,$module); + my $modfname = $modparts[-1]; + + my $modpname = join('/',@modparts); + my $modlibname = (caller())[1]; + my $c = @modparts; + $modlibname =~ s,[\\/][^\\/]+$,, while $c--; # Q&D basename + my $file = "$modlibname/auto/$modpname/$modfname.$dl_dlext"; + +# print STDERR "XSLoader::load for $module ($file)\n" if $dl_debug; + + my $bs = $file; + $bs =~ s/(\.\w+)?(;\d*)?$/\.bs/; # look for .bs 'beside' the library + + goto retry if not -f $file or -s $bs; + + my $bootname = "boot_$module"; + $bootname =~ s/\W/_/g; + @DynaLoader::dl_require_symbols = ($bootname); + + my $boot_symbol_ref; + + if ($^O eq 'darwin') { + if ($boot_symbol_ref = dl_find_symbol(0, $bootname)) { + goto boot; #extension library has already been loaded, e.g. darwin + } + } + + # Many dynamic extension loading problems will appear to come from + # this section of code: XYZ failed at line 123 of DynaLoader.pm. + # Often these errors are actually occurring in the initialisation + # C code of the extension XS file. Perl reports the error as being + # in this perl code simply because this was the last perl code + # it executed. + + my $libref = dl_load_file($file, 0) or do { + require Carp; + Carp::croak("Can't load '$file' for module $module: " . dl_error()); + }; + push(@DynaLoader::dl_librefs,$libref); # record loaded object + + my @unresolved = dl_undef_symbols(); + if (@unresolved) { + require Carp; + Carp::carp("Undefined symbols present after loading $file: @unresolved\n"); + } + + $boot_symbol_ref = dl_find_symbol($libref, $bootname) or do { + require Carp; + Carp::croak("Can't find '$bootname' symbol in $file\n"); + }; + + push(@DynaLoader::dl_modules, $module); # record loaded module + + boot: + my $xs = dl_install_xsub("${module}::bootstrap", $boot_symbol_ref, $file); + + # See comment block above + push(@DynaLoader::dl_shared_objects, $file); # record files loaded + return &$xs(@_); + + retry: + my $bootstrap_inherit = DynaLoader->can('bootstrap_inherit') || + XSLoader->can('bootstrap_inherit'); + goto &$bootstrap_inherit; +} + +# Versions of DynaLoader prior to 5.6.0 don't have this function. +sub bootstrap_inherit { + package DynaLoader; + + my $module = $_[0]; + local *DynaLoader::isa = *{"$module\::ISA"}; + local @DynaLoader::isa = (@DynaLoader::isa, 'DynaLoader'); + # Cannot goto due to delocalization. Will report errors on a wrong line? + require DynaLoader; + DynaLoader::bootstrap(@_); +} + +1; + + +__END__ + +=head1 NAME + +XSLoader - Dynamically load C libraries into Perl code + +=head1 VERSION + +Version 0.06 + +=head1 SYNOPSIS + + package YourPackage; + use XSLoader; + + XSLoader::load 'YourPackage', $YourPackage::VERSION; + +=head1 DESCRIPTION + +This module defines a standard I<simplified> interface to the dynamic +linking mechanisms available on many platforms. Its primary purpose is +to implement cheap automatic dynamic loading of Perl modules. + +For a more complicated interface, see L<DynaLoader>. Many (most) +features of C<DynaLoader> are not implemented in C<XSLoader>, like for +example the C<dl_load_flags>, not honored by C<XSLoader>. + +=head2 Migration from C<DynaLoader> + +A typical module using L<DynaLoader|DynaLoader> starts like this: + + package YourPackage; + require DynaLoader; + + our @ISA = qw( OnePackage OtherPackage DynaLoader ); + our $VERSION = '0.01'; + bootstrap YourPackage $VERSION; + +Change this to + + package YourPackage; + use XSLoader; + + our @ISA = qw( OnePackage OtherPackage ); + our $VERSION = '0.01'; + XSLoader::load 'YourPackage', $VERSION; + +In other words: replace C<require DynaLoader> by C<use XSLoader>, remove +C<DynaLoader> from C<@ISA>, change C<bootstrap> by C<XSLoader::load>. Do not +forget to quote the name of your package on the C<XSLoader::load> line, +and add comma (C<,>) before the arguments (C<$VERSION> above). + +Of course, if C<@ISA> contained only C<DynaLoader>, there is no need to have +the C<@ISA> assignment at all; moreover, if instead of C<our> one uses the +more backward-compatible + + use vars qw($VERSION @ISA); + +one can remove this reference to C<@ISA> together with the C<@ISA> assignment. + +If no C<$VERSION> was specified on the C<bootstrap> line, the last line becomes + + XSLoader::load 'YourPackage'; + +=head2 Backward compatible boilerplate + +If you want to have your cake and eat it too, you need a more complicated +boilerplate. + + package YourPackage; + use vars qw($VERSION @ISA); + + @ISA = qw( OnePackage OtherPackage ); + $VERSION = '0.01'; + eval { + require XSLoader; + XSLoader::load('YourPackage', $VERSION); + 1; + } or do { + require DynaLoader; + push @ISA, 'DynaLoader'; + bootstrap YourPackage $VERSION; + }; + +The parentheses about C<XSLoader::load()> arguments are needed since we replaced +C<use XSLoader> by C<require>, so the compiler does not know that a function +C<XSLoader::load()> is present. + +This boilerplate uses the low-overhead C<XSLoader> if present; if used with +an antic Perl which has no C<XSLoader>, it falls back to using C<DynaLoader>. + +=head1 Order of initialization: early load() + +I<Skip this section if the XSUB functions are supposed to be called from other +modules only; read it only if you call your XSUBs from the code in your module, +or have a C<BOOT:> section in your XS file (see L<perlxs/"The BOOT: Keyword">). +What is described here is equally applicable to the L<DynaLoader|DynaLoader> +interface.> + +A sufficiently complicated module using XS would have both Perl code (defined +in F<YourPackage.pm>) and XS code (defined in F<YourPackage.xs>). If this +Perl code makes calls into this XS code, and/or this XS code makes calls to +the Perl code, one should be careful with the order of initialization. + +The call to C<XSLoader::load()> (or C<bootstrap()>) has three side effects: + +=over + +=item * + +if C<$VERSION> was specified, a sanity check is done to ensure that the +versions of the F<.pm> and the (compiled) F<.xs> parts are compatible; + +=item * + +the XSUBs are made accessible from Perl; + +=item * + +if a C<BOOT:> section was present in the F<.xs> file, the code there is called. + +=back + +Consequently, if the code in the F<.pm> file makes calls to these XSUBs, it is +convenient to have XSUBs installed before the Perl code is defined; for +example, this makes prototypes for XSUBs visible to this Perl code. +Alternatively, if the C<BOOT:> section makes calls to Perl functions (or +uses Perl variables) defined in the F<.pm> file, they must be defined prior to +the call to C<XSLoader::load()> (or C<bootstrap()>). + +The first situation being much more frequent, it makes sense to rewrite the +boilerplate as + + package YourPackage; + use XSLoader; + use vars qw($VERSION @ISA); + + BEGIN { + @ISA = qw( OnePackage OtherPackage ); + $VERSION = '0.01'; + + # Put Perl code used in the BOOT: section here + + XSLoader::load 'YourPackage', $VERSION; + } + + # Put Perl code making calls into XSUBs here + +=head2 The most hairy case + +If the interdependence of your C<BOOT:> section and Perl code is +more complicated than this (e.g., the C<BOOT:> section makes calls to Perl +functions which make calls to XSUBs with prototypes), get rid of the C<BOOT:> +section altogether. Replace it with a function C<onBOOT()>, and call it like +this: + + package YourPackage; + use XSLoader; + use vars qw($VERSION @ISA); + + BEGIN { + @ISA = qw( OnePackage OtherPackage ); + $VERSION = '0.01'; + XSLoader::load 'YourPackage', $VERSION; + } + + # Put Perl code used in onBOOT() function here; calls to XSUBs are + # prototype-checked. + + onBOOT; + + # Put Perl initialization code assuming that XS is initialized here + + +=head1 DIAGNOSTICS + +=over 4 + +=item Can't find '%s' symbol in %s + +B<(F)> The bootstrap symbol could not be found in the extension module. + +=item Can't load '%s' for module %s: %s + +B<(F)> The loading or initialisation of the extension module failed. +The detailed error follows. + +=item Undefined symbols present after loading %s: %s + +B<(W)> As the message says, some symbols stay undefined although the +extension module was correctly loaded and initialised. The list of undefined +symbols follows. + +=item XSLoader::load('Your::Module', $Your::Module::VERSION) + +B<(F)> You tried to invoke C<load()> without any argument. You must supply +a module name, and optionally its version. + +=back + + +=head1 LIMITATIONS + +To reduce the overhead as much as possible, only one possible location +is checked to find the extension DLL (this location is where C<make install> +would put the DLL). If not found, the search for the DLL is transparently +delegated to C<DynaLoader>, which looks for the DLL along the C<@INC> list. + +In particular, this is applicable to the structure of C<@INC> used for testing +not-yet-installed extensions. This means that running uninstalled extensions +may have much more overhead than running the same extensions after +C<make install>. + + +=head1 BUGS + +Please report any bugs or feature requests via the perlbug(1) utility. + + +=head1 SEE ALSO + +L<DynaLoader> + + +=head1 AUTHORS + +Ilya Zakharevich originally extracted C<XSLoader> from C<DynaLoader>. + +CPAN version is currently maintained by SE<eacute>bastien Aperghis-Tramoni +E<lt>sebastien@aperghis.netE<gt> + +Previous maintainer was Michael G Schwern <schwern@pobox.com> + + +=head1 COPYRIGHT + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/Master/tlpkg/installer/perllib/auto/Cwd/Cwd.bs b/Master/tlpkg/installer/perllib/auto/Cwd/Cwd.bs new file mode 100644 index 00000000000..e69de29bb2d --- /dev/null +++ b/Master/tlpkg/installer/perllib/auto/Cwd/Cwd.bs diff --git a/Master/tlpkg/installer/perllib/auto/Cwd/Cwd.dll b/Master/tlpkg/installer/perllib/auto/Cwd/Cwd.dll Binary files differnew file mode 100755 index 00000000000..67f6d7baa57 --- /dev/null +++ b/Master/tlpkg/installer/perllib/auto/Cwd/Cwd.dll diff --git a/Master/tlpkg/installer/perllib/auto/DynaLoader/autosplit.ix b/Master/tlpkg/installer/perllib/auto/DynaLoader/autosplit.ix new file mode 100644 index 00000000000..d7605efa074 --- /dev/null +++ b/Master/tlpkg/installer/perllib/auto/DynaLoader/autosplit.ix @@ -0,0 +1,8 @@ +# Index created by AutoSplit for ../LIB\DynaLoader.pm +# (file acts as timestamp) +package DynaLoader; +sub dl_findfile ; +sub dl_expandspec ; +sub dl_find_symbol_anywhere +; +1; diff --git a/Master/tlpkg/installer/perllib/auto/DynaLoader/dl_expandspec.al b/Master/tlpkg/installer/perllib/auto/DynaLoader/dl_expandspec.al new file mode 100644 index 00000000000..0bea19a3e4d --- /dev/null +++ b/Master/tlpkg/installer/perllib/auto/DynaLoader/dl_expandspec.al @@ -0,0 +1,34 @@ +# NOTE: Derived from ../LIB\DynaLoader.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package DynaLoader; + +#line 377 "../LIB\DynaLoader.pm (autosplit into ..\lib\auto\DynaLoader\dl_expandspec.al)" +sub dl_expandspec { + my($spec) = @_; + # Optional function invoked if DynaLoader.pm sets $do_expand. + # Most systems do not require or use this function. + # Some systems may implement it in the dl_*.xs file in which case + # this autoload version will not be called but is harmless. + + # This function is designed to deal with systems which treat some + # 'filenames' in a special way. For example VMS 'Logical Names' + # (something like unix environment variables - but different). + # This function should recognise such names and expand them into + # full file paths. + # Must return undef if $spec is invalid or file does not exist. + + my $file = $spec; # default output to input + + if ($Is_VMS) { # dl_expandspec should be defined in dl_vms.xs + require Carp; + Carp::croak("dl_expandspec: should be defined in XS file!\n"); + } else { + return undef unless -f $file; + } + print STDERR "dl_expandspec($spec) => $file\n" if $dl_debug; + $file; +} + +# end of DynaLoader::dl_expandspec +1; diff --git a/Master/tlpkg/installer/perllib/auto/DynaLoader/dl_find_symbol_anywhere.al b/Master/tlpkg/installer/perllib/auto/DynaLoader/dl_find_symbol_anywhere.al new file mode 100644 index 00000000000..2232454ba69 --- /dev/null +++ b/Master/tlpkg/installer/perllib/auto/DynaLoader/dl_find_symbol_anywhere.al @@ -0,0 +1,19 @@ +# NOTE: Derived from ../LIB\DynaLoader.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package DynaLoader; + +#line 403 "../LIB\DynaLoader.pm (autosplit into ..\lib\auto\DynaLoader\dl_find_symbol_anywhere.al)" +sub dl_find_symbol_anywhere +{ + my $sym = shift; + my $libref; + foreach $libref (@dl_librefs) { + my $symref = dl_find_symbol($libref,$sym); + return $symref if $symref; + } + return undef; +} + +1; +# end of DynaLoader::dl_find_symbol_anywhere diff --git a/Master/tlpkg/installer/perllib/auto/DynaLoader/dl_findfile.al b/Master/tlpkg/installer/perllib/auto/DynaLoader/dl_findfile.al new file mode 100644 index 00000000000..9f8df39d00c --- /dev/null +++ b/Master/tlpkg/installer/perllib/auto/DynaLoader/dl_findfile.al @@ -0,0 +1,115 @@ +# NOTE: Derived from ../LIB\DynaLoader.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package DynaLoader; + +#line 269 "../LIB\DynaLoader.pm (autosplit into ..\lib\auto\DynaLoader\dl_findfile.al)" +sub dl_findfile { + # Read ext/DynaLoader/DynaLoader.doc for detailed information. + # This function does not automatically consider the architecture + # or the perl library auto directories. + my (@args) = @_; + my (@dirs, $dir); # which directories to search + my (@found); # full paths to real files we have found + my $dl_ext= 'dll'; # $Config::Config{'dlext'} suffix for perl extensions + my $dl_so = 'dll'; # $Config::Config{'so'} suffix for shared libraries + + print STDERR "dl_findfile(@args)\n" if $dl_debug; + + # accumulate directories but process files as they appear + arg: foreach(@args) { + # Special fast case: full filepath requires no search + if ($Is_VMS && m%[:>/\]]% && -f $_) { + push(@found,dl_expandspec(VMS::Filespec::vmsify($_))); + last arg unless wantarray; + next; + } + elsif ($Is_MacOS) { + if (m/:/ && -f $_) { + push(@found,$_); + last arg unless wantarray; + } + } + elsif (m:/: && -f $_ && !$do_expand) { + push(@found,$_); + last arg unless wantarray; + next; + } + + # Deal with directories first: + # Using a -L prefix is the preferred option (faster and more robust) + if (m:^-L:) { s/^-L//; push(@dirs, $_); next; } + + if ($Is_MacOS) { + # Otherwise we try to try to spot directories by a heuristic + # (this is a more complicated issue than it first appears) + if (m/:/ && -d $_) { push(@dirs, $_); next; } + # Only files should get this far... + my(@names, $name); # what filenames to look for + s/^-l//; + push(@names, $_); + foreach $dir (@dirs, @dl_library_path) { + next unless -d $dir; + $dir =~ s/^([^:]+)$/:$1/; + $dir =~ s/:$//; + foreach $name (@names) { + my($file) = "$dir:$name"; + print STDERR " checking in $dir for $name\n" if $dl_debug; + if (-f $file) { + push(@found, $file); + next arg; # no need to look any further + } + } + } + next; + } + + # Otherwise we try to try to spot directories by a heuristic + # (this is a more complicated issue than it first appears) + if (m:/: && -d $_) { push(@dirs, $_); next; } + + # VMS: we may be using native VMS directory syntax instead of + # Unix emulation, so check this as well + if ($Is_VMS && /[:>\]]/ && -d $_) { push(@dirs, $_); next; } + + # Only files should get this far... + my(@names, $name); # what filenames to look for + if (m:-l: ) { # convert -lname to appropriate library name + s/-l//; + push(@names,"lib$_.$dl_so"); + push(@names,"lib$_.a"); + } else { # Umm, a bare name. Try various alternatives: + # these should be ordered with the most likely first + push(@names,"$_.$dl_ext") unless m/\.$dl_ext$/o; + push(@names,"$_.$dl_so") unless m/\.$dl_so$/o; + push(@names,"lib$_.$dl_so") unless m:/:; + push(@names,"$_.a") if !m/\.a$/ and $dlsrc eq "dl_dld.xs"; + push(@names, $_); + } + foreach $dir (@dirs, @dl_library_path) { + next unless -d $dir; + chop($dir = VMS::Filespec::unixpath($dir)) if $Is_VMS; + foreach $name (@names) { + my($file) = "$dir/$name"; + print STDERR " checking in $dir for $name\n" if $dl_debug; + $file = ($do_expand) ? dl_expandspec($file) : (-f $file && $file); + #$file = _check_file($file); + if ($file) { + push(@found, $file); + next arg; # no need to look any further + } + } + } + } + if ($dl_debug) { + foreach(@dirs) { + print STDERR " dl_findfile ignored non-existent directory: $_\n" unless -d $_; + } + print STDERR "dl_findfile found: @found\n"; + } + return $found[0] unless wantarray; + @found; +} + +# end of DynaLoader::dl_findfile +1; diff --git a/Master/tlpkg/installer/perllib/auto/Encode/Byte/Byte.bs b/Master/tlpkg/installer/perllib/auto/Encode/Byte/Byte.bs new file mode 100644 index 00000000000..e69de29bb2d --- /dev/null +++ b/Master/tlpkg/installer/perllib/auto/Encode/Byte/Byte.bs diff --git a/Master/tlpkg/installer/perllib/auto/Encode/Byte/Byte.dll b/Master/tlpkg/installer/perllib/auto/Encode/Byte/Byte.dll Binary files differnew file mode 100755 index 00000000000..88474ccb046 --- /dev/null +++ b/Master/tlpkg/installer/perllib/auto/Encode/Byte/Byte.dll diff --git a/Master/tlpkg/installer/perllib/auto/Encode/Encode.bs b/Master/tlpkg/installer/perllib/auto/Encode/Encode.bs new file mode 100644 index 00000000000..e69de29bb2d --- /dev/null +++ b/Master/tlpkg/installer/perllib/auto/Encode/Encode.bs diff --git a/Master/tlpkg/installer/perllib/auto/Encode/Encode.dll b/Master/tlpkg/installer/perllib/auto/Encode/Encode.dll Binary files differnew file mode 100755 index 00000000000..69c8ebf8acb --- /dev/null +++ b/Master/tlpkg/installer/perllib/auto/Encode/Encode.dll diff --git a/Master/tlpkg/installer/perllib/auto/Encode/Unicode/Unicode.bs b/Master/tlpkg/installer/perllib/auto/Encode/Unicode/Unicode.bs new file mode 100644 index 00000000000..e69de29bb2d --- /dev/null +++ b/Master/tlpkg/installer/perllib/auto/Encode/Unicode/Unicode.bs diff --git a/Master/tlpkg/installer/perllib/auto/Encode/Unicode/Unicode.dll b/Master/tlpkg/installer/perllib/auto/Encode/Unicode/Unicode.dll Binary files differnew file mode 100755 index 00000000000..71a757a6b64 --- /dev/null +++ b/Master/tlpkg/installer/perllib/auto/Encode/Unicode/Unicode.dll diff --git a/Master/tlpkg/installer/perllib/auto/Tk/CancelRepeat.al b/Master/tlpkg/installer/perllib/auto/Tk/CancelRepeat.al new file mode 100644 index 00000000000..d0d6bb1b2a3 --- /dev/null +++ b/Master/tlpkg/installer/perllib/auto/Tk/CancelRepeat.al @@ -0,0 +1,15 @@ +# NOTE: Derived from blib\lib\Tk.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk; + +#line 491 "blib\lib\Tk.pm (autosplit into blib\lib\auto\Tk\CancelRepeat.al)" +sub CancelRepeat +{ + my $w = shift->MainWindow; + my $id = delete $w->{_afterId_}; + $w->after('cancel',$id) if (defined $id); +} + +# end of Tk::CancelRepeat +1; diff --git a/Master/tlpkg/installer/perllib/auto/Tk/Clipboard/autosplit.ix b/Master/tlpkg/installer/perllib/auto/Tk/Clipboard/autosplit.ix new file mode 100644 index 00000000000..9831f74facb --- /dev/null +++ b/Master/tlpkg/installer/perllib/auto/Tk/Clipboard/autosplit.ix @@ -0,0 +1,6 @@ +# Index created by AutoSplit for blib\lib\Tk\Clipboard.pm +# (file acts as timestamp) +package Tk::Clipboard; +sub getSelected +; +1; diff --git a/Master/tlpkg/installer/perllib/auto/Tk/Clipboard/getSelected.al b/Master/tlpkg/installer/perllib/auto/Tk/Clipboard/getSelected.al new file mode 100644 index 00000000000..44ba7b74bf0 --- /dev/null +++ b/Master/tlpkg/installer/perllib/auto/Tk/Clipboard/getSelected.al @@ -0,0 +1,15 @@ +# NOTE: Derived from blib\lib\Tk\Clipboard.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk::Clipboard; + +#line 115 "blib\lib\Tk\Clipboard.pm (autosplit into blib\lib\auto\Tk\Clipboard\getSelected.al)" +sub getSelected +{ + my $w = shift; + my $val = Tk::catch { $w->get('sel.first','sel.last') }; + return $val; +} + +1; +# end of Tk::Clipboard::getSelected diff --git a/Master/tlpkg/installer/perllib/auto/Tk/Entry/Entry.bs b/Master/tlpkg/installer/perllib/auto/Tk/Entry/Entry.bs new file mode 100644 index 00000000000..e69de29bb2d --- /dev/null +++ b/Master/tlpkg/installer/perllib/auto/Tk/Entry/Entry.bs diff --git a/Master/tlpkg/installer/perllib/auto/Tk/Entry/Entry.dll b/Master/tlpkg/installer/perllib/auto/Tk/Entry/Entry.dll Binary files differnew file mode 100755 index 00000000000..9b1c07a7792 --- /dev/null +++ b/Master/tlpkg/installer/perllib/auto/Tk/Entry/Entry.dll diff --git a/Master/tlpkg/installer/perllib/auto/Tk/Error.al b/Master/tlpkg/installer/perllib/auto/Tk/Error.al new file mode 100644 index 00000000000..7efe2c7043d --- /dev/null +++ b/Master/tlpkg/installer/perllib/auto/Tk/Error.al @@ -0,0 +1,20 @@ +# NOTE: Derived from blib\lib\Tk.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk; + +#line 479 "blib\lib\Tk.pm (autosplit into blib\lib\auto\Tk\Error.al)" +sub Error +{my $w = shift; + my $error = shift; + if (Exists($w)) + { + my $grab = $w->grab('current'); + $grab->Unbusy if (defined $grab); + } + chomp($error); + warn "Tk::Error: $error\n " . join("\n ",@_)."\n"; +} + +# end of Tk::Error +1; diff --git a/Master/tlpkg/installer/perllib/auto/Tk/Event/Event.bs b/Master/tlpkg/installer/perllib/auto/Tk/Event/Event.bs new file mode 100644 index 00000000000..e69de29bb2d --- /dev/null +++ b/Master/tlpkg/installer/perllib/auto/Tk/Event/Event.bs diff --git a/Master/tlpkg/installer/perllib/auto/Tk/Event/Event.dll b/Master/tlpkg/installer/perllib/auto/Tk/Event/Event.dll Binary files differnew file mode 100755 index 00000000000..5a9706cb92e --- /dev/null +++ b/Master/tlpkg/installer/perllib/auto/Tk/Event/Event.dll diff --git a/Master/tlpkg/installer/perllib/auto/Tk/Frame/autosplit.ix b/Master/tlpkg/installer/perllib/auto/Tk/Frame/autosplit.ix new file mode 100644 index 00000000000..6e5b939fce1 --- /dev/null +++ b/Master/tlpkg/installer/perllib/auto/Tk/Frame/autosplit.ix @@ -0,0 +1,24 @@ +# Index created by AutoSplit for blib\lib\Tk\Frame.pm +# (file acts as timestamp) +package Tk::Frame; +sub labelPack +; +sub labelVariable +; +sub label +; +sub queuePack +; +sub sbset +; +sub freeze_on_map +; +sub AddScrollbars +; +sub packscrollbars +; +sub scrollbars +; +sub FindMenu +; +1; diff --git a/Master/tlpkg/installer/perllib/auto/Tk/PNG/PNG.bs b/Master/tlpkg/installer/perllib/auto/Tk/PNG/PNG.bs new file mode 100644 index 00000000000..e69de29bb2d --- /dev/null +++ b/Master/tlpkg/installer/perllib/auto/Tk/PNG/PNG.bs diff --git a/Master/tlpkg/installer/perllib/auto/Tk/PNG/PNG.dll b/Master/tlpkg/installer/perllib/auto/Tk/PNG/PNG.dll Binary files differnew file mode 100755 index 00000000000..08bbbed4fcc --- /dev/null +++ b/Master/tlpkg/installer/perllib/auto/Tk/PNG/PNG.dll diff --git a/Master/tlpkg/installer/perllib/auto/Tk/RepeatId.al b/Master/tlpkg/installer/perllib/auto/Tk/RepeatId.al new file mode 100644 index 00000000000..e71d2a337a0 --- /dev/null +++ b/Master/tlpkg/installer/perllib/auto/Tk/RepeatId.al @@ -0,0 +1,16 @@ +# NOTE: Derived from blib\lib\Tk.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk; + +#line 498 "blib\lib\Tk.pm (autosplit into blib\lib\auto\Tk\RepeatId.al)" +sub RepeatId +{ + my ($w,$id) = @_; + $w = $w->MainWindow; + $w->CancelRepeat; + $w->{_afterId_} = $id; +} + +# end of Tk::RepeatId +1; diff --git a/Master/tlpkg/installer/perllib/auto/Tk/Tk.bs b/Master/tlpkg/installer/perllib/auto/Tk/Tk.bs new file mode 100644 index 00000000000..e69de29bb2d --- /dev/null +++ b/Master/tlpkg/installer/perllib/auto/Tk/Tk.bs diff --git a/Master/tlpkg/installer/perllib/auto/Tk/Tk.dll b/Master/tlpkg/installer/perllib/auto/Tk/Tk.dll Binary files differnew file mode 100755 index 00000000000..8d80944808d --- /dev/null +++ b/Master/tlpkg/installer/perllib/auto/Tk/Tk.dll diff --git a/Master/tlpkg/installer/perllib/auto/Tk/Toplevel/autosplit.ix b/Master/tlpkg/installer/perllib/auto/Tk/Toplevel/autosplit.ix new file mode 100644 index 00000000000..859b90d9a40 --- /dev/null +++ b/Master/tlpkg/installer/perllib/auto/Tk/Toplevel/autosplit.ix @@ -0,0 +1,10 @@ +# Index created by AutoSplit for blib\lib\Tk\Toplevel.pm +# (file acts as timestamp) +package Tk::Toplevel; +sub FG_Create ; +sub FG_BindIn ; +sub FG_BindOut ; +sub FG_Destroy ; +sub FG_In ; +sub FG_Out ; +1; diff --git a/Master/tlpkg/installer/perllib/auto/Tk/Widget/autosplit.ix b/Master/tlpkg/installer/perllib/auto/Tk/Widget/autosplit.ix new file mode 100644 index 00000000000..b610773d4dc --- /dev/null +++ b/Master/tlpkg/installer/perllib/auto/Tk/Widget/autosplit.ix @@ -0,0 +1,11 @@ +# Index created by AutoSplit for blib\lib\Tk\Widget.pm +# (file acts as timestamp) +package Tk::Widget; +sub bindDump ; +sub ASkludge +; +sub clipboardKeysyms +; +sub pathname +; +1; diff --git a/Master/tlpkg/installer/perllib/auto/Tk/Wm/AnchorAdjust.al b/Master/tlpkg/installer/perllib/auto/Tk/Wm/AnchorAdjust.al new file mode 100644 index 00000000000..538612878ed --- /dev/null +++ b/Master/tlpkg/installer/perllib/auto/Tk/Wm/AnchorAdjust.al @@ -0,0 +1,17 @@ +# NOTE: Derived from blib\lib\Tk\Wm.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk::Wm; + +#line 87 "blib\lib\Tk\Wm.pm (autosplit into blib\lib\auto\Tk\Wm\AnchorAdjust.al)" +sub AnchorAdjust +{ + my ($anchor,$X,$Y,$w,$h) = @_; + $anchor = 'c' unless (defined $anchor); + $Y += ($anchor =~ /s/) ? $h : ($anchor =~ /n/) ? 0 : $h/2; + $X += ($anchor =~ /e/) ? $w : ($anchor =~ /w/) ? 0 : $w/2; + return ($X,$Y); +} + +# end of Tk::Wm::AnchorAdjust +1; diff --git a/Master/tlpkg/installer/perllib/auto/Tk/Wm/FullScreen.al b/Master/tlpkg/installer/perllib/auto/Tk/Wm/FullScreen.al new file mode 100644 index 00000000000..4d5702cc60d --- /dev/null +++ b/Master/tlpkg/installer/perllib/auto/Tk/Wm/FullScreen.al @@ -0,0 +1,29 @@ +# NOTE: Derived from blib\lib\Tk\Wm.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk::Wm; + +#line 138 "blib\lib\Tk\Wm.pm (autosplit into blib\lib\auto\Tk\Wm\FullScreen.al)" +sub FullScreen +{ + my $w = shift; + my $over = (@_) ? shift : 0; + my $width = $w->screenwidth; + my $height = $w->screenheight; + $w->GeometryRequest($width,$height); + $w->overrideredirect($over & 1); + $w->Post(0,0); + $w->update; + if ($over & 2) + { + my $x = $w->rootx; + my $y = $w->rooty; + $width -= 2*$x; + $height -= $x + $y; + $w->GeometryRequest($width,$height); + $w->update; + } +} + +# end of Tk::Wm::FullScreen +1; diff --git a/Master/tlpkg/installer/perllib/auto/Tk/Wm/Popup.al b/Master/tlpkg/installer/perllib/auto/Tk/Wm/Popup.al new file mode 100644 index 00000000000..3f460c5bac6 --- /dev/null +++ b/Master/tlpkg/installer/perllib/auto/Tk/Wm/Popup.al @@ -0,0 +1,50 @@ +# NOTE: Derived from blib\lib\Tk\Wm.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk::Wm; + +#line 96 "blib\lib\Tk\Wm.pm (autosplit into blib\lib\auto\Tk\Wm\Popup.al)" +sub Popup +{ + my $w = shift; + $w->configure(@_) if @_; + $w->idletasks; + my ($mw,$mh) = ($w->reqwidth,$w->reqheight); + my ($rx,$ry,$rw,$rh) = (0,0,0,0); + my $base = $w->cget('-popover'); + my $outside = 0; + if (defined $base) + { + if ($base eq 'cursor') + { + ($rx,$ry) = $w->pointerxy; + } + else + { + $rx = $base->rootx; + $ry = $base->rooty; + $rw = $base->Width; + $rh = $base->Height; + } + } + else + { + my $sc = ($w->parent) ? $w->parent->toplevel : $w; + $rx = -$sc->vrootx; + $ry = -$sc->vrooty; + $rw = $w->screenwidth; + $rh = $w->screenheight; + } + my ($X,$Y) = AnchorAdjust($w->cget('-overanchor'),$rx,$ry,$rw,$rh); + ($X,$Y) = AnchorAdjust($w->cget('-popanchor'),$X,$Y,-$mw,-$mh); + # adjust to not cross screen borders + if ($X < 0) { $X = 0 } + if ($Y < 0) { $Y = 0 } + if ($mw > $w->screenwidth) { $X = 0 } + if ($mh > $w->screenheight) { $Y = 0 } + $w->Post($X,$Y); + $w->waitVisibility; +} + +# end of Tk::Wm::Popup +1; diff --git a/Master/tlpkg/installer/perllib/auto/Tk/Wm/Post.al b/Master/tlpkg/installer/perllib/auto/Tk/Wm/Post.al new file mode 100644 index 00000000000..f3f5c8e3e08 --- /dev/null +++ b/Master/tlpkg/installer/perllib/auto/Tk/Wm/Post.al @@ -0,0 +1,20 @@ +# NOTE: Derived from blib\lib\Tk\Wm.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk::Wm; + +#line 75 "blib\lib\Tk\Wm.pm (autosplit into blib\lib\auto\Tk\Wm\Post.al)" +sub Post +{ + my ($w,$X,$Y) = @_; + $X = int($X); + $Y = int($Y); + $w->positionfrom('user'); + $w->geometry("+$X+$Y"); + # $w->MoveToplevelWindow($X,$Y); + $w->deiconify; + $w->raise; +} + +# end of Tk::Wm::Post +1; diff --git a/Master/tlpkg/installer/perllib/auto/Tk/Wm/autosplit.ix b/Master/tlpkg/installer/perllib/auto/Tk/Wm/autosplit.ix new file mode 100644 index 00000000000..201dbe8ba99 --- /dev/null +++ b/Master/tlpkg/installer/perllib/auto/Tk/Wm/autosplit.ix @@ -0,0 +1,14 @@ +# Index created by AutoSplit for blib\lib\Tk\Wm.pm +# (file acts as timestamp) +package Tk::Wm; +sub Post +; +sub AnchorAdjust +; +sub Popup +; +sub FullScreen +; +sub iconposition +; +1; diff --git a/Master/tlpkg/installer/perllib/auto/Tk/Wm/iconposition.al b/Master/tlpkg/installer/perllib/auto/Tk/Wm/iconposition.al new file mode 100644 index 00000000000..9254968f61c --- /dev/null +++ b/Master/tlpkg/installer/perllib/auto/Tk/Wm/iconposition.al @@ -0,0 +1,24 @@ +# NOTE: Derived from blib\lib\Tk\Wm.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk::Wm; + +#line 159 "blib\lib\Tk\Wm.pm (autosplit into blib\lib\auto\Tk\Wm\iconposition.al)" +sub iconposition +{ + my $w = shift; + if (@_ == 1) + { + return $w->wm('iconposition',$1,$2) if $_[0] =~ /^(\d+),(\d+)$/; + if ($_[0] =~ /^([+-])(\d+)([+-])(\d+)$/) + { + my $x = ($1 eq '-') ? $w->screenwidth-$2 : $2; + my $y = ($3 eq '-') ? $w->screenheight-$4 : $4; + return $w->wm('iconposition',$x,$y); + } + } + $w->wm('iconposition',@_); +} + +1; +# end of Tk::Wm::iconposition diff --git a/Master/tlpkg/installer/perllib/auto/Tk/autosplit.ix b/Master/tlpkg/installer/perllib/auto/Tk/autosplit.ix new file mode 100644 index 00000000000..7bd25b78a9a --- /dev/null +++ b/Master/tlpkg/installer/perllib/auto/Tk/autosplit.ix @@ -0,0 +1,45 @@ +# Index created by AutoSplit for blib\lib\Tk.pm +# (file acts as timestamp) +package Tk; +sub Error +; +sub CancelRepeat +; +sub RepeatId +; +sub FocusChildren ; +sub focusNext +; +sub focusPrev +; +sub FocusOK +; +sub EnterFocus +; +sub tabFocus +; +sub focusFollowsMouse +; +sub TraverseToMenu +; +sub FirstMenu +; +sub Selection +; +sub Receive +; +sub break +; +sub updateWidgets +; +sub ImageNames +; +sub ImageTypes +; +sub interps +; +sub lsearch +; +sub getEncoding +; +1; diff --git a/Master/tlpkg/installer/perllib/auto/Tk/getEncoding.al b/Master/tlpkg/installer/perllib/auto/Tk/getEncoding.al new file mode 100644 index 00000000000..b9e230edbf1 --- /dev/null +++ b/Master/tlpkg/installer/perllib/auto/Tk/getEncoding.al @@ -0,0 +1,43 @@ +# NOTE: Derived from blib\lib\Tk.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package Tk; + +#line 785 "blib\lib\Tk.pm (autosplit into blib\lib\auto\Tk\getEncoding.al)" +sub getEncoding +{ + my ($class,$name) = @_; + eval { require Encode }; + if ($@) + { + require Tk::DummyEncode; + return Tk::DummyEncode->getEncoding($name); + } + $name = $Tk::font_encoding{$name} if exists $Tk::font_encoding{$name}; + my $enc = Encode::find_encoding($name); + + unless ($enc) + { + $enc = Encode::find_encoding($name) if ($name =~ s/[-_]\d+$//) + } +# if ($enc) +# { +# print STDERR "Lookup '$name' => ".$enc->name."\n"; +# } +# else +# { +# print STDERR "Failed '$name'\n"; +# } + unless ($enc) + { + if ($name eq 'X11ControlChars') + { + require Tk::DummyEncode; + $Encode::encoding{$name} = $enc = Tk::DummyEncode->getEncoding($name); + } + } + return $enc; +} + +1; +# end of Tk::getEncoding diff --git a/Master/tlpkg/installer/perllib/auto/Win32/API/API.bs b/Master/tlpkg/installer/perllib/auto/Win32/API/API.bs new file mode 100644 index 00000000000..e69de29bb2d --- /dev/null +++ b/Master/tlpkg/installer/perllib/auto/Win32/API/API.bs diff --git a/Master/tlpkg/installer/perllib/auto/Win32/API/API.dll b/Master/tlpkg/installer/perllib/auto/Win32/API/API.dll Binary files differnew file mode 100644 index 00000000000..3a7efc0adca --- /dev/null +++ b/Master/tlpkg/installer/perllib/auto/Win32/API/API.dll diff --git a/Master/tlpkg/installer/perllib/auto/Win32/API/Callback/Callback.bs b/Master/tlpkg/installer/perllib/auto/Win32/API/Callback/Callback.bs new file mode 100644 index 00000000000..e69de29bb2d --- /dev/null +++ b/Master/tlpkg/installer/perllib/auto/Win32/API/Callback/Callback.bs diff --git a/Master/tlpkg/installer/perllib/auto/Win32/API/Callback/Callback.dll b/Master/tlpkg/installer/perllib/auto/Win32/API/Callback/Callback.dll Binary files differnew file mode 100644 index 00000000000..147c679d576 --- /dev/null +++ b/Master/tlpkg/installer/perllib/auto/Win32/API/Callback/Callback.dll diff --git a/Master/tlpkg/installer/perllib/auto/Win32API/Registry/Registry.bs b/Master/tlpkg/installer/perllib/auto/Win32API/Registry/Registry.bs new file mode 100644 index 00000000000..e69de29bb2d --- /dev/null +++ b/Master/tlpkg/installer/perllib/auto/Win32API/Registry/Registry.bs diff --git a/Master/tlpkg/installer/perllib/auto/Win32API/Registry/Registry.dll b/Master/tlpkg/installer/perllib/auto/Win32API/Registry/Registry.dll Binary files differnew file mode 100755 index 00000000000..45b7bc0688a --- /dev/null +++ b/Master/tlpkg/installer/perllib/auto/Win32API/Registry/Registry.dll diff --git a/Master/tlpkg/installer/perllib/base.pm b/Master/tlpkg/installer/perllib/base.pm new file mode 100644 index 00000000000..001914be4d3 --- /dev/null +++ b/Master/tlpkg/installer/perllib/base.pm @@ -0,0 +1,226 @@ +package base; + +use strict 'vars'; +use vars qw($VERSION); +$VERSION = '2.07'; + +# constant.pm is slow +sub SUCCESS () { 1 } + +sub PUBLIC () { 2**0 } +sub PRIVATE () { 2**1 } +sub INHERITED () { 2**2 } +sub PROTECTED () { 2**3 } + + +my $Fattr = \%fields::attr; + +sub has_fields { + my($base) = shift; + my $fglob = ${"$base\::"}{FIELDS}; + return( ($fglob && *$fglob{HASH}) ? 1 : 0 ); +} + +sub has_version { + my($base) = shift; + my $vglob = ${$base.'::'}{VERSION}; + return( ($vglob && *$vglob{SCALAR}) ? 1 : 0 ); +} + +sub has_attr { + my($proto) = shift; + my($class) = ref $proto || $proto; + return exists $Fattr->{$class}; +} + +sub get_attr { + $Fattr->{$_[0]} = [1] unless $Fattr->{$_[0]}; + return $Fattr->{$_[0]}; +} + +if ($] < 5.009) { + *get_fields = sub { + # Shut up a possible typo warning. + () = \%{$_[0].'::FIELDS'}; + my $f = \%{$_[0].'::FIELDS'}; + + # should be centralized in fields? perhaps + # fields::mk_FIELDS_be_OK. Peh. As long as %{ $package . '::FIELDS' } + # is used here anyway, it doesn't matter. + bless $f, 'pseudohash' if (ref($f) ne 'pseudohash'); + + return $f; + } +} +else { + *get_fields = sub { + # Shut up a possible typo warning. + () = \%{$_[0].'::FIELDS'}; + return \%{$_[0].'::FIELDS'}; + } +} + +sub import { + my $class = shift; + + return SUCCESS unless @_; + + # List of base classes from which we will inherit %FIELDS. + my $fields_base; + + my $inheritor = caller(0); + + foreach my $base (@_) { + next if $inheritor->isa($base); + + if (has_version($base)) { + ${$base.'::VERSION'} = '-1, set by base.pm' + unless defined ${$base.'::VERSION'}; + } + else { + local $SIG{__DIE__}; + eval "require $base"; + # Only ignore "Can't locate" errors from our eval require. + # Other fatal errors (syntax etc) must be reported. + die if $@ && $@ !~ /^Can't locate .*? at \(eval /; + unless (%{"$base\::"}) { + require Carp; + Carp::croak(<<ERROR); +Base class package "$base" is empty. + (Perhaps you need to 'use' the module which defines that package first.) +ERROR + + } + ${$base.'::VERSION'} = "-1, set by base.pm" + unless defined ${$base.'::VERSION'}; + } + push @{"$inheritor\::ISA"}, $base; + + if ( has_fields($base) || has_attr($base) ) { + # No multiple fields inheritence *suck* + if ($fields_base) { + require Carp; + Carp::croak("Can't multiply inherit %FIELDS"); + } else { + $fields_base = $base; + } + } + } + + if( defined $fields_base ) { + inherit_fields($inheritor, $fields_base); + } +} + + +sub inherit_fields { + my($derived, $base) = @_; + + return SUCCESS unless $base; + + my $battr = get_attr($base); + my $dattr = get_attr($derived); + my $dfields = get_fields($derived); + my $bfields = get_fields($base); + + $dattr->[0] = @$battr; + + if( keys %$dfields ) { + warn "$derived is inheriting from $base but already has its own ". + "fields!\n". + "This will cause problems.\n". + "Be sure you use base BEFORE declaring fields\n"; + } + + # Iterate through the base's fields adding all the non-private + # ones to the derived class. Hang on to the original attribute + # (Public, Private, etc...) and add Inherited. + # This is all too complicated to do efficiently with add_fields(). + while (my($k,$v) = each %$bfields) { + my $fno; + if ($fno = $dfields->{$k} and $fno != $v) { + require Carp; + Carp::croak ("Inherited %FIELDS can't override existing %FIELDS"); + } + + if( $battr->[$v] & PRIVATE ) { + $dattr->[$v] = PRIVATE | INHERITED; + } + else { + $dattr->[$v] = INHERITED | $battr->[$v]; + $dfields->{$k} = $v; + } + } + + foreach my $idx (1..$#{$battr}) { + next if defined $dattr->[$idx]; + $dattr->[$idx] = $battr->[$idx] & INHERITED; + } +} + + +1; + +__END__ + +=head1 NAME + +base - Establish IS-A relationship with base classes at compile time + +=head1 SYNOPSIS + + package Baz; + use base qw(Foo Bar); + +=head1 DESCRIPTION + +Allows you to both load one or more modules, while setting up inheritance from +those modules at the same time. Roughly similar in effect to + + package Baz; + BEGIN { + require Foo; + require Bar; + push @ISA, qw(Foo Bar); + } + +If any of the listed modules are not loaded yet, I<base> silently attempts to +C<require> them (and silently continues if the C<require> failed). Whether to +C<require> a base class module is determined by the absence of a global variable +$VERSION in the base package. If $VERSION is not detected even after loading +it, <base> will define $VERSION in the base package, setting it to the string +C<-1, set by base.pm>. + +Will also initialize the fields if one of the base classes has it. +Multiple inheritence of fields is B<NOT> supported, if two or more +base classes each have inheritable fields the 'base' pragma will +croak. See L<fields>, L<public> and L<protected> for a description of +this feature. + +=head1 DIAGNOSTICS + +=over 4 + +=item Base class package "%s" is empty. + +base.pm was unable to require the base package, because it was not +found in your path. + +=back + +=head1 HISTORY + +This module was introduced with Perl 5.004_04. + + +=head1 CAVEATS + +Due to the limitations of the implementation, you must use +base I<before> you declare any of your own fields. + + +=head1 SEE ALSO + +L<fields> + +=cut diff --git a/Master/tlpkg/installer/perllib/bytes.pm b/Master/tlpkg/installer/perllib/bytes.pm new file mode 100644 index 00000000000..a8222794ddf --- /dev/null +++ b/Master/tlpkg/installer/perllib/bytes.pm @@ -0,0 +1,88 @@ +package bytes; + +our $VERSION = '1.02'; + +$bytes::hint_bits = 0x00000008; + +sub import { + $^H |= $bytes::hint_bits; +} + +sub unimport { + $^H &= ~$bytes::hint_bits; +} + +sub AUTOLOAD { + require "bytes_heavy.pl"; + goto &$AUTOLOAD if defined &$AUTOLOAD; + require Carp; + Carp::croak("Undefined subroutine $AUTOLOAD called"); +} + +sub length ($); +sub chr ($); +sub ord ($); +sub substr ($$;$$); +sub index ($$;$); +sub rindex ($$;$); + +1; +__END__ + +=head1 NAME + +bytes - Perl pragma to force byte semantics rather than character semantics + +=head1 SYNOPSIS + + use bytes; + ... chr(...); # or bytes::chr + ... index(...); # or bytes::index + ... length(...); # or bytes::length + ... ord(...); # or bytes::ord + ... rindex(...); # or bytes::rindex + ... substr(...); # or bytes::substr + no bytes; + + +=head1 DESCRIPTION + +The C<use bytes> pragma disables character semantics for the rest of the +lexical scope in which it appears. C<no bytes> can be used to reverse +the effect of C<use bytes> within the current lexical scope. + +Perl normally assumes character semantics in the presence of character +data (i.e. data that has come from a source that has been marked as +being of a particular character encoding). When C<use bytes> is in +effect, the encoding is temporarily ignored, and each string is treated +as a series of bytes. + +As an example, when Perl sees C<$x = chr(400)>, it encodes the character +in UTF-8 and stores it in $x. Then it is marked as character data, so, +for instance, C<length $x> returns C<1>. However, in the scope of the +C<bytes> pragma, $x is treated as a series of bytes - the bytes that make +up the UTF8 encoding - and C<length $x> returns C<2>: + + $x = chr(400); + print "Length is ", length $x, "\n"; # "Length is 1" + printf "Contents are %vd\n", $x; # "Contents are 400" + { + use bytes; # or "require bytes; bytes::length()" + print "Length is ", length $x, "\n"; # "Length is 2" + printf "Contents are %vd\n", $x; # "Contents are 198.144" + } + +chr(), ord(), substr(), index() and rindex() behave similarly. + +For more on the implications and differences between character +semantics and byte semantics, see L<perluniintro> and L<perlunicode>. + +=head1 LIMITATIONS + +bytes::substr() does not work as an lvalue(). + +=head1 SEE ALSO + +L<perluniintro>, L<perlunicode>, L<utf8> + +=cut diff --git a/Master/tlpkg/installer/perllib/constant.pm b/Master/tlpkg/installer/perllib/constant.pm new file mode 100644 index 00000000000..159c29978a5 --- /dev/null +++ b/Master/tlpkg/installer/perllib/constant.pm @@ -0,0 +1,340 @@ +package constant; + +use strict; +use 5.006_00; +use warnings::register; + +our($VERSION, %declared); +$VERSION = '1.05'; + +#======================================================================= + +# Some names are evil choices. +my %keywords = map +($_, 1), qw{ BEGIN INIT CHECK END DESTROY AUTOLOAD }; + +my %forced_into_main = map +($_, 1), + qw{ STDIN STDOUT STDERR ARGV ARGVOUT ENV INC SIG }; + +my %forbidden = (%keywords, %forced_into_main); + +#======================================================================= +# import() - import symbols into user's namespace +# +# What we actually do is define a function in the caller's namespace +# which returns the value. The function we create will normally +# be inlined as a constant, thereby avoiding further sub calling +# overhead. +#======================================================================= +sub import { + my $class = shift; + return unless @_; # Ignore 'use constant;' + my %constants = (); + my $multiple = ref $_[0]; + + if ( $multiple ) { + if (ref $_[0] ne 'HASH') { + require Carp; + Carp::croak("Invalid reference type '".ref(shift)."' not 'HASH'"); + } + %constants = %{+shift}; + } else { + $constants{+shift} = undef; + } + + foreach my $name ( keys %constants ) { + unless (defined $name) { + require Carp; + Carp::croak("Can't use undef as constant name"); + } + my $pkg = caller; + + # Normal constant name + if ($name =~ /^_?[^\W_0-9]\w*\z/ and !$forbidden{$name}) { + # Everything is okay + + # Name forced into main, but we're not in main. Fatal. + } elsif ($forced_into_main{$name} and $pkg ne 'main') { + require Carp; + Carp::croak("Constant name '$name' is forced into main::"); + + # Starts with double underscore. Fatal. + } elsif ($name =~ /^__/) { + require Carp; + Carp::croak("Constant name '$name' begins with '__'"); + + # Maybe the name is tolerable + } elsif ($name =~ /^[A-Za-z_]\w*\z/) { + # Then we'll warn only if you've asked for warnings + if (warnings::enabled()) { + if ($keywords{$name}) { + warnings::warn("Constant name '$name' is a Perl keyword"); + } elsif ($forced_into_main{$name}) { + warnings::warn("Constant name '$name' is " . + "forced into package main::"); + } + } + + # Looks like a boolean + # use constant FRED == fred; + } elsif ($name =~ /^[01]?\z/) { + require Carp; + if (@_) { + Carp::croak("Constant name '$name' is invalid"); + } else { + Carp::croak("Constant name looks like boolean value"); + } + + } else { + # Must have bad characters + require Carp; + Carp::croak("Constant name '$name' has invalid characters"); + } + + { + no strict 'refs'; + my $full_name = "${pkg}::$name"; + $declared{$full_name}++; + if ($multiple) { + my $scalar = $constants{$name}; + *$full_name = sub () { $scalar }; + } else { + if (@_ == 1) { + my $scalar = $_[0]; + *$full_name = sub () { $scalar }; + } elsif (@_) { + my @list = @_; + *$full_name = sub () { @list }; + } else { + *$full_name = sub () { }; + } + } + } + } +} + +1; + +__END__ + +=head1 NAME + +constant - Perl pragma to declare constants + +=head1 SYNOPSIS + + use constant PI => 4 * atan2(1, 1); + use constant DEBUG => 0; + + print "Pi equals ", PI, "...\n" if DEBUG; + + use constant { + SEC => 0, + MIN => 1, + HOUR => 2, + MDAY => 3, + MON => 4, + YEAR => 5, + WDAY => 6, + YDAY => 7, + ISDST => 8, + }; + + use constant WEEKDAYS => qw( + Sunday Monday Tuesday Wednesday Thursday Friday Saturday + ); + + print "Today is ", (WEEKDAYS)[ (localtime)[WDAY] ], ".\n"; + +=head1 DESCRIPTION + +This will declare a symbol to be a constant with the given value. + +When you declare a constant such as C<PI> using the method shown +above, each machine your script runs upon can have as many digits +of accuracy as it can use. Also, your program will be easier to +read, more likely to be maintained (and maintained correctly), and +far less likely to send a space probe to the wrong planet because +nobody noticed the one equation in which you wrote C<3.14195>. + +When a constant is used in an expression, perl replaces it with its +value at compile time, and may then optimize the expression further. +In particular, any code in an C<if (CONSTANT)> block will be optimized +away if the constant is false. + +=head1 NOTES + +As with all C<use> directives, defining a constant happens at +compile time. Thus, it's probably not correct to put a constant +declaration inside of a conditional statement (like C<if ($foo) +{ use constant ... }>). + +Constants defined using this module cannot be interpolated into +strings like variables. However, concatenation works just fine: + + print "Pi equals PI...\n"; # WRONG: does not expand "PI" + print "Pi equals ".PI."...\n"; # right + +Even though a reference may be declared as a constant, the reference may +point to data which may be changed, as this code shows. + + use constant ARRAY => [ 1,2,3,4 ]; + print ARRAY->[1]; + ARRAY->[1] = " be changed"; + print ARRAY->[1]; + +Dereferencing constant references incorrectly (such as using an array +subscript on a constant hash reference, or vice versa) will be trapped at +compile time. + +Constants belong to the package they are defined in. To refer to a +constant defined in another package, specify the full package name, as +in C<Some::Package::CONSTANT>. Constants may be exported by modules, +and may also be called as either class or instance methods, that is, +as C<< Some::Package->CONSTANT >> or as C<< $obj->CONSTANT >> where +C<$obj> is an instance of C<Some::Package>. Subclasses may define +their own constants to override those in their base class. + +The use of all caps for constant names is merely a convention, +although it is recommended in order to make constants stand out +and to help avoid collisions with other barewords, keywords, and +subroutine names. Constant names must begin with a letter or +underscore. Names beginning with a double underscore are reserved. Some +poor choices for names will generate warnings, if warnings are enabled at +compile time. + +=head2 List constants + +Constants may be lists of more (or less) than one value. A constant +with no values evaluates to C<undef> in scalar context. Note that +constants with more than one value do I<not> return their last value in +scalar context as one might expect. They currently return the number +of values, but B<this may change in the future>. Do not use constants +with multiple values in scalar context. + +B<NOTE:> This implies that the expression defining the value of a +constant is evaluated in list context. This may produce surprises: + + use constant TIMESTAMP => localtime; # WRONG! + use constant TIMESTAMP => scalar localtime; # right + +The first line above defines C<TIMESTAMP> as a 9-element list, as +returned by localtime() in list context. To set it to the string +returned by localtime() in scalar context, an explicit C<scalar> +keyword is required. + +List constants are lists, not arrays. To index or slice them, they +must be placed in parentheses. + + my @workdays = WEEKDAYS[1 .. 5]; # WRONG! + my @workdays = (WEEKDAYS)[1 .. 5]; # right + +=head2 Defining multiple constants at once + +Instead of writing multiple C<use constant> statements, you may define +multiple constants in a single statement by giving, instead of the +constant name, a reference to a hash where the keys are the names of +the constants to be defined. Obviously, all constants defined using +this method must have a single value. + + use constant { + FOO => "A single value", + BAR => "This", "won't", "work!", # Error! + }; + +This is a fundamental limitation of the way hashes are constructed in +Perl. The error messages produced when this happens will often be +quite cryptic -- in the worst case there may be none at all, and +you'll only later find that something is broken. + +When defining multiple constants, you cannot use the values of other +constants defined in the same declaration. This is because the +calling package doesn't know about any constant within that group +until I<after> the C<use> statement is finished. + + use constant { + BITMASK => 0xAFBAEBA8, + NEGMASK => ~BITMASK, # Error! + }; + +=head2 Magic constants + +Magical values and references can be made into constants at compile +time, allowing for way cool stuff like this. (These error numbers +aren't totally portable, alas.) + + use constant E2BIG => ($! = 7); + print E2BIG, "\n"; # something like "Arg list too long" + print 0+E2BIG, "\n"; # "7" + +You can't produce a tied constant by giving a tied scalar as the +value. References to tied variables, however, can be used as +constants without any problems. + +=head1 TECHNICAL NOTES + +In the current implementation, scalar constants are actually +inlinable subroutines. As of version 5.004 of Perl, the appropriate +scalar constant is inserted directly in place of some subroutine +calls, thereby saving the overhead of a subroutine call. See +L<perlsub/"Constant Functions"> for details about how and when this +happens. + +In the rare case in which you need to discover at run time whether a +particular constant has been declared via this module, you may use +this function to examine the hash C<%constant::declared>. If the given +constant name does not include a package name, the current package is +used. + + sub declared ($) { + use constant 1.01; # don't omit this! + my $name = shift; + $name =~ s/^::/main::/; + my $pkg = caller; + my $full_name = $name =~ /::/ ? $name : "${pkg}::$name"; + $constant::declared{$full_name}; + } + +=head1 BUGS + +In the current version of Perl, list constants are not inlined +and some symbols may be redefined without generating a warning. + +It is not possible to have a subroutine or a keyword with the same +name as a constant in the same package. This is probably a Good Thing. + +A constant with a name in the list C<STDIN STDOUT STDERR ARGV ARGVOUT +ENV INC SIG> is not allowed anywhere but in package C<main::>, for +technical reasons. + +Unlike constants in some languages, these cannot be overridden +on the command line or via environment variables. + +You can get into trouble if you use constants in a context which +automatically quotes barewords (as is true for any subroutine call). +For example, you can't say C<$hash{CONSTANT}> because C<CONSTANT> will +be interpreted as a string. Use C<$hash{CONSTANT()}> or +C<$hash{+CONSTANT}> to prevent the bareword quoting mechanism from +kicking in. Similarly, since the C<< => >> operator quotes a bareword +immediately to its left, you have to say C<< CONSTANT() => 'value' >> +(or simply use a comma in place of the big arrow) instead of +C<< CONSTANT => 'value' >>. + +=head1 AUTHOR + +Tom Phoenix, E<lt>F<rootbeer@redcat.com>E<gt>, with help from +many other folks. + +Multiple constant declarations at once added by Casey West, +E<lt>F<casey@geeknest.com>E<gt>. + +Documentation mostly rewritten by Ilmari Karonen, +E<lt>F<perl@itz.pp.sci.fi>E<gt>. + +=head1 COPYRIGHT + +Copyright (C) 1997, 1999 Tom Phoenix + +This module is free software; you can redistribute it or modify it +under the same terms as Perl itself. + +=cut diff --git a/Master/tlpkg/installer/perllib/newgetopt.pl b/Master/tlpkg/installer/perllib/newgetopt.pl new file mode 100644 index 00000000000..95eef220fe7 --- /dev/null +++ b/Master/tlpkg/installer/perllib/newgetopt.pl @@ -0,0 +1,75 @@ +# $Id: newgetopt.pl,v 1.18 2001-09-21 15:34:59+02 jv Exp $ + +# This library is no longer being maintained, and is included for backward +# compatibility with Perl 4 programs which may require it. +# It is now just a wrapper around the Getopt::Long module. +# +# In particular, this should not be used as an example of modern Perl +# programming techniques. +# +# Suggested alternative: Getopt::Long + +{ package newgetopt; + + # Values for $order. See GNU getopt.c for details. + $REQUIRE_ORDER = 0; + $PERMUTE = 1; + $RETURN_IN_ORDER = 2; + + # Handle POSIX compliancy. + if ( defined $ENV{"POSIXLY_CORRECT"} ) { + $autoabbrev = 0; # no automatic abbrev of options (???) + $getopt_compat = 0; # disallow '+' to start options + $option_start = "(--|-)"; + $order = $REQUIRE_ORDER; + $bundling = 0; + $passthrough = 0; + } + else { + $autoabbrev = 1; # automatic abbrev of options + $getopt_compat = 1; # allow '+' to start options + $option_start = "(--|-|\\+)"; + $order = $PERMUTE; + $bundling = 0; + $passthrough = 0; + } + + # Other configurable settings. + $debug = 0; # for debugging + $ignorecase = 1; # ignore case when matching options + $argv_end = "--"; # don't change this! +} + +use Getopt::Long; + +################ Subroutines ################ + +sub NGetOpt { + + $Getopt::Long::debug = $newgetopt::debug + if defined $newgetopt::debug; + $Getopt::Long::autoabbrev = $newgetopt::autoabbrev + if defined $newgetopt::autoabbrev; + $Getopt::Long::getopt_compat = $newgetopt::getopt_compat + if defined $newgetopt::getopt_compat; + $Getopt::Long::option_start = $newgetopt::option_start + if defined $newgetopt::option_start; + $Getopt::Long::order = $newgetopt::order + if defined $newgetopt::order; + $Getopt::Long::bundling = $newgetopt::bundling + if defined $newgetopt::bundling; + $Getopt::Long::ignorecase = $newgetopt::ignorecase + if defined $newgetopt::ignorecase; + $Getopt::Long::ignorecase = $newgetopt::ignorecase + if defined $newgetopt::ignorecase; + $Getopt::Long::passthrough = $newgetopt::passthrough + if defined $newgetopt::passthrough; + + &GetOptions; +} + +################ Package return ################ + +1; + +################ End of newgetopt.pl ################ diff --git a/Master/tlpkg/installer/perllib/overload.pm b/Master/tlpkg/installer/perllib/overload.pm new file mode 100644 index 00000000000..15b7e775e74 --- /dev/null +++ b/Master/tlpkg/installer/perllib/overload.pm @@ -0,0 +1,1434 @@ +package overload; + +our $VERSION = '1.04'; + +$overload::hint_bits = 0x20000; # HINT_LOCALIZE_HH + +sub nil {} + +sub OVERLOAD { + $package = shift; + my %arg = @_; + my ($sub, $fb); + $ {$package . "::OVERLOAD"}{dummy}++; # Register with magic by touching. + *{$package . "::()"} = \&nil; # Make it findable via fetchmethod. + for (keys %arg) { + if ($_ eq 'fallback') { + $fb = $arg{$_}; + } else { + $sub = $arg{$_}; + if (not ref $sub and $sub !~ /::/) { + $ {$package . "::(" . $_} = $sub; + $sub = \&nil; + } + #print STDERR "Setting `$ {'package'}::\cO$_' to \\&`$sub'.\n"; + *{$package . "::(" . $_} = \&{ $sub }; + } + } + ${$package . "::()"} = $fb; # Make it findable too (fallback only). +} + +sub import { + $package = (caller())[0]; + # *{$package . "::OVERLOAD"} = \&OVERLOAD; + shift; + $package->overload::OVERLOAD(@_); +} + +sub unimport { + $package = (caller())[0]; + ${$package . "::OVERLOAD"}{dummy}++; # Upgrade the table + shift; + for (@_) { + if ($_ eq 'fallback') { + undef $ {$package . "::()"}; + } else { + delete $ {$package . "::"}{"(" . $_}; + } + } +} + +sub Overloaded { + my $package = shift; + $package = ref $package if ref $package; + $package->can('()'); +} + +sub ov_method { + my $globref = shift; + return undef unless $globref; + my $sub = \&{*$globref}; + return $sub if $sub ne \&nil; + return shift->can($ {*$globref}); +} + +sub OverloadedStringify { + my $package = shift; + $package = ref $package if ref $package; + #$package->can('(""') + ov_method mycan($package, '(""'), $package + or ov_method mycan($package, '(0+'), $package + or ov_method mycan($package, '(bool'), $package + or ov_method mycan($package, '(nomethod'), $package; +} + +sub Method { + my $package = shift; + $package = ref $package if ref $package; + #my $meth = $package->can('(' . shift); + ov_method mycan($package, '(' . shift), $package; + #return $meth if $meth ne \&nil; + #return $ {*{$meth}}; +} + +sub AddrRef { + my $package = ref $_[0]; + return "$_[0]" unless $package; + + require Scalar::Util; + my $class = Scalar::Util::blessed($_[0]); + my $class_prefix = defined($class) ? "$class=" : ""; + my $type = Scalar::Util::reftype($_[0]); + my $addr = Scalar::Util::refaddr($_[0]); + return sprintf("$class_prefix$type(0x%x)", $addr); +} + +*StrVal = *AddrRef; + +sub mycan { # Real can would leave stubs. + my ($package, $meth) = @_; + return \*{$package . "::$meth"} if defined &{$package . "::$meth"}; + my $p; + foreach $p (@{$package . "::ISA"}) { + my $out = mycan($p, $meth); + return $out if $out; + } + return undef; +} + +%constants = ( + 'integer' => 0x1000, # HINT_NEW_INTEGER + 'float' => 0x2000, # HINT_NEW_FLOAT + 'binary' => 0x4000, # HINT_NEW_BINARY + 'q' => 0x8000, # HINT_NEW_STRING + 'qr' => 0x10000, # HINT_NEW_RE + ); + +%ops = ( with_assign => "+ - * / % ** << >> x .", + assign => "+= -= *= /= %= **= <<= >>= x= .=", + num_comparison => "< <= > >= == !=", + '3way_comparison'=> "<=> cmp", + str_comparison => "lt le gt ge eq ne", + binary => "& | ^", + unary => "neg ! ~", + mutators => '++ --', + func => "atan2 cos sin exp abs log sqrt int", + conversion => 'bool "" 0+', + iterators => '<>', + dereferencing => '${} @{} %{} &{} *{}', + special => 'nomethod fallback ='); + +use warnings::register; +sub constant { + # Arguments: what, sub + while (@_) { + if (@_ == 1) { + warnings::warnif ("Odd number of arguments for overload::constant"); + last; + } + elsif (!exists $constants {$_ [0]}) { + warnings::warnif ("`$_[0]' is not an overloadable type"); + } + elsif (!ref $_ [1] || "$_[1]" !~ /CODE\(0x[\da-f]+\)$/) { + # Can't use C<ref $_[1] eq "CODE"> above as code references can be + # blessed, and C<ref> would return the package the ref is blessed into. + if (warnings::enabled) { + $_ [1] = "undef" unless defined $_ [1]; + warnings::warn ("`$_[1]' is not a code reference"); + } + } + else { + $^H{$_[0]} = $_[1]; + $^H |= $constants{$_[0]} | $overload::hint_bits; + } + shift, shift; + } +} + +sub remove_constant { + # Arguments: what, sub + while (@_) { + delete $^H{$_[0]}; + $^H &= ~ $constants{$_[0]}; + shift, shift; + } +} + +1; + +__END__ + +=head1 NAME + +overload - Package for overloading Perl operations + +=head1 SYNOPSIS + + package SomeThing; + + use overload + '+' => \&myadd, + '-' => \&mysub; + # etc + ... + + package main; + $a = new SomeThing 57; + $b=5+$a; + ... + if (overload::Overloaded $b) {...} + ... + $strval = overload::StrVal $b; + +=head1 DESCRIPTION + +=head2 Declaration of overloaded functions + +The compilation directive + + package Number; + use overload + "+" => \&add, + "*=" => "muas"; + +declares function Number::add() for addition, and method muas() in +the "class" C<Number> (or one of its base classes) +for the assignment form C<*=> of multiplication. + +Arguments of this directive come in (key, value) pairs. Legal values +are values legal inside a C<&{ ... }> call, so the name of a +subroutine, a reference to a subroutine, or an anonymous subroutine +will all work. Note that values specified as strings are +interpreted as methods, not subroutines. Legal keys are listed below. + +The subroutine C<add> will be called to execute C<$a+$b> if $a +is a reference to an object blessed into the package C<Number>, or if $a is +not an object from a package with defined mathemagic addition, but $b is a +reference to a C<Number>. It can also be called in other situations, like +C<$a+=7>, or C<$a++>. See L<MAGIC AUTOGENERATION>. (Mathemagical +methods refer to methods triggered by an overloaded mathematical +operator.) + +Since overloading respects inheritance via the @ISA hierarchy, the +above declaration would also trigger overloading of C<+> and C<*=> in +all the packages which inherit from C<Number>. + +=head2 Calling Conventions for Binary Operations + +The functions specified in the C<use overload ...> directive are called +with three (in one particular case with four, see L<Last Resort>) +arguments. If the corresponding operation is binary, then the first +two arguments are the two arguments of the operation. However, due to +general object calling conventions, the first argument should always be +an object in the package, so in the situation of C<7+$a>, the +order of the arguments is interchanged. It probably does not matter +when implementing the addition method, but whether the arguments +are reversed is vital to the subtraction method. The method can +query this information by examining the third argument, which can take +three different values: + +=over 7 + +=item FALSE + +the order of arguments is as in the current operation. + +=item TRUE + +the arguments are reversed. + +=item C<undef> + +the current operation is an assignment variant (as in +C<$a+=7>), but the usual function is called instead. This additional +information can be used to generate some optimizations. Compare +L<Calling Conventions for Mutators>. + +=back + +=head2 Calling Conventions for Unary Operations + +Unary operation are considered binary operations with the second +argument being C<undef>. Thus the functions that overloads C<{"++"}> +is called with arguments C<($a,undef,'')> when $a++ is executed. + +=head2 Calling Conventions for Mutators + +Two types of mutators have different calling conventions: + +=over + +=item C<++> and C<--> + +The routines which implement these operators are expected to actually +I<mutate> their arguments. So, assuming that $obj is a reference to a +number, + + sub incr { my $n = $ {$_[0]}; ++$n; $_[0] = bless \$n} + +is an appropriate implementation of overloaded C<++>. Note that + + sub incr { ++$ {$_[0]} ; shift } + +is OK if used with preincrement and with postincrement. (In the case +of postincrement a copying will be performed, see L<Copy Constructor>.) + +=item C<x=> and other assignment versions + +There is nothing special about these methods. They may change the +value of their arguments, and may leave it as is. The result is going +to be assigned to the value in the left-hand-side if different from +this value. + +This allows for the same method to be used as overloaded C<+=> and +C<+>. Note that this is I<allowed>, but not recommended, since by the +semantic of L<"Fallback"> Perl will call the method for C<+> anyway, +if C<+=> is not overloaded. + +=back + +B<Warning.> Due to the presence of assignment versions of operations, +routines which may be called in assignment context may create +self-referential structures. Currently Perl will not free self-referential +structures until cycles are C<explicitly> broken. You may get problems +when traversing your structures too. + +Say, + + use overload '+' => sub { bless [ \$_[0], \$_[1] ] }; + +is asking for trouble, since for code C<$obj += $foo> the subroutine +is called as C<$obj = add($obj, $foo, undef)>, or C<$obj = [\$obj, +\$foo]>. If using such a subroutine is an important optimization, one +can overload C<+=> explicitly by a non-"optimized" version, or switch +to non-optimized version if C<not defined $_[2]> (see +L<Calling Conventions for Binary Operations>). + +Even if no I<explicit> assignment-variants of operators are present in +the script, they may be generated by the optimizer. Say, C<",$obj,"> or +C<',' . $obj . ','> may be both optimized to + + my $tmp = ',' . $obj; $tmp .= ','; + +=head2 Overloadable Operations + +The following symbols can be specified in C<use overload> directive: + +=over 5 + +=item * I<Arithmetic operations> + + "+", "+=", "-", "-=", "*", "*=", "/", "/=", "%", "%=", + "**", "**=", "<<", "<<=", ">>", ">>=", "x", "x=", ".", ".=", + +For these operations a substituted non-assignment variant can be called if +the assignment variant is not available. Methods for operations C<+>, +C<->, C<+=>, and C<-=> can be called to automatically generate +increment and decrement methods. The operation C<-> can be used to +autogenerate missing methods for unary minus or C<abs>. + +See L<"MAGIC AUTOGENERATION">, L<"Calling Conventions for Mutators"> and +L<"Calling Conventions for Binary Operations">) for details of these +substitutions. + +=item * I<Comparison operations> + + "<", "<=", ">", ">=", "==", "!=", "<=>", + "lt", "le", "gt", "ge", "eq", "ne", "cmp", + +If the corresponding "spaceship" variant is available, it can be +used to substitute for the missing operation. During C<sort>ing +arrays, C<cmp> is used to compare values subject to C<use overload>. + +=item * I<Bit operations> + + "&", "^", "|", "neg", "!", "~", + +C<neg> stands for unary minus. If the method for C<neg> is not +specified, it can be autogenerated using the method for +subtraction. If the method for C<!> is not specified, it can be +autogenerated using the methods for C<bool>, or C<"">, or C<0+>. + +=item * I<Increment and decrement> + + "++", "--", + +If undefined, addition and subtraction methods can be +used instead. These operations are called both in prefix and +postfix form. + +=item * I<Transcendental functions> + + "atan2", "cos", "sin", "exp", "abs", "log", "sqrt", "int" + +If C<abs> is unavailable, it can be autogenerated using methods +for "E<lt>" or "E<lt>=E<gt>" combined with either unary minus or subtraction. + +Note that traditionally the Perl function L<int> rounds to 0, thus for +floating-point-like types one should follow the same semantic. If +C<int> is unavailable, it can be autogenerated using the overloading of +C<0+>. + +=item * I<Boolean, string and numeric conversion> + + 'bool', '""', '0+', + +If one or two of these operations are not overloaded, the remaining ones can +be used instead. C<bool> is used in the flow control operators +(like C<while>) and for the ternary C<?:> operation. These functions can +return any arbitrary Perl value. If the corresponding operation for this value +is overloaded too, that operation will be called again with this value. + +As a special case if the overload returns the object itself then it will +be used directly. An overloaded conversion returning the object is +probably a bug, because you're likely to get something that looks like +C<YourPackage=HASH(0x8172b34)>. + +=item * I<Iteration> + + "<>" + +If not overloaded, the argument will be converted to a filehandle or +glob (which may require a stringification). The same overloading +happens both for the I<read-filehandle> syntax C<E<lt>$varE<gt>> and +I<globbing> syntax C<E<lt>${var}E<gt>>. + +B<BUGS> Even in list context, the iterator is currently called only +once and with scalar context. + +=item * I<Dereferencing> + + '${}', '@{}', '%{}', '&{}', '*{}'. + +If not overloaded, the argument will be dereferenced I<as is>, thus +should be of correct type. These functions should return a reference +of correct type, or another object with overloaded dereferencing. + +As a special case if the overload returns the object itself then it +will be used directly (provided it is the correct type). + +The dereference operators must be specified explicitly they will not be passed to +"nomethod". + +=item * I<Special> + + "nomethod", "fallback", "=", + +see L<SPECIAL SYMBOLS FOR C<use overload>>. + +=back + +See L<"Fallback"> for an explanation of when a missing method can be +autogenerated. + +A computer-readable form of the above table is available in the hash +%overload::ops, with values being space-separated lists of names: + + with_assign => '+ - * / % ** << >> x .', + assign => '+= -= *= /= %= **= <<= >>= x= .=', + num_comparison => '< <= > >= == !=', + '3way_comparison'=> '<=> cmp', + str_comparison => 'lt le gt ge eq ne', + binary => '& | ^', + unary => 'neg ! ~', + mutators => '++ --', + func => 'atan2 cos sin exp abs log sqrt', + conversion => 'bool "" 0+', + iterators => '<>', + dereferencing => '${} @{} %{} &{} *{}', + special => 'nomethod fallback =' + +=head2 Inheritance and overloading + +Inheritance interacts with overloading in two ways. + +=over + +=item Strings as values of C<use overload> directive + +If C<value> in + + use overload key => value; + +is a string, it is interpreted as a method name. + +=item Overloading of an operation is inherited by derived classes + +Any class derived from an overloaded class is also overloaded. The +set of overloaded methods is the union of overloaded methods of all +the ancestors. If some method is overloaded in several ancestor, then +which description will be used is decided by the usual inheritance +rules: + +If C<A> inherits from C<B> and C<C> (in this order), C<B> overloads +C<+> with C<\&D::plus_sub>, and C<C> overloads C<+> by C<"plus_meth">, +then the subroutine C<D::plus_sub> will be called to implement +operation C<+> for an object in package C<A>. + +=back + +Note that since the value of the C<fallback> key is not a subroutine, +its inheritance is not governed by the above rules. In the current +implementation, the value of C<fallback> in the first overloaded +ancestor is used, but this is accidental and subject to change. + +=head1 SPECIAL SYMBOLS FOR C<use overload> + +Three keys are recognized by Perl that are not covered by the above +description. + +=head2 Last Resort + +C<"nomethod"> should be followed by a reference to a function of four +parameters. If defined, it is called when the overloading mechanism +cannot find a method for some operation. The first three arguments of +this function coincide with the arguments for the corresponding method if +it were found, the fourth argument is the symbol +corresponding to the missing method. If several methods are tried, +the last one is used. Say, C<1-$a> can be equivalent to + + &nomethodMethod($a,1,1,"-") + +if the pair C<"nomethod" =E<gt> "nomethodMethod"> was specified in the +C<use overload> directive. + +The C<"nomethod"> mechanism is I<not> used for the dereference operators +( ${} @{} %{} &{} *{} ). + + +If some operation cannot be resolved, and there is no function +assigned to C<"nomethod">, then an exception will be raised via die()-- +unless C<"fallback"> was specified as a key in C<use overload> directive. + + +=head2 Fallback + +The key C<"fallback"> governs what to do if a method for a particular +operation is not found. Three different cases are possible depending on +the value of C<"fallback">: + +=over 16 + +=item * C<undef> + +Perl tries to use a +substituted method (see L<MAGIC AUTOGENERATION>). If this fails, it +then tries to calls C<"nomethod"> value; if missing, an exception +will be raised. + +=item * TRUE + +The same as for the C<undef> value, but no exception is raised. Instead, +it silently reverts to what it would have done were there no C<use overload> +present. + +=item * defined, but FALSE + +No autogeneration is tried. Perl tries to call +C<"nomethod"> value, and if this is missing, raises an exception. + +=back + +B<Note.> C<"fallback"> inheritance via @ISA is not carved in stone +yet, see L<"Inheritance and overloading">. + +=head2 Copy Constructor + +The value for C<"="> is a reference to a function with three +arguments, i.e., it looks like the other values in C<use +overload>. However, it does not overload the Perl assignment +operator. This would go against Camel hair. + +This operation is called in the situations when a mutator is applied +to a reference that shares its object with some other reference, such +as + + $a=$b; + ++$a; + +To make this change $a and not change $b, a copy of C<$$a> is made, +and $a is assigned a reference to this new object. This operation is +done during execution of the C<++$a>, and not during the assignment, +(so before the increment C<$$a> coincides with C<$$b>). This is only +done if C<++> is expressed via a method for C<'++'> or C<'+='> (or +C<nomethod>). Note that if this operation is expressed via C<'+'> +a nonmutator, i.e., as in + + $a=$b; + $a=$a+1; + +then C<$a> does not reference a new copy of C<$$a>, since $$a does not +appear as lvalue when the above code is executed. + +If the copy constructor is required during the execution of some mutator, +but a method for C<'='> was not specified, it can be autogenerated as a +string copy if the object is a plain scalar. + +=over 5 + +=item B<Example> + +The actually executed code for + + $a=$b; + Something else which does not modify $a or $b.... + ++$a; + +may be + + $a=$b; + Something else which does not modify $a or $b.... + $a = $a->clone(undef,""); + $a->incr(undef,""); + +if $b was mathemagical, and C<'++'> was overloaded with C<\&incr>, +C<'='> was overloaded with C<\&clone>. + +=back + +Same behaviour is triggered by C<$b = $a++>, which is consider a synonym for +C<$b = $a; ++$a>. + +=head1 MAGIC AUTOGENERATION + +If a method for an operation is not found, and the value for C<"fallback"> is +TRUE or undefined, Perl tries to autogenerate a substitute method for +the missing operation based on the defined operations. Autogenerated method +substitutions are possible for the following operations: + +=over 16 + +=item I<Assignment forms of arithmetic operations> + +C<$a+=$b> can use the method for C<"+"> if the method for C<"+="> +is not defined. + +=item I<Conversion operations> + +String, numeric, and boolean conversion are calculated in terms of one +another if not all of them are defined. + +=item I<Increment and decrement> + +The C<++$a> operation can be expressed in terms of C<$a+=1> or C<$a+1>, +and C<$a--> in terms of C<$a-=1> and C<$a-1>. + +=item C<abs($a)> + +can be expressed in terms of C<$aE<lt>0> and C<-$a> (or C<0-$a>). + +=item I<Unary minus> + +can be expressed in terms of subtraction. + +=item I<Negation> + +C<!> and C<not> can be expressed in terms of boolean conversion, or +string or numerical conversion. + +=item I<Concatenation> + +can be expressed in terms of string conversion. + +=item I<Comparison operations> + +can be expressed in terms of its "spaceship" counterpart: either +C<E<lt>=E<gt>> or C<cmp>: + + <, >, <=, >=, ==, != in terms of <=> + lt, gt, le, ge, eq, ne in terms of cmp + +=item I<Iterator> + + <> in terms of builtin operations + +=item I<Dereferencing> + + ${} @{} %{} &{} *{} in terms of builtin operations + +=item I<Copy operator> + +can be expressed in terms of an assignment to the dereferenced value, if this +value is a scalar and not a reference. + +=back + +=head1 Losing overloading + +The restriction for the comparison operation is that even if, for example, +`C<cmp>' should return a blessed reference, the autogenerated `C<lt>' +function will produce only a standard logical value based on the +numerical value of the result of `C<cmp>'. In particular, a working +numeric conversion is needed in this case (possibly expressed in terms of +other conversions). + +Similarly, C<.=> and C<x=> operators lose their mathemagical properties +if the string conversion substitution is applied. + +When you chop() a mathemagical object it is promoted to a string and its +mathemagical properties are lost. The same can happen with other +operations as well. + +=head1 Run-time Overloading + +Since all C<use> directives are executed at compile-time, the only way to +change overloading during run-time is to + + eval 'use overload "+" => \&addmethod'; + +You can also use + + eval 'no overload "+", "--", "<="'; + +though the use of these constructs during run-time is questionable. + +=head1 Public functions + +Package C<overload.pm> provides the following public functions: + +=over 5 + +=item overload::StrVal(arg) + +Gives string value of C<arg> as in absence of stringify overloading. If you +are using this to get the address of a reference (useful for checking if two +references point to the same thing) then you may be better off using +C<Scalar::Util::refaddr()>, which is faster. + +=item overload::Overloaded(arg) + +Returns true if C<arg> is subject to overloading of some operations. + +=item overload::Method(obj,op) + +Returns C<undef> or a reference to the method that implements C<op>. + +=back + +=head1 Overloading constants + +For some applications, the Perl parser mangles constants too much. +It is possible to hook into this process via C<overload::constant()> +and C<overload::remove_constant()> functions. + +These functions take a hash as an argument. The recognized keys of this hash +are: + +=over 8 + +=item integer + +to overload integer constants, + +=item float + +to overload floating point constants, + +=item binary + +to overload octal and hexadecimal constants, + +=item q + +to overload C<q>-quoted strings, constant pieces of C<qq>- and C<qx>-quoted +strings and here-documents, + +=item qr + +to overload constant pieces of regular expressions. + +=back + +The corresponding values are references to functions which take three arguments: +the first one is the I<initial> string form of the constant, the second one +is how Perl interprets this constant, the third one is how the constant is used. +Note that the initial string form does not +contain string delimiters, and has backslashes in backslash-delimiter +combinations stripped (thus the value of delimiter is not relevant for +processing of this string). The return value of this function is how this +constant is going to be interpreted by Perl. The third argument is undefined +unless for overloaded C<q>- and C<qr>- constants, it is C<q> in single-quote +context (comes from strings, regular expressions, and single-quote HERE +documents), it is C<tr> for arguments of C<tr>/C<y> operators, +it is C<s> for right-hand side of C<s>-operator, and it is C<qq> otherwise. + +Since an expression C<"ab$cd,,"> is just a shortcut for C<'ab' . $cd . ',,'>, +it is expected that overloaded constant strings are equipped with reasonable +overloaded catenation operator, otherwise absurd results will result. +Similarly, negative numbers are considered as negations of positive constants. + +Note that it is probably meaningless to call the functions overload::constant() +and overload::remove_constant() from anywhere but import() and unimport() methods. +From these methods they may be called as + + sub import { + shift; + return unless @_; + die "unknown import: @_" unless @_ == 1 and $_[0] eq ':constant'; + overload::constant integer => sub {Math::BigInt->new(shift)}; + } + +B<BUGS> Currently overloaded-ness of constants does not propagate +into C<eval '...'>. + +=head1 IMPLEMENTATION + +What follows is subject to change RSN. + +The table of methods for all operations is cached in magic for the +symbol table hash for the package. The cache is invalidated during +processing of C<use overload>, C<no overload>, new function +definitions, and changes in @ISA. However, this invalidation remains +unprocessed until the next C<bless>ing into the package. Hence if you +want to change overloading structure dynamically, you'll need an +additional (fake) C<bless>ing to update the table. + +(Every SVish thing has a magic queue, and magic is an entry in that +queue. This is how a single variable may participate in multiple +forms of magic simultaneously. For instance, environment variables +regularly have two forms at once: their %ENV magic and their taint +magic. However, the magic which implements overloading is applied to +the stashes, which are rarely used directly, thus should not slow down +Perl.) + +If an object belongs to a package using overload, it carries a special +flag. Thus the only speed penalty during arithmetic operations without +overloading is the checking of this flag. + +In fact, if C<use overload> is not present, there is almost no overhead +for overloadable operations, so most programs should not suffer +measurable performance penalties. A considerable effort was made to +minimize the overhead when overload is used in some package, but the +arguments in question do not belong to packages using overload. When +in doubt, test your speed with C<use overload> and without it. So far +there have been no reports of substantial speed degradation if Perl is +compiled with optimization turned on. + +There is no size penalty for data if overload is not used. The only +size penalty if overload is used in some package is that I<all> the +packages acquire a magic during the next C<bless>ing into the +package. This magic is three-words-long for packages without +overloading, and carries the cache table if the package is overloaded. + +Copying (C<$a=$b>) is shallow; however, a one-level-deep copying is +carried out before any operation that can imply an assignment to the +object $a (or $b) refers to, like C<$a++>. You can override this +behavior by defining your own copy constructor (see L<"Copy Constructor">). + +It is expected that arguments to methods that are not explicitly supposed +to be changed are constant (but this is not enforced). + +=head1 Metaphor clash + +One may wonder why the semantic of overloaded C<=> is so counter intuitive. +If it I<looks> counter intuitive to you, you are subject to a metaphor +clash. + +Here is a Perl object metaphor: + +I< object is a reference to blessed data> + +and an arithmetic metaphor: + +I< object is a thing by itself>. + +The I<main> problem of overloading C<=> is the fact that these metaphors +imply different actions on the assignment C<$a = $b> if $a and $b are +objects. Perl-think implies that $a becomes a reference to whatever +$b was referencing. Arithmetic-think implies that the value of "object" +$a is changed to become the value of the object $b, preserving the fact +that $a and $b are separate entities. + +The difference is not relevant in the absence of mutators. After +a Perl-way assignment an operation which mutates the data referenced by $a +would change the data referenced by $b too. Effectively, after +C<$a = $b> values of $a and $b become I<indistinguishable>. + +On the other hand, anyone who has used algebraic notation knows the +expressive power of the arithmetic metaphor. Overloading works hard +to enable this metaphor while preserving the Perlian way as far as +possible. Since it is not possible to freely mix two contradicting +metaphors, overloading allows the arithmetic way to write things I<as +far as all the mutators are called via overloaded access only>. The +way it is done is described in L<Copy Constructor>. + +If some mutator methods are directly applied to the overloaded values, +one may need to I<explicitly unlink> other values which references the +same value: + + $a = new Data 23; + ... + $b = $a; # $b is "linked" to $a + ... + $a = $a->clone; # Unlink $b from $a + $a->increment_by(4); + +Note that overloaded access makes this transparent: + + $a = new Data 23; + $b = $a; # $b is "linked" to $a + $a += 4; # would unlink $b automagically + +However, it would not make + + $a = new Data 23; + $a = 4; # Now $a is a plain 4, not 'Data' + +preserve "objectness" of $a. But Perl I<has> a way to make assignments +to an object do whatever you want. It is just not the overload, but +tie()ing interface (see L<perlfunc/tie>). Adding a FETCH() method +which returns the object itself, and STORE() method which changes the +value of the object, one can reproduce the arithmetic metaphor in its +completeness, at least for variables which were tie()d from the start. + +(Note that a workaround for a bug may be needed, see L<"BUGS">.) + +=head1 Cookbook + +Please add examples to what follows! + +=head2 Two-face scalars + +Put this in F<two_face.pm> in your Perl library directory: + + package two_face; # Scalars with separate string and + # numeric values. + sub new { my $p = shift; bless [@_], $p } + use overload '""' => \&str, '0+' => \&num, fallback => 1; + sub num {shift->[1]} + sub str {shift->[0]} + +Use it as follows: + + require two_face; + my $seven = new two_face ("vii", 7); + printf "seven=$seven, seven=%d, eight=%d\n", $seven, $seven+1; + print "seven contains `i'\n" if $seven =~ /i/; + +(The second line creates a scalar which has both a string value, and a +numeric value.) This prints: + + seven=vii, seven=7, eight=8 + seven contains `i' + +=head2 Two-face references + +Suppose you want to create an object which is accessible as both an +array reference and a hash reference, similar to the +L<pseudo-hash|perlref/"Pseudo-hashes: Using an array as a hash"> +builtin Perl type. Let's make it better than a pseudo-hash by +allowing index 0 to be treated as a normal element. + + package two_refs; + use overload '%{}' => \&gethash, '@{}' => sub { $ {shift()} }; + sub new { + my $p = shift; + bless \ [@_], $p; + } + sub gethash { + my %h; + my $self = shift; + tie %h, ref $self, $self; + \%h; + } + + sub TIEHASH { my $p = shift; bless \ shift, $p } + my %fields; + my $i = 0; + $fields{$_} = $i++ foreach qw{zero one two three}; + sub STORE { + my $self = ${shift()}; + my $key = $fields{shift()}; + defined $key or die "Out of band access"; + $$self->[$key] = shift; + } + sub FETCH { + my $self = ${shift()}; + my $key = $fields{shift()}; + defined $key or die "Out of band access"; + $$self->[$key]; + } + +Now one can access an object using both the array and hash syntax: + + my $bar = new two_refs 3,4,5,6; + $bar->[2] = 11; + $bar->{two} == 11 or die 'bad hash fetch'; + +Note several important features of this example. First of all, the +I<actual> type of $bar is a scalar reference, and we do not overload +the scalar dereference. Thus we can get the I<actual> non-overloaded +contents of $bar by just using C<$$bar> (what we do in functions which +overload dereference). Similarly, the object returned by the +TIEHASH() method is a scalar reference. + +Second, we create a new tied hash each time the hash syntax is used. +This allows us not to worry about a possibility of a reference loop, +which would lead to a memory leak. + +Both these problems can be cured. Say, if we want to overload hash +dereference on a reference to an object which is I<implemented> as a +hash itself, the only problem one has to circumvent is how to access +this I<actual> hash (as opposed to the I<virtual> hash exhibited by the +overloaded dereference operator). Here is one possible fetching routine: + + sub access_hash { + my ($self, $key) = (shift, shift); + my $class = ref $self; + bless $self, 'overload::dummy'; # Disable overloading of %{} + my $out = $self->{$key}; + bless $self, $class; # Restore overloading + $out; + } + +To remove creation of the tied hash on each access, one may an extra +level of indirection which allows a non-circular structure of references: + + package two_refs1; + use overload '%{}' => sub { ${shift()}->[1] }, + '@{}' => sub { ${shift()}->[0] }; + sub new { + my $p = shift; + my $a = [@_]; + my %h; + tie %h, $p, $a; + bless \ [$a, \%h], $p; + } + sub gethash { + my %h; + my $self = shift; + tie %h, ref $self, $self; + \%h; + } + + sub TIEHASH { my $p = shift; bless \ shift, $p } + my %fields; + my $i = 0; + $fields{$_} = $i++ foreach qw{zero one two three}; + sub STORE { + my $a = ${shift()}; + my $key = $fields{shift()}; + defined $key or die "Out of band access"; + $a->[$key] = shift; + } + sub FETCH { + my $a = ${shift()}; + my $key = $fields{shift()}; + defined $key or die "Out of band access"; + $a->[$key]; + } + +Now if $baz is overloaded like this, then C<$baz> is a reference to a +reference to the intermediate array, which keeps a reference to an +actual array, and the access hash. The tie()ing object for the access +hash is a reference to a reference to the actual array, so + +=over + +=item * + +There are no loops of references. + +=item * + +Both "objects" which are blessed into the class C<two_refs1> are +references to a reference to an array, thus references to a I<scalar>. +Thus the accessor expression C<$$foo-E<gt>[$ind]> involves no +overloaded operations. + +=back + +=head2 Symbolic calculator + +Put this in F<symbolic.pm> in your Perl library directory: + + package symbolic; # Primitive symbolic calculator + use overload nomethod => \&wrap; + + sub new { shift; bless ['n', @_] } + sub wrap { + my ($obj, $other, $inv, $meth) = @_; + ($obj, $other) = ($other, $obj) if $inv; + bless [$meth, $obj, $other]; + } + +This module is very unusual as overloaded modules go: it does not +provide any usual overloaded operators, instead it provides the L<Last +Resort> operator C<nomethod>. In this example the corresponding +subroutine returns an object which encapsulates operations done over +the objects: C<new symbolic 3> contains C<['n', 3]>, C<2 + new +symbolic 3> contains C<['+', 2, ['n', 3]]>. + +Here is an example of the script which "calculates" the side of +circumscribed octagon using the above package: + + require symbolic; + my $iter = 1; # 2**($iter+2) = 8 + my $side = new symbolic 1; + my $cnt = $iter; + + while ($cnt--) { + $side = (sqrt(1 + $side**2) - 1)/$side; + } + print "OK\n"; + +The value of $side is + + ['/', ['-', ['sqrt', ['+', 1, ['**', ['n', 1], 2]], + undef], 1], ['n', 1]] + +Note that while we obtained this value using a nice little script, +there is no simple way to I<use> this value. In fact this value may +be inspected in debugger (see L<perldebug>), but ony if +C<bareStringify> B<O>ption is set, and not via C<p> command. + +If one attempts to print this value, then the overloaded operator +C<""> will be called, which will call C<nomethod> operator. The +result of this operator will be stringified again, but this result is +again of type C<symbolic>, which will lead to an infinite loop. + +Add a pretty-printer method to the module F<symbolic.pm>: + + sub pretty { + my ($meth, $a, $b) = @{+shift}; + $a = 'u' unless defined $a; + $b = 'u' unless defined $b; + $a = $a->pretty if ref $a; + $b = $b->pretty if ref $b; + "[$meth $a $b]"; + } + +Now one can finish the script by + + print "side = ", $side->pretty, "\n"; + +The method C<pretty> is doing object-to-string conversion, so it +is natural to overload the operator C<""> using this method. However, +inside such a method it is not necessary to pretty-print the +I<components> $a and $b of an object. In the above subroutine +C<"[$meth $a $b]"> is a catenation of some strings and components $a +and $b. If these components use overloading, the catenation operator +will look for an overloaded operator C<.>; if not present, it will +look for an overloaded operator C<"">. Thus it is enough to use + + use overload nomethod => \&wrap, '""' => \&str; + sub str { + my ($meth, $a, $b) = @{+shift}; + $a = 'u' unless defined $a; + $b = 'u' unless defined $b; + "[$meth $a $b]"; + } + +Now one can change the last line of the script to + + print "side = $side\n"; + +which outputs + + side = [/ [- [sqrt [+ 1 [** [n 1 u] 2]] u] 1] [n 1 u]] + +and one can inspect the value in debugger using all the possible +methods. + +Something is still amiss: consider the loop variable $cnt of the +script. It was a number, not an object. We cannot make this value of +type C<symbolic>, since then the loop will not terminate. + +Indeed, to terminate the cycle, the $cnt should become false. +However, the operator C<bool> for checking falsity is overloaded (this +time via overloaded C<"">), and returns a long string, thus any object +of type C<symbolic> is true. To overcome this, we need a way to +compare an object to 0. In fact, it is easier to write a numeric +conversion routine. + +Here is the text of F<symbolic.pm> with such a routine added (and +slightly modified str()): + + package symbolic; # Primitive symbolic calculator + use overload + nomethod => \&wrap, '""' => \&str, '0+' => \# + + sub new { shift; bless ['n', @_] } + sub wrap { + my ($obj, $other, $inv, $meth) = @_; + ($obj, $other) = ($other, $obj) if $inv; + bless [$meth, $obj, $other]; + } + sub str { + my ($meth, $a, $b) = @{+shift}; + $a = 'u' unless defined $a; + if (defined $b) { + "[$meth $a $b]"; + } else { + "[$meth $a]"; + } + } + my %subr = ( n => sub {$_[0]}, + sqrt => sub {sqrt $_[0]}, + '-' => sub {shift() - shift()}, + '+' => sub {shift() + shift()}, + '/' => sub {shift() / shift()}, + '*' => sub {shift() * shift()}, + '**' => sub {shift() ** shift()}, + ); + sub num { + my ($meth, $a, $b) = @{+shift}; + my $subr = $subr{$meth} + or die "Do not know how to ($meth) in symbolic"; + $a = $a->num if ref $a eq __PACKAGE__; + $b = $b->num if ref $b eq __PACKAGE__; + $subr->($a,$b); + } + +All the work of numeric conversion is done in %subr and num(). Of +course, %subr is not complete, it contains only operators used in the +example below. Here is the extra-credit question: why do we need an +explicit recursion in num()? (Answer is at the end of this section.) + +Use this module like this: + + require symbolic; + my $iter = new symbolic 2; # 16-gon + my $side = new symbolic 1; + my $cnt = $iter; + + while ($cnt) { + $cnt = $cnt - 1; # Mutator `--' not implemented + $side = (sqrt(1 + $side**2) - 1)/$side; + } + printf "%s=%f\n", $side, $side; + printf "pi=%f\n", $side*(2**($iter+2)); + +It prints (without so many line breaks) + + [/ [- [sqrt [+ 1 [** [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] + [n 1]] 2]]] 1] + [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]]]=0.198912 + pi=3.182598 + +The above module is very primitive. It does not implement +mutator methods (C<++>, C<-=> and so on), does not do deep copying +(not required without mutators!), and implements only those arithmetic +operations which are used in the example. + +To implement most arithmetic operations is easy; one should just use +the tables of operations, and change the code which fills %subr to + + my %subr = ( 'n' => sub {$_[0]} ); + foreach my $op (split " ", $overload::ops{with_assign}) { + $subr{$op} = $subr{"$op="} = eval "sub {shift() $op shift()}"; + } + my @bins = qw(binary 3way_comparison num_comparison str_comparison); + foreach my $op (split " ", "@overload::ops{ @bins }") { + $subr{$op} = eval "sub {shift() $op shift()}"; + } + foreach my $op (split " ", "@overload::ops{qw(unary func)}") { + print "defining `$op'\n"; + $subr{$op} = eval "sub {$op shift()}"; + } + +Due to L<Calling Conventions for Mutators>, we do not need anything +special to make C<+=> and friends work, except filling C<+=> entry of +%subr, and defining a copy constructor (needed since Perl has no +way to know that the implementation of C<'+='> does not mutate +the argument, compare L<Copy Constructor>). + +To implement a copy constructor, add C<< '=' => \&cpy >> to C<use overload> +line, and code (this code assumes that mutators change things one level +deep only, so recursive copying is not needed): + + sub cpy { + my $self = shift; + bless [@$self], ref $self; + } + +To make C<++> and C<--> work, we need to implement actual mutators, +either directly, or in C<nomethod>. We continue to do things inside +C<nomethod>, thus add + + if ($meth eq '++' or $meth eq '--') { + @$obj = ($meth, (bless [@$obj]), 1); # Avoid circular reference + return $obj; + } + +after the first line of wrap(). This is not a most effective +implementation, one may consider + + sub inc { $_[0] = bless ['++', shift, 1]; } + +instead. + +As a final remark, note that one can fill %subr by + + my %subr = ( 'n' => sub {$_[0]} ); + foreach my $op (split " ", $overload::ops{with_assign}) { + $subr{$op} = $subr{"$op="} = eval "sub {shift() $op shift()}"; + } + my @bins = qw(binary 3way_comparison num_comparison str_comparison); + foreach my $op (split " ", "@overload::ops{ @bins }") { + $subr{$op} = eval "sub {shift() $op shift()}"; + } + foreach my $op (split " ", "@overload::ops{qw(unary func)}") { + $subr{$op} = eval "sub {$op shift()}"; + } + $subr{'++'} = $subr{'+'}; + $subr{'--'} = $subr{'-'}; + +This finishes implementation of a primitive symbolic calculator in +50 lines of Perl code. Since the numeric values of subexpressions +are not cached, the calculator is very slow. + +Here is the answer for the exercise: In the case of str(), we need no +explicit recursion since the overloaded C<.>-operator will fall back +to an existing overloaded operator C<"">. Overloaded arithmetic +operators I<do not> fall back to numeric conversion if C<fallback> is +not explicitly requested. Thus without an explicit recursion num() +would convert C<['+', $a, $b]> to C<$a + $b>, which would just rebuild +the argument of num(). + +If you wonder why defaults for conversion are different for str() and +num(), note how easy it was to write the symbolic calculator. This +simplicity is due to an appropriate choice of defaults. One extra +note: due to the explicit recursion num() is more fragile than sym(): +we need to explicitly check for the type of $a and $b. If components +$a and $b happen to be of some related type, this may lead to problems. + +=head2 I<Really> symbolic calculator + +One may wonder why we call the above calculator symbolic. The reason +is that the actual calculation of the value of expression is postponed +until the value is I<used>. + +To see it in action, add a method + + sub STORE { + my $obj = shift; + $#$obj = 1; + @$obj->[0,1] = ('=', shift); + } + +to the package C<symbolic>. After this change one can do + + my $a = new symbolic 3; + my $b = new symbolic 4; + my $c = sqrt($a**2 + $b**2); + +and the numeric value of $c becomes 5. However, after calling + + $a->STORE(12); $b->STORE(5); + +the numeric value of $c becomes 13. There is no doubt now that the module +symbolic provides a I<symbolic> calculator indeed. + +To hide the rough edges under the hood, provide a tie()d interface to the +package C<symbolic> (compare with L<Metaphor clash>). Add methods + + sub TIESCALAR { my $pack = shift; $pack->new(@_) } + sub FETCH { shift } + sub nop { } # Around a bug + +(the bug is described in L<"BUGS">). One can use this new interface as + + tie $a, 'symbolic', 3; + tie $b, 'symbolic', 4; + $a->nop; $b->nop; # Around a bug + + my $c = sqrt($a**2 + $b**2); + +Now numeric value of $c is 5. After C<$a = 12; $b = 5> the numeric value +of $c becomes 13. To insulate the user of the module add a method + + sub vars { my $p = shift; tie($_, $p), $_->nop foreach @_; } + +Now + + my ($a, $b); + symbolic->vars($a, $b); + my $c = sqrt($a**2 + $b**2); + + $a = 3; $b = 4; + printf "c5 %s=%f\n", $c, $c; + + $a = 12; $b = 5; + printf "c13 %s=%f\n", $c, $c; + +shows that the numeric value of $c follows changes to the values of $a +and $b. + +=head1 AUTHOR + +Ilya Zakharevich E<lt>F<ilya@math.mps.ohio-state.edu>E<gt>. + +=head1 DIAGNOSTICS + +When Perl is run with the B<-Do> switch or its equivalent, overloading +induces diagnostic messages. + +Using the C<m> command of Perl debugger (see L<perldebug>) one can +deduce which operations are overloaded (and which ancestor triggers +this overloading). Say, if C<eq> is overloaded, then the method C<(eq> +is shown by debugger. The method C<()> corresponds to the C<fallback> +key (in fact a presence of this method shows that this package has +overloading enabled, and it is what is used by the C<Overloaded> +function of module C<overload>). + +The module might issue the following warnings: + +=over 4 + +=item Odd number of arguments for overload::constant + +(W) The call to overload::constant contained an odd number of arguments. +The arguments should come in pairs. + +=item `%s' is not an overloadable type + +(W) You tried to overload a constant type the overload package is unaware of. + +=item `%s' is not a code reference + +(W) The second (fourth, sixth, ...) argument of overload::constant needs +to be a code reference. Either an anonymous subroutine, or a reference +to a subroutine. + +=back + +=head1 BUGS + +Because it is used for overloading, the per-package hash %OVERLOAD now +has a special meaning in Perl. The symbol table is filled with names +looking like line-noise. + +For the purpose of inheritance every overloaded package behaves as if +C<fallback> is present (possibly undefined). This may create +interesting effects if some package is not overloaded, but inherits +from two overloaded packages. + +Relation between overloading and tie()ing is broken. Overloading is +triggered or not basing on the I<previous> class of tie()d value. + +This happens because the presence of overloading is checked too early, +before any tie()d access is attempted. If the FETCH()ed class of the +tie()d value does not change, a simple workaround is to access the value +immediately after tie()ing, so that after this call the I<previous> class +coincides with the current one. + +B<Needed:> a way to fix this without a speed penalty. + +Barewords are not covered by overloaded string constants. + +This document is confusing. There are grammos and misleading language +used in places. It would seem a total rewrite is needed. + +=cut + diff --git a/Master/tlpkg/installer/perllib/strict.pm b/Master/tlpkg/installer/perllib/strict.pm new file mode 100644 index 00000000000..d14391add44 --- /dev/null +++ b/Master/tlpkg/installer/perllib/strict.pm @@ -0,0 +1,136 @@ +package strict; + +$strict::VERSION = "1.03"; + +my %bitmask = ( +refs => 0x00000002, +subs => 0x00000200, +vars => 0x00000400 +); + +sub bits { + my $bits = 0; + my @wrong; + foreach my $s (@_) { + push @wrong, $s unless exists $bitmask{$s}; + $bits |= $bitmask{$s} || 0; + } + if (@wrong) { + require Carp; + Carp::croak("Unknown 'strict' tag(s) '@wrong'"); + } + $bits; +} + +my $default_bits = bits(qw(refs subs vars)); + +sub import { + shift; + $^H |= @_ ? bits(@_) : $default_bits; +} + +sub unimport { + shift; + $^H &= ~ (@_ ? bits(@_) : $default_bits); +} + +1; +__END__ + +=head1 NAME + +strict - Perl pragma to restrict unsafe constructs + +=head1 SYNOPSIS + + use strict; + + use strict "vars"; + use strict "refs"; + use strict "subs"; + + use strict; + no strict "vars"; + +=head1 DESCRIPTION + +If no import list is supplied, all possible restrictions are assumed. +(This is the safest mode to operate in, but is sometimes too strict for +casual programming.) Currently, there are three possible things to be +strict about: "subs", "vars", and "refs". + +=over 6 + +=item C<strict refs> + +This generates a runtime error if you +use symbolic references (see L<perlref>). + + use strict 'refs'; + $ref = \$foo; + print $$ref; # ok + $ref = "foo"; + print $$ref; # runtime error; normally ok + $file = "STDOUT"; + print $file "Hi!"; # error; note: no comma after $file + +There is one exception to this rule: + + $bar = \&{'foo'}; + &$bar; + +is allowed so that C<goto &$AUTOLOAD> would not break under stricture. + + +=item C<strict vars> + +This generates a compile-time error if you access a variable that wasn't +declared via C<our> or C<use vars>, +localized via C<my()>, or wasn't fully qualified. Because this is to avoid +variable suicide problems and subtle dynamic scoping issues, a merely +local() variable isn't good enough. See L<perlfunc/my> and +L<perlfunc/local>. + + use strict 'vars'; + $X::foo = 1; # ok, fully qualified + my $foo = 10; # ok, my() var + local $foo = 9; # blows up + + package Cinna; + our $bar; # Declares $bar in current package + $bar = 'HgS'; # ok, global declared via pragma + +The local() generated a compile-time error because you just touched a global +name without fully qualifying it. + +Because of their special use by sort(), the variables $a and $b are +exempted from this check. + +=item C<strict subs> + +This disables the poetry optimization, generating a compile-time error if +you try to use a bareword identifier that's not a subroutine, unless it +is a simple identifier (no colons) and that it appears in curly braces or +on the left hand side of the C<< => >> symbol. + + use strict 'subs'; + $SIG{PIPE} = Plumber; # blows up + $SIG{PIPE} = "Plumber"; # just fine: quoted string is always ok + $SIG{PIPE} = \&Plumber; # preferred form + +=back + +See L<perlmodlib/Pragmatic Modules>. + +=head1 HISTORY + +C<strict 'subs'>, with Perl 5.6.1, erroneously permitted to use an unquoted +compound identifier (e.g. C<Foo::Bar>) as a hash key (before C<< => >> or +inside curlies), but without forcing it always to a literal string. + +Starting with Perl 5.8.1 strict is strict about its restrictions: +if unknown restrictions are used, the strict pragma will abort with + + Unknown 'strict' tag(s) '...' + +=cut diff --git a/Master/tlpkg/installer/perllib/unicore/Canonical.pl b/Master/tlpkg/installer/perllib/unicore/Canonical.pl new file mode 100644 index 00000000000..fce1e219700 --- /dev/null +++ b/Master/tlpkg/installer/perllib/unicore/Canonical.pl @@ -0,0 +1,1042 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables from e.g. UnicodeData.txt. +# Any changes made here will be lost! + +## +## Data in this file used by ../utf8_heavy.pl +## + +## Mapping from lc(canonical name) to filename in ./lib +%utf8::Canonical = ( + + # InAegeanNumbers + aegeannumbers => 'InAegean', + + alphabetic => 'Alphabet', + + # InAlphabeticPresentationForms + alphabeticpresentationforms => 'InAlphab', + + # InAncientGreekMusicalNotation + ancientgreekmusicalnotation => 'InAncie2', + + # InAncientGreekNumbers + ancientgreeknumbers => 'InAncien', + + arabic => 'Arab', + + # InArabicPresentationFormsA + arabicpresentationformsa => 'InArabi4', + + # InArabicPresentationFormsB + arabicpresentationformsb => 'InArabi3', + + # InArabicSupplement + arabicsupplement => 'InArabi2', + + armenian => 'Armn', + + # InArrows + arrows => 'InArrows', + + # AsciiHexDigit + asciihexdigit => 'AsciiHex', + + # InBasicLatin + basiclatin => 'InBasicL', + + bengali => 'Beng', + + # BidiControl + bidicontrol => 'BidiCont', + + # InBlockElements + blockelements => 'InBlockE', + + bopomofo => 'Bopo', + + # InBopomofoExtended + bopomofoextended => 'InBopom2', + + # InBoxDrawing + boxdrawing => 'InBoxDra', + + braille => 'Brai', + + # InBraillePatterns + braillepatterns => 'InBraill', + + buginese => 'Bugi', + buhid => 'Buhd', + + # InByzantineMusicalSymbols + byzantinemusicalsymbols => 'InByzant', + + # CanadianAboriginal + canadianaboriginal => 'Canadian', + + # CasedLetter + casedletter => 'LC', + + cherokee => 'Cher', + + # InCjkCompatibility + cjkcompatibility => 'InCjkCom', + + # InCjkCompatibilityForms + cjkcompatibilityforms => 'InCjkCo2', + + # InCjkCompatibilityIdeographs + cjkcompatibilityideographs => 'InCjkCo3', + + # InCjkCompatibilityIdeographsSupplement + cjkcompatibilityideographssupplement => 'InCjkCo4', + + # InCjkRadicalsSupplement + cjkradicalssupplement => 'InCjkRad', + + # InCjkStrokes + cjkstrokes => 'InCjkStr', + + # InCjkSymbolsAndPunctuation + cjksymbolsandpunctuation => 'InCjkSym', + + # InCjkUnifiedIdeographs + cjkunifiedideographs => 'InCjkUni', + + # InCjkUnifiedIdeographsExtensionA + cjkunifiedideographsextensiona => 'InCjkUn3', + + # InCjkUnifiedIdeographsExtensionB + cjkunifiedideographsextensionb => 'InCjkUn2', + + # ClosePunctuation + closepunctuation => 'Pe', + + # InCombiningDiacriticalMarks + combiningdiacriticalmarks => 'InCombi2', + + # InCombiningDiacriticalMarksForSymbols + combiningdiacriticalmarksforsymbols => 'InCombi4', + + # InCombiningDiacriticalMarksSupplement + combiningdiacriticalmarkssupplement => 'InCombi3', + + # InCombiningHalfMarks + combininghalfmarks => 'InCombin', + + common => 'Zyyy', + + # ConnectorPunctuation + connectorpunctuation => 'Pc', + + control => 'Cc', + + # InControlPictures + controlpictures => 'InContro', + + coptic => 'Copt', + + # CurrencySymbol + currencysymbol => 'Sc', + + # InCurrencySymbols + currencysymbols => 'InCurren', + + cypriot => 'Cprt', + + # InCypriotSyllabary + cypriotsyllabary => 'InCyprio', + + cyrillic => 'Cyrl', + + # InCyrillicSupplement + cyrillicsupplement => 'InCyril2', + + dash => 'Dash2', + + # DashPunctuation + dashpunctuation => 'Pd', + + # DecimalNumber + decimalnumber => 'Nd', + + deprecated => 'Deprecat', + deseret => 'Dsrt', + devanagari => 'Deva', + diacritic => 'Diacriti', + + # InDingbats + dingbats => 'InDingba', + + # InEnclosedAlphanumerics + enclosedalphanumerics => 'InEnclos', + + # InEnclosedCjkLettersAndMonths + enclosedcjklettersandmonths => 'InEnclo2', + + # EnclosingMark + enclosingmark => 'Me', + + ethiopic => 'Ethi', + + # InEthiopicExtended + ethiopicextended => 'InEthio2', + + # InEthiopicSupplement + ethiopicsupplement => 'InEthio3', + + extender => 'Extender', + + # FinalPunctuation + finalpunctuation => 'Pf', + + format => 'Cf', + + # InGeneralPunctuation + generalpunctuation => 'InGenera', + + # InGeometricShapes + geometricshapes => 'InGeomet', + + georgian => 'Geor', + + # InGeorgianSupplement + georgiansupplement => 'InGeorg2', + + glagolitic => 'Glag', + gothic => 'Goth', + + # GraphemeLink + graphemelink => 'Grapheme', + + greek => 'Grek', + + # InGreekAndCoptic + greekandcoptic => 'InGreekA', + + # InGreekExtended + greekextended => 'InGreekE', + + gujarati => 'Gujr', + gurmukhi => 'Guru', + + # InHalfwidthAndFullwidthForms + halfwidthandfullwidthforms => 'InHalfwi', + + han => 'Hani', + hangul => 'Hang', + + # InHangulCompatibilityJamo + hangulcompatibilityjamo => 'InHangu3', + + # InHangulJamo + hanguljamo => 'InHangul', + + # InHangulSyllables + hangulsyllables => 'InHangu2', + + hanunoo => 'Hano', + hebrew => 'Hebr', + + # HexDigit + hexdigit => 'HexDigit', + + # InHighPrivateUseSurrogates + highprivateusesurrogates => 'InHighPr', + + # InHighSurrogates + highsurrogates => 'InHighSu', + + hiragana => 'Hira', + hyphen => 'Hyphen2', + + # IdContinue + idcontinue => 'IdContin', + + ideographic => 'Ideograp', + + # InIdeographicDescriptionCharacters + ideographicdescriptioncharacters => 'InIdeogr', + + # IdsBinaryOperator + idsbinaryoperator => 'IdsBinar', + + # IdStart + idstart => 'IdStart', + + # IdsTrinaryOperator + idstrinaryoperator => 'IdsTrina', + + # InAegeanNumbers + inaegeannumbers => 'InAegean', + + # InAlphabeticPresentationForms + inalphabeticpresentationforms => 'InAlphab', + + # InAncientGreekMusicalNotation + inancientgreekmusicalnotation => 'InAncie2', + + # InAncientGreekNumbers + inancientgreeknumbers => 'InAncien', + + # InArabic + inarabic => 'InArabic', + + # InArabicPresentationFormsA + inarabicpresentationformsa => 'InArabi4', + + # InArabicPresentationFormsB + inarabicpresentationformsb => 'InArabi3', + + # InArabicSupplement + inarabicsupplement => 'InArabi2', + + # InArmenian + inarmenian => 'InArmeni', + + # InArrows + inarrows => 'InArrows', + + # InBasicLatin + inbasiclatin => 'InBasicL', + + # InBengali + inbengali => 'InBengal', + + # InBlockElements + inblockelements => 'InBlockE', + + # InBopomofo + inbopomofo => 'InBopomo', + + # InBopomofoExtended + inbopomofoextended => 'InBopom2', + + # InBoxDrawing + inboxdrawing => 'InBoxDra', + + # InBraillePatterns + inbraillepatterns => 'InBraill', + + # InBuginese + inbuginese => 'InBugine', + + # InBuhid + inbuhid => 'InBuhid', + + # InByzantineMusicalSymbols + inbyzantinemusicalsymbols => 'InByzant', + + # InCherokee + incherokee => 'InCherok', + + # InCjkCompatibility + incjkcompatibility => 'InCjkCom', + + # InCjkCompatibilityForms + incjkcompatibilityforms => 'InCjkCo2', + + # InCjkCompatibilityIdeographs + incjkcompatibilityideographs => 'InCjkCo3', + + # InCjkCompatibilityIdeographsSupplement + incjkcompatibilityideographssupplement => 'InCjkCo4', + + # InCjkRadicalsSupplement + incjkradicalssupplement => 'InCjkRad', + + # InCjkStrokes + incjkstrokes => 'InCjkStr', + + # InCjkSymbolsAndPunctuation + incjksymbolsandpunctuation => 'InCjkSym', + + # InCjkUnifiedIdeographs + incjkunifiedideographs => 'InCjkUni', + + # InCjkUnifiedIdeographsExtensionA + incjkunifiedideographsextensiona => 'InCjkUn3', + + # InCjkUnifiedIdeographsExtensionB + incjkunifiedideographsextensionb => 'InCjkUn2', + + # InCombiningDiacriticalMarks + incombiningdiacriticalmarks => 'InCombi2', + + # InCombiningDiacriticalMarksForSymbols + incombiningdiacriticalmarksforsymbols => 'InCombi4', + + # InCombiningDiacriticalMarksSupplement + incombiningdiacriticalmarkssupplement => 'InCombi3', + + # InCombiningHalfMarks + incombininghalfmarks => 'InCombin', + + # InControlPictures + incontrolpictures => 'InContro', + + # InCoptic + incoptic => 'InCoptic', + + # InCurrencySymbols + incurrencysymbols => 'InCurren', + + # InCypriotSyllabary + incypriotsyllabary => 'InCyprio', + + # InCyrillic + incyrillic => 'InCyrill', + + # InCyrillicSupplement + incyrillicsupplement => 'InCyril2', + + # InDeseret + indeseret => 'InDesere', + + # InDevanagari + indevanagari => 'InDevana', + + # InDingbats + indingbats => 'InDingba', + + # InEnclosedAlphanumerics + inenclosedalphanumerics => 'InEnclos', + + # InEnclosedCjkLettersAndMonths + inenclosedcjklettersandmonths => 'InEnclo2', + + # InEthiopic + inethiopic => 'InEthiop', + + # InEthiopicExtended + inethiopicextended => 'InEthio2', + + # InEthiopicSupplement + inethiopicsupplement => 'InEthio3', + + # InGeneralPunctuation + ingeneralpunctuation => 'InGenera', + + # InGeometricShapes + ingeometricshapes => 'InGeomet', + + # InGeorgian + ingeorgian => 'InGeorgi', + + # InGeorgianSupplement + ingeorgiansupplement => 'InGeorg2', + + # InGlagolitic + inglagolitic => 'InGlagol', + + # InGothic + ingothic => 'InGothic', + + # InGreekAndCoptic + ingreekandcoptic => 'InGreekA', + + # InGreekExtended + ingreekextended => 'InGreekE', + + # InGujarati + ingujarati => 'InGujara', + + # InGurmukhi + ingurmukhi => 'InGurmuk', + + # InHalfwidthAndFullwidthForms + inhalfwidthandfullwidthforms => 'InHalfwi', + + # InHangulCompatibilityJamo + inhangulcompatibilityjamo => 'InHangu3', + + # InHangulJamo + inhanguljamo => 'InHangul', + + # InHangulSyllables + inhangulsyllables => 'InHangu2', + + # InHanunoo + inhanunoo => 'InHanuno', + + # InHebrew + inhebrew => 'InHebrew', + + inherited => 'Qaai', + + # InHighPrivateUseSurrogates + inhighprivateusesurrogates => 'InHighPr', + + # InHighSurrogates + inhighsurrogates => 'InHighSu', + + # InHiragana + inhiragana => 'InHiraga', + + # InIdeographicDescriptionCharacters + inideographicdescriptioncharacters => 'InIdeogr', + + # InIpaExtensions + inipaextensions => 'InIpaExt', + + # InitialPunctuation + initialpunctuation => 'Pi', + + # InKanbun + inkanbun => 'InKanbun', + + # InKangxiRadicals + inkangxiradicals => 'InKangxi', + + # InKannada + inkannada => 'InKannad', + + # InKatakana + inkatakana => 'InKataka', + + # InKatakanaPhoneticExtensions + inkatakanaphoneticextensions => 'InKatak2', + + # InKharoshthi + inkharoshthi => 'InKharos', + + # InKhmer + inkhmer => 'InKhmer', + + # InKhmerSymbols + inkhmersymbols => 'InKhmerS', + + # InLao + inlao => 'InLao', + + # InLatin1Supplement + inlatin1supplement => 'InLatin1', + + # InLatinExtendedA + inlatinextendeda => 'InLatin2', + + # InLatinExtendedAdditional + inlatinextendedadditional => 'InLatin3', + + # InLatinExtendedB + inlatinextendedb => 'InLatinE', + + # InLetterlikeSymbols + inletterlikesymbols => 'InLetter', + + # InLimbu + inlimbu => 'InLimbu', + + # InLinearBIdeograms + inlinearbideograms => 'InLinear', + + # InLinearBSyllabary + inlinearbsyllabary => 'InLinea2', + + # InLowSurrogates + inlowsurrogates => 'InLowSur', + + # InMalayalam + inmalayalam => 'InMalaya', + + # InMathematicalAlphanumericSymbols + inmathematicalalphanumericsymbols => 'InMathe2', + + # InMathematicalOperators + inmathematicaloperators => 'InMathem', + + # InMiscellaneousMathematicalSymbolsA + inmiscellaneousmathematicalsymbolsa => 'InMisce4', + + # InMiscellaneousMathematicalSymbolsB + inmiscellaneousmathematicalsymbolsb => 'InMisce5', + + # InMiscellaneousSymbols + inmiscellaneoussymbols => 'InMiscel', + + # InMiscellaneousSymbolsAndArrows + inmiscellaneoussymbolsandarrows => 'InMisce3', + + # InMiscellaneousTechnical + inmiscellaneoustechnical => 'InMisce2', + + # InModifierToneLetters + inmodifiertoneletters => 'InModifi', + + # InMongolian + inmongolian => 'InMongol', + + # InMusicalSymbols + inmusicalsymbols => 'InMusica', + + # InMyanmar + inmyanmar => 'InMyanma', + + # InNewTaiLue + innewtailue => 'InNewTai', + + # InNumberForms + innumberforms => 'InNumber', + + # InOgham + inogham => 'InOgham', + + # InOldItalic + inolditalic => 'InOldIta', + + # InOldPersian + inoldpersian => 'InOldPer', + + # InOpticalCharacterRecognition + inopticalcharacterrecognition => 'InOptica', + + # InOriya + inoriya => 'InOriya', + + # InOsmanya + inosmanya => 'InOsmany', + + # InPhoneticExtensions + inphoneticextensions => 'InPhonet', + + # InPhoneticExtensionsSupplement + inphoneticextensionssupplement => 'InPhone2', + + # InPrivateUseArea + inprivateusearea => 'InPrivat', + + # InRunic + inrunic => 'InRunic', + + # InShavian + inshavian => 'InShavia', + + # InSinhala + insinhala => 'InSinhal', + + # InSmallFormVariants + insmallformvariants => 'InSmallF', + + # InSpacingModifierLetters + inspacingmodifierletters => 'InSpacin', + + # InSpecials + inspecials => 'InSpecia', + + # InSuperscriptsAndSubscripts + insuperscriptsandsubscripts => 'InSupers', + + # InSupplementalArrowsA + insupplementalarrowsa => 'InSuppl2', + + # InSupplementalArrowsB + insupplementalarrowsb => 'InSupple', + + # InSupplementalMathematicalOperators + insupplementalmathematicaloperators => 'InSuppl6', + + # InSupplementalPunctuation + insupplementalpunctuation => 'InSuppl3', + + # InSupplementaryPrivateUseAreaA + insupplementaryprivateuseareaa => 'InSuppl4', + + # InSupplementaryPrivateUseAreaB + insupplementaryprivateuseareab => 'InSuppl5', + + # InSylotiNagri + insylotinagri => 'InSyloti', + + # InSyriac + insyriac => 'InSyriac', + + # InTagalog + intagalog => 'InTagalo', + + # InTagbanwa + intagbanwa => 'InTagban', + + # InTags + intags => 'InTags', + + # InTaiLe + intaile => 'InTaiLe', + + # InTaiXuanJingSymbols + intaixuanjingsymbols => 'InTaiXua', + + # InTamil + intamil => 'InTamil', + + # InTelugu + intelugu => 'InTelugu', + + # InThaana + inthaana => 'InThaana', + + # InThai + inthai => 'InThai', + + # InTibetan + intibetan => 'InTibeta', + + # InTifinagh + intifinagh => 'InTifina', + + # InUgaritic + inugaritic => 'InUgarit', + + # InUnifiedCanadianAboriginalSyllabics + inunifiedcanadianaboriginalsyllabics => 'InUnifie', + + # InVariationSelectors + invariationselectors => 'InVariat', + + # InVariationSelectorsSupplement + invariationselectorssupplement => 'InVaria2', + + # InVerticalForms + inverticalforms => 'InVertic', + + # InYijingHexagramSymbols + inyijinghexagramsymbols => 'InYijing', + + # InYiRadicals + inyiradicals => 'InYiRadi', + + # InYiSyllables + inyisyllables => 'InYiSyll', + + # InIpaExtensions + ipaextensions => 'InIpaExt', + + # JoinControl + joincontrol => 'JoinCont', + + # InKanbun + kanbun => 'InKanbun', + + # InKangxiRadicals + kangxiradicals => 'InKangxi', + + kannada => 'Knda', + katakana => 'Kana', + + # InKatakanaPhoneticExtensions + katakanaphoneticextensions => 'InKatak2', + + kharoshthi => 'Khar', + khmer => 'Khmr', + + # InKhmerSymbols + khmersymbols => 'InKhmerS', + + lao => 'Laoo', + latin => 'Latn', + + # InLatin1Supplement + latin1supplement => 'InLatin1', + + # InLatinExtendedA + latinextendeda => 'InLatin2', + + # InLatinExtendedAdditional + latinextendedadditional => 'InLatin3', + + # InLatinExtendedB + latinextendedb => 'InLatinE', + + letter => 'L', + + # InLetterlikeSymbols + letterlikesymbols => 'InLetter', + + # LetterNumber + letternumber => 'Nl', + + limbu => 'Limb', + + # LinearB + linearb => 'LinearB', + + # InLinearBIdeograms + linearbideograms => 'InLinear', + + # InLinearBSyllabary + linearbsyllabary => 'InLinea2', + + # LineSeparator + lineseparator => 'Zl', + + # LogicalOrderException + logicalorderexception => 'LogicalO', + + lowercase => 'Lowercas', + + # LowercaseLetter + lowercaseletter => 'Ll', + + # InLowSurrogates + lowsurrogates => 'InLowSur', + + malayalam => 'Mlym', + mark => 'M', + math => 'Math', + + # InMathematicalAlphanumericSymbols + mathematicalalphanumericsymbols => 'InMathe2', + + # InMathematicalOperators + mathematicaloperators => 'InMathem', + + # MathSymbol + mathsymbol => 'Sm', + + # InMiscellaneousMathematicalSymbolsA + miscellaneousmathematicalsymbolsa => 'InMisce4', + + # InMiscellaneousMathematicalSymbolsB + miscellaneousmathematicalsymbolsb => 'InMisce5', + + # InMiscellaneousSymbols + miscellaneoussymbols => 'InMiscel', + + # InMiscellaneousSymbolsAndArrows + miscellaneoussymbolsandarrows => 'InMisce3', + + # InMiscellaneousTechnical + miscellaneoustechnical => 'InMisce2', + + # ModifierLetter + modifierletter => 'Lm', + + # ModifierSymbol + modifiersymbol => 'Sk', + + # InModifierToneLetters + modifiertoneletters => 'InModifi', + + mongolian => 'Mong', + + # InMusicalSymbols + musicalsymbols => 'InMusica', + + myanmar => 'Mymr', + + # NewTaiLue + newtailue => 'NewTaiLu', + + # NoncharacterCodePoint + noncharactercodepoint => 'Nonchara', + + # NonspacingMark + nonspacingmark => 'Mn', + + number => 'N', + + # InNumberForms + numberforms => 'InNumber', + + ogham => 'Ogam', + + # OldItalic + olditalic => 'OldItali', + + # OldPersian + oldpersian => 'OldPersi', + + # OpenPunctuation + openpunctuation => 'Ps', + + # InOpticalCharacterRecognition + opticalcharacterrecognition => 'InOptica', + + oriya => 'Orya', + osmanya => 'Osma', + other => 'C', + + # OtherAlphabetic + otheralphabetic => 'OtherAlp', + + # OtherDefaultIgnorableCodePoint + otherdefaultignorablecodepoint => 'OtherDef', + + # OtherGraphemeExtend + othergraphemeextend => 'OtherGra', + + # OtherIdContinue + otheridcontinue => 'OtherIdC', + + # OtherIdStart + otheridstart => 'OtherIdS', + + # OtherLetter + otherletter => 'Lo', + + # OtherLowercase + otherlowercase => 'OtherLow', + + # OtherMath + othermath => 'OtherMat', + + # OtherNumber + othernumber => 'No', + + # OtherPunctuation + otherpunctuation => 'Po', + + # OtherSymbol + othersymbol => 'So', + + # OtherUppercase + otheruppercase => 'OtherUpp', + + # ParagraphSeparator + paragraphseparator => 'Zp', + + # PatternSyntax + patternsyntax => 'PatternS', + + # PatternWhiteSpace + patternwhitespace => 'PatternW', + + # InPhoneticExtensions + phoneticextensions => 'InPhonet', + + # InPhoneticExtensionsSupplement + phoneticextensionssupplement => 'InPhone2', + + # PrivateUse + privateuse => 'Co', + + # InPrivateUseArea + privateusearea => 'InPrivat', + + punctuation => 'P', + + # QuotationMark + quotationmark => 'Quotatio', + + radical => 'Radical2', + runic => 'Runr', + separator => 'Z', + shavian => 'Shaw', + sinhala => 'Sinh', + + # InSmallFormVariants + smallformvariants => 'InSmallF', + + # SoftDotted + softdotted => 'SoftDott', + + # SpaceSeparator + spaceseparator => 'Zs', + + # SpacingMark + spacingmark => 'Mc', + + # InSpacingModifierLetters + spacingmodifierletters => 'InSpacin', + + # InSpecials + specials => 'InSpecia', + + sterm => 'Sterm2', + + # InSuperscriptsAndSubscripts + superscriptsandsubscripts => 'InSupers', + + # InSupplementalArrowsA + supplementalarrowsa => 'InSuppl2', + + # InSupplementalArrowsB + supplementalarrowsb => 'InSupple', + + # InSupplementalMathematicalOperators + supplementalmathematicaloperators => 'InSuppl6', + + # InSupplementalPunctuation + supplementalpunctuation => 'InSuppl3', + + # InSupplementaryPrivateUseAreaA + supplementaryprivateuseareaa => 'InSuppl4', + + # InSupplementaryPrivateUseAreaB + supplementaryprivateuseareab => 'InSuppl5', + + surrogate => 'Cs', + + # SylotiNagri + sylotinagri => 'SylotiNa', + + symbol => 'S', + syriac => 'Syrc', + tagalog => 'Tglg', + tagbanwa => 'Tagb', + + # InTags + tags => 'InTags', + + # TaiLe + taile => 'TaiLe', + + # InTaiXuanJingSymbols + taixuanjingsymbols => 'InTaiXua', + + tamil => 'Taml', + telugu => 'Telu', + + # TerminalPunctuation + terminalpunctuation => 'Terminal', + + thaana => 'Thaa', + thai => 'Thai', + tibetan => 'Tibt', + tifinagh => 'Tfng', + + # TitlecaseLetter + titlecaseletter => 'Lt', + + ugaritic => 'Ugar', + unassigned => 'Cn', + + # InUnifiedCanadianAboriginalSyllabics + unifiedcanadianaboriginalsyllabics => 'InUnifie', + + # UnifiedIdeograph + unifiedideograph => 'UnifiedI', + + uppercase => 'Uppercas', + + # UppercaseLetter + uppercaseletter => 'Lu', + + # VariationSelector + variationselector => 'Variatio', + + # InVariationSelectors + variationselectors => 'InVariat', + + # InVariationSelectorsSupplement + variationselectorssupplement => 'InVaria2', + + # InVerticalForms + verticalforms => 'InVertic', + + # WhiteSpace + whitespace => 'WhiteSpa', + + yi => 'Yiii', + + # InYijingHexagramSymbols + yijinghexagramsymbols => 'InYijing', + + # InYiRadicals + yiradicals => 'InYiRadi', + + # InYiSyllables + yisyllables => 'InYiSyll', + +); +1 diff --git a/Master/tlpkg/installer/perllib/unicore/Exact.pl b/Master/tlpkg/installer/perllib/unicore/Exact.pl new file mode 100644 index 00000000000..42312b054cc --- /dev/null +++ b/Master/tlpkg/installer/perllib/unicore/Exact.pl @@ -0,0 +1,73 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables from e.g. UnicodeData.txt. +# Any changes made here will be lost! + +## +## Data in this file used by ../utf8_heavy.pl +## + +## Mapping from name to filename in ./lib/gc_sc +%utf8::Exact = ( + ASCII => 'ASCII', + All => 'Any', + Alnum => 'Alnum', + Alpha => 'Alpha', + Any => 'Any', + Assigned => 'Assigned', + Blank => 'Blank', + C => 'C', + Cc => 'Cc', + Cf => 'Cf', + Cn => 'Cn', + Cntrl => 'Cntrl', + Co => 'Co', + Cs => 'Cs', + Digit => 'Digit', + Graph => 'Graph', + InGreek => 'InGreekA', + L => 'L', + LC => 'LC', + Ll => 'Ll', + Lm => 'Lm', + Lo => 'Lo', + Lower => 'Lower', + Lt => 'Lt', + Lu => 'Lu', + M => 'M', + Mc => 'Mc', + Me => 'Me', + Mn => 'Mn', + N => 'N', + Nd => 'Nd', + Nl => 'Nl', + No => 'No', + P => 'P', + Pc => 'Pc', + Pd => 'Pd', + Pe => 'Pe', + Pf => 'Pf', + Pi => 'Pi', + Po => 'Po', + Print => 'Print', + Ps => 'Ps', + Punct => 'Punct', + S => 'S', + Sc => 'Sc', + Sk => 'Sk', + Sm => 'Sm', + So => 'So', + Space => 'Space', + SpacePerl => 'SpacePer', + Title => 'Title', + Upper => 'Upper', + Word => 'Word', + XDigit => 'XDigit', + Z => 'Z', + Zl => 'Zl', + Zp => 'Zp', + Zs => 'Zs', + _CanonDCIJ => '_CanonDC', + _CaseIgnorable => '_CaseIgn', + _CombAbove => '_CombAbo', +); +1; diff --git a/Master/tlpkg/installer/perllib/unicore/PVA.pl b/Master/tlpkg/installer/perllib/unicore/PVA.pl new file mode 100644 index 00000000000..d836bdb7549 --- /dev/null +++ b/Master/tlpkg/installer/perllib/unicore/PVA.pl @@ -0,0 +1,2044 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables from e.g. UnicodeData.txt. +# Any changes made here will be lost! + + +%utf8::PropertyAlias = ( +'sc', +'Script', +'xonfkd', +'ExpandsOnNFKD', +'patsyn', +'PatternSyntax', +'nfkcqc', +'NFKCQuickCheck', +'oalpha', +'OtherAlphabetic', +'gcb', +'GraphemeClusterBreak', +'nfcqc', +'NFCQuickCheck', +'ids', +'IDStart', +'lb', +'LineBreak', +'stc', +'SimpleTitlecaseMapping', +'xonfkc', +'ExpandsOnNFKC', +'patws', +'PatternWhiteSpace', +'tc', +'TitlecaseMapping', +'lower', +'Lowercase', +'idst', +'IDSTrinaryOperator', +'radical', +'Radical', +'fcnfkc', +'FCNFKCClosure', +'dm', +'DecompositionMapping', +'slc', +'SimpleLowercaseMapping', +'wspace', +'WhiteSpace', +'di', +'DefaultIgnorableCodePoint', +'nt', +'NumericType', +'ea', +'EastAsianWidth', +'ahex', +'ASCIIHexDigit', +'alpha', +'Alphabetic', +'uc', +'UppercaseMapping', +'dia', +'Diacritic', +'gc', +'GeneralCategory', +'xids', +'XIDStart', +'oupper', +'OtherUppercase', +'wb', +'WordBreak', +'math', +'Math', +'sb', +'SentenceBreak', +'qmark', +'QuotationMark', +'nfdqc', +'NFDQuickCheck', +'ideo', +'Ideographic', +'blk', +'Block', +'odi', +'OtherDefaultIgnorableCodePoint', +'hst', +'HangulSyllableType', +'bidim', +'BidiMirrored', +'olower', +'OtherLowercase', +'na', +'Name', +'hyphen', +'Hyphen', +'xidc', +'XIDContinue', +'oidc', +'OtherIDContinue', +'bidic', +'BidiControl', +'na1', +'Unicode1Name', +'compex', +'FullCompositionExclusion', +'ext', +'Extender', +'cf', +'CaseFolding', +'grlink', +'GraphemeLink', +'xonfc', +'ExpandsOnNFC', +'sd', +'SoftDotted', +'ccc', +'CanonicalCombiningClass', +'dash', +'Dash', +'hex', +'HexDigit', +'grbase', +'GraphemeBase', +'dt', +'DecompositionType', +'xonfd', +'ExpandsOnNFD', +'scc', +'SpecialCaseCondition', +'idsb', +'IDSBinaryOperator', +'age', +'Age', +'loe', +'LogicalOrderException', +'term', +'TerminalPunctuation', +'ce', +'CompositionExclusion', +'isc', +'ISOComment', +'dep', +'Deprecated', +'sfc', +'SimpleCaseFolding', +'bc', +'BidiClass', +'nchar', +'NoncharacterCodePoint', +'jt', +'JoiningType', +'upper', +'Uppercase', +'uideo', +'UnifiedIdeograph', +'sterm', +'STerm', +'nfkdqc', +'NFKDQuickCheck', +'oids', +'OtherIDStart', +'joinc', +'JoinControl', +'nv', +'NumericValue', +'suc', +'SimpleUppercaseMapping', +'urs', +'UnicodeRadicalStroke', +'bmg', +'BidiMirroringGlyph', +'grext', +'GraphemeExtend', +'idc', +'IDContinue', +'vs', +'VariationSelector', +'omath', +'OtherMath', +'lc', +'LowercaseMapping', +'ogrext', +'OtherGraphemeExtend', +'jg', +'JoiningGroup', +); + +%utf8::PA_reverse = ( +'linebreak', +'lb', +'bidiclass', +'bc', +'terminalpunctuation', +'Term', +'expandsonnfkc', +'XONFKC', +'extender', +'Ext', +'simplecasefolding', +'sfc', +'patternsyntax', +'PatSyn', +'sentencebreak', +'SB', +'numericvalue', +'nv', +'patternwhitespace', +'PatWS', +'softdotted', +'SD', +'logicalorderexception', +'LOE', +'idstart', +'IDS', +'generalcategory', +'gc', +'decompositiontype', +'dt', +'name', +'na', +'numerictype', +'nt', +'otherlowercase', +'OLower', +'joininggroup', +'jg', +'expandsonnfkd', +'XONFKD', +'deprecated', +'Dep', +'radical', +'Radical', +'idstrinaryoperator', +'IDST', +'xidstart', +'XIDS', +'lowercase', +'Lower', +'unifiedideograph', +'UIdeo', +'othergraphemeextend', +'OGrExt', +'eastasianwidth', +'ea', +'math', +'Math', +'graphemelink', +'GrLink', +'noncharactercodepoint', +'NChar', +'graphemebase', +'GrBase', +'bidimirrored', +'BidiM', +'casefolding', +'cf', +'simpleuppercasemapping', +'suc', +'fullcompositionexclusion', +'CompEx', +'compositionexclusion', +'CE', +'uppercasemapping', +'uc', +'decompositionmapping', +'dm', +'whitespace', +'WSpace', +'hyphen', +'Hyphen', +'ideographic', +'Ideo', +'idcontinue', +'IDC', +'idsbinaryoperator', +'IDSB', +'hangulsyllabletype', +'hst', +'asciihexdigit', +'AHex', +'otheruppercase', +'OUpper', +'nfkdquickcheck', +'NFKDQC', +'simpletitlecasemapping', +'stc', +'nfcquickcheck', +'NFCQC', +'bidicontrol', +'BidiC', +'diacritic', +'Dia', +'joiningtype', +'jt', +'otheralphabetic', +'OAlpha', +'canonicalcombiningclass', +'ccc', +'alphabetic', +'Alpha', +'titlecasemapping', +'tc', +'unicoderadicalstroke', +'URS', +'hexdigit', +'Hex', +'unicode1name', +'na1', +'dash', +'Dash', +'fcnfkcclosure', +'FCNFKC', +'graphemeextend', +'GrExt', +'joincontrol', +'JoinC', +'xidcontinue', +'XIDC', +'quotationmark', +'QMark', +'expandsonnfd', +'XONFD', +'age', +'age', +'otheridcontinue', +'OIDC', +'uppercase', +'Upper', +'expandsonnfc', +'XONFC', +'defaultignorablecodepoint', +'DI', +'nfdquickcheck', +'NFDQC', +'isocomment', +'isc', +'otherdefaultignorablecodepoint', +'ODI', +'variationselector', +'VS', +'specialcasecondition', +'scc', +'script', +'sc', +'otheridstart', +'OIDS', +'sterm', +'STerm', +'graphemeclusterbreak', +'GCB', +'nfkcquickcheck', +'NFKCQC', +'bidimirroringglyph', +'bmg', +'othermath', +'OMath', +'block', +'blk', +'wordbreak', +'WB', +'lowercasemapping', +'lc', +'simplelowercasemapping', +'slc', +); + +%utf8::PropValueAlias = ( +'sc', +{ +'tglg', +'Tagalog', +'runr', +'Runic', +'osma', +'Osmanya', +'hano', +'Hanunoo', +'cans', +'CanadianAboriginal', +'tagb', +'Tagbanwa', +'mlym', +'Malayalam', +'knda', +'Kannada', +'grek', +'Greek', +'ethi', +'Ethiopic', +'orya', +'Oriya', +'cher', +'Cherokee', +'mong', +'Mongolian', +'khmr', +'Khmer', +'ogam', +'Ogham', +'hrkt', +'KatakanaOrHiragana', +'armn', +'Armenian', +'ital', +'OldItalic', +'hani', +'Han', +'shaw', +'Shavian', +'taml', +'Tamil', +'tibt', +'Tibetan', +'guru', +'Gurmukhi', +'ugar', +'Ugaritic', +'qaai', +'Inherited', +'kana', +'Katakana', +'gujr', +'Gujarati', +'thaa', +'Thaana', +'cyrl', +'Cyrillic', +'copt', +'Coptic', +'sylo', +'SylotiNagri', +'thai', +'Thai', +'talu', +'NewTaiLue', +'laoo', +'Lao', +'sinh', +'Sinhala', +'beng', +'Bengali', +'hira', +'Hiragana', +'brai', +'Braille', +'telu', +'Telugu', +'limb', +'Limbu', +'geor', +'Georgian', +'mymr', +'Myanmar', +'glag', +'Glagolitic', +'hang', +'Hangul', +'syrc', +'Syriac', +'tfng', +'Tifinagh', +'dsrt', +'Deseret', +'buhd', +'Buhid', +'yiii', +'Yi', +'arab', +'Arabic', +'bopo', +'Bopomofo', +'khar', +'Kharoshthi', +'linb', +'LinearB', +'deva', +'Devanagari', +'xpeo', +'OldPersian', +'goth', +'Gothic', +'cprt', +'Cypriot', +'tale', +'TaiLe', +'zyyy', +'Common', +'latn', +'Latin', +'bugi', +'Buginese', +'hebr', +'Hebrew', +}, +'dt', +{ +'fra', +'Fraction', +'none', +'None', +'sml', +'Small', +'enc', +'Circle', +'font', +'Font', +'init', +'Initial', +'nb', +'Nobreak', +'iso', +'Isolated', +'sup', +'Super', +'fin', +'Final', +'wide', +'Wide', +'nar', +'Narrow', +'can', +'Canonical', +'med', +'Medial', +'sub', +'Sub', +'vert', +'Vertical', +'sqr', +'Square', +'com', +'Compat', +}, +'nt', +{ +'none', +'None', +'di', +'Digit', +'de', +'Decimal', +'nu', +'Numeric', +}, +'ea', +{ +'w', +'Wide', +'n', +'Neutral', +'h', +'Halfwidth', +'a', +'Ambiguous', +'f', +'Fullwidth', +'na', +'Narrow', +}, +'NFKC_QC', +{ +'y', +'Yes', +'n', +'No', +'m', +'Maybe', +}, +'bc', +{ +'r', +'RightToLeft', +'rlo', +'RightToLeftOverride', +'es', +'EuropeanSeparator', +'ws', +'WhiteSpace', +'rle', +'RightToLeftEmbedding', +'on', +'OtherNeutral', +'bn', +'BoundaryNeutral', +'et', +'EuropeanTerminator', +'pdf', +'PopDirectionalFormat', +'lro', +'LeftToRightOverride', +'s', +'SegmentSeparator', +'al', +'ArabicLetter', +'en', +'EuropeanNumber', +'l', +'LeftToRight', +'b', +'ParagraphSeparator', +'lre', +'LeftToRightEmbedding', +'cs', +'CommonSeparator', +'nsm', +'NonspacingMark', +'an', +'ArabicNumber', +}, +'gc', +{ +'sc', +'CurrencySymbol', +'mc', +'SpacingMark', +'lm', +'ModifierLetter', +'cn', +'Unassigned', +'pf', +'FinalPunctuation', +'no', +'OtherNumber', +'cc', +'Control', +'lo', +'OtherLetter', +'po', +'OtherPunctuation', +'zs', +'SpaceSeparator', +'co', +'PrivateUse', +'so', +'OtherSymbol', +'ll', +'LowercaseLetter', +'nd', +'DecimalNumber', +'cf', +'Format', +'me', +'EnclosingMark', +'s', +'Symbol', +'zp', +'ParagraphSeparator', +'pd', +'DashPunctuation', +'c', +'Other', +'lt', +'TitlecaseLetter', +'cs', +'Surrogate', +'l&', +'CasedLetter', +'z', +'Separator', +'ps', +'OpenPunctuation', +'zl', +'LineSeparator', +'pc', +'ConnectorPunctuation', +'pi', +'InitialPunctuation', +'n', +'Number', +'m', +'Mark', +'nl', +'LetterNumber', +'sm', +'MathSymbol', +'l', +'Letter', +'mn', +'NonspacingMark', +'p', +'Punctuation', +'lc', +'CasedLetter', +'sk', +'ModifierSymbol', +'lu', +'UppercaseLetter', +'pe', +'ClosePunctuation', +}, +'GCB', +{ +'cn', +'Control', +'ex', +'Extend', +'v', +'V', +'lv', +'LV', +'xx', +'Other', +'l', +'L', +'lvt', +'LVT', +'cr', +'CR', +'lf', +'LF', +'t', +'T', +}, +'lb', +{ +'sp', +'Space', +'ba', +'BreakAfter', +'gl', +'Glue', +'xx', +'Unknown', +'nu', +'Numeric', +'cb', +'ContingentBreak', +'sy', +'BreakSymbols', +'cr', +'CarriageReturn', +'in', +'Inseparable', +'bb', +'BreakBefore', +'sg', +'Surrogate', +'sa', +'ComplexContext', +'po', +'PostfixNumeric', +'jl', +'JL', +'id', +'Ideographic', +'al', +'Alphabetic', +'bk', +'MandatoryBreak', +'pr', +'PrefixNumeric', +'b2', +'BreakBoth', +'op', +'OpenPunctuation', +'cl', +'ClosePunctuation', +'is', +'InfixNumeric', +'qu', +'Quotation', +'hy', +'Hyphen', +'wj', +'WordJoiner', +'zw', +'ZWSpace', +'jt', +'JT', +'ex', +'Exclamation', +'cm', +'CombiningMark', +'h2', +'H2', +'nl', +'NextLine', +'ns', +'Nonstarter', +'h3', +'H3', +'ai', +'Ambiguous', +'lf', +'LineFeed', +'jv', +'JV', +}, +'jt', +{ +'l', +'LeftJoining', +'u', +'NonJoining', +'c', +'JoinCausing', +'r', +'RightJoining', +'d', +'DualJoining', +'t', +'Transparent', +}, +'NFKD_QC', +{ +'y', +'Yes', +'n', +'No', +}, +'NFC_QC', +{ +'y', +'Yes', +'n', +'No', +'m', +'Maybe', +}, +'hst', +{ +'l', +'LeadingJamo', +'lvt', +'LVTSyllable', +'v', +'VowelJamo', +'lv', +'LVSyllable', +'t', +'TrailingJamo', +'na', +'NotApplicable', +}, +'NFD_QC', +{ +'y', +'Yes', +'n', +'No', +}, +'WB', +{ +'ml', +'MidLetter', +'le', +'ALetter', +'ex', +'ExtendNumLet', +'xx', +'Other', +'nu', +'Numeric', +'fo', +'Format', +'mn', +'MidNum', +'ka', +'Katakana', +}, +'SB', +{ +'sp', +'Sp', +'cl', +'Close', +'le', +'OLetter', +'up', +'Upper', +'st', +'STerm', +'xx', +'Other', +'nu', +'Numeric', +'fo', +'Format', +'se', +'Sep', +'lo', +'Lower', +'at', +'ATerm', +}, +'ccc', +{ +'atb', +'AttachedBelow', +'db', +'DoubleBelow', +'a', +'Above', +'r', +'Right', +'da', +'DoubleAbove', +'is', +'IotaSubscript', +'nr', +'NotReordered', +'ov', +'Overlay', +'br', +'BelowRight', +'nk', +'Nukta', +'atbl', +'AttachedBelowLeft', +'al', +'AboveLeft', +'ar', +'AboveRight', +'atar', +'AttachedAboveRight', +'l', +'Left', +'b', +'Below', +'vr', +'Virama', +'kv', +'KanaVoicing', +'bl', +'BelowLeft', +}, +); + +%utf8::PVA_reverse = ( +'sc', +{ +'newtailue', +'Talu', +'canadianaboriginal', +'Cans', +'gujarati', +'Gujr', +'latin', +'Latn', +'hangul', +'Hang', +'deseret', +'Dsrt', +'hebrew', +'Hebr', +'inherited', +'Qaai', +'linearb', +'Linb', +'ugaritic', +'Ugar', +'taile', +'Tale', +'armenian', +'Armn', +'tifinagh', +'Tfng', +'myanmar', +'Mymr', +'gurmukhi', +'Guru', +'greek', +'Grek', +'coptic', +'Copt', +'cyrillic', +'Cyrl', +'thaana', +'Thaa', +'lao', +'Laoo', +'katakana', +'Kana', +'khmer', +'Khmr', +'tibetan', +'Tibt', +'hiragana', +'Hira', +'mongolian', +'Mong', +'thai', +'Thai', +'yi', +'Yiii', +'sylotinagri', +'Sylo', +'bopomofo', +'Bopo', +'malayalam', +'Mlym', +'telugu', +'Telu', +'limbu', +'Limb', +'oriya', +'Orya', +'buhid', +'Buhd', +'cypriot', +'Cprt', +'bengali', +'Beng', +'katakanaorhiragana', +'Hrkt', +'oldpersian', +'Xpeo', +'tagalog', +'Tglg', +'syriac', +'Syrc', +'cherokee', +'Cher', +'ogham', +'Ogam', +'hanunoo', +'Hano', +'braille', +'Brai', +'tamil', +'Taml', +'common', +'Zyyy', +'runic', +'Runr', +'georgian', +'Geor', +'ethiopic', +'Ethi', +'glagolitic', +'Glag', +'han', +'Hani', +'kharoshthi', +'Khar', +'kannada', +'Knda', +'tagbanwa', +'Tagb', +'arabic', +'Arab', +'sinhala', +'Sinh', +'gothic', +'Goth', +'osmanya', +'Osma', +'olditalic', +'Ital', +'devanagari', +'Deva', +'buginese', +'Bugi', +'shavian', +'Shaw', +}, +'dt', +{ +'small', +'sml', +'none', +'none', +'isolated', +'iso', +'narrow', +'nar', +'square', +'sqr', +'nobreak', +'nb', +'fraction', +'fra', +'font', +'font', +'medial', +'med', +'wide', +'wide', +'canonical', +'can', +'circle', +'enc', +'super', +'sup', +'vertical', +'vert', +'final', +'fin', +'compat', +'com', +'sub', +'sub', +'initial', +'init', +}, +'nt', +{ +'none', +'None', +'digit', +'Di', +'numeric', +'Nu', +'decimal', +'De', +}, +'ea', +{ +'halfwidth', +'H', +'fullwidth', +'F', +'ambiguous', +'A', +'narrow', +'Na', +'wide', +'W', +'neutral', +'N', +}, +'NFKC_QC', +{ +'yes', +'Y', +'maybe', +'M', +'no', +'N', +}, +'bc', +{ +'nonspacingmark', +'NSM', +'whitespace', +'WS', +'righttoleft', +'R', +'lefttoright', +'L', +'boundaryneutral', +'BN', +'segmentseparator', +'S', +'lefttorightembedding', +'LRE', +'europeanterminator', +'ET', +'righttoleftembedding', +'RLE', +'righttoleftoverride', +'RLO', +'lefttorightoverride', +'LRO', +'europeanseparator', +'ES', +'europeannumber', +'EN', +'commonseparator', +'CS', +'arabicletter', +'AL', +'paragraphseparator', +'B', +'otherneutral', +'ON', +'popdirectionalformat', +'PDF', +'arabicnumber', +'AN', +}, +'gc', +{ +'modifiersymbol', +'Sk', +'letternumber', +'Nl', +'connectorpunctuation', +'Pc', +'spacingmark', +'Mc', +'mark', +'M', +'unassigned', +'Cn', +'enclosingmark', +'Me', +'lineseparator', +'Zl', +'lowercaseletter', +'Ll', +'symbol', +'S', +'letter', +'L', +'othernumber', +'No', +'paragraphseparator', +'Zp', +'modifierletter', +'Lm', +'titlecaseletter', +'Lt', +'decimalnumber', +'Nd', +'other', +'C', +'mathsymbol', +'Sm', +'surrogate', +'Cs', +'otherletter', +'Lo', +'nonspacingmark', +'Mn', +'number', +'N', +'uppercaseletter', +'Lu', +'spaceseparator', +'Zs', +'privateuse', +'Co', +'openpunctuation', +'Ps', +'punctuation', +'P', +'control', +'Cc', +'casedletter', +'LC', +'closepunctuation', +'Pe', +'otherpunctuation', +'Po', +'finalpunctuation', +'Pf', +'format', +'Cf', +'initialpunctuation', +'Pi', +'separator', +'Z', +'othersymbol', +'So', +'dashpunctuation', +'Pd', +'currencysymbol', +'Sc', +}, +'GCB', +{ +'extend', +'EX', +'v', +'V', +'lv', +'LV', +'l', +'L', +'lvt', +'LVT', +'cr', +'CR', +'other', +'XX', +'lf', +'LF', +'control', +'CN', +'t', +'T', +}, +'lb', +{ +'carriagereturn', +'CR', +'ideographic', +'ID', +'hyphen', +'HY', +'ambiguous', +'AI', +'contingentbreak', +'CB', +'complexcontext', +'SA', +'prefixnumeric', +'PR', +'jl', +'JL', +'inseparable', +'IN', +'breaksymbols', +'SY', +'breakafter', +'BA', +'breakbefore', +'BB', +'postfixnumeric', +'PO', +'glue', +'GL', +'wordjoiner', +'WJ', +'breakboth', +'B2', +'quotation', +'QU', +'combiningmark', +'CM', +'nonstarter', +'NS', +'linefeed', +'LF', +'alphabetic', +'AL', +'surrogate', +'SG', +'mandatorybreak', +'BK', +'unknown', +'XX', +'exclamation', +'EX', +'openpunctuation', +'OP', +'jt', +'JT', +'closepunctuation', +'CL', +'space', +'SP', +'zwspace', +'ZW', +'h2', +'H2', +'infixnumeric', +'IS', +'nextline', +'NL', +'numeric', +'NU', +'h3', +'H3', +'jv', +'JV', +}, +'jt', +{ +'leftjoining', +'L', +'transparent', +'T', +'nonjoining', +'U', +'rightjoining', +'R', +'dualjoining', +'D', +'joincausing', +'C', +}, +'NFKD_QC', +{ +'yes', +'Y', +'no', +'N', +}, +'NFC_QC', +{ +'yes', +'Y', +'maybe', +'M', +'no', +'N', +}, +'hst', +{ +'lvtsyllable', +'LVT', +'lvsyllable', +'LV', +'leadingjamo', +'L', +'notapplicable', +'NA', +'voweljamo', +'V', +'trailingjamo', +'T', +}, +'NFD_QC', +{ +'yes', +'Y', +'no', +'N', +}, +'WB', +{ +'midletter', +'ML', +'format', +'FO', +'katakana', +'KA', +'other', +'XX', +'midnum', +'MN', +'numeric', +'NU', +'extendnumlet', +'EX', +'aletter', +'LE', +}, +'SB', +{ +'sp', +'SP', +'upper', +'UP', +'sterm', +'ST', +'aterm', +'AT', +'close', +'CL', +'oletter', +'LE', +'sep', +'SE', +'format', +'FO', +'other', +'XX', +'lower', +'LO', +'numeric', +'NU', +}, +'ccc', +{ +'left', +'L', +'attachedbelowleft', +'ATBL', +'belowleft', +'BL', +'aboveright', +'AR', +'kanavoicing', +'KV', +'above', +'A', +'aboveleft', +'AL', +'nukta', +'NK', +'below', +'B', +'doublebelow', +'DB', +'virama', +'VR', +'belowright', +'BR', +'notreordered', +'NR', +'attachedbelow', +'ATB', +'right', +'R', +'iotasubscript', +'IS', +'doubleabove', +'DA', +'attachedaboveright', +'ATAR', +'overlay', +'OV', +}, +); + +%utf8::PVA_abbr_map = ( +'jt', +{ +'l', +'L', +'u', +'U', +'c', +'C', +'r', +'R', +'d', +'D', +'t', +'T', +}, +'dt', +{ +'fra', +'fra', +'none', +'none', +'sml', +'sml', +'enc', +'enc', +'font', +'font', +'init', +'init', +'nb', +'nb', +'iso', +'iso', +'sup', +'sup', +'fin', +'fin', +'wide', +'wide', +'nar', +'nar', +'can', +'can', +'med', +'med', +'sub', +'sub', +'vert', +'vert', +'sqr', +'sqr', +'com', +'com', +}, +'nt', +{ +'none', +'None', +'di', +'Di', +'de', +'De', +'nu', +'Nu', +}, +'NFKD_QC', +{ +'y', +'Y', +'n', +'N', +}, +'ea', +{ +'w', +'W', +'n', +'N', +'h', +'H', +'a', +'A', +'f', +'F', +'na', +'Na', +}, +'gc_sc', +{ +'runr', +'Runr', +'osma', +'Osma', +'sc', +'Sc', +'mc', +'Mc', +'hano', +'Hano', +'cans', +'Cans', +'lm', +'Lm', +'cn', +'Cn', +'knda', +'Knda', +'orya', +'Orya', +'cher', +'Cher', +'khmr', +'Khmr', +'ogam', +'Ogam', +'lo', +'Lo', +'po', +'Po', +'co', +'Co', +'ital', +'Ital', +'ll', +'Ll', +'tibt', +'Tibt', +'kana', +'Kana', +'zp', +'Zp', +'gujr', +'Gujr', +'thaa', +'Thaa', +'cs', +'Cs', +'copt', +'Copt', +'z', +'Z', +'ps', +'Ps', +'sylo', +'Sylo', +'talu', +'Talu', +'laoo', +'Laoo', +'sinh', +'Sinh', +'zl', +'Zl', +'pc', +'Pc', +'hira', +'Hira', +'limb', +'Limb', +'mymr', +'Mymr', +'yiii', +'Yiii', +'arab', +'Arab', +'deva', +'Deva', +'xpeo', +'Xpeo', +'cprt', +'Cprt', +'bugi', +'Bugi', +'sk', +'Sk', +'hebr', +'Hebr', +'lu', +'Lu', +'pe', +'Pe', +'tglg', +'Tglg', +'tagb', +'Tagb', +'mlym', +'Mlym', +'pf', +'Pf', +'no', +'No', +'grek', +'Grek', +'ethi', +'Ethi', +'mong', +'Mong', +'cc', +'Cc', +'hrkt', +'Hrkt', +'armn', +'Armn', +'zs', +'Zs', +'so', +'So', +'hani', +'Hani', +'shaw', +'Shaw', +'taml', +'Taml', +'me', +'Me', +'cf', +'Cf', +'nd', +'Nd', +'s', +'S', +'guru', +'Guru', +'ugar', +'Ugar', +'qaai', +'Qaai', +'lt', +'Lt', +'c', +'C', +'pd', +'Pd', +'cyrl', +'Cyrl', +'l&', +'LC', +'thai', +'Thai', +'beng', +'Beng', +'brai', +'Brai', +'telu', +'Telu', +'pi', +'Pi', +'geor', +'Geor', +'glag', +'Glag', +'hang', +'Hang', +'syrc', +'Syrc', +'tfng', +'Tfng', +'n', +'N', +'dsrt', +'Dsrt', +'buhd', +'Buhd', +'m', +'M', +'khar', +'Khar', +'sm', +'Sm', +'nl', +'Nl', +'bopo', +'Bopo', +'linb', +'Linb', +'mn', +'Mn', +'l', +'L', +'p', +'P', +'goth', +'Goth', +'tale', +'Tale', +'lc', +'LC', +'zyyy', +'Zyyy', +'latn', +'Latn', +}, +'NFC_QC', +{ +'y', +'Y', +'n', +'N', +'m', +'M', +}, +'NFD_QC', +{ +'y', +'Y', +'n', +'N', +}, +'hst', +{ +'l', +'L', +'lvt', +'LVT', +'v', +'V', +'lv', +'LV', +'t', +'T', +'na', +'NA', +}, +'NFKC_QC', +{ +'y', +'Y', +'n', +'N', +'m', +'M', +}, +'WB', +{ +'ml', +'ML', +'le', +'LE', +'ex', +'EX', +'xx', +'XX', +'nu', +'NU', +'fo', +'FO', +'mn', +'MN', +'ka', +'KA', +}, +'SB', +{ +'sp', +'SP', +'cl', +'CL', +'le', +'LE', +'up', +'UP', +'st', +'ST', +'xx', +'XX', +'nu', +'NU', +'fo', +'FO', +'se', +'SE', +'lo', +'LO', +'at', +'AT', +}, +'bc', +{ +'r', +'R', +'rlo', +'RLO', +'es', +'ES', +'ws', +'WS', +'rle', +'RLE', +'on', +'ON', +'bn', +'BN', +'et', +'ET', +'pdf', +'PDF', +'lro', +'LRO', +'s', +'S', +'al', +'AL', +'en', +'EN', +'l', +'L', +'b', +'B', +'lre', +'LRE', +'cs', +'CS', +'nsm', +'NSM', +'an', +'AN', +}, +'GCB', +{ +'cn', +'CN', +'ex', +'EX', +'v', +'V', +'lv', +'LV', +'xx', +'XX', +'l', +'L', +'lvt', +'LVT', +'cr', +'CR', +'lf', +'LF', +'t', +'T', +}, +'ccc', +{ +'atb', +'ATB', +'db', +'DB', +'a', +'A', +'r', +'R', +'da', +'DA', +'is', +'IS', +'nr', +'NR', +'ov', +'OV', +'br', +'BR', +'nk', +'NK', +'atbl', +'ATBL', +'al', +'AL', +'ar', +'AR', +'atar', +'ATAR', +'l', +'L', +'b', +'B', +'vr', +'VR', +'kv', +'KV', +'bl', +'BL', +}, +'lb', +{ +'sp', +'SP', +'ba', +'BA', +'gl', +'GL', +'xx', +'XX', +'nu', +'NU', +'cb', +'CB', +'sy', +'SY', +'cr', +'CR', +'in', +'IN', +'bb', +'BB', +'sg', +'SG', +'sa', +'SA', +'po', +'PO', +'jl', +'JL', +'id', +'ID', +'al', +'AL', +'bk', +'BK', +'pr', +'PR', +'b2', +'B2', +'op', +'OP', +'cl', +'CL', +'is', +'IS', +'qu', +'QU', +'hy', +'HY', +'wj', +'WJ', +'zw', +'ZW', +'jt', +'JT', +'ex', +'EX', +'cm', +'CM', +'h2', +'H2', +'nl', +'NL', +'ns', +'NS', +'h3', +'H3', +'ai', +'AI', +'lf', +'LF', +'jv', +'JV', +}, +); +1; diff --git a/Master/tlpkg/installer/perllib/unicore/To/Lower.pl b/Master/tlpkg/installer/perllib/unicore/To/Lower.pl new file mode 100644 index 00000000000..77a7a7fb0e0 --- /dev/null +++ b/Master/tlpkg/installer/perllib/unicore/To/Lower.pl @@ -0,0 +1,905 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables from e.g. UnicodeData.txt. +# Any changes made here will be lost! + + +# The key UTF-8 _bytes_, the value UTF-8 (speed hack) +%utf8::ToSpecLower = +( +"\xC4\xB0" => "\x{0069}\x{0307}", +"\xE1\xBE\x88" => "\x{1F80}", +"\xE1\xBE\x89" => "\x{1F81}", +"\xE1\xBE\x8A" => "\x{1F82}", +"\xE1\xBE\x8B" => "\x{1F83}", +"\xE1\xBE\x8C" => "\x{1F84}", +"\xE1\xBE\x8D" => "\x{1F85}", +"\xE1\xBE\x8E" => "\x{1F86}", +"\xE1\xBE\x8F" => "\x{1F87}", +"\xE1\xBE\x98" => "\x{1F90}", +"\xE1\xBE\x99" => "\x{1F91}", +"\xE1\xBE\x9A" => "\x{1F92}", +"\xE1\xBE\x9B" => "\x{1F93}", +"\xE1\xBE\x9C" => "\x{1F94}", +"\xE1\xBE\x9D" => "\x{1F95}", +"\xE1\xBE\x9E" => "\x{1F96}", +"\xE1\xBE\x9F" => "\x{1F97}", +"\xE1\xBE\xA8" => "\x{1FA0}", +"\xE1\xBE\xA9" => "\x{1FA1}", +"\xE1\xBE\xAA" => "\x{1FA2}", +"\xE1\xBE\xAB" => "\x{1FA3}", +"\xE1\xBE\xAC" => "\x{1FA4}", +"\xE1\xBE\xAD" => "\x{1FA5}", +"\xE1\xBE\xAE" => "\x{1FA6}", +"\xE1\xBE\xAF" => "\x{1FA7}", +"\xE1\xBE\xBC" => "\x{1FB3}", +"\xE1\xBF\x8C" => "\x{1FC3}", +"\xE1\xBF\xBC" => "\x{1FF3}", +); + +return <<'END'; +0041 0061 +0042 0062 +0043 0063 +0044 0064 +0045 0065 +0046 0066 +0047 0067 +0048 0068 +0049 0069 +004A 006A +004B 006B +004C 006C +004D 006D +004E 006E +004F 006F +0050 0070 +0051 0071 +0052 0072 +0053 0073 +0054 0074 +0055 0075 +0056 0076 +0057 0077 +0058 0078 +0059 0079 +005A 007A +00C0 00E0 +00C1 00E1 +00C2 00E2 +00C3 00E3 +00C4 00E4 +00C5 00E5 +00C6 00E6 +00C7 00E7 +00C8 00E8 +00C9 00E9 +00CA 00EA +00CB 00EB +00CC 00EC +00CD 00ED +00CE 00EE +00CF 00EF +00D0 00F0 +00D1 00F1 +00D2 00F2 +00D3 00F3 +00D4 00F4 +00D5 00F5 +00D6 00F6 +00D8 00F8 +00D9 00F9 +00DA 00FA +00DB 00FB +00DC 00FC +00DD 00FD +00DE 00FE +0100 0101 +0102 0103 +0104 0105 +0106 0107 +0108 0109 +010A 010B +010C 010D +010E 010F +0110 0111 +0112 0113 +0114 0115 +0116 0117 +0118 0119 +011A 011B +011C 011D +011E 011F +0120 0121 +0122 0123 +0124 0125 +0126 0127 +0128 0129 +012A 012B +012C 012D +012E 012F +0132 0133 +0134 0135 +0136 0137 +0139 013A +013B 013C +013D 013E +013F 0140 +0141 0142 +0143 0144 +0145 0146 +0147 0148 +014A 014B +014C 014D +014E 014F +0150 0151 +0152 0153 +0154 0155 +0156 0157 +0158 0159 +015A 015B +015C 015D +015E 015F +0160 0161 +0162 0163 +0164 0165 +0166 0167 +0168 0169 +016A 016B +016C 016D +016E 016F +0170 0171 +0172 0173 +0174 0175 +0176 0177 +0178 00FF +0179 017A +017B 017C +017D 017E +0181 0253 +0182 0183 +0184 0185 +0186 0254 +0187 0188 +0189 0256 +018A 0257 +018B 018C +018E 01DD +018F 0259 +0190 025B +0191 0192 +0193 0260 +0194 0263 +0196 0269 +0197 0268 +0198 0199 +019C 026F +019D 0272 +019F 0275 +01A0 01A1 +01A2 01A3 +01A4 01A5 +01A6 0280 +01A7 01A8 +01A9 0283 +01AC 01AD +01AE 0288 +01AF 01B0 +01B1 028A +01B2 028B +01B3 01B4 +01B5 01B6 +01B7 0292 +01B8 01B9 +01BC 01BD +01C4 01C6 +01C5 01C6 +01C7 01C9 +01C8 01C9 +01CA 01CC +01CB 01CC +01CD 01CE +01CF 01D0 +01D1 01D2 +01D3 01D4 +01D5 01D6 +01D7 01D8 +01D9 01DA +01DB 01DC +01DE 01DF +01E0 01E1 +01E2 01E3 +01E4 01E5 +01E6 01E7 +01E8 01E9 +01EA 01EB +01EC 01ED +01EE 01EF +01F1 01F3 +01F2 01F3 +01F4 01F5 +01F6 0195 +01F7 01BF +01F8 01F9 +01FA 01FB +01FC 01FD +01FE 01FF +0200 0201 +0202 0203 +0204 0205 +0206 0207 +0208 0209 +020A 020B +020C 020D +020E 020F +0210 0211 +0212 0213 +0214 0215 +0216 0217 +0218 0219 +021A 021B +021C 021D +021E 021F +0220 019E +0222 0223 +0224 0225 +0226 0227 +0228 0229 +022A 022B +022C 022D +022E 022F +0230 0231 +0232 0233 +023B 023C +023D 019A +0241 0294 +0386 03AC +0388 03AD +0389 03AE +038A 03AF +038C 03CC +038E 03CD +038F 03CE +0391 03B1 +0392 03B2 +0393 03B3 +0394 03B4 +0395 03B5 +0396 03B6 +0397 03B7 +0398 03B8 +0399 03B9 +039A 03BA +039B 03BB +039C 03BC +039D 03BD +039E 03BE +039F 03BF +03A0 03C0 +03A1 03C1 +03A3 03C3 +03A4 03C4 +03A5 03C5 +03A6 03C6 +03A7 03C7 +03A8 03C8 +03A9 03C9 +03AA 03CA +03AB 03CB +03D8 03D9 +03DA 03DB +03DC 03DD +03DE 03DF +03E0 03E1 +03E2 03E3 +03E4 03E5 +03E6 03E7 +03E8 03E9 +03EA 03EB +03EC 03ED +03EE 03EF +03F4 03B8 +03F7 03F8 +03F9 03F2 +03FA 03FB +0400 0450 +0401 0451 +0402 0452 +0403 0453 +0404 0454 +0405 0455 +0406 0456 +0407 0457 +0408 0458 +0409 0459 +040A 045A +040B 045B +040C 045C +040D 045D +040E 045E +040F 045F +0410 0430 +0411 0431 +0412 0432 +0413 0433 +0414 0434 +0415 0435 +0416 0436 +0417 0437 +0418 0438 +0419 0439 +041A 043A +041B 043B +041C 043C +041D 043D +041E 043E +041F 043F +0420 0440 +0421 0441 +0422 0442 +0423 0443 +0424 0444 +0425 0445 +0426 0446 +0427 0447 +0428 0448 +0429 0449 +042A 044A +042B 044B +042C 044C +042D 044D +042E 044E +042F 044F +0460 0461 +0462 0463 +0464 0465 +0466 0467 +0468 0469 +046A 046B +046C 046D +046E 046F +0470 0471 +0472 0473 +0474 0475 +0476 0477 +0478 0479 +047A 047B +047C 047D +047E 047F +0480 0481 +048A 048B +048C 048D +048E 048F +0490 0491 +0492 0493 +0494 0495 +0496 0497 +0498 0499 +049A 049B +049C 049D +049E 049F +04A0 04A1 +04A2 04A3 +04A4 04A5 +04A6 04A7 +04A8 04A9 +04AA 04AB +04AC 04AD +04AE 04AF +04B0 04B1 +04B2 04B3 +04B4 04B5 +04B6 04B7 +04B8 04B9 +04BA 04BB +04BC 04BD +04BE 04BF +04C1 04C2 +04C3 04C4 +04C5 04C6 +04C7 04C8 +04C9 04CA +04CB 04CC +04CD 04CE +04D0 04D1 +04D2 04D3 +04D4 04D5 +04D6 04D7 +04D8 04D9 +04DA 04DB +04DC 04DD +04DE 04DF +04E0 04E1 +04E2 04E3 +04E4 04E5 +04E6 04E7 +04E8 04E9 +04EA 04EB +04EC 04ED +04EE 04EF +04F0 04F1 +04F2 04F3 +04F4 04F5 +04F6 04F7 +04F8 04F9 +0500 0501 +0502 0503 +0504 0505 +0506 0507 +0508 0509 +050A 050B +050C 050D +050E 050F +0531 0561 +0532 0562 +0533 0563 +0534 0564 +0535 0565 +0536 0566 +0537 0567 +0538 0568 +0539 0569 +053A 056A +053B 056B +053C 056C +053D 056D +053E 056E +053F 056F +0540 0570 +0541 0571 +0542 0572 +0543 0573 +0544 0574 +0545 0575 +0546 0576 +0547 0577 +0548 0578 +0549 0579 +054A 057A +054B 057B +054C 057C +054D 057D +054E 057E +054F 057F +0550 0580 +0551 0581 +0552 0582 +0553 0583 +0554 0584 +0555 0585 +0556 0586 +10A0 2D00 +10A1 2D01 +10A2 2D02 +10A3 2D03 +10A4 2D04 +10A5 2D05 +10A6 2D06 +10A7 2D07 +10A8 2D08 +10A9 2D09 +10AA 2D0A +10AB 2D0B +10AC 2D0C +10AD 2D0D +10AE 2D0E +10AF 2D0F +10B0 2D10 +10B1 2D11 +10B2 2D12 +10B3 2D13 +10B4 2D14 +10B5 2D15 +10B6 2D16 +10B7 2D17 +10B8 2D18 +10B9 2D19 +10BA 2D1A +10BB 2D1B +10BC 2D1C +10BD 2D1D +10BE 2D1E +10BF 2D1F +10C0 2D20 +10C1 2D21 +10C2 2D22 +10C3 2D23 +10C4 2D24 +10C5 2D25 +1E00 1E01 +1E02 1E03 +1E04 1E05 +1E06 1E07 +1E08 1E09 +1E0A 1E0B +1E0C 1E0D +1E0E 1E0F +1E10 1E11 +1E12 1E13 +1E14 1E15 +1E16 1E17 +1E18 1E19 +1E1A 1E1B +1E1C 1E1D +1E1E 1E1F +1E20 1E21 +1E22 1E23 +1E24 1E25 +1E26 1E27 +1E28 1E29 +1E2A 1E2B +1E2C 1E2D +1E2E 1E2F +1E30 1E31 +1E32 1E33 +1E34 1E35 +1E36 1E37 +1E38 1E39 +1E3A 1E3B +1E3C 1E3D +1E3E 1E3F +1E40 1E41 +1E42 1E43 +1E44 1E45 +1E46 1E47 +1E48 1E49 +1E4A 1E4B +1E4C 1E4D +1E4E 1E4F +1E50 1E51 +1E52 1E53 +1E54 1E55 +1E56 1E57 +1E58 1E59 +1E5A 1E5B +1E5C 1E5D +1E5E 1E5F +1E60 1E61 +1E62 1E63 +1E64 1E65 +1E66 1E67 +1E68 1E69 +1E6A 1E6B +1E6C 1E6D +1E6E 1E6F +1E70 1E71 +1E72 1E73 +1E74 1E75 +1E76 1E77 +1E78 1E79 +1E7A 1E7B +1E7C 1E7D +1E7E 1E7F +1E80 1E81 +1E82 1E83 +1E84 1E85 +1E86 1E87 +1E88 1E89 +1E8A 1E8B +1E8C 1E8D +1E8E 1E8F +1E90 1E91 +1E92 1E93 +1E94 1E95 +1EA0 1EA1 +1EA2 1EA3 +1EA4 1EA5 +1EA6 1EA7 +1EA8 1EA9 +1EAA 1EAB +1EAC 1EAD +1EAE 1EAF +1EB0 1EB1 +1EB2 1EB3 +1EB4 1EB5 +1EB6 1EB7 +1EB8 1EB9 +1EBA 1EBB +1EBC 1EBD +1EBE 1EBF +1EC0 1EC1 +1EC2 1EC3 +1EC4 1EC5 +1EC6 1EC7 +1EC8 1EC9 +1ECA 1ECB +1ECC 1ECD +1ECE 1ECF +1ED0 1ED1 +1ED2 1ED3 +1ED4 1ED5 +1ED6 1ED7 +1ED8 1ED9 +1EDA 1EDB +1EDC 1EDD +1EDE 1EDF +1EE0 1EE1 +1EE2 1EE3 +1EE4 1EE5 +1EE6 1EE7 +1EE8 1EE9 +1EEA 1EEB +1EEC 1EED +1EEE 1EEF +1EF0 1EF1 +1EF2 1EF3 +1EF4 1EF5 +1EF6 1EF7 +1EF8 1EF9 +1F08 1F00 +1F09 1F01 +1F0A 1F02 +1F0B 1F03 +1F0C 1F04 +1F0D 1F05 +1F0E 1F06 +1F0F 1F07 +1F18 1F10 +1F19 1F11 +1F1A 1F12 +1F1B 1F13 +1F1C 1F14 +1F1D 1F15 +1F28 1F20 +1F29 1F21 +1F2A 1F22 +1F2B 1F23 +1F2C 1F24 +1F2D 1F25 +1F2E 1F26 +1F2F 1F27 +1F38 1F30 +1F39 1F31 +1F3A 1F32 +1F3B 1F33 +1F3C 1F34 +1F3D 1F35 +1F3E 1F36 +1F3F 1F37 +1F48 1F40 +1F49 1F41 +1F4A 1F42 +1F4B 1F43 +1F4C 1F44 +1F4D 1F45 +1F59 1F51 +1F5B 1F53 +1F5D 1F55 +1F5F 1F57 +1F68 1F60 +1F69 1F61 +1F6A 1F62 +1F6B 1F63 +1F6C 1F64 +1F6D 1F65 +1F6E 1F66 +1F6F 1F67 +1FB8 1FB0 +1FB9 1FB1 +1FBA 1F70 +1FBB 1F71 +1FC8 1F72 +1FC9 1F73 +1FCA 1F74 +1FCB 1F75 +1FD8 1FD0 +1FD9 1FD1 +1FDA 1F76 +1FDB 1F77 +1FE8 1FE0 +1FE9 1FE1 +1FEA 1F7A +1FEB 1F7B +1FEC 1FE5 +1FF8 1F78 +1FF9 1F79 +1FFA 1F7C +1FFB 1F7D +2126 03C9 +212A 006B +212B 00E5 +2160 2170 +2161 2171 +2162 2172 +2163 2173 +2164 2174 +2165 2175 +2166 2176 +2167 2177 +2168 2178 +2169 2179 +216A 217A +216B 217B +216C 217C +216D 217D +216E 217E +216F 217F +24B6 24D0 +24B7 24D1 +24B8 24D2 +24B9 24D3 +24BA 24D4 +24BB 24D5 +24BC 24D6 +24BD 24D7 +24BE 24D8 +24BF 24D9 +24C0 24DA +24C1 24DB +24C2 24DC +24C3 24DD +24C4 24DE +24C5 24DF +24C6 24E0 +24C7 24E1 +24C8 24E2 +24C9 24E3 +24CA 24E4 +24CB 24E5 +24CC 24E6 +24CD 24E7 +24CE 24E8 +24CF 24E9 +2C00 2C30 +2C01 2C31 +2C02 2C32 +2C03 2C33 +2C04 2C34 +2C05 2C35 +2C06 2C36 +2C07 2C37 +2C08 2C38 +2C09 2C39 +2C0A 2C3A +2C0B 2C3B +2C0C 2C3C +2C0D 2C3D +2C0E 2C3E +2C0F 2C3F +2C10 2C40 +2C11 2C41 +2C12 2C42 +2C13 2C43 +2C14 2C44 +2C15 2C45 +2C16 2C46 +2C17 2C47 +2C18 2C48 +2C19 2C49 +2C1A 2C4A +2C1B 2C4B +2C1C 2C4C +2C1D 2C4D +2C1E 2C4E +2C1F 2C4F +2C20 2C50 +2C21 2C51 +2C22 2C52 +2C23 2C53 +2C24 2C54 +2C25 2C55 +2C26 2C56 +2C27 2C57 +2C28 2C58 +2C29 2C59 +2C2A 2C5A +2C2B 2C5B +2C2C 2C5C +2C2D 2C5D +2C2E 2C5E +2C80 2C81 +2C82 2C83 +2C84 2C85 +2C86 2C87 +2C88 2C89 +2C8A 2C8B +2C8C 2C8D +2C8E 2C8F +2C90 2C91 +2C92 2C93 +2C94 2C95 +2C96 2C97 +2C98 2C99 +2C9A 2C9B +2C9C 2C9D +2C9E 2C9F +2CA0 2CA1 +2CA2 2CA3 +2CA4 2CA5 +2CA6 2CA7 +2CA8 2CA9 +2CAA 2CAB +2CAC 2CAD +2CAE 2CAF +2CB0 2CB1 +2CB2 2CB3 +2CB4 2CB5 +2CB6 2CB7 +2CB8 2CB9 +2CBA 2CBB +2CBC 2CBD +2CBE 2CBF +2CC0 2CC1 +2CC2 2CC3 +2CC4 2CC5 +2CC6 2CC7 +2CC8 2CC9 +2CCA 2CCB +2CCC 2CCD +2CCE 2CCF +2CD0 2CD1 +2CD2 2CD3 +2CD4 2CD5 +2CD6 2CD7 +2CD8 2CD9 +2CDA 2CDB +2CDC 2CDD +2CDE 2CDF +2CE0 2CE1 +2CE2 2CE3 +FF21 FF41 +FF22 FF42 +FF23 FF43 +FF24 FF44 +FF25 FF45 +FF26 FF46 +FF27 FF47 +FF28 FF48 +FF29 FF49 +FF2A FF4A +FF2B FF4B +FF2C FF4C +FF2D FF4D +FF2E FF4E +FF2F FF4F +FF30 FF50 +FF31 FF51 +FF32 FF52 +FF33 FF53 +FF34 FF54 +FF35 FF55 +FF36 FF56 +FF37 FF57 +FF38 FF58 +FF39 FF59 +FF3A FF5A +10400 10428 +10401 10429 +10402 1042A +10403 1042B +10404 1042C +10405 1042D +10406 1042E +10407 1042F +10408 10430 +10409 10431 +1040A 10432 +1040B 10433 +1040C 10434 +1040D 10435 +1040E 10436 +1040F 10437 +10410 10438 +10411 10439 +10412 1043A +10413 1043B +10414 1043C +10415 1043D +10416 1043E +10417 1043F +10418 10440 +10419 10441 +1041A 10442 +1041B 10443 +1041C 10444 +1041D 10445 +1041E 10446 +1041F 10447 +10420 10448 +10421 10449 +10422 1044A +10423 1044B +10424 1044C +10425 1044D +10426 1044E +10427 1044F +END diff --git a/Master/tlpkg/installer/perllib/unicore/lib/gc_sc/Uppercas.pl b/Master/tlpkg/installer/perllib/unicore/lib/gc_sc/Uppercas.pl new file mode 100644 index 00000000000..4778dc3ab52 --- /dev/null +++ b/Master/tlpkg/installer/perllib/unicore/lib/gc_sc/Uppercas.pl @@ -0,0 +1,490 @@ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by mktables from e.g. UnicodeData.txt. +# Any changes made here will be lost! + +# +# This file supports: +# \p{Uppercase} (and fuzzy permutations) +# +# Meaning: [\p{Lu}\p{Other_Uppercase}] +# +return <<'END'; +0041 005A +00C0 00D6 +00D8 00DE +0100 +0102 +0104 +0106 +0108 +010A +010C +010E +0110 +0112 +0114 +0116 +0118 +011A +011C +011E +0120 +0122 +0124 +0126 +0128 +012A +012C +012E +0130 +0132 +0134 +0136 +0139 +013B +013D +013F +0141 +0143 +0145 +0147 +014A +014C +014E +0150 +0152 +0154 +0156 +0158 +015A +015C +015E +0160 +0162 +0164 +0166 +0168 +016A +016C +016E +0170 +0172 +0174 +0176 +0178 0179 +017B +017D +0181 0182 +0184 +0186 0187 +0189 018B +018E 0191 +0193 0194 +0196 0198 +019C 019D +019F 01A0 +01A2 +01A4 +01A6 01A7 +01A9 +01AC +01AE 01AF +01B1 01B3 +01B5 +01B7 01B8 +01BC +01C4 +01C7 +01CA +01CD +01CF +01D1 +01D3 +01D5 +01D7 +01D9 +01DB +01DE +01E0 +01E2 +01E4 +01E6 +01E8 +01EA +01EC +01EE +01F1 +01F4 +01F6 01F8 +01FA +01FC +01FE +0200 +0202 +0204 +0206 +0208 +020A +020C +020E +0210 +0212 +0214 +0216 +0218 +021A +021C +021E +0220 +0222 +0224 +0226 +0228 +022A +022C +022E +0230 +0232 +023A 023B +023D 023E +0241 +0386 +0388 038A +038C +038E 038F +0391 03A1 +03A3 03AB +03D2 03D4 +03D8 +03DA +03DC +03DE +03E0 +03E2 +03E4 +03E6 +03E8 +03EA +03EC +03EE +03F4 +03F7 +03F9 03FA +03FD 042F +0460 +0462 +0464 +0466 +0468 +046A +046C +046E +0470 +0472 +0474 +0476 +0478 +047A +047C +047E +0480 +048A +048C +048E +0490 +0492 +0494 +0496 +0498 +049A +049C +049E +04A0 +04A2 +04A4 +04A6 +04A8 +04AA +04AC +04AE +04B0 +04B2 +04B4 +04B6 +04B8 +04BA +04BC +04BE +04C0 04C1 +04C3 +04C5 +04C7 +04C9 +04CB +04CD +04D0 +04D2 +04D4 +04D6 +04D8 +04DA +04DC +04DE +04E0 +04E2 +04E4 +04E6 +04E8 +04EA +04EC +04EE +04F0 +04F2 +04F4 +04F6 +04F8 +0500 +0502 +0504 +0506 +0508 +050A +050C +050E +0531 0556 +10A0 10C5 +1E00 +1E02 +1E04 +1E06 +1E08 +1E0A +1E0C +1E0E +1E10 +1E12 +1E14 +1E16 +1E18 +1E1A +1E1C +1E1E +1E20 +1E22 +1E24 +1E26 +1E28 +1E2A +1E2C +1E2E +1E30 +1E32 +1E34 +1E36 +1E38 +1E3A +1E3C +1E3E +1E40 +1E42 +1E44 +1E46 +1E48 +1E4A +1E4C +1E4E +1E50 +1E52 +1E54 +1E56 +1E58 +1E5A +1E5C +1E5E +1E60 +1E62 +1E64 +1E66 +1E68 +1E6A +1E6C +1E6E +1E70 +1E72 +1E74 +1E76 +1E78 +1E7A +1E7C +1E7E +1E80 +1E82 +1E84 +1E86 +1E88 +1E8A +1E8C +1E8E +1E90 +1E92 +1E94 +1EA0 +1EA2 +1EA4 +1EA6 +1EA8 +1EAA +1EAC +1EAE +1EB0 +1EB2 +1EB4 +1EB6 +1EB8 +1EBA +1EBC +1EBE +1EC0 +1EC2 +1EC4 +1EC6 +1EC8 +1ECA +1ECC +1ECE +1ED0 +1ED2 +1ED4 +1ED6 +1ED8 +1EDA +1EDC +1EDE +1EE0 +1EE2 +1EE4 +1EE6 +1EE8 +1EEA +1EEC +1EEE +1EF0 +1EF2 +1EF4 +1EF6 +1EF8 +1F08 1F0F +1F18 1F1D +1F28 1F2F +1F38 1F3F +1F48 1F4D +1F59 +1F5B +1F5D +1F5F +1F68 1F6F +1FB8 1FBB +1FC8 1FCB +1FD8 1FDB +1FE8 1FEC +1FF8 1FFB +2102 +2107 +210B 210D +2110 2112 +2115 +2119 211D +2124 +2126 +2128 +212A 212D +2130 2131 +2133 +213E 213F +2145 +2160 216F +24B6 24CF +2C00 2C2E +2C80 +2C82 +2C84 +2C86 +2C88 +2C8A +2C8C +2C8E +2C90 +2C92 +2C94 +2C96 +2C98 +2C9A +2C9C +2C9E +2CA0 +2CA2 +2CA4 +2CA6 +2CA8 +2CAA +2CAC +2CAE +2CB0 +2CB2 +2CB4 +2CB6 +2CB8 +2CBA +2CBC +2CBE +2CC0 +2CC2 +2CC4 +2CC6 +2CC8 +2CCA +2CCC +2CCE +2CD0 +2CD2 +2CD4 +2CD6 +2CD8 +2CDA +2CDC +2CDE +2CE0 +2CE2 +FF21 FF3A +10400 10427 +1D400 1D419 +1D434 1D44D +1D468 1D481 +1D49C +1D49E 1D49F +1D4A2 +1D4A5 1D4A6 +1D4A9 1D4AC +1D4AE 1D4B5 +1D4D0 1D4E9 +1D504 1D505 +1D507 1D50A +1D50D 1D514 +1D516 1D51C +1D538 1D539 +1D53B 1D53E +1D540 1D544 +1D546 +1D54A 1D550 +1D56C 1D585 +1D5A0 1D5B9 +1D5D4 1D5ED +1D608 1D621 +1D63C 1D655 +1D670 1D689 +1D6A8 1D6C0 +1D6E2 1D6FA +1D71C 1D734 +1D756 1D76E +1D790 1D7A8 +END diff --git a/Master/tlpkg/installer/perllib/utf8.pm b/Master/tlpkg/installer/perllib/utf8.pm new file mode 100644 index 00000000000..56c991bef9a --- /dev/null +++ b/Master/tlpkg/installer/perllib/utf8.pm @@ -0,0 +1,214 @@ +package utf8; + +$utf8::hint_bits = 0x00800000; + +our $VERSION = '1.06'; + +sub import { + $^H |= $utf8::hint_bits; + $enc{caller()} = $_[1] if $_[1]; +} + +sub unimport { + $^H &= ~$utf8::hint_bits; +} + +sub AUTOLOAD { + require "utf8_heavy.pl"; + goto &$AUTOLOAD if defined &$AUTOLOAD; + require Carp; + Carp::croak("Undefined subroutine $AUTOLOAD called"); +} + +1; +__END__ + +=head1 NAME + +utf8 - Perl pragma to enable/disable UTF-8 (or UTF-EBCDIC) in source code + +=head1 SYNOPSIS + + use utf8; + no utf8; + + # Convert a Perl scalar to/from UTF-8. + $num_octets = utf8::upgrade($string); + $success = utf8::downgrade($string[, FAIL_OK]); + + # Change the native bytes of a Perl scalar to/from UTF-8 bytes. + utf8::encode($string); + utf8::decode($string); + + $flag = utf8::is_utf8(STRING); # since Perl 5.8.1 + $flag = utf8::valid(STRING); + +=head1 DESCRIPTION + +The C<use utf8> pragma tells the Perl parser to allow UTF-8 in the +program text in the current lexical scope (allow UTF-EBCDIC on EBCDIC based +platforms). The C<no utf8> pragma tells Perl to switch back to treating +the source text as literal bytes in the current lexical scope. + +This pragma is primarily a compatibility device. Perl versions +earlier than 5.6 allowed arbitrary bytes in source code, whereas +in future we would like to standardize on the UTF-8 encoding for +source text. + +B<Do not use this pragma for anything else than telling Perl that your +script is written in UTF-8.> The utility functions described below are +useful for their own purposes, but they are not really part of the +"pragmatic" effect. + +Until UTF-8 becomes the default format for source text, either this +pragma or the L<encoding> pragma should be used to recognize UTF-8 +in the source. When UTF-8 becomes the standard source format, this +pragma will effectively become a no-op. For convenience in what +follows the term I<UTF-X> is used to refer to UTF-8 on ASCII and ISO +Latin based platforms and UTF-EBCDIC on EBCDIC based platforms. + +See also the effects of the C<-C> switch and its cousin, the +C<$ENV{PERL_UNICODE}>, in L<perlrun>. + +Enabling the C<utf8> pragma has the following effect: + +=over 4 + +=item * + +Bytes in the source text that have their high-bit set will be treated +as being part of a literal UTF-8 character. This includes most +literals such as identifier names, string constants, and constant +regular expression patterns. + +On EBCDIC platforms characters in the Latin 1 character set are +treated as being part of a literal UTF-EBCDIC character. + +=back + +Note that if you have bytes with the eighth bit on in your script +(for example embedded Latin-1 in your string literals), C<use utf8> +will be unhappy since the bytes are most probably not well-formed +UTF-8. If you want to have such bytes and use utf8, you can disable +utf8 until the end the block (or file, if at top level) by C<no utf8;>. + +If you want to automatically upgrade your 8-bit legacy bytes to UTF-8, +use the L<encoding> pragma instead of this pragma. For example, if +you want to implicitly upgrade your ISO 8859-1 (Latin-1) bytes to UTF-8 +as used in e.g. C<chr()> and C<\x{...}>, try this: + + use encoding "latin-1"; + my $c = chr(0xc4); + my $x = "\x{c5}"; + +In case you are wondering: yes, C<use encoding 'utf8';> works much +the same as C<use utf8;>. + +=head2 Utility functions + +The following functions are defined in the C<utf8::> package by the +Perl core. You do not need to say C<use utf8> to use these and in fact +you should not say that unless you really want to have UTF-8 source code. + +=over 4 + +=item * $num_octets = utf8::upgrade($string) + +Converts in-place the octet sequence in the native encoding +(Latin-1 or EBCDIC) to the equivalent character sequence in I<UTF-X>. +I<$string> already encoded as characters does no harm. +Returns the number of octets necessary to represent the string as I<UTF-X>. +Can be used to make sure that the UTF-8 flag is on, +so that C<\w> or C<lc()> work as Unicode on strings +containing characters in the range 0x80-0xFF (on ASCII and +derivatives). + +B<Note that this function does not handle arbitrary encodings.> +Therefore I<Encode.pm> is recommended for the general purposes. + +Affected by the encoding pragma. + +=item * $success = utf8::downgrade($string[, FAIL_OK]) + +Converts in-place the character sequence in I<UTF-X> +to the equivalent octet sequence in the native encoding (Latin-1 or EBCDIC). +I<$string> already encoded as octets does no harm. +Returns true on success. On failure dies or, if the value of +C<FAIL_OK> is true, returns false. +Can be used to make sure that the UTF-8 flag is off, +e.g. when you want to make sure that the substr() or length() function +works with the usually faster byte algorithm. + +B<Note that this function does not handle arbitrary encodings.> +Therefore I<Encode.pm> is recommended for the general purposes. + +B<Not> affected by the encoding pragma. + +B<NOTE:> this function is experimental and may change +or be removed without notice. + +=item * utf8::encode($string) + +Converts in-place the character sequence to the corresponding octet sequence +in I<UTF-X>. The UTF-8 flag is turned off. Returns nothing. + +B<Note that this function does not handle arbitrary encodings.> +Therefore I<Encode.pm> is recommended for the general purposes. + +=item * utf8::decode($string) + +Attempts to convert in-place the octet sequence in I<UTF-X> +to the corresponding character sequence. The UTF-8 flag is turned on +only if the source string contains multiple-byte I<UTF-X> characters. +If I<$string> is invalid as I<UTF-X>, returns false; otherwise returns true. + +B<Note that this function does not handle arbitrary encodings.> +Therefore I<Encode.pm> is recommended for the general purposes. + +B<NOTE:> this function is experimental and may change +or be removed without notice. + +=item * $flag = utf8::is_utf8(STRING) + +(Since Perl 5.8.1) Test whether STRING is in UTF-8. Functionally +the same as Encode::is_utf8(). + +=item * $flag = utf8::valid(STRING) + +[INTERNAL] Test whether STRING is in a consistent state regarding +UTF-8. Will return true is well-formed UTF-8 and has the UTF-8 flag +on B<or> if string is held as bytes (both these states are 'consistent'). +Main reason for this routine is to allow Perl's testsuite to check +that operations have left strings in a consistent state. You most +probably want to use utf8::is_utf8() instead. + +=back + +C<utf8::encode> is like C<utf8::upgrade>, but the UTF8 flag is +cleared. See L<perlunicode> for more on the UTF8 flag and the C API +functions C<sv_utf8_upgrade>, C<sv_utf8_downgrade>, C<sv_utf8_encode>, +and C<sv_utf8_decode>, which are wrapped by the Perl functions +C<utf8::upgrade>, C<utf8::downgrade>, C<utf8::encode> and +C<utf8::decode>. Note that in the Perl 5.8.0 and 5.8.1 implementation +the functions utf8::is_utf8, utf8::valid, utf8::encode, utf8::decode, +utf8::upgrade, and utf8::downgrade are always available, without a +C<require utf8> statement-- this may change in future releases. + +=head1 BUGS + +One can have Unicode in identifier names, but not in package/class or +subroutine names. While some limited functionality towards this does +exist as of Perl 5.8.0, that is more accidental than designed; use of +Unicode for the said purposes is unsupported. + +One reason of this unfinishedness is its (currently) inherent +unportability: since both package names and subroutine names may need +to be mapped to file and directory names, the Unicode capability of +the filesystem becomes important-- and there unfortunately aren't +portable answers. + +=head1 SEE ALSO + +L<perluniintro>, L<encoding>, L<perlrun>, L<bytes>, L<perlunicode> + +=cut diff --git a/Master/tlpkg/installer/perllib/utf8_heavy.pl b/Master/tlpkg/installer/perllib/utf8_heavy.pl new file mode 100644 index 00000000000..b6fdeb997b3 --- /dev/null +++ b/Master/tlpkg/installer/perllib/utf8_heavy.pl @@ -0,0 +1,412 @@ +package utf8; +use strict; +use warnings; + +sub DEBUG () { 0 } + +sub DESTROY {} + +my %Cache; + +our (%PropertyAlias, %PA_reverse, %PropValueAlias, %PVA_reverse, %PVA_abbr_map); + +sub croak { require Carp; Carp::croak(@_) } + +## +## "SWASH" == "SWATCH HASH". A "swatch" is a swatch of the Unicode landscape. +## It's a data structure that encodes a set of Unicode characters. +## + +sub SWASHNEW { + my ($class, $type, $list, $minbits, $none) = @_; + local $^D = 0 if $^D; + + print STDERR "SWASHNEW @_\n" if DEBUG; + + ## + ## Get the list of codepoints for the type. + ## Called from utf8.c + ## + ## Given a $type, our goal is to fill $list with the set of codepoint + ## ranges. + ## + ## To make the parsing of $type clear, this code takes the a rather + ## unorthodox approach of last'ing out of the block once we have the + ## info we need. Were this to be a subroutine, the 'last' would just + ## be a 'return'. + ## + my $file; ## file to load data from, and also part of the %Cache key. + my $ListSorted = 0; + + if ($type) + { + $type =~ s/^\s+//; + $type =~ s/\s+$//; + + print "type = $type\n" if DEBUG; + + GETFILE: + { + ## + ## It could be a user-defined property. + ## + + my $caller1 = $type =~ s/(.+)::// ? $1 : caller(1); + + if (defined $caller1 && $type =~ /^(?:\w+)$/) { + my $prop = "${caller1}::$type"; + if (exists &{$prop}) { + no strict 'refs'; + + $list = &{$prop}; + last GETFILE; + } + } + + my $wasIs; + + ($wasIs = $type =~ s/^Is(?:\s+|[-_])?//i) + or + $type =~ s/^(?:(?:General(?:\s+|_)?)?Category|gc)\s*[:=]\s*//i + or + $type =~ s/^(?:Script|sc)\s*[:=]\s*//i + or + $type =~ s/^Block\s*[:=]\s*/In/i; + + + ## + ## See if it's in some enumeration. + ## + require "unicore/PVA.pl"; + if ($type =~ /^([\w\s]+)[:=]\s*(.*)/) { + my ($enum, $val) = (lc $1, lc $2); + $enum =~ tr/ _-//d; + $val =~ tr/ _-//d; + + my $pa = $PropertyAlias{$enum} ? $enum : $PA_reverse{$enum}; + my $f = $PropValueAlias{$pa}{$val} ? $val : $PVA_reverse{$pa}{lc $val}; + + if ($pa and $f) { + $pa = "gc_sc" if $pa eq "gc" or $pa eq "sc"; + $file = "unicore/lib/$pa/$PVA_abbr_map{$pa}{lc $f}.pl"; + last GETFILE; + } + } + else { + my $t = lc $type; + $t =~ tr/ _-//d; + + if ($PropValueAlias{gc}{$t} or $PropValueAlias{sc}{$t}) { + $file = "unicore/lib/gc_sc/$PVA_abbr_map{gc_sc}{$t}.pl"; + last GETFILE; + } + } + + ## + ## See if it's in the direct mapping table. + ## + require "unicore/Exact.pl"; + if (my $base = $utf8::Exact{$type}) { + $file = "unicore/lib/gc_sc/$base.pl"; + last GETFILE; + } + + ## + ## If not there exactly, try the canonical form. The canonical + ## form is lowercased, with any separators (\s+|[-_]) removed. + ## + my $canonical = lc $type; + $canonical =~ s/(?<=[a-z\d])(?:\s+|[-_])(?=[a-z\d])//g; + print "canonical = $canonical\n" if DEBUG; + + require "unicore/Canonical.pl"; + if (my $base = ($utf8::Canonical{$canonical} || $utf8::Canonical{ lc $utf8::PropertyAlias{$canonical} })) { + $file = "unicore/lib/gc_sc/$base.pl"; + last GETFILE; + } + + ## + ## See if it's a user-level "To". + ## + + my $caller0 = caller(0); + + if (defined $caller0 && $type =~ /^To(?:\w+)$/) { + my $map = $caller0 . "::" . $type; + + if (exists &{$map}) { + no strict 'refs'; + + $list = &{$map}; + last GETFILE; + } + } + + ## + ## Last attempt -- see if it's a standard "To" name + ## (e.g. "ToLower") ToTitle is used by ucfirst(). + ## The user-level way to access ToDigit() and ToFold() + ## is to use Unicode::UCD. + ## + if ($type =~ /^To(Digit|Fold|Lower|Title|Upper)$/) + { + $file = "unicore/To/$1.pl"; + ## would like to test to see if $file actually exists.... + last GETFILE; + } + + ## + ## If we reach this line, it's because we couldn't figure + ## out what to do with $type. Ouch. + ## + + return $type; + } + + if (defined $file) { + print "found it (file='$file')\n" if DEBUG; + + ## + ## If we reach here, it was due to a 'last GETFILE' above + ## (exception: user-defined properties and mappings), so we + ## have a filename, so now we load it if we haven't already. + ## If we have, return the cached results. The cache key is the + ## file to load. + ## + if ($Cache{$file} and ref($Cache{$file}) eq $class) + { + print "Returning cached '$file' for \\p{$type}\n" if DEBUG; + return $Cache{$class, $file}; + } + + $list = do $file; + } + + $ListSorted = 1; ## we know that these lists are sorted + } + + my $extras; + my $bits = 0; + + my $ORIG = $list; + if ($list) { + my @tmp = split(/^/m, $list); + my %seen; + no warnings; + $extras = join '', grep /^[^0-9a-fA-F]/, @tmp; + $list = join '', + map { $_->[1] } + sort { $a->[0] <=> $b->[0] } + map { /^([0-9a-fA-F]+)/; [ hex($1), $_ ] } + grep { /^([0-9a-fA-F]+)/ and not $seen{$1}++ } @tmp; # XXX doesn't do ranges right + } + + if ($none) { + my $hextra = sprintf "%04x", $none + 1; + $list =~ s/\tXXXX$/\t$hextra/mg; + } + + if ($minbits < 32) { + my $top = 0; + while ($list =~ /^([0-9a-fA-F]+)(?:[\t]([0-9a-fA-F]+)?)(?:[ \t]([0-9a-fA-F]+))?/mg) { + my $min = hex $1; + my $max = defined $2 ? hex $2 : $min; + my $val = defined $3 ? hex $3 : 0; + $val += $max - $min if defined $3; + $top = $val if $val > $top; + } + $bits = + $top > 0xffff ? 32 : + $top > 0xff ? 16 : + $top > 1 ? 8 : 1 + } + $bits = $minbits if $bits < $minbits; + + my @extras; + for my $x ($extras) { + pos $x = 0; + while ($x =~ /^([^0-9a-fA-F\n])(.*)/mg) { + my $char = $1; + my $name = $2; + print STDERR "$1 => $2\n" if DEBUG; + if ($char =~ /[-+!&]/) { + my ($c,$t) = split(/::/, $name, 2); # bogus use of ::, really + my $subobj; + if ($c eq 'utf8') { + $subobj = utf8->SWASHNEW($t, "", 0, 0, 0); + } + elsif (exists &$name) { + $subobj = utf8->SWASHNEW($name, "", 0, 0, 0); + } + elsif ($c =~ /^([0-9a-fA-F]+)/) { + $subobj = utf8->SWASHNEW("", $c, 0, 0, 0); + } + return $subobj unless ref $subobj; + push @extras, $name => $subobj; + $bits = $subobj->{BITS} if $bits < $subobj->{BITS}; + } + } + } + + print STDERR "CLASS = $class, TYPE => $type, BITS => $bits, NONE => $none\nEXTRAS =>\n$extras\nLIST =>\n$list\n" if DEBUG; + + my $SWASH = bless { + TYPE => $type, + BITS => $bits, + EXTRAS => $extras, + LIST => $list, + NONE => $none, + @extras, + } => $class; + + if ($file) { + $Cache{$class, $file} = $SWASH; + } + + return $SWASH; +} + +# NOTE: utf8.c:swash_init() assumes entries are never modified once generated. + +sub SWASHGET { + # See utf8.c:Perl_swash_fetch for problems with this interface. + my ($self, $start, $len) = @_; + local $^D = 0 if $^D; + my $type = $self->{TYPE}; + my $bits = $self->{BITS}; + my $none = $self->{NONE}; + print STDERR "SWASHGET @_ [$type/$bits/$none]\n" if DEBUG; + my $end = $start + $len; + my $swatch = ""; + my $key; + vec($swatch, $len - 1, $bits) = 0; # Extend to correct length. + if ($none) { + for $key (0 .. $len - 1) { vec($swatch, $key, $bits) = $none } + } + + for ($self->{LIST}) { + pos $_ = 0; + if ($bits > 1) { + LINE: + while (/^([0-9a-fA-F]+)(?:[ \t]([0-9a-fA-F]+)?)?(?:[ \t]([0-9a-fA-F]+))?/mg) { + chomp; + my ($a, $b, $c) = ($1, $2, $3); + croak "$type: illegal mapping '$_'" + if $type =~ /^To/ && + !(defined $a && defined $c); + my $min = hex $a; + my $max = defined $b ? hex $b : $min; + my $val = defined $c ? hex $c : 0; + next if $max < $start; + print "$min $max $val\n" if DEBUG; + if ($none) { + if ($min < $start) { + $val += $start - $min if $val < $none; + $min = $start; + } + for ($key = $min; $key <= $max; $key++) { + last LINE if $key >= $end; + print STDERR "$key => $val\n" if DEBUG; + vec($swatch, $key - $start, $bits) = $val; + ++$val if $val < $none; + } + } + else { + if ($min < $start) { + $val += $start - $min; + $min = $start; + } + for ($key = $min; $key <= $max; $key++, $val++) { + last LINE if $key >= $end; + print STDERR "$key => $val\n" if DEBUG; + vec($swatch, $key - $start, $bits) = $val; + } + } + } + } + else { + LINE: + while (/^([0-9a-fA-F]+)(?:[ \t]+([0-9a-fA-F]+))?/mg) { + chomp; + my $min = hex $1; + my $max = defined $2 ? hex $2 : $min; + next if $max < $start; + if ($min < $start) { + $min = $start; + } + for ($key = $min; $key <= $max; $key++) { + last LINE if $key >= $end; + print STDERR "$key => 1\n" if DEBUG; + vec($swatch, $key - $start, 1) = 1; + } + } + } + } + for my $x ($self->{EXTRAS}) { + pos $x = 0; + while ($x =~ /^([-+!&])(.*)/mg) { + my $char = $1; + my $name = $2; + print STDERR "INDIRECT $1 $2\n" if DEBUG; + my $otherbits = $self->{$name}->{BITS}; + croak("SWASHGET size mismatch") if $bits < $otherbits; + my $other = $self->{$name}->SWASHGET($start, $len); + if ($char eq '+') { + if ($bits == 1 and $otherbits == 1) { + $swatch |= $other; + } + else { + for ($key = 0; $key < $len; $key++) { + vec($swatch, $key, $bits) = vec($other, $key, $otherbits); + } + } + } + elsif ($char eq '!') { + if ($bits == 1 and $otherbits == 1) { + $swatch |= ~$other; + } + else { + for ($key = 0; $key < $len; $key++) { + if (!vec($other, $key, $otherbits)) { + vec($swatch, $key, $bits) = 1; + } + } + } + } + elsif ($char eq '-') { + if ($bits == 1 and $otherbits == 1) { + $swatch &= ~$other; + } + else { + for ($key = 0; $key < $len; $key++) { + if (vec($other, $key, $otherbits)) { + vec($swatch, $key, $bits) = 0; + } + } + } + } + elsif ($char eq '&') { + if ($bits == 1 and $otherbits == 1) { + $swatch &= $other; + } + else { + for ($key = 0; $key < $len; $key++) { + if (!vec($other, $key, $otherbits)) { + vec($swatch, $key, $bits) = 0; + } + } + } + } + } + } + if (DEBUG) { + print STDERR "CELLS "; + for ($key = 0; $key < $len; $key++) { + print STDERR vec($swatch, $key, $bits), " "; + } + print STDERR "\n"; + } + $swatch; +} + +1; diff --git a/Master/tlpkg/installer/perllib/vars.pm b/Master/tlpkg/installer/perllib/vars.pm new file mode 100644 index 00000000000..a0151b84030 --- /dev/null +++ b/Master/tlpkg/installer/perllib/vars.pm @@ -0,0 +1,82 @@ +package vars; + +use 5.006; + +our $VERSION = '1.01'; + +use warnings::register; +use strict qw(vars subs); + +sub import { + my $callpack = caller; + my ($pack, @imports) = @_; + my ($sym, $ch); + foreach (@imports) { + if (($ch, $sym) = /^([\$\@\%\*\&])(.+)/) { + if ($sym =~ /\W/) { + # time for a more-detailed check-up + if ($sym =~ /^\w+[[{].*[]}]$/) { + require Carp; + Carp::croak("Can't declare individual elements of hash or array"); + } elsif (warnings::enabled() and length($sym) == 1 and $sym !~ tr/a-zA-Z//) { + warnings::warn("No need to declare built-in vars"); + } elsif (($^H &= strict::bits('vars'))) { + require Carp; + Carp::croak("'$_' is not a valid variable name under strict vars"); + } + } + $sym = "${callpack}::$sym" unless $sym =~ /::/; + *$sym = + ( $ch eq "\$" ? \$$sym + : $ch eq "\@" ? \@$sym + : $ch eq "\%" ? \%$sym + : $ch eq "\*" ? \*$sym + : $ch eq "\&" ? \&$sym + : do { + require Carp; + Carp::croak("'$_' is not a valid variable name"); + }); + } else { + require Carp; + Carp::croak("'$_' is not a valid variable name"); + } + } +}; + +1; +__END__ + +=head1 NAME + +vars - Perl pragma to predeclare global variable names (obsolete) + +=head1 SYNOPSIS + + use vars qw($frob @mung %seen); + +=head1 DESCRIPTION + +NOTE: For variables in the current package, the functionality provided +by this pragma has been superseded by C<our> declarations, available +in Perl v5.6.0 or later. See L<perlfunc/our>. + +This will predeclare all the variables whose names are +in the list, allowing you to use them under "use strict", and +disabling any typo warnings. + +Unlike pragmas that affect the C<$^H> hints variable, the C<use vars> and +C<use subs> declarations are not BLOCK-scoped. They are thus effective +for the entire file in which they appear. You may not rescind such +declarations with C<no vars> or C<no subs>. + +Packages such as the B<AutoLoader> and B<SelfLoader> that delay +loading of subroutines within packages can create problems with +package lexicals defined using C<my()>. While the B<vars> pragma +cannot duplicate the effect of package lexicals (total transparency +outside of the package), it can act as an acceptable substitute by +pre-declaring global symbols, ensuring their availability to the +later-loaded routines. + +See L<perlmodlib/Pragmatic Modules>. + +=cut diff --git a/Master/tlpkg/installer/perllib/warnings.pm b/Master/tlpkg/installer/perllib/warnings.pm new file mode 100644 index 00000000000..e43b686c908 --- /dev/null +++ b/Master/tlpkg/installer/perllib/warnings.pm @@ -0,0 +1,497 @@ +# -*- buffer-read-only: t -*- +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file was created by warnings.pl +# Any changes made here will be lost. +# + +package warnings; + +our $VERSION = '1.05'; + +=head1 NAME + +warnings - Perl pragma to control optional warnings + +=head1 SYNOPSIS + + use warnings; + no warnings; + + use warnings "all"; + no warnings "all"; + + use warnings::register; + if (warnings::enabled()) { + warnings::warn("some warning"); + } + + if (warnings::enabled("void")) { + warnings::warn("void", "some warning"); + } + + if (warnings::enabled($object)) { + warnings::warn($object, "some warning"); + } + + warnings::warnif("some warning"); + warnings::warnif("void", "some warning"); + warnings::warnif($object, "some warning"); + +=head1 DESCRIPTION + +The C<warnings> pragma is a replacement for the command line flag C<-w>, +but the pragma is limited to the enclosing block, while the flag is global. +See L<perllexwarn> for more information. + +If no import list is supplied, all possible warnings are either enabled +or disabled. + +A number of functions are provided to assist module authors. + +=over 4 + +=item use warnings::register + +Creates a new warnings category with the same name as the package where +the call to the pragma is used. + +=item warnings::enabled() + +Use the warnings category with the same name as the current package. + +Return TRUE if that warnings category is enabled in the calling module. +Otherwise returns FALSE. + +=item warnings::enabled($category) + +Return TRUE if the warnings category, C<$category>, is enabled in the +calling module. +Otherwise returns FALSE. + +=item warnings::enabled($object) + +Use the name of the class for the object reference, C<$object>, as the +warnings category. + +Return TRUE if that warnings category is enabled in the first scope +where the object is used. +Otherwise returns FALSE. + +=item warnings::warn($message) + +Print C<$message> to STDERR. + +Use the warnings category with the same name as the current package. + +If that warnings category has been set to "FATAL" in the calling module +then die. Otherwise return. + +=item warnings::warn($category, $message) + +Print C<$message> to STDERR. + +If the warnings category, C<$category>, has been set to "FATAL" in the +calling module then die. Otherwise return. + +=item warnings::warn($object, $message) + +Print C<$message> to STDERR. + +Use the name of the class for the object reference, C<$object>, as the +warnings category. + +If that warnings category has been set to "FATAL" in the scope where C<$object> +is first used then die. Otherwise return. + + +=item warnings::warnif($message) + +Equivalent to: + + if (warnings::enabled()) + { warnings::warn($message) } + +=item warnings::warnif($category, $message) + +Equivalent to: + + if (warnings::enabled($category)) + { warnings::warn($category, $message) } + +=item warnings::warnif($object, $message) + +Equivalent to: + + if (warnings::enabled($object)) + { warnings::warn($object, $message) } + +=back + +See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>. + +=cut + +use Carp (); + +our %Offsets = ( + + # Warnings Categories added in Perl 5.008 + + 'all' => 0, + 'closure' => 2, + 'deprecated' => 4, + 'exiting' => 6, + 'glob' => 8, + 'io' => 10, + 'closed' => 12, + 'exec' => 14, + 'layer' => 16, + 'newline' => 18, + 'pipe' => 20, + 'unopened' => 22, + 'misc' => 24, + 'numeric' => 26, + 'once' => 28, + 'overflow' => 30, + 'pack' => 32, + 'portable' => 34, + 'recursion' => 36, + 'redefine' => 38, + 'regexp' => 40, + 'severe' => 42, + 'debugging' => 44, + 'inplace' => 46, + 'internal' => 48, + 'malloc' => 50, + 'signal' => 52, + 'substr' => 54, + 'syntax' => 56, + 'ambiguous' => 58, + 'bareword' => 60, + 'digit' => 62, + 'parenthesis' => 64, + 'precedence' => 66, + 'printf' => 68, + 'prototype' => 70, + 'qw' => 72, + 'reserved' => 74, + 'semicolon' => 76, + 'taint' => 78, + 'threads' => 80, + 'uninitialized' => 82, + 'unpack' => 84, + 'untie' => 86, + 'utf8' => 88, + 'void' => 90, + 'y2k' => 92, + ); + +our %Bits = ( + 'all' => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x15", # [0..46] + 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00", # [29] + 'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00", # [30] + 'closed' => "\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6] + 'closure' => "\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1] + 'debugging' => "\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00", # [22] + 'deprecated' => "\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2] + 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00", # [31] + 'exec' => "\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7] + 'exiting' => "\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3] + 'glob' => "\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4] + 'inplace' => "\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00", # [23] + 'internal' => "\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00", # [24] + 'io' => "\x00\x54\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..11] + 'layer' => "\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8] + 'malloc' => "\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00", # [25] + 'misc' => "\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00", # [12] + 'newline' => "\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9] + 'numeric' => "\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00", # [13] + 'once' => "\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00", # [14] + 'overflow' => "\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00", # [15] + 'pack' => "\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00", # [16] + 'parenthesis' => "\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00", # [32] + 'pipe' => "\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10] + 'portable' => "\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00", # [17] + 'precedence' => "\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00", # [33] + 'printf' => "\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00", # [34] + 'prototype' => "\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00", # [35] + 'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00", # [36] + 'recursion' => "\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00", # [18] + 'redefine' => "\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00", # [19] + 'regexp' => "\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00", # [20] + 'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00", # [37] + 'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00", # [38] + 'severe' => "\x00\x00\x00\x00\x00\x54\x05\x00\x00\x00\x00\x00", # [21..25] + 'signal' => "\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00", # [26] + 'substr' => "\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00", # [27] + 'syntax' => "\x00\x00\x00\x00\x00\x00\x00\x55\x55\x15\x00\x00", # [28..38] + 'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00", # [39] + 'threads' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00", # [40] + 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00", # [41] + 'unopened' => "\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11] + 'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00", # [42] + 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00", # [43] + 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01", # [44] + 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04", # [45] + 'y2k' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10", # [46] + ); + +our %DeadBits = ( + 'all' => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\x2a", # [0..46] + 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00", # [29] + 'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00", # [30] + 'closed' => "\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6] + 'closure' => "\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1] + 'debugging' => "\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00", # [22] + 'deprecated' => "\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2] + 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00", # [31] + 'exec' => "\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7] + 'exiting' => "\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3] + 'glob' => "\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4] + 'inplace' => "\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00", # [23] + 'internal' => "\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00", # [24] + 'io' => "\x00\xa8\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..11] + 'layer' => "\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8] + 'malloc' => "\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00", # [25] + 'misc' => "\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00", # [12] + 'newline' => "\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9] + 'numeric' => "\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00", # [13] + 'once' => "\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00", # [14] + 'overflow' => "\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00", # [15] + 'pack' => "\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00", # [16] + 'parenthesis' => "\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00", # [32] + 'pipe' => "\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10] + 'portable' => "\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00", # [17] + 'precedence' => "\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00", # [33] + 'printf' => "\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00", # [34] + 'prototype' => "\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00", # [35] + 'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00", # [36] + 'recursion' => "\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00", # [18] + 'redefine' => "\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00", # [19] + 'regexp' => "\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00", # [20] + 'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00", # [37] + 'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00", # [38] + 'severe' => "\x00\x00\x00\x00\x00\xa8\x0a\x00\x00\x00\x00\x00", # [21..25] + 'signal' => "\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00", # [26] + 'substr' => "\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00", # [27] + 'syntax' => "\x00\x00\x00\x00\x00\x00\x00\xaa\xaa\x2a\x00\x00", # [28..38] + 'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00", # [39] + 'threads' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00", # [40] + 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00", # [41] + 'unopened' => "\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11] + 'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00", # [42] + 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00", # [43] + 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02", # [44] + 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08", # [45] + 'y2k' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20", # [46] + ); + +$NONE = "\0\0\0\0\0\0\0\0\0\0\0\0"; +$LAST_BIT = 94 ; +$BYTES = 12 ; + +$All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ; + +sub Croaker +{ + local $Carp::CarpInternal{'warnings'}; + delete $Carp::CarpInternal{'warnings'}; + Carp::croak(@_); +} + +sub bits +{ + # called from B::Deparse.pm + + push @_, 'all' unless @_; + + my $mask; + my $catmask ; + my $fatal = 0 ; + my $no_fatal = 0 ; + + foreach my $word ( @_ ) { + if ($word eq 'FATAL') { + $fatal = 1; + $no_fatal = 0; + } + elsif ($word eq 'NONFATAL') { + $fatal = 0; + $no_fatal = 1; + } + elsif ($catmask = $Bits{$word}) { + $mask |= $catmask ; + $mask |= $DeadBits{$word} if $fatal ; + $mask &= ~($DeadBits{$word}|$All) if $no_fatal ; + } + else + { Croaker("Unknown warnings category '$word'")} + } + + return $mask ; +} + +sub import +{ + shift; + + my $catmask ; + my $fatal = 0 ; + my $no_fatal = 0 ; + + my $mask = ${^WARNING_BITS} ; + + if (vec($mask, $Offsets{'all'}, 1)) { + $mask |= $Bits{'all'} ; + $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1); + } + + push @_, 'all' unless @_; + + foreach my $word ( @_ ) { + if ($word eq 'FATAL') { + $fatal = 1; + $no_fatal = 0; + } + elsif ($word eq 'NONFATAL') { + $fatal = 0; + $no_fatal = 1; + } + elsif ($catmask = $Bits{$word}) { + $mask |= $catmask ; + $mask |= $DeadBits{$word} if $fatal ; + $mask &= ~($DeadBits{$word}|$All) if $no_fatal ; + } + else + { Croaker("Unknown warnings category '$word'")} + } + + ${^WARNING_BITS} = $mask ; +} + +sub unimport +{ + shift; + + my $catmask ; + my $mask = ${^WARNING_BITS} ; + + if (vec($mask, $Offsets{'all'}, 1)) { + $mask |= $Bits{'all'} ; + $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1); + } + + push @_, 'all' unless @_; + + foreach my $word ( @_ ) { + if ($word eq 'FATAL') { + next; + } + elsif ($catmask = $Bits{$word}) { + $mask &= ~($catmask | $DeadBits{$word} | $All); + } + else + { Croaker("Unknown warnings category '$word'")} + } + + ${^WARNING_BITS} = $mask ; +} + +my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = (); + +sub __chk +{ + my $category ; + my $offset ; + my $isobj = 0 ; + + if (@_) { + # check the category supplied. + $category = shift ; + if (my $type = ref $category) { + Croaker("not an object") + if exists $builtin_type{$type}; + $category = $type; + $isobj = 1 ; + } + $offset = $Offsets{$category}; + Croaker("Unknown warnings category '$category'") + unless defined $offset; + } + else { + $category = (caller(1))[0] ; + $offset = $Offsets{$category}; + Croaker("package '$category' not registered for warnings") + unless defined $offset ; + } + + my $this_pkg = (caller(1))[0] ; + my $i = 2 ; + my $pkg ; + + if ($isobj) { + while (do { { package DB; $pkg = (caller($i++))[0] } } ) { + last unless @DB::args && $DB::args[0] =~ /^$category=/ ; + } + $i -= 2 ; + } + else { + for ($i = 2 ; $pkg = (caller($i))[0] ; ++ $i) { + last if $pkg ne $this_pkg ; + } + $i = 2 + if !$pkg || $pkg eq $this_pkg ; + } + + my $callers_bitmask = (caller($i))[9] ; + return ($callers_bitmask, $offset, $i) ; +} + +sub enabled +{ + Croaker("Usage: warnings::enabled([category])") + unless @_ == 1 || @_ == 0 ; + + my ($callers_bitmask, $offset, $i) = __chk(@_) ; + + return 0 unless defined $callers_bitmask ; + return vec($callers_bitmask, $offset, 1) || + vec($callers_bitmask, $Offsets{'all'}, 1) ; +} + + +sub warn +{ + Croaker("Usage: warnings::warn([category,] 'message')") + unless @_ == 2 || @_ == 1 ; + + my $message = pop ; + my ($callers_bitmask, $offset, $i) = __chk(@_) ; + Carp::croak($message) + if vec($callers_bitmask, $offset+1, 1) || + vec($callers_bitmask, $Offsets{'all'}+1, 1) ; + Carp::carp($message) ; +} + +sub warnif +{ + Croaker("Usage: warnings::warnif([category,] 'message')") + unless @_ == 2 || @_ == 1 ; + + my $message = pop ; + my ($callers_bitmask, $offset, $i) = __chk(@_) ; + + return + unless defined $callers_bitmask && + (vec($callers_bitmask, $offset, 1) || + vec($callers_bitmask, $Offsets{'all'}, 1)) ; + + Carp::croak($message) + if vec($callers_bitmask, $offset+1, 1) || + vec($callers_bitmask, $Offsets{'all'}+1, 1) ; + + Carp::carp($message) ; +} + +1; +# ex: set ro: diff --git a/Master/tlpkg/installer/perllib/warnings/register.pm b/Master/tlpkg/installer/perllib/warnings/register.pm new file mode 100644 index 00000000000..57c865df522 --- /dev/null +++ b/Master/tlpkg/installer/perllib/warnings/register.pm @@ -0,0 +1,51 @@ +package warnings::register; + +our $VERSION = '1.01'; + +=pod + +=head1 NAME + +warnings::register - warnings import function + +=head1 SYNOPSIS + + use warnings::register; + +=head1 DESCRIPTION + +Creates a warnings category with the same name as the current package. + +See L<warnings> and L<perllexwarn> for more information on this module's +usage. + +=cut + +require warnings; + +sub mkMask +{ + my ($bit) = @_; + my $mask = ""; + + vec($mask, $bit, 1) = 1; + return $mask; +} + +sub import +{ + shift; + my $package = (caller(0))[0]; + if (! defined $warnings::Bits{$package}) { + $warnings::Bits{$package} = mkMask($warnings::LAST_BIT); + vec($warnings::Bits{'all'}, $warnings::LAST_BIT, 1) = 1; + $warnings::Offsets{$package} = $warnings::LAST_BIT ++; + foreach my $k (keys %warnings::Bits) { + vec($warnings::Bits{$k}, $warnings::LAST_BIT, 1) = 0; + } + $warnings::DeadBits{$package} = mkMask($warnings::LAST_BIT); + vec($warnings::DeadBits{'all'}, $warnings::LAST_BIT++, 1) = 1; + } +} + +1; |