diff options
| author | Norbert Preining <preining@logic.at> | 2008-02-08 10:43:34 +0000 |
|---|---|---|
| committer | Norbert Preining <preining@logic.at> | 2008-02-08 10:43:34 +0000 |
| commit | 89d71dbbefd096388626ed8196aac192402653a0 (patch) | |
| tree | 936b8863cd93f150432fa4cf5ac85830031e3993 /Master/tlpkg/lib | |
| parent | adacd50612f3170de7ba006c8aba8c844f994872 (diff) | |
move the perl installer lib also to tlpkg/installer
git-svn-id: svn://tug.org/texlive/trunk@6547 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/lib')
115 files changed, 0 insertions, 33392 deletions
diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/AutoLoader.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/AutoLoader.pm deleted file mode 100644 index 4352d8b1fbe..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/AutoLoader.pm +++ /dev/null @@ -1,343 +0,0 @@ -package AutoLoader; - -use strict; -use 5.006_001; - -our($VERSION, $AUTOLOAD); - -my $is_dosish; -my $is_epoc; -my $is_vms; -my $is_macos; - -BEGIN { - $is_dosish = $^O eq 'dos' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'NetWare'; - $is_epoc = $^O eq 'epoc'; - $is_vms = $^O eq 'VMS'; - $is_macos = $^O eq 'MacOS'; - $VERSION = '5.60'; -} - -AUTOLOAD { - my $sub = $AUTOLOAD; - my $filename; - # Braces used to preserve $1 et al. - { - # Try to find the autoloaded file from the package-qualified - # name of the sub. e.g., if the sub needed is - # Getopt::Long::GetOptions(), then $INC{Getopt/Long.pm} is - # something like '/usr/lib/perl5/Getopt/Long.pm', and the - # autoload file is '/usr/lib/perl5/auto/Getopt/Long/GetOptions.al'. - # - # However, if @INC is a relative path, this might not work. If, - # for example, @INC = ('lib'), then $INC{Getopt/Long.pm} is - # 'lib/Getopt/Long.pm', and we want to require - # 'auto/Getopt/Long/GetOptions.al' (without the leading 'lib'). - # In this case, we simple prepend the 'auto/' and let the - # C<require> take care of the searching for us. - - my ($pkg,$func) = ($sub =~ /(.*)::([^:]+)$/); - $pkg =~ s#::#/#g; - if (defined($filename = $INC{"$pkg.pm"})) { - if ($is_macos) { - $pkg =~ tr#/#:#; - $filename =~ s#^(.*)$pkg\.pm\z#$1auto:$pkg:$func.al#s; - } else { - $filename =~ s#^(.*)$pkg\.pm\z#$1auto/$pkg/$func.al#s; - } - - # if the file exists, then make sure that it is a - # a fully anchored path (i.e either '/usr/lib/auto/foo/bar.al', - # or './lib/auto/foo/bar.al'. This avoids C<require> searching - # (and failing) to find the 'lib/auto/foo/bar.al' because it - # looked for 'lib/lib/auto/foo/bar.al', given @INC = ('lib'). - - if (-r $filename) { - unless ($filename =~ m|^/|s) { - if ($is_dosish) { - unless ($filename =~ m{^([a-z]:)?[\\/]}is) { - if ($^O ne 'NetWare') { - $filename = "./$filename"; - } else { - $filename = "$filename"; - } - } - } - elsif ($is_epoc) { - unless ($filename =~ m{^([a-z?]:)?[\\/]}is) { - $filename = "./$filename"; - } - } - elsif ($is_vms) { - # XXX todo by VMSmiths - $filename = "./$filename"; - } - elsif (!$is_macos) { - $filename = "./$filename"; - } - } - } - else { - $filename = undef; - } - } - unless (defined $filename) { - # let C<require> do the searching - $filename = "auto/$sub.al"; - $filename =~ s#::#/#g; - } - } - my $save = $@; - local $!; # Do not munge the value. - eval { local $SIG{__DIE__}; require $filename }; - if ($@) { - if (substr($sub,-9) eq '::DESTROY') { - no strict 'refs'; - *$sub = sub {}; - $@ = undef; - } elsif ($@ =~ /^Can't locate/) { - # The load might just have failed because the filename was too - # long for some old SVR3 systems which treat long names as errors. - # If we can successfully truncate a long name then it's worth a go. - # There is a slight risk that we could pick up the wrong file here - # but autosplit should have warned about that when splitting. - if ($filename =~ s/(\w{12,})\.al$/substr($1,0,11).".al"/e){ - eval { local $SIG{__DIE__}; require $filename }; - } - } - if ($@){ - $@ =~ s/ at .*\n//; - my $error = $@; - require Carp; - Carp::croak($error); - } - } - $@ = $save; - goto &$sub; -} - -sub import { - my $pkg = shift; - my $callpkg = caller; - - # - # Export symbols, but not by accident of inheritance. - # - - if ($pkg eq 'AutoLoader') { - no strict 'refs'; - *{ $callpkg . '::AUTOLOAD' } = \&AUTOLOAD - if @_ and $_[0] =~ /^&?AUTOLOAD$/; - } - - # - # Try to find the autosplit index file. Eg., if the call package - # is POSIX, then $INC{POSIX.pm} is something like - # '/usr/local/lib/perl5/POSIX.pm', and the autosplit index file is in - # '/usr/local/lib/perl5/auto/POSIX/autosplit.ix', so we require that. - # - # However, if @INC is a relative path, this might not work. If, - # for example, @INC = ('lib'), then - # $INC{POSIX.pm} is 'lib/POSIX.pm', and we want to require - # 'auto/POSIX/autosplit.ix' (without the leading 'lib'). - # - - (my $calldir = $callpkg) =~ s#::#/#g; - my $path = $INC{$calldir . '.pm'}; - if (defined($path)) { - # Try absolute path name. - if ($is_macos) { - (my $malldir = $calldir) =~ tr#/#:#; - $path =~ s#^(.*)$malldir\.pm\z#$1auto:$malldir:autosplit.ix#s; - } else { - $path =~ s#^(.*)$calldir\.pm\z#$1auto/$calldir/autosplit.ix#; - } - - eval { require $path; }; - # If that failed, try relative path with normal @INC searching. - if ($@) { - $path ="auto/$calldir/autosplit.ix"; - eval { require $path; }; - } - if ($@) { - my $error = $@; - require Carp; - Carp::carp($error); - } - } -} - -sub unimport { - my $callpkg = caller; - - no strict 'refs'; - my $symname = $callpkg . '::AUTOLOAD'; - undef *{ $symname } if \&{ $symname } == \&AUTOLOAD; - *{ $symname } = \&{ $symname }; -} - -1; - -__END__ - -=head1 NAME - -AutoLoader - load subroutines only on demand - -=head1 SYNOPSIS - - package Foo; - use AutoLoader 'AUTOLOAD'; # import the default AUTOLOAD subroutine - - package Bar; - use AutoLoader; # don't import AUTOLOAD, define our own - sub AUTOLOAD { - ... - $AutoLoader::AUTOLOAD = "..."; - goto &AutoLoader::AUTOLOAD; - } - -=head1 DESCRIPTION - -The B<AutoLoader> module works with the B<AutoSplit> module and the -C<__END__> token to defer the loading of some subroutines until they are -used rather than loading them all at once. - -To use B<AutoLoader>, the author of a module has to place the -definitions of subroutines to be autoloaded after an C<__END__> token. -(See L<perldata>.) The B<AutoSplit> module can then be run manually to -extract the definitions into individual files F<auto/funcname.al>. - -B<AutoLoader> implements an AUTOLOAD subroutine. When an undefined -subroutine in is called in a client module of B<AutoLoader>, -B<AutoLoader>'s AUTOLOAD subroutine attempts to locate the subroutine in a -file with a name related to the location of the file from which the -client module was read. As an example, if F<POSIX.pm> is located in -F</usr/local/lib/perl5/POSIX.pm>, B<AutoLoader> will look for perl -subroutines B<POSIX> in F</usr/local/lib/perl5/auto/POSIX/*.al>, where -the C<.al> file has the same name as the subroutine, sans package. If -such a file exists, AUTOLOAD will read and evaluate it, -thus (presumably) defining the needed subroutine. AUTOLOAD will then -C<goto> the newly defined subroutine. - -Once this process completes for a given function, it is defined, so -future calls to the subroutine will bypass the AUTOLOAD mechanism. - -=head2 Subroutine Stubs - -In order for object method lookup and/or prototype checking to operate -correctly even when methods have not yet been defined it is necessary to -"forward declare" each subroutine (as in C<sub NAME;>). See -L<perlsub/"SYNOPSIS">. Such forward declaration creates "subroutine -stubs", which are place holders with no code. - -The AutoSplit and B<AutoLoader> modules automate the creation of forward -declarations. The AutoSplit module creates an 'index' file containing -forward declarations of all the AutoSplit subroutines. When the -AutoLoader module is 'use'd it loads these declarations into its callers -package. - -Because of this mechanism it is important that B<AutoLoader> is always -C<use>d and not C<require>d. - -=head2 Using B<AutoLoader>'s AUTOLOAD Subroutine - -In order to use B<AutoLoader>'s AUTOLOAD subroutine you I<must> -explicitly import it: - - use AutoLoader 'AUTOLOAD'; - -=head2 Overriding B<AutoLoader>'s AUTOLOAD Subroutine - -Some modules, mainly extensions, provide their own AUTOLOAD subroutines. -They typically need to check for some special cases (such as constants) -and then fallback to B<AutoLoader>'s AUTOLOAD for the rest. - -Such modules should I<not> import B<AutoLoader>'s AUTOLOAD subroutine. -Instead, they should define their own AUTOLOAD subroutines along these -lines: - - use AutoLoader; - use Carp; - - sub AUTOLOAD { - my $sub = $AUTOLOAD; - (my $constname = $sub) =~ s/.*:://; - my $val = constant($constname, @_ ? $_[0] : 0); - if ($! != 0) { - if ($! =~ /Invalid/ || $!{EINVAL}) { - $AutoLoader::AUTOLOAD = $sub; - goto &AutoLoader::AUTOLOAD; - } - else { - croak "Your vendor has not defined constant $constname"; - } - } - *$sub = sub { $val }; # same as: eval "sub $sub { $val }"; - goto &$sub; - } - -If any module's own AUTOLOAD subroutine has no need to fallback to the -AutoLoader's AUTOLOAD subroutine (because it doesn't have any AutoSplit -subroutines), then that module should not use B<AutoLoader> at all. - -=head2 Package Lexicals - -Package lexicals declared with C<my> in the main block of a package -using B<AutoLoader> will not be visible to auto-loaded subroutines, due to -the fact that the given scope ends at the C<__END__> marker. A module -using such variables as package globals will not work properly under the -B<AutoLoader>. - -The C<vars> pragma (see L<perlmod/"vars">) may be used in such -situations as an alternative to explicitly qualifying all globals with -the package namespace. Variables pre-declared with this pragma will be -visible to any autoloaded routines (but will not be invisible outside -the package, unfortunately). - -=head2 Not Using AutoLoader - -You can stop using AutoLoader by simply - - no AutoLoader; - -=head2 B<AutoLoader> vs. B<SelfLoader> - -The B<AutoLoader> is similar in purpose to B<SelfLoader>: both delay the -loading of subroutines. - -B<SelfLoader> uses the C<__DATA__> marker rather than C<__END__>. -While this avoids the use of a hierarchy of disk files and the -associated open/close for each routine loaded, B<SelfLoader> suffers a -startup speed disadvantage in the one-time parsing of the lines after -C<__DATA__>, after which routines are cached. B<SelfLoader> can also -handle multiple packages in a file. - -B<AutoLoader> only reads code as it is requested, and in many cases -should be faster, but requires a mechanism like B<AutoSplit> be used to -create the individual files. L<ExtUtils::MakeMaker> will invoke -B<AutoSplit> automatically if B<AutoLoader> is used in a module source -file. - -=head1 CAVEATS - -AutoLoaders prior to Perl 5.002 had a slightly different interface. Any -old modules which use B<AutoLoader> should be changed to the new calling -style. Typically this just means changing a require to a use, adding -the explicit C<'AUTOLOAD'> import if needed, and removing B<AutoLoader> -from C<@ISA>. - -On systems with restrictions on file name length, the file corresponding -to a subroutine may have a shorter name that the routine itself. This -can lead to conflicting file names. The I<AutoSplit> package warns of -these potential conflicts when used to split a module. - -AutoLoader may fail to find the autosplit files (or even find the wrong -ones) in cases where C<@INC> contains relative paths, B<and> the program -does C<chdir>. - -=head1 SEE ALSO - -L<SelfLoader> - an autoloader that doesn't use external files. - -=cut diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Carp.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Carp.pm deleted file mode 100644 index 1a814ead34f..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/Carp.pm +++ /dev/null @@ -1,274 +0,0 @@ -package Carp; - -our $VERSION = '1.04'; - -=head1 NAME - -carp - warn of errors (from perspective of caller) - -cluck - warn of errors with stack backtrace - (not exported by default) - -croak - die of errors (from perspective of caller) - -confess - die of errors with stack backtrace - -shortmess - return the message that carp and croak produce - -longmess - return the message that cluck and confess produce - -=head1 SYNOPSIS - - use Carp; - croak "We're outta here!"; - - use Carp qw(cluck); - cluck "This is how we got here!"; - - print FH Carp::shortmess("This will have caller's details added"); - print FH Carp::longmess("This will have stack backtrace added"); - -=head1 DESCRIPTION - -The Carp routines are useful in your own modules because -they act like die() or warn(), but with a message which is more -likely to be useful to a user of your module. In the case of -cluck, confess, and longmess that context is a summary of every -call in the call-stack. For a shorter message you can use carp, -croak or shortmess which report the error as being from where -your module was called. There is no guarantee that that is where -the error was, but it is a good educated guess. - -You can also alter the way the output and logic of C<Carp> works, by -changing some global variables in the C<Carp> namespace. See the -section on C<GLOBAL VARIABLES> below. - -Here is a more complete description of how shortmess works. What -it does is search the call-stack for a function call stack where -it hasn't been told that there shouldn't be an error. If every -call is marked safe, it then gives up and gives a full stack -backtrace instead. In other words it presumes that the first likely -looking potential suspect is guilty. Its rules for telling whether -a call shouldn't generate errors work as follows: - -=over 4 - -=item 1. - -Any call from a package to itself is safe. - -=item 2. - -Packages claim that there won't be errors on calls to or from -packages explicitly marked as safe by inclusion in @CARP_NOT, or -(if that array is empty) @ISA. The ability to override what -@ISA says is new in 5.8. - -=item 3. - -The trust in item 2 is transitive. If A trusts B, and B -trusts C, then A trusts C. So if you do not override @ISA -with @CARP_NOT, then this trust relationship is identical to, -"inherits from". - -=item 4. - -Any call from an internal Perl module is safe. (Nothing keeps -user modules from marking themselves as internal to Perl, but -this practice is discouraged.) - -=item 5. - -Any call to Carp is safe. (This rule is what keeps it from -reporting the error where you call carp/croak/shortmess.) - -=back - -=head2 Forcing a Stack Trace - -As a debugging aid, you can force Carp to treat a croak as a confess -and a carp as a cluck across I<all> modules. In other words, force a -detailed stack trace to be given. This can be very helpful when trying -to understand why, or from where, a warning or error is being generated. - -This feature is enabled by 'importing' the non-existent symbol -'verbose'. You would typically enable it by saying - - perl -MCarp=verbose script.pl - -or by including the string C<MCarp=verbose> in the PERL5OPT -environment variable. - -Alternately, you can set the global variable C<$Carp::Verbose> to true. -See the C<GLOBAL VARIABLES> section below. - -=cut - -# This package is heavily used. Be small. Be fast. Be good. - -# Comments added by Andy Wardley <abw@kfs.org> 09-Apr-98, based on an -# _almost_ complete understanding of the package. Corrections and -# comments are welcome. - -# The members of %Internal are packages that are internal to perl. -# Carp will not report errors from within these packages if it -# can. The members of %CarpInternal are internal to Perl's warning -# system. Carp will not report errors from within these packages -# either, and will not report calls *to* these packages for carp and -# croak. They replace $CarpLevel, which is deprecated. The -# $Max(EvalLen|(Arg(Len|Nums)) variables are used to specify how the eval -# text and function arguments should be formatted when printed. - -# Comments added by Jos I. Boumans <kane@dwim.org> 11-Aug-2004 -# I can not get %CarpInternal or %Internal to work as advertised, -# therefor leaving it out of the below documentation. -# $CarpLevel may be decprecated according to the last comment, but -# after 6 years, it's still around and in heavy use ;) - -=pod - -=head1 GLOBAL VARIABLES - -=head2 $Carp::CarpLevel - -This variable determines how many call frames are to be skipped when -reporting where an error occurred on a call to one of C<Carp>'s -functions. For example: - - $Carp::CarpLevel = 1; - sub bar { .... or _error('Wrong input') } - sub _error { Carp::carp(@_) } - -This would make Carp report the error as coming from C<bar>'s caller, -rather than from C<_error>'s caller, as it normally would. - -Defaults to C<0>. - -=head2 $Carp::MaxEvalLen - -This variable determines how many characters of a string-eval are to -be shown in the output. Use a value of C<0> to show all text. - -Defaults to C<0>. - -=head2 $Carp::MaxArgLen - -This variable determines how many characters of each argument to a -function to print. Use a value of C<0> to show the full length of the -argument. - -Defaults to C<64>. - -=head2 $Carp::MaxArgNums - -This variable determines how many arguments to each function to show. -Use a value of C<0> to show all arguments to a function call. - -Defaults to C<8>. - -=head2 $Carp::Verbose - -This variable makes C<Carp> use the C<longmess> function at all times. -This effectively means that all calls to C<carp> become C<cluck> and -all calls to C<croak> become C<confess>. - -Note, this is analogous to using C<use Carp 'verbose'>. - -Defaults to C<0>. - -=cut - - -$CarpInternal{Carp}++; -$CarpInternal{warnings}++; -$CarpLevel = 0; # How many extra package levels to skip on carp. - # How many calls to skip on confess. - # Reconciling these notions is hard, use - # %Internal and %CarpInternal instead. -$MaxEvalLen = 0; # How much eval '...text...' to show. 0 = all. -$MaxArgLen = 64; # How much of each argument to print. 0 = all. -$MaxArgNums = 8; # How many arguments to print. 0 = all. -$Verbose = 0; # If true then make shortmess call longmess instead - -require Exporter; -@ISA = ('Exporter'); -@EXPORT = qw(confess croak carp); -@EXPORT_OK = qw(cluck verbose longmess shortmess); -@EXPORT_FAIL = qw(verbose); # hook to enable verbose mode - -=head1 BUGS - -The Carp routines don't handle exception objects currently. -If called with a first argument that is a reference, they simply -call die() or warn(), as appropriate. - -=cut - -# if the caller specifies verbose usage ("perl -MCarp=verbose script.pl") -# then the following method will be called by the Exporter which knows -# to do this thanks to @EXPORT_FAIL, above. $_[1] will contain the word -# 'verbose'. - -sub export_fail { - shift; - $Verbose = shift if $_[0] eq 'verbose'; - return @_; -} - - -# longmess() crawls all the way up the stack reporting on all the function -# calls made. The error string, $error, is originally constructed from the -# arguments passed into longmess() via confess(), cluck() or shortmess(). -# This gets appended with the stack trace messages which are generated for -# each function call on the stack. - -sub longmess { - { - local($@, $!); - # XXX fix require to not clear $@ or $!? - # don't use require unless we need to (for Safe compartments) - require Carp::Heavy unless $INC{"Carp/Heavy.pm"}; - } - # Icky backwards compatibility wrapper. :-( - my $call_pack = caller(); - if ($Internal{$call_pack} or $CarpInternal{$call_pack}) { - return longmess_heavy(@_); - } - else { - local $CarpLevel = $CarpLevel + 1; - return longmess_heavy(@_); - } -} - - -# shortmess() is called by carp() and croak() to skip all the way up to -# the top-level caller's package and report the error from there. confess() -# and cluck() generate a full stack trace so they call longmess() to -# generate that. In verbose mode shortmess() calls longmess() so -# you always get a stack trace - -sub shortmess { # Short-circuit &longmess if called via multiple packages - { - local($@, $!); - # XXX fix require to not clear $@ or $!? - # don't use require unless we need to (for Safe compartments) - require Carp::Heavy unless $INC{"Carp/Heavy.pm"}; - } - # Icky backwards compatibility wrapper. :-( - my $call_pack = caller(); - local @CARP_NOT = caller(); - shortmess_heavy(@_); -} - - -# the following four functions call longmess() or shortmess() depending on -# whether they should generate a full stack trace (confess() and cluck()) -# or simply report the caller's package (croak() and carp()), respectively. -# confess() and croak() die, carp() and cluck() warn. - -sub croak { die shortmess @_ } -sub confess { die longmess @_ } -sub carp { warn shortmess @_ } -sub cluck { warn longmess @_ } - -1; diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Carp/Heavy.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Carp/Heavy.pm deleted file mode 100644 index 55bca2b421a..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/Carp/Heavy.pm +++ /dev/null @@ -1,241 +0,0 @@ -# Carp::Heavy uses some variables in common with Carp. -package Carp; - -=head1 NAME - -Carp::Heavy - heavy machinery, no user serviceable parts inside - -=cut - -# use strict; # not yet - -# On one line so MakeMaker will see it. -use Carp; our $VERSION = $Carp::VERSION; - -our ($CarpLevel, $MaxArgNums, $MaxEvalLen, $MaxArgLen, $Verbose); - -sub caller_info { - my $i = shift(@_) + 1; - package DB; - my %call_info; - @call_info{ - qw(pack file line sub has_args wantarray evaltext is_require) - } = caller($i); - - unless (defined $call_info{pack}) { - return (); - } - - my $sub_name = Carp::get_subname(\%call_info); - if ($call_info{has_args}) { - my @args = map {Carp::format_arg($_)} @DB::args; - if ($MaxArgNums and @args > $MaxArgNums) { # More than we want to show? - $#args = $MaxArgNums; - push @args, '...'; - } - # Push the args onto the subroutine - $sub_name .= '(' . join (', ', @args) . ')'; - } - $call_info{sub_name} = $sub_name; - return wantarray() ? %call_info : \%call_info; -} - -# Transform an argument to a function into a string. -sub format_arg { - my $arg = shift; - if (ref($arg)) { - $arg = defined($overload::VERSION) ? overload::StrVal($arg) : "$arg"; - }elsif (not defined($arg)) { - $arg = 'undef'; - } - $arg =~ s/'/\\'/g; - $arg = str_len_trim($arg, $MaxArgLen); - - # Quote it? - $arg = "'$arg'" unless $arg =~ /^-?[\d.]+\z/; - - # The following handling of "control chars" is direct from - # the original code - it is broken on Unicode though. - # Suggestions? - utf8::is_utf8($arg) - or $arg =~ s/([[:cntrl:]]|[[:^ascii:]])/sprintf("\\x{%x}",ord($1))/eg; - return $arg; -} - -# Takes an inheritance cache and a package and returns -# an anon hash of known inheritances and anon array of -# inheritances which consequences have not been figured -# for. -sub get_status { - my $cache = shift; - my $pkg = shift; - $cache->{$pkg} ||= [{$pkg => $pkg}, [trusts_directly($pkg)]]; - return @{$cache->{$pkg}}; -} - -# Takes the info from caller() and figures out the name of -# the sub/require/eval -sub get_subname { - my $info = shift; - if (defined($info->{evaltext})) { - my $eval = $info->{evaltext}; - if ($info->{is_require}) { - return "require $eval"; - } - else { - $eval =~ s/([\\\'])/\\$1/g; - return "eval '" . str_len_trim($eval, $MaxEvalLen) . "'"; - } - } - - return ($info->{sub} eq '(eval)') ? 'eval {...}' : $info->{sub}; -} - -# Figures out what call (from the point of view of the caller) -# the long error backtrace should start at. -sub long_error_loc { - my $i; - my $lvl = $CarpLevel; - { - my $pkg = caller(++$i); - unless(defined($pkg)) { - # This *shouldn't* happen. - if (%Internal) { - local %Internal; - $i = long_error_loc(); - last; - } - else { - # OK, now I am irritated. - return 2; - } - } - redo if $CarpInternal{$pkg}; - redo unless 0 > --$lvl; - redo if $Internal{$pkg}; - } - return $i - 1; -} - - -sub longmess_heavy { - return @_ if ref($_[0]); # don't break references as exceptions - my $i = long_error_loc(); - return ret_backtrace($i, @_); -} - -# Returns a full stack backtrace starting from where it is -# told. -sub ret_backtrace { - my ($i, @error) = @_; - my $mess; - my $err = join '', @error; - $i++; - - my $tid_msg = ''; - if (defined &Thread::tid) { - my $tid = Thread->self->tid; - $tid_msg = " thread $tid" if $tid; - } - - my %i = caller_info($i); - $mess = "$err at $i{file} line $i{line}$tid_msg\n"; - - while (my %i = caller_info(++$i)) { - $mess .= "\t$i{sub_name} called at $i{file} line $i{line}$tid_msg\n"; - } - - return $mess; -} - -sub ret_summary { - my ($i, @error) = @_; - my $err = join '', @error; - $i++; - - my $tid_msg = ''; - if (defined &Thread::tid) { - my $tid = Thread->self->tid; - $tid_msg = " thread $tid" if $tid; - } - - my %i = caller_info($i); - return "$err at $i{file} line $i{line}$tid_msg\n"; -} - - -sub short_error_loc { - my $cache; - my $i = 1; - my $lvl = $CarpLevel; - { - my $called = caller($i++); - my $caller = caller($i); - return 0 unless defined($caller); # What happened? - redo if $Internal{$caller}; - redo if $CarpInternal{$called}; - redo if trusts($called, $caller, $cache); - redo if trusts($caller, $called, $cache); - redo unless 0 > --$lvl; - } - return $i - 1; -} - -sub shortmess_heavy { - return longmess_heavy(@_) if $Verbose; - return @_ if ref($_[0]); # don't break references as exceptions - my $i = short_error_loc(); - if ($i) { - ret_summary($i, @_); - } - else { - longmess_heavy(@_); - } -} - -# If a string is too long, trims it with ... -sub str_len_trim { - my $str = shift; - my $max = shift || 0; - if (2 < $max and $max < length($str)) { - substr($str, $max - 3) = '...'; - } - return $str; -} - -# Takes two packages and an optional cache. Says whether the -# first inherits from the second. -# -# Recursive versions of this have to work to avoid certain -# possible endless loops, and when following long chains of -# inheritance are less efficient. -sub trusts { - my $child = shift; - my $parent = shift; - my $cache = shift || {}; - my ($known, $partial) = get_status($cache, $child); - # Figure out consequences until we have an answer - while (@$partial and not exists $known->{$parent}) { - my $anc = shift @$partial; - next if exists $known->{$anc}; - $known->{$anc}++; - my ($anc_knows, $anc_partial) = get_status($cache, $anc); - my @found = keys %$anc_knows; - @$known{@found} = (); - push @$partial, @$anc_partial; - } - return exists $known->{$parent}; -} - -# Takes a package and gives a list of those trusted directly -sub trusts_directly { - my $class = shift; - no strict 'refs'; - no warnings 'once'; - return @{"$class\::CARP_NOT"} - ? @{"$class\::CARP_NOT"} - : @{"$class\::ISA"}; -} - -1; - diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Config.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Config.pm deleted file mode 100644 index 7e5ad77b30a..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/Config.pm +++ /dev/null @@ -1,95 +0,0 @@ -# This file was created by configpm when Perl was built. Any changes -# made to this file will be lost the next time perl is built. - -package Config; -use strict; -# use warnings; Pulls in Carp -# use vars pulls in Carp -@Config::EXPORT = qw(%Config); -@Config::EXPORT_OK = qw(myconfig config_sh config_vars config_re); - -# Need to stub all the functions to make code such as print Config::config_sh -# keep working - -sub myconfig; -sub config_sh; -sub config_vars; -sub config_re; - -my %Export_Cache = map {($_ => 1)} (@Config::EXPORT, @Config::EXPORT_OK); - -our %Config; - -# Define our own import method to avoid pulling in the full Exporter: -sub import { - my $pkg = shift; - @_ = @Config::EXPORT unless @_; - - my @funcs = grep $_ ne '%Config', @_; - my $export_Config = @funcs < @_ ? 1 : 0; - - no strict 'refs'; - my $callpkg = caller(0); - foreach my $func (@funcs) { - die sprintf qq{"%s" is not exported by the %s module\n}, - $func, __PACKAGE__ unless $Export_Cache{$func}; - *{$callpkg.'::'.$func} = \&{$func}; - } - - *{"$callpkg\::Config"} = \%Config if $export_Config; - return; -} - -die "Perl lib version (v5.8.8) doesn't match executable version ($])" - unless $^V; - -$^V eq v5.8.8 - or die "Perl lib version (v5.8.8) doesn't match executable version (" . - sprintf("v%vd",$^V) . ")"; - - -sub FETCH { - my($self, $key) = @_; - - # check for cached value (which may be undef so we use exists not defined) - return $self->{$key} if exists $self->{$key}; - - return $self->fetch_string($key); -} -sub TIEHASH { - bless $_[1], $_[0]; -} - -sub DESTROY { } - -sub AUTOLOAD { - require 'Config_heavy.pl'; - goto \&launcher unless $Config::AUTOLOAD =~ /launcher$/; - die "&Config::AUTOLOAD failed on $Config::AUTOLOAD"; -} - -# tie returns the object, so the value returned to require will be true. -tie %Config, 'Config', { - archlibexp => 'x:\\perl\\lib', - archname => 'MSWin32-x86-multi-thread', - cc => 'gcc', - d_readlink => undef, - d_symlink => undef, - dlsrc => 'dl_win32.xs', - dont_use_nlink => undef, - exe_ext => '.exe', - inc_version_list => '', - intsize => '4', - ldlibpthname => '', - libpth => 'x:\\msys\\mingw\\lib', - osname => 'MSWin32', - osvers => '5.1', - path_sep => ';', - privlibexp => 'x:\\perl\\lib', - scriptdir => 'x:\\perl\\bin', - sitearchexp => 'x:\\perl\\site\\lib', - sitelibexp => 'x:\\perl\\site\\lib', - useithreads => 'define', - usevendorprefix => undef, - version => '5.8.8', -}; diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Cwd.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Cwd.pm deleted file mode 100644 index 8d25af9f7cd..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/Cwd.pm +++ /dev/null @@ -1,710 +0,0 @@ -package Cwd; - -=head1 NAME - -Cwd - get pathname of current working directory - -=head1 SYNOPSIS - - use Cwd; - my $dir = getcwd; - - use Cwd 'abs_path'; - my $abs_path = abs_path($file); - -=head1 DESCRIPTION - -This module provides functions for determining the pathname of the -current working directory. It is recommended that getcwd (or another -*cwd() function) be used in I<all> code to ensure portability. - -By default, it exports the functions cwd(), getcwd(), fastcwd(), and -fastgetcwd() (and, on Win32, getdcwd()) into the caller's namespace. - - -=head2 getcwd and friends - -Each of these functions are called without arguments and return the -absolute path of the current working directory. - -=over 4 - -=item getcwd - - my $cwd = getcwd(); - -Returns the current working directory. - -Re-implements the getcwd(3) (or getwd(3)) functions in Perl. - -=item cwd - - my $cwd = cwd(); - -The cwd() is the most natural form for the current architecture. For -most systems it is identical to `pwd` (but without the trailing line -terminator). - -=item fastcwd - - my $cwd = fastcwd(); - -A more dangerous version of getcwd(), but potentially faster. - -It might conceivably chdir() you out of a directory that it can't -chdir() you back into. If fastcwd encounters a problem it will return -undef but will probably leave you in a different directory. For a -measure of extra security, if everything appears to have worked, the -fastcwd() function will check that it leaves you in the same directory -that it started in. If it has changed it will C<die> with the message -"Unstable directory path, current directory changed -unexpectedly". That should never happen. - -=item fastgetcwd - - my $cwd = fastgetcwd(); - -The fastgetcwd() function is provided as a synonym for cwd(). - -=item getdcwd - - my $cwd = getdcwd(); - my $cwd = getdcwd('C:'); - -The getdcwd() function is also provided on Win32 to get the current working -directory on the specified drive, since Windows maintains a separate current -working directory for each drive. If no drive is specified then the current -drive is assumed. - -This function simply calls the Microsoft C library _getdcwd() function. - -=back - - -=head2 abs_path and friends - -These functions are exported only on request. They each take a single -argument and return the absolute pathname for it. If no argument is -given they'll use the current working directory. - -=over 4 - -=item abs_path - - my $abs_path = abs_path($file); - -Uses the same algorithm as getcwd(). Symbolic links and relative-path -components ("." and "..") are resolved to return the canonical -pathname, just like realpath(3). - -=item realpath - - my $abs_path = realpath($file); - -A synonym for abs_path(). - -=item fast_abs_path - - my $abs_path = fast_abs_path($file); - -A more dangerous, but potentially faster version of abs_path. - -=back - -=head2 $ENV{PWD} - -If you ask to override your chdir() built-in function, - - use Cwd qw(chdir); - -then your PWD environment variable will be kept up to date. Note that -it will only be kept up to date if all packages which use chdir import -it from Cwd. - - -=head1 NOTES - -=over 4 - -=item * - -Since the path seperators are different on some operating systems ('/' -on Unix, ':' on MacPerl, etc...) we recommend you use the File::Spec -modules wherever portability is a concern. - -=item * - -Actually, on Mac OS, the C<getcwd()>, C<fastgetcwd()> and C<fastcwd()> -functions are all aliases for the C<cwd()> function, which, on Mac OS, -calls `pwd`. Likewise, the C<abs_path()> function is an alias for -C<fast_abs_path()>. - -=back - -=head1 AUTHOR - -Originally by the perl5-porters. - -Maintained by Ken Williams <KWILLIAMS@cpan.org> - -=head1 COPYRIGHT - -Copyright (c) 2004 by the Perl 5 Porters. All rights reserved. - -This program is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -Portions of the C code in this library are copyright (c) 1994 by the -Regents of the University of California. All rights reserved. The -license on this code is compatible with the licensing of the rest of -the distribution - please see the source code in F<Cwd.xs> for the -details. - -=head1 SEE ALSO - -L<File::chdir> - -=cut - -use strict; -use Exporter; -use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION); - -$VERSION = '3.12'; - -@ISA = qw/ Exporter /; -@EXPORT = qw(cwd getcwd fastcwd fastgetcwd); -push @EXPORT, qw(getdcwd) if $^O eq 'MSWin32'; -@EXPORT_OK = qw(chdir abs_path fast_abs_path realpath fast_realpath); - -# sys_cwd may keep the builtin command - -# All the functionality of this module may provided by builtins, -# there is no sense to process the rest of the file. -# The best choice may be to have this in BEGIN, but how to return from BEGIN? - -if ($^O eq 'os2') { - local $^W = 0; - - *cwd = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd; - *getcwd = \&cwd; - *fastgetcwd = \&cwd; - *fastcwd = \&cwd; - - *fast_abs_path = \&sys_abspath if defined &sys_abspath; - *abs_path = \&fast_abs_path; - *realpath = \&fast_abs_path; - *fast_realpath = \&fast_abs_path; - - return 1; -} - -# If loading the XS stuff doesn't work, we can fall back to pure perl -eval { - if ( $] >= 5.006 ) { - require XSLoader; - XSLoader::load( __PACKAGE__, $VERSION ); - } else { - require DynaLoader; - push @ISA, 'DynaLoader'; - __PACKAGE__->bootstrap( $VERSION ); - } -}; - -# Must be after the DynaLoader stuff: -$VERSION = eval $VERSION; - -# Big nasty table of function aliases -my %METHOD_MAP = - ( - VMS => - { - cwd => '_vms_cwd', - getcwd => '_vms_cwd', - fastcwd => '_vms_cwd', - fastgetcwd => '_vms_cwd', - abs_path => '_vms_abs_path', - fast_abs_path => '_vms_abs_path', - }, - - MSWin32 => - { - # We assume that &_NT_cwd is defined as an XSUB or in the core. - cwd => '_NT_cwd', - getcwd => '_NT_cwd', - fastcwd => '_NT_cwd', - fastgetcwd => '_NT_cwd', - abs_path => 'fast_abs_path', - realpath => 'fast_abs_path', - }, - - dos => - { - cwd => '_dos_cwd', - getcwd => '_dos_cwd', - fastgetcwd => '_dos_cwd', - fastcwd => '_dos_cwd', - abs_path => 'fast_abs_path', - }, - - qnx => - { - cwd => '_qnx_cwd', - getcwd => '_qnx_cwd', - fastgetcwd => '_qnx_cwd', - fastcwd => '_qnx_cwd', - abs_path => '_qnx_abs_path', - fast_abs_path => '_qnx_abs_path', - }, - - cygwin => - { - getcwd => 'cwd', - fastgetcwd => 'cwd', - fastcwd => 'cwd', - abs_path => 'fast_abs_path', - realpath => 'fast_abs_path', - }, - - epoc => - { - cwd => '_epoc_cwd', - getcwd => '_epoc_cwd', - fastgetcwd => '_epoc_cwd', - fastcwd => '_epoc_cwd', - abs_path => 'fast_abs_path', - }, - - MacOS => - { - getcwd => 'cwd', - fastgetcwd => 'cwd', - fastcwd => 'cwd', - abs_path => 'fast_abs_path', - }, - ); - -$METHOD_MAP{NT} = $METHOD_MAP{MSWin32}; -$METHOD_MAP{nto} = $METHOD_MAP{qnx}; - - -# Find the pwd command in the expected locations. We assume these -# are safe. This prevents _backtick_pwd() consulting $ENV{PATH} -# so everything works under taint mode. -my $pwd_cmd; -foreach my $try ('/bin/pwd', - '/usr/bin/pwd', - '/QOpenSys/bin/pwd', # OS/400 PASE. - ) { - - if( -x $try ) { - $pwd_cmd = $try; - last; - } -} -unless ($pwd_cmd) { - # Isn't this wrong? _backtick_pwd() will fail if somenone has - # pwd in their path but it is not /bin/pwd or /usr/bin/pwd? - # See [perl #16774]. --jhi - $pwd_cmd = 'pwd'; -} - -# Lazy-load Carp -sub _carp { require Carp; Carp::carp(@_) } -sub _croak { require Carp; Carp::croak(@_) } - -# The 'natural and safe form' for UNIX (pwd may be setuid root) -sub _backtick_pwd { - # Localize %ENV entries in a way that won't create new hash keys - my @localize = grep exists $ENV{$_}, qw(PATH IFS CDPATH ENV BASH_ENV); - local @ENV{@localize}; - - my $cwd = `$pwd_cmd`; - # Belt-and-suspenders in case someone said "undef $/". - local $/ = "\n"; - # `pwd` may fail e.g. if the disk is full - chomp($cwd) if defined $cwd; - $cwd; -} - -# Since some ports may predefine cwd internally (e.g., NT) -# we take care not to override an existing definition for cwd(). - -unless ($METHOD_MAP{$^O}{cwd} or defined &cwd) { - # The pwd command is not available in some chroot(2)'ed environments - my $sep = $Config::Config{path_sep} || ':'; - my $os = $^O; # Protect $^O from tainting - if( $os eq 'MacOS' || (defined $ENV{PATH} && - $os ne 'MSWin32' && # no pwd on Windows - grep { -x "$_/pwd" } split($sep, $ENV{PATH})) ) - { - *cwd = \&_backtick_pwd; - } - else { - *cwd = \&getcwd; - } -} - -# set a reasonable (and very safe) default for fastgetcwd, in case it -# isn't redefined later (20001212 rspier) -*fastgetcwd = \&cwd; - -# By Brandon S. Allbery -# -# Usage: $cwd = getcwd(); - -sub getcwd -{ - abs_path('.'); -} - - -# By John Bazik -# -# Usage: $cwd = &fastcwd; -# -# This is a faster version of getcwd. It's also more dangerous because -# you might chdir out of a directory that you can't chdir back into. - -sub fastcwd_ { - my($odev, $oino, $cdev, $cino, $tdev, $tino); - my(@path, $path); - local(*DIR); - - my($orig_cdev, $orig_cino) = stat('.'); - ($cdev, $cino) = ($orig_cdev, $orig_cino); - for (;;) { - my $direntry; - ($odev, $oino) = ($cdev, $cino); - CORE::chdir('..') || return undef; - ($cdev, $cino) = stat('.'); - last if $odev == $cdev && $oino == $cino; - opendir(DIR, '.') || return undef; - for (;;) { - $direntry = readdir(DIR); - last unless defined $direntry; - next if $direntry eq '.'; - next if $direntry eq '..'; - - ($tdev, $tino) = lstat($direntry); - last unless $tdev != $odev || $tino != $oino; - } - closedir(DIR); - return undef unless defined $direntry; # should never happen - unshift(@path, $direntry); - } - $path = '/' . join('/', @path); - if ($^O eq 'apollo') { $path = "/".$path; } - # At this point $path may be tainted (if tainting) and chdir would fail. - # Untaint it then check that we landed where we started. - $path =~ /^(.*)\z/s # untaint - && CORE::chdir($1) or return undef; - ($cdev, $cino) = stat('.'); - die "Unstable directory path, current directory changed unexpectedly" - if $cdev != $orig_cdev || $cino != $orig_cino; - $path; -} -if (not defined &fastcwd) { *fastcwd = \&fastcwd_ } - - -# Keeps track of current working directory in PWD environment var -# Usage: -# use Cwd 'chdir'; -# chdir $newdir; - -my $chdir_init = 0; - -sub chdir_init { - if ($ENV{'PWD'} and $^O ne 'os2' and $^O ne 'dos' and $^O ne 'MSWin32') { - my($dd,$di) = stat('.'); - my($pd,$pi) = stat($ENV{'PWD'}); - if (!defined $dd or !defined $pd or $di != $pi or $dd != $pd) { - $ENV{'PWD'} = cwd(); - } - } - else { - my $wd = cwd(); - $wd = Win32::GetFullPathName($wd) if $^O eq 'MSWin32'; - $ENV{'PWD'} = $wd; - } - # Strip an automounter prefix (where /tmp_mnt/foo/bar == /foo/bar) - if ($^O ne 'MSWin32' and $ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|s) { - my($pd,$pi) = stat($2); - my($dd,$di) = stat($1); - if (defined $pd and defined $dd and $di == $pi and $dd == $pd) { - $ENV{'PWD'}="$2$3"; - } - } - $chdir_init = 1; -} - -sub chdir { - my $newdir = @_ ? shift : ''; # allow for no arg (chdir to HOME dir) - $newdir =~ s|///*|/|g unless $^O eq 'MSWin32'; - chdir_init() unless $chdir_init; - my $newpwd; - if ($^O eq 'MSWin32') { - # get the full path name *before* the chdir() - $newpwd = Win32::GetFullPathName($newdir); - } - - return 0 unless CORE::chdir $newdir; - - if ($^O eq 'VMS') { - return $ENV{'PWD'} = $ENV{'DEFAULT'} - } - elsif ($^O eq 'MacOS') { - return $ENV{'PWD'} = cwd(); - } - elsif ($^O eq 'MSWin32') { - $ENV{'PWD'} = $newpwd; - return 1; - } - - if ($newdir =~ m#^/#s) { - $ENV{'PWD'} = $newdir; - } else { - my @curdir = split(m#/#,$ENV{'PWD'}); - @curdir = ('') unless @curdir; - my $component; - foreach $component (split(m#/#, $newdir)) { - next if $component eq '.'; - pop(@curdir),next if $component eq '..'; - push(@curdir,$component); - } - $ENV{'PWD'} = join('/',@curdir) || '/'; - } - 1; -} - - -sub _perl_abs_path -{ - my $start = @_ ? shift : '.'; - my($dotdots, $cwd, @pst, @cst, $dir, @tst); - - unless (@cst = stat( $start )) - { - _carp("stat($start): $!"); - return ''; - } - - unless (-d _) { - # Make sure we can be invoked on plain files, not just directories. - # NOTE that this routine assumes that '/' is the only directory separator. - - my ($dir, $file) = $start =~ m{^(.*)/(.+)$} - or return cwd() . '/' . $start; - - # Can't use "-l _" here, because the previous stat was a stat(), not an lstat(). - if (-l $start) { - my $link_target = readlink($start); - die "Can't resolve link $start: $!" unless defined $link_target; - - require File::Spec; - $link_target = $dir . '/' . $link_target - unless File::Spec->file_name_is_absolute($link_target); - - return abs_path($link_target); - } - - return $dir ? abs_path($dir) . "/$file" : "/$file"; - } - - $cwd = ''; - $dotdots = $start; - do - { - $dotdots .= '/..'; - @pst = @cst; - local *PARENT; - unless (opendir(PARENT, $dotdots)) - { - _carp("opendir($dotdots): $!"); - return ''; - } - unless (@cst = stat($dotdots)) - { - _carp("stat($dotdots): $!"); - closedir(PARENT); - return ''; - } - if ($pst[0] == $cst[0] && $pst[1] == $cst[1]) - { - $dir = undef; - } - else - { - do - { - unless (defined ($dir = readdir(PARENT))) - { - _carp("readdir($dotdots): $!"); - closedir(PARENT); - return ''; - } - $tst[0] = $pst[0]+1 unless (@tst = lstat("$dotdots/$dir")) - } - while ($dir eq '.' || $dir eq '..' || $tst[0] != $pst[0] || - $tst[1] != $pst[1]); - } - $cwd = (defined $dir ? "$dir" : "" ) . "/$cwd" ; - closedir(PARENT); - } while (defined $dir); - chop($cwd) unless $cwd eq '/'; # drop the trailing / - $cwd; -} - - -my $Curdir; -sub fast_abs_path { - local $ENV{PWD} = $ENV{PWD} || ''; # Guard against clobberage - my $cwd = getcwd(); - require File::Spec; - my $path = @_ ? shift : ($Curdir ||= File::Spec->curdir); - - # Detaint else we'll explode in taint mode. This is safe because - # we're not doing anything dangerous with it. - ($path) = $path =~ /(.*)/; - ($cwd) = $cwd =~ /(.*)/; - - unless (-e $path) { - _croak("$path: No such file or directory"); - } - - unless (-d _) { - # Make sure we can be invoked on plain files, not just directories. - - my ($vol, $dir, $file) = File::Spec->splitpath($path); - return File::Spec->catfile($cwd, $path) unless length $dir; - - if (-l $path) { - my $link_target = readlink($path); - die "Can't resolve link $path: $!" unless defined $link_target; - - $link_target = File::Spec->catpath($vol, $dir, $link_target) - unless File::Spec->file_name_is_absolute($link_target); - - return fast_abs_path($link_target); - } - - return $dir eq File::Spec->rootdir - ? File::Spec->catpath($vol, $dir, $file) - : fast_abs_path(File::Spec->catpath($vol, $dir, '')) . '/' . $file; - } - - if (!CORE::chdir($path)) { - _croak("Cannot chdir to $path: $!"); - } - my $realpath = getcwd(); - if (! ((-d $cwd) && (CORE::chdir($cwd)))) { - _croak("Cannot chdir back to $cwd: $!"); - } - $realpath; -} - -# added function alias to follow principle of least surprise -# based on previous aliasing. --tchrist 27-Jan-00 -*fast_realpath = \&fast_abs_path; - - -# --- PORTING SECTION --- - -# VMS: $ENV{'DEFAULT'} points to default directory at all times -# 06-Mar-1996 Charles Bailey bailey@newman.upenn.edu -# Note: Use of Cwd::chdir() causes the logical name PWD to be defined -# in the process logical name table as the default device and directory -# seen by Perl. This may not be the same as the default device -# and directory seen by DCL after Perl exits, since the effects -# the CRTL chdir() function persist only until Perl exits. - -sub _vms_cwd { - return $ENV{'DEFAULT'}; -} - -sub _vms_abs_path { - return $ENV{'DEFAULT'} unless @_; - - # may need to turn foo.dir into [.foo] - my $path = VMS::Filespec::pathify($_[0]); - $path = $_[0] unless defined $path; - - return VMS::Filespec::rmsexpand($path); -} - -sub _os2_cwd { - $ENV{'PWD'} = `cmd /c cd`; - chomp $ENV{'PWD'}; - $ENV{'PWD'} =~ s:\\:/:g ; - return $ENV{'PWD'}; -} - -sub _win32_cwd { - $ENV{'PWD'} = Win32::GetCwd(); - $ENV{'PWD'} =~ s:\\:/:g ; - return $ENV{'PWD'}; -} - -*_NT_cwd = defined &Win32::GetCwd ? \&_win32_cwd : \&_os2_cwd; - -sub _dos_cwd { - if (!defined &Dos::GetCwd) { - $ENV{'PWD'} = `command /c cd`; - chomp $ENV{'PWD'}; - $ENV{'PWD'} =~ s:\\:/:g ; - } else { - $ENV{'PWD'} = Dos::GetCwd(); - } - return $ENV{'PWD'}; -} - -sub _qnx_cwd { - local $ENV{PATH} = ''; - local $ENV{CDPATH} = ''; - local $ENV{ENV} = ''; - $ENV{'PWD'} = `/usr/bin/fullpath -t`; - chomp $ENV{'PWD'}; - return $ENV{'PWD'}; -} - -sub _qnx_abs_path { - local $ENV{PATH} = ''; - local $ENV{CDPATH} = ''; - local $ENV{ENV} = ''; - my $path = @_ ? shift : '.'; - local *REALPATH; - - defined( open(REALPATH, '-|') || exec '/usr/bin/fullpath', '-t', $path ) or - die "Can't open /usr/bin/fullpath: $!"; - my $realpath = <REALPATH>; - close REALPATH; - chomp $realpath; - return $realpath; -} - -sub _epoc_cwd { - $ENV{'PWD'} = EPOC::getcwd(); - return $ENV{'PWD'}; -} - - -# Now that all the base-level functions are set up, alias the -# user-level functions to the right places - -if (exists $METHOD_MAP{$^O}) { - my $map = $METHOD_MAP{$^O}; - foreach my $name (keys %$map) { - local $^W = 0; # assignments trigger 'subroutine redefined' warning - no strict 'refs'; - *{$name} = \&{$map->{$name}}; - } -} - -# In case the XS version doesn't load. -*abs_path = \&_perl_abs_path unless defined &abs_path; - -# added function alias for those of us more -# used to the libc function. --tchrist 27-Jan-00 -*realpath = \&abs_path; - -1; diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/DynaLoader.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/DynaLoader.pm deleted file mode 100644 index 178e9b2616c..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/DynaLoader.pm +++ /dev/null @@ -1,833 +0,0 @@ - -# Generated from DynaLoader.pm.PL - -package DynaLoader; - -# And Gandalf said: 'Many folk like to know beforehand what is to -# be set on the table; but those who have laboured to prepare the -# feast like to keep their secret; for wonder makes the words of -# praise louder.' - -# (Quote from Tolkien suggested by Anno Siegel.) -# -# See pod text at end of file for documentation. -# See also ext/DynaLoader/README in source tree for other information. -# -# Tim.Bunce@ig.co.uk, August 1994 - -use vars qw($VERSION *AUTOLOAD); - -$VERSION = '1.05'; # avoid typo warning - -require AutoLoader; -*AUTOLOAD = \&AutoLoader::AUTOLOAD; - -use Config; - -# The following require can't be removed during maintenance -# releases, sadly, because of the risk of buggy code that does -# require Carp; Carp::croak "..."; without brackets dying -# if Carp hasn't been loaded in earlier compile time. :-( -# We'll let those bugs get found on the development track. -require Carp if $] < 5.00450; - -# enable debug/trace messages from DynaLoader perl code -$dl_debug = $ENV{PERL_DL_DEBUG} || 0 unless defined $dl_debug; - -# -# Flags to alter dl_load_file behaviour. Assigned bits: -# 0x01 make symbols available for linking later dl_load_file's. -# (only known to work on Solaris 2 using dlopen(RTLD_GLOBAL)) -# (ignored under VMS; effect is built-in to image linking) -# -# This is called as a class method $module->dl_load_flags. The -# definition here will be inherited and result on "default" loading -# behaviour unless a sub-class of DynaLoader defines its own version. -# - -sub dl_load_flags { 0x00 } - -# ($dl_dlext, $dlsrc) -# = @Config::Config{'dlext', 'dlsrc'}; - ($dl_dlext, $dlsrc) = ('dll','dl_win32.xs') -; -# Some systems need special handling to expand file specifications -# (VMS support by Charles Bailey <bailey@HMIVAX.HUMGEN.UPENN.EDU>) -# See dl_expandspec() for more details. Should be harmless but -# inefficient to define on systems that don't need it. -$Is_VMS = $^O eq 'VMS'; -$do_expand = $Is_VMS; -$Is_MacOS = $^O eq 'MacOS'; - -my $Mac_FS; -$Mac_FS = eval { require Mac::FileSpec::Unixish } if $Is_MacOS; - -@dl_require_symbols = (); # names of symbols we need -@dl_resolve_using = (); # names of files to link with -@dl_library_path = (); # path to look for files - -#XSLoader.pm may have added elements before we were required -#@dl_shared_objects = (); # shared objects for symbols we have -#@dl_librefs = (); # things we have loaded -#@dl_modules = (); # Modules we have loaded - -# This is a fix to support DLD's unfortunate desire to relink -lc -@dl_resolve_using = dl_findfile('-lc') if $dlsrc eq "dl_dld.xs"; - -# Initialise @dl_library_path with the 'standard' library path -# for this platform as determined by Configure. - -push(@dl_library_path, split(' ', $Config::Config{libpth})); - - -my $ldlibpthname = $Config::Config{ldlibpthname}; -my $ldlibpthname_defined = defined $Config::Config{ldlibpthname}; -my $pthsep = $Config::Config{path_sep}; - -# Add to @dl_library_path any extra directories we can gather from environment -# during runtime. - -if ($ldlibpthname_defined && - exists $ENV{$ldlibpthname}) { - push(@dl_library_path, split(/$pthsep/, $ENV{$ldlibpthname})); -} - -# E.g. HP-UX supports both its native SHLIB_PATH *and* LD_LIBRARY_PATH. - -if ($ldlibpthname_defined && - $ldlibpthname ne 'LD_LIBRARY_PATH' && - exists $ENV{LD_LIBRARY_PATH}) { - push(@dl_library_path, split(/$pthsep/, $ENV{LD_LIBRARY_PATH})); -} - - -# No prizes for guessing why we don't say 'bootstrap DynaLoader;' here. -# NOTE: All dl_*.xs (including dl_none.xs) define a dl_error() XSUB -boot_DynaLoader('DynaLoader') if defined(&boot_DynaLoader) && - !defined(&dl_error); - -if ($dl_debug) { - print STDERR "DynaLoader.pm loaded (@INC, @dl_library_path)\n"; - print STDERR "DynaLoader not linked into this perl\n" - unless defined(&boot_DynaLoader); -} - -1; # End of main code - - -sub croak { require Carp; Carp::croak(@_) } - -sub bootstrap_inherit { - my $module = $_[0]; - local *isa = *{"$module\::ISA"}; - local @isa = (@isa, 'DynaLoader'); - # Cannot goto due to delocalization. Will report errors on a wrong line? - bootstrap(@_); -} - -# The bootstrap function cannot be autoloaded (without complications) -# so we define it here: - -sub bootstrap { - # use local vars to enable $module.bs script to edit values - local(@args) = @_; - local($module) = $args[0]; - local(@dirs, $file); - - unless ($module) { - require Carp; - Carp::confess("Usage: DynaLoader::bootstrap(module)"); - } - - # A common error on platforms which don't support dynamic loading. - # Since it's fatal and potentially confusing we give a detailed message. - croak("Can't load module $module, dynamic loading not available in this perl.\n". - " (You may need to build a new perl executable which either supports\n". - " dynamic loading or has the $module module statically linked into it.)\n") - unless defined(&dl_load_file); - - my @modparts = split(/::/,$module); - my $modfname = $modparts[-1]; - - # Some systems have restrictions on files names for DLL's etc. - # mod2fname returns appropriate file base name (typically truncated) - # It may also edit @modparts if required. - $modfname = &mod2fname(\@modparts) if defined &mod2fname; - - # Truncate the module name to 8.3 format for NetWare - if (($^O eq 'NetWare') && (length($modfname) > 8)) { - $modfname = substr($modfname, 0, 8); - } - - my $modpname = join(($Is_MacOS ? ':' : '/'),@modparts); - - print STDERR "DynaLoader::bootstrap for $module ", - ($Is_MacOS - ? "(:auto:$modpname:$modfname.$dl_dlext)\n" : - "(auto/$modpname/$modfname.$dl_dlext)\n") - if $dl_debug; - - foreach (@INC) { - chop($_ = VMS::Filespec::unixpath($_)) if $Is_VMS; - my $dir; - if ($Is_MacOS) { - my $path = $_; - if ($Mac_FS && ! -d $path) { - $path = Mac::FileSpec::Unixish::nativize($path); - } - $path .= ":" unless /:$/; - $dir = "${path}auto:$modpname"; - } else { - $dir = "$_/auto/$modpname"; - } - - next unless -d $dir; # skip over uninteresting directories - - # check for common cases to avoid autoload of dl_findfile - my $try = $Is_MacOS ? "$dir:$modfname.$dl_dlext" : "$dir/$modfname.$dl_dlext"; - last if $file = ($do_expand) ? dl_expandspec($try) : ((-f $try) && $try); - - # no luck here, save dir for possible later dl_findfile search - push @dirs, $dir; - } - # last resort, let dl_findfile have a go in all known locations - $file = dl_findfile(map("-L$_",@dirs,@INC), $modfname) unless $file; - - croak("Can't locate loadable object for module $module in \@INC (\@INC contains: @INC)") - unless $file; # wording similar to error from 'require' - - $file = uc($file) if $Is_VMS && $Config::Config{d_vms_case_sensitive_symbols}; - my $bootname = "boot_$module"; - $bootname =~ s/\W/_/g; - @dl_require_symbols = ($bootname); - - # Execute optional '.bootstrap' perl script for this module. - # The .bs file can be used to configure @dl_resolve_using etc to - # match the needs of the individual module on this architecture. - my $bs = $file; - $bs =~ s/(\.\w+)?(;\d*)?$/\.bs/; # look for .bs 'beside' the library - if (-s $bs) { # only read file if it's not empty - print STDERR "BS: $bs ($^O, $dlsrc)\n" if $dl_debug; - eval { do $bs; }; - warn "$bs: $@\n" if $@; - } - - my $boot_symbol_ref; - - if ($^O eq 'darwin') { - if ($boot_symbol_ref = dl_find_symbol(0, $bootname)) { - goto boot; #extension library has already been loaded, e.g. darwin - } - } - - # Many dynamic extension loading problems will appear to come from - # this section of code: XYZ failed at line 123 of DynaLoader.pm. - # Often these errors are actually occurring in the initialisation - # C code of the extension XS file. Perl reports the error as being - # in this perl code simply because this was the last perl code - # it executed. - - my $libref = dl_load_file($file, $module->dl_load_flags) or - croak("Can't load '$file' for module $module: ".dl_error()); - - push(@dl_librefs,$libref); # record loaded object - - my @unresolved = dl_undef_symbols(); - if (@unresolved) { - require Carp; - Carp::carp("Undefined symbols present after loading $file: @unresolved\n"); - } - - $boot_symbol_ref = dl_find_symbol($libref, $bootname) or - croak("Can't find '$bootname' symbol in $file\n"); - - push(@dl_modules, $module); # record loaded module - - boot: - my $xs = dl_install_xsub("${module}::bootstrap", $boot_symbol_ref, $file); - - # See comment block above - - push(@dl_shared_objects, $file); # record files loaded - - &$xs(@args); -} - - -#sub _check_file { # private utility to handle dl_expandspec vs -f tests -# my($file) = @_; -# return $file if (!$do_expand && -f $file); # the common case -# return $file if ( $do_expand && ($file=dl_expandspec($file))); -# return undef; -#} - - -# Let autosplit and the autoloader deal with these functions: -__END__ - - -sub dl_findfile { - # Read ext/DynaLoader/DynaLoader.doc for detailed information. - # This function does not automatically consider the architecture - # or the perl library auto directories. - my (@args) = @_; - my (@dirs, $dir); # which directories to search - my (@found); # full paths to real files we have found - my $dl_ext= 'dll'; # $Config::Config{'dlext'} suffix for perl extensions - my $dl_so = 'dll'; # $Config::Config{'so'} suffix for shared libraries - - print STDERR "dl_findfile(@args)\n" if $dl_debug; - - # accumulate directories but process files as they appear - arg: foreach(@args) { - # Special fast case: full filepath requires no search - if ($Is_VMS && m%[:>/\]]% && -f $_) { - push(@found,dl_expandspec(VMS::Filespec::vmsify($_))); - last arg unless wantarray; - next; - } - elsif ($Is_MacOS) { - if (m/:/ && -f $_) { - push(@found,$_); - last arg unless wantarray; - } - } - elsif (m:/: && -f $_ && !$do_expand) { - push(@found,$_); - last arg unless wantarray; - next; - } - - # Deal with directories first: - # Using a -L prefix is the preferred option (faster and more robust) - if (m:^-L:) { s/^-L//; push(@dirs, $_); next; } - - if ($Is_MacOS) { - # Otherwise we try to try to spot directories by a heuristic - # (this is a more complicated issue than it first appears) - if (m/:/ && -d $_) { push(@dirs, $_); next; } - # Only files should get this far... - my(@names, $name); # what filenames to look for - s/^-l//; - push(@names, $_); - foreach $dir (@dirs, @dl_library_path) { - next unless -d $dir; - $dir =~ s/^([^:]+)$/:$1/; - $dir =~ s/:$//; - foreach $name (@names) { - my($file) = "$dir:$name"; - print STDERR " checking in $dir for $name\n" if $dl_debug; - if (-f $file) { - push(@found, $file); - next arg; # no need to look any further - } - } - } - next; - } - - # Otherwise we try to try to spot directories by a heuristic - # (this is a more complicated issue than it first appears) - if (m:/: && -d $_) { push(@dirs, $_); next; } - - # VMS: we may be using native VMS directory syntax instead of - # Unix emulation, so check this as well - if ($Is_VMS && /[:>\]]/ && -d $_) { push(@dirs, $_); next; } - - # Only files should get this far... - my(@names, $name); # what filenames to look for - if (m:-l: ) { # convert -lname to appropriate library name - s/-l//; - push(@names,"lib$_.$dl_so"); - push(@names,"lib$_.a"); - } else { # Umm, a bare name. Try various alternatives: - # these should be ordered with the most likely first - push(@names,"$_.$dl_ext") unless m/\.$dl_ext$/o; - push(@names,"$_.$dl_so") unless m/\.$dl_so$/o; - push(@names,"lib$_.$dl_so") unless m:/:; - push(@names,"$_.a") if !m/\.a$/ and $dlsrc eq "dl_dld.xs"; - push(@names, $_); - } - foreach $dir (@dirs, @dl_library_path) { - next unless -d $dir; - chop($dir = VMS::Filespec::unixpath($dir)) if $Is_VMS; - foreach $name (@names) { - my($file) = "$dir/$name"; - print STDERR " checking in $dir for $name\n" if $dl_debug; - $file = ($do_expand) ? dl_expandspec($file) : (-f $file && $file); - #$file = _check_file($file); - if ($file) { - push(@found, $file); - next arg; # no need to look any further - } - } - } - } - if ($dl_debug) { - foreach(@dirs) { - print STDERR " dl_findfile ignored non-existent directory: $_\n" unless -d $_; - } - print STDERR "dl_findfile found: @found\n"; - } - return $found[0] unless wantarray; - @found; -} - - -sub dl_expandspec { - my($spec) = @_; - # Optional function invoked if DynaLoader.pm sets $do_expand. - # Most systems do not require or use this function. - # Some systems may implement it in the dl_*.xs file in which case - # this autoload version will not be called but is harmless. - - # This function is designed to deal with systems which treat some - # 'filenames' in a special way. For example VMS 'Logical Names' - # (something like unix environment variables - but different). - # This function should recognise such names and expand them into - # full file paths. - # Must return undef if $spec is invalid or file does not exist. - - my $file = $spec; # default output to input - - if ($Is_VMS) { # dl_expandspec should be defined in dl_vms.xs - require Carp; - Carp::croak("dl_expandspec: should be defined in XS file!\n"); - } else { - return undef unless -f $file; - } - print STDERR "dl_expandspec($spec) => $file\n" if $dl_debug; - $file; -} - -sub dl_find_symbol_anywhere -{ - my $sym = shift; - my $libref; - foreach $libref (@dl_librefs) { - my $symref = dl_find_symbol($libref,$sym); - return $symref if $symref; - } - return undef; -} - -=head1 NAME - -DynaLoader - Dynamically load C libraries into Perl code - -=head1 SYNOPSIS - - package YourPackage; - require DynaLoader; - @ISA = qw(... DynaLoader ...); - bootstrap YourPackage; - - # optional method for 'global' loading - sub dl_load_flags { 0x01 } - - -=head1 DESCRIPTION - -This document defines a standard generic interface to the dynamic -linking mechanisms available on many platforms. Its primary purpose is -to implement automatic dynamic loading of Perl modules. - -This document serves as both a specification for anyone wishing to -implement the DynaLoader for a new platform and as a guide for -anyone wishing to use the DynaLoader directly in an application. - -The DynaLoader is designed to be a very simple high-level -interface that is sufficiently general to cover the requirements -of SunOS, HP-UX, NeXT, Linux, VMS and other platforms. - -It is also hoped that the interface will cover the needs of OS/2, NT -etc and also allow pseudo-dynamic linking (using C<ld -A> at runtime). - -It must be stressed that the DynaLoader, by itself, is practically -useless for accessing non-Perl libraries because it provides almost no -Perl-to-C 'glue'. There is, for example, no mechanism for calling a C -library function or supplying arguments. A C::DynaLib module -is available from CPAN sites which performs that function for some -common system types. And since the year 2000, there's also Inline::C, -a module that allows you to write Perl subroutines in C. Also available -from your local CPAN site. - -DynaLoader Interface Summary - - @dl_library_path - @dl_resolve_using - @dl_require_symbols - $dl_debug - @dl_librefs - @dl_modules - @dl_shared_objects - Implemented in: - bootstrap($modulename) Perl - @filepaths = dl_findfile(@names) Perl - $flags = $modulename->dl_load_flags Perl - $symref = dl_find_symbol_anywhere($symbol) Perl - - $libref = dl_load_file($filename, $flags) C - $status = dl_unload_file($libref) C - $symref = dl_find_symbol($libref, $symbol) C - @symbols = dl_undef_symbols() C - dl_install_xsub($name, $symref [, $filename]) C - $message = dl_error C - -=over 4 - -=item @dl_library_path - -The standard/default list of directories in which dl_findfile() will -search for libraries etc. Directories are searched in order: -$dl_library_path[0], [1], ... etc - -@dl_library_path is initialised to hold the list of 'normal' directories -(F</usr/lib>, etc) determined by B<Configure> (C<$Config{'libpth'}>). This should -ensure portability across a wide range of platforms. - -@dl_library_path should also be initialised with any other directories -that can be determined from the environment at runtime (such as -LD_LIBRARY_PATH for SunOS). - -After initialisation @dl_library_path can be manipulated by an -application using push and unshift before calling dl_findfile(). -Unshift can be used to add directories to the front of the search order -either to save search time or to override libraries with the same name -in the 'normal' directories. - -The load function that dl_load_file() calls may require an absolute -pathname. The dl_findfile() function and @dl_library_path can be -used to search for and return the absolute pathname for the -library/object that you wish to load. - -=item @dl_resolve_using - -A list of additional libraries or other shared objects which can be -used to resolve any undefined symbols that might be generated by a -later call to load_file(). - -This is only required on some platforms which do not handle dependent -libraries automatically. For example the Socket Perl extension -library (F<auto/Socket/Socket.so>) contains references to many socket -functions which need to be resolved when it's loaded. Most platforms -will automatically know where to find the 'dependent' library (e.g., -F</usr/lib/libsocket.so>). A few platforms need to be told the -location of the dependent library explicitly. Use @dl_resolve_using -for this. - -Example usage: - - @dl_resolve_using = dl_findfile('-lsocket'); - -=item @dl_require_symbols - -A list of one or more symbol names that are in the library/object file -to be dynamically loaded. This is only required on some platforms. - -=item @dl_librefs - -An array of the handles returned by successful calls to dl_load_file(), -made by bootstrap, in the order in which they were loaded. -Can be used with dl_find_symbol() to look for a symbol in any of -the loaded files. - -=item @dl_modules - -An array of module (package) names that have been bootstrap'ed. - -=item @dl_shared_objects - -An array of file names for the shared objects that were loaded. - -=item dl_error() - -Syntax: - - $message = dl_error(); - -Error message text from the last failed DynaLoader function. Note -that, similar to errno in unix, a successful function call does not -reset this message. - -Implementations should detect the error as soon as it occurs in any of -the other functions and save the corresponding message for later -retrieval. This will avoid problems on some platforms (such as SunOS) -where the error message is very temporary (e.g., dlerror()). - -=item $dl_debug - -Internal debugging messages are enabled when $dl_debug is set true. -Currently setting $dl_debug only affects the Perl side of the -DynaLoader. These messages should help an application developer to -resolve any DynaLoader usage problems. - -$dl_debug is set to C<$ENV{'PERL_DL_DEBUG'}> if defined. - -For the DynaLoader developer/porter there is a similar debugging -variable added to the C code (see dlutils.c) and enabled if Perl was -built with the B<-DDEBUGGING> flag. This can also be set via the -PERL_DL_DEBUG environment variable. Set to 1 for minimal information or -higher for more. - -=item dl_findfile() - -Syntax: - - @filepaths = dl_findfile(@names) - -Determine the full paths (including file suffix) of one or more -loadable files given their generic names and optionally one or more -directories. Searches directories in @dl_library_path by default and -returns an empty list if no files were found. - -Names can be specified in a variety of platform independent forms. Any -names in the form B<-lname> are converted into F<libname.*>, where F<.*> is -an appropriate suffix for the platform. - -If a name does not already have a suitable prefix and/or suffix then -the corresponding file will be searched for by trying combinations of -prefix and suffix appropriate to the platform: "$name.o", "lib$name.*" -and "$name". - -If any directories are included in @names they are searched before -@dl_library_path. Directories may be specified as B<-Ldir>. Any other -names are treated as filenames to be searched for. - -Using arguments of the form C<-Ldir> and C<-lname> is recommended. - -Example: - - @dl_resolve_using = dl_findfile(qw(-L/usr/5lib -lposix)); - - -=item dl_expandspec() - -Syntax: - - $filepath = dl_expandspec($spec) - -Some unusual systems, such as VMS, require special filename handling in -order to deal with symbolic names for files (i.e., VMS's Logical Names). - -To support these systems a dl_expandspec() function can be implemented -either in the F<dl_*.xs> file or code can be added to the autoloadable -dl_expandspec() function in F<DynaLoader.pm>. See F<DynaLoader.pm> for -more information. - -=item dl_load_file() - -Syntax: - - $libref = dl_load_file($filename, $flags) - -Dynamically load $filename, which must be the path to a shared object -or library. An opaque 'library reference' is returned as a handle for -the loaded object. Returns undef on error. - -The $flags argument to alters dl_load_file behaviour. -Assigned bits: - - 0x01 make symbols available for linking later dl_load_file's. - (only known to work on Solaris 2 using dlopen(RTLD_GLOBAL)) - (ignored under VMS; this is a normal part of image linking) - -(On systems that provide a handle for the loaded object such as SunOS -and HPUX, $libref will be that handle. On other systems $libref will -typically be $filename or a pointer to a buffer containing $filename. -The application should not examine or alter $libref in any way.) - -This is the function that does the real work. It should use the -current values of @dl_require_symbols and @dl_resolve_using if required. - - SunOS: dlopen($filename) - HP-UX: shl_load($filename) - Linux: dld_create_reference(@dl_require_symbols); dld_link($filename) - NeXT: rld_load($filename, @dl_resolve_using) - VMS: lib$find_image_symbol($filename,$dl_require_symbols[0]) - -(The dlopen() function is also used by Solaris and some versions of -Linux, and is a common choice when providing a "wrapper" on other -mechanisms as is done in the OS/2 port.) - -=item dl_unload_file() - -Syntax: - - $status = dl_unload_file($libref) - -Dynamically unload $libref, which must be an opaque 'library reference' as -returned from dl_load_file. Returns one on success and zero on failure. - -This function is optional and may not necessarily be provided on all platforms. -If it is defined, it is called automatically when the interpreter exits for -every shared object or library loaded by DynaLoader::bootstrap. All such -library references are stored in @dl_librefs by DynaLoader::Bootstrap as it -loads the libraries. The files are unloaded in last-in, first-out order. - -This unloading is usually necessary when embedding a shared-object perl (e.g. -one configured with -Duseshrplib) within a larger application, and the perl -interpreter is created and destroyed several times within the lifetime of the -application. In this case it is possible that the system dynamic linker will -unload and then subsequently reload the shared libperl without relocating any -references to it from any files DynaLoaded by the previous incarnation of the -interpreter. As a result, any shared objects opened by DynaLoader may point to -a now invalid 'ghost' of the libperl shared object, causing apparently random -memory corruption and crashes. This behaviour is most commonly seen when using -Apache and mod_perl built with the APXS mechanism. - - SunOS: dlclose($libref) - HP-UX: ??? - Linux: ??? - NeXT: ??? - VMS: ??? - -(The dlclose() function is also used by Solaris and some versions of -Linux, and is a common choice when providing a "wrapper" on other -mechanisms as is done in the OS/2 port.) - -=item dl_load_flags() - -Syntax: - - $flags = dl_load_flags $modulename; - -Designed to be a method call, and to be overridden by a derived class -(i.e. a class which has DynaLoader in its @ISA). The definition in -DynaLoader itself returns 0, which produces standard behavior from -dl_load_file(). - -=item dl_find_symbol() - -Syntax: - - $symref = dl_find_symbol($libref, $symbol) - -Return the address of the symbol $symbol or C<undef> if not found. If the -target system has separate functions to search for symbols of different -types then dl_find_symbol() should search for function symbols first and -then other types. - -The exact manner in which the address is returned in $symref is not -currently defined. The only initial requirement is that $symref can -be passed to, and understood by, dl_install_xsub(). - - SunOS: dlsym($libref, $symbol) - HP-UX: shl_findsym($libref, $symbol) - Linux: dld_get_func($symbol) and/or dld_get_symbol($symbol) - NeXT: rld_lookup("_$symbol") - VMS: lib$find_image_symbol($libref,$symbol) - - -=item dl_find_symbol_anywhere() - -Syntax: - - $symref = dl_find_symbol_anywhere($symbol) - -Applies dl_find_symbol() to the members of @dl_librefs and returns -the first match found. - -=item dl_undef_symbols() - -Example - - @symbols = dl_undef_symbols() - -Return a list of symbol names which remain undefined after load_file(). -Returns C<()> if not known. Don't worry if your platform does not provide -a mechanism for this. Most do not need it and hence do not provide it, -they just return an empty list. - - -=item dl_install_xsub() - -Syntax: - - dl_install_xsub($perl_name, $symref [, $filename]) - -Create a new Perl external subroutine named $perl_name using $symref as -a pointer to the function which implements the routine. This is simply -a direct call to newXSUB(). Returns a reference to the installed -function. - -The $filename parameter is used by Perl to identify the source file for -the function if required by die(), caller() or the debugger. If -$filename is not defined then "DynaLoader" will be used. - - -=item bootstrap() - -Syntax: - -bootstrap($module) - -This is the normal entry point for automatic dynamic loading in Perl. - -It performs the following actions: - -=over 8 - -=item * - -locates an auto/$module directory by searching @INC - -=item * - -uses dl_findfile() to determine the filename to load - -=item * - -sets @dl_require_symbols to C<("boot_$module")> - -=item * - -executes an F<auto/$module/$module.bs> file if it exists -(typically used to add to @dl_resolve_using any files which -are required to load the module on the current platform) - -=item * - -calls dl_load_flags() to determine how to load the file. - -=item * - -calls dl_load_file() to load the file - -=item * - -calls dl_undef_symbols() and warns if any symbols are undefined - -=item * - -calls dl_find_symbol() for "boot_$module" - -=item * - -calls dl_install_xsub() to install it as "${module}::bootstrap" - -=item * - -calls &{"${module}::bootstrap"} to bootstrap the module (actually -it uses the function reference returned by dl_install_xsub for speed) - -=back - -=back - - -=head1 AUTHOR - -Tim Bunce, 11 August 1994. - -This interface is based on the work and comments of (in no particular -order): Larry Wall, Robert Sanders, Dean Roehrich, Jeff Okamoto, Anno -Siegel, Thomas Neumann, Paul Marquess, Charles Bailey, myself and others. - -Larry Wall designed the elegant inherited bootstrap mechanism and -implemented the first Perl 5 dynamic loader using it. - -Solaris global loading added by Nick Ing-Simmons with design/coding -assistance from Tim Bunce, January 1996. - -=cut diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Encode.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Encode.pm deleted file mode 100644 index ac0123c89ec..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/Encode.pm +++ /dev/null @@ -1,851 +0,0 @@ -# -# $Id: Encode.pm,v 2.12 2005/09/08 14:17:17 dankogai Exp dankogai $ -# -package Encode; -use strict; -our $VERSION = sprintf "%d.%02d", q$Revision: 2.12 $ =~ /(\d+)/g; -sub DEBUG () { 0 } -use XSLoader (); -XSLoader::load(__PACKAGE__, $VERSION); - -require Exporter; -use base qw/Exporter/; - -# Public, encouraged API is exported by default - -our @EXPORT = qw( - decode decode_utf8 encode encode_utf8 - encodings find_encoding clone_encoding -); - -our @FB_FLAGS = qw(DIE_ON_ERR WARN_ON_ERR RETURN_ON_ERR LEAVE_SRC - PERLQQ HTMLCREF XMLCREF STOP_AT_PARTIAL); -our @FB_CONSTS = qw(FB_DEFAULT FB_CROAK FB_QUIET FB_WARN - FB_PERLQQ FB_HTMLCREF FB_XMLCREF); - -our @EXPORT_OK = - ( - qw( - _utf8_off _utf8_on define_encoding from_to is_16bit is_8bit - is_utf8 perlio_ok resolve_alias utf8_downgrade utf8_upgrade - ), - @FB_FLAGS, @FB_CONSTS, - ); - -our %EXPORT_TAGS = - ( - all => [ @EXPORT, @EXPORT_OK ], - fallbacks => [ @FB_CONSTS ], - fallback_all => [ @FB_CONSTS, @FB_FLAGS ], - ); - -# Documentation moved after __END__ for speed - NI-S - -our $ON_EBCDIC = (ord("A") == 193); - -use Encode::Alias; - -# Make a %Encoding package variable to allow a certain amount of cheating -our %Encoding; -our %ExtModule; -require Encode::Config; -eval { require Encode::ConfigLocal }; - -sub encodings -{ - my $class = shift; - my %enc; - if (@_ and $_[0] eq ":all"){ - %enc = ( %Encoding, %ExtModule ); - }else{ - %enc = %Encoding; - for my $mod (map {m/::/o ? $_ : "Encode::$_" } @_){ - DEBUG and warn $mod; - for my $enc (keys %ExtModule){ - $ExtModule{$enc} eq $mod and $enc{$enc} = $mod; - } - } - } - return - sort { lc $a cmp lc $b } - grep {!/^(?:Internal|Unicode|Guess)$/o} keys %enc; -} - -sub perlio_ok{ - my $obj = ref($_[0]) ? $_[0] : find_encoding($_[0]); - $obj->can("perlio_ok") and return $obj->perlio_ok(); - return 0; # safety net -} - -sub define_encoding -{ - my $obj = shift; - my $name = shift; - $Encoding{$name} = $obj; - my $lc = lc($name); - define_alias($lc => $obj) unless $lc eq $name; - while (@_){ - my $alias = shift; - define_alias($alias, $obj); - } - return $obj; -} - -sub getEncoding -{ - my ($class, $name, $skip_external) = @_; - - ref($name) && $name->can('renew') and return $name; - exists $Encoding{$name} and return $Encoding{$name}; - my $lc = lc $name; - exists $Encoding{$lc} and return $Encoding{$lc}; - - my $oc = $class->find_alias($name); - defined($oc) and return $oc; - $lc ne $name and $oc = $class->find_alias($lc); - defined($oc) and return $oc; - - unless ($skip_external) - { - if (my $mod = $ExtModule{$name} || $ExtModule{$lc}){ - $mod =~ s,::,/,g ; $mod .= '.pm'; - eval{ require $mod; }; - exists $Encoding{$name} and return $Encoding{$name}; - } - } - return; -} - -sub find_encoding($;$) -{ - my ($name, $skip_external) = @_; - return __PACKAGE__->getEncoding($name,$skip_external); -} - -sub resolve_alias($){ - my $obj = find_encoding(shift); - defined $obj and return $obj->name; - return; -} - -sub clone_encoding($){ - my $obj = find_encoding(shift); - ref $obj or return; - eval { require Storable }; - $@ and return; - return Storable::dclone($obj); -} - -sub encode($$;$) -{ - my ($name, $string, $check) = @_; - return undef unless defined $string; - $string .= '' if ref $string; # stringify; - $check ||=0; - my $enc = find_encoding($name); - unless(defined $enc){ - require Carp; - Carp::croak("Unknown encoding '$name'"); - } - my $octets = $enc->encode($string,$check); - $_[1] = $string if $check and !($check & LEAVE_SRC()); - return $octets; -} - -sub decode($$;$) -{ - my ($name,$octets,$check) = @_; - return undef unless defined $octets; - $octets .= '' if ref $octets; - $check ||=0; - my $enc = find_encoding($name); - unless(defined $enc){ - require Carp; - Carp::croak("Unknown encoding '$name'"); - } - my $string = $enc->decode($octets,$check); - $_[1] = $octets if $check and !($check & LEAVE_SRC()); - return $string; -} - -sub from_to($$$;$) -{ - my ($string,$from,$to,$check) = @_; - return undef unless defined $string; - $check ||=0; - my $f = find_encoding($from); - unless (defined $f){ - require Carp; - Carp::croak("Unknown encoding '$from'"); - } - my $t = find_encoding($to); - unless (defined $t){ - require Carp; - Carp::croak("Unknown encoding '$to'"); - } - my $uni = $f->decode($string,$check); - return undef if ($check && length($string)); - $string = $t->encode($uni,$check); - return undef if ($check && length($uni)); - return defined($_[0] = $string) ? length($string) : undef ; -} - -sub encode_utf8($) -{ - my ($str) = @_; - utf8::encode($str); - return $str; -} - -sub decode_utf8($;$) -{ - my ($str, $check) = @_; - if ($check){ - return decode("utf8", $str, $check); - }else{ - return decode("utf8", $str); - return $str; - } -} - -predefine_encodings(1); - -# -# This is to restore %Encoding if really needed; -# - -sub predefine_encodings{ - use Encode::Encoding; - no warnings 'redefine'; - my $use_xs = shift; - if ($ON_EBCDIC) { - # was in Encode::UTF_EBCDIC - package Encode::UTF_EBCDIC; - push @Encode::UTF_EBCDIC::ISA, 'Encode::Encoding'; - *decode = sub{ - my ($obj,$str,$chk) = @_; - my $res = ''; - for (my $i = 0; $i < length($str); $i++) { - $res .= - chr(utf8::unicode_to_native(ord(substr($str,$i,1)))); - } - $_[1] = '' if $chk; - return $res; - }; - *encode = sub{ - my ($obj,$str,$chk) = @_; - my $res = ''; - for (my $i = 0; $i < length($str); $i++) { - $res .= - chr(utf8::native_to_unicode(ord(substr($str,$i,1)))); - } - $_[1] = '' if $chk; - return $res; - }; - $Encode::Encoding{Unicode} = - bless {Name => "UTF_EBCDIC"} => "Encode::UTF_EBCDIC"; - } else { - package Encode::Internal; - push @Encode::Internal::ISA, 'Encode::Encoding'; - *decode = sub{ - my ($obj,$str,$chk) = @_; - utf8::upgrade($str); - $_[1] = '' if $chk; - return $str; - }; - *encode = \&decode; - $Encode::Encoding{Unicode} = - bless {Name => "Internal"} => "Encode::Internal"; - } - - { - # was in Encode::utf8 - package Encode::utf8; - push @Encode::utf8::ISA, 'Encode::Encoding'; - # - if ($use_xs){ - Encode::DEBUG and warn __PACKAGE__, " XS on"; - *decode = \&decode_xs; - *encode = \&encode_xs; - }else{ - Encode::DEBUG and warn __PACKAGE__, " XS off"; - *decode = sub{ - my ($obj,$octets,$chk) = @_; - my $str = Encode::decode_utf8($octets); - if (defined $str) { - $_[1] = '' if $chk; - return $str; - } - return undef; - }; - *encode = sub { - my ($obj,$string,$chk) = @_; - my $octets = Encode::encode_utf8($string); - $_[1] = '' if $chk; - return $octets; - }; - } - *cat_decode = sub{ # ($obj, $dst, $src, $pos, $trm, $chk) - my ($obj, undef, undef, $pos, $trm) = @_; # currently ignores $chk - my ($rdst, $rsrc, $rpos) = \@_[1,2,3]; - use bytes; - if ((my $npos = index($$rsrc, $trm, $pos)) >= 0) { - $$rdst .= substr($$rsrc, $pos, $npos - $pos + length($trm)); - $$rpos = $npos + length($trm); - return 1; - } - $$rdst .= substr($$rsrc, $pos); - $$rpos = length($$rsrc); - return ''; - }; - $Encode::Encoding{utf8} = - bless {Name => "utf8"} => "Encode::utf8"; - $Encode::Encoding{"utf-8-strict"} = - bless {Name => "utf-8-strict", strict_utf8 => 1 } => "Encode::utf8"; - } -} - -1; - -__END__ - -=head1 NAME - -Encode - character encodings - -=head1 SYNOPSIS - - use Encode; - -=head2 Table of Contents - -Encode consists of a collection of modules whose details are too big -to fit in one document. This POD itself explains the top-level APIs -and general topics at a glance. For other topics and more details, -see the PODs below: - - Name Description - -------------------------------------------------------- - Encode::Alias Alias definitions to encodings - Encode::Encoding Encode Implementation Base Class - Encode::Supported List of Supported Encodings - Encode::CN Simplified Chinese Encodings - Encode::JP Japanese Encodings - Encode::KR Korean Encodings - Encode::TW Traditional Chinese Encodings - -------------------------------------------------------- - -=head1 DESCRIPTION - -The C<Encode> module provides the interfaces between Perl's strings -and the rest of the system. Perl strings are sequences of -B<characters>. - -The repertoire of characters that Perl can represent is at least that -defined by the Unicode Consortium. On most platforms the ordinal -values of the characters (as returned by C<ord(ch)>) is the "Unicode -codepoint" for the character (the exceptions are those platforms where -the legacy encoding is some variant of EBCDIC rather than a super-set -of ASCII - see L<perlebcdic>). - -Traditionally, computer data has been moved around in 8-bit chunks -often called "bytes". These chunks are also known as "octets" in -networking standards. Perl is widely used to manipulate data of many -types - not only strings of characters representing human or computer -languages but also "binary" data being the machine's representation of -numbers, pixels in an image - or just about anything. - -When Perl is processing "binary data", the programmer wants Perl to -process "sequences of bytes". This is not a problem for Perl - as a -byte has 256 possible values, it easily fits in Perl's much larger -"logical character". - -=head2 TERMINOLOGY - -=over 2 - -=item * - -I<character>: a character in the range 0..(2**32-1) (or more). -(What Perl's strings are made of.) - -=item * - -I<byte>: a character in the range 0..255 -(A special case of a Perl character.) - -=item * - -I<octet>: 8 bits of data, with ordinal values 0..255 -(Term for bytes passed to or from a non-Perl context, e.g. a disk file.) - -=back - -=head1 PERL ENCODING API - -=over 2 - -=item $octets = encode(ENCODING, $string [, CHECK]) - -Encodes a string from Perl's internal form into I<ENCODING> and returns -a sequence of octets. ENCODING can be either a canonical name or -an alias. For encoding names and aliases, see L</"Defining Aliases">. -For CHECK, see L</"Handling Malformed Data">. - -For example, to convert a string from Perl's internal format to -iso-8859-1 (also known as Latin1), - - $octets = encode("iso-8859-1", $string); - -B<CAVEAT>: When you run C<$octets = encode("utf8", $string)>, then $octets -B<may not be equal to> $string. Though they both contain the same data, the utf8 flag -for $octets is B<always> off. When you encode anything, utf8 flag of -the result is always off, even when it contains completely valid utf8 -string. See L</"The UTF-8 flag"> below. - -If the $string is C<undef> then C<undef> is returned. - -=item $string = decode(ENCODING, $octets [, CHECK]) - -Decodes a sequence of octets assumed to be in I<ENCODING> into Perl's -internal form and returns the resulting string. As in encode(), -ENCODING can be either a canonical name or an alias. For encoding names -and aliases, see L</"Defining Aliases">. For CHECK, see -L</"Handling Malformed Data">. - -For example, to convert ISO-8859-1 data to a string in Perl's internal format: - - $string = decode("iso-8859-1", $octets); - -B<CAVEAT>: When you run C<$string = decode("utf8", $octets)>, then $string -B<may not be equal to> $octets. Though they both contain the same data, -the utf8 flag for $string is on unless $octets entirely consists of -ASCII data (or EBCDIC on EBCDIC machines). See L</"The UTF-8 flag"> -below. - -If the $string is C<undef> then C<undef> is returned. - -=item [$length =] from_to($octets, FROM_ENC, TO_ENC [, CHECK]) - -Converts B<in-place> data between two encodings. The data in $octets -must be encoded as octets and not as characters in Perl's internal -format. For example, to convert ISO-8859-1 data to Microsoft's CP1250 -encoding: - - from_to($octets, "iso-8859-1", "cp1250"); - -and to convert it back: - - from_to($octets, "cp1250", "iso-8859-1"); - -Note that because the conversion happens in place, the data to be -converted cannot be a string constant; it must be a scalar variable. - -from_to() returns the length of the converted string in octets on -success, I<undef> on error. - -B<CAVEAT>: The following operations look the same but are not quite so; - - from_to($data, "iso-8859-1", "utf8"); #1 - $data = decode("iso-8859-1", $data); #2 - -Both #1 and #2 make $data consist of a completely valid UTF-8 string -but only #2 turns utf8 flag on. #1 is equivalent to - - $data = encode("utf8", decode("iso-8859-1", $data)); - -See L</"The UTF-8 flag"> below. - -=item $octets = encode_utf8($string); - -Equivalent to C<$octets = encode("utf8", $string);> The characters -that comprise $string are encoded in Perl's internal format and the -result is returned as a sequence of octets. All possible -characters have a UTF-8 representation so this function cannot fail. - - -=item $string = decode_utf8($octets [, CHECK]); - -equivalent to C<$string = decode("utf8", $octets [, CHECK])>. -The sequence of octets represented by -$octets is decoded from UTF-8 into a sequence of logical -characters. Not all sequences of octets form valid UTF-8 encodings, so -it is possible for this call to fail. For CHECK, see -L</"Handling Malformed Data">. - -=back - -=head2 Listing available encodings - - use Encode; - @list = Encode->encodings(); - -Returns a list of the canonical names of the available encodings that -are loaded. To get a list of all available encodings including the -ones that are not loaded yet, say - - @all_encodings = Encode->encodings(":all"); - -Or you can give the name of a specific module. - - @with_jp = Encode->encodings("Encode::JP"); - -When "::" is not in the name, "Encode::" is assumed. - - @ebcdic = Encode->encodings("EBCDIC"); - -To find out in detail which encodings are supported by this package, -see L<Encode::Supported>. - -=head2 Defining Aliases - -To add a new alias to a given encoding, use: - - use Encode; - use Encode::Alias; - define_alias(newName => ENCODING); - -After that, newName can be used as an alias for ENCODING. -ENCODING may be either the name of an encoding or an -I<encoding object> - -But before you do so, make sure the alias is nonexistent with -C<resolve_alias()>, which returns the canonical name thereof. -i.e. - - Encode::resolve_alias("latin1") eq "iso-8859-1" # true - Encode::resolve_alias("iso-8859-12") # false; nonexistent - Encode::resolve_alias($name) eq $name # true if $name is canonical - -resolve_alias() does not need C<use Encode::Alias>; it can be -exported via C<use Encode qw(resolve_alias)>. - -See L<Encode::Alias> for details. - -=head1 Encoding via PerlIO - -If your perl supports I<PerlIO> (which is the default), you can use a PerlIO layer to decode -and encode directly via a filehandle. The following two examples -are totally identical in their functionality. - - # via PerlIO - open my $in, "<:encoding(shiftjis)", $infile or die; - open my $out, ">:encoding(euc-jp)", $outfile or die; - while(<$in>){ print $out $_; } - - # via from_to - open my $in, "<", $infile or die; - open my $out, ">", $outfile or die; - while(<$in>){ - from_to($_, "shiftjis", "euc-jp", 1); - print $out $_; - } - -Unfortunately, it may be that encodings are PerlIO-savvy. You can check -if your encoding is supported by PerlIO by calling the C<perlio_ok> -method. - - Encode::perlio_ok("hz"); # False - find_encoding("euc-cn")->perlio_ok; # True where PerlIO is available - - use Encode qw(perlio_ok); # exported upon request - perlio_ok("euc-jp") - -Fortunately, all encodings that come with Encode core are PerlIO-savvy -except for hz and ISO-2022-kr. For gory details, see -L<Encode::Encoding> and L<Encode::PerlIO>. - -=head1 Handling Malformed Data - -The optional I<CHECK> argument tells Encode what to do when it -encounters malformed data. Without CHECK, Encode::FB_DEFAULT ( == 0 ) -is assumed. - -As of version 2.12 Encode supports coderef values for CHECK. See below. - -=over 2 - -=item B<NOTE:> Not all encoding support this feature - -Some encodings ignore I<CHECK> argument. For example, -L<Encode::Unicode> ignores I<CHECK> and it always croaks on error. - -=back - -Now here is the list of I<CHECK> values available - -=over 2 - -=item I<CHECK> = Encode::FB_DEFAULT ( == 0) - -If I<CHECK> is 0, (en|de)code will put a I<substitution character> in -place of a malformed character. When you encode, E<lt>subcharE<gt> -will be used. When you decode the code point C<0xFFFD> is used. If -the data is supposed to be UTF-8, an optional lexical warning -(category utf8) is given. - -=item I<CHECK> = Encode::FB_CROAK ( == 1) - -If I<CHECK> is 1, methods will die on error immediately with an error -message. Therefore, when I<CHECK> is set to 1, you should trap the -error with eval{} unless you really want to let it die. - -=item I<CHECK> = Encode::FB_QUIET - -If I<CHECK> is set to Encode::FB_QUIET, (en|de)code will immediately -return the portion of the data that has been processed so far when an -error occurs. The data argument will be overwritten with everything -after that point (that is, the unprocessed part of data). This is -handy when you have to call decode repeatedly in the case where your -source data may contain partial multi-byte character sequences, -(i.e. you are reading with a fixed-width buffer). Here is a sample -code that does exactly this: - - my $buffer = ''; my $string = ''; - while(read $fh, $buffer, 256, length($buffer)){ - $string .= decode($encoding, $buffer, Encode::FB_QUIET); - # $buffer now contains the unprocessed partial character - } - -=item I<CHECK> = Encode::FB_WARN - -This is the same as above, except that it warns on error. Handy when -you are debugging the mode above. - -=item perlqq mode (I<CHECK> = Encode::FB_PERLQQ) - -=item HTML charref mode (I<CHECK> = Encode::FB_HTMLCREF) - -=item XML charref mode (I<CHECK> = Encode::FB_XMLCREF) - -For encodings that are implemented by Encode::XS, CHECK == -Encode::FB_PERLQQ turns (en|de)code into C<perlqq> fallback mode. - -When you decode, C<\xI<HH>> will be inserted for a malformed character, -where I<HH> is the hex representation of the octet that could not be -decoded to utf8. And when you encode, C<\x{I<HHHH>}> will be inserted, -where I<HHHH> is the Unicode ID of the character that cannot be found -in the character repertoire of the encoding. - -HTML/XML character reference modes are about the same, in place of -C<\x{I<HHHH>}>, HTML uses C<&#I<NNN>;> where I<NNN> is a decimal number and -XML uses C<&#xI<HHHH>;> where I<HHHH> is the hexadecimal number. - -In Encode 2.10 or later, C<LEAVE_SRC> is also implied. - -=item The bitmask - -These modes are actually set via a bitmask. Here is how the FB_XX -constants are laid out. You can import the FB_XX constants via -C<use Encode qw(:fallbacks)>; you can import the generic bitmask -constants via C<use Encode qw(:fallback_all)>. - - FB_DEFAULT FB_CROAK FB_QUIET FB_WARN FB_PERLQQ - DIE_ON_ERR 0x0001 X - WARN_ON_ERR 0x0002 X - RETURN_ON_ERR 0x0004 X X - LEAVE_SRC 0x0008 X - PERLQQ 0x0100 X - HTMLCREF 0x0200 - XMLCREF 0x0400 - -=back - -=head2 coderef for CHECK - -As of Encode 2.12 CHECK can also be a code reference which takes the -ord value of unmapped caharacter as an argument and returns a string -that represents the fallback character. For instance, - - $ascii = encode("ascii", $utf8, sub{ sprintf "<U+%04X>", shift }); - -Acts like FB_PERLQQ but E<lt>U+I<XXXX>E<gt> is used instead of -\x{I<XXXX>}. - -=head1 Defining Encodings - -To define a new encoding, use: - - use Encode qw(define_encoding); - define_encoding($object, 'canonicalName' [, alias...]); - -I<canonicalName> will be associated with I<$object>. The object -should provide the interface described in L<Encode::Encoding>. -If more than two arguments are provided then additional -arguments are taken as aliases for I<$object>. - -See L<Encode::Encoding> for more details. - -=head1 The UTF-8 flag - -Before the introduction of utf8 support in perl, The C<eq> operator -just compared the strings represented by two scalars. Beginning with -perl 5.8, C<eq> compares two strings with simultaneous consideration -of I<the utf8 flag>. To explain why we made it so, I will quote page -402 of C<Programming Perl, 3rd ed.> - -=over 2 - -=item Goal #1: - -Old byte-oriented programs should not spontaneously break on the old -byte-oriented data they used to work on. - -=item Goal #2: - -Old byte-oriented programs should magically start working on the new -character-oriented data when appropriate. - -=item Goal #3: - -Programs should run just as fast in the new character-oriented mode -as in the old byte-oriented mode. - -=item Goal #4: - -Perl should remain one language, rather than forking into a -byte-oriented Perl and a character-oriented Perl. - -=back - -Back when C<Programming Perl, 3rd ed.> was written, not even Perl 5.6.0 -was born and many features documented in the book remained -unimplemented for a long time. Perl 5.8 corrected this and the introduction -of the UTF-8 flag is one of them. You can think of this perl notion as of a -byte-oriented mode (utf8 flag off) and a character-oriented mode (utf8 -flag on). - -Here is how Encode takes care of the utf8 flag. - -=over 2 - -=item * - -When you encode, the resulting utf8 flag is always off. - -=item * - -When you decode, the resulting utf8 flag is on unless you can -unambiguously represent data. Here is the definition of -dis-ambiguity. - -After C<$utf8 = decode('foo', $octet);>, - - When $octet is... The utf8 flag in $utf8 is - --------------------------------------------- - In ASCII only (or EBCDIC only) OFF - In ISO-8859-1 ON - In any other Encoding ON - --------------------------------------------- - -As you see, there is one exception, In ASCII. That way you can assume -Goal #1. And with Encode Goal #2 is assumed but you still have to be -careful in such cases mentioned in B<CAVEAT> paragraphs. - -This utf8 flag is not visible in perl scripts, exactly for the same -reason you cannot (or you I<don't have to>) see if a scalar contains a -string, integer, or floating point number. But you can still peek -and poke these if you will. See the section below. - -=back - -=head2 Messing with Perl's Internals - -The following API uses parts of Perl's internals in the current -implementation. As such, they are efficient but may change. - -=over 2 - -=item is_utf8(STRING [, CHECK]) - -[INTERNAL] Tests whether the UTF-8 flag is turned on in the STRING. -If CHECK is true, also checks the data in STRING for being well-formed -UTF-8. Returns true if successful, false otherwise. - -As of perl 5.8.1, L<utf8> also has utf8::is_utf8(). - -=item _utf8_on(STRING) - -[INTERNAL] Turns on the UTF-8 flag in STRING. The data in STRING is -B<not> checked for being well-formed UTF-8. Do not use unless you -B<know> that the STRING is well-formed UTF-8. Returns the previous -state of the UTF-8 flag (so please don't treat the return value as -indicating success or failure), or C<undef> if STRING is not a string. - -=item _utf8_off(STRING) - -[INTERNAL] Turns off the UTF-8 flag in STRING. Do not use frivolously. -Returns the previous state of the UTF-8 flag (so please don't treat the -return value as indicating success or failure), or C<undef> if STRING is -not a string. - -=back - -=head1 UTF-8 vs. utf8 - - ....We now view strings not as sequences of bytes, but as sequences - of numbers in the range 0 .. 2**32-1 (or in the case of 64-bit - computers, 0 .. 2**64-1) -- Programming Perl, 3rd ed. - -That has been the perl's notion of UTF-8 but official UTF-8 is more -strict; Its ranges is much narrower (0 .. 10FFFF), some sequences are -not allowed (i.e. Those used in the surrogate pair, 0xFFFE, et al). - -Now that is overruled by Larry Wall himself. - - From: Larry Wall <larry@wall.org> - Date: December 04, 2004 11:51:58 JST - To: perl-unicode@perl.org - Subject: Re: Make Encode.pm support the real UTF-8 - Message-Id: <20041204025158.GA28754@wall.org> - - On Fri, Dec 03, 2004 at 10:12:12PM +0000, Tim Bunce wrote: - : I've no problem with 'utf8' being perl's unrestricted uft8 encoding, - : but "UTF-8" is the name of the standard and should give the - : corresponding behaviour. - - For what it's worth, that's how I've always kept them straight in my - head. - - Also for what it's worth, Perl 6 will mostly default to strict but - make it easy to switch back to lax. - - Larry - -Do you copy? As of Perl 5.8.7, B<UTF-8> means strict, official UTF-8 -while B<utf8> means liberal, lax, version thereof. And Encode version -2.10 or later thus groks the difference between C<UTF-8> and C"utf8". - - encode("utf8", "\x{FFFF_FFFF}", 1); # okay - encode("UTF-8", "\x{FFFF_FFFF}", 1); # croaks - -C<UTF-8> in Encode is actually a canonical name for C<utf-8-strict>. -Yes, the hyphen between "UTF" and "8" is important. Without it Encode -goes "liberal" - - find_encoding("UTF-8")->name # is 'utf-8-strict' - find_encoding("utf-8")->name # ditto. names are case insensitive - find_encoding("utf8")->name # ditto. "_" are treated as "-" - find_encoding("UTF8")->name # is 'utf8'. - - -=head1 SEE ALSO - -L<Encode::Encoding>, -L<Encode::Supported>, -L<Encode::PerlIO>, -L<encoding>, -L<perlebcdic>, -L<perlfunc/open>, -L<perlunicode>, -L<utf8>, -the Perl Unicode Mailing List E<lt>perl-unicode@perl.orgE<gt> - -=head1 MAINTAINER - -This project was originated by Nick Ing-Simmons and later maintained -by Dan Kogai E<lt>dankogai@dan.co.jpE<gt>. See AUTHORS for a full -list of people involved. For any questions, use -E<lt>perl-unicode@perl.orgE<gt> so we can all share. - -=cut diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Encode/Alias.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Encode/Alias.pm deleted file mode 100644 index c0bbf69f469..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/Encode/Alias.pm +++ /dev/null @@ -1,341 +0,0 @@ -package Encode::Alias; -use strict; -no warnings 'redefine'; -use Encode; -our $VERSION = do { my @r = (q$Revision: 2.4 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; -sub DEBUG () { 0 } - -use base qw(Exporter); - -# Public, encouraged API is exported by default - -our @EXPORT = - qw ( - define_alias - find_alias - ); - -our @Alias; # ordered matching list -our %Alias; # cached known aliases - -sub find_alias{ - my $class = shift; - my $find = shift; - unless (exists $Alias{$find}) { - $Alias{$find} = undef; # Recursion guard - for (my $i=0; $i < @Alias; $i += 2){ - my $alias = $Alias[$i]; - my $val = $Alias[$i+1]; - my $new; - if (ref($alias) eq 'Regexp' && $find =~ $alias){ - DEBUG and warn "eval $val"; - $new = eval $val; - DEBUG and $@ and warn "$val, $@"; - }elsif (ref($alias) eq 'CODE'){ - DEBUG and warn "$alias", "->", "($find)"; - $new = $alias->($find); - }elsif (lc($find) eq lc($alias)){ - $new = $val; - } - if (defined($new)){ - next if $new eq $find; # avoid (direct) recursion on bugs - DEBUG and warn "$alias, $new"; - my $enc = (ref($new)) ? $new : Encode::find_encoding($new); - if ($enc){ - $Alias{$find} = $enc; - last; - } - } - } - # case insensitive search when canonical is not in all lowercase - # RT ticket #7835 - unless ($Alias{$find}){ - my $lcfind = lc($find); - for my $name (keys %Encode::Encoding, keys %Encode::ExtModule){ - $lcfind eq lc($name) or next; - $Alias{$find} = Encode::find_encoding($name); - DEBUG and warn "$find => $name"; - } - } - } - if (DEBUG){ - my $name; - if (my $e = $Alias{$find}){ - $name = $e->name; - }else{ - $name = ""; - } - warn "find_alias($class, $find)->name = $name"; - } - return $Alias{$find}; -} - -sub define_alias{ - while (@_){ - my ($alias,$name) = splice(@_,0,2); - unshift(@Alias, $alias => $name); # newer one has precedence - if (ref($alias)){ - # clear %Alias cache to allow overrides - my @a = keys %Alias; - for my $k (@a){ - if (ref($alias) eq 'Regexp' && $k =~ $alias){ - DEBUG and warn "delete \$Alias\{$k\}"; - delete $Alias{$k}; - } - elsif (ref($alias) eq 'CODE'){ - DEBUG and warn "delete \$Alias\{$k\}"; - delete $Alias{$alias->($name)}; - } - } - }else{ - DEBUG and warn "delete \$Alias\{$alias\}"; - delete $Alias{$alias}; - } - } -} - -# Allow latin-1 style names as well -# 0 1 2 3 4 5 6 7 8 9 10 -our @Latin2iso = ( 0, 1, 2, 3, 4, 9, 10, 13, 14, 15, 16 ); -# Allow winlatin1 style names as well -our %Winlatin2cp = ( - 'latin1' => 1252, - 'latin2' => 1250, - 'cyrillic' => 1251, - 'greek' => 1253, - 'turkish' => 1254, - 'hebrew' => 1255, - 'arabic' => 1256, - 'baltic' => 1257, - 'vietnamese' => 1258, - ); - -init_aliases(); - -sub undef_aliases{ - @Alias = (); - %Alias = (); -} - -sub init_aliases -{ - undef_aliases(); - # Try all-lower-case version should all else fails - define_alias( qr/^(.*)$/ => '"\L$1"' ); - - # UTF/UCS stuff - define_alias( qr/^UTF-?7$/i => '"UTF-7"'); - define_alias( qr/^UCS-?2-?LE$/i => '"UCS-2LE"' ); - define_alias( qr/^UCS-?2-?(BE)?$/i => '"UCS-2BE"', - qr/^UCS-?4-?(BE|LE)?$/i => 'uc("UTF-32$1")', - qr/^iso-10646-1$/i => '"UCS-2BE"' ); - define_alias( qr/^UTF-?(16|32)-?BE$/i => '"UTF-$1BE"', - qr/^UTF-?(16|32)-?LE$/i => '"UTF-$1LE"', - qr/^UTF-?(16|32)$/i => '"UTF-$1"', - ); - # ASCII - define_alias(qr/^(?:US-?)ascii$/i => '"ascii"'); - define_alias('C' => 'ascii'); - define_alias(qr/\bISO[-_]?646[-_]?US$/i => '"ascii"'); - # Allow variants of iso-8859-1 etc. - define_alias( qr/\biso[-_]?(\d+)[-_](\d+)$/i => '"iso-$1-$2"' ); - - # At least HP-UX has these. - define_alias( qr/\biso8859(\d+)$/i => '"iso-8859-$1"' ); - - # More HP stuff. - define_alias( qr/\b(?:hp-)?(arabic|greek|hebrew|kana|roman|thai|turkish)8$/i => '"${1}8"' ); - - # The Official name of ASCII. - define_alias( qr/\bANSI[-_]?X3\.4[-_]?1968$/i => '"ascii"' ); - - # This is a font issue, not an encoding issue. - # (The currency symbol of the Latin 1 upper half - # has been redefined as the euro symbol.) - define_alias( qr/^(.+)\@euro$/i => '"$1"' ); - - define_alias( qr/\b(?:iso[-_]?)?latin[-_]?(\d+)$/i - => 'defined $Encode::Alias::Latin2iso[$1] ? "iso-8859-$Encode::Alias::Latin2iso[$1]" : undef' ); - - define_alias( qr/\bwin(latin[12]|cyrillic|baltic|greek|turkish| - hebrew|arabic|baltic|vietnamese)$/ix => - '"cp" . $Encode::Alias::Winlatin2cp{lc($1)}' ); - - # Common names for non-latin preferred MIME names - define_alias( 'ascii' => 'US-ascii', - 'cyrillic' => 'iso-8859-5', - 'arabic' => 'iso-8859-6', - 'greek' => 'iso-8859-7', - 'hebrew' => 'iso-8859-8', - 'thai' => 'iso-8859-11', - 'tis620' => 'iso-8859-11', - ); - - # At least AIX has IBM-NNN (surprisingly...) instead of cpNNN. - # And Microsoft has their own naming (again, surprisingly). - # And windows-* is registered in IANA! - define_alias( qr/\b(?:cp|ibm|ms|windows)[-_ ]?(\d{2,4})$/i => '"cp$1"'); - - # Sometimes seen with a leading zero. - # define_alias( qr/\bcp037\b/i => '"cp37"'); - - # Mac Mappings - # predefined in *.ucm; unneeded - # define_alias( qr/\bmacIcelandic$/i => '"macIceland"'); - define_alias( qr/^mac_(.*)$/i => '"mac$1"'); - # Ououououou. gone. They are differente! - # define_alias( qr/\bmacRomanian$/i => '"macRumanian"'); - - # Standardize on the dashed versions. - define_alias( qr/\bkoi8[\s\-_]*([ru])$/i => '"koi8-$1"' ); - - unless ($Encode::ON_EBCDIC){ - # for Encode::CN - define_alias( qr/\beuc.*cn$/i => '"euc-cn"' ); - define_alias( qr/\bcn.*euc$/i => '"euc-cn"' ); - # define_alias( qr/\bGB[- ]?(\d+)$/i => '"euc-cn"' ) - # CP936 doesn't have vendor-addon for GBK, so they're identical. - define_alias( qr/^gbk$/i => '"cp936"'); - # This fixes gb2312 vs. euc-cn confusion, practically - define_alias( qr/\bGB[-_ ]?2312(?!-?raw)/i => '"euc-cn"' ); - # for Encode::JP - define_alias( qr/\bjis$/i => '"7bit-jis"' ); - define_alias( qr/\beuc.*jp$/i => '"euc-jp"' ); - define_alias( qr/\bjp.*euc$/i => '"euc-jp"' ); - define_alias( qr/\bujis$/i => '"euc-jp"' ); - define_alias( qr/\bshift.*jis$/i => '"shiftjis"' ); - define_alias( qr/\bsjis$/i => '"shiftjis"' ); - define_alias( qr/\bwindows-31j$/i => '"cp932"' ); - # for Encode::KR - define_alias( qr/\beuc.*kr$/i => '"euc-kr"' ); - define_alias( qr/\bkr.*euc$/i => '"euc-kr"' ); - # This fixes ksc5601 vs. euc-kr confusion, practically - define_alias( qr/(?:x-)?uhc$/i => '"cp949"' ); - define_alias( qr/(?:x-)?windows-949$/i => '"cp949"' ); - define_alias( qr/\bks_c_5601-1987$/i => '"cp949"' ); - # for Encode::TW - define_alias( qr/\bbig-?5$/i => '"big5-eten"' ); - define_alias( qr/\bbig5-?et(?:en)?$/i => '"big5-eten"' ); - define_alias( qr/\btca[-_]?big5$/i => '"big5-eten"' ); - define_alias( qr/\bbig5-?hk(?:scs)?$/i => '"big5-hkscs"' ); - define_alias( qr/\bhk(?:scs)?[-_]?big5$/i => '"big5-hkscs"' ); - } - # utf8 is blessed :) - define_alias( qr/^UTF-8$/i => '"utf-8-strict"'); - # At last, Map white space and _ to '-' - define_alias( qr/^(\S+)[\s_]+(.*)$/i => '"$1-$2"' ); -} - -1; -__END__ - -# TODO: HP-UX '8' encodings arabic8 greek8 hebrew8 kana8 thai8 turkish8 -# TODO: HP-UX '15' encodings japanese15 korean15 roi15 -# TODO: Cyrillic encoding ISO-IR-111 (useful?) -# TODO: Armenian encoding ARMSCII-8 -# TODO: Hebrew encoding ISO-8859-8-1 -# TODO: Thai encoding TCVN -# TODO: Vietnamese encodings VPS -# TODO: Mac Asian+African encodings: Arabic Armenian Bengali Burmese -# ChineseSimp ChineseTrad Devanagari Ethiopic ExtArabic -# Farsi Georgian Gujarati Gurmukhi Hebrew Japanese -# Kannada Khmer Korean Laotian Malayalam Mongolian -# Oriya Sinhalese Symbol Tamil Telugu Tibetan Vietnamese - -=head1 NAME - -Encode::Alias - alias definitions to encodings - -=head1 SYNOPSIS - - use Encode; - use Encode::Alias; - define_alias( newName => ENCODING); - -=head1 DESCRIPTION - -Allows newName to be used as an alias for ENCODING. ENCODING may be -either the name of an encoding or an encoding object (as described -in L<Encode>). - -Currently I<newName> can be specified in the following ways: - -=over 4 - -=item As a simple string. - -=item As a qr// compiled regular expression, e.g.: - - define_alias( qr/^iso8859-(\d+)$/i => '"iso-8859-$1"' ); - -In this case, if I<ENCODING> is not a reference, it is C<eval>-ed -in order to allow C<$1> etc. to be substituted. The example is one -way to alias names as used in X11 fonts to the MIME names for the -iso-8859-* family. Note the double quotes inside the single quotes. - -(or, you don't have to do this yourself because this example is predefined) - -If you are using a regex here, you have to use the quotes as shown or -it won't work. Also note that regex handling is tricky even for the -experienced. Use this feature with caution. - -=item As a code reference, e.g.: - - define_alias( sub {shift =~ /^iso8859-(\d+)$/i ? "iso-8859-$1" : undef } ); - -The same effect as the example above in a different way. The coderef -takes the alias name as an argument and returns a canonical name on -success or undef if not. Note the second argument is not required. -Use this with even more caution than the regex version. - -=back - -=head3 Changes in code reference aliasing - -As of Encode 1.87, the older form - - define_alias( sub { return /^iso8859-(\d+)$/i ? "iso-8859-$1" : undef } ); - -no longer works. - -Encode up to 1.86 internally used "local $_" to implement ths older -form. But consider the code below; - - use Encode; - $_ = "eeeee" ; - while (/(e)/g) { - my $utf = decode('aliased-encoding-name', $1); - print "position:",pos,"\n"; - } - -Prior to Encode 1.86 this fails because of "local $_". - -=head2 Alias overloading - -You can override predefined aliases by simply applying define_alias(). -The new alias is always evaluated first, and when necessary, -define_alias() flushes the internal cache to make the new definition -available. - - # redirect SHIFT_JIS to MS/IBM Code Page 932, which is a - # superset of SHIFT_JIS - - define_alias( qr/shift.*jis$/i => '"cp932"' ); - define_alias( qr/sjis$/i => '"cp932"' ); - -If you want to zap all predefined aliases, you can use - - Encode::Alias->undef_aliases; - -to do so. And - - Encode::Alias->init_aliases; - -gets the factory settings back. - -=head1 SEE ALSO - -L<Encode>, L<Encode::Supported> - -=cut - diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Encode/Byte.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Encode/Byte.pm deleted file mode 100644 index d40c1c3d9d1..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/Encode/Byte.pm +++ /dev/null @@ -1,119 +0,0 @@ -package Encode::Byte; -use Encode; -our $VERSION = do { my @r = (q$Revision: 2.0 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; - -use XSLoader; -XSLoader::load(__PACKAGE__,$VERSION); - -1; -__END__ - -=head1 NAME - -Encode::Byte - Single Byte Encodings - -=head1 SYNOPSIS - - use Encode qw/encode decode/; - $greek = encode("iso-8859-7", $utf8); # loads Encode::Byte implicitly - $utf8 = decode("iso-8859-7", $greek); # ditto - -=head1 ABSTRACT - -This module implements various single byte encodings. For most cases it uses -\x80-\xff (upper half) to map non-ASCII characters. Encodings -supported are as follows. - - Canonical Alias Description - -------------------------------------------------------------------- - # ISO 8859 series - (iso-8859-1 is in built-in) - iso-8859-2 latin2 [ISO] - iso-8859-3 latin3 [ISO] - iso-8859-4 latin4 [ISO] - iso-8859-5 [ISO] - iso-8859-6 [ISO] - iso-8859-7 [ISO] - iso-8859-8 [ISO] - iso-8859-9 latin5 [ISO] - iso-8859-10 latin6 [ISO] - iso-8859-11 - (iso-8859-12 is nonexistent) - iso-8859-13 latin7 [ISO] - iso-8859-14 latin8 [ISO] - iso-8859-15 latin9 [ISO] - iso-8859-16 latin10 [ISO] - - # Cyrillic - koi8-f - koi8-r cp878 [RFC1489] - koi8-u [RFC2319] - - # Vietnamese - viscii - - # all cp* are also available as ibm-*, ms-*, and windows-* - # also see L<http://msdn.microsoft.com/workshop/author/dhtml/reference/charsets/charset4.asp> - - cp424 - cp437 - cp737 - cp775 - cp850 - cp852 - cp855 - cp856 - cp857 - cp860 - cp861 - cp862 - cp863 - cp864 - cp865 - cp866 - cp869 - cp874 - cp1006 - cp1250 WinLatin2 - cp1251 WinCyrillic - cp1252 WinLatin1 - cp1253 WinGreek - cp1254 WinTurkish - cp1255 WinHebrew - cp1256 WinArabic - cp1257 WinBaltic - cp1258 WinVietnamese - - # Macintosh - # Also see L<http://developer.apple.com/technotes/tn/tn1150.html> - MacArabic - MacCentralEurRoman - MacCroatian - MacCyrillic - MacFarsi - MacGreek - MacHebrew - MacIcelandic - MacRoman - MacRomanian - MacRumanian - MacSami - MacThai - MacTurkish - MacUkrainian - - # More vendor encodings - AdobeStandardEncoding - nextstep - gsm0338 # used in GSM handsets - hp-roman8 - -=head1 DESCRIPTION - -To find how to use this module in detail, see L<Encode>. - -=head1 SEE ALSO - -L<Encode> - -=cut diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Encode/Config.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Encode/Config.pm deleted file mode 100644 index d69b92d8248..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/Encode/Config.pm +++ /dev/null @@ -1,166 +0,0 @@ -# -# Demand-load module list -# -package Encode::Config; -our $VERSION = do { my @r = (q$Revision: 2.1 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; - -use strict; - -our %ExtModule = - ( - # Encode::Byte - #iso-8859-1 is in Encode.pm itself - 'iso-8859-2' => 'Encode::Byte', - 'iso-8859-3' => 'Encode::Byte', - 'iso-8859-4' => 'Encode::Byte', - 'iso-8859-5' => 'Encode::Byte', - 'iso-8859-6' => 'Encode::Byte', - 'iso-8859-7' => 'Encode::Byte', - 'iso-8859-8' => 'Encode::Byte', - 'iso-8859-9' => 'Encode::Byte', - 'iso-8859-10' => 'Encode::Byte', - 'iso-8859-11' => 'Encode::Byte', - 'iso-8859-13' => 'Encode::Byte', - 'iso-8859-14' => 'Encode::Byte', - 'iso-8859-15' => 'Encode::Byte', - 'iso-8859-16' => 'Encode::Byte', - 'koi8-f' => 'Encode::Byte', - 'koi8-r' => 'Encode::Byte', - 'koi8-u' => 'Encode::Byte', - 'viscii' => 'Encode::Byte', - 'cp424' => 'Encode::Byte', - 'cp437' => 'Encode::Byte', - 'cp737' => 'Encode::Byte', - 'cp775' => 'Encode::Byte', - 'cp850' => 'Encode::Byte', - 'cp852' => 'Encode::Byte', - 'cp855' => 'Encode::Byte', - 'cp856' => 'Encode::Byte', - 'cp857' => 'Encode::Byte', - 'cp860' => 'Encode::Byte', - 'cp861' => 'Encode::Byte', - 'cp862' => 'Encode::Byte', - 'cp863' => 'Encode::Byte', - 'cp864' => 'Encode::Byte', - 'cp865' => 'Encode::Byte', - 'cp866' => 'Encode::Byte', - 'cp869' => 'Encode::Byte', - 'cp874' => 'Encode::Byte', - 'cp1006' => 'Encode::Byte', - 'cp1250' => 'Encode::Byte', - 'cp1251' => 'Encode::Byte', - 'cp1252' => 'Encode::Byte', - 'cp1253' => 'Encode::Byte', - 'cp1254' => 'Encode::Byte', - 'cp1255' => 'Encode::Byte', - 'cp1256' => 'Encode::Byte', - 'cp1257' => 'Encode::Byte', - 'cp1258' => 'Encode::Byte', - 'AdobeStandardEncoding' => 'Encode::Byte', - 'MacArabic' => 'Encode::Byte', - 'MacCentralEurRoman' => 'Encode::Byte', - 'MacCroatian' => 'Encode::Byte', - 'MacCyrillic' => 'Encode::Byte', - 'MacFarsi' => 'Encode::Byte', - 'MacGreek' => 'Encode::Byte', - 'MacHebrew' => 'Encode::Byte', - 'MacIcelandic' => 'Encode::Byte', - 'MacRoman' => 'Encode::Byte', - 'MacRomanian' => 'Encode::Byte', - 'MacRumanian' => 'Encode::Byte', - 'MacSami' => 'Encode::Byte', - 'MacThai' => 'Encode::Byte', - 'MacTurkish' => 'Encode::Byte', - 'MacUkrainian' => 'Encode::Byte', - 'nextstep' => 'Encode::Byte', - 'hp-roman8' => 'Encode::Byte', - 'gsm0338' => 'Encode::Byte', - # Encode::EBCDIC - 'cp37' => 'Encode::EBCDIC', - 'cp500' => 'Encode::EBCDIC', - 'cp875' => 'Encode::EBCDIC', - 'cp1026' => 'Encode::EBCDIC', - 'cp1047' => 'Encode::EBCDIC', - 'posix-bc' => 'Encode::EBCDIC', - # Encode::Symbol - 'dingbats' => 'Encode::Symbol', - 'symbol' => 'Encode::Symbol', - 'AdobeSymbol' => 'Encode::Symbol', - 'AdobeZdingbat' => 'Encode::Symbol', - 'MacDingbats' => 'Encode::Symbol', - 'MacSymbol' => 'Encode::Symbol', - # Encode::Unicode - 'UCS-2BE' => 'Encode::Unicode', - 'UCS-2LE' => 'Encode::Unicode', - 'UTF-16' => 'Encode::Unicode', - 'UTF-16BE' => 'Encode::Unicode', - 'UTF-16LE' => 'Encode::Unicode', - 'UTF-32' => 'Encode::Unicode', - 'UTF-32BE' => 'Encode::Unicode', - 'UTF-32LE' => 'Encode::Unicode', - 'UTF-7' => 'Encode::Unicode::UTF7', - ); - -unless (ord("A") == 193){ - %ExtModule = - ( - %ExtModule, - 'euc-cn' => 'Encode::CN', - 'gb12345-raw' => 'Encode::CN', - 'gb2312-raw' => 'Encode::CN', - 'hz' => 'Encode::CN', - 'iso-ir-165' => 'Encode::CN', - 'cp936' => 'Encode::CN', - 'MacChineseSimp' => 'Encode::CN', - - '7bit-jis' => 'Encode::JP', - 'euc-jp' => 'Encode::JP', - 'iso-2022-jp' => 'Encode::JP', - 'iso-2022-jp-1' => 'Encode::JP', - 'jis0201-raw' => 'Encode::JP', - 'jis0208-raw' => 'Encode::JP', - 'jis0212-raw' => 'Encode::JP', - 'cp932' => 'Encode::JP', - 'MacJapanese' => 'Encode::JP', - 'shiftjis' => 'Encode::JP', - - - 'euc-kr' => 'Encode::KR', - 'iso-2022-kr' => 'Encode::KR', - 'johab' => 'Encode::KR', - 'ksc5601-raw' => 'Encode::KR', - 'cp949' => 'Encode::KR', - 'MacKorean' => 'Encode::KR', - - 'big5-eten' => 'Encode::TW', - 'big5-hkscs' => 'Encode::TW', - 'cp950' => 'Encode::TW', - 'MacChineseTrad' => 'Encode::TW', - - #'big5plus' => 'Encode::HanExtra', - #'euc-tw' => 'Encode::HanExtra', - #'gb18030' => 'Encode::HanExtra', - - 'MIME-Header' => 'Encode::MIME::Header', - 'MIME-B' => 'Encode::MIME::Header', - 'MIME-Q' => 'Encode::MIME::Header', - - 'MIME-Header-ISO_2022_JP' => 'Encode::MIME::Header::ISO_2022_JP', - ); -} - -# -# Why not export ? to keep ConfigLocal Happy! -# -while (my ($enc,$mod) = each %ExtModule){ - $Encode::ExtModule{$enc} = $mod; -} - -1; -__END__ - -=head1 NAME - -Encode::Config -- internally used by Encode - -=cut diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Encode/Encoding.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Encode/Encoding.pm deleted file mode 100644 index 06af9fb6994..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/Encode/Encoding.pm +++ /dev/null @@ -1,341 +0,0 @@ -package Encode::Encoding; -# Base class for classes which implement encodings -use strict; -our $VERSION = do { my @r = (q$Revision: 2.2 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; - -require Encode; - -sub DEBUG { 0 } -sub Define -{ - my $obj = shift; - my $canonical = shift; - $obj = bless { Name => $canonical },$obj unless ref $obj; - # warn "$canonical => $obj\n"; - Encode::define_encoding($obj, $canonical, @_); -} - -sub name { return shift->{'Name'} } - -# sub renew { return $_[0] } - -sub renew { - my $self = shift; - my $clone = bless { %$self } => ref($self); - $clone->{renewed}++; # so the caller can see it - DEBUG and warn $clone->{renewed}; - return $clone; -} - -sub renewed{ return $_[0]->{renewed} || 0 } - -*new_sequence = \&renew; - -sub needs_lines { 0 }; - -sub perlio_ok { - eval{ require PerlIO::encoding }; - return $@ ? 0 : 1; -} - -# (Temporary|legacy) methods - -sub toUnicode { shift->decode(@_) } -sub fromUnicode { shift->encode(@_) } - -# -# Needs to be overloaded or just croak -# - -sub encode { - require Carp; - my $obj = shift; - my $class = ref($obj) ? ref($obj) : $obj; - Carp::croak($class . "->encode() not defined!"); -} - -sub decode{ - require Carp; - my $obj = shift; - my $class = ref($obj) ? ref($obj) : $obj; - Carp::croak($class . "->encode() not defined!"); -} - -sub DESTROY {} - -1; -__END__ - -=head1 NAME - -Encode::Encoding - Encode Implementation Base Class - -=head1 SYNOPSIS - - package Encode::MyEncoding; - use base qw(Encode::Encoding); - - __PACKAGE__->Define(qw(myCanonical myAlias)); - -=head1 DESCRIPTION - -As mentioned in L<Encode>, encodings are (in the current -implementation at least) defined as objects. The mapping of encoding -name to object is via the C<%Encode::Encoding> hash. Though you can -directly manipulate this hash, it is strongly encouraged to use this -base class module and add encode() and decode() methods. - -=head2 Methods you should implement - -You are strongly encouraged to implement methods below, at least -either encode() or decode(). - -=over 4 - -=item -E<gt>encode($string [,$check]) - -MUST return the octet sequence representing I<$string>. - -=over 2 - -=item * - -If I<$check> is true, it SHOULD modify I<$string> in place to remove -the converted part (i.e. the whole string unless there is an error). -If perlio_ok() is true, SHOULD becomes MUST. - -=item * - -If an error occurs, it SHOULD return the octet sequence for the -fragment of string that has been converted and modify $string in-place -to remove the converted part leaving it starting with the problem -fragment. If perlio_ok() is true, SHOULD becomes MUST. - -=item * - -If I<$check> is is false then C<encode> MUST make a "best effort" to -convert the string - for example, by using a replacement character. - -=back - -=item -E<gt>decode($octets [,$check]) - -MUST return the string that I<$octets> represents. - -=over 2 - -=item * - -If I<$check> is true, it SHOULD modify I<$octets> in place to remove -the converted part (i.e. the whole sequence unless there is an -error). If perlio_ok() is true, SHOULD becomes MUST. - -=item * - -If an error occurs, it SHOULD return the fragment of string that has -been converted and modify $octets in-place to remove the converted -part leaving it starting with the problem fragment. If perlio_ok() is -true, SHOULD becomes MUST. - -=item * - -If I<$check> is false then C<decode> should make a "best effort" to -convert the string - for example by using Unicode's "\x{FFFD}" as a -replacement character. - -=back - -=back - -If you want your encoding to work with L<encoding> pragma, you should -also implement the method below. - -=over 4 - -=item -E<gt>cat_decode($destination, $octets, $offset, $terminator [,$check]) - -MUST decode I<$octets> with I<$offset> and concatenate it to I<$destination>. -Decoding will terminate when $terminator (a string) appears in output. -I<$offset> will be modified to the last $octets position at end of decode. -Returns true if $terminator appears output, else returns false. - -=back - -=head2 Other methods defined in Encode::Encodings - -You do not have to override methods shown below unless you have to. - -=over 4 - -=item -E<gt>name - -Predefined As: - - sub name { return shift->{'Name'} } - -MUST return the string representing the canonical name of the encoding. - -=item -E<gt>renew - -Predefined As: - - sub renew { - my $self = shift; - my $clone = bless { %$self } => ref($self); - $clone->{renewed}++; - return $clone; - } - -This method reconstructs the encoding object if necessary. If you need -to store the state during encoding, this is where you clone your object. - -PerlIO ALWAYS calls this method to make sure it has its own private -encoding object. - -=item -E<gt>renewed - -Predefined As: - - sub renewed { $_[0]->{renewed} || 0 } - -Tells whether the object is renewed (and how many times). Some -modules emit C<Use of uninitialized value in null operation> warning -unless the value is numeric so return 0 for false. - -=item -E<gt>perlio_ok() - -Predefined As: - - sub perlio_ok { - eval{ require PerlIO::encoding }; - return $@ ? 0 : 1; - } - -If your encoding does not support PerlIO for some reasons, just; - - sub perlio_ok { 0 } - -=item -E<gt>needs_lines() - -Predefined As: - - sub needs_lines { 0 }; - -If your encoding can work with PerlIO but needs line buffering, you -MUST define this method so it returns true. 7bit ISO-2022 encodings -are one example that needs this. When this method is missing, false -is assumed. - -=back - -=head2 Example: Encode::ROT13 - - package Encode::ROT13; - use strict; - use base qw(Encode::Encoding); - - __PACKAGE__->Define('rot13'); - - sub encode($$;$){ - my ($obj, $str, $chk) = @_; - $str =~ tr/A-Za-z/N-ZA-Mn-za-m/; - $_[1] = '' if $chk; # this is what in-place edit means - return $str; - } - - # Jr pna or ynml yvxr guvf; - *decode = \&encode; - - 1; - -=head1 Why the heck Encode API is different? - -It should be noted that the I<$check> behaviour is different from the -outer public API. The logic is that the "unchecked" case is useful -when the encoding is part of a stream which may be reporting errors -(e.g. STDERR). In such cases, it is desirable to get everything -through somehow without causing additional errors which obscure the -original one. Also, the encoding is best placed to know what the -correct replacement character is, so if that is the desired behaviour -then letting low level code do it is the most efficient. - -By contrast, if I<$check> is true, the scheme above allows the -encoding to do as much as it can and tell the layer above how much -that was. What is lacking at present is a mechanism to report what -went wrong. The most likely interface will be an additional method -call to the object, or perhaps (to avoid forcing per-stream objects -on otherwise stateless encodings) an additional parameter. - -It is also highly desirable that encoding classes inherit from -C<Encode::Encoding> as a base class. This allows that class to define -additional behaviour for all encoding objects. - - package Encode::MyEncoding; - use base qw(Encode::Encoding); - - __PACKAGE__->Define(qw(myCanonical myAlias)); - -to create an object with C<< bless {Name => ...}, $class >>, and call -define_encoding. They inherit their C<name> method from -C<Encode::Encoding>. - -=head2 Compiled Encodings - -For the sake of speed and efficiency, most of the encodings are now -supported via a I<compiled form>: XS modules generated from UCM -files. Encode provides the enc2xs tool to achieve that. Please see -L<enc2xs> for more details. - -=head1 SEE ALSO - -L<perlmod>, L<enc2xs> - -=begin future - -=over 4 - -=item Scheme 1 - -The fixup routine gets passed the remaining fragment of string being -processed. It modifies it in place to remove bytes/characters it can -understand and returns a string used to represent them. For example: - - sub fixup { - my $ch = substr($_[0],0,1,''); - return sprintf("\x{%02X}",ord($ch); - } - -This scheme is close to how the underlying C code for Encode works, -but gives the fixup routine very little context. - -=item Scheme 2 - -The fixup routine gets passed the original string, an index into -it of the problem area, and the output string so far. It appends -what it wants to the output string and returns a new index into the -original string. For example: - - sub fixup { - # my ($s,$i,$d) = @_; - my $ch = substr($_[0],$_[1],1); - $_[2] .= sprintf("\x{%02X}",ord($ch); - return $_[1]+1; - } - -This scheme gives maximal control to the fixup routine but is more -complicated to code, and may require that the internals of Encode be tweaked to -keep the original string intact. - -=item Other Schemes - -Hybrids of the above. - -Multiple return values rather than in-place modifications. - -Index into the string could be C<pos($str)> allowing C<s/\G...//>. - -=back - -=end future - -=cut diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Encode/Unicode.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Encode/Unicode.pm deleted file mode 100644 index 4d0c31d82d3..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/Encode/Unicode.pm +++ /dev/null @@ -1,268 +0,0 @@ -package Encode::Unicode; - -use strict; -use warnings; -no warnings 'redefine'; - -our $VERSION = do { my @r = (q$Revision: 2.2 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; - -use XSLoader; -XSLoader::load(__PACKAGE__,$VERSION); - -# -# Object Generator 8 transcoders all at once! -# - -require Encode; - -our %BOM_Unknown = map {$_ => 1} qw(UTF-16 UTF-32); - -for my $name (qw(UTF-16 UTF-16BE UTF-16LE - UTF-32 UTF-32BE UTF-32LE - UCS-2BE UCS-2LE)) -{ - my ($size, $endian, $ucs2, $mask); - $name =~ /^(\w+)-(\d+)(\w*)$/o; - if ($ucs2 = ($1 eq 'UCS')){ - $size = 2; - }else{ - $size = $2/8; - } - $endian = ($3 eq 'BE') ? 'n' : ($3 eq 'LE') ? 'v' : '' ; - $size == 4 and $endian = uc($endian); - - $Encode::Encoding{$name} = - bless { - Name => $name, - size => $size, - endian => $endian, - ucs2 => $ucs2, - } => __PACKAGE__; -} - -use base qw(Encode::Encoding); - -sub renew { - my $self = shift; - $BOM_Unknown{$self->name} or return $self; - my $clone = bless { %$self } => ref($self); - $clone->{renewed}++; # so the caller knows it is renewed. - return $clone; -} - -# There used to be a perl implemntation of (en|de)code but with -# XS version is ripe, perl version is zapped for optimal speed - -*decode = \&decode_xs; -*encode = \&encode_xs; - -1; -__END__ - -=head1 NAME - -Encode::Unicode -- Various Unicode Transformation Formats - -=cut - -=head1 SYNOPSIS - - use Encode qw/encode decode/; - $ucs2 = encode("UCS-2BE", $utf8); - $utf8 = decode("UCS-2BE", $ucs2); - -=head1 ABSTRACT - -This module implements all Character Encoding Schemes of Unicode that -are officially documented by Unicode Consortium (except, of course, -for UTF-8, which is a native format in perl). - -=over 4 - -=item L<http://www.unicode.org/glossary/> says: - -I<Character Encoding Scheme> A character encoding form plus byte -serialization. There are Seven character encoding schemes in Unicode: -UTF-8, UTF-16, UTF-16BE, UTF-16LE, UTF-32 (UCS-4), UTF-32BE (UCS-4BE) and -UTF-32LE (UCS-4LE), and UTF-7. - -Since UTF-7 is a 7-bit (re)encoded version of UTF-16BE, It is not part of -Unicode's Character Encoding Scheme. It is separately implemented in -Encode::Unicode::UTF7. For details see L<Encode::Unicode::UTF7>. - -=item Quick Reference - - Decodes from ord(N) Encodes chr(N) to... - octet/char BOM S.P d800-dfff ord > 0xffff \x{1abcd} == - ---------------+-----------------+------------------------------ - UCS-2BE 2 N N is bogus Not Available - UCS-2LE 2 N N bogus Not Available - UTF-16 2/4 Y Y is S.P S.P BE/LE - UTF-16BE 2/4 N Y S.P S.P 0xd82a,0xdfcd - UTF-16LE 2 N Y S.P S.P 0x2ad8,0xcddf - UTF-32 4 Y - is bogus As is BE/LE - UTF-32BE 4 N - bogus As is 0x0001abcd - UTF-32LE 4 N - bogus As is 0xcdab0100 - UTF-8 1-4 - - bogus >= 4 octets \xf0\x9a\af\8d - ---------------+-----------------+------------------------------ - -=back - -=head1 Size, Endianness, and BOM - -You can categorize these CES by 3 criteria: size of each character, -endianness, and Byte Order Mark. - -=head2 by size - -UCS-2 is a fixed-length encoding with each character taking 16 bits. -It B<does not> support I<surrogate pairs>. When a surrogate pair -is encountered during decode(), its place is filled with \x{FFFD} -if I<CHECK> is 0, or the routine croaks if I<CHECK> is 1. When a -character whose ord value is larger than 0xFFFF is encountered, -its place is filled with \x{FFFD} if I<CHECK> is 0, or the routine -croaks if I<CHECK> is 1. - -UTF-16 is almost the same as UCS-2 but it supports I<surrogate pairs>. -When it encounters a high surrogate (0xD800-0xDBFF), it fetches the -following low surrogate (0xDC00-0xDFFF) and C<desurrogate>s them to -form a character. Bogus surrogates result in death. When \x{10000} -or above is encountered during encode(), it C<ensurrogate>s them and -pushes the surrogate pair to the output stream. - -UTF-32 (UCS-4) is a fixed-length encoding with each character taking 32 bits. -Since it is 32-bit, there is no need for I<surrogate pairs>. - -=head2 by endianness - -The first (and now failed) goal of Unicode was to map all character -repertoires into a fixed-length integer so that programmers are happy. -Since each character is either a I<short> or I<long> in C, you have to -pay attention to the endianness of each platform when you pass data -to one another. - -Anything marked as BE is Big Endian (or network byte order) and LE is -Little Endian (aka VAX byte order). For anything not marked either -BE or LE, a character called Byte Order Mark (BOM) indicating the -endianness is prepended to the string. - -CAVEAT: Though BOM in utf8 (\xEF\xBB\xBF) is valid, it is meaningless -and as of this writing Encode suite just leave it as is (\x{FeFF}). - -=over 4 - -=item BOM as integer when fetched in network byte order - - 16 32 bits/char - ------------------------- - BE 0xFeFF 0x0000FeFF - LE 0xFFeF 0xFFFe0000 - ------------------------- - -=back - -This modules handles the BOM as follows. - -=over 4 - -=item * - -When BE or LE is explicitly stated as the name of encoding, BOM is -simply treated as a normal character (ZERO WIDTH NO-BREAK SPACE). - -=item * - -When BE or LE is omitted during decode(), it checks if BOM is at the -beginning of the string; if one is found, the endianness is set to -what the BOM says. If no BOM is found, the routine dies. - -=item * - -When BE or LE is omitted during encode(), it returns a BE-encoded -string with BOM prepended. So when you want to encode a whole text -file, make sure you encode() the whole text at once, not line by line -or each line, not file, will have a BOM prepended. - -=item * - -C<UCS-2> is an exception. Unlike others, this is an alias of UCS-2BE. -UCS-2 is already registered by IANA and others that way. - -=back - -=head1 Surrogate Pairs - -To say the least, surrogate pairs were the biggest mistake of the -Unicode Consortium. But according to the late Douglas Adams in I<The -Hitchhiker's Guide to the Galaxy> Trilogy, C<In the beginning the -Universe was created. This has made a lot of people very angry and -been widely regarded as a bad move>. Their mistake was not of this -magnitude so let's forgive them. - -(I don't dare make any comparison with Unicode Consortium and the -Vogons here ;) Or, comparing Encode to Babel Fish is completely -appropriate -- if you can only stick this into your ear :) - -Surrogate pairs were born when the Unicode Consortium finally -admitted that 16 bits were not big enough to hold all the world's -character repertoires. But they already made UCS-2 16-bit. What -do we do? - -Back then, the range 0xD800-0xDFFF was not allocated. Let's split -that range in half and use the first half to represent the C<upper -half of a character> and the second half to represent the C<lower -half of a character>. That way, you can represent 1024 * 1024 = -1048576 more characters. Now we can store character ranges up to -\x{10ffff} even with 16-bit encodings. This pair of half-character is -now called a I<surrogate pair> and UTF-16 is the name of the encoding -that embraces them. - -Here is a formula to ensurrogate a Unicode character \x{10000} and -above; - - $hi = ($uni - 0x10000) / 0x400 + 0xD800; - $lo = ($uni - 0x10000) % 0x400 + 0xDC00; - -And to desurrogate; - - $uni = 0x10000 + ($hi - 0xD800) * 0x400 + ($lo - 0xDC00); - -Note this move has made \x{D800}-\x{DFFF} into a forbidden zone but -perl does not prohibit the use of characters within this range. To perl, -every one of \x{0000_0000} up to \x{ffff_ffff} (*) is I<a character>. - - (*) or \x{ffff_ffff_ffff_ffff} if your perl is compiled with 64-bit - integer support! - -=head1 Error Checking - -Unlike most encodings which accept various ways to handle errors, -Unicode encodings simply croaks. - - % perl -MEncode -e '$_ = "\xfe\xff\xd8\xd9\xda\xdb\0\n"' \ - -e 'Encode::from_to($_, "utf16","shift_jis", 0); print' - UTF-16:Malformed LO surrogate d8d9 at /path/to/Encode.pm line 184. - % perl -MEncode -e '$a = "BOM missing"' \ - -e ' Encode::from_to($a, "utf16", "shift_jis", 0); print' - UTF-16:Unrecognised BOM 424f at /path/to/Encode.pm line 184. - -Unlike other encodings where mappings are not one-to-one against -Unicode, UTFs are supposed to map 100% against one another. So Encode -is more strict on UTFs. - -Consider that "division by zero" of Encode :) - -=head1 SEE ALSO - -L<Encode>, L<Encode::Unicode::UTF7>, L<http://www.unicode.org/glossary/>, -L<http://www.unicode.org/unicode/faq/utf_bom.html>, - -RFC 2781 L<http://rfc.net/rfc2781.html>, - -The whole Unicode standard L<http://www.unicode.org/unicode/uni2book/u2.html> - -Ch. 15, pp. 403 of C<Programming Perl (3rd Edition)> -by Larry Wall, Tom Christiansen, Jon Orwant; -O'Reilly & Associates; ISBN 0-596-00027-8 - -=cut diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Exporter.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Exporter.pm deleted file mode 100644 index d9c22049776..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/Exporter.pm +++ /dev/null @@ -1,440 +0,0 @@ -package Exporter; - -require 5.006; - -# Be lean. -#use strict; -#no strict 'refs'; - -our $Debug = 0; -our $ExportLevel = 0; -our $Verbose ||= 0; -our $VERSION = '5.58'; -our (%Cache); -$Carp::Internal{Exporter} = 1; - -sub as_heavy { - require Exporter::Heavy; - # Unfortunately, this does not work if the caller is aliased as *name = \&foo - # Thus the need to create a lot of identical subroutines - my $c = (caller(1))[3]; - $c =~ s/.*:://; - \&{"Exporter::Heavy::heavy_$c"}; -} - -sub export { - goto &{as_heavy()}; -} - -sub import { - my $pkg = shift; - my $callpkg = caller($ExportLevel); - - if ($pkg eq "Exporter" and @_ and $_[0] eq "import") { - *{$callpkg."::import"} = \&import; - return; - } - - # We *need* to treat @{"$pkg\::EXPORT_FAIL"} since Carp uses it :-( - my($exports, $fail) = (\@{"$pkg\::EXPORT"}, \@{"$pkg\::EXPORT_FAIL"}); - return export $pkg, $callpkg, @_ - if $Verbose or $Debug or @$fail > 1; - my $export_cache = ($Cache{$pkg} ||= {}); - my $args = @_ or @_ = @$exports; - - local $_; - if ($args and not %$export_cache) { - s/^&//, $export_cache->{$_} = 1 - foreach (@$exports, @{"$pkg\::EXPORT_OK"}); - } - my $heavy; - # Try very hard not to use {} and hence have to enter scope on the foreach - # We bomb out of the loop with last as soon as heavy is set. - if ($args or $fail) { - ($heavy = (/\W/ or $args and not exists $export_cache->{$_} - or @$fail and $_ eq $fail->[0])) and last - foreach (@_); - } else { - ($heavy = /\W/) and last - foreach (@_); - } - return export $pkg, $callpkg, ($args ? @_ : ()) if $heavy; - local $SIG{__WARN__} = - sub {require Carp; &Carp::carp}; - # shortcut for the common case of no type character - *{"$callpkg\::$_"} = \&{"$pkg\::$_"} foreach @_; -} - -# Default methods - -sub export_fail { - my $self = shift; - @_; -} - -# Unfortunately, caller(1)[3] "does not work" if the caller is aliased as -# *name = \&foo. Thus the need to create a lot of identical subroutines -# Otherwise we could have aliased them to export(). - -sub export_to_level { - goto &{as_heavy()}; -} - -sub export_tags { - goto &{as_heavy()}; -} - -sub export_ok_tags { - goto &{as_heavy()}; -} - -sub require_version { - goto &{as_heavy()}; -} - -1; -__END__ - -=head1 NAME - -Exporter - Implements default import method for modules - -=head1 SYNOPSIS - -In module YourModule.pm: - - package YourModule; - require Exporter; - @ISA = qw(Exporter); - @EXPORT_OK = qw(munge frobnicate); # symbols to export on request - -or - - package YourModule; - use Exporter 'import'; # gives you Exporter's import() method directly - @EXPORT_OK = qw(munge frobnicate); # symbols to export on request - -In other files which wish to use YourModule: - - use ModuleName qw(frobnicate); # import listed symbols - frobnicate ($left, $right) # calls YourModule::frobnicate - -=head1 DESCRIPTION - -The Exporter module implements an C<import> method which allows a module -to export functions and variables to its users' namespaces. Many modules -use Exporter rather than implementing their own C<import> method because -Exporter provides a highly flexible interface, with an implementation optimised -for the common case. - -Perl automatically calls the C<import> method when processing a -C<use> statement for a module. Modules and C<use> are documented -in L<perlfunc> and L<perlmod>. Understanding the concept of -modules and how the C<use> statement operates is important to -understanding the Exporter. - -=head2 How to Export - -The arrays C<@EXPORT> and C<@EXPORT_OK> in a module hold lists of -symbols that are going to be exported into the users name space by -default, or which they can request to be exported, respectively. The -symbols can represent functions, scalars, arrays, hashes, or typeglobs. -The symbols must be given by full name with the exception that the -ampersand in front of a function is optional, e.g. - - @EXPORT = qw(afunc $scalar @array); # afunc is a function - @EXPORT_OK = qw(&bfunc %hash *typeglob); # explicit prefix on &bfunc - -If you are only exporting function names it is recommended to omit the -ampersand, as the implementation is faster this way. - -=head2 Selecting What To Export - -Do B<not> export method names! - -Do B<not> export anything else by default without a good reason! - -Exports pollute the namespace of the module user. If you must export -try to use @EXPORT_OK in preference to @EXPORT and avoid short or -common symbol names to reduce the risk of name clashes. - -Generally anything not exported is still accessible from outside the -module using the ModuleName::item_name (or $blessed_ref-E<gt>method) -syntax. By convention you can use a leading underscore on names to -informally indicate that they are 'internal' and not for public use. - -(It is actually possible to get private functions by saying: - - my $subref = sub { ... }; - $subref->(@args); # Call it as a function - $obj->$subref(@args); # Use it as a method - -However if you use them for methods it is up to you to figure out -how to make inheritance work.) - -As a general rule, if the module is trying to be object oriented -then export nothing. If it's just a collection of functions then -@EXPORT_OK anything but use @EXPORT with caution. For function and -method names use barewords in preference to names prefixed with -ampersands for the export lists. - -Other module design guidelines can be found in L<perlmod>. - -=head2 How to Import - -In other files which wish to use your module there are three basic ways for -them to load your module and import its symbols: - -=over 4 - -=item C<use ModuleName;> - -This imports all the symbols from ModuleName's @EXPORT into the namespace -of the C<use> statement. - -=item C<use ModuleName ();> - -This causes perl to load your module but does not import any symbols. - -=item C<use ModuleName qw(...);> - -This imports only the symbols listed by the caller into their namespace. -All listed symbols must be in your @EXPORT or @EXPORT_OK, else an error -occurs. The advanced export features of Exporter are accessed like this, -but with list entries that are syntactically distinct from symbol names. - -=back - -Unless you want to use its advanced features, this is probably all you -need to know to use Exporter. - -=head1 Advanced features - -=head2 Specialised Import Lists - -If any of the entries in an import list begins with !, : or / then -the list is treated as a series of specifications which either add to -or delete from the list of names to import. They are processed left to -right. Specifications are in the form: - - [!]name This name only - [!]:DEFAULT All names in @EXPORT - [!]:tag All names in $EXPORT_TAGS{tag} anonymous list - [!]/pattern/ All names in @EXPORT and @EXPORT_OK which match - -A leading ! indicates that matching names should be deleted from the -list of names to import. If the first specification is a deletion it -is treated as though preceded by :DEFAULT. If you just want to import -extra names in addition to the default set you will still need to -include :DEFAULT explicitly. - -e.g., Module.pm defines: - - @EXPORT = qw(A1 A2 A3 A4 A5); - @EXPORT_OK = qw(B1 B2 B3 B4 B5); - %EXPORT_TAGS = (T1 => [qw(A1 A2 B1 B2)], T2 => [qw(A1 A2 B3 B4)]); - - Note that you cannot use tags in @EXPORT or @EXPORT_OK. - Names in EXPORT_TAGS must also appear in @EXPORT or @EXPORT_OK. - -An application using Module can say something like: - - use Module qw(:DEFAULT :T2 !B3 A3); - -Other examples include: - - use Socket qw(!/^[AP]F_/ !SOMAXCONN !SOL_SOCKET); - use POSIX qw(:errno_h :termios_h !TCSADRAIN !/^EXIT/); - -Remember that most patterns (using //) will need to be anchored -with a leading ^, e.g., C</^EXIT/> rather than C</EXIT/>. - -You can say C<BEGIN { $Exporter::Verbose=1 }> to see how the -specifications are being processed and what is actually being imported -into modules. - -=head2 Exporting without using Exporter's import method - -Exporter has a special method, 'export_to_level' which is used in situations -where you can't directly call Exporter's import method. The export_to_level -method looks like: - - MyPackage->export_to_level($where_to_export, $package, @what_to_export); - -where $where_to_export is an integer telling how far up the calling stack -to export your symbols, and @what_to_export is an array telling what -symbols *to* export (usually this is @_). The $package argument is -currently unused. - -For example, suppose that you have a module, A, which already has an -import function: - - package A; - - @ISA = qw(Exporter); - @EXPORT_OK = qw ($b); - - sub import - { - $A::b = 1; # not a very useful import method - } - -and you want to Export symbol $A::b back to the module that called -package A. Since Exporter relies on the import method to work, via -inheritance, as it stands Exporter::import() will never get called. -Instead, say the following: - - package A; - @ISA = qw(Exporter); - @EXPORT_OK = qw ($b); - - sub import - { - $A::b = 1; - A->export_to_level(1, @_); - } - -This will export the symbols one level 'above' the current package - ie: to -the program or module that used package A. - -Note: Be careful not to modify C<@_> at all before you call export_to_level -- or people using your package will get very unexplained results! - -=head2 Exporting without inheriting from Exporter - -By including Exporter in your @ISA you inherit an Exporter's import() method -but you also inherit several other helper methods which you probably don't -want. To avoid this you can do - - package YourModule; - use Exporter qw( import ); - -which will export Exporter's own import() method into YourModule. -Everything will work as before but you won't need to include Exporter in -@YourModule::ISA. - -=head2 Module Version Checking - -The Exporter module will convert an attempt to import a number from a -module into a call to $module_name-E<gt>require_version($value). This can -be used to validate that the version of the module being used is -greater than or equal to the required version. - -The Exporter module supplies a default require_version method which -checks the value of $VERSION in the exporting module. - -Since the default require_version method treats the $VERSION number as -a simple numeric value it will regard version 1.10 as lower than -1.9. For this reason it is strongly recommended that you use numbers -with at least two decimal places, e.g., 1.09. - -=head2 Managing Unknown Symbols - -In some situations you may want to prevent certain symbols from being -exported. Typically this applies to extensions which have functions -or constants that may not exist on some systems. - -The names of any symbols that cannot be exported should be listed -in the C<@EXPORT_FAIL> array. - -If a module attempts to import any of these symbols the Exporter -will give the module an opportunity to handle the situation before -generating an error. The Exporter will call an export_fail method -with a list of the failed symbols: - - @failed_symbols = $module_name->export_fail(@failed_symbols); - -If the export_fail method returns an empty list then no error is -recorded and all the requested symbols are exported. If the returned -list is not empty then an error is generated for each symbol and the -export fails. The Exporter provides a default export_fail method which -simply returns the list unchanged. - -Uses for the export_fail method include giving better error messages -for some symbols and performing lazy architectural checks (put more -symbols into @EXPORT_FAIL by default and then take them out if someone -actually tries to use them and an expensive check shows that they are -usable on that platform). - -=head2 Tag Handling Utility Functions - -Since the symbols listed within %EXPORT_TAGS must also appear in either -@EXPORT or @EXPORT_OK, two utility functions are provided which allow -you to easily add tagged sets of symbols to @EXPORT or @EXPORT_OK: - - %EXPORT_TAGS = (foo => [qw(aa bb cc)], bar => [qw(aa cc dd)]); - - Exporter::export_tags('foo'); # add aa, bb and cc to @EXPORT - Exporter::export_ok_tags('bar'); # add aa, cc and dd to @EXPORT_OK - -Any names which are not tags are added to @EXPORT or @EXPORT_OK -unchanged but will trigger a warning (with C<-w>) to avoid misspelt tags -names being silently added to @EXPORT or @EXPORT_OK. Future versions -may make this a fatal error. - -=head2 Generating combined tags - -If several symbol categories exist in %EXPORT_TAGS, it's usually -useful to create the utility ":all" to simplify "use" statements. - -The simplest way to do this is: - - %EXPORT_TAGS = (foo => [qw(aa bb cc)], bar => [qw(aa cc dd)]); - - # add all the other ":class" tags to the ":all" class, - # deleting duplicates - { - my %seen; - - push @{$EXPORT_TAGS{all}}, - grep {!$seen{$_}++} @{$EXPORT_TAGS{$_}} foreach keys %EXPORT_TAGS; - } - -CGI.pm creates an ":all" tag which contains some (but not really -all) of its categories. That could be done with one small -change: - - # add some of the other ":class" tags to the ":all" class, - # deleting duplicates - { - my %seen; - - push @{$EXPORT_TAGS{all}}, - grep {!$seen{$_}++} @{$EXPORT_TAGS{$_}} - foreach qw/html2 html3 netscape form cgi internal/; - } - -Note that the tag names in %EXPORT_TAGS don't have the leading ':'. - -=head2 C<AUTOLOAD>ed Constants - -Many modules make use of C<AUTOLOAD>ing for constant subroutines to -avoid having to compile and waste memory on rarely used values (see -L<perlsub> for details on constant subroutines). Calls to such -constant subroutines are not optimized away at compile time because -they can't be checked at compile time for constancy. - -Even if a prototype is available at compile time, the body of the -subroutine is not (it hasn't been C<AUTOLOAD>ed yet). perl needs to -examine both the C<()> prototype and the body of a subroutine at -compile time to detect that it can safely replace calls to that -subroutine with the constant value. - -A workaround for this is to call the constants once in a C<BEGIN> block: - - package My ; - - use Socket ; - - foo( SO_LINGER ); ## SO_LINGER NOT optimized away; called at runtime - BEGIN { SO_LINGER } - foo( SO_LINGER ); ## SO_LINGER optimized away at compile time. - -This forces the C<AUTOLOAD> for C<SO_LINGER> to take place before -SO_LINGER is encountered later in C<My> package. - -If you are writing a package that C<AUTOLOAD>s, consider forcing -an C<AUTOLOAD> for any constants explicitly imported by other packages -or which are usually used when your package is C<use>d. - -=cut diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Exporter/Heavy.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Exporter/Heavy.pm deleted file mode 100644 index 2cc792288f0..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/Exporter/Heavy.pm +++ /dev/null @@ -1,248 +0,0 @@ -package Exporter::Heavy; - -use strict; -no strict 'refs'; - -# On one line so MakeMaker will see it. -require Exporter; our $VERSION = $Exporter::VERSION; -$Carp::Internal{"Exporter::Heavy"} = 1; - -=head1 NAME - -Exporter::Heavy - Exporter guts - -=head1 SYNOPSIS - -(internal use only) - -=head1 DESCRIPTION - -No user-serviceable parts inside. - -=cut - -# -# We go to a lot of trouble not to 'require Carp' at file scope, -# because Carp requires Exporter, and something has to give. -# - -sub _rebuild_cache { - my ($pkg, $exports, $cache) = @_; - s/^&// foreach @$exports; - @{$cache}{@$exports} = (1) x @$exports; - my $ok = \@{"${pkg}::EXPORT_OK"}; - if (@$ok) { - s/^&// foreach @$ok; - @{$cache}{@$ok} = (1) x @$ok; - } -} - -sub heavy_export { - - # First make import warnings look like they're coming from the "use". - local $SIG{__WARN__} = sub { - my $text = shift; - if ($text =~ s/ at \S*Exporter\S*.pm line \d+.*\n//) { - require Carp; - local $Carp::CarpLevel = 1; # ignore package calling us too. - Carp::carp($text); - } - else { - warn $text; - } - }; - local $SIG{__DIE__} = sub { - require Carp; - local $Carp::CarpLevel = 1; # ignore package calling us too. - Carp::croak("$_[0]Illegal null symbol in \@${1}::EXPORT") - if $_[0] =~ /^Unable to create sub named "(.*?)::"/; - }; - - my($pkg, $callpkg, @imports) = @_; - my($type, $sym, $cache_is_current, $oops); - my($exports, $export_cache) = (\@{"${pkg}::EXPORT"}, - $Exporter::Cache{$pkg} ||= {}); - - if (@imports) { - if (!%$export_cache) { - _rebuild_cache ($pkg, $exports, $export_cache); - $cache_is_current = 1; - } - - if (grep m{^[/!:]}, @imports) { - my $tagsref = \%{"${pkg}::EXPORT_TAGS"}; - my $tagdata; - my %imports; - my($remove, $spec, @names, @allexports); - # negated first item implies starting with default set: - unshift @imports, ':DEFAULT' if $imports[0] =~ m/^!/; - foreach $spec (@imports){ - $remove = $spec =~ s/^!//; - - if ($spec =~ s/^://){ - if ($spec eq 'DEFAULT'){ - @names = @$exports; - } - elsif ($tagdata = $tagsref->{$spec}) { - @names = @$tagdata; - } - else { - warn qq["$spec" is not defined in %${pkg}::EXPORT_TAGS]; - ++$oops; - next; - } - } - elsif ($spec =~ m:^/(.*)/$:){ - my $patn = $1; - @allexports = keys %$export_cache unless @allexports; # only do keys once - @names = grep(/$patn/, @allexports); # not anchored by default - } - else { - @names = ($spec); # is a normal symbol name - } - - warn "Import ".($remove ? "del":"add").": @names " - if $Exporter::Verbose; - - if ($remove) { - foreach $sym (@names) { delete $imports{$sym} } - } - else { - @imports{@names} = (1) x @names; - } - } - @imports = keys %imports; - } - - my @carp; - foreach $sym (@imports) { - if (!$export_cache->{$sym}) { - if ($sym =~ m/^\d/) { - $pkg->VERSION($sym); # inherit from UNIVERSAL - # If the version number was the only thing specified - # then we should act as if nothing was specified: - if (@imports == 1) { - @imports = @$exports; - last; - } - # We need a way to emulate 'use Foo ()' but still - # allow an easy version check: "use Foo 1.23, ''"; - if (@imports == 2 and !$imports[1]) { - @imports = (); - last; - } - } elsif ($sym !~ s/^&// || !$export_cache->{$sym}) { - # Last chance - see if they've updated EXPORT_OK since we - # cached it. - - unless ($cache_is_current) { - %$export_cache = (); - _rebuild_cache ($pkg, $exports, $export_cache); - $cache_is_current = 1; - } - - if (!$export_cache->{$sym}) { - # accumulate the non-exports - push @carp, - qq["$sym" is not exported by the $pkg module\n]; - $oops++; - } - } - } - } - if ($oops) { - require Carp; - Carp::croak("@{carp}Can't continue after import errors"); - } - } - else { - @imports = @$exports; - } - - my($fail, $fail_cache) = (\@{"${pkg}::EXPORT_FAIL"}, - $Exporter::FailCache{$pkg} ||= {}); - - if (@$fail) { - if (!%$fail_cache) { - # Build cache of symbols. Optimise the lookup by adding - # barewords twice... both with and without a leading &. - # (Technique could be applied to $export_cache at cost of memory) - my @expanded = map { /^\w/ ? ($_, '&'.$_) : $_ } @$fail; - warn "${pkg}::EXPORT_FAIL cached: @expanded" if $Exporter::Verbose; - @{$fail_cache}{@expanded} = (1) x @expanded; - } - my @failed; - foreach $sym (@imports) { push(@failed, $sym) if $fail_cache->{$sym} } - if (@failed) { - @failed = $pkg->export_fail(@failed); - foreach $sym (@failed) { - require Carp; - Carp::carp(qq["$sym" is not implemented by the $pkg module ], - "on this architecture"); - } - if (@failed) { - require Carp; - Carp::croak("Can't continue after import errors"); - } - } - } - - warn "Importing into $callpkg from $pkg: ", - join(", ",sort @imports) if $Exporter::Verbose; - - foreach $sym (@imports) { - # shortcut for the common case of no type character - (*{"${callpkg}::$sym"} = \&{"${pkg}::$sym"}, next) - unless $sym =~ s/^(\W)//; - $type = $1; - *{"${callpkg}::$sym"} = - $type eq '&' ? \&{"${pkg}::$sym"} : - $type eq '$' ? \${"${pkg}::$sym"} : - $type eq '@' ? \@{"${pkg}::$sym"} : - $type eq '%' ? \%{"${pkg}::$sym"} : - $type eq '*' ? *{"${pkg}::$sym"} : - do { require Carp; Carp::croak("Can't export symbol: $type$sym") }; - } -} - -sub heavy_export_to_level -{ - my $pkg = shift; - my $level = shift; - (undef) = shift; # XXX redundant arg - my $callpkg = caller($level); - $pkg->export($callpkg, @_); -} - -# Utility functions - -sub _push_tags { - my($pkg, $var, $syms) = @_; - my @nontag = (); - my $export_tags = \%{"${pkg}::EXPORT_TAGS"}; - push(@{"${pkg}::$var"}, - map { $export_tags->{$_} ? @{$export_tags->{$_}} - : scalar(push(@nontag,$_),$_) } - (@$syms) ? @$syms : keys %$export_tags); - if (@nontag and $^W) { - # This may change to a die one day - require Carp; - Carp::carp(join(", ", @nontag)." are not tags of $pkg"); - } -} - -sub heavy_require_version { - my($self, $wanted) = @_; - my $pkg = ref $self || $self; - return ${pkg}->VERSION($wanted); -} - -sub heavy_export_tags { - _push_tags((caller)[0], "EXPORT", \@_); -} - -sub heavy_export_ok_tags { - _push_tags((caller)[0], "EXPORT_OK", \@_); -} - -1; diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Getopt/Long.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Getopt/Long.pm deleted file mode 100644 index 04038db58e3..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/Getopt/Long.pm +++ /dev/null @@ -1,2504 +0,0 @@ -# Getopt::Long.pm -- Universal options parsing - -package Getopt::Long; - -# RCS Status : $Id: GetoptLong.pm,v 2.72 2005-04-28 21:18:33+02 jv Exp $ -# Author : Johan Vromans -# Created On : Tue Sep 11 15:00:12 1990 -# Last Modified By: Johan Vromans -# Last Modified On: Wed Dec 14 21:17:21 2005 -# Update Count : 1458 -# Status : Released - -################ Copyright ################ - -# This program is Copyright 1990,2005 by Johan Vromans. -# This program is free software; you can redistribute it and/or -# modify it under the terms of the Perl Artistic License or the -# GNU General Public License as published by the Free Software -# Foundation; either version 2 of the License, or (at your option) any -# later version. -# -# This program is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -# GNU General Public License for more details. -# -# If you do not have a copy of the GNU General Public License write to -# the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, -# MA 02139, USA. - -################ Module Preamble ################ - -use 5.004; - -use strict; - -use vars qw($VERSION); -$VERSION = 2.35; -# For testing versions only. -#use vars qw($VERSION_STRING); -#$VERSION_STRING = "2.35"; - -use Exporter; -use vars qw(@ISA @EXPORT @EXPORT_OK); -@ISA = qw(Exporter); - -# Exported subroutines. -sub GetOptions(@); # always -sub Configure(@); # on demand -sub HelpMessage(@); # on demand -sub VersionMessage(@); # in demand - -BEGIN { - # Init immediately so their contents can be used in the 'use vars' below. - @EXPORT = qw(&GetOptions $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER); - @EXPORT_OK = qw(&HelpMessage &VersionMessage &Configure); -} - -# User visible variables. -use vars @EXPORT, @EXPORT_OK; -use vars qw($error $debug $major_version $minor_version); -# Deprecated visible variables. -use vars qw($autoabbrev $getopt_compat $ignorecase $bundling $order - $passthrough); -# Official invisible variables. -use vars qw($genprefix $caller $gnu_compat $auto_help $auto_version $longprefix); - -# Public subroutines. -sub config(@); # deprecated name - -# Private subroutines. -sub ConfigDefaults(); -sub ParseOptionSpec($$); -sub OptCtl($); -sub FindOption($$$$); -sub ValidValue ($$$$$); - -################ Local Variables ################ - -# $requested_version holds the version that was mentioned in the 'use' -# or 'require', if any. It can be used to enable or disable specific -# features. -my $requested_version = 0; - -################ Resident subroutines ################ - -sub ConfigDefaults() { - # Handle POSIX compliancy. - if ( defined $ENV{"POSIXLY_CORRECT"} ) { - $genprefix = "(--|-)"; - $autoabbrev = 0; # no automatic abbrev of options - $bundling = 0; # no bundling of single letter switches - $getopt_compat = 0; # disallow '+' to start options - $order = $REQUIRE_ORDER; - } - else { - $genprefix = "(--|-|\\+)"; - $autoabbrev = 1; # automatic abbrev of options - $bundling = 0; # bundling off by default - $getopt_compat = 1; # allow '+' to start options - $order = $PERMUTE; - } - # Other configurable settings. - $debug = 0; # for debugging - $error = 0; # error tally - $ignorecase = 1; # ignore case when matching options - $passthrough = 0; # leave unrecognized options alone - $gnu_compat = 0; # require --opt=val if value is optional - $longprefix = "(--)"; # what does a long prefix look like -} - -# Override import. -sub import { - my $pkg = shift; # package - my @syms = (); # symbols to import - my @config = (); # configuration - my $dest = \@syms; # symbols first - for ( @_ ) { - if ( $_ eq ':config' ) { - $dest = \@config; # config next - next; - } - push(@$dest, $_); # push - } - # Hide one level and call super. - local $Exporter::ExportLevel = 1; - push(@syms, qw(&GetOptions)) if @syms; # always export GetOptions - $pkg->SUPER::import(@syms); - # And configure. - Configure(@config) if @config; -} - -################ Initialization ################ - -# Values for $order. See GNU getopt.c for details. -($REQUIRE_ORDER, $PERMUTE, $RETURN_IN_ORDER) = (0..2); -# Version major/minor numbers. -($major_version, $minor_version) = $VERSION =~ /^(\d+)\.(\d+)/; - -ConfigDefaults(); - -################ OO Interface ################ - -package Getopt::Long::Parser; - -# Store a copy of the default configuration. Since ConfigDefaults has -# just been called, what we get from Configure is the default. -my $default_config = do { - Getopt::Long::Configure () -}; - -sub new { - my $that = shift; - my $class = ref($that) || $that; - my %atts = @_; - - # Register the callers package. - my $self = { caller_pkg => (caller)[0] }; - - bless ($self, $class); - - # Process config attributes. - if ( defined $atts{config} ) { - my $save = Getopt::Long::Configure ($default_config, @{$atts{config}}); - $self->{settings} = Getopt::Long::Configure ($save); - delete ($atts{config}); - } - # Else use default config. - else { - $self->{settings} = $default_config; - } - - if ( %atts ) { # Oops - die(__PACKAGE__.": unhandled attributes: ". - join(" ", sort(keys(%atts)))."\n"); - } - - $self; -} - -sub configure { - my ($self) = shift; - - # Restore settings, merge new settings in. - my $save = Getopt::Long::Configure ($self->{settings}, @_); - - # Restore orig config and save the new config. - $self->{settings} = Getopt::Long::Configure ($save); -} - -sub getoptions { - my ($self) = shift; - - # Restore config settings. - my $save = Getopt::Long::Configure ($self->{settings}); - - # Call main routine. - my $ret = 0; - $Getopt::Long::caller = $self->{caller_pkg}; - - eval { - # Locally set exception handler to default, otherwise it will - # be called implicitly here, and again explicitly when we try - # to deliver the messages. - local ($SIG{__DIE__}) = '__DEFAULT__'; - $ret = Getopt::Long::GetOptions (@_); - }; - - # Restore saved settings. - Getopt::Long::Configure ($save); - - # Handle errors and return value. - die ($@) if $@; - return $ret; -} - -package Getopt::Long; - -################ Back to Normal ################ - -# Indices in option control info. -# Note that ParseOptions uses the fields directly. Search for 'hard-wired'. -use constant CTL_TYPE => 0; -#use constant CTL_TYPE_FLAG => ''; -#use constant CTL_TYPE_NEG => '!'; -#use constant CTL_TYPE_INCR => '+'; -#use constant CTL_TYPE_INT => 'i'; -#use constant CTL_TYPE_INTINC => 'I'; -#use constant CTL_TYPE_XINT => 'o'; -#use constant CTL_TYPE_FLOAT => 'f'; -#use constant CTL_TYPE_STRING => 's'; - -use constant CTL_CNAME => 1; - -use constant CTL_DEFAULT => 2; - -use constant CTL_DEST => 3; - use constant CTL_DEST_SCALAR => 0; - use constant CTL_DEST_ARRAY => 1; - use constant CTL_DEST_HASH => 2; - use constant CTL_DEST_CODE => 3; - -use constant CTL_AMIN => 4; -use constant CTL_AMAX => 5; - -# FFU. -#use constant CTL_RANGE => ; -#use constant CTL_REPEAT => ; - -sub GetOptions(@) { - - my @optionlist = @_; # local copy of the option descriptions - my $argend = '--'; # option list terminator - my %opctl = (); # table of option specs - my $pkg = $caller || (caller)[0]; # current context - # Needed if linkage is omitted. - my @ret = (); # accum for non-options - my %linkage; # linkage - my $userlinkage; # user supplied HASH - my $opt; # current option - my $prefix = $genprefix; # current prefix - - $error = ''; - - if ( $debug ) { - # Avoid some warnings if debugging. - local ($^W) = 0; - print STDERR - ("Getopt::Long $Getopt::Long::VERSION (", - '$Revision: 2.72 $', ") ", - "called from package \"$pkg\".", - "\n ", - "ARGV: (@ARGV)", - "\n ", - "autoabbrev=$autoabbrev,". - "bundling=$bundling,", - "getopt_compat=$getopt_compat,", - "gnu_compat=$gnu_compat,", - "order=$order,", - "\n ", - "ignorecase=$ignorecase,", - "requested_version=$requested_version,", - "passthrough=$passthrough,", - "genprefix=\"$genprefix\",", - "longprefix=\"$longprefix\".", - "\n"); - } - - # Check for ref HASH as first argument. - # First argument may be an object. It's OK to use this as long - # as it is really a hash underneath. - $userlinkage = undef; - if ( @optionlist && ref($optionlist[0]) and - UNIVERSAL::isa($optionlist[0],'HASH') ) { - $userlinkage = shift (@optionlist); - print STDERR ("=> user linkage: $userlinkage\n") if $debug; - } - - # See if the first element of the optionlist contains option - # starter characters. - # Be careful not to interpret '<>' as option starters. - if ( @optionlist && $optionlist[0] =~ /^\W+$/ - && !($optionlist[0] eq '<>' - && @optionlist > 0 - && ref($optionlist[1])) ) { - $prefix = shift (@optionlist); - # Turn into regexp. Needs to be parenthesized! - $prefix =~ s/(\W)/\\$1/g; - $prefix = "([" . $prefix . "])"; - print STDERR ("=> prefix=\"$prefix\"\n") if $debug; - } - - # Verify correctness of optionlist. - %opctl = (); - while ( @optionlist ) { - my $opt = shift (@optionlist); - - unless ( defined($opt) ) { - $error .= "Undefined argument in option spec\n"; - next; - } - - # Strip leading prefix so people can specify "--foo=i" if they like. - $opt = $+ if $opt =~ /^$prefix+(.*)$/s; - - if ( $opt eq '<>' ) { - if ( (defined $userlinkage) - && !(@optionlist > 0 && ref($optionlist[0])) - && (exists $userlinkage->{$opt}) - && ref($userlinkage->{$opt}) ) { - unshift (@optionlist, $userlinkage->{$opt}); - } - unless ( @optionlist > 0 - && ref($optionlist[0]) && ref($optionlist[0]) eq 'CODE' ) { - $error .= "Option spec <> requires a reference to a subroutine\n"; - # Kill the linkage (to avoid another error). - shift (@optionlist) - if @optionlist && ref($optionlist[0]); - next; - } - $linkage{'<>'} = shift (@optionlist); - next; - } - - # Parse option spec. - my ($name, $orig) = ParseOptionSpec ($opt, \%opctl); - unless ( defined $name ) { - # Failed. $orig contains the error message. Sorry for the abuse. - $error .= $orig; - # Kill the linkage (to avoid another error). - shift (@optionlist) - if @optionlist && ref($optionlist[0]); - next; - } - - # If no linkage is supplied in the @optionlist, copy it from - # the userlinkage if available. - if ( defined $userlinkage ) { - unless ( @optionlist > 0 && ref($optionlist[0]) ) { - if ( exists $userlinkage->{$orig} && - ref($userlinkage->{$orig}) ) { - print STDERR ("=> found userlinkage for \"$orig\": ", - "$userlinkage->{$orig}\n") - if $debug; - unshift (@optionlist, $userlinkage->{$orig}); - } - else { - # Do nothing. Being undefined will be handled later. - next; - } - } - } - - # Copy the linkage. If omitted, link to global variable. - if ( @optionlist > 0 && ref($optionlist[0]) ) { - print STDERR ("=> link \"$orig\" to $optionlist[0]\n") - if $debug; - my $rl = ref($linkage{$orig} = shift (@optionlist)); - - if ( $rl eq "ARRAY" ) { - $opctl{$name}[CTL_DEST] = CTL_DEST_ARRAY; - } - elsif ( $rl eq "HASH" ) { - $opctl{$name}[CTL_DEST] = CTL_DEST_HASH; - } - elsif ( $rl eq "SCALAR" ) { -# if ( $opctl{$name}[CTL_DEST] == CTL_DEST_ARRAY ) { -# my $t = $linkage{$orig}; -# $$t = $linkage{$orig} = []; -# } -# elsif ( $opctl{$name}[CTL_DEST] == CTL_DEST_HASH ) { -# } -# else { - # Ok. -# } - } - elsif ( $rl eq "CODE" ) { - # Ok. - } - else { - $error .= "Invalid option linkage for \"$opt\"\n"; - } - } - else { - # Link to global $opt_XXX variable. - # Make sure a valid perl identifier results. - my $ov = $orig; - $ov =~ s/\W/_/g; - if ( $opctl{$name}[CTL_DEST] == CTL_DEST_ARRAY ) { - print STDERR ("=> link \"$orig\" to \@$pkg","::opt_$ov\n") - if $debug; - eval ("\$linkage{\$orig} = \\\@".$pkg."::opt_$ov;"); - } - elsif ( $opctl{$name}[CTL_DEST] == CTL_DEST_HASH ) { - print STDERR ("=> link \"$orig\" to \%$pkg","::opt_$ov\n") - if $debug; - eval ("\$linkage{\$orig} = \\\%".$pkg."::opt_$ov;"); - } - else { - print STDERR ("=> link \"$orig\" to \$$pkg","::opt_$ov\n") - if $debug; - eval ("\$linkage{\$orig} = \\\$".$pkg."::opt_$ov;"); - } - } - } - - # Bail out if errors found. - die ($error) if $error; - $error = 0; - - # Supply --version and --help support, if needed and allowed. - if ( defined($auto_version) ? $auto_version : ($requested_version >= 2.3203) ) { - if ( !defined($opctl{version}) ) { - $opctl{version} = ['','version',0,CTL_DEST_CODE,undef]; - $linkage{version} = \&VersionMessage; - } - $auto_version = 1; - } - if ( defined($auto_help) ? $auto_help : ($requested_version >= 2.3203) ) { - if ( !defined($opctl{help}) && !defined($opctl{'?'}) ) { - $opctl{help} = $opctl{'?'} = ['','help',0,CTL_DEST_CODE,undef]; - $linkage{help} = \&HelpMessage; - } - $auto_help = 1; - } - - # Show the options tables if debugging. - if ( $debug ) { - my ($arrow, $k, $v); - $arrow = "=> "; - while ( ($k,$v) = each(%opctl) ) { - print STDERR ($arrow, "\$opctl{$k} = $v ", OptCtl($v), "\n"); - $arrow = " "; - } - } - - # Process argument list - my $goon = 1; - while ( $goon && @ARGV > 0 ) { - - # Get next argument. - $opt = shift (@ARGV); - print STDERR ("=> arg \"", $opt, "\"\n") if $debug; - - # Double dash is option list terminator. - if ( $opt eq $argend ) { - push (@ret, $argend) if $passthrough; - last; - } - - # Look it up. - my $tryopt = $opt; - my $found; # success status - my $key; # key (if hash type) - my $arg; # option argument - my $ctl; # the opctl entry - - ($found, $opt, $ctl, $arg, $key) = - FindOption ($prefix, $argend, $opt, \%opctl); - - if ( $found ) { - - # FindOption undefines $opt in case of errors. - next unless defined $opt; - - my $argcnt = 0; - while ( defined $arg ) { - - # Get the canonical name. - print STDERR ("=> cname for \"$opt\" is ") if $debug; - $opt = $ctl->[CTL_CNAME]; - print STDERR ("\"$ctl->[CTL_CNAME]\"\n") if $debug; - - if ( defined $linkage{$opt} ) { - print STDERR ("=> ref(\$L{$opt}) -> ", - ref($linkage{$opt}), "\n") if $debug; - - if ( ref($linkage{$opt}) eq 'SCALAR' ) { - if ( $ctl->[CTL_TYPE] eq '+' ) { - print STDERR ("=> \$\$L{$opt} += \"$arg\"\n") - if $debug; - if ( defined ${$linkage{$opt}} ) { - ${$linkage{$opt}} += $arg; - } - else { - ${$linkage{$opt}} = $arg; - } - } - elsif ( $ctl->[CTL_DEST] == CTL_DEST_ARRAY ) { - print STDERR ("=> ref(\$L{$opt}) auto-vivified", - " to ARRAY\n") - if $debug; - my $t = $linkage{$opt}; - $$t = $linkage{$opt} = []; - print STDERR ("=> push(\@{\$L{$opt}, \"$arg\")\n") - if $debug; - push (@{$linkage{$opt}}, $arg); - } - elsif ( $ctl->[CTL_DEST] == CTL_DEST_HASH ) { - print STDERR ("=> ref(\$L{$opt}) auto-vivified", - " to HASH\n") - if $debug; - my $t = $linkage{$opt}; - $$t = $linkage{$opt} = {}; - print STDERR ("=> \$\$L{$opt}->{$key} = \"$arg\"\n") - if $debug; - $linkage{$opt}->{$key} = $arg; - } - else { - print STDERR ("=> \$\$L{$opt} = \"$arg\"\n") - if $debug; - ${$linkage{$opt}} = $arg; - } - } - elsif ( ref($linkage{$opt}) eq 'ARRAY' ) { - print STDERR ("=> push(\@{\$L{$opt}, \"$arg\")\n") - if $debug; - push (@{$linkage{$opt}}, $arg); - } - elsif ( ref($linkage{$opt}) eq 'HASH' ) { - print STDERR ("=> \$\$L{$opt}->{$key} = \"$arg\"\n") - if $debug; - $linkage{$opt}->{$key} = $arg; - } - elsif ( ref($linkage{$opt}) eq 'CODE' ) { - print STDERR ("=> &L{$opt}(\"$opt\"", - $ctl->[CTL_DEST] == CTL_DEST_HASH ? ", \"$key\"" : "", - ", \"$arg\")\n") - if $debug; - my $eval_error = do { - local $@; - local $SIG{__DIE__} = '__DEFAULT__'; - eval { - &{$linkage{$opt}}($opt, - $ctl->[CTL_DEST] == CTL_DEST_HASH ? ($key) : (), - $arg); - }; - $@; - }; - print STDERR ("=> die($eval_error)\n") - if $debug && $eval_error ne ''; - if ( $eval_error =~ /^!/ ) { - if ( $eval_error =~ /^!FINISH\b/ ) { - $goon = 0; - } - } - elsif ( $eval_error ne '' ) { - warn ($eval_error); - $error++; - } - } - else { - print STDERR ("Invalid REF type \"", ref($linkage{$opt}), - "\" in linkage\n"); - die("Getopt::Long -- internal error!\n"); - } - } - # No entry in linkage means entry in userlinkage. - elsif ( $ctl->[CTL_DEST] == CTL_DEST_ARRAY ) { - if ( defined $userlinkage->{$opt} ) { - print STDERR ("=> push(\@{\$L{$opt}}, \"$arg\")\n") - if $debug; - push (@{$userlinkage->{$opt}}, $arg); - } - else { - print STDERR ("=>\$L{$opt} = [\"$arg\"]\n") - if $debug; - $userlinkage->{$opt} = [$arg]; - } - } - elsif ( $ctl->[CTL_DEST] == CTL_DEST_HASH ) { - if ( defined $userlinkage->{$opt} ) { - print STDERR ("=> \$L{$opt}->{$key} = \"$arg\"\n") - if $debug; - $userlinkage->{$opt}->{$key} = $arg; - } - else { - print STDERR ("=>\$L{$opt} = {$key => \"$arg\"}\n") - if $debug; - $userlinkage->{$opt} = {$key => $arg}; - } - } - else { - if ( $ctl->[CTL_TYPE] eq '+' ) { - print STDERR ("=> \$L{$opt} += \"$arg\"\n") - if $debug; - if ( defined $userlinkage->{$opt} ) { - $userlinkage->{$opt} += $arg; - } - else { - $userlinkage->{$opt} = $arg; - } - } - else { - print STDERR ("=>\$L{$opt} = \"$arg\"\n") if $debug; - $userlinkage->{$opt} = $arg; - } - } - - $argcnt++; - last if $argcnt >= $ctl->[CTL_AMAX] && $ctl->[CTL_AMAX] != -1; - undef($arg); - - # Need more args? - if ( $argcnt < $ctl->[CTL_AMIN] ) { - if ( @ARGV ) { - if ( ValidValue($ctl, $ARGV[0], 1, $argend, $prefix) ) { - $arg = shift(@ARGV); - ($key,$arg) = $arg =~ /^([^=]+)=(.*)/ - if $ctl->[CTL_DEST] == CTL_DEST_HASH; - next; - } - warn("Value \"$ARGV[0]\" invalid for option $opt\n"); - $error++; - } - else { - warn("Insufficient arguments for option $opt\n"); - $error++; - } - } - - # Any more args? - if ( @ARGV && ValidValue($ctl, $ARGV[0], 0, $argend, $prefix) ) { - $arg = shift(@ARGV); - ($key,$arg) = $arg =~ /^([^=]+)=(.*)/ - if $ctl->[CTL_DEST] == CTL_DEST_HASH; - next; - } - } - } - - # Not an option. Save it if we $PERMUTE and don't have a <>. - elsif ( $order == $PERMUTE ) { - # Try non-options call-back. - my $cb; - if ( (defined ($cb = $linkage{'<>'})) ) { - print STDERR ("=> &L{$tryopt}(\"$tryopt\")\n") - if $debug; - my $eval_error = do { - local $@; - local $SIG{__DIE__} = '__DEFAULT__'; - eval { &$cb ($tryopt) }; - $@; - }; - print STDERR ("=> die($eval_error)\n") - if $debug && $eval_error ne ''; - if ( $eval_error =~ /^!/ ) { - if ( $eval_error =~ /^!FINISH\b/ ) { - $goon = 0; - } - } - elsif ( $eval_error ne '' ) { - warn ($eval_error); - $error++; - } - } - else { - print STDERR ("=> saving \"$tryopt\" ", - "(not an option, may permute)\n") if $debug; - push (@ret, $tryopt); - } - next; - } - - # ...otherwise, terminate. - else { - # Push this one back and exit. - unshift (@ARGV, $tryopt); - return ($error == 0); - } - - } - - # Finish. - if ( @ret && $order == $PERMUTE ) { - # Push back accumulated arguments - print STDERR ("=> restoring \"", join('" "', @ret), "\"\n") - if $debug; - unshift (@ARGV, @ret); - } - - return ($error == 0); -} - -# A readable representation of what's in an optbl. -sub OptCtl ($) { - my ($v) = @_; - my @v = map { defined($_) ? ($_) : ("<undef>") } @$v; - "[". - join(",", - "\"$v[CTL_TYPE]\"", - "\"$v[CTL_CNAME]\"", - "\"$v[CTL_DEFAULT]\"", - ("\$","\@","\%","\&")[$v[CTL_DEST] || 0], - $v[CTL_AMIN] || '', - $v[CTL_AMAX] || '', -# $v[CTL_RANGE] || '', -# $v[CTL_REPEAT] || '', - ). "]"; -} - -# Parse an option specification and fill the tables. -sub ParseOptionSpec ($$) { - my ($opt, $opctl) = @_; - - # Match option spec. - if ( $opt !~ m;^ - ( - # Option name - (?: \w+[-\w]* ) - # Alias names, or "?" - (?: \| (?: \? | \w[-\w]* )? )* - )? - ( - # Either modifiers ... - [!+] - | - # ... or a value/dest/repeat specification - [=:] [ionfs] [@%]? (?: \{\d*,?\d*\} )? - | - # ... or an optional-with-default spec - : (?: -?\d+ | \+ ) [@%]? - )? - $;x ) { - return (undef, "Error in option spec: \"$opt\"\n"); - } - - my ($names, $spec) = ($1, $2); - $spec = '' unless defined $spec; - - # $orig keeps track of the primary name the user specified. - # This name will be used for the internal or external linkage. - # In other words, if the user specifies "FoO|BaR", it will - # match any case combinations of 'foo' and 'bar', but if a global - # variable needs to be set, it will be $opt_FoO in the exact case - # as specified. - my $orig; - - my @names; - if ( defined $names ) { - @names = split (/\|/, $names); - $orig = $names[0]; - } - else { - @names = (''); - $orig = ''; - } - - # Construct the opctl entries. - my $entry; - if ( $spec eq '' || $spec eq '+' || $spec eq '!' ) { - # Fields are hard-wired here. - $entry = [$spec,$orig,undef,CTL_DEST_SCALAR,0,0]; - } - elsif ( $spec =~ /^:(-?\d+|\+)([@%])?$/ ) { - my $def = $1; - my $dest = $2; - my $type = $def eq '+' ? 'I' : 'i'; - $dest ||= '$'; - $dest = $dest eq '@' ? CTL_DEST_ARRAY - : $dest eq '%' ? CTL_DEST_HASH : CTL_DEST_SCALAR; - # Fields are hard-wired here. - $entry = [$type,$orig,$def eq '+' ? undef : $def, - $dest,0,1]; - } - else { - my ($mand, $type, $dest) = - $spec =~ /^([=:])([ionfs])([@%])?(\{(\d+)?(,)?(\d+)?\})?$/; - return (undef, "Cannot repeat while bundling: \"$opt\"\n") - if $bundling && defined($4); - my ($mi, $cm, $ma) = ($5, $6, $7); - return (undef, "{0} is useless in option spec: \"$opt\"\n") - if defined($mi) && !$mi && !defined($ma) && !defined($cm); - - $type = 'i' if $type eq 'n'; - $dest ||= '$'; - $dest = $dest eq '@' ? CTL_DEST_ARRAY - : $dest eq '%' ? CTL_DEST_HASH : CTL_DEST_SCALAR; - # Default minargs to 1/0 depending on mand status. - $mi = $mand eq '=' ? 1 : 0 unless defined $mi; - # Adjust mand status according to minargs. - $mand = $mi ? '=' : ':'; - # Adjust maxargs. - $ma = $mi ? $mi : 1 unless defined $ma || defined $cm; - return (undef, "Max must be greater than zero in option spec: \"$opt\"\n") - if defined($ma) && !$ma; - return (undef, "Max less than min in option spec: \"$opt\"\n") - if defined($ma) && $ma < $mi; - - # Fields are hard-wired here. - $entry = [$type,$orig,undef,$dest,$mi,$ma||-1]; - } - - # Process all names. First is canonical, the rest are aliases. - my $dups = ''; - foreach ( @names ) { - - $_ = lc ($_) - if $ignorecase > (($bundling && length($_) == 1) ? 1 : 0); - - if ( exists $opctl->{$_} ) { - $dups .= "Duplicate specification \"$opt\" for option \"$_\"\n"; - } - - if ( $spec eq '!' ) { - $opctl->{"no$_"} = $entry; - $opctl->{"no-$_"} = $entry; - $opctl->{$_} = [@$entry]; - $opctl->{$_}->[CTL_TYPE] = ''; - } - else { - $opctl->{$_} = $entry; - } - } - - if ( $dups && $^W ) { - foreach ( split(/\n+/, $dups) ) { - warn($_."\n"); - } - } - ($names[0], $orig); -} - -# Option lookup. -sub FindOption ($$$$) { - - # returns (1, $opt, $ctl, $arg, $key) if okay, - # returns (1, undef) if option in error, - # returns (0) otherwise. - - my ($prefix, $argend, $opt, $opctl) = @_; - - print STDERR ("=> find \"$opt\"\n") if $debug; - - return (0) unless $opt =~ /^$prefix(.*)$/s; - return (0) if $opt eq "-" && !defined $opctl->{''}; - - $opt = $+; - my $starter = $1; - - print STDERR ("=> split \"$starter\"+\"$opt\"\n") if $debug; - - my $optarg; # value supplied with --opt=value - my $rest; # remainder from unbundling - - # If it is a long option, it may include the value. - # With getopt_compat, only if not bundling. - if ( ($starter=~/^$longprefix$/ - || ($getopt_compat && ($bundling == 0 || $bundling == 2))) - && $opt =~ /^([^=]+)=(.*)$/s ) { - $opt = $1; - $optarg = $2; - print STDERR ("=> option \"", $opt, - "\", optarg = \"$optarg\"\n") if $debug; - } - - #### Look it up ### - - my $tryopt = $opt; # option to try - - if ( $bundling && $starter eq '-' ) { - - # To try overrides, obey case ignore. - $tryopt = $ignorecase ? lc($opt) : $opt; - - # If bundling == 2, long options can override bundles. - if ( $bundling == 2 && length($tryopt) > 1 - && defined ($opctl->{$tryopt}) ) { - print STDERR ("=> $starter$tryopt overrides unbundling\n") - if $debug; - } - else { - $tryopt = $opt; - # Unbundle single letter option. - $rest = length ($tryopt) > 0 ? substr ($tryopt, 1) : ''; - $tryopt = substr ($tryopt, 0, 1); - $tryopt = lc ($tryopt) if $ignorecase > 1; - print STDERR ("=> $starter$tryopt unbundled from ", - "$starter$tryopt$rest\n") if $debug; - $rest = undef unless $rest ne ''; - } - } - - # Try auto-abbreviation. - elsif ( $autoabbrev ) { - # Sort the possible long option names. - my @names = sort(keys (%$opctl)); - # Downcase if allowed. - $opt = lc ($opt) if $ignorecase; - $tryopt = $opt; - # Turn option name into pattern. - my $pat = quotemeta ($opt); - # Look up in option names. - my @hits = grep (/^$pat/, @names); - print STDERR ("=> ", scalar(@hits), " hits (@hits) with \"$pat\" ", - "out of ", scalar(@names), "\n") if $debug; - - # Check for ambiguous results. - unless ( (@hits <= 1) || (grep ($_ eq $opt, @hits) == 1) ) { - # See if all matches are for the same option. - my %hit; - foreach ( @hits ) { - my $hit = $_; - $hit = $opctl->{$hit}->[CTL_CNAME] - if defined $opctl->{$hit}->[CTL_CNAME]; - $hit{$hit} = 1; - } - # Remove auto-supplied options (version, help). - if ( keys(%hit) == 2 ) { - if ( $auto_version && exists($hit{version}) ) { - delete $hit{version}; - } - elsif ( $auto_help && exists($hit{help}) ) { - delete $hit{help}; - } - } - # Now see if it really is ambiguous. - unless ( keys(%hit) == 1 ) { - return (0) if $passthrough; - warn ("Option ", $opt, " is ambiguous (", - join(", ", @hits), ")\n"); - $error++; - return (1, undef); - } - @hits = keys(%hit); - } - - # Complete the option name, if appropriate. - if ( @hits == 1 && $hits[0] ne $opt ) { - $tryopt = $hits[0]; - $tryopt = lc ($tryopt) if $ignorecase; - print STDERR ("=> option \"$opt\" -> \"$tryopt\"\n") - if $debug; - } - } - - # Map to all lowercase if ignoring case. - elsif ( $ignorecase ) { - $tryopt = lc ($opt); - } - - # Check validity by fetching the info. - my $ctl = $opctl->{$tryopt}; - unless ( defined $ctl ) { - return (0) if $passthrough; - # Pretend one char when bundling. - if ( $bundling == 1 && length($starter) == 1 ) { - $opt = substr($opt,0,1); - unshift (@ARGV, $starter.$rest) if defined $rest; - } - warn ("Unknown option: ", $opt, "\n"); - $error++; - return (1, undef); - } - # Apparently valid. - $opt = $tryopt; - print STDERR ("=> found ", OptCtl($ctl), - " for \"", $opt, "\"\n") if $debug; - - #### Determine argument status #### - - # If it is an option w/o argument, we're almost finished with it. - my $type = $ctl->[CTL_TYPE]; - my $arg; - - if ( $type eq '' || $type eq '!' || $type eq '+' ) { - if ( defined $optarg ) { - return (0) if $passthrough; - warn ("Option ", $opt, " does not take an argument\n"); - $error++; - undef $opt; - } - elsif ( $type eq '' || $type eq '+' ) { - # Supply explicit value. - $arg = 1; - } - else { - $opt =~ s/^no-?//i; # strip NO prefix - $arg = 0; # supply explicit value - } - unshift (@ARGV, $starter.$rest) if defined $rest; - return (1, $opt, $ctl, $arg); - } - - # Get mandatory status and type info. - my $mand = $ctl->[CTL_AMIN]; - - # Check if there is an option argument available. - if ( $gnu_compat && defined $optarg && $optarg eq '' ) { - return (1, $opt, $ctl, $type eq 's' ? '' : 0) unless $mand; - $optarg = 0 unless $type eq 's'; - } - - # Check if there is an option argument available. - if ( defined $optarg - ? ($optarg eq '') - : !(defined $rest || @ARGV > 0) ) { - # Complain if this option needs an argument. - if ( $mand ) { - return (0) if $passthrough; - warn ("Option ", $opt, " requires an argument\n"); - $error++; - return (1, undef); - } - if ( $type eq 'I' ) { - # Fake incremental type. - my @c = @$ctl; - $c[CTL_TYPE] = '+'; - return (1, $opt, \@c, 1); - } - return (1, $opt, $ctl, - defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] : - $type eq 's' ? '' : 0); - } - - # Get (possibly optional) argument. - $arg = (defined $rest ? $rest - : (defined $optarg ? $optarg : shift (@ARGV))); - - # Get key if this is a "name=value" pair for a hash option. - my $key; - if ($ctl->[CTL_DEST] == CTL_DEST_HASH && defined $arg) { - ($key, $arg) = ($arg =~ /^([^=]*)=(.*)$/s) ? ($1, $2) - : ($arg, defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] : - ($mand ? undef : ($type eq 's' ? "" : 1))); - if (! defined $arg) { - warn ("Option $opt, key \"$key\", requires a value\n"); - $error++; - # Push back. - unshift (@ARGV, $starter.$rest) if defined $rest; - return (1, undef); - } - } - - #### Check if the argument is valid for this option #### - - my $key_valid = $ctl->[CTL_DEST] == CTL_DEST_HASH ? "[^=]+=" : ""; - - if ( $type eq 's' ) { # string - # A mandatory string takes anything. - return (1, $opt, $ctl, $arg, $key) if $mand; - - # An optional string takes almost anything. - return (1, $opt, $ctl, $arg, $key) - if defined $optarg || defined $rest; - return (1, $opt, $ctl, $arg, $key) if $arg eq "-"; # ?? - - # Check for option or option list terminator. - if ($arg eq $argend || - $arg =~ /^$prefix.+/) { - # Push back. - unshift (@ARGV, $arg); - # Supply empty value. - $arg = ''; - } - } - - elsif ( $type eq 'i' # numeric/integer - || $type eq 'I' # numeric/integer w/ incr default - || $type eq 'o' ) { # dec/oct/hex/bin value - - my $o_valid = - $type eq 'o' ? "[-+]?[1-9][0-9]*|0x[0-9a-f]+|0b[01]+|0[0-7]*" - : "[-+]?[0-9]+"; - - if ( $bundling && defined $rest - && $rest =~ /^($key_valid)($o_valid)(.*)$/si ) { - ($key, $arg, $rest) = ($1, $2, $+); - chop($key) if $key; - $arg = ($type eq 'o' && $arg =~ /^0/) ? oct($arg) : 0+$arg; - unshift (@ARGV, $starter.$rest) if defined $rest && $rest ne ''; - } - elsif ( $arg =~ /^($o_valid)$/si ) { - $arg = ($type eq 'o' && $arg =~ /^0/) ? oct($arg) : 0+$arg; - } - else { - if ( defined $optarg || $mand ) { - if ( $passthrough ) { - unshift (@ARGV, defined $rest ? $starter.$rest : $arg) - unless defined $optarg; - return (0); - } - warn ("Value \"", $arg, "\" invalid for option ", - $opt, " (", - $type eq 'o' ? "extended " : '', - "number expected)\n"); - $error++; - # Push back. - unshift (@ARGV, $starter.$rest) if defined $rest; - return (1, undef); - } - else { - # Push back. - unshift (@ARGV, defined $rest ? $starter.$rest : $arg); - if ( $type eq 'I' ) { - # Fake incremental type. - my @c = @$ctl; - $c[CTL_TYPE] = '+'; - return (1, $opt, \@c, 1); - } - # Supply default value. - $arg = defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] : 0; - } - } - } - - elsif ( $type eq 'f' ) { # real number, int is also ok - # We require at least one digit before a point or 'e', - # and at least one digit following the point and 'e'. - # [-]NN[.NN][eNN] - if ( $bundling && defined $rest && - $rest =~ /^($key_valid)([-+]?[0-9]+(\.[0-9]+)?([eE][-+]?[0-9]+)?)(.*)$/s ) { - ($key, $arg, $rest) = ($1, $2, $+); - chop($key) if $key; - unshift (@ARGV, $starter.$rest) if defined $rest && $rest ne ''; - } - elsif ( $arg !~ /^[-+]?[0-9.]+(\.[0-9]+)?([eE][-+]?[0-9]+)?$/ ) { - if ( defined $optarg || $mand ) { - if ( $passthrough ) { - unshift (@ARGV, defined $rest ? $starter.$rest : $arg) - unless defined $optarg; - return (0); - } - warn ("Value \"", $arg, "\" invalid for option ", - $opt, " (real number expected)\n"); - $error++; - # Push back. - unshift (@ARGV, $starter.$rest) if defined $rest; - return (1, undef); - } - else { - # Push back. - unshift (@ARGV, defined $rest ? $starter.$rest : $arg); - # Supply default value. - $arg = 0.0; - } - } - } - else { - die("Getopt::Long internal error (Can't happen)\n"); - } - return (1, $opt, $ctl, $arg, $key); -} - -sub ValidValue ($$$$$) { - my ($ctl, $arg, $mand, $argend, $prefix) = @_; - - if ( $ctl->[CTL_DEST] == CTL_DEST_HASH ) { - return 0 unless $arg =~ /[^=]+=(.*)/; - $arg = $1; - } - - my $type = $ctl->[CTL_TYPE]; - - if ( $type eq 's' ) { # string - # A mandatory string takes anything. - return (1) if $mand; - - return (1) if $arg eq "-"; - - # Check for option or option list terminator. - return 0 if $arg eq $argend || $arg =~ /^$prefix.+/; - return 1; - } - - elsif ( $type eq 'i' # numeric/integer - || $type eq 'I' # numeric/integer w/ incr default - || $type eq 'o' ) { # dec/oct/hex/bin value - - my $o_valid = - $type eq 'o' ? "[-+]?[1-9][0-9]*|0x[0-9a-f]+|0b[01]+|0[0-7]*" - : "[-+]?[0-9]+"; - - return $arg =~ /^$o_valid$/si; - } - - elsif ( $type eq 'f' ) { # real number, int is also ok - # We require at least one digit before a point or 'e', - # and at least one digit following the point and 'e'. - # [-]NN[.NN][eNN] - return $arg =~ /^[-+]?[0-9.]+(\.[0-9]+)?([eE][-+]?[0-9]+)?$/; - } - die("ValidValue: Cannot happen\n"); -} - -# Getopt::Long Configuration. -sub Configure (@) { - my (@options) = @_; - - my $prevconfig = - [ $error, $debug, $major_version, $minor_version, - $autoabbrev, $getopt_compat, $ignorecase, $bundling, $order, - $gnu_compat, $passthrough, $genprefix, $auto_version, $auto_help, - $longprefix ]; - - if ( ref($options[0]) eq 'ARRAY' ) { - ( $error, $debug, $major_version, $minor_version, - $autoabbrev, $getopt_compat, $ignorecase, $bundling, $order, - $gnu_compat, $passthrough, $genprefix, $auto_version, $auto_help, - $longprefix ) = @{shift(@options)}; - } - - my $opt; - foreach $opt ( @options ) { - my $try = lc ($opt); - my $action = 1; - if ( $try =~ /^no_?(.*)$/s ) { - $action = 0; - $try = $+; - } - if ( ($try eq 'default' or $try eq 'defaults') && $action ) { - ConfigDefaults (); - } - elsif ( ($try eq 'posix_default' or $try eq 'posix_defaults') ) { - local $ENV{POSIXLY_CORRECT}; - $ENV{POSIXLY_CORRECT} = 1 if $action; - ConfigDefaults (); - } - elsif ( $try eq 'auto_abbrev' or $try eq 'autoabbrev' ) { - $autoabbrev = $action; - } - elsif ( $try eq 'getopt_compat' ) { - $getopt_compat = $action; - } - elsif ( $try eq 'gnu_getopt' ) { - if ( $action ) { - $gnu_compat = 1; - $bundling = 1; - $getopt_compat = 0; - $order = $PERMUTE; - } - } - elsif ( $try eq 'gnu_compat' ) { - $gnu_compat = $action; - } - elsif ( $try =~ /^(auto_?)?version$/ ) { - $auto_version = $action; - } - elsif ( $try =~ /^(auto_?)?help$/ ) { - $auto_help = $action; - } - elsif ( $try eq 'ignorecase' or $try eq 'ignore_case' ) { - $ignorecase = $action; - } - elsif ( $try eq 'ignore_case_always' ) { - $ignorecase = $action ? 2 : 0; - } - elsif ( $try eq 'bundling' ) { - $bundling = $action; - } - elsif ( $try eq 'bundling_override' ) { - $bundling = $action ? 2 : 0; - } - elsif ( $try eq 'require_order' ) { - $order = $action ? $REQUIRE_ORDER : $PERMUTE; - } - elsif ( $try eq 'permute' ) { - $order = $action ? $PERMUTE : $REQUIRE_ORDER; - } - elsif ( $try eq 'pass_through' or $try eq 'passthrough' ) { - $passthrough = $action; - } - elsif ( $try =~ /^prefix=(.+)$/ && $action ) { - $genprefix = $1; - # Turn into regexp. Needs to be parenthesized! - $genprefix = "(" . quotemeta($genprefix) . ")"; - eval { '' =~ /$genprefix/; }; - die("Getopt::Long: invalid pattern \"$genprefix\"") if $@; - } - elsif ( $try =~ /^prefix_pattern=(.+)$/ && $action ) { - $genprefix = $1; - # Parenthesize if needed. - $genprefix = "(" . $genprefix . ")" - unless $genprefix =~ /^\(.*\)$/; - eval { '' =~ m"$genprefix"; }; - die("Getopt::Long: invalid pattern \"$genprefix\"") if $@; - } - elsif ( $try =~ /^long_prefix_pattern=(.+)$/ && $action ) { - $longprefix = $1; - # Parenthesize if needed. - $longprefix = "(" . $longprefix . ")" - unless $longprefix =~ /^\(.*\)$/; - eval { '' =~ m"$longprefix"; }; - die("Getopt::Long: invalid long prefix pattern \"$longprefix\"") if $@; - } - elsif ( $try eq 'debug' ) { - $debug = $action; - } - else { - die("Getopt::Long: unknown config parameter \"$opt\"") - } - } - $prevconfig; -} - -# Deprecated name. -sub config (@) { - Configure (@_); -} - -# Issue a standard message for --version. -# -# The arguments are mostly the same as for Pod::Usage::pod2usage: -# -# - a number (exit value) -# - a string (lead in message) -# - a hash with options. See Pod::Usage for details. -# -sub VersionMessage(@) { - # Massage args. - my $pa = setup_pa_args("version", @_); - - my $v = $main::VERSION; - my $fh = $pa->{-output} || - ($pa->{-exitval} eq "NOEXIT" || $pa->{-exitval} < 2) ? \*STDOUT : \*STDERR; - - print $fh (defined($pa->{-message}) ? $pa->{-message} : (), - $0, defined $v ? " version $v" : (), - "\n", - "(", __PACKAGE__, "::", "GetOptions", - " version ", - defined($Getopt::Long::VERSION_STRING) - ? $Getopt::Long::VERSION_STRING : $VERSION, ";", - " Perl version ", - $] >= 5.006 ? sprintf("%vd", $^V) : $], - ")\n"); - exit($pa->{-exitval}) unless $pa->{-exitval} eq "NOEXIT"; -} - -# Issue a standard message for --help. -# -# The arguments are the same as for Pod::Usage::pod2usage: -# -# - a number (exit value) -# - a string (lead in message) -# - a hash with options. See Pod::Usage for details. -# -sub HelpMessage(@) { - eval { - require Pod::Usage; - import Pod::Usage; - 1; - } || die("Cannot provide help: cannot load Pod::Usage\n"); - - # Note that pod2usage will issue a warning if -exitval => NOEXIT. - pod2usage(setup_pa_args("help", @_)); - -} - -# Helper routine to set up a normalized hash ref to be used as -# argument to pod2usage. -sub setup_pa_args($@) { - my $tag = shift; # who's calling - - # If called by direct binding to an option, it will get the option - # name and value as arguments. Remove these, if so. - @_ = () if @_ == 2 && $_[0] eq $tag; - - my $pa; - if ( @_ > 1 ) { - $pa = { @_ }; - } - else { - $pa = shift || {}; - } - - # At this point, $pa can be a number (exit value), string - # (message) or hash with options. - - if ( UNIVERSAL::isa($pa, 'HASH') ) { - # Get rid of -msg vs. -message ambiguity. - $pa->{-message} = $pa->{-msg}; - delete($pa->{-msg}); - } - elsif ( $pa =~ /^-?\d+$/ ) { - $pa = { -exitval => $pa }; - } - else { - $pa = { -message => $pa }; - } - - # These are _our_ defaults. - $pa->{-verbose} = 0 unless exists($pa->{-verbose}); - $pa->{-exitval} = 0 unless exists($pa->{-exitval}); - $pa; -} - -# Sneak way to know what version the user requested. -sub VERSION { - $requested_version = $_[1]; - shift->SUPER::VERSION(@_); -} - -1; - -################ Documentation ################ - -=head1 NAME - -Getopt::Long - Extended processing of command line options - -=head1 SYNOPSIS - - use Getopt::Long; - my $data = "file.dat"; - my $length = 24; - my $verbose; - $result = GetOptions ("length=i" => \$length, # numeric - "file=s" => \$data, # string - "verbose" => \$verbose); # flag - -=head1 DESCRIPTION - -The Getopt::Long module implements an extended getopt function called -GetOptions(). This function adheres to the POSIX syntax for command -line options, with GNU extensions. In general, this means that options -have long names instead of single letters, and are introduced with a -double dash "--". Support for bundling of command line options, as was -the case with the more traditional single-letter approach, is provided -but not enabled by default. - -=head1 Command Line Options, an Introduction - -Command line operated programs traditionally take their arguments from -the command line, for example filenames or other information that the -program needs to know. Besides arguments, these programs often take -command line I<options> as well. Options are not necessary for the -program to work, hence the name 'option', but are used to modify its -default behaviour. For example, a program could do its job quietly, -but with a suitable option it could provide verbose information about -what it did. - -Command line options come in several flavours. Historically, they are -preceded by a single dash C<->, and consist of a single letter. - - -l -a -c - -Usually, these single-character options can be bundled: - - -lac - -Options can have values, the value is placed after the option -character. Sometimes with whitespace in between, sometimes not: - - -s 24 -s24 - -Due to the very cryptic nature of these options, another style was -developed that used long names. So instead of a cryptic C<-l> one -could use the more descriptive C<--long>. To distinguish between a -bundle of single-character options and a long one, two dashes are used -to precede the option name. Early implementations of long options used -a plus C<+> instead. Also, option values could be specified either -like - - --size=24 - -or - - --size 24 - -The C<+> form is now obsolete and strongly deprecated. - -=head1 Getting Started with Getopt::Long - -Getopt::Long is the Perl5 successor of C<newgetopt.pl>. This was the -first Perl module that provided support for handling the new style of -command line options, hence the name Getopt::Long. This module also -supports single-character options and bundling. Single character -options may be any alphabetic character, a question mark, and a dash. -Long options may consist of a series of letters, digits, and dashes. -Although this is currently not enforced by Getopt::Long, multiple -consecutive dashes are not allowed, and the option name must not end -with a dash. - -To use Getopt::Long from a Perl program, you must include the -following line in your Perl program: - - use Getopt::Long; - -This will load the core of the Getopt::Long module and prepare your -program for using it. Most of the actual Getopt::Long code is not -loaded until you really call one of its functions. - -In the default configuration, options names may be abbreviated to -uniqueness, case does not matter, and a single dash is sufficient, -even for long option names. Also, options may be placed between -non-option arguments. See L<Configuring Getopt::Long> for more -details on how to configure Getopt::Long. - -=head2 Simple options - -The most simple options are the ones that take no values. Their mere -presence on the command line enables the option. Popular examples are: - - --all --verbose --quiet --debug - -Handling simple options is straightforward: - - my $verbose = ''; # option variable with default value (false) - my $all = ''; # option variable with default value (false) - GetOptions ('verbose' => \$verbose, 'all' => \$all); - -The call to GetOptions() parses the command line arguments that are -present in C<@ARGV> and sets the option variable to the value C<1> if -the option did occur on the command line. Otherwise, the option -variable is not touched. Setting the option value to true is often -called I<enabling> the option. - -The option name as specified to the GetOptions() function is called -the option I<specification>. Later we'll see that this specification -can contain more than just the option name. The reference to the -variable is called the option I<destination>. - -GetOptions() will return a true value if the command line could be -processed successfully. Otherwise, it will write error messages to -STDERR, and return a false result. - -=head2 A little bit less simple options - -Getopt::Long supports two useful variants of simple options: -I<negatable> options and I<incremental> options. - -A negatable option is specified with an exclamation mark C<!> after the -option name: - - my $verbose = ''; # option variable with default value (false) - GetOptions ('verbose!' => \$verbose); - -Now, using C<--verbose> on the command line will enable C<$verbose>, -as expected. But it is also allowed to use C<--noverbose>, which will -disable C<$verbose> by setting its value to C<0>. Using a suitable -default value, the program can find out whether C<$verbose> is false -by default, or disabled by using C<--noverbose>. - -An incremental option is specified with a plus C<+> after the -option name: - - my $verbose = ''; # option variable with default value (false) - GetOptions ('verbose+' => \$verbose); - -Using C<--verbose> on the command line will increment the value of -C<$verbose>. This way the program can keep track of how many times the -option occurred on the command line. For example, each occurrence of -C<--verbose> could increase the verbosity level of the program. - -=head2 Mixing command line option with other arguments - -Usually programs take command line options as well as other arguments, -for example, file names. It is good practice to always specify the -options first, and the other arguments last. Getopt::Long will, -however, allow the options and arguments to be mixed and 'filter out' -all the options before passing the rest of the arguments to the -program. To stop Getopt::Long from processing further arguments, -insert a double dash C<--> on the command line: - - --size 24 -- --all - -In this example, C<--all> will I<not> be treated as an option, but -passed to the program unharmed, in C<@ARGV>. - -=head2 Options with values - -For options that take values it must be specified whether the option -value is required or not, and what kind of value the option expects. - -Three kinds of values are supported: integer numbers, floating point -numbers, and strings. - -If the option value is required, Getopt::Long will take the -command line argument that follows the option and assign this to the -option variable. If, however, the option value is specified as -optional, this will only be done if that value does not look like a -valid command line option itself. - - my $tag = ''; # option variable with default value - GetOptions ('tag=s' => \$tag); - -In the option specification, the option name is followed by an equals -sign C<=> and the letter C<s>. The equals sign indicates that this -option requires a value. The letter C<s> indicates that this value is -an arbitrary string. Other possible value types are C<i> for integer -values, and C<f> for floating point values. Using a colon C<:> instead -of the equals sign indicates that the option value is optional. In -this case, if no suitable value is supplied, string valued options get -an empty string C<''> assigned, while numeric options are set to C<0>. - -=head2 Options with multiple values - -Options sometimes take several values. For example, a program could -use multiple directories to search for library files: - - --library lib/stdlib --library lib/extlib - -To accomplish this behaviour, simply specify an array reference as the -destination for the option: - - GetOptions ("library=s" => \@libfiles); - -Alternatively, you can specify that the option can have multiple -values by adding a "@", and pass a scalar reference as the -destination: - - GetOptions ("library=s@" => \$libfiles); - -Used with the example above, C<@libfiles> (or C<@$libfiles>) would -contain two strings upon completion: C<"lib/srdlib"> and -C<"lib/extlib">, in that order. It is also possible to specify that -only integer or floating point numbers are acceptable values. - -Often it is useful to allow comma-separated lists of values as well as -multiple occurrences of the options. This is easy using Perl's split() -and join() operators: - - GetOptions ("library=s" => \@libfiles); - @libfiles = split(/,/,join(',',@libfiles)); - -Of course, it is important to choose the right separator string for -each purpose. - -Warning: What follows is an experimental feature. - -Options can take multiple values at once, for example - - --coordinates 52.2 16.4 --rgbcolor 255 255 149 - -This can be accomplished by adding a repeat specifier to the option -specification. Repeat specifiers are very similar to the C<{...}> -repeat specifiers that can be used with regular expression patterns. -For example, the above command line would be handled as follows: - - GetOptions('coordinates=f{2}' => \@coor, 'rgbcolor=i{3}' => \@color); - -The destination for the option must be an array or array reference. - -It is also possible to specify the minimal and maximal number of -arguments an option takes. C<foo=s{2,4}> indicates an option that -takes at least two and at most 4 arguments. C<foo=s{,}> indicates one -or more values; C<foo:s{,}> indicates zero or more option values. - -=head2 Options with hash values - -If the option destination is a reference to a hash, the option will -take, as value, strings of the form I<key>C<=>I<value>. The value will -be stored with the specified key in the hash. - - GetOptions ("define=s" => \%defines); - -Alternatively you can use: - - GetOptions ("define=s%" => \$defines); - -When used with command line options: - - --define os=linux --define vendor=redhat - -the hash C<%defines> (or C<%$defines>) will contain two keys, C<"os"> -with value C<"linux> and C<"vendor"> with value C<"redhat">. It is -also possible to specify that only integer or floating point numbers -are acceptable values. The keys are always taken to be strings. - -=head2 User-defined subroutines to handle options - -Ultimate control over what should be done when (actually: each time) -an option is encountered on the command line can be achieved by -designating a reference to a subroutine (or an anonymous subroutine) -as the option destination. When GetOptions() encounters the option, it -will call the subroutine with two or three arguments. The first -argument is the name of the option. For a scalar or array destination, -the second argument is the value to be stored. For a hash destination, -the second arguments is the key to the hash, and the third argument -the value to be stored. It is up to the subroutine to store the value, -or do whatever it thinks is appropriate. - -A trivial application of this mechanism is to implement options that -are related to each other. For example: - - my $verbose = ''; # option variable with default value (false) - GetOptions ('verbose' => \$verbose, - 'quiet' => sub { $verbose = 0 }); - -Here C<--verbose> and C<--quiet> control the same variable -C<$verbose>, but with opposite values. - -If the subroutine needs to signal an error, it should call die() with -the desired error message as its argument. GetOptions() will catch the -die(), issue the error message, and record that an error result must -be returned upon completion. - -If the text of the error message starts with an exclamation mark C<!> -it is interpreted specially by GetOptions(). There is currently one -special command implemented: C<die("!FINISH")> will cause GetOptions() -to stop processing options, as if it encountered a double dash C<-->. - -=head2 Options with multiple names - -Often it is user friendly to supply alternate mnemonic names for -options. For example C<--height> could be an alternate name for -C<--length>. Alternate names can be included in the option -specification, separated by vertical bar C<|> characters. To implement -the above example: - - GetOptions ('length|height=f' => \$length); - -The first name is called the I<primary> name, the other names are -called I<aliases>. When using a hash to store options, the key will -always be the primary name. - -Multiple alternate names are possible. - -=head2 Case and abbreviations - -Without additional configuration, GetOptions() will ignore the case of -option names, and allow the options to be abbreviated to uniqueness. - - GetOptions ('length|height=f' => \$length, "head" => \$head); - -This call will allow C<--l> and C<--L> for the length option, but -requires a least C<--hea> and C<--hei> for the head and height options. - -=head2 Summary of Option Specifications - -Each option specifier consists of two parts: the name specification -and the argument specification. - -The name specification contains the name of the option, optionally -followed by a list of alternative names separated by vertical bar -characters. - - length option name is "length" - length|size|l name is "length", aliases are "size" and "l" - -The argument specification is optional. If omitted, the option is -considered boolean, a value of 1 will be assigned when the option is -used on the command line. - -The argument specification can be - -=over 4 - -=item ! - -The option does not take an argument and may be negated by prefixing -it with "no" or "no-". E.g. C<"foo!"> will allow C<--foo> (a value of -1 will be assigned) as well as C<--nofoo> and C<--no-foo> (a value of -0 will be assigned). If the option has aliases, this applies to the -aliases as well. - -Using negation on a single letter option when bundling is in effect is -pointless and will result in a warning. - -=item + - -The option does not take an argument and will be incremented by 1 -every time it appears on the command line. E.g. C<"more+">, when used -with C<--more --more --more>, will increment the value three times, -resulting in a value of 3 (provided it was 0 or undefined at first). - -The C<+> specifier is ignored if the option destination is not a scalar. - -=item = I<type> [ I<desttype> ] [ I<repeat> ] - -The option requires an argument of the given type. Supported types -are: - -=over 4 - -=item s - -String. An arbitrary sequence of characters. It is valid for the -argument to start with C<-> or C<-->. - -=item i - -Integer. An optional leading plus or minus sign, followed by a -sequence of digits. - -=item o - -Extended integer, Perl style. This can be either an optional leading -plus or minus sign, followed by a sequence of digits, or an octal -string (a zero, optionally followed by '0', '1', .. '7'), or a -hexadecimal string (C<0x> followed by '0' .. '9', 'a' .. 'f', case -insensitive), or a binary string (C<0b> followed by a series of '0' -and '1'). - -=item f - -Real number. For example C<3.14>, C<-6.23E24> and so on. - -=back - -The I<desttype> can be C<@> or C<%> to specify that the option is -list or a hash valued. This is only needed when the destination for -the option value is not otherwise specified. It should be omitted when -not needed. - -The I<repeat> specifies the number of values this option takes per -occurrence on the command line. It has the format C<{> [ I<min> ] [ C<,> [ I<max> ] ] C<}>. - -I<min> denotes the minimal number of arguments. It defaults to 1 for -options with C<=> and to 0 for options with C<:>, see below. Note that -I<min> overrules the C<=> / C<:> semantics. - -I<max> denotes the maximum number of arguments. It must be at least -I<min>. If I<max> is omitted, I<but the comma is not>, there is no -upper bound to the number of argument values taken. - -=item : I<type> [ I<desttype> ] - -Like C<=>, but designates the argument as optional. -If omitted, an empty string will be assigned to string values options, -and the value zero to numeric options. - -Note that if a string argument starts with C<-> or C<-->, it will be -considered an option on itself. - -=item : I<number> [ I<desttype> ] - -Like C<:i>, but if the value is omitted, the I<number> will be assigned. - -=item : + [ I<desttype> ] - -Like C<:i>, but if the value is omitted, the current value for the -option will be incremented. - -=back - -=head1 Advanced Possibilities - -=head2 Object oriented interface - -Getopt::Long can be used in an object oriented way as well: - - use Getopt::Long; - $p = new Getopt::Long::Parser; - $p->configure(...configuration options...); - if ($p->getoptions(...options descriptions...)) ... - -Configuration options can be passed to the constructor: - - $p = new Getopt::Long::Parser - config => [...configuration options...]; - -=head2 Thread Safety - -Getopt::Long is thread safe when using ithreads as of Perl 5.8. It is -I<not> thread safe when using the older (experimental and now -obsolete) threads implementation that was added to Perl 5.005. - -=head2 Documentation and help texts - -Getopt::Long encourages the use of Pod::Usage to produce help -messages. For example: - - use Getopt::Long; - use Pod::Usage; - - my $man = 0; - my $help = 0; - - GetOptions('help|?' => \$help, man => \$man) or pod2usage(2); - pod2usage(1) if $help; - pod2usage(-exitstatus => 0, -verbose => 2) if $man; - - __END__ - - =head1 NAME - - sample - Using Getopt::Long and Pod::Usage - - =head1 SYNOPSIS - - sample [options] [file ...] - - Options: - -help brief help message - -man full documentation - - =head1 OPTIONS - - =over 8 - - =item B<-help> - - Print a brief help message and exits. - - =item B<-man> - - Prints the manual page and exits. - - =back - - =head1 DESCRIPTION - - B<This program> will read the given input file(s) and do something - useful with the contents thereof. - - =cut - -See L<Pod::Usage> for details. - -=head2 Storing option values in a hash - -Sometimes, for example when there are a lot of options, having a -separate variable for each of them can be cumbersome. GetOptions() -supports, as an alternative mechanism, storing options in a hash. - -To obtain this, a reference to a hash must be passed I<as the first -argument> to GetOptions(). For each option that is specified on the -command line, the option value will be stored in the hash with the -option name as key. Options that are not actually used on the command -line will not be put in the hash, on other words, -C<exists($h{option})> (or defined()) can be used to test if an option -was used. The drawback is that warnings will be issued if the program -runs under C<use strict> and uses C<$h{option}> without testing with -exists() or defined() first. - - my %h = (); - GetOptions (\%h, 'length=i'); # will store in $h{length} - -For options that take list or hash values, it is necessary to indicate -this by appending an C<@> or C<%> sign after the type: - - GetOptions (\%h, 'colours=s@'); # will push to @{$h{colours}} - -To make things more complicated, the hash may contain references to -the actual destinations, for example: - - my $len = 0; - my %h = ('length' => \$len); - GetOptions (\%h, 'length=i'); # will store in $len - -This example is fully equivalent with: - - my $len = 0; - GetOptions ('length=i' => \$len); # will store in $len - -Any mixture is possible. For example, the most frequently used options -could be stored in variables while all other options get stored in the -hash: - - my $verbose = 0; # frequently referred - my $debug = 0; # frequently referred - my %h = ('verbose' => \$verbose, 'debug' => \$debug); - GetOptions (\%h, 'verbose', 'debug', 'filter', 'size=i'); - if ( $verbose ) { ... } - if ( exists $h{filter} ) { ... option 'filter' was specified ... } - -=head2 Bundling - -With bundling it is possible to set several single-character options -at once. For example if C<a>, C<v> and C<x> are all valid options, - - -vax - -would set all three. - -Getopt::Long supports two levels of bundling. To enable bundling, a -call to Getopt::Long::Configure is required. - -The first level of bundling can be enabled with: - - Getopt::Long::Configure ("bundling"); - -Configured this way, single-character options can be bundled but long -options B<must> always start with a double dash C<--> to avoid -ambiguity. For example, when C<vax>, C<a>, C<v> and C<x> are all valid -options, - - -vax - -would set C<a>, C<v> and C<x>, but - - --vax - -would set C<vax>. - -The second level of bundling lifts this restriction. It can be enabled -with: - - Getopt::Long::Configure ("bundling_override"); - -Now, C<-vax> would set the option C<vax>. - -When any level of bundling is enabled, option values may be inserted -in the bundle. For example: - - -h24w80 - -is equivalent to - - -h 24 -w 80 - -When configured for bundling, single-character options are matched -case sensitive while long options are matched case insensitive. To -have the single-character options matched case insensitive as well, -use: - - Getopt::Long::Configure ("bundling", "ignorecase_always"); - -It goes without saying that bundling can be quite confusing. - -=head2 The lonesome dash - -Normally, a lone dash C<-> on the command line will not be considered -an option. Option processing will terminate (unless "permute" is -configured) and the dash will be left in C<@ARGV>. - -It is possible to get special treatment for a lone dash. This can be -achieved by adding an option specification with an empty name, for -example: - - GetOptions ('' => \$stdio); - -A lone dash on the command line will now be a legal option, and using -it will set variable C<$stdio>. - -=head2 Argument callback - -A special option 'name' C<< <> >> can be used to designate a subroutine -to handle non-option arguments. When GetOptions() encounters an -argument that does not look like an option, it will immediately call this -subroutine and passes it one parameter: the argument name. - -For example: - - my $width = 80; - sub process { ... } - GetOptions ('width=i' => \$width, '<>' => \&process); - -When applied to the following command line: - - arg1 --width=72 arg2 --width=60 arg3 - -This will call -C<process("arg1")> while C<$width> is C<80>, -C<process("arg2")> while C<$width> is C<72>, and -C<process("arg3")> while C<$width> is C<60>. - -This feature requires configuration option B<permute>, see section -L<Configuring Getopt::Long>. - -=head1 Configuring Getopt::Long - -Getopt::Long can be configured by calling subroutine -Getopt::Long::Configure(). This subroutine takes a list of quoted -strings, each specifying a configuration option to be enabled, e.g. -C<ignore_case>, or disabled, e.g. C<no_ignore_case>. Case does not -matter. Multiple calls to Configure() are possible. - -Alternatively, as of version 2.24, the configuration options may be -passed together with the C<use> statement: - - use Getopt::Long qw(:config no_ignore_case bundling); - -The following options are available: - -=over 12 - -=item default - -This option causes all configuration options to be reset to their -default values. - -=item posix_default - -This option causes all configuration options to be reset to their -default values as if the environment variable POSIXLY_CORRECT had -been set. - -=item auto_abbrev - -Allow option names to be abbreviated to uniqueness. -Default is enabled unless environment variable -POSIXLY_CORRECT has been set, in which case C<auto_abbrev> is disabled. - -=item getopt_compat - -Allow C<+> to start options. -Default is enabled unless environment variable -POSIXLY_CORRECT has been set, in which case C<getopt_compat> is disabled. - -=item gnu_compat - -C<gnu_compat> controls whether C<--opt=> is allowed, and what it should -do. Without C<gnu_compat>, C<--opt=> gives an error. With C<gnu_compat>, -C<--opt=> will give option C<opt> and empty value. -This is the way GNU getopt_long() does it. - -=item gnu_getopt - -This is a short way of setting C<gnu_compat> C<bundling> C<permute> -C<no_getopt_compat>. With C<gnu_getopt>, command line handling should be -fully compatible with GNU getopt_long(). - -=item require_order - -Whether command line arguments are allowed to be mixed with options. -Default is disabled unless environment variable -POSIXLY_CORRECT has been set, in which case C<require_order> is enabled. - -See also C<permute>, which is the opposite of C<require_order>. - -=item permute - -Whether command line arguments are allowed to be mixed with options. -Default is enabled unless environment variable -POSIXLY_CORRECT has been set, in which case C<permute> is disabled. -Note that C<permute> is the opposite of C<require_order>. - -If C<permute> is enabled, this means that - - --foo arg1 --bar arg2 arg3 - -is equivalent to - - --foo --bar arg1 arg2 arg3 - -If an argument callback routine is specified, C<@ARGV> will always be -empty upon successful return of GetOptions() since all options have been -processed. The only exception is when C<--> is used: - - --foo arg1 --bar arg2 -- arg3 - -This will call the callback routine for arg1 and arg2, and then -terminate GetOptions() leaving C<"arg2"> in C<@ARGV>. - -If C<require_order> is enabled, options processing -terminates when the first non-option is encountered. - - --foo arg1 --bar arg2 arg3 - -is equivalent to - - --foo -- arg1 --bar arg2 arg3 - -If C<pass_through> is also enabled, options processing will terminate -at the first unrecognized option, or non-option, whichever comes -first. - -=item bundling (default: disabled) - -Enabling this option will allow single-character options to be -bundled. To distinguish bundles from long option names, long options -I<must> be introduced with C<--> and bundles with C<->. - -Note that, if you have options C<a>, C<l> and C<all>, and -auto_abbrev enabled, possible arguments and option settings are: - - using argument sets option(s) - ------------------------------------------ - -a, --a a - -l, --l l - -al, -la, -ala, -all,... a, l - --al, --all all - -The surprising part is that C<--a> sets option C<a> (due to auto -completion), not C<all>. - -Note: disabling C<bundling> also disables C<bundling_override>. - -=item bundling_override (default: disabled) - -If C<bundling_override> is enabled, bundling is enabled as with -C<bundling> but now long option names override option bundles. - -Note: disabling C<bundling_override> also disables C<bundling>. - -B<Note:> Using option bundling can easily lead to unexpected results, -especially when mixing long options and bundles. Caveat emptor. - -=item ignore_case (default: enabled) - -If enabled, case is ignored when matching long option names. If, -however, bundling is enabled as well, single character options will be -treated case-sensitive. - -With C<ignore_case>, option specifications for options that only -differ in case, e.g., C<"foo"> and C<"Foo">, will be flagged as -duplicates. - -Note: disabling C<ignore_case> also disables C<ignore_case_always>. - -=item ignore_case_always (default: disabled) - -When bundling is in effect, case is ignored on single-character -options also. - -Note: disabling C<ignore_case_always> also disables C<ignore_case>. - -=item auto_version (default:disabled) - -Automatically provide support for the B<--version> option if -the application did not specify a handler for this option itself. - -Getopt::Long will provide a standard version message that includes the -program name, its version (if $main::VERSION is defined), and the -versions of Getopt::Long and Perl. The message will be written to -standard output and processing will terminate. - -C<auto_version> will be enabled if the calling program explicitly -specified a version number higher than 2.32 in the C<use> or -C<require> statement. - -=item auto_help (default:disabled) - -Automatically provide support for the B<--help> and B<-?> options if -the application did not specify a handler for this option itself. - -Getopt::Long will provide a help message using module L<Pod::Usage>. The -message, derived from the SYNOPSIS POD section, will be written to -standard output and processing will terminate. - -C<auto_help> will be enabled if the calling program explicitly -specified a version number higher than 2.32 in the C<use> or -C<require> statement. - -=item pass_through (default: disabled) - -Options that are unknown, ambiguous or supplied with an invalid option -value are passed through in C<@ARGV> instead of being flagged as -errors. This makes it possible to write wrapper scripts that process -only part of the user supplied command line arguments, and pass the -remaining options to some other program. - -If C<require_order> is enabled, options processing will terminate at -the first unrecognized option, or non-option, whichever comes first. -However, if C<permute> is enabled instead, results can become confusing. - -Note that the options terminator (default C<-->), if present, will -also be passed through in C<@ARGV>. - -=item prefix - -The string that starts options. If a constant string is not -sufficient, see C<prefix_pattern>. - -=item prefix_pattern - -A Perl pattern that identifies the strings that introduce options. -Default is C<--|-|\+> unless environment variable -POSIXLY_CORRECT has been set, in which case it is C<--|->. - -=item long_prefix_pattern - -A Perl pattern that allows the disambiguation of long and short -prefixes. Default is C<-->. - -Typically you only need to set this if you are using nonstandard -prefixes and want some or all of them to have the same semantics as -'--' does under normal circumstances. - -For example, setting prefix_pattern to C<--|-|\+|\/> and -long_prefix_pattern to C<--|\/> would add Win32 style argument -handling. - -=item debug (default: disabled) - -Enable debugging output. - -=back - -=head1 Exportable Methods - -=over - -=item VersionMessage - -This subroutine provides a standard version message. Its argument can be: - -=over 4 - -=item * - -A string containing the text of a message to print I<before> printing -the standard message. - -=item * - -A numeric value corresponding to the desired exit status. - -=item * - -A reference to a hash. - -=back - -If more than one argument is given then the entire argument list is -assumed to be a hash. If a hash is supplied (either as a reference or -as a list) it should contain one or more elements with the following -keys: - -=over 4 - -=item C<-message> - -=item C<-msg> - -The text of a message to print immediately prior to printing the -program's usage message. - -=item C<-exitval> - -The desired exit status to pass to the B<exit()> function. -This should be an integer, or else the string "NOEXIT" to -indicate that control should simply be returned without -terminating the invoking process. - -=item C<-output> - -A reference to a filehandle, or the pathname of a file to which the -usage message should be written. The default is C<\*STDERR> unless the -exit value is less than 2 (in which case the default is C<\*STDOUT>). - -=back - -You cannot tie this routine directly to an option, e.g.: - - GetOptions("version" => \&VersionMessage); - -Use this instead: - - GetOptions("version" => sub { VersionMessage() }); - -=item HelpMessage - -This subroutine produces a standard help message, derived from the -program's POD section SYNOPSIS using L<Pod::Usage>. It takes the same -arguments as VersionMessage(). In particular, you cannot tie it -directly to an option, e.g.: - - GetOptions("help" => \&HelpMessage); - -Use this instead: - - GetOptions("help" => sub { HelpMessage() }); - -=back - -=head1 Return values and Errors - -Configuration errors and errors in the option definitions are -signalled using die() and will terminate the calling program unless -the call to Getopt::Long::GetOptions() was embedded in C<eval { ... -}>, or die() was trapped using C<$SIG{__DIE__}>. - -GetOptions returns true to indicate success. -It returns false when the function detected one or more errors during -option parsing. These errors are signalled using warn() and can be -trapped with C<$SIG{__WARN__}>. - -=head1 Legacy - -The earliest development of C<newgetopt.pl> started in 1990, with Perl -version 4. As a result, its development, and the development of -Getopt::Long, has gone through several stages. Since backward -compatibility has always been extremely important, the current version -of Getopt::Long still supports a lot of constructs that nowadays are -no longer necessary or otherwise unwanted. This section describes -briefly some of these 'features'. - -=head2 Default destinations - -When no destination is specified for an option, GetOptions will store -the resultant value in a global variable named C<opt_>I<XXX>, where -I<XXX> is the primary name of this option. When a progam executes -under C<use strict> (recommended), these variables must be -pre-declared with our() or C<use vars>. - - our $opt_length = 0; - GetOptions ('length=i'); # will store in $opt_length - -To yield a usable Perl variable, characters that are not part of the -syntax for variables are translated to underscores. For example, -C<--fpp-struct-return> will set the variable -C<$opt_fpp_struct_return>. Note that this variable resides in the -namespace of the calling program, not necessarily C<main>. For -example: - - GetOptions ("size=i", "sizes=i@"); - -with command line "-size 10 -sizes 24 -sizes 48" will perform the -equivalent of the assignments - - $opt_size = 10; - @opt_sizes = (24, 48); - -=head2 Alternative option starters - -A string of alternative option starter characters may be passed as the -first argument (or the first argument after a leading hash reference -argument). - - my $len = 0; - GetOptions ('/', 'length=i' => $len); - -Now the command line may look like: - - /length 24 -- arg - -Note that to terminate options processing still requires a double dash -C<-->. - -GetOptions() will not interpret a leading C<< "<>" >> as option starters -if the next argument is a reference. To force C<< "<" >> and C<< ">" >> as -option starters, use C<< "><" >>. Confusing? Well, B<using a starter -argument is strongly deprecated> anyway. - -=head2 Configuration variables - -Previous versions of Getopt::Long used variables for the purpose of -configuring. Although manipulating these variables still work, it is -strongly encouraged to use the C<Configure> routine that was introduced -in version 2.17. Besides, it is much easier. - -=head1 Trouble Shooting - -=head2 GetOptions does not return a false result when an option is not supplied - -That's why they're called 'options'. - -=head2 GetOptions does not split the command line correctly - -The command line is not split by GetOptions, but by the command line -interpreter (CLI). On Unix, this is the shell. On Windows, it is -COMMAND.COM or CMD.EXE. Other operating systems have other CLIs. - -It is important to know that these CLIs may behave different when the -command line contains special characters, in particular quotes or -backslashes. For example, with Unix shells you can use single quotes -(C<'>) and double quotes (C<">) to group words together. The following -alternatives are equivalent on Unix: - - "two words" - 'two words' - two\ words - -In case of doubt, insert the following statement in front of your Perl -program: - - print STDERR (join("|",@ARGV),"\n"); - -to verify how your CLI passes the arguments to the program. - -=head2 Undefined subroutine &main::GetOptions called - -Are you running Windows, and did you write - - use GetOpt::Long; - -(note the capital 'O')? - -=head2 How do I put a "-?" option into a Getopt::Long? - -You can only obtain this using an alias, and Getopt::Long of at least -version 2.13. - - use Getopt::Long; - GetOptions ("help|?"); # -help and -? will both set $opt_help - -=head1 AUTHOR - -Johan Vromans <jvromans@squirrel.nl> - -=head1 COPYRIGHT AND DISCLAIMER - -This program is Copyright 1990,2005 by Johan Vromans. -This program is free software; you can redistribute it and/or -modify it under the terms of the Perl Artistic License or the -GNU General Public License as published by the Free Software -Foundation; either version 2 of the License, or (at your option) any -later version. - -This program is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -If you do not have a copy of the GNU General Public License write to -the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, -MA 02139, USA. - -=cut - diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/List/Util.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/List/Util.pm deleted file mode 100644 index cfe31f70123..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/List/Util.pm +++ /dev/null @@ -1,277 +0,0 @@ -# List::Util.pm -# -# Copyright (c) 1997-2005 Graham Barr <gbarr@pobox.com>. All rights reserved. -# This program is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. - -package List::Util; - -use strict; -use vars qw(@ISA @EXPORT_OK $VERSION $XS_VERSION $TESTING_PERL_ONLY); -require Exporter; - -@ISA = qw(Exporter); -@EXPORT_OK = qw(first min max minstr maxstr reduce sum shuffle); -$VERSION = "1.18"; -$XS_VERSION = $VERSION; -$VERSION = eval $VERSION; - -eval { - # PERL_DL_NONLAZY must be false, or any errors in loading will just - # cause the perl code to be tested - local $ENV{PERL_DL_NONLAZY} = 0 if $ENV{PERL_DL_NONLAZY}; - eval { - require XSLoader; - XSLoader::load('List::Util', $XS_VERSION); - 1; - } or do { - require DynaLoader; - local @ISA = qw(DynaLoader); - bootstrap List::Util $XS_VERSION; - }; -} unless $TESTING_PERL_ONLY; - - -# This code is only compiled if the XS did not load -# of for perl < 5.6.0 - -if (!defined &reduce) { -eval <<'ESQ' - -sub reduce (&@) { - my $code = shift; - no strict 'refs'; - - return shift unless @_ > 1; - - use vars qw($a $b); - - my $caller = caller; - local(*{$caller."::a"}) = \my $a; - local(*{$caller."::b"}) = \my $b; - - $a = shift; - foreach (@_) { - $b = $_; - $a = &{$code}(); - } - - $a; -} - -sub first (&@) { - my $code = shift; - - foreach (@_) { - return $_ if &{$code}(); - } - - undef; -} - -ESQ -} - -# This code is only compiled if the XS did not load -eval <<'ESQ' if !defined ∑ - -use vars qw($a $b); - -sub sum (@) { reduce { $a + $b } @_ } - -sub min (@) { reduce { $a < $b ? $a : $b } @_ } - -sub max (@) { reduce { $a > $b ? $a : $b } @_ } - -sub minstr (@) { reduce { $a lt $b ? $a : $b } @_ } - -sub maxstr (@) { reduce { $a gt $b ? $a : $b } @_ } - -sub shuffle (@) { - my @a=\(@_); - my $n; - my $i=@_; - map { - $n = rand($i--); - (${$a[$n]}, $a[$n] = $a[$i])[0]; - } @_; -} - -ESQ - -1; - -__END__ - -=head1 NAME - -List::Util - A selection of general-utility list subroutines - -=head1 SYNOPSIS - - use List::Util qw(first max maxstr min minstr reduce shuffle sum); - -=head1 DESCRIPTION - -C<List::Util> contains a selection of subroutines that people have -expressed would be nice to have in the perl core, but the usage would -not really be high enough to warrant the use of a keyword, and the size -so small such that being individual extensions would be wasteful. - -By default C<List::Util> does not export any subroutines. The -subroutines defined are - -=over 4 - -=item first BLOCK LIST - -Similar to C<grep> in that it evaluates BLOCK setting C<$_> to each element -of LIST in turn. C<first> returns the first element where the result from -BLOCK is a true value. If BLOCK never returns true or LIST was empty then -C<undef> is returned. - - $foo = first { defined($_) } @list # first defined value in @list - $foo = first { $_ > $value } @list # first value in @list which - # is greater than $value - -This function could be implemented using C<reduce> like this - - $foo = reduce { defined($a) ? $a : wanted($b) ? $b : undef } undef, @list - -for example wanted() could be defined() which would return the first -defined value in @list - -=item max LIST - -Returns the entry in the list with the highest numerical value. If the -list is empty then C<undef> is returned. - - $foo = max 1..10 # 10 - $foo = max 3,9,12 # 12 - $foo = max @bar, @baz # whatever - -This function could be implemented using C<reduce> like this - - $foo = reduce { $a > $b ? $a : $b } 1..10 - -=item maxstr LIST - -Similar to C<max>, but treats all the entries in the list as strings -and returns the highest string as defined by the C<gt> operator. -If the list is empty then C<undef> is returned. - - $foo = maxstr 'A'..'Z' # 'Z' - $foo = maxstr "hello","world" # "world" - $foo = maxstr @bar, @baz # whatever - -This function could be implemented using C<reduce> like this - - $foo = reduce { $a gt $b ? $a : $b } 'A'..'Z' - -=item min LIST - -Similar to C<max> but returns the entry in the list with the lowest -numerical value. If the list is empty then C<undef> is returned. - - $foo = min 1..10 # 1 - $foo = min 3,9,12 # 3 - $foo = min @bar, @baz # whatever - -This function could be implemented using C<reduce> like this - - $foo = reduce { $a < $b ? $a : $b } 1..10 - -=item minstr LIST - -Similar to C<min>, but treats all the entries in the list as strings -and returns the lowest string as defined by the C<lt> operator. -If the list is empty then C<undef> is returned. - - $foo = minstr 'A'..'Z' # 'A' - $foo = minstr "hello","world" # "hello" - $foo = minstr @bar, @baz # whatever - -This function could be implemented using C<reduce> like this - - $foo = reduce { $a lt $b ? $a : $b } 'A'..'Z' - -=item reduce BLOCK LIST - -Reduces LIST by calling BLOCK multiple times, setting C<$a> and C<$b> -each time. The first call will be with C<$a> and C<$b> set to the first -two elements of the list, subsequent calls will be done by -setting C<$a> to the result of the previous call and C<$b> to the next -element in the list. - -Returns the result of the last call to BLOCK. If LIST is empty then -C<undef> is returned. If LIST only contains one element then that -element is returned and BLOCK is not executed. - - $foo = reduce { $a < $b ? $a : $b } 1..10 # min - $foo = reduce { $a lt $b ? $a : $b } 'aa'..'zz' # minstr - $foo = reduce { $a + $b } 1 .. 10 # sum - $foo = reduce { $a . $b } @bar # concat - -=item shuffle LIST - -Returns the elements of LIST in a random order - - @cards = shuffle 0..51 # 0..51 in a random order - -=item sum LIST - -Returns the sum of all the elements in LIST. If LIST is empty then -C<undef> is returned. - - $foo = sum 1..10 # 55 - $foo = sum 3,9,12 # 24 - $foo = sum @bar, @baz # whatever - -This function could be implemented using C<reduce> like this - - $foo = reduce { $a + $b } 1..10 - -=back - -=head1 KNOWN BUGS - -With perl versions prior to 5.005 there are some cases where reduce -will return an incorrect result. This will show up as test 7 of -reduce.t failing. - -=head1 SUGGESTED ADDITIONS - -The following are additions that have been requested, but I have been reluctant -to add due to them being very simple to implement in perl - - # One argument is true - - sub any { $_ && return 1 for @_; 0 } - - # All arguments are true - - sub all { $_ || return 0 for @_; 1 } - - # All arguments are false - - sub none { $_ && return 0 for @_; 1 } - - # One argument is false - - sub notall { $_ || return 1 for @_; 0 } - - # How many elements are true - - sub true { scalar grep { $_ } @_ } - - # How many elements are false - - sub false { scalar grep { !$_ } @_ } - -=head1 COPYRIGHT - -Copyright (c) 1997-2005 Graham Barr <gbarr@pobox.com>. All rights reserved. -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -=cut diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Scalar/Util.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Scalar/Util.pm deleted file mode 100644 index 4ae525a17c0..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/Scalar/Util.pm +++ /dev/null @@ -1,147 +0,0 @@ -# Scalar::Util.pm -# -# Copyright (c) 1997-2005 Graham Barr <gbarr@pobox.com>. All rights reserved. -# This program is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. - -package Scalar::Util; - -use strict; -use vars qw(@ISA @EXPORT_OK $VERSION); -require Exporter; -require List::Util; # List::Util loads the XS - -@ISA = qw(Exporter); -@EXPORT_OK = qw(blessed dualvar reftype weaken isweak tainted readonly openhandle refaddr isvstring looks_like_number set_prototype); -$VERSION = "1.18"; -$VERSION = eval $VERSION; - -sub export_fail { - if (grep { /^(weaken|isweak)$/ } @_ ) { - require Carp; - Carp::croak("Weak references are not implemented in the version of perl"); - } - if (grep { /^(isvstring)$/ } @_ ) { - require Carp; - Carp::croak("Vstrings are not implemented in the version of perl"); - } - if (grep { /^(dualvar|set_prototype)$/ } @_ ) { - require Carp; - Carp::croak("$1 is only avaliable with the XS version"); - } - - @_; -} - -sub openhandle ($) { - my $fh = shift; - my $rt = reftype($fh) || ''; - - return defined(fileno($fh)) ? $fh : undef - if $rt eq 'IO'; - - if (reftype(\$fh) eq 'GLOB') { # handle openhandle(*DATA) - $fh = \(my $tmp=$fh); - } - elsif ($rt ne 'GLOB') { - return undef; - } - - (tied(*$fh) or defined(fileno($fh))) - ? $fh : undef; -} - -eval <<'ESQ' unless defined &dualvar; - -use vars qw(@EXPORT_FAIL); -push @EXPORT_FAIL, qw(weaken isweak dualvar isvstring set_prototype); - -# The code beyond here is only used if the XS is not installed - -# Hope nobody defines a sub by this name -sub UNIVERSAL::a_sub_not_likely_to_be_here { ref($_[0]) } - -sub blessed ($) { - local($@, $SIG{__DIE__}, $SIG{__WARN__}); - length(ref($_[0])) - ? eval { $_[0]->a_sub_not_likely_to_be_here } - : undef -} - -sub refaddr($) { - my $pkg = ref($_[0]) or return undef; - if (blessed($_[0])) { - bless $_[0], 'Scalar::Util::Fake'; - } - else { - $pkg = undef; - } - "$_[0]" =~ /0x(\w+)/; - my $i = do { local $^W; hex $1 }; - bless $_[0], $pkg if defined $pkg; - $i; -} - -sub reftype ($) { - local($@, $SIG{__DIE__}, $SIG{__WARN__}); - my $r = shift; - my $t; - - length($t = ref($r)) or return undef; - - # This eval will fail if the reference is not blessed - eval { $r->a_sub_not_likely_to_be_here; 1 } - ? do { - $t = eval { - # we have a GLOB or an IO. Stringify a GLOB gives it's name - my $q = *$r; - $q =~ /^\*/ ? "GLOB" : "IO"; - } - or do { - # OK, if we don't have a GLOB what parts of - # a glob will it populate. - # NOTE: A glob always has a SCALAR - local *glob = $r; - defined *glob{ARRAY} && "ARRAY" - or defined *glob{HASH} && "HASH" - or defined *glob{CODE} && "CODE" - or length(ref(${$r})) ? "REF" : "SCALAR"; - } - } - : $t -} - -sub tainted { - local($@, $SIG{__DIE__}, $SIG{__WARN__}); - local $^W = 0; - eval { kill 0 * $_[0] }; - $@ =~ /^Insecure/; -} - -sub readonly { - return 0 if tied($_[0]) || (ref(\($_[0])) ne "SCALAR"); - - local($@, $SIG{__DIE__}, $SIG{__WARN__}); - my $tmp = $_[0]; - - !eval { $_[0] = $tmp; 1 }; -} - -sub looks_like_number { - local $_ = shift; - - # checks from perlfaq4 - return 0 if !defined($_) or ref($_); - return 1 if (/^[+-]?\d+$/); # is a +/- integer - return 1 if (/^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/); # a C float - return 1 if ($] >= 5.008 and /^(Inf(inity)?|NaN)$/i) or ($] >= 5.006001 and /^Inf$/i); - - 0; -} - -ESQ - -1; - -__END__ - diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Symbol.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Symbol.pm deleted file mode 100644 index 3bb5d9240c1..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/Symbol.pm +++ /dev/null @@ -1,170 +0,0 @@ -package Symbol; - -=head1 NAME - -Symbol - manipulate Perl symbols and their names - -=head1 SYNOPSIS - - use Symbol; - - $sym = gensym; - open($sym, "filename"); - $_ = <$sym>; - # etc. - - ungensym $sym; # no effect - - # replace *FOO{IO} handle but not $FOO, %FOO, etc. - *FOO = geniosym; - - print qualify("x"), "\n"; # "Test::x" - print qualify("x", "FOO"), "\n" # "FOO::x" - print qualify("BAR::x"), "\n"; # "BAR::x" - print qualify("BAR::x", "FOO"), "\n"; # "BAR::x" - print qualify("STDOUT", "FOO"), "\n"; # "main::STDOUT" (global) - print qualify(\*x), "\n"; # returns \*x - print qualify(\*x, "FOO"), "\n"; # returns \*x - - use strict refs; - print { qualify_to_ref $fh } "foo!\n"; - $ref = qualify_to_ref $name, $pkg; - - use Symbol qw(delete_package); - delete_package('Foo::Bar'); - print "deleted\n" unless exists $Foo::{'Bar::'}; - -=head1 DESCRIPTION - -C<Symbol::gensym> creates an anonymous glob and returns a reference -to it. Such a glob reference can be used as a file or directory -handle. - -For backward compatibility with older implementations that didn't -support anonymous globs, C<Symbol::ungensym> is also provided. -But it doesn't do anything. - -C<Symbol::geniosym> creates an anonymous IO handle. This can be -assigned into an existing glob without affecting the non-IO portions -of the glob. - -C<Symbol::qualify> turns unqualified symbol names into qualified -variable names (e.g. "myvar" -E<gt> "MyPackage::myvar"). If it is given a -second parameter, C<qualify> uses it as the default package; -otherwise, it uses the package of its caller. Regardless, global -variable names (e.g. "STDOUT", "ENV", "SIG") are always qualified with -"main::". - -Qualification applies only to symbol names (strings). References are -left unchanged under the assumption that they are glob references, -which are qualified by their nature. - -C<Symbol::qualify_to_ref> is just like C<Symbol::qualify> except that it -returns a glob ref rather than a symbol name, so you can use the result -even if C<use strict 'refs'> is in effect. - -C<Symbol::delete_package> wipes out a whole package namespace. Note -this routine is not exported by default--you may want to import it -explicitly. - -=head1 BUGS - -C<Symbol::delete_package> is a bit too powerful. It undefines every symbol that -lives in the specified package. Since perl, for performance reasons, does not -perform a symbol table lookup each time a function is called or a global -variable is accessed, some code that has already been loaded and that makes use -of symbols in package C<Foo> may stop working after you delete C<Foo>, even if -you reload the C<Foo> module afterwards. - -=cut - -BEGIN { require 5.005; } - -require Exporter; -@ISA = qw(Exporter); -@EXPORT = qw(gensym ungensym qualify qualify_to_ref); -@EXPORT_OK = qw(delete_package geniosym); - -$VERSION = '1.06'; - -my $genpkg = "Symbol::"; -my $genseq = 0; - -my %global = map {$_ => 1} qw(ARGV ARGVOUT ENV INC SIG STDERR STDIN STDOUT); - -# -# Note that we never _copy_ the glob; we just make a ref to it. -# If we did copy it, then SVf_FAKE would be set on the copy, and -# glob-specific behaviors (e.g. C<*$ref = \&func>) wouldn't work. -# -sub gensym () { - my $name = "GEN" . $genseq++; - my $ref = \*{$genpkg . $name}; - delete $$genpkg{$name}; - $ref; -} - -sub geniosym () { - my $sym = gensym(); - # force the IO slot to be filled - select(select $sym); - *$sym{IO}; -} - -sub ungensym ($) {} - -sub qualify ($;$) { - my ($name) = @_; - if (!ref($name) && index($name, '::') == -1 && index($name, "'") == -1) { - my $pkg; - # Global names: special character, "^xyz", or other. - if ($name =~ /^(([^a-z])|(\^[a-z_]+))\z/i || $global{$name}) { - # RGS 2001-11-05 : translate leading ^X to control-char - $name =~ s/^\^([a-z_])/'qq(\c'.$1.')'/eei; - $pkg = "main"; - } - else { - $pkg = (@_ > 1) ? $_[1] : caller; - } - $name = $pkg . "::" . $name; - } - $name; -} - -sub qualify_to_ref ($;$) { - return \*{ qualify $_[0], @_ > 1 ? $_[1] : caller }; -} - -# -# of Safe.pm lineage -# -sub delete_package ($) { - my $pkg = shift; - - # expand to full symbol table name if needed - - unless ($pkg =~ /^main::.*::$/) { - $pkg = "main$pkg" if $pkg =~ /^::/; - $pkg = "main::$pkg" unless $pkg =~ /^main::/; - $pkg .= '::' unless $pkg =~ /::$/; - } - - my($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/; - my $stem_symtab = *{$stem}{HASH}; - return unless defined $stem_symtab and exists $stem_symtab->{$leaf}; - - - # free all the symbols in the package - - my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH}; - foreach my $name (keys %$leaf_symtab) { - undef *{$pkg . $name}; - } - - # delete the symbol table - - %$leaf_symtab = (); - delete $stem_symtab->{$leaf}; -} - -1; diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tie/Hash.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tie/Hash.pm deleted file mode 100644 index a838915482b..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tie/Hash.pm +++ /dev/null @@ -1,257 +0,0 @@ -package Tie::Hash; - -our $VERSION = '1.02'; - -=head1 NAME - -Tie::Hash, Tie::StdHash, Tie::ExtraHash - base class definitions for tied hashes - -=head1 SYNOPSIS - - package NewHash; - require Tie::Hash; - - @ISA = (Tie::Hash); - - sub DELETE { ... } # Provides needed method - sub CLEAR { ... } # Overrides inherited method - - - package NewStdHash; - require Tie::Hash; - - @ISA = (Tie::StdHash); - - # All methods provided by default, define only those needing overrides - # Accessors access the storage in %{$_[0]}; - # TIEHASH should return a reference to the actual storage - sub DELETE { ... } - - package NewExtraHash; - require Tie::Hash; - - @ISA = (Tie::ExtraHash); - - # All methods provided by default, define only those needing overrides - # Accessors access the storage in %{$_[0][0]}; - # TIEHASH should return an array reference with the first element being - # the reference to the actual storage - sub DELETE { - $_[0][1]->('del', $_[0][0], $_[1]); # Call the report writer - delete $_[0][0]->{$_[1]}; # $_[0]->SUPER::DELETE($_[1]) - } - - - package main; - - tie %new_hash, 'NewHash'; - tie %new_std_hash, 'NewStdHash'; - tie %new_extra_hash, 'NewExtraHash', - sub {warn "Doing \U$_[1]\E of $_[2].\n"}; - -=head1 DESCRIPTION - -This module provides some skeletal methods for hash-tying classes. See -L<perltie> for a list of the functions required in order to tie a hash -to a package. The basic B<Tie::Hash> package provides a C<new> method, as well -as methods C<TIEHASH>, C<EXISTS> and C<CLEAR>. The B<Tie::StdHash> and -B<Tie::ExtraHash> packages -provide most methods for hashes described in L<perltie> (the exceptions -are C<UNTIE> and C<DESTROY>). They cause tied hashes to behave exactly like standard hashes, -and allow for selective overwriting of methods. B<Tie::Hash> grandfathers the -C<new> method: it is used if C<TIEHASH> is not defined -in the case a class forgets to include a C<TIEHASH> method. - -For developers wishing to write their own tied hashes, the required methods -are briefly defined below. See the L<perltie> section for more detailed -descriptive, as well as example code: - -=over 4 - -=item TIEHASH classname, LIST - -The method invoked by the command C<tie %hash, classname>. Associates a new -hash instance with the specified class. C<LIST> would represent additional -arguments (along the lines of L<AnyDBM_File> and compatriots) needed to -complete the association. - -=item STORE this, key, value - -Store datum I<value> into I<key> for the tied hash I<this>. - -=item FETCH this, key - -Retrieve the datum in I<key> for the tied hash I<this>. - -=item FIRSTKEY this - -Return the first key in the hash. - -=item NEXTKEY this, lastkey - -Return the next key in the hash. - -=item EXISTS this, key - -Verify that I<key> exists with the tied hash I<this>. - -The B<Tie::Hash> implementation is a stub that simply croaks. - -=item DELETE this, key - -Delete the key I<key> from the tied hash I<this>. - -=item CLEAR this - -Clear all values from the tied hash I<this>. - -=item SCALAR this - -Returns what evaluating the hash in scalar context yields. - -B<Tie::Hash> does not implement this method (but B<Tie::StdHash> -and B<Tie::ExtraHash> do). - -=back - -=head1 Inheriting from B<Tie::StdHash> - -The accessor methods assume that the actual storage for the data in the tied -hash is in the hash referenced by C<tied(%tiedhash)>. Thus overwritten -C<TIEHASH> method should return a hash reference, and the remaining methods -should operate on the hash referenced by the first argument: - - package ReportHash; - our @ISA = 'Tie::StdHash'; - - sub TIEHASH { - my $storage = bless {}, shift; - warn "New ReportHash created, stored in $storage.\n"; - $storage - } - sub STORE { - warn "Storing data with key $_[1] at $_[0].\n"; - $_[0]{$_[1]} = $_[2] - } - - -=head1 Inheriting from B<Tie::ExtraHash> - -The accessor methods assume that the actual storage for the data in the tied -hash is in the hash referenced by C<(tied(%tiedhash))-E<gt>[0]>. Thus overwritten -C<TIEHASH> method should return an array reference with the first -element being a hash reference, and the remaining methods should operate on the -hash C<< %{ $_[0]->[0] } >>: - - package ReportHash; - our @ISA = 'Tie::ExtraHash'; - - sub TIEHASH { - my $class = shift; - my $storage = bless [{}, @_], $class; - warn "New ReportHash created, stored in $storage.\n"; - $storage; - } - sub STORE { - warn "Storing data with key $_[1] at $_[0].\n"; - $_[0][0]{$_[1]} = $_[2] - } - -The default C<TIEHASH> method stores "extra" arguments to tie() starting -from offset 1 in the array referenced by C<tied(%tiedhash)>; this is the -same storage algorithm as in TIEHASH subroutine above. Hence, a typical -package inheriting from B<Tie::ExtraHash> does not need to overwrite this -method. - -=head1 C<SCALAR>, C<UNTIE> and C<DESTROY> - -The methods C<UNTIE> and C<DESTROY> are not defined in B<Tie::Hash>, -B<Tie::StdHash>, or B<Tie::ExtraHash>. Tied hashes do not require -presence of these methods, but if defined, the methods will be called in -proper time, see L<perltie>. - -C<SCALAR> is only defined in B<Tie::StdHash> and B<Tie::ExtraHash>. - -If needed, these methods should be defined by the package inheriting from -B<Tie::Hash>, B<Tie::StdHash>, or B<Tie::ExtraHash>. See L<pertie/"SCALAR"> -to find out what happens when C<SCALAR> does not exist. - -=head1 MORE INFORMATION - -The packages relating to various DBM-related implementations (F<DB_File>, -F<NDBM_File>, etc.) show examples of general tied hashes, as does the -L<Config> module. While these do not utilize B<Tie::Hash>, they serve as -good working examples. - -=cut - -use Carp; -use warnings::register; - -sub new { - my $pkg = shift; - $pkg->TIEHASH(@_); -} - -# Grandfather "new" - -sub TIEHASH { - my $pkg = shift; - if (defined &{"${pkg}::new"}) { - warnings::warnif("WARNING: calling ${pkg}->new since ${pkg}->TIEHASH is missing"); - $pkg->new(@_); - } - else { - croak "$pkg doesn't define a TIEHASH method"; - } -} - -sub EXISTS { - my $pkg = ref $_[0]; - croak "$pkg doesn't define an EXISTS method"; -} - -sub CLEAR { - my $self = shift; - my $key = $self->FIRSTKEY(@_); - my @keys; - - while (defined $key) { - push @keys, $key; - $key = $self->NEXTKEY(@_, $key); - } - foreach $key (@keys) { - $self->DELETE(@_, $key); - } -} - -# The Tie::StdHash package implements standard perl hash behaviour. -# It exists to act as a base class for classes which only wish to -# alter some parts of their behaviour. - -package Tie::StdHash; -# @ISA = qw(Tie::Hash); # would inherit new() only - -sub TIEHASH { bless {}, $_[0] } -sub STORE { $_[0]->{$_[1]} = $_[2] } -sub FETCH { $_[0]->{$_[1]} } -sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} } -sub NEXTKEY { each %{$_[0]} } -sub EXISTS { exists $_[0]->{$_[1]} } -sub DELETE { delete $_[0]->{$_[1]} } -sub CLEAR { %{$_[0]} = () } -sub SCALAR { scalar %{$_[0]} } - -package Tie::ExtraHash; - -sub TIEHASH { my $p = shift; bless [{}, @_], $p } -sub STORE { $_[0][0]{$_[1]} = $_[2] } -sub FETCH { $_[0][0]{$_[1]} } -sub FIRSTKEY { my $a = scalar keys %{$_[0][0]}; each %{$_[0][0]} } -sub NEXTKEY { each %{$_[0][0]} } -sub EXISTS { exists $_[0][0]->{$_[1]} } -sub DELETE { delete $_[0][0]->{$_[1]} } -sub CLEAR { %{$_[0][0]} = () } -sub SCALAR { scalar %{$_[0][0]} } - -1; diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk.pm deleted file mode 100644 index deb453172eb..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk.pm +++ /dev/null @@ -1,821 +0,0 @@ -# -# Copyright (c) 1992-1994 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. -# Copyright (c) 1995-2004 Nick Ing-Simmons. All rights reserved. -# This program is free software; you can redistribute it and/or - -# modify it under the same terms as Perl itself, subject -# to additional disclaimer in Tk/license.terms due to partial -# derivation from Tk8.0 sources. -# -package Tk; -require 5.007; -use Tk::Event (); -use AutoLoader qw(AUTOLOAD); -use DynaLoader; -use Cwd(); -use base qw(Exporter DynaLoader); - -*fileevent = \&Tk::Event::IO::fileevent; - -use Encode; -$Tk::encodeStopOnError = Encode::FB_QUIET(); -$Tk::encodeFallback = Encode::FB_PERLQQ(); # Encode::FB_DEFAULT(); - -our %font_encoding = ('jis0208' => 'jis0208-raw', - 'jis0212' => 'jis0212-raw', - 'ksc5601' => 'ksc5601-raw', - 'gb2312' => 'gb2312-raw', - 'unicode' => 'ucs-2le', - ); - -BEGIN { - if($^O eq 'cygwin') - { - require Tk::Config; - $Tk::platform = $Tk::Config::win_arch; - $Tk::platform = 'unix' if $Tk::platform eq 'x'; - } - else - { - $Tk::platform = ($^O eq 'MSWin32') ? $^O : 'unix'; - } -}; - -$Tk::tearoff = 1 if ($Tk::platform eq 'unix'); - - -@EXPORT = qw(Exists Ev exit MainLoop DoOneEvent tkinit); -@EXPORT_OK = qw(NoOp after *widget *event lsearch catch $XS_VERSION - DONT_WAIT WINDOW_EVENTS FILE_EVENTS TIMER_EVENTS - IDLE_EVENTS ALL_EVENTS - NORMAL_BG ACTIVE_BG SELECT_BG - SELECT_FG TROUGH INDICATOR DISABLED BLACK WHITE); -%EXPORT_TAGS = (eventtypes => [qw(DONT_WAIT WINDOW_EVENTS FILE_EVENTS - TIMER_EVENTS IDLE_EVENTS ALL_EVENTS)], - variables => [qw(*widget *event)], - colors => [qw(NORMAL_BG ACTIVE_BG SELECT_BG SELECT_FG - TROUGH INDICATOR DISABLED BLACK WHITE)], - ); - -use strict; -use Carp; - -# Record author's perforce depot record -$Tk::CHANGE = q$Change: 3279 $; - -# $tk_version and $tk_patchLevel are reset by pTk when a mainwindow -# is created, $VERSION is checked by bootstrap -$Tk::version = '8.4'; -$Tk::patchLevel = '8.4'; -$Tk::VERSION = '804.027'; -$Tk::XS_VERSION = $Tk::VERSION; -$Tk::strictMotif = 0; - - -{($Tk::library) = __FILE__ =~ /^(.*)\.pm$/;} -$Tk::library = Tk->findINC('.') unless (defined($Tk::library) && -d $Tk::library); - -$Tk::widget = undef; -$Tk::event = undef; - -use vars qw($inMainLoop); - -bootstrap Tk; - -my $boot_time = timeofday(); - -# This is a workround for Solaris X11 locale handling -Preload(DynaLoader::dl_findfile('-L/usr/openwin/lib','-lX11')) - if (NeedPreload() && -d '/usr/openwin/lib'); - -use Tk::Submethods ('option' => [qw(add get clear readfile)], - 'clipboard' => [qw(clear append)] - ); - -# -# Next few routines are here as perl code as doing caller() -# in XS code is very complicated - so instead C code calls BackTrace -# -sub _backTrace -{ - my $w = shift; - my $i = 1; - my ($pack,$file,$line,$sub) = caller($i++); - while (1) - { - my $loc = "at $file line $line"; - ($pack,$file,$line,$sub) = caller($i++); - last unless defined($sub); - return 1 if $sub eq '(eval)'; - $w->AddErrorInfo("$sub $loc"); - } - return 0; -} - -sub BackTrace -{ - my $w = shift; - return unless (@_ || $@); - my $mess = (@_) ? shift : "$@"; - die "$mess\n" if $w->_backTrace; - # if we get here we are not in an eval so report now - $w->Fail($mess); - $w->idletasks; - die "$mess\n"; -} - -# -# This is a $SIG{__DIE__} handler which does not change the $@ -# string in the way 'croak' does, but rather add to Tk's ErrorInfo. -# It stops at 1st enclosing eval on assumption that the eval -# is part of Tk call process and will add its own context to ErrorInfo -# and then pass on the error. -# -sub __DIE__ -{ - my $mess = shift; - my $w = $Tk::widget; - # Note that if a __DIE__ handler returns it re-dies up the chain. - return unless defined($w) && Exists($w); - # This special message is for exit() as an exception see pTkCallback.c - return if $mess =~/^_TK_EXIT_\(\d+\)/; - return if $w->_backTrace; - # Not in an eval - should not happen -} - -sub XEvent::xy { shift->Info('xy') } - -sub XEvent::AUTOLOAD -{ - my ($meth) = $XEvent::AUTOLOAD =~ /(\w)$/; - no strict 'refs'; - *{$XEvent::AUTOLOAD} = sub { shift->Info($meth) }; - goto &$XEvent::AUTOLOAD; -} - -sub NoOp { } - -sub Ev -{ - if (@_ == 1) - { - my $arg = $_[0]; - return bless (((ref $arg) ? $arg : \$arg), 'Tk::Ev'); - } - else - { - return bless [@_],'Tk::Ev'; - } -} - -sub InitClass -{ - my ($package,$parent) = @_; - croak "Unexpected type of parent $parent" unless(ref $parent); - croak "$parent is not a widget" unless($parent->IsWidget); - my $mw = $parent->MainWindow; - my $hash = $mw->TkHash('_ClassInit_'); - unless (exists $hash->{$package}) - { - $package->Install($mw); - $hash->{$package} = $package->ClassInit($mw); - } -} - -require Tk::Widget; -require Tk::Image; -require Tk::MainWindow; - -sub Exists -{my $w = shift; - return defined($w) && ref($w) && $w->IsWidget && $w->exists; -} - -sub Time_So_Far -{ - return timeofday() - $boot_time; -} - -# Selection* are not autoloaded as names are too long. - -sub SelectionOwn -{my $widget = shift; - selection('own',(@_,$widget)); -} - -sub SelectionOwner -{ - selection('own','-displayof',@_); -} - -sub SelectionClear -{ - selection('clear','-displayof',@_); -} - -sub SelectionExists -{ - selection('exists','-displayof',@_); -} - -sub SelectionHandle -{my $widget = shift; - my $command = pop; - selection('handle',@_,$widget,$command); -} - -sub SplitString -{ - local $_ = shift; - my (@arr, $tmp); - while (/\{([^{}]*)\}|((?:[^\s\\]|\\.)+)/gs) { - if (defined $1) { push @arr, $1 } - else { $tmp = $2 ; $tmp =~ s/\\([\s\\])/$1/g; push @arr, $tmp } - } - # carp '('.join(',',@arr).")"; - return @arr; -} - -sub Methods -{ - my ($package) = caller; - no strict 'refs'; - foreach my $meth (@_) - { - my $name = $meth; - *{$package."::$meth"} = sub { shift->WidgetMethod($name,@_) }; - } -} - -my %dialog = ( tk_chooseColor => 'ColorDialog', - tk_messageBox => 'MessageBox', - tk_getOpenFile => 'FDialog', - tk_getSaveFile => 'FDialog', - tk_chooseDirectory => 'FDialog' -# Slaven claims NI-S's version above does not work -# and provides this -# tk_chooseDirectory => 'DirDialog' - ); - -foreach my $dialog (keys %dialog) - { - no strict 'refs'; - unless (defined &$dialog) - { - my $kind = $dialog; - my $code = \&{"Tk::$dialog{$dialog}"}; - *$dialog = sub { &$code($kind,@_) }; - } - } - -sub MessageBox { - my ($kind,%args) = @_; - require Tk::Dialog; - my $parent = delete $args{'-parent'}; - my $args = \%args; - - $args->{-bitmap} = delete $args->{-icon} if defined $args->{-icon}; - $args->{-text} = delete $args->{-message} if defined $args->{-message}; - $args->{-type} = 'OK' unless defined $args->{-type}; - - my $type; - if (defined($type = delete $args->{-type})) { - delete $args->{-type}; - my @buttons = grep($_,map(ucfirst($_), - split(/(abort|retry|ignore|yes|no|cancel|ok)/, - lc($type)))); - $args->{-buttons} = [@buttons]; - $args->{-default_button} = ucfirst(delete $args->{-default}) if - defined $args->{-default}; - if (not defined $args->{-default_button} and scalar(@buttons) == 1) { - $args->{-default_button} = $buttons[0]; - } - my $md = $parent->Dialog(%$args); - my $an = $md->Show; - $md->destroy; - return $an; - } -} # end messageBox - -sub messageBox -{ - my ($widget,%args) = @_; - # remove in a later version: - if (exists $args{'-text'}) - { - warn "The -text option is deprecated. Please use -message instead"; - if (!exists $args{'-message'}) - { - $args{'-message'} = delete $args{'-text'}; - } - } - $args{'-type'} = (exists $args{'-type'}) ? lc($args{'-type'}) : 'ok'; - $args{'-default'} = lc($args{'-default'}) if (exists $args{'-default'}); - ucfirst tk_messageBox(-parent => $widget, %args); -} - -sub getOpenFile -{ - tk_getOpenFile(-parent => shift,@_); -} - -sub getSaveFile -{ - tk_getSaveFile(-parent => shift,@_); -} - -sub chooseColor -{ - tk_chooseColor(-parent => shift,@_); -} - -sub chooseDirectory -{ - tk_chooseDirectory(-parent => shift,@_); -} - -sub DialogWrapper -{ - my ($method,$kind,%args) = @_; - my $created = 0; - my $w = delete $args{'-parent'}; - if (defined $w) - { - $args{'-popover'} = $w; - } - else - { - $w = MainWindow->new; - $w->withdraw; - $created = 1; - } - my $mw = $w->toplevel; - my $fs = $mw->{$kind}; - unless (defined $fs) - { - $mw->{$kind} = $fs = $mw->$method(%args); - } - else - { - $fs->configure(%args); - } - my $val = $fs->Show; - $w->destroy if $created; - return $val; -} - -sub ColorDialog -{ - require Tk::ColorEditor; - DialogWrapper('ColorDialog',@_); -} - -sub FDialog -{ - require Tk::FBox; - my $cmd = shift; - if ($cmd =~ /Save/) - { - push @_, -type => 'save'; - } - elsif ($cmd =~ /Directory/) - { - push @_, -type => 'dir'; - } - DialogWrapper('FBox', $cmd, @_); -} - -sub DirDialog -{ - require Tk::DirTree; - DialogWrapper('DirTreeDialog',@_); -} - -*MotifFDialog = \&FDialog; - -*CORE::GLOBAL::exit = \&exit; - -sub MainLoop -{ - unless ($inMainLoop) - { - local $inMainLoop = 1; - while (Tk::MainWindow->Count) - { - DoOneEvent(0); - } - } -} - -sub tkinit { return MainWindow->new(@_) } - -# a wrapper on eval which turns off user $SIG{__DIE__} -sub catch (&) -{ - my $sub = shift; - eval {local $SIG{'__DIE__'}; &$sub }; -} - -my $Home; - -sub TranslateFileName -{ - local $_ = shift; - unless (defined $Home) - { - $Home = $ENV{'HOME'} || (defined $ENV{'HOMEDRIVE'} && defined $ENV{'HOMEPATH'} ? $ENV{'HOMEDRIVE'}.$ENV{'HOMEPATH'} : ""); - $Home =~ s#\\#/#g; - $Home .= '/' unless $Home =~ m#/$#; - } - s#~/#$Home#g; - # warn $_; - return $_; -} - -sub findINC -{ - my $file = join('/',@_); - my $dir; - $file =~ s,::,/,g; - foreach $dir (@INC) - { - my $path; - return $path if (-e ($path = "$dir/$file")); - } - return undef; -} - -sub idletasks -{ - shift->update('idletasks'); -} - -sub backtrace -{ - my ($self,$msg,$i) = @_; - $i = 1 if @_ < 3; - while (1) - { - my ($pack,$file,$line,$sub) = caller($i++); - last unless defined($sub); - $msg .= "\n $sub at $file line $line"; - } - return "$msg\n"; -} - -sub die_with_trace -{ - my ($self,$msg) = @_; - die $self->backtrace($msg,1); -} - - - -1; - -__END__ - -sub Error -{my $w = shift; - my $error = shift; - if (Exists($w)) - { - my $grab = $w->grab('current'); - $grab->Unbusy if (defined $grab); - } - chomp($error); - warn "Tk::Error: $error\n " . join("\n ",@_)."\n"; -} - -sub CancelRepeat -{ - my $w = shift->MainWindow; - my $id = delete $w->{_afterId_}; - $w->after('cancel',$id) if (defined $id); -} - -sub RepeatId -{ - my ($w,$id) = @_; - $w = $w->MainWindow; - $w->CancelRepeat; - $w->{_afterId_} = $id; -} - - - -#---------------------------------------------------------------------------- -# focus.tcl -- -# -# This file defines several procedures for managing the input -# focus. -# -# @(#) focus.tcl 1.6 94/12/19 17:06:46 -# -# Copyright (c) 1994 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. - -sub FocusChildren { shift->children } - -# -# focusNext -- -# This procedure is invoked to move the input focus to the next window -# after a given one. "Next" is defined in terms of the window -# stacking order, with all the windows underneath a given top-level -# (no matter how deeply nested in the hierarchy) considered except -# for frames and toplevels. -# -# Arguments: -# w - Name of a window: the procedure will set the focus -# to the next window after this one in the traversal -# order. -sub focusNext -{ - my $w = shift; - my $cur = $w; - while (1) - { - # Descend to just before the first child of the current widget. - my $parent = $cur; - my @children = $cur->FocusChildren(); - my $i = -1; - # Look for the next sibling that isn't a top-level. - while (1) - { - $i += 1; - if ($i < @children) - { - $cur = $children[$i]; - next if ($cur->toplevel == $cur); - last - } - # No more siblings, so go to the current widget's parent. - # If it's a top-level, break out of the loop, otherwise - # look for its next sibling. - $cur = $parent; - last if ($cur->toplevel() == $cur); - $parent = $parent->parent(); - @children = $parent->FocusChildren(); - $i = lsearch(\@children,$cur); - } - if ($cur == $w || $cur->FocusOK) - { - $cur->tabFocus; - return; - } - } -} -# focusPrev -- -# This procedure is invoked to move the input focus to the previous -# window before a given one. "Previous" is defined in terms of the -# window stacking order, with all the windows underneath a given -# top-level (no matter how deeply nested in the hierarchy) considered. -# -# Arguments: -# w - Name of a window: the procedure will set the focus -# to the previous window before this one in the traversal -# order. -sub focusPrev -{ - my $w = shift; - my $cur = $w; - my @children; - my $i; - my $parent; - while (1) - { - # Collect information about the current window's position - # among its siblings. Also, if the window is a top-level, - # then reposition to just after the last child of the window. - if ($cur->toplevel() == $cur) - { - $parent = $cur; - @children = $cur->FocusChildren(); - $i = @children; - } - else - { - $parent = $cur->parent(); - @children = $parent->FocusChildren(); - $i = lsearch(\@children,$cur); - } - # Go to the previous sibling, then descend to its last descendant - # (highest in stacking order. While doing this, ignore top-levels - # and their descendants. When we run out of descendants, go up - # one level to the parent. - while ($i > 0) - { - $i--; - $cur = $children[$i]; - next if ($cur->toplevel() == $cur); - $parent = $cur; - @children = $parent->FocusChildren(); - $i = @children; - } - $cur = $parent; - if ($cur == $w || $cur->FocusOK) - { - $cur->tabFocus; - return; - } - } - -} - -sub FocusOK -{ - my $w = shift; - my $value; - catch { $value = $w->cget('-takefocus') }; - if (!$@ && defined($value)) - { - return 0 if ($value eq '0'); - return $w->viewable if ($value eq '1'); - if ($value) - { - $value = $w->$value(); - return $value if (defined $value); - } - } - if (!$w->viewable) - { - return 0; - } - catch { $value = $w->cget('-state') } ; - if (!$@ && defined($value) && $value eq 'disabled') - { - return 0; - } - $value = grep(/Key|Focus/,$w->Tk::bind(),$w->Tk::bind(ref($w))); - return $value; -} - - -# focusFollowsMouse -# -# If this procedure is invoked, Tk will enter "focus-follows-mouse" -# mode, where the focus is always on whatever window contains the -# mouse. If this procedure isn't invoked, then the user typically -# has to click on a window to give it the focus. -# -# Arguments: -# None. - -sub EnterFocus -{ - my $w = shift; - return unless $w; - my $Ev = $w->XEvent; - my $d = $Ev->d; - $w->Tk::focus() if ($d eq 'NotifyAncestor' || $d eq 'NotifyNonlinear' || $d eq 'NotifyInferior'); -} - -sub tabFocus -{ - shift->Tk::focus; -} - -sub focusFollowsMouse -{ - my $widget = shift; - $widget->bind('all','<Enter>','EnterFocus'); -} - -# tkTraverseToMenu -- -# This procedure implements keyboard traversal of menus. Given an -# ASCII character "char", it looks for a menubutton with that character -# underlined. If one is found, it posts the menubutton's menu -# -# Arguments: -# w - Window in which the key was typed (selects -# a toplevel window). -# char - Character that selects a menu. The case -# is ignored. If an empty string, nothing -# happens. -sub TraverseToMenu -{ - my $w = shift; - my $char = shift; - return unless(defined $char && $char ne ''); - $w = $w->toplevel->FindMenu($char); -} -# tkFirstMenu -- -# This procedure traverses to the first menubutton in the toplevel -# for a given window, and posts that menubutton's menu. -# -# Arguments: -# w - Name of a window. Selects which toplevel -# to search for menubuttons. -sub FirstMenu -{ - my $w = shift; - $w = $w->toplevel->FindMenu(''); -} - -# These wrappers don't use method syntax so need to live -# in same package as raw Tk routines are newXS'ed into. - -sub Selection -{my $widget = shift; - my $cmd = shift; - croak 'Use SelectionOwn/SelectionOwner' if ($cmd eq 'own'); - croak "Use Selection\u$cmd()"; -} - -# If we have sub Clipboard in Tk then use base qw(Tk::Clipboard ....) -# calls it when it does its eval "require $base" -#sub Clipboard -#{my $w = shift; -# my $cmd = shift; -# croak "Use clipboard\u$cmd()"; -#} - -sub Receive -{ - my $w = shift; - warn 'Receive(' . join(',',@_) .')'; - die 'Tk rejects send(' . join(',',@_) .")\n"; -} - -sub break -{ - die "_TK_BREAK_\n"; -} - -sub updateWidgets -{ - my ($w) = @_; - while ($w->DoOneEvent(DONT_WAIT|IDLE_EVENTS|WINDOW_EVENTS)) - { - } - $w; -} - -sub ImageNames -{ - image('names'); -} - -sub ImageTypes -{ - image('types'); -} - -sub interps -{ - my $w = shift; - return $w->winfo('interps','-displayof'); -} - -sub lsearch -{my $ar = shift; - my $x = shift; - my $i; - for ($i = 0; $i < scalar @$ar; $i++) - { - return $i if ($$ar[$i] eq $x); - } - return -1; -} - - -sub getEncoding -{ - my ($class,$name) = @_; - eval { require Encode }; - if ($@) - { - require Tk::DummyEncode; - return Tk::DummyEncode->getEncoding($name); - } - $name = $Tk::font_encoding{$name} if exists $Tk::font_encoding{$name}; - my $enc = Encode::find_encoding($name); - - unless ($enc) - { - $enc = Encode::find_encoding($name) if ($name =~ s/[-_]\d+$//) - } -# if ($enc) -# { -# print STDERR "Lookup '$name' => ".$enc->name."\n"; -# } -# else -# { -# print STDERR "Failed '$name'\n"; -# } - unless ($enc) - { - if ($name eq 'X11ControlChars') - { - require Tk::DummyEncode; - $Encode::encoding{$name} = $enc = Tk::DummyEncode->getEncoding($name); - } - } - return $enc; -} - - - diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/After.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/After.pm deleted file mode 100644 index 85a0e406ee5..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/After.pm +++ /dev/null @@ -1,104 +0,0 @@ -# Copyright (c) 1995-2004 Nick Ing-Simmons. All rights reserved. -# This program is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. -package Tk::After; -use Carp; - -use vars qw($VERSION); -$VERSION = '4.007'; # $Id: //depot/Tkutf8/Tk/After.pm#11 $ - -sub _cancelAll -{ - my $w = shift; - my $h = delete $w->{_After_}; - foreach my $obj (values %$h) - { - # carp "Auto cancel ".$obj->[1]." for ".$obj->[0]->PathName; - $obj->cancel; - bless $obj,"Tk::After::Cancelled"; - } -} - -sub Tk::After::Cancelled::once { } -sub Tk::After::Cancelled::repeat { } - -sub submit -{ - my $obj = shift; - my $w = $obj->[0]; - my $id = $obj->[1]; - my $t = $obj->[2]; - my $method = $obj->[3]; - delete($w->{_After_}{$id}) if (defined $id); - $id = $w->Tk::after($t,[$method => $obj]); - unless (exists $w->{_After_}) - { - $w->{_After_} = {}; - $w->OnDestroy([\&_cancelAll, $w]); - } - $w->{_After_}{$id} = $obj; - $obj->[1] = $id; - return $obj; -} - -sub DESTROY -{ - my $obj = shift; - $obj->cancel; - undef $obj->[0]; - undef $obj->[4]; -} - -sub new -{ - my ($class,$w,$t,$method,@cb) = @_; - my $cb = (@cb == 1) ? shift(@cb) : [@cb]; - my $obj = bless [$w,undef,$t,$method,Tk::Callback->new($cb)],$class; - return $obj->submit; -} - -sub cancel -{ - my $obj = shift; - my $id = $obj->[1]; - my $w = $obj->[0]; - if ($id) - { - $w->Tk::after('cancel'=> $id) if Tk::Exists($w); - delete $w->{_After_}{$id} if exists $w->{_After_}; - $obj->[1] = undef; - } - return $obj; -} - -sub repeat -{ - my $obj = shift; - $obj->submit; - local $Tk::widget = $obj->[0]; - $obj->[4]->Call; -} - -sub once -{ - my $obj = shift; - my $w = $obj->[0]; - my $id = $obj->[1]; - delete $w->{_After_}{$id}; - local $Tk::widget = $w; - $obj->[4]->Call; -} - -sub time { - my $obj = shift; - my $delay = shift; - if (defined $delay) { - $obj->cancel if $delay == 0; - $obj->[2] = $delay; - } - $obj->[2]; -} - -1; -__END__ - diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Button.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Button.pm deleted file mode 100644 index efa597dee14..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Button.pm +++ /dev/null @@ -1,148 +0,0 @@ -package Tk::Button; -# Conversion from Tk4.0 button.tcl competed. -# -# Copyright (c) 1992-1994 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. -# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved. -# This program is free software; you can redistribute it and/or - -use vars qw($VERSION); -$VERSION = '4.008'; # $Id: //depot/Tkutf8/Tk/Button.pm#8 $ - -# modify it under the same terms as Perl itself, subject -# to additional disclaimer in license.terms due to partial -# derivation from Tk4.0 sources. - -use strict; - -require Tk::Widget; -use base qw(Tk::Widget); - -use vars qw($buttonWindow $relief); - -Tk::Methods('deselect','flash','invoke','select','toggle'); - -sub Tk_cmd { \&Tk::button } - -Construct Tk::Widget 'Button'; - -sub ClassInit -{ - my ($class,$mw) = @_; - $mw->bind($class,'<Enter>', 'Enter'); - $mw->bind($class,'<Leave>', 'Leave'); - $mw->bind($class,'<1>', 'butDown'); - $mw->bind($class,'<ButtonRelease-1>', 'butUp'); - $mw->bind($class,'<space>', 'Invoke'); - $mw->bind($class,'<Return>', 'Invoke'); - return $class; -} - -# tkButtonEnter -- -# The procedure below is invoked when the mouse pointer enters a -# button widget. It records the button we're in and changes the -# state of the button to active unless the button is disabled. -# -# Arguments: -# w - The name of the widget. - -sub Enter -{ - my $w = shift; - my $E = shift; - if ($w->cget('-state') ne 'disabled') - { - $w->configure('-state' => 'active'); - $w->configure('-state' => 'active', '-relief' => 'sunken') if (defined($buttonWindow) && $w == $buttonWindow) - } - $Tk::window = $w; -} - -# tkButtonLeave -- -# The procedure below is invoked when the mouse pointer leaves a -# button widget. It changes the state of the button back to -# inactive. If we're leaving the button window with a mouse button -# pressed (tkPriv(buttonWindow) == $w), restore the relief of the -# button too. -# -# Arguments: -# w - The name of the widget. -sub Leave -{ - my $w = shift; - $w->configure('-state'=>'normal') if ($w->cget('-state') ne 'disabled'); - $w->configure('-relief' => $relief) if (defined($buttonWindow) && $w == $buttonWindow); - undef $Tk::window; -} - -# tkButtonDown -- -# The procedure below is invoked when the mouse button is pressed in -# a button widget. It records the fact that the mouse is in the button, -# saves the button's relief so it can be restored later, and changes -# the relief to sunken. -# -# Arguments: -# w - The name of the widget. -sub butDown -{ - my $w = shift; - $relief = $w->cget('-relief'); - if ($w->cget('-state') ne 'disabled') - { - $buttonWindow = $w; - $w->configure('-relief' => 'sunken') - } -} - -# tkButtonUp -- -# The procedure below is invoked when the mouse button is released -# in a button widget. It restores the button's relief and invokes -# the command as long as the mouse hasn't left the button. -# -# Arguments: -# w - The name of the widget. -sub butUp -{ - my $w = shift; - if (defined($buttonWindow) && $buttonWindow == $w) - { - undef $buttonWindow; - $w->configure('-relief' => $relief); - if ($w->IS($Tk::window) && $w->cget('-state') ne 'disabled') - { - $w->invoke; - } - } -} - -# tkButtonInvoke -- -# The procedure below is called when a button is invoked through -# the keyboard. It simulate a press of the button via the mouse. -# -# Arguments: -# w - The name of the widget. -sub Invoke -{ - my $w = shift; - if ($w->cget('-state') ne 'disabled') - { - my $oldRelief = $w->cget('-relief'); - my $oldState = $w->cget('-state'); - $w->configure('-state' => 'active', '-relief' => 'sunken'); - $w->idletasks; - $w->after(100); - $w->configure('-state' => $oldState, '-relief' => $oldRelief); - $w->invoke; - } -} - - - -1; - -__END__ - - - - - diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Checkbutton.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Checkbutton.pm deleted file mode 100644 index 491d8cd2444..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Checkbutton.pm +++ /dev/null @@ -1,42 +0,0 @@ -package Tk::Checkbutton; -# Conversion from Tk4.0 button.tcl competed. -# Copyright (c) 1992-1994 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. -# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved. -# This program is free software; you can redistribute it and/or - - -use vars qw($VERSION); -$VERSION = '4.006'; # $Id: //depot/Tkutf8/Tk/Checkbutton.pm#6 $ - -# modify it under the same terms as Perl itself, subject -# to additional disclaimer in license.terms due to partial -# derivation from Tk4.0 sources. - -require Tk::Widget; -require Tk::Button; - -use base qw(Tk::Button); - -Construct Tk::Widget 'Checkbutton'; - -sub Tk_cmd { \&Tk::checkbutton } - - -sub ClassInit -{ - my ($class,$mw) = @_; - $mw->bind($class,'<Enter>', 'Enter'); - $mw->bind($class,'<Leave>', 'Leave'); - $mw->bind($class,'<1>', 'Invoke'); - $mw->bind($class,'<space>', 'Invoke'); - return $class; -} - -sub Invoke -{ - my $w = shift; - $w->invoke() unless($w->cget('-state') eq 'disabled'); -} - -1; diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Clipboard.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Clipboard.pm deleted file mode 100644 index b0eb0ea2b07..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Clipboard.pm +++ /dev/null @@ -1,122 +0,0 @@ -# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved. -# This program is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. -package Tk::Clipboard; -use strict; - -use vars qw($VERSION); -$VERSION = sprintf '4.%03d', q$Revision: #8 $ =~ /\D(\d+)\s*$/; - -use AutoLoader qw(AUTOLOAD); -use Tk qw(catch); - -sub clipEvents -{ - return qw[Copy Cut Paste]; -} - -sub ClassInit -{ - my ($class,$mw) = @_; - foreach my $op ($class->clipEvents) - { - $mw->Tk::bind($class,"<<$op>>","clipboard$op"); - } - return $class; -} - -sub clipboardSet -{ - my $w = shift; - $w->clipboardClear; - $w->clipboardAppend(@_); -} - -sub clipboardCopy -{ - my $w = shift; - my $val = $w->getSelected; - if (defined $val) - { - $w->clipboardSet('--',$val); - } - return $val; -} - -sub clipboardCut -{ - my $w = shift; - my $val = $w->clipboardCopy; - if (defined $val) - { - $w->deleteSelected; - } - return $val; -} - -sub clipboardGet -{ - my $w = shift; - $w->SelectionGet('-selection','CLIPBOARD',@_); -} - -sub clipboardPaste -{ - my $w = shift; - local $@; - catch - { -## Different from Tcl/Tk version: -# if ($w->windowingsystem eq 'x11') -# { -# catch -# { -# $w->deleteSelected; -# }; -# } - $w->insert("insert", $w->clipboardGet); - $w->SeeInsert if $w->can('SeeInsert'); - }; -} - -sub clipboardOperations -{ - my @class = (); - my $mw = shift; - if (ref $mw) - { - $mw = $mw->DelegateFor('bind'); - } - else - { - push(@class,$mw); - $mw = shift; - } - while (@_) - { - my $op = shift; - $mw->Tk::bind(@class,"<<$op>>","clipboard$op"); - } -} - -# These methods work for Entry and Text -# and can be overridden where they don't work - -sub deleteSelected -{ - my $w = shift; - catch { $w->delete('sel.first','sel.last') }; -} - - -1; -__END__ - -sub getSelected -{ - my $w = shift; - my $val = Tk::catch { $w->get('sel.first','sel.last') }; - return $val; -} - - diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/CmdLine.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/CmdLine.pm deleted file mode 100644 index 2e821e826ae..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/CmdLine.pm +++ /dev/null @@ -1,954 +0,0 @@ -package Tk::CmdLine; # -*-Perl-*- - -#/----------------------------------------------------------------------------// -#/ Module: Tk/CmdLine.pm -#/ -#/ Purpose: -#/ -#/ Process standard X11 command line options and set initial resources. -#/ -#/ Author: ???? Date: ???? -#/ -#/ History: SEE POD -#/----------------------------------------------------------------------------// - -use vars qw($VERSION); -$VERSION = '4.006'; # $Id: //depot/Tkutf8/Tk/CmdLine.pm#6 $ - -use 5.004; - -use strict; - -use Config; - -my $OBJECT = undef; # define the current object - -#/----------------------------------------------------------------------------// -#/ Constructor -#/ Returns the object reference. -#/----------------------------------------------------------------------------// - -sub new # Tk::CmdLine::new() -{ - my $this = shift(@_); - my $class = ref($this) || $this; - - my $name = 'pTk'; - $name = $1 if (($0 =~ m/(?:^|[\/\\])([\w-]+)(?:\.\w+)?$/) && ($1 ne '-e')); - - my $self = { - name => $name, - config => { -name => $name }, - options => {}, - methods => {}, - command => [], - synchronous => 0, - iconic => 0, - motif => ($Tk::strictMotif || 0), - resources => {} }; - - return bless($self, $class); -} - -#/----------------------------------------------------------------------------// -#/ Process the arguments in a given array or in @ARGV. -#/ Returns the object reference. -#/----------------------------------------------------------------------------// - -sub Argument_ # Tk::CmdLine::Argument_($flag) # private method -{ - my $self = shift(@_); - my $flag = shift(@_); - unless ($self->{offset} < @{$self->{argv}}) - { - die 'Usage: ', $self->{name}, ' ... ', $flag, " <argument> ...\n"; - } - return splice(@{$self->{argv}}, $self->{offset}, 1); -} - -sub Config_ # Tk::CmdLine::Config_($flag, $name) # private method -{ - my $self = shift(@_); - my ($flag, $name) = @_; - my $val = $self->Argument_($flag); - push(@{$self->{command}}, $flag, $val); - $self->{config}->{"-$name"} = $val; -} - -sub Flag_ # Tk::CmdLine::Flag_($flag, $name) # private method -{ - my $self = shift(@_); - my ($flag, $name) = @_; - push(@{$self->{command}}, $flag); - $self->{$name} = 1; -} - -sub Option_ # Tk::CmdLine::Option_($flag, $name) # private method -{ - my $self = shift(@_); - my ($flag, $name) = @_; - my $val = $self->Argument_($flag); - push(@{$self->{command}}, $flag, $val); - $self->{options}->{"*$name"} = $val; -} - -sub Method_ # Tk::CmdLine::Method_($flag, $name) # private method -{ - my $self = shift(@_); - my ($flag, $name) = @_; - my $val = $self->Argument_($flag); - push(@{$self->{command}}, $flag, $val); - $self->{methods}->{$name} = $val; -} - -sub Resource_ # Tk::CmdLine::Resource_($flag, $name) # private method -{ - my $self = shift(@_); - my ($flag, $name) = @_; - my $val = $self->Argument_($flag); - if ($val =~ /^([^!:\s]+)*\s*:\s*(.*)$/) - { - push(@{$self->{command}}, $flag, $val); - $self->{options}->{$1} = $2; - } -} - -my %Method = ( - background => 'Option_', - bg => 'background', # alias - class => 'Config_', - display => 'screen', # alias - fg => 'foreground', # alias - fn => 'font', # alias - font => 'Option_', - foreground => 'Option_', - geometry => 'Method_', - iconic => 'Flag_', - iconposition => 'Method_', - motif => 'Flag_', - name => 'Config_', - screen => 'Config_', - synchronous => 'Flag_', - title => 'Config_', - xrm => 'Resource_' -); - -sub SetArguments # Tk::CmdLine::SetArguments([@argument]) -{ - my $self = (@_ # define the object as necessary - ? ((ref($_[0]) eq __PACKAGE__) - ? shift(@_) - : (($_[0] eq __PACKAGE__) ? shift(@_) : 1) && ($OBJECT ||= __PACKAGE__->new())) - : ($OBJECT ||= __PACKAGE__->new())); - $OBJECT = $self; # update the current object - $self->{argv} = (@_ ? [ @_ ] : \@ARGV); - $self->{offset} = 0; # its existence will denote that this method has been called - - my @option = (); - - while ($self->{offset} < @{$self->{argv}}) - { - last if ($self->{argv}->[$self->{offset}] eq '--'); - unless ( - (($self->{argv}->[$self->{offset}] =~ /^-{1,2}(\w+)$/) && (@option = $1)) || - (($self->{argv}->[$self->{offset}] =~ /^--(\w+)=(.*)$/) && (@option = ($1, $2)))) - { - ++$self->{offset}; - next; - } - - next if (!exists($Method{$option[0]}) && ++$self->{offset}); - - $option[0] = $Method{$option[0]} if exists($Method{$Method{$option[0]}}); - - my $method = $Method{$option[0]}; - - if (@option > 1) # replace --<option>=<value> with <value> - { - $self->{argv}->[$self->{offset}] = $option[1]; - } - else # remove the argument - { - splice(@{$self->{argv}}, $self->{offset}, 1); - } - - $self->$method(('-' . $option[0]), $option[0]); - } - - $self->{config}->{-class} ||= ucfirst($self->{config}->{-name}); - - delete($self->{argv}); # no longer needed - - return $self; -} - -use vars qw(&process); *process = \&SetArguments; # alias to keep old code happy - -#/----------------------------------------------------------------------------// -#/ Get a list of the arguments that have been processed by SetArguments(). -#/ Returns an array. -#/----------------------------------------------------------------------------// - -sub GetArguments # Tk::CmdLine::GetArguments() -{ - my $self = (@_ # define the object as necessary - ? ((ref($_[0]) eq __PACKAGE__) - ? shift(@_) - : (($_[0] eq __PACKAGE__) ? shift(@_) : 1) && ($OBJECT ||= __PACKAGE__->new())) - : ($OBJECT ||= __PACKAGE__->new())); - $OBJECT = $self; # update the current object - - $self->SetArguments() unless exists($self->{offset}); # set arguments if not yet done - - return @{$self->{command}}; -} - -#/----------------------------------------------------------------------------// -#/ Get the value of a configuration option (default: -class). -#/ Returns the option value. -#/----------------------------------------------------------------------------// - -sub cget # Tk::CmdLine::cget([$option]) -{ - my $self = (@_ # define the object as necessary - ? ((ref($_[0]) eq __PACKAGE__) - ? shift(@_) - : (($_[0] eq __PACKAGE__) ? shift(@_) : 1) && ($OBJECT ||= __PACKAGE__->new())) - : ($OBJECT ||= __PACKAGE__->new())); - $OBJECT = $self; # update the current object - my $option = shift(@_) || '-class'; - - $self->SetArguments() unless exists($self->{offset}); # set arguments if not yet done - - return (exists($self->{config}->{$option}) ? $self->{config}->{$option} : undef); -} - -#/----------------------------------------------------------------------------// - -sub CreateArgs # Tk::CmdLine::CreateArgs() -{ - my $self = (@_ # define the object as necessary - ? ((ref($_[0]) eq __PACKAGE__) - ? shift(@_) - : (($_[0] eq __PACKAGE__) ? shift(@_) : 1) && ($OBJECT ||= __PACKAGE__->new())) - : ($OBJECT ||= __PACKAGE__->new())); - $OBJECT = $self; # update the current object - - $self->SetArguments() unless exists($self->{offset}); # set arguments if not yet done - - return $self->{config}; -} - -#/----------------------------------------------------------------------------// - -sub Tk::MainWindow::apply_command_line -{ - my $mw = shift(@_); - - my $self = ($OBJECT ||= __PACKAGE__->new()); - - $self->SetArguments() unless exists($self->{offset}); # set arguments if not yet done - - foreach my $priority (keys(%{$self->{resources}})) - { - foreach my $resource (@{$self->{resources}->{$priority}}) - { - $mw->optionAdd(@{$resource}, $priority); - } - } - - foreach my $key (keys(%{$self->{options}})) - { - $mw->optionAdd($key => $self->{options}->{$key}, 'interactive'); - } - - foreach my $key (keys(%{$self->{methods}})) - { - $mw->$key($self->{methods}->{$key}); - } - - if ($self->{methods}->{geometry}) - { - if ($self->{methods}->{geometry} =~ /[+-]\d+[+-]\d+/) - { - $mw->positionfrom('user'); - } - if ($self->{methods}->{geometry} =~ /\d+x\d+/) - { - $mw->sizefrom('user'); - } - delete $self->{methods}->{geometry}; # XXX needed? - } - - $mw->Synchronize() if $self->{synchronous}; - - if ($self->{iconic}) - { - $mw->iconify(); - $self->{iconic} = 0; - } - - $Tk::strictMotif = ($self->{motif} || 0); - - # Both these are needed to reliably save state - # but 'hostname' is tricky to do portably. - # $mw->client(hostname()); - $mw->protocol('WM_SAVE_YOURSELF' => ['WMSaveYourself',$mw]); - $mw->command([ $self->{name}, @{$self->{command}} ]); -} - -#/----------------------------------------------------------------------------// -#/ Set the initial resources. -#/ Returns the object reference. -#/----------------------------------------------------------------------------// - -sub SetResources # Tk::CmdLine::SetResources((\@resource | $resource) [, $priority]) -{ - my $self = (@_ # define the object as necessary - ? ((ref($_[0]) eq __PACKAGE__) - ? shift(@_) - : (($_[0] eq __PACKAGE__) ? shift(@_) : 1) && ($OBJECT ||= __PACKAGE__->new())) - : ($OBJECT ||= __PACKAGE__->new())); - $OBJECT = $self; # update the current object - - $self->SetArguments() unless exists($self->{offset}); # set arguments if not yet done - return $self unless @_; - - my $data = shift(@_); - my $priority = shift(@_) || 'userDefault'; - - $self->{resources}->{$priority} = [] unless exists($self->{resources}->{$priority}); - - foreach my $resource ((ref($data) eq 'ARRAY') ? @{$data} : $data) - { - if (ref($resource) eq 'ARRAY') # resources in [ <pattern>, <value> ] format - { - push(@{$self->{resources}->{$priority}}, [ @{$resource} ]) - if (@{$resource} == 2); - } - else # resources in resource file format - { - push(@{$self->{resources}->{$priority}}, [ $1, $2 ]) - if ($resource =~ /^([^!:\s]+)*\s*:\s*(.*)$/); - } - } - - return $self; -} - -#/----------------------------------------------------------------------------// -#/ Load initial resources from one or more files (default: $XFILESEARCHPATH with -#/ priority 'startupFile' and $XUSERFILESEARCHPATH with priority 'userDefault'). -#/ Returns the object reference. -#/----------------------------------------------------------------------------// - -sub LoadResources # Tk::CmdLine::LoadResources([%options]) -{ - my $self = (@_ # define the object as necessary - ? ((ref($_[0]) eq __PACKAGE__) - ? shift(@_) - : (($_[0] eq __PACKAGE__) ? shift(@_) : 1) && ($OBJECT ||= __PACKAGE__->new())) - : ($OBJECT ||= __PACKAGE__->new())); - $OBJECT = $self; # update the current object - - $self->SetArguments() unless exists($self->{offset}); # set arguments if not yet done - - my %options = @_; - - my @file = (); - my $echo = (exists($options{-echo}) - ? (defined($options{-echo}) ? $options{-echo} : \*STDOUT) : undef); - - unless (%options && (exists($options{-file}) || exists($options{-symbol}))) - { - @file = ( - { -symbol => 'XFILESEARCHPATH', -priority => 'startupFile' }, - { -symbol => 'XUSERFILESEARCHPATH', -priority => 'userDefault' } ); - } - else - { - @file = { %options }; - } - - my $delimiter = (($^O eq 'MSWin32') ? ';' : ':'); - - foreach my $file (@file) - { - my $fileSpec = $file->{-spec} = undef; - if (exists($file->{-symbol})) - { - my $xpath = undef; - if ($file->{-symbol} eq 'XUSERFILESEARCHPATH') - { - $file->{-priority} ||= 'userDefault'; - foreach my $symbol (qw(XUSERFILESEARCHPATH XAPPLRESDIR HOME)) - { - last if (exists($ENV{$symbol}) && ($xpath = $ENV{$symbol})); - } - next unless defined($xpath); - } - else - { - $file->{-priority} ||= (($file->{-symbol} eq 'XFILESEARCHPATH') - ? 'startupFile' : 'userDefault'); - next unless ( - exists($ENV{$file->{-symbol}}) && ($xpath = $ENV{$file->{-symbol}})); - } - - unless (exists($self->{translation})) - { - $self->{translation} = { - '%l' => '', # ignored - '%C' => '', # ignored - '%S' => '', # ignored - '%L' => ($ENV{LANG} || 'C'), # language - '%T' => 'app-defaults', # type - '%N' => $self->{config}->{-class} # filename - }; - } - - my @postfix = map({ $_ . '/' . $self->{config}->{-class} } - ('/' . $self->{translation}->{'%L'}), ''); - - ITEM: foreach $fileSpec (split($Config{path_sep}, $xpath)) - { - if ($fileSpec =~ s/(%[A-Za-z])/$self->{translation}->{$1}/g) # File Pattern - { - if (defined($echo) && ($file->{-symbol} ne 'XFILESEARCHPATH')) - { - print $echo 'Checking ', $fileSpec, "\n"; - } - next unless ((-f $fileSpec) && (-r _) && (-s _)); - $file->{-spec} = $fileSpec; - last; - } - else # Directory - Check for <Directory>/$LANG/<Class>, <Directory>/<CLASS> - { - foreach my $postfix (@postfix) - { - my $fileSpec2 = $fileSpec . $postfix; - if (defined($echo) && ($file->{-symbol} ne 'XFILESEARCHPATH')) - { - print $echo 'Checking ', $fileSpec2, "\n"; - } - next unless ((-f $fileSpec2) && (-r _) && (-s _)); - $file->{-spec} = $fileSpec2; - last ITEM; - } - } - } - } - elsif (exists($file->{-file}) && ($fileSpec = $file->{-file})) - { - print $echo 'Checking ', $fileSpec, "\n" if defined($echo); - next unless ((-f $fileSpec) && (-r _) && (-s _)); - $file->{-spec} = $fileSpec; - } - } - - foreach my $file (@file) - { - next unless defined($file->{-spec}); - local *SPEC; - next unless open(SPEC,$file->{-spec}); - print $echo ' Loading ', $file->{-spec}, "\n" if defined($echo); - - my $resource = undef; - my @resource = (); - my $continuation = 0; - - while (defined(my $line = <SPEC>)) - { - chomp($line); - next if ($line =~ /^\s*$/); # skip blank lines - next if ($line =~ /^\s*!/); # skip comments - $continuation = ($line =~ s/\s*\\$/ /); # search for trailing backslash - unless (defined($resource)) # it is the first line - { - $resource = $line; - } - else # it is a continuation line - { - $line =~ s/^\s*//; # remove leading whitespace - $resource .= $line; - } - next if $continuation; - push(@resource, [ $1, $2 ]) if ($resource =~ /^([^:\s]+)*\s*:\s*(.*)$/); - $resource = undef; - } - - close(SPEC); - - if (defined($resource)) # special case - EOF after line with trailing backslash - { - push(@resource, [ $1, $2 ]) if ($resource =~ /^([^:\s]+)*\s*:\s*(.*)$/); - } - - $self->SetResources(\@resource, $file->{-priority}) if @resource; - } - - return $self; -} - -#/----------------------------------------------------------------------------// - -1; - -__END__ - -=cut - -=head1 NAME - -Tk::CmdLine - Process standard X11 command line options and set initial resources - -=for pm Tk/CmdLine.pm - -=for category Creating and Configuring Widgets - -=head1 SYNOPSIS - - Tk::CmdLine::SetArguments([@argument]); - - my $value = Tk::CmdLine::cget([$option]); - - Tk::CmdLine::SetResources((\@resource | $resource) [, $priority]); - - Tk::CmdLine::LoadResources( - [ -symbol => $symbol ] - [ -file => $fileSpec ] - [ -priority => $priority ] - [ -echo => $fileHandle ] ); - -=head1 DESCRIPTION - -Process standard X11 command line options and set initial resources. - -The X11R5 man page for X11 says: "Most X programs attempt to use the same names -for command line options and arguments. All applications written with the -X Toolkit Intrinsics automatically accept the following options: ...". -This module processes these command line options for perl/Tk applications -using the C<SetArguments>() function. - -This module can optionally be used to load initial resources explicitly via -function C<SetResources>(), or from specified files (default: the standard X11 -application-specific resource files) via function C<LoadResources>(). - -=head2 Command Line Options - -=over 4 - -=item B<-background> I<Color> | B<-bg> I<Color> - -Specifies the color to be used for the window background. - -=item B<-class> I<Class> - -Specifies the class under which resources for the application should be found. -This option is useful in shell aliases to distinguish between invocations -of an application, without resorting to creating links to alter the executable -file name. - -=item B<-display> I<Display> | B<-screen> I<Display> - -Specifies the name of the X server to be used. - -=item B<-font> I<Font> | B<-fn> I<Font> - -Specifies the font to be used for displaying text. - -=item B<-foreground> I<Color> | B<-fg> I<Color> - -Specifies the color to be used for text or graphics. - -=item B<-geometry> I<Geometry> - -Specifies the initial size and location of the I<first> -L<MainWindow|Tk::MainWindow>. - -=item B<-iconic> - -Indicates that the user would prefer that the application's windows initially -not be visible as if the windows had been immediately iconified by the user. -Window managers may choose not to honor the application's request. - -=item B<-motif> - -Specifies that the application should adhere as closely as possible to Motif -look-and-feel standards. For example, active elements such as buttons and -scrollbar sliders will not change color when the pointer passes over them. - -=item B<-name> I<Name> - -Specifies the name under which resources for the application should be found. -This option is useful in shell aliases to distinguish between invocations -of an application, without resorting to creating links to alter the executable -file name. - -=item B<-synchronous> - -Indicates that requests to the X server should be sent synchronously, instead of -asynchronously. Since Xlib normally buffers requests to the server, errors do -do not necessarily get reported immediately after they occur. This option turns -off the buffering so that the application can be debugged. It should never -be used with a working program. - -=item B<-title> I<TitleString> - -This option specifies the title to be used for this window. This information is -sometimes used by a window manager to provide some sort of header identifying -the window. - -=item B<-xrm> I<ResourceString> - -Specifies a resource pattern and value to override any defaults. It is also -very useful for setting resources that do not have explicit command line -arguments. - -The I<ResourceString> is of the form E<lt>I<pattern>E<gt>:E<lt>I<value>E<gt>, -that is (the first) ':' is used to determine which part is pattern and which -part is value. The (E<lt>I<pattern>E<gt>, E<lt>I<value>E<gt>) pair is entered -into the options database with B<optionAdd> (for each -L<MainWindow|Tk::MainWindow> configured), with I<interactive> priority. - -=back - -=head2 Initial Resources - -There are several mechanism for initializing the resource database to be used -by an X11 application. Resources may be defined in a $C<HOME>/.Xdefaults file, -a system application defaults file (e.g. -/usr/lib/X11/app-defaults/E<lt>B<CLASS>E<gt>), -or a user application defaults file (e.g. $C<HOME>/E<lt>B<CLASS>E<gt>). -The Tk::CmdLine functionality for setting initial resources concerns itself -with the latter two. - -Resource files contain data lines of the form -E<lt>I<pattern>E<gt>:E<lt>I<value>E<gt>. -They may also contain blank lines and comment lines (denoted -by a ! character as the first non-blank character). Refer to L<option|Tk::option> -for a description of E<lt>I<pattern>E<gt>:E<lt>I<value>E<gt>. - -=over 4 - -=item System Application Defaults Files - -System application defaults files may be specified via environment variable -$C<XFILESEARCHPATH> which, if set, contains a list of file patterns -(joined using the OS-dependent path delimiter, e.g. colon on B<UNIX>). - -=item User Application Defaults Files - -User application defaults files may be specified via environment variables -$C<XUSERFILESEARCHPATH>, $C<XAPPLRESDIR> or $C<HOME>. - -=back - -=head1 METHODS - -=over 4 - -=item B<SetArguments> - Tk::CmdLine::SetArguments([@argument]) - -Extract the X11 options contained in a specified array (@ARGV by default). - - Tk::CmdLine::SetArguments([@argument]) - -The X11 options may be specified using a single dash I<-> as per the X11 -convention, or using two dashes I<--> as per the POSIX standard (e.g. -B<-geometry> I<100x100>, B<-geometry> I<100x100> or B<-geometry=>I<100x100>). -The options may be interspersed with other options or arguments. -A I<--> by itself terminates option processing. - -By default, command line options are extracted from @ARGV the first time -a MainWindow is created. The Tk::MainWindow constructor indirectly invokes -C<SetArguments>() to do this. - -=item B<GetArguments> - Tk::CmdLine::GetArguments() - -Get a list of the X11 options that have been processed by C<SetArguments>(). -(C<GetArguments>() first invokes C<SetArguments>() if it has not already been invoked.) - -=item B<cget> - Tk::CmdLine::cget([$option]) - -Get the value of a configuration option specified via C<SetArguments>(). -(C<cget>() first invokes C<SetArguments>() if it has not already been invoked.) - - Tk::CmdLine::cget([$option]) - -The valid options are: B<-class>, B<-name>, B<-screen> and B<-title>. -If no option is specified, B<-class> is implied. - -A typical use of C<cget>() might be to obtain the application class in order -to define the name of a resource file to be loaded in via C<LoadResources>(). - - my $class = Tk::CmdLine::cget(); # process command line and return class - -=item B<SetResources> - Tk::CmdLine::SetResources((\@resource | $resource) [, $priority]) - -Set the initial resources. - - Tk::CmdLine::SetResources((\@resource | $resource) [, $priority]) - -A single resource may be specified using a string of the form -'E<lt>I<pattern>E<gt>:E<lt>I<value>E<gt>'. Multiple resources may be specified -by passing an array reference whose elements are either strings of the above -form, and/or anonymous arrays of the form [ E<lt>I<pattern>E<gt>, -E<lt>I<value>E<gt> ]. The optional second argument specifies the priority, -as defined in L<option|Tk::option>, to be associated with the resources -(default: I<userDefault>). - -Note that C<SetResources>() first invokes C<SetArguments>() if it has not already -been invoked. - -=item B<LoadResources> - Tk::CmdLine::LoadResources([%options]) - -Load initial resources from one or more files. - - Tk::CmdLine::LoadResources( - [ -symbol => $symbol ] - [ -file => $fileSpec ] - [ -priority => $priority ] - [ -echo => $fileHandle ] ); - -[ B<-symbol> =E<gt> $symbol ] specifies the name of an environment variable -that, if set, defines a list of one or more directories and/or file patterns -(joined using the OS-dependent path delimiter, e.g. colon on B<UNIX>). -$C<XUSERFILESEARCHPATH> is a special case. -If $C<XUSERFILESEARCHPATH> is not set, $C<XAPPLRESDIR> is checked instead. -If $C<XAPPLRESDIR> is not set, $C<HOME> is checked instead. - -An item is identified as a file pattern if it contains one or more /%[A-Za-z]/ -patterns. Only patterns B<%L>, B<%T> and B<%N> are currently recognized. All -others are replaced with the null string. Pattern B<%L> is translated into -$C<LANG>. Pattern B<%T> is translated into I<app-defaults>. Pattern B<%N> is -translated into the application class name. - -Each file pattern, after substitutions are applied, is assumed to define a -FileSpec to be examined. - -When a directory is specified, FileSpecs -E<lt>B<DIRECTORY>E<gt>/E<lt>B<LANG>E<gt>/E<lt>B<CLASS>E<gt> -and E<lt>B<DIRECTORY>E<gt>/E<lt>B<CLASS>E<gt> are defined, in that order. - -[ B<-file> =E<gt> $fileSpec ] specifies a resource file to be loaded in. -The file is silently skipped if if does not exist, or if it is not readable. - -[ B<-priority> =E<gt> $priority ] specifies the priority, as defined in -L<option|Tk::option>, to be associated with the resources -(default: I<userDefault>). - -[ B<-echo> =E<gt> $fileHandle ] may be used to specify that a line should be -printed to the corresponding FileHandle (default: \*STDOUT) everytime a file -is examined / loaded. - -If no B<-symbol> or B<-file> options are specified, C<LoadResources>() -processes symbol $C<XFILESEARCHPATH> with priority I<startupFile> and -$C<XUSERFILESEARCHPATH> with priority I<userDefault>. -(Note that $C<XFILESEARCHPATH> and $C<XUSERFILESEARCHPATH> are supposed to -contain only patterns. $C<XAPPLRESDIR> and $C<HOME> are supposed to be a single -directory. C<LoadResources>() does not check/care whether this is the case.) - -For each set of FileSpecs, C<LoadResources>() examines each FileSpec to -determine if the file exists and is readable. The first file that meets this -criteria is read in and C<SetResources>() is invoked. - -Note that C<LoadResources>() first invokes C<SetArguments>() if it has not already -been invoked. - -=back - -=head1 NOTES - -This module is an object-oriented module whose methods can be invoked as object -methods, class methods or regular functions. This is accomplished via an -internally-maintained object reference which is created as necessary, and which -always points to the last object used. C<SetArguments>(), C<SetResources>() and -C<LoadResources>() return the object reference. - -=head1 EXAMPLES - -=over - -=item 1 - -@ARGV is processed by Tk::CmdLine at MainWindow creation. - - use Tk; - - # <Process @ARGV - ignoring all X11-specific options> - - my $mw = MainWindow->new(); - - MainLoop(); - -=item 2 - -@ARGV is processed by Tk::CmdLine before MainWindow creation. -An @ARGV of (--geometry=100x100 -opt1 a b c -bg red) -is equal to (-opt1 a b c) after C<SetArguments>() is invoked. - - use Tk; - - Tk::CmdLine::SetArguments(); # Tk::CmdLine->SetArguments() works too - - # <Process @ARGV - not worrying about X11-specific options> - - my $mw = MainWindow->new(); - - MainLoop(); - -=item 3 - -Just like 2) except that default arguments are loaded first. - - use Tk; - - Tk::CmdLine::SetArguments(qw(-name test -iconic)); - Tk::CmdLine::SetArguments(); - - # <Process @ARGV - not worrying about X11-specific options> - - my $mw = MainWindow->new(); - - MainLoop(); - -=item 4 - -@ARGV is processed by Tk::CmdLine before MainWindow creation. -Standard resource files are loaded in before MainWindow creation. - - use Tk; - - Tk::CmdLine::SetArguments(); - - # <Process @ARGV - not worrying about X11-specific options> - - Tk::CmdLine::LoadResources(); - - my $mw = MainWindow->new(); - - MainLoop(); - -=item 5 - -@ARGV is processed by Tk::CmdLine before MainWindow creation. -Standard resource files are loaded in before MainWindow creation -using non-default priorities. - - use Tk; - - Tk::CmdLine::SetArguments(); - - # <Process @ARGV - not worrying about X11-specific options> - - Tk::CmdLine::LoadResources(-echo => \*STDOUT, - -priority => 65, -symbol => 'XFILESEARCHPATH' ); - Tk::CmdLine::LoadResources(-echo => \*STDOUT, - -priority => 75, -symbol => 'XUSERFILESEARCHPATH' ); - - my $mw = MainWindow->new(); - - MainLoop(); - -=item 6 - -@ARGV is processed by Tk::CmdLine before MainWindow creation. -Standard resource files are loaded in before MainWindow creation. -Individual resources are also loaded in before MainWindow creation. - - use Tk; - - Tk::CmdLine::SetArguments(); - - # <Process @ARGV - not worrying about X11-specific options> - - Tk::CmdLine::LoadResources(); - - Tk::CmdLine::SetResources( # set a single resource - '*Button*background: red', - 'widgetDefault' ); - - Tk::CmdLine::SetResources( # set multiple resources - [ '*Button*background: red', '*Button*foreground: blue' ], - 'widgetDefault' ); - - my $mw = MainWindow->new(); - - MainLoop(); - -=back - -=head1 ENVIRONMENT - -=over 4 - -=item B<HOME> (optional) - -Home directory which may contain user application defaults files as -$C<HOME>/$C<LANG>/E<lt>B<CLASS>E<gt> or $C<HOME>/E<lt>B<CLASS>E<gt>. - -=item B<LANG> (optional) - -The current language (default: I<C>). - -=item B<XFILESEARCHPATH> (optional) - -List of FileSpec patterns -(joined using the OS-dependent path delimiter, e.g. colon on B<UNIX>) -used in defining system application defaults files. - -=item B<XUSERFILESEARCHPATH> (optional) - -List of FileSpec patterns -(joined using the OS-dependent path delimiter, e.g. colon on B<UNIX>) -used in defining user application defaults files. - -=item B<XAPPLRESDIR> (optional) - -Directory containing user application defaults files as -$C<XAPPLRESDIR>/$C<LANG>/E<lt>B<CLASS>E<gt> or -$C<XAPPLRESDIR>/E<lt>B<CLASS>E<gt>. - -=back - -=head1 SEE ALSO - -L<MainWindow|Tk::MainWindow> -L<option|Tk::option> - -=head1 HISTORY - -=over 4 - -=item * - -1999.03.04 Ben Pavon E<lt>ben.pavon@hsc.hac.comE<gt> - -Rewritten as an object-oriented module. - -Allow one to process command line options in a specified array (@ARGV by default). -Eliminate restrictions on the format and location of the options within the array -(previously the X11 options could not be specified in POSIX format and had to be -at the beginning of the array). - -Added the C<SetResources>() and C<LoadResources>() functions to allow the definition -of resources prior to MainWindow creation. - -=item * - -2000.08.31 Ben Pavon E<lt>ben.pavon@hsc.hac.comE<gt> - -Added the C<GetArguments>() method which returns the list of arguments that -have been processed by C<SetArguments>(). - -Modified C<LoadResources>() to split the symbols using the OS-dependent -path delimiter defined in the B<Config> module. - -Modified C<LoadResources>() to eliminate a warning message when processing -patterns B<%l>, B<%C>, B<%S>. - -=back - -=cut - diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Configure.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Configure.pm deleted file mode 100644 index 26252ae4958..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Configure.pm +++ /dev/null @@ -1,69 +0,0 @@ -package Tk::Configure; -use vars qw($VERSION); -$VERSION = '4.008'; # $Id: //depot/Tkutf8/Tk/Configure.pm#8 $ - -use Carp; -use Tk::Pretty; - - -# Class that handles cget/configure for options that -# need translating from public form -# e.g. $cw->configure(-label => 'fred') -# into $cw->subwiget('label')->configure(-text => 'fred') -# Should probably do something clever with regexp's here - - -sub new -{ - my ($class,@args) = @_; - unshift(@args,'configure','cget') if (@args < 3); - return bless \@args,$class; -} - -sub cget -{ - croak('Wrong number of args to cget') unless (@_ == 2); - my ($alias,$key) = @_; - my ($set,$get,$widget,@args) = @$alias; - $widget->$get(@args); -} - -sub configure -{ - my $alias = shift; - shift if (@_); - my ($set,$get,$widget,@args) = @$alias; - if (wantarray) - { - my @results; - eval { @results = $widget->$set(@args,@_) }; - croak($@) if $@; - return @results; - } - else - { - my $results; - eval { $results = $widget->$set(@args,@_) }; - croak($@) if $@; - return $results; - } -} - -*TIESCALAR = \&new; -*TIEHASH = \&new; - -sub FETCH -{ - my $alias = shift; - my ($set,$get,$widget,@args) = @$alias; - return $widget->$get(@args,@_); -} - -sub STORE -{ - my $alias = shift; - my ($set,$get,$widget,@args) = @$alias; - $widget->$set(@args,@_); -} - -1; diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Derived.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Derived.pm deleted file mode 100644 index c31c205d2fb..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Derived.pm +++ /dev/null @@ -1,512 +0,0 @@ -# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved. -# This program is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. -package Tk::Derived; -require Tk::Widget; -require Tk::Configure; -use strict; -use Carp; - -use vars qw($VERSION); -$VERSION = sprintf '4.%03d', q$Revision: #10 $ =~ /\D(\d+)\s*$/; - -$Tk::Derived::Debug = 0; - -my $ENHANCED_CONFIGSPECS = 0; # disable for now - -use Tk qw(NORMAL_BG BLACK); - -sub Subwidget -{ - my $cw = shift; - my @result = (); - if (exists $cw->{SubWidget}) - { - if (@_) - { - foreach my $name (@_) - { - push(@result,$cw->{SubWidget}{$name}) if (exists $cw->{SubWidget}{$name}); - } - } - else - { - @result = values %{$cw->{SubWidget}}; - } - } - return (wantarray) ? @result : $result[0]; -} - -sub _makelist -{ - my $widget = shift; - my (@specs) = (ref $widget && ref $widget eq 'ARRAY') ? (@$widget) : ($widget); - return @specs; -} - -sub Subconfigure -{ - # This finds the widget or widgets to to which to apply a particular - # configure option - my ($cw,$opt) = @_; - my $config = $cw->ConfigSpecs; - my $widget; - my @subwidget = (); - my @arg = (); - if (defined $opt) - { - $widget = $config->{$opt}; - unless (defined $widget) - { - $widget = ($opt =~ /^-(.*)$/) ? $config->{$1} : $config->{-$opt}; - } - # Handle alias entries - if (defined($widget) && !ref($widget)) - { - $opt = $widget; - $widget = $config->{$widget}; - } - push(@arg,$opt) unless ($opt eq 'DEFAULT'); - } - $widget = $config->{DEFAULT} unless (defined $widget); - if (defined $widget) - { - $cw->BackTrace("Invalid ConfigSpecs $widget") unless (ref($widget) && (ref $widget eq 'ARRAY')); - $widget = $widget->[0]; - } - else - { - $widget = 'SELF'; - } - foreach $widget (_makelist($widget)) - { - $widget = 'SELF' if (ref($widget) && $widget == $cw); - if (ref $widget) - { - my $ref = ref $widget; - if ($ref eq 'ARRAY') - { - $widget = Tk::Configure->new(@$widget); - push(@subwidget,$widget) - } - elsif ($ref eq 'HASH') - { - foreach my $key (%$widget) - { - foreach my $sw (_makelist($widget->{$key})) - { - push(@subwidget,Tk::Configure->new($sw,$key)); - } - } - } - else - { - push(@subwidget,$widget) - } - } - elsif ($widget eq 'ADVERTISED') - { - push(@subwidget,$cw->Subwidget) - } - elsif ($widget eq 'DESCENDANTS') - { - push(@subwidget,$cw->Descendants) - } - elsif ($widget eq 'CHILDREN') - { - push(@subwidget,$cw->children) - } - elsif ($widget eq 'METHOD') - { - my ($method) = ($opt =~ /^-?(.*)$/); - push(@subwidget,Tk::Configure->new($method,$method,$cw)) - } - elsif ($widget eq 'SETMETHOD') - { - my ($method) = ($opt =~ /^-?(.*)$/); - push(@subwidget,Tk::Configure->new($method,'_cget',$cw,@arg)) - } - elsif ($widget eq 'SELF') - { - push(@subwidget,Tk::Configure->new('Tk::configure', 'Tk::cget', $cw,@arg)) - } - elsif ($widget eq 'PASSIVE') - { - push(@subwidget,Tk::Configure->new('_configure','_cget',$cw,@arg)) - } - elsif ($widget eq 'CALLBACK') - { - push(@subwidget,Tk::Configure->new('_callback','_cget',$cw,@arg)) - } - else - { - push(@subwidget,$cw->Subwidget($widget)); - } - } - $cw->BackTrace("No delegate subwidget '$widget' for $opt") unless (@subwidget); - return (wantarray) ? @subwidget : $subwidget[0]; -} - -sub _cget -{ - my ($cw,$opt) = @_; - $cw->BackTrace('Wrong number of args to cget') unless (@_ == 2); - return $cw->{Configure}{$opt} -} - -sub _configure -{ - my ($cw,$opt,$val) = @_; - $cw->BackTrace('Wrong number of args to configure') unless (@_ == 3); - $cw->{Configure}{$opt} = $val; -} - -sub _callback -{ - my ($cw,$opt,$val) = @_; - $cw->BackTrace('Wrong number of args to configure') unless (@_ == 3); - $val = Tk::Callback->new($val) if defined($val) && ref($val); - $cw->{Configure}{$opt} = $val; -} - -sub cget -{my ($cw,$opt) = @_; - my @result; - local $SIG{'__DIE__'}; - foreach my $sw ($cw->Subconfigure($opt)) - { - if (wantarray) - { - eval { @result = $sw->cget($opt) }; - } - else - { - eval { $result[0] = $sw->cget($opt) }; - } - last unless $@; - } - return wantarray ? @result : $result[0]; -} - -sub Configured -{ - # Called whenever a derived widget is re-configured - my ($cw,$args,$changed) = @_; - if (@_ > 1) - { - $cw->afterIdle(['ConfigChanged',$cw,$changed]) if (%$changed); - } - return exists $cw->{'Configure'}; -} - -sub configure -{ - # The default composite widget configuration method uses hash stored - # in the widget's hash to map configuration options - # onto subwidgets. - # - my @results = (); - my $cw = shift; - if (@_ <= 1) - { - # Enquiry cases - my $spec = $cw->ConfigSpecs; - if (@_) - { - # Return info on the nominated option - my $opt = $_[0]; - my $info = $spec->{$opt}; - unless (defined $info) - { - $info = ($opt =~ /^-(.*)$/) ? $spec->{$1} : $spec->{-$opt}; - } - if (defined $info) - { - if (ref $info) - { - # If the default slot is undef then ask subwidgets in turn - # for their default value until one accepts it. - if ($ENHANCED_CONFIGSPECS && !defined($info->[3])) - {local $SIG{'__DIE__'}; - my @def; - foreach my $sw ($cw->Subconfigure($opt)) - { - eval { @def = $sw->configure($opt) }; - last unless $@; - } - $info->[3] = $def[3]; - $info->[1] = $def[1] unless defined $info->[1]; - $info->[2] = $def[2] unless defined $info->[2]; - } - push(@results,$opt,$info->[1],$info->[2],$info->[3],$cw->cget($opt)); - } - else - { - # Real (core) Tk widgets return db name rather than option name - # for aliases so recurse to get that ... - my @real = $cw->configure($info); - push(@results,$opt,$real[1]); - } - } - else - { - push(@results,$cw->Subconfigure($opt)->configure($opt)); - } - } - else - { - my $opt; - my %results; - if (exists $spec->{'DEFAULT'}) - { - foreach $opt ($cw->Subconfigure('DEFAULT')->configure) - { - $results{$opt->[0]} = $opt; - } - } - foreach $opt (keys %$spec) - { - $results{$opt} = [$cw->configure($opt)] if ($opt ne 'DEFAULT'); - } - foreach $opt (sort keys %results) - { - push(@results,$results{$opt}); - } - } - } - else - { - my (%args) = @_; - my %changed = (); - my ($opt,$val); - my $config = $cw->TkHash('Configure'); - - while (($opt,$val) = each %args) - { - my $var = \$config->{$opt}; - my $old = $$var; - $$var = $val; - my $accepted = 0; - my $error = "No widget handles $opt"; - foreach my $subwidget ($cw->Subconfigure($opt)) - { - next unless (defined $subwidget); - eval {local $SIG{'__DIE__'}; $subwidget->configure($opt => $val) }; - if ($@) - { - my $val2 = (defined $val) ? $val : 'undef'; - $error = "Can't set $opt to `$val2' for $cw: " . $@; - undef $@; - } - else - { - $accepted = 1; - } - } - $cw->BackTrace($error) unless ($accepted); - $val = $$var; - $changed{$opt} = $val if (!defined $old || !defined $val || "$old" ne "$val"); - } - $cw->Configured(\%args,\%changed); - } - return (wantarray) ? @results : \@results; -} - -sub ConfigDefault -{ - my ($cw,$args) = @_; - - $cw->BackTrace('Bad args') unless (defined $args && ref $args eq 'HASH'); - - my $specs = $cw->ConfigSpecs; - # Should we enforce a Delagates(DEFAULT => ) as well ? - $specs->{'DEFAULT'} = ['SELF'] unless (exists $specs->{'DEFAULT'}); - - # - # This is a pain with Text or Entry as core widget, they don't - # inherit SELF's cursor. So comment it out for Tk402.001 - # - # $specs->{'-cursor'} = ['SELF',undef,undef,undef] unless (exists $specs->{'-cursor'}); - - # Now some hacks that cause colours to propogate down a composite widget - # tree - really needs more thought, other options adding such as active - # colours too and maybe fonts - - my $child = ($cw->children)[0]; # 1st child window (if any) - - unless (exists($specs->{'-background'})) - { - Tk::catch { $cw->Tk::cget('-background') }; - my (@bg) = $@ ? ('PASSIVE') : ('SELF'); - push(@bg,'CHILDREN') if $child; - $specs->{'-background'} = [\@bg,'background','Background',NORMAL_BG]; - } - unless (exists($specs->{'-foreground'})) - { - Tk::catch { $cw->Tk::cget('-foreground') }; - my (@fg) = $@ ? ('PASSIVE') : ('SELF'); - push(@fg,'CHILDREN') if $child; - $specs->{'-foreground'} = [\@fg,'foreground','Foreground',BLACK]; - } - $cw->ConfigAlias(-fg => '-foreground', -bg => '-background'); - - # Pre-scan args for aliases - this avoids defaulting - # options specified via alias - foreach my $opt (keys %$args) - { - my $info = $specs->{$opt}; - if (defined($info) && !ref($info)) - { - $args->{$info} = delete $args->{$opt}; - } - } - - # Now walk %$specs supplying defaults for all the options - # which have a defined default value, potentially looking up .Xdefaults database - # options for the name/class of the 'frame' - - foreach my $opt (keys %$specs) - { - if ($opt ne 'DEFAULT') - { - unless (exists $args->{$opt}) - { - my $info = $specs->{$opt}; - if (ref $info) - { - # Not an alias - if ($ENHANCED_CONFIGSPECS && !defined $info->[3]) - { - # configure inquire to fill in default slot from subwidget - $cw->configure($opt); - } - if (defined $info->[3]) - { - if (defined $info->[1] && defined $info->[2]) - { - # Should we do this on the Subconfigure widget instead? - # to match *Entry.Background - my $db = $cw->optionGet($info->[1],$info->[2]); - $info->[3] = $db if (defined $db); - } - $args->{$opt} = $info->[3]; - } - } - } - } - } -} - -sub ConfigSpecs -{ - my $cw = shift; - my $specs = $cw->TkHash('ConfigSpecs'); - while (@_) - { - my $key = shift; - my $val = shift; - $specs->{$key} = $val; - } - return $specs; -} - -sub _alias -{ - my ($specs,$opt,$main) = @_; - if (exists($specs->{$opt})) - { - unless (exists $specs->{$main}) - { - my $targ = $specs->{$opt}; - if (ref($targ)) - { - # opt is a real option - $specs->{$main} = $opt - } - else - { - # opt is itself an alias - # make main point to same place - $specs->{$main} = $targ unless $targ eq $main; - } - } - return 1; - } - return 0; -} - -sub ConfigAlias -{ - my $cw = shift; - my $specs = $cw->ConfigSpecs; - while (@_ >= 2) - { - my $opt = shift; - my $main = shift; - unless (_alias($specs,$opt,$main) || _alias($specs,$main,$opt)) - { - $cw->BackTrace("Neither $opt nor $main exist"); - } - } - $cw->BackTrace('Odd number of args to ConfigAlias') if (@_); -} - -sub Delegate -{ - my ($cw,$method,@args) = @_; - my $widget = $cw->DelegateFor($method); - if ($widget == $cw) - { - $method = "Tk::Widget::$method" - } - my @result; - if (wantarray) - { - @result = $widget->$method(@args); - } - else - { - $result[0] = $widget->$method(@args); - } - return (wantarray) ? @result : $result[0]; -} - -sub InitObject -{ - my ($cw,$args) = @_; - $cw->Populate($args); - $cw->ConfigDefault($args); -} - -sub ConfigChanged -{ - my ($cw,$args) = @_; -} - -sub Advertise -{ - my ($cw,$name,$widget) = @_; - confess 'No name' unless (defined $name); - croak 'No widget' unless (defined $widget); - my $hash = $cw->TkHash('SubWidget'); - $hash->{$name} = $widget; # advertise it - return $widget; -} - -sub Component -{ - my ($cw,$kind,$name,%args) = @_; - $args{'Name'} = "\l$name" if (defined $name && !exists $args{'Name'}); - # my $pack = delete $args{'-pack'}; - my $delegate = delete $args{'-delegate'}; - my $w = $cw->$kind(%args); # Create it - # $w->pack(@$pack) if (defined $pack); - $cw->Advertise($name,$w) if (defined $name); - $cw->Delegates(map(($_ => $w),@$delegate)) if (defined $delegate); - return $w; # and return it -} - -1; -__END__ - - diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Dialog.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Dialog.pm deleted file mode 100644 index 8173f4a5acc..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Dialog.pm +++ /dev/null @@ -1,70 +0,0 @@ -package Tk::Dialog; - -use vars qw($VERSION); -$VERSION = '4.004'; # $Id: //depot/Tkutf8/Tk/Dialog.pm#4 $ - -# Dialog - a translation of `tk_dialog' from Tcl/Tk to TkPerl (based on -# John Stoffel's idea). -# -# Stephen O. Lidie, Lehigh University Computing Center. 94/12/27 -# lusol@Lehigh.EDU - -# Documentation after __END__ - -use Carp; -use strict; -use base qw(Tk::DialogBox); - -Construct Tk::Widget 'Dialog'; - -sub Populate -{ - - # Dialog object constructor. Uses `new' method from base class - # to create object container then creates the dialog toplevel. - - my($cw, $args) = @_; - - $cw->SUPER::Populate($args); - - my ($w_bitmap,$w_but,$pad1,$pad2); - - # Create the Toplevel window and divide it into top and bottom parts. - - my (@pl) = (-side => 'top', -fill => 'both'); - - ($pad1, $pad2) = - ([-padx => '3m', -pady => '3m'], [-padx => '3m', -pady => '2m']); - - - $cw->iconname('Dialog'); - - my $w_top = $cw->Subwidget('top'); - - # Fill the top part with the bitmap and message. - - @pl = (-side => 'left'); - - $w_bitmap = $w_top->Label(Name => 'bitmap'); - $w_bitmap->pack(@pl, @$pad1); - - my $w_msg = $w_top->Label( -wraplength => '3i', -justify => 'left' ); - - $w_msg->pack(-side => 'right', -expand => 1, -fill => 'both', @$pad1); - - $cw->Advertise(message => $w_msg); - $cw->Advertise(bitmap => $w_bitmap ); - - $cw->ConfigSpecs( -image => ['bitmap',undef,undef,undef], - -bitmap => ['bitmap',undef,undef,undef], - -font => ['message','font','Font', '-*-Times-Medium-R-Normal--*-180-*-*-*-*-*-*'], - DEFAULT => ['message',undef,undef,undef] - ); -} - -1; - -__END__ - -=cut - diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/DialogBox.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/DialogBox.pm deleted file mode 100644 index 13335404e15..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/DialogBox.pm +++ /dev/null @@ -1,135 +0,0 @@ -# -# DialogBox is similar to Dialog except that it allows any widget -# in the top frame. Widgets can be added with the add method. Currently -# there exists no way of deleting a widget once it has been added. - -package Tk::DialogBox; - -use strict; -use Carp; - -use vars qw($VERSION); -$VERSION = sprintf '4.%03d', q$Revision: #13 $ =~ /\D(\d+)\s*$/; - -use base qw(Tk::Toplevel); - -Tk::Widget->Construct('DialogBox'); - -sub Populate { - my ($cw, $args) = @_; - - $cw->SUPER::Populate($args); - my $buttons = delete $args->{'-buttons'}; - $buttons = ['OK'] unless defined $buttons; - my $default_button = delete $args->{'-default_button'}; - $default_button = $buttons->[0] unless defined $default_button; - - $cw->{'selected_button'} = ''; - $cw->transient($cw->Parent->toplevel); - $cw->withdraw; - if (@$buttons == 1) { - $cw->protocol('WM_DELETE_WINDOW' => sub { $cw->{'default_button'}->invoke }); - } else { - $cw->protocol('WM_DELETE_WINDOW' => sub {}); - } - - # create the two frames - my $top = $cw->Component('Frame', 'top'); - $top->configure(-relief => 'raised', -bd => 1) unless $Tk::platform eq 'MSWin32'; - my $bot = $cw->Component('Frame', 'bottom'); - $bot->configure(-relief => 'raised', -bd => 1) unless $Tk::platform eq 'MSWin32'; - $bot->pack(qw/-side bottom -fill both -ipady 3 -ipadx 3/); - $top->pack(qw/-side top -fill both -ipady 3 -ipadx 3 -expand 1/); - - # create a row of buttons in the bottom. - my $bl; # foreach my $var: perl > 5.003_08 - foreach $bl (@$buttons) - { - my $b = $bot->Button(-text => $bl, -command => sub { $cw->{'selected_button'} = "$bl" } ); - $b->bind('<Return>' => [ $b, 'Invoke']); - $cw->Advertise("B_$bl" => $b); - if ($Tk::platform eq 'MSWin32') - { - $b->configure(-width => 10, -pady => 0); - } - if ($bl eq $default_button) { - if ($Tk::platform eq 'MSWin32') { - $b->pack(-side => 'left', -expand => 1, -padx => 1, -pady => 1); - } else { - my $db = $bot->Frame(-relief => 'sunken', -bd => 1); - $b->raise($db); - $b->pack(-in => $db, -padx => '2', -pady => '2'); - $db->pack(-side => 'left', -expand => 1, -padx => 1, -pady => 1); - } - $cw->{'default_button'} = $b; - $cw->bind('<Return>' => [ $b, 'Invoke']); - } else { - $b->pack(-side => 'left', -expand => 1, -padx => 1, -pady => 1); - } - } - $cw->ConfigSpecs(-command => ['CALLBACK', undef, undef, undef ], - -foreground => ['DESCENDANTS', 'foreground','Foreground', 'black'], - -background => ['DESCENDANTS', 'background','Background', undef], - -focus => ['PASSIVE', undef, undef, undef], - -showcommand => ['CALLBACK', undef, undef, undef], - ); - $cw->Delegates('Construct',$top); -} - -sub add { - my ($cw, $wnam, @args) = @_; - my $w = $cw->Subwidget('top')->$wnam(@args); - $cw->Advertise("\L$wnam" => $w); - return $w; -} - -sub Wait -{ - my $cw = shift; - $cw->Callback(-showcommand => $cw); - $cw->waitVariable(\$cw->{'selected_button'}); - $cw->grabRelease; - $cw->withdraw; - $cw->Callback(-command => $cw->{'selected_button'}); -} - -sub Show { - - croak 'DialogBox: "Show" method requires at least 1 argument' - if scalar @_ < 1; - my $cw = shift; - my ($grab) = @_; - my $old_focus = $cw->focusSave; - my $old_grab = $cw->grabSave; - - shift if defined $grab && length $grab && ($grab =~ /global/); - $cw->Popup(@_); - - Tk::catch { - if (defined $grab && length $grab && ($grab =~ /global/)) { - $cw->grabGlobal; - } else { - $cw->grab; - } - }; - if (my $focusw = $cw->cget(-focus)) { - $focusw->focus; - } elsif (defined $cw->{'default_button'}) { - $cw->{'default_button'}->focus; - } else { - $cw->focus; - } - $cw->Wait; - &$old_focus; - &$old_grab; - return $cw->{'selected_button'}; -} - -sub Exit -{ - my $cw = shift; - #kill the dialogbox, by faking a 'DONE' - $cw->{'selected_button'} = $cw->{'default_button'}->cget(-text); -} - -1; diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/DummyEncode.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/DummyEncode.pm deleted file mode 100644 index 5ead808405d..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/DummyEncode.pm +++ /dev/null @@ -1,46 +0,0 @@ -package Tk::DummyEncode; - -use vars qw($VERSION); -$VERSION = '4.007'; # $Id: //depot/Tkutf8/Tk/DummyEncode.pm#7 $ - -sub getEncoding -{ - my ($class,$name) = @_; - return undef unless ($name =~ /(iso8859-1|X11ControlChars)/); - my $pkg = $name; - $pkg =~ s/\W+/_/g; - return bless {Name => $name},$class.'::'.$pkg; -} - -package Tk::DummyEncode::iso8859_1; -sub encode -{ - my ($obj,$uni,$chk) = @_; - $_[1] = '' if $chk; - return $uni; -} - -sub decode -{ - my ($obj,$byt,$chk) = @_; - $_[1] -= '' if $chk; - return $byt; -} - -package Tk::DummyEncode::X11ControlChars; -sub encode -{ - my ($obj,$uni,$chk) = @_; - my $str = ''; - foreach my $ch (split(//,$uni)) - { - $str .= sprintf("\\x{%x}",ord($ch)); - } - $_[1] = '' if $chk; - return $str; -} - -1; - -__END__ diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Entry.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Entry.pm deleted file mode 100644 index 51b3f0c6767..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Entry.pm +++ /dev/null @@ -1,615 +0,0 @@ -package Tk::Entry; - -# Converted from entry.tcl -- -# -# This file defines the default bindings for Tk entry widgets. -# -# @(#) entry.tcl 1.22 94/12/17 16:05:14 -# -# Copyright (c) 1992-1994 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. -# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved. -# This program is free software; you can redistribute it and/or - -use vars qw($VERSION); -use strict; -$VERSION = sprintf '4.%03d',q$Revision: #17 $ =~ /#(\d+)/; - -# modify it under the same terms as Perl itself, subject -# to additional disclaimer in license.terms due to partial -# derivation from Tk4.0 sources. - -use Tk::Widget (); -use Tk::Clipboard (); -use base qw(Tk::Clipboard Tk::Widget); - -import Tk qw(Ev $XS_VERSION); - -Construct Tk::Widget 'Entry'; - -bootstrap Tk::Entry; - -sub Tk_cmd { \&Tk::entry } - -Tk::Methods('bbox','delete','get','icursor','index','insert','scan', - 'selection','validate','xview'); - -use Tk::Submethods ( 'selection' => [qw(clear range adjust present to from)], - 'xview' => [qw(moveto scroll)], - ); - -sub wordstart -{my ($w,$pos) = @_; - my $string = $w->get; - $pos = $w->index('insert')-1 unless(defined $pos); - $string = substr($string,0,$pos); - $string =~ s/\S*$//; - length $string; -} - -sub wordend -{my ($w,$pos) = @_; - my $string = $w->get; - my $anc = length $string; - $pos = $w->index('insert') unless(defined $pos); - $string = substr($string,$pos); - $string =~ s/^(?:((?=\s)\s*|(?=\S)\S*))//x; - $anc - length($string); -} - -sub deltainsert -{ - my ($w,$d) = @_; - return $w->index('insert')+$d; -} - -# -# Bind -- -# This procedure is invoked the first time the mouse enters an -# entry widget or an entry widget receives the input focus. It creates -# all of the class bindings for entries. -# -# Arguments: -# event - Indicates which event caused the procedure to be invoked -# (Enter or FocusIn). It is used so that we can carry out -# the functions of that event in addition to setting up -# bindings. -sub ClassInit -{ - my ($class,$mw) = @_; - - $class->SUPER::ClassInit($mw); - - # <<Cut>>, <<Copy>> and <<Paste>> defined in Tk::Clipboard - $mw->bind($class,'<<Clear>>' => sub { - my $w = shift; - $w->delete("sel.first", "sel.last"); - }); - $mw->bind($class,'<<PasteSelection>>' => [sub { - my($w, $x) = @_; - # XXX logic in Tcl/Tk version screwed up? - if (!$Tk::strictMotif && !$Tk::mouseMoved) { - $w->Paste($x); - } - }, Ev('x')]); - - # Standard Motif bindings: - # The <Escape> binding is different from the Tcl/Tk version: - $mw->bind($class,'<Escape>','selectionClear'); - - $mw->bind($class,'<1>',['Button1',Ev('x'),Ev('y')]); - $mw->bind($class,'<ButtonRelease-1>',['Button1Release',Ev('x'),Ev('y')]); - $mw->bind($class,'<B1-Motion>',['Motion',Ev('x'),Ev('y')]); - - $mw->bind($class,'<Double-1>',['MouseSelect',Ev('x'),'word','sel.first']); - $mw->bind($class,'<Double-Shift-1>',['MouseSelect',Ev('x'),'word']); - $mw->bind($class,'<Triple-1>',['MouseSelect',Ev('x'),'line',0]); - $mw->bind($class,'<Triple-Shift-1>',['MouseSelect',Ev('x'),'line']); - - $mw->bind($class,'<Shift-1>','Shift_1'); - - - $mw->bind($class,'<B1-Leave>',['AutoScan',Ev('x')]); - $mw->bind($class,'<B1-Enter>','CancelRepeat'); - $mw->bind($class,'<Control-1>','Control_1'); - $mw->bind($class,'<Left>', ['SetCursor',Ev('deltainsert',-1)]); - $mw->bind($class,'<Right>',['SetCursor',Ev('deltainsert',1)]); - $mw->bind($class,'<Shift-Left>',['KeySelect',Ev('deltainsert',-1)]); - $mw->bind($class,'<Shift-Right>',['KeySelect',Ev('deltainsert',1)]); - $mw->bind($class,'<Control-Left>',['SetCursor',Ev(['wordstart'])]); - $mw->bind($class,'<Control-Right>',['SetCursor',Ev(['wordend'])]); - $mw->bind($class,'<Shift-Control-Left>',['KeySelect',Ev(['wordstart'])]); - $mw->bind($class,'<Shift-Control-Right>',['KeySelect',Ev(['wordend'])]); - $mw->bind($class,'<Home>',['SetCursor',0]); - $mw->bind($class,'<Shift-Home>',['KeySelect',0]); - $mw->bind($class,'<End>',['SetCursor','end']); - $mw->bind($class,'<Shift-End>',['KeySelect','end']); - $mw->bind($class,'<Delete>','Delete'); - - $mw->bind($class,'<BackSpace>','Backspace'); - - $mw->bind($class,'<Control-space>',['selectionFrom','insert']); - $mw->bind($class,'<Select>',['selectionFrom','insert']); - $mw->bind($class,'<Control-Shift-space>',['selectionAdjust','insert']); - $mw->bind($class,'<Shift-Select>',['selectionAdjust','insert']); - - $mw->bind($class,'<Control-slash>',['selectionRange',0,'end']); - $mw->bind($class,'<Control-backslash>','selectionClear'); - - # $class->clipboardOperations($mw,qw[Copy Cut Paste]); - - $mw->bind($class,'<KeyPress>', ['Insert',Ev('A')]); - - # Ignore all Alt, Meta, and Control keypresses unless explicitly bound. - # Otherwise, if a widget binding for one of these is defined, the - # <KeyPress> class binding will also fire and insert the character, - # which is wrong. Ditto for Return, and Tab. - - $mw->bind($class,'<Alt-KeyPress>' ,'NoOp'); - $mw->bind($class,'<Meta-KeyPress>' ,'NoOp'); - $mw->bind($class,'<Control-KeyPress>' ,'NoOp'); - $mw->bind($class,'<Return>' ,'NoOp'); - $mw->bind($class,'<KP_Enter>' ,'NoOp'); - $mw->bind($class,'<Tab>' ,'NoOp'); - if ($mw->windowingsystem =~ /^(?:classic|aqua)$/) - { - $mw->bind($class,'<Command-KeyPress>', 'NoOp'); - } - - # On Windows, paste is done using Shift-Insert. Shift-Insert already - # generates the <<Paste>> event, so we don't need to do anything here. - if ($Tk::platform ne 'MSWin32') - { - $mw->bind($class,'<Insert>','InsertSelection'); - } - - if (!$Tk::strictMotif) - { - # Additional emacs-like bindings: - $mw->bind($class,'<Control-a>',['SetCursor',0]); - $mw->bind($class,'<Control-b>',['SetCursor',Ev('deltainsert',-1)]); - $mw->bind($class,'<Control-d>',['delete','insert']); - $mw->bind($class,'<Control-e>',['SetCursor','end']); - $mw->bind($class,'<Control-f>',['SetCursor',Ev('deltainsert',1)]); - $mw->bind($class,'<Control-h>','Backspace'); - $mw->bind($class,'<Control-k>',['delete','insert','end']); - - $mw->bind($class,'<Control-t>','Transpose'); - - # XXX The original Tcl/Tk bindings use NextWord/PreviousWord instead - $mw->bind($class,'<Meta-b>',['SetCursor',Ev(['wordstart'])]); - $mw->bind($class,'<Meta-d>',['delete','insert',Ev(['wordend'])]); - $mw->bind($class,'<Meta-f>',['SetCursor',Ev(['wordend'])]); - $mw->bind($class,'<Meta-BackSpace>',['delete',Ev(['wordstart']),'insert']); - $mw->bind($class,'<Meta-Delete>',['delete',Ev(['wordstart']),'insert']); - - # A few additional bindings from John Ousterhout. -# XXX conflicts with <<Copy>>: $mw->bind($class,'<Control-w>',['delete',Ev(['wordstart']),'insert']); - $mw->bind($class,'<2>','Button_2'); - $mw->bind($class,'<B2-Motion>','B2_Motion'); -# XXX superseded by <<PasteSelection>>: $mw->bind($class,'<ButtonRelease-2>','ButtonRelease_2'); - } - return $class; -} - - -sub Shift_1 -{ - my $w = shift; - my $Ev = $w->XEvent; - $Tk::selectMode = 'char'; - $w->selectionAdjust('@' . $Ev->x) -} - - -sub Control_1 -{ - my $w = shift; - my $Ev = $w->XEvent; - $w->icursor('@' . $Ev->x) -} - - -sub Delete -{ - my $w = shift; - if ($w->selectionPresent) - { - $w->deleteSelected - } - else - { - $w->delete('insert') - } -} - - -sub InsertSelection -{ - my $w = shift; - eval {local $SIG{__DIE__}; $w->Insert($w->GetSelection)} -} - - -# Original is ::tk::EntryScanMark -sub Button_2 -{ - my $w = shift; - my $Ev = $w->XEvent; - $w->scan('mark',$Ev->x); - $Tk::x = $Ev->x; - $Tk::y = $Ev->y; - $Tk::mouseMoved = 0 -} - - -# Original is ::tk::EntryScanDrag -sub B2_Motion -{ - my $w = shift; - my $Ev = $w->XEvent; - # Make sure these exist, as some weird situations can trigger the - # motion binding without the initial press. [Tcl/Tk Bug #220269] - if (!defined $Tk::x) { $Tk::x = $Ev->x } - if (abs(($Ev->x-$Tk::x)) > 2) - { - $Tk::mouseMoved = 1 - } - $w->scan('dragto',$Ev->x) -} - - -# XXX Not needed anymore -sub ButtonRelease_2 -{ - my $w = shift; - my $Ev = $w->XEvent; - if (!$Tk::mouseMoved) - { - eval - {local $SIG{__DIE__}; - $w->insert('insert',$w->SelectionGet); - $w->SeeInsert; - } - } -} - -sub Button1Release -{ - shift->CancelRepeat; -} - -# ::tk::EntryClosestGap -- -# Given x and y coordinates, this procedure finds the closest boundary -# between characters to the given coordinates and returns the index -# of the character just after the boundary. -# -# Arguments: -# w - The entry window. -# x - X-coordinate within the window. -sub ClosestGap -{ - my($w, $x) = @_; - my $pos = $w->index('@'.$x); - my @bbox = $w->bbox($pos); - if ($x - $bbox[0] < $bbox[2] / 2) - { - return $pos; - } - $pos + 1; -} - -# Button1 -- -# This procedure is invoked to handle button-1 presses in entry -# widgets. It moves the insertion cursor, sets the selection anchor, -# and claims the input focus. -# -# Arguments: -# w - The entry window in which the button was pressed. -# x - The x-coordinate of the button press. -sub Button1 -{ - my $w = shift; - my $x = shift; - $Tk::selectMode = 'char'; - $Tk::mouseMoved = 0; - $Tk::pressX = $x; - $w->icursor($w->ClosestGap($x)); - $w->selectionFrom('insert'); - $w->selectionClear; - if ($w->cget('-state') ne 'disabled') - { - $w->focus() - } -} - -sub Motion -{ - my ($w,$x,$y) = @_; - $Tk::x = $x; # XXX ? - $w->MouseSelect($x); -} - -# MouseSelect -- -# This procedure is invoked when dragging out a selection with -# the mouse. Depending on the selection mode (character, word, -# line) it selects in different-sized units. This procedure -# ignores mouse motions initially until the mouse has moved from -# one character to another or until there have been multiple clicks. -# -# Arguments: -# w - The entry window in which the button was pressed. -# x - The x-coordinate of the mouse. -sub MouseSelect -{ - - my $w = shift; - my $x = shift; - return if UNIVERSAL::isa($w, 'Tk::Spinbox') and $w->{_element} ne 'entry'; - $Tk::selectMode = shift if (@_); - my $cur = $w->index($w->ClosestGap($x)); - return unless defined $cur; - my $anchor = $w->index('anchor'); - return unless defined $anchor; - $Tk::pressX ||= $x; # XXX Better use "if !defined $Tk::pressX"? - if (($cur != $anchor) || (abs($Tk::pressX - $x) >= 3)) - { - $Tk::mouseMoved = 1 - } - my $mode = $Tk::selectMode; - return unless $mode; - if ($mode eq 'char') - { - # The Tcl version uses selectionRange here XXX - if ($Tk::mouseMoved) - { - if ($cur < $anchor) - { - $w->selectionTo($cur) - } - else - { - $w->selectionTo($cur+1) - } - } - } - elsif ($mode eq 'word') - { - # The Tcl version uses tcl_wordBreakBefore/After here XXX - if ($cur < $w->index('anchor')) - { - $w->selectionRange($w->wordstart($cur),$w->wordend($anchor-1)) - } - else - { - $w->selectionRange($w->wordstart($anchor),$w->wordend($cur)) - } - } - elsif ($mode eq 'line') - { - $w->selectionRange(0,'end') - } - if (@_) - { - my $ipos = shift; - eval {local $SIG{__DIE__}; $w->icursor($ipos) }; - } - $w->idletasks; -} -# ::tk::EntryPaste -- -# This procedure sets the insertion cursor to the current mouse position, -# pastes the selection there, and sets the focus to the window. -# -# Arguments: -# w - The entry window. -# x - X position of the mouse. -sub Paste -{ - my($w, $x) = @_; - $w->icursor($w->ClosestGap($x)); - eval { local $SIG{__DIE__}; - $w->insert("insert", $w->GetSelection); - $w->SeeInsert; # Perl/Tk extension - }; - if ($w->cget(-state) ne 'disabled') - { - $w->focus; - } -} -# AutoScan -- -# This procedure is invoked when the mouse leaves an entry window -# with button 1 down. It scrolls the window left or right, -# depending on where the mouse is, and reschedules itself as an -# 'after' command so that the window continues to scroll until the -# mouse moves back into the window or the mouse button is released. -# -# Arguments: -# w - The entry window. -# x - The x-coordinate of the mouse when it left the window. -sub AutoScan -{ - my $w = shift; - my $x = shift; - return if !Tk::Exists($w); - if ($x >= $w->width) - { - $w->xview('scroll',2,'units') - } - elsif ($x < 0) - { - $w->xview('scroll',-2,'units') - } - else - { - return; - } - $w->MouseSelect($x); - $w->RepeatId($w->after(50,['AutoScan',$w,$x])) -} -# KeySelect -# This procedure is invoked when stroking out selections using the -# keyboard. It moves the cursor to a new position, then extends -# the selection to that position. -# -# Arguments: -# w - The entry window. -# new - A new position for the insertion cursor (the cursor hasn't -# actually been moved to this position yet). -sub KeySelect -{ - my $w = shift; - my $new = shift; - if (!$w->selectionPresent) - { - $w->selectionFrom('insert'); - $w->selectionTo($new) - } - else - { - $w->selectionAdjust($new) - } - $w->icursor($new); - $w->SeeInsert; -} -# Insert -- -# Insert a string into an entry at the point of the insertion cursor. -# If there is a selection in the entry, and it covers the point of the -# insertion cursor, then delete the selection before inserting. -# -# Arguments: -# w - The entry window in which to insert the string -# s - The string to insert (usually just a single character) -sub Insert -{ - my $w = shift; - my $s = shift; - return unless (defined $s && $s ne ''); - eval - {local $SIG{__DIE__}; - my $insert = $w->index('insert'); - if ($w->index('sel.first') <= $insert && $w->index('sel.last') >= $insert) - { - $w->deleteSelected - } - }; - $w->insert('insert',$s); - $w->SeeInsert -} -# Backspace -- -# Backspace over the character just before the insertion cursor. -# -# Arguments: -# w - The entry window in which to backspace. -sub Backspace -{ - my $w = shift; - if ($w->selectionPresent) - { - $w->deleteSelected - } - else - { - my $x = $w->index('insert')-1; - $w->delete($x) if ($x >= 0); - # XXX Missing repositioning part from Tcl/Tk source - } -} -# SeeInsert -# Make sure that the insertion cursor is visible in the entry window. -# If not, adjust the view so that it is. -# -# Arguments: -# w - The entry window. -sub SeeInsert -{ - my $w = shift; - my $c = $w->index('insert'); -# -# Probably a bug in your version of tcl/tk (I've not this problem -# when I test Entry in the widget demo for tcl/tk) -# index('\@0') give always 0. Consequence : -# if you make <Control-E> or <Control-F> view is adapted -# but with <Control-A> or <Control-B> view is not adapted -# - my $left = $w->index('@0'); - if ($left > $c) - { - $w->xview($c); - return; - } - my $x = $w->width; - while ($w->index('@' . $x) <= $c && $left < $c) - { - $left += 1; - $w->xview($left) - } -} -# SetCursor -# Move the insertion cursor to a given position in an entry. Also -# clears the selection, if there is one in the entry, and makes sure -# that the insertion cursor is visible. -# -# Arguments: -# w - The entry window. -# pos - The desired new position for the cursor in the window. -sub SetCursor -{ - my $w = shift; - my $pos = shift; - $w->icursor($pos); - $w->selectionClear; - $w->SeeInsert; -} -# Transpose -# This procedure implements the 'transpose' function for entry widgets. -# It tranposes the characters on either side of the insertion cursor, -# unless the cursor is at the end of the line. In this case it -# transposes the two characters to the left of the cursor. In either -# case, the cursor ends up to the right of the transposed characters. -# -# Arguments: -# w - The entry window. -sub Transpose -{ - my $w = shift; - my $i = $w->index('insert'); - $i++ if ($i < $w->index('end')); - my $first = $i-2; - return if ($first < 0); - my $str = $w->get; - my $new = substr($str,$i-1,1) . substr($str,$first,1); - $w->delete($first,$i); - $w->insert('insert',$new); - $w->SeeInsert; -} - -sub tabFocus -{ - my $w = shift; - $w->selectionRange(0,'end'); - $w->icursor('end'); - $w->SUPER::tabFocus; -} - -# ::tk::EntryGetSelection -- -# -# Returns the selected text of the entry with respect to the -show option. -# -# Arguments: -# w - The entry window from which the text to get -sub getSelected -{ - my $w = shift; - return undef unless $w->selectionPresent; - my $str = $w->get; - my $show = $w->cget('-show'); - $str = $show x length($str) if (defined $show); - my $s = $w->index('sel.first'); - my $e = $w->index('sel.last'); - return substr($str,$s,$e-$s); -} - - -1; - -__END__ diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Event.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Event.pm deleted file mode 100644 index cecd57c54ae..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Event.pm +++ /dev/null @@ -1,13 +0,0 @@ -package Tk::Event; -use vars qw($VERSION $XS_VERSION @EXPORT_OK); -END { CleanupGlue() } -$VERSION = sprintf '4.%03d', q$Revision: #15 $ =~ /\D(\d+)\s*$/; -$XS_VERSION = '804.027'; -use base qw(Exporter); -use XSLoader; -@EXPORT_OK = qw($XS_VERSION DONT_WAIT WINDOW_EVENTS FILE_EVENTS - TIMER_EVENTS IDLE_EVENTS ALL_EVENTS); -XSLoader::load 'Tk::Event',$XS_VERSION; -require Tk::Event::IO; -1; -__END__ diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Event/IO.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Event/IO.pm deleted file mode 100644 index 10b47e246ff..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Event/IO.pm +++ /dev/null @@ -1,132 +0,0 @@ -package Tk::Event::IO; -use strict; -use Carp; - -use vars qw($VERSION @EXPORT_OK); -$VERSION = sprintf '4.%03d', q$Revision: #8 $ =~ /\D(\d+)\s*$/; - -use base qw(Exporter); -use Symbol (); - -@EXPORT_OK = qw(READABLE WRITABLE); - -sub PrintArgs -{ - my $func = (caller(1))[3]; - print "$func(",join(',',@_),")\n"; -} - -sub PRINT -{ - my $obj = shift; - $obj->wait(WRITABLE); - my $h = $obj->handle; - return print $h @_; -} - -sub PRINTF -{ - my $obj = shift; - $obj->wait(WRITABLE); - my $h = $obj->handle; - return printf $h @_; -} - -sub WRITE -{ - my $obj = $_[0]; - $obj->wait(WRITABLE); - return syswrite($obj->handle,$_[1],$_[2]); -} - -my $depth = 0; -sub READLINE -{ - my $obj = shift; - $obj->wait(READABLE); - my $h = $obj->handle; - my $w = <$h>; - return $w; -} - -sub READ -{ - my $obj = $_[0]; - $obj->wait(READABLE); - my $h = $obj->handle; - return sysread($h,$_[1],$_[2],defined $_[3] ? $_[3] : 0); -} - -sub GETC -{ - my $obj = $_[0]; - $obj->wait(READABLE); - my $h = $obj->handle; - return getc($h); -} - -sub CLOSE -{ - my $obj = shift; - $obj->unwatch; - my $h = $obj->handle; - return close($h); -} - -sub EOF -{ - my $obj = shift; - my $h = $obj->handle; - return eof($h); -} - -sub FILENO -{ - my $obj = shift; - my $h = $obj->handle; - return fileno($h); -} - -sub imode -{ - my $mode = shift; - my $imode = ${{'readable' => READABLE(), - 'writable' => WRITABLE()}}{$mode}; - croak("Invalid handler type '$mode'") unless (defined $imode); - return $imode; -} - -sub fileevent -{ - my ($widget,$file,$mode,$cb) = @_; - my $imode = imode($mode); - unless (ref $file) - { - no strict 'refs'; - $file = Symbol::qualify($file,(caller)[0]); - $file = \*{$file}; - } - my $obj = tied(*$file); - unless ($obj && $obj->isa('Tk::Event::IO')) - { - $obj = tie *$file,'Tk::Event::IO', $file; - } - if (@_ == 3) - { - # query return the handler - return $obj->handler($imode); - } - else - { - # set the handler - my $h = $obj->handler($imode,$cb); - undef $obj; # Prevent warnings about untie with ref to object - unless ($h) - { - untie *$file; - } - } -} - -1; -__END__ diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Frame.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Frame.pm deleted file mode 100644 index a5716cdf9bd..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Frame.pm +++ /dev/null @@ -1,378 +0,0 @@ -# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved. -# This program is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. -package Tk::Frame; -require Tk::Widget; -require Tk::Derived; -use AutoLoader; -use strict qw(vars); -use Carp; - -use base qw(Tk::Derived Tk::Widget); - -Construct Tk::Widget 'Frame'; - -use vars qw($VERSION); -$VERSION = '4.010'; # $Id: //depot/Tkutf8/Tk/Frame.pm#10 $ - -sub Tk_cmd { \&Tk::frame } - -sub CreateOptions -{ - return (shift->SUPER::CreateOptions,'-colormap','-visual','-container') -} - -sub Default -{ - my ($cw,$name,$widget) = @_; - confess 'No name' unless (defined $name); - croak 'No widget' unless (defined $widget); - $cw->Delegates(DEFAULT => $widget); - $cw->ConfigSpecs(DEFAULT => [$widget]); - $widget->pack('-expand' => 1, -fill => 'both') unless ($widget->manager); # Suspect - $cw->Advertise($name,$widget); -} - -sub ConfigDelegate -{ - my ($cw,$name,@skip) = @_; - my $sw = $cw->Subwidget($name); - my $sc; - my %skip = (); - foreach $sc (@skip) - { - $skip{$sc} = 1; - } - foreach $sc ($sw->configure) - { - my (@info) = @$sc; - next if (@info == 2); - my $option = $info[0]; - unless ($skip{$option}) - { - $option =~ s/^-(.*)/-$name\u$1/; - $info[0] = Tk::Configure->new($sw,$info[0]); - pop(@info); - $cw->ConfigSpecs($option => \@info); - } - } -} - -sub bind -{my ($cw,@args) = @_; - $cw->Delegate('bind',@args); -} - -sub menu -{my ($cw,@args) = @_; - $cw->Delegate('menu',@args); -} - -sub focus -{my ($cw,@args) = @_; - $cw->Delegate('focus',@args); -} - -#sub bindtags -#{my ($cw,@args) = @_; -# $cw->Delegate('bindtags',@args); -#} - -sub selection -{my ($cw,@args) = @_; - $cw->Delegate('selection',@args); -} - -sub autoLabel { 1 } - -sub Populate -{ - my ($cw,$args) = @_; - if ($cw->autoLabel) - { - $cw->ConfigSpecs('-labelPack' => [ 'METHOD', undef, undef, undef]); - $cw->ConfigSpecs('-labelVariable' => [ 'METHOD', undef, undef, undef]); - $cw->ConfigSpecs('-label' => [ 'METHOD', undef, undef, undef]); - $cw->labelPack([]) if grep /^-label\w+/, keys %$args; - } -} - -sub Menubar -{ - my $frame = shift; - my $menu = $frame->cget('-menu'); - if (defined $menu) - { - $menu->configure(@_) if @_; - } - else - { - $menu = $frame->Menu(-type => 'menubar',@_); - $frame->configure('-menu' => $menu); - } - $frame->Advertise('menubar' => $menu); - return $menu; -} - -1; - -__END__ - -sub labelPack -{ - my ($cw,$val) = @_; - my $w = $cw->Subwidget('label'); - my @result = (); - if (@_ > 1) - { - if (defined($w) && !defined($val)) - { - $w->packForget; - } - elsif (defined($val) && !defined ($w)) - { - require Tk::Label; - $w = Tk::Label->new($cw,-textvariable => $cw->labelVariable); - $cw->Advertise('label' => $w); - $cw->ConfigDelegate('label',qw(-text -textvariable)); - } - if (defined($val) && defined($w)) - { - my %pack = @$val; - unless (exists $pack{-side}) - { - $pack{-side} = 'top' unless (exists $pack{-side}); - } - unless (exists $pack{-fill}) - { - $pack{-fill} = 'x' if ($pack{-side} =~ /(top|bottom)/); - $pack{-fill} = 'y' if ($pack{-side} =~ /(left|right)/); - } - unless (exists($pack{'-before'}) || exists($pack{'-after'})) - { - my $before = ($cw->packSlaves)[0]; - $pack{'-before'} = $before if (defined $before); - } - $w->pack(%pack); - } - } - @result = $w->packInfo if (defined $w); - return (wantarray) ? @result : \@result; -} - -sub labelVariable -{ - my ($cw,$val) = @_; - my $var = \$cw->{Configure}{'-labelVariable'}; - if (@_ > 1 && defined $val) - { - $$var = $val; - $$val = '' unless (defined $$val); - my $w = $cw->Subwidget('label'); - unless (defined $w) - { - $cw->labelPack([]); - $w = $cw->Subwidget('label'); - } - $w->configure(-textvariable => $val); - } - return $$var; -} - -sub label -{ - my ($cw,$val) = @_; - my $var = $cw->cget('-labelVariable'); - if (@_ > 1 && defined $val) - { - if (!defined $var) - { - $var = \$cw->{Configure}{'-label'}; - $cw->labelVariable($var); - } - $$var = $val; - } - return (defined $var) ? $$var : undef;; -} - -sub queuePack -{ - my ($cw) = @_; - unless ($cw->{'pack_pending'}) - { - $cw->{'pack_pending'} = 1; - $cw->afterIdle([$cw,'packscrollbars']); - } -} - -sub sbset -{ - my ($cw,$sb,$ref,@args) = @_; - $sb->set(@args); - $cw->queuePack if (@args == 2 && $sb->Needed != $$ref); -} - -sub freeze_on_map -{ - my ($w) = @_; - unless ($w->Tk::bind('Freeze','<Map>')) - { - $w->Tk::bind('Freeze','<Map>',['packPropagate' => 0]) - } - $w->AddBindTag('Freeze'); -} - -sub AddScrollbars -{ - require Tk::Scrollbar; - my ($cw,$w) = @_; - my $def = ''; - my ($x,$y) = ('',''); - my $s = 0; - my $c; - $cw->freeze_on_map; - foreach $c ($w->configure) - { - my $opt = $c->[0]; - if ($opt eq '-yscrollcommand') - { - my $slice = Tk::Frame->new($cw,Name => 'ysbslice'); - my $ysb = Tk::Scrollbar->new($slice,-orient => 'vertical', -command => [ 'yview', $w ]); - my $size = $ysb->cget('-width'); - my $corner = Tk::Frame->new($slice,Name=>'corner','-relief' => 'raised', - '-width' => $size, '-height' => $size); - $ysb->pack(-side => 'left', -fill => 'y'); - $cw->Advertise('yscrollbar' => $ysb); - $cw->Advertise('corner' => $corner); - $cw->Advertise('ysbslice' => $slice); - $corner->{'before'} = $ysb->PathName; - $slice->{'before'} = $w->PathName; - $y = 'w'; - $s = 1; - } - elsif ($opt eq '-xscrollcommand') - { - my $xsb = Tk::Scrollbar->new($cw,-orient => 'horizontal', -command => [ 'xview', $w ]); - $cw->Advertise('xscrollbar' => $xsb); - $xsb->{'before'} = $w->PathName; - $x = 's'; - $s = 1; - } - } - if ($s) - { - $cw->Advertise('scrolled' => $w); - $cw->ConfigSpecs('-scrollbars' => ['METHOD','scrollbars','Scrollbars',$x.$y]); - } -} - -sub packscrollbars -{ - my ($cw) = @_; - my $opt = $cw->cget('-scrollbars'); - my $slice = $cw->Subwidget('ysbslice'); - my $xsb = $cw->Subwidget('xscrollbar'); - my $corner = $cw->Subwidget('corner'); - my $w = $cw->Subwidget('scrolled'); - my $xside = (($opt =~ /n/) ? 'top' : 'bottom'); - my $havex = 0; - my $havey = 0; - $opt =~ s/r//; - $cw->{'pack_pending'} = 0; - if (defined $slice) - { - my $reqy; - my $ysb = $cw->Subwidget('yscrollbar'); - if ($opt =~ /(o)?[we]/ && (($reqy = !defined($1)) || $ysb->Needed)) - { - my $yside = (($opt =~ /w/) ? 'left' : 'right'); - $slice->pack(-side => $yside, -fill => 'y',-before => $slice->{'before'}); - $havey = 1; - if ($reqy) - { - $w->configure(-yscrollcommand => ['set', $ysb]); - } - else - { - $w->configure(-yscrollcommand => ['sbset', $cw, $ysb, \$cw->{'packysb'}]); - } - } - else - { - $w->configure(-yscrollcommand => undef) unless $opt =~ s/[we]//; - $slice->packForget; - } - $cw->{'packysb'} = $havey; - } - if (defined $xsb) - { - my $reqx; - if ($opt =~ /(o)?[ns]/ && (($reqx = !defined($1)) || $xsb->Needed)) - { - $xsb->pack(-side => $xside, -fill => 'x',-before => $xsb->{'before'}); - $havex = 1; - if ($reqx) - { - $w->configure(-xscrollcommand => ['set', $xsb]); - } - else - { - $w->configure(-xscrollcommand => ['sbset', $cw, $xsb, \$cw->{'packxsb'}]); - } - } - else - { - $w->configure(-xscrollcommand => undef) unless $opt =~ s/[ns]//; - $xsb->packForget; - } - $cw->{'packxsb'} = $havex; - } - if (defined $corner) - { - if ($havex && $havey && defined $corner->{'before'}) - { - my $anchor = $opt; - $anchor =~ s/o//g; - $corner->configure(-height => $xsb->ReqHeight); - $corner->pack(-before => $corner->{'before'}, -side => $xside, - -anchor => $anchor, -fill => 'x'); - } - else - { - $corner->packForget; - } - } -} - -sub scrollbars -{ - my ($cw,$opt) = @_; - my $var = \$cw->{'-scrollbars'}; - if (@_ > 1) - { - my $old = $$var; - if (!defined $old || $old ne $opt) - { - $$var = $opt; - $cw->queuePack; - } - } - return $$var; -} - -sub FindMenu -{ - my ($w,$char) = @_; - my $child; - my $match; - foreach $child ($w->children) - { - next unless (ref $child); - $match = $child->FindMenu($char); - return $match if (defined $match); - } - return undef; -} - - - diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Image.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Image.pm deleted file mode 100644 index 0f41c387fc2..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Image.pm +++ /dev/null @@ -1,74 +0,0 @@ -# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved. -# This program is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. -package Tk::Image; - -# This module does for images what Tk::Widget does for widgets: -# provides a base class for them to inherit from. -require DynaLoader; - -use base qw(DynaLoader Tk); # but are they ? - -use vars qw($VERSION); -$VERSION = '4.011'; # $Id: //depot/Tkutf8/Tk/Image.pm#11 $ - -sub new -{ - my $package = shift; - my $widget = shift; - $package->InitClass($widget); - my $leaf = $package->Tk_image; - my $obj = $widget->Tk::image('create',$leaf,@_); - $obj = $widget->_object($obj) unless (ref $obj); - return bless $obj,$package; -} - -sub Install -{ - # Dynamically loaded image types can install standard images here - my ($class,$mw) = @_; -} - -sub ClassInit -{ - # Carry out class bindings (or whatever) - my ($package,$mw) = @_; - return $package; -} - -require Tk::Submethods; - -Direct Tk::Submethods ('image' => [qw(delete width height type)]); - -sub Tk::Widget::imageNames -{ - my $w = shift; - $w->image('names',@_); -} - -sub Tk::Widget::imageTypes -{ - my $w = shift; - map("\u$_",$w->image('types',@_)); -} - -sub Construct -{ - my ($base,$name) = @_; - my $class = (caller(0))[0]; - - # Hack for broken ->isa in perl5.6.0 - delete ${"$class\::"}{'::ISA::CACHE::'} if $] == 5.006; - - *{"Tk::Widget::$name"} = sub { $class->new(@_) }; -} - -# This is here to prevent AUTOLOAD trying to find it. -sub DESTROY -{ - my $i = shift; - # maybe do image delete ??? -} - - -1; diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Label.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Label.pm deleted file mode 100644 index ebea1741c2f..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Label.pm +++ /dev/null @@ -1,21 +0,0 @@ -# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved. -# This program is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. - -package Tk::Label; -require Tk; - - -use vars qw($VERSION); -$VERSION = '4.006'; # $Id: //depot/Tkutf8/Tk/Label.pm#6 $ - -use base qw(Tk::Widget); - -Construct Tk::Widget 'Label'; - -sub Tk_cmd { \&Tk::label } - -1; - - - diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/MainWindow.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/MainWindow.pm deleted file mode 100644 index 5384ccb560b..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/MainWindow.pm +++ /dev/null @@ -1,213 +0,0 @@ -# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved. -# This program is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. -package Tk::MainWindow; -use base qw(Tk::Toplevel); -BEGIN { @MainWindow::ISA = 'Tk::MainWindow' } - -use strict; - -use vars qw($VERSION); -$VERSION = sprintf '4.%03d', q$Revision: #12 $ =~ /\D(\d+)\s*$/; - -use Tk::CmdLine; -use Tk qw(catch); -require Tk::Toplevel; - -use Carp; - -$| = 1; - -my $pid = $$; - -my %Windows = (); - -sub CreateArgs -{ - my ($class,$args) = @_; - my $cmd = Tk::CmdLine->CreateArgs(); - my $key; - foreach $key (keys %$cmd) - { - $args->{$key} = $cmd->{$key} unless exists $args->{$key}; - } - my %result = $class->SUPER::CreateArgs(undef,$args); - my $name = delete($args->{'-name'}); - unless (Tk::tainting) - { - $ENV{'DISPLAY'} = ':0' unless (exists $ENV{'DISPLAY'}); - $result{'-screen'} = $ENV{'DISPLAY'} unless exists $result{'-screen'}; - } - return (-name => "\l$name",%result); -} - -sub new -{ - my $package = shift; - if (@_ > 0 && $_[0] =~ /:\d+(\.\d+)?$/) - { - carp "Usage $package->new(-screen => '$_[0]' ...)" if $^W; - unshift(@_,'-screen'); - } - croak('Odd number of args'."$package->new(" . join(',',@_) .')') if @_ % 2; - my %args = @_; - - my $top = eval { bless Create($package->CreateArgs(\%args)), $package }; - croak($@ . "$package->new(" . join(',',@_) .')') if ($@); - $top->apply_command_line; - $top->InitBindings; - $top->SetBindtags; - $top->InitObject(\%args); - eval { $top->configure(%args) }; - croak "$@" if ($@); - if (($top->positionfrom||'') ne 'user' and ($top->sizefrom||'') ne 'user') { - my $geometry = $top->optionGet(qw(geometry Geometry)); - if ($geometry) { - $top->geometry($geometry); - } - } - $Windows{$top} = $top; - return $top; -} - -sub _Destroyed -{ - my $top = shift; - $top->SUPER::_Destroyed; - delete $Windows{$top}; -} - -sub InitBindings -{ - my $mw = shift; - $mw->bind('all','<Tab>','focusNext'); - # <<LeftTab>> is named <<PrevWindow>> in Tcl/Tk - $mw->eventAdd(qw[<<LeftTab>> <Shift-Tab>]); - # This is needed for XFree86 systems - catch { $mw->eventAdd(qw[<<LeftTab>> <ISO_Left_Tab>]) }; - # This seems to be correct on *some* HP systems. - catch { $mw->eventAdd(qw[<<LeftTab>> <hpBackTab>]) }; - $mw->bind('all','<<LeftTab>>','focusPrev'); - if ($mw->windowingsystem eq 'x11') - { - $mw->eventAdd(qw[<<Cut>> <Control-Key-x> <Key-F20> <Meta-Key-w>]); - $mw->eventAdd(qw[<<Copy>> <Control-Key-c> <Key-F16> <Control-Key-w>]); - $mw->eventAdd(qw[<<Paste>> <Control-Key-v> <Key-F18> <Control-Key-y>]); - $mw->eventAdd(qw[<<PasteSelection>> <ButtonRelease-2>]); - $mw->eventAdd(qw[<<Undo>> <Control-Key-z> <Key-Undo> <Key-F14> - <Control-Key-underscore>]); - $mw->eventAdd(qw[<<Redo>> <Control-Key-y> <Shift-Key-Undo> <Key-F12> <Shift-Key-F14>]); - } - elsif ($mw->windowingsystem eq 'win32') - { - $mw->eventAdd(qw[<<Cut>> <Control-Key-x> <Shift-Key-Delete>]); - $mw->eventAdd(qw[<<Copy>> <Control-Key-c> <Control-Key-Insert>]); - $mw->eventAdd(qw[<<Paste>> <Control-Key-v> <Shift-Key-Insert>]); - $mw->eventAdd(qw[<<Undo>> <Control-Key-z>]); - $mw->eventAdd(qw[<<Redo>> <Control-Key-y>]); - } - elsif ($mw->windowingsystem eq 'aqua') - { - $mw->eventAdd(qw[<<Cut>> <Command-Key-x> <Key-F2>]); - $mw->eventAdd(qw[<<Copy>> <Command-Key-c> <Key-F3>]); - $mw->eventAdd(qw[<<Paste>> <Command-Key-v> <Key-F4>]); - $mw->eventAdd(qw[<<PasteSelection>> <ButtonRelease-2>]); - $mw->eventAdd(qw[<<Clear>> <Clear>]); - $mw->eventAdd(qw[<<Undo>> <Command-Key-z>]); - $mw->eventAdd(qw[<<Redo>> <Command-Key-y>]); - } - elsif ($mw->windowingsystem eq 'classic') - { - $mw->eventAdd(qw[<<Cut>> <Control-Key-x> <Key-F2>]); - $mw->eventAdd(qw[<<Copy>> <Control-Key-c> <Key-F3>]); - $mw->eventAdd(qw[<<Paste>> <Control-Key-v> <Key-F4>]); - $mw->eventAdd(qw[<<PasteSelection>> <ButtonRelease-2>]); - $mw->eventAdd(qw[<<Clear>> <Clear>]); - $mw->eventAdd(qw[<<Undo>> <Control-Key-z> <Key-F1>]); - $mw->eventAdd(qw[<<Redo>> <Control-Key-Z>]); - } - - # FIXME - Should these move to Menubutton ? - my $c = ($Tk::platform eq 'unix') ? 'all' : 'Tk::Menubutton'; - $mw->bind($c,'<Alt-KeyPress>',['TraverseToMenu',Tk::Ev('K')]); - $mw->bind($c,'<F10>','FirstMenu'); -} - -sub Existing -{ - my @Windows; - foreach my $name (keys %Windows) - { - my $obj = $Windows{$name}; - if (Tk::Exists($obj)) - { - push(@Windows,$obj); - } - else - { - delete $Windows{$name}; - } - } - return @Windows; -} - -END -{ - if (Tk::IsParentProcess()) - { - foreach my $top (values %Windows) - { - if ($top->IsWidget) - { - # Tk data structuctures are still in place - # this can occur if non-callback perl code did a 'die'. - # It will also handle some cases of non-Tk 'exit' being called - # Destroy this mainwindow and hence is descendants ... - $top->destroy; - } - } - } -} - -sub CmdLine { return shift->command } - -sub WMSaveYourself -{ - my $mw = shift; - my @args = @{$mw->command}; -# warn 'preWMSaveYourself:'.join(' ',@args)."\n"; - @args = ($0) unless (@args); - my $i = 1; - while ($i < @args) - { - if ($args[$i] eq '-iconic') - { - splice(@args,$i,1); - } - elsif ($args[$i] =~ /^-(geometry|iconposition)$/) - { - splice(@args,$i,2); - } - } - - my @ip = $mw->wm('iconposition'); -# print 'ip ',join(',',@ip),"\n"; - my $icon = $mw->iconwindow; - if (defined($icon)) - { - @ip = $icon->geometry =~ /\d+x\d+([+-]\d+)([+-]\d+)/; - } - splice(@args,1,0,'-iconposition' => join(',',@ip)) if (@ip == 2); - - splice(@args,1,0,'-iconic') if ($mw->state() eq 'iconic'); - - splice(@args,1,0,'-geometry' => $mw->geometry); -# warn 'postWMSaveYourself:'.join(' ',@args)."\n"; - $mw->command([@args]); -} - -1; - -__END__ - -=cut diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/PNG.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/PNG.pm deleted file mode 100644 index 1ecb4001d17..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/PNG.pm +++ /dev/null @@ -1,43 +0,0 @@ -package Tk::PNG; -require DynaLoader; - -use vars qw($VERSION); -$VERSION = sprintf '4.%03d', q$Revision: #3 $ =~ /\D(\d+)\s*$/; - -use Tk 800.005; -require Tk::Image; -require Tk::Photo; - -use base qw(DynaLoader); - -bootstrap Tk::PNG $Tk::VERSION; - -1; - -__END__ - -=head1 NAME - -Tk::PNG - PNG loader for Tk::Photo - -=head1 SYNOPSIS - - use Tk; - use Tk::PNG; - - my $image = $widget->Photo('-format' => 'png', -file => 'something.png'); - - -=head1 DESCRIPTION - -This is an extension for Tk800.* which supplies -PNG format loader for Photo image type. - - -=head1 AUTHOR - -Nick Ing-Simmons E<lt>nick@ing-simmons.netE<gt> - -=cut - - diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Photo.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Photo.pm deleted file mode 100644 index a596dc4d78b..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Photo.pm +++ /dev/null @@ -1,22 +0,0 @@ -package Tk::Photo; - -use vars qw($VERSION); -$VERSION = sprintf '4.%03d', 4+q$Revision: #4 $ =~ /\D(\d+)\s*$/; - -use Tk qw($XS_VERSION); - -use base qw(Tk::Image); - -Construct Tk::Image 'Photo'; - -sub Tk_image { 'photo' } - -Tk::Methods('blank','copy','data','formats','get','put','read', - 'redither','transparency','write'); - -use Tk::Submethods ( - 'transparency' => [qw/get set/], -); - -1; -__END__ diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Pretty.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Pretty.pm deleted file mode 100644 index 7e442a4bcbc..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Pretty.pm +++ /dev/null @@ -1,93 +0,0 @@ -# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved. -# This program is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. -package Tk::Pretty; -require Exporter; - -use vars qw($VERSION @EXPORT); -$VERSION = '4.006'; # $Id: //depot/Tkutf8/Tk/Pretty.pm#6 $ - -use base qw(Exporter); - -@EXPORT = qw(Pretty PrintArgs); - -sub pretty_list -{ - join(',',map(&Pretty($_),@_)); -} - -sub Pretty -{ - return pretty_list(@_) if (@_ > 1); - my $obj = shift; - return 'undef' unless defined($obj); - my $type = "$obj"; - return $type if ($type =~ /=HASH/ && exists($obj->{"_Tcl_CmdInfo_\0"})); - my $result = ''; - if (ref $obj) - { - my $class; - if ($type =~ /^([^=]+)=(.*)$/) - { - $class = $1; - $type = $2; - $result .= 'bless('; - } - if ($type =~ /^ARRAY/) - { - $result .= '['; - $result .= pretty_list(@$obj); - $result .= ']'; - } - elsif ($type =~ /^HASH/) - { - $result .= '{'; - if (%$obj) - { - my ($key, $value); - while (($key,$value) = each %$obj) - { - $result .= $key . '=>' . Pretty($value) . ','; - } - chop($result); - } - $result .= '}'; - } - elsif ($type =~ /^REF/) - { - $result .= "\\" . Pretty($$obj); - } - elsif ($type =~ /^SCALAR/) - { - $result .= Pretty($$obj); - } - else - { - $result .= $type; - } - $result .= ",$class)" if (defined $class); - } - else - { - if ($obj =~ /^-?[0-9]+(.[0-9]*(e[+-][0-9]+)?)?$/ || - $obj =~ /^[A-Z_][A-Za-z_0-9]*$/ || - $obj =~ /^[a-z_][A-Za-z_0-9]*[A-Z_][A-Za-z_0-9]*$/ - ) - { - $result .= $obj; - } - else - { - $result .= "'" . $obj . "'"; - } - } - return $result; -} - -sub PrintArgs -{ - my $name = (caller(1))[3]; - print "$name(",Pretty(@_),")\n"; -} - -1; diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Radiobutton.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Radiobutton.pm deleted file mode 100644 index d09d41b4208..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Radiobutton.pm +++ /dev/null @@ -1,45 +0,0 @@ -# Conversion from Tk4.0 button.tcl competed. -# Copyright (c) 1992-1994 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. -# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved. -# This program is free software; you can redistribute it and/or - -package Tk::Radiobutton; - -use vars qw($VERSION); -$VERSION = '4.006'; # $Id: //depot/Tkutf8/Tk/Radiobutton.pm#6 $ - -# modify it under the same terms as Perl itself, subject -# to additional disclaimer in license.terms due to partial -# derivation from Tk4.0 sources. - -require Tk::Button; - - -use base qw(Tk::Button); -Construct Tk::Widget 'Radiobutton'; - -sub Tk_cmd { \&Tk::radiobutton } - -sub CreateOptions -{ - return (shift->SUPER::CreateOptions,'-variable'); -} - -sub ClassInit -{ - my ($class,$mw) = @_; - $mw->bind($class,'<Enter>', 'Enter'); - $mw->bind($class,'<Leave>', 'Leave'); - $mw->bind($class,'<1>', 'Invoke'); - $mw->bind($class,'<space>', 'Invoke'); - return $class; -} - -sub Invoke -{ - my $w = shift; - $w->invoke() unless($w->cget('-state') eq 'disabled'); -} - -1; diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Submethods.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Submethods.pm deleted file mode 100644 index a2b8e3bd186..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Submethods.pm +++ /dev/null @@ -1,46 +0,0 @@ -package Tk::Submethods; - -use vars qw($VERSION); -$VERSION = '4.004'; # $Id: //depot/Tkutf8/Tk/Submethods.pm#4 $ - -sub import -{ - my $class = shift; - no strict 'refs'; - my $package = caller(0); - while (@_) - { - my $fn = shift; - my $sm = shift; - foreach my $sub (@{$sm}) - { - my ($suffix) = $sub =~ /(\w+)$/; - my $pfn = $package.'::'.$fn; - *{$pfn."\u$suffix"} = sub { shift->$pfn($sub,@_) }; - } - } -} - -sub Direct -{ - my $class = shift; - no strict 'refs'; - my $package = caller(0); - while (@_) - { - my $fn = shift; - my $sm = shift; - my $sub; - foreach $sub (@{$sm}) - { - # eval "sub ${package}::${sub} { shift->$fn('$sub',\@_) }"; - *{$package.'::'.$sub} = sub { shift->$fn($sub,@_) }; - } - } -} - -1; - -__END__ - -=cut diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Toplevel.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Toplevel.pm deleted file mode 100644 index 7bcd156d475..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Toplevel.pm +++ /dev/null @@ -1,211 +0,0 @@ -# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved. -# This program is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. -package Tk::Toplevel; -use AutoLoader; - -use vars qw($VERSION); -$VERSION = '4.006'; # $Id: //depot/Tkutf8/Tk/Toplevel.pm#6 $ - -use base qw(Tk::Wm Tk::Frame); - -Construct Tk::Widget 'Toplevel'; - -sub Tk_cmd { \&Tk::toplevel } - -sub CreateOptions -{ - return (shift->SUPER::CreateOptions,'-screen','-use') -} - -sub Populate -{ - my ($cw,$arg) = @_; - $cw->SUPER::Populate($arg); - $cw->ConfigSpecs('-title',['METHOD',undef,undef,$cw->class]); -} - -sub Icon -{ - my ($top,%args) = @_; - my $icon = $top->iconwindow; - my $state = $top->state; - if ($state ne 'withdrawn') - { - $top->withdraw; - $top->update; # Let attributes propogate - } - unless (defined $icon) - { - $icon = Tk::Toplevel->new($top,'-borderwidth' => 0,'-class'=>'Icon'); - $icon->withdraw; - # Fake Populate - my $lab = $icon->Component('Label' => 'icon'); - $lab->pack('-expand'=>1,'-fill' => 'both'); - $icon->ConfigSpecs(DEFAULT => ['DESCENDANTS']); - # Now do tail of InitObject - $icon->ConfigDefault(\%args); - # And configure that new would have done - $top->iconwindow($icon); - $top->update; - $lab->DisableButtonEvents; - $lab->update; - } - $top->iconimage($args{'-image'}) if (exists $args{'-image'}); - $icon->configure(%args); - $icon->idletasks; # Let size request propogate - $icon->geometry($icon->ReqWidth . 'x' . $icon->ReqHeight); - $icon->update; # Let attributes propogate - $top->deiconify if ($state eq 'normal'); - $top->iconify if ($state eq 'iconic'); -} - -sub menu -{ - my $w = shift; - my $menu; - $menu = $w->cget('-menu'); - unless (defined $menu) - { - $w->configure(-menu => ($menu = $w->SUPER::menu)) - } - $menu->configure(@_) if @_; - return $menu; -} - - -1; -__END__ - -#---------------------------------------------------------------------- -# -# Focus Group -# -# Focus groups are used to handle the user's focusing actions inside a -# toplevel. -# -# One example of using focus groups is: when the user focuses on an -# entry, the text in the entry is highlighted and the cursor is put to -# the end of the text. When the user changes focus to another widget, -# the text in the previously focused entry is validated. -# - -#---------------------------------------------------------------------- -# tkFocusGroup_Create -- -# -# Create a focus group. All the widgets in a focus group must be -# within the same focus toplevel. Each toplevel can have only -# one focus group, which is identified by the name of the -# toplevel widget. -# -sub FG_Create { - my $t = shift; - unless (exists $t->{'_fg'}) { - $t->{'_fg'} = 1; - $t->bind('<FocusIn>', sub { - my $w = shift; - my $Ev = $w->XEvent; - $t->FG_In($w, $Ev->d); - } - ); - $t->bind('<FocusOut>', sub { - my $w = shift; - my $Ev = $w->XEvent; - $t->FG_Out($w, $Ev->d); - } - ); - $t->bind('<Destroy>', sub { - my $w = shift; - my $Ev = $w->XEvent; - $t->FG_Destroy($w); - } - ); - # <Destroy> is not sufficient to break loops if never mapped. - $t->OnDestroy([$t,'FG_Destroy']); - } -} - -# tkFocusGroup_BindIn -- -# -# Add a widget into the "FocusIn" list of the focus group. The $cmd will be -# called when the widget is focused on by the user. -# -sub FG_BindIn { - my($t, $w, $cmd) = @_; - $t->Error("focus group \"$t\" doesn't exist") unless (exists $t->{'_fg'}); - $t->{'_FocusIn'}{$w} = Tk::Callback->new($cmd); -} - -# tkFocusGroup_BindOut -- -# -# Add a widget into the "FocusOut" list of the focus group. The -# $cmd will be called when the widget loses the focus (User -# types Tab or click on another widget). -# -sub FG_BindOut { - my($t, $w, $cmd) = @_; - $t->Error("focus group \"$t\" doesn't exist") unless (exists $t->{'_fg'}); - $t->{'_FocusOut'}{$w} = Tk::Callback->new($cmd); -} - -# tkFocusGroup_Destroy -- -# -# Cleans up when members of the focus group is deleted, or when the -# toplevel itself gets deleted. -# -sub FG_Destroy { - my($t, $w) = @_; - if (!defined($w) || $t == $w) { - delete $t->{'_fg'}; - delete $t->{'_focus'}; - delete $t->{'_FocusOut'}; - delete $t->{'_FocusIn'}; - } else { - if (exists $t->{'_focus'}) { - delete $t->{'_focus'} if ($t->{'_focus'} == $w); - } - delete $t->{'_FocusIn'}{$w}; - delete $t->{'_FocusOut'}{$w}; - } -} - -# tkFocusGroup_In -- -# -# Handles the <FocusIn> event. Calls the FocusIn command for the newly -# focused widget in the focus group. -# -sub FG_In { - my($t, $w, $detail) = @_; - if (defined $t->{'_focus'} and $t->{'_focus'} eq $w) { - # This is already in focus - return; - } else { - $t->{'_focus'} = $w; - $t->{'_FocusIn'}{$w}->Call if exists $t->{'_FocusIn'}{$w}; - } -} - -# tkFocusGroup_Out -- -# -# Handles the <FocusOut> event. Checks if this is really a lose -# focus event, not one generated by the mouse moving out of the -# toplevel window. Calls the FocusOut command for the widget -# who loses its focus. -# -sub FG_Out { - my($t, $w, $detail) = @_; - if ($detail ne 'NotifyNonlinear' and $detail ne 'NotifyNonlinearVirtual') { - # This is caused by mouse moving out of the window - return; - } - unless (exists $t->{'_FocusOut'}{$w}) { - return; - } else { - $t->{'_FocusOut'}{$w}->Call; - delete $t->{'_focus'}; - } -} - -1; - -__END__ diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Widget.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Widget.pm deleted file mode 100644 index e94c037e6fe..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Widget.pm +++ /dev/null @@ -1,1510 +0,0 @@ -# Copyright (c) 1995-2004 Nick Ing-Simmons. All rights reserved. -# This program is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. -package Tk::Widget; -use vars qw($VERSION @DefaultMenuLabels); -$VERSION = sprintf '4.%03d', q$Revision: #30 $ =~ /\D(\d+)\s*$/; - -require Tk; -use AutoLoader; -use strict; -use Carp; -use base qw(DynaLoader Tk); - -# stubs for 'autoloaded' widget classes -sub Button; -sub Canvas; -sub Checkbutton; -sub Entry; -sub Frame; -sub Label; -sub Labelframe; -sub Listbox; -sub Menu; -sub Menubutton; -sub Message; -sub Panedwindow; -sub Radiobutton; -sub Scale; -sub Scrollbar; -sub Spinbox; -sub Text; -sub Toplevel; - -sub Pixmap; -sub Bitmap; -sub Photo; - -sub ScrlListbox; -sub Optionmenu; - -sub import -{ - my $package = shift; - carp 'use Tk::Widget () to pre-load widgets is deprecated' if (@_); - my $need; - foreach $need (@_) - { - unless (defined &{$need}) - { - require "Tk/${need}.pm"; - } - croak "Cannot locate $need" unless (defined &{$need}); - } -} - -@DefaultMenuLabels = qw[~File ~Help]; - -# Some tidy-ness functions for winfo stuff - -sub True { 1 } -sub False { 0 } - -use Tk::Submethods( 'grab' => [qw(current status release -global)], - 'focus' => [qw(-force -lastfor)], - 'pack' => [qw(configure forget info propagate slaves)], - 'grid' => [qw(bbox columnconfigure configure forget info location propagate rowconfigure size slaves)], - 'form' => [qw(check configure forget grid info slaves)], - 'event' => [qw(add delete generate info)], - 'place' => [qw(configure forget info slaves)], - 'wm' => [qw(capture release)], - 'font' => [qw(actual configure create delete families measure metrics names subfonts)] - ); - -BEGIN { - # FIXME - these don't work in the compiler - *IsMenu = \&False; - *IsMenubutton = \&False; - *configure_self = \&Tk::configure; - *cget_self = \&Tk::cget; -} - - - -Direct Tk::Submethods ( - 'winfo' => [qw(cells class colormapfull depth exists - geometry height id ismapped manager name parent reqheight - reqwidth rootx rooty screen screencells screendepth screenheight - screenmmheight screenmmwidth screenvisual screenwidth visual - visualsavailable vrootheight viewable vrootwidth vrootx vrooty - width x y toplevel children pixels pointerx pointery pointerxy - server fpixels rgb )], - 'tk' => [qw(appname caret scaling useinputmethods windowingsystem)]); - - -sub DESTROY -{ - my $w = shift; - $w->destroy if ($w->IsWidget); -} - -sub Install -{ - # Dynamically loaded widgets add their core commands - # to the Tk base class here - my ($package,$mw) = @_; -} - -sub ClassInit -{ - # Carry out class bindings (or whatever) - my ($package,$mw) = @_; - return $package; -} - -sub CreateOptions -{ - return (); -} - -sub CreateArgs -{ - my ($package,$parent,$args) = @_; - # Remove from hash %$args any configure-like - # options which only apply at create time (e.g. -colormap for Frame), - # or which may as well be applied right away - # return these as a list of -key => value pairs - # Augment same hash with default values for missing mandatory options, - # allthough this can be done later in InitObject. - - # Honour -class => if present, we have hacked Tk_ConfigureWidget to - # allow -class to be passed to any widget. - my @result = (); - my $class = delete $args->{'-class'}; - ($class) = $package =~ /([A-Z][A-Z0-9_]*)$/i unless (defined $class); - @result = (-class => "\u$class") if (defined $class); - foreach my $opt ($package->CreateOptions) - { - push(@result, $opt => delete $args->{$opt}) if exists $args->{$opt}; - } - return @result; -} - -sub InitObject -{ - my ($obj,$args) = @_; - # per object initialization, for example populating - # with sub-widgets, adding a few object bindings to augment - # inherited class bindings, changing binding tags. - # Also another chance to mess with %$args before configure... -} - -sub SetBindtags -{ - my ($obj) = @_; - $obj->bindtags([ref($obj),$obj,$obj->toplevel,'all']); -} - -sub new -{ - local $SIG{'__DIE__'} = \&Carp::croak; - my $package = shift; - my $parent = shift; - $package->InitClass($parent); - $parent->BackTrace("Odd number of args to $package->new(...)") unless ((@_ % 2) == 0); - my %args = @_; - my @args = $package->CreateArgs($parent,\%args); - my $cmd = $package->Tk_cmd; - my $pname = $parent->PathName; - $pname = '' if ($pname eq '.'); - my $leaf = delete $args{'Name'}; - if (defined $leaf) - { - $leaf =~ s/[^a-z0-9_#]+/_/ig; - $leaf = lcfirst($leaf); - } - else - { - ($leaf) = "\L$package" =~ /([a-z][a-z0-9_]*)$/; - } - my $lname = $pname . '.' . $leaf; - # create a hash indexed by leaf name to speed up - # creation of a lot of sub-widgets of the same type - # e.g. entries in Table - my $nhash = $parent->TkHash('_names_'); - $nhash->{$leaf} = 0 unless (exists $nhash->{$leaf}); - while (defined ($parent->Widget($lname))) - { - $lname = $pname . '.' . $leaf . ++$nhash->{$leaf}; - } - my $obj = eval { &$cmd($parent, $lname, @args) }; - confess $@ if $@; - unless (ref $obj) - { - die "No value from $cmd $lname" unless defined $obj; - warn "$cmd '$lname' returned '$obj'" unless $obj eq $lname; - $obj = $parent->Widget($lname = $obj); - die "$obj from $lname" unless ref $obj; - } - bless $obj,$package; - $obj->SetBindtags; - my $notice = $parent->can('NoticeChild'); - $parent->$notice($obj,\%args) if $notice; - $obj->InitObject(\%args); -# ASkludge(\%args,1); - $obj->configure(%args) if (%args); -# ASkludge(\%args,0); - return $obj; -} - -sub DelegateFor -{ - my ($w,$method) = @_; - while(exists $w->{'Delegates'}) - { - my $delegate = $w->{'Delegates'}; - my $widget = $delegate->{$method}; - $widget = $delegate->{DEFAULT} unless (defined $widget); - $widget = $w->Subwidget($widget) if (defined $widget && !ref $widget); - last unless (defined $widget); - last if $widget == $w; - $w = $widget; - } - return $w; -} - -sub Delegates -{ - my $cw = shift; - my $specs = $cw->TkHash('Delegates'); - while (@_) - { - my $key = shift; - my $val = shift; - $specs->{$key} = $val; - } - return $specs; -} - -sub Construct -{ - my ($base,$name) = @_; - my $class = (caller(0))[0]; - no strict 'refs'; - - # Hack for broken ->isa in perl5.6.0 - delete ${"$class\::"}{'::ISA::CACHE::'} if $] == 5.006; - - # Pre ->isa scheme - *{$base.'::Is'.$name} = \&False; - *{$class.'::Is'.$name} = \&True; - - # DelegateFor trickyness is to allow Frames and other derived things - # to force creation in a delegate e.g. a ScrlText with embeded windows - # need those windows to be children of the Text to get clipping right - # and not of the Frame which contains the Text and the scrollbars. - *{$base.'::'."$name"} = sub { $class->new(shift->DelegateFor('Construct'),@_) }; -} - -sub IS -{ - return (defined $_[1]) && $_[0] == $_[1]; -} - -sub _AutoloadTkWidget -{ - my ($self,$method) = @_; - my $what = "Tk::Widget::$method"; - unless (defined &$what) - { - require "Tk/$method.pm"; - } - return $what; -} - -# require UNIVERSAL; don't load .pm use XS code from perl core though - -sub AUTOLOAD -{ - # Take a copy into a 'my' variable so we can recurse - my $what = $Tk::Widget::AUTOLOAD; - my $save = $@; - my $name; - # warn "AUTOLOAD $what ".(ref($_[0]) || $_[0])."\n"; - # Braces used to preserve $1 et al. - { - my ($pkg,$func) = $what =~ /(.*)::([^:]+)$/; - confess("Attempt to load '$what'") unless defined($pkg) && $func =~ /^[\w:]+$/; - $pkg =~ s#::#/#g; - if (defined($name=$INC{"$pkg.pm"})) - { - $name =~ s#^(.*)$pkg\.pm$#$1auto/$pkg/$func.al#; - } - else - { - $name = "auto/$what.al"; - $name =~ s#::#/#g; - } - } - # This may fail, catch error and prevent user's __DIE__ handler - # from triggering as well... - eval {local $SIG{'__DIE__'}; require $name}; - if ($@) - { - croak $@ unless ($@ =~ /Can't locate\s+(?:file\s+)?'?\Q$name\E'?/); - my($package,$method) = ($what =~ /^(.*)::([^:]*)$/); - if (ref $_[0] && !$_[0]->can($method) - && $_[0]->can('Delegate') - && $method !~ /^(ConfigSpecs|Delegates)/ ) - { - my $delegate = $_[0]->Delegates; - if (%$delegate || tied %$delegate) - { - my $widget = $delegate->{$method}; - $widget = $delegate->{DEFAULT} unless (defined $widget); - if (defined $widget) - { - my $subwidget = (ref $widget) ? $widget : $_[0]->Subwidget($widget); - if (defined $subwidget) - { - no strict 'refs'; - # print "AUTOLOAD: $what\n"; - *{$what} = sub { shift->Delegate($method,@_) }; - } - else - { - croak "No delegate subwidget '$widget' for $what"; - } - } - } - } - if (!defined(&$what) && ref($_[0]) && $method =~ /^[A-Z]\w+$/) - { - # Use ->can as ->isa is broken in perl5.6.0 - my $sub = UNIVERSAL::can($_[0],'_AutoloadTkWidget'); - if ($sub) - { - carp "Assuming 'require Tk::$method;'" unless $_[0]->can($method); - $what = $_[0]->$sub($method) - } - } - } - $@ = $save; - $DB::sub = $what; # Tell debugger what is going on... - unless (defined &$what) - { - no strict 'refs'; - *{$what} = sub { croak("Failed to AUTOLOAD '$what'") }; - } - goto &$what; -} - -sub _Destroyed -{ - my $w = shift; - my $a = delete $w->{'_Destroy_'}; - if (ref($a)) - { - while (@$a) - { - my $ent = pop(@$a); - if (ref $ent) - { - eval {local $SIG{'__DIE__'}; $ent->Call }; - } - else - { - delete $w->{$ent}; - } - } - } -} - -sub _OnDestroy -{ - my $w = shift; - $w->{'_Destroy_'} = [] unless (exists $w->{'_Destroy_'}); - push(@{$w->{'_Destroy_'}},@_); -} - -sub OnDestroy -{ - my $w = shift; - $w->_OnDestroy(Tk::Callback->new(@_)); -} - -sub TkHash -{ - my ($w,$key) = @_; - return $w->{$key} if exists $w->{$key}; - my $hash = $w->{$key} = {}; - $w->_OnDestroy($key); - return $hash; -} - -sub privateData -{ - my $w = shift; - my $p = shift || caller; - $w->{$p} ||= {}; -} - -my @image_types; -my %image_method; - -sub ImageMethod -{ - shift if (@_ & 1); - while (@_) - { - my ($name,$method) = splice(@_,0,2); - push(@image_types,$name); - $image_method{$name} = $method; - } -} - -sub Getimage -{ - my ($w, $name) = @_; - my $mw = $w->MainWindow; - croak "Usage \$widget->Getimage('name')" unless defined($name); - my $images = ($mw->{'__Images__'} ||= {}); - - return $images->{$name} if $images->{$name}; - - ImageMethod(xpm => 'Pixmap', - gif => 'Photo', - ppm => 'Photo', - xbm => 'Bitmap' ) unless @image_types; - - foreach my $type (@image_types) - { - my $method = $image_method{$type}; - my $file = Tk->findINC( "$name.$type" ); - next unless( $file && $method ); - my $sub = $w->can($method); - unless (defined &$sub) - { - require Tk::widgets; - Tk::widgets->import($method); - } - $images->{$name} = $w->$method( -file => $file ); - return $images->{$name}; - } - - # Try built-in bitmaps - $images->{$name} = $w->Pixmap( -id => $name ); - return $images->{$name}; -} - -sub SaveGrabInfo -{ - my $w = shift; - $Tk::oldGrab = $w->grabCurrent; - if (defined $Tk::oldGrab) - { - $Tk::grabStatus = $Tk::oldGrab->grabStatus; - } -} - -sub grabSave -{ - my ($w) = @_; - my $grab = $w->grabCurrent; - return sub {} if (!defined $grab); - my $method = ($grab->grabStatus eq 'global') ? 'grabGlobal' : 'grab'; - return sub { eval {local $SIG{'__DIE__'}; $grab->$method() } }; -} - -sub focusCurrent -{ - my ($w) = @_; - $w->Tk::focus('-displayof'); -} - -sub focusSave -{ - my ($w) = @_; - my $focus = $w->focusCurrent; - return sub {} if (!defined $focus); - return sub { eval {local $SIG{'__DIE__'}; $focus->focus } }; -} - -# This is supposed to replicate Tk::after behaviour, -# but does auto-cancel when widget is deleted. -require Tk::After; - -sub afterCancel -{ - my ($w,$what) = @_; - if (defined $what) - { - return $what->cancel if ref($what); - carp "dubious cancel of $what" if 0 && $^W; - $w->Tk::after('cancel' => $what); - } -} - -sub afterIdle -{ - my $w = shift; - return Tk::After->new($w,'idle','once',@_); -} - -sub afterInfo { - my ($w, $id) = @_; - if (defined $id) { - return ($id->[4], $id->[2], $id->[3]); - } else { - return sort( keys %{$w->{_After_}} ); - } -} - -sub after -{ - my $w = shift; - my $t = shift; - if (@_) - { - if ($t ne 'cancel') - { - require Tk::After; - return Tk::After->new($w,$t,'once',@_) - } - while (@_) - { - my $what = shift; - $w->afterCancel($what); - } - } - else - { - $w->Tk::after($t); - } -} - -sub repeat -{ - require Tk::After; - my $w = shift; - my $t = shift; - return Tk::After->new($w,$t,'repeat',@_); -} - -sub FindMenu -{ - # default FindMenu is that there is no menu. - return undef; -} - -sub XEvent { shift->{'_XEvent_'} } - -sub propertyRoot -{ - my $w = shift; - return $w->property(@_,'root'); -} - -# atom, atomname, containing, interps, pathname -# don't work this way - there is no window arg -# So we pretend there was an call the C versions from Tk.xs - -sub atom { shift->InternAtom(@_) } -sub atomname { shift->GetAtomName(@_) } -sub containing { shift->Containing(@_) } - -# interps not done yet -# pathname not done yet - -# walk and descendants adapted from Stephen's composite -# versions as they only use core features they can go here. -# hierachy is reversed in that descendants calls walk rather -# than vice versa as this avoids building a list. -# Walk should possibly be enhanced so allow early termination -# like '-prune' of find. - -sub Walk -{ - # Traverse a widget hierarchy while executing a subroutine. - my($cw, $proc, @args) = @_; - my $subwidget; - foreach $subwidget ($cw->children) - { - $subwidget->Walk($proc,@args); - &$proc($subwidget, @args); - } -} # end walk - -sub Descendants -{ - # Return a list of widgets derived from a parent widget and all its - # descendants of a particular class. - # If class is not passed returns the entire widget hierarchy. - - my($widget, $class) = @_; - my(@widget_tree) = (); - - $widget->Walk( - sub { my ($widget,$list,$class) = @_; - push(@$list, $widget) if (!defined($class) or $class eq $widget->class); - }, - \@widget_tree, $class - ); - return @widget_tree; -} - -sub Palette -{ - my $w = shift->MainWindow; - unless (exists $w->{_Palette_}) - { - my %Palette = (); - my $c = $w->Checkbutton(); - my $e = $w->Entry(); - my $s = $w->Scrollbar(); - $Palette{'activeBackground'} = ($c->configure('-activebackground'))[3] ; - $Palette{'activeForeground'} = ($c->configure('-activeforeground'))[3]; - $Palette{'background'} = ($c->configure('-background'))[3]; - $Palette{'disabledForeground'} = ($c->configure('-disabledforeground'))[3]; - $Palette{'foreground'} = ($c->configure('-foreground'))[3]; - $Palette{'highlightBackground'} = ($c->configure('-highlightbackground'))[3]; - $Palette{'highlightColor'} = ($c->configure('-highlightcolor'))[3]; - $Palette{'insertBackground'} = ($e->configure('-insertbackground'))[3]; - $Palette{'selectColor'} = ($c->configure('-selectcolor'))[3]; - $Palette{'selectBackground'} = ($e->configure('-selectbackground'))[3]; - $Palette{'selectForeground'} = ($e->configure('-selectforeground'))[3]; - $Palette{'troughColor'} = ($s->configure('-troughcolor'))[3]; - $c->destroy; - $e->destroy; - $s->destroy; - $w->{_Palette_} = \%Palette; - } - return $w->{_Palette_}; -} - -# tk_setPalette -- -# Changes the default color scheme for a Tk application by setting -# default colors in the option database and by modifying all of the -# color options for existing widgets that have the default value. -# -# Arguments: -# The arguments consist of either a single color name, which -# will be used as the new background color (all other colors will -# be computed from this) or an even number of values consisting of -# option names and values. The name for an option is the one used -# for the option database, such as activeForeground, not -activeforeground. -sub setPalette -{ - my $w = shift->MainWindow; - my %new = (@_ == 1) ? (background => $_[0]) : @_; - my $priority = delete($new{'priority'}) || 'widgetDefault'; - - # Create an array that has the complete new palette. If some colors - # aren't specified, compute them from other colors that are specified. - - die 'must specify a background color' if (!exists $new{background}); - $new{'foreground'} = 'black' unless (exists $new{foreground}); - my @bg = $w->rgb($new{'background'}); - my @fg = $w->rgb($new{'foreground'}); - my $darkerBg = sprintf('#%02x%02x%02x',9*$bg[0]/2560,9*$bg[1]/2560,9*$bg[2]/2560); - foreach my $i ('activeForeground','insertBackground','selectForeground','highlightColor') - { - $new{$i} = $new{'foreground'} unless (exists $new{$i}); - } - unless (exists $new{'disabledForeground'}) - { - $new{'disabledForeground'} = sprintf('#%02x%02x%02x',(3*$bg[0]+$fg[0])/1024,(3*$bg[1]+$fg[1])/1024,(3*$bg[2]+$fg[2])/1024); - } - $new{'highlightBackground'} = $new{'background'} unless (exists $new{'highlightBackground'}); - - unless (exists $new{'activeBackground'}) - { - my @light; - # Pick a default active background that is lighter than the - # normal background. To do this, round each color component - # up by 15% or 1/3 of the way to full white, whichever is - # greater. - foreach my $i (0, 1, 2) - { - $light[$i] = $bg[$i]/256; - my $inc1 = $light[$i]*15/100; - my $inc2 = (255-$light[$i])/3; - if ($inc1 > $inc2) - { - $light[$i] += $inc1 - } - else - { - $light[$i] += $inc2 - } - $light[$i] = 255 if ($light[$i] > 255); - } - $new{'activeBackground'} = sprintf('#%02x%02x%02x',@light); - } - $new{'selectBackground'} = $darkerBg unless (exists $new{'selectBackground'}); - $new{'troughColor'} = $darkerBg unless (exists $new{'troughColor'}); - $new{'selectColor'} = '#b03060' unless (exists $new{'selectColor'}); - - # Before doing this, make sure that the Tk::Palette variable holds - # the default values of all options, so that tkRecolorTree can - # be sure to only change options that have their default values. - # If the variable exists, then it is already correct (it was created - # the last time this procedure was invoked). If the variable - # doesn't exist, fill it in using the defaults from a few widgets. - my $Palette = $w->Palette; - - # Walk the widget hierarchy, recoloring all existing windows. - $w->RecolorTree(\%new); - # Change the option database so that future windows will get the - # same colors. - foreach my $option (keys %new) - { - $w->option('add',"*$option",$new{$option},$priority); - # Save the options in the global variable Tk::Palette, for use the - # next time we change the options. - $Palette->{$option} = $new{$option}; - } -} - -# tkRecolorTree -- -# This procedure changes the colors in a window and all of its -# descendants, according to information provided by the colors -# argument. It only modifies colors that have their default values -# as specified by the Tk::Palette variable. -# -# Arguments: -# w - The name of a window. This window and all its -# descendants are recolored. -# colors - The name of an array variable in the caller, -# which contains color information. Each element -# is named after a widget configuration option, and -# each value is the value for that option. -sub RecolorTree -{ - my ($w,$colors) = @_; - local ($@); - my $Palette = $w->Palette; - foreach my $dbOption (keys %$colors) - { - my $option = "-\L$dbOption"; - my $value; - eval {local $SIG{'__DIE__'}; $value = $w->cget($option) }; - if (defined $value) - { - if ($value eq $Palette->{$dbOption}) - { - $w->configure($option,$colors->{$dbOption}); - } - } - } - foreach my $child ($w->children) - { - $child->RecolorTree($colors); - } -} -# tkDarken -- -# Given a color name, computes a new color value that darkens (or -# brightens) the given color by a given percent. -# -# Arguments: -# color - Name of starting color. -# perecent - Integer telling how much to brighten or darken as a -# percent: 50 means darken by 50%, 110 means brighten -# by 10%. -sub Darken -{ - my ($w,$color,$percent) = @_; - my @l = $w->rgb($color); - my $red = $l[0]/256; - my $green = $l[1]/256; - my $blue = $l[2]/256; - $red = int($red*$percent/100); - $red = 255 if ($red > 255); - $green = int($green*$percent/100); - $green = 255 if ($green > 255); - $blue = int($blue*$percent/100); - $blue = 255 if ($blue > 255); - sprintf('#%02x%02x%02x',$red,$green,$blue) -} -# tk_bisque -- -# Reset the Tk color palette to the old "bisque" colors. -# -# Arguments: -# None. -sub bisque -{ - shift->setPalette('activeBackground' => '#e6ceb1', - 'activeForeground' => 'black', - 'background' => '#ffe4c4', - 'disabledForeground' => '#b0b0b0', - 'foreground' => 'black', - 'highlightBackground' => '#ffe4c4', - 'highlightColor' => 'black', - 'insertBackground' => 'black', - 'selectColor' => '#b03060', - 'selectBackground' => '#e6ceb1', - 'selectForeground' => 'black', - 'troughColor' => '#cdb79e' - ); -} - -sub PrintConfig -{ - require Tk::Pretty; - my ($w) = (@_); - my $c; - foreach $c ($w->configure) - { - print Tk::Pretty::Pretty(@$c),"\n"; - } -} - -sub BusyRecurse -{ - my ($restore,$w,$cursor,$recurse,$top) = @_; - my $c = $w->cget('-cursor'); - my @tags = $w->bindtags; - if ($top || defined($c)) - { - push(@$restore, sub { return unless Tk::Exists($w); $w->configure(-cursor => $c); $w->bindtags(\@tags) }); - $w->configure(-cursor => $cursor); - } - else - { - push(@$restore, sub { return unless Tk::Exists($w); $w->bindtags(\@tags) }); - } - $w->bindtags(['Busy',@tags]); - if ($recurse) - { - foreach my $child ($w->children) - { - BusyRecurse($restore,$child,$cursor,1,0); - } - } - return $restore; -} - -sub Busy -{ - my ($w,@args) = @_; - return unless $w->viewable; - my($sub, %args); - for(my $i=0; $i<=$#args; $i++) - { - if (ref $args[$i] eq 'CODE') - { - if (defined $sub) - { - croak "Multiple code definitions not allowed in Tk::Widget::Busy"; - } - $sub = $args[$i]; - } - else - { - $args{$args[$i]} = $args[$i+1]; $i++; - } - } - my $cursor = delete $args{'-cursor'}; - my $recurse = delete $args{'-recurse'}; - $cursor = 'watch' unless defined $cursor; - unless (exists $w->{'Busy'}) - { - my @old = ($w->grabSave); - my $key; - my @config; - foreach $key (keys %args) - { - push(@config,$key => $w->Tk::cget($key)); - } - if (@config) - { - push(@old, sub { $w->Tk::configure(@config) }); - $w->Tk::configure(%args); - } - unless ($w->Tk::bind('Busy')) - { - $w->Tk::bind('Busy','<Any-KeyPress>',[_busy => 1]); - $w->Tk::bind('Busy','<Any-KeyRelease>',[_busy => 0]); - $w->Tk::bind('Busy','<Any-ButtonPress>',[_busy => 1]); - $w->Tk::bind('Busy','<Any-ButtonRelease>',[_busy => 0]); - $w->Tk::bind('Busy','<Any-Motion>',[_busy => 0]); - } - $w->{'Busy'} = BusyRecurse(\@old,$w,$cursor,$recurse,1); - } - my $g = $w->grabCurrent; - if (defined $g) - { - # warn "$g has the grab"; - $g->grabRelease; - } - $w->update; - eval {local $SIG{'__DIE__'}; $w->grab }; - $w->update; - if ($sub) - { - eval { $sub->() }; - my $err = $@; - $w->Unbusy(-recurse => $recurse); - die $err if $err; - } -} - -sub _busy -{ - my ($w,$f) = @_; - $w->bell if $f; - $w->break; -} - -sub Unbusy -{ - my ($w) = @_; - $w->update; - $w->grabRelease if Tk::Exists($w); - my $old = delete $w->{'Busy'}; - if (defined $old) - { - local $SIG{'__DIE__'}; - eval { &{pop(@$old)} } while (@$old); - } - $w->update if Tk::Exists($w); -} - -sub waitVisibility -{ - my ($w) = shift; - $w->tkwait('visibility',$w); -} - -sub waitVariable -{ - my ($w) = shift; - $w->tkwait('variable',@_); -} - -sub waitWindow -{ - my ($w) = shift; - $w->tkwait('window',$w); -} - -sub EventWidget -{ - my ($w) = @_; - return $w->{'_EventWidget_'}; -} - -sub Popwidget -{ - my ($ew,$method,$w,@args) = @_; - $w->{'_EventWidget_'} = $ew; - $w->$method(@args); -} - -sub ColorOptions -{ - my ($w,$args) = @_; - my $opt; - $args = {} unless (defined $args); - foreach $opt (qw(-foreground -background -disabledforeground - -activebackground -activeforeground - )) - { - $args->{$opt} = $w->cget($opt) unless (exists $args->{$opt}) - } - return (wantarray) ? %$args : $args; -} - -sub XscrollBind -{ - my ($mw,$class) = @_; - $mw->bind($class,'<Left>', ['xview','scroll',-1,'units']); - $mw->bind($class,'<Control-Left>', ['xview','scroll',-1,'pages']); - $mw->bind($class,'<Control-Prior>',['xview','scroll',-1,'pages']); - $mw->bind($class,'<Right>', ['xview','scroll',1,'units']); - $mw->bind($class,'<Control-Right>',['xview','scroll',1,'pages']); - $mw->bind($class,'<Control-Next>', ['xview','scroll',1,'pages']); - - $mw->bind($class,'<Home>', ['xview','moveto',0]); - $mw->bind($class,'<End>', ['xview','moveto',1]); - $mw->XMouseWheelBind($class); -} - -sub PriorNextBind -{ - my ($mw,$class) = @_; - $mw->bind($class,'<Next>', ['yview','scroll',1,'pages']); - $mw->bind($class,'<Prior>', ['yview','scroll',-1,'pages']); -} - -sub XMouseWheelBind -{ - my ($mw,$class) = @_; - # <4> and <5> are how mousewheel looks on X - # <4> and <5> are how mousewheel looks on X - $mw->bind($class,'<Shift-4>', ['xview','scroll',-1,'units']); - $mw->bind($class,'<Shift-5>', ['xview','scroll',1,'units']); - $mw->bind($class,'<Button-6>', ['xview','scroll',-1,'units']); - $mw->bind($class,'<Button-7>', ['xview','scroll',1,'units']); -} - -sub YMouseWheelBind -{ - my ($mw,$class) = @_; - # <4> and <5> are how mousewheel looks on X - $mw->bind($class,'<4>', ['yview','scroll',-1,'units']); - $mw->bind($class,'<5>', ['yview','scroll',1,'units']); -} - -sub YscrollBind -{ - my ($mw,$class) = @_; - $mw->PriorNextBind($class); - $mw->bind($class,'<Up>', ['yview','scroll',-1,'units']); - $mw->bind($class,'<Down>', ['yview','scroll',1,'units']); - $mw->YMouseWheelBind($class); -} - -sub XYscrollBind -{ - my ($mw,$class) = @_; - $mw->YscrollBind($class); - $mw->XscrollBind($class); - # <4> and <5> are how mousewheel looks on X -} - -sub MouseWheelBind -{ - my($mw,$class) = @_; - - # The MouseWheel will typically only fire on Windows. However, one - # could use the "event generate" command to produce MouseWheel - # events on other platforms. - - $mw->Tk::bind($class, '<MouseWheel>', - [ sub { $_[0]->yview('scroll',-($_[1]/120)*3,'units') }, Tk::Ev("D")]); - - if ($Tk::platform eq 'unix') - { - # Support for mousewheels on Linux/Unix commonly comes through mapping - # the wheel to the extended buttons. If you have a mousewheel, find - # Linux configuration info at: - # http://www.inria.fr/koala/colas/mouse-wheel-scroll/ - $mw->Tk::bind($class, '<4>', - sub { $_[0]->yview('scroll', -3, 'units') - unless $Tk::strictMotif; - }); - $mw->Tk::bind($class, '<5>', - sub { $_[0]->yview('scroll', 3, 'units') - unless $Tk::strictMotif; - }); - } -} - -sub ScrlListbox -{ - my $parent = shift; - return $parent->Scrolled('Listbox',-scrollbars => 'w', @_); -} - -sub AddBindTag -{ - my ($w,$tag) = @_; - my $t; - my @tags = $w->bindtags; - foreach $t (@tags) - { - return if $t eq $tag; - } - $w->bindtags([@tags,$tag]); -} - -sub Callback -{ - my $w = shift; - my $name = shift; - my $cb = $w->cget($name); - if (defined $cb) - { - return $cb->Call(@_) if (ref $cb); - return $w->$cb(@_); - } - return (wantarray) ? () : undef; -} - -sub packAdjust -{ -# print 'packAdjust(',join(',',@_),")\n"; - require Tk::Adjuster; - my ($w,%args) = @_; - my $delay = delete($args{'-delay'}); - $delay = 1 unless (defined $delay); - $w->pack(%args); - %args = $w->packInfo; - my $adj = Tk::Adjuster->new($args{'-in'}, - -widget => $w, -delay => $delay, -side => $args{'-side'}); - $adj->packed($w,%args); - return $w; -} - -sub gridAdjust -{ - require Tk::Adjuster; - my ($w,%args) = @_; - my $delay = delete($args{'-delay'}); - $delay = 1 unless (defined $delay); - $w->grid(%args); - %args = $w->gridInfo; - my $adj = Tk::Adjuster->new($args{'-in'},-widget => $w, -delay => $delay); - $adj->gridded($w,%args); - return $w; -} - -sub place -{ - local $SIG{'__DIE__'} = \&Carp::croak; - my $w = shift; - if (@_ && $_[0] =~ /^(?:configure|forget|info|slaves)$/x) - { - $w->Tk::place(@_); - } - else - { - # Two things going on here: - # 1. Add configure on the front so that we can drop leading '-' - $w->Tk::place('configure',@_); - # 2. Return the widget rather than nothing - return $w; - } -} - -sub pack -{ - local $SIG{'__DIE__'} = \&Carp::croak; - my $w = shift; - if (@_ && $_[0] =~ /^(?:configure|forget|info|propagate|slaves)$/x) - { - # maybe array/scalar context issue with slaves - $w->Tk::pack(@_); - } - else - { - # Two things going on here: - # 1. Add configure on the front so that we can drop leading '-' - $w->Tk::pack('configure',@_); - # 2. Return the widget rather than nothing - return $w; - } -} - -sub grid -{ - local $SIG{'__DIE__'} = \&Carp::croak; - my $w = shift; - if (@_ && $_[0] =~ /^(?:bbox|columnconfigure|configure|forget|info|location|propagate|rowconfigure|size|slaves)$/x) - { - my $opt = shift; - Tk::grid($opt,$w,@_); - } - else - { - # Two things going on here: - # 1. Add configure on the front so that we can drop leading '-' - Tk::grid('configure',$w,@_); - # 2. Return the widget rather than nothing - return $w; - } -} - -sub form -{ - local $SIG{'__DIE__'} = \&Carp::croak; - my $w = shift; - if (@_ && $_[0] =~ /^(?:configure|check|forget|grid|info|slaves)$/x) - { - $w->Tk::form(@_); - } - else - { - # Two things going on here: - # 1. Add configure on the front so that we can drop leading '-' - $w->Tk::form('configure',@_); - # 2. Return the widget rather than nothing - return $w; - } -} - -sub Scrolled -{ - my ($parent,$kind,%args) = @_; - $kind = 'Pane' if $kind eq 'Frame'; - # Find args that are Frame create time args - my @args = Tk::Frame->CreateArgs($parent,\%args); - my $name = delete $args{'Name'}; - push(@args,'Name' => $name) if (defined $name); - my $cw = $parent->Frame(@args); - @args = (); - # Now remove any args that Frame can handle - foreach my $k ('-scrollbars',map($_->[0],$cw->configure)) - { - push(@args,$k,delete($args{$k})) if (exists $args{$k}) - } - # Anything else must be for target widget - pass at widget create time - my $w = $cw->$kind(%args); - # Now re-set %args to be ones Frame can handle - %args = @args; - $cw->ConfigSpecs('-scrollbars' => ['METHOD','scrollbars','Scrollbars','se'], - '-background' => [$w,'background','Background'], - '-foreground' => [$w,'foreground','Foreground'], - ); - $cw->AddScrollbars($w); - $cw->Default("\L$kind" => $w); - $cw->Delegates('bind' => $w, 'bindtags' => $w, 'menu' => $w); - $cw->ConfigDefault(\%args); - $cw->configure(%args); - return $cw; -} - -sub Populate -{ - my ($cw,$args) = @_; -} - -sub ForwardEvent -{ - my $self = shift; - my $to = shift; - $to->PassEvent($self->XEvent); -} - -# Save / Return abstract event type as in Tix. -sub EventType -{ - my $w = shift; - $w->{'_EventType_'} = $_[0] if @_; - return $w->{'_EventType_'}; -} - -sub PostPopupMenu -{ - my ($w, $X, $Y) = @_; - if (@_ < 3) - { - my $e = $w->XEvent; - $X = $e->X; - $Y = $e->Y; - } - my $menu = $w->menu; - $menu->Post($X,$Y) if defined $menu; -} - -sub FillMenu -{ - my ($w,$menu,@labels) = @_; - foreach my $lab (@labels) - { - my $method = $lab.'MenuItems'; - $method =~ s/~//g; - $method =~ s/[\s-]+/_/g; - if ($w->can($method)) - { - $menu->Menubutton(-label => $lab, -tearoff => 0, -menuitems => $w->$method()); - } - } - return $menu; -} - -sub menu -{ - my ($w,$menu) = @_; - if (@_ > 1) - { - $w->_OnDestroy('_MENU_') unless exists $w->{'_MENU_'}; - $w->{'_MENU_'} = $menu; - } - return unless defined wantarray; - unless (exists $w->{'_MENU_'}) - { - $w->_OnDestroy('_MENU_'); - $w->{'_MENU_'} = $menu = $w->Menu(-tearoff => 0); - $w->FillMenu($menu,$w->MenuLabels); - } - return $w->{'_MENU_'}; -} - -sub MenuLabels -{ - return @DefaultMenuLabels; -} - -sub FileMenuItems -{ - my ($w) = @_; - return [ ["command"=>'E~xit', -command => [ $w, 'WmDeleteWindow']]]; -} - -sub WmDeleteWindow -{ - shift->toplevel->WmDeleteWindow -} - -sub BalloonInfo -{ - my ($widget,$balloon,$X,$Y,@opt) = @_; - foreach my $opt (@opt) - { - my $info = $balloon->GetOption($opt,$widget); - return $info if defined $info; - } -} - -sub ConfigSpecs { - - my $w = shift; - - return map { ( $_->[0], [ $w, @$_[ 1 .. 4 ] ] ) } $w->configure; - -} - -*GetSelection = - ($Tk::platform eq 'unix' - ? sub - { - my $w = shift; - my $sel = @_ ? shift : "PRIMARY"; - my $txt = eval { local $SIG{__DIE__}; - $w->SelectionGet(-selection => $sel, -type => "UTF8_STRING") - }; - if ($@) - { - $txt = eval { local $SIG{__DIE__}; - $w->SelectionGet(-selection => $sel) - }; - if ($@) - { - die "could not find default selection"; - } - } - $txt; - } - : sub - { - my $w = shift; - my $sel = @_ ? shift : "PRIMARY"; - my $txt = eval { local $SIG{__DIE__}; - $w->SelectionGet(-selection => $sel) - }; - if ($@) - { - die "could not find default selection"; - } - $txt; - } - ); - -1; -__END__ - -sub bindDump { - - # Dump lots of good binding information. This pretty-print subroutine - # is, essentially, the following code in disguise: - # - # print "Binding information for $w\n"; - # foreach my $tag ($w->bindtags) { - # printf "\n Binding tag '$tag' has these bindings:\n"; - # foreach my $binding ($w->bind($tag)) { - # printf " $binding\n"; - # } - # } - - my ($w) = @_; - - my (@bindtags) = $w->bindtags; - my $digits = length( scalar @bindtags ); - my ($spc1, $spc2) = ($digits + 33, $digits + 35); - my $format1 = "%${digits}d."; - my $format2 = ' ' x ($digits + 2); - my $n = 0; - - my @out; - push @out, sprintf( "\n## Binding information for '%s', %s ##", $w->PathName, $w ); - - foreach my $tag (@bindtags) { - my (@bindings) = $w->bind($tag); - $n++; # count this bindtag - - if ($#bindings == -1) { - push @out, sprintf( "\n$format1 Binding tag '$tag' has no bindings.\n", $n ); - } else { - push @out, sprintf( "\n$format1 Binding tag '$tag' has these bindings:\n", $n ); - - foreach my $binding ( @bindings ) { - my $callback = $w->bind($tag, $binding); - push @out, sprintf( "$format2%27s : %-40s\n", $binding, $callback ); - - if ($callback =~ /SCALAR/) { - if (ref $$callback) { - push @out, sprintf( "%s %s\n", ' ' x $spc1, $$callback ); - } else { - push @out, sprintf( "%s '%s'\n", ' ' x $spc1, $$callback ); - } - } elsif ($callback =~ /ARRAY/) { - if (ref $callback->[0]) { - push @out, sprintf( "%s %s\n", ' ' x $spc1, $callback->[0], "\n" ); - } else { - push @out, sprintf( "%s '%s'\n", ' ' x $spc1, $callback->[0], "\n" ); - } - foreach my $arg (@$callback[1 .. $#{@$callback}]) { - if (ref $arg) { - push @out, sprintf( "%s %-40s", ' ' x $spc2, $arg ); - } else { - push @out, sprintf( "%s '%s'", ' ' x $spc2, $arg ); - } - - if (ref $arg eq 'Tk::Ev') { - if ($arg =~ /SCALAR/) { - push @out, sprintf( ": '$$arg'" ); - } else { - push @out, sprintf( ": '%s'", join("' '", @$arg) ); - } - } - - push @out, sprintf( "\n" ); - } # forend callback arguments - } # ifend callback - - } # forend all bindings for one tag - - } # ifend have bindings - - } # forend all tags - push @out, sprintf( "\n" ); - return @out; - -} # end bindDump - - -sub ASkludge -{ - my ($hash,$sense) = @_; - foreach my $key (%$hash) - { - if ($key =~ /-.*variable/ && ref($hash->{$key}) eq 'SCALAR') - { - if ($sense) - { - my $val = ${$hash->{$key}}; - require Tie::Scalar; - tie ${$hash->{$key}},'Tie::StdScalar'; - ${$hash->{$key}} = $val; - } - else - { - untie ${$hash->{$key}}; - } - } - } -} - - - -# clipboardKeysyms -- -# This procedure is invoked to identify the keys that correspond to -# the "copy", "cut", and "paste" functions for the clipboard. -# -# Arguments: -# copy - Name of the key (keysym name plus modifiers, if any, -# such as "Meta-y") used for the copy operation. -# cut - Name of the key used for the cut operation. -# paste - Name of the key used for the paste operation. -# -# This method is obsolete use clipboardOperations and abstract -# event types instead. See Clipboard.pm and Mainwindow.pm - -sub clipboardKeysyms -{ - my @class = (); - my $mw = shift; - if (ref $mw) - { - $mw = $mw->DelegateFor('bind'); - } - else - { - push(@class,$mw); - $mw = shift; - } - if (@_) - { - my $copy = shift; - $mw->Tk::bind(@class,"<$copy>",'clipboardCopy') if (defined $copy); - } - if (@_) - { - my $cut = shift; - $mw->Tk::bind(@class,"<$cut>",'clipboardCut') if (defined $cut); - } - if (@_) - { - my $paste = shift; - $mw->Tk::bind(@class,"<$paste>",'clipboardPaste') if (defined $paste); - } -} - -sub pathname -{ - my ($w,$id) = @_; - my $x = $w->winfo('pathname',-displayof => oct($id)); - return $x->PathName; -} diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Wm.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Wm.pm deleted file mode 100644 index ffbe4877857..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Wm.pm +++ /dev/null @@ -1,174 +0,0 @@ -# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved. -# This program is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. -package Tk::Wm; -use AutoLoader; - -require Tk::Widget; -*AUTOLOAD = \&Tk::Widget::AUTOLOAD; - -use strict qw(vars); - -# There are issues with this stuff now we have Tix's wm release/capture -# as toplevel-ness is now dynamic. - - -use vars qw($VERSION); -$VERSION = sprintf '4.%03d', q$Revision: #14 $ =~ /\D(\d+)\s*$/; - -use Tk::Submethods; - -*{Tk::Wm::wmGrid} = sub { shift->wm("grid", @_) }; -*{Tk::Wm::wmTracing} = sub { shift->wm("tracing", @_) }; - -Direct Tk::Submethods ('wm' => [qw(aspect attributes client colormapwindows command - deiconify focusmodel frame geometry group - iconbitmap iconify iconimage iconmask iconname - iconwindow maxsize minsize overrideredirect positionfrom - protocol resizable sizefrom state title transient - withdraw wrapper)]); - -sub SetBindtags -{ - my ($obj) = @_; - $obj->bindtags([ref($obj),$obj,'all']); -} - -sub Populate -{ - my ($cw,$args) = @_; - $cw->ConfigSpecs('-overanchor' => ['PASSIVE',undef,undef,undef], - '-popanchor' => ['PASSIVE',undef,undef,undef], - '-popover' => ['PASSIVE',undef,undef,undef] - ); -} - -sub MoveResizeWindow -{ - my ($w,$x,$y,$width,$height) = @_; - $w->withdraw; - $w->geometry($width.'x'.$height); - $w->MoveToplevelWindow($x,$y); - $w->deiconify; -} - -sub WmDeleteWindow -{ - my ($w) = @_; - my $cb = $w->protocol('WM_DELETE_WINDOW'); - if (defined $cb) - { - $cb->Call; - } - else - { - $w->destroy; - } -} - - -1; - -__END__ - - -sub Post -{ - my ($w,$X,$Y) = @_; - $X = int($X); - $Y = int($Y); - $w->positionfrom('user'); - $w->geometry("+$X+$Y"); - # $w->MoveToplevelWindow($X,$Y); - $w->deiconify; - $w->raise; -} - -sub AnchorAdjust -{ - my ($anchor,$X,$Y,$w,$h) = @_; - $anchor = 'c' unless (defined $anchor); - $Y += ($anchor =~ /s/) ? $h : ($anchor =~ /n/) ? 0 : $h/2; - $X += ($anchor =~ /e/) ? $w : ($anchor =~ /w/) ? 0 : $w/2; - return ($X,$Y); -} - -sub Popup -{ - my $w = shift; - $w->configure(@_) if @_; - $w->idletasks; - my ($mw,$mh) = ($w->reqwidth,$w->reqheight); - my ($rx,$ry,$rw,$rh) = (0,0,0,0); - my $base = $w->cget('-popover'); - my $outside = 0; - if (defined $base) - { - if ($base eq 'cursor') - { - ($rx,$ry) = $w->pointerxy; - } - else - { - $rx = $base->rootx; - $ry = $base->rooty; - $rw = $base->Width; - $rh = $base->Height; - } - } - else - { - my $sc = ($w->parent) ? $w->parent->toplevel : $w; - $rx = -$sc->vrootx; - $ry = -$sc->vrooty; - $rw = $w->screenwidth; - $rh = $w->screenheight; - } - my ($X,$Y) = AnchorAdjust($w->cget('-overanchor'),$rx,$ry,$rw,$rh); - ($X,$Y) = AnchorAdjust($w->cget('-popanchor'),$X,$Y,-$mw,-$mh); - # adjust to not cross screen borders - if ($X < 0) { $X = 0 } - if ($Y < 0) { $Y = 0 } - if ($mw > $w->screenwidth) { $X = 0 } - if ($mh > $w->screenheight) { $Y = 0 } - $w->Post($X,$Y); - $w->waitVisibility; -} - -sub FullScreen -{ - my $w = shift; - my $over = (@_) ? shift : 0; - my $width = $w->screenwidth; - my $height = $w->screenheight; - $w->GeometryRequest($width,$height); - $w->overrideredirect($over & 1); - $w->Post(0,0); - $w->update; - if ($over & 2) - { - my $x = $w->rootx; - my $y = $w->rooty; - $width -= 2*$x; - $height -= $x + $y; - $w->GeometryRequest($width,$height); - $w->update; - } -} - -sub iconposition -{ - my $w = shift; - if (@_ == 1) - { - return $w->wm('iconposition',$1,$2) if $_[0] =~ /^(\d+),(\d+)$/; - if ($_[0] =~ /^([+-])(\d+)([+-])(\d+)$/) - { - my $x = ($1 eq '-') ? $w->screenwidth-$2 : $2; - my $y = ($3 eq '-') ? $w->screenheight-$4 : $4; - return $w->wm('iconposition',$x,$y); - } - } - $w->wm('iconposition',@_); -} - diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Win32/API.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Win32/API.pm deleted file mode 100644 index e1bac5cda48..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/Win32/API.pm +++ /dev/null @@ -1,745 +0,0 @@ -package Win32::API; - -# See the bottom of this file for the POD documentation. Search for the -# string '=head'. - -####################################################################### -# -# Win32::API - Perl Win32 API Import Facility -# -# Version: 0.47 -# Date: 12 Nov 2007 -# Author: Aldo Calpini <dada@perl.it> -# Maintainer: Cosimo Streppone <cosimo@cpan.org> -# -# Changes for gcc/cygwin: Daniel Risacher <magnus@alum.mit.edu> -# ported from 0.41 based on Daniel's patch by Reini Urban <rurban@x-ray.at> -# -# $Id: API.pm,v 1.0 2001/10/30 13:57:31 dada Exp $ -# -####################################################################### - -require Exporter; # to export the constants to the main:: space -require DynaLoader; # to dynuhlode the module. -@ISA = qw( Exporter DynaLoader ); - -use vars qw( $DEBUG ); -$DEBUG = 0; - -sub DEBUG { - if ($Win32::API::DEBUG) { - printf @_ if @_ or return 1; - } else { - return 0; - } -} - -use Win32::API::Type; -use Win32::API::Struct; -BEGIN { - if ($^O eq 'cygwin') { - require File::Basename; - } -} - -####################################################################### -# STATIC OBJECT PROPERTIES -# -$VERSION = '0.47'; - -#### some package-global hash to -#### keep track of the imported -#### libraries and procedures -my %Libraries = (); -my %Procedures = (); - - -####################################################################### -# dynamically load in the API extension module. -# -bootstrap Win32::API; - -####################################################################### -# PUBLIC METHODS -# -sub new { - my($class, $dll, $proc, $in, $out) = @_; - my $hdll; - my $self = {}; - - if ($^O eq 'cygwin' and $dll ne File::Basename::basename($dll)) { - # need to convert $dll to win32 path - # isn't there an API for this? - my $newdll = `cygpath -w "$dll"`; - chomp $newdll; - DEBUG "(PM)new: converted '$dll' to\n '$newdll'\n"; - $dll = $newdll; - } - - #### avoid loading a library more than once - if(exists($Libraries{$dll})) { - DEBUG "Win32::API::new: Library '$dll' already loaded, handle=$Libraries{$dll}\n"; - $hdll = $Libraries{$dll}; - } else { - DEBUG "Win32::API::new: Loading library '$dll'\n"; - $hdll = Win32::API::LoadLibrary($dll); -# $Libraries{$dll} = $hdll; - } - - #### if the dll can't be loaded, set $! to Win32's GetLastError() - if(!$hdll) { - $! = Win32::GetLastError(); - DEBUG "FAILED Loading library '$dll': $!\n"; - delete $Libraries{$dll}; - return undef; - } - - #### determine if we have a prototype or not - if( (not defined $in) and (not defined $out) ) { - ($proc, $self->{in}, $self->{intypes}, $self->{out}) = parse_prototype( $proc ); - return undef unless $proc; - $self->{proto} = 1; - } else { - $self->{in} = []; - if(ref($in) eq 'ARRAY') { - foreach (@$in) { - push(@{ $self->{in} }, type_to_num($_)); - } - } else { - my @in = split '', $in; - foreach (@in) { - push(@{ $self->{in} }, type_to_num($_)); - } - } - $self->{out} = type_to_num($out); - } - - #### first try to import the function of given name... - my $hproc = Win32::API::GetProcAddress($hdll, $proc); - - #### ...then try appending either A or W (for ASCII or Unicode) - if(!$hproc) { - my $tproc = $proc; - $tproc .= (IsUnicode() ? "W" : "A"); - # print "Win32::API::new: procedure not found, trying '$tproc'...\n"; - $hproc = Win32::API::GetProcAddress($hdll, $tproc); - } - - #### ...if all that fails, set $! accordingly - if(!$hproc) { - $! = Win32::GetLastError(); - DEBUG "FAILED GetProcAddress for Proc '$proc': $!\n"; - return undef; - } - DEBUG "GetProcAddress('$proc') = '$hproc'\n"; - - #### ok, let's stuff the object - $self->{procname} = $proc; - $self->{dll} = $hdll; - $self->{dllname} = $dll; - $self->{proc} = $hproc; - - #### keep track of the imported function - $Libraries{$dll} = $hdll; - $Procedures{$dll}++; - - DEBUG "Object blessed!\n"; - - #### cast the spell - bless($self, $class); - return $self; -} - -sub Import { - my($class, $dll, $proc, $in, $out) = @_; - $Imported{"$dll:$proc"} = Win32::API->new($dll, $proc, $in, $out) or return 0; - my $P = (caller)[0]; - eval qq( - sub ${P}::$Imported{"$dll:$proc"}->{procname} { \$Win32::API::Imported{"$dll:$proc"}->Call(\@_); } - ); - return $@ ? 0 : 1; -} - - -####################################################################### -# PRIVATE METHODS -# -sub DESTROY { - my($self) = @_; - - #### decrease this library's procedures reference count - $Procedures{$self->{dllname}}--; - - #### once it reaches 0, free it - if($Procedures{$self->{dllname}} == 0) { - DEBUG "Win32::API::DESTROY: Freeing library '$self->{dllname}'\n"; - Win32::API::FreeLibrary($Libraries{$self->{dllname}}); - delete($Libraries{$self->{dllname}}); - } -} - -sub type_to_num { - my $type = shift; - my $out = shift; - my $num; - - if( $type eq 'N' - or $type eq 'n' - or $type eq 'l' - or $type eq 'L' - ) { - $num = 1; - } elsif($type eq 'P' - or $type eq 'p' - ) { - $num = 2; - } elsif($type eq 'I' - or $type eq 'i' - ) { - $num = 3; - } elsif($type eq 'f' - or $type eq 'F' - ) { - $num = 4; - } elsif($type eq 'D' - or $type eq 'd' - ) { - $num = 5; - } elsif($type eq 'c' - or $type eq 'C' - ) { - $num = 6; - } else { - $num = 0; - } - unless(defined $out) { - if( $type eq 's' - or $type eq 'S' - ) { - $num = 51; - } elsif($type eq 'b' - or $type eq 'B' - ) { - $num = 22; - } elsif($type eq 'k' - or $type eq 'K' - ) { - $num = 101; - } - } - return $num; -} - -sub parse_prototype { - my($proto) = @_; - - my @in_params = (); - my @in_types = (); - if($proto =~ /^\s*(\S+)\s+(\S+)\s*\(([^\)]*)\)/) { - my $ret = $1; - my $proc = $2; - my $params = $3; - - $params =~ s/^\s+//; - $params =~ s/\s+$//; - - DEBUG "(PM)parse_prototype: got PROC '%s'\n", $proc; - DEBUG "(PM)parse_prototype: got PARAMS '%s'\n", $params; - - foreach my $param (split(/\s*,\s*/, $params)) { - my($type, $name); - if($param =~ /(\S+)\s+(\S+)/) { - ($type, $name) = ($1, $2); - } - - if(Win32::API::Type::is_known($type)) { - if(Win32::API::Type::is_pointer($type)) { - DEBUG "(PM)parse_prototype: IN='%s' PACKING='%s' API_TYPE=%d\n", - $type, - Win32::API::Type->packing( $type ), - type_to_num('P'); - push(@in_params, type_to_num('P')); - } else { - DEBUG "(PM)parse_prototype: IN='%s' PACKING='%s' API_TYPE=%d\n", - $type, - Win32::API::Type->packing( $type ), - type_to_num( Win32::API::Type->packing( $type ) ); - push(@in_params, type_to_num( Win32::API::Type->packing( $type ) )); - } - } elsif( Win32::API::Struct::is_known( $type ) ) { - DEBUG "(PM)parse_prototype: IN='%s' PACKING='%s' API_TYPE=%d\n", - $type, 'S', type_to_num('S'); - push(@in_params, type_to_num('S')); - } else { - warn "Win32::API::parse_prototype: WARNING unknown parameter type '$type'"; - push(@in_params, type_to_num('I')); - } - push(@in_types, $type); - - } - DEBUG "parse_prototype: IN=[ @in_params ]\n"; - - - - if(Win32::API::Type::is_known($ret)) { - if(Win32::API::Type::is_pointer($ret)) { - DEBUG "parse_prototype: OUT='%s' PACKING='%s' API_TYPE=%d\n", - $ret, - Win32::API::Type->packing( $ret ), - type_to_num('P'); - return ( $proc, \@in_params, \@in_types, type_to_num('P') ); - } else { - DEBUG "parse_prototype: OUT='%s' PACKING='%s' API_TYPE=%d\n", - $ret, - Win32::API::Type->packing( $ret ), - type_to_num( Win32::API::Type->packing( $ret ) ); - return ( $proc, \@in_params, \@in_types, type_to_num(Win32::API::Type->packing($ret)) ); - } - } else { - warn "Win32::API::parse_prototype: WARNING unknown output parameter type '$ret'"; - return ( $proc, \@in_params, \@in_types, type_to_num('I') ); - } - - } else { - warn "Win32::API::parse_prototype: bad prototype '$proto'"; - return undef; - } -} - -1; - -__END__ - -####################################################################### -# DOCUMENTATION -# - -=head1 NAME - -Win32::API - Perl Win32 API Import Facility - -=head1 SYNOPSIS - - #### Method 1: with prototype - - use Win32::API; - $function = Win32::API->new( - 'mydll, 'int sum_integers(int a, int b)', - ); - $return = $function->Call(3, 2); - - #### Method 2: with parameter list - - use Win32::API; - $function = Win32::API->new( - 'mydll', 'sum_integers', 'II', 'I', - ); - $return = $function->Call(3, 2); - - #### Method 3: with Import - - use Win32::API; - Win32::API->Import( - 'mydll', 'int sum_integers(int a, int b)', - ); - $return = sum_integers(3, 2); - - -=for LATER-UNIMPLEMENTED - #### or - use Win32::API mydll => 'int sum_integers(int a, int b)'; - $return = sum_integers(3, 2); - - -=head1 ABSTRACT - -With this module you can import and call arbitrary functions -from Win32's Dynamic Link Libraries (DLL), without having -to write an XS extension. Note, however, that this module -can't do anything (parameters input and output is limited -to simpler cases), and anyway a regular XS extension is -always safer and faster. - -The current version of Win32::API is available at my website: - - http://dada.perl.it/ - -It's also available on your nearest CPAN mirror (but allow a few days -for worldwide spreading of the latest version) reachable at: - - http://www.perl.com/CPAN/authors/Aldo_Calpini/ - -A short example of how you can use this module (it just gets the PID of -the current process, eg. same as Perl's internal C<$$>): - - use Win32::API; - Win32::API->Import("kernel32", "int GetCurrentProcessId()"); - $PID = GetCurrentProcessId(); - -The possibilities are nearly infinite (but not all are good :-). -Enjoy it. - - -=head1 CREDITS - -All the credits go to Andrea Frosini -for the neat assembler trick that makes this thing work. -I've also used some work by Dave Roth for the prototyping stuff. -A big thank you also to Gurusamy Sarathy for his -unvaluable help in XS development, and to all the Perl community for -being what it is. - - -=head1 DESCRIPTION - -To use this module put the following line at the beginning of your script: - - use Win32::API; - -You can now use the C<new()> function of the Win32::API module to create a -new Win32::API object (see L<IMPORTING A FUNCTION>) and then invoke the -C<Call()> method on this object to perform a call to the imported API -(see L<CALLING AN IMPORTED FUNCTION>). - -Starting from version 0.40, you can also avoid creating a Win32::API object -and instead automatically define a Perl sub with the same name of the API -function you're importing. The details of the API definitions are the same, -just the call is different: - - my $GetCurrentProcessId = Win32::API->new( - "kernel32", "int GetCurrentProcessId()" - ); - my $PID = $GetCurrentProcessId->Call(); - - #### vs. - - Win32::API->Import("kernel32", "int GetCurrentProcessId()"); - $PID = GetCurrentProcessId(); - -Note that C<Import> returns 1 on success and 0 on failure (in which case you -can check the content of C<$^E>). - -=head2 IMPORTING A FUNCTION - -You can import a function from a 32 bit Dynamic Link Library (DLL) file -with the C<new()> function. This will create a Perl object that contains the -reference to that function, which you can later C<Call()>. - -What you need to know is the prototype of the function you're going to import -(eg. the definition of the function expressed in C syntax). - -Starting from version 0.40, there are 2 different approaches for this step: -(the preferred) one uses the prototype directly, while the other (now deprecated) -one uses Win32::API's internal representation for parameters. - -=head2 IMPORTING A FUNCTION BY PROTOTYPE - -You need to pass 2 parameters: - -=over 4 - -=item 1. -The name of the library from which you want to import the function. - -=item 2. -The C prototype of the function. - -=back - -See L<Win32::API::Type> for a list of the known parameter types and -L<Win32::API::Struct> for information on how to define a structure. - -=head2 IMPORTING A FUNCTION WITH A PARAMETER LIST - -You need to pass 4 parameters: - -=over 4 - -=item 1. -The name of the library from which you want to import the function. - -=item 2. -The name of the function (as exported by the library). - -=item 3. -The number and types of the arguments the function expects as input. - -=item 4. -The type of the value returned by the function. - -=back - -To better explain their meaning, let's suppose that we -want to import and call the Win32 API C<GetTempPath()>. -This function is defined in C as: - - DWORD WINAPI GetTempPathA( DWORD nBufferLength, LPSTR lpBuffer ); - -This is documented in the B<Win32 SDK Reference>; you can look -for it on the Microsoft's WWW site, or in your C compiler's -documentation, if you own one. - -=over 4 - -=item B<1.> - -The first parameter is the name of the library file that -exports this function; our function resides in the F<KERNEL32.DLL> -system file. -When specifying this name as parameter, the F<.DLL> extension -is implicit, and if no path is given, the file is searched through -a couple of directories, including: - -=over 4 - -=item 1. The directory from which the application loaded. - -=item 2. The current directory. - -=item 3. The Windows system directory (eg. c:\windows\system or system32). - -=item 4. The Windows directory (eg. c:\windows). - -=item 5. The directories that are listed in the PATH environment variable. - -=back - -So, you don't have to write F<C:\windows\system\kernel32.dll>; -only F<kernel32> is enough: - - $GetTempPath = new Win32::API('kernel32', ... - -=item B<2.> - -Now for the second parameter: the name of the function. -It must be written exactly as it is exported -by the library (case is significant here). -If you are using Windows 95 or NT 4.0, you can use the B<Quick View> -command on the DLL file to see the function it exports. -Remember that you can only import functions from 32 bit DLLs: -in Quick View, the file's characteristics should report -somewhere "32 bit word machine"; as a rule of thumb, -when you see that all the exported functions are in upper case, -the DLL is a 16 bit one and you can't use it. -If their capitalization looks correct, then it's probably a 32 bit -DLL. - -Also note that many Win32 APIs are exported twice, with the addition of -a final B<A> or B<W> to their name, for - respectively - the ASCII -and the Unicode version. -When a function name is not found, Win32::API will actually append -an B<A> to the name and try again; if the extension is built on a -Unicode system, then it will try with the B<W> instead. -So our function name will be: - - $GetTempPath = new Win32::API('kernel32', 'GetTempPath', ... - -In our case C<GetTempPath> is really loaded as C<GetTempPathA>. - -=item B<3.> - -The third parameter, the input parameter list, specifies how many -arguments the function wants, and their types. It can be passed as -a single string, in which each character represents one parameter, -or as a list reference. The following forms are valid: - - "abcd" - [a, b, c, d] - \@LIST - -But those are not: - - (a, b, c, d) - @LIST - -The number of characters, or elements in the list, specifies the number -of parameters, and each character or element specifies the type of an -argument; allowed types are: - -=over 4 - -=item C<I>: -value is an integer (int) - -=item C<N>: -value is a number (long) - -=item C<F>: -value is a floating point number (float) - -=item C<D>: -value is a double precision number (double) - -=item C<C>: -value is a char (char) - -=item C<P>: -value is a pointer (to a string, structure, etc...) - -=item C<S>: -value is a Win32::API::Struct object (see below) - -=item C<K>: -value is a Win32::API::Callback object (see L<Win32::API::Callback>) - -=back - -Our function needs two parameters: a number (C<DWORD>) and a pointer to a -string (C<LPSTR>): - - $GetTempPath = new Win32::API('kernel32', 'GetTempPath', 'NP', ... - -=item B<4.> - -The fourth and final parameter is the type of the value returned by the -function. It can be one of the types seen above, plus another type named B<V> -(for C<void>), used for functions that do not return a value. -In our example the value returned by GetTempPath() is a C<DWORD>, so -our return type will be B<N>: - - $GetTempPath = new Win32::API('kernel32', 'GetTempPath', 'NP', 'N'); - -Now the line is complete, and the GetTempPath() API is ready to be used -in Perl. Before calling it, you should test that $GetTempPath is -C<defined>, otherwise either the function or the library could not be -loaded; in this case, C<$!> will be set to the error message reported -by Windows. -Our definition, with error checking added, should then look like this: - - $GetTempPath = new Win32::API('kernel32', 'GetTempPath', 'NP', 'N'); - if(not defined $GetTempPath) { - die "Can't import API GetTempPath: $!\n"; - } - -=back - -=head2 CALLING AN IMPORTED FUNCTION - -To effectively make a call to an imported function you must use the -Call() method on the Win32::API object you created. -Continuing with the example from the previous paragraph, -the GetTempPath() API can be called using the method: - - $GetTempPath->Call(... - -Of course, parameters have to be passed as defined in the import phase. -In particular, if the number of parameters does not match (in the example, -if GetTempPath() is called with more or less than two parameters), -Perl will C<croak> an error message and C<die>. - -The two parameters needed here are the length of the buffer -that will hold the returned temporary path, and a pointer to the -buffer itself. -For numerical parameters, you can use either a constant expression -or a variable, while B<for pointers you must use a variable name> (no -Perl references, just a plain variable name). -Also note that B<memory must be allocated before calling the function>, -just like in C. -For example, to pass a buffer of 80 characters to GetTempPath(), -it must be initialized before with: - - $lpBuffer = " " x 80; - -This allocates a string of 80 characters. If you don't do so, you'll -probably get C<Runtime exception> errors, and generally nothing will -work. The call should therefore include: - - $lpBuffer = " " x 80; - $GetTempPath->Call(80, $lpBuffer); - -And the result will be stored in the $lpBuffer variable. -Note that you don't need to pass a reference to the variable -(eg. you B<don't need> C<\$lpBuffer>), even if its value will be set -by the function. - -A little problem here is that Perl does not trim the variable, -so $lpBuffer will still contain 80 characters in return; the exceeding -characters will be spaces, because we said C<" " x 80>. - -In this case we're lucky enough, because the value returned by -the GetTempPath() function is the length of the string, so to get -the actual temporary path we can write: - - $lpBuffer = " " x 80; - $return = $GetTempPath->Call(80, $lpBuffer); - $TempPath = substr($lpBuffer, 0, $return); - -If you don't know the length of the string, you can usually -cut it at the C<\0> (ASCII zero) character, which is the string -delimiter in C: - - $TempPath = ((split(/\0/, $lpBuffer))[0]; - # or - $lpBuffer =~ s/\0.*$//; - -=head2 USING STRUCTURES - -Starting from version 0.40, Win32::API comes with a support package -named Win32::API::Struct. The package is loaded automatically with -Win32::API, so you don't need to use it explicitly. - -With this module you can conveniently define structures and use -them as parameters to Win32::API functions. A short example follows: - - - # the 'POINT' structure is defined in C as: - # typedef struct { - # LONG x; - # LONG y; - # } POINT; - - - #### define the structure - Win32::API::Struct->typedef( POINT => qw{ - LONG x; - LONG y; - }); - - #### import an API that uses this structure - Win32::API->Import('user32', 'BOOL GetCursorPos(LPPOINT lpPoint)'); - - #### create a 'POINT' object - my $pt = Win32::API::Struct->new('POINT'); - - #### call the function passing our structure object - GetCursorPos($pt); - - #### and now, access its members - print "The cursor is at: $pt->{x}, $pt->{y}\n"; - -Note that this works only when the function wants a -B<pointer to a structure>: as you can see, our structure is named -'POINT', but the API used 'LPPOINT'. 'LP' is automatically added at -the beginning of the structure name when feeding it to a Win32::API -call. - -For more information, see also L<Win32::API::Struct>. - -If you don't want (or can't) use the Win32::API::Struct facility, -you can still use the low-level approach to use structures: - - -=over 4 - -=item 1. -you have to pack() the required elements in a variable: - - $lpPoint = pack('LL', 0, 0); # store two LONGs - -=item 2. to access the values stored in a structure, unpack() it as required: - - ($x, $y) = unpack('LL', $lpPoint); # get the actual values - -=back - -The rest is left as an exercise to the reader... - -=head1 AUTHOR - -Aldo Calpini ( I<dada@perl.it> ). - -=head1 MAINTAINER - -Cosimo Streppone ( I<cosimo@cpan.org> ) - -=cut diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Win32/API.pm.orig b/Master/tlpkg/lib/Perl5_lib-TL_inst/Win32/API.pm.orig deleted file mode 100644 index 9e4accd8bf6..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/Win32/API.pm.orig +++ /dev/null @@ -1,741 +0,0 @@ -package Win32::API;
-
-# See the bottom of this file for the POD documentation. Search for the
-# string '=head'.
-
-#######################################################################
-#
-# Win32::API - Perl Win32 API Import Facility
-#
-# Version: 0.47
-# Date: 12 Nov 2007
-# Author: Aldo Calpini <dada@perl.it>
-# Maintainer: Cosimo Streppone <cosimo@cpan.org>
-#
-# Changes for gcc/cygwin: Daniel Risacher <magnus@alum.mit.edu>
-# ported from 0.41 based on Daniel's patch by Reini Urban <rurban@x-ray.at>
-#
-# $Id: API.pm,v 1.0 2001/10/30 13:57:31 dada Exp $
-#
-#######################################################################
-
-require Exporter; # to export the constants to the main:: space
-require DynaLoader; # to dynuhlode the module.
-@ISA = qw( Exporter DynaLoader );
-
-use vars qw( $DEBUG );
-$DEBUG = 0;
-
-sub DEBUG {
- if ($Win32::API::DEBUG) {
- printf @_ if @_ or return 1;
- } else {
- return 0;
- }
-}
-
-use Win32::API::Type;
-use Win32::API::Struct;
-use File::Basename ();
-
-#######################################################################
-# STATIC OBJECT PROPERTIES
-#
-$VERSION = '0.47';
-
-#### some package-global hash to
-#### keep track of the imported
-#### libraries and procedures
-my %Libraries = ();
-my %Procedures = ();
-
-
-#######################################################################
-# dynamically load in the API extension module.
-#
-bootstrap Win32::API;
-
-#######################################################################
-# PUBLIC METHODS
-#
-sub new {
- my($class, $dll, $proc, $in, $out) = @_;
- my $hdll;
- my $self = {};
-
- if ($^O eq 'cygwin' and $dll ne File::Basename::basename($dll)) {
- # need to convert $dll to win32 path
- # isn't there an API for this?
- my $newdll = `cygpath -w "$dll"`;
- chomp $newdll;
- DEBUG "(PM)new: converted '$dll' to\n '$newdll'\n";
- $dll = $newdll;
- }
-
- #### avoid loading a library more than once
- if(exists($Libraries{$dll})) {
- DEBUG "Win32::API::new: Library '$dll' already loaded, handle=$Libraries{$dll}\n";
- $hdll = $Libraries{$dll};
- } else {
- DEBUG "Win32::API::new: Loading library '$dll'\n";
- $hdll = Win32::API::LoadLibrary($dll);
-# $Libraries{$dll} = $hdll;
- }
-
- #### if the dll can't be loaded, set $! to Win32's GetLastError()
- if(!$hdll) {
- $! = Win32::GetLastError();
- DEBUG "FAILED Loading library '$dll': $!\n";
- delete $Libraries{$dll};
- return undef;
- }
-
- #### determine if we have a prototype or not
- if( (not defined $in) and (not defined $out) ) {
- ($proc, $self->{in}, $self->{intypes}, $self->{out}) = parse_prototype( $proc );
- return undef unless $proc;
- $self->{proto} = 1;
- } else {
- $self->{in} = [];
- if(ref($in) eq 'ARRAY') {
- foreach (@$in) {
- push(@{ $self->{in} }, type_to_num($_));
- }
- } else {
- my @in = split '', $in;
- foreach (@in) {
- push(@{ $self->{in} }, type_to_num($_));
- }
- }
- $self->{out} = type_to_num($out);
- }
-
- #### first try to import the function of given name...
- my $hproc = Win32::API::GetProcAddress($hdll, $proc);
-
- #### ...then try appending either A or W (for ASCII or Unicode)
- if(!$hproc) {
- my $tproc = $proc;
- $tproc .= (IsUnicode() ? "W" : "A");
- # print "Win32::API::new: procedure not found, trying '$tproc'...\n";
- $hproc = Win32::API::GetProcAddress($hdll, $tproc);
- }
-
- #### ...if all that fails, set $! accordingly
- if(!$hproc) {
- $! = Win32::GetLastError();
- DEBUG "FAILED GetProcAddress for Proc '$proc': $!\n";
- return undef;
- }
- DEBUG "GetProcAddress('$proc') = '$hproc'\n";
-
- #### ok, let's stuff the object
- $self->{procname} = $proc;
- $self->{dll} = $hdll;
- $self->{dllname} = $dll;
- $self->{proc} = $hproc;
-
- #### keep track of the imported function
- $Libraries{$dll} = $hdll;
- $Procedures{$dll}++;
-
- DEBUG "Object blessed!\n";
-
- #### cast the spell
- bless($self, $class);
- return $self;
-}
-
-sub Import {
- my($class, $dll, $proc, $in, $out) = @_;
- $Imported{"$dll:$proc"} = Win32::API->new($dll, $proc, $in, $out) or return 0;
- my $P = (caller)[0];
- eval qq(
- sub ${P}::$Imported{"$dll:$proc"}->{procname} { \$Win32::API::Imported{"$dll:$proc"}->Call(\@_); }
- );
- return $@ ? 0 : 1;
-}
-
-
-#######################################################################
-# PRIVATE METHODS
-#
-sub DESTROY {
- my($self) = @_;
-
- #### decrease this library's procedures reference count
- $Procedures{$self->{dllname}}--;
-
- #### once it reaches 0, free it
- if($Procedures{$self->{dllname}} == 0) {
- DEBUG "Win32::API::DESTROY: Freeing library '$self->{dllname}'\n";
- Win32::API::FreeLibrary($Libraries{$self->{dllname}});
- delete($Libraries{$self->{dllname}});
- }
-}
-
-sub type_to_num {
- my $type = shift;
- my $out = shift;
- my $num;
-
- if( $type eq 'N'
- or $type eq 'n'
- or $type eq 'l'
- or $type eq 'L'
- ) {
- $num = 1;
- } elsif($type eq 'P'
- or $type eq 'p'
- ) {
- $num = 2;
- } elsif($type eq 'I'
- or $type eq 'i'
- ) {
- $num = 3;
- } elsif($type eq 'f'
- or $type eq 'F'
- ) {
- $num = 4;
- } elsif($type eq 'D'
- or $type eq 'd'
- ) {
- $num = 5;
- } elsif($type eq 'c'
- or $type eq 'C'
- ) {
- $num = 6;
- } else {
- $num = 0;
- }
- unless(defined $out) {
- if( $type eq 's'
- or $type eq 'S'
- ) {
- $num = 51;
- } elsif($type eq 'b'
- or $type eq 'B'
- ) {
- $num = 22;
- } elsif($type eq 'k'
- or $type eq 'K'
- ) {
- $num = 101;
- }
- }
- return $num;
-}
-
-sub parse_prototype {
- my($proto) = @_;
-
- my @in_params = ();
- my @in_types = ();
- if($proto =~ /^\s*(\S+)\s+(\S+)\s*\(([^\)]*)\)/) {
- my $ret = $1;
- my $proc = $2;
- my $params = $3;
-
- $params =~ s/^\s+//;
- $params =~ s/\s+$//;
-
- DEBUG "(PM)parse_prototype: got PROC '%s'\n", $proc;
- DEBUG "(PM)parse_prototype: got PARAMS '%s'\n", $params;
-
- foreach my $param (split(/\s*,\s*/, $params)) {
- my($type, $name);
- if($param =~ /(\S+)\s+(\S+)/) {
- ($type, $name) = ($1, $2);
- }
-
- if(Win32::API::Type::is_known($type)) {
- if(Win32::API::Type::is_pointer($type)) {
- DEBUG "(PM)parse_prototype: IN='%s' PACKING='%s' API_TYPE=%d\n",
- $type,
- Win32::API::Type->packing( $type ),
- type_to_num('P');
- push(@in_params, type_to_num('P'));
- } else {
- DEBUG "(PM)parse_prototype: IN='%s' PACKING='%s' API_TYPE=%d\n",
- $type,
- Win32::API::Type->packing( $type ),
- type_to_num( Win32::API::Type->packing( $type ) );
- push(@in_params, type_to_num( Win32::API::Type->packing( $type ) ));
- }
- } elsif( Win32::API::Struct::is_known( $type ) ) {
- DEBUG "(PM)parse_prototype: IN='%s' PACKING='%s' API_TYPE=%d\n",
- $type, 'S', type_to_num('S');
- push(@in_params, type_to_num('S'));
- } else {
- warn "Win32::API::parse_prototype: WARNING unknown parameter type '$type'";
- push(@in_params, type_to_num('I'));
- }
- push(@in_types, $type);
-
- }
- DEBUG "parse_prototype: IN=[ @in_params ]\n";
-
-
-
- if(Win32::API::Type::is_known($ret)) {
- if(Win32::API::Type::is_pointer($ret)) {
- DEBUG "parse_prototype: OUT='%s' PACKING='%s' API_TYPE=%d\n",
- $ret,
- Win32::API::Type->packing( $ret ),
- type_to_num('P');
- return ( $proc, \@in_params, \@in_types, type_to_num('P') );
- } else {
- DEBUG "parse_prototype: OUT='%s' PACKING='%s' API_TYPE=%d\n",
- $ret,
- Win32::API::Type->packing( $ret ),
- type_to_num( Win32::API::Type->packing( $ret ) );
- return ( $proc, \@in_params, \@in_types, type_to_num(Win32::API::Type->packing($ret)) );
- }
- } else {
- warn "Win32::API::parse_prototype: WARNING unknown output parameter type '$ret'";
- return ( $proc, \@in_params, \@in_types, type_to_num('I') );
- }
-
- } else {
- warn "Win32::API::parse_prototype: bad prototype '$proto'";
- return undef;
- }
-}
-
-1;
-
-__END__
-
-#######################################################################
-# DOCUMENTATION
-#
-
-=head1 NAME
-
-Win32::API - Perl Win32 API Import Facility
-
-=head1 SYNOPSIS
-
- #### Method 1: with prototype
-
- use Win32::API;
- $function = Win32::API->new(
- 'mydll, 'int sum_integers(int a, int b)',
- );
- $return = $function->Call(3, 2);
-
- #### Method 2: with parameter list
-
- use Win32::API;
- $function = Win32::API->new(
- 'mydll', 'sum_integers', 'II', 'I',
- );
- $return = $function->Call(3, 2);
-
- #### Method 3: with Import
-
- use Win32::API;
- Win32::API->Import(
- 'mydll', 'int sum_integers(int a, int b)',
- );
- $return = sum_integers(3, 2);
-
-
-=for LATER-UNIMPLEMENTED
- #### or
- use Win32::API mydll => 'int sum_integers(int a, int b)';
- $return = sum_integers(3, 2);
-
-
-=head1 ABSTRACT
-
-With this module you can import and call arbitrary functions
-from Win32's Dynamic Link Libraries (DLL), without having
-to write an XS extension. Note, however, that this module
-can't do anything (parameters input and output is limited
-to simpler cases), and anyway a regular XS extension is
-always safer and faster.
-
-The current version of Win32::API is available at my website:
-
- http://dada.perl.it/
-
-It's also available on your nearest CPAN mirror (but allow a few days
-for worldwide spreading of the latest version) reachable at:
-
- http://www.perl.com/CPAN/authors/Aldo_Calpini/
-
-A short example of how you can use this module (it just gets the PID of
-the current process, eg. same as Perl's internal C<$$>):
-
- use Win32::API;
- Win32::API->Import("kernel32", "int GetCurrentProcessId()");
- $PID = GetCurrentProcessId();
-
-The possibilities are nearly infinite (but not all are good :-).
-Enjoy it.
-
-
-=head1 CREDITS
-
-All the credits go to Andrea Frosini
-for the neat assembler trick that makes this thing work.
-I've also used some work by Dave Roth for the prototyping stuff.
-A big thank you also to Gurusamy Sarathy for his
-unvaluable help in XS development, and to all the Perl community for
-being what it is.
-
-
-=head1 DESCRIPTION
-
-To use this module put the following line at the beginning of your script:
-
- use Win32::API;
-
-You can now use the C<new()> function of the Win32::API module to create a
-new Win32::API object (see L<IMPORTING A FUNCTION>) and then invoke the
-C<Call()> method on this object to perform a call to the imported API
-(see L<CALLING AN IMPORTED FUNCTION>).
-
-Starting from version 0.40, you can also avoid creating a Win32::API object
-and instead automatically define a Perl sub with the same name of the API
-function you're importing. The details of the API definitions are the same,
-just the call is different:
-
- my $GetCurrentProcessId = Win32::API->new(
- "kernel32", "int GetCurrentProcessId()"
- );
- my $PID = $GetCurrentProcessId->Call();
-
- #### vs.
-
- Win32::API->Import("kernel32", "int GetCurrentProcessId()");
- $PID = GetCurrentProcessId();
-
-Note that C<Import> returns 1 on success and 0 on failure (in which case you
-can check the content of C<$^E>).
-
-=head2 IMPORTING A FUNCTION
-
-You can import a function from a 32 bit Dynamic Link Library (DLL) file
-with the C<new()> function. This will create a Perl object that contains the
-reference to that function, which you can later C<Call()>.
-
-What you need to know is the prototype of the function you're going to import
-(eg. the definition of the function expressed in C syntax).
-
-Starting from version 0.40, there are 2 different approaches for this step:
-(the preferred) one uses the prototype directly, while the other (now deprecated)
-one uses Win32::API's internal representation for parameters.
-
-=head2 IMPORTING A FUNCTION BY PROTOTYPE
-
-You need to pass 2 parameters:
-
-=over 4
-
-=item 1.
-The name of the library from which you want to import the function.
-
-=item 2.
-The C prototype of the function.
-
-=back
-
-See L<Win32::API::Type> for a list of the known parameter types and
-L<Win32::API::Struct> for information on how to define a structure.
-
-=head2 IMPORTING A FUNCTION WITH A PARAMETER LIST
-
-You need to pass 4 parameters:
-
-=over 4
-
-=item 1.
-The name of the library from which you want to import the function.
-
-=item 2.
-The name of the function (as exported by the library).
-
-=item 3.
-The number and types of the arguments the function expects as input.
-
-=item 4.
-The type of the value returned by the function.
-
-=back
-
-To better explain their meaning, let's suppose that we
-want to import and call the Win32 API C<GetTempPath()>.
-This function is defined in C as:
-
- DWORD WINAPI GetTempPathA( DWORD nBufferLength, LPSTR lpBuffer );
-
-This is documented in the B<Win32 SDK Reference>; you can look
-for it on the Microsoft's WWW site, or in your C compiler's
-documentation, if you own one.
-
-=over 4
-
-=item B<1.>
-
-The first parameter is the name of the library file that
-exports this function; our function resides in the F<KERNEL32.DLL>
-system file.
-When specifying this name as parameter, the F<.DLL> extension
-is implicit, and if no path is given, the file is searched through
-a couple of directories, including:
-
-=over 4
-
-=item 1. The directory from which the application loaded.
-
-=item 2. The current directory.
-
-=item 3. The Windows system directory (eg. c:\windows\system or system32).
-
-=item 4. The Windows directory (eg. c:\windows).
-
-=item 5. The directories that are listed in the PATH environment variable.
-
-=back
-
-So, you don't have to write F<C:\windows\system\kernel32.dll>;
-only F<kernel32> is enough:
-
- $GetTempPath = new Win32::API('kernel32', ...
-
-=item B<2.>
-
-Now for the second parameter: the name of the function.
-It must be written exactly as it is exported
-by the library (case is significant here).
-If you are using Windows 95 or NT 4.0, you can use the B<Quick View>
-command on the DLL file to see the function it exports.
-Remember that you can only import functions from 32 bit DLLs:
-in Quick View, the file's characteristics should report
-somewhere "32 bit word machine"; as a rule of thumb,
-when you see that all the exported functions are in upper case,
-the DLL is a 16 bit one and you can't use it.
-If their capitalization looks correct, then it's probably a 32 bit
-DLL.
-
-Also note that many Win32 APIs are exported twice, with the addition of
-a final B<A> or B<W> to their name, for - respectively - the ASCII
-and the Unicode version.
-When a function name is not found, Win32::API will actually append
-an B<A> to the name and try again; if the extension is built on a
-Unicode system, then it will try with the B<W> instead.
-So our function name will be:
-
- $GetTempPath = new Win32::API('kernel32', 'GetTempPath', ...
-
-In our case C<GetTempPath> is really loaded as C<GetTempPathA>.
-
-=item B<3.>
-
-The third parameter, the input parameter list, specifies how many
-arguments the function wants, and their types. It can be passed as
-a single string, in which each character represents one parameter,
-or as a list reference. The following forms are valid:
-
- "abcd"
- [a, b, c, d]
- \@LIST
-
-But those are not:
-
- (a, b, c, d)
- @LIST
-
-The number of characters, or elements in the list, specifies the number
-of parameters, and each character or element specifies the type of an
-argument; allowed types are:
-
-=over 4
-
-=item C<I>:
-value is an integer (int)
-
-=item C<N>:
-value is a number (long)
-
-=item C<F>:
-value is a floating point number (float)
-
-=item C<D>:
-value is a double precision number (double)
-
-=item C<C>:
-value is a char (char)
-
-=item C<P>:
-value is a pointer (to a string, structure, etc...)
-
-=item C<S>:
-value is a Win32::API::Struct object (see below)
-
-=item C<K>:
-value is a Win32::API::Callback object (see L<Win32::API::Callback>)
-
-=back
-
-Our function needs two parameters: a number (C<DWORD>) and a pointer to a
-string (C<LPSTR>):
-
- $GetTempPath = new Win32::API('kernel32', 'GetTempPath', 'NP', ...
-
-=item B<4.>
-
-The fourth and final parameter is the type of the value returned by the
-function. It can be one of the types seen above, plus another type named B<V>
-(for C<void>), used for functions that do not return a value.
-In our example the value returned by GetTempPath() is a C<DWORD>, so
-our return type will be B<N>:
-
- $GetTempPath = new Win32::API('kernel32', 'GetTempPath', 'NP', 'N');
-
-Now the line is complete, and the GetTempPath() API is ready to be used
-in Perl. Before calling it, you should test that $GetTempPath is
-C<defined>, otherwise either the function or the library could not be
-loaded; in this case, C<$!> will be set to the error message reported
-by Windows.
-Our definition, with error checking added, should then look like this:
-
- $GetTempPath = new Win32::API('kernel32', 'GetTempPath', 'NP', 'N');
- if(not defined $GetTempPath) {
- die "Can't import API GetTempPath: $!\n";
- }
-
-=back
-
-=head2 CALLING AN IMPORTED FUNCTION
-
-To effectively make a call to an imported function you must use the
-Call() method on the Win32::API object you created.
-Continuing with the example from the previous paragraph,
-the GetTempPath() API can be called using the method:
-
- $GetTempPath->Call(...
-
-Of course, parameters have to be passed as defined in the import phase.
-In particular, if the number of parameters does not match (in the example,
-if GetTempPath() is called with more or less than two parameters),
-Perl will C<croak> an error message and C<die>.
-
-The two parameters needed here are the length of the buffer
-that will hold the returned temporary path, and a pointer to the
-buffer itself.
-For numerical parameters, you can use either a constant expression
-or a variable, while B<for pointers you must use a variable name> (no
-Perl references, just a plain variable name).
-Also note that B<memory must be allocated before calling the function>,
-just like in C.
-For example, to pass a buffer of 80 characters to GetTempPath(),
-it must be initialized before with:
-
- $lpBuffer = " " x 80;
-
-This allocates a string of 80 characters. If you don't do so, you'll
-probably get C<Runtime exception> errors, and generally nothing will
-work. The call should therefore include:
-
- $lpBuffer = " " x 80;
- $GetTempPath->Call(80, $lpBuffer);
-
-And the result will be stored in the $lpBuffer variable.
-Note that you don't need to pass a reference to the variable
-(eg. you B<don't need> C<\$lpBuffer>), even if its value will be set
-by the function.
-
-A little problem here is that Perl does not trim the variable,
-so $lpBuffer will still contain 80 characters in return; the exceeding
-characters will be spaces, because we said C<" " x 80>.
-
-In this case we're lucky enough, because the value returned by
-the GetTempPath() function is the length of the string, so to get
-the actual temporary path we can write:
-
- $lpBuffer = " " x 80;
- $return = $GetTempPath->Call(80, $lpBuffer);
- $TempPath = substr($lpBuffer, 0, $return);
-
-If you don't know the length of the string, you can usually
-cut it at the C<\0> (ASCII zero) character, which is the string
-delimiter in C:
-
- $TempPath = ((split(/\0/, $lpBuffer))[0];
- # or
- $lpBuffer =~ s/\0.*$//;
-
-=head2 USING STRUCTURES
-
-Starting from version 0.40, Win32::API comes with a support package
-named Win32::API::Struct. The package is loaded automatically with
-Win32::API, so you don't need to use it explicitly.
-
-With this module you can conveniently define structures and use
-them as parameters to Win32::API functions. A short example follows:
-
-
- # the 'POINT' structure is defined in C as:
- # typedef struct {
- # LONG x;
- # LONG y;
- # } POINT;
-
-
- #### define the structure
- Win32::API::Struct->typedef( POINT => qw{
- LONG x;
- LONG y;
- });
-
- #### import an API that uses this structure
- Win32::API->Import('user32', 'BOOL GetCursorPos(LPPOINT lpPoint)');
-
- #### create a 'POINT' object
- my $pt = Win32::API::Struct->new('POINT');
-
- #### call the function passing our structure object
- GetCursorPos($pt);
-
- #### and now, access its members
- print "The cursor is at: $pt->{x}, $pt->{y}\n";
-
-Note that this works only when the function wants a
-B<pointer to a structure>: as you can see, our structure is named
-'POINT', but the API used 'LPPOINT'. 'LP' is automatically added at
-the beginning of the structure name when feeding it to a Win32::API
-call.
-
-For more information, see also L<Win32::API::Struct>.
-
-If you don't want (or can't) use the Win32::API::Struct facility,
-you can still use the low-level approach to use structures:
-
-
-=over 4
-
-=item 1.
-you have to pack() the required elements in a variable:
-
- $lpPoint = pack('LL', 0, 0); # store two LONGs
-
-=item 2. to access the values stored in a structure, unpack() it as required:
-
- ($x, $y) = unpack('LL', $lpPoint); # get the actual values
-
-=back
-
-The rest is left as an exercise to the reader...
-
-=head1 AUTHOR
-
-Aldo Calpini ( I<dada@perl.it> ).
-
-=head1 MAINTAINER
-
-Cosimo Streppone ( I<cosimo@cpan.org> )
-
-=cut
diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Win32/API/Callback.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Win32/API/Callback.pm deleted file mode 100644 index 22de9d4f46a..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/Win32/API/Callback.pm +++ /dev/null @@ -1,174 +0,0 @@ -package Win32::API::Callback; - -# See the bottom of this file for the POD documentation. Search for the -# string '=head'. - -####################################################################### -# -# Win32::API::Callback - Perl Win32 API Import Facility -# -# Author: Aldo Calpini <dada@perl.it> -# Maintainer: Cosimo Streppone <cosimo@cpan.org> -# -# $Id: Callback.pm,v 1.0 2001/10/30 13:57:31 dada Exp $ -# -####################################################################### - -$VERSION = '0.47'; - -require Exporter; # to export the constants to the main:: space -require DynaLoader; # to dynuhlode the module. -@ISA = qw( Exporter DynaLoader ); - -sub DEBUG { - if ($WIN32::API::DEBUG) { - printf @_ if @_ or return 1; - } else { - return 0; - } -} - -use Win32::API; -use Win32::API::Type; -use Win32::API::Struct; - -####################################################################### -# This AUTOLOAD is used to 'autoload' constants from the constant() -# XS function. If a constant is not found then control is passed -# to the AUTOLOAD in AutoLoader. -# - -sub AUTOLOAD { - my($constname); - ($constname = $AUTOLOAD) =~ s/.*:://; - #reset $! to zero to reset any current errors. - $!=0; - my $val = constant($constname, @_ ? $_[0] : 0); - if ($! != 0) { - if ($! =~ /Invalid/) { - $AutoLoader::AUTOLOAD = $AUTOLOAD; - goto &AutoLoader::AUTOLOAD; - } else { - ($pack,$file,$line) = caller; - die "Your vendor has not defined Win32::API::Callback macro $constname, used at $file line $line."; - } - } - eval "sub $AUTOLOAD { $val }"; - goto &$AUTOLOAD; -} - - -####################################################################### -# dynamically load in the API extension module. -# -bootstrap Win32::API::Callback; - -####################################################################### -# PUBLIC METHODS -# -sub new { - my($class, $proc, $in, $out) = @_; - my %self = (); - - # printf "(PM)Callback::new: got proc='%s', in='%s', out='%s'\n", $proc, $in, $out; - - $self{in} = []; - if(ref($in) eq 'ARRAY') { - foreach (@$in) { - push(@{ $self{in} }, Win32::API::type_to_num($_)); - } - } else { - my @in = split '', $in; - foreach (@in) { - push(@{ $self{in} }, Win32::API::type_to_num($_)); - } - } - $self{out} = Win32::API::type_to_num($out); - $self{sub} = $proc; - my $self = bless \%self, $class; - - DEBUG "(PM)Callback::new: calling CallbackCreate($self)...\n"; - my $hproc = CallbackCreate($self); - - DEBUG "(PM)Callback::new: hproc=$hproc\n"; - - #### ...if that fails, set $! accordingly - if(!$hproc) { - $! = Win32::GetLastError(); - return undef; - } - - #### ok, let's stuff the object - $self->{code} = $hproc; - $self->{sub} = $proc; - - #### cast the spell - return $self; -} - -sub MakeStruct { - my($self, $n, $addr) = @_; - DEBUG "(PM)Win32::API::Callback::MakeStruct: got self='$self'\n"; - my $struct = Win32::API::Struct->new($self->{intypes}->[$n]); - $struct->FromMemory($addr); - return $struct; -} - -1; - -__END__ - -####################################################################### -# DOCUMENTATION -# - -=head1 NAME - -Win32::API::Callback - Callback support for Win32::API - -=head1 SYNOPSIS - - use Win32::API; - use Win32::API::Callback; - - my $callback = Win32::API::Callback->new( - sub { my($a, $b) = @_; return $a+$b; }, - "NN", "N", - ); - - Win32::API->Import( - 'mydll', 'two_integers_cb', 'KNN', 'N', - ); - - $sum = two_integers_cb( $callback, 3, 2 ); - - -=head1 FOREWORDS - -=over 4 - -=item * -Support for this module is B<highly experimental> at this point. - -=item * -I won't be surprised if it doesn't work for you. - -=item * -Feedback is very appreciated. - -=item * -Documentation is in the work. Either see the SYNOPSIS above -or the samples in the F<samples> directory. - -=back - -=head1 AUTHOR - -Aldo Calpini ( I<dada@perl.it> ). - -=head1 MAINTAINER - -Cosimo Streppone ( I<cosimo@cpan.org> ). - -=cut - diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Win32/API/Struct.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Win32/API/Struct.pm deleted file mode 100644 index 05a4c8c60a5..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/Win32/API/Struct.pm +++ /dev/null @@ -1,532 +0,0 @@ -package Win32::API::Struct; - -# See the bottom of this file for the POD documentation. Search for the -# string '=head'. - -####################################################################### -# -# Win32::API::Struct - Perl Win32 API struct Facility -# -# Author: Aldo Calpini <dada@perl.it> -# Maintainer: Cosimo Streppone <cosimo@cpan.org> -# -# $Id: Struct.pm,v 1.0 2001/10/30 13:57:31 dada Exp $ -####################################################################### - -$VERSION = '0.47'; - -use Win32::API::Type; - -use Carp; - -require Exporter; # to export the constants to the main:: space -require DynaLoader; # to dynuhlode the module. -@ISA = qw( Exporter DynaLoader ); - -my %Known = (); - -sub DEBUG { - if ($Win32::API::DEBUG) { - printf @_ if @_ or return 1; - } else { - return 0; - } -} - -sub typedef { - my $class = shift; - my $struct = shift; - my($type, $name); - my $self = { - align => undef, - typedef => [], - }; - while(defined($type = shift)) { - $name = shift; - $name =~ s/;$//; - push( @{ $self->{typedef} }, [ recognize($type, $name) ] ); - } - - $Known{$struct} = $self; - return 1; -} - - -sub recognize { - my($type, $name) = @_; - my($size, $packing); - if(exists $Known{$type}) { - $packing = ">"; - return $name, $packing, $type; - } else { - $packing = Win32::API::Type::packing($type); - return undef unless defined $packing; - if($name =~ s/\[(.*)\]$//) { - $size = $1; - $packing = $packing."*".$size; - } - DEBUG "(PM)Struct::recognize got '$name', '$type' -> '$packing'\n"; - return $name, $packing, $type; - } -} - -sub new { - my $class = shift; - my($type, $name); - my $self = { - typedef => [], - }; - if($#_ == 0) { - if(exists $Known{$_[0]}) { - DEBUG "(PM)Struct::new: got '$_[0]'\n"; - $self->{typedef} = $Known{$_[0]}->{typedef}; - foreach my $member (@{ $self->{typedef} }) { - ($name, $packing, $type) = @$member; - if($packing eq '>') { - $self->{$name} = Win32::API::Struct->new($type); - } - } - $self->{__typedef__} = $_[0]; - } else { - carp "Unknown Win32::API::Struct '$_[0]'"; - return undef; - } - } else { - while(defined($type = shift)) { - $name = shift; - # print "new: found member $name ($type)\n"; - if(not exists $Win32::API::Type::Known{$type}) { - warn "Unknown Win32::API::Struct type '$type'"; - return undef; - } else { - push( @{ $self->{typedef} }, [ $name, $Win32::API::Type::Known{$type}, $type ] ); - } - } - } - return bless $self; -} - -sub members { - my $self = shift; - return map {$_->[0]} @{ $self->{typedef} }; -} - -sub sizeof { - my $self = shift; - my $size = 0; - my $align = 0; - my $first = undef; - foreach my $member (@{ $self->{typedef} }) { - my($name, $packing, $type) = @$member; - - if(ref( $self->{$name} ) eq "Win32::API::Struct") { - $size += $self->{$name}->sizeof(); - # $align = $self->{$name}->sizeof() if $self->{$name}->sizeof() > $align; - } else { - if($packing =~ /\w\*(\d+)/) { - $size += Win32::API::Type::sizeof($type) * $1; - $first = Win32::API::Type::sizeof($type) * $1 unless defined $first; - DEBUG "(PM)Struct::sizeof: sizeof with member($name) now = ". $size. "\n"; - } else { - $size += Win32::API::Type::sizeof($type); - $first = Win32::API::Type::sizeof($type) unless defined $first; - $align = Win32::API::Type::sizeof($type) - if Win32::API::Type::sizeof($type) > $align; - DEBUG "(PM)Struct::sizeof: sizeof with member($name) now = ". $size. "\n"; - } - } - } - DEBUG "(PM)Struct::sizeof first=$first align=$align\n"; - #DEBUG "(PM)Struct::sizeof returning %d\n", $first + (scalar(@{ $self->{typedef} })-1) * $align; - #return $first + (scalar(@{ $self->{typedef} })-1) * $align; - DEBUG "(PM)Struct::sizeof returning %d\n", scalar(@{ $self->{typedef} }) * $align; - if(defined $align and $align > 0) { - return scalar(@{ $self->{typedef} }) * $align; - } else { - return $size; - } - return $size; -} - -sub align { - my $self = shift; - my $align = shift; - - if(not defined $align) { - return $self->{align} unless $self->{align} eq 'auto'; - $align = 0; - foreach my $member (@{ $self->{typedef} }) { - my($name, $packing, $type) = @$member; - - if(ref( $self->{$name} ) eq "Win32::API::Struct") { - #### ???? - } else { - if($packing =~ /\w\*(\d+)/) { - #### ???? - } else { - $align = Win32::API::Type::sizeof($type) - if Win32::API::Type::sizeof($type) > $align; - } - } - } - return $align; - } else { - $self->{align} = $align; - - } -} - -sub getPack { - my $self = shift; - my $packing = ""; - my($type, $name); - my @items = (); - my @recipients = (); - - my $align = $self->align(); - - foreach my $member (@{ $self->{typedef} }) { - ($name, $type, $orig) = @$member; - if($type eq '>') { - my($subpacking, $subitems, $subrecipients) = $self->{$name}->getPack(); - - DEBUG "(PM)Struct::getPack($self->{__typedef__}) ++ $subpacking\n"; - - $packing .= $subpacking; - push(@items, @$subitems); - push(@recipients, @$subrecipients); - } else { - if($type =~ /\w\*(\d+)/) { - my $size = $1; - $type = "a$size"; - } - - DEBUG "(PM)Struct::getPack($self->{__typedef__}) ++ $type\n"; - - if($type eq 'p') { - $type = "L"; - push(@items, Win32::API::PointerTo($self->{$name})); - } else { - push(@items, $self->{$name}); - } - $packing .= $type; - - if($Win32::API::Type::PackSize{$type} < $align) { - $packing .= ("x" x ($align - $Win32::API::Type::PackSize{$type})); - } - - push(@recipients, $self); - } - } - DEBUG "(PM)Struct::getPack: $self->{__typedef__}(buffer) = pack($packing, @items)\n"; - return($packing, [@items], [@recipients]); -} - - -sub Pack { - my $self = shift; - my($packing, $items, $recipients) = $self->getPack(); - DEBUG "(PM)Struct::Pack: $self->{__typedef__}(buffer) = pack($packing, @$items)\n"; - $self->{buffer} = pack($packing, @$items); - if(DEBUG) { - for my $i (0..$self->sizeof-1) { - printf " %3d: 0x%02x\n", $i, ord(substr($self->{buffer}, $i, 1)); - } - } - $self->{buffer_recipients} = $recipients -} - -sub getUnpack { - my $self = shift; - my $packing = ""; - my($type, $name); - my @items = (); - my $align = $self->align(); - foreach my $member (@{ $self->{typedef} }) { - ($name, $type, $orig) = @$member; - if($type eq '>') { - my($subpacking, @subitems) = $self->{$name}->getUnpack(); - - DEBUG "(PM)Struct::getUnpack($self->{__typedef__}) ++ $subpacking\n"; - $packing .= $subpacking; - - - push(@items, @subitems); - } else { - if($type =~ /\w\*(\d+)/) { - my $size = $1; - $type = "Z$size"; - } - - #if($type eq 'p') { - # $packing .= 'Z*'; - # DEBUG "(PM)Struct::getUnpack($self->{__typedef__}) ++ Z*\n"; - #} else { - $packing .= $type; - DEBUG "(PM)Struct::getUnpack($self->{__typedef__}) ++ $type\n"; - #} - if($type ne 'p' and $type !~ /^Z(\d+)/ and $Win32::API::Type::PackSize{$type} < $align) { - DEBUG "(PM)Struct::getUnpack %s(%d) < %d\n", - $type, $Win32::API::Type::PackSize{$type}, $align - ; - $packing .= ("x" x ($align - $Win32::API::Type::PackSize{$type})); - } - - push(@items, $name); - } - } - DEBUG "(PM)Struct::getUnpack($self->{__typedef__}): unpack($packing, @items)\n"; - return($packing, @items); -} - -sub Unpack { - my $self = shift; - my($packing, @items) = $self->getUnpack(); - my @itemvalue = unpack($packing, $self->{buffer}); - DEBUG "(PM)Struct::Unpack: unpack($packing, buffer) = @itemvalue\n"; - foreach my $i (0..$#items) { - my $recipient = $self->{buffer_recipients}->[$i]; - DEBUG "(PM)Struct::Unpack: %s(%s) = '%s' (0x%08x)\n", - $recipient->{__typedef__}, - $items[$i], - $itemvalue[$i], - $itemvalue[$i], - ; - $recipient->{$items[$i]} = $itemvalue[$i]; - DEBUG "(PM)Struct::Unpack: self.$items[$i] = $self->{$items[$i]}\n"; - } -} - -sub FromMemory { - my($self, $addr) = @_; - DEBUG "(PM)Struct::FromMemory: doing Pack\n"; - $self->Pack(); - DEBUG "(PM)Struct::FromMemory: doing GetMemory( 0x%08x, %d )\n", $addr, $self->sizeof; - $self->{buffer} = Win32::API::ReadMemory( $addr, $self->sizeof ); - $self->Unpack(); - DEBUG "(PM)Struct::FromMemory: doing Unpack\n"; - DEBUG "(PM)Struct::FromMemory: structure is now:\n"; - $self->Dump() if DEBUG; - DEBUG "\n"; -} - -sub Dump { - my $self = shift; - my $prefix = shift; - foreach my $member (@{ $self->{typedef} }) { - ($name, $packing, $type) = @$member; - if( ref($self->{$name}) ) { - $self->{$name}->Dump($name); - } else { - printf "%-20s %-20s %-20s\n", $prefix, $name, $self->{$name}; - } - } -} - - -sub is_known { - my $name = shift; - if(exists $Known{ $name }) { - return 1; - } else { - if($name =~ s/^LP//) { - return exists $Known{ $name }; - } - return 0; - } -} - -sub TIEHASH { - return Win32::API::Struct::new(@_); -} - -sub EXISTS { - -} - -sub FETCH { - my $self = shift; - my $key = shift; - - if($key eq 'sizeof') { - return $self->sizeof; - } - my @members = map { $_->[0] } @{ $self->{typedef} }; - if(grep(/^\Q$key\E$/, @members)) { - return $self->{$key}; - } else { - warn "'$key' is not a member of Win32::API::Struct $self->{__typedef__}"; - } -} - -sub STORE { - my $self = shift; - my($key, $val) = @_; - my @members = map { $_->[0] } @{ $self->{typedef} }; - if(grep(/^\Q$key\E$/, @members)) { - $self->{$key} = $val; - } else { - warn "'$key' is not a member of Win32::API::Struct $self->{__typedef__}"; - } -} - -sub FIRSTKEY { - my $self = shift; - my @members = map { $_->[0] } @{ $self->{typedef} }; - return $members[0]; -} - -sub NEXTKEY { - my $self = shift; - my $key = shift; - my @members = map { $_->[0] } @{ $self->{typedef} }; - for my $i (0..$#members-1) { - return $members[$i+1] if $members[$i] eq $key; - } - return undef; -} - -1; - -####################################################################### -# DOCUMENTATION -# - -=head1 NAME - -Win32::API::Struct - C struct support package for Win32::API - -=head1 SYNOPSIS - - use Win32::API; - - Win32::API::Struct->typedef( 'POINT', qw( - LONG x; - LONG y; - )); - - my $Point = Win32::API::Struct->new( 'POINT' ); - $Point->{x} = 1024; - $Point->{y} = 768; - - #### alternatively - - tie %Point, 'Win32::API::Struct', 'POINT'; - $Point{x} = 1024; - $Point{y} = 768; - - -=head1 ABSTRACT - -This module enables you to define C structs for use with -Win32::API. - -See L<Win32::API> for more info about its usage. - -=head1 DESCRIPTION - -This module is automatically imported by Win32::API, so you don't -need to 'use' it explicitly. The main methods are C<typedef> and -C<new>, which are documented below. - -=over 4 - -=item C<typedef NAME, TYPE, MEMBER, TYPE, MEMBER, ...> - -This method defines a structure named C<NAME>. The definition consists -of types and member names, just like in C. In fact, most of the -times you can cut the C definition for a structure and paste it -verbatim to your script, enclosing it in a C<qw()> block. The -function takes care of removing the semicolon after the member -name. - -The synopsis example could be written like this: - - Win32::API::Struct->typedef('POINT', 'LONG', 'x', 'LONG', 'y'); - -But it could also be written like this (note the indirect object -syntax), which is pretty cool: - - typedef Win32::API::Struct POINT => qw{ - LONG x; - LONG y; - }; - -Also note that C<typedef> automatically defines an 'LPNAME' type, -which holds a pointer to your structure. In the example above, -'LPPOINT' is also defined and can be used in a call to a -Win32::API (in fact, this is what you're really going to use when -doing API calls). - -=item C<new NAME> - -This creates a structure (a Win32::API::Struct object) of the -type C<NAME> (it must have been defined with C<typedef>). In Perl, -when you create a structure, all the members are undefined. But -when you use that structure in C (eg. a Win32::API call), you -can safely assume that they will be treated as zero (or NULL). - -=item C<sizeof> - -This returns the size, in bytes, of the structure. Acts just like -the C function of the same name. It is particularly useful for -structures that need a member to be initialized to the structure's -own size. - -=item C<align [SIZE]> - -Sets or returns the structure alignment (eg. how the structure is -stored in memory). This is a very advanced option, and you normally -don't need to mess with it. -All structures in the Win32 Platform SDK should work without it. -But if you define your own structure, you may need to give it an -explicit alignment. In most cases, passing a C<SIZE> of 'auto' -should keep the world happy. - -=back - -=head2 THE C<tie> INTERFACE - -Instead of creating an object with the C<new> method, you can -tie a hash, which will hold the desired structure, using the -C<tie> builtin function: - - tie %structure, Win32::API::Struct => 'NAME'; - -The differences between the tied and non-tied approaches are: - -=over 4 - -=item * -with tied structures, you can access members directly as -hash lookups, eg. - - # tied # non-tied - $Point{x} vs. $Point->{x} - -=item * -with tied structures, when you try to fetch or store a -member that is not part of the structure, it will result -in a warning, eg. - - print $Point{z}; - # this will warn: 'z' is not a member of Win32::API::Struct POINT - -=item * -when you pass a tied structure as a Win32::API parameter, -remember to backslash it, eg. - - # tied # non-tied - GetCursorPos( \%Point ) vs. GetCursorPos( $Point ) - -=back - -=head1 AUTHOR - -Aldo Calpini ( I<dada@perl.it> ). - -=head1 MAINTAINER - -Cosimo Streppone ( I<cosimo@cpan.org> ). - -=cut diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Win32/API/Test.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Win32/API/Test.pm deleted file mode 100644 index 6cbeed6bfac..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/Win32/API/Test.pm +++ /dev/null @@ -1,120 +0,0 @@ -# -# Win32::API::Test - Test helper package for Win32::API -# -# Version: 0.01 -# Date: 23 Dec 2006 -# Author: Cosimo Streppone <cosimo@cpan.org> -# -# $Id: API.pm,v 1.0 2001/10/30 13:57:31 dada Exp $ -# -package Win32::API::Test; - -sub compiler_name () { - use Config; - my $cc = $Config{ccname}; - if($cc eq 'cl' || $cc eq 'cl.exe') - { - $cc = 'cl'; - } - return($cc); -} - -sub compiler_version () { - use Config; - my $ver = $Config{ccversion} || 0; - if( $ver =~ /^(\d+\.\d+)/ ) - { - $ver = 0 + $1; - } - return($ver); -} - -# -# Run the compiler and get version from there... -# User might be running a compiler different from -# that used to build perl. -# For example, Cosimo does. For testing, of course. -# -# *** -# *** IT DOES NOT WORK NOW. -# *** FOR REASONS I DON'T KNOW, CL.EXE OUTPUTS ITS -# *** VERSION STRING IN THE FIRST TWO LINES THAT -# *** I'M NOT ABLE TO CATCH... -# *** -# -sub compiler_version_from_shell () { - my $cc = compiler_name(); - my $ver; - # MSVC - if($cc eq 'cl') - { - my @ver = `$cc`; - my $ver = join('',@ver); - print 'VER:'.$ver.':'."\n"; - if($ver =~ /Version (\d[\d\.]+)/ms ) - { - $ver = $1; - } - } - # GCC - elsif($cc eq 'cc' || $cc eq 'gcc' || $cc eq 'winegcc' ) - { - $ver = join('', `$cc --version`); - if($ver =~ /gcc.*(\d[\d+]+)/ms ) - { - $ver = $1; - } - } - # Borland C - elsif($cc eq 'bcc32' || $cc eq 'bcc') - { - $ver = join('', `$cc`); - if($ver =~ /Borland C\+\+ (\d[\d\.]+)/ms ) - { - $ver = $1; - } - } - return($ver); -} - -sub find_test_dll () { - require File::Spec; - my $dll_name = $_[0]; - my @paths = qw(.. ../t ../t/dll . ./dll ./t/dll); - while(my $path = shift @paths) - { - $dll = File::Spec->catfile($path, $dll_name); - return $dll if -s $dll; - } - return(undef); -} - -1; - -__END__ - - -####################################################################### -# DOCUMENTATION -# - -=head1 NAME - -Win32::API::Test - Test helper package for Win32::API - -=head1 SYNOPSIS - - my $test_dll = Win32::API::Test::find_test_dll('API_test.dll'); - -Check the t/*.t test scripts for more details. - -=head1 DESCRIPTION - -Simple package to hold Win32::API test suite helper functions. -No more, no less. - -=head1 AUTHOR - -Cosimo Streppone ( I<cosimo@cpan.org> ) - -=cut diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Win32/API/Type.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Win32/API/Type.pm deleted file mode 100644 index 334b0b731e1..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/Win32/API/Type.pm +++ /dev/null @@ -1,446 +0,0 @@ -package Win32::API::Type; - -# See the bottom of this file for the POD documentation. Search for the -# string '=head'. - -####################################################################### -# -# Win32::API::Type - Perl Win32 API type definitions -# -# Author: Aldo Calpini <dada@perl.it> -# Maintainer: Cosimo Streppone <cosimo@cpan.org> -# -# $Id: Type.pm,v 1.0 2001/10/30 13:57:31 dada Exp $ -####################################################################### - -$VERSION = '0.47'; - -use Carp; - -require Exporter; # to export the constants to the main:: space -require DynaLoader; # to dynuhlode the module. -@ISA = qw( Exporter DynaLoader ); - -use vars qw( %Known %PackSize %Modifier %Pointer ); - -sub DEBUG { - if ($Win32::API::DEBUG) { - printf @_ if @_ or return 1; - } else { - return 0; - } -} - -%Known = (); -%PackSize = (); -%Modifier = (); -%Pointer = (); - -# Initialize data structures at startup. -# Aldo wants to keep the <DATA> approach. -# -my $section = 'nothing'; -foreach (<DATA>) { - next if /^\s*#/ or /^\s*$/; - chomp; - if( /\[(.+)\]/) { - $section = $1; - next; - } - if($section eq 'TYPE') { - my($name, $packing) = split(/\s+/); - # DEBUG "(PM)Type::INIT: Known('$name') => '$packing'\n"; - $Known{$name} = $packing; - } elsif($section eq 'PACKSIZE') { - my($packing, $size) = split(/\s+/); - # DEBUG "(PM)Type::INIT: PackSize('$packing') => '$size'\n"; - $PackSize{$packing} = $size; - } elsif($section eq 'MODIFIER') { - my($modifier, $mapto) = split(/\s+/, $_, 2); - my %maps = (); - foreach my $item (split(/\s+/, $mapto)) { - my($k, $v) = split(/=/, $item); - $maps{$k} = $v; - } - # DEBUG "(PM)Type::INIT: Modifier('$modifier') => '%maps'\n"; - $Modifier{$modifier} = { %maps }; - } elsif($section eq 'POINTER') { - my($pointer, $pointto) = split(/\s+/); - # DEBUG "(PM)Type::INIT: Pointer('$pointer') => '$pointto'\n"; - $Pointer{$pointer} = $pointto; - } -} -close(DATA); - -sub new { - my $class = shift; - my($type) = @_; - my $packing = packing($type); - my $size = sizeof($type); - my $self = { - type => $type, - packing => $packing, - size => $size, - }; - return bless $self; -} - -sub typedef { - my $class = shift; - my($name, $type) = @_; - my $packing = packing($type, $name); - DEBUG "(PM)Type::typedef: packing='$packing'\n"; - my $size = sizeof($type); - $Known{$name} = $packing; - return 1; -} - - -sub is_known { - my $self = shift; - my $type = shift; - $type = $self unless defined $type; - if(ref($type) =~ /Win32::API::Type/) { - return 1; - } else { - return defined packing($type); - } -} - -sub sizeof { - my $self = shift; - my $type = shift; - $type = $self unless defined $type; - if(ref($type) =~ /Win32::API::Type/) { - return $self->{size}; - } else { - my $packing = packing($type); - if($packing =~ /(\w)\*(\d+)/) { - return $PackSize{ $1 } * $2; - } else { - return $PackSize{ $packing }; - } - } -} - -sub packing { - # DEBUG "(PM)Type::packing: called by ". join("::", (caller(1))[0,3]). "\n"; - my $self = shift; - my $is_pointer = 0; - if(ref($self) =~ /Win32::API::Type/) { - # DEBUG "(PM)Type::packing: got an object\n"; - return $self->{packing}; - } - my $type = ($self eq 'Win32::API::Type') ? shift : $self; - my $name = shift; - - # DEBUG "(PM)Type::packing: got '$type', '$name'\n"; - my($modifier, $size, $packing); - if(exists $Pointer{$type}) { - # DEBUG "(PM)Type::packing: got '$type', is really '$Pointer{$type}'\n"; - $type = $Pointer{$type}; - $is_pointer = 1; - } elsif($type =~ /(\w+)\s+(\w+)/) { - $modifier = $1; - $type = $2; - # DEBUG "(PM)packing: got modifier '$modifier', type '$type'\n"; - } - - $type =~ s/\*$//; - - if(exists $Known{$type}) { - if(defined $name and $name =~ s/\[(.*)\]$//) { - $size = $1; - $packing = $Known{$type}[0]."*".$size; - # DEBUG "(PM)Type::packing: composite packing: '$packing' '$size'\n"; - } else { - $packing = $Known{$type}; - if($is_pointer and $packing eq 'c') { - $packing = "p"; - } - # DEBUG "(PM)Type::packing: simple packing: '$packing'\n"; - } - if(defined $modifier and exists $Modifier{$modifier}->{$type}) { - # DEBUG "(PM)Type::packing: applying modifier '$modifier' -> '$Modifier{$modifier}->{$type}'\n"; - $packing = $Modifier{$modifier}->{$type}; - } - return $packing; - } else { - # DEBUG "(PM)Type::packing: NOT FOUND\n"; - return undef; - } -} - - -sub is_pointer { - my $self = shift; - my $type = shift; - $type = $self unless defined $type; - if(ref($type) =~ /Win32::API::Type/) { - return 1; - } else { - if($type =~ /\*$/) { - return 1; - } else { - return exists $Pointer{$type}; - } - } -} - -sub Pack { - my $type = $_[0]; - - if(packing($type) eq 'c' and is_pointer($type)) { - $_[1] = pack("Z*", $_[1]); - return $_[1]; - } - $_[1] = pack( packing($type), $_[1]); - return $_[1]; -} - -sub Unpack { - my $type = $_[0]; - if(packing($type) eq 'c' and is_pointer($type)) { - DEBUG "(PM)Type::Unpack: got packing 'c', is a pointer, unpacking 'Z*' '$_[1]'\n"; - $_[1] = unpack("Z*", $_[1]); - DEBUG "(PM)Type::Unpack: returning '$_[1]'\n"; - return $_[1]; - } - DEBUG "(PM)Type::Unpack: unpacking '".packing($type)."' '$_[1]'\n"; - $_[1] = unpack( packing($type), $_[1]); - DEBUG "(PM)Type::Unpack: returning '$_[1]'\n"; - return $_[1]; -} - -1; - -####################################################################### -# DOCUMENTATION -# - -=head1 NAME - -Win32::API::Type - C type support package for Win32::API - -=head1 SYNOPSIS - - use Win32::API; - - Win32::API::Type->typedef( 'my_number', 'LONG' ); - - -=head1 ABSTRACT - -This module is a support package for Win32::API that implements -C types for the import with prototype functionality. - -See L<Win32::API> for more info about its usage. - -=head1 DESCRIPTION - -This module is automatically imported by Win32::API, so you don't -need to 'use' it explicitly. These are the methods of this package: - -=over 4 - -=item C<typedef NAME, TYPE> - -This method defines a new type named C<NAME>. This actually just -creates an alias for the already-defined type C<TYPE>, which you -can use as a parameter in a Win32::API call. - -=item C<sizeof TYPE> - -This returns the size, in bytes, of C<TYPE>. Acts just like -the C function of the same name. - -=item C<is_known TYPE> - -Returns true if C<TYPE> is known by Win32::API::Type, false -otherwise. - -=back - -=head2 SUPPORTED TYPES - -This module should recognize all the types defined in the -Win32 Platform SDK header files. -Please see the source for this module, in the C<__DATA__> section, -for the full list. - -=head1 AUTHOR - -Aldo Calpini ( I<dada@perl.it> ). - -=head1 MAINTAINER - -Cosimo Streppone ( I<cosimo@cpan.org> ). - -=cut - - -__DATA__ - -[TYPE] -ATOM s -BOOL L -BOOLEAN c -BYTE C -CHAR c -COLORREF L -DWORD L -DWORD32 L -DWORD64 Q -FLOAT f -HACCEL L -HANDLE L -HBITMAP L -HBRUSH L -HCOLORSPACE L -HCONV L -HCONVLIST L -HCURSOR L -HDC L -HDDEDATA L -HDESK L -HDROP L -HDWP L -HENHMETAFILE L -HFILE L -HFONT L -HGDIOBJ L -HGLOBAL L -HHOOK L -HICON L -HIMC L -HINSTANCE L -HKEY L -HKL L -HLOCAL L -HMENU L -HMETAFILE L -HMODULE L -HPALETTE L -HPEN L -HRGN L -HRSRC L -HSZ L -HWINSTA L -HWND L -INT i -INT32 i -INT64 q -LANGID s -LCID L -LCSCSTYPE L -LCSGAMUTMATCH L -LCTYPE L -LONG l -LONG32 l -LONG64 q -LONGLONG q -LPARAM L -LRESULT L -REGSAM L -SC_HANDLE L -SC_LOCK L -SERVICE_STATUS_HANDLE L -SHORT s -SIZE_T L -SSIZE_T L -TBYTE c -TCHAR C -UCHAR C -UINT I -UINT_PTR L -UINT32 I -UINT64 Q -ULONG L -ULONG32 L -ULONG64 Q -ULONGLONG Q -USHORT S -WCHAR S -WORD S -WPARAM L -VOID c - -int i -long l -float f -double d -char c - -#CRITICAL_SECTION 24 -- a structure -#LUID ? 8 -- a structure -#VOID 0 -#CONST 4 -#FILE_SEGMENT_ELEMENT 8 -- a structure - -[PACKSIZE] -c 1 -C 1 -d 8 -f 4 -i 4 -I 4 -l 4 -L 4 -q 8 -Q 8 -s 2 -S 2 -p 4 - -[MODIFIER] -unsigned int=I long=L short=S char=C - -[POINTER] -INT_PTR INT -LPBOOL BOOL -LPBYTE BYTE -LPCOLORREF COLORREF -LPCSTR CHAR -#LPCTSTR CHAR or WCHAR -LPCTSTR CHAR -LPCVOID any -LPCWSTR WCHAR -LPDWORD DWORD -LPHANDLE HANDLE -LPINT INT -LPLONG LONG -LPSTR CHAR -#LPTSTR CHAR or WCHAR -LPTSTR CHAR -LPVOID VOID -LPWORD WORD -LPWSTR WCHAR - -PBOOL BOOL -PBOOLEAN BOOL -PBYTE BYTE -PCHAR CHAR -PCSTR CSTR -PCWCH CWCH -PCWSTR CWSTR -PDWORD DWORD -PFLOAT FLOAT -PHANDLE HANDLE -PHKEY HKEY -PINT INT -PLCID LCID -PLONG LONG -PSHORT SHORT -PSTR CHAR -#PTBYTE TBYTE -- -#PTCHAR TCHAR -- -#PTSTR CHAR or WCHAR -PTSTR CHAR -PUCHAR UCHAR -PUINT UINT -PULONG ULONG -PUSHORT USHORT -PVOID VOID -PWCHAR WCHAR -PWORD WORD -PWSTR WCHAR diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Win32/Env.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Win32/Env.pm deleted file mode 100644 index c5420718175..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/Win32/Env.pm +++ /dev/null @@ -1,169 +0,0 @@ -package Win32::Env; -our $VERSION='0.01'; - -=head1 NAME - -Win32::Env - get and set global system and user enviroment varialbes under Win32. - -=head1 VERSION - -Version 0.01 - -=head1 SYNOPSIS - - use Win32::Env; - - my $user_path=GetEnv(ENV_USER, 'PATH'); - # Limit PATH for other programs to system path and specified directory for 10 seconds - SetEnv(ENV_USER, 'PATH', 'C:\\Perl\\bin'); - BroadcastEnv(); - sleep(10); - # Restore everything back - SetEnv(ENV_USER, 'PATH', $user_path); - BroadcastEnv(); - -=cut - - -use warnings; -use strict; - -use Win32::TieRegistry(FixSzNulls=>1); - -use Exporter qw(import); -our @EXPORT=qw(SetEnv GetEnv BroadcastEnv ENV_USER ENV_SYSTEM); - -use constant ENV_USER =>0; -use constant ENV_SYSTEM =>1; - -use constant ENVKEY_USER => 'HKEY_CURRENT_USER\\Environment'; -use constant ENVKEY_SYSTEM => 'HKEY_LOCAL_MACHINE\\SYSTEM\\CurrentControlSet\\Control\\Session Manager\\Environment'; - -=head1 EXPORT - -SetEnv GetEnv BroadcastEnv ENV_USER ENV_SYSTEM - -=head1 FUNCTIONS - -=cut - -sub _NWA{ - my $lib=shift, - my @proto=@_; - require Win32::API; - return(new Win32::API($lib, @proto) or die "Can't import API $proto[0] from $lib: $^E\n"); -} - -# TODO: error/sanity checks for other args -sub _num_to_key($){ - my $sysusr=shift; - if($sysusr==ENV_USER) { $sysusr=ENVKEY_USER; } - elsif($sysusr==ENV_SYSTEM) { $sysusr=ENVKEY_SYSTEM; } - else { return; } # And Carp! - return $sysusr; -} - -=head2 SetEnv($sys_or_usr, $variable, $value) - -Sets variable in enviroment to specified value. C<$sys_or_usr> specifies either -current user's enviroment with exported constant C<ENV_USER> or system's global environment -with C<ENV_SYSTEM>. - -=cut - -sub SetEnv($$$){ - my ($sysusr, $var, $value)=@_; - $sysusr=(_num_to_key($sysusr) or return); - $Registry->{"$sysusr\\$var"}=$value; -} - -=head2 GetEnv($sys_or_usr, $variable) - -Returns value of enviroment variable. Its difference from plain C<$ENV{$variable}> is that -you can (and must) select current user's or system's global enviroment with C<$sys_or_usr>. -It is selected with same constants as in L<#SetEnv>. - -=cut - -sub GetEnv($$){ - my ($sysusr, $var, $value)=@_; - $sysusr=(_num_to_key($sysusr) or return); - return $Registry->{"$sysusr\\$var"}; -} - -=head2 BroadcastEnv() - -Broadcasts system message that enviroment has changed. This will make system processes responsible for -enviroment aware of change, otherwise your changes will be noticed only on next reboot. Note that most -user programs still won't see changes until next run and that your changes will not be available in C<%ENV> -to either your process or any processes you spawn. Assign to C<%ENV> yourself in addition to C<SetEnv> if -need it. - -=cut - -sub BroadcastEnv(){ - use constant HWND_BROADCAST => 0xffff; - use constant WM_SETTINGCHANGE => 0x001A; - print "Broadcasting \"Enviroment settings changed\" message...\n"; - # SendMessageTimeout(HWND_BROADCAST, WM_SETTINGCHANGE, 0, (LPARAM) "Environment", SMTO_ABORTIFHUNG, 5000, &dwReturnValue); - my $SendMessage=_NWA('user32', 'SendMessage', 'LLPP', 'L'); - $SendMessage->Call(HWND_BROADCAST, WM_SETTINGCHANGE, 0, 'Environment'); - print "Broadcast complete.\n"; -} - -1; - -=head1 AUTHOR - -Oleg "Rowaa[SR13]" V. Volkov, C<< <ROWAA at cpan.org> >> - -=head1 BUGS / TODO - -Only first argument to C<GetEnv>/C<SetEnv> is checked right now. Considering that functions work with -Windows registry, more sanity checks should be added to other arguments. - -Any limitations of Win32::TieRegistry apply to this module too, because it is used to write all -changes to the registry. - -Please report any bugs or feature requests to -C<bug-win32-env at rt.cpan.org>, or through the web interface at -L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Win32-Env>. -I will be notified, and then you'll automatically be notified of progress on -your bug as I make changes. - -=head1 SUPPORT - -You can find documentation for this module with the perldoc command. - - perldoc Win32::Env - -You can also look for information at: - -=over 4 - -=item * AnnoCPAN: Annotated CPAN documentation - -L<http://annocpan.org/dist/Win32-Env> - -=item * CPAN Ratings - -L<http://cpanratings.perl.org/d/Win32-Env> - -=item * RT: CPAN's request tracker - -L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Win32-Env> - -=item * Search CPAN - -L<http://search.cpan.org/dist/Win32-Env> - -=back - -=head1 COPYRIGHT & LICENSE - -Copyright 2006 Oleg "Rowaa[SR13]" V. Volkov, all rights reserved. - -This program is free software; you can redistribute it and/or modify it -under the same terms as Perl itself. - -=cut diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Win32/Registry.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Win32/Registry.pm deleted file mode 100644 index c83fca5a3b1..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/Win32/Registry.pm +++ /dev/null @@ -1,547 +0,0 @@ -package Win32::Registry; - -=head1 NAME - -Win32::Registry - accessing the Windows registry [obsolete, use Win32::TieRegistry] - -=head1 SYNOPSIS - - use Win32::Registry; - my $tips; - $::HKEY_LOCAL_MACHINE->Open("SOFTWARE\\Microsoft\\Windows" - ."\\CurrentVersion\\Explorer\\Tips", $tips) - or die "Can't open tips: $^E"; - my ($type, $value); - $tips->QueryValueEx("18", $type, $value) or die "No tip #18: $^E"; - print "Here's a tip: $value\n"; - -=head1 DESCRIPTION - - NOTE: This module provides a very klunky interface to access the - Windows registry, and is not currently being developed actively. It - only exists for backward compatibility with old code that uses it. - For more powerful and flexible ways to access the registry, use - Win32::TieRegistry. - -Win32::Registry provides an object oriented interface to the Windows -Registry. - -The following "root" registry objects are exported to the main:: name -space. Additional keys must be opened by calling the provided methods -on one of these. - - $HKEY_CLASSES_ROOT - $HKEY_CURRENT_USER - $HKEY_LOCAL_MACHINE - $HKEY_USERS - $HKEY_PERFORMANCE_DATA - $HKEY_CURRENT_CONFIG - $HKEY_DYN_DATA - -=cut - -use strict; -require Exporter; -require DynaLoader; -use Win32::WinError; - -require Win32 unless defined &Win32::GetLastError; - -use vars qw($VERSION $AUTOLOAD @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); - -$VERSION = '0.07'; - -@ISA = qw( Exporter DynaLoader ); -@EXPORT = qw( - HKEY_CLASSES_ROOT - HKEY_CURRENT_USER - HKEY_LOCAL_MACHINE - HKEY_PERFORMANCE_DATA - HKEY_CURRENT_CONFIG - HKEY_DYN_DATA - HKEY_USERS - KEY_ALL_ACCESS - KEY_CREATE_LINK - KEY_CREATE_SUB_KEY - KEY_ENUMERATE_SUB_KEYS - KEY_EXECUTE - KEY_NOTIFY - KEY_QUERY_VALUE - KEY_READ - KEY_SET_VALUE - KEY_WRITE - REG_BINARY - REG_CREATED_NEW_KEY - REG_DWORD - REG_DWORD_BIG_ENDIAN - REG_DWORD_LITTLE_ENDIAN - REG_EXPAND_SZ - REG_FULL_RESOURCE_DESCRIPTOR - REG_LEGAL_CHANGE_FILTER - REG_LEGAL_OPTION - REG_LINK - REG_MULTI_SZ - REG_NONE - REG_NOTIFY_CHANGE_ATTRIBUTES - REG_NOTIFY_CHANGE_LAST_SET - REG_NOTIFY_CHANGE_NAME - REG_NOTIFY_CHANGE_SECURITY - REG_OPENED_EXISTING_KEY - REG_OPTION_BACKUP_RESTORE - REG_OPTION_CREATE_LINK - REG_OPTION_NON_VOLATILE - REG_OPTION_RESERVED - REG_OPTION_VOLATILE - REG_REFRESH_HIVE - REG_RESOURCE_LIST - REG_RESOURCE_REQUIREMENTS_LIST - REG_SZ - REG_WHOLE_HIVE_VOLATILE -); - -@EXPORT_OK = qw( - RegCloseKey - RegConnectRegistry - RegCreateKey - RegCreateKeyEx - RegDeleteKey - RegDeleteValue - RegEnumKey - RegEnumValue - RegFlushKey - RegGetKeySecurity - RegLoadKey - RegNotifyChangeKeyValue - RegOpenKey - RegOpenKeyEx - RegQueryInfoKey - RegQueryValue - RegQueryValueEx - RegReplaceKey - RegRestoreKey - RegSaveKey - RegSetKeySecurity - RegSetValue - RegSetValueEx - RegUnLoadKey -); -$EXPORT_TAGS{ALL}= \@EXPORT_OK; - -bootstrap Win32::Registry; - -sub import { - my $pkg = shift; - if ($_[0] && "Win32" eq $_[0]) { - Exporter::export($pkg, "Win32", @EXPORT_OK); - shift; - } - Win32::Registry->export_to_level(1+$Exporter::ExportLevel, $pkg, @_); -} - -####################################################################### -# This AUTOLOAD is used to 'autoload' constants from the constant() -# XS function. If a constant is not found then control is passed -# to the AUTOLOAD in AutoLoader. - -sub AUTOLOAD { - my($constname); - ($constname = $AUTOLOAD) =~ s/.*:://; - #reset $! to zero to reset any current errors. - local $! = 0; - my $val = constant($constname, 0); - if ($! != 0) { - if ($! =~ /Invalid/) { - $AutoLoader::AUTOLOAD = $AUTOLOAD; - goto &AutoLoader::AUTOLOAD; - } - else { - my ($pack,$file,$line) = caller; - die "Unknown constant $constname in Win32::Registry " - . "at $file line $line.\n"; - } - } - eval "sub $AUTOLOAD { $val }"; - goto &$AUTOLOAD; -} - -####################################################################### -# _new is a private constructor, not intended for public use. -# - -sub _new { - my $self; - if ($_[0]) { - $self->{'handle'} = $_[0]; - bless $self; - } - $self; -} - -#define the basic registry objects to be exported. -#these had to be hardwired unfortunately. -# XXX Yuck! - -{ - package main; - use vars qw( - $HKEY_CLASSES_ROOT - $HKEY_CURRENT_USER - $HKEY_LOCAL_MACHINE - $HKEY_USERS - $HKEY_PERFORMANCE_DATA - $HKEY_CURRENT_CONFIG - $HKEY_DYN_DATA - ); -} - -$::HKEY_CLASSES_ROOT = _new(&HKEY_CLASSES_ROOT); -$::HKEY_CURRENT_USER = _new(&HKEY_CURRENT_USER); -$::HKEY_LOCAL_MACHINE = _new(&HKEY_LOCAL_MACHINE); -$::HKEY_USERS = _new(&HKEY_USERS); -$::HKEY_PERFORMANCE_DATA = _new(&HKEY_PERFORMANCE_DATA); -$::HKEY_CURRENT_CONFIG = _new(&HKEY_CURRENT_CONFIG); -$::HKEY_DYN_DATA = _new(&HKEY_DYN_DATA); - -=head2 Methods - -The following methods are supported. Note that subkeys can be -specified as a path name, separated by backslashes (which may -need to be doubled if you put them in double quotes). - -=over 8 - -=item Open - - $reg_obj->Open($sub_key_name, $sub_reg_obj); - -Opens a subkey of a registry object, returning the new registry object -in $sub_reg_obj. - -=cut - -sub Open { - my $self = shift; - die 'usage: $obj->Open($sub_key_name, $sub_reg_obj)' if @_ != 2; - - my ($subkey) = @_; - my ($result,$subhandle); - - $result = RegOpenKey($self->{'handle'},$subkey,$subhandle); - $_[1] = _new($subhandle); - - return 0 unless $_[1]; - $! = Win32::GetLastError() unless $result; - return $result; -} - -=item Close - - $reg_obj->Close(); - -Closes an open registry key. - -=cut - -sub Close { - my $self = shift; - die 'usage: $obj->Close()' if @_ != 0; - - return unless exists $self->{'handle'}; - my $result = RegCloseKey($self->{'handle'}); - if ($result) { - delete $self->{'handle'}; - } - else { - $! = Win32::GetLastError(); - } - return $result; -} - -sub DESTROY { - my $self = shift; - return unless exists $self->{'handle'}; - RegCloseKey($self->{'handle'}); - delete $self->{'handle'}; -} - - -=item Connect - - $reg_obj->Connect($node_name, $new_reg_obj); - -Connects to a remote Registry on the node specified by $node_name, -returning it in $new_reg_obj. Returns false if it fails. - -=cut - -sub Connect { - my $self = shift; - die 'usage: $obj->Connect($node_name, $new_reg_obj)' if @_ != 2; - - my ($node) = @_; - my ($result,$subhandle); - - $result = RegConnectRegistry ($node, $self->{'handle'}, $subhandle); - $_[1] = _new($subhandle); - - return 0 unless $_[1]; - $! = Win32::GetLastError() unless $result; - return $result; -} - -=item Create - - $reg_obj->Create($sub_key_name, $new_reg_obj); - -Opens the subkey specified by $sub_key_name, returning the new registry -object in $new_reg_obj. If the specified subkey doesn't exist, it is -created. - -=cut - -sub Create { - my $self = shift; - die 'usage: $obj->Create($sub_key_name, $new_reg_obj)' if @_ != 2; - - my ($subkey) = @_; - my ($result,$subhandle); - - $result = RegCreateKey($self->{'handle'},$subkey,$subhandle); - $_[1] = _new ($subhandle); - - return 0 unless $_[1]; - $! = Win32::GetLastError() unless $result; - return $result; -} - -=item SetValue - - $reg_obj->SetValue($sub_key_name, $type, $value); - -Sets the default value for a subkey specified by $sub_key_name. - -=cut - -sub SetValue { - my $self = shift; - die 'usage: $obj->SetValue($subkey, $type, $value)' if @_ != 3; - my $result = RegSetValue($self->{'handle'}, @_); - $! = Win32::GetLastError() unless $result; - return $result; -} - -=item SetValueEx - - $reg_obj->SetValueEx($value_name, $reserved, $type, $value); - -Sets the value for the value name identified by $value_name -in the key specified by $reg_obj. - -=cut - -sub SetValueEx { - my $self = shift; - die 'usage: $obj->SetValueEx($value_name, $reserved, $type, $value)' if @_ != 4; - my $result = RegSetValueEx($self->{'handle'}, @_); - $! = Win32::GetLastError() unless $result; - return $result; -} - -=item QueryValue - - $reg_obj->QueryValue($sub_key_name, $value); - -Gets the default value of the subkey specified by $sub_key_name. - -=cut - -sub QueryValue { - my $self = shift; - die 'usage: $obj->QueryValue($sub_key_name, $value)' if @_ != 2; - my $result = RegQueryValue($self->{'handle'}, $_[0], $_[1]); - $! = Win32::GetLastError() unless $result; - return $result; -} - -=item QueryKey - - $reg_obj->QueryKey($classref, $number_of_subkeys, $number_of_values); - -Gets information on a key specified by $reg_obj. - -=cut - -sub QueryKey { - my $garbage; - my $self = shift; - die 'usage: $obj->QueryKey($classref, $number_of_subkeys, $number_of_values)' - if @_ != 3; - - my $result = RegQueryInfoKey($self->{'handle'}, $_[0], - $garbage, $garbage, $_[1], - $garbage, $garbage, $_[2], - $garbage, $garbage, $garbage, $garbage); - - $! = Win32::GetLastError() unless $result; - return $result; -} - -=item QueryValueEx - - $reg_obj->QueryValueEx($value_name, $type, $value); - -Gets the value for the value name identified by $value_name -in the key specified by $reg_obj. - -=cut - -sub QueryValueEx { - my $self = shift; - die 'usage: $obj->QueryValueEx($value_name, $type, $value)' if @_ != 3; - my $result = RegQueryValueEx($self->{'handle'}, $_[0], undef, $_[1], $_[2]); - $! = Win32::GetLastError() unless $result; - return $result; -} - -=item GetKeys - - my @keys; - $reg_obj->GetKeys(\@keys); - -Populates the supplied array reference with the names of all the keys -within the registry object $reg_obj. - -=cut - -sub GetKeys { - my $self = shift; - die 'usage: $obj->GetKeys($arrayref)' if @_ != 1 or ref($_[0]) ne 'ARRAY'; - - my ($result, $i, $keyname); - $keyname = "DummyVal"; - $i = 0; - $result = 1; - - while ( $result ) { - $result = RegEnumKey( $self->{'handle'},$i++, $keyname ); - if ($result) { - push( @{$_[0]}, $keyname ); - } - } - return(1); -} - -=item GetValues - - my %values; - $reg_obj->GetValues(\%values); - -Populates the supplied hash reference with entries of the form - - $value_name => [ $value_name, $type, $data ] - -for each value in the registry object $reg_obj. - -=cut - -sub GetValues { - my $self = shift; - die 'usage: $obj->GetValues($hashref)' if @_ != 1; - - my ($result,$name,$type,$data,$i); - $name = "DummyVal"; - $i = 0; - while ( $result=RegEnumValue( $self->{'handle'}, - $i++, - $name, - undef, - $type, - $data )) - { - $_[0]->{$name} = [ $name, $type, $data ]; - } - return(1); -} - -=item DeleteKey - - $reg_obj->DeleteKey($sub_key_name); - -Deletes a subkey specified by $sub_key_name from the registry. - -=cut - -sub DeleteKey { - my $self = shift; - die 'usage: $obj->DeleteKey($sub_key_name)' if @_ != 1; - my $result = RegDeleteKey($self->{'handle'}, @_); - $! = Win32::GetLastError() unless $result; - return $result; -} - -=item DeleteValue - - $reg_obj->DeleteValue($value_name); - -Deletes a value identified by $value_name from the registry. - -=cut - -sub DeleteValue { - my $self = shift; - die 'usage: $obj->DeleteValue($value_name)' if @_ != 1; - my $result = RegDeleteValue($self->{'handle'}, @_); - $! = Win32::GetLastError() unless $result; - return $result; -} - -=item Save - - $reg_obj->Save($filename); - -Saves the hive specified by $reg_obj to a file. - -=cut - -sub Save { - my $self = shift; - die 'usage: $obj->Save($filename)' if @_ != 1; - my $result = RegSaveKey($self->{'handle'}, @_); - $! = Win32::GetLastError() unless $result; - return $result; -} - -=item Load - - $reg_obj->Load($sub_key_name, $file_name); - -Loads a key specified by $sub_key_name from a file. - -=cut - -sub Load { - my $self = shift; - die 'usage: $obj->Load($sub_key_name, $file_name)' if @_ != 2; - my $result = RegLoadKey($self->{'handle'}, @_); - $! = Win32::GetLastError() unless $result; - return $result; -} - -=item UnLoad - - $reg_obj->Unload($sub_key_name); - -Unloads a registry hive. - -=cut - -sub UnLoad { - my $self = shift; - die 'usage: $obj->UnLoad($sub_key_name)' if @_ != 1; - my $result = RegUnLoadKey($self->{'handle'}, @_); - $! = Win32::GetLastError() unless $result; - return $result; -} - -1; -__END__ diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Win32/TieRegistry.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Win32/TieRegistry.pm deleted file mode 100644 index 0abbbddb6b8..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/Win32/TieRegistry.pm +++ /dev/null @@ -1,3801 +0,0 @@ -# Win32/TieRegistry.pm -- Perl module to easily use a Registry -# (on Win32 systems so far). -# by Tye McQueen, tye@metronet.com, see http://www.metronet.com/~tye/. - -# -# Skip to "=head" line for user documentation. -# - - -package Win32::TieRegistry; - - -use strict; -use vars qw( $PACK $VERSION @ISA @EXPORT @EXPORT_OK ); - -$PACK= "Win32::TieRegistry"; # Used in error messages. -$VERSION= '0.26'; - - -use Carp; - -require Tie::Hash; -@ISA= qw(Tie::Hash); - -# Required other modules: -use Win32API::Registry 0.12 qw( :KEY_ :HKEY_ :REG_ ); - -#Optional other modules: -use vars qw( $_NoMoreItems $_FileNotFound $_TooSmall $_MoreData $_SetDualVar ); - -if( eval { require Win32::WinError } ) { - $_NoMoreItems= Win32::WinError::constant("ERROR_NO_MORE_ITEMS",0); - $_FileNotFound= Win32::WinError::constant("ERROR_FILE_NOT_FOUND",0); - $_TooSmall= Win32::WinError::constant("ERROR_INSUFFICIENT_BUFFER",0); - $_MoreData= Win32::WinError::constant("ERROR_MORE_DATA",0); -} else { - $_NoMoreItems= "^No more data"; - $_FileNotFound= "cannot find the file"; - $_TooSmall= " data area passed to "; - $_MoreData= "^more data is avail"; -} -if( $_SetDualVar= eval { require SetDualVar } ) { - import SetDualVar; -} - - -#Implementation details: -# When opened: -# HANDLE long; actual handle value -# MACHINE string; name of remote machine ("" if local) -# PATH list ref; machine-relative full path for this key: -# ["LMachine","System","Disk"] -# ["HKEY_LOCAL_MACHINE","System","Disk"] -# DELIM char; delimiter used to separate subkeys (def="\\") -# OS_DELIM char; always "\\" for Win32 -# ACCESS long; usually KEY_ALL_ACCESS, perhaps KEY_READ, etc. -# ROOTS string; var name for "Lmachine"->HKEY_LOCAL_MACHINE map -# FLAGS int; bits to control certain options -# Often: -# VALUES ref to list of value names (data/type never cached) -# SUBKEYS ref to list of subkey names -# SUBCLASSES ref to list of subkey classes -# SUBTIMES ref to list of subkey write times -# MEMBERS ref to list of subkey_name.DELIM's, DELIM.value_name's -# MEMBHASH hash ref to with MEMBERS as keys and 1's as values -# Once Key "Info" requested: -# Class CntSubKeys CntValues MaxSubKeyLen MaxSubClassLen -# MaxValNameLen MaxValDataLen SecurityLen LastWrite -# If is tied to a hash and iterating over key values: -# PREVIDX int; index of last MEMBERS element return -# If is the key object returned by Load(): -# UNLOADME list ref; information about Load()ed key -# If is a subkey of a "loaded" key other than the one returned by Load(): -# DEPENDON obj ref; object that can't be destroyed before us - - -#Package-local variables: - -# Option flag bits: -use vars qw( $Flag_ArrVal $Flag_TieVal $Flag_DualTyp $Flag_DualBin - $Flag_FastDel $Flag_HexDWord $Flag_Split $Flag_FixNulls ); -$Flag_ArrVal= 0x0001; -$Flag_TieVal= 0x0002; -$Flag_FastDel= 0x0004; -$Flag_HexDWord= 0x0008; -$Flag_Split= 0x0010; -$Flag_DualTyp= 0x0020; -$Flag_DualBin= 0x0040; -$Flag_FixNulls= 0x0080; - - -use vars qw( $RegObj %_Roots %RegHash $Registry ); - -# Short-hand for HKEY_* constants: -%_Roots= ( - "Classes" => HKEY_CLASSES_ROOT, - "CUser" => HKEY_CURRENT_USER, - "LMachine" => HKEY_LOCAL_MACHINE, - "Users" => HKEY_USERS, - "PerfData" => HKEY_PERFORMANCE_DATA, # Too picky to be useful - "CConfig" => HKEY_CURRENT_CONFIG, - "DynData" => HKEY_DYN_DATA, # Too picky to be useful -); - -# Basic master Registry object: -$RegObj= {}; -@$RegObj{qw( HANDLE MACHINE PATH DELIM OS_DELIM ACCESS FLAGS ROOTS )}= ( - "NONE", "", [], "\\", "\\", - KEY_READ|KEY_WRITE, $Flag_HexDWord|$Flag_FixNulls, "${PACK}::_Roots" ); -$RegObj->{FLAGS} |= $Flag_DualTyp|$Flag_DualBin if $_SetDualVar; -bless $RegObj; - -# Fill cache for master Registry object: -@$RegObj{qw( VALUES SUBKEYS SUBCLASSES SUBTIMES )}= ( - [], [ keys(%_Roots) ], [], [] ); -grep( s#$#$RegObj->{DELIM}#, - @{ $RegObj->{MEMBERS}= [ @{$RegObj->{SUBKEYS}} ] } ); -@$RegObj{qw( Class MaxSubKeyLen MaxSubClassLen MaxValNameLen - MaxValDataLen SecurityLen LastWrite CntSubKeys CntValues )}= - ( "", 0, 0, 0, 0, 0, 0, 0, 0 ); - -# Create master Registry tied hash: -$RegObj->Tie( \%RegHash ); - -# Create master Registry combination object and tied hash reference: -$Registry= \%RegHash; -bless $Registry; - - -# Preloaded methods go here. - - -# Map option names to name of subroutine that controls that option: -use vars qw( @_opt_subs %_opt_subs ); -@_opt_subs= qw( Delimiter ArrayValues TieValues SplitMultis DWordsToHex - FastDelete FixSzNulls DualTypes DualBinVals AllowLoad AllowSave ); -@_opt_subs{@_opt_subs}= @_opt_subs; - -sub import -{ - my $pkg= shift(@_); - my $level= $Exporter::ExportLevel; - my $expto= caller($level); - my @export= (); - my @consts= (); - my $registry= $Registry->Clone; - local( $_ ); - while( @_ ) { - $_= shift(@_); - if( /^\$(\w+::)*\w+$/ ) { - push( @export, "ObjVar" ) if /^\$RegObj$/; - push( @export, $_ ); - } elsif( /^\%(\w+::)*\w+$/ ) { - push( @export, $_ ); - } elsif( /^[$%]/ ) { - croak "${PACK}->import: Invalid variable name ($_)"; - } elsif( /^:/ || /^(H?KEY|REG)_/ ) { - push( @consts, $_ ); - } elsif( ! @_ ) { - croak "${PACK}->import: Missing argument after option ($_)"; - } elsif( exists $_opt_subs{$_} ) { - $_= $_opt_subs{$_}; - $registry->$_( shift(@_) ); - } elsif( /^TiedRef$/ ) { - $_= shift(@_); - if( ! ref($_) && /^(\$?)(\w+::)*\w+$/ ) { - $_= '$'.$_ unless '$' eq $1; - } elsif( "SCALAR" ne ref($_) ) { - croak "${PACK}->import: Invalid var after TiedRef ($_)"; - } - push( @export, $_ ); - } elsif( /^TiedHash$/ ) { - $_= shift(@_); - if( ! ref($_) && /^(\%?)(\w+::)*\w+$/ ) { - $_= '%'.$_ unless '%' eq $1; - } elsif( "HASH" ne ref($_) ) { - croak "${PACK}->import: Invalid var after TiedHash ($_)"; - } - push( @export, $_ ); - } elsif( /^ObjectRef$/ ) { - $_= shift(@_); - if( ! ref($_) && /^(\$?)(\w+::)*\w+$/ ) { - push( @export, "ObjVar" ); - $_= '$'.$_ unless '$' eq $1; - } elsif( "SCALAR" eq ref($_) ) { - push( @export, "ObjRef" ); - } else { - croak "${PACK}->import: Invalid var after ObjectRef ($_)"; - } - push( @export, $_ ); - } elsif( /^ExportLevel$/ ) { - $level= shift(@_); - $expto= caller($level); - } elsif( /^ExportTo$/ ) { - undef $level; - $expto= caller($level); - } else { - croak "${PACK}->import: Invalid option ($_)"; - } - } - Win32API::Registry->export( $expto, @consts ) if @consts; - @export= ('$Registry') unless @export; - while( @export ) { - $_= shift( @export ); - if( /^\$((?:\w+::)*)(\w+)$/ ) { - my( $pack, $sym )= ( $1, $2 ); - $pack= $expto unless defined($pack) && "" ne $pack; - no strict 'refs'; - *{"${pack}::$sym"}= \${"${pack}::$sym"}; - ${"${pack}::$sym"}= $registry; - } elsif( /^\%((?:\w+::)*)(\w+)$/ ) { - my( $pack, $sym )= ( $1, $2 ); - $pack= $expto unless defined($pack) && "" ne $pack; - no strict 'refs'; - *{"${pack}::$sym"}= \%{"${pack}::$sym"}; - $registry->Tie( \%{"${pack}::$sym"} ); - } elsif( "SCALAR" eq ref($_) ) { - $$_= $registry; - } elsif( "HASH" eq ref($_) ) { - $registry->Tie( $_ ); - } elsif( /^ObjVar$/ ) { - $_= shift( @_ ); - /^\$((?:\w+::)*)(\w+)$/; - my( $pack, $sym )= ( $1, $2 ); - $pack= $expto unless defined($pack) && "" ne $pack; - no strict 'refs'; - *{"${pack}::$sym"}= \${"${pack}::$sym"}; - ${"${pack}::$sym"}= $registry->ObjectRef; - } elsif( /^ObjRef$/ ) { - ${shift(@_)}= $registry->ObjectRef; - } else { - die "Impossible var to export ($_)"; - } - } -} - - -use vars qw( @_new_Opts %_new_Opts ); -@_new_Opts= qw( ACCESS DELIM MACHINE DEPENDON ); -@_new_Opts{@_new_Opts}= (1) x @_new_Opts; - -sub _new -{ - my $this= shift( @_ ); - $this= tied(%$this) if ref($this) && tied(%$this); - my $class= ref($this) || $this; - my $self= {}; - my( $handle, $rpath, $opts )= @_; - if( @_ < 2 || "ARRAY" ne ref($rpath) || 3 < @_ - || 3 == @_ && "HASH" ne ref($opts) ) { - croak "Usage: ${PACK}->_new( \$handle, \\\@path, {OPT=>VAL,...} );\n", - " options: @_new_Opts\nCalled"; - } - @$self{qw( HANDLE PATH )}= ( $handle, $rpath ); - @$self{qw( MACHINE ACCESS DELIM OS_DELIM ROOTS FLAGS )}= - ( $this->Machine, $this->Access, $this->Delimiter, - $this->OS_Delimiter, $this->_Roots, $this->_Flags ); - if( ref($opts) ) { - my @err= grep( ! $_new_Opts{$_}, keys(%$opts) ); - @err and croak "${PACK}->_new: Invalid options (@err)"; - @$self{ keys(%$opts) }= values(%$opts); - } - bless $self, $class; - return $self; -} - - -sub _split -{ - my $self= shift( @_ ); - $self= tied(%$self) if tied(%$self); - my $path= shift( @_ ); - my $delim= @_ ? shift(@_) : $self->Delimiter; - my $list= [ split( /\Q$delim/, $path ) ]; - return $list; -} - - -sub _rootKey -{ - my $self= shift(@_); - $self= tied(%$self) if tied(%$self); - my $keyPath= shift(@_); - my $delim= @_ ? shift(@_) : $self->Delimiter; - my( $root, $subPath ); - if( "ARRAY" eq ref($keyPath) ) { - $subPath= $keyPath; - } else { - $subPath= $self->_split( $keyPath, $delim ); - } - $root= shift( @$subPath ); - if( $root =~ /^HKEY_/ ) { - my $handle= Win32API::Registry::constant($root,0); - $handle or croak "Invalid HKEY_ constant ($root): $!"; - return( $self->_new( $handle, [$root], {DELIM=>$delim} ), - $subPath ); - } elsif( $root =~ /^([-+]|0x)?\d/ ) { - return( $self->_new( $root, [sprintf("0x%lX",$root)], - {DELIM=>$delim} ), - $subPath ); - } else { - my $roots= $self->Roots; - if( $roots->{$root} ) { - return( $self->_new( $roots->{$root}, [$root], {DELIM=>$delim} ), - $subPath ); - } - croak "No such root key ($root)"; - } -} - - -sub _open -{ - my $this= shift(@_); - $this= tied(%$this) if ref($this) && tied(%$this); - my $subPath= shift(@_); - my $sam= @_ ? shift(@_) : $this->Access; - my $subKey= join( $this->OS_Delimiter, @$subPath ); - my $handle= 0; - $this->RegOpenKeyEx( $subKey, 0, $sam, $handle ) - or return (); - return $this->_new( $handle, [ @{$this->_Path}, @$subPath ], - { ACCESS=>$sam, ( defined($this->{UNLOADME}) ? ("DEPENDON",$this) - : defined($this->{DEPENDON}) ? ("DEPENDON",$this->{DEPENDON}) : () ) - } ); -} - - -sub ObjectRef -{ - my $self= shift(@_); - $self= tied(%$self) if tied(%$self); - return $self; -} - - -sub _constant -{ - my( $name, $desc )= @_; - my $value= Win32API::Registry::constant( $name, 0 ); - my $func= (caller(1))[3]; - if( 0 == $value ) { - if( $! =~ /invalid/i ) { - croak "$func: Invalid $desc ($name)"; - } elsif( 0 != $! ) { - croak "$func: \u$desc ($name) not support on this platform"; - } - } - return $value; -} - - -sub _connect -{ - my $this= shift(@_); - $this= tied(%$this) if ref($this) && tied(%$this); - my $subPath= pop(@_); - $subPath= $this->_split( $subPath ) unless ref($subPath); - my $machine= @_ ? shift(@_) : shift(@$subPath); - my $handle= 0; - my( $temp )= $this->_rootKey( [@$subPath] ); - $temp->RegConnectRegistry( $machine, $temp->Handle, $handle ) - or return (); - my $self= $this->_new( $handle, [shift(@$subPath)], {MACHINE=>$machine} ); - return( $self, $subPath ); -} - - -use vars qw( @Connect_Opts %Connect_Opts ); -@Connect_Opts= qw(Access Delimiter); -@Connect_Opts{@Connect_Opts}= (1) x @Connect_Opts; - -sub Connect -{ - my $this= shift(@_); - my $tied= ref($this) && tied(%$this); - $this= tied(%$this) if $tied; - my( $machine, $key, $opts )= @_; - my $delim= ""; - my $sam; - my $subPath; - if( @_ < 2 || 3 < @_ - || 3 == @_ && "HASH" ne ref($opts) ) { - croak "Usage: \$obj= ${PACK}->Connect(", - " \$Machine, \$subKey, { OPT=>VAL,... } );\n", - " options: @Connect_Opts\nCalled"; - } - if( ref($opts) ) { - my @err= grep( ! $Connect_Opts{$_}, keys(%$opts) ); - @err and croak "${PACK}->Connect: Invalid options (@err)"; - } - $delim= "$opts->{Delimiter}" if defined($opts->{Delimiter}); - $delim= $this->Delimiter if "" eq $delim; - $sam= defined($opts->{Access}) ? $opts->{Access} : $this->Access; - $sam= _constant($sam,"key access type") if $sam =~ /^KEY_/; - ( $this, $subPath )= $this->_connect( $machine, $key ); - return () unless defined($this); - my $self= $this->_open( $subPath, $sam ); - return () unless defined($self); - $self->Delimiter( $delim ); - $self= $self->TiedRef if $tied; - return $self; -} - - -my @_newVirtual_keys= qw( MEMBERS VALUES SUBKEYS SUBTIMES SUBCLASSES - Class SecurityLen LastWrite CntValues CntSubKeys - MaxValNameLen MaxValDataLen MaxSubKeyLen MaxSubClassLen ); - -sub _newVirtual -{ - my $self= shift(@_); - my( $rPath, $root, $opts )= @_; - my $new= $self->_new( "NONE", $rPath, $opts ) - or return (); - @{$new}{@_newVirtual_keys}= @{$root->ObjectRef}{@_newVirtual_keys}; - return $new; -} - - -#$key= new Win32::TieRegistry "LMachine/System/Disk"; -#$key= new Win32::TieRegistry "//Server1/LMachine/System/Disk"; -#Win32::TieRegistry->new( HKEY_LOCAL_MACHINE, {DELIM=>"/",ACCESS=>KEY_READ} ); -#Win32::TieRegistry->new( [ HKEY_LOCAL_MACHINE, ".../..." ], {DELIM=>$DELIM} ); -#$key->new( ... ); - -use vars qw( @new_Opts %new_Opts ); -@new_Opts= qw(Access Delimiter); -@new_Opts{@new_Opts}= (1) x @new_Opts; - -sub new -{ - my $this= shift( @_ ); - $this= tied(%$this) if ref($this) && tied(%$this); - if( ! ref($this) ) { - no strict "refs"; - my $self= ${"${this}::Registry"}; - croak "${this}->new failed since ${PACK}::new sees that ", - "\$${this}::Registry is not an object." - if ! ref($self); - $this= $self->Clone; - } - my( $subKey, $opts )= @_; - my $delim= ""; - my $dlen; - my $sam; - my $subPath; - if( @_ < 1 || 2 < @_ - || 2 == @_ && "HASH" ne ref($opts) ) { - croak "Usage: \$obj= ${PACK}->new( \$subKey, { OPT=>VAL,... } );\n", - " options: @new_Opts\nCalled"; - } - if( defined($opts) ) { - my @err= grep( ! $new_Opts{$_}, keys(%$opts) ); - @err and die "${PACK}->new: Invalid options (@err)"; - } - $delim= "$opts->{Delimiter}" if defined($opts->{Delimiter}); - $delim= $this->Delimiter if "" eq $delim; - $dlen= length($delim); - $sam= defined($opts->{Access}) ? $opts->{Access} : $this->Access; - $sam= _constant($sam,"key access type") if $sam =~ /^KEY_/; - if( "ARRAY" eq ref($subKey) ) { - $subPath= $subKey; - if( "NONE" eq $this->Handle && @$subPath ) { - ( $this, $subPath )= $this->_rootKey( $subPath ); - } - } elsif( $delim x 2 eq substr($subKey,0,2*$dlen) ) { - my $path= $this->_split( substr($subKey,2*$dlen), $delim ); - my $mach= shift(@$path); - if( ! @$path ) { - return $this->_newVirtual( $path, $Registry, - {MACHINE=>$mach,DELIM=>$delim,ACCESS=>$sam} ); - } - ( $this, $subPath )= $this->_connect( $mach, $path ); - return () if ! defined($this); - if( 0 == @$subPath ) { - $this->Delimiter( $delim ); - return $this; - } - } elsif( $delim eq substr($subKey,0,$dlen) ) { - ( $this, $subPath )= $this->_rootKey( substr($subKey,$dlen), $delim ); - } elsif( "NONE" eq $this->Handle && "" ne $subKey ) { - my( $mach )= $this->Machine; - if( $mach ) { - ( $this, $subPath )= $this->_connect( $mach, $subKey ); - } else { - ( $this, $subPath )= $this->_rootKey( $subKey, $delim ); - } - } else { - $subPath= $this->_split( $subKey, $delim ); - } - return () unless defined($this); - if( 0 == @$subPath && "NONE" eq $this->Handle ) { - return $this->_newVirtual( $this->_Path, $this, - { DELIM=>$delim, ACCESS=>$sam } ); - } - my $self= $this->_open( $subPath, $sam ); - return () unless defined($self); - $self->Delimiter( $delim ); - return $self; -} - - -sub Open -{ - my $self= shift(@_); - my $tied= ref($self) && tied(%$self); - $self= tied(%$self) if $tied; - $self= $self->new( @_ ); - $self= $self->TiedRef if defined($self) && $tied; - return $self; -} - - -sub Clone -{ - my $self= shift( @_ ); - my $new= $self->Open(""); - return $new; -} - - -{ my @flush; - sub Flush - { - my $self= shift(@_); - $self= tied(%$self) if tied(%$self); - my( $flush )= shift(@_); - @_ and croak "Usage: \$key->Flush( \$bFlush );"; - return 0 if "NONE" eq $self->Handle; - @flush= qw( VALUES SUBKEYS SUBCLASSES SUBTIMES MEMBERS Class - CntSubKeys CntValues MaxSubKeyLen MaxSubClassLen - MaxValNameLen MaxValDataLen SecurityLen LastWrite PREVIDX ) - unless @flush; - delete( @$self{@flush} ); - if( defined($flush) && $flush ) { - return $self->RegFlushKey(); - } else { - return 1; - } - } -} - - -sub _DualVal -{ - my( $hRef, $num )= @_; - if( $_SetDualVar && $$hRef{$num} ) { - &SetDualVar( $num, "$$hRef{$num}", 0+$num ); - } - return $num; -} - - -use vars qw( @_RegDataTypes %_RegDataTypes ); -@_RegDataTypes= qw( REG_SZ REG_EXPAND_SZ REG_BINARY REG_LINK REG_MULTI_SZ - REG_DWORD_LITTLE_ENDIAN REG_DWORD_BIG_ENDIAN REG_DWORD - REG_RESOURCE_LIST REG_FULL_RESOURCE_DESCRIPTOR - REG_RESOURCE_REQUIREMENTS_LIST REG_NONE ); -# Make sure that REG_DWORD appears _after_ other REG_DWORD_* -# items above and that REG_NONE appears _last_. -foreach( @_RegDataTypes ) { - $_RegDataTypes{Win32API::Registry::constant($_,0)}= $_; -} - -sub GetValue -{ - my $self= shift(@_); - $self= tied(%$self) if tied(%$self); - 1 == @_ or croak "Usage: (\$data,\$type)= \$key->GetValue('ValName');"; - my( $valName )= @_; - my( $valType, $valData, $dLen )= (0,"",0); - return () if "NONE" eq $self->Handle; - $self->RegQueryValueEx( $valName, [], $valType, $valData, - $dLen= ( defined($self->{MaxValDataLen}) ? $self->{MaxValDataLen} : 0 ) - ) or return (); - if( REG_DWORD == $valType ) { - my $val= unpack("L",$valData); - $valData= sprintf "0x%08.8lX", $val if $self->DWordsToHex; - &SetDualVar( $valData, $valData, $val ) if $self->DualBinVals - } elsif( REG_BINARY == $valType && length($valData) <= 4 ) { - &SetDualVar( $valData, $valData, hex reverse unpack("h*",$valData) ) - if $self->DualBinVals; - } elsif( ( REG_SZ == $valType || REG_EXPAND_SZ == $valType ) - && $self->FixSzNulls ) { - substr($valData,-1)= "" if "\0" eq substr($valData,-1); - } elsif( REG_MULTI_SZ == $valType && $self->SplitMultis ) { - ## $valData =~ s/\0\0$//; # Why does this often fail?? - substr($valData,-2)= "" if "\0\0" eq substr($valData,-2); - $valData= [ split( /\0/, $valData, -1 ) ] - } - if( ! wantarray ) { - return $valData; - } elsif( ! $self->DualTypes ) { - return( $valData, $valType ); - } else { - return( $valData, _DualVal( \%_RegDataTypes, $valType ) ); - } -} - - -sub _ErrNum -{ - # return $^E; - return Win32::GetLastError(); -} - - -sub _ErrMsg -{ - # return $^E; - return Win32::FormatMessage( Win32::GetLastError() ); -} - -sub _Err -{ - my $err; - # return $^E; - return _ErrMsg if ! $_SetDualVar; - return &SetDualVar( $err, _ErrMsg, _ErrNum ); -} - -sub _NoMoreItems -{ - return - $_NoMoreItems =~ /^\d/ - ? _ErrNum == $_NoMoreItems - : _ErrMsg =~ /$_NoMoreItems/io; -} - - -sub _FileNotFound -{ - return - $_FileNotFound =~ /^\d/ - ? _ErrNum == $_FileNotFound - : _ErrMsg =~ /$_FileNotFound/io; -} - - -sub _TooSmall -{ - return - $_TooSmall =~ /^\d/ - ? _ErrNum == $_TooSmall - : _ErrMsg =~ /$_TooSmall/io; -} - - -sub _MoreData -{ - return - $_MoreData =~ /^\d/ - ? _ErrNum == $_MoreData - : _ErrMsg =~ /$_MoreData/io; -} - - -sub _enumValues -{ - my $self= shift(@_); - $self= tied(%$self) if tied(%$self); - my( @names )= (); - my $pos= 0; - my $name= ""; - my $nlen= 1+$self->Information("MaxValNameLen"); - while( $self->RegEnumValue($pos++,$name,$nlen,[],[],[],[]) ) { - push( @names, $name ); - } - if( ! _NoMoreItems() ) { - return (); - } - $self->{VALUES}= \@names; - return 1; -} - - -sub ValueNames -{ - my $self= shift(@_); - $self= tied(%$self) if tied(%$self); - @_ and croak "Usage: \@names= \$key->ValueNames;"; - $self->_enumValues unless $self->{VALUES}; - return @{$self->{VALUES}}; -} - - -sub _enumSubKeys -{ - my $self= shift(@_); - $self= tied(%$self) if tied(%$self); - my( @subkeys, @classes, @times )= (); - my $pos= 0; - my( $subkey, $class, $time )= ("","",""); - my( $namSiz, $clsSiz )= $self->Information( - qw( MaxSubKeyLen MaxSubClassLen )); - $namSiz++; $clsSiz++; - while( $self->RegEnumKeyEx( - $pos++, $subkey, $namSiz, [], $class, $clsSiz, $time ) ) { - push( @subkeys, $subkey ); - push( @classes, $class ); - push( @times, $time ); - } - if( ! _NoMoreItems() ) { - return (); - } - $self->{SUBKEYS}= \@subkeys; - $self->{SUBCLASSES}= \@classes; - $self->{SUBTIMES}= \@times; - return 1; -} - - -sub SubKeyNames -{ - my $self= shift(@_); - $self= tied(%$self) if tied(%$self); - @_ and croak "Usage: \@names= \$key->SubKeyNames;"; - $self->_enumSubKeys unless $self->{SUBKEYS}; - return @{$self->{SUBKEYS}}; -} - - -sub SubKeyClasses -{ - my $self= shift(@_); - @_ and croak "Usage: \@classes= \$key->SubKeyClasses;"; - $self->_enumSubKeys unless $self->{SUBCLASSES}; - return @{$self->{SUBCLASSES}}; -} - - -sub SubKeyTimes -{ - my $self= shift(@_); - $self= tied(%$self) if tied(%$self); - @_ and croak "Usage: \@times= \$key->SubKeyTimes;"; - $self->_enumSubKeys unless $self->{SUBTIMES}; - return @{$self->{SUBTIMES}}; -} - - -sub _MemberNames -{ - my $self= shift(@_); - $self= tied(%$self) if tied(%$self); - @_ and croak "Usage: \$arrayRef= \$key->_MemberNames;"; - if( ! $self->{MEMBERS} ) { - $self->_enumValues unless $self->{VALUES}; - $self->_enumSubKeys unless $self->{SUBKEYS}; - my( @members )= ( map( $_.$self->{DELIM}, @{$self->{SUBKEYS}} ), - map( $self->{DELIM}.$_, @{$self->{VALUES}} ) ); - $self->{MEMBERS}= \@members; - } - return $self->{MEMBERS}; -} - - -sub _MembersHash -{ - my $self= shift(@_); - $self= tied(%$self) if tied(%$self); - @_ and croak "Usage: \$hashRef= \$key->_MembersHash;"; - if( ! $self->{MEMBHASH} ) { - my $aRef= $self->_MemberNames; - $self->{MEMBHASH}= {}; - @{$self->{MEMBHASH}}{@$aRef}= (1) x @$aRef; - } - return $self->{MEMBHASH}; -} - - -sub MemberNames -{ - my $self= shift(@_); - $self= tied(%$self) if tied(%$self); - @_ and croak "Usage: \@members= \$key->MemberNames;"; - return @{$self->_MemberNames}; -} - - -sub Information -{ - my $self= shift(@_); - $self= tied(%$self) if tied(%$self); - my( $time, $nkeys, $nvals, $xsec, $xkey, $xcls, $xname, $xdata )= - ("",0,0,0,0,0,0,0); - my $clen= 8; - if( ! $self->RegQueryInfoKey( [], [], $nkeys, $xkey, $xcls, - $nvals, $xname, $xdata, $xsec, $time ) ) { - return (); - } - if( defined($self->{Class}) ) { - $clen= length($self->{Class}); - } else { - $self->{Class}= ""; - } - while( ! $self->RegQueryInfoKey( $self->{Class}, $clen, - [],[],[],[],[],[],[],[],[]) - && _MoreData ) { - $clen *= 2; - } - my( %info ); - @info{ qw( LastWrite CntSubKeys CntValues SecurityLen - MaxValDataLen MaxSubKeyLen MaxSubClassLen MaxValNameLen ) - }= ( $time, $nkeys, $nvals, $xsec, - $xdata, $xkey, $xcls, $xname ); - if( @_ ) { - my( %check ); - @check{keys(%info)}= keys(%info); - my( @err )= grep( ! $check{$_}, @_ ); - if( @err ) { - croak "${PACK}::Information- Invalid info requested (@err)"; - } - return @info{@_}; - } else { - return %info; - } -} - - -sub Delimiter -{ - my $self= shift(@_); - $self= tied(%$self) if tied(%$self); - $self= $RegObj unless ref($self); - my( $oldDelim )= $self->{DELIM}; - if( 1 == @_ && "" ne "$_[0]" ) { - delete $self->{MEMBERS}; - delete $self->{MEMBHASH}; - $self->{DELIM}= "$_[0]"; - } elsif( 0 != @_ ) { - croak "Usage: \$oldDelim= \$key->Delimiter(\$newDelim);"; - } - return $oldDelim; -} - - -sub Handle -{ - my $self= shift(@_); - $self= tied(%$self) if tied(%$self); - @_ and croak "Usage: \$handle= \$key->Handle;"; - $self= $RegObj unless ref($self); - return $self->{HANDLE}; -} - - -sub Path -{ - my $self= shift(@_); - $self= tied(%$self) if tied(%$self); - @_ and croak "Usage: \$path= \$key->Path;"; - my $delim= $self->{DELIM}; - $self= $RegObj unless ref($self); - if( "" eq $self->{MACHINE} ) { - return( $delim . join( $delim, @{$self->{PATH}} ) . $delim ); - } else { - return( $delim x 2 - . join( $delim, $self->{MACHINE}, @{$self->{PATH}} ) - . $delim ); - } -} - - -sub _Path -{ - my $self= shift(@_); - $self= tied(%$self) if tied(%$self); - @_ and croak "Usage: \$arrRef= \$key->_Path;"; - $self= $RegObj unless ref($self); - return $self->{PATH}; -} - - -sub Machine -{ - my $self= shift(@_); - $self= tied(%$self) if tied(%$self); - @_ and croak "Usage: \$machine= \$key->Machine;"; - $self= $RegObj unless ref($self); - return $self->{MACHINE}; -} - - -sub Access -{ - my $self= shift(@_); - $self= tied(%$self) if tied(%$self); - @_ and croak "Usage: \$access= \$key->Access;"; - $self= $RegObj unless ref($self); - return $self->{ACCESS}; -} - - -sub OS_Delimiter -{ - my $self= shift(@_); - @_ and croak "Usage: \$backslash= \$key->OS_Delimiter;"; - return $self->{OS_DELIM}; -} - - -sub _Roots -{ - my $self= shift(@_); - $self= tied(%$self) if ref($self) && tied(%$self); - @_ and croak "Usage: \$varName= \$key->_Roots;"; - $self= $RegObj unless ref($self); - return $self->{ROOTS}; -} - - -sub Roots -{ - my $self= shift(@_); - $self= tied(%$self) if ref($self) && tied(%$self); - @_ and croak "Usage: \$hashRef= \$key->Roots;"; - $self= $RegObj unless ref($self); - return eval "\\%$self->{ROOTS}"; -} - - -sub TIEHASH -{ - my( $this )= shift(@_); - $this= tied(%$this) if ref($this) && tied(%$this); - my( $key )= @_; - if( 1 == @_ && ref($key) && "$key" =~ /=/ ) { - return $key; # $key is already an object (blessed reference). - } - return $this->new( @_ ); -} - - -sub Tie -{ - my $self= shift(@_); - $self= tied(%$self) if tied(%$self); - my( $hRef )= @_; - if( 1 != @_ || ! ref($hRef) || "$hRef" !~ /(^|=)HASH\(/ ) { - croak "Usage: \$key->Tie(\\\%hash);"; - } - return tie %$hRef, ref($self), $self; -} - - -sub TiedRef -{ - my $self= shift(@_); - $self= tied(%$self) if tied(%$self); - my $hRef= @_ ? shift(@_) : {}; - return () if ! defined($self); - $self->Tie($hRef); - bless $hRef, ref($self); - return $hRef; -} - - -sub _Flags -{ - my $self= shift(@_); - $self= tied(%$self) if tied(%$self); - my $oldFlags= $self->{FLAGS}; - if( 1 == @_ ) { - $self->{FLAGS}= shift(@_); - } elsif( 0 != @_ ) { - croak "Usage: \$oldBits= \$key->_Flags(\$newBits);"; - } - return $oldFlags; -} - - -sub ArrayValues -{ - my $self= shift(@_); - $self= tied(%$self) if tied(%$self); - my $oldFlag= $Flag_ArrVal == ( $Flag_ArrVal & $self->{FLAGS} ); - if( 1 == @_ ) { - my $bool= shift(@_); - if( $bool ) { - $self->{FLAGS} |= $Flag_ArrVal; - } else { - $self->{FLAGS} &= ~( $Flag_ArrVal | $Flag_TieVal ); - } - } elsif( 0 != @_ ) { - croak "Usage: \$oldBool= \$key->ArrayValues(\$newBool);"; - } - return $oldFlag; -} - - -sub TieValues -{ - my $self= shift(@_); - $self= tied(%$self) if tied(%$self); - my $oldFlag= $Flag_TieVal == ( $Flag_TieVal & $self->{FLAGS} ); - if( 1 == @_ ) { - my $bool= shift(@_); - if( $bool ) { - croak "${PACK}->TieValues cannot be enabled with this version"; - $self->{FLAGS} |= $Flag_TieVal; - } else { - $self->{FLAGS} &= ~$Flag_TieVal; - } - } elsif( 0 != @_ ) { - croak "Usage: \$oldBool= \$key->TieValues(\$newBool);"; - } - return $oldFlag; -} - - -sub FastDelete -{ - my $self= shift(@_); - $self= tied(%$self) if tied(%$self); - my $oldFlag= $Flag_FastDel == ( $Flag_FastDel & $self->{FLAGS} ); - if( 1 == @_ ) { - my $bool= shift(@_); - if( $bool ) { - $self->{FLAGS} |= $Flag_FastDel; - } else { - $self->{FLAGS} &= ~$Flag_FastDel; - } - } elsif( 0 != @_ ) { - croak "Usage: \$oldBool= \$key->FastDelete(\$newBool);"; - } - return $oldFlag; -} - - -sub SplitMultis -{ - my $self= shift(@_); - $self= tied(%$self) if tied(%$self); - my $oldFlag= $Flag_Split == ( $Flag_Split & $self->{FLAGS} ); - if( 1 == @_ ) { - my $bool= shift(@_); - if( $bool ) { - $self->{FLAGS} |= $Flag_Split; - } else { - $self->{FLAGS} &= ~$Flag_Split; - } - } elsif( 0 != @_ ) { - croak "Usage: \$oldBool= \$key->SplitMultis(\$newBool);"; - } - return $oldFlag; -} - - -sub DWordsToHex -{ - my $self= shift(@_); - $self= tied(%$self) if tied(%$self); - my $oldFlag= $Flag_HexDWord == ( $Flag_HexDWord & $self->{FLAGS} ); - if( 1 == @_ ) { - my $bool= shift(@_); - if( $bool ) { - $self->{FLAGS} |= $Flag_HexDWord; - } else { - $self->{FLAGS} &= ~$Flag_HexDWord; - } - } elsif( 0 != @_ ) { - croak "Usage: \$oldBool= \$key->DWordsToHex(\$newBool);"; - } - return $oldFlag; -} - - -sub FixSzNulls -{ - my $self= shift(@_); - $self= tied(%$self) if tied(%$self); - my $oldFlag= $Flag_FixNulls == ( $Flag_FixNulls & $self->{FLAGS} ); - if( 1 == @_ ) { - my $bool= shift(@_); - if( $bool ) { - $self->{FLAGS} |= $Flag_FixNulls; - } else { - $self->{FLAGS} &= ~$Flag_FixNulls; - } - } elsif( 0 != @_ ) { - croak "Usage: \$oldBool= \$key->FixSzNulls(\$newBool);"; - } - return $oldFlag; -} - - -sub DualTypes -{ - my $self= shift(@_); - $self= tied(%$self) if tied(%$self); - my $oldFlag= $Flag_DualTyp == ( $Flag_DualTyp & $self->{FLAGS} ); - if( 1 == @_ ) { - my $bool= shift(@_); - if( $bool ) { - croak "${PACK}->DualTypes cannot be enabled since ", - "SetDualVar module not installed" - unless $_SetDualVar; - $self->{FLAGS} |= $Flag_DualTyp; - } else { - $self->{FLAGS} &= ~$Flag_DualTyp; - } - } elsif( 0 != @_ ) { - croak "Usage: \$oldBool= \$key->DualTypes(\$newBool);"; - } - return $oldFlag; -} - - -sub DualBinVals -{ - my $self= shift(@_); - $self= tied(%$self) if tied(%$self); - my $oldFlag= $Flag_DualBin == ( $Flag_DualBin & $self->{FLAGS} ); - if( 1 == @_ ) { - my $bool= shift(@_); - if( $bool ) { - croak "${PACK}->DualBinVals cannot be enabled since ", - "SetDualVar module not installed" - unless $_SetDualVar; - $self->{FLAGS} |= $Flag_DualBin; - } else { - $self->{FLAGS} &= ~$Flag_DualBin; - } - } elsif( 0 != @_ ) { - croak "Usage: \$oldBool= \$key->DualBinVals(\$newBool);"; - } - return $oldFlag; -} - - -sub GetOptions -{ - my $self= shift(@_); - $self= tied(%$self) if tied(%$self); - my( $opt, $meth ); - if( ! @_ || 1 == @_ && "HASH" eq ref($_[0]) ) { - my $href= @_ ? $_[0] : {}; - foreach $opt ( grep !/^Allow/, @_opt_subs ) { - $meth= $_opt_subs{$opt}; - $href->{$opt}= $self->$meth(); - } - return @_ ? $self : $href; - } - my @old; - foreach $opt ( @_ ) { - $meth= $_opt_subs{$opt}; - if( defined $meth ) { - if( $opt eq "AllowLoad" || $opt eq "AllowSave" ) { - croak "${PACK}->GetOptions: Getting current setting of $opt ", - "not supported in this release"; - } - push( @old, $self->$meth() ); - } else { - croak "${PACK}->GetOptions: Invalid option ($opt) ", - "not one of ( ", join(" ",grep !/^Allow/, @_opt_subs), " )"; - } - } - return wantarray ? @old : $old[-1]; -} - - -sub SetOptions -{ - my $self= shift(@_); - # Don't get object if hash ref so "ref" returns original ref. - my( $opt, $meth, @old ); - while( @_ ) { - $opt= shift(@_); - $meth= $_opt_subs{$opt}; - if( ! @_ ) { - croak "${PACK}->SetOptions: Option value missing ", - "after option name ($opt)"; - } elsif( defined $meth ) { - push( @old, $self->$meth( shift(@_) ) ); - } elsif( $opt eq substr("reference",0,length($opt)) ) { - shift(@_) if @_; - push( @old, $self ); - } else { - croak "${PACK}->SetOptions: Invalid option ($opt) ", - "not one of ( @_opt_subs )"; - } - } - return wantarray ? @old : $old[-1]; -} - - -sub _parseTiedEnt -{ - my $self= shift(@_); - $self= tied(%$self) if tied(%$self); - my $ent= shift(@_); - my $delim= shift(@_); - my $dlen= length( $delim ); - my $parent= @_ ? shift(@_) : 0; - my $off; - if( $delim x 2 eq substr($ent,0,2*$dlen) && "NONE" eq $self->Handle ) { - if( 0 <= ( $off= index( $ent, $delim x 2, 2*$dlen ) ) ) { - return( substr( $ent, 0, $off ), substr( $ent, 2*$dlen+$off ) ); - } elsif( $delim eq substr($ent,-$dlen) ) { - return( substr($ent,0,-$dlen) ); - } elsif( 2*$dlen <= ( $off= rindex( $ent, $delim ) ) ) { - return( substr( $ent, 0, $off ), - undef, substr( $ent, $dlen+$off ) ); - } elsif( $parent ) { - return(); - } else { - return( $ent ); - } - } elsif( $delim eq substr($ent,0,$dlen) && "NONE" ne $self->Handle ) { - return( undef, substr($ent,$dlen) ); - } elsif( $self->{MEMBERS} && $self->_MembersHash->{$ent} ) { - return( substr($ent,0,-$dlen) ); - } elsif( 0 <= ( $off= index( $ent, $delim x 2 ) ) ) { - return( substr( $ent, 0, $off ), substr( $ent, 2*$dlen+$off ) ); - } elsif( $delim eq substr($ent,-$dlen) ) { - if( $parent - && 0 <= ( $off= rindex( $ent, $delim, length($ent)-2*$dlen ) ) ) { - return( substr($ent,0,$off), - undef, undef, substr($ent,$dlen+$off,-$dlen) ); - } else { - return( substr($ent,0,-$dlen) ); - } - } elsif( 0 <= ( $off= rindex( $ent, $delim ) ) ) { - return( - substr( $ent, 0, $off ), undef, substr( $ent, $dlen+$off ) ); - } else { - return( undef, undef, $ent ); - } -} - - -sub _FetchValue -{ - my $self= shift( @_ ); - my( $val, $createKey )= @_; - my( $data, $type ); - if( ( $data, $type )= $self->GetValue( $val ) ) { - return $self->ArrayValues ? [ $data, $type ] - : wantarray ? ( $data, $type ) - : $data; - } elsif( $createKey and $data= $self->new($val) ) { - return $data->TiedRef; - } else { - return (); - } -} - - -sub FETCH -{ - my $self= shift(@_); - my $ent= shift(@_); - my $delim= $self->Delimiter; - my( $key, $val, $ambig )= $self->_parseTiedEnt( $ent, $delim, 0 ); - my $sub; - if( defined($key) ) { - if( defined($self->{MEMBHASH}) - && $self->{MEMBHASH}->{$key.$delim} - && 0 <= index($key,$delim) ) { - return () - unless $sub= $self->new( $key, - {"Delimiter"=>$self->OS_Delimiter} ); - $sub->Delimiter($delim); - } else { - return () - unless $sub= $self->new( $key ); - } - } else { - $sub= $self; - } - if( defined($val) ) { - return $sub->_FetchValue( $val ); - } elsif( ! defined($ambig) ) { - return $sub->TiedRef; - } elsif( defined($key) ) { - return $sub->FETCH( $ambig ); - } else { - return $sub->_FetchValue( $ambig, "" ne $ambig ); - } -} - - -sub _FetchOld -{ - my( $self, $key )= @_; - my $old= $self->FETCH($key); - if( $old ) { - my $copy= {}; - %$copy= %$old; - return $copy; - } - # return $^E; - return _Err; -} - - -sub DELETE -{ - my $self= shift(@_); - my $ent= shift(@_); - my $delim= $self->Delimiter; - my( $key, $val, $ambig, $subkey )= $self->_parseTiedEnt( $ent, $delim, 1 ); - my $sub; - my $fast= defined(wantarray) ? $self->FastDelete : 2; - my $old= 1; # Value returned if FastDelete is set. - if( defined($key) - && ( defined($val) || defined($ambig) || defined($subkey) ) ) { - return () - unless $sub= $self->new( $key ); - } else { - $sub= $self; - } - if( defined($val) ) { - $old= $sub->GetValue($val) || _Err unless 2 <= $fast; - $sub->RegDeleteValue( $val ); - } elsif( defined($subkey) ) { - $old= $sub->_FetchOld( $subkey.$delim ) unless $fast; - $sub->RegDeleteKey( $subkey ); - } elsif( defined($ambig) ) { - if( defined($key) ) { - $old= $sub->DELETE($ambig); - } else { - $old= $sub->GetValue($ambig) || _Err unless 2 <= $fast; - if( defined( $old ) ) { - $sub->RegDeleteValue( $ambig ); - } else { - $old= $sub->_FetchOld( $ambig.$delim ) unless $fast; - $sub->RegDeleteKey( $ambig ); - } - } - } elsif( defined($key) ) { - $old= $sub->_FetchOld( $key.$delim ) unless $fast; - $sub->RegDeleteKey( $key ); - } else { - croak "${PACK}->DELETE: Key ($ent) can never be deleted"; - } - return $old; -} - - -sub SetValue -{ - my $self= shift(@_); - $self= tied(%$self) if tied(%$self); - my $name= shift(@_); - my $data= shift(@_); - my( $type )= @_; - my $size; - if( ! defined($type) ) { - if( "ARRAY" eq ref($data) ) { - croak "${PACK}->SetValue: Value is array reference but ", - "no data type given" - unless 2 == @$data; - ( $data, $type )= @$data; - } else { - $type= REG_SZ; - } - } - $type= _constant($type,"registry value data type") if $type =~ /^REG_/; - if( REG_MULTI_SZ == $type && "ARRAY" eq ref($data) ) { - $data= join( "\0", @$data ) . "\0\0"; - ## $data= pack( "a*" x (1+@$data), map( $_."\0", @$data, "" ) ); - } elsif( ( REG_SZ == $type || REG_EXPAND_SZ == $type ) - && $self->FixSzNulls ) { - $data .= "\0" unless "\0" eq substr($data,0,-1); - } elsif( REG_DWORD == $type && $data =~ /^0x[0-9a-fA-F]{3,}$/ ) { - $data= pack( "L", hex($data) ); - # We could to $data=pack("L",$data) for REG_DWORD but I see - # no nice way to always destinguish when to do this or not. - } - return $self->RegSetValueEx( $name, 0, $type, $data, length($data) ); -} - - -sub StoreKey -{ - my $this= shift(@_); - $this= tied(%$this) if ref($this) && tied(%$this); - my $subKey= shift(@_); - my $data= shift(@_); - my $ent; - my $self; - if( ! ref($data) || "$data" !~ /(^|=)HASH/ ) { - croak "${PACK}->StoreKey: For ", $this->Path.$subKey, ",\n", - " subkey data must be a HASH reference"; - } - if( defined( $$data{""} ) && "HASH" eq ref($$data{""}) ) { - $self= $this->CreateKey( $subKey, delete $$data{""} ); - } else { - $self= $this->CreateKey( $subKey ); - } - return () if ! defined($self); - foreach $ent ( keys(%$data) ) { - return () - unless $self->STORE( $ent, $$data{$ent} ); - } - return $self; -} - - -# = { "" => {OPT=>VAL}, "val"=>[], "key"=>{} } creates a new key -# = "string" creates a new REG_SZ value -# = [ data, type ] creates a new value -sub STORE -{ - my $self= shift(@_); - my $ent= shift(@_); - my $data= shift(@_); - my $delim= $self->Delimiter; - my( $key, $val, $ambig, $subkey )= $self->_parseTiedEnt( $ent, $delim, 1 ); - my $sub; - if( defined($key) - && ( defined($val) || defined($ambig) || defined($subkey) ) ) { - return () - unless $sub= $self->new( $key ); - } else { - $sub= $self; - } - if( defined($val) ) { - croak "${PACK}->STORE: For ", $sub->Path.$delim.$val, ",\n", - " value data cannot be a HASH reference" - if ref($data) && "$data" =~ /(^|=)HASH/; - $sub->SetValue( $val, $data ); - } elsif( defined($subkey) ) { - croak "${PACK}->STORE: For ", $sub->Path.$subkey.$delim, ",\n", - " subkey data must be a HASH reference" - unless ref($data) && "$data" =~ /(^|=)HASH/; - $sub->StoreKey( $subkey, $data ); - } elsif( defined($ambig) ) { - if( ref($data) && "$data" =~ /(^|=)HASH/ ) { - $sub->StoreKey( $ambig, $data ); - } else { - $sub->SetValue( $ambig, $data ); - } - } elsif( defined($key) ) { - croak "${PACK}->STORE: For ", $sub->Path.$key.$delim, ",\n", - " subkey data must be a HASH reference" - unless ref($data) && "$data" =~ /(^|=)HASH/; - $sub->StoreKey( $key, $data ); - } else { - croak "${PACK}->STORE: Key ($ent) can never be created nor set"; - } -} - - -sub EXISTS -{ - my $self= shift(@_); - my $ent= shift(@_); - return defined( $self->FETCH($ent) ); -} - - -sub FIRSTKEY -{ - my $self= shift(@_); - my $members= $self->_MemberNames; - $self->{PREVIDX}= 0; - return @{$members} ? $members->[0] : undef; -} - - -sub NEXTKEY -{ - my $self= shift(@_); - my $prev= shift(@_); - my $idx= $self->{PREVIDX}; - my $members= $self->_MemberNames; - if( ! defined($idx) || $prev ne $members->[$idx] ) { - $idx= 0; - while( $idx < @$members && $prev ne $members->[$idx] ) { - $idx++; - } - } - $self->{PREVIDX}= ++$idx; - return $members->[$idx]; -} - - -sub DESTROY -{ - my $self= shift(@_); - return if tied(%$self); - my $unload; - local $@; - eval { $unload= $self->{UNLOADME}; 1 } - or return; - my $debug= $ENV{DEBUG_TIE_REGISTRY}; - if( defined($debug) ) { - if( 1 < $debug ) { - my $hand= $self->Handle; - my $dep= $self->{DEPENDON}; - carp "${PACK} destroying ", $self->Path, " (", - "NONE" eq $hand ? $hand : sprintf("0x%lX",$hand), ")", - defined($dep) ? (" [depends on ",$dep->Path,"]") : (); - } else { - warn "${PACK} destroying ", $self->Path, ".\n"; - } - } - $self->RegCloseKey - unless "NONE" eq $self->Handle; - if( defined($unload) ) { - if( defined($debug) && 1 < $debug ) { - my( $obj, $subKey, $file )= @$unload; - warn "Unloading ", $self->Path, - " (from ", $obj->Path, ", $subKey)...\n"; - } - $self->UnLoad - || warn "Couldn't unload ", $self->Path, ": ", _ErrMsg, "\n"; - ## carp "Never unloaded ${PACK}::Load($$unload[2])"; - } - #delete $self->{DEPENDON}; -} - - -use vars qw( @CreateKey_Opts %CreateKey_Opts %_KeyDispNames ); -@CreateKey_Opts= qw( Access Class Options Delimiter - Disposition Security Volatile Backup ); -@CreateKey_Opts{@CreateKey_Opts}= (1) x @CreateKey_Opts; -%_KeyDispNames= ( REG_CREATED_NEW_KEY() => "REG_CREATED_NEW_KEY", - REG_OPENED_EXISTING_KEY() => "REG_OPENED_EXISTING_KEY" ); - -sub CreateKey -{ - my $self= shift(@_); - my $tied= tied(%$self); - $self= tied(%$self) if $tied; - my( $subKey, $opts )= @_; - my( $sam )= $self->Access; - my( $delim )= $self->Delimiter; - my( $class )= ""; - my( $flags )= 0; - my( $secure )= []; - my( $garb )= []; - my( $result )= \$garb; - my( $handle )= 0; - if( @_ < 1 || 2 < @_ - || 2 == @_ && "HASH" ne ref($opts) ) { - croak "Usage: \$new= \$old->CreateKey( \$subKey, {OPT=>VAL,...} );\n", - " options: @CreateKey_Opts\nCalled"; - } - if( defined($opts) ) { - $sam= $opts->{"Access"} if defined($opts->{"Access"}); - $class= $opts->{Class} if defined($opts->{Class}); - $flags= $opts->{Options} if defined($opts->{Options}); - $delim= $opts->{"Delimiter"} if defined($opts->{"Delimiter"}); - $secure= $opts->{Security} if defined($opts->{Security}); - if( defined($opts->{Disposition}) ) { - "SCALAR" eq ref($opts->{Disposition}) - or croak "${PACK}->CreateKey option `Disposition'", - " must provide a scalar reference"; - $result= $opts->{Disposition}; - } - if( 0 == $flags ) { - $flags |= REG_OPTION_VOLATILE - if defined($opts->{Volatile}) && $opts->{Volatile}; - $flags |= REG_OPTION_BACKUP_RESTORE - if defined($opts->{Backup}) && $opts->{Backup}; - } - } - my $subPath= ref($subKey) ? $subKey : $self->_split($subKey,$delim); - $subKey= join( $self->OS_Delimiter, @$subPath ); - $self->RegCreateKeyEx( $subKey, 0, $class, $flags, $sam, - $secure, $handle, $$result ) - or return (); - if( ! ref($$result) && $self->DualTypes ) { - $$result= _DualVal( \%_KeyDispNames, $$result ); - } - my $new= $self->_new( $handle, [ @{$self->_Path}, @{$subPath} ] ); - $new->{ACCESS}= $sam; - $new->{DELIM}= $delim; - $new= $new->TiedRef if $tied; - return $new; -} - - -use vars qw( $Load_Cnt @Load_Opts %Load_Opts ); -$Load_Cnt= 0; -@Load_Opts= qw(NewSubKey); -@Load_Opts{@Load_Opts}= (1) x @Load_Opts; - -sub Load -{ - my $this= shift(@_); - my $tied= ref($this) && tied(%$this); - $this= tied(%$this) if $tied; - my( $file, $subKey, $opts )= @_; - if( 2 == @_ && "HASH" eq ref($subKey) ) { - $opts= $subKey; - undef $subKey; - } - @_ < 1 || 3 < @_ || defined($opts) && "HASH" ne ref($opts) - and croak "Usage: \$key= ", - "${PACK}->Load( \$fileName, [\$newSubKey,] {OPT=>VAL...} );\n", - " options: @Load_Opts @new_Opts\nCalled"; - if( defined($opts) && exists($opts->{NewSubKey}) ) { - $subKey= delete $opts->{NewSubKey}; - } - if( ! defined( $subKey ) ) { - if( "" ne $this->Machine ) { - ( $this )= $this->_connect( [$this->Machine,"LMachine"] ); - } else { - ( $this )= $this->_rootKey( "LMachine" ); # Could also be "Users" - } - $subKey= "PerlTie:$$." . ++$Load_Cnt; - } - $this->RegLoadKey( $subKey, $file ) - or return (); - my $self= $this->new( $subKey, defined($opts) ? $opts : () ); - if( ! defined( $self ) ) { - { my $err= Win32::GetLastError(); - #{ local( $^E ); #} - $this->RegUnLoadKey( $subKey ) or carp - "Can't unload $subKey from ", $this->Path, ": ", _ErrMsg, "\n"; - Win32::SetLastError($err); - } - return (); - } - $self->{UNLOADME}= [ $this, $subKey, $file ]; - $self= $self->TiedRef if $tied; - return $self; -} - - -sub UnLoad -{ - my $self= shift(@_); - $self= tied(%$self) if tied(%$self); - @_ and croak "Usage: \$key->UnLoad;"; - my $unload= $self->{UNLOADME}; - "ARRAY" eq ref($unload) - or croak "${PACK}->UnLoad called on a key which was not Load()ed"; - my( $obj, $subKey, $file )= @$unload; - $self->RegCloseKey; - return Win32API::Registry::RegUnLoadKey( $obj->Handle, $subKey ); -} - - -sub AllowSave -{ - my $self= shift(@_); - $self= tied(%$self) if tied(%$self); - return $self->AllowPriv( "SeBackupPrivilege", @_ ); -} - - -sub AllowLoad -{ - my $self= shift(@_); - $self= tied(%$self) if tied(%$self); - return $self->AllowPriv( "SeRestorePrivilege", @_ ); -} - - -# RegNotifyChangeKeyValue( hKey, bWatchSubtree, iNotifyFilter, hEvent, bAsync ) - - -sub RegCloseKey { my $self= shift(@_); - Win32API::Registry::RegCloseKey $self->Handle, @_; } -sub RegConnectRegistry { my $self= shift(@_); - Win32API::Registry::RegConnectRegistry @_; } -sub RegCreateKey { my $self= shift(@_); - Win32API::Registry::RegCreateKey $self->Handle, @_; } -sub RegCreateKeyEx { my $self= shift(@_); - Win32API::Registry::RegCreateKeyEx $self->Handle, @_; } -sub RegDeleteKey { my $self= shift(@_); - Win32API::Registry::RegDeleteKey $self->Handle, @_; } -sub RegDeleteValue { my $self= shift(@_); - Win32API::Registry::RegDeleteValue $self->Handle, @_; } -sub RegEnumKey { my $self= shift(@_); - Win32API::Registry::RegEnumKey $self->Handle, @_; } -sub RegEnumKeyEx { my $self= shift(@_); - Win32API::Registry::RegEnumKeyEx $self->Handle, @_; } -sub RegEnumValue { my $self= shift(@_); - Win32API::Registry::RegEnumValue $self->Handle, @_; } -sub RegFlushKey { my $self= shift(@_); - Win32API::Registry::RegFlushKey $self->Handle, @_; } -sub RegGetKeySecurity { my $self= shift(@_); - Win32API::Registry::RegGetKeySecurity $self->Handle, @_; } -sub RegLoadKey { my $self= shift(@_); - Win32API::Registry::RegLoadKey $self->Handle, @_; } -sub RegNotifyChangeKeyValue { my $self= shift(@_); - Win32API::Registry::RegNotifyChangeKeyValue $self->Handle, @_; } -sub RegOpenKey { my $self= shift(@_); - Win32API::Registry::RegOpenKey $self->Handle, @_; } -sub RegOpenKeyEx { my $self= shift(@_); - Win32API::Registry::RegOpenKeyEx $self->Handle, @_; } -sub RegQueryInfoKey { my $self= shift(@_); - Win32API::Registry::RegQueryInfoKey $self->Handle, @_; } -sub RegQueryMultipleValues { my $self= shift(@_); - Win32API::Registry::RegQueryMultipleValues $self->Handle, @_; } -sub RegQueryValue { my $self= shift(@_); - Win32API::Registry::RegQueryValue $self->Handle, @_; } -sub RegQueryValueEx { my $self= shift(@_); - Win32API::Registry::RegQueryValueEx $self->Handle, @_; } -sub RegReplaceKey { my $self= shift(@_); - Win32API::Registry::RegReplaceKey $self->Handle, @_; } -sub RegRestoreKey { my $self= shift(@_); - Win32API::Registry::RegRestoreKey $self->Handle, @_; } -sub RegSaveKey { my $self= shift(@_); - Win32API::Registry::RegSaveKey $self->Handle, @_; } -sub RegSetKeySecurity { my $self= shift(@_); - Win32API::Registry::RegSetKeySecurity $self->Handle, @_; } -sub RegSetValue { my $self= shift(@_); - Win32API::Registry::RegSetValue $self->Handle, @_; } -sub RegSetValueEx { my $self= shift(@_); - Win32API::Registry::RegSetValueEx $self->Handle, @_; } -sub RegUnLoadKey { my $self= shift(@_); - Win32API::Registry::RegUnLoadKey $self->Handle, @_; } -sub AllowPriv { my $self= shift(@_); - Win32API::Registry::AllowPriv @_; } - - -# Autoload methods go after =cut, and are processed by the autosplit program. - -1; -__END__ - -=head1 NAME - -Win32::TieRegistry - Powerful and easy ways to manipulate a registry -[on Win32 for now]. - -=head1 SYNOPSIS - - use Win32::TieRegistry 0.20 ( UseOptionName=>UseOptionValue[,...] ); - - $Registry->SomeMethodCall(arg1,...); - - $subKey= $Registry->{"Key\\SubKey\\"}; - $valueData= $Registry->{"Key\\SubKey\\\\ValueName"}; - $Registry->{"Key\\SubKey\\"}= { "NewSubKey" => {...} }; - $Registry->{"Key\\SubKey\\\\ValueName"}= "NewValueData"; - $Registry->{"\\ValueName"}= [ pack("fmt",$data), REG_DATATYPE ]; - -=head1 EXAMPLES - - use Win32::TieRegistry( Delimiter=>"#", ArrayValues=>0 ); - $pound= $Registry->Delimiter("/"); - $diskKey= $Registry->{"LMachine/System/Disk/"} - or die "Can't read LMachine/System/Disk key: $^E\n"; - $data= $key->{"/Information"} - or die "Can't read LMachine/System/Disk//Information value: $^E\n"; - $remoteKey= $Registry->{"//ServerA/LMachine/System/"} - or die "Can't read //ServerA/LMachine/System/ key: $^E\n"; - $remoteData= $remoteKey->{"Disk//Information"} - or die "Can't read ServerA's System/Disk//Information value: $^E\n"; - foreach $entry ( keys(%$diskKey) ) { - ... - } - foreach $subKey ( $diskKey->SubKeyNames ) { - ... - } - $diskKey->AllowSave( 1 ); - $diskKey->RegSaveKey( "C:/TEMP/DiskReg", [] ); - -=head1 DESCRIPTION - -The I<Win32::TieRegistry> module lets you manipulate the Registry -via objects [as in "object oriented"] or via tied hashes. But -you will probably mostly use a combination reference, that is, a -reference to a tied hash that has also been made an object so that -you can mix both access methods [as shown above]. - -If you did not get this module as part of L<libwin32>, you might -want to get a recent version of L<libwin32> from CPAN which should -include this module and the I<Win32API::Registry> module that it -uses. - -Skip to the L<SUMMARY> section if you just want to dive in and start -using the Registry from Perl. - -Accessing and manipulating the registry is extremely simple using -I<Win32::TieRegistry>. A single, simple expression can return -you almost any bit of information stored in the Registry. -I<Win32::TieRegistry> also gives you full access to the "raw" -underlying API calls so that you can do anything with the Registry -in Perl that you could do in C. But the "simple" interface has -been carefully designed to handle almost all operations itself -without imposing arbitrary limits while providing sensible -defaults so you can list only the parameters you care about. - -But first, an overview of the Registry itself. - -=head2 The Registry - -The Registry is a forest: a collection of several tree structures. -The root of each tree is a key. These root keys are identified by -predefined constants whose names start with "HKEY_". Although all -keys have a few attributes associated with each [a class, a time -stamp, and security information], the most important aspect of keys -is that each can contain subkeys and can contain values. - -Each subkey has a name: a string which cannot be blank and cannot -contain the delimiter character [backslash: C<'\\'>] nor nul -[C<'\0'>]. Each subkey is also a key and so can contain subkeys -and values [and has a class, time stamp, and security information]. - -Each value has a name: a string which E<can> be blank and E<can> -contain the delimiter character [backslash: C<'\\'>] and any -character except for null, C<'\0'>. Each value also has data -associated with it. Each value's data is a contiguous chunk of -bytes, which is exactly what a Perl string value is so Perl -strings will usually be used to represent value data. - -Each value also has a data type which says how to interpret the -value data. The primary data types are: - -=over - -=item REG_SZ - -A null-terminated string. - -=item REG_EXPAND_SZ - -A null-terminated string which contains substrings consisting of a -percent sign [C<'%'>], an environment variable name, then a percent -sign, that should be replaced with the value associate with that -environment variable. The system does I<not> automatically do this -substitution. - -=item REG_BINARY - -Some arbitrary binary value. You can think of these as being -"packed" into a string. - -If your system has the L<SetDualVar> module installed, -the C<DualBinVals()> option wasn't turned off, and you -fetch a C<REG_BINARY> value of 4 bytes or fewer, then -you can use the returned value in a numeric context to -get at the "unpacked" numeric value. See C<GetValue()> -for more information. - -=item REG_MULTI_SZ - -Several null-terminated strings concatenated together with an -extra trailing C<'\0'> at the end of the list. Note that the list -can include empty strings so use the value's length to determine -the end of the list, not the first occurrence of C<'\0\0'>. -It is best to set the C<SplitMultis()> option so I<Win32::TieRegistry> -will split these values into an array of strings for you. - -=item REG_DWORD - -A long [4-byte] integer value. These values are expected either -packed into a 4-character string or as a hex string of E<more than> -4 characters [but I<not> as a numeric value, unfortunately, as there is -no sure way to tell a numeric value from a packed 4-byte string that -just happens to be a string containing a valid numeric value]. - -How such values are returned depends on the C<DualBinVals()> and -C<DWordsToHex()> options. See C<GetValue()> for details. - -=back - -In the underlying Registry calls, most places which take a -subkey name also allow you to pass in a subkey "path" -- a -string of several subkey names separated by the delimiter -character, backslash [C<'\\'>]. For example, doing -C<RegOpenKeyEx(HKEY_LOCAL_MACHINE,"SYSTEM\\DISK",...)> is much -like opening the C<"SYSTEM"> subkey of C<HKEY_LOCAL_MACHINE>, -then opening its C<"DISK"> subkey, then closing the C<"SYSTEM"> -subkey. - -All of the I<Win32::TieRegistry> features allow you to use your -own delimiter in place of the system's delimiter, [C<'\\'>]. In -most of our examples we will use a forward slash [C<'/'>] as our -delimiter as it is easier to read and less error prone to use when -writing Perl code since you have to type two backslashes for each -backslash you want in a string. Note that this is true even when -using single quotes -- C<'\\HostName\LMachine\'> is an invalid -string and must be written as C<'\\\\HostName\\LMachine\\'>. - -You can also connect to the registry of other computers on your -network. This will be discussed more later. - -Although the Registry does not have a single root key, the -I<Win32::TieRegistry> module creates a virtual root key for you -which has all of the I<HKEY_*> keys as subkeys. - -=head2 Tied Hashes Documentation - -Before you can use a tied hash, you must create one. One way to -do that is via: - - use Win32::TieRegistry ( TiedHash => '%RegHash' ); - -which exports a C<%RegHash> variable into your package and ties it -to the virtual root key of the Registry. An alternate method is: - - my %RegHash; - use Win32::TieRegistry ( TiedHash => \%RegHash ); - -There are also several ways you can tie a hash variable to any -other key of the Registry, which are discussed later. - -Note that you will most likely use C<$Registry> instead of using -a tied hash. C<$Registry> is a reference to a hash that has -been tied to the virtual root of your computer's Registry [as if, -C<$Registry= \%RegHash>]. So you would use C<$Registry-E<gt>{Key}> -rather than C<$RegHash{Key}> and use C<keys %{$Registry}> rather -than C<keys %RegHash>, for example. - -For each hash which has been tied to a Registry key, the Perl -C<keys> function will return a list containing the name of each -of the key's subkeys with a delimiter character appended to it and -containing the name of each of the key's values with a delimiter -prepended to it. For example: - - keys( %{ $Registry->{"HKEY_CLASSES_ROOT\\batfile\\"} } ) - -might yield the following list value: - - ( "DefaultIcon\\", # The subkey named "DefaultIcon" - "shell\\", # The subkey named "shell" - "shellex\\", # The subkey named "shellex" - "\\", # The default value [named ""] - "\\EditFlags" ) # The value named "EditFlags" - -For the virtual root key, short-hand subkey names are used as -shown below. You can use the short-hand name, the regular -I<HKEY_*> name, or any numeric value to access these keys, but -the short-hand names are all that will be returned by the C<keys> -function. - -=over - -=item "Classes" for HKEY_CLASSES_ROOT - -Contains mappings between file name extensions and the uses -for such files along with configuration information for COM -[MicroSoft's Common Object Model] objects. Usually a link to -the C<"SOFTWARE\\Classes"> subkey of the C<HKEY_LOCAL_MACHINE> -key. - -=item "CUser" for HKEY_CURRENT_USER - -Contains information specific to the currently logged-in user. -Mostly software configuration information. Usually a link to -a subkey of the C<HKEY_USERS> key. - -=item "LMachine" for HKEY_LOCAL_MACHINE - -Contains all manner of information about the computer. - -=item "Users" for HKEY_USERS - -Contains one subkey, C<".DEFAULT">, which gets copied to a new -subkey whenever a new user is added. Also contains a subkey for -each user of the system, though only those for active users -[usually only one] are loaded at any given time. - -=item "PerfData" for HKEY_PERFORMANCE_DATA - -Used to access data about system performance. Access via this key -is "special" and all but the most carefully constructed calls will -fail, usually with C<ERROR_INSUFFICIENT_BUFFER>. For example, you -can't enumerate key names without also enumerating values which -require huge buffers but the exact buffer size required cannot be -determined beforehand because C<RegQueryInfoKey()> E<always> fails -with C<ERROR_INSUFFICIENT_BUFFER> for C<HKEY_PERFORMANCE_DATA> no -matter how it is called. So it is currently not very useful to -tie a hash to this key. You can use it to create an object to use -for making carefully constructed calls to the underlying Reg*() -routines. - -=item "CConfig" for HKEY_CURRENT_CONFIG - -Contains minimal information about the computer's current -configuration that is required very early in the boot process. -For example, setting for the display adapter such as screen -resolution and refresh rate are found in here. - -=item "DynData" for HKEY_DYN_DATA - -Dynamic data. We have found no documentation for this key. - -=back - -A tied hash is much like a regular hash variable in Perl -- you give -it a key string inside braces, [C<{> and C<}>], and it gives you -back a value [or lets you set a value]. For I<Win32::TieRegistry> -hashes, there are two types of values that will be returned. - -=over - -=item SubKeys - -If you give it a string which represents a subkey, then it will -give you back a reference to a hash which has been tied to that -subkey. It can't return the hash itself, so it returns a -reference to it. It also blesses that reference so that it is -also an object so you can use it to call method functions. - -=item Values - -If you give it a string which is a value name, then it will give -you back a string which is the data for that value. Alternately, -you can request that it give you both the data value string and -the data value type [we discuss how to request this later]. In -this case, it would return a reference to an array where the value -data string is element C<[0]> and the value data type is element -C<[1]>. - -=back - -The key string which you use in the tied hash must be interpreted -to determine whether it is a value name or a key name or a path -that combines several of these or even other things. There are -two simple rules that make this interpretation easy and -unambiguous: - - Put a delimiter after each key name. - Put a delimiter in front of each value name. - -Exactly how the key string will be intepreted is governed by the -following cases, in the order listed. These cases are designed -to "do what you mean". Most of the time you won't have to think -about them, especially if you follow the two simple rules above. -After the list of cases we give several examples which should be -clear enough so feel free to skip to them unless you are worried -about the details. - -=over - -=item Remote machines - -If the hash is tied to the virtual root of the registry [or the -virtual root of a remote machine's registry], then we treat hash -key strings which start with the delimiter character specially. - -If the hash key string starts with two delimiters in a row, then -those should be immediately followed by the name of a remote -machine whose registry we wish to connect to. That can be -followed by a delimiter and more subkey names, etc. If the -machine name is not following by anything, then a virtual root -for the remote machine's registry is created, a hash is tied to -it, and a reference to that hash it is returned. - -=item Hash key string starts with the delimiter - -If the hash is tied to a virtual root key, then the leading -delimiter is ignored. It should be followed by a valid Registry -root key name [either a short-hand name like C<"LMachine">, an -I<HKEY_*> value, or a numeric value]. This alternate notation is -allowed in order to be more consistant with the C<Open()> method -function. - -For all other Registry keys, the leading delimiter indicates -that the rest of the string is a value name. The leading -delimiter is stripped and the rest of the string [which can -be empty and can contain more delimiters] is used as a value -name with no further parsing. - -=item Exact match with direct subkey name followed by delimiter - -If you have already called the Perl C<keys> function on the tied -hash [or have already called C<MemberNames> on the object] and the -hash key string exactly matches one of the strings returned, then -no further parsing is done. In other words, if the key string -exactly matches the name of a direct subkey with a delimiter -appended, then a reference to a hash tied to that subkey is -returned [but only if C<keys> or C<MemberNames> has already -been called for that tied hash]. - -This is only important if you have selected a delimiter other than -the system default delimiter and one of the subkey names contains -the delimiter you have chosen. This rule allows you to deal with -subkeys which contain your chosen delimiter in their name as long -as you only traverse subkeys one level at a time and always -enumerate the list of members before doing so. - -The main advantage of this is that Perl code which recursively -traverses a hash will work on hashes tied to Registry keys even if -a non-default delimiter has been selected. - -=item Hash key string contains two delimiters in a row - -If the hash key string contains two [or more] delimiters in a row, -then the string is split between the first pair of delimiters. -The first part is interpreted as a subkey name or a path of subkey -names separated by delimiters and with a trailing delimiter. The -second part is interpreted as a value name with one leading -delimiter [any extra delimiters are considered part of the value -name]. - -=item Hash key string ends with a delimiter - -If the key string ends with a delimiter, then it is treated -as a subkey name or path of subkey names separated by delimiters. - -=item Hash key string contains a delimiter - -If the key string contains a delimiter, then it is split after -the last delimiter. The first part is treated as a subkey name or -path of subkey names separated by delimiters. The second part -is ambiguous and is treated as outlined in the next item. - -=item Hash key string contains no delimiters - -If the hash key string contains no delimiters, then it is ambiguous. - -If you are reading from the hash [fetching], then we first use the -key string as a value name. If there is a value with a matching -name in the Registry key which the hash is tied to, then the value -data string [and possibly the value data type] is returned. -Otherwise, we retry by using the hash key string as a subkey name. -If there is a subkey with a matching name, then we return a -reference to a hash tied to that subkey. Otherwise we return -C<undef>. - -If you are writing to the hash [storing], then we use the key -string as a subkey name only if the value you are storing is a -reference to a hash value. Otherwise we use the key string as -a value name. - -=back - -=head3 Examples - -Here are some examples showing different ways of accessing Registry -information using references to tied hashes: - -=over - -=item Canonical value fetch - - $tip18= $Registry->{"HKEY_LOCAL_MACHINE\\Software\\Microsoft\\" - . 'Windows\\CurrentVersion\\Explorer\\Tips\\\\18'}; - -Should return the text of important tip number 18. Note that two -backslashes, C<"\\">, are required to get a single backslash into -a Perl double-quoted or single-qouted string. Note that C<"\\"> -is appended to each key name [C<"HKEY_LOCAL_MACHINE"> through -C<"Tips">] and C<"\\"> is prepended to the value name, C<"18">. - -=item Changing your delimiter - - $Registry->Delimiter("/"); - $tip18= $Registry->{"HKEY_LOCAL_MACHINE/Software/Microsoft/" - . 'Windows/CurrentVersion/Explorer/Tips//18'}; - -This usually makes things easier to read when working in Perl. -All remaining examples will assume the delimiter has been changed -as above. - -=item Using intermediate keys - - $ms= $Registry->{"LMachine/Software/Microsoft/"}; - $tips= $ms->{"Windows/CurrentVersion/Explorer/Tips/"}; - $tip18= $winlogon->{"/18"}; - -Same as above but opens more keys into the Registry which lets you -efficiently re-access those intermediate keys. This is slightly -less efficient if you never reuse those intermediate keys. - -=item Chaining in a single statement - - $tip18= $Registry->{"LMachine/Software/Microsoft/"}-> - {"Windows/CurrentVersion/Explorer/Tips/"}->{"/18"}; - -Like above, this creates intermediate key objects then uses -them to access other data. Once this statement finishes, the -intermediate key objects are destroyed. Several handles into -the Registry are opened and closed by this statement so it is -less efficient but there are times when this will be useful. - -=item Even less efficient example of chaining - - $tip18= $Registry->{"LMachine/Software/Microsoft"}-> - {"Windows/CurrentVersion/Explorer/Tips"}->{"/18"}; - -Because we left off the trailing delimiters, I<Win32::TieRegistry> -doesn't know whether final names, C<"Microsoft"> and C<"Tips">, -are subkey names or value names. So this statement ends up -executing the same code as the next one. - -=item What the above really does - - $tip18= $Registry->{"LMachine/Software/"}->{"Microsoft"}-> - {"Windows/CurrentVersion/Explorer/"}->{"Tips"}->{"/18"}; - -With more chains to go through, more temporary objects are created -and later destroyed than in our first chaining example. Also, -when C<"Microsoft"> is looked up, I<Win32::TieRegistry> first -tries to open it as a value and fails then tries it as a subkey. -The same is true for when it looks up C<"Tips">. - -=item Getting all of the tips - - $tips= $Registry->{"LMachine/Software/Microsoft/"}-> - {"Windows/CurrentVersion/Explorer/Tips/"} - or die "Can't find the Windows tips: $^E\n"; - foreach( keys %$tips ) { - print "$_: ", $tips->{$_}, "\n"; - } - -First notice that we actually check for failure for the first -time. We are assuming that the C<"Tips"> key contains no subkeys. -Otherwise the C<print> statement would show something like -C<"Win32::TieRegistry=HASH(0xc03ebc)"> for each subkey. - -The output from the above code will start something like: - - /0: If you don't know how to do something,[...] - -=back - -=head3 Deleting items - -You can use the Perl C<delete> function to delete a value from a -Registry key or to delete a subkey as long that subkey contains -no subkeys of its own. See L<More Examples>, below, for more -information. - -=head3 Storing items - -You can use the Perl assignment operator [C<=>] to create new -keys, create new values, or replace values. The values you store -should be in the same format as the values you would fetch from a -tied hash. For example, you can use a single assignment statement -to copy an entire Registry tree. The following statement: - - $Registry->{"LMachine/Software/Classes/Tie_Registry/"}= - $Registry->{"LMachine/Software/Classes/batfile/"}; - -creates a C<"Tie_Registry"> subkey under the C<"Software\\Classes"> -subkey of the C<HKEY_LOCAL_MACHINE> key. Then it populates it -with copies of all of the subkeys and values in the C<"batfile"> -subkey and all of its subkeys. Note that you need to have -called C<$Registry-E<gt>ArrayValues(1)> for the proper value data -type information to be copied. Note also that this release of -I<Win32::TieRegistry> does not copy key attributes such as class -name and security information [this is planned for a future release]. - -The following statement creates a whole subtree in the Registry: - - $Registry->{"LMachine/Software/FooCorp/"}= { - "FooWriter/" => { - "/Version" => "4.032", - "Startup/" => { - "/Title" => "Foo Writer Deluxe ][", - "/WindowSize" => [ pack("LL",$wid,$ht), "REG_BINARY" ], - "/TaskBarIcon" => [ "0x0001", "REG_DWORD" ], - }, - "Compatibility/" => { - "/AutoConvert" => "Always", - "/Default Palette" => "Windows Colors", - }, - }, - "/License", => "0123-9C8EF1-09-FC", - }; - -Note that all but the last Registry key used on the left-hand -side of the assignment [that is, "LMachine/Software/" but not -"FooCorp/"] must already exist for this statement to succeed. - -By using the leading a trailing delimiters on each subkey name and -value name, I<Win32::TieRegistry> will tell you if you try to assign -subkey information to a value or visa-versa. - -=head3 More examples - -=over - -=item Adding a new tip - - $tips= $Registry->{"LMachine/Software/Microsoft/"}-> - {"Windows/CurrentVersion/Explorer/Tips/"} - or die "Can't find the Windows tips: $^E\n"; - $tips{'/186'}= "Be very careful when making changes to the Registry!"; - -=item Deleting our new tip - - $tips= $Registry->{"LMachine/Software/Microsoft/"}-> - {"Windows/CurrentVersion/Explorer/Tips/"} - or die "Can't find the Windows tips: $^E\n"; - $tip186= delete $tips{'/186'}; - -Note that Perl's C<delete> function returns the value that was deleted. - -=item Adding a new tip differently - - $Registry->{"LMachine/Software/Microsoft/" . - "Windows/CurrentVersion/Explorer/Tips//186"}= - "Be very careful when making changes to the Registry!"; - -=item Deleting differently - - $tip186= delete $Registry->{"LMachine/Software/Microsoft/Windows/" . - "CurrentVersion/Explorer/Tips//186"}; - -Note that this only deletes the tail of what we looked up, the -C<"186"> value, not any of the keys listed. - -=item Deleting a key - -WARNING: The following code will delete all information about the -current user's tip preferences. Actually executing this command -would probably cause the user to see the Welcome screen the next -time they log in and may cause more serious problems. This -statement is shown as an example only and should not be used when -experimenting. - - $tips= delete $Registry->{"CUser/Software/Microsoft/Windows/" . - "CurrentVersion/Explorer/Tips/"}; - -This deletes the C<"Tips"> key and the values it contains. The -C<delete> function will return a reference to a hash [not a tied -hash] containing the value names and value data that were deleted. - -The information to be returned is copied from the Registry into a -regular Perl hash before the key is deleted. If the key has many -subkeys, this copying could take a significant amount of memory -and/or processor time. So you can disable this process by calling -the C<FastDelete> member function: - - $prevSetting= $regKey->FastDelete(1); - -which will cause all subsequent delete operations via C<$regKey> -to simply return a true value if they succeed. This optimization -is automatically done if you use C<delete> in a void context. - -=item Technical notes on deleting - -If you use C<delete> to delete a Registry key or value and use -the return value, then I<Win32::TieRegistry> usually looks up the -current contents of that key or value so they can be returned if -the deletion is successful. If the deletion succeeds but the -attempt to lookup the old contents failed, then the return value -of C<delete> will be C<$^E> from the failed part of the operation. - -=item Undeleting a key - - $Registry->{"LMachine/Software/Microsoft/Windows/" . - "CurrentVersion/Explorer/Tips/"}= $tips; - -This adds back what we just deleted. Note that this version of -I<Win32::TieRegistry> will use defaults for the key attributes -[such as class name and security] and will not restore the -previous attributes. - -=item Not deleting a key - -WARNING: Actually executing the following code could cause -serious problems. This statement is shown as an example only and -should not be used when experimenting. - - $res= delete $Registry->{"CUser/Software/Microsoft/Windows/"} - defined($res) || die "Can't delete URL key: $^E\n"; - -Since the "Windows" key should contain subkeys, that C<delete> -statement should make no changes to the Registry, return C<undef>, -and set C<$^E> to "Access is denied". - -=item Not deleting again - - $tips= $Registry->{"CUser/Software/Microsoft/Windows/" . - "CurrentVersion/Explorer/Tips/"}; - delete $tips; - -The Perl C<delete> function requires that its argument be an -expression that ends in a hash element lookup [or hash slice], -which is not the case here. The C<delete> function doesn't -know which hash $tips came from and so can't delete it. - -=back - -=head2 Objects Documentation - -The following member functions are defined for use on -I<Win32::TieRegistry> objects: - -=over - -=item new - -The C<new> method creates a new I<Win32::TieRegistry> object. -C<new> is mostly a synonym for C<Open()> so see C<Open()> below for -information on what arguments to pass in. Examples: - - $machKey= new Win32::TieRegistry "LMachine" - or die "Can't access HKEY_LOCAL_MACHINE key: $^E\n"; - $userKey= Win32::TieRegistry->new("CUser") - or die "Can't access HKEY_CURRENT_USER key: $^E\n"; - -Note that calling C<new> via a reference to a tied hash returns -a simple object, not a reference to a tied hash. - -=item Open - -=item $subKey= $key->Open( $sSubKey, $rhOptions ) - -The C<Open> method opens a Registry key and returns a new -I<Win32::TieRegistry> object associated with that Registry key. -If C<Open> is called via a reference to a tied hash, then C<Open> -returns another reference to a tied hash. Otherwise C<Open> -returns a simple object and you should then use C<TiedRef> to get -a reference to a tied hash. - -C<$sSubKey> is a string specifying a subkey to be opened. -Alternately C<$sSubKey> can be a reference to an array value -containing the list of increasingly deep subkeys specifying the -path to the subkey to be opened. - -C<$rhOptions> is an optional reference to a hash containing extra -options. The C<Open> method supports two options, C<"Delimiter"> -and C<"Access">, and C<$rhOptions> should have only have zero or -more of these strings as keys. See the "Examples" section below -for more information. - -The C<"Delimiter"> option specifies what string [usually a single -character] will be used as the delimiter to be appended to subkey -names and prepended to value names. If this option is not specified, -the new key [C<$subKey>] inherits the delimiter of the old key -[C<$key>]. - -The C<"Access"> option specifies what level of access to the -Registry key you wish to have once it has been opened. If this -option is not specified, the new key [C<$subKey>] is opened with -the same access level used when the old key [C<$key>] was opened. -The virtual root of the Registry pretends it was opened with -access C<KEY_READ()|KEY_WRITE()> so this is the default access when -opening keys directory via C<$Registry>. If you don't plan on -modifying a key, you should open it with C<KEY_READ> access as -you may not have C<KEY_WRITE> access to it or some of its subkeys. - -If the C<"Access"> option value is a string that starts with -C<"KEY_">, then it should match E<one> of the predefined access -levels [probably C<"KEY_READ">, C<"KEY_WRITE">, or -C<"KEY_ALL_ACCESS">] exported by the I<Win32API::Registry> module. -Otherwise, a numeric value is expected. For maximum flexibility, -include C<use Win32::TieRegistry qw(:KEY_);>, for example, near -the top of your script so you can specify more complicated access -levels such as C<KEY_READ()|KEY_WRITE()>. - -If C<$sSubKey> does not begin with the delimiter [or C<$sSubKey> -is an array reference], then the path to the subkey to be opened -will be relative to the path of the original key [C<$key>]. If -C<$sSubKey> begins with a single delimiter, then the path to the -subkey to be opened will be relative to the virtual root of the -Registry on whichever machine the original key resides. If -C<$sSubKey> begins with two consectutive delimiters, then those -must be followed by a machine name which causes the C<Connect()> -method function to be called. - -Examples: - - $machKey= $Registry->Open( "LMachine", {Access=>KEY_READ(),Delimiter=>"/"} ) - or die "Can't open HKEY_LOCAL_MACHINE key: $^E\n"; - $swKey= $machKey->Open( "Software" ); - $logonKey= $swKey->Open( "Microsoft/Windows NT/CurrentVersion/Winlogon/" ); - $NTversKey= $swKey->Open( ["Microsoft","Windows NT","CurrentVersion"] ); - $versKey= $swKey->Open( qw(Microsoft Windows CurrentVersion) ); - - $remoteKey= $Registry->Open( "//HostA/LMachine/System/", {Delimiter=>"/"} ) - or die "Can't connect to HostA or can't open subkey: $^E\n"; - -=item Clone - -=item $copy= $key->Clone - -Creates a new object that is associated with the same Registry key -as the invoking object. - -=item Connect - -=item $remoteKey= $Registry->Connect( $sMachineName, $sKeyPath, $rhOptions ) - -The C<Connect> method connects to the Registry of a remote machine, -and opens a key within it, then returns a new I<Win32::TieRegistry> -object associated with that remote Registry key. If C<Connect> -was called using a reference to a tied hash, then the return value -will also be a reference to a tied hash [or C<undef>]. Otherwise, -if you wish to use the returned object as a tied hash [not just as -an object], then use the C<TiedRef> method function after C<Connect>. - -C<$sMachineName> is the name of the remote machine. You don't have -to preceed the machine name with two delimiter characters. - -C<$sKeyPath> is a string specifying the remote key to be opened. -Alternately C<$sKeyPath> can be a reference to an array value -containing the list of increasingly deep keys specifying the path -to the key to be opened. - -C<$rhOptions> is an optional reference to a hash containing extra -options. The C<Connect> method supports two options, C<"Delimiter"> -and C<"Access">. See the C<Open> method documentation for more -information on these options. - -C<$sKeyPath> is already relative to the virtual root of the Registry -of the remote machine. A single leading delimiter on C<sKeyPath> -will be ignored and is not required. - -C<$sKeyPath> can be empty in which case C<Connect> will return an -object representing the virtual root key of the remote Registry. -Each subsequent use of C<Open> on this virtual root key will call -the system C<RegConnectRegistry> function. - -The C<Connect> method can be called via any I<Win32::TieRegistry> -object, not just C<$Registry>. Attributes such as the desired -level of access and the delimiter will be inherited from the -object used but the C<$sKeyPath> will always be relative to the -virtual root of the remote machine's registry. - -Examples: - - $remMachKey= $Registry->Connect( "HostA", "LMachine", {Delimiter->"/"} ) - or die "Can't connect to HostA's HKEY_LOCAL_MACHINE key: $^E\n"; - - $remVersKey= $remMachKey->Connect( "www.microsoft.com", - "LMachine/Software/Microsoft/Inetsrv/CurrentVersion/", - { Access=>KEY_READ, Delimiter=>"/" } ) - or die "Can't check what version of IIS Microsoft is running: $^E\n"; - - $remVersKey= $remMachKey->Connect( "www", - qw(LMachine Software Microsoft Inetsrv CurrentVersion) ) - or die "Can't check what version of IIS we are running: $^E\n"; - -=item ObjectRef - -=item $object_ref= $obj_or_hash_ref->ObjectRef - -For a simple object, just returns itself [C<$obj == $obj->ObjectRef>]. - -For a reference to a tied hash [if it is also an object], C<ObjectRef> -returns the simple object that the hash is tied to. - -This is primarilly useful when debugging since typing C<x $Registry> -will try to display your I<entire> registry contents to your screen. -But the debugger command C<x $Registry->ObjectRef> will just dump -the implementation details of the underlying object to your screen. - -=item Flush( $bFlush ) - -Flushes all cached information about the Registry key so that future -uses will get fresh data from the Registry. - -If the optional C<$bFlush> is specified and a true value, then -C<RegFlushKey()> will be called, which is almost never necessary. - -=item GetValue - -=item $ValueData= $key->GetValue( $sValueName ) - -=item ($ValueData,$ValueType)= $key->GetValue( $sValueName ) - -Gets a Registry value's data and data type. - -C<$ValueData> is usually just a Perl string that contains the -value data [packed into it]. For certain types of data, however, -C<$ValueData> may be processed as described below. - -C<$ValueType> is the C<REG_*> constant describing the type of value -data stored in C<$ValueData>. If the C<DualTypes()> option is on, -then C<$ValueType> will be a dual value. That is, when used in a -numeric context, C<$ValueType> will give the numeric value of a -C<REG_*> constant. However, when used in a non-numeric context, -C<$ValueType> will return the name of the C<REG_*> constant, for -example C<"REG_SZ"> [note the quotes]. So both of the following -can be true at the same time: - - $ValueType == REG_SZ() - $ValueType eq "REG_SZ" - -=over - -=item REG_SZ and REG_EXPAND_SZ - -If the C<FixSzNulls()> option is on, then the trailing C<'\0'> will be -stripped [unless there isn't one] before values of type C<REG_SZ> -and C<REG_EXPAND_SZ> are returned. Note that C<SetValue()> will add -a trailing C<'\0'> under similar circumstances. - -=item REG_MULTI_SZ - -If the C<SplitMultis()> option is on, then values of this type are -returned as a reference to an array containing the strings. For -example, a value that, with C<SplitMultis()> off, would be returned as: - - "Value1\000Value2\000\000" - -would be returned, with C<SplitMultis()> on, as: - - [ "Value1", "Value2" ] - -=item REG_DWORD - -If the C<DualBinVals()> option is on, then the value is returned -as a scalar containing both a string and a number [much like -the C<$!> variable -- see the L<SetDualVar> module for more -information] where the number part is the "unpacked" value. -Use the returned value in a numeric context to access this part -of the value. For example: - - $num= 0 + $Registry->{"CUser/Console//ColorTable01"}; - -If the C<DWordsToHex()> option is off, the string part of the -returned value is a packed, 4-byte string [use C<unpack("L",$value)> -to get the numeric value. - -If C<DWordsToHex()> is on, the string part of the returned value is -a 10-character hex strings [with leading "0x"]. You can use -C<hex($value)> to get the numeric value. - -Note that C<SetValue()> will properly understand each of these -returned value formats no matter how C<DualBinVals()> is set. - -=back - -=item ValueNames - -=item @names= $key->ValueNames - -Returns the list of value names stored directly in a Registry key. -Note that the names returned do I<not> have a delimiter prepended -to them like with C<MemberNames()> and tied hashes. - -Once you request this information, it is cached in the object and -future requests will always return the same list unless C<Flush()> -has been called. - -=item SubKeyNames - -=item @key_names= $key->SubKeyNames - -Returns the list of subkey names stored directly in a Registry key. -Note that the names returned do I<not> have a delimiter appended -to them like with C<MemberNames()> and tied hashes. - -Once you request this information, it is cached in the object and -future requests will always return the same list unless C<Flush()> -has been called. - -=item SubKeyClasses - -=item @classes= $key->SubKeyClasses - -Returns the list of classes for subkeys stored directly in a -Registry key. The classes are returned in the same order as -the subkey names returned by C<SubKeyNames()>. - -=item SubKeyTimes - -=item @times= $key->SubKeyTimes - -Returns the list of last-modified times for subkeys stored -directly in a Registry key. The times are returned in the same -order as the subkey names returned by C<SubKeyNames()>. Each -time is a C<FILETIME> structure packed into a Perl string. - -Once you request this information, it is cached in the object and -future requests will always return the same list unless C<Flush()> -has been called. - -=item MemberNames - -=item @members= $key->MemberNames - -Returns the list of subkey names and value names stored directly -in a Registry key. Subkey names have a delimiter appended to the -end and value names have a delimiter prepended to the front. - -Note that a value name could end in a delimiter [or could be C<""> -so that the member name returned is just a delimiter] so the -presence or absence of the leading delimiter is what should be -used to determine whether a particular name is for a subkey or a -value, not the presence or absence of a trailing delimiter. - -Once you request this information, it is cached in the object and -future requests will always return the same list unless C<Flush()> -has been called. - -=item Information - -=item %info= $key->Information - -=item @items= $key->Information( @itemNames ); - -Returns the following information about a Registry key: - -=over - -=item LastWrite - -A C<FILETIME> structure indicating when the key was last modified -and packed into a Perl string. - -=item CntSubKeys - -The number of subkeys stored directly in this key. - -=item CntValues - -The number of values stored directly in this key. - -=item SecurityLen - -The length [in bytes] of the largest[?] C<SECURITY_DESCRIPTOR> -associated with the Registry key. - -=item MaxValDataLen - -The length [in bytes] of the longest value data associated with -a value stored in this key. - -=item MaxSubKeyLen - -The length [in chars] of the longest subkey name associated with -a subkey stored in this key. - -=item MaxSubClassLen - -The length [in chars] of the longest class name associated with -a subkey stored directly in this key. - -=item MaxValNameLen - -The length [in chars] of the longest value name associated with -a value stored in this key. - -=back - -With no arguments, returns a hash [not a reference to a hash] where -the keys are the names for the items given above and the values -are the information describe above. For example: - - %info= ( "CntValues" => 25, # Key contains 25 values. - "MaxValNameLen" => 20, # One of which has a 20-char name. - "MaxValDataLen" => 42, # One of which has a 42-byte value. - "CntSubKeys" => 1, # Key has 1 immediate subkey. - "MaxSubKeyLen" => 13, # One of which has a 12-char name. - "MaxSubClassLen" => 0, # All of which have class names of "". - "SecurityLen" => 232, # One SECURITY_DESCRIPTOR is 232 bytes. - "LastWrite" => "\x90mZ\cX{\xA3\xBD\cA\c@\cA" - # Key was last modifed 1998/06/01 16:29:32 GMT - ); - -With arguments, each one must be the name of a item given above. -The return value is the information associated with the listed -names. In other words: - - return $key->Information( @names ); - -returns the same list as: - - %info= $key->Information; - return @info{@names}; - -=item Delimiter - -=item $oldDelim= $key->Delimiter - -=item $oldDelim= $key->Delimiter( $newDelim ) - -Gets and possibly changes the delimiter used for this object. The -delimiter is appended to subkey names and prepended to value names -in many return values. It is also used when parsing keys passed -to tied hashes. - -The delimiter defaults to backslash (C<'\\'>) but is inherited from -the object used to create a new object and can be specified by an -option when a new object is created. - -=item Handle - -=item $handle= $key->Handle - -Returns the raw C<HKEY> handle for the associated Registry key as -an integer value. This value can then be used to Reg*() calls -from I<Win32API::Registry>. However, it is usually easier to just -call the I<Win32API::Registry> calls directly via: - - $key->RegNotifyChangeKeyValue( ... ); - -For the virtual root of the local or a remote Registry, -C<Handle()> return C<"NONE">. - -=item Path - -=item $path= $key->Path - -Returns a string describing the path of key names to this -Registry key. The string is built so that if it were passed -to C<$Registry->Open()>, it would reopen the same Registry key -[except in the rare case where one of the key names contains -C<$key->Delimiter>]. - -=item Machine - -=item $computerName= $key->Machine - -Returns the name of the computer [or "machine"] on which this Registry -key resides. Returns C<""> for local Registry keys. - -=item Access - -Returns the numeric value of the bit mask used to specify the -types of access requested when this Registry key was opened. Can -be compared to C<KEY_*> values. - -=item OS_Delimiter - -Returns the delimiter used by the operating system's RegOpenKeyEx() -call. For Win32, this is always backslash (C<"\\">). - -=item Roots - -Returns the mapping from root key names like C<"LMachine"> to their -associated C<HKEY_*> constants. Primarily for internal use and -subject to change. - -=item Tie - -=item $key->Tie( \%hash ); - -Ties the referenced hash to that Registry key. Pretty much the -same as - - tie %hash, ref($key), $key; - -Since C<ref($key)> is the class [package] to tie the hash to and -C<TIEHASH()> just returns its argument, C<$key>, [without calling -C<new()>] when it sees that it is already a blessed object. - -=item TiedRef - -=item $TiedHashRef= $hash_or_obj_ref->TiedRef - -For a simple object, returns a reference to a hash tied to the -object. Used to promote a simple object into a combined object -and hash ref. - -If already a reference to a tied hash [that is also an object], -it just returns itself [C<$ref == $ref->TiedRef>]. - -Mostly used internally. - -=item ArrayValues - -=item $oldBool= $key->ArrayValues - -=item $oldBool= $key->ArrayValues( $newBool ) - -Gets the current setting of the C<ArrayValues> option and possibly -turns it on or off. - -When off, Registry values fetched via a tied hash are returned as -just a value scalar [the same as C<GetValue()> in a scalar context]. -When on, they are returned as a reference to an array containing -the value data as the C<[0]> element and the data type as the C<[1]> -element. - -=item TieValues - -=item $oldBool= TieValues - -=item $oldBool= TieValues( $newBool ) - -Gets the current setting of the C<TieValues> option and possibly -turns it on or off. - -Turning this option on is not yet supported in this release of -I<Win32::TieRegistry>. In a future release, turning this option -on will cause Registry values returned from a tied hash to be -a tied array that you can use to modify the value in the Registry. - -=item FastDelete - -=item $oldBool= $key->FastDelete - -=item $oldBool= $key->FastDelete( $newBool ) - -Gets the current setting of the C<FastDelete> option and possibly -turns it on or off. - -When on, successfully deleting a Registry key [via a tied hash] -simply returns C<1>. - -When off, successfully deleting a Registry key [via a tied hash -and not in a void context] returns a reference to a hash that -contains the values present in the key when it was deleted. This -hash is just like that returned when referencing the key before it -was deleted except that it is an ordinary hash, not one tied to -the I<Win32::TieRegistry> package. - -Note that deleting either a Registry key or value via a tied hash -I<in a void context> prevents any overhead in trying to build an -appropriate return value. - -Note that deleting a Registry I<value> via a tied hash [not in -a void context] returns the value data even if <FastDelete> is on. - -=item SplitMultis - -=item $oldBool= $key->SplitMultis - -=item $oldBool= $key->SplitMultis( $newBool ) - -Gets the current setting of the C<SplitMultis> option and possibly -turns it on or off. - -If on, Registry values of type C<REG_MULTI_SZ> are returned as -a reference to an array of strings. See C<GetValue()> for more -information. - -=item DWordsToHex - -=item $oldBool= $key->DWordsToHex - -=item $oldBool= $key->DWordsToHex( $newBool ) - -Gets the current setting of the C<DWordsToHex> option and possibly -turns it on or off. - -If on, Registry values of type C<REG_DWORD> are returned as a hex -string with leading C<"0x"> and longer than 4 characters. See -C<GetValue()> for more information. - -=item FixSzNulls - -=item $oldBool= $key->FixSzNulls - -=item $oldBool= $key->FixSzNulls( $newBool ) - -Gets the current setting of the C<FixSzNulls> option and possibly -turns it on or off. - -If on, Registry values of type C<REG_SZ> and C<REG_EXPAND_SZ> have -trailing C<'\0'>s added before they are set and stripped before -they are returned. See C<GetValue()> and C<SetValue()> for more -information. - -=item DualTypes - -=item $oldBool= $key->DualTypes - -=item $oldBool= $key->DualTypes( $newBool ) - -Gets the current setting of the C<DualTypes> option and possibly -turns it on or off. - -If on, data types are returned as a combined numeric/string value -holding both the numeric value of a C<REG_*> constant and the -string value of the constant's name. See C<GetValue()> for -more information. - -=item DualBinVals - -=item $oldBool= $key->DualBinVals - -=item $oldBool= $key->DualBinVals( $newBool ) - -Gets the current setting of the C<DualBinVals> option and possibly -turns it on or off. - -If on, Registry value data of type C<REG_BINARY> and no more than -4 bytes long and Registry values of type C<REG_DWORD> are returned -as a combined numeric/string value where the numeric value is the -"unpacked" binary value as returned by: - - hex reverse unpack( "h*", $valData ) - -on a "little-endian" computer. [Would be C<hex unpack("H*",$valData)> -on a "big-endian" computer if this module is ever ported to one.] - -See C<GetValue()> for more information. - -=item GetOptions - -=item @oldOptValues= $key->GetOptions( @optionNames ) - -=item $refHashOfOldOpts= $key->GetOptions() - -=item $key->GetOptions( \%hashForOldOpts ) - -Returns the current setting of any of the following options: - - Delimiter FixSzNulls DWordsToHex - ArrayValues SplitMultis DualBinVals - TieValues FastDelete DualTypes - -Pass in one or more of the above names (as strings) to get back -an array of the corresponding current settings in the same order: - - my( $fastDel, $delim )= $key->GetOptions("FastDelete","Delimiter"); - -Pass in no arguments to get back a reference to a hash where -the above option names are the keys and the values are -the corresponding current settings for each option: - - my $href= $key->GetOptions(); - my $delim= $href->{Delimiter}; - -Pass in a single reference to a hash to have the above key/value -pairs I<added> to the referenced hash. For this case, the -return value is the original object so further methods can be -chained after the call to GetOptions: - - my %oldOpts; - $key->GetOptions( \%oldOpts )->SetOptions( Delimiter => "/" ); - -=item SetOptions - -=item @oldOpts= $key->SetOptions( optNames=>$optValue,... ) - -Changes the current setting of any of the following options, -returning the previous setting(s): - - Delimiter FixSzNulls DWordsToHex AllowLoad - ArrayValues SplitMultis DualBinVals AllowSave - TieValues FastDelete DualTypes - -For C<AllowLoad> and C<AllowSave>, instead of the previous -setting, C<SetOptions> returns whether or not the change was -successful. - -In a scalar context, returns only the last item. The last -option can also be specified as C<"ref"> or C<"r"> [which doesn't -need to be followed by a value] to allow chaining: - - $key->SetOptions(AllowSave=>1,"ref")->RegSaveKey(...) - -=item SetValue - -=item $okay= $key->SetValue( $ValueName, $ValueData ); - -=item $okay= $key->SetValue( $ValueName, $ValueData, $ValueType ); - -Adds or replaces a Registry value. Returns a true value if -successfully, false otherwise. - -C<$ValueName> is the name of the value to add or replace and -should I<not> have a delimiter prepended to it. Case is ignored. - -C<$ValueType> is assumed to be C<REG_SZ> if it is omitted. Otherwise, -it should be one the C<REG_*> constants. - -C<$ValueData> is the data to be stored in the value, probably packed -into a Perl string. Other supported formats for value data are -listed below for each posible C<$ValueType>. - -=over - -=item REG_SZ or REG_EXPAND_SZ - -The only special processing for these values is the addition of -the required trailing C<'\0'> if it is missing. This can be -turned off by disabling the C<FixSzNulls> option. - -=item REG_MULTI_SZ - -These values can also be specified as a reference to a list of -strings. For example, the following two lines are equivalent: - - $key->SetValue( "Val1\000Value2\000LastVal\000\000", "REG_MULTI_SZ" ); - $key->SetValue( ["Val1","Value2","LastVal"], "REG_MULTI_SZ" ); - -Note that if the required two trailing nulls (C<"\000\000">) are -missing, then this release of C<SetValue()> will I<not> add them. - -=item REG_DWORD - -These values can also be specified as a hex value with the leading -C<"0x"> included and totaling I<more than> 4 bytes. These will be -packed into a 4-byte string via: - - $data= pack( "L", hex($data) ); - -=item REG_BINARY - -This value type is listed just to emphasize that no alternate -format is supported for it. In particular, you should I<not> pass -in a numeric value for this type of data. C<SetValue()> cannot -distinguish such from a packed string that just happens to match -a numeric value and so will treat it as a packed string. - -=back - -An alternate calling format: - - $okay= $key->SetValue( $ValueName, [ $ValueData, $ValueType ] ); - -[two arguments, the second of which is a reference to an array -containing the value data and value type] is supported to ease -using tied hashes with C<SetValue()>. - -=item CreateKey - -=item $newKey= $key->CreateKey( $subKey ); - -=item $newKey= $key->CreateKey( $subKey, { Option=>OptVal,... } ); - -Creates a Registry key or just updates attributes of one. Calls -C<RegCreateKeyEx()> then, if it succeeded, creates an object -associated with the [possibly new] subkey. - -C<$subKey> is the name of a subkey [or a path to one] to be -created or updated. It can also be a reference to an array -containing a list of subkey names. - -The second argument, if it exists, should be a reference to a -hash specifying options either to be passed to C<RegCreateKeyEx()> -or to be used when creating the associated object. The following -items are the supported keys for this options hash: - -=over - -=item Delimiter - -Specifies the delimiter to be used to parse C<$subKey> and to be -used in the new object. Defaults to C<$key->Delimiter>. - -=item Access - -Specifies the types of access requested when the subkey is opened. -Should be a numeric bit mask that combines one or more C<KEY_*> -constant values. - -=item Class - -The name to assign as the class of the new or updated subkey. -Defaults to C<""> as we have never seen a use for this information. - -=item Disposition - -Lets you specify a reference to a scalar where, upon success, will be -stored either C<REG_CREATED_NEW_KEY()> or C<REG_OPENED_EXISTING_KEY()> -depending on whether a new key was created or an existing key was -opened. - -If you, for example, did C<use Win32::TieRegistry qw(REG_CREATED_NEW_KEY)> -then you can use C<REG_CREATED_NEW_KEY()> to compare against the numeric -value stored in the referenced scalar. - -If the C<DualTypes> option is enabled, then in addition to the -numeric value described above, the referenced scalar will also -have a string value equal to either C<"REG_CREATED_NEW_KEY"> or -C<"REG_OPENED_EXISTING_KEY">, as appropriate. - -=item Security - -Lets you specify a C<SECURITY_ATTRIBUTES> structure packed into a -Perl string. See C<Win32API::Registry::RegCreateKeyEx()> for more -information. - -=item Volatile - -If true, specifies that the new key should be volatile, that is, -stored only in memory and not backed by a hive file [and not saved -if the computer is rebooted]. This option is ignored under -Windows 95. Specifying C<Volatile=E<GT>1> is the same as -specifying C<Options=E<GT>REG_OPTION_VOLATILE>. - -=item Backup - -If true, specifies that the new key should be opened for -backup/restore access. The C<Access> option is ignored. If the -calling process has enabled C<"SeBackupPrivilege">, then the -subkey is opened with C<KEY_READ> access as the C<"LocalSystem"> -user which should have access to all subkeys. If the calling -process has enabled C<"SeRestorePrivilege">, then the subkey is -opened with C<KEY_WRITE> access as the C<"LocalSystem"> user which -should have access to all subkeys. - -This option is ignored under Windows 95. Specifying C<Backup=E<GT>1> -is the same as specifying C<Options=E<GT>REG_OPTION_BACKUP_RESTORE>. - -=item Options - -Lets you specify options to the C<RegOpenKeyEx()> call. The value -for this option should be a numeric value combining zero or more -of the C<REG_OPTION_*> bit masks. You may with to used the -C<Volatile> and/or C<Backup> options instead of this one. - -=back - -=item StoreKey - -=item $newKey= $key->StoreKey( $subKey, \%Contents ); - -Primarily for internal use. - -Used to create or update a Registry key and any number of subkeys -or values under it or its subkeys. - -C<$subKey> is the name of a subkey to be created [or a path of -subkey names separated by delimiters]. If that subkey already -exists, then it is updated. - -C<\%Contents> is a reference to a hash containing pairs of -value names with value data and/or subkey names with hash -references similar to C<\%Contents>. Each of these cause -a value or subkey of C<$subKey> to be created or updated. - -If C<$Contents{""}> exists and is a reference to a hash, then -it used as the options argument when C<CreateKey()> is called -for C<$subKey>. This allows you to specify ... - - if( defined( $$data{""} ) && "HASH" eq ref($$data{""}) ) { - $self= $this->CreateKey( $subKey, delete $$data{""} ); - -=item Load - -=item $newKey= $key->Load( $file ) - -=item $newKey= $key->Load( $file, $newSubKey ) - -=item $newKey= $key->Load( $file, $newSubKey, { Option=>OptVal... } ) - -=item $newKey= $key->Load( $file, { Option=>OptVal... } ) - -Loads a hive file into a Registry. That is, creates a new subkey -and associates a hive file with it. - -C<$file> is a hive file, that is a file created by calling -C<RegSaveKey()>. The C<$file> path is interpreted relative to -C<%SystemRoot%/System32/config> on the machine where C<$key> -resides. - -C<$newSubKey> is the name to be given to the new subkey. If -C<$newSubKey> is specified, then C<$key> must be -C<HKEY_LOCAL_MACHINE> or C<HKEY_USERS> of the local computer -or a remote computer and C<$newSubKey> should not contain any -occurrences of either the delimiter or the OS delimiter. - -If C<$newSubKey> is not specified, then it is as if C<$key> -was C<$Registry-E<GT>{LMachine}> and C<$newSubKey> is -C<"PerlTie:999"> where C<"999"> is actually a sequence number -incremented each time this process calls C<Load()>. - -You can specify as the last argument a reference to a hash -containing options. You can specify the same options that you -can specify to C<Open()>. See C<Open()> for more information on -those. In addition, you can specify the option C<"NewSubKey">. -The value of this option is interpretted exactly as if it was -specified as the C<$newSubKey> parameter and overrides the -C<$newSubKey> if one was specified. - -The hive is automatically unloaded when the returned object -[C<$newKey>] is destroyed. Registry key objects opened within -the hive will keep a reference to the C<$newKey> object so that -it will not be destroyed before these keys are closed. - -=item UnLoad - -=item $okay= $key->UnLoad - -Unloads a hive that was loaded via C<Load()>. Cannot unload other -hives. C<$key> must be the return from a previous call to C<Load()>. -C<$key> is closed and then the hive is unloaded. - -=item AllowSave - -=item $okay= AllowSave( $bool ) - -Enables or disables the C<"ReBackupPrivilege"> privilege for the -current process. You will probably have to enable this privilege -before you can use C<RegSaveKey()>. - -The return value indicates whether the operation succeeded, not -whether the privilege was previously enabled. - -=item AllowLoad - -=item $okay= AllowLoad( $bool ) - -Enables or disables the C<"ReRestorePrivilege"> privilege for the -current process. You will probably have to enable this privilege -before you can use C<RegLoadKey()>, C<RegUnLoadKey()>, -C<RegReplaceKey()>, or C<RegRestoreKey> and thus C<Load()> and -C<UnLoad()>. - -The return value indicates whether the operation succeeded, not -whether the privilege was previously enabled. - -=back - -=head2 Exports [C<use> and C<import()>] - -To have nothing imported into your package, use something like: - - use Win32::TieRegistry 0.20 (); - -which would verify that you have at least version 0.20 but wouldn't -call C<import()>. The F<Changes> file can be useful in figuring out -which, if any, prior versions of I<Win32::TieRegistry> you want to -support in your script. - -The code - - use Win32::TieRegistry; - -imports the variable C<$Registry> into your package and sets it -to be a reference to a hash tied to a copy of the master Registry -virtual root object with the default options. One disadvantage -to this "default" usage is that Perl does not support checking -the module version when you use it. - -Alternately, you can specify a list of arguments on the C<use> -line that will be passed to the C<Win32::TieRegistry->import()> -method to control what items to import into your package. These -arguments fall into the following broad categories: - -=over - -=item Import a reference to a hash tied to a Registry virtual root - -You can request that a scalar variable be imported (possibly) -and set to be a reference to a hash tied to a Registry virtual root -using any of the following types of arguments or argument pairs: - -=over - -=item "TiedRef", '$scalar' - -=item "TiedRef", '$pack::scalar' - -=item "TiedRef", 'scalar' - -=item "TiedRef", 'pack::scalar' - -All of the above import a scalar named C<$scalar> into your package -(or the package named "pack") and then sets it. - -=item '$scalar' - -=item '$pack::scalar' - -These are equivalent to the previous items to support a more -traditional appearance to the list of exports. Note that the -scalar name cannot be "RegObj" here. - -=item "TiedRef", \$scalar - -=item \$scalar - -These versions don't import anything but set the referenced C<$scalar>. - -=back - -=item Import a hash tied to the Registry virtual root - -You can request that a hash variable be imported (possibly) -and tied to a Registry virtual root using any of the following -types of arguments or argument pairs: - -=over - -=item "TiedHash", '%hash' - -=item "TiedHash", '%pack::hash' - -=item "TiedHash", 'hash' - -=item "TiedHash", 'pack::hash' - -All of the above import a hash named C<%hash> into your package -(or the package named "pack") and then sets it. - -=item '%hash' - -=item '%pack::hash' - -These are equivalent to the previous items to support a more -traditional appearance to the list of exports. - -=item "TiedHash", \%hash - -=item \%hash - -These versions don't import anything but set the referenced C<%hash>. - -=back - -=item Import a Registry virtual root object - -You can request that a scalar variable be imported (possibly) -and set to be a Registry virtual root object using any of the -following types of arguments or argument pairs: - -=over - -=item "ObjectRef", '$scalar' - -=item "ObjectRef", '$pack::scalar' - -=item "ObjectRef", 'scalar' - -=item "ObjectRef", 'pack::scalar' - -All of the above import a scalar named C<$scalar> into your package -(or the package named "pack") and then sets it. - -=item '$RegObj' - -This is equivalent to the previous items for backward compatibility. - -=item "ObjectRef", \$scalar - -This version doesn't import anything but sets the referenced C<$scalar>. - -=back - -=item Import constant(s) exported by I<Win32API::Registry> - -You can list any constants that are exported by I<Win32API::Registry> -to have them imported into your package. These constants have names -starting with "KEY_" or "REG_" (or even "HKEY_"). - -You can also specify C<":KEY_">, C<":REG_">, and even C<":HKEY_"> to -import a whole set of constants. - -See I<Win32API::Registry> documentation for more information. - -=item Options - -You can list any option names that can be listed in the C<SetOptions()> -method call, each folowed by the value to use for that option. -A Registry virtual root object is created, all of these options are -set for it, then each variable to be imported/set is associated with -this object. - -In addition, the following special options are supported: - -=over - -=item ExportLevel - -Whether to import variables into your package or some -package that uses your package. Defaults to the value of -C<$Exporter::ExportLevel> and has the same meaning. See -the L<Exporter> module for more information. - -=item ExportTo - -The name of the package to import variables and constants into. -Overrides I<ExportLevel>. - -=back - -=back - -=head3 Specifying constants in your Perl code - -This module was written with a strong emphasis on the convenience of -the module user. Therefore, most places where you can specify a -constant like C<REG_SZ()> also allow you to specify a string -containing the name of the constant, C<"REG_SZ">. This is convenient -because you may not have imported that symbolic constant. - -Perl also emphasizes programmer convenience so the code C<REG_SZ> -can be used to mean C<REG_SZ()> or C<"REG_SZ"> or be illegal. -Note that using C<®_SZ> (as we've seen in much Win32 Perl code) -is not a good idea since it passes the current C<@_> to the -C<constant()> routine of the module which, at the least, can give -you a warning under B<-w>. - -Although greatly a matter of style, the "safest" practice is probably -to specifically list all constants in the C<use Win32::TieRegistry> -statement, specify C<use strict> [or at least C<use strict qw(subs)>], -and use bare constant names when you want the numeric value. This will -detect mispelled constant names at compile time. - - use strict; - my $Registry; - use Win32::TieRegistry 0.20 ( - TiedRef => \$Registry, Delimiter => "/", ArrayValues => 1, - SplitMultis => 1, AllowLoad => 1, - qw( REG_SZ REG_EXPAND_SZ REG_DWORD REG_BINARY REG_MULTI_SZ - KEY_READ KEY_WRITE KEY_ALL_ACCESS ), - ); - $Registry->{"LMachine/Software/FooCorp/"}= { - "FooWriter/" => { - "/Fonts" => [ ["Times","Courier","Lucinda"], REG_MULTI_SZ ], - "/WindowSize" => [ pack("LL",24,80), REG_BINARY ], - "/TaskBarIcon" => [ "0x0001", REG_DWORD ], - }, - } or die "Can't create Software/FooCorp/: $^E\n"; - -If you don't want to C<use strict qw(subs)>, the second safest practice -is similar to the above but use the C<REG_SZ()> form for constants -when possible and quoted constant names when required. Note that -C<qw()> is a form of quoting. - - use Win32::TieRegistry 0.20 qw( - TiedRef $Registry - Delimiter / ArrayValues 1 SplitMultis 1 AllowLoad 1 - REG_SZ REG_EXPAND_SZ REG_DWORD REG_BINARY REG_MULTI_SZ - KEY_READ KEY_WRITE KEY_ALL_ACCESS - ); - $Registry->{"LMachine/Software/FooCorp/"}= { - "FooWriter/" => { - "/Fonts" => [ ["Times","Courier","Lucinda"], REG_MULTI_SZ() ], - "/WindowSize" => [ pack("LL",24,80), REG_BINARY() ], - "/TaskBarIcon" => [ "0x0001", REG_DWORD() ], - }, - } or die "Can't create Software/FooCorp/: $^E\n"; - -The examples in this document mostly use quoted constant names -(C<"REG_SZ">) since that works regardless of which constants -you imported and whether or not you have C<use strict> in your -script. It is not the best choice for you to use for real -scripts (vs. examples) because it is less efficient and is not -supported by most other similar modules. - -=head1 SUMMARY - -Most things can be done most easily via tied hashes. Skip down to the -the L<Tied Hashes Summary> to get started quickly. - -=head2 Objects Summary - -Here are quick examples that document the most common functionality -of all of the method functions [except for a few almost useless ones]. - - # Just another way of saying Open(): - $key= new Win32::TieRegistry "LMachine\\Software\\", - { Access=>KEY_READ()|KEY_WRITE(), Delimiter=>"\\" }; - - # Open a Registry key: - $subKey= $key->Open( "SubKey/SubSubKey/", - { Access=>KEY_ALL_ACCESS, Delimiter=>"/" } ); - - # Connect to a remote Registry key: - $remKey= $Registry->Connect( "MachineName", "LMachine/", - { Access=>KEY_READ, Delimiter=>"/" } ); - - # Get value data: - $valueString= $key->GetValue("ValueName"); - ( $valueString, $valueType )= $key->GetValue("ValueName"); - - # Get list of value names: - @valueNames= $key->ValueNames; - - # Get list of subkey names: - @subKeyNames= $key->SubKeyNames; - - # Get combined list of value names (with leading delimiters) - # and subkey names (with trailing delimiters): - @memberNames= $key->MemberNames; - - # Get all information about a key: - %keyInfo= $key->Information; - # keys(%keyInfo)= qw( Class LastWrite SecurityLen - # CntSubKeys MaxSubKeyLen MaxSubClassLen - # CntValues MaxValNameLen MaxValDataLen ); - - # Get selected information about a key: - ( $class, $cntSubKeys )= $key->Information( "Class", "CntSubKeys" ); - - # Get and/or set delimiter: - $delim= $key->Delimiter; - $oldDelim= $key->Delimiter( $newDelim ); - - # Get "path" for an open key: - $path= $key->Path; - # For example, "/CUser/Control Panel/Mouse/" - # or "//HostName/LMachine/System/DISK/". - - # Get name of machine where key is from: - $mach= $key->Machine; - # Will usually be "" indicating key is on local machine. - - # Control different options (see main documentation for descriptions): - $oldBool= $key->ArrayValues( $newBool ); - $oldBool= $key->FastDelete( $newBool ); - $oldBool= $key->FixSzNulls( $newBool ); - $oldBool= $key->SplitMultis( $newBool ); - $oldBool= $key->DWordsToHex( $newBool ); - $oldBool= $key->DualBinVals( $newBool ); - $oldBool= $key->DualTypes( $newBool ); - @oldBools= $key->SetOptions( ArrayValues=>1, FastDelete=>1, FixSzNulls=>0, - Delimiter=>"/", AllowLoad=>1, AllowSave=>1 ); - @oldBools= $key->GetOptions( ArrayValues, FastDelete, FixSzNulls ); - - # Add or set a value: - $key->SetValue( "ValueName", $valueDataString ); - $key->SetValue( "ValueName", pack($format,$valueData), "REG_BINARY" ); - - # Add or set a key: - $key->CreateKey( "SubKeyName" ); - $key->CreateKey( "SubKeyName", - { Access=>"KEY_ALL_ACCESS", Class=>"ClassName", - Delimiter=>"/", Volatile=>1, Backup=>1 } ); - - # Load an off-line Registry hive file into the on-line Registry: - $newKey= $Registry->Load( "C:/Path/To/Hive/FileName" ); - $newKey= $key->Load( "C:/Path/To/Hive/FileName", "NewSubKeyName", - { Access=>"KEY_READ" } ); - # Unload a Registry hive file loaded via the Load() method: - $newKey->UnLoad; - - # (Dis)Allow yourself to load Registry hive files: - $success= $Registry->AllowLoad( $bool ); - - # (Dis)Allow yourself to save a Registry key to a hive file: - $success= $Registry->AllowSave( $bool ); - - # Save a Registry key to a new hive file: - $key->RegSaveKey( "C:/Path/To/Hive/FileName", [] ); - -=head3 Other Useful Methods - -See I<Win32API::Registry> for more information on these methods. -These methods are provided for coding convenience and are -identical to the I<Win32API::Registry> functions except that these -don't take a handle to a Registry key, instead getting the handle -from the invoking object [C<$key>]. - - $key->RegGetKeySecurity( $iSecInfo, $sSecDesc, $lenSecDesc ); - $key->RegLoadKey( $sSubKeyName, $sPathToFile ); - $key->RegNotifyChangeKeyValue( - $bWatchSubtree, $iNotifyFilter, $hEvent, $bAsync ); - $key->RegQueryMultipleValues( - $structValueEnts, $cntValueEnts, $Buffer, $lenBuffer ); - $key->RegReplaceKey( $sSubKeyName, $sPathToNewFile, $sPathToBackupFile ); - $key->RegRestoreKey( $sPathToFile, $iFlags ); - $key->RegSetKeySecurity( $iSecInfo, $sSecDesc ); - $key->RegUnLoadKey( $sSubKeyName ); - -=head2 Tied Hashes Summary - -For fast learners, this may be the only section you need to read. -Always append one delimiter to the end of each Registry key name -and prepend one delimiter to the front of each Registry value name. - -=head3 Opening keys - - use Win32::TieRegistry ( Delimiter=>"/", ArrayValues=>1 ); - $Registry->Delimiter("/"); # Set delimiter to "/". - $swKey= $Registry->{"LMachine/Software/"}; - $winKey= $swKey->{"Microsoft/Windows/CurrentVersion/"}; - $userKey= $Registry-> - {"CUser/Software/Microsoft/Windows/CurrentVersion/"}; - $remoteKey= $Registry->{"//HostName/LMachine/"}; - -=head3 Reading values - - $progDir= $winKey->{"/ProgramFilesDir"}; # "C:\\Program Files" - $tip21= $winKey->{"Explorer/Tips//21"}; # Text of tip #21. - - $winKey->ArrayValues(1); - ( $devPath, $type )= $winKey->{"/DevicePath"}; - # $devPath eq "%SystemRoot%\\inf" - # $type eq "REG_EXPAND_SZ" [if you have SetDualVar.pm installed] - # $type == REG_EXPAND_SZ() [if did C<use Win32::TieRegistry qw(:REG_)>] - -=head3 Setting values - - $winKey->{"Setup//SourcePath"}= "\\\\SwServer\\SwShare\\Windows"; - # Simple. Assumes data type of REG_SZ. - - $winKey->{"Setup//Installation Sources"}= - [ "D:\x00\\\\SwServer\\SwShare\\Windows\0\0", "REG_MULTI_SZ" ]; - # "\x00" and "\0" used to mark ends of each string and end of list. - - $winKey->{"Setup//Installation Sources"}= - [ ["D:","\\\\SwServer\\SwShare\\Windows"], "REG_MULTI_SZ" ]; - # Alternate method that is easier to read. - - $userKey->{"Explorer/Tips//DisplayInitialTipWindow"}= - [ pack("L",0), "REG_DWORD" ]; - $userKey->{"Explorer/Tips//Next"}= [ pack("S",3), "REG_BINARY" ]; - $userKey->{"Explorer/Tips//Show"}= [ pack("L",0), "REG_BINARY" ]; - -=head3 Adding keys - - $swKey->{"FooCorp/"}= { - "FooWriter/" => { - "/Version" => "4.032", - "Startup/" => { - "/Title" => "Foo Writer Deluxe ][", - "/WindowSize" => [ pack("LL",$wid,$ht), "REG_BINARY" ], - "/TaskBarIcon" => [ "0x0001", "REG_DWORD" ], - }, - "Compatibility/" => { - "/AutoConvert" => "Always", - "/Default Palette" => "Windows Colors", - }, - }, - "/License", => "0123-9C8EF1-09-FC", - }; - -=head3 Listing all subkeys and values - - @members= keys( %{$swKey} ); - @subKeys= grep( m#^/#, keys( %{$swKey->{"Classes/batfile/"}} ) ); - # @subKeys= ( "/", "/EditFlags" ); - @valueNames= grep( ! m#^/#, keys( %{$swKey->{"Classes/batfile/"}} ) ); - # @valueNames= ( "DefaultIcon/", "shell/", "shellex/" ); - -=head3 Deleting values or keys with no subkeys - - $oldValue= delete $userKey->{"Explorer/Tips//Next"}; - - $oldValues= delete $userKey->{"Explorer/Tips/"}; - # $oldValues will be reference to hash containing deleted keys values. - -=head3 Closing keys - - undef $swKey; # Explicit way to close a key. - $winKey= "Anything else"; # Implicitly closes a key. - exit 0; # Implicitly closes all keys. - -=head2 Tie::Registry - -This module was originally called I<Tie::Registry>. Changing code -that used I<Tie::Registry> over to I<Win32::TieRegistry> is trivial -as the module name should only be mentioned once, in the C<use> -line. However, finding all of the places that used I<Tie::Registry> -may not be completely trivial so we have included F<Tie/Registry.pm> -which you can install to provide backward compatibility. - -=head1 AUTHOR - -Tye McQueen. See http://www.metronet.com/~tye/ or e-mail -tye@metronet.com with bug reports. - -=head1 SEE ALSO - -I<Win32API::Registry> - Provides access to C<Reg*()>, C<HKEY_*>, -C<KEY_*>, C<REG_*> [required]. - -I<Win32::WinError> - Defines C<ERROR_*> values [optional]. - -L<SetDualVar> - For returning C<REG_*> values as combined -string/integer values [optional]. - -=head1 BUGS - -Perl5.004_02 has bugs that make I<Win32::TieRegistry> fail in -strange and subtle ways. - -Using I<Win32::TieRegistry> with versions of Perl prior to 5.005 -can be tricky or impossible. Most notes about this have been -removed from the documentation (they get rather complicated -and confusing). This includes references to C<$^E> perhaps not -being meaningful. - -Because Perl hashes are case sensitive, certain lookups are also -case sensistive. In particular, the root keys ("Classes", "CUser", -"LMachine", "Users", "PerfData", "CConfig", "DynData", and HKEY_*) -must always be entered without changing between upper and lower -case letters. Also, the special rule for matching subkey names -that contain the user-selected delimiter only works if case is -matched. All other key name and value name lookups should be case -insensitive because the underlying Reg*() calls ignore case. - -Information about each key is cached when using a tied hash. -This cache is not flushed nor updated when changes are made, -I<even when the same tied hash is used> to make the changes. - -Current implementations of Perl's "global destruction" phase can -cause objects returned by C<Load()> to be destroyed while keys -within the hive are still open, if the objects still exist when -the script starts to exit. When this happens, the automatic -C<UnLoad()> will report a failure and the hive will remain loaded -in the Registry. - -Trying to C<Load()> a hive file that is located on a remote network -share may silently delete all data from the hive. This is a bug -in the Win32 APIs, not any Perl code or modules. This module does -not try to protect you from this bug. - -There is no test suite. - -=head1 FUTURE DIRECTIONS - -The following items are desired by the author and may appear in a -future release of this module. - -=over - -=item TieValues option - -Currently described in main documentation but no yet implemented. - -=item AutoRefresh option - -Trigger use of C<RegNotifyChangeKeyValue()> to keep tied hash -caches up-to-date even when other programs make changes. - -=item Error options - -Allow the user to have unchecked calls (calls in a "void context") -to automatically report errors via C<warn> or C<die>. - -For complex operations, such a copying an entire subtree, provide -access to detailed information about errors (and perhaps some -warnings) that were encountered. Let the user control whether -the complex operation continues in spite of errors. - -=back - -=cut - -# Autoload not currently supported by Perl under Windows. diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Win32API/Registry.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Win32API/Registry.pm deleted file mode 100644 index dbf98b4e2e9..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/Win32API/Registry.pm +++ /dev/null @@ -1,1792 +0,0 @@ -# Registry.pm -- Low-level access to functions/constants from WINREG.h - -package Win32API::Registry; - -use strict; -use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); #@EXPORT_FAIL); -$VERSION= '0.24'; - -require Exporter; -require DynaLoader; -@ISA= qw(Exporter DynaLoader); - -@EXPORT= qw(); -%EXPORT_TAGS= ( - Func => [qw( regConstant regLastError - AllowPriv AbortSystemShutdown InitiateSystemShutdown - RegCloseKey RegConnectRegistry RegCreateKey - RegCreateKeyEx RegDeleteKey RegDeleteValue - RegEnumKey RegEnumKeyEx RegEnumValue - RegFlushKey RegGetKeySecurity RegLoadKey - RegNotifyChangeKeyValue RegOpenKey RegOpenKeyEx - RegQueryInfoKey RegQueryMultipleValues RegQueryValue - RegQueryValueEx RegReplaceKey RegRestoreKey - RegSaveKey RegSetKeySecurity RegSetValue - RegSetValueEx RegUnLoadKey )], - FuncA => [qw( - AbortSystemShutdownA InitiateSystemShutdownA - RegConnectRegistryA RegCreateKeyA RegCreateKeyExA - RegDeleteKeyA RegDeleteValueA RegEnumKeyA - RegEnumKeyExA RegEnumValueA RegLoadKeyA - RegOpenKeyA RegOpenKeyExA RegQueryInfoKeyA - RegQueryMultipleValuesA RegQueryValueA RegQueryValueExA - RegReplaceKeyA RegRestoreKeyA RegSaveKeyA - RegSetValueA RegSetValueExA RegUnLoadKeyA )], - FuncW => [qw( - AbortSystemShutdownW InitiateSystemShutdownW - RegConnectRegistryW RegCreateKeyW RegCreateKeyExW - RegDeleteKeyW RegDeleteValueW RegEnumKeyW - RegEnumKeyExW RegEnumValueW RegLoadKeyW - RegOpenKeyW RegOpenKeyExW RegQueryInfoKeyW - RegQueryMultipleValuesW RegQueryValueW RegQueryValueExW - RegReplaceKeyW RegRestoreKeyW RegSaveKeyW - RegSetValueW RegSetValueExW RegUnLoadKeyW )], - HKEY_ => [qw( - HKEY_CLASSES_ROOT HKEY_CURRENT_CONFIG HKEY_CURRENT_USER - HKEY_DYN_DATA HKEY_LOCAL_MACHINE HKEY_PERFORMANCE_DATA - HKEY_USERS )], - KEY_ => [qw( - KEY_QUERY_VALUE KEY_SET_VALUE KEY_CREATE_SUB_KEY - KEY_ENUMERATE_SUB_KEYS KEY_NOTIFY KEY_CREATE_LINK - KEY_READ KEY_WRITE KEY_EXECUTE - KEY_ALL_ACCESS), - 'KEY_DELETE', # DELETE (0x00010000L) - 'KEY_READ_CONTROL', # READ_CONTROL (0x00020000L) - 'KEY_WRITE_DAC', # WRITE_DAC (0x00040000L) - 'KEY_WRITE_OWNER', # WRITE_OWNER (0x00080000L) - 'KEY_SYNCHRONIZE', # SYNCHRONIZE (0x00100000L) (not used) - ], - REG_ => [qw( - REG_OPTION_RESERVED REG_OPTION_NON_VOLATILE REG_OPTION_VOLATILE - REG_OPTION_CREATE_LINK REG_OPTION_BACKUP_RESTORE - REG_OPTION_OPEN_LINK REG_LEGAL_OPTION REG_CREATED_NEW_KEY - REG_OPENED_EXISTING_KEY REG_WHOLE_HIVE_VOLATILE REG_REFRESH_HIVE - REG_NO_LAZY_FLUSH REG_NOTIFY_CHANGE_ATTRIBUTES - REG_NOTIFY_CHANGE_NAME REG_NOTIFY_CHANGE_LAST_SET - REG_NOTIFY_CHANGE_SECURITY REG_LEGAL_CHANGE_FILTER - REG_NONE REG_SZ REG_EXPAND_SZ - REG_BINARY REG_DWORD REG_DWORD_LITTLE_ENDIAN - REG_DWORD_BIG_ENDIAN REG_LINK REG_MULTI_SZ - REG_RESOURCE_LIST REG_FULL_RESOURCE_DESCRIPTOR - REG_RESOURCE_REQUIREMENTS_LIST )], - SE_ => [qw( - SE_ASSIGNPRIMARYTOKEN_NAME SE_AUDIT_NAME - SE_BACKUP_NAME SE_CHANGE_NOTIFY_NAME - SE_CREATE_PAGEFILE_NAME SE_CREATE_PERMANENT_NAME - SE_CREATE_TOKEN_NAME SE_DEBUG_NAME - SE_INCREASE_QUOTA_NAME SE_INC_BASE_PRIORITY_NAME - SE_LOAD_DRIVER_NAME SE_LOCK_MEMORY_NAME - SE_MACHINE_ACCOUNT_NAME SE_PROF_SINGLE_PROCESS_NAME - SE_REMOTE_SHUTDOWN_NAME SE_RESTORE_NAME - SE_SECURITY_NAME SE_SHUTDOWN_NAME - SE_SYSTEMTIME_NAME SE_SYSTEM_ENVIRONMENT_NAME - SE_SYSTEM_PROFILE_NAME SE_TAKE_OWNERSHIP_NAME - SE_TCB_NAME SE_UNSOLICITED_INPUT_NAME )], -); -@EXPORT_OK= (); -{ my $ref; - foreach $ref ( values(%EXPORT_TAGS) ) { - push( @EXPORT_OK, @$ref ) unless $ref->[0] =~ /^SE_/; - } -} -$EXPORT_TAGS{ALL}= [ @EXPORT_OK ]; # \@EXPORT_OK once SE_* settles down. -# push( @EXPORT_OK, "JHEREG_TACOSALAD" ); # Used to test Mkconst2perl -push( @EXPORT_OK, @{$EXPORT_TAGS{SE_}} ); - -bootstrap Win32API::Registry $VERSION; - -# Preloaded methods go here. - -# To convert C constants to Perl code in cRegistry.pc -# [instead of C or C++ code in cRegistry.h]: -# * Modify F<Makefile.PL> to add WriteMakeFile() => -# CONST2PERL/postamble => [[ "Win32API::Registry" => ]] WRITE_PERL => 1. -# * Either comment out C<#include "cRegistry.h"> from F<Registry.xs> -# or make F<cRegistry.h> an empty file. -# * Make sure the following C<if> block is not commented out. -# * "nmake clean", "perl Makefile.PL", "nmake" - -if( ! defined ®_NONE ) { - require "Win32API/Registry/cRegistry.pc"; -} - -# This would be convenient but inconsistant and hard to explain: -#push( @{$EXPORT_TAGS{ALL}}, @{$EXPORT_TAGS{SE_}} ) -# if defined &SE_TCB_NAME; - -sub regConstant -{ - my( $name )= @_; - if( 1 != @_ || ! $name || $name =~ /\W/ ) { - require Carp; - Carp::croak( 'Usage: ',__PACKAGE__,'::regConstant("CONST_NAME")' ); - } - my $proto= prototype $name; - if( defined \&$name - && defined $proto - && "" eq $proto ) { - no strict 'refs'; - return &$name; - } - return undef; -} - -# We provide this for backwards compatibility: -sub constant -{ - my( $name )= @_; - my $value= regConstant( $name ); - if( defined $value ) { - $!= 0; - return $value; - } - $!= 11; # EINVAL - return 0; -} - -# BEGIN { -# my $code= 'return _regLastError(@_)'; -# local( $!, $^E )= ( 1, 1 ); -# if( $! ne $^E ) { -# $code= ' -# local( $^E )= _regLastError(@_); -# my $ret= $^E; -# return $ret; -# '; -# } -# eval "sub regLastError { $code }"; -# die "$@" if $@; -# } - -package Win32API::Registry::_error; - -use overload - '""' => sub { - require Win32 unless defined &Win32::FormatMessage; - $_ = Win32::FormatMessage(Win32API::Registry::_regLastError()); - tr/\r\n//d; - return $_; - }, - '0+' => sub { Win32API::Registry::_regLastError() }, - 'fallback' => 1; - -sub new { return bless {}, shift } -sub set { Win32API::Registry::_regLastError($_[1]); return $_[0] } - -package Win32API::Registry; - -my $_error = new Win32API::Registry::_error; - -sub regLastError { - require Carp; - Carp::croak('Usage: ',__PACKAGE__,'::regLastError( [$setWin32ErrCode] )') if @_ > 1; - $_error->set($_[0]) if defined $_[0]; - return $_error; -} - -# Since we ISA DynaLoader which ISA AutoLoader, we ISA AutoLoader so we -# need this next chunk to prevent Win32API::Registry->nonesuch() from -# looking for "nonesuch.al" and producing confusing error messages: -use vars qw($AUTOLOAD); -sub AUTOLOAD { - require Carp; - Carp::croak( - "Can't locate method $AUTOLOAD via package Win32API::Registry" ); -} - -# Replace "&rout;" with "goto &rout;" when that is supported on Win32. - -# Let user omit all buffer sizes: -sub RegEnumKeyExA { - if( 6 == @_ ) { splice(@_,4,0,[]); splice(@_,2,0,[]); } - &_RegEnumKeyExA; -} -sub RegEnumKeyExW { - if( 6 == @_ ) { splice(@_,4,0,[]); splice(@_,2,0,[]); } - &_RegEnumKeyExW; -} -sub RegEnumValueA { - if( 6 == @_ ) { splice(@_,2,0,[]); push(@_,[]); } - &_RegEnumValueA; -} -sub RegEnumValueW { - if( 6 == @_ ) { splice(@_,2,0,[]); push(@_,[]); } - &_RegEnumValueW; -} -sub RegQueryInfoKeyA { - if( 11 == @_ ) { splice(@_,2,0,[]); } - &_RegQueryInfoKeyA; -} -sub RegQueryInfoKeyW { - if( 11 == @_ ) { splice(@_,2,0,[]); } - &_RegQueryInfoKeyW; -} - -sub RegEnumKeyA { - push(@_,[]) if 3 == @_; - &_RegEnumKeyA; -} -sub RegEnumKeyW { - push(@_,[]) if 3 == @_; - &_RegEnumKeyW; -} -sub RegGetKeySecurity { - push(@_,[]) if 3 == @_; - &_RegGetKeySecurity; -} -sub RegQueryMultipleValuesA { - push(@_,[]) if 4 == @_; - &_RegQueryMultipleValuesA; -} -sub RegQueryMultipleValuesW { - push(@_,[]) if 4 == @_; - &_RegQueryMultipleValuesW; -} -sub RegQueryValueA { - push(@_,[]) if 3 == @_; - &_RegQueryValueA; -} -sub RegQueryValueW { - push(@_,[]) if 3 == @_; - &_RegQueryValueW; -} -sub RegQueryValueExA { - push(@_,[]) if 5 == @_; - &_RegQueryValueExA; -} -sub RegQueryValueExW { - push(@_,[]) if 5 == @_; - &_RegQueryValueExW; -} -sub RegSetValueA { - push(@_,0) if 4 == @_; - &_RegSetValueA; -} -sub RegSetValueW { - push(@_,0) if 4 == @_; - &_RegSetValueW; -} -sub RegSetValueExA { - push(@_,0) if 5 == @_; - &_RegSetValueExA; -} -sub RegSetValueExW { - push(@_,0) if 5 == @_; - &_RegSetValueExW; -} - -# Aliases for non-Unicode functions: -sub AbortSystemShutdown { &AbortSystemShutdownA; } -sub InitiateSystemShutdown { &InitiateSystemShutdownA; } -sub RegConnectRegistry { &RegConnectRegistryA; } -sub RegCreateKey { &RegCreateKeyA; } -sub RegCreateKeyEx { &RegCreateKeyExA; } -sub RegDeleteKey { &RegDeleteKeyA; } -sub RegDeleteValue { &RegDeleteValueA; } -sub RegEnumKey { &RegEnumKeyA; } -sub RegEnumKeyEx { &RegEnumKeyExA; } -sub RegEnumValue { &RegEnumValueA; } -sub RegLoadKey { &RegLoadKeyA; } -sub RegOpenKey { &RegOpenKeyA; } -sub RegOpenKeyEx { &RegOpenKeyExA; } -sub RegQueryInfoKey { &RegQueryInfoKeyA; } -sub RegQueryMultipleValues { &RegQueryMultipleValuesA; } -sub RegQueryValue { &RegQueryValueA; } -sub RegQueryValueEx { &RegQueryValueExA; } -sub RegReplaceKey { &RegReplaceKeyA; } -sub RegRestoreKey { &RegRestoreKeyA; } -sub RegSaveKey { &RegSaveKeyA; } -sub RegSetValue { &RegSetValueA; } -sub RegSetValueEx { &RegSetValueExA; } -sub RegUnLoadKey { &RegUnLoadKeyA; } - -1; -__END__ - -=head1 NAME - -Win32API::Registry - Low-level access to Win32 system API calls from WINREG.H - -=head1 SYNOPSIS - - use Win32API::Registry 0.21 qw( :ALL ); - - RegOpenKeyEx( HKEY_LOCAL_MACHINE, "SYSTEM\\Disk", 0, KEY_READ, $key ); - or die "Can't open HKEY_LOCAL_MACHINE\\SYSTEM\\Disk: ", - regLastError(),"\n"; - RegQueryValueEx( $key, "Information", [], $type, $data, [] ); - or die "Can't read HKEY_L*MACHINE\\SYSTEM\\Disk\\Information: ", - regLastError(),"\n"; - [...] - RegCloseKey( $key ) - or die "Can't close HKEY_LOCAL_MACHINE\\SYSTEM\\Disk: ", - regLastError(),"\n"; - -=head1 DESCRIPTION - -This provides fairly low-level access to the Win32 System API -calls dealing with the Registry [mostly from WINREG.H]. This -is mostly intended to be used by other modules such as -C<Win32::TieRegistry> [which provides an extremely Perl-friendly -method for using the Registry]. - -For a description of the logical structure of the Registry, see -the documentation for the C<Win32::TieRegistry> module. - -To pass in C<NULL> as the pointer to an optional buffer, pass in -an empty list reference, C<[]>. - -Beyond raw access to the API calls and related constants, this module -handles smart buffer allocation and translation of return codes. - -All calls return a true value for success and a false value for -failure. After any failure, C<$^E> should automatically be set -to indicate the reason. However, current versions of Perl often -overwrite C<$^E> too quickly, so you can use C<regLastError()> -instead, which is only set by Win32API::Registry routines. - -Note that C<$!> is not set by these routines except by -C<Win32API::Registry::constant()> when a constant is not defined. - -=head2 Exports - -Nothing is exported by default. The following tags can be used to -have sets of symbols exported. - -[Note that much of the following documentation refers to the -behavior of the underlying API calls which may vary in current -and future versions of the Win32 API without any changes to this -module. Therefore you should check the Win32 API documentation -directly when needed.] - -=over - -=item :Func - -The basic function names: - -=over - -=item AllowPriv - -=item C<AllowPriv( $sPrivName, $bEnable )> - -Not a Win32 API call. Enables or disables a specific privilege for -the current process. Returns a true value if successful and a false -value [and sets C<$^E>/C<regLastError()>] on failure. This routine -does not provide a way to tell if a privilege is currently enabled. - -C<$sPrivname> is a Win32 privilege name [see L</:SE_>]. For example, -C<"SeBackupPrivilege"> [a.k.a. C<SE_BACKUP_NAME>] controls whether -you can use C<RegSaveKey()> and C<"SeRestorePrivilege"> [a.k.a. -C<SE_RESTORE_NAME>] controls whether you can use C<RegLoadKey()>. - -If C<$bEnable> is true, then C<AllowPriv()> tries to enable the -privilege. Otherwise it tries to disable the privilege. - -=item AbortSystemShutdown - -=item C<AbortSystemShutdown( $sComputerName )> - -Tries to abort a remote shutdown request previously made via -C<InitiateSystemShutdown()>. Returns a true value if successful -and a false value [and sets C<$^E>/C<regLastError()>] on failure. - -=item InitiateSystemShutdown - -=item C<InitiateSystemShutdown( $sComputer, $sMessage, $uTimeoutSecs, $bForce, $bReboot )> - -Requests that a [remote] computer be shutdown or rebooted. -Returns a true value if successful and a false value [and -sets C<$^E>/C<regLastError()>] on failure. - -C<$sComputer> is the name [or address] of the computer to be -shutdown or rebooted. You can use C<[]> [for C<NULL>] or C<""> -to indicate the local computer. - -C<$sMessage> is the message to be displayed in a pop-up window -on the desktop of the computer to be shutdown or rebooted until -the timeout expires or the shutdown is aborted via -C<AbortSystemShutdown()>. With C<$iTimeoutSecs == 0>, the -message will never be visible. - -C<$iTimeoutSecs> is the number of seconds to wait before starting -the shutdown. - -If C<$bForce> is false, then any applications running on the remote -computer get a chance to prompt the remote user whether they want -to save changes. Also, for any applications that do not exit quickly -enough, the operating system will prompt the user whether they wish -to wait longer for the application to exit or force it to exit now. -At any of these prompts the user can press B<CANCEL> to abort the -shutdown but if no applications have unsaved data, they will likely -all exit quickly and the shutdown will progress with the remote user -having no option to cancel the shutdown. - -If C<$bForce> is true, all applications are told to exit immediately -and so will not prompt the user even if there is unsaved data. Any -applications that take too long to exit will be forcibly killed after -a short time. The only way to abort the shutdown is to call -C<AbortSystemShutdown()> before the timeout expires and there is no -way to abort the shutdown once it has begun. - -If C<$bReboot> is true, the computer will automatically reboot once -the shutdown is complete. If C<$bReboot> is false, then when the -shutdown is complete the computer will halt at a screen indicating -that the shutdown is complete and offering a way for the user to -start to boot the computer. - -You must have the C<"SeRemoteShutdownPrivilege"> privilege -on the remote computer for this call to succeed. If shutting -down the local computer, then the calling process must have -the C<"SeShutdownPrivilege"> privilege and have it enabled. - -=item RegCloseKey - -=item C<RegCloseKey( $hKey )> - -Closes the handle to a Registry key returned by C<RegOpenKeyEx()>, -C<RegConnectRegistry()>, C<RegCreateKeyEx()>, or a few other -routines. Returns a true value if successful and a false value -[and sets C<$^E>/C<regLastError()>] on failure. - -=item RegConnectRegistry - -=item C<RegConnectRegistry( $sComputer, $hRootKey, $ohKey )> - -Connects to one of the root Registry keys of a remote computer. -Returns a true value if successful and a false value [and -sets C<$^E>/C<regLastError()>] on failure. - -C<$sComputer> is the name [or address] of a remote computer -whose Registry you wish to access. - -C<$hKey> must be either C<HKEY_LOCAL_MACHINE> or C<HKEY_USERS> -and specifies which root Registry key on the remote computer -you wish to have access to. - -C<$phKey> will be set to the handle to be used to access the -remote Registry key if the call succeeds. - -=item regConstant - -=item C<$value= regConstant( $sConstantName )> - -Fetch the value of a constant. Returns C<undef> if C<$sConstantName> -is not the name of a constant supported by this module. Never sets -C<$!> nor C<$^E>. - -This function is rarely used since you will usually get the value of a -constant by having that constant imported into your package by listing -the constant name in the C<use Win32API::Registry> statement and then -simply using the constant name in your code [perhaps followed by -C<()>]. This function is useful for verifying constant names not in -Perl code, for example, after prompting a user to type in a constant -name. - -=item RegCreateKey - -=item C<RegCreateKey( $hKey, $sSubKey, $ohSubKey )> - -This routine is meant only for compatibility with Windows version -3.1. Use C<RegCreateKeyEx()> instead. - -=item RegCreateKeyEx - -=item C<RegCreateKeyEx( $hKey, $sSubKey, $uZero, $sClass, $uOpts, $uAccess, $pSecAttr, $ohNewKey, $ouDisp )> - -Creates a new Registry subkey. Returns a true value if successful and -a false value [and sets C<$^E>/C<regLastError()>] on failure. - -C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from -a previous call]. - -C<$sSubKey> is the name of the new subkey to be created. - -C<$iZero> is reserved for future use and should always be specified -as C<0>. - -C<$sClass> is a string to be used as the class for the new -subkey. We are not aware of any current use for Registry key -class information so the empty string, C<"">, should usually -be used here. - -C<$iOpts> is a numeric value containing bits that control options -used while creating the new subkey. C<REG_OPTION_NON_VOLATILE> -is the default. C<REG_OPTION_VOLATILE> [which is ignored on -Windows 95] means the data stored under this key is not kept -in a file and will not be preserved when the system reboots. -C<REG_OPTION_BACKUP_RESTORE> [also ignored on Windows 95] means -ignore the C<$iAccess> parameter and try to open the new key with -the access required to backup or restore the key. - -C<$iAccess> is a numeric mask of bits specifying what type of -access is desired when opening the new subkey. See C<RegOpenKeyEx()>. - -C<$pSecAttr> is a C<SECURITY_ATTRIBUTES> structure packed into -a Perl string which controls whether the returned handle can be -inherited by child processes. Normally you would pass C<[]> for -this parameter to have C<NULL> passed to the underlying API -indicating that the handle cannot be inherited. If not under -Windows95, then C<$pSecAttr> also allows you to specify -C<SECURITY_DESCRIPTOR> that controls which users will have -what type of access to the new key -- otherwise the new key -inherits its security from its parent key. - -C<$phKey> will be set to the handle to be used to access the new -subkey if the call succeeds. - -C<$piDisp> will be set to either C<REG_CREATED_NEW_KEY> or -C<REG_OPENED_EXISTING_KEY> to indicate for which reason the -call succeeded. Can be specified as C<[]> if you don't care. - -If C<$phKey> and C<$piDisp> start out as integers, then they will -probably remain unchanged if the call fails. - -=item RegDeleteKey - -=item C<RegDeleteKey( $hKey, $sSubKey )> - -Deletes a subkey of an open Registry key provided that the subkey -contains no subkeys of its own [but the subkey may contain values]. -Returns a true value if successful and a false value [and sets -C<$^E>/C<regLastError()>] on failure. - -C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from -a previous call]. - -C<$sSubKey> is the name of the subkey to be deleted. - -=item RegDeleteValue - -=item C<RegDeleteValue( $hKey, $sValueName )> - -Deletes a value from an open Registry key. Returns a true value if -successful and a false value [and sets C<$^E>/C<regLastError()>] on -failure. - -C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from -a previous call]. - -C<$sValueKey> is the name of the value to be deleted. - -=item RegEnumKey - -=item C<RegEnumKey( $hKey, $uIndex, $osName, $ilNameSize )> - -This routine is meant only for compatibility with Windows version -3.1. Use C<RegEnumKeyEx()> instead. - -=item RegEnumKeyEx - -=item C<RegEnumKeyEx( $hKey, $uIndex, $osName, $iolName, $pNull, $osClass, $iolClass, $opftLastWrite )> - -Lets you enumerate the names of all of the subkeys directly under -an open Registry key. Returns a true value if successful and a false -value [and sets C<$^E>/C<regLastError()>] on failure. - -C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from -a previous call]. - -C<$iIndex> is the sequence number of the immediate subkey that -you want information on. Start with this value as C<0> then -repeat the call incrementing this value each time until the -call fails with C<$^E>/C<regLastError()> numerically equal to -C<ERROR_NO_MORE_ITEMS>. - -C<$sName> will be set to the name of the subkey. Can be C<[]> if -you don't care about the name. - -C<$plName> initially specifies the [minimum] buffer size to be -allocated for C<$sName>. Will be set to the length of the subkey -name if the requested subkey exists even if C<$sName> isn't -successfully set to the subkey name. See L<Buffer sizes> for -more information. - -C<$pNull> is reserved for future used and should be passed as C<[]>. - -C<$sClass> will be set to the class name for the subkey. Can be -C<[]> if you don't care about the class. - -C<$plClass> initially specifies the [minimum] buffer size to be -allocated for C<$sClass> and will be set to the length of the -subkey class name if the requested subkey exists. See L<Buffer -sizes> for more information. - -C<$pftLastWrite> will be set to a C<FILETIME> structure packed -into a Perl string and indicating when the subkey was last changed. -Can be C<[]>. - -You may omit both C<$plName> and C<$plClass> to get the same effect -as passing in C<[]> for each of them. - -=item RegEnumValue - -=item C<RegEnumValue( $hKey, $uIndex, $osValName, $iolValName, $pNull, $ouType, $opValData, $iolValData )> - -Lets you enumerate the names of all of the values contained in an -open Registry key. Returns a true value if successful and a false -value [and sets C<$^E>/C<regLastError()>] on failure. - -C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from -a previous call]. - -C<$iIndex> is the sequence number of the value that you want -information on. Start with this value as C<0> then repeat the -call incrementing this value each time until the call fails with -C<ERROR_NO_MORE_ITEMS>. - -C<$sValName> will be set to the name of the value. Can be C<[]> -if you don't care about the name. - -C<$plValName> initially specifies the [minimum] buffer size to be -allocated for C<$sValName>. Will be set to the length of the value -name if the requested value exists even if C<$sValName> isn't -successfully set to the value name. See L<Buffer sizes> for -more information. - -C<$pNull> is reserved for future used and should be passed as C<[]>. - -C<$piType> will be set to the type of data stored in the value data. -If the call succeeds, it will be set to a C<REG_*> value unless -passed in as C<[]>. - -C<$pValData> will be set to the data [packed into a Perl string] -that is stored in the requested value. Can be C<[]> if you don't -care about the value data. - -C<$plValData> initially specifies the [minimum] buffer size to be -allocated for C<$sValData> and will be set to the length of the -value data if the requested value exists. See L<Buffer sizes> for -more information. - -You may omit both C<$plValName> and C<$plValData> to get the same -effect as passing in C<[]> for each of them. - -=item RegFlushKey - -=item C<RegFlushKey( $hKey )> - -Forces the data stored under an open Registry key to be flushed -to the disk file where the data is preserved between reboots. -Forced flushing is not guaranteed to be efficient so this routine -should almost never be called. Returns a true value if successful -and a false value [and sets C<$^E>/C<regLastError()>] on failure. - -C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from -a previous call]. - -=item RegGetKeySecurity - -=item C<RegGetKeySecurity( $hKey, $uSecInfo, $opSecDesc, $iolSecDesc )> - -Retrieves one of the C<SECURITY_DESCRIPTOR> structures describing -part of the security for an open Registry key. Returns a true value -if successful and a false value [and sets C<$^E>/C<regLastError()>] -on failure. - -C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from -a previous call]. - -C<$iSecInfo> is a numeric C<SECURITY_INFORMATION> value that -specifies which parts of the C<SECURITY_DESCRIPTOR> structure -to retrieve. Should be C<OWNER_SECURITY_INFORMATION>, -C<GROUP_SECURITY_INFORMATION>, C<DACL_SECURITY_INFORMATION>, or -or C<SACL_SECURITY_INFORMATION> or two or more of these bits -combined using C<|>. - -C<$pSecDesc> will be set to the requested C<SECURITY_DESCRIPTOR> -structure [packed into a Perl string]. - -C<$plSecDesc> initially specifies the [minimum] buffer size to be -allocated for C<$sSecDesc> and will be set to the length of the -security descriptor. See L<Buffer sizes> for more information. -You may omit this parameter to get the same effect as passing in -C<[]> for it. - -=item regLastError - -=item C<$svError= regLastError();> - -=item C<regLastError( $uError );> - -Returns the last error encountered by a routine from this module. -It is just like C<$^E> except it isn't changed by anything except -routines from this module. Ideally you could just use C<$^E>, but -current versions of Perl often overwrite C<$^E> before you get a -chance to check it and really old versions of Perl don't really -support C<$^E> under Win32. - -Just like C<$^E>, in a numeric context C<regLastError()> returns -the numeric error value while in a string context it returns a -text description of the error [actually it returns a Perl scalar -that contains both values so C<$x= regLastError()> causes C<$x> -to give different values in string vs. numeric contexts]. - -The last form sets the error returned by future calls to -C<regLastError()> and should not be used often. C<$uError> must -be a numeric error code. Also returns the dual-valued version -of C<$uError>. - -=item RegLoadKey - -=item C<RegLoadKey( $hKey, $sSubKey, $sFileName )> - -Loads a hive file. That is, it creates a new subkey in the -Registry and associates that subkey with a disk file that contains -a Registry hive so that the new subkey can be used to access the -keys and values stored in that hive. Hives are usually created -via C<RegSaveKey()>. Returns a true value if successful and a -false value [and sets C<$^E>/C<regLastError()>] on failure. - -C<$hKey> is the handle to a Registry key that can have hives -loaded to it. This must be C<HKEY_LOCAL_MACHINE>, C<HKEY_USERS>, -or a remote version of one of these from a call to -C<RegConnectRegistry()>. - -C<$sSubKey> is the name of the new subkey to created and associated -with the hive file. - -C<$sFileName> is the name of the hive file to be loaded. This -file name is interpretted relative to the -C<%SystemRoot%/System32/config> directory on the computer where -the C<$hKey> key resides. If C<$sFileName> is on a FAT file -system, then its name must not have an extension. - -You must have the C<SE_RESTORE_NAME> privilege to use this routine. - -WARNING: Loading of hive files via a network share may silently -corrupt the hive and so should not be attempted [this is a problem -in at least some versions of the underlying API which this module -does not try to fix or avoid]. To access a hive file located on a -remote computer, connect to the remote computer's Registry and load -the hive via that. - -=item RegNotifyChangeKeyValue - -=item C<RegNotifyChangeKeyValue( $hKey, $bWatchSubtree, $uNotifyFilter, $hEvent, $bAsync )> - -Arranges for your process to be notified when part of the Registry -is changed. Returns a true value if successful and a false value -[and sets C<$^E>/C<regLastError()>] on failure. - -C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from -a previous call] for which you wish to be notified when any changes -are made to it. - -If C<$bWatchSubtree> is true, then changes to any subkey or -descendant of C<$hKey> are also reported. - -C<$iNotifyFilter> controllers what types of changes are reported. It -is a numeric value containing one or more of the following bit masks: - -=over - -=item C<REG_NOTIFY_CHANGE_NAME> - -Notify if a subkey is added or deleted to a monitored key. - -=item C<REG_NOTIFY_CHANGE_LAST_SET> - -Notify if a value in a monitored key is added, deleted, or modified. - -=item C<REG_NOTIFY_CHANGE_SECURITY> - -Notify if a security descriptor of a monitored key is changed. - -=item C<REG_NOTIFY_CHANGE_ATTRIBUTES> - -Notify if any attributes of a monitored key are changed [class -name or security descriptors]. - -=back - -C<$hEvent> is ignored unless C<$bAsync> is true. Otherwise, C<$hEvent> -is a handle to a Win32 I<event> that will be signaled when changes are -to be reported. - -If C<$bAsync> is true, then C<RegNotifyChangeKeyValue()> returns -immediately and uses C<$hEvent> to notify your process of changes. -If C<$bAsync> is false, then C<RegNotifyChangeKeyValue()> does -not return until there is a change to be notified of. - -This routine does not work with Registry keys on remote computers. - -=item RegOpenKey - -=item C<RegOpenKey( $hKey, $sSubKey, $ohSubKey )> - -This routine is meant only for compatibility with Windows version -3.1. Use C<RegOpenKeyEx()> instead. - -=item RegOpenKeyEx - -=item C<RegOpenKeyEx( $hKey, $sSubKey, $uOptions, $uAccess, $ohSubKey )> - -Opens an existing Registry key. Returns a true value if successful -and a false value [and sets C<$^E>/C<regLastError()>] on failure. - -C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from -a previous call]. - -C<$sSubKey> is the name of an existing subkey to be opened. -Can be C<""> or C<[]> to open an additional handle to the -key specified by C<$hKey>. - -C<$iOptions> is a numeric value containing bits that control options -used while opening the subkey. There are currently no supported -options so this parameter should be specified as C<0>. - -C<$iAccess> is a numeric mask of bits specifying what type of -access is desired when opening the new subkey. Should be a -combination of one or more of the following bit masks: - -=over - -=item C<KEY_ALL_ACCESS> - - KEY_READ | KEY_WRITE | KEY_CREATE_LINK - -=item C<KEY_READ> - - KEY_QUERY_VALUE | KEY_ENUMERATE_SUBKEYS | KEY_NOTIFY | STANDARD_RIGHTS_READ - -=item C<KEY_WRITE> - - KEY_SET_VALUE | KEY_CREATE_SUB_KEY | STANDARD_RIGHTS_WRITE - -=item C<KEY_QUERY_VALUE> - -=item C<KEY_SET_VALUE> - -=item C<KEY_ENUMERATE_SUB_KEYS> - -=item C<KEY_CREATE_SUB_KEY> - -=item C<KEY_NOTIFY> - -Allows you to use C<RegNotifyChangeKeyValue()> on the opened key. - -=item C<KEY_EXECUTE> - -Same as C<KEY_READ>. - -=item C<KEY_CREATE_LINK> - -Gives you permission to create a symbolic link like -C<HKEY_CLASSES_ROOT> and C<HKEY_CURRENT_USER>, though the method for -doing so is not documented [and probably requires use of the mostly -undocumented "native" routines, C<Nt*()> a.k.a. C<Zw*()>]. - -=back - -C<$phKey> will be set to the handle to be used to access the new subkey -if the call succeeds. - -=item RegQueryInfoKey - -=item C<RegQueryInfoKey( $hKey, $osClass, $iolClass, $pNull, $ocSubKeys, $olSubKey, $olSubClass, $ocValues, $olValName, $olValData, $olSecDesc, $opftTime )> - -Gets miscellaneous information about an open Registry key. -Returns a true value if successful and a false value [and -sets C<$^E>/C<regLastError()>] on failure. - -C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from -a previous call]. - -C<$sClass> will be set to the class name for the key. Can be -C<[]> if you don't care about the class. - -C<$plClass> initially specifies the [minimum] buffer size to be -allocated for C<$sClass> and will be set to the length of the -key's class name. See L<Buffer sizes> for more information. -You may omit this parameter to get the same effect as passing in -C<[]> for it. - -C<$pNull> is reserved for future use and should be passed as C<[]>. - -C<$pcSubKeys> will be set to the count of the number of subkeys -directly under this key. Can be C<[]>. - -C<$plSubKey> will be set to the length of the longest subkey name. -Can be C<[]>. - -C<$plSubClass> will be set to the length of the longest class name -used with an immediate subkey of this key. Can be C<[]>. - -C<$pcValues> will be set to the count of the number of values in -this key. Can be C<[]>. - -C<$plValName> will be set to the length of the longest value name -in this key. Can be C<[]>. - -C<$plValData> will be set to the length of the longest value data -in this key. Can be C<[]>. - -C<$plSecDesc> will be set to the length of this key's full security -descriptor. - -C<$pftTime> will be set to a C<FILETIME> structure packed -into a Perl string and indicating when this key was last changed. -Can be C<[]>. - -=item RegQueryMultipleValues - -=item C<RegQueryMultipleValues( $hKey, $ioarValueEnts, $icValueEnts, $opBuffer, $iolBuffer )> - -Allows you to use a single call to query several values from a single -open Registry key to maximize efficiency. Returns a true value if -successful and a false value [and sets C<$^E>/C<regLastError()>] on -failure. - -C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from -a previous call]. - -C<$pValueEnts> should contain a list of C<VALENT> structures packed -into a single Perl string. Each C<VALENT> structure should have -the C<ve_valuename> entry [the first 4 bytes] pointing to a string -containing the name of a value stored in this key. The remaining -fields are set if the function succeeds. - -C<$cValueEnts> should contain the count of the number of C<VALENT> -structures contained in C<$pValueEnts>. - -C<$pBuffer> will be set to the data from all of the requested values -concatenated into a single Perl string. - -C<$plBuffer> initially specifies the [minimum] buffer size to be -allocated for C<$sBuffer> and will be set to the total length of -the data to be written to C<$sBuffer>. See L<Buffer sizes> for -more information. You may omit this parameter to get the same -effect as passing in C<[]> for it. - -Here is sample code to populate C<$pValueEnts>: - - # @ValueNames= ...list of value name strings...; - $cValueEnts= @ValueNames; - $pValueEnts= pack( " p x4 x4 x4 " x $cValueEnts, @ValueNames ); - -Here is sample code to retrieve the data type and data length -returned in C<$pValueEnts>: - - @Lengths= unpack( " x4 L x4 x4 " x $cValueEnts, $pValueEnts ); - @Types= unpack( " x4 x4 x4 L " x $cValueEnts, $pValueEnts ); - -Given the above, and assuming you haven't modified C<$sBuffer> since -the call, you can also extract the value data strings from C<$sBuffer> -by using the pointers returned in C<$pValueEnts>: - - @Data= unpack( join( "", map {" x4 x4 P$_ x4 "} @Lengths ), - $pValueEnts ); - -Much better is to use the lengths and extract directly from -C<$sBuffer> using C<unpack()> [or C<substr()>]: - - @Data= unpack( join("",map("P$_",@Lengths)), $sBuffer ); - -=item RegQueryValue - -=item C<RegQueryValue( $hKey, $sSubKey, $osValueData, $iolValueData )> - -This routine is meant only for compatibility with Windows version -3.1. Use C<RegQueryValueEx()> instead. This routine can only -query unamed values [a.k.a. "default values"], that is, values with -a name of C<"">. - -=item RegQueryValueEx - -=item C<RegQueryValueEx( $hKey, $sValueName, $pNull, $ouType, $opValueData, $iolValueData )> - -Lets you look up value data stored in an open Registry key by -specifying the value name. Returns a true value if successful -and a false value [and sets C<$^E>/C<regLastError()>] on failure. - -C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from -a previous call]. - -C<$sValueName> is the name of the value whose data you wish to -retrieve. - -C<$pNull> this parameter is reserved for future use and should be -specified as C<[]>. - -C<$piType> will be set to indicate what type of data is stored in -the named value. Will be set to a C<REG_*> value if the function -succeeds. - -C<$pValueData> will be set to the value data [packed into a Perl -string] that is stored in the named value. Can be C<[]> if you -don't care about the value data. - -C<$plValueData> initially specifies the [minimum] buffer size to be -allocated for C<$sValueData> and will be set to the size [always -in bytes] of the data to be written to C<$sValueData>, even if -C<$sValueData> is not successfully written to. See L<Buffer sizes> -for more information. - -=item RegReplaceKey - -=item C<RegReplaceKey( $hKey, $sSubKey, $sNewFile, $sOldFile )> - -Lets you replace an entire hive when the system is next booted. -Returns a true value if successful and a false value [and sets -C<$^E>/C<regLastError()>] on failure. - -C<$hKey> is the handle to a Registry key that has hive(s) -loaded in it. This must be C<HKEY_LOCAL_MACHINE>, -C<HKEY_USERS>, or a remote version of one of these from -a call to C<RegConnectRegistry()>. - -C<$sSubKey> is the name of the subkey of C<$hKey> whose hive -you wish to have replaced on the next reboot. - -C<$sNewFile> is the name of a file that will replace the existing -hive file when the system reboots. - -C<$sOldFile> is the file name to save the current hive file to -when the system reboots. - -C<$sNewFile> and C<$sOldFile> are interpretted relative to the -C<%SystemRoot%/System32/config> directory on the computer where -the C<$hKey> key resides [I think]. If either file is [would be] -on a FAT file system, then its name must not have an extension. - -You must have the C<SE_RESTORE_NAME> privilege to use this routine. - -=item RegRestoreKey - -=item C<RegRestoreKey( $hKey, $sFileName, $uFlags )> - -Reads in a hive file and copies its contents over an existing -Registry tree. Returns a true value if successful and a false -value [and sets C<$^E>/C<regLastError()>] on failure. - -C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from -a previous call]. - -C<$sFileName> is the name of the hive file to be read. For each -value and subkey in this file, a value or subkey will be added -or replaced in C<$hKey>. - -C<$uFlags> is usally C<0>. It can also be C<REG_WHOLE_HIVE_VOLATILE> -which, rather than copying the hive over the existing key, -replaces the existing key with a temporary, memory-only Registry -key and then copies the hive contents into it. This option only -works if C<$hKey> is C<HKEY_LOCAL_MACHINE>, C<HKEY_USERS>, or a -remote version of one of these from a call to C<RegConnectRegistry()>. - -C<RegRestoreKey> does I<not> delete values nor keys from the -existing Registry tree when there is no corresponding value/key -in the hive file. - -=item RegSaveKey - -=item C<RegSaveKey( $hKey, $sFileName, $pSecAttr )> - -Dumps any open Registry key and all of its subkeys and values into -a new hive file. Returns a true value if successful and a false -value [and sets C<$^E>/C<regLastError()>] on failure. - -C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from -a previous call]. - -C<$sFileName> is the name of the file that the Registry tree -should be saved to. It is interpretted relative to the -C<%SystemRoot%/System32/config> directory on the computer where -the C<$hKey> key resides. If C<$sFileName> is on a FAT file system, -then it must not have an extension. - -C<$pSecAttr> contains a C<SECURITY_ATTRIBUTES> structure that specifies -the permissions to be set on the new file that is created. This can -be C<[]>. - -You must have the C<SE_RESTORE_NAME> privilege to use this routine. - -=item RegSetKeySecurity - -=item C<RegSetKeySecurity( $hKey, $uSecInfo, $pSecDesc )> - -Sets [part of] the C<SECURITY_DESCRIPTOR> structure describing part -of the security for an open Registry key. Returns a true value if -successful and a false value [and sets C<$^E>/C<regLastError()>] on -failure. - -C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from -a previous call]. - -C<$uSecInfo> is a numeric C<SECURITY_INFORMATION> value that -specifies which C<SECURITY_DESCRIPTOR> structure to set. Should -be C<OWNER_SECURITY_INFORMATION>, C<GROUP_SECURITY_INFORMATION>, -C<DACL_SECURITY_INFORMATION>, or C<SACL_SECURITY_INFORMATION> -or two or more of these bits combined using C<|>. - -C<$pSecDesc> contains the new C<SECURITY_DESCRIPTOR> structure -packed into a Perl string. - -=item RegSetValue - -=item C<RegSetValue( $hKey, $sSubKey, $uType, $sValueData, $lValueData )> - -This routine is meant only for compatibility with Windows version -3.1. Use C<RegSetValueEx()> instead. This routine can only -set unamed values [a.k.a. "default values"]. - -=item RegSetValueEx - -=item C<RegSetValueEx( $hKey, $sName, $uZero, $uType, $pData, $lData )> - -Adds or replaces a value in an open Registry key. Returns -a true value if successful and a false value [and sets -C<$^E>/C<regLastError()>] on failure. - -C<$hKey> is the handle to a Registry key [either C<HKEY_*> or from -a previous call]. - -C<$sName> is the name of the value to be set. - -C<$uZero> is reserved for future use and should be specified as C<0>. - -C<$uType> is the type of data stored in C<$pData>. It should -be a C<REG_*> value. - -C<$pData> is the value data packed into a Perl string. - -C<$lData> is the length of the value data that is stored in C<$pData>. -You will usually omit this parameter or pass in C<0> to have -C<length($pData)> used. In both of these cases, if C<$iType> is -C<REG_SZ> or C<REG_EXPAND_SZ>, C<RegSetValueEx()> will append a -trailing C<'\0'> to the end of C<$pData> [unless there is already -one]. - -=item RegUnLoadKey - -=item C<RegUnLoadKey( $hKey, $sSubKey )> - -Unloads a previously loaded hive file. That is, closes the -hive file then deletes the subkey that was providing access -to it. Returns a true value if successful and a false value -[and sets C<$^E>/C<regLastError()>] on failure. - -C<$hKey> is the handle to a Registry key that has hives -loaded in it. This must be C<HKEY_LOCAL_MACHINE>, C<HKEY_USERS>, -or a remote version of one of these from a call to -C<RegConnectRegistry()>. - -C<$sSubKey> is the name of the subkey whose hive you wish to -have unloaded. - -=item :FuncA - -The ASCII-specific function names. - -Each of these is identical to the version listed above without the -trailing "A": - - AbortSystemShutdownA InitiateSystemShutdownA - RegConnectRegistryA RegCreateKeyA RegCreateKeyExA - RegDeleteKeyA RegDeleteValueA RegEnumKeyA - RegEnumKeyExA RegEnumValueA RegLoadKeyA - RegOpenKeyA RegOpenKeyExA RegQueryInfoKeyA - RegQueryMultipleValuesA RegQueryValueA RegQueryValueExA - RegReplaceKeyA RegRestoreKeyA RegSaveKeyA - RegSetValueA RegSetValueExA RegUnLoadKeyA - -=item :FuncW - -The UNICODE-specific function names. These are the same as the -versions listed above without the trailing "W" except that string -parameters are UNICODE strings rather than ASCII strings, as -indicated. - -=item AbortSystemShutdownW - -=item C<AbortSystemShutdownW( $swComputerName )> - -C<$swComputerName> is UNICODE. - -=item InitiateSystemShutdownW - -=item C<InitiateSystemShutdownW( $swComputer, $swMessage, $uTimeoutSecs, $bForce, $bReboot )> - -C<$swComputer> and C<$swMessage> are UNICODE. - -=item RegConnectRegistryW - -=item C<RegConnectRegistryW( $swComputer, $hRootKey, $ohKey )> - -C<$swComputer> is UNICODE. - -=item RegCreateKeyW - -=item C<RegCreateKeyW( $hKey, $swSubKey, $ohSubKey )> - -C<$swSubKey> is UNICODE. - -=item RegCreateKeyExW - -=item C<RegCreateKeyExW( $hKey, $swSubKey, $uZero, $swClass, $uOpts, $uAccess, $pSecAttr, $ohNewKey, $ouDisp )> - -C<$swSubKey> and C<$swClass> are UNICODE. - -=item RegDeleteKeyW - -=item C<RegDeleteKeyW( $hKey, $swSubKey )> - -C<$swSubKey> is UNICODE. - -=item RegDeleteValueW - -=item C<RegDeleteValueW( $hKey, $swValueName )> - -C<$swValueName> is UNICODE. - -=item RegEnumKeyW - -=item C<RegEnumKeyW( $hKey, $uIndex, $oswName, $ilwNameSize )> - -C<$oswName> is UNICODE and C<$ilwNameSize> is measured as number of -C<WCHAR>s. - -=item RegEnumKeyExW - -=item C<RegEnumKeyExW( $hKey, $uIndex, $oswName, $iolwName, $pNull, $oswClass, $iolwClass, $opftLastWrite )> - -C<$swName> and C<$swClass> are UNICODE and C<$iolwName> and C<$iolwClass> -are measured as number of C<WCHAR>s. - -=item RegEnumValueW - -=item C<RegEnumValueW( $hKey, $uIndex, $oswName, $iolwName, $pNull, $ouType, $opData, $iolData )> - -C<$oswName> is UNICODE and C<$iolwName> is measured as number -of C<WCHAR>s. - -C<$opData> is UNICODE if C<$piType> is C<REG_SZ>, C<REG_EXPAND_SZ>, -or C<REG_MULTI_SZ>. Note that C<$iolData> is measured as number -of bytes even in these cases. - -=item RegLoadKeyW - -=item C<RegLoadKeyW( $hKey, $swSubKey, $swFileName )> - -C<$swSubKey> and C<$swFileName> are UNICODE. - -=item RegOpenKeyW - -=item C<RegOpenKeyW( $hKey, $swSubKey, $ohSubKey )> - -C<$swSubKey> is UNICODE. - -=item RegOpenKeyExW - -=item C<RegOpenKeyExW( $hKey, $swSubKey, $uOptions, $uAccess, $ohSubKey )> - -C<$swSubKey> is UNICODE. - -=item RegQueryInfoKeyW - -=item C<RegQueryInfoKeyW( $hKey, $oswClass, $iolwClass, $pNull, $ocSubKeys, $olwSubKey, $olwSubClass, $ocValues, $olwValName, $olValData, $olSecDesc, $opftTime )> - -C<$swClass> is UNICODE. C<$iolwClass>, C<$olwSubKey>, C<$olwSubClass>, -and C<$olwValName> are measured as number of C<WCHAR>s. Note that -C<$olValData> is measured as number of bytes. - -=item RegQueryMultipleValuesW - -=item C<RegQueryMultipleValuesW( $hKey, $ioarValueEnts, $icValueEnts, $opBuffer, $iolBuffer )> - -The C<ve_valuename> fields of the C<VALENT> [actually C<VALENTW>] -structures in C<$ioarValueEnts> are UNICODE. Values of type C<REG_SZ>, -C<REG_EXPAND_SZ>, and C<REG_MULTI_SZ> are written to C<$opBuffer> -in UNICODE. Note that C<$iolBuffer> and the C<ve_valuelen> fields -of the C<VALENT> [C<VALENTW>] structures are measured as number of -bytes. - -=item RegQueryValueW - -=item C<RegQueryValueW( $hKey, $swSubKey, $oswValueData, $iolValueData )> - -C<$swSubKey> and C<$oswValueData> are UNICODE. Note that -C<$iolValueData> is measured as number of bytes. - -=item RegQueryValueExW - -=item C<RegQueryValueExW( $hKey, $swName, $pNull, $ouType, $opData, $iolData )> - -C<$swName> is UNICODE. - -C<$opData> is UNICODE if C<$ouType> is C<REG_SZ>, C<REG_EXPAND_SZ>, -or C<REG_MULTI_SZ>. Note that C<$iolData> is measured as number of -bytes even in these cases. - -=item RegReplaceKeyW - -=item C<RegReplaceKeyW( $hKey, $swSubKey, $swNewFile, $swOldFile )> - -C<$swSubKey>, C<$swNewFile>, and C<$swOldFile> are UNICODE. - -=item RegRestoreKeyW - -=item C<RegRestoreKeyW( $hKey, $swFileName, $uFlags )> - -C<$swFileName> is UNICODE. - -=item RegSaveKeyW - -=item C<RegSaveKeyW( $hKey, $swFileName, $pSecAttr )> - -C<$swFileName> is UNICODE. - -=item RegSetValueW - -=item C<RegSetValueW( $hKey, $swSubKey, $uType, $swValueData, $lValueData )> - -C<$swSubKey> and C<$swValueData> are UNICODE. Note that -C<$lValueData> is measured as number of bytes even though -C<$swValueData> is always UNICODE. - -=item RegSetValueExW - -=item C<RegSetValueExW( $hKey, $swName, $uZero, $uType, $pData, $lData )> - -C<$swName> is UNICODE. - -C<$pData> is UNICODE if C<$uType> is C<REG_SZ>, C<REG_EXPAND_SZ>, -or C<REG_MULTI_SZ>. Note that C<$lData> is measured as number of -bytes even in these cases. - -=item RegUnLoadKeyW - -=item C<RegUnLoadKeyW( $hKey, $swSubKey )> - -C<$swSubKey> is UNICODE. - -=item :HKEY_ - -All C<HKEY_*> constants: - - HKEY_CLASSES_ROOT HKEY_CURRENT_CONFIG HKEY_CURRENT_USER - HKEY_DYN_DATA HKEY_LOCAL_MACHINE HKEY_PERFORMANCE_DATA - HKEY_USERS - -=item :KEY_ - -All C<KEY_*> constants: - - KEY_QUERY_VALUE KEY_SET_VALUE KEY_CREATE_SUB_KEY - KEY_ENUMERATE_SUB_KEYS KEY_NOTIFY KEY_CREATE_LINK - KEY_READ KEY_WRITE KEY_EXECUTE - KEY_ALL_ACCESS - -=item :REG_ - -All C<REG_*> constants: - - REG_CREATED_NEW_KEY REG_OPENED_EXISTING_KEY - - REG_LEGAL_CHANGE_FILTER REG_NOTIFY_CHANGE_ATTRIBUTES - REG_NOTIFY_CHANGE_NAME REG_NOTIFY_CHANGE_LAST_SET - REG_NOTIFY_CHANGE_SECURITY REG_LEGAL_OPTION - - REG_OPTION_BACKUP_RESTORE REG_OPTION_CREATE_LINK - REG_OPTION_NON_VOLATILE REG_OPTION_OPEN_LINK - REG_OPTION_RESERVED REG_OPTION_VOLATILE - - REG_WHOLE_HIVE_VOLATILE REG_REFRESH_HIVE - REG_NO_LAZY_FLUSH - - REG_NONE REG_SZ - REG_EXPAND_SZ REG_BINARY - REG_DWORD REG_DWORD_LITTLE_ENDIAN - REG_DWORD_BIG_ENDIAN REG_LINK - REG_MULTI_SZ REG_RESOURCE_LIST - REG_FULL_RESOURCE_DESCRIPTOR REG_RESOURCE_REQUIREMENTS_LIST - -=item :ALL - -All of the above. - -=item :SE_ - -The strings for the following privilege names: - - SE_ASSIGNPRIMARYTOKEN_NAME SE_AUDIT_NAME - SE_BACKUP_NAME SE_CHANGE_NOTIFY_NAME - SE_CREATE_PAGEFILE_NAME SE_CREATE_PERMANENT_NAME - SE_CREATE_TOKEN_NAME SE_DEBUG_NAME - SE_INCREASE_QUOTA_NAME SE_INC_BASE_PRIORITY_NAME - SE_LOAD_DRIVER_NAME SE_LOCK_MEMORY_NAME - SE_MACHINE_ACCOUNT_NAME SE_PROF_SINGLE_PROCESS_NAME - SE_REMOTE_SHUTDOWN_NAME SE_RESTORE_NAME - SE_SECURITY_NAME SE_SHUTDOWN_NAME - SE_SYSTEMTIME_NAME SE_SYSTEM_ENVIRONMENT_NAME - SE_SYSTEM_PROFILE_NAME SE_TAKE_OWNERSHIP_NAME - SE_TCB_NAME SE_UNSOLICITED_INPUT_NAME - -It can be difficult to successfully build this module in a way -that makes these constants available. So some builds of this -module may not make them available. For such builds, trying -to export any of these constants will cause a fatal error. -For this reason, none of these symbols are currently included -in the C<":ALL"> grouping. - -=back - -=head2 The Win32API:: heirarchy - -This and the other Win32API:: modules are meant to expose the -nearly raw API calls so they can be used from Perl code in any -way they might be used from C code. This provides the following -advantages: - -=over - -=item Many modules can be written by people that don't have a C compiler. - -=item Encourages more module code to be written in Perl [not C]. - -Perl code is often much easier to inspect, debug, customize, and -enhance than XS code. - -=item Allows those already familiar with the Win32 API to get -off to a quick start. - -=item Provides an interactive tool for exploring even obscure -details of the Win32 API. - -It can be very useful to interactively explore ad-hoc calls into -parts of the Win32 API using: - - perl -de 0 - -=item Ensures that native Win32 data structures can be used. - -This allows maximum efficiency. It also allows data from one -module [for example, time or security information from the -C<Win32API::Registry> or C<Win32API::File> modules] to be used -with other modules [for example, C<Win32API::Time> and -C<Win32API::SecDesc>]. - -=item Provides a single version of the XS interface to each API -call where improvements can be collected. - -=back - -=head2 Buffer sizes - -For each parameter that specifies a buffer size, a value of C<0> -can be passed. For parameter that are pointers to buffer sizes, -you can also pass in C<NULL> by specifying an empty list reference, -C<[]>. Both of these cases will ensure that the variable has -I<some> buffer space allocated to it and pass in that buffer's -allocated size. Many of the calls indicate, via C<ERROR_MORE_DATA>, -that the buffer size was not sufficient and the F<Registry.xs> -code will automatically enlarge the buffer to the required size -and repeat the call. - -Numeric buffer sizes are used as minimum initial sizes for the -buffers. The larger of this size and the size of space already -allocated to the scalar will be passed to the underlying routine. -If that size was insufficient, and the underlying call provides -an easy method for determining the needed buffer size, then the -buffer will be enlarged and the call repeated as above. - -The underlying calls define buffer size parameter as unsigned, so -negative buffer sizes are treated as very large positive buffer -sizes which usually cause C<malloc()> to fail. - -To force the F<Registry.xs> code to pass in a specific value for -a buffer size, preceed the size with an equals sign via C<"=".>. -Buffer sizes that are passed in as strings starting with an equals -sign will have the equal sign stripped and the remainder of the string -interpretted as a number [via C's C<strtoul()> using only base 10] -which will be passed to the underlying routine [even if the allocated -buffer is actually larger]. The F<Registry.xs> code will enlarge the -buffer to the specified size, if needed, but will not enlarge the -buffer based on the underlying routine requesting more space. - -Some Reg*() calls may not currently set the buffer size when they -return C<ERROR_MORE_DATA>. But some that are not documented as -doing so, currently do so anyway. So the code assumes that any -routine I<might> do this and resizes any buffers and repeats the -call. We hope that eventually all routines will provide this -feature. - -When you use C<[]> for a buffer size, you can still find the -length of the data returned by using C<length($buffer)>. Note -that this length will be in bytes while a few of the buffer -sizes would have been in units of wide characters. - -Note that the RegQueryValueEx*() and RegEnumValue*() calls -will trim the trailing C<'\0'> [if present] from the returned data -values of type C<REG_SZ> or C<REG_EXPAND_SZ> but only if the -value data length parameter is omitted [or specified as C<[]>]. - -The RegSetValueEx*() calls will add a trailing C<'\0'> [if -missing] to the supplied data values of type C<REG_SZ> and -C<REG_EXPAND_SZ> but only if the value data length parameter -is omitted [or specified as C<0>]. - -=head2 Hungarian Notation - -The following abbreviations are used at the start of each parameter -name to hint at aspects of how the parameter is used. The prefix -is always in lower case and followed by a capital letter that starts -the descriptive part of the parameter name. Several of the following -abbreviations can be combined into a single prefix. - -Probably not all of these prefix notations are used by this module. -This document section may be included in any C<Win32API> module and -so covers some notations not used by this specific module. - -=over - -=item s - -A string. In C, a C<'\0'>-terminated C<char *>. In Perl, just a -string except that it will be truncated at the first C<"\0">, if -it contains one. - -=item sw - -A wide [UNICODE] string. In C, a C<L'\0'>-terminated C<WCHAR *>. -In Perl, a string that contains UNICODE data. You can convert a -string to UNICODE in Perl via: - - $string= "This is an example string"; - $unicode= pack( "S*", unpack("C*",$string), 0 ); - -Note how C<, 0> above causes an explicit C<L'\0'> to be added since -Perl's implicit C<'\0'> that it puts after each of its strings is not -wide enough to terminate a UNICODE string. So UNICODE strings are -different than regular strings in that the Perl version of a regular -string will not include the trialing C<'\0'> while the Perl version -of a UNICODE string must include the trailing C<L'\0'>. - -If a UNICODE string contains no non-ASCII characters, then you -can convert it back into a normal string via: - - $string= pack( "C*", unpack("S*",$unicode) ); - $string =~ s/\0$//; - -=item p - -A pointer to some buffer [usually containing some C<struct>]. In C, -a C<void *> or some other pointer type. In Perl, a string that is -usually manipulated using C<pack> and C<unpack>. The "p" is usually -followed by more prefix character(s) to indicate what type of data is -stored in the bufffer. - -=item a - -A packed array. In C, an array [usually of C<struct>s]. In Perl, a -string containing the packed data. The "a" is usually followed by -more prefix character(s) to indicate the data type of the elements. - -These packed arrays are also called "vectors" in places to avoid -confusion with Perl arrays. - -=item n - -A generic number. In C, any of the integer or floating point data -types. In Perl, a number; either an integer, unsigned, or double -[IV, UV, or NV, respectively]. Usually an integer. - -=item iv - -A signed integral value. In C, any of the signed integer data types. -In Perl, an integer [IV]. - -=item u - -An unsigned integral value. In C, any of the unsigned integer data -types. In Perl, an unsigned integer [UV]. - -=item d - -A floating-point number. In C, a C<float> or C<double> or, perhaps, -a C<long double>. In Perl, a double-precision floating-point number -[NV]. - -=item b - -A Boolean value. In C, any integer data type, though usually via -a type alias of C<bool> or C<BOOL>, containing either a 0 [false] or -non-zero [true] value. In Perl, a scalar containing a Boolean value -[C<0>, C<"">, or C<undef> for "false" and anything else for "true"]. - -=item c - -A count of items. In C, any integer data type. In Perl, an unsigned -integer [UV]. Usually used in conjunction with a "vector" parameter -[see L</a> above] to indicate the number of elements. - -=item l - -A length [in bytes]. In C, any integer data type. In Perl, an -unsigned integer [UV]. Usually used in conjunction with a "string" -or "pointer" parameter [see L</s> and L</p> above] to indicate the -buffer size or the size of the value stored in the buffer. - -For strings, there is no general rule as to whether the trailing -C<'\0'> is included in such sizes. For this reason, the C<Win32API> -modules follow the Perl rule of always allocating one extra byte -and reporting buffer sizes as being one smaller than allocated in -case the C<'\0'> is not included in the size. - -=item lw - -A length measured as number of UNICODE characters. In C, a count -of C<WCHAR>s. In Perl, an unsigned integer [UV] counting "shorts" -[see "s" and "S" in C<pack> and C<unpack>]. - -For UNICODE strings, the trailing C<L'\0'> may or may not be -included in a length so, again, we always allocate extra room -for one and don't report that extra space. - -=item h - -A handle. In C, a C<HANDLE> or more-specific handle data type. -In Perl, an unsigned integer [UV]. In C, these handles are often -actually some type of pointer, but Perl just treats them as opaque -numbers, as it should. This prefix is also used for other pointers -that are treated as integers in Perl code. - -=item r - -A record. In C, almost always a C<struct> or perhaps C<union>. Note -that C C<struct>s are rarely passed by value so the "r" is almost -always preceeded by a "p" or "a" [see L</p> and L</a> above]. For -the very rare unadorned "r", Perl stores the record in the same way -as a "pr", that is, in a string. For the very rare case where Perl -explicitly stores a pointer to the C<struct> rather than storing the -C<struct> directly in a Perl string, the prefix "pp" or "ppr" or even -"par" is used. - -=item sv - -=item rv - -=item hv - -=item av - -=item cv - -A Perl data type. Respectively, a scalar value [SV], a reference -[RV] [usually to a scalar], a hash [HV], a Perl array [AV], or a Perl -code reference [PVCV]. For the "hv", "av", and "cv" prefixes, a -leading "rv" is usually assumed. For a parameter to an XS subroutine, -a prefix of "sv" means the parameter is a scalar and so may be a string -or a number [or C<undef>] or even both at the same time. So "sv" -doesn't imply a leading "rv". - -=item Input or Output - -Whether a parameter is for input data, output data, or both is usually -not reflected by the data type prefix. In cases where this is not -obvious nor reflected in the parameter name proper, we may use the -following in front of the data type prefix. - -=over - -=item i - -An input parameter given to the API [usually omitted]. - -=item o - -An output-only parameter taken from the API. You should not get a -warning if such a parameter is C<undef> when you pass it into the -function. You should get an error if such a parameter is read-only. -You can [usually] pass in C<[]> for such a parameter to have the -parameter silently ignored. - -The output may be written directly into the Perl variable passed -to the subroutine, the same way the buffer parameter to Perl's -C<sysread()>. This method is often avoided in Perl because -the call then lacks any visual cue that some parameters are being -overwritten. But this method closely matches the C API which is -what we are trying to do. - -=item io - -Input given to the API then overwritten with output taken from the -API. You should get a warning [if B<-w> is in effect] if such a -parameter is C<undef> when you pass it into the function [unless it -is a buffer or buffer length parameter]. If the value is read-only, -then [for most parameters] the output is silently not written. This -is because it is often convenient to pass in read-only constants for -many such parameters. You can also usually pass in C<[]> for such -parameters. - -=back - -=item pp - -=item ppr - -=item par - -=item pap - -These are just unusual combinations of prefix characters described above. - -For each, a pointer is stored in a [4-byte] Perl string. You can -usually use C<unpack "P"> to access the real data from Perl. - -For "ppr" [and often for "pp"], the pointer points directly at a -C C<struct>. For "par", the pointer points to the first element -of a C [packed] array of C<struct>s. For "pap", the pointer points -to a C [packed] array of pointers to other things. - -=item ap - -Here we have a list of pointers packed into a single Perl string. - -=back - -=head1 BUGS - -The old ActiveState ports of Perl for Win32 [but not, ActivePerl, the -ActiveState distributions of standard Perl 5.004 and beyond] do not support -the tools for building extensions and so do not support this extension. - -No routines are provided for using the data returned in the C<FILETIME> -buffers. Those are in the C<Win32API::Time> module. - -No routines are provided for dealing with UNICODE data effectively. -See L</:FuncW> above for some simple-minded UNICODE methods. - -Parts of the module test will fail if used on a version of Perl -that does not yet set C<$^E> based on C<GetLastError()>. - -On NT 4.0 [at least], the RegEnum*() calls do not set the required -buffer sizes when returning C<ERROR_MORE_DATA> so this module will -not grow the buffers in such cases. C<Win32::TieRegistry> overcomes -this by using values from C<RegQueryInfoKey()> for buffer sizes in -RegEnum* calls. - -On NT 4.0 [at least], C<RegQueryInfoKey()> on C<HKEY_PERFORMANCE_DATA> -never succeeds. Also, C<RegQueryValueEx()> on C<HKEY_PERFORMANCE_DATA> -never returns the required buffer size. To access C<HKEY_PERFORMANCE_DATA> -you will need to keep growing the data buffer until the call succeeds. - -Because C<goto &subroutine> seems to be buggy under Win32 Perl, -it is not used in the stubs in F<Registry.pm>. - -=head1 AUTHOR - -Tye McQueen, tye@metronet.com, http://www.metronet.com/~tye/. - -=head1 SEE ALSO - -=over - -=item L<Win32::TieRegistry> - -=item L<Win32::Registry> - -=back - -=cut diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Win32API/Registry/cRegistry.pc b/Master/tlpkg/lib/Perl5_lib-TL_inst/Win32API/Registry/cRegistry.pc deleted file mode 100644 index 9659d0c4361..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/Win32API/Registry/cRegistry.pc +++ /dev/null @@ -1,87 +0,0 @@ -# Generated by cRegistry_pc.cxx. -# Package Win32API::Registry with options: -# CPLUSPLUS => q[1] -# IFDEF => q[ /^SE_/ ? '__cplusplus' : /REG_/ ] -# IMPORT_LIST => [q[/._/], q[!/[a-z]/]] -# VALUES => { KEY_DELETE=>q[DELETE], KEY_READ_CONTROL=>q[READ_CONTROL], KEY_WRITE_OWNER=>q[WRITE_OWNER], KEY_SYNCHRONIZE=>q[SYNCHRONIZE], KEY_WRITE_DAC=>q[WRITE_DAC] } -# WRITE_PERL => q[1] -# Perl files eval'd: -# Registry.pm => last if /^\s*(bootstrap|XSLoader::load)\b/ -# C files included: -# Registry.xs => last if m#/[/*]\s*CONSTS_DEFINED\b|^\s*MODULE\b# -sub HKEY_CLASSES_ROOT () { 0x80000000 } -sub HKEY_CURRENT_CONFIG () { 0x80000005 } -sub HKEY_CURRENT_USER () { 0x80000001 } -sub HKEY_DYN_DATA () { 0x80000006 } -sub HKEY_LOCAL_MACHINE () { 0x80000002 } -sub HKEY_PERFORMANCE_DATA () { 0x80000004 } -sub HKEY_USERS () { 0x80000003 } -sub KEY_ALL_ACCESS () { 983103 } -sub KEY_CREATE_LINK () { 32 } -sub KEY_CREATE_SUB_KEY () { 4 } -sub KEY_DELETE () { 65536 } -sub KEY_ENUMERATE_SUB_KEYS () { 8 } -sub KEY_EXECUTE () { 131097 } -sub KEY_NOTIFY () { 16 } -sub KEY_QUERY_VALUE () { 1 } -sub KEY_READ () { 131097 } -sub KEY_READ_CONTROL () { 131072 } -sub KEY_SET_VALUE () { 2 } -sub KEY_SYNCHRONIZE () { 1048576 } -sub KEY_WRITE () { 131078 } -sub KEY_WRITE_DAC () { 262144 } -sub KEY_WRITE_OWNER () { 524288 } -sub REG_BINARY () { 3 } -sub REG_CREATED_NEW_KEY () { 1 } -sub REG_DWORD () { 4 } -sub REG_DWORD_BIG_ENDIAN () { 5 } -sub REG_DWORD_LITTLE_ENDIAN () { 4 } -sub REG_EXPAND_SZ () { 2 } -sub REG_FULL_RESOURCE_DESCRIPTOR () { 9 } -sub REG_LEGAL_CHANGE_FILTER () { 15 } -sub REG_LEGAL_OPTION () { 15 } -sub REG_LINK () { 6 } -sub REG_MULTI_SZ () { 7 } -sub REG_NONE () { 0 } -sub REG_NOTIFY_CHANGE_ATTRIBUTES () { 2 } -sub REG_NOTIFY_CHANGE_LAST_SET () { 4 } -sub REG_NOTIFY_CHANGE_NAME () { 1 } -sub REG_NOTIFY_CHANGE_SECURITY () { 8 } -sub REG_NO_LAZY_FLUSH () { 4 } -sub REG_OPENED_EXISTING_KEY () { 2 } -sub REG_OPTION_BACKUP_RESTORE () { 4 } -sub REG_OPTION_CREATE_LINK () { 2 } -sub REG_OPTION_NON_VOLATILE () { 0 } -sub REG_OPTION_OPEN_LINK () { 8 } -sub REG_OPTION_RESERVED () { 0 } -sub REG_OPTION_VOLATILE () { 1 } -sub REG_REFRESH_HIVE () { 2 } -sub REG_RESOURCE_LIST () { 8 } -sub REG_RESOURCE_REQUIREMENTS_LIST () { 10 } -sub REG_SZ () { 1 } -sub REG_WHOLE_HIVE_VOLATILE () { 1 } -sub SE_ASSIGNPRIMARYTOKEN_NAME () { 'SeAssignPrimaryTokenPrivilege' } -sub SE_AUDIT_NAME () { 'SeAuditPrivilege' } -sub SE_BACKUP_NAME () { 'SeBackupPrivilege' } -sub SE_CHANGE_NOTIFY_NAME () { 'SeChangeNotifyPrivilege' } -sub SE_CREATE_PAGEFILE_NAME () { 'SeCreatePagefilePrivilege' } -sub SE_CREATE_PERMANENT_NAME () { 'SeCreatePermanentPrivilege' } -sub SE_CREATE_TOKEN_NAME () { 'SeCreateTokenPrivilege' } -sub SE_DEBUG_NAME () { 'SeDebugPrivilege' } -sub SE_INCREASE_QUOTA_NAME () { 'SeIncreaseQuotaPrivilege' } -sub SE_INC_BASE_PRIORITY_NAME () { 'SeIncreaseBasePriorityPrivilege' } -sub SE_LOAD_DRIVER_NAME () { 'SeLoadDriverPrivilege' } -sub SE_LOCK_MEMORY_NAME () { 'SeLockMemoryPrivilege' } -sub SE_MACHINE_ACCOUNT_NAME () { 'SeMachineAccountPrivilege' } -sub SE_PROF_SINGLE_PROCESS_NAME () { 'SeProfileSingleProcessPrivilege' } -sub SE_REMOTE_SHUTDOWN_NAME () { 'SeRemoteShutdownPrivilege' } -sub SE_RESTORE_NAME () { 'SeRestorePrivilege' } -sub SE_SECURITY_NAME () { 'SeSecurityPrivilege' } -sub SE_SHUTDOWN_NAME () { 'SeShutdownPrivilege' } -sub SE_SYSTEMTIME_NAME () { 'SeSystemtimePrivilege' } -sub SE_SYSTEM_ENVIRONMENT_NAME () { 'SeSystemEnvironmentPrivilege' } -sub SE_SYSTEM_PROFILE_NAME () { 'SeSystemProfilePrivilege' } -sub SE_TAKE_OWNERSHIP_NAME () { 'SeTakeOwnershipPrivilege' } -sub SE_TCB_NAME () { 'SeTcbPrivilege' } -sub SE_UNSOLICITED_INPUT_NAME () { 'SeUnsolicitedInputPrivilege' } -1; diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/XSLoader.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/XSLoader.pm deleted file mode 100644 index 34172dcfa70..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/XSLoader.pm +++ /dev/null @@ -1,356 +0,0 @@ -# Generated from XSLoader.pm.PL (resolved %Config::Config value) - -package XSLoader; - -$VERSION = "0.06"; - -#use strict; - -# enable debug/trace messages from DynaLoader perl code -# $dl_debug = $ENV{PERL_DL_DEBUG} || 0 unless defined $dl_debug; - - my $dl_dlext = 'dll'; - -package DynaLoader; - -# No prizes for guessing why we don't say 'bootstrap DynaLoader;' here. -# NOTE: All dl_*.xs (including dl_none.xs) define a dl_error() XSUB -boot_DynaLoader('DynaLoader') if defined(&boot_DynaLoader) && - !defined(&dl_error); -package XSLoader; - -sub load { - package DynaLoader; - - die q{XSLoader::load('Your::Module', $Your::Module::VERSION)} unless @_; - - my($module) = $_[0]; - - # work with static linking too - my $b = "$module\::bootstrap"; - goto &$b if defined &$b; - - goto retry unless $module and defined &dl_load_file; - - my @modparts = split(/::/,$module); - my $modfname = $modparts[-1]; - - my $modpname = join('/',@modparts); - my $modlibname = (caller())[1]; - my $c = @modparts; - $modlibname =~ s,[\\/][^\\/]+$,, while $c--; # Q&D basename - my $file = "$modlibname/auto/$modpname/$modfname.$dl_dlext"; - -# print STDERR "XSLoader::load for $module ($file)\n" if $dl_debug; - - my $bs = $file; - $bs =~ s/(\.\w+)?(;\d*)?$/\.bs/; # look for .bs 'beside' the library - - goto retry if not -f $file or -s $bs; - - my $bootname = "boot_$module"; - $bootname =~ s/\W/_/g; - @DynaLoader::dl_require_symbols = ($bootname); - - my $boot_symbol_ref; - - if ($^O eq 'darwin') { - if ($boot_symbol_ref = dl_find_symbol(0, $bootname)) { - goto boot; #extension library has already been loaded, e.g. darwin - } - } - - # Many dynamic extension loading problems will appear to come from - # this section of code: XYZ failed at line 123 of DynaLoader.pm. - # Often these errors are actually occurring in the initialisation - # C code of the extension XS file. Perl reports the error as being - # in this perl code simply because this was the last perl code - # it executed. - - my $libref = dl_load_file($file, 0) or do { - require Carp; - Carp::croak("Can't load '$file' for module $module: " . dl_error()); - }; - push(@DynaLoader::dl_librefs,$libref); # record loaded object - - my @unresolved = dl_undef_symbols(); - if (@unresolved) { - require Carp; - Carp::carp("Undefined symbols present after loading $file: @unresolved\n"); - } - - $boot_symbol_ref = dl_find_symbol($libref, $bootname) or do { - require Carp; - Carp::croak("Can't find '$bootname' symbol in $file\n"); - }; - - push(@DynaLoader::dl_modules, $module); # record loaded module - - boot: - my $xs = dl_install_xsub("${module}::bootstrap", $boot_symbol_ref, $file); - - # See comment block above - push(@DynaLoader::dl_shared_objects, $file); # record files loaded - return &$xs(@_); - - retry: - my $bootstrap_inherit = DynaLoader->can('bootstrap_inherit') || - XSLoader->can('bootstrap_inherit'); - goto &$bootstrap_inherit; -} - -# Versions of DynaLoader prior to 5.6.0 don't have this function. -sub bootstrap_inherit { - package DynaLoader; - - my $module = $_[0]; - local *DynaLoader::isa = *{"$module\::ISA"}; - local @DynaLoader::isa = (@DynaLoader::isa, 'DynaLoader'); - # Cannot goto due to delocalization. Will report errors on a wrong line? - require DynaLoader; - DynaLoader::bootstrap(@_); -} - -1; - - -__END__ - -=head1 NAME - -XSLoader - Dynamically load C libraries into Perl code - -=head1 VERSION - -Version 0.06 - -=head1 SYNOPSIS - - package YourPackage; - use XSLoader; - - XSLoader::load 'YourPackage', $YourPackage::VERSION; - -=head1 DESCRIPTION - -This module defines a standard I<simplified> interface to the dynamic -linking mechanisms available on many platforms. Its primary purpose is -to implement cheap automatic dynamic loading of Perl modules. - -For a more complicated interface, see L<DynaLoader>. Many (most) -features of C<DynaLoader> are not implemented in C<XSLoader>, like for -example the C<dl_load_flags>, not honored by C<XSLoader>. - -=head2 Migration from C<DynaLoader> - -A typical module using L<DynaLoader|DynaLoader> starts like this: - - package YourPackage; - require DynaLoader; - - our @ISA = qw( OnePackage OtherPackage DynaLoader ); - our $VERSION = '0.01'; - bootstrap YourPackage $VERSION; - -Change this to - - package YourPackage; - use XSLoader; - - our @ISA = qw( OnePackage OtherPackage ); - our $VERSION = '0.01'; - XSLoader::load 'YourPackage', $VERSION; - -In other words: replace C<require DynaLoader> by C<use XSLoader>, remove -C<DynaLoader> from C<@ISA>, change C<bootstrap> by C<XSLoader::load>. Do not -forget to quote the name of your package on the C<XSLoader::load> line, -and add comma (C<,>) before the arguments (C<$VERSION> above). - -Of course, if C<@ISA> contained only C<DynaLoader>, there is no need to have -the C<@ISA> assignment at all; moreover, if instead of C<our> one uses the -more backward-compatible - - use vars qw($VERSION @ISA); - -one can remove this reference to C<@ISA> together with the C<@ISA> assignment. - -If no C<$VERSION> was specified on the C<bootstrap> line, the last line becomes - - XSLoader::load 'YourPackage'; - -=head2 Backward compatible boilerplate - -If you want to have your cake and eat it too, you need a more complicated -boilerplate. - - package YourPackage; - use vars qw($VERSION @ISA); - - @ISA = qw( OnePackage OtherPackage ); - $VERSION = '0.01'; - eval { - require XSLoader; - XSLoader::load('YourPackage', $VERSION); - 1; - } or do { - require DynaLoader; - push @ISA, 'DynaLoader'; - bootstrap YourPackage $VERSION; - }; - -The parentheses about C<XSLoader::load()> arguments are needed since we replaced -C<use XSLoader> by C<require>, so the compiler does not know that a function -C<XSLoader::load()> is present. - -This boilerplate uses the low-overhead C<XSLoader> if present; if used with -an antic Perl which has no C<XSLoader>, it falls back to using C<DynaLoader>. - -=head1 Order of initialization: early load() - -I<Skip this section if the XSUB functions are supposed to be called from other -modules only; read it only if you call your XSUBs from the code in your module, -or have a C<BOOT:> section in your XS file (see L<perlxs/"The BOOT: Keyword">). -What is described here is equally applicable to the L<DynaLoader|DynaLoader> -interface.> - -A sufficiently complicated module using XS would have both Perl code (defined -in F<YourPackage.pm>) and XS code (defined in F<YourPackage.xs>). If this -Perl code makes calls into this XS code, and/or this XS code makes calls to -the Perl code, one should be careful with the order of initialization. - -The call to C<XSLoader::load()> (or C<bootstrap()>) has three side effects: - -=over - -=item * - -if C<$VERSION> was specified, a sanity check is done to ensure that the -versions of the F<.pm> and the (compiled) F<.xs> parts are compatible; - -=item * - -the XSUBs are made accessible from Perl; - -=item * - -if a C<BOOT:> section was present in the F<.xs> file, the code there is called. - -=back - -Consequently, if the code in the F<.pm> file makes calls to these XSUBs, it is -convenient to have XSUBs installed before the Perl code is defined; for -example, this makes prototypes for XSUBs visible to this Perl code. -Alternatively, if the C<BOOT:> section makes calls to Perl functions (or -uses Perl variables) defined in the F<.pm> file, they must be defined prior to -the call to C<XSLoader::load()> (or C<bootstrap()>). - -The first situation being much more frequent, it makes sense to rewrite the -boilerplate as - - package YourPackage; - use XSLoader; - use vars qw($VERSION @ISA); - - BEGIN { - @ISA = qw( OnePackage OtherPackage ); - $VERSION = '0.01'; - - # Put Perl code used in the BOOT: section here - - XSLoader::load 'YourPackage', $VERSION; - } - - # Put Perl code making calls into XSUBs here - -=head2 The most hairy case - -If the interdependence of your C<BOOT:> section and Perl code is -more complicated than this (e.g., the C<BOOT:> section makes calls to Perl -functions which make calls to XSUBs with prototypes), get rid of the C<BOOT:> -section altogether. Replace it with a function C<onBOOT()>, and call it like -this: - - package YourPackage; - use XSLoader; - use vars qw($VERSION @ISA); - - BEGIN { - @ISA = qw( OnePackage OtherPackage ); - $VERSION = '0.01'; - XSLoader::load 'YourPackage', $VERSION; - } - - # Put Perl code used in onBOOT() function here; calls to XSUBs are - # prototype-checked. - - onBOOT; - - # Put Perl initialization code assuming that XS is initialized here - - -=head1 DIAGNOSTICS - -=over 4 - -=item Can't find '%s' symbol in %s - -B<(F)> The bootstrap symbol could not be found in the extension module. - -=item Can't load '%s' for module %s: %s - -B<(F)> The loading or initialisation of the extension module failed. -The detailed error follows. - -=item Undefined symbols present after loading %s: %s - -B<(W)> As the message says, some symbols stay undefined although the -extension module was correctly loaded and initialised. The list of undefined -symbols follows. - -=item XSLoader::load('Your::Module', $Your::Module::VERSION) - -B<(F)> You tried to invoke C<load()> without any argument. You must supply -a module name, and optionally its version. - -=back - - -=head1 LIMITATIONS - -To reduce the overhead as much as possible, only one possible location -is checked to find the extension DLL (this location is where C<make install> -would put the DLL). If not found, the search for the DLL is transparently -delegated to C<DynaLoader>, which looks for the DLL along the C<@INC> list. - -In particular, this is applicable to the structure of C<@INC> used for testing -not-yet-installed extensions. This means that running uninstalled extensions -may have much more overhead than running the same extensions after -C<make install>. - - -=head1 BUGS - -Please report any bugs or feature requests via the perlbug(1) utility. - - -=head1 SEE ALSO - -L<DynaLoader> - - -=head1 AUTHORS - -Ilya Zakharevich originally extracted C<XSLoader> from C<DynaLoader>. - -CPAN version is currently maintained by SE<eacute>bastien Aperghis-Tramoni -E<lt>sebastien@aperghis.netE<gt> - -Previous maintainer was Michael G Schwern <schwern@pobox.com> - - -=head1 COPYRIGHT - -This program is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -=cut diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Cwd/Cwd.bs b/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Cwd/Cwd.bs deleted file mode 100644 index e69de29bb2d..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Cwd/Cwd.bs +++ /dev/null diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Cwd/Cwd.dll b/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Cwd/Cwd.dll Binary files differdeleted file mode 100755 index 67f6d7baa57..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Cwd/Cwd.dll +++ /dev/null diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/DynaLoader/autosplit.ix b/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/DynaLoader/autosplit.ix deleted file mode 100644 index d7605efa074..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/DynaLoader/autosplit.ix +++ /dev/null @@ -1,8 +0,0 @@ -# Index created by AutoSplit for ../LIB\DynaLoader.pm -# (file acts as timestamp) -package DynaLoader; -sub dl_findfile ; -sub dl_expandspec ; -sub dl_find_symbol_anywhere -; -1; diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/DynaLoader/dl_expandspec.al b/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/DynaLoader/dl_expandspec.al deleted file mode 100644 index 0bea19a3e4d..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/DynaLoader/dl_expandspec.al +++ /dev/null @@ -1,34 +0,0 @@ -# NOTE: Derived from ../LIB\DynaLoader.pm. -# Changes made here will be lost when autosplit is run again. -# See AutoSplit.pm. -package DynaLoader; - -#line 377 "../LIB\DynaLoader.pm (autosplit into ..\lib\auto\DynaLoader\dl_expandspec.al)" -sub dl_expandspec { - my($spec) = @_; - # Optional function invoked if DynaLoader.pm sets $do_expand. - # Most systems do not require or use this function. - # Some systems may implement it in the dl_*.xs file in which case - # this autoload version will not be called but is harmless. - - # This function is designed to deal with systems which treat some - # 'filenames' in a special way. For example VMS 'Logical Names' - # (something like unix environment variables - but different). - # This function should recognise such names and expand them into - # full file paths. - # Must return undef if $spec is invalid or file does not exist. - - my $file = $spec; # default output to input - - if ($Is_VMS) { # dl_expandspec should be defined in dl_vms.xs - require Carp; - Carp::croak("dl_expandspec: should be defined in XS file!\n"); - } else { - return undef unless -f $file; - } - print STDERR "dl_expandspec($spec) => $file\n" if $dl_debug; - $file; -} - -# end of DynaLoader::dl_expandspec -1; diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/DynaLoader/dl_find_symbol_anywhere.al b/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/DynaLoader/dl_find_symbol_anywhere.al deleted file mode 100644 index 2232454ba69..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/DynaLoader/dl_find_symbol_anywhere.al +++ /dev/null @@ -1,19 +0,0 @@ -# NOTE: Derived from ../LIB\DynaLoader.pm. -# Changes made here will be lost when autosplit is run again. -# See AutoSplit.pm. -package DynaLoader; - -#line 403 "../LIB\DynaLoader.pm (autosplit into ..\lib\auto\DynaLoader\dl_find_symbol_anywhere.al)" -sub dl_find_symbol_anywhere -{ - my $sym = shift; - my $libref; - foreach $libref (@dl_librefs) { - my $symref = dl_find_symbol($libref,$sym); - return $symref if $symref; - } - return undef; -} - -1; -# end of DynaLoader::dl_find_symbol_anywhere diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/DynaLoader/dl_findfile.al b/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/DynaLoader/dl_findfile.al deleted file mode 100644 index 9f8df39d00c..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/DynaLoader/dl_findfile.al +++ /dev/null @@ -1,115 +0,0 @@ -# NOTE: Derived from ../LIB\DynaLoader.pm. -# Changes made here will be lost when autosplit is run again. -# See AutoSplit.pm. -package DynaLoader; - -#line 269 "../LIB\DynaLoader.pm (autosplit into ..\lib\auto\DynaLoader\dl_findfile.al)" -sub dl_findfile { - # Read ext/DynaLoader/DynaLoader.doc for detailed information. - # This function does not automatically consider the architecture - # or the perl library auto directories. - my (@args) = @_; - my (@dirs, $dir); # which directories to search - my (@found); # full paths to real files we have found - my $dl_ext= 'dll'; # $Config::Config{'dlext'} suffix for perl extensions - my $dl_so = 'dll'; # $Config::Config{'so'} suffix for shared libraries - - print STDERR "dl_findfile(@args)\n" if $dl_debug; - - # accumulate directories but process files as they appear - arg: foreach(@args) { - # Special fast case: full filepath requires no search - if ($Is_VMS && m%[:>/\]]% && -f $_) { - push(@found,dl_expandspec(VMS::Filespec::vmsify($_))); - last arg unless wantarray; - next; - } - elsif ($Is_MacOS) { - if (m/:/ && -f $_) { - push(@found,$_); - last arg unless wantarray; - } - } - elsif (m:/: && -f $_ && !$do_expand) { - push(@found,$_); - last arg unless wantarray; - next; - } - - # Deal with directories first: - # Using a -L prefix is the preferred option (faster and more robust) - if (m:^-L:) { s/^-L//; push(@dirs, $_); next; } - - if ($Is_MacOS) { - # Otherwise we try to try to spot directories by a heuristic - # (this is a more complicated issue than it first appears) - if (m/:/ && -d $_) { push(@dirs, $_); next; } - # Only files should get this far... - my(@names, $name); # what filenames to look for - s/^-l//; - push(@names, $_); - foreach $dir (@dirs, @dl_library_path) { - next unless -d $dir; - $dir =~ s/^([^:]+)$/:$1/; - $dir =~ s/:$//; - foreach $name (@names) { - my($file) = "$dir:$name"; - print STDERR " checking in $dir for $name\n" if $dl_debug; - if (-f $file) { - push(@found, $file); - next arg; # no need to look any further - } - } - } - next; - } - - # Otherwise we try to try to spot directories by a heuristic - # (this is a more complicated issue than it first appears) - if (m:/: && -d $_) { push(@dirs, $_); next; } - - # VMS: we may be using native VMS directory syntax instead of - # Unix emulation, so check this as well - if ($Is_VMS && /[:>\]]/ && -d $_) { push(@dirs, $_); next; } - - # Only files should get this far... - my(@names, $name); # what filenames to look for - if (m:-l: ) { # convert -lname to appropriate library name - s/-l//; - push(@names,"lib$_.$dl_so"); - push(@names,"lib$_.a"); - } else { # Umm, a bare name. Try various alternatives: - # these should be ordered with the most likely first - push(@names,"$_.$dl_ext") unless m/\.$dl_ext$/o; - push(@names,"$_.$dl_so") unless m/\.$dl_so$/o; - push(@names,"lib$_.$dl_so") unless m:/:; - push(@names,"$_.a") if !m/\.a$/ and $dlsrc eq "dl_dld.xs"; - push(@names, $_); - } - foreach $dir (@dirs, @dl_library_path) { - next unless -d $dir; - chop($dir = VMS::Filespec::unixpath($dir)) if $Is_VMS; - foreach $name (@names) { - my($file) = "$dir/$name"; - print STDERR " checking in $dir for $name\n" if $dl_debug; - $file = ($do_expand) ? dl_expandspec($file) : (-f $file && $file); - #$file = _check_file($file); - if ($file) { - push(@found, $file); - next arg; # no need to look any further - } - } - } - } - if ($dl_debug) { - foreach(@dirs) { - print STDERR " dl_findfile ignored non-existent directory: $_\n" unless -d $_; - } - print STDERR "dl_findfile found: @found\n"; - } - return $found[0] unless wantarray; - @found; -} - -# end of DynaLoader::dl_findfile -1; diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Encode/Byte/Byte.bs b/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Encode/Byte/Byte.bs deleted file mode 100644 index e69de29bb2d..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Encode/Byte/Byte.bs +++ /dev/null diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Encode/Byte/Byte.dll b/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Encode/Byte/Byte.dll Binary files differdeleted file mode 100755 index 88474ccb046..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Encode/Byte/Byte.dll +++ /dev/null diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Encode/Encode.bs b/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Encode/Encode.bs deleted file mode 100644 index e69de29bb2d..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Encode/Encode.bs +++ /dev/null diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Encode/Encode.dll b/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Encode/Encode.dll Binary files differdeleted file mode 100755 index 69c8ebf8acb..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Encode/Encode.dll +++ /dev/null diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Encode/Unicode/Unicode.bs b/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Encode/Unicode/Unicode.bs deleted file mode 100644 index e69de29bb2d..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Encode/Unicode/Unicode.bs +++ /dev/null diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Encode/Unicode/Unicode.dll b/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Encode/Unicode/Unicode.dll Binary files differdeleted file mode 100755 index 71a757a6b64..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Encode/Unicode/Unicode.dll +++ /dev/null diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/CancelRepeat.al b/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/CancelRepeat.al deleted file mode 100644 index d0d6bb1b2a3..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/CancelRepeat.al +++ /dev/null @@ -1,15 +0,0 @@ -# NOTE: Derived from blib\lib\Tk.pm. -# Changes made here will be lost when autosplit is run again. -# See AutoSplit.pm. -package Tk; - -#line 491 "blib\lib\Tk.pm (autosplit into blib\lib\auto\Tk\CancelRepeat.al)" -sub CancelRepeat -{ - my $w = shift->MainWindow; - my $id = delete $w->{_afterId_}; - $w->after('cancel',$id) if (defined $id); -} - -# end of Tk::CancelRepeat -1; diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Clipboard/autosplit.ix b/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Clipboard/autosplit.ix deleted file mode 100644 index 9831f74facb..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Clipboard/autosplit.ix +++ /dev/null @@ -1,6 +0,0 @@ -# Index created by AutoSplit for blib\lib\Tk\Clipboard.pm -# (file acts as timestamp) -package Tk::Clipboard; -sub getSelected -; -1; diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Clipboard/getSelected.al b/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Clipboard/getSelected.al deleted file mode 100644 index 44ba7b74bf0..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Clipboard/getSelected.al +++ /dev/null @@ -1,15 +0,0 @@ -# NOTE: Derived from blib\lib\Tk\Clipboard.pm. -# Changes made here will be lost when autosplit is run again. -# See AutoSplit.pm. -package Tk::Clipboard; - -#line 115 "blib\lib\Tk\Clipboard.pm (autosplit into blib\lib\auto\Tk\Clipboard\getSelected.al)" -sub getSelected -{ - my $w = shift; - my $val = Tk::catch { $w->get('sel.first','sel.last') }; - return $val; -} - -1; -# end of Tk::Clipboard::getSelected diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Entry/Entry.bs b/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Entry/Entry.bs deleted file mode 100644 index e69de29bb2d..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Entry/Entry.bs +++ /dev/null diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Entry/Entry.dll b/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Entry/Entry.dll Binary files differdeleted file mode 100755 index 9b1c07a7792..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Entry/Entry.dll +++ /dev/null diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Error.al b/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Error.al deleted file mode 100644 index 7efe2c7043d..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Error.al +++ /dev/null @@ -1,20 +0,0 @@ -# NOTE: Derived from blib\lib\Tk.pm. -# Changes made here will be lost when autosplit is run again. -# See AutoSplit.pm. -package Tk; - -#line 479 "blib\lib\Tk.pm (autosplit into blib\lib\auto\Tk\Error.al)" -sub Error -{my $w = shift; - my $error = shift; - if (Exists($w)) - { - my $grab = $w->grab('current'); - $grab->Unbusy if (defined $grab); - } - chomp($error); - warn "Tk::Error: $error\n " . join("\n ",@_)."\n"; -} - -# end of Tk::Error -1; diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Event/Event.bs b/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Event/Event.bs deleted file mode 100644 index e69de29bb2d..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Event/Event.bs +++ /dev/null diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Event/Event.dll b/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Event/Event.dll Binary files differdeleted file mode 100755 index 5a9706cb92e..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Event/Event.dll +++ /dev/null diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Frame/autosplit.ix b/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Frame/autosplit.ix deleted file mode 100644 index 6e5b939fce1..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Frame/autosplit.ix +++ /dev/null @@ -1,24 +0,0 @@ -# Index created by AutoSplit for blib\lib\Tk\Frame.pm -# (file acts as timestamp) -package Tk::Frame; -sub labelPack -; -sub labelVariable -; -sub label -; -sub queuePack -; -sub sbset -; -sub freeze_on_map -; -sub AddScrollbars -; -sub packscrollbars -; -sub scrollbars -; -sub FindMenu -; -1; diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/PNG/PNG.bs b/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/PNG/PNG.bs deleted file mode 100644 index e69de29bb2d..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/PNG/PNG.bs +++ /dev/null diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/PNG/PNG.dll b/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/PNG/PNG.dll Binary files differdeleted file mode 100755 index 08bbbed4fcc..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/PNG/PNG.dll +++ /dev/null diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/RepeatId.al b/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/RepeatId.al deleted file mode 100644 index e71d2a337a0..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/RepeatId.al +++ /dev/null @@ -1,16 +0,0 @@ -# NOTE: Derived from blib\lib\Tk.pm. -# Changes made here will be lost when autosplit is run again. -# See AutoSplit.pm. -package Tk; - -#line 498 "blib\lib\Tk.pm (autosplit into blib\lib\auto\Tk\RepeatId.al)" -sub RepeatId -{ - my ($w,$id) = @_; - $w = $w->MainWindow; - $w->CancelRepeat; - $w->{_afterId_} = $id; -} - -# end of Tk::RepeatId -1; diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Tk.bs b/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Tk.bs deleted file mode 100644 index e69de29bb2d..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Tk.bs +++ /dev/null diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Tk.dll b/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Tk.dll Binary files differdeleted file mode 100755 index 8d80944808d..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Tk.dll +++ /dev/null diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Toplevel/autosplit.ix b/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Toplevel/autosplit.ix deleted file mode 100644 index 859b90d9a40..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Toplevel/autosplit.ix +++ /dev/null @@ -1,10 +0,0 @@ -# Index created by AutoSplit for blib\lib\Tk\Toplevel.pm -# (file acts as timestamp) -package Tk::Toplevel; -sub FG_Create ; -sub FG_BindIn ; -sub FG_BindOut ; -sub FG_Destroy ; -sub FG_In ; -sub FG_Out ; -1; diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Widget/autosplit.ix b/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Widget/autosplit.ix deleted file mode 100644 index b610773d4dc..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Widget/autosplit.ix +++ /dev/null @@ -1,11 +0,0 @@ -# Index created by AutoSplit for blib\lib\Tk\Widget.pm -# (file acts as timestamp) -package Tk::Widget; -sub bindDump ; -sub ASkludge -; -sub clipboardKeysyms -; -sub pathname -; -1; diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Wm/AnchorAdjust.al b/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Wm/AnchorAdjust.al deleted file mode 100644 index 538612878ed..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Wm/AnchorAdjust.al +++ /dev/null @@ -1,17 +0,0 @@ -# NOTE: Derived from blib\lib\Tk\Wm.pm. -# Changes made here will be lost when autosplit is run again. -# See AutoSplit.pm. -package Tk::Wm; - -#line 87 "blib\lib\Tk\Wm.pm (autosplit into blib\lib\auto\Tk\Wm\AnchorAdjust.al)" -sub AnchorAdjust -{ - my ($anchor,$X,$Y,$w,$h) = @_; - $anchor = 'c' unless (defined $anchor); - $Y += ($anchor =~ /s/) ? $h : ($anchor =~ /n/) ? 0 : $h/2; - $X += ($anchor =~ /e/) ? $w : ($anchor =~ /w/) ? 0 : $w/2; - return ($X,$Y); -} - -# end of Tk::Wm::AnchorAdjust -1; diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Wm/FullScreen.al b/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Wm/FullScreen.al deleted file mode 100644 index 4d5702cc60d..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Wm/FullScreen.al +++ /dev/null @@ -1,29 +0,0 @@ -# NOTE: Derived from blib\lib\Tk\Wm.pm. -# Changes made here will be lost when autosplit is run again. -# See AutoSplit.pm. -package Tk::Wm; - -#line 138 "blib\lib\Tk\Wm.pm (autosplit into blib\lib\auto\Tk\Wm\FullScreen.al)" -sub FullScreen -{ - my $w = shift; - my $over = (@_) ? shift : 0; - my $width = $w->screenwidth; - my $height = $w->screenheight; - $w->GeometryRequest($width,$height); - $w->overrideredirect($over & 1); - $w->Post(0,0); - $w->update; - if ($over & 2) - { - my $x = $w->rootx; - my $y = $w->rooty; - $width -= 2*$x; - $height -= $x + $y; - $w->GeometryRequest($width,$height); - $w->update; - } -} - -# end of Tk::Wm::FullScreen -1; diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Wm/Popup.al b/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Wm/Popup.al deleted file mode 100644 index 3f460c5bac6..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Wm/Popup.al +++ /dev/null @@ -1,50 +0,0 @@ -# NOTE: Derived from blib\lib\Tk\Wm.pm. -# Changes made here will be lost when autosplit is run again. -# See AutoSplit.pm. -package Tk::Wm; - -#line 96 "blib\lib\Tk\Wm.pm (autosplit into blib\lib\auto\Tk\Wm\Popup.al)" -sub Popup -{ - my $w = shift; - $w->configure(@_) if @_; - $w->idletasks; - my ($mw,$mh) = ($w->reqwidth,$w->reqheight); - my ($rx,$ry,$rw,$rh) = (0,0,0,0); - my $base = $w->cget('-popover'); - my $outside = 0; - if (defined $base) - { - if ($base eq 'cursor') - { - ($rx,$ry) = $w->pointerxy; - } - else - { - $rx = $base->rootx; - $ry = $base->rooty; - $rw = $base->Width; - $rh = $base->Height; - } - } - else - { - my $sc = ($w->parent) ? $w->parent->toplevel : $w; - $rx = -$sc->vrootx; - $ry = -$sc->vrooty; - $rw = $w->screenwidth; - $rh = $w->screenheight; - } - my ($X,$Y) = AnchorAdjust($w->cget('-overanchor'),$rx,$ry,$rw,$rh); - ($X,$Y) = AnchorAdjust($w->cget('-popanchor'),$X,$Y,-$mw,-$mh); - # adjust to not cross screen borders - if ($X < 0) { $X = 0 } - if ($Y < 0) { $Y = 0 } - if ($mw > $w->screenwidth) { $X = 0 } - if ($mh > $w->screenheight) { $Y = 0 } - $w->Post($X,$Y); - $w->waitVisibility; -} - -# end of Tk::Wm::Popup -1; diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Wm/Post.al b/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Wm/Post.al deleted file mode 100644 index f3f5c8e3e08..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Wm/Post.al +++ /dev/null @@ -1,20 +0,0 @@ -# NOTE: Derived from blib\lib\Tk\Wm.pm. -# Changes made here will be lost when autosplit is run again. -# See AutoSplit.pm. -package Tk::Wm; - -#line 75 "blib\lib\Tk\Wm.pm (autosplit into blib\lib\auto\Tk\Wm\Post.al)" -sub Post -{ - my ($w,$X,$Y) = @_; - $X = int($X); - $Y = int($Y); - $w->positionfrom('user'); - $w->geometry("+$X+$Y"); - # $w->MoveToplevelWindow($X,$Y); - $w->deiconify; - $w->raise; -} - -# end of Tk::Wm::Post -1; diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Wm/autosplit.ix b/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Wm/autosplit.ix deleted file mode 100644 index 201dbe8ba99..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Wm/autosplit.ix +++ /dev/null @@ -1,14 +0,0 @@ -# Index created by AutoSplit for blib\lib\Tk\Wm.pm -# (file acts as timestamp) -package Tk::Wm; -sub Post -; -sub AnchorAdjust -; -sub Popup -; -sub FullScreen -; -sub iconposition -; -1; diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Wm/iconposition.al b/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Wm/iconposition.al deleted file mode 100644 index 9254968f61c..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Wm/iconposition.al +++ /dev/null @@ -1,24 +0,0 @@ -# NOTE: Derived from blib\lib\Tk\Wm.pm. -# Changes made here will be lost when autosplit is run again. -# See AutoSplit.pm. -package Tk::Wm; - -#line 159 "blib\lib\Tk\Wm.pm (autosplit into blib\lib\auto\Tk\Wm\iconposition.al)" -sub iconposition -{ - my $w = shift; - if (@_ == 1) - { - return $w->wm('iconposition',$1,$2) if $_[0] =~ /^(\d+),(\d+)$/; - if ($_[0] =~ /^([+-])(\d+)([+-])(\d+)$/) - { - my $x = ($1 eq '-') ? $w->screenwidth-$2 : $2; - my $y = ($3 eq '-') ? $w->screenheight-$4 : $4; - return $w->wm('iconposition',$x,$y); - } - } - $w->wm('iconposition',@_); -} - -1; -# end of Tk::Wm::iconposition diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/autosplit.ix b/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/autosplit.ix deleted file mode 100644 index 7bd25b78a9a..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/autosplit.ix +++ /dev/null @@ -1,45 +0,0 @@ -# Index created by AutoSplit for blib\lib\Tk.pm -# (file acts as timestamp) -package Tk; -sub Error -; -sub CancelRepeat -; -sub RepeatId -; -sub FocusChildren ; -sub focusNext -; -sub focusPrev -; -sub FocusOK -; -sub EnterFocus -; -sub tabFocus -; -sub focusFollowsMouse -; -sub TraverseToMenu -; -sub FirstMenu -; -sub Selection -; -sub Receive -; -sub break -; -sub updateWidgets -; -sub ImageNames -; -sub ImageTypes -; -sub interps -; -sub lsearch -; -sub getEncoding -; -1; diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/getEncoding.al b/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/getEncoding.al deleted file mode 100644 index b9e230edbf1..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/getEncoding.al +++ /dev/null @@ -1,43 +0,0 @@ -# NOTE: Derived from blib\lib\Tk.pm. -# Changes made here will be lost when autosplit is run again. -# See AutoSplit.pm. -package Tk; - -#line 785 "blib\lib\Tk.pm (autosplit into blib\lib\auto\Tk\getEncoding.al)" -sub getEncoding -{ - my ($class,$name) = @_; - eval { require Encode }; - if ($@) - { - require Tk::DummyEncode; - return Tk::DummyEncode->getEncoding($name); - } - $name = $Tk::font_encoding{$name} if exists $Tk::font_encoding{$name}; - my $enc = Encode::find_encoding($name); - - unless ($enc) - { - $enc = Encode::find_encoding($name) if ($name =~ s/[-_]\d+$//) - } -# if ($enc) -# { -# print STDERR "Lookup '$name' => ".$enc->name."\n"; -# } -# else -# { -# print STDERR "Failed '$name'\n"; -# } - unless ($enc) - { - if ($name eq 'X11ControlChars') - { - require Tk::DummyEncode; - $Encode::encoding{$name} = $enc = Tk::DummyEncode->getEncoding($name); - } - } - return $enc; -} - -1; -# end of Tk::getEncoding diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Win32/API/API.bs b/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Win32/API/API.bs deleted file mode 100644 index e69de29bb2d..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Win32/API/API.bs +++ /dev/null diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Win32/API/API.dll b/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Win32/API/API.dll Binary files differdeleted file mode 100644 index 3a7efc0adca..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Win32/API/API.dll +++ /dev/null diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Win32/API/Callback/Callback.bs b/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Win32/API/Callback/Callback.bs deleted file mode 100644 index e69de29bb2d..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Win32/API/Callback/Callback.bs +++ /dev/null diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Win32/API/Callback/Callback.dll b/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Win32/API/Callback/Callback.dll Binary files differdeleted file mode 100644 index 147c679d576..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Win32/API/Callback/Callback.dll +++ /dev/null diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Win32API/Registry/Registry.bs b/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Win32API/Registry/Registry.bs deleted file mode 100644 index e69de29bb2d..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Win32API/Registry/Registry.bs +++ /dev/null diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Win32API/Registry/Registry.dll b/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Win32API/Registry/Registry.dll Binary files differdeleted file mode 100755 index 45b7bc0688a..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Win32API/Registry/Registry.dll +++ /dev/null diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/base.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/base.pm deleted file mode 100644 index 001914be4d3..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/base.pm +++ /dev/null @@ -1,226 +0,0 @@ -package base; - -use strict 'vars'; -use vars qw($VERSION); -$VERSION = '2.07'; - -# constant.pm is slow -sub SUCCESS () { 1 } - -sub PUBLIC () { 2**0 } -sub PRIVATE () { 2**1 } -sub INHERITED () { 2**2 } -sub PROTECTED () { 2**3 } - - -my $Fattr = \%fields::attr; - -sub has_fields { - my($base) = shift; - my $fglob = ${"$base\::"}{FIELDS}; - return( ($fglob && *$fglob{HASH}) ? 1 : 0 ); -} - -sub has_version { - my($base) = shift; - my $vglob = ${$base.'::'}{VERSION}; - return( ($vglob && *$vglob{SCALAR}) ? 1 : 0 ); -} - -sub has_attr { - my($proto) = shift; - my($class) = ref $proto || $proto; - return exists $Fattr->{$class}; -} - -sub get_attr { - $Fattr->{$_[0]} = [1] unless $Fattr->{$_[0]}; - return $Fattr->{$_[0]}; -} - -if ($] < 5.009) { - *get_fields = sub { - # Shut up a possible typo warning. - () = \%{$_[0].'::FIELDS'}; - my $f = \%{$_[0].'::FIELDS'}; - - # should be centralized in fields? perhaps - # fields::mk_FIELDS_be_OK. Peh. As long as %{ $package . '::FIELDS' } - # is used here anyway, it doesn't matter. - bless $f, 'pseudohash' if (ref($f) ne 'pseudohash'); - - return $f; - } -} -else { - *get_fields = sub { - # Shut up a possible typo warning. - () = \%{$_[0].'::FIELDS'}; - return \%{$_[0].'::FIELDS'}; - } -} - -sub import { - my $class = shift; - - return SUCCESS unless @_; - - # List of base classes from which we will inherit %FIELDS. - my $fields_base; - - my $inheritor = caller(0); - - foreach my $base (@_) { - next if $inheritor->isa($base); - - if (has_version($base)) { - ${$base.'::VERSION'} = '-1, set by base.pm' - unless defined ${$base.'::VERSION'}; - } - else { - local $SIG{__DIE__}; - eval "require $base"; - # Only ignore "Can't locate" errors from our eval require. - # Other fatal errors (syntax etc) must be reported. - die if $@ && $@ !~ /^Can't locate .*? at \(eval /; - unless (%{"$base\::"}) { - require Carp; - Carp::croak(<<ERROR); -Base class package "$base" is empty. - (Perhaps you need to 'use' the module which defines that package first.) -ERROR - - } - ${$base.'::VERSION'} = "-1, set by base.pm" - unless defined ${$base.'::VERSION'}; - } - push @{"$inheritor\::ISA"}, $base; - - if ( has_fields($base) || has_attr($base) ) { - # No multiple fields inheritence *suck* - if ($fields_base) { - require Carp; - Carp::croak("Can't multiply inherit %FIELDS"); - } else { - $fields_base = $base; - } - } - } - - if( defined $fields_base ) { - inherit_fields($inheritor, $fields_base); - } -} - - -sub inherit_fields { - my($derived, $base) = @_; - - return SUCCESS unless $base; - - my $battr = get_attr($base); - my $dattr = get_attr($derived); - my $dfields = get_fields($derived); - my $bfields = get_fields($base); - - $dattr->[0] = @$battr; - - if( keys %$dfields ) { - warn "$derived is inheriting from $base but already has its own ". - "fields!\n". - "This will cause problems.\n". - "Be sure you use base BEFORE declaring fields\n"; - } - - # Iterate through the base's fields adding all the non-private - # ones to the derived class. Hang on to the original attribute - # (Public, Private, etc...) and add Inherited. - # This is all too complicated to do efficiently with add_fields(). - while (my($k,$v) = each %$bfields) { - my $fno; - if ($fno = $dfields->{$k} and $fno != $v) { - require Carp; - Carp::croak ("Inherited %FIELDS can't override existing %FIELDS"); - } - - if( $battr->[$v] & PRIVATE ) { - $dattr->[$v] = PRIVATE | INHERITED; - } - else { - $dattr->[$v] = INHERITED | $battr->[$v]; - $dfields->{$k} = $v; - } - } - - foreach my $idx (1..$#{$battr}) { - next if defined $dattr->[$idx]; - $dattr->[$idx] = $battr->[$idx] & INHERITED; - } -} - - -1; - -__END__ - -=head1 NAME - -base - Establish IS-A relationship with base classes at compile time - -=head1 SYNOPSIS - - package Baz; - use base qw(Foo Bar); - -=head1 DESCRIPTION - -Allows you to both load one or more modules, while setting up inheritance from -those modules at the same time. Roughly similar in effect to - - package Baz; - BEGIN { - require Foo; - require Bar; - push @ISA, qw(Foo Bar); - } - -If any of the listed modules are not loaded yet, I<base> silently attempts to -C<require> them (and silently continues if the C<require> failed). Whether to -C<require> a base class module is determined by the absence of a global variable -$VERSION in the base package. If $VERSION is not detected even after loading -it, <base> will define $VERSION in the base package, setting it to the string -C<-1, set by base.pm>. - -Will also initialize the fields if one of the base classes has it. -Multiple inheritence of fields is B<NOT> supported, if two or more -base classes each have inheritable fields the 'base' pragma will -croak. See L<fields>, L<public> and L<protected> for a description of -this feature. - -=head1 DIAGNOSTICS - -=over 4 - -=item Base class package "%s" is empty. - -base.pm was unable to require the base package, because it was not -found in your path. - -=back - -=head1 HISTORY - -This module was introduced with Perl 5.004_04. - - -=head1 CAVEATS - -Due to the limitations of the implementation, you must use -base I<before> you declare any of your own fields. - - -=head1 SEE ALSO - -L<fields> - -=cut diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/bytes.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/bytes.pm deleted file mode 100644 index a8222794ddf..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/bytes.pm +++ /dev/null @@ -1,88 +0,0 @@ -package bytes; - -our $VERSION = '1.02'; - -$bytes::hint_bits = 0x00000008; - -sub import { - $^H |= $bytes::hint_bits; -} - -sub unimport { - $^H &= ~$bytes::hint_bits; -} - -sub AUTOLOAD { - require "bytes_heavy.pl"; - goto &$AUTOLOAD if defined &$AUTOLOAD; - require Carp; - Carp::croak("Undefined subroutine $AUTOLOAD called"); -} - -sub length ($); -sub chr ($); -sub ord ($); -sub substr ($$;$$); -sub index ($$;$); -sub rindex ($$;$); - -1; -__END__ - -=head1 NAME - -bytes - Perl pragma to force byte semantics rather than character semantics - -=head1 SYNOPSIS - - use bytes; - ... chr(...); # or bytes::chr - ... index(...); # or bytes::index - ... length(...); # or bytes::length - ... ord(...); # or bytes::ord - ... rindex(...); # or bytes::rindex - ... substr(...); # or bytes::substr - no bytes; - - -=head1 DESCRIPTION - -The C<use bytes> pragma disables character semantics for the rest of the -lexical scope in which it appears. C<no bytes> can be used to reverse -the effect of C<use bytes> within the current lexical scope. - -Perl normally assumes character semantics in the presence of character -data (i.e. data that has come from a source that has been marked as -being of a particular character encoding). When C<use bytes> is in -effect, the encoding is temporarily ignored, and each string is treated -as a series of bytes. - -As an example, when Perl sees C<$x = chr(400)>, it encodes the character -in UTF-8 and stores it in $x. Then it is marked as character data, so, -for instance, C<length $x> returns C<1>. However, in the scope of the -C<bytes> pragma, $x is treated as a series of bytes - the bytes that make -up the UTF8 encoding - and C<length $x> returns C<2>: - - $x = chr(400); - print "Length is ", length $x, "\n"; # "Length is 1" - printf "Contents are %vd\n", $x; # "Contents are 400" - { - use bytes; # or "require bytes; bytes::length()" - print "Length is ", length $x, "\n"; # "Length is 2" - printf "Contents are %vd\n", $x; # "Contents are 198.144" - } - -chr(), ord(), substr(), index() and rindex() behave similarly. - -For more on the implications and differences between character -semantics and byte semantics, see L<perluniintro> and L<perlunicode>. - -=head1 LIMITATIONS - -bytes::substr() does not work as an lvalue(). - -=head1 SEE ALSO - -L<perluniintro>, L<perlunicode>, L<utf8> - -=cut diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/constant.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/constant.pm deleted file mode 100644 index 159c29978a5..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/constant.pm +++ /dev/null @@ -1,340 +0,0 @@ -package constant; - -use strict; -use 5.006_00; -use warnings::register; - -our($VERSION, %declared); -$VERSION = '1.05'; - -#======================================================================= - -# Some names are evil choices. -my %keywords = map +($_, 1), qw{ BEGIN INIT CHECK END DESTROY AUTOLOAD }; - -my %forced_into_main = map +($_, 1), - qw{ STDIN STDOUT STDERR ARGV ARGVOUT ENV INC SIG }; - -my %forbidden = (%keywords, %forced_into_main); - -#======================================================================= -# import() - import symbols into user's namespace -# -# What we actually do is define a function in the caller's namespace -# which returns the value. The function we create will normally -# be inlined as a constant, thereby avoiding further sub calling -# overhead. -#======================================================================= -sub import { - my $class = shift; - return unless @_; # Ignore 'use constant;' - my %constants = (); - my $multiple = ref $_[0]; - - if ( $multiple ) { - if (ref $_[0] ne 'HASH') { - require Carp; - Carp::croak("Invalid reference type '".ref(shift)."' not 'HASH'"); - } - %constants = %{+shift}; - } else { - $constants{+shift} = undef; - } - - foreach my $name ( keys %constants ) { - unless (defined $name) { - require Carp; - Carp::croak("Can't use undef as constant name"); - } - my $pkg = caller; - - # Normal constant name - if ($name =~ /^_?[^\W_0-9]\w*\z/ and !$forbidden{$name}) { - # Everything is okay - - # Name forced into main, but we're not in main. Fatal. - } elsif ($forced_into_main{$name} and $pkg ne 'main') { - require Carp; - Carp::croak("Constant name '$name' is forced into main::"); - - # Starts with double underscore. Fatal. - } elsif ($name =~ /^__/) { - require Carp; - Carp::croak("Constant name '$name' begins with '__'"); - - # Maybe the name is tolerable - } elsif ($name =~ /^[A-Za-z_]\w*\z/) { - # Then we'll warn only if you've asked for warnings - if (warnings::enabled()) { - if ($keywords{$name}) { - warnings::warn("Constant name '$name' is a Perl keyword"); - } elsif ($forced_into_main{$name}) { - warnings::warn("Constant name '$name' is " . - "forced into package main::"); - } - } - - # Looks like a boolean - # use constant FRED == fred; - } elsif ($name =~ /^[01]?\z/) { - require Carp; - if (@_) { - Carp::croak("Constant name '$name' is invalid"); - } else { - Carp::croak("Constant name looks like boolean value"); - } - - } else { - # Must have bad characters - require Carp; - Carp::croak("Constant name '$name' has invalid characters"); - } - - { - no strict 'refs'; - my $full_name = "${pkg}::$name"; - $declared{$full_name}++; - if ($multiple) { - my $scalar = $constants{$name}; - *$full_name = sub () { $scalar }; - } else { - if (@_ == 1) { - my $scalar = $_[0]; - *$full_name = sub () { $scalar }; - } elsif (@_) { - my @list = @_; - *$full_name = sub () { @list }; - } else { - *$full_name = sub () { }; - } - } - } - } -} - -1; - -__END__ - -=head1 NAME - -constant - Perl pragma to declare constants - -=head1 SYNOPSIS - - use constant PI => 4 * atan2(1, 1); - use constant DEBUG => 0; - - print "Pi equals ", PI, "...\n" if DEBUG; - - use constant { - SEC => 0, - MIN => 1, - HOUR => 2, - MDAY => 3, - MON => 4, - YEAR => 5, - WDAY => 6, - YDAY => 7, - ISDST => 8, - }; - - use constant WEEKDAYS => qw( - Sunday Monday Tuesday Wednesday Thursday Friday Saturday - ); - - print "Today is ", (WEEKDAYS)[ (localtime)[WDAY] ], ".\n"; - -=head1 DESCRIPTION - -This will declare a symbol to be a constant with the given value. - -When you declare a constant such as C<PI> using the method shown -above, each machine your script runs upon can have as many digits -of accuracy as it can use. Also, your program will be easier to -read, more likely to be maintained (and maintained correctly), and -far less likely to send a space probe to the wrong planet because -nobody noticed the one equation in which you wrote C<3.14195>. - -When a constant is used in an expression, perl replaces it with its -value at compile time, and may then optimize the expression further. -In particular, any code in an C<if (CONSTANT)> block will be optimized -away if the constant is false. - -=head1 NOTES - -As with all C<use> directives, defining a constant happens at -compile time. Thus, it's probably not correct to put a constant -declaration inside of a conditional statement (like C<if ($foo) -{ use constant ... }>). - -Constants defined using this module cannot be interpolated into -strings like variables. However, concatenation works just fine: - - print "Pi equals PI...\n"; # WRONG: does not expand "PI" - print "Pi equals ".PI."...\n"; # right - -Even though a reference may be declared as a constant, the reference may -point to data which may be changed, as this code shows. - - use constant ARRAY => [ 1,2,3,4 ]; - print ARRAY->[1]; - ARRAY->[1] = " be changed"; - print ARRAY->[1]; - -Dereferencing constant references incorrectly (such as using an array -subscript on a constant hash reference, or vice versa) will be trapped at -compile time. - -Constants belong to the package they are defined in. To refer to a -constant defined in another package, specify the full package name, as -in C<Some::Package::CONSTANT>. Constants may be exported by modules, -and may also be called as either class or instance methods, that is, -as C<< Some::Package->CONSTANT >> or as C<< $obj->CONSTANT >> where -C<$obj> is an instance of C<Some::Package>. Subclasses may define -their own constants to override those in their base class. - -The use of all caps for constant names is merely a convention, -although it is recommended in order to make constants stand out -and to help avoid collisions with other barewords, keywords, and -subroutine names. Constant names must begin with a letter or -underscore. Names beginning with a double underscore are reserved. Some -poor choices for names will generate warnings, if warnings are enabled at -compile time. - -=head2 List constants - -Constants may be lists of more (or less) than one value. A constant -with no values evaluates to C<undef> in scalar context. Note that -constants with more than one value do I<not> return their last value in -scalar context as one might expect. They currently return the number -of values, but B<this may change in the future>. Do not use constants -with multiple values in scalar context. - -B<NOTE:> This implies that the expression defining the value of a -constant is evaluated in list context. This may produce surprises: - - use constant TIMESTAMP => localtime; # WRONG! - use constant TIMESTAMP => scalar localtime; # right - -The first line above defines C<TIMESTAMP> as a 9-element list, as -returned by localtime() in list context. To set it to the string -returned by localtime() in scalar context, an explicit C<scalar> -keyword is required. - -List constants are lists, not arrays. To index or slice them, they -must be placed in parentheses. - - my @workdays = WEEKDAYS[1 .. 5]; # WRONG! - my @workdays = (WEEKDAYS)[1 .. 5]; # right - -=head2 Defining multiple constants at once - -Instead of writing multiple C<use constant> statements, you may define -multiple constants in a single statement by giving, instead of the -constant name, a reference to a hash where the keys are the names of -the constants to be defined. Obviously, all constants defined using -this method must have a single value. - - use constant { - FOO => "A single value", - BAR => "This", "won't", "work!", # Error! - }; - -This is a fundamental limitation of the way hashes are constructed in -Perl. The error messages produced when this happens will often be -quite cryptic -- in the worst case there may be none at all, and -you'll only later find that something is broken. - -When defining multiple constants, you cannot use the values of other -constants defined in the same declaration. This is because the -calling package doesn't know about any constant within that group -until I<after> the C<use> statement is finished. - - use constant { - BITMASK => 0xAFBAEBA8, - NEGMASK => ~BITMASK, # Error! - }; - -=head2 Magic constants - -Magical values and references can be made into constants at compile -time, allowing for way cool stuff like this. (These error numbers -aren't totally portable, alas.) - - use constant E2BIG => ($! = 7); - print E2BIG, "\n"; # something like "Arg list too long" - print 0+E2BIG, "\n"; # "7" - -You can't produce a tied constant by giving a tied scalar as the -value. References to tied variables, however, can be used as -constants without any problems. - -=head1 TECHNICAL NOTES - -In the current implementation, scalar constants are actually -inlinable subroutines. As of version 5.004 of Perl, the appropriate -scalar constant is inserted directly in place of some subroutine -calls, thereby saving the overhead of a subroutine call. See -L<perlsub/"Constant Functions"> for details about how and when this -happens. - -In the rare case in which you need to discover at run time whether a -particular constant has been declared via this module, you may use -this function to examine the hash C<%constant::declared>. If the given -constant name does not include a package name, the current package is -used. - - sub declared ($) { - use constant 1.01; # don't omit this! - my $name = shift; - $name =~ s/^::/main::/; - my $pkg = caller; - my $full_name = $name =~ /::/ ? $name : "${pkg}::$name"; - $constant::declared{$full_name}; - } - -=head1 BUGS - -In the current version of Perl, list constants are not inlined -and some symbols may be redefined without generating a warning. - -It is not possible to have a subroutine or a keyword with the same -name as a constant in the same package. This is probably a Good Thing. - -A constant with a name in the list C<STDIN STDOUT STDERR ARGV ARGVOUT -ENV INC SIG> is not allowed anywhere but in package C<main::>, for -technical reasons. - -Unlike constants in some languages, these cannot be overridden -on the command line or via environment variables. - -You can get into trouble if you use constants in a context which -automatically quotes barewords (as is true for any subroutine call). -For example, you can't say C<$hash{CONSTANT}> because C<CONSTANT> will -be interpreted as a string. Use C<$hash{CONSTANT()}> or -C<$hash{+CONSTANT}> to prevent the bareword quoting mechanism from -kicking in. Similarly, since the C<< => >> operator quotes a bareword -immediately to its left, you have to say C<< CONSTANT() => 'value' >> -(or simply use a comma in place of the big arrow) instead of -C<< CONSTANT => 'value' >>. - -=head1 AUTHOR - -Tom Phoenix, E<lt>F<rootbeer@redcat.com>E<gt>, with help from -many other folks. - -Multiple constant declarations at once added by Casey West, -E<lt>F<casey@geeknest.com>E<gt>. - -Documentation mostly rewritten by Ilmari Karonen, -E<lt>F<perl@itz.pp.sci.fi>E<gt>. - -=head1 COPYRIGHT - -Copyright (C) 1997, 1999 Tom Phoenix - -This module is free software; you can redistribute it or modify it -under the same terms as Perl itself. - -=cut diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/newgetopt.pl b/Master/tlpkg/lib/Perl5_lib-TL_inst/newgetopt.pl deleted file mode 100644 index 95eef220fe7..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/newgetopt.pl +++ /dev/null @@ -1,75 +0,0 @@ -# $Id: newgetopt.pl,v 1.18 2001-09-21 15:34:59+02 jv Exp $ - -# This library is no longer being maintained, and is included for backward -# compatibility with Perl 4 programs which may require it. -# It is now just a wrapper around the Getopt::Long module. -# -# In particular, this should not be used as an example of modern Perl -# programming techniques. -# -# Suggested alternative: Getopt::Long - -{ package newgetopt; - - # Values for $order. See GNU getopt.c for details. - $REQUIRE_ORDER = 0; - $PERMUTE = 1; - $RETURN_IN_ORDER = 2; - - # Handle POSIX compliancy. - if ( defined $ENV{"POSIXLY_CORRECT"} ) { - $autoabbrev = 0; # no automatic abbrev of options (???) - $getopt_compat = 0; # disallow '+' to start options - $option_start = "(--|-)"; - $order = $REQUIRE_ORDER; - $bundling = 0; - $passthrough = 0; - } - else { - $autoabbrev = 1; # automatic abbrev of options - $getopt_compat = 1; # allow '+' to start options - $option_start = "(--|-|\\+)"; - $order = $PERMUTE; - $bundling = 0; - $passthrough = 0; - } - - # Other configurable settings. - $debug = 0; # for debugging - $ignorecase = 1; # ignore case when matching options - $argv_end = "--"; # don't change this! -} - -use Getopt::Long; - -################ Subroutines ################ - -sub NGetOpt { - - $Getopt::Long::debug = $newgetopt::debug - if defined $newgetopt::debug; - $Getopt::Long::autoabbrev = $newgetopt::autoabbrev - if defined $newgetopt::autoabbrev; - $Getopt::Long::getopt_compat = $newgetopt::getopt_compat - if defined $newgetopt::getopt_compat; - $Getopt::Long::option_start = $newgetopt::option_start - if defined $newgetopt::option_start; - $Getopt::Long::order = $newgetopt::order - if defined $newgetopt::order; - $Getopt::Long::bundling = $newgetopt::bundling - if defined $newgetopt::bundling; - $Getopt::Long::ignorecase = $newgetopt::ignorecase - if defined $newgetopt::ignorecase; - $Getopt::Long::ignorecase = $newgetopt::ignorecase - if defined $newgetopt::ignorecase; - $Getopt::Long::passthrough = $newgetopt::passthrough - if defined $newgetopt::passthrough; - - &GetOptions; -} - -################ Package return ################ - -1; - -################ End of newgetopt.pl ################ diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/overload.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/overload.pm deleted file mode 100644 index 15b7e775e74..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/overload.pm +++ /dev/null @@ -1,1434 +0,0 @@ -package overload; - -our $VERSION = '1.04'; - -$overload::hint_bits = 0x20000; # HINT_LOCALIZE_HH - -sub nil {} - -sub OVERLOAD { - $package = shift; - my %arg = @_; - my ($sub, $fb); - $ {$package . "::OVERLOAD"}{dummy}++; # Register with magic by touching. - *{$package . "::()"} = \&nil; # Make it findable via fetchmethod. - for (keys %arg) { - if ($_ eq 'fallback') { - $fb = $arg{$_}; - } else { - $sub = $arg{$_}; - if (not ref $sub and $sub !~ /::/) { - $ {$package . "::(" . $_} = $sub; - $sub = \&nil; - } - #print STDERR "Setting `$ {'package'}::\cO$_' to \\&`$sub'.\n"; - *{$package . "::(" . $_} = \&{ $sub }; - } - } - ${$package . "::()"} = $fb; # Make it findable too (fallback only). -} - -sub import { - $package = (caller())[0]; - # *{$package . "::OVERLOAD"} = \&OVERLOAD; - shift; - $package->overload::OVERLOAD(@_); -} - -sub unimport { - $package = (caller())[0]; - ${$package . "::OVERLOAD"}{dummy}++; # Upgrade the table - shift; - for (@_) { - if ($_ eq 'fallback') { - undef $ {$package . "::()"}; - } else { - delete $ {$package . "::"}{"(" . $_}; - } - } -} - -sub Overloaded { - my $package = shift; - $package = ref $package if ref $package; - $package->can('()'); -} - -sub ov_method { - my $globref = shift; - return undef unless $globref; - my $sub = \&{*$globref}; - return $sub if $sub ne \&nil; - return shift->can($ {*$globref}); -} - -sub OverloadedStringify { - my $package = shift; - $package = ref $package if ref $package; - #$package->can('(""') - ov_method mycan($package, '(""'), $package - or ov_method mycan($package, '(0+'), $package - or ov_method mycan($package, '(bool'), $package - or ov_method mycan($package, '(nomethod'), $package; -} - -sub Method { - my $package = shift; - $package = ref $package if ref $package; - #my $meth = $package->can('(' . shift); - ov_method mycan($package, '(' . shift), $package; - #return $meth if $meth ne \&nil; - #return $ {*{$meth}}; -} - -sub AddrRef { - my $package = ref $_[0]; - return "$_[0]" unless $package; - - require Scalar::Util; - my $class = Scalar::Util::blessed($_[0]); - my $class_prefix = defined($class) ? "$class=" : ""; - my $type = Scalar::Util::reftype($_[0]); - my $addr = Scalar::Util::refaddr($_[0]); - return sprintf("$class_prefix$type(0x%x)", $addr); -} - -*StrVal = *AddrRef; - -sub mycan { # Real can would leave stubs. - my ($package, $meth) = @_; - return \*{$package . "::$meth"} if defined &{$package . "::$meth"}; - my $p; - foreach $p (@{$package . "::ISA"}) { - my $out = mycan($p, $meth); - return $out if $out; - } - return undef; -} - -%constants = ( - 'integer' => 0x1000, # HINT_NEW_INTEGER - 'float' => 0x2000, # HINT_NEW_FLOAT - 'binary' => 0x4000, # HINT_NEW_BINARY - 'q' => 0x8000, # HINT_NEW_STRING - 'qr' => 0x10000, # HINT_NEW_RE - ); - -%ops = ( with_assign => "+ - * / % ** << >> x .", - assign => "+= -= *= /= %= **= <<= >>= x= .=", - num_comparison => "< <= > >= == !=", - '3way_comparison'=> "<=> cmp", - str_comparison => "lt le gt ge eq ne", - binary => "& | ^", - unary => "neg ! ~", - mutators => '++ --', - func => "atan2 cos sin exp abs log sqrt int", - conversion => 'bool "" 0+', - iterators => '<>', - dereferencing => '${} @{} %{} &{} *{}', - special => 'nomethod fallback ='); - -use warnings::register; -sub constant { - # Arguments: what, sub - while (@_) { - if (@_ == 1) { - warnings::warnif ("Odd number of arguments for overload::constant"); - last; - } - elsif (!exists $constants {$_ [0]}) { - warnings::warnif ("`$_[0]' is not an overloadable type"); - } - elsif (!ref $_ [1] || "$_[1]" !~ /CODE\(0x[\da-f]+\)$/) { - # Can't use C<ref $_[1] eq "CODE"> above as code references can be - # blessed, and C<ref> would return the package the ref is blessed into. - if (warnings::enabled) { - $_ [1] = "undef" unless defined $_ [1]; - warnings::warn ("`$_[1]' is not a code reference"); - } - } - else { - $^H{$_[0]} = $_[1]; - $^H |= $constants{$_[0]} | $overload::hint_bits; - } - shift, shift; - } -} - -sub remove_constant { - # Arguments: what, sub - while (@_) { - delete $^H{$_[0]}; - $^H &= ~ $constants{$_[0]}; - shift, shift; - } -} - -1; - -__END__ - -=head1 NAME - -overload - Package for overloading Perl operations - -=head1 SYNOPSIS - - package SomeThing; - - use overload - '+' => \&myadd, - '-' => \&mysub; - # etc - ... - - package main; - $a = new SomeThing 57; - $b=5+$a; - ... - if (overload::Overloaded $b) {...} - ... - $strval = overload::StrVal $b; - -=head1 DESCRIPTION - -=head2 Declaration of overloaded functions - -The compilation directive - - package Number; - use overload - "+" => \&add, - "*=" => "muas"; - -declares function Number::add() for addition, and method muas() in -the "class" C<Number> (or one of its base classes) -for the assignment form C<*=> of multiplication. - -Arguments of this directive come in (key, value) pairs. Legal values -are values legal inside a C<&{ ... }> call, so the name of a -subroutine, a reference to a subroutine, or an anonymous subroutine -will all work. Note that values specified as strings are -interpreted as methods, not subroutines. Legal keys are listed below. - -The subroutine C<add> will be called to execute C<$a+$b> if $a -is a reference to an object blessed into the package C<Number>, or if $a is -not an object from a package with defined mathemagic addition, but $b is a -reference to a C<Number>. It can also be called in other situations, like -C<$a+=7>, or C<$a++>. See L<MAGIC AUTOGENERATION>. (Mathemagical -methods refer to methods triggered by an overloaded mathematical -operator.) - -Since overloading respects inheritance via the @ISA hierarchy, the -above declaration would also trigger overloading of C<+> and C<*=> in -all the packages which inherit from C<Number>. - -=head2 Calling Conventions for Binary Operations - -The functions specified in the C<use overload ...> directive are called -with three (in one particular case with four, see L<Last Resort>) -arguments. If the corresponding operation is binary, then the first -two arguments are the two arguments of the operation. However, due to -general object calling conventions, the first argument should always be -an object in the package, so in the situation of C<7+$a>, the -order of the arguments is interchanged. It probably does not matter -when implementing the addition method, but whether the arguments -are reversed is vital to the subtraction method. The method can -query this information by examining the third argument, which can take -three different values: - -=over 7 - -=item FALSE - -the order of arguments is as in the current operation. - -=item TRUE - -the arguments are reversed. - -=item C<undef> - -the current operation is an assignment variant (as in -C<$a+=7>), but the usual function is called instead. This additional -information can be used to generate some optimizations. Compare -L<Calling Conventions for Mutators>. - -=back - -=head2 Calling Conventions for Unary Operations - -Unary operation are considered binary operations with the second -argument being C<undef>. Thus the functions that overloads C<{"++"}> -is called with arguments C<($a,undef,'')> when $a++ is executed. - -=head2 Calling Conventions for Mutators - -Two types of mutators have different calling conventions: - -=over - -=item C<++> and C<--> - -The routines which implement these operators are expected to actually -I<mutate> their arguments. So, assuming that $obj is a reference to a -number, - - sub incr { my $n = $ {$_[0]}; ++$n; $_[0] = bless \$n} - -is an appropriate implementation of overloaded C<++>. Note that - - sub incr { ++$ {$_[0]} ; shift } - -is OK if used with preincrement and with postincrement. (In the case -of postincrement a copying will be performed, see L<Copy Constructor>.) - -=item C<x=> and other assignment versions - -There is nothing special about these methods. They may change the -value of their arguments, and may leave it as is. The result is going -to be assigned to the value in the left-hand-side if different from -this value. - -This allows for the same method to be used as overloaded C<+=> and -C<+>. Note that this is I<allowed>, but not recommended, since by the -semantic of L<"Fallback"> Perl will call the method for C<+> anyway, -if C<+=> is not overloaded. - -=back - -B<Warning.> Due to the presence of assignment versions of operations, -routines which may be called in assignment context may create -self-referential structures. Currently Perl will not free self-referential -structures until cycles are C<explicitly> broken. You may get problems -when traversing your structures too. - -Say, - - use overload '+' => sub { bless [ \$_[0], \$_[1] ] }; - -is asking for trouble, since for code C<$obj += $foo> the subroutine -is called as C<$obj = add($obj, $foo, undef)>, or C<$obj = [\$obj, -\$foo]>. If using such a subroutine is an important optimization, one -can overload C<+=> explicitly by a non-"optimized" version, or switch -to non-optimized version if C<not defined $_[2]> (see -L<Calling Conventions for Binary Operations>). - -Even if no I<explicit> assignment-variants of operators are present in -the script, they may be generated by the optimizer. Say, C<",$obj,"> or -C<',' . $obj . ','> may be both optimized to - - my $tmp = ',' . $obj; $tmp .= ','; - -=head2 Overloadable Operations - -The following symbols can be specified in C<use overload> directive: - -=over 5 - -=item * I<Arithmetic operations> - - "+", "+=", "-", "-=", "*", "*=", "/", "/=", "%", "%=", - "**", "**=", "<<", "<<=", ">>", ">>=", "x", "x=", ".", ".=", - -For these operations a substituted non-assignment variant can be called if -the assignment variant is not available. Methods for operations C<+>, -C<->, C<+=>, and C<-=> can be called to automatically generate -increment and decrement methods. The operation C<-> can be used to -autogenerate missing methods for unary minus or C<abs>. - -See L<"MAGIC AUTOGENERATION">, L<"Calling Conventions for Mutators"> and -L<"Calling Conventions for Binary Operations">) for details of these -substitutions. - -=item * I<Comparison operations> - - "<", "<=", ">", ">=", "==", "!=", "<=>", - "lt", "le", "gt", "ge", "eq", "ne", "cmp", - -If the corresponding "spaceship" variant is available, it can be -used to substitute for the missing operation. During C<sort>ing -arrays, C<cmp> is used to compare values subject to C<use overload>. - -=item * I<Bit operations> - - "&", "^", "|", "neg", "!", "~", - -C<neg> stands for unary minus. If the method for C<neg> is not -specified, it can be autogenerated using the method for -subtraction. If the method for C<!> is not specified, it can be -autogenerated using the methods for C<bool>, or C<"">, or C<0+>. - -=item * I<Increment and decrement> - - "++", "--", - -If undefined, addition and subtraction methods can be -used instead. These operations are called both in prefix and -postfix form. - -=item * I<Transcendental functions> - - "atan2", "cos", "sin", "exp", "abs", "log", "sqrt", "int" - -If C<abs> is unavailable, it can be autogenerated using methods -for "E<lt>" or "E<lt>=E<gt>" combined with either unary minus or subtraction. - -Note that traditionally the Perl function L<int> rounds to 0, thus for -floating-point-like types one should follow the same semantic. If -C<int> is unavailable, it can be autogenerated using the overloading of -C<0+>. - -=item * I<Boolean, string and numeric conversion> - - 'bool', '""', '0+', - -If one or two of these operations are not overloaded, the remaining ones can -be used instead. C<bool> is used in the flow control operators -(like C<while>) and for the ternary C<?:> operation. These functions can -return any arbitrary Perl value. If the corresponding operation for this value -is overloaded too, that operation will be called again with this value. - -As a special case if the overload returns the object itself then it will -be used directly. An overloaded conversion returning the object is -probably a bug, because you're likely to get something that looks like -C<YourPackage=HASH(0x8172b34)>. - -=item * I<Iteration> - - "<>" - -If not overloaded, the argument will be converted to a filehandle or -glob (which may require a stringification). The same overloading -happens both for the I<read-filehandle> syntax C<E<lt>$varE<gt>> and -I<globbing> syntax C<E<lt>${var}E<gt>>. - -B<BUGS> Even in list context, the iterator is currently called only -once and with scalar context. - -=item * I<Dereferencing> - - '${}', '@{}', '%{}', '&{}', '*{}'. - -If not overloaded, the argument will be dereferenced I<as is>, thus -should be of correct type. These functions should return a reference -of correct type, or another object with overloaded dereferencing. - -As a special case if the overload returns the object itself then it -will be used directly (provided it is the correct type). - -The dereference operators must be specified explicitly they will not be passed to -"nomethod". - -=item * I<Special> - - "nomethod", "fallback", "=", - -see L<SPECIAL SYMBOLS FOR C<use overload>>. - -=back - -See L<"Fallback"> for an explanation of when a missing method can be -autogenerated. - -A computer-readable form of the above table is available in the hash -%overload::ops, with values being space-separated lists of names: - - with_assign => '+ - * / % ** << >> x .', - assign => '+= -= *= /= %= **= <<= >>= x= .=', - num_comparison => '< <= > >= == !=', - '3way_comparison'=> '<=> cmp', - str_comparison => 'lt le gt ge eq ne', - binary => '& | ^', - unary => 'neg ! ~', - mutators => '++ --', - func => 'atan2 cos sin exp abs log sqrt', - conversion => 'bool "" 0+', - iterators => '<>', - dereferencing => '${} @{} %{} &{} *{}', - special => 'nomethod fallback =' - -=head2 Inheritance and overloading - -Inheritance interacts with overloading in two ways. - -=over - -=item Strings as values of C<use overload> directive - -If C<value> in - - use overload key => value; - -is a string, it is interpreted as a method name. - -=item Overloading of an operation is inherited by derived classes - -Any class derived from an overloaded class is also overloaded. The -set of overloaded methods is the union of overloaded methods of all -the ancestors. If some method is overloaded in several ancestor, then -which description will be used is decided by the usual inheritance -rules: - -If C<A> inherits from C<B> and C<C> (in this order), C<B> overloads -C<+> with C<\&D::plus_sub>, and C<C> overloads C<+> by C<"plus_meth">, -then the subroutine C<D::plus_sub> will be called to implement -operation C<+> for an object in package C<A>. - -=back - -Note that since the value of the C<fallback> key is not a subroutine, -its inheritance is not governed by the above rules. In the current -implementation, the value of C<fallback> in the first overloaded -ancestor is used, but this is accidental and subject to change. - -=head1 SPECIAL SYMBOLS FOR C<use overload> - -Three keys are recognized by Perl that are not covered by the above -description. - -=head2 Last Resort - -C<"nomethod"> should be followed by a reference to a function of four -parameters. If defined, it is called when the overloading mechanism -cannot find a method for some operation. The first three arguments of -this function coincide with the arguments for the corresponding method if -it were found, the fourth argument is the symbol -corresponding to the missing method. If several methods are tried, -the last one is used. Say, C<1-$a> can be equivalent to - - &nomethodMethod($a,1,1,"-") - -if the pair C<"nomethod" =E<gt> "nomethodMethod"> was specified in the -C<use overload> directive. - -The C<"nomethod"> mechanism is I<not> used for the dereference operators -( ${} @{} %{} &{} *{} ). - - -If some operation cannot be resolved, and there is no function -assigned to C<"nomethod">, then an exception will be raised via die()-- -unless C<"fallback"> was specified as a key in C<use overload> directive. - - -=head2 Fallback - -The key C<"fallback"> governs what to do if a method for a particular -operation is not found. Three different cases are possible depending on -the value of C<"fallback">: - -=over 16 - -=item * C<undef> - -Perl tries to use a -substituted method (see L<MAGIC AUTOGENERATION>). If this fails, it -then tries to calls C<"nomethod"> value; if missing, an exception -will be raised. - -=item * TRUE - -The same as for the C<undef> value, but no exception is raised. Instead, -it silently reverts to what it would have done were there no C<use overload> -present. - -=item * defined, but FALSE - -No autogeneration is tried. Perl tries to call -C<"nomethod"> value, and if this is missing, raises an exception. - -=back - -B<Note.> C<"fallback"> inheritance via @ISA is not carved in stone -yet, see L<"Inheritance and overloading">. - -=head2 Copy Constructor - -The value for C<"="> is a reference to a function with three -arguments, i.e., it looks like the other values in C<use -overload>. However, it does not overload the Perl assignment -operator. This would go against Camel hair. - -This operation is called in the situations when a mutator is applied -to a reference that shares its object with some other reference, such -as - - $a=$b; - ++$a; - -To make this change $a and not change $b, a copy of C<$$a> is made, -and $a is assigned a reference to this new object. This operation is -done during execution of the C<++$a>, and not during the assignment, -(so before the increment C<$$a> coincides with C<$$b>). This is only -done if C<++> is expressed via a method for C<'++'> or C<'+='> (or -C<nomethod>). Note that if this operation is expressed via C<'+'> -a nonmutator, i.e., as in - - $a=$b; - $a=$a+1; - -then C<$a> does not reference a new copy of C<$$a>, since $$a does not -appear as lvalue when the above code is executed. - -If the copy constructor is required during the execution of some mutator, -but a method for C<'='> was not specified, it can be autogenerated as a -string copy if the object is a plain scalar. - -=over 5 - -=item B<Example> - -The actually executed code for - - $a=$b; - Something else which does not modify $a or $b.... - ++$a; - -may be - - $a=$b; - Something else which does not modify $a or $b.... - $a = $a->clone(undef,""); - $a->incr(undef,""); - -if $b was mathemagical, and C<'++'> was overloaded with C<\&incr>, -C<'='> was overloaded with C<\&clone>. - -=back - -Same behaviour is triggered by C<$b = $a++>, which is consider a synonym for -C<$b = $a; ++$a>. - -=head1 MAGIC AUTOGENERATION - -If a method for an operation is not found, and the value for C<"fallback"> is -TRUE or undefined, Perl tries to autogenerate a substitute method for -the missing operation based on the defined operations. Autogenerated method -substitutions are possible for the following operations: - -=over 16 - -=item I<Assignment forms of arithmetic operations> - -C<$a+=$b> can use the method for C<"+"> if the method for C<"+="> -is not defined. - -=item I<Conversion operations> - -String, numeric, and boolean conversion are calculated in terms of one -another if not all of them are defined. - -=item I<Increment and decrement> - -The C<++$a> operation can be expressed in terms of C<$a+=1> or C<$a+1>, -and C<$a--> in terms of C<$a-=1> and C<$a-1>. - -=item C<abs($a)> - -can be expressed in terms of C<$aE<lt>0> and C<-$a> (or C<0-$a>). - -=item I<Unary minus> - -can be expressed in terms of subtraction. - -=item I<Negation> - -C<!> and C<not> can be expressed in terms of boolean conversion, or -string or numerical conversion. - -=item I<Concatenation> - -can be expressed in terms of string conversion. - -=item I<Comparison operations> - -can be expressed in terms of its "spaceship" counterpart: either -C<E<lt>=E<gt>> or C<cmp>: - - <, >, <=, >=, ==, != in terms of <=> - lt, gt, le, ge, eq, ne in terms of cmp - -=item I<Iterator> - - <> in terms of builtin operations - -=item I<Dereferencing> - - ${} @{} %{} &{} *{} in terms of builtin operations - -=item I<Copy operator> - -can be expressed in terms of an assignment to the dereferenced value, if this -value is a scalar and not a reference. - -=back - -=head1 Losing overloading - -The restriction for the comparison operation is that even if, for example, -`C<cmp>' should return a blessed reference, the autogenerated `C<lt>' -function will produce only a standard logical value based on the -numerical value of the result of `C<cmp>'. In particular, a working -numeric conversion is needed in this case (possibly expressed in terms of -other conversions). - -Similarly, C<.=> and C<x=> operators lose their mathemagical properties -if the string conversion substitution is applied. - -When you chop() a mathemagical object it is promoted to a string and its -mathemagical properties are lost. The same can happen with other -operations as well. - -=head1 Run-time Overloading - -Since all C<use> directives are executed at compile-time, the only way to -change overloading during run-time is to - - eval 'use overload "+" => \&addmethod'; - -You can also use - - eval 'no overload "+", "--", "<="'; - -though the use of these constructs during run-time is questionable. - -=head1 Public functions - -Package C<overload.pm> provides the following public functions: - -=over 5 - -=item overload::StrVal(arg) - -Gives string value of C<arg> as in absence of stringify overloading. If you -are using this to get the address of a reference (useful for checking if two -references point to the same thing) then you may be better off using -C<Scalar::Util::refaddr()>, which is faster. - -=item overload::Overloaded(arg) - -Returns true if C<arg> is subject to overloading of some operations. - -=item overload::Method(obj,op) - -Returns C<undef> or a reference to the method that implements C<op>. - -=back - -=head1 Overloading constants - -For some applications, the Perl parser mangles constants too much. -It is possible to hook into this process via C<overload::constant()> -and C<overload::remove_constant()> functions. - -These functions take a hash as an argument. The recognized keys of this hash -are: - -=over 8 - -=item integer - -to overload integer constants, - -=item float - -to overload floating point constants, - -=item binary - -to overload octal and hexadecimal constants, - -=item q - -to overload C<q>-quoted strings, constant pieces of C<qq>- and C<qx>-quoted -strings and here-documents, - -=item qr - -to overload constant pieces of regular expressions. - -=back - -The corresponding values are references to functions which take three arguments: -the first one is the I<initial> string form of the constant, the second one -is how Perl interprets this constant, the third one is how the constant is used. -Note that the initial string form does not -contain string delimiters, and has backslashes in backslash-delimiter -combinations stripped (thus the value of delimiter is not relevant for -processing of this string). The return value of this function is how this -constant is going to be interpreted by Perl. The third argument is undefined -unless for overloaded C<q>- and C<qr>- constants, it is C<q> in single-quote -context (comes from strings, regular expressions, and single-quote HERE -documents), it is C<tr> for arguments of C<tr>/C<y> operators, -it is C<s> for right-hand side of C<s>-operator, and it is C<qq> otherwise. - -Since an expression C<"ab$cd,,"> is just a shortcut for C<'ab' . $cd . ',,'>, -it is expected that overloaded constant strings are equipped with reasonable -overloaded catenation operator, otherwise absurd results will result. -Similarly, negative numbers are considered as negations of positive constants. - -Note that it is probably meaningless to call the functions overload::constant() -and overload::remove_constant() from anywhere but import() and unimport() methods. -From these methods they may be called as - - sub import { - shift; - return unless @_; - die "unknown import: @_" unless @_ == 1 and $_[0] eq ':constant'; - overload::constant integer => sub {Math::BigInt->new(shift)}; - } - -B<BUGS> Currently overloaded-ness of constants does not propagate -into C<eval '...'>. - -=head1 IMPLEMENTATION - -What follows is subject to change RSN. - -The table of methods for all operations is cached in magic for the -symbol table hash for the package. The cache is invalidated during -processing of C<use overload>, C<no overload>, new function -definitions, and changes in @ISA. However, this invalidation remains -unprocessed until the next C<bless>ing into the package. Hence if you -want to change overloading structure dynamically, you'll need an -additional (fake) C<bless>ing to update the table. - -(Every SVish thing has a magic queue, and magic is an entry in that -queue. This is how a single variable may participate in multiple -forms of magic simultaneously. For instance, environment variables -regularly have two forms at once: their %ENV magic and their taint -magic. However, the magic which implements overloading is applied to -the stashes, which are rarely used directly, thus should not slow down -Perl.) - -If an object belongs to a package using overload, it carries a special -flag. Thus the only speed penalty during arithmetic operations without -overloading is the checking of this flag. - -In fact, if C<use overload> is not present, there is almost no overhead -for overloadable operations, so most programs should not suffer -measurable performance penalties. A considerable effort was made to -minimize the overhead when overload is used in some package, but the -arguments in question do not belong to packages using overload. When -in doubt, test your speed with C<use overload> and without it. So far -there have been no reports of substantial speed degradation if Perl is -compiled with optimization turned on. - -There is no size penalty for data if overload is not used. The only -size penalty if overload is used in some package is that I<all> the -packages acquire a magic during the next C<bless>ing into the -package. This magic is three-words-long for packages without -overloading, and carries the cache table if the package is overloaded. - -Copying (C<$a=$b>) is shallow; however, a one-level-deep copying is -carried out before any operation that can imply an assignment to the -object $a (or $b) refers to, like C<$a++>. You can override this -behavior by defining your own copy constructor (see L<"Copy Constructor">). - -It is expected that arguments to methods that are not explicitly supposed -to be changed are constant (but this is not enforced). - -=head1 Metaphor clash - -One may wonder why the semantic of overloaded C<=> is so counter intuitive. -If it I<looks> counter intuitive to you, you are subject to a metaphor -clash. - -Here is a Perl object metaphor: - -I< object is a reference to blessed data> - -and an arithmetic metaphor: - -I< object is a thing by itself>. - -The I<main> problem of overloading C<=> is the fact that these metaphors -imply different actions on the assignment C<$a = $b> if $a and $b are -objects. Perl-think implies that $a becomes a reference to whatever -$b was referencing. Arithmetic-think implies that the value of "object" -$a is changed to become the value of the object $b, preserving the fact -that $a and $b are separate entities. - -The difference is not relevant in the absence of mutators. After -a Perl-way assignment an operation which mutates the data referenced by $a -would change the data referenced by $b too. Effectively, after -C<$a = $b> values of $a and $b become I<indistinguishable>. - -On the other hand, anyone who has used algebraic notation knows the -expressive power of the arithmetic metaphor. Overloading works hard -to enable this metaphor while preserving the Perlian way as far as -possible. Since it is not possible to freely mix two contradicting -metaphors, overloading allows the arithmetic way to write things I<as -far as all the mutators are called via overloaded access only>. The -way it is done is described in L<Copy Constructor>. - -If some mutator methods are directly applied to the overloaded values, -one may need to I<explicitly unlink> other values which references the -same value: - - $a = new Data 23; - ... - $b = $a; # $b is "linked" to $a - ... - $a = $a->clone; # Unlink $b from $a - $a->increment_by(4); - -Note that overloaded access makes this transparent: - - $a = new Data 23; - $b = $a; # $b is "linked" to $a - $a += 4; # would unlink $b automagically - -However, it would not make - - $a = new Data 23; - $a = 4; # Now $a is a plain 4, not 'Data' - -preserve "objectness" of $a. But Perl I<has> a way to make assignments -to an object do whatever you want. It is just not the overload, but -tie()ing interface (see L<perlfunc/tie>). Adding a FETCH() method -which returns the object itself, and STORE() method which changes the -value of the object, one can reproduce the arithmetic metaphor in its -completeness, at least for variables which were tie()d from the start. - -(Note that a workaround for a bug may be needed, see L<"BUGS">.) - -=head1 Cookbook - -Please add examples to what follows! - -=head2 Two-face scalars - -Put this in F<two_face.pm> in your Perl library directory: - - package two_face; # Scalars with separate string and - # numeric values. - sub new { my $p = shift; bless [@_], $p } - use overload '""' => \&str, '0+' => \&num, fallback => 1; - sub num {shift->[1]} - sub str {shift->[0]} - -Use it as follows: - - require two_face; - my $seven = new two_face ("vii", 7); - printf "seven=$seven, seven=%d, eight=%d\n", $seven, $seven+1; - print "seven contains `i'\n" if $seven =~ /i/; - -(The second line creates a scalar which has both a string value, and a -numeric value.) This prints: - - seven=vii, seven=7, eight=8 - seven contains `i' - -=head2 Two-face references - -Suppose you want to create an object which is accessible as both an -array reference and a hash reference, similar to the -L<pseudo-hash|perlref/"Pseudo-hashes: Using an array as a hash"> -builtin Perl type. Let's make it better than a pseudo-hash by -allowing index 0 to be treated as a normal element. - - package two_refs; - use overload '%{}' => \&gethash, '@{}' => sub { $ {shift()} }; - sub new { - my $p = shift; - bless \ [@_], $p; - } - sub gethash { - my %h; - my $self = shift; - tie %h, ref $self, $self; - \%h; - } - - sub TIEHASH { my $p = shift; bless \ shift, $p } - my %fields; - my $i = 0; - $fields{$_} = $i++ foreach qw{zero one two three}; - sub STORE { - my $self = ${shift()}; - my $key = $fields{shift()}; - defined $key or die "Out of band access"; - $$self->[$key] = shift; - } - sub FETCH { - my $self = ${shift()}; - my $key = $fields{shift()}; - defined $key or die "Out of band access"; - $$self->[$key]; - } - -Now one can access an object using both the array and hash syntax: - - my $bar = new two_refs 3,4,5,6; - $bar->[2] = 11; - $bar->{two} == 11 or die 'bad hash fetch'; - -Note several important features of this example. First of all, the -I<actual> type of $bar is a scalar reference, and we do not overload -the scalar dereference. Thus we can get the I<actual> non-overloaded -contents of $bar by just using C<$$bar> (what we do in functions which -overload dereference). Similarly, the object returned by the -TIEHASH() method is a scalar reference. - -Second, we create a new tied hash each time the hash syntax is used. -This allows us not to worry about a possibility of a reference loop, -which would lead to a memory leak. - -Both these problems can be cured. Say, if we want to overload hash -dereference on a reference to an object which is I<implemented> as a -hash itself, the only problem one has to circumvent is how to access -this I<actual> hash (as opposed to the I<virtual> hash exhibited by the -overloaded dereference operator). Here is one possible fetching routine: - - sub access_hash { - my ($self, $key) = (shift, shift); - my $class = ref $self; - bless $self, 'overload::dummy'; # Disable overloading of %{} - my $out = $self->{$key}; - bless $self, $class; # Restore overloading - $out; - } - -To remove creation of the tied hash on each access, one may an extra -level of indirection which allows a non-circular structure of references: - - package two_refs1; - use overload '%{}' => sub { ${shift()}->[1] }, - '@{}' => sub { ${shift()}->[0] }; - sub new { - my $p = shift; - my $a = [@_]; - my %h; - tie %h, $p, $a; - bless \ [$a, \%h], $p; - } - sub gethash { - my %h; - my $self = shift; - tie %h, ref $self, $self; - \%h; - } - - sub TIEHASH { my $p = shift; bless \ shift, $p } - my %fields; - my $i = 0; - $fields{$_} = $i++ foreach qw{zero one two three}; - sub STORE { - my $a = ${shift()}; - my $key = $fields{shift()}; - defined $key or die "Out of band access"; - $a->[$key] = shift; - } - sub FETCH { - my $a = ${shift()}; - my $key = $fields{shift()}; - defined $key or die "Out of band access"; - $a->[$key]; - } - -Now if $baz is overloaded like this, then C<$baz> is a reference to a -reference to the intermediate array, which keeps a reference to an -actual array, and the access hash. The tie()ing object for the access -hash is a reference to a reference to the actual array, so - -=over - -=item * - -There are no loops of references. - -=item * - -Both "objects" which are blessed into the class C<two_refs1> are -references to a reference to an array, thus references to a I<scalar>. -Thus the accessor expression C<$$foo-E<gt>[$ind]> involves no -overloaded operations. - -=back - -=head2 Symbolic calculator - -Put this in F<symbolic.pm> in your Perl library directory: - - package symbolic; # Primitive symbolic calculator - use overload nomethod => \&wrap; - - sub new { shift; bless ['n', @_] } - sub wrap { - my ($obj, $other, $inv, $meth) = @_; - ($obj, $other) = ($other, $obj) if $inv; - bless [$meth, $obj, $other]; - } - -This module is very unusual as overloaded modules go: it does not -provide any usual overloaded operators, instead it provides the L<Last -Resort> operator C<nomethod>. In this example the corresponding -subroutine returns an object which encapsulates operations done over -the objects: C<new symbolic 3> contains C<['n', 3]>, C<2 + new -symbolic 3> contains C<['+', 2, ['n', 3]]>. - -Here is an example of the script which "calculates" the side of -circumscribed octagon using the above package: - - require symbolic; - my $iter = 1; # 2**($iter+2) = 8 - my $side = new symbolic 1; - my $cnt = $iter; - - while ($cnt--) { - $side = (sqrt(1 + $side**2) - 1)/$side; - } - print "OK\n"; - -The value of $side is - - ['/', ['-', ['sqrt', ['+', 1, ['**', ['n', 1], 2]], - undef], 1], ['n', 1]] - -Note that while we obtained this value using a nice little script, -there is no simple way to I<use> this value. In fact this value may -be inspected in debugger (see L<perldebug>), but ony if -C<bareStringify> B<O>ption is set, and not via C<p> command. - -If one attempts to print this value, then the overloaded operator -C<""> will be called, which will call C<nomethod> operator. The -result of this operator will be stringified again, but this result is -again of type C<symbolic>, which will lead to an infinite loop. - -Add a pretty-printer method to the module F<symbolic.pm>: - - sub pretty { - my ($meth, $a, $b) = @{+shift}; - $a = 'u' unless defined $a; - $b = 'u' unless defined $b; - $a = $a->pretty if ref $a; - $b = $b->pretty if ref $b; - "[$meth $a $b]"; - } - -Now one can finish the script by - - print "side = ", $side->pretty, "\n"; - -The method C<pretty> is doing object-to-string conversion, so it -is natural to overload the operator C<""> using this method. However, -inside such a method it is not necessary to pretty-print the -I<components> $a and $b of an object. In the above subroutine -C<"[$meth $a $b]"> is a catenation of some strings and components $a -and $b. If these components use overloading, the catenation operator -will look for an overloaded operator C<.>; if not present, it will -look for an overloaded operator C<"">. Thus it is enough to use - - use overload nomethod => \&wrap, '""' => \&str; - sub str { - my ($meth, $a, $b) = @{+shift}; - $a = 'u' unless defined $a; - $b = 'u' unless defined $b; - "[$meth $a $b]"; - } - -Now one can change the last line of the script to - - print "side = $side\n"; - -which outputs - - side = [/ [- [sqrt [+ 1 [** [n 1 u] 2]] u] 1] [n 1 u]] - -and one can inspect the value in debugger using all the possible -methods. - -Something is still amiss: consider the loop variable $cnt of the -script. It was a number, not an object. We cannot make this value of -type C<symbolic>, since then the loop will not terminate. - -Indeed, to terminate the cycle, the $cnt should become false. -However, the operator C<bool> for checking falsity is overloaded (this -time via overloaded C<"">), and returns a long string, thus any object -of type C<symbolic> is true. To overcome this, we need a way to -compare an object to 0. In fact, it is easier to write a numeric -conversion routine. - -Here is the text of F<symbolic.pm> with such a routine added (and -slightly modified str()): - - package symbolic; # Primitive symbolic calculator - use overload - nomethod => \&wrap, '""' => \&str, '0+' => \# - - sub new { shift; bless ['n', @_] } - sub wrap { - my ($obj, $other, $inv, $meth) = @_; - ($obj, $other) = ($other, $obj) if $inv; - bless [$meth, $obj, $other]; - } - sub str { - my ($meth, $a, $b) = @{+shift}; - $a = 'u' unless defined $a; - if (defined $b) { - "[$meth $a $b]"; - } else { - "[$meth $a]"; - } - } - my %subr = ( n => sub {$_[0]}, - sqrt => sub {sqrt $_[0]}, - '-' => sub {shift() - shift()}, - '+' => sub {shift() + shift()}, - '/' => sub {shift() / shift()}, - '*' => sub {shift() * shift()}, - '**' => sub {shift() ** shift()}, - ); - sub num { - my ($meth, $a, $b) = @{+shift}; - my $subr = $subr{$meth} - or die "Do not know how to ($meth) in symbolic"; - $a = $a->num if ref $a eq __PACKAGE__; - $b = $b->num if ref $b eq __PACKAGE__; - $subr->($a,$b); - } - -All the work of numeric conversion is done in %subr and num(). Of -course, %subr is not complete, it contains only operators used in the -example below. Here is the extra-credit question: why do we need an -explicit recursion in num()? (Answer is at the end of this section.) - -Use this module like this: - - require symbolic; - my $iter = new symbolic 2; # 16-gon - my $side = new symbolic 1; - my $cnt = $iter; - - while ($cnt) { - $cnt = $cnt - 1; # Mutator `--' not implemented - $side = (sqrt(1 + $side**2) - 1)/$side; - } - printf "%s=%f\n", $side, $side; - printf "pi=%f\n", $side*(2**($iter+2)); - -It prints (without so many line breaks) - - [/ [- [sqrt [+ 1 [** [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] - [n 1]] 2]]] 1] - [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]]]=0.198912 - pi=3.182598 - -The above module is very primitive. It does not implement -mutator methods (C<++>, C<-=> and so on), does not do deep copying -(not required without mutators!), and implements only those arithmetic -operations which are used in the example. - -To implement most arithmetic operations is easy; one should just use -the tables of operations, and change the code which fills %subr to - - my %subr = ( 'n' => sub {$_[0]} ); - foreach my $op (split " ", $overload::ops{with_assign}) { - $subr{$op} = $subr{"$op="} = eval "sub {shift() $op shift()}"; - } - my @bins = qw(binary 3way_comparison num_comparison str_comparison); - foreach my $op (split " ", "@overload::ops{ @bins }") { - $subr{$op} = eval "sub {shift() $op shift()}"; - } - foreach my $op (split " ", "@overload::ops{qw(unary func)}") { - print "defining `$op'\n"; - $subr{$op} = eval "sub {$op shift()}"; - } - -Due to L<Calling Conventions for Mutators>, we do not need anything -special to make C<+=> and friends work, except filling C<+=> entry of -%subr, and defining a copy constructor (needed since Perl has no -way to know that the implementation of C<'+='> does not mutate -the argument, compare L<Copy Constructor>). - -To implement a copy constructor, add C<< '=' => \&cpy >> to C<use overload> -line, and code (this code assumes that mutators change things one level -deep only, so recursive copying is not needed): - - sub cpy { - my $self = shift; - bless [@$self], ref $self; - } - -To make C<++> and C<--> work, we need to implement actual mutators, -either directly, or in C<nomethod>. We continue to do things inside -C<nomethod>, thus add - - if ($meth eq '++' or $meth eq '--') { - @$obj = ($meth, (bless [@$obj]), 1); # Avoid circular reference - return $obj; - } - -after the first line of wrap(). This is not a most effective -implementation, one may consider - - sub inc { $_[0] = bless ['++', shift, 1]; } - -instead. - -As a final remark, note that one can fill %subr by - - my %subr = ( 'n' => sub {$_[0]} ); - foreach my $op (split " ", $overload::ops{with_assign}) { - $subr{$op} = $subr{"$op="} = eval "sub {shift() $op shift()}"; - } - my @bins = qw(binary 3way_comparison num_comparison str_comparison); - foreach my $op (split " ", "@overload::ops{ @bins }") { - $subr{$op} = eval "sub {shift() $op shift()}"; - } - foreach my $op (split " ", "@overload::ops{qw(unary func)}") { - $subr{$op} = eval "sub {$op shift()}"; - } - $subr{'++'} = $subr{'+'}; - $subr{'--'} = $subr{'-'}; - -This finishes implementation of a primitive symbolic calculator in -50 lines of Perl code. Since the numeric values of subexpressions -are not cached, the calculator is very slow. - -Here is the answer for the exercise: In the case of str(), we need no -explicit recursion since the overloaded C<.>-operator will fall back -to an existing overloaded operator C<"">. Overloaded arithmetic -operators I<do not> fall back to numeric conversion if C<fallback> is -not explicitly requested. Thus without an explicit recursion num() -would convert C<['+', $a, $b]> to C<$a + $b>, which would just rebuild -the argument of num(). - -If you wonder why defaults for conversion are different for str() and -num(), note how easy it was to write the symbolic calculator. This -simplicity is due to an appropriate choice of defaults. One extra -note: due to the explicit recursion num() is more fragile than sym(): -we need to explicitly check for the type of $a and $b. If components -$a and $b happen to be of some related type, this may lead to problems. - -=head2 I<Really> symbolic calculator - -One may wonder why we call the above calculator symbolic. The reason -is that the actual calculation of the value of expression is postponed -until the value is I<used>. - -To see it in action, add a method - - sub STORE { - my $obj = shift; - $#$obj = 1; - @$obj->[0,1] = ('=', shift); - } - -to the package C<symbolic>. After this change one can do - - my $a = new symbolic 3; - my $b = new symbolic 4; - my $c = sqrt($a**2 + $b**2); - -and the numeric value of $c becomes 5. However, after calling - - $a->STORE(12); $b->STORE(5); - -the numeric value of $c becomes 13. There is no doubt now that the module -symbolic provides a I<symbolic> calculator indeed. - -To hide the rough edges under the hood, provide a tie()d interface to the -package C<symbolic> (compare with L<Metaphor clash>). Add methods - - sub TIESCALAR { my $pack = shift; $pack->new(@_) } - sub FETCH { shift } - sub nop { } # Around a bug - -(the bug is described in L<"BUGS">). One can use this new interface as - - tie $a, 'symbolic', 3; - tie $b, 'symbolic', 4; - $a->nop; $b->nop; # Around a bug - - my $c = sqrt($a**2 + $b**2); - -Now numeric value of $c is 5. After C<$a = 12; $b = 5> the numeric value -of $c becomes 13. To insulate the user of the module add a method - - sub vars { my $p = shift; tie($_, $p), $_->nop foreach @_; } - -Now - - my ($a, $b); - symbolic->vars($a, $b); - my $c = sqrt($a**2 + $b**2); - - $a = 3; $b = 4; - printf "c5 %s=%f\n", $c, $c; - - $a = 12; $b = 5; - printf "c13 %s=%f\n", $c, $c; - -shows that the numeric value of $c follows changes to the values of $a -and $b. - -=head1 AUTHOR - -Ilya Zakharevich E<lt>F<ilya@math.mps.ohio-state.edu>E<gt>. - -=head1 DIAGNOSTICS - -When Perl is run with the B<-Do> switch or its equivalent, overloading -induces diagnostic messages. - -Using the C<m> command of Perl debugger (see L<perldebug>) one can -deduce which operations are overloaded (and which ancestor triggers -this overloading). Say, if C<eq> is overloaded, then the method C<(eq> -is shown by debugger. The method C<()> corresponds to the C<fallback> -key (in fact a presence of this method shows that this package has -overloading enabled, and it is what is used by the C<Overloaded> -function of module C<overload>). - -The module might issue the following warnings: - -=over 4 - -=item Odd number of arguments for overload::constant - -(W) The call to overload::constant contained an odd number of arguments. -The arguments should come in pairs. - -=item `%s' is not an overloadable type - -(W) You tried to overload a constant type the overload package is unaware of. - -=item `%s' is not a code reference - -(W) The second (fourth, sixth, ...) argument of overload::constant needs -to be a code reference. Either an anonymous subroutine, or a reference -to a subroutine. - -=back - -=head1 BUGS - -Because it is used for overloading, the per-package hash %OVERLOAD now -has a special meaning in Perl. The symbol table is filled with names -looking like line-noise. - -For the purpose of inheritance every overloaded package behaves as if -C<fallback> is present (possibly undefined). This may create -interesting effects if some package is not overloaded, but inherits -from two overloaded packages. - -Relation between overloading and tie()ing is broken. Overloading is -triggered or not basing on the I<previous> class of tie()d value. - -This happens because the presence of overloading is checked too early, -before any tie()d access is attempted. If the FETCH()ed class of the -tie()d value does not change, a simple workaround is to access the value -immediately after tie()ing, so that after this call the I<previous> class -coincides with the current one. - -B<Needed:> a way to fix this without a speed penalty. - -Barewords are not covered by overloaded string constants. - -This document is confusing. There are grammos and misleading language -used in places. It would seem a total rewrite is needed. - -=cut - diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/strict.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/strict.pm deleted file mode 100644 index d14391add44..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/strict.pm +++ /dev/null @@ -1,136 +0,0 @@ -package strict; - -$strict::VERSION = "1.03"; - -my %bitmask = ( -refs => 0x00000002, -subs => 0x00000200, -vars => 0x00000400 -); - -sub bits { - my $bits = 0; - my @wrong; - foreach my $s (@_) { - push @wrong, $s unless exists $bitmask{$s}; - $bits |= $bitmask{$s} || 0; - } - if (@wrong) { - require Carp; - Carp::croak("Unknown 'strict' tag(s) '@wrong'"); - } - $bits; -} - -my $default_bits = bits(qw(refs subs vars)); - -sub import { - shift; - $^H |= @_ ? bits(@_) : $default_bits; -} - -sub unimport { - shift; - $^H &= ~ (@_ ? bits(@_) : $default_bits); -} - -1; -__END__ - -=head1 NAME - -strict - Perl pragma to restrict unsafe constructs - -=head1 SYNOPSIS - - use strict; - - use strict "vars"; - use strict "refs"; - use strict "subs"; - - use strict; - no strict "vars"; - -=head1 DESCRIPTION - -If no import list is supplied, all possible restrictions are assumed. -(This is the safest mode to operate in, but is sometimes too strict for -casual programming.) Currently, there are three possible things to be -strict about: "subs", "vars", and "refs". - -=over 6 - -=item C<strict refs> - -This generates a runtime error if you -use symbolic references (see L<perlref>). - - use strict 'refs'; - $ref = \$foo; - print $$ref; # ok - $ref = "foo"; - print $$ref; # runtime error; normally ok - $file = "STDOUT"; - print $file "Hi!"; # error; note: no comma after $file - -There is one exception to this rule: - - $bar = \&{'foo'}; - &$bar; - -is allowed so that C<goto &$AUTOLOAD> would not break under stricture. - - -=item C<strict vars> - -This generates a compile-time error if you access a variable that wasn't -declared via C<our> or C<use vars>, -localized via C<my()>, or wasn't fully qualified. Because this is to avoid -variable suicide problems and subtle dynamic scoping issues, a merely -local() variable isn't good enough. See L<perlfunc/my> and -L<perlfunc/local>. - - use strict 'vars'; - $X::foo = 1; # ok, fully qualified - my $foo = 10; # ok, my() var - local $foo = 9; # blows up - - package Cinna; - our $bar; # Declares $bar in current package - $bar = 'HgS'; # ok, global declared via pragma - -The local() generated a compile-time error because you just touched a global -name without fully qualifying it. - -Because of their special use by sort(), the variables $a and $b are -exempted from this check. - -=item C<strict subs> - -This disables the poetry optimization, generating a compile-time error if -you try to use a bareword identifier that's not a subroutine, unless it -is a simple identifier (no colons) and that it appears in curly braces or -on the left hand side of the C<< => >> symbol. - - use strict 'subs'; - $SIG{PIPE} = Plumber; # blows up - $SIG{PIPE} = "Plumber"; # just fine: quoted string is always ok - $SIG{PIPE} = \&Plumber; # preferred form - -=back - -See L<perlmodlib/Pragmatic Modules>. - -=head1 HISTORY - -C<strict 'subs'>, with Perl 5.6.1, erroneously permitted to use an unquoted -compound identifier (e.g. C<Foo::Bar>) as a hash key (before C<< => >> or -inside curlies), but without forcing it always to a literal string. - -Starting with Perl 5.8.1 strict is strict about its restrictions: -if unknown restrictions are used, the strict pragma will abort with - - Unknown 'strict' tag(s) '...' - -=cut diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/unicore/Canonical.pl b/Master/tlpkg/lib/Perl5_lib-TL_inst/unicore/Canonical.pl deleted file mode 100644 index fce1e219700..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/unicore/Canonical.pl +++ /dev/null @@ -1,1042 +0,0 @@ -# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables from e.g. UnicodeData.txt. -# Any changes made here will be lost! - -## -## Data in this file used by ../utf8_heavy.pl -## - -## Mapping from lc(canonical name) to filename in ./lib -%utf8::Canonical = ( - - # InAegeanNumbers - aegeannumbers => 'InAegean', - - alphabetic => 'Alphabet', - - # InAlphabeticPresentationForms - alphabeticpresentationforms => 'InAlphab', - - # InAncientGreekMusicalNotation - ancientgreekmusicalnotation => 'InAncie2', - - # InAncientGreekNumbers - ancientgreeknumbers => 'InAncien', - - arabic => 'Arab', - - # InArabicPresentationFormsA - arabicpresentationformsa => 'InArabi4', - - # InArabicPresentationFormsB - arabicpresentationformsb => 'InArabi3', - - # InArabicSupplement - arabicsupplement => 'InArabi2', - - armenian => 'Armn', - - # InArrows - arrows => 'InArrows', - - # AsciiHexDigit - asciihexdigit => 'AsciiHex', - - # InBasicLatin - basiclatin => 'InBasicL', - - bengali => 'Beng', - - # BidiControl - bidicontrol => 'BidiCont', - - # InBlockElements - blockelements => 'InBlockE', - - bopomofo => 'Bopo', - - # InBopomofoExtended - bopomofoextended => 'InBopom2', - - # InBoxDrawing - boxdrawing => 'InBoxDra', - - braille => 'Brai', - - # InBraillePatterns - braillepatterns => 'InBraill', - - buginese => 'Bugi', - buhid => 'Buhd', - - # InByzantineMusicalSymbols - byzantinemusicalsymbols => 'InByzant', - - # CanadianAboriginal - canadianaboriginal => 'Canadian', - - # CasedLetter - casedletter => 'LC', - - cherokee => 'Cher', - - # InCjkCompatibility - cjkcompatibility => 'InCjkCom', - - # InCjkCompatibilityForms - cjkcompatibilityforms => 'InCjkCo2', - - # InCjkCompatibilityIdeographs - cjkcompatibilityideographs => 'InCjkCo3', - - # InCjkCompatibilityIdeographsSupplement - cjkcompatibilityideographssupplement => 'InCjkCo4', - - # InCjkRadicalsSupplement - cjkradicalssupplement => 'InCjkRad', - - # InCjkStrokes - cjkstrokes => 'InCjkStr', - - # InCjkSymbolsAndPunctuation - cjksymbolsandpunctuation => 'InCjkSym', - - # InCjkUnifiedIdeographs - cjkunifiedideographs => 'InCjkUni', - - # InCjkUnifiedIdeographsExtensionA - cjkunifiedideographsextensiona => 'InCjkUn3', - - # InCjkUnifiedIdeographsExtensionB - cjkunifiedideographsextensionb => 'InCjkUn2', - - # ClosePunctuation - closepunctuation => 'Pe', - - # InCombiningDiacriticalMarks - combiningdiacriticalmarks => 'InCombi2', - - # InCombiningDiacriticalMarksForSymbols - combiningdiacriticalmarksforsymbols => 'InCombi4', - - # InCombiningDiacriticalMarksSupplement - combiningdiacriticalmarkssupplement => 'InCombi3', - - # InCombiningHalfMarks - combininghalfmarks => 'InCombin', - - common => 'Zyyy', - - # ConnectorPunctuation - connectorpunctuation => 'Pc', - - control => 'Cc', - - # InControlPictures - controlpictures => 'InContro', - - coptic => 'Copt', - - # CurrencySymbol - currencysymbol => 'Sc', - - # InCurrencySymbols - currencysymbols => 'InCurren', - - cypriot => 'Cprt', - - # InCypriotSyllabary - cypriotsyllabary => 'InCyprio', - - cyrillic => 'Cyrl', - - # InCyrillicSupplement - cyrillicsupplement => 'InCyril2', - - dash => 'Dash2', - - # DashPunctuation - dashpunctuation => 'Pd', - - # DecimalNumber - decimalnumber => 'Nd', - - deprecated => 'Deprecat', - deseret => 'Dsrt', - devanagari => 'Deva', - diacritic => 'Diacriti', - - # InDingbats - dingbats => 'InDingba', - - # InEnclosedAlphanumerics - enclosedalphanumerics => 'InEnclos', - - # InEnclosedCjkLettersAndMonths - enclosedcjklettersandmonths => 'InEnclo2', - - # EnclosingMark - enclosingmark => 'Me', - - ethiopic => 'Ethi', - - # InEthiopicExtended - ethiopicextended => 'InEthio2', - - # InEthiopicSupplement - ethiopicsupplement => 'InEthio3', - - extender => 'Extender', - - # FinalPunctuation - finalpunctuation => 'Pf', - - format => 'Cf', - - # InGeneralPunctuation - generalpunctuation => 'InGenera', - - # InGeometricShapes - geometricshapes => 'InGeomet', - - georgian => 'Geor', - - # InGeorgianSupplement - georgiansupplement => 'InGeorg2', - - glagolitic => 'Glag', - gothic => 'Goth', - - # GraphemeLink - graphemelink => 'Grapheme', - - greek => 'Grek', - - # InGreekAndCoptic - greekandcoptic => 'InGreekA', - - # InGreekExtended - greekextended => 'InGreekE', - - gujarati => 'Gujr', - gurmukhi => 'Guru', - - # InHalfwidthAndFullwidthForms - halfwidthandfullwidthforms => 'InHalfwi', - - han => 'Hani', - hangul => 'Hang', - - # InHangulCompatibilityJamo - hangulcompatibilityjamo => 'InHangu3', - - # InHangulJamo - hanguljamo => 'InHangul', - - # InHangulSyllables - hangulsyllables => 'InHangu2', - - hanunoo => 'Hano', - hebrew => 'Hebr', - - # HexDigit - hexdigit => 'HexDigit', - - # InHighPrivateUseSurrogates - highprivateusesurrogates => 'InHighPr', - - # InHighSurrogates - highsurrogates => 'InHighSu', - - hiragana => 'Hira', - hyphen => 'Hyphen2', - - # IdContinue - idcontinue => 'IdContin', - - ideographic => 'Ideograp', - - # InIdeographicDescriptionCharacters - ideographicdescriptioncharacters => 'InIdeogr', - - # IdsBinaryOperator - idsbinaryoperator => 'IdsBinar', - - # IdStart - idstart => 'IdStart', - - # IdsTrinaryOperator - idstrinaryoperator => 'IdsTrina', - - # InAegeanNumbers - inaegeannumbers => 'InAegean', - - # InAlphabeticPresentationForms - inalphabeticpresentationforms => 'InAlphab', - - # InAncientGreekMusicalNotation - inancientgreekmusicalnotation => 'InAncie2', - - # InAncientGreekNumbers - inancientgreeknumbers => 'InAncien', - - # InArabic - inarabic => 'InArabic', - - # InArabicPresentationFormsA - inarabicpresentationformsa => 'InArabi4', - - # InArabicPresentationFormsB - inarabicpresentationformsb => 'InArabi3', - - # InArabicSupplement - inarabicsupplement => 'InArabi2', - - # InArmenian - inarmenian => 'InArmeni', - - # InArrows - inarrows => 'InArrows', - - # InBasicLatin - inbasiclatin => 'InBasicL', - - # InBengali - inbengali => 'InBengal', - - # InBlockElements - inblockelements => 'InBlockE', - - # InBopomofo - inbopomofo => 'InBopomo', - - # InBopomofoExtended - inbopomofoextended => 'InBopom2', - - # InBoxDrawing - inboxdrawing => 'InBoxDra', - - # InBraillePatterns - inbraillepatterns => 'InBraill', - - # InBuginese - inbuginese => 'InBugine', - - # InBuhid - inbuhid => 'InBuhid', - - # InByzantineMusicalSymbols - inbyzantinemusicalsymbols => 'InByzant', - - # InCherokee - incherokee => 'InCherok', - - # InCjkCompatibility - incjkcompatibility => 'InCjkCom', - - # InCjkCompatibilityForms - incjkcompatibilityforms => 'InCjkCo2', - - # InCjkCompatibilityIdeographs - incjkcompatibilityideographs => 'InCjkCo3', - - # InCjkCompatibilityIdeographsSupplement - incjkcompatibilityideographssupplement => 'InCjkCo4', - - # InCjkRadicalsSupplement - incjkradicalssupplement => 'InCjkRad', - - # InCjkStrokes - incjkstrokes => 'InCjkStr', - - # InCjkSymbolsAndPunctuation - incjksymbolsandpunctuation => 'InCjkSym', - - # InCjkUnifiedIdeographs - incjkunifiedideographs => 'InCjkUni', - - # InCjkUnifiedIdeographsExtensionA - incjkunifiedideographsextensiona => 'InCjkUn3', - - # InCjkUnifiedIdeographsExtensionB - incjkunifiedideographsextensionb => 'InCjkUn2', - - # InCombiningDiacriticalMarks - incombiningdiacriticalmarks => 'InCombi2', - - # InCombiningDiacriticalMarksForSymbols - incombiningdiacriticalmarksforsymbols => 'InCombi4', - - # InCombiningDiacriticalMarksSupplement - incombiningdiacriticalmarkssupplement => 'InCombi3', - - # InCombiningHalfMarks - incombininghalfmarks => 'InCombin', - - # InControlPictures - incontrolpictures => 'InContro', - - # InCoptic - incoptic => 'InCoptic', - - # InCurrencySymbols - incurrencysymbols => 'InCurren', - - # InCypriotSyllabary - incypriotsyllabary => 'InCyprio', - - # InCyrillic - incyrillic => 'InCyrill', - - # InCyrillicSupplement - incyrillicsupplement => 'InCyril2', - - # InDeseret - indeseret => 'InDesere', - - # InDevanagari - indevanagari => 'InDevana', - - # InDingbats - indingbats => 'InDingba', - - # InEnclosedAlphanumerics - inenclosedalphanumerics => 'InEnclos', - - # InEnclosedCjkLettersAndMonths - inenclosedcjklettersandmonths => 'InEnclo2', - - # InEthiopic - inethiopic => 'InEthiop', - - # InEthiopicExtended - inethiopicextended => 'InEthio2', - - # InEthiopicSupplement - inethiopicsupplement => 'InEthio3', - - # InGeneralPunctuation - ingeneralpunctuation => 'InGenera', - - # InGeometricShapes - ingeometricshapes => 'InGeomet', - - # InGeorgian - ingeorgian => 'InGeorgi', - - # InGeorgianSupplement - ingeorgiansupplement => 'InGeorg2', - - # InGlagolitic - inglagolitic => 'InGlagol', - - # InGothic - ingothic => 'InGothic', - - # InGreekAndCoptic - ingreekandcoptic => 'InGreekA', - - # InGreekExtended - ingreekextended => 'InGreekE', - - # InGujarati - ingujarati => 'InGujara', - - # InGurmukhi - ingurmukhi => 'InGurmuk', - - # InHalfwidthAndFullwidthForms - inhalfwidthandfullwidthforms => 'InHalfwi', - - # InHangulCompatibilityJamo - inhangulcompatibilityjamo => 'InHangu3', - - # InHangulJamo - inhanguljamo => 'InHangul', - - # InHangulSyllables - inhangulsyllables => 'InHangu2', - - # InHanunoo - inhanunoo => 'InHanuno', - - # InHebrew - inhebrew => 'InHebrew', - - inherited => 'Qaai', - - # InHighPrivateUseSurrogates - inhighprivateusesurrogates => 'InHighPr', - - # InHighSurrogates - inhighsurrogates => 'InHighSu', - - # InHiragana - inhiragana => 'InHiraga', - - # InIdeographicDescriptionCharacters - inideographicdescriptioncharacters => 'InIdeogr', - - # InIpaExtensions - inipaextensions => 'InIpaExt', - - # InitialPunctuation - initialpunctuation => 'Pi', - - # InKanbun - inkanbun => 'InKanbun', - - # InKangxiRadicals - inkangxiradicals => 'InKangxi', - - # InKannada - inkannada => 'InKannad', - - # InKatakana - inkatakana => 'InKataka', - - # InKatakanaPhoneticExtensions - inkatakanaphoneticextensions => 'InKatak2', - - # InKharoshthi - inkharoshthi => 'InKharos', - - # InKhmer - inkhmer => 'InKhmer', - - # InKhmerSymbols - inkhmersymbols => 'InKhmerS', - - # InLao - inlao => 'InLao', - - # InLatin1Supplement - inlatin1supplement => 'InLatin1', - - # InLatinExtendedA - inlatinextendeda => 'InLatin2', - - # InLatinExtendedAdditional - inlatinextendedadditional => 'InLatin3', - - # InLatinExtendedB - inlatinextendedb => 'InLatinE', - - # InLetterlikeSymbols - inletterlikesymbols => 'InLetter', - - # InLimbu - inlimbu => 'InLimbu', - - # InLinearBIdeograms - inlinearbideograms => 'InLinear', - - # InLinearBSyllabary - inlinearbsyllabary => 'InLinea2', - - # InLowSurrogates - inlowsurrogates => 'InLowSur', - - # InMalayalam - inmalayalam => 'InMalaya', - - # InMathematicalAlphanumericSymbols - inmathematicalalphanumericsymbols => 'InMathe2', - - # InMathematicalOperators - inmathematicaloperators => 'InMathem', - - # InMiscellaneousMathematicalSymbolsA - inmiscellaneousmathematicalsymbolsa => 'InMisce4', - - # InMiscellaneousMathematicalSymbolsB - inmiscellaneousmathematicalsymbolsb => 'InMisce5', - - # InMiscellaneousSymbols - inmiscellaneoussymbols => 'InMiscel', - - # InMiscellaneousSymbolsAndArrows - inmiscellaneoussymbolsandarrows => 'InMisce3', - - # InMiscellaneousTechnical - inmiscellaneoustechnical => 'InMisce2', - - # InModifierToneLetters - inmodifiertoneletters => 'InModifi', - - # InMongolian - inmongolian => 'InMongol', - - # InMusicalSymbols - inmusicalsymbols => 'InMusica', - - # InMyanmar - inmyanmar => 'InMyanma', - - # InNewTaiLue - innewtailue => 'InNewTai', - - # InNumberForms - innumberforms => 'InNumber', - - # InOgham - inogham => 'InOgham', - - # InOldItalic - inolditalic => 'InOldIta', - - # InOldPersian - inoldpersian => 'InOldPer', - - # InOpticalCharacterRecognition - inopticalcharacterrecognition => 'InOptica', - - # InOriya - inoriya => 'InOriya', - - # InOsmanya - inosmanya => 'InOsmany', - - # InPhoneticExtensions - inphoneticextensions => 'InPhonet', - - # InPhoneticExtensionsSupplement - inphoneticextensionssupplement => 'InPhone2', - - # InPrivateUseArea - inprivateusearea => 'InPrivat', - - # InRunic - inrunic => 'InRunic', - - # InShavian - inshavian => 'InShavia', - - # InSinhala - insinhala => 'InSinhal', - - # InSmallFormVariants - insmallformvariants => 'InSmallF', - - # InSpacingModifierLetters - inspacingmodifierletters => 'InSpacin', - - # InSpecials - inspecials => 'InSpecia', - - # InSuperscriptsAndSubscripts - insuperscriptsandsubscripts => 'InSupers', - - # InSupplementalArrowsA - insupplementalarrowsa => 'InSuppl2', - - # InSupplementalArrowsB - insupplementalarrowsb => 'InSupple', - - # InSupplementalMathematicalOperators - insupplementalmathematicaloperators => 'InSuppl6', - - # InSupplementalPunctuation - insupplementalpunctuation => 'InSuppl3', - - # InSupplementaryPrivateUseAreaA - insupplementaryprivateuseareaa => 'InSuppl4', - - # InSupplementaryPrivateUseAreaB - insupplementaryprivateuseareab => 'InSuppl5', - - # InSylotiNagri - insylotinagri => 'InSyloti', - - # InSyriac - insyriac => 'InSyriac', - - # InTagalog - intagalog => 'InTagalo', - - # InTagbanwa - intagbanwa => 'InTagban', - - # InTags - intags => 'InTags', - - # InTaiLe - intaile => 'InTaiLe', - - # InTaiXuanJingSymbols - intaixuanjingsymbols => 'InTaiXua', - - # InTamil - intamil => 'InTamil', - - # InTelugu - intelugu => 'InTelugu', - - # InThaana - inthaana => 'InThaana', - - # InThai - inthai => 'InThai', - - # InTibetan - intibetan => 'InTibeta', - - # InTifinagh - intifinagh => 'InTifina', - - # InUgaritic - inugaritic => 'InUgarit', - - # InUnifiedCanadianAboriginalSyllabics - inunifiedcanadianaboriginalsyllabics => 'InUnifie', - - # InVariationSelectors - invariationselectors => 'InVariat', - - # InVariationSelectorsSupplement - invariationselectorssupplement => 'InVaria2', - - # InVerticalForms - inverticalforms => 'InVertic', - - # InYijingHexagramSymbols - inyijinghexagramsymbols => 'InYijing', - - # InYiRadicals - inyiradicals => 'InYiRadi', - - # InYiSyllables - inyisyllables => 'InYiSyll', - - # InIpaExtensions - ipaextensions => 'InIpaExt', - - # JoinControl - joincontrol => 'JoinCont', - - # InKanbun - kanbun => 'InKanbun', - - # InKangxiRadicals - kangxiradicals => 'InKangxi', - - kannada => 'Knda', - katakana => 'Kana', - - # InKatakanaPhoneticExtensions - katakanaphoneticextensions => 'InKatak2', - - kharoshthi => 'Khar', - khmer => 'Khmr', - - # InKhmerSymbols - khmersymbols => 'InKhmerS', - - lao => 'Laoo', - latin => 'Latn', - - # InLatin1Supplement - latin1supplement => 'InLatin1', - - # InLatinExtendedA - latinextendeda => 'InLatin2', - - # InLatinExtendedAdditional - latinextendedadditional => 'InLatin3', - - # InLatinExtendedB - latinextendedb => 'InLatinE', - - letter => 'L', - - # InLetterlikeSymbols - letterlikesymbols => 'InLetter', - - # LetterNumber - letternumber => 'Nl', - - limbu => 'Limb', - - # LinearB - linearb => 'LinearB', - - # InLinearBIdeograms - linearbideograms => 'InLinear', - - # InLinearBSyllabary - linearbsyllabary => 'InLinea2', - - # LineSeparator - lineseparator => 'Zl', - - # LogicalOrderException - logicalorderexception => 'LogicalO', - - lowercase => 'Lowercas', - - # LowercaseLetter - lowercaseletter => 'Ll', - - # InLowSurrogates - lowsurrogates => 'InLowSur', - - malayalam => 'Mlym', - mark => 'M', - math => 'Math', - - # InMathematicalAlphanumericSymbols - mathematicalalphanumericsymbols => 'InMathe2', - - # InMathematicalOperators - mathematicaloperators => 'InMathem', - - # MathSymbol - mathsymbol => 'Sm', - - # InMiscellaneousMathematicalSymbolsA - miscellaneousmathematicalsymbolsa => 'InMisce4', - - # InMiscellaneousMathematicalSymbolsB - miscellaneousmathematicalsymbolsb => 'InMisce5', - - # InMiscellaneousSymbols - miscellaneoussymbols => 'InMiscel', - - # InMiscellaneousSymbolsAndArrows - miscellaneoussymbolsandarrows => 'InMisce3', - - # InMiscellaneousTechnical - miscellaneoustechnical => 'InMisce2', - - # ModifierLetter - modifierletter => 'Lm', - - # ModifierSymbol - modifiersymbol => 'Sk', - - # InModifierToneLetters - modifiertoneletters => 'InModifi', - - mongolian => 'Mong', - - # InMusicalSymbols - musicalsymbols => 'InMusica', - - myanmar => 'Mymr', - - # NewTaiLue - newtailue => 'NewTaiLu', - - # NoncharacterCodePoint - noncharactercodepoint => 'Nonchara', - - # NonspacingMark - nonspacingmark => 'Mn', - - number => 'N', - - # InNumberForms - numberforms => 'InNumber', - - ogham => 'Ogam', - - # OldItalic - olditalic => 'OldItali', - - # OldPersian - oldpersian => 'OldPersi', - - # OpenPunctuation - openpunctuation => 'Ps', - - # InOpticalCharacterRecognition - opticalcharacterrecognition => 'InOptica', - - oriya => 'Orya', - osmanya => 'Osma', - other => 'C', - - # OtherAlphabetic - otheralphabetic => 'OtherAlp', - - # OtherDefaultIgnorableCodePoint - otherdefaultignorablecodepoint => 'OtherDef', - - # OtherGraphemeExtend - othergraphemeextend => 'OtherGra', - - # OtherIdContinue - otheridcontinue => 'OtherIdC', - - # OtherIdStart - otheridstart => 'OtherIdS', - - # OtherLetter - otherletter => 'Lo', - - # OtherLowercase - otherlowercase => 'OtherLow', - - # OtherMath - othermath => 'OtherMat', - - # OtherNumber - othernumber => 'No', - - # OtherPunctuation - otherpunctuation => 'Po', - - # OtherSymbol - othersymbol => 'So', - - # OtherUppercase - otheruppercase => 'OtherUpp', - - # ParagraphSeparator - paragraphseparator => 'Zp', - - # PatternSyntax - patternsyntax => 'PatternS', - - # PatternWhiteSpace - patternwhitespace => 'PatternW', - - # InPhoneticExtensions - phoneticextensions => 'InPhonet', - - # InPhoneticExtensionsSupplement - phoneticextensionssupplement => 'InPhone2', - - # PrivateUse - privateuse => 'Co', - - # InPrivateUseArea - privateusearea => 'InPrivat', - - punctuation => 'P', - - # QuotationMark - quotationmark => 'Quotatio', - - radical => 'Radical2', - runic => 'Runr', - separator => 'Z', - shavian => 'Shaw', - sinhala => 'Sinh', - - # InSmallFormVariants - smallformvariants => 'InSmallF', - - # SoftDotted - softdotted => 'SoftDott', - - # SpaceSeparator - spaceseparator => 'Zs', - - # SpacingMark - spacingmark => 'Mc', - - # InSpacingModifierLetters - spacingmodifierletters => 'InSpacin', - - # InSpecials - specials => 'InSpecia', - - sterm => 'Sterm2', - - # InSuperscriptsAndSubscripts - superscriptsandsubscripts => 'InSupers', - - # InSupplementalArrowsA - supplementalarrowsa => 'InSuppl2', - - # InSupplementalArrowsB - supplementalarrowsb => 'InSupple', - - # InSupplementalMathematicalOperators - supplementalmathematicaloperators => 'InSuppl6', - - # InSupplementalPunctuation - supplementalpunctuation => 'InSuppl3', - - # InSupplementaryPrivateUseAreaA - supplementaryprivateuseareaa => 'InSuppl4', - - # InSupplementaryPrivateUseAreaB - supplementaryprivateuseareab => 'InSuppl5', - - surrogate => 'Cs', - - # SylotiNagri - sylotinagri => 'SylotiNa', - - symbol => 'S', - syriac => 'Syrc', - tagalog => 'Tglg', - tagbanwa => 'Tagb', - - # InTags - tags => 'InTags', - - # TaiLe - taile => 'TaiLe', - - # InTaiXuanJingSymbols - taixuanjingsymbols => 'InTaiXua', - - tamil => 'Taml', - telugu => 'Telu', - - # TerminalPunctuation - terminalpunctuation => 'Terminal', - - thaana => 'Thaa', - thai => 'Thai', - tibetan => 'Tibt', - tifinagh => 'Tfng', - - # TitlecaseLetter - titlecaseletter => 'Lt', - - ugaritic => 'Ugar', - unassigned => 'Cn', - - # InUnifiedCanadianAboriginalSyllabics - unifiedcanadianaboriginalsyllabics => 'InUnifie', - - # UnifiedIdeograph - unifiedideograph => 'UnifiedI', - - uppercase => 'Uppercas', - - # UppercaseLetter - uppercaseletter => 'Lu', - - # VariationSelector - variationselector => 'Variatio', - - # InVariationSelectors - variationselectors => 'InVariat', - - # InVariationSelectorsSupplement - variationselectorssupplement => 'InVaria2', - - # InVerticalForms - verticalforms => 'InVertic', - - # WhiteSpace - whitespace => 'WhiteSpa', - - yi => 'Yiii', - - # InYijingHexagramSymbols - yijinghexagramsymbols => 'InYijing', - - # InYiRadicals - yiradicals => 'InYiRadi', - - # InYiSyllables - yisyllables => 'InYiSyll', - -); -1 diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/unicore/Exact.pl b/Master/tlpkg/lib/Perl5_lib-TL_inst/unicore/Exact.pl deleted file mode 100644 index 42312b054cc..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/unicore/Exact.pl +++ /dev/null @@ -1,73 +0,0 @@ -# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables from e.g. UnicodeData.txt. -# Any changes made here will be lost! - -## -## Data in this file used by ../utf8_heavy.pl -## - -## Mapping from name to filename in ./lib/gc_sc -%utf8::Exact = ( - ASCII => 'ASCII', - All => 'Any', - Alnum => 'Alnum', - Alpha => 'Alpha', - Any => 'Any', - Assigned => 'Assigned', - Blank => 'Blank', - C => 'C', - Cc => 'Cc', - Cf => 'Cf', - Cn => 'Cn', - Cntrl => 'Cntrl', - Co => 'Co', - Cs => 'Cs', - Digit => 'Digit', - Graph => 'Graph', - InGreek => 'InGreekA', - L => 'L', - LC => 'LC', - Ll => 'Ll', - Lm => 'Lm', - Lo => 'Lo', - Lower => 'Lower', - Lt => 'Lt', - Lu => 'Lu', - M => 'M', - Mc => 'Mc', - Me => 'Me', - Mn => 'Mn', - N => 'N', - Nd => 'Nd', - Nl => 'Nl', - No => 'No', - P => 'P', - Pc => 'Pc', - Pd => 'Pd', - Pe => 'Pe', - Pf => 'Pf', - Pi => 'Pi', - Po => 'Po', - Print => 'Print', - Ps => 'Ps', - Punct => 'Punct', - S => 'S', - Sc => 'Sc', - Sk => 'Sk', - Sm => 'Sm', - So => 'So', - Space => 'Space', - SpacePerl => 'SpacePer', - Title => 'Title', - Upper => 'Upper', - Word => 'Word', - XDigit => 'XDigit', - Z => 'Z', - Zl => 'Zl', - Zp => 'Zp', - Zs => 'Zs', - _CanonDCIJ => '_CanonDC', - _CaseIgnorable => '_CaseIgn', - _CombAbove => '_CombAbo', -); -1; diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/unicore/PVA.pl b/Master/tlpkg/lib/Perl5_lib-TL_inst/unicore/PVA.pl deleted file mode 100644 index d836bdb7549..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/unicore/PVA.pl +++ /dev/null @@ -1,2044 +0,0 @@ -# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables from e.g. UnicodeData.txt. -# Any changes made here will be lost! - - -%utf8::PropertyAlias = ( -'sc', -'Script', -'xonfkd', -'ExpandsOnNFKD', -'patsyn', -'PatternSyntax', -'nfkcqc', -'NFKCQuickCheck', -'oalpha', -'OtherAlphabetic', -'gcb', -'GraphemeClusterBreak', -'nfcqc', -'NFCQuickCheck', -'ids', -'IDStart', -'lb', -'LineBreak', -'stc', -'SimpleTitlecaseMapping', -'xonfkc', -'ExpandsOnNFKC', -'patws', -'PatternWhiteSpace', -'tc', -'TitlecaseMapping', -'lower', -'Lowercase', -'idst', -'IDSTrinaryOperator', -'radical', -'Radical', -'fcnfkc', -'FCNFKCClosure', -'dm', -'DecompositionMapping', -'slc', -'SimpleLowercaseMapping', -'wspace', -'WhiteSpace', -'di', -'DefaultIgnorableCodePoint', -'nt', -'NumericType', -'ea', -'EastAsianWidth', -'ahex', -'ASCIIHexDigit', -'alpha', -'Alphabetic', -'uc', -'UppercaseMapping', -'dia', -'Diacritic', -'gc', -'GeneralCategory', -'xids', -'XIDStart', -'oupper', -'OtherUppercase', -'wb', -'WordBreak', -'math', -'Math', -'sb', -'SentenceBreak', -'qmark', -'QuotationMark', -'nfdqc', -'NFDQuickCheck', -'ideo', -'Ideographic', -'blk', -'Block', -'odi', -'OtherDefaultIgnorableCodePoint', -'hst', -'HangulSyllableType', -'bidim', -'BidiMirrored', -'olower', -'OtherLowercase', -'na', -'Name', -'hyphen', -'Hyphen', -'xidc', -'XIDContinue', -'oidc', -'OtherIDContinue', -'bidic', -'BidiControl', -'na1', -'Unicode1Name', -'compex', -'FullCompositionExclusion', -'ext', -'Extender', -'cf', -'CaseFolding', -'grlink', -'GraphemeLink', -'xonfc', -'ExpandsOnNFC', -'sd', -'SoftDotted', -'ccc', -'CanonicalCombiningClass', -'dash', -'Dash', -'hex', -'HexDigit', -'grbase', -'GraphemeBase', -'dt', -'DecompositionType', -'xonfd', -'ExpandsOnNFD', -'scc', -'SpecialCaseCondition', -'idsb', -'IDSBinaryOperator', -'age', -'Age', -'loe', -'LogicalOrderException', -'term', -'TerminalPunctuation', -'ce', -'CompositionExclusion', -'isc', -'ISOComment', -'dep', -'Deprecated', -'sfc', -'SimpleCaseFolding', -'bc', -'BidiClass', -'nchar', -'NoncharacterCodePoint', -'jt', -'JoiningType', -'upper', -'Uppercase', -'uideo', -'UnifiedIdeograph', -'sterm', -'STerm', -'nfkdqc', -'NFKDQuickCheck', -'oids', -'OtherIDStart', -'joinc', -'JoinControl', -'nv', -'NumericValue', -'suc', -'SimpleUppercaseMapping', -'urs', -'UnicodeRadicalStroke', -'bmg', -'BidiMirroringGlyph', -'grext', -'GraphemeExtend', -'idc', -'IDContinue', -'vs', -'VariationSelector', -'omath', -'OtherMath', -'lc', -'LowercaseMapping', -'ogrext', -'OtherGraphemeExtend', -'jg', -'JoiningGroup', -); - -%utf8::PA_reverse = ( -'linebreak', -'lb', -'bidiclass', -'bc', -'terminalpunctuation', -'Term', -'expandsonnfkc', -'XONFKC', -'extender', -'Ext', -'simplecasefolding', -'sfc', -'patternsyntax', -'PatSyn', -'sentencebreak', -'SB', -'numericvalue', -'nv', -'patternwhitespace', -'PatWS', -'softdotted', -'SD', -'logicalorderexception', -'LOE', -'idstart', -'IDS', -'generalcategory', -'gc', -'decompositiontype', -'dt', -'name', -'na', -'numerictype', -'nt', -'otherlowercase', -'OLower', -'joininggroup', -'jg', -'expandsonnfkd', -'XONFKD', -'deprecated', -'Dep', -'radical', -'Radical', -'idstrinaryoperator', -'IDST', -'xidstart', -'XIDS', -'lowercase', -'Lower', -'unifiedideograph', -'UIdeo', -'othergraphemeextend', -'OGrExt', -'eastasianwidth', -'ea', -'math', -'Math', -'graphemelink', -'GrLink', -'noncharactercodepoint', -'NChar', -'graphemebase', -'GrBase', -'bidimirrored', -'BidiM', -'casefolding', -'cf', -'simpleuppercasemapping', -'suc', -'fullcompositionexclusion', -'CompEx', -'compositionexclusion', -'CE', -'uppercasemapping', -'uc', -'decompositionmapping', -'dm', -'whitespace', -'WSpace', -'hyphen', -'Hyphen', -'ideographic', -'Ideo', -'idcontinue', -'IDC', -'idsbinaryoperator', -'IDSB', -'hangulsyllabletype', -'hst', -'asciihexdigit', -'AHex', -'otheruppercase', -'OUpper', -'nfkdquickcheck', -'NFKDQC', -'simpletitlecasemapping', -'stc', -'nfcquickcheck', -'NFCQC', -'bidicontrol', -'BidiC', -'diacritic', -'Dia', -'joiningtype', -'jt', -'otheralphabetic', -'OAlpha', -'canonicalcombiningclass', -'ccc', -'alphabetic', -'Alpha', -'titlecasemapping', -'tc', -'unicoderadicalstroke', -'URS', -'hexdigit', -'Hex', -'unicode1name', -'na1', -'dash', -'Dash', -'fcnfkcclosure', -'FCNFKC', -'graphemeextend', -'GrExt', -'joincontrol', -'JoinC', -'xidcontinue', -'XIDC', -'quotationmark', -'QMark', -'expandsonnfd', -'XONFD', -'age', -'age', -'otheridcontinue', -'OIDC', -'uppercase', -'Upper', -'expandsonnfc', -'XONFC', -'defaultignorablecodepoint', -'DI', -'nfdquickcheck', -'NFDQC', -'isocomment', -'isc', -'otherdefaultignorablecodepoint', -'ODI', -'variationselector', -'VS', -'specialcasecondition', -'scc', -'script', -'sc', -'otheridstart', -'OIDS', -'sterm', -'STerm', -'graphemeclusterbreak', -'GCB', -'nfkcquickcheck', -'NFKCQC', -'bidimirroringglyph', -'bmg', -'othermath', -'OMath', -'block', -'blk', -'wordbreak', -'WB', -'lowercasemapping', -'lc', -'simplelowercasemapping', -'slc', -); - -%utf8::PropValueAlias = ( -'sc', -{ -'tglg', -'Tagalog', -'runr', -'Runic', -'osma', -'Osmanya', -'hano', -'Hanunoo', -'cans', -'CanadianAboriginal', -'tagb', -'Tagbanwa', -'mlym', -'Malayalam', -'knda', -'Kannada', -'grek', -'Greek', -'ethi', -'Ethiopic', -'orya', -'Oriya', -'cher', -'Cherokee', -'mong', -'Mongolian', -'khmr', -'Khmer', -'ogam', -'Ogham', -'hrkt', -'KatakanaOrHiragana', -'armn', -'Armenian', -'ital', -'OldItalic', -'hani', -'Han', -'shaw', -'Shavian', -'taml', -'Tamil', -'tibt', -'Tibetan', -'guru', -'Gurmukhi', -'ugar', -'Ugaritic', -'qaai', -'Inherited', -'kana', -'Katakana', -'gujr', -'Gujarati', -'thaa', -'Thaana', -'cyrl', -'Cyrillic', -'copt', -'Coptic', -'sylo', -'SylotiNagri', -'thai', -'Thai', -'talu', -'NewTaiLue', -'laoo', -'Lao', -'sinh', -'Sinhala', -'beng', -'Bengali', -'hira', -'Hiragana', -'brai', -'Braille', -'telu', -'Telugu', -'limb', -'Limbu', -'geor', -'Georgian', -'mymr', -'Myanmar', -'glag', -'Glagolitic', -'hang', -'Hangul', -'syrc', -'Syriac', -'tfng', -'Tifinagh', -'dsrt', -'Deseret', -'buhd', -'Buhid', -'yiii', -'Yi', -'arab', -'Arabic', -'bopo', -'Bopomofo', -'khar', -'Kharoshthi', -'linb', -'LinearB', -'deva', -'Devanagari', -'xpeo', -'OldPersian', -'goth', -'Gothic', -'cprt', -'Cypriot', -'tale', -'TaiLe', -'zyyy', -'Common', -'latn', -'Latin', -'bugi', -'Buginese', -'hebr', -'Hebrew', -}, -'dt', -{ -'fra', -'Fraction', -'none', -'None', -'sml', -'Small', -'enc', -'Circle', -'font', -'Font', -'init', -'Initial', -'nb', -'Nobreak', -'iso', -'Isolated', -'sup', -'Super', -'fin', -'Final', -'wide', -'Wide', -'nar', -'Narrow', -'can', -'Canonical', -'med', -'Medial', -'sub', -'Sub', -'vert', -'Vertical', -'sqr', -'Square', -'com', -'Compat', -}, -'nt', -{ -'none', -'None', -'di', -'Digit', -'de', -'Decimal', -'nu', -'Numeric', -}, -'ea', -{ -'w', -'Wide', -'n', -'Neutral', -'h', -'Halfwidth', -'a', -'Ambiguous', -'f', -'Fullwidth', -'na', -'Narrow', -}, -'NFKC_QC', -{ -'y', -'Yes', -'n', -'No', -'m', -'Maybe', -}, -'bc', -{ -'r', -'RightToLeft', -'rlo', -'RightToLeftOverride', -'es', -'EuropeanSeparator', -'ws', -'WhiteSpace', -'rle', -'RightToLeftEmbedding', -'on', -'OtherNeutral', -'bn', -'BoundaryNeutral', -'et', -'EuropeanTerminator', -'pdf', -'PopDirectionalFormat', -'lro', -'LeftToRightOverride', -'s', -'SegmentSeparator', -'al', -'ArabicLetter', -'en', -'EuropeanNumber', -'l', -'LeftToRight', -'b', -'ParagraphSeparator', -'lre', -'LeftToRightEmbedding', -'cs', -'CommonSeparator', -'nsm', -'NonspacingMark', -'an', -'ArabicNumber', -}, -'gc', -{ -'sc', -'CurrencySymbol', -'mc', -'SpacingMark', -'lm', -'ModifierLetter', -'cn', -'Unassigned', -'pf', -'FinalPunctuation', -'no', -'OtherNumber', -'cc', -'Control', -'lo', -'OtherLetter', -'po', -'OtherPunctuation', -'zs', -'SpaceSeparator', -'co', -'PrivateUse', -'so', -'OtherSymbol', -'ll', -'LowercaseLetter', -'nd', -'DecimalNumber', -'cf', -'Format', -'me', -'EnclosingMark', -'s', -'Symbol', -'zp', -'ParagraphSeparator', -'pd', -'DashPunctuation', -'c', -'Other', -'lt', -'TitlecaseLetter', -'cs', -'Surrogate', -'l&', -'CasedLetter', -'z', -'Separator', -'ps', -'OpenPunctuation', -'zl', -'LineSeparator', -'pc', -'ConnectorPunctuation', -'pi', -'InitialPunctuation', -'n', -'Number', -'m', -'Mark', -'nl', -'LetterNumber', -'sm', -'MathSymbol', -'l', -'Letter', -'mn', -'NonspacingMark', -'p', -'Punctuation', -'lc', -'CasedLetter', -'sk', -'ModifierSymbol', -'lu', -'UppercaseLetter', -'pe', -'ClosePunctuation', -}, -'GCB', -{ -'cn', -'Control', -'ex', -'Extend', -'v', -'V', -'lv', -'LV', -'xx', -'Other', -'l', -'L', -'lvt', -'LVT', -'cr', -'CR', -'lf', -'LF', -'t', -'T', -}, -'lb', -{ -'sp', -'Space', -'ba', -'BreakAfter', -'gl', -'Glue', -'xx', -'Unknown', -'nu', -'Numeric', -'cb', -'ContingentBreak', -'sy', -'BreakSymbols', -'cr', -'CarriageReturn', -'in', -'Inseparable', -'bb', -'BreakBefore', -'sg', -'Surrogate', -'sa', -'ComplexContext', -'po', -'PostfixNumeric', -'jl', -'JL', -'id', -'Ideographic', -'al', -'Alphabetic', -'bk', -'MandatoryBreak', -'pr', -'PrefixNumeric', -'b2', -'BreakBoth', -'op', -'OpenPunctuation', -'cl', -'ClosePunctuation', -'is', -'InfixNumeric', -'qu', -'Quotation', -'hy', -'Hyphen', -'wj', -'WordJoiner', -'zw', -'ZWSpace', -'jt', -'JT', -'ex', -'Exclamation', -'cm', -'CombiningMark', -'h2', -'H2', -'nl', -'NextLine', -'ns', -'Nonstarter', -'h3', -'H3', -'ai', -'Ambiguous', -'lf', -'LineFeed', -'jv', -'JV', -}, -'jt', -{ -'l', -'LeftJoining', -'u', -'NonJoining', -'c', -'JoinCausing', -'r', -'RightJoining', -'d', -'DualJoining', -'t', -'Transparent', -}, -'NFKD_QC', -{ -'y', -'Yes', -'n', -'No', -}, -'NFC_QC', -{ -'y', -'Yes', -'n', -'No', -'m', -'Maybe', -}, -'hst', -{ -'l', -'LeadingJamo', -'lvt', -'LVTSyllable', -'v', -'VowelJamo', -'lv', -'LVSyllable', -'t', -'TrailingJamo', -'na', -'NotApplicable', -}, -'NFD_QC', -{ -'y', -'Yes', -'n', -'No', -}, -'WB', -{ -'ml', -'MidLetter', -'le', -'ALetter', -'ex', -'ExtendNumLet', -'xx', -'Other', -'nu', -'Numeric', -'fo', -'Format', -'mn', -'MidNum', -'ka', -'Katakana', -}, -'SB', -{ -'sp', -'Sp', -'cl', -'Close', -'le', -'OLetter', -'up', -'Upper', -'st', -'STerm', -'xx', -'Other', -'nu', -'Numeric', -'fo', -'Format', -'se', -'Sep', -'lo', -'Lower', -'at', -'ATerm', -}, -'ccc', -{ -'atb', -'AttachedBelow', -'db', -'DoubleBelow', -'a', -'Above', -'r', -'Right', -'da', -'DoubleAbove', -'is', -'IotaSubscript', -'nr', -'NotReordered', -'ov', -'Overlay', -'br', -'BelowRight', -'nk', -'Nukta', -'atbl', -'AttachedBelowLeft', -'al', -'AboveLeft', -'ar', -'AboveRight', -'atar', -'AttachedAboveRight', -'l', -'Left', -'b', -'Below', -'vr', -'Virama', -'kv', -'KanaVoicing', -'bl', -'BelowLeft', -}, -); - -%utf8::PVA_reverse = ( -'sc', -{ -'newtailue', -'Talu', -'canadianaboriginal', -'Cans', -'gujarati', -'Gujr', -'latin', -'Latn', -'hangul', -'Hang', -'deseret', -'Dsrt', -'hebrew', -'Hebr', -'inherited', -'Qaai', -'linearb', -'Linb', -'ugaritic', -'Ugar', -'taile', -'Tale', -'armenian', -'Armn', -'tifinagh', -'Tfng', -'myanmar', -'Mymr', -'gurmukhi', -'Guru', -'greek', -'Grek', -'coptic', -'Copt', -'cyrillic', -'Cyrl', -'thaana', -'Thaa', -'lao', -'Laoo', -'katakana', -'Kana', -'khmer', -'Khmr', -'tibetan', -'Tibt', -'hiragana', -'Hira', -'mongolian', -'Mong', -'thai', -'Thai', -'yi', -'Yiii', -'sylotinagri', -'Sylo', -'bopomofo', -'Bopo', -'malayalam', -'Mlym', -'telugu', -'Telu', -'limbu', -'Limb', -'oriya', -'Orya', -'buhid', -'Buhd', -'cypriot', -'Cprt', -'bengali', -'Beng', -'katakanaorhiragana', -'Hrkt', -'oldpersian', -'Xpeo', -'tagalog', -'Tglg', -'syriac', -'Syrc', -'cherokee', -'Cher', -'ogham', -'Ogam', -'hanunoo', -'Hano', -'braille', -'Brai', -'tamil', -'Taml', -'common', -'Zyyy', -'runic', -'Runr', -'georgian', -'Geor', -'ethiopic', -'Ethi', -'glagolitic', -'Glag', -'han', -'Hani', -'kharoshthi', -'Khar', -'kannada', -'Knda', -'tagbanwa', -'Tagb', -'arabic', -'Arab', -'sinhala', -'Sinh', -'gothic', -'Goth', -'osmanya', -'Osma', -'olditalic', -'Ital', -'devanagari', -'Deva', -'buginese', -'Bugi', -'shavian', -'Shaw', -}, -'dt', -{ -'small', -'sml', -'none', -'none', -'isolated', -'iso', -'narrow', -'nar', -'square', -'sqr', -'nobreak', -'nb', -'fraction', -'fra', -'font', -'font', -'medial', -'med', -'wide', -'wide', -'canonical', -'can', -'circle', -'enc', -'super', -'sup', -'vertical', -'vert', -'final', -'fin', -'compat', -'com', -'sub', -'sub', -'initial', -'init', -}, -'nt', -{ -'none', -'None', -'digit', -'Di', -'numeric', -'Nu', -'decimal', -'De', -}, -'ea', -{ -'halfwidth', -'H', -'fullwidth', -'F', -'ambiguous', -'A', -'narrow', -'Na', -'wide', -'W', -'neutral', -'N', -}, -'NFKC_QC', -{ -'yes', -'Y', -'maybe', -'M', -'no', -'N', -}, -'bc', -{ -'nonspacingmark', -'NSM', -'whitespace', -'WS', -'righttoleft', -'R', -'lefttoright', -'L', -'boundaryneutral', -'BN', -'segmentseparator', -'S', -'lefttorightembedding', -'LRE', -'europeanterminator', -'ET', -'righttoleftembedding', -'RLE', -'righttoleftoverride', -'RLO', -'lefttorightoverride', -'LRO', -'europeanseparator', -'ES', -'europeannumber', -'EN', -'commonseparator', -'CS', -'arabicletter', -'AL', -'paragraphseparator', -'B', -'otherneutral', -'ON', -'popdirectionalformat', -'PDF', -'arabicnumber', -'AN', -}, -'gc', -{ -'modifiersymbol', -'Sk', -'letternumber', -'Nl', -'connectorpunctuation', -'Pc', -'spacingmark', -'Mc', -'mark', -'M', -'unassigned', -'Cn', -'enclosingmark', -'Me', -'lineseparator', -'Zl', -'lowercaseletter', -'Ll', -'symbol', -'S', -'letter', -'L', -'othernumber', -'No', -'paragraphseparator', -'Zp', -'modifierletter', -'Lm', -'titlecaseletter', -'Lt', -'decimalnumber', -'Nd', -'other', -'C', -'mathsymbol', -'Sm', -'surrogate', -'Cs', -'otherletter', -'Lo', -'nonspacingmark', -'Mn', -'number', -'N', -'uppercaseletter', -'Lu', -'spaceseparator', -'Zs', -'privateuse', -'Co', -'openpunctuation', -'Ps', -'punctuation', -'P', -'control', -'Cc', -'casedletter', -'LC', -'closepunctuation', -'Pe', -'otherpunctuation', -'Po', -'finalpunctuation', -'Pf', -'format', -'Cf', -'initialpunctuation', -'Pi', -'separator', -'Z', -'othersymbol', -'So', -'dashpunctuation', -'Pd', -'currencysymbol', -'Sc', -}, -'GCB', -{ -'extend', -'EX', -'v', -'V', -'lv', -'LV', -'l', -'L', -'lvt', -'LVT', -'cr', -'CR', -'other', -'XX', -'lf', -'LF', -'control', -'CN', -'t', -'T', -}, -'lb', -{ -'carriagereturn', -'CR', -'ideographic', -'ID', -'hyphen', -'HY', -'ambiguous', -'AI', -'contingentbreak', -'CB', -'complexcontext', -'SA', -'prefixnumeric', -'PR', -'jl', -'JL', -'inseparable', -'IN', -'breaksymbols', -'SY', -'breakafter', -'BA', -'breakbefore', -'BB', -'postfixnumeric', -'PO', -'glue', -'GL', -'wordjoiner', -'WJ', -'breakboth', -'B2', -'quotation', -'QU', -'combiningmark', -'CM', -'nonstarter', -'NS', -'linefeed', -'LF', -'alphabetic', -'AL', -'surrogate', -'SG', -'mandatorybreak', -'BK', -'unknown', -'XX', -'exclamation', -'EX', -'openpunctuation', -'OP', -'jt', -'JT', -'closepunctuation', -'CL', -'space', -'SP', -'zwspace', -'ZW', -'h2', -'H2', -'infixnumeric', -'IS', -'nextline', -'NL', -'numeric', -'NU', -'h3', -'H3', -'jv', -'JV', -}, -'jt', -{ -'leftjoining', -'L', -'transparent', -'T', -'nonjoining', -'U', -'rightjoining', -'R', -'dualjoining', -'D', -'joincausing', -'C', -}, -'NFKD_QC', -{ -'yes', -'Y', -'no', -'N', -}, -'NFC_QC', -{ -'yes', -'Y', -'maybe', -'M', -'no', -'N', -}, -'hst', -{ -'lvtsyllable', -'LVT', -'lvsyllable', -'LV', -'leadingjamo', -'L', -'notapplicable', -'NA', -'voweljamo', -'V', -'trailingjamo', -'T', -}, -'NFD_QC', -{ -'yes', -'Y', -'no', -'N', -}, -'WB', -{ -'midletter', -'ML', -'format', -'FO', -'katakana', -'KA', -'other', -'XX', -'midnum', -'MN', -'numeric', -'NU', -'extendnumlet', -'EX', -'aletter', -'LE', -}, -'SB', -{ -'sp', -'SP', -'upper', -'UP', -'sterm', -'ST', -'aterm', -'AT', -'close', -'CL', -'oletter', -'LE', -'sep', -'SE', -'format', -'FO', -'other', -'XX', -'lower', -'LO', -'numeric', -'NU', -}, -'ccc', -{ -'left', -'L', -'attachedbelowleft', -'ATBL', -'belowleft', -'BL', -'aboveright', -'AR', -'kanavoicing', -'KV', -'above', -'A', -'aboveleft', -'AL', -'nukta', -'NK', -'below', -'B', -'doublebelow', -'DB', -'virama', -'VR', -'belowright', -'BR', -'notreordered', -'NR', -'attachedbelow', -'ATB', -'right', -'R', -'iotasubscript', -'IS', -'doubleabove', -'DA', -'attachedaboveright', -'ATAR', -'overlay', -'OV', -}, -); - -%utf8::PVA_abbr_map = ( -'jt', -{ -'l', -'L', -'u', -'U', -'c', -'C', -'r', -'R', -'d', -'D', -'t', -'T', -}, -'dt', -{ -'fra', -'fra', -'none', -'none', -'sml', -'sml', -'enc', -'enc', -'font', -'font', -'init', -'init', -'nb', -'nb', -'iso', -'iso', -'sup', -'sup', -'fin', -'fin', -'wide', -'wide', -'nar', -'nar', -'can', -'can', -'med', -'med', -'sub', -'sub', -'vert', -'vert', -'sqr', -'sqr', -'com', -'com', -}, -'nt', -{ -'none', -'None', -'di', -'Di', -'de', -'De', -'nu', -'Nu', -}, -'NFKD_QC', -{ -'y', -'Y', -'n', -'N', -}, -'ea', -{ -'w', -'W', -'n', -'N', -'h', -'H', -'a', -'A', -'f', -'F', -'na', -'Na', -}, -'gc_sc', -{ -'runr', -'Runr', -'osma', -'Osma', -'sc', -'Sc', -'mc', -'Mc', -'hano', -'Hano', -'cans', -'Cans', -'lm', -'Lm', -'cn', -'Cn', -'knda', -'Knda', -'orya', -'Orya', -'cher', -'Cher', -'khmr', -'Khmr', -'ogam', -'Ogam', -'lo', -'Lo', -'po', -'Po', -'co', -'Co', -'ital', -'Ital', -'ll', -'Ll', -'tibt', -'Tibt', -'kana', -'Kana', -'zp', -'Zp', -'gujr', -'Gujr', -'thaa', -'Thaa', -'cs', -'Cs', -'copt', -'Copt', -'z', -'Z', -'ps', -'Ps', -'sylo', -'Sylo', -'talu', -'Talu', -'laoo', -'Laoo', -'sinh', -'Sinh', -'zl', -'Zl', -'pc', -'Pc', -'hira', -'Hira', -'limb', -'Limb', -'mymr', -'Mymr', -'yiii', -'Yiii', -'arab', -'Arab', -'deva', -'Deva', -'xpeo', -'Xpeo', -'cprt', -'Cprt', -'bugi', -'Bugi', -'sk', -'Sk', -'hebr', -'Hebr', -'lu', -'Lu', -'pe', -'Pe', -'tglg', -'Tglg', -'tagb', -'Tagb', -'mlym', -'Mlym', -'pf', -'Pf', -'no', -'No', -'grek', -'Grek', -'ethi', -'Ethi', -'mong', -'Mong', -'cc', -'Cc', -'hrkt', -'Hrkt', -'armn', -'Armn', -'zs', -'Zs', -'so', -'So', -'hani', -'Hani', -'shaw', -'Shaw', -'taml', -'Taml', -'me', -'Me', -'cf', -'Cf', -'nd', -'Nd', -'s', -'S', -'guru', -'Guru', -'ugar', -'Ugar', -'qaai', -'Qaai', -'lt', -'Lt', -'c', -'C', -'pd', -'Pd', -'cyrl', -'Cyrl', -'l&', -'LC', -'thai', -'Thai', -'beng', -'Beng', -'brai', -'Brai', -'telu', -'Telu', -'pi', -'Pi', -'geor', -'Geor', -'glag', -'Glag', -'hang', -'Hang', -'syrc', -'Syrc', -'tfng', -'Tfng', -'n', -'N', -'dsrt', -'Dsrt', -'buhd', -'Buhd', -'m', -'M', -'khar', -'Khar', -'sm', -'Sm', -'nl', -'Nl', -'bopo', -'Bopo', -'linb', -'Linb', -'mn', -'Mn', -'l', -'L', -'p', -'P', -'goth', -'Goth', -'tale', -'Tale', -'lc', -'LC', -'zyyy', -'Zyyy', -'latn', -'Latn', -}, -'NFC_QC', -{ -'y', -'Y', -'n', -'N', -'m', -'M', -}, -'NFD_QC', -{ -'y', -'Y', -'n', -'N', -}, -'hst', -{ -'l', -'L', -'lvt', -'LVT', -'v', -'V', -'lv', -'LV', -'t', -'T', -'na', -'NA', -}, -'NFKC_QC', -{ -'y', -'Y', -'n', -'N', -'m', -'M', -}, -'WB', -{ -'ml', -'ML', -'le', -'LE', -'ex', -'EX', -'xx', -'XX', -'nu', -'NU', -'fo', -'FO', -'mn', -'MN', -'ka', -'KA', -}, -'SB', -{ -'sp', -'SP', -'cl', -'CL', -'le', -'LE', -'up', -'UP', -'st', -'ST', -'xx', -'XX', -'nu', -'NU', -'fo', -'FO', -'se', -'SE', -'lo', -'LO', -'at', -'AT', -}, -'bc', -{ -'r', -'R', -'rlo', -'RLO', -'es', -'ES', -'ws', -'WS', -'rle', -'RLE', -'on', -'ON', -'bn', -'BN', -'et', -'ET', -'pdf', -'PDF', -'lro', -'LRO', -'s', -'S', -'al', -'AL', -'en', -'EN', -'l', -'L', -'b', -'B', -'lre', -'LRE', -'cs', -'CS', -'nsm', -'NSM', -'an', -'AN', -}, -'GCB', -{ -'cn', -'CN', -'ex', -'EX', -'v', -'V', -'lv', -'LV', -'xx', -'XX', -'l', -'L', -'lvt', -'LVT', -'cr', -'CR', -'lf', -'LF', -'t', -'T', -}, -'ccc', -{ -'atb', -'ATB', -'db', -'DB', -'a', -'A', -'r', -'R', -'da', -'DA', -'is', -'IS', -'nr', -'NR', -'ov', -'OV', -'br', -'BR', -'nk', -'NK', -'atbl', -'ATBL', -'al', -'AL', -'ar', -'AR', -'atar', -'ATAR', -'l', -'L', -'b', -'B', -'vr', -'VR', -'kv', -'KV', -'bl', -'BL', -}, -'lb', -{ -'sp', -'SP', -'ba', -'BA', -'gl', -'GL', -'xx', -'XX', -'nu', -'NU', -'cb', -'CB', -'sy', -'SY', -'cr', -'CR', -'in', -'IN', -'bb', -'BB', -'sg', -'SG', -'sa', -'SA', -'po', -'PO', -'jl', -'JL', -'id', -'ID', -'al', -'AL', -'bk', -'BK', -'pr', -'PR', -'b2', -'B2', -'op', -'OP', -'cl', -'CL', -'is', -'IS', -'qu', -'QU', -'hy', -'HY', -'wj', -'WJ', -'zw', -'ZW', -'jt', -'JT', -'ex', -'EX', -'cm', -'CM', -'h2', -'H2', -'nl', -'NL', -'ns', -'NS', -'h3', -'H3', -'ai', -'AI', -'lf', -'LF', -'jv', -'JV', -}, -); -1; diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/unicore/To/Lower.pl b/Master/tlpkg/lib/Perl5_lib-TL_inst/unicore/To/Lower.pl deleted file mode 100644 index 77a7a7fb0e0..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/unicore/To/Lower.pl +++ /dev/null @@ -1,905 +0,0 @@ -# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables from e.g. UnicodeData.txt. -# Any changes made here will be lost! - - -# The key UTF-8 _bytes_, the value UTF-8 (speed hack) -%utf8::ToSpecLower = -( -"\xC4\xB0" => "\x{0069}\x{0307}", -"\xE1\xBE\x88" => "\x{1F80}", -"\xE1\xBE\x89" => "\x{1F81}", -"\xE1\xBE\x8A" => "\x{1F82}", -"\xE1\xBE\x8B" => "\x{1F83}", -"\xE1\xBE\x8C" => "\x{1F84}", -"\xE1\xBE\x8D" => "\x{1F85}", -"\xE1\xBE\x8E" => "\x{1F86}", -"\xE1\xBE\x8F" => "\x{1F87}", -"\xE1\xBE\x98" => "\x{1F90}", -"\xE1\xBE\x99" => "\x{1F91}", -"\xE1\xBE\x9A" => "\x{1F92}", -"\xE1\xBE\x9B" => "\x{1F93}", -"\xE1\xBE\x9C" => "\x{1F94}", -"\xE1\xBE\x9D" => "\x{1F95}", -"\xE1\xBE\x9E" => "\x{1F96}", -"\xE1\xBE\x9F" => "\x{1F97}", -"\xE1\xBE\xA8" => "\x{1FA0}", -"\xE1\xBE\xA9" => "\x{1FA1}", -"\xE1\xBE\xAA" => "\x{1FA2}", -"\xE1\xBE\xAB" => "\x{1FA3}", -"\xE1\xBE\xAC" => "\x{1FA4}", -"\xE1\xBE\xAD" => "\x{1FA5}", -"\xE1\xBE\xAE" => "\x{1FA6}", -"\xE1\xBE\xAF" => "\x{1FA7}", -"\xE1\xBE\xBC" => "\x{1FB3}", -"\xE1\xBF\x8C" => "\x{1FC3}", -"\xE1\xBF\xBC" => "\x{1FF3}", -); - -return <<'END'; -0041 0061 -0042 0062 -0043 0063 -0044 0064 -0045 0065 -0046 0066 -0047 0067 -0048 0068 -0049 0069 -004A 006A -004B 006B -004C 006C -004D 006D -004E 006E -004F 006F -0050 0070 -0051 0071 -0052 0072 -0053 0073 -0054 0074 -0055 0075 -0056 0076 -0057 0077 -0058 0078 -0059 0079 -005A 007A -00C0 00E0 -00C1 00E1 -00C2 00E2 -00C3 00E3 -00C4 00E4 -00C5 00E5 -00C6 00E6 -00C7 00E7 -00C8 00E8 -00C9 00E9 -00CA 00EA -00CB 00EB -00CC 00EC -00CD 00ED -00CE 00EE -00CF 00EF -00D0 00F0 -00D1 00F1 -00D2 00F2 -00D3 00F3 -00D4 00F4 -00D5 00F5 -00D6 00F6 -00D8 00F8 -00D9 00F9 -00DA 00FA -00DB 00FB -00DC 00FC -00DD 00FD -00DE 00FE -0100 0101 -0102 0103 -0104 0105 -0106 0107 -0108 0109 -010A 010B -010C 010D -010E 010F -0110 0111 -0112 0113 -0114 0115 -0116 0117 -0118 0119 -011A 011B -011C 011D -011E 011F -0120 0121 -0122 0123 -0124 0125 -0126 0127 -0128 0129 -012A 012B -012C 012D -012E 012F -0132 0133 -0134 0135 -0136 0137 -0139 013A -013B 013C -013D 013E -013F 0140 -0141 0142 -0143 0144 -0145 0146 -0147 0148 -014A 014B -014C 014D -014E 014F -0150 0151 -0152 0153 -0154 0155 -0156 0157 -0158 0159 -015A 015B -015C 015D -015E 015F -0160 0161 -0162 0163 -0164 0165 -0166 0167 -0168 0169 -016A 016B -016C 016D -016E 016F -0170 0171 -0172 0173 -0174 0175 -0176 0177 -0178 00FF -0179 017A -017B 017C -017D 017E -0181 0253 -0182 0183 -0184 0185 -0186 0254 -0187 0188 -0189 0256 -018A 0257 -018B 018C -018E 01DD -018F 0259 -0190 025B -0191 0192 -0193 0260 -0194 0263 -0196 0269 -0197 0268 -0198 0199 -019C 026F -019D 0272 -019F 0275 -01A0 01A1 -01A2 01A3 -01A4 01A5 -01A6 0280 -01A7 01A8 -01A9 0283 -01AC 01AD -01AE 0288 -01AF 01B0 -01B1 028A -01B2 028B -01B3 01B4 -01B5 01B6 -01B7 0292 -01B8 01B9 -01BC 01BD -01C4 01C6 -01C5 01C6 -01C7 01C9 -01C8 01C9 -01CA 01CC -01CB 01CC -01CD 01CE -01CF 01D0 -01D1 01D2 -01D3 01D4 -01D5 01D6 -01D7 01D8 -01D9 01DA -01DB 01DC -01DE 01DF -01E0 01E1 -01E2 01E3 -01E4 01E5 -01E6 01E7 -01E8 01E9 -01EA 01EB -01EC 01ED -01EE 01EF -01F1 01F3 -01F2 01F3 -01F4 01F5 -01F6 0195 -01F7 01BF -01F8 01F9 -01FA 01FB -01FC 01FD -01FE 01FF -0200 0201 -0202 0203 -0204 0205 -0206 0207 -0208 0209 -020A 020B -020C 020D -020E 020F -0210 0211 -0212 0213 -0214 0215 -0216 0217 -0218 0219 -021A 021B -021C 021D -021E 021F -0220 019E -0222 0223 -0224 0225 -0226 0227 -0228 0229 -022A 022B -022C 022D -022E 022F -0230 0231 -0232 0233 -023B 023C -023D 019A -0241 0294 -0386 03AC -0388 03AD -0389 03AE -038A 03AF -038C 03CC -038E 03CD -038F 03CE -0391 03B1 -0392 03B2 -0393 03B3 -0394 03B4 -0395 03B5 -0396 03B6 -0397 03B7 -0398 03B8 -0399 03B9 -039A 03BA -039B 03BB -039C 03BC -039D 03BD -039E 03BE -039F 03BF -03A0 03C0 -03A1 03C1 -03A3 03C3 -03A4 03C4 -03A5 03C5 -03A6 03C6 -03A7 03C7 -03A8 03C8 -03A9 03C9 -03AA 03CA -03AB 03CB -03D8 03D9 -03DA 03DB -03DC 03DD -03DE 03DF -03E0 03E1 -03E2 03E3 -03E4 03E5 -03E6 03E7 -03E8 03E9 -03EA 03EB -03EC 03ED -03EE 03EF -03F4 03B8 -03F7 03F8 -03F9 03F2 -03FA 03FB -0400 0450 -0401 0451 -0402 0452 -0403 0453 -0404 0454 -0405 0455 -0406 0456 -0407 0457 -0408 0458 -0409 0459 -040A 045A -040B 045B -040C 045C -040D 045D -040E 045E -040F 045F -0410 0430 -0411 0431 -0412 0432 -0413 0433 -0414 0434 -0415 0435 -0416 0436 -0417 0437 -0418 0438 -0419 0439 -041A 043A -041B 043B -041C 043C -041D 043D -041E 043E -041F 043F -0420 0440 -0421 0441 -0422 0442 -0423 0443 -0424 0444 -0425 0445 -0426 0446 -0427 0447 -0428 0448 -0429 0449 -042A 044A -042B 044B -042C 044C -042D 044D -042E 044E -042F 044F -0460 0461 -0462 0463 -0464 0465 -0466 0467 -0468 0469 -046A 046B -046C 046D -046E 046F -0470 0471 -0472 0473 -0474 0475 -0476 0477 -0478 0479 -047A 047B -047C 047D -047E 047F -0480 0481 -048A 048B -048C 048D -048E 048F -0490 0491 -0492 0493 -0494 0495 -0496 0497 -0498 0499 -049A 049B -049C 049D -049E 049F -04A0 04A1 -04A2 04A3 -04A4 04A5 -04A6 04A7 -04A8 04A9 -04AA 04AB -04AC 04AD -04AE 04AF -04B0 04B1 -04B2 04B3 -04B4 04B5 -04B6 04B7 -04B8 04B9 -04BA 04BB -04BC 04BD -04BE 04BF -04C1 04C2 -04C3 04C4 -04C5 04C6 -04C7 04C8 -04C9 04CA -04CB 04CC -04CD 04CE -04D0 04D1 -04D2 04D3 -04D4 04D5 -04D6 04D7 -04D8 04D9 -04DA 04DB -04DC 04DD -04DE 04DF -04E0 04E1 -04E2 04E3 -04E4 04E5 -04E6 04E7 -04E8 04E9 -04EA 04EB -04EC 04ED -04EE 04EF -04F0 04F1 -04F2 04F3 -04F4 04F5 -04F6 04F7 -04F8 04F9 -0500 0501 -0502 0503 -0504 0505 -0506 0507 -0508 0509 -050A 050B -050C 050D -050E 050F -0531 0561 -0532 0562 -0533 0563 -0534 0564 -0535 0565 -0536 0566 -0537 0567 -0538 0568 -0539 0569 -053A 056A -053B 056B -053C 056C -053D 056D -053E 056E -053F 056F -0540 0570 -0541 0571 -0542 0572 -0543 0573 -0544 0574 -0545 0575 -0546 0576 -0547 0577 -0548 0578 -0549 0579 -054A 057A -054B 057B -054C 057C -054D 057D -054E 057E -054F 057F -0550 0580 -0551 0581 -0552 0582 -0553 0583 -0554 0584 -0555 0585 -0556 0586 -10A0 2D00 -10A1 2D01 -10A2 2D02 -10A3 2D03 -10A4 2D04 -10A5 2D05 -10A6 2D06 -10A7 2D07 -10A8 2D08 -10A9 2D09 -10AA 2D0A -10AB 2D0B -10AC 2D0C -10AD 2D0D -10AE 2D0E -10AF 2D0F -10B0 2D10 -10B1 2D11 -10B2 2D12 -10B3 2D13 -10B4 2D14 -10B5 2D15 -10B6 2D16 -10B7 2D17 -10B8 2D18 -10B9 2D19 -10BA 2D1A -10BB 2D1B -10BC 2D1C -10BD 2D1D -10BE 2D1E -10BF 2D1F -10C0 2D20 -10C1 2D21 -10C2 2D22 -10C3 2D23 -10C4 2D24 -10C5 2D25 -1E00 1E01 -1E02 1E03 -1E04 1E05 -1E06 1E07 -1E08 1E09 -1E0A 1E0B -1E0C 1E0D -1E0E 1E0F -1E10 1E11 -1E12 1E13 -1E14 1E15 -1E16 1E17 -1E18 1E19 -1E1A 1E1B -1E1C 1E1D -1E1E 1E1F -1E20 1E21 -1E22 1E23 -1E24 1E25 -1E26 1E27 -1E28 1E29 -1E2A 1E2B -1E2C 1E2D -1E2E 1E2F -1E30 1E31 -1E32 1E33 -1E34 1E35 -1E36 1E37 -1E38 1E39 -1E3A 1E3B -1E3C 1E3D -1E3E 1E3F -1E40 1E41 -1E42 1E43 -1E44 1E45 -1E46 1E47 -1E48 1E49 -1E4A 1E4B -1E4C 1E4D -1E4E 1E4F -1E50 1E51 -1E52 1E53 -1E54 1E55 -1E56 1E57 -1E58 1E59 -1E5A 1E5B -1E5C 1E5D -1E5E 1E5F -1E60 1E61 -1E62 1E63 -1E64 1E65 -1E66 1E67 -1E68 1E69 -1E6A 1E6B -1E6C 1E6D -1E6E 1E6F -1E70 1E71 -1E72 1E73 -1E74 1E75 -1E76 1E77 -1E78 1E79 -1E7A 1E7B -1E7C 1E7D -1E7E 1E7F -1E80 1E81 -1E82 1E83 -1E84 1E85 -1E86 1E87 -1E88 1E89 -1E8A 1E8B -1E8C 1E8D -1E8E 1E8F -1E90 1E91 -1E92 1E93 -1E94 1E95 -1EA0 1EA1 -1EA2 1EA3 -1EA4 1EA5 -1EA6 1EA7 -1EA8 1EA9 -1EAA 1EAB -1EAC 1EAD -1EAE 1EAF -1EB0 1EB1 -1EB2 1EB3 -1EB4 1EB5 -1EB6 1EB7 -1EB8 1EB9 -1EBA 1EBB -1EBC 1EBD -1EBE 1EBF -1EC0 1EC1 -1EC2 1EC3 -1EC4 1EC5 -1EC6 1EC7 -1EC8 1EC9 -1ECA 1ECB -1ECC 1ECD -1ECE 1ECF -1ED0 1ED1 -1ED2 1ED3 -1ED4 1ED5 -1ED6 1ED7 -1ED8 1ED9 -1EDA 1EDB -1EDC 1EDD -1EDE 1EDF -1EE0 1EE1 -1EE2 1EE3 -1EE4 1EE5 -1EE6 1EE7 -1EE8 1EE9 -1EEA 1EEB -1EEC 1EED -1EEE 1EEF -1EF0 1EF1 -1EF2 1EF3 -1EF4 1EF5 -1EF6 1EF7 -1EF8 1EF9 -1F08 1F00 -1F09 1F01 -1F0A 1F02 -1F0B 1F03 -1F0C 1F04 -1F0D 1F05 -1F0E 1F06 -1F0F 1F07 -1F18 1F10 -1F19 1F11 -1F1A 1F12 -1F1B 1F13 -1F1C 1F14 -1F1D 1F15 -1F28 1F20 -1F29 1F21 -1F2A 1F22 -1F2B 1F23 -1F2C 1F24 -1F2D 1F25 -1F2E 1F26 -1F2F 1F27 -1F38 1F30 -1F39 1F31 -1F3A 1F32 -1F3B 1F33 -1F3C 1F34 -1F3D 1F35 -1F3E 1F36 -1F3F 1F37 -1F48 1F40 -1F49 1F41 -1F4A 1F42 -1F4B 1F43 -1F4C 1F44 -1F4D 1F45 -1F59 1F51 -1F5B 1F53 -1F5D 1F55 -1F5F 1F57 -1F68 1F60 -1F69 1F61 -1F6A 1F62 -1F6B 1F63 -1F6C 1F64 -1F6D 1F65 -1F6E 1F66 -1F6F 1F67 -1FB8 1FB0 -1FB9 1FB1 -1FBA 1F70 -1FBB 1F71 -1FC8 1F72 -1FC9 1F73 -1FCA 1F74 -1FCB 1F75 -1FD8 1FD0 -1FD9 1FD1 -1FDA 1F76 -1FDB 1F77 -1FE8 1FE0 -1FE9 1FE1 -1FEA 1F7A -1FEB 1F7B -1FEC 1FE5 -1FF8 1F78 -1FF9 1F79 -1FFA 1F7C -1FFB 1F7D -2126 03C9 -212A 006B -212B 00E5 -2160 2170 -2161 2171 -2162 2172 -2163 2173 -2164 2174 -2165 2175 -2166 2176 -2167 2177 -2168 2178 -2169 2179 -216A 217A -216B 217B -216C 217C -216D 217D -216E 217E -216F 217F -24B6 24D0 -24B7 24D1 -24B8 24D2 -24B9 24D3 -24BA 24D4 -24BB 24D5 -24BC 24D6 -24BD 24D7 -24BE 24D8 -24BF 24D9 -24C0 24DA -24C1 24DB -24C2 24DC -24C3 24DD -24C4 24DE -24C5 24DF -24C6 24E0 -24C7 24E1 -24C8 24E2 -24C9 24E3 -24CA 24E4 -24CB 24E5 -24CC 24E6 -24CD 24E7 -24CE 24E8 -24CF 24E9 -2C00 2C30 -2C01 2C31 -2C02 2C32 -2C03 2C33 -2C04 2C34 -2C05 2C35 -2C06 2C36 -2C07 2C37 -2C08 2C38 -2C09 2C39 -2C0A 2C3A -2C0B 2C3B -2C0C 2C3C -2C0D 2C3D -2C0E 2C3E -2C0F 2C3F -2C10 2C40 -2C11 2C41 -2C12 2C42 -2C13 2C43 -2C14 2C44 -2C15 2C45 -2C16 2C46 -2C17 2C47 -2C18 2C48 -2C19 2C49 -2C1A 2C4A -2C1B 2C4B -2C1C 2C4C -2C1D 2C4D -2C1E 2C4E -2C1F 2C4F -2C20 2C50 -2C21 2C51 -2C22 2C52 -2C23 2C53 -2C24 2C54 -2C25 2C55 -2C26 2C56 -2C27 2C57 -2C28 2C58 -2C29 2C59 -2C2A 2C5A -2C2B 2C5B -2C2C 2C5C -2C2D 2C5D -2C2E 2C5E -2C80 2C81 -2C82 2C83 -2C84 2C85 -2C86 2C87 -2C88 2C89 -2C8A 2C8B -2C8C 2C8D -2C8E 2C8F -2C90 2C91 -2C92 2C93 -2C94 2C95 -2C96 2C97 -2C98 2C99 -2C9A 2C9B -2C9C 2C9D -2C9E 2C9F -2CA0 2CA1 -2CA2 2CA3 -2CA4 2CA5 -2CA6 2CA7 -2CA8 2CA9 -2CAA 2CAB -2CAC 2CAD -2CAE 2CAF -2CB0 2CB1 -2CB2 2CB3 -2CB4 2CB5 -2CB6 2CB7 -2CB8 2CB9 -2CBA 2CBB -2CBC 2CBD -2CBE 2CBF -2CC0 2CC1 -2CC2 2CC3 -2CC4 2CC5 -2CC6 2CC7 -2CC8 2CC9 -2CCA 2CCB -2CCC 2CCD -2CCE 2CCF -2CD0 2CD1 -2CD2 2CD3 -2CD4 2CD5 -2CD6 2CD7 -2CD8 2CD9 -2CDA 2CDB -2CDC 2CDD -2CDE 2CDF -2CE0 2CE1 -2CE2 2CE3 -FF21 FF41 -FF22 FF42 -FF23 FF43 -FF24 FF44 -FF25 FF45 -FF26 FF46 -FF27 FF47 -FF28 FF48 -FF29 FF49 -FF2A FF4A -FF2B FF4B -FF2C FF4C -FF2D FF4D -FF2E FF4E -FF2F FF4F -FF30 FF50 -FF31 FF51 -FF32 FF52 -FF33 FF53 -FF34 FF54 -FF35 FF55 -FF36 FF56 -FF37 FF57 -FF38 FF58 -FF39 FF59 -FF3A FF5A -10400 10428 -10401 10429 -10402 1042A -10403 1042B -10404 1042C -10405 1042D -10406 1042E -10407 1042F -10408 10430 -10409 10431 -1040A 10432 -1040B 10433 -1040C 10434 -1040D 10435 -1040E 10436 -1040F 10437 -10410 10438 -10411 10439 -10412 1043A -10413 1043B -10414 1043C -10415 1043D -10416 1043E -10417 1043F -10418 10440 -10419 10441 -1041A 10442 -1041B 10443 -1041C 10444 -1041D 10445 -1041E 10446 -1041F 10447 -10420 10448 -10421 10449 -10422 1044A -10423 1044B -10424 1044C -10425 1044D -10426 1044E -10427 1044F -END diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/unicore/lib/gc_sc/Uppercas.pl b/Master/tlpkg/lib/Perl5_lib-TL_inst/unicore/lib/gc_sc/Uppercas.pl deleted file mode 100644 index 4778dc3ab52..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/unicore/lib/gc_sc/Uppercas.pl +++ /dev/null @@ -1,490 +0,0 @@ -# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file is built by mktables from e.g. UnicodeData.txt. -# Any changes made here will be lost! - -# -# This file supports: -# \p{Uppercase} (and fuzzy permutations) -# -# Meaning: [\p{Lu}\p{Other_Uppercase}] -# -return <<'END'; -0041 005A -00C0 00D6 -00D8 00DE -0100 -0102 -0104 -0106 -0108 -010A -010C -010E -0110 -0112 -0114 -0116 -0118 -011A -011C -011E -0120 -0122 -0124 -0126 -0128 -012A -012C -012E -0130 -0132 -0134 -0136 -0139 -013B -013D -013F -0141 -0143 -0145 -0147 -014A -014C -014E -0150 -0152 -0154 -0156 -0158 -015A -015C -015E -0160 -0162 -0164 -0166 -0168 -016A -016C -016E -0170 -0172 -0174 -0176 -0178 0179 -017B -017D -0181 0182 -0184 -0186 0187 -0189 018B -018E 0191 -0193 0194 -0196 0198 -019C 019D -019F 01A0 -01A2 -01A4 -01A6 01A7 -01A9 -01AC -01AE 01AF -01B1 01B3 -01B5 -01B7 01B8 -01BC -01C4 -01C7 -01CA -01CD -01CF -01D1 -01D3 -01D5 -01D7 -01D9 -01DB -01DE -01E0 -01E2 -01E4 -01E6 -01E8 -01EA -01EC -01EE -01F1 -01F4 -01F6 01F8 -01FA -01FC -01FE -0200 -0202 -0204 -0206 -0208 -020A -020C -020E -0210 -0212 -0214 -0216 -0218 -021A -021C -021E -0220 -0222 -0224 -0226 -0228 -022A -022C -022E -0230 -0232 -023A 023B -023D 023E -0241 -0386 -0388 038A -038C -038E 038F -0391 03A1 -03A3 03AB -03D2 03D4 -03D8 -03DA -03DC -03DE -03E0 -03E2 -03E4 -03E6 -03E8 -03EA -03EC -03EE -03F4 -03F7 -03F9 03FA -03FD 042F -0460 -0462 -0464 -0466 -0468 -046A -046C -046E -0470 -0472 -0474 -0476 -0478 -047A -047C -047E -0480 -048A -048C -048E -0490 -0492 -0494 -0496 -0498 -049A -049C -049E -04A0 -04A2 -04A4 -04A6 -04A8 -04AA -04AC -04AE -04B0 -04B2 -04B4 -04B6 -04B8 -04BA -04BC -04BE -04C0 04C1 -04C3 -04C5 -04C7 -04C9 -04CB -04CD -04D0 -04D2 -04D4 -04D6 -04D8 -04DA -04DC -04DE -04E0 -04E2 -04E4 -04E6 -04E8 -04EA -04EC -04EE -04F0 -04F2 -04F4 -04F6 -04F8 -0500 -0502 -0504 -0506 -0508 -050A -050C -050E -0531 0556 -10A0 10C5 -1E00 -1E02 -1E04 -1E06 -1E08 -1E0A -1E0C -1E0E -1E10 -1E12 -1E14 -1E16 -1E18 -1E1A -1E1C -1E1E -1E20 -1E22 -1E24 -1E26 -1E28 -1E2A -1E2C -1E2E -1E30 -1E32 -1E34 -1E36 -1E38 -1E3A -1E3C -1E3E -1E40 -1E42 -1E44 -1E46 -1E48 -1E4A -1E4C -1E4E -1E50 -1E52 -1E54 -1E56 -1E58 -1E5A -1E5C -1E5E -1E60 -1E62 -1E64 -1E66 -1E68 -1E6A -1E6C -1E6E -1E70 -1E72 -1E74 -1E76 -1E78 -1E7A -1E7C -1E7E -1E80 -1E82 -1E84 -1E86 -1E88 -1E8A -1E8C -1E8E -1E90 -1E92 -1E94 -1EA0 -1EA2 -1EA4 -1EA6 -1EA8 -1EAA -1EAC -1EAE -1EB0 -1EB2 -1EB4 -1EB6 -1EB8 -1EBA -1EBC -1EBE -1EC0 -1EC2 -1EC4 -1EC6 -1EC8 -1ECA -1ECC -1ECE -1ED0 -1ED2 -1ED4 -1ED6 -1ED8 -1EDA -1EDC -1EDE -1EE0 -1EE2 -1EE4 -1EE6 -1EE8 -1EEA -1EEC -1EEE -1EF0 -1EF2 -1EF4 -1EF6 -1EF8 -1F08 1F0F -1F18 1F1D -1F28 1F2F -1F38 1F3F -1F48 1F4D -1F59 -1F5B -1F5D -1F5F -1F68 1F6F -1FB8 1FBB -1FC8 1FCB -1FD8 1FDB -1FE8 1FEC -1FF8 1FFB -2102 -2107 -210B 210D -2110 2112 -2115 -2119 211D -2124 -2126 -2128 -212A 212D -2130 2131 -2133 -213E 213F -2145 -2160 216F -24B6 24CF -2C00 2C2E -2C80 -2C82 -2C84 -2C86 -2C88 -2C8A -2C8C -2C8E -2C90 -2C92 -2C94 -2C96 -2C98 -2C9A -2C9C -2C9E -2CA0 -2CA2 -2CA4 -2CA6 -2CA8 -2CAA -2CAC -2CAE -2CB0 -2CB2 -2CB4 -2CB6 -2CB8 -2CBA -2CBC -2CBE -2CC0 -2CC2 -2CC4 -2CC6 -2CC8 -2CCA -2CCC -2CCE -2CD0 -2CD2 -2CD4 -2CD6 -2CD8 -2CDA -2CDC -2CDE -2CE0 -2CE2 -FF21 FF3A -10400 10427 -1D400 1D419 -1D434 1D44D -1D468 1D481 -1D49C -1D49E 1D49F -1D4A2 -1D4A5 1D4A6 -1D4A9 1D4AC -1D4AE 1D4B5 -1D4D0 1D4E9 -1D504 1D505 -1D507 1D50A -1D50D 1D514 -1D516 1D51C -1D538 1D539 -1D53B 1D53E -1D540 1D544 -1D546 -1D54A 1D550 -1D56C 1D585 -1D5A0 1D5B9 -1D5D4 1D5ED -1D608 1D621 -1D63C 1D655 -1D670 1D689 -1D6A8 1D6C0 -1D6E2 1D6FA -1D71C 1D734 -1D756 1D76E -1D790 1D7A8 -END diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/utf8.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/utf8.pm deleted file mode 100644 index 56c991bef9a..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/utf8.pm +++ /dev/null @@ -1,214 +0,0 @@ -package utf8; - -$utf8::hint_bits = 0x00800000; - -our $VERSION = '1.06'; - -sub import { - $^H |= $utf8::hint_bits; - $enc{caller()} = $_[1] if $_[1]; -} - -sub unimport { - $^H &= ~$utf8::hint_bits; -} - -sub AUTOLOAD { - require "utf8_heavy.pl"; - goto &$AUTOLOAD if defined &$AUTOLOAD; - require Carp; - Carp::croak("Undefined subroutine $AUTOLOAD called"); -} - -1; -__END__ - -=head1 NAME - -utf8 - Perl pragma to enable/disable UTF-8 (or UTF-EBCDIC) in source code - -=head1 SYNOPSIS - - use utf8; - no utf8; - - # Convert a Perl scalar to/from UTF-8. - $num_octets = utf8::upgrade($string); - $success = utf8::downgrade($string[, FAIL_OK]); - - # Change the native bytes of a Perl scalar to/from UTF-8 bytes. - utf8::encode($string); - utf8::decode($string); - - $flag = utf8::is_utf8(STRING); # since Perl 5.8.1 - $flag = utf8::valid(STRING); - -=head1 DESCRIPTION - -The C<use utf8> pragma tells the Perl parser to allow UTF-8 in the -program text in the current lexical scope (allow UTF-EBCDIC on EBCDIC based -platforms). The C<no utf8> pragma tells Perl to switch back to treating -the source text as literal bytes in the current lexical scope. - -This pragma is primarily a compatibility device. Perl versions -earlier than 5.6 allowed arbitrary bytes in source code, whereas -in future we would like to standardize on the UTF-8 encoding for -source text. - -B<Do not use this pragma for anything else than telling Perl that your -script is written in UTF-8.> The utility functions described below are -useful for their own purposes, but they are not really part of the -"pragmatic" effect. - -Until UTF-8 becomes the default format for source text, either this -pragma or the L<encoding> pragma should be used to recognize UTF-8 -in the source. When UTF-8 becomes the standard source format, this -pragma will effectively become a no-op. For convenience in what -follows the term I<UTF-X> is used to refer to UTF-8 on ASCII and ISO -Latin based platforms and UTF-EBCDIC on EBCDIC based platforms. - -See also the effects of the C<-C> switch and its cousin, the -C<$ENV{PERL_UNICODE}>, in L<perlrun>. - -Enabling the C<utf8> pragma has the following effect: - -=over 4 - -=item * - -Bytes in the source text that have their high-bit set will be treated -as being part of a literal UTF-8 character. This includes most -literals such as identifier names, string constants, and constant -regular expression patterns. - -On EBCDIC platforms characters in the Latin 1 character set are -treated as being part of a literal UTF-EBCDIC character. - -=back - -Note that if you have bytes with the eighth bit on in your script -(for example embedded Latin-1 in your string literals), C<use utf8> -will be unhappy since the bytes are most probably not well-formed -UTF-8. If you want to have such bytes and use utf8, you can disable -utf8 until the end the block (or file, if at top level) by C<no utf8;>. - -If you want to automatically upgrade your 8-bit legacy bytes to UTF-8, -use the L<encoding> pragma instead of this pragma. For example, if -you want to implicitly upgrade your ISO 8859-1 (Latin-1) bytes to UTF-8 -as used in e.g. C<chr()> and C<\x{...}>, try this: - - use encoding "latin-1"; - my $c = chr(0xc4); - my $x = "\x{c5}"; - -In case you are wondering: yes, C<use encoding 'utf8';> works much -the same as C<use utf8;>. - -=head2 Utility functions - -The following functions are defined in the C<utf8::> package by the -Perl core. You do not need to say C<use utf8> to use these and in fact -you should not say that unless you really want to have UTF-8 source code. - -=over 4 - -=item * $num_octets = utf8::upgrade($string) - -Converts in-place the octet sequence in the native encoding -(Latin-1 or EBCDIC) to the equivalent character sequence in I<UTF-X>. -I<$string> already encoded as characters does no harm. -Returns the number of octets necessary to represent the string as I<UTF-X>. -Can be used to make sure that the UTF-8 flag is on, -so that C<\w> or C<lc()> work as Unicode on strings -containing characters in the range 0x80-0xFF (on ASCII and -derivatives). - -B<Note that this function does not handle arbitrary encodings.> -Therefore I<Encode.pm> is recommended for the general purposes. - -Affected by the encoding pragma. - -=item * $success = utf8::downgrade($string[, FAIL_OK]) - -Converts in-place the character sequence in I<UTF-X> -to the equivalent octet sequence in the native encoding (Latin-1 or EBCDIC). -I<$string> already encoded as octets does no harm. -Returns true on success. On failure dies or, if the value of -C<FAIL_OK> is true, returns false. -Can be used to make sure that the UTF-8 flag is off, -e.g. when you want to make sure that the substr() or length() function -works with the usually faster byte algorithm. - -B<Note that this function does not handle arbitrary encodings.> -Therefore I<Encode.pm> is recommended for the general purposes. - -B<Not> affected by the encoding pragma. - -B<NOTE:> this function is experimental and may change -or be removed without notice. - -=item * utf8::encode($string) - -Converts in-place the character sequence to the corresponding octet sequence -in I<UTF-X>. The UTF-8 flag is turned off. Returns nothing. - -B<Note that this function does not handle arbitrary encodings.> -Therefore I<Encode.pm> is recommended for the general purposes. - -=item * utf8::decode($string) - -Attempts to convert in-place the octet sequence in I<UTF-X> -to the corresponding character sequence. The UTF-8 flag is turned on -only if the source string contains multiple-byte I<UTF-X> characters. -If I<$string> is invalid as I<UTF-X>, returns false; otherwise returns true. - -B<Note that this function does not handle arbitrary encodings.> -Therefore I<Encode.pm> is recommended for the general purposes. - -B<NOTE:> this function is experimental and may change -or be removed without notice. - -=item * $flag = utf8::is_utf8(STRING) - -(Since Perl 5.8.1) Test whether STRING is in UTF-8. Functionally -the same as Encode::is_utf8(). - -=item * $flag = utf8::valid(STRING) - -[INTERNAL] Test whether STRING is in a consistent state regarding -UTF-8. Will return true is well-formed UTF-8 and has the UTF-8 flag -on B<or> if string is held as bytes (both these states are 'consistent'). -Main reason for this routine is to allow Perl's testsuite to check -that operations have left strings in a consistent state. You most -probably want to use utf8::is_utf8() instead. - -=back - -C<utf8::encode> is like C<utf8::upgrade>, but the UTF8 flag is -cleared. See L<perlunicode> for more on the UTF8 flag and the C API -functions C<sv_utf8_upgrade>, C<sv_utf8_downgrade>, C<sv_utf8_encode>, -and C<sv_utf8_decode>, which are wrapped by the Perl functions -C<utf8::upgrade>, C<utf8::downgrade>, C<utf8::encode> and -C<utf8::decode>. Note that in the Perl 5.8.0 and 5.8.1 implementation -the functions utf8::is_utf8, utf8::valid, utf8::encode, utf8::decode, -utf8::upgrade, and utf8::downgrade are always available, without a -C<require utf8> statement-- this may change in future releases. - -=head1 BUGS - -One can have Unicode in identifier names, but not in package/class or -subroutine names. While some limited functionality towards this does -exist as of Perl 5.8.0, that is more accidental than designed; use of -Unicode for the said purposes is unsupported. - -One reason of this unfinishedness is its (currently) inherent -unportability: since both package names and subroutine names may need -to be mapped to file and directory names, the Unicode capability of -the filesystem becomes important-- and there unfortunately aren't -portable answers. - -=head1 SEE ALSO - -L<perluniintro>, L<encoding>, L<perlrun>, L<bytes>, L<perlunicode> - -=cut diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/utf8_heavy.pl b/Master/tlpkg/lib/Perl5_lib-TL_inst/utf8_heavy.pl deleted file mode 100644 index b6fdeb997b3..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/utf8_heavy.pl +++ /dev/null @@ -1,412 +0,0 @@ -package utf8; -use strict; -use warnings; - -sub DEBUG () { 0 } - -sub DESTROY {} - -my %Cache; - -our (%PropertyAlias, %PA_reverse, %PropValueAlias, %PVA_reverse, %PVA_abbr_map); - -sub croak { require Carp; Carp::croak(@_) } - -## -## "SWASH" == "SWATCH HASH". A "swatch" is a swatch of the Unicode landscape. -## It's a data structure that encodes a set of Unicode characters. -## - -sub SWASHNEW { - my ($class, $type, $list, $minbits, $none) = @_; - local $^D = 0 if $^D; - - print STDERR "SWASHNEW @_\n" if DEBUG; - - ## - ## Get the list of codepoints for the type. - ## Called from utf8.c - ## - ## Given a $type, our goal is to fill $list with the set of codepoint - ## ranges. - ## - ## To make the parsing of $type clear, this code takes the a rather - ## unorthodox approach of last'ing out of the block once we have the - ## info we need. Were this to be a subroutine, the 'last' would just - ## be a 'return'. - ## - my $file; ## file to load data from, and also part of the %Cache key. - my $ListSorted = 0; - - if ($type) - { - $type =~ s/^\s+//; - $type =~ s/\s+$//; - - print "type = $type\n" if DEBUG; - - GETFILE: - { - ## - ## It could be a user-defined property. - ## - - my $caller1 = $type =~ s/(.+)::// ? $1 : caller(1); - - if (defined $caller1 && $type =~ /^(?:\w+)$/) { - my $prop = "${caller1}::$type"; - if (exists &{$prop}) { - no strict 'refs'; - - $list = &{$prop}; - last GETFILE; - } - } - - my $wasIs; - - ($wasIs = $type =~ s/^Is(?:\s+|[-_])?//i) - or - $type =~ s/^(?:(?:General(?:\s+|_)?)?Category|gc)\s*[:=]\s*//i - or - $type =~ s/^(?:Script|sc)\s*[:=]\s*//i - or - $type =~ s/^Block\s*[:=]\s*/In/i; - - - ## - ## See if it's in some enumeration. - ## - require "unicore/PVA.pl"; - if ($type =~ /^([\w\s]+)[:=]\s*(.*)/) { - my ($enum, $val) = (lc $1, lc $2); - $enum =~ tr/ _-//d; - $val =~ tr/ _-//d; - - my $pa = $PropertyAlias{$enum} ? $enum : $PA_reverse{$enum}; - my $f = $PropValueAlias{$pa}{$val} ? $val : $PVA_reverse{$pa}{lc $val}; - - if ($pa and $f) { - $pa = "gc_sc" if $pa eq "gc" or $pa eq "sc"; - $file = "unicore/lib/$pa/$PVA_abbr_map{$pa}{lc $f}.pl"; - last GETFILE; - } - } - else { - my $t = lc $type; - $t =~ tr/ _-//d; - - if ($PropValueAlias{gc}{$t} or $PropValueAlias{sc}{$t}) { - $file = "unicore/lib/gc_sc/$PVA_abbr_map{gc_sc}{$t}.pl"; - last GETFILE; - } - } - - ## - ## See if it's in the direct mapping table. - ## - require "unicore/Exact.pl"; - if (my $base = $utf8::Exact{$type}) { - $file = "unicore/lib/gc_sc/$base.pl"; - last GETFILE; - } - - ## - ## If not there exactly, try the canonical form. The canonical - ## form is lowercased, with any separators (\s+|[-_]) removed. - ## - my $canonical = lc $type; - $canonical =~ s/(?<=[a-z\d])(?:\s+|[-_])(?=[a-z\d])//g; - print "canonical = $canonical\n" if DEBUG; - - require "unicore/Canonical.pl"; - if (my $base = ($utf8::Canonical{$canonical} || $utf8::Canonical{ lc $utf8::PropertyAlias{$canonical} })) { - $file = "unicore/lib/gc_sc/$base.pl"; - last GETFILE; - } - - ## - ## See if it's a user-level "To". - ## - - my $caller0 = caller(0); - - if (defined $caller0 && $type =~ /^To(?:\w+)$/) { - my $map = $caller0 . "::" . $type; - - if (exists &{$map}) { - no strict 'refs'; - - $list = &{$map}; - last GETFILE; - } - } - - ## - ## Last attempt -- see if it's a standard "To" name - ## (e.g. "ToLower") ToTitle is used by ucfirst(). - ## The user-level way to access ToDigit() and ToFold() - ## is to use Unicode::UCD. - ## - if ($type =~ /^To(Digit|Fold|Lower|Title|Upper)$/) - { - $file = "unicore/To/$1.pl"; - ## would like to test to see if $file actually exists.... - last GETFILE; - } - - ## - ## If we reach this line, it's because we couldn't figure - ## out what to do with $type. Ouch. - ## - - return $type; - } - - if (defined $file) { - print "found it (file='$file')\n" if DEBUG; - - ## - ## If we reach here, it was due to a 'last GETFILE' above - ## (exception: user-defined properties and mappings), so we - ## have a filename, so now we load it if we haven't already. - ## If we have, return the cached results. The cache key is the - ## file to load. - ## - if ($Cache{$file} and ref($Cache{$file}) eq $class) - { - print "Returning cached '$file' for \\p{$type}\n" if DEBUG; - return $Cache{$class, $file}; - } - - $list = do $file; - } - - $ListSorted = 1; ## we know that these lists are sorted - } - - my $extras; - my $bits = 0; - - my $ORIG = $list; - if ($list) { - my @tmp = split(/^/m, $list); - my %seen; - no warnings; - $extras = join '', grep /^[^0-9a-fA-F]/, @tmp; - $list = join '', - map { $_->[1] } - sort { $a->[0] <=> $b->[0] } - map { /^([0-9a-fA-F]+)/; [ hex($1), $_ ] } - grep { /^([0-9a-fA-F]+)/ and not $seen{$1}++ } @tmp; # XXX doesn't do ranges right - } - - if ($none) { - my $hextra = sprintf "%04x", $none + 1; - $list =~ s/\tXXXX$/\t$hextra/mg; - } - - if ($minbits < 32) { - my $top = 0; - while ($list =~ /^([0-9a-fA-F]+)(?:[\t]([0-9a-fA-F]+)?)(?:[ \t]([0-9a-fA-F]+))?/mg) { - my $min = hex $1; - my $max = defined $2 ? hex $2 : $min; - my $val = defined $3 ? hex $3 : 0; - $val += $max - $min if defined $3; - $top = $val if $val > $top; - } - $bits = - $top > 0xffff ? 32 : - $top > 0xff ? 16 : - $top > 1 ? 8 : 1 - } - $bits = $minbits if $bits < $minbits; - - my @extras; - for my $x ($extras) { - pos $x = 0; - while ($x =~ /^([^0-9a-fA-F\n])(.*)/mg) { - my $char = $1; - my $name = $2; - print STDERR "$1 => $2\n" if DEBUG; - if ($char =~ /[-+!&]/) { - my ($c,$t) = split(/::/, $name, 2); # bogus use of ::, really - my $subobj; - if ($c eq 'utf8') { - $subobj = utf8->SWASHNEW($t, "", 0, 0, 0); - } - elsif (exists &$name) { - $subobj = utf8->SWASHNEW($name, "", 0, 0, 0); - } - elsif ($c =~ /^([0-9a-fA-F]+)/) { - $subobj = utf8->SWASHNEW("", $c, 0, 0, 0); - } - return $subobj unless ref $subobj; - push @extras, $name => $subobj; - $bits = $subobj->{BITS} if $bits < $subobj->{BITS}; - } - } - } - - print STDERR "CLASS = $class, TYPE => $type, BITS => $bits, NONE => $none\nEXTRAS =>\n$extras\nLIST =>\n$list\n" if DEBUG; - - my $SWASH = bless { - TYPE => $type, - BITS => $bits, - EXTRAS => $extras, - LIST => $list, - NONE => $none, - @extras, - } => $class; - - if ($file) { - $Cache{$class, $file} = $SWASH; - } - - return $SWASH; -} - -# NOTE: utf8.c:swash_init() assumes entries are never modified once generated. - -sub SWASHGET { - # See utf8.c:Perl_swash_fetch for problems with this interface. - my ($self, $start, $len) = @_; - local $^D = 0 if $^D; - my $type = $self->{TYPE}; - my $bits = $self->{BITS}; - my $none = $self->{NONE}; - print STDERR "SWASHGET @_ [$type/$bits/$none]\n" if DEBUG; - my $end = $start + $len; - my $swatch = ""; - my $key; - vec($swatch, $len - 1, $bits) = 0; # Extend to correct length. - if ($none) { - for $key (0 .. $len - 1) { vec($swatch, $key, $bits) = $none } - } - - for ($self->{LIST}) { - pos $_ = 0; - if ($bits > 1) { - LINE: - while (/^([0-9a-fA-F]+)(?:[ \t]([0-9a-fA-F]+)?)?(?:[ \t]([0-9a-fA-F]+))?/mg) { - chomp; - my ($a, $b, $c) = ($1, $2, $3); - croak "$type: illegal mapping '$_'" - if $type =~ /^To/ && - !(defined $a && defined $c); - my $min = hex $a; - my $max = defined $b ? hex $b : $min; - my $val = defined $c ? hex $c : 0; - next if $max < $start; - print "$min $max $val\n" if DEBUG; - if ($none) { - if ($min < $start) { - $val += $start - $min if $val < $none; - $min = $start; - } - for ($key = $min; $key <= $max; $key++) { - last LINE if $key >= $end; - print STDERR "$key => $val\n" if DEBUG; - vec($swatch, $key - $start, $bits) = $val; - ++$val if $val < $none; - } - } - else { - if ($min < $start) { - $val += $start - $min; - $min = $start; - } - for ($key = $min; $key <= $max; $key++, $val++) { - last LINE if $key >= $end; - print STDERR "$key => $val\n" if DEBUG; - vec($swatch, $key - $start, $bits) = $val; - } - } - } - } - else { - LINE: - while (/^([0-9a-fA-F]+)(?:[ \t]+([0-9a-fA-F]+))?/mg) { - chomp; - my $min = hex $1; - my $max = defined $2 ? hex $2 : $min; - next if $max < $start; - if ($min < $start) { - $min = $start; - } - for ($key = $min; $key <= $max; $key++) { - last LINE if $key >= $end; - print STDERR "$key => 1\n" if DEBUG; - vec($swatch, $key - $start, 1) = 1; - } - } - } - } - for my $x ($self->{EXTRAS}) { - pos $x = 0; - while ($x =~ /^([-+!&])(.*)/mg) { - my $char = $1; - my $name = $2; - print STDERR "INDIRECT $1 $2\n" if DEBUG; - my $otherbits = $self->{$name}->{BITS}; - croak("SWASHGET size mismatch") if $bits < $otherbits; - my $other = $self->{$name}->SWASHGET($start, $len); - if ($char eq '+') { - if ($bits == 1 and $otherbits == 1) { - $swatch |= $other; - } - else { - for ($key = 0; $key < $len; $key++) { - vec($swatch, $key, $bits) = vec($other, $key, $otherbits); - } - } - } - elsif ($char eq '!') { - if ($bits == 1 and $otherbits == 1) { - $swatch |= ~$other; - } - else { - for ($key = 0; $key < $len; $key++) { - if (!vec($other, $key, $otherbits)) { - vec($swatch, $key, $bits) = 1; - } - } - } - } - elsif ($char eq '-') { - if ($bits == 1 and $otherbits == 1) { - $swatch &= ~$other; - } - else { - for ($key = 0; $key < $len; $key++) { - if (vec($other, $key, $otherbits)) { - vec($swatch, $key, $bits) = 0; - } - } - } - } - elsif ($char eq '&') { - if ($bits == 1 and $otherbits == 1) { - $swatch &= $other; - } - else { - for ($key = 0; $key < $len; $key++) { - if (!vec($other, $key, $otherbits)) { - vec($swatch, $key, $bits) = 0; - } - } - } - } - } - } - if (DEBUG) { - print STDERR "CELLS "; - for ($key = 0; $key < $len; $key++) { - print STDERR vec($swatch, $key, $bits), " "; - } - print STDERR "\n"; - } - $swatch; -} - -1; diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/vars.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/vars.pm deleted file mode 100644 index a0151b84030..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/vars.pm +++ /dev/null @@ -1,82 +0,0 @@ -package vars; - -use 5.006; - -our $VERSION = '1.01'; - -use warnings::register; -use strict qw(vars subs); - -sub import { - my $callpack = caller; - my ($pack, @imports) = @_; - my ($sym, $ch); - foreach (@imports) { - if (($ch, $sym) = /^([\$\@\%\*\&])(.+)/) { - if ($sym =~ /\W/) { - # time for a more-detailed check-up - if ($sym =~ /^\w+[[{].*[]}]$/) { - require Carp; - Carp::croak("Can't declare individual elements of hash or array"); - } elsif (warnings::enabled() and length($sym) == 1 and $sym !~ tr/a-zA-Z//) { - warnings::warn("No need to declare built-in vars"); - } elsif (($^H &= strict::bits('vars'))) { - require Carp; - Carp::croak("'$_' is not a valid variable name under strict vars"); - } - } - $sym = "${callpack}::$sym" unless $sym =~ /::/; - *$sym = - ( $ch eq "\$" ? \$$sym - : $ch eq "\@" ? \@$sym - : $ch eq "\%" ? \%$sym - : $ch eq "\*" ? \*$sym - : $ch eq "\&" ? \&$sym - : do { - require Carp; - Carp::croak("'$_' is not a valid variable name"); - }); - } else { - require Carp; - Carp::croak("'$_' is not a valid variable name"); - } - } -}; - -1; -__END__ - -=head1 NAME - -vars - Perl pragma to predeclare global variable names (obsolete) - -=head1 SYNOPSIS - - use vars qw($frob @mung %seen); - -=head1 DESCRIPTION - -NOTE: For variables in the current package, the functionality provided -by this pragma has been superseded by C<our> declarations, available -in Perl v5.6.0 or later. See L<perlfunc/our>. - -This will predeclare all the variables whose names are -in the list, allowing you to use them under "use strict", and -disabling any typo warnings. - -Unlike pragmas that affect the C<$^H> hints variable, the C<use vars> and -C<use subs> declarations are not BLOCK-scoped. They are thus effective -for the entire file in which they appear. You may not rescind such -declarations with C<no vars> or C<no subs>. - -Packages such as the B<AutoLoader> and B<SelfLoader> that delay -loading of subroutines within packages can create problems with -package lexicals defined using C<my()>. While the B<vars> pragma -cannot duplicate the effect of package lexicals (total transparency -outside of the package), it can act as an acceptable substitute by -pre-declaring global symbols, ensuring their availability to the -later-loaded routines. - -See L<perlmodlib/Pragmatic Modules>. - -=cut diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/warnings.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/warnings.pm deleted file mode 100644 index e43b686c908..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/warnings.pm +++ /dev/null @@ -1,497 +0,0 @@ -# -*- buffer-read-only: t -*- -# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! -# This file was created by warnings.pl -# Any changes made here will be lost. -# - -package warnings; - -our $VERSION = '1.05'; - -=head1 NAME - -warnings - Perl pragma to control optional warnings - -=head1 SYNOPSIS - - use warnings; - no warnings; - - use warnings "all"; - no warnings "all"; - - use warnings::register; - if (warnings::enabled()) { - warnings::warn("some warning"); - } - - if (warnings::enabled("void")) { - warnings::warn("void", "some warning"); - } - - if (warnings::enabled($object)) { - warnings::warn($object, "some warning"); - } - - warnings::warnif("some warning"); - warnings::warnif("void", "some warning"); - warnings::warnif($object, "some warning"); - -=head1 DESCRIPTION - -The C<warnings> pragma is a replacement for the command line flag C<-w>, -but the pragma is limited to the enclosing block, while the flag is global. -See L<perllexwarn> for more information. - -If no import list is supplied, all possible warnings are either enabled -or disabled. - -A number of functions are provided to assist module authors. - -=over 4 - -=item use warnings::register - -Creates a new warnings category with the same name as the package where -the call to the pragma is used. - -=item warnings::enabled() - -Use the warnings category with the same name as the current package. - -Return TRUE if that warnings category is enabled in the calling module. -Otherwise returns FALSE. - -=item warnings::enabled($category) - -Return TRUE if the warnings category, C<$category>, is enabled in the -calling module. -Otherwise returns FALSE. - -=item warnings::enabled($object) - -Use the name of the class for the object reference, C<$object>, as the -warnings category. - -Return TRUE if that warnings category is enabled in the first scope -where the object is used. -Otherwise returns FALSE. - -=item warnings::warn($message) - -Print C<$message> to STDERR. - -Use the warnings category with the same name as the current package. - -If that warnings category has been set to "FATAL" in the calling module -then die. Otherwise return. - -=item warnings::warn($category, $message) - -Print C<$message> to STDERR. - -If the warnings category, C<$category>, has been set to "FATAL" in the -calling module then die. Otherwise return. - -=item warnings::warn($object, $message) - -Print C<$message> to STDERR. - -Use the name of the class for the object reference, C<$object>, as the -warnings category. - -If that warnings category has been set to "FATAL" in the scope where C<$object> -is first used then die. Otherwise return. - - -=item warnings::warnif($message) - -Equivalent to: - - if (warnings::enabled()) - { warnings::warn($message) } - -=item warnings::warnif($category, $message) - -Equivalent to: - - if (warnings::enabled($category)) - { warnings::warn($category, $message) } - -=item warnings::warnif($object, $message) - -Equivalent to: - - if (warnings::enabled($object)) - { warnings::warn($object, $message) } - -=back - -See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>. - -=cut - -use Carp (); - -our %Offsets = ( - - # Warnings Categories added in Perl 5.008 - - 'all' => 0, - 'closure' => 2, - 'deprecated' => 4, - 'exiting' => 6, - 'glob' => 8, - 'io' => 10, - 'closed' => 12, - 'exec' => 14, - 'layer' => 16, - 'newline' => 18, - 'pipe' => 20, - 'unopened' => 22, - 'misc' => 24, - 'numeric' => 26, - 'once' => 28, - 'overflow' => 30, - 'pack' => 32, - 'portable' => 34, - 'recursion' => 36, - 'redefine' => 38, - 'regexp' => 40, - 'severe' => 42, - 'debugging' => 44, - 'inplace' => 46, - 'internal' => 48, - 'malloc' => 50, - 'signal' => 52, - 'substr' => 54, - 'syntax' => 56, - 'ambiguous' => 58, - 'bareword' => 60, - 'digit' => 62, - 'parenthesis' => 64, - 'precedence' => 66, - 'printf' => 68, - 'prototype' => 70, - 'qw' => 72, - 'reserved' => 74, - 'semicolon' => 76, - 'taint' => 78, - 'threads' => 80, - 'uninitialized' => 82, - 'unpack' => 84, - 'untie' => 86, - 'utf8' => 88, - 'void' => 90, - 'y2k' => 92, - ); - -our %Bits = ( - 'all' => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x15", # [0..46] - 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00", # [29] - 'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00", # [30] - 'closed' => "\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6] - 'closure' => "\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1] - 'debugging' => "\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00", # [22] - 'deprecated' => "\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2] - 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00", # [31] - 'exec' => "\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7] - 'exiting' => "\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3] - 'glob' => "\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4] - 'inplace' => "\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00", # [23] - 'internal' => "\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00", # [24] - 'io' => "\x00\x54\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..11] - 'layer' => "\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8] - 'malloc' => "\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00", # [25] - 'misc' => "\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00", # [12] - 'newline' => "\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9] - 'numeric' => "\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00", # [13] - 'once' => "\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00", # [14] - 'overflow' => "\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00", # [15] - 'pack' => "\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00", # [16] - 'parenthesis' => "\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00", # [32] - 'pipe' => "\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10] - 'portable' => "\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00", # [17] - 'precedence' => "\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00", # [33] - 'printf' => "\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00", # [34] - 'prototype' => "\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00", # [35] - 'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00", # [36] - 'recursion' => "\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00", # [18] - 'redefine' => "\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00", # [19] - 'regexp' => "\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00", # [20] - 'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00", # [37] - 'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00", # [38] - 'severe' => "\x00\x00\x00\x00\x00\x54\x05\x00\x00\x00\x00\x00", # [21..25] - 'signal' => "\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00", # [26] - 'substr' => "\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00", # [27] - 'syntax' => "\x00\x00\x00\x00\x00\x00\x00\x55\x55\x15\x00\x00", # [28..38] - 'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00", # [39] - 'threads' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00", # [40] - 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00", # [41] - 'unopened' => "\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11] - 'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00", # [42] - 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00", # [43] - 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01", # [44] - 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04", # [45] - 'y2k' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10", # [46] - ); - -our %DeadBits = ( - 'all' => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\x2a", # [0..46] - 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00", # [29] - 'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00", # [30] - 'closed' => "\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6] - 'closure' => "\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1] - 'debugging' => "\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00", # [22] - 'deprecated' => "\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2] - 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00", # [31] - 'exec' => "\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7] - 'exiting' => "\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3] - 'glob' => "\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4] - 'inplace' => "\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00", # [23] - 'internal' => "\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00", # [24] - 'io' => "\x00\xa8\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..11] - 'layer' => "\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8] - 'malloc' => "\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00", # [25] - 'misc' => "\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00", # [12] - 'newline' => "\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9] - 'numeric' => "\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00", # [13] - 'once' => "\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00", # [14] - 'overflow' => "\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00", # [15] - 'pack' => "\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00", # [16] - 'parenthesis' => "\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00", # [32] - 'pipe' => "\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10] - 'portable' => "\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00", # [17] - 'precedence' => "\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00", # [33] - 'printf' => "\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00", # [34] - 'prototype' => "\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00", # [35] - 'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00", # [36] - 'recursion' => "\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00", # [18] - 'redefine' => "\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00", # [19] - 'regexp' => "\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00", # [20] - 'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00", # [37] - 'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00", # [38] - 'severe' => "\x00\x00\x00\x00\x00\xa8\x0a\x00\x00\x00\x00\x00", # [21..25] - 'signal' => "\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00", # [26] - 'substr' => "\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00", # [27] - 'syntax' => "\x00\x00\x00\x00\x00\x00\x00\xaa\xaa\x2a\x00\x00", # [28..38] - 'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00", # [39] - 'threads' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00", # [40] - 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00", # [41] - 'unopened' => "\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11] - 'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00", # [42] - 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00", # [43] - 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02", # [44] - 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08", # [45] - 'y2k' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20", # [46] - ); - -$NONE = "\0\0\0\0\0\0\0\0\0\0\0\0"; -$LAST_BIT = 94 ; -$BYTES = 12 ; - -$All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ; - -sub Croaker -{ - local $Carp::CarpInternal{'warnings'}; - delete $Carp::CarpInternal{'warnings'}; - Carp::croak(@_); -} - -sub bits -{ - # called from B::Deparse.pm - - push @_, 'all' unless @_; - - my $mask; - my $catmask ; - my $fatal = 0 ; - my $no_fatal = 0 ; - - foreach my $word ( @_ ) { - if ($word eq 'FATAL') { - $fatal = 1; - $no_fatal = 0; - } - elsif ($word eq 'NONFATAL') { - $fatal = 0; - $no_fatal = 1; - } - elsif ($catmask = $Bits{$word}) { - $mask |= $catmask ; - $mask |= $DeadBits{$word} if $fatal ; - $mask &= ~($DeadBits{$word}|$All) if $no_fatal ; - } - else - { Croaker("Unknown warnings category '$word'")} - } - - return $mask ; -} - -sub import -{ - shift; - - my $catmask ; - my $fatal = 0 ; - my $no_fatal = 0 ; - - my $mask = ${^WARNING_BITS} ; - - if (vec($mask, $Offsets{'all'}, 1)) { - $mask |= $Bits{'all'} ; - $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1); - } - - push @_, 'all' unless @_; - - foreach my $word ( @_ ) { - if ($word eq 'FATAL') { - $fatal = 1; - $no_fatal = 0; - } - elsif ($word eq 'NONFATAL') { - $fatal = 0; - $no_fatal = 1; - } - elsif ($catmask = $Bits{$word}) { - $mask |= $catmask ; - $mask |= $DeadBits{$word} if $fatal ; - $mask &= ~($DeadBits{$word}|$All) if $no_fatal ; - } - else - { Croaker("Unknown warnings category '$word'")} - } - - ${^WARNING_BITS} = $mask ; -} - -sub unimport -{ - shift; - - my $catmask ; - my $mask = ${^WARNING_BITS} ; - - if (vec($mask, $Offsets{'all'}, 1)) { - $mask |= $Bits{'all'} ; - $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1); - } - - push @_, 'all' unless @_; - - foreach my $word ( @_ ) { - if ($word eq 'FATAL') { - next; - } - elsif ($catmask = $Bits{$word}) { - $mask &= ~($catmask | $DeadBits{$word} | $All); - } - else - { Croaker("Unknown warnings category '$word'")} - } - - ${^WARNING_BITS} = $mask ; -} - -my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = (); - -sub __chk -{ - my $category ; - my $offset ; - my $isobj = 0 ; - - if (@_) { - # check the category supplied. - $category = shift ; - if (my $type = ref $category) { - Croaker("not an object") - if exists $builtin_type{$type}; - $category = $type; - $isobj = 1 ; - } - $offset = $Offsets{$category}; - Croaker("Unknown warnings category '$category'") - unless defined $offset; - } - else { - $category = (caller(1))[0] ; - $offset = $Offsets{$category}; - Croaker("package '$category' not registered for warnings") - unless defined $offset ; - } - - my $this_pkg = (caller(1))[0] ; - my $i = 2 ; - my $pkg ; - - if ($isobj) { - while (do { { package DB; $pkg = (caller($i++))[0] } } ) { - last unless @DB::args && $DB::args[0] =~ /^$category=/ ; - } - $i -= 2 ; - } - else { - for ($i = 2 ; $pkg = (caller($i))[0] ; ++ $i) { - last if $pkg ne $this_pkg ; - } - $i = 2 - if !$pkg || $pkg eq $this_pkg ; - } - - my $callers_bitmask = (caller($i))[9] ; - return ($callers_bitmask, $offset, $i) ; -} - -sub enabled -{ - Croaker("Usage: warnings::enabled([category])") - unless @_ == 1 || @_ == 0 ; - - my ($callers_bitmask, $offset, $i) = __chk(@_) ; - - return 0 unless defined $callers_bitmask ; - return vec($callers_bitmask, $offset, 1) || - vec($callers_bitmask, $Offsets{'all'}, 1) ; -} - - -sub warn -{ - Croaker("Usage: warnings::warn([category,] 'message')") - unless @_ == 2 || @_ == 1 ; - - my $message = pop ; - my ($callers_bitmask, $offset, $i) = __chk(@_) ; - Carp::croak($message) - if vec($callers_bitmask, $offset+1, 1) || - vec($callers_bitmask, $Offsets{'all'}+1, 1) ; - Carp::carp($message) ; -} - -sub warnif -{ - Croaker("Usage: warnings::warnif([category,] 'message')") - unless @_ == 2 || @_ == 1 ; - - my $message = pop ; - my ($callers_bitmask, $offset, $i) = __chk(@_) ; - - return - unless defined $callers_bitmask && - (vec($callers_bitmask, $offset, 1) || - vec($callers_bitmask, $Offsets{'all'}, 1)) ; - - Carp::croak($message) - if vec($callers_bitmask, $offset+1, 1) || - vec($callers_bitmask, $Offsets{'all'}+1, 1) ; - - Carp::carp($message) ; -} - -1; -# ex: set ro: diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/warnings/register.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/warnings/register.pm deleted file mode 100644 index 57c865df522..00000000000 --- a/Master/tlpkg/lib/Perl5_lib-TL_inst/warnings/register.pm +++ /dev/null @@ -1,51 +0,0 @@ -package warnings::register; - -our $VERSION = '1.01'; - -=pod - -=head1 NAME - -warnings::register - warnings import function - -=head1 SYNOPSIS - - use warnings::register; - -=head1 DESCRIPTION - -Creates a warnings category with the same name as the current package. - -See L<warnings> and L<perllexwarn> for more information on this module's -usage. - -=cut - -require warnings; - -sub mkMask -{ - my ($bit) = @_; - my $mask = ""; - - vec($mask, $bit, 1) = 1; - return $mask; -} - -sub import -{ - shift; - my $package = (caller(0))[0]; - if (! defined $warnings::Bits{$package}) { - $warnings::Bits{$package} = mkMask($warnings::LAST_BIT); - vec($warnings::Bits{'all'}, $warnings::LAST_BIT, 1) = 1; - $warnings::Offsets{$package} = $warnings::LAST_BIT ++; - foreach my $k (keys %warnings::Bits) { - vec($warnings::Bits{$k}, $warnings::LAST_BIT, 1) = 0; - } - $warnings::DeadBits{$package} = mkMask($warnings::LAST_BIT); - vec($warnings::DeadBits{'all'}, $warnings::LAST_BIT++, 1) = 1; - } -} - -1; |