summaryrefslogtreecommitdiff
path: root/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32
diff options
context:
space:
mode:
authorNorbert Preining <norbert@preining.info>2019-09-02 13:46:59 +0900
committerNorbert Preining <norbert@preining.info>2019-09-02 13:46:59 +0900
commite0c6872cf40896c7be36b11dcc744620f10adf1d (patch)
tree60335e10d2f4354b0674ec22d7b53f0f8abee672 /systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32
Initial commit
Diffstat (limited to 'systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32')
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/API.pm1474
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/API/Callback.pm575
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/API/Callback/IATPatch.pod181
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/API/Struct.pm755
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/API/Type.pm590
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/Console.pm1463
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/OLE.pm968
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/OLE/Const.pm201
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/OLE/Enum.pm95
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/OLE/Lite.pm224
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/OLE/NEWS.pod380
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/OLE/NLS.pm968
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/OLE/TPJ.pod798
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/OLE/TypeInfo.pm389
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/OLE/Variant.pm577
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/Shortcut.pm752
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/TieRegistry.pm3803
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/WinError.pm1017
18 files changed, 15210 insertions, 0 deletions
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/API.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/API.pm
new file mode 100644
index 0000000000..e353e2eb32
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/API.pm
@@ -0,0 +1,1474 @@
+# See the bottom of this file for the POD documentation. Search for the
+# string '=head'.
+
+#######################################################################
+#
+# Win32::API - Perl Win32 API Import Facility
+#
+# 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>
+#
+#######################################################################
+
+package Win32::API;
+ use strict;
+ use warnings;
+BEGIN {
+ require Exporter; # to export the constants to the main:: space
+
+ sub ISCYG ();
+ if($^O eq 'cygwin') {
+ BEGIN{warnings->unimport('uninitialized')}
+ die "Win32::API on Cygwin requires the cygpath tool on PATH"
+ if index(`cygpath --help`,'Usage: cygpath') == -1;
+ require File::Basename;
+ eval "sub ISCYG () { 1 }";
+ } else {
+ eval "sub ISCYG () { 0 }";
+ }
+
+
+ use vars qw( $DEBUG $sentinal @ISA @EXPORT_OK $VERSION );
+
+ @ISA = qw( Exporter );
+ @EXPORT_OK = qw( ReadMemory IsBadReadPtr MoveMemory
+ WriteMemory SafeReadWideCString ); # symbols to export on request
+
+ use Scalar::Util qw( looks_like_number weaken);
+
+ sub ERROR_NOACCESS () { 998 }
+ sub ERROR_NOT_ENOUGH_MEMORY () { 8 }
+ sub ERROR_INVALID_PARAMETER () { 87 }
+ sub APICONTROL_CC_STD () { 0 }
+ sub APICONTROL_CC_C () { 1 }
+ sub APICONTROL_CC_mask () { 0x7 }
+ sub APICONTROL_UseMI64 () { 0x8 }
+ sub APICONTROL_is_more () { 0x10 }
+ sub APICONTROL_has_proto() { 0x20 }
+ eval ' *Win32::API::Type::PTRSIZE = *Win32::API::More::PTRSIZE = *PTRSIZE = sub () { '.length(pack('p', undef)).' };'.
+ #Win64 added in 5.7.3
+ ' *Win32::API::Type::IVSIZE = *Win32::API::More::IVSIZE = *IVSIZE = sub () { '.length(pack($] >= 5.007003 ? 'J' : 'I' ,0)).' };'.
+ ' *Win32::API::Type::DEBUGCONST = *Win32::API::Struct::DEBUGCONST = *DEBUGCONST = sub () { '.(!!$DEBUG+0).' };'
+}
+
+sub DEBUG {
+ #checking flag redundant now, but keep in case of an accidental unprotected call
+ if ($Win32::API::DEBUG) {
+ printf @_ if @_ or return 1;
+ }
+ else {
+ return 0;
+ }
+}
+
+use Win32::API::Type ();
+use Win32::API::Struct ();
+
+#######################################################################
+# STATIC OBJECT PROPERTIES
+#
+#### some package-global hash to
+#### keep track of the imported
+#### libraries and procedures
+my %Libraries = ();
+my %Procedures = ();
+
+
+#######################################################################
+# dynamically load in the API extension module.
+# BEGIN required for constant subs in BOOT:
+BEGIN {
+ $VERSION = '0.84';
+ require XSLoader;
+ XSLoader::load 'Win32::API', $VERSION;
+}
+
+#######################################################################
+# PUBLIC METHODS
+#
+sub new {
+ die "Win32::API/More::new/Import is a class method that takes 2 to 6 parameters, see POD"
+ if @_ < 3 || @_ > 7;
+ my ($class, $dll, $hproc, $ccnum, $outnum) = (shift, shift);
+ if(! defined $dll){
+ $hproc = shift;
+ }
+ my ($proc, $in, $out, $callconvention) = @_;
+ my ($hdll, $freedll, $proto, $stackunwind) = (0, 0, 0, 0);
+ my $self = {};
+ if(! defined $hproc){
+ if (ISCYG() 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" if DEBUGCONST;
+ $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" if DEBUGCONST;
+ $hdll = $Libraries{$dll};
+ }
+ else {
+ DEBUG "Win32::API::new: Loading library '$dll'\n" if DEBUGCONST;
+ $hdll = Win32::API::LoadLibrary($dll);
+ $freedll = 1;
+ # $Libraries{$dll} = $hdll;
+ }
+
+ #### if the dll can't be loaded, set $! to Win32's GetLastError()
+ if (!$hdll) {
+ $! = Win32::GetLastError();
+ DEBUG "FAILED Loading library '$dll': $^E\n" if DEBUGCONST;
+ return undef;
+ }
+ }
+ else{
+ if(!looks_like_number($hproc) || IsBadReadPtr($hproc, 4)){
+ Win32::SetLastError(ERROR_NOACCESS);
+ DEBUG "FAILED Function pointer '$hproc' is not a valid memory location\n" if DEBUGCONST;
+ return undef;
+ }
+ }
+ #### determine if we have a prototype or not, outtype is for future use in XS
+ if ((not defined $in) and (not defined $out)) {
+ ($proc, $self->{in}, $self->{intypes}, $outnum, $self->{outtype},
+ $ccnum) = parse_prototype($class, $proc);
+ if( ! $proc ){
+ Win32::API::FreeLibrary($hdll) if $freedll;
+ Win32::SetLastError(ERROR_INVALID_PARAMETER);
+ return undef;
+ }
+ $proto = 1;
+ }
+ else {
+ $self->{in} = [];
+ my $self_in = $self->{in}; #avoid hash derefing
+ if (ref($in) eq 'ARRAY') {
+ foreach (@$in) {
+ push(@{$self_in}, $class->type_to_num($_));
+ }
+ }
+ else {
+ my @in = split '', $in;
+ foreach (@in) {
+ push(@{$self_in}, $class->type_to_num($_));
+ }
+ }#'V' must be one and ONLY letter for "in"
+ foreach(@{$self_in}){
+ if($_ == 0){
+ if(@{$self_in} != 1){
+ Win32::API::FreeLibrary($hdll) if $freedll;
+ die "Win32::API 'V' for in prototype must be the only parameter";
+ } else {undef(@{$self_in});} #empty arr, as if in param was ""
+ }
+ }
+ $outnum = $class->type_to_num($out, 1);
+ $ccnum = calltype_to_num($callconvention);
+ }
+
+ if(!$hproc){ #if not non DLL func
+ #### first try to import the function of given name...
+ $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, give up, $! setting is back compat, $! is deprecated
+ if (!$hproc) {
+ my $err = $! = Win32::GetLastError();
+ DEBUG "FAILED GetProcAddress for Proc '$proc': $^E\n" if DEBUGCONST;
+ Win32::API::FreeLibrary($hdll) if $freedll;
+ Win32::SetLastError($err);
+ return undef;
+ }
+ DEBUG "GetProcAddress('$proc') = '$hproc'\n" if DEBUGCONST;
+ }
+ else {
+ DEBUG "Using non-DLL function pointer '$hproc' for '$proc'\n" if DEBUGCONST;
+ }
+ if(PTRSIZE == 4 && $ccnum == APICONTROL_CC_C) {#fold out on WIN64
+ #calculate add to ESP amount, in units of 4, will be *4ed later
+ $stackunwind += $_ == T_QUAD || $_ == T_DOUBLE ? 2 : 1 for(@{$self->{in}});
+ if($stackunwind > 0xFFFF) {
+ goto too_many_in_params;
+ }
+ }
+ # if a prototype has 8 byte types on 32bit, $stackunwind will be higher than
+ # length of {in} letter array, so 2 different checks need to be done
+ if($#{$self->{in}} > 0xFFFF) {
+ too_many_in_params:
+ DEBUG "FAILED This function has too many parameters (> ~65535) \n" if DEBUGCONST;
+ Win32::API::FreeLibrary($hdll) if $freedll;
+ Win32::SetLastError(ERROR_NOT_ENOUGH_MEMORY);
+ return undef;
+ }
+ #### ok, let's stuff the object
+ $self->{procname} = $proc;
+ $self->{dll} = $hdll;
+ $self->{dllname} = $dll;
+
+ $outnum &= ~T_FLAG_NUMERIC;
+ my $control;
+ $self->{weakapi} = \$control;
+ weaken($self->{weakapi});
+ $control = pack( 'L'
+ .'L'
+ .(PTRSIZE == 8 ? 'Q' : 'L')
+ .(PTRSIZE == 8 ? 'Q' : 'L')
+ .(PTRSIZE == 8 ? 'Q' : 'L')
+ .(PTRSIZE == 8 ? '' : 'L')
+ ,($class eq "Win32::API::More" ? APICONTROL_is_more : 0)
+ | ($proto ? APICONTROL_has_proto : 0)
+ | $ccnum
+ | (PTRSIZE == 8 ? 0 : $stackunwind << 8)
+ | $outnum << 24
+ , scalar(@{$self->{in}}) * PTRSIZE #in param count, in SV * units
+ , $hproc
+ , \($self->{weakapi})+0 #weak api obj ref
+ , (exists $self->{intypes} ? ($self->{intypes})+0 : 0)
+ , 0); #padding to align to 8 bytes on 32 bit only
+ #align to 16 bytes
+ $control .= "\x00" x ((((length($control)+ 15) >> 4) << 4)-length($control));
+ #make a APIPARAM template array
+ my ($i, $arr_end) = (0, scalar(@{$self->{in}}));
+ for(; $i< $arr_end; $i++) {
+ my $tin = $self->{in}[$i];
+ #unsigned meaningless no sign vs zero extends are done bc uv/iv is
+ #the biggest native integer on the cpu, big to small is truncation
+ #numeric is implemented as T_NUMCHAR for in, keeps asm jumptable clean
+ $tin &= ~(T_FLAG_UNSIGNED|T_FLAG_NUMERIC);
+ $tin--; #T_VOID doesn't exist as in param in XS
+ #put index of param array slice in unused space for croaks, why not?
+ $control .= "\x00" x 8 . pack('CCSSS', $tin, 0, 0, $i, $i+1);
+ }
+ _Align($control, 16); #align the whole PVX to 16 bytes for SSE moves
+
+ #### keep track of the imported function
+ if(defined $dll){
+ $Libraries{$dll} = $hdll;
+ $Procedures{$dll}++;
+ }
+ DEBUG "Object blessed!\n" if DEBUGCONST;
+
+ my $ref = bless(\$control, $class);
+ SetMagicSV($ref, $self);
+ return $ref;
+}
+
+sub Import {
+ my $closure = shift->new(@_)
+ or return undef;
+ my $procname = ${Win32::API::GetMagicSV($closure)}{procname};
+ #dont allow "sub main:: {0;}"
+ Win32::SetLastError(ERROR_INVALID_PARAMETER), return undef if $procname eq '';
+ _ImportXS($closure, (caller)[0].'::'.$procname);
+ return $closure;
+}
+
+#######################################################################
+# PRIVATE METHODS
+#
+sub DESTROY {
+ my ($self) = GetMagicSV($_[0]);
+
+ return if ! defined $self->{dllname};
+ #### 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" if DEBUGCONST;
+ Win32::API::FreeLibrary($Libraries{$self->{dllname}});
+ delete($Libraries{$self->{dllname}});
+ }
+}
+
+# Convert calling convention string (_cdecl|__stdcall)
+# to a C const. Unknown counts as __stdcall
+#
+sub calltype_to_num {
+ my $type = shift;
+
+ if (!$type || $type eq "__stdcall" || $type eq "WINAPI" || $type eq "NTAPI"
+ || $type eq "CALLBACK" ) {
+ return APICONTROL_CC_STD;
+ }
+ elsif ($type eq "_cdecl" || $type eq "__cdecl" || $type eq "WINAPIV") {
+ return APICONTROL_CC_C;
+ }
+ else {
+ warn "unknown calling convention: '$type'";
+ return APICONTROL_CC_STD;
+ }
+}
+
+
+sub type_to_num {
+ die "wrong class" if shift ne "Win32::API";
+ my $type = shift;
+ my $out = shift;
+ my ($num, $numeric);
+ if(index($type, 'num', 0) == 0){
+ substr($type, 0, length('num'), '');
+ $numeric = 1;
+ }
+ else{
+ $numeric = 0;
+ }
+
+ if ( $type eq 'N'
+ or $type eq 'n'
+ or $type eq 'l'
+ or $type eq 'L'
+ or ( PTRSIZE == 8 and $type eq 'Q' || $type eq 'q'))
+ {
+ $num = T_NUMBER;
+ }
+ elsif ($type eq 'P'
+ or $type eq 'p')
+ {
+ $num = T_POINTER;
+ }
+ elsif ($type eq 'I'
+ or $type eq 'i')
+ {
+ $num = T_INTEGER;
+ }
+ elsif ($type eq 'f'
+ or $type eq 'F')
+ {
+ $num = T_FLOAT;
+ }
+ elsif ($type eq 'D'
+ or $type eq 'd')
+ {
+ $num = T_DOUBLE;
+ }
+ elsif ($type eq 'c'
+ or $type eq 'C')
+ {
+ $num = $numeric ? T_NUMCHAR : T_CHAR;
+ }
+ elsif (PTRSIZE == 4 and $type eq 'q' || $type eq 'Q')
+ {
+ $num = T_QUAD;
+ }
+ elsif($type eq '>'){
+ die "Win32::API does not support pass by copy structs as function arguments";
+ }
+ else {
+ $num = T_VOID; #'V' takes this branch, which is T_VOID in C
+ }#not valid return types of the C func
+ if(defined $out) {#b/B remains private/undocumented
+ die "Win32::API invalid return type, structs and ".
+ "callbacks as return types not supported"
+ if($type =~ m/^s|S|t|T|b|B|k|K$/);
+ }
+ else {#in type
+ if ($type eq 's' or $type eq 'S' or $type eq 't' or $type eq 'T')
+ {
+ $num = T_STRUCTURE;
+ }
+ elsif ($type eq 'b'
+ or $type eq 'B')
+ {
+ $num = T_POINTERPOINTER;
+ }
+ elsif ($type eq 'k'
+ or $type eq 'K')
+ {
+ $num = T_CODE;
+ }
+ }
+ $num |= T_FLAG_NUMERIC if $numeric;
+ return $num;
+}
+
+package Win32::API::More;
+
+use vars qw( @ISA );
+@ISA = qw ( Win32::API );
+sub type_to_num {
+ die "wrong class" if shift ne "Win32::API::More";
+ my $type = shift;
+ my $out = shift;
+ my ($num, $numeric);
+ if(index($type, 'num', 0) == 0){
+ substr($type, 0, length('num'), '');
+ $numeric = 1;
+ }
+ else{
+ $numeric = 0;
+ }
+
+ if ( $type eq 'N'
+ or $type eq 'n'
+ or $type eq 'l'
+ or $type eq 'L'
+ or ( PTRSIZE == 8 and $type eq 'Q' || $type eq 'q')
+ or (! $out and # in XS short 'in's are interger/numbers code
+ $type eq 'S'
+ || $type eq 's'))
+ {
+ $num = Win32::API::T_NUMBER;
+ if(defined $out && ($type eq 'N' || $type eq 'L'
+ || $type eq 'S' || $type eq 'Q')){
+ $num |= Win32::API::T_FLAG_UNSIGNED;
+ }
+ }
+ elsif ($type eq 'P'
+ or $type eq 'p')
+ {
+ $num = Win32::API::T_POINTER;
+ }
+ elsif ($type eq 'I'
+ or $type eq 'i')
+ {
+ $num = Win32::API::T_INTEGER;
+ if(defined $out && $type eq 'I'){
+ $num |= Win32::API::T_FLAG_UNSIGNED;
+ }
+ }
+ elsif ($type eq 'f'
+ or $type eq 'F')
+ {
+ $num = Win32::API::T_FLOAT;
+ }
+ elsif ($type eq 'D'
+ or $type eq 'd')
+ {
+ $num = Win32::API::T_DOUBLE;
+ }
+ elsif ($type eq 'c'
+ or $type eq 'C')
+ {
+ $num = $numeric ? Win32::API::T_NUMCHAR : Win32::API::T_CHAR;
+ if(defined $out && $type eq 'C'){
+ $num |= Win32::API::T_FLAG_UNSIGNED;
+ }
+ }
+ elsif (PTRSIZE == 4 and $type eq 'q' || $type eq 'Q')
+ {
+ $num = Win32::API::T_QUAD;
+ if(defined $out && $type eq 'Q'){
+ $num |= Win32::API::T_FLAG_UNSIGNED;
+ }
+ }
+ elsif ($type eq 's') #4 is only used for out params
+ {
+ $num = Win32::API::T_SHORT;
+ }
+ elsif ($type eq 'S')
+ {
+ $num = Win32::API::T_SHORT | Win32::API::T_FLAG_UNSIGNED;
+ }
+ elsif($type eq '>'){
+ die "Win32::API does not support pass by copy structs as function arguments";
+ }
+ else {
+ $num = Win32::API::T_VOID; #'V' takes this branch, which is T_VOID in C
+ } #not valid return types of the C func
+ if(defined $out) {#b/B remains private/undocumented
+ die "Win32::API invalid return type, structs and ".
+ "callbacks as return types not supported"
+ if($type =~ m/^t|T|b|B|k|K$/);
+ }
+ else {#in type
+ if ( $type eq 't'
+ or $type eq 'T')
+ {
+ $num = Win32::API::T_STRUCTURE;
+ }
+ elsif ($type eq 'b'
+ or $type eq 'B')
+ {
+ $num = Win32::API::T_POINTERPOINTER;
+ }
+ elsif ($type eq 'k'
+ or $type eq 'K')
+ {
+ $num = Win32::API::T_CODE;
+ }
+ }
+ $num |= Win32::API::T_FLAG_NUMERIC if $numeric;
+ return $num;
+}
+package Win32::API;
+
+sub parse_prototype {
+ my ($class, $proto) = @_;
+
+ my @in_params = ();
+ my @in_types = (); #one day create a BNF-ish formal grammer parser here
+ if ($proto =~ /^\s*((?:(?:un|)signed\s+|) #optional signedness
+ \S+)(?:\s*(\*)\s*|\s+) #type and maybe a *
+ (?:(\w+)\s+)? # maybe a calling convention
+ (\S+)\s* #func name
+ \(([^\)]*)\) #param list
+ /x) {
+ my $ret = $1.(defined($2)?$2:'');
+ my $callconvention = $3;
+ my $proc = $4;
+ my $params = $5;
+
+ $params =~ s/^\s+//;
+ $params =~ s/\s+$//;
+
+ DEBUG "(PM)parse_prototype: got PROC '%s'\n", $proc if DEBUGCONST;
+ DEBUG "(PM)parse_prototype: got PARAMS '%s'\n", $params if DEBUGCONST;
+
+ foreach my $param (split(/\s*,\s*/, $params)) {
+ my ($type, $name);
+ #match "in_t* _var" "in_t * _var" "in_t *_var" "in_t _var" "in_t*_var" supported
+ #unsigned or signed or nothing as prefix supported
+ # "in_t ** _var" and "const in_t* var" not supported
+ if ($param =~ /((?:(?:un|)signed\s+|)\w+)(?:\s*(\*)\s*|\s+)(\w+)/) {
+ ($type, $name) = ($1.(defined($2)? $2:''), $3);
+ }
+ {
+ BEGIN{warnings->unimport('uninitialized')}
+ if($type eq '') {goto BADPROTO;} #something very wrong, bail out
+ }
+ my $packing = Win32::API::Type::packing($type);
+ if (defined $packing && $packing ne '>') {
+ if (Win32::API::Type::is_pointer($type)) {
+ DEBUG "(PM)parse_prototype: IN='%s' PACKING='%s' API_TYPE=%d\n",
+ $type,
+ $packing,
+ $class->type_to_num('P') if DEBUGCONST;
+ push(@in_params, $class->type_to_num('P'));
+ }
+ else {
+ DEBUG "(PM)parse_prototype: IN='%s' PACKING='%s' API_TYPE=%d\n",
+ $type,
+ $packing,
+ $class->type_to_num(Win32::API::Type->packing($type, undef, 1)) if DEBUGCONST;
+ push(@in_params, $class->type_to_num(Win32::API::Type->packing($type, undef, 1)));
+ }
+ }
+ elsif (Win32::API::Struct::is_known($type)) {
+ DEBUG "(PM)parse_prototype: IN='%s' PACKING='%s' API_TYPE=%d\n",
+ $type, 'T', Win32::API::More->type_to_num('T') if DEBUGCONST;
+ push(@in_params, Win32::API::More->type_to_num('T'));
+ }
+ else {
+ warn
+ "Win32::API::parse_prototype: WARNING unknown parameter type '$type'";
+ push(@in_params, $class->type_to_num('I'));
+ }
+ push(@in_types, $type);
+
+ }
+ DEBUG "parse_prototype: IN=[ @in_params ]\n" if DEBUGCONST;
+
+
+ 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),
+ $class->type_to_num('P') if DEBUGCONST;
+ return ($proc, \@in_params, \@in_types, $class->type_to_num('P', 1),
+ $ret, calltype_to_num($callconvention));
+ }
+ else {
+ DEBUG "parse_prototype: OUT='%s' PACKING='%s' API_TYPE=%d\n",
+ $ret,
+ Win32::API::Type->packing($ret),
+ $class->type_to_num(Win32::API::Type->packing($ret, undef, 1), 1) if DEBUGCONST;
+ return (
+ $proc, \@in_params, \@in_types,
+ $class->type_to_num(Win32::API::Type->packing($ret, undef, 1), 1),
+ $ret, calltype_to_num($callconvention)
+ );
+ }
+ }
+ else {
+ warn
+ "Win32::API::parse_prototype: WARNING unknown output parameter type '$ret'";
+ return ($proc, \@in_params, \@in_types, $class->type_to_num('I', 1),
+ $ret, calltype_to_num($callconvention));
+ }
+
+ }
+ else {
+ BADPROTO:
+ warn "Win32::API::parse_prototype: bad prototype '$proto'";
+ return undef;
+ }
+}
+
+#
+# XXX hack, see the proper implementation in TODO
+# The point here is don't let fork children free the parent's DLLs.
+# CLONE runs on ::API and ::More, that's bad and causes a DLL leak, make sure
+# CLONE dups the DLL handles only once per CLONE
+# GetModuleHandleEx was not used since that is a WinXP and newer function, not Win2K.
+# GetModuleFileName was used to get full DLL pathname incase SxS/multiple DLLs
+# with same file name exist in the process. Even if the dll was loaded as a
+# relative path initially, later SxS can load a DLL with a different full path
+# yet same file name, and then LoadLibrary'ing the original relative path
+# might increase the refcount on the wrong DLL or return a different HMODULE
+sub CLONE {
+ return if $_[0] ne "Win32::API";
+
+ _my_cxt_clone();
+ foreach( keys %Libraries){
+ if($Libraries{$_} != Win32::API::LoadLibrary(Win32::API::GetModuleFileName($Libraries{$_}))){
+ die "Win32::API::CLONE unable to clone DLL \"$Libraries{$_}\" Unicode Problem??";
+ }
+ }
+}
+
+1;
+
+__END__
+
+#######################################################################
+# DOCUMENTATION
+#
+
+=head1 NAME
+
+Win32::API - Perl Win32 API Import Facility
+
+=head1 SYNOPSIS
+
+ #### Method 1: with prototype
+
+ use Win32::API;
+ $function = Win32::API::More->new(
+ 'mydll', 'int sum_integers(int a, int b)'
+ );
+ #### $^E is non-Cygwin only
+ die "Error: $^E" if ! $function;
+ #### or on Cygwin and non-Cygwin
+ die "Error: ".(Win32::FormatMessage(Win32::GetLastError())) if ! $function;
+ ####
+ $return = $function->Call(3, 2);
+
+ #### Method 2: with prototype and your function pointer
+
+ use Win32::API;
+ $function = Win32::API::More->new(
+ undef, 38123456, 'int name_ignored(int a, int b)'
+ );
+ die "Error: $^E" if ! $function; #$^E is non-Cygwin only
+ $return = $function->Call(3, 2);
+
+ #### Method 3: with parameter list
+
+ use Win32::API;
+ $function = Win32::API::More->new(
+ 'mydll', 'sum_integers', 'II', 'I'
+ );
+ die "Error: $^E" if ! $function; #$^E is non-Cygwin only
+ $return = $function->Call(3, 2);
+
+ #### Method 4: with parameter list and your function pointer
+
+ use Win32::API;
+ $function = Win32::API::More->new(
+ undef, 38123456, 'name_ignored', 'II', 'I'
+ );
+ die "Error: $^E" if ! $function; #$^E is non-Cygwin only
+ $return = $function->Call(3, 2);
+
+ #### Method 5: with Import (slightly faster than ->Call)
+
+ use Win32::API;
+ $function = Win32::API::More->Import(
+ 'mydll', 'int sum_integers(int a, int b)'
+ );
+ die "Error: $^E" if ! $function; #$^E is non-Cygwin only
+ $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) or arbitrary functions for
+which you have a pointer (MS COM, etc), without having
+to write an XS extension. Note, however, that this module
+can't do everything. In fact, parameters input and output is
+limited to simpler cases.
+
+A regular B<XS> extension is always safer and faster anyway.
+
+The current version of Win32::API is always available at your
+nearest CPAN mirror:
+
+ http://search.cpan.org/dist/Win32-API/
+
+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::More->Import("kernel32", "int GetCurrentProcessId()");
+ $PID = GetCurrentProcessId();
+
+Starting with 0.69. Win32::API initiated objects are deprecated due to numerous
+bugs and improvements, use Win32::API::More now. The use statement remains
+as C<use Win32::API;>.
+
+The possibilities are nearly infinite (but not all are good :-).
+Enjoy it.
+
+=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::More 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::More object
+and instead automatically define a Perl sub with the same name of the API
+function you're importing. This 2nd way using C<Import> to create a sub instead
+of an object is slightly faster than doing C<-E<gt>Call()>. The details of the
+API definitions are the same, just the method name is different:
+
+ my $GetCurrentProcessId = Win32::API::More->new(
+ "kernel32", "int GetCurrentProcessId()"
+ );
+ die "Failed to import GetCurrentProcessId" if !$GetCurrentProcessId;
+ $GetCurrentProcessId->UseMI64(1);
+ my $PID = $GetCurrentProcessId->Call();
+
+ #### vs.
+
+ my $UnusedGCPI = Win32::API::More->Import("kernel32", "int GetCurrentProcessId()");
+ die "Failed to import GetCurrentProcessId" if !$UnusedGCPI;
+ $UnusedGCPI->UseMI64(1);
+ $PID = GetCurrentProcessId();
+
+Note that C<Import> returns the Win32::API obj on success and false on failure
+(in which case you can check the content of C<$^E>). This allows some settings
+to be set through method calls that can't be specified as a parameter to Import,
+yet still have the convience of not writing C<-E<gt>Call()>. The Win32::API obj
+does not need to be assigned to a scalar. C<unless(Win32::API::More-E<gt>Import>
+is fine. Prior to v0.76_02, C<Import> returned returned 1 on success and 0 on
+failure.
+
+=head2 IMPORTING A FUNCTION
+
+You can import a function from a 32 bit Dynamic Link Library (DLL) file with
+the C<new()> function or, starting in 0.69, supply your own function pointer.
+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 or 3 parameters:
+
+=over 4
+
+=item 1.
+
+The name of the library from which you want to import the function. If the
+name is undef, you are requesting a object created from a function pointer,
+and must supply item 2.
+
+=item 2.
+
+This parameter is optional, most people should skip it, skip does not mean
+supplying undef. Supply a function pointer in the format of number 1234, not
+string "\x01\x02\x03\x04". Undef will be returned if the pointer is not
+readable, L<Win32::GetLastError|Win32/Win32::GetLastError()>/L<perlvar/"$^E">
+will be C<ERROR_NOACCESS>.
+
+=item 3.
+
+The C prototype of the function. If you are using a function pointer, the name
+of the function should be something "friendly" to you and no attempt is made
+to retrieve such a name from any DLL's export table. This name for a function
+pointer is also used for Import().
+
+=back
+
+When calling a function imported with a prototype, if you pass an
+undefined Perl scalar to one of its arguments, it will be
+automatically turned into a C C<NULL> value.
+
+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.
+
+If a prototype type is exactly C<signed char> or C<unsigned char> for an
+"in" parameter or the return parameter, and for "in" parameters only
+C<signed char *> or C<unsigned char *> the parameters will be treated as a
+number, C<0x01>, not C<"\x01">. "UCHAR" is not "unsigned char". Change the
+C prototype if you want numeric handling for your chars.
+
+=head2 IMPORTING A FUNCTION WITH A PARAMETER LIST
+
+You need to pass at minimum 4 parameters.
+
+=over 4
+
+=item 1.
+The name of the library from which you want to import the function.
+
+=item 2.
+This parameter is optional, most people should skip it, skip does not mean
+supplying undef. Supply a function pointer in the format of number C<1234>,
+not string C<"\x01\x02\x03\x04">. Undef will be returned if the pointer is not
+readable, L<Win32::GetLastError|Win32/Win32::GetLastError()>/L<perlvar/"$^E">
+will be C<ERROR_NOACCESS>.
+
+=item 3.
+The name of the function (as exported by the library) or for function pointers
+a name that is "friendly" to you. This name for a function pointer is also used
+for Import(). No attempt is made to retrieve such a name from any DLL's export
+table in the 2nd case.
+
+=item 4.
+The number and types of the arguments the function expects as input.
+
+=item 5.
+The type of the value returned by the function.
+
+=item 6.
+And optionally you can specify the calling convention, this defaults to
+'__stdcall', alternatively you can specify '_cdecl' or '__cdecl' (API > v0.68)
+or (API > v0.70_02) 'WINAPI', 'NTAPI', 'CALLBACK' (__stdcall), 'WINAPIV' (__cdecl) .
+False is __stdcall. Vararg functions are always cdecl. MS DLLs are typically
+stdcall. Non-MS DLLs are typically cdecl. If API > v0.75, mixing up the calling
+convention on 32 bits is detected and Perl will C<croak> an error message and
+C<die>.
+
+=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
+
+You may, but don't have to write F<C:\windows\system\kernel32.dll>; or
+F<kernel32.dll>, only F<kernel32> is enough:
+
+ $GetTempPath = new Win32::API::More('kernel32', ...
+
+=item B<2.>
+
+Since this function is from a DLL, skip the 2nd parameter. Skip does not
+mean supplying undef.
+
+=item B<3.>
+
+Now for the real 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 or 64 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. You also can not load a 32 bit
+DLL into a 64 bit Perl, or vice versa. If you try, C<new>/C<Import> will fail
+and C<$^E> will be C<ERROR_BAD_EXE_FORMAT>.
+If their capitalization looks correct, then it's probably a 32 bit
+DLL. If you have Platform SDK or Visual Studio, you can use the Dumpbin
+tool. Call it as C<dumpbin /exports name_of_dll.dll> on the command line.
+If you have Mingw GCC, use objdump as
+C<objdump -x name_of_dll.dll E<gt> dlldump.txt> and search for the word exports
+in the very long output.
+
+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::More('kernel32', 'GetTempPath', ...
+
+In our case C<GetTempPath> is really loaded as C<GetTempPathA>.
+
+=item B<4.>
+
+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 unsigned integer (unsigned int)
+
+=item C<i>:
+value is an signed integer (signed int or int)
+
+=item C<N>:
+value is a unsigned pointer sized number (unsigned long)
+
+=item C<n>:
+value is a signed pointer sized number (signed long or long)
+
+=item C<Q>:
+value is a unsigned 64 bit integer number (unsigned long long, unsigned __int64)
+See next item for details.
+
+=item C<q>:
+value is a signed 64 bit integer number (long long, __int64)
+If your perl has 'Q'/'q' quads support for L<perlfunc/pack> then Win32::API's 'q'
+is a normal perl numeric scalar. All 64 bit Perls have quad support. Almost no
+32 bit Perls have quad support. On 32 bit Perls, without quad support,
+Win32::API's 'q'/'Q' letter is a packed 8 byte string. So C<0x8000000050000000>
+from a perl with native Quad support would be written as
+C<"\x00\x00\x00\x50\x00\x00\x00\x80"> on a 32 bit Perl without Quad support.
+To improve the use of 64 bit integers with Win32::API on a 32 bit Perl without
+Quad support, there is a per Win32::API::* object setting called L</UseMI64>
+that causes all quads to be accepted as, and returned as L<Math::Int64> objects.
+For "in" params in Win32::API and Win32::API::More and "out" in
+Win32::API::Callback only, if the argument is a reference, it will automatically
+be treated as a Math::Int64 object without having to previously call
+L</UseMI64>.
+
+=item C<F>:
+value is a single precision (4 bytes) floating point number (float)
+
+=item C<D>:
+value is a double precision (8 bytes) floating point number (double)
+
+=item C<S>:
+value is a unsigned short (unsigned short)
+
+=item C<s>:
+value is a signed short (signed short or short)
+
+=item C<C>:
+value is a char (char), pass as C<"a">, not C<97>, C<"abc"> will truncate to C<"a">
+
+=item C<P>:
+value is a pointer (to a string, structure, etc...)
+padding out the buffer string is required, buffer overflow detection is
+performed. Pack and unpack the data yourself. If P is a return type, only
+null terminated strings or NULL pointer are supported. If P is an in type, NULL
+is integer C<0>. C<undef>, C<"0">, and C<""+0> are not integer C<0>, C<"0"+0> is
+integer C<0>.
+
+It is suggested to
+not use P as a return type and instead use N and read the memory yourself, and
+free the pointer if applicable. This pointer is effectively undefined after the
+C function returns control to Perl. The C function may not hold onto it after
+the C function returns control. There are exceptions where the pointer will
+remain valid after the C function returns control, but tread at your own risk,
+and at your knowledge of Perl interpreter's C internals.
+
+=item C<T>:
+value is a Win32::API::Struct object, in parameter only, pass by reference
+(pointer) only, pass by copy not implemented, see other sections for more
+
+=item C<K>:
+value is a Win32::API::Callback object, in parameter only, (see L<Win32::API::Callback>)
+
+=item C<V>:
+no value, no parameters, stands for C<void>, may not be combined with any other
+letters, equivalent to a ""
+
+=back
+
+For beginners, just skip this paragraph.
+Note, all parameter types are little endian. This is probably what you want
+unless the documentation for the C function you are calling explicitly says
+the parameters must be big endian. If there is no documentation for your C
+function or no mention of endianess in the documentation, this doesn't apply
+to you and skip the rest of this paragraph. There is no inherent support
+for big endian parameters. Perl's scalar numbers model is that numeric
+scalars are effectively opaque and their machine representation is
+irrelevant. On Windows Perl, scalar numbers are little endian
+internally. So C<$number = 5; print "$number";> will put 5 on the screen.
+C<$number> given to Win32::API will pass little endian integer 5 to the C
+function call. This is almost surly what you want. If you really must pass
+a big endian integer, do C<$number = unpack('L', pack('N', 5));>, then
+C<print "$number";> will put 83886080 on the screen, but this is big endian 5,
+and passing 83886080 to C<-E<gt>Call()> will make sure that
+the C function is getting big endian 5. See L<perlpacktut> for more.
+
+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 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>, which is a
+typedef for unsigned long, so our return type will be B<N>:
+
+ $GetTempPath = new Win32::API::More('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
+L<perlfunc/defined>, otherwise errors such as the function or the library could
+not be loaded or the C prototype was unparsable happened, and no object was
+created. If the return value is undefined, to get detailed error status, use
+L<perlvar/"$^E"> or L<Win32::GetLastError|Win32/Win32::GetLastError()>. C<$^E>
+is slower than C<Win32::GetLastError> and useless on Cygwin, but C<$^E> in
+string context provides a readable description of the error. In numeric context,
+C<$^E> is equivelent to C<Win32::GetLastError>. C<Win32::GetLastError> always
+returns an integer error code. You may use
+L<Win32::FormatMessage|Win32/Win32::FormatMessage()> to convert an integer error
+code to a readable description on Cygwin and Native builds of Perl.
+
+Our definition, with error checking added, should then look like this:
+
+ $GetTempPath = new Win32::API::More('kernel32', 'GetTempPath', 'NP', 'N');
+ if(not defined $GetTempPath) {
+ die "Can't import API GetTempPath: $^E\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 except for char, you can use either a constant expression
+or a variable, it will be numified similar to the expression C<($var+0)>.
+For pointers, 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 a fatal buffer overflow error starting in 0.69.
+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 never 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>, not a "pass by copy" structure. As you can see, our
+structure is named 'POINT', but the API used 'LPPOINT'. Some heuristics are
+done to validate the argument's type vs the parameter's type if the function
+has a C prototype definition (not letter definition). First, if the parameter
+type starts with the LP prefix, the LP prefix is stripped, then compared to
+the argument's type. If that fails, the Win32::API::Type database
+(see L<Win32::API::Type/typedef>)
+will be used to convert the parameter type to the base type. If that fails,
+the parameter type will be stripped of a trailing whitespace then a '*', and
+then checked against the base type. L<Dies|perlfunc/die> if the parameter and
+argument types do not match after 3 attempts.
+
+For more information, see also L<Win32::API::Struct>.
+
+If you don't want (or can't) use the C<Win32::API::Struct> facility,
+you can still use the low-level approach to use structures:
+
+=over 4
+
+=item 1.
+
+you have to L<pack()|perlfunc/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, L<unpack()|perlfunc/unpack> it as required:
+
+ ($x, $y) = unpack(';;', $lpPoint); # get the actual values
+
+=back
+
+The rest is left as an exercise to the reader...
+
+=head2 EXPORTED FUNCTIONS
+
+=head3 ReadMemory
+
+ $copy_of_memblock = ReadMemory($SourcePtr, $length);
+
+Reads the source pointer for C<$length> number of bytes. Returns a copy of
+the memory block in a scalar. No readability checking is done on C<$SourcePtr>.
+C<$SourcePtr>'s format is 123456, not C<"\x01\x02\x03\x04">.
+
+=head3 WriteMemory
+
+ WriteMemory($DestPtr, $sourceScalar, $length);
+
+Copies the string contents of the C<$sourceScalar> scalar to C<$DestPtr> for
+C<$length> bytes. $length must be less than or equal to the length of
+C<$sourceScalar>, otherwise the function croaks. No readability checking is
+done on C<$DestPtr>. C<$DestPtr>'s format is 123456, not
+C<"\x01\x02\x03\x04">. Returns nothing.
+
+=head3 MoveMemory
+
+ MoveMemory($destPtr, $sourcePtr, $length);
+
+Copies a block of memory from one location to another. The source and
+destination blocks may overlap. All pointers are in the format of 123456,
+not C<"\x01\x02\x03\x04">. No readability checking is done. Returns nothing.
+
+=head3 IsBadReadPtr
+
+ if(IsBadReadPtr($ptr, $length)) {die "bad ptr";}
+
+Probes a memory block for C<$length> bytes for readability. Returns true if
+access violation occurs, otherwise false is returned. This function is useful
+to avoid dereferencing pointers which will crash the perl process. This function
+has many limitations, including not detecting uninitialized memory, not
+detecting freed memory, and not detecting gibberish. It can not tell whether a
+function pointer is valid x86 machine code. Ideally, you should never use it,
+or remove it once your code is stable. C<$ptr> is in the format of 123456,
+not C<"\x01\x02\x03\x04">. See MS's documentation for a lot more
+on this function of the same name.
+
+=head3 SafeReadWideCString
+
+ $source = Encode::encode("UTF-16LE","Just another perl h\x{00E2}cker\x00");
+ $string = SafeReadWideCString(unpack('J',pack('p', $source)));
+ die "impossible" if $source ne "Just another perl h\x{00E2}cker";
+
+Safely (SEH aware) reads a utf-16 wide null terminated string (the first and
+only parameter), into a scalar. Returns undef, if an access violation happens
+or null pointer (same thing). The string pointer is in the format of 123456,
+not C<"\x01\x02\x03\x04">. The returned scalar will be UTF8 marked if the string
+can not be represented in the system's ANSI codepage. Conversion is done with
+WideCharToMultiByte. Returns a 0 length scalar string if WideCharToMultiByte fails.
+This function was created because L<pack's|perlfunc/pack> p letter won't read UTF16
+and L</ReadMemory> and L</IsBadReadPtr> require an explicit length.
+
+=head2 CONSTRUCTORS
+
+=head3 new
+
+ $obj = Win32::API::More->new([$dllname | (undef , $funcptr)], [$c_proto | ($in, $out [, $calling_convention])]);
+
+See L</DESCRIPTION>.
+
+=head3 Import
+ $obj = Win32::API::More->Import([$dllname | (undef , $funcptr)], [$c_proto | ($in, $out [, $calling_convention])]);
+
+See L</DESCRIPTION>.
+
+=head2 METHODS
+
+=head3 Call
+
+The main method of a Win32::API object. Documented elsewhere in this document.
+
+=head3 UseMI64
+
+ $bool = $APIObj->UseMI64();
+ $oldbool = $APIObj->UseMI64($newbool);
+
+Turns on Quads as L<Math::Int64> objects support for a particular object
+instance. You must call L<perlfunc/use>/L<perlfunc/require> on Math::Int64
+before calling UseMI64. Win32::API does not C<use> Math::Int64 for you.
+Works on Win32::API and Win32::API::Callback objects. This method
+does not exist if your Perl natively supports Quads (64 bit Perl for example).
+Takes 1 optional parameter, which is a true or false value to use or don't use
+Math::Int64, returns the old setting, which is a true or false value. If called
+without any parameters, returns current setting, which is a true or false value,
+without setting the option. As discussed in L</q>, if you are not using
+Math::Int64 you must supply/will receive 8 byte scalar strings for quads.
+For "in" params in Win32::API and Win32::API::More and "out" in
+Win32::API::Callback only, if the argument is a reference, it will automatically
+be treated as a Math::Int64 object without having to previously call this
+function.
+
+=head2 VERBOSE DEBUGGING
+
+If using C<Win32::GetLastError> and C<$^E> does not reveal the problem with your
+use of Win32::API, you may turn on Win32::API's very verbose debugging mode as
+follows
+
+ BEGIN {
+ $Win32::API::DEBUG = 1;
+ }
+ use Win32::API;
+ $function = Win32::API::More->new(
+ 'mydll', 'int sum_integers(int a, int b)'
+ );
+
+=head1 HISTORY
+
+=over 4
+
+=item UseMI64 API change
+
+Starting in 0.71, UseMI64 on a set returns old value, not previously
+new value.
+
+=item fork safe
+
+Starting in 0.71, a Win32::API object can go through a fork and work
+correctly in the child and parent psuedo-processes. Previously when either
+psuedo-processes exited, the DLL would be unloaded and the other
+psuedo-processes would crash if a Call() was done on the object.
+
+=item return value signedness
+
+Prior to 0.69, for numeric integer types, the return scalar was always signed.
+Unsigned-ness was ignored.
+
+=item shorts
+
+Prior to 0.69, shorts were not supported. 'S' meant a sturct. To fix this
+Win32::API::More class was created for 0.69. 'S'/'s' now means short, per pack's
+letters. Struct has been moved to letter 'T'. Win32::API will continue to exist
+for legacy code.
+
+=item float return types
+
+Prior to 0.69, if a function had a return type of float, it was silently
+not called.
+
+=item buffer overflow protection
+
+Introduced in 0.69. If disabling is required, which is highly
+B<not recommended>, set an environmental variable called
+WIN32_API_SORRY_I_WAS_AN_IDIOT to 1.
+
+=item automatic un/pack
+
+Starting with 0.69, when using Win32::API::More, there is automatic un/packing
+of pointers to numbers-ish things for in parameters when using the C
+prototype interface.
+
+=item Quads on 32 bit
+
+Added in 0.70.
+
+=item __stdcall vs __cdecl checking on 32 bits
+
+Added in 0.76_01
+
+=item Import returns an api obj on success, undef on failure, instead of 1 or 0
+
+Added in 0.76_02
+
+=item checking C<$!> for C<new>/C<Import> failure is broken and deprecated
+
+Starting in 0.76_06, due to many bugs with C<new> and C<Import> not setting
+L<perlvar/$!> or Win32 and C error codes overlapping and Win32 error codes being
+stringified as different C error codes, checking C<$!> is deprecated and the
+existing, partial setting of C<$!>, maybe removed in the future. Only check
+C<Win32::GetLastError()> or C<$^E> to find out why the call failed.
+
+=back
+
+See the C<Changes> file for more details, many of which not mentioned here.
+
+=head1 BUGS AND LIMITATIONS
+
+=over 4
+
+=item E<nbsp> Unicode DLL paths
+
+Untested.
+
+=item E<nbsp> ithreads
+
+Minimally tested.
+
+=item E<nbsp> C functions getting utf8 scalars vs byte scalars
+
+Untested and undefined.
+
+=back
+
+=head1 SEE ALSO
+
+L<Math::Int64>
+
+L<Win32::API::Struct>
+
+L<Win32::API::Type>
+
+L<Win32::API::Callback>
+
+L<Win32::API::Callback::IATPatch>
+
+L<http://homepage.ntlworld.com/jonathan.deboynepollard/FGA/function-calling-conventions.html>
+
+=head1 AUTHOR
+
+Aldo Calpini ( I<dada@perl.it> ).
+
+=head1 MAINTAINER
+
+Cosimo Streppone ( I<cosimo@cpan.org> )
+
+=head1 MAJOR CONTRIBUTOR
+
+Daniel Dragan ( I<bulkdd@cpan.org> )
+
+=head1 LICENSE
+
+To finally clarify this, C<Win32::API> is OSI-approved free software;
+you can redistribute it and/or modify it under the same terms as Perl
+itself.
+
+See L<http://dev.perl.org/licenses/artistic.html>
+
+=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 invaluable help in XS development, and to all the Perl
+community for being what it is.
+
+Cosimo also wants to personally thank everyone that contributed
+to Win32::API with complaints, emails, patches, RT bug reports
+and so on.
+
+=cut
+
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/API/Callback.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/API/Callback.pm
new file mode 100644
index 0000000000..1731a637fb
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/API/Callback.pm
@@ -0,0 +1,575 @@
+# 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>
+# Author: Daniel Dragan <bulkdd@cpan.org>
+# Maintainer: Cosimo Streppone <cosimo@cpan.org>
+#
+#######################################################################
+
+package Win32::API::Callback;
+use strict;
+use warnings;
+use vars qw( $VERSION $Stage2FuncPtrPkd );
+
+$VERSION = '0.84';
+
+#require XSLoader; # to dynuhlode the module. #already loaded by Win32::API
+#use Data::Dumper;
+
+use Win32::API qw ( WriteMemory ) ;
+
+BEGIN {
+ #there is supposed to be 64 bit IVs on 32 bit perl compatibility here
+ #but it is untested
+ *IVSIZE = *Win32::API::IVSIZE;
+ #what kind of stack processing/calling convention/machine code we needed
+ eval "sub ISX64 () { ".(Win32::API::PTRSIZE() == 8 ? 1 : 0)." }";
+ eval 'sub OPV () {'.$].'}';
+ sub OPV();
+ sub CONTEXT_XMM0();
+ sub CONTEXT_RAX();
+ *IsBadStringPtr = *Win32::API::IsBadStringPtr;
+ sub PTRSIZE ();
+ *PTRSIZE = *Win32::API::PTRSIZE;
+ sub PTRLET ();
+ *PTRLET = *Win32::API::Type::pointer_pack_type;
+ if(OPV <= 5.008000){ #don't have unpackstring in C
+ eval('sub _CallUnpack {return unpack($_[0], $_[1]);}');
+ }
+ *DEBUGCONST = *Win32::API::DEBUGCONST;
+ *DEBUG = *Win32::API::DEBUG;
+}
+#######################################################################
+# dynamically load in the API extension module.
+#
+XSLoader::load 'Win32::API::Callback', $VERSION;
+
+#######################################################################
+# PUBLIC METHODS
+#
+sub new {
+ my ($class, $proc, $in, $out, $callconvention) = @_;
+ my $self = bless {}, $class; #about croak/die safety, can safely bless here,
+ #a ::Callback has no DESTROY, it has no resources to release, there is a HeapBlock obj
+ #stored in the ::Callback hash, but the HeapBlock destroys on its own
+ # printf "(PM)Callback::new: got proc='%s', in='%s', out='%s'\n", $proc, $in, $out;
+
+ $self->{intypes} = []; #XS requires this, do not remove
+ if (ref($in) eq 'ARRAY') {
+ foreach (@$in) {
+ push(@{$self->{intypes}}, $_);
+ }
+ }
+ else {
+ my @in = split '', $in;
+ foreach (@in) {
+ push(@{$self->{intypes}}, $_);
+ }
+ }
+ $self->{inbytes} = 0;
+ foreach(@{$self->{intypes}}){ #calc how long the c stack is
+ if($_ eq 'Q' or $_ eq 'q' or $_ eq 'D' or $_ eq 'd'){
+ $self->{inbytes} += 8; #always 8
+ }
+ else{
+ $self->{inbytes} += PTRSIZE; #4 or 8
+ }
+ }
+ $self->{outtype} = $out;
+ $self->{out} = Win32::API->type_to_num($out);
+ $self->{sub} = $proc;
+ $self->{cdecl} = Win32::API::calltype_to_num($callconvention);
+
+ DEBUG "(PM)Callback::new: calling CallbackCreate($self)...\n" if DEBUGCONST;
+ my $hproc = MakeCB($self);
+
+ DEBUG "(PM)Callback::new: hproc=$hproc\n" if DEBUGCONST;
+
+ $self->{code} = $hproc;
+
+ #### cast the spell
+ return $self;
+}
+
+sub MakeStruct {
+ my ($self, $n, $addr) = @_;
+ DEBUG "(PM)Win32::API::Callback::MakeStruct: got self='$self'\n" if DEBUGCONST;
+ my $struct = Win32::API::Struct->new($self->{intypes}->[$n]);
+ $struct->FromMemory($addr);
+ return $struct;
+}
+
+#this was rewritten in XS, and is broken b/c it doesn't work on 32bit Perl with Quads
+#sub MakeParamArr { #on x64, never do "$i++; $packedparam .= $arr->[$i];"
+# #on x86, structs and over word size params appears on the stack,
+# #on x64 anything over the size of a "word" is passed by pointer
+# #nothing takes more than 8 bytes per parameter on x64
+# #there is no way to formally specify a pass by copy struct in ::Callback
+# #this only matters on x86, a work around is a bunch of N/I parameters,
+# #repack them as Js, then concat them, and you have the original pass by copy
+# #x86 struct
+# my ($self, $arr) = @_;
+# my ($i, @pass_arr) = (0);
+# for(@{$self->{intypes}}){ #elements of intypes are not 1 to 1 with stack params
+# my ($typeletter, $packedparam, $finalParam, $unpackletter) = ($_, $arr->[$i]);
+#
+# #structs don't work, this is broken code from old version
+# #$self->{intypes} is letters types not C prototype params
+# #C prototype support would have to exist for MakeStruct to work
+# if( $typeletter eq 'S' || $typeletter eq 's'){
+# die "Win32::API::Callback::MakeParamArr type letter \"S\" and struct support not implemented";
+# #push(@pass_arr, MakeStruct($self, $i, $packedparam));
+# }elsif($typeletter eq 'I'){
+# $unpackletter = 'I', goto UNPACK;
+# }elsif($typeletter eq 'i'){
+# $unpackletter = 'i', goto UNPACK;
+# }elsif($typeletter eq 'f' || $typeletter eq 'F'){
+# $unpackletter = 'f', goto UNPACK;
+# }
+# elsif($typeletter eq 'd' || $typeletter eq 'D'){
+# if(IVSIZE == 4){ #need more data, 32 bit machine
+# $packedparam .= $arr->[++$i];
+# }
+# $unpackletter = 'd', goto UNPACK;
+# }
+# elsif($typeletter eq 'N' || $typeletter eq 'L' #on x64, J is 8 bytes
+# || (IVSIZE == 8 ? $typeletter eq 'Q': 0)){
+# $unpackletter = 'J', goto UNPACK;
+# }elsif($typeletter eq 'n' || $typeletter eq 'l'
+# || (IVSIZE == 8 ? $typeletter eq 'q': 0)){
+# $unpackletter = 'j', goto UNPACK;
+# }elsif(IVSIZE == 4 && ($typeletter eq 'q' || $typeletter eq 'Q')){
+# #need more data, 32 bit machine
+# $finalParam = $packedparam . $arr->[++$i];
+# }elsif($typeletter eq 'p' || $typeletter eq 'P'){
+# if(!IsBadStringPtr($arr->[$i], ~0)){ #P letter is terrible design
+# $unpackletter = 'p', goto UNPACK;
+# }#else undef
+# }
+# else{ die "Win32::API::Callback::MakeParamArr unknown in type letter $typeletter";}
+# goto GOTPARAM;
+# UNPACK:
+# $finalParam = unpack($unpackletter, $packedparam);
+# GOTPARAM:
+# $i++;
+# push(@pass_arr, $finalParam);
+# }
+# return \@pass_arr;
+#}
+
+#on x64
+#void RunCB($self, $EBP_ESP, $retval)
+#on x86
+#void RunCB($self, $EBP_ESP, $retval, $unwindcount, $F_or_D)
+if(! ISX64 ) {
+*RunCB = sub {#32 bits
+ my $self = $_[0];
+ my (@pass_arr, $return, $typeletter, $inbytes, @arr);
+ $inbytes = $self->{inbytes};
+ #first is ebp copy then ret address
+ $inbytes += PTRSIZE * 2;
+ my $paramcount = $inbytes / PTRSIZE ;
+ my $stackstr = unpack('P'.$inbytes, pack(PTRLET, $_[1]));
+ #pack () were added in 5.7.2
+ if (OPV > 5.007002) {
+ @arr = unpack("(a[".PTRLET."])[$paramcount]",$stackstr);
+ } else {
+ #letter can not be used for size, must be numeric on 5.6
+ @arr = unpack(("a4") x $paramcount,$stackstr);
+ }
+ shift @arr, shift @arr; #remove ebp copy and ret address
+ $paramcount -= 2;
+ $return = &{$self->{sub}}(@{MakeParamArr($self, \@arr)});
+
+ #now the return type
+ $typeletter = $self->{outtype};
+ #float_or_double flag, its always used
+ #float is default for faster copy of probably unused value
+ $_[4] = 0;
+ #its all the same in memory
+ if($typeletter eq 'n' || $typeletter eq 'N'
+ || $typeletter eq 'l' || $typeletter eq 'L'
+ || $typeletter eq 'i' || $typeletter eq 'I'){
+ $_[2] = pack(PTRLET, $return);
+ }elsif($typeletter eq 'q' || $typeletter eq 'Q'){
+ if(IVSIZE == 4){
+ if($self->{'UseMI64'} || ref($return)){ #un/signed meaningless
+ $_[2] = Math::Int64::int64_to_native($return);
+ }
+ else{
+ warn("Win32::API::Callback::RunCB return value for return type Q is under 8 bytes long")
+ if length($return) < 8;
+ $_[2] = $return.''; #$return should be a 8 byte string
+ #will be garbage padded in XS if < 8, but must be a string, not a IV or under
+ }
+ }
+ else{
+ $_[2] = pack($typeletter, $return);
+ }
+ }elsif($typeletter eq 'f' || $typeletter eq 'F' ){
+ $_[2] = pack('f', $return);
+ }elsif($typeletter eq 'd' || $typeletter eq 'D' ){
+ $_[2] = pack('d', $return);
+ $_[4] = 1; #use double
+ }else { #return null
+ $_[2] = "\x00" x 8;
+ }
+
+ if(! $self->{cdecl}){
+ $_[3] = PTRSIZE * $paramcount; #stack rewind amount in bytes
+ }
+ else{$_[3] = 0;}
+};
+}
+else{ #64 bits
+*RunCB = sub {
+ my $self = $_[0];
+ my (@pass_arr, $return, $typeletter);
+ my $paramcount = $self->{inbytes} / IVSIZE;
+ my $stack_ptr = unpack('P[J]', pack('J', ($_[1]+CONTEXT_RAX())));
+ my $stack_str = unpack('P['.$self->{inbytes}.']', $stack_ptr);
+ my @stack_arr = unpack("(a[J])[$paramcount]",$stack_str);
+ #not very efficient, todo search for f/F/d/D in new() not here
+ my $XMMStr = unpack('P['.(4 * 16).']', pack('J', ($_[1]+CONTEXT_XMM0())));
+ #print Dumper([unpack('(H[32])[4]', $XMMStr)]);
+ my @XMM = unpack('(a[16])[4]', $XMMStr);
+ #assume registers are copied to shadow stack space already
+ #because of ... prototype, so only XMM registers need to be fetched.
+ #Limitation, vararg funcs on x64 get floating points in normal registers
+ #not XMMs, so a vararg function taking floats and doubles in the first 4
+ #parameters isn't supported
+ if($paramcount){
+ for(0..($paramcount > 4 ? 4 : $paramcount)-1){
+ my $typeletter = ${$self->{intypes}}[$_];
+ if($typeletter eq 'f' || $typeletter eq 'F' || $typeletter eq 'd'
+ || $typeletter eq 'D'){
+ #x64 calling convention does not use the high 64 bits of a XMM register
+ #although right here the high 64 bits are in @XMM elements
+ #J on x64 is 8 bytes, a double will not corrupt, this is unreachable on x86
+ #note we are copying 16 bytes elements to @stack_arr, @stack_arr is
+ #normally 8 byte elements, unpack ignores the excess bytes later
+ $stack_arr[$_] = $XMM[$_];
+ }
+ }
+ }
+ #print Dumper(\@stack_arr);
+ #print Dumper(\@XMM);
+ $return = &{$self->{sub}}(@{MakeParamArr($self, \@stack_arr)});
+
+ #now the return type
+ $typeletter = $self->{outtype};
+ #its all the same in memory
+ if($typeletter eq 'n' || $typeletter eq 'N'
+ || $typeletter eq 'l' || $typeletter eq 'L'
+ || $typeletter eq 'i' || $typeletter eq 'I'
+ || $typeletter eq 'q' || $typeletter eq 'Q'){
+ $_[2] = pack('J', $return);
+ }
+ elsif($typeletter eq 'f' || $typeletter eq 'F' ){
+ $_[2] = pack('f', $return);
+ }
+ elsif($typeletter eq 'd' || $typeletter eq 'D' ){
+ $_[2] = pack('d', $return);
+ }
+ else { #return null
+ $_[2] = pack('J', 0);
+ }
+};
+}
+
+sub MakeCB{
+
+ my $self = $_[0];
+ #this x86 function does not corrupt the callstack in a debugger since it
+ #uses ebp and saves ebp on the stack, the function won't have a pretty
+ #name though
+ my $code = (!ISX64) ? ('' #parenthesis required to constant fold
+ ."\x55" # push ebp
+ ."\x8B\xEC" # mov ebp, esp
+ ."\x83\xEC\x0C"# sub esp, 0Ch
+ ."\x8D\x45\xFC" # lea eax, [ebp+FuncRtnCxtVar]
+ ."\x50"# push eax
+ ."\x8D\x45\xF4"# lea eax, [ebp+retval]
+ ."\x50"# push eax
+ ."\x8B\xC5"# mov eax,ebp
+ ."\x50"# push eax
+ ."\xB8").PackedRVTarget($self)#B8 mov imm32 to eax, a HV * winds up here
+ .("\x50"# push eax
+ ."\xB8").$Stage2FuncPtrPkd # mov eax, 0C0DE0001h
+ .("\xFF\xD0"# call eax
+ #since ST(0) is volatile, we don't care if we fill it with garbage
+ ."\x80\x7D\xFE\x00"#cmp [ebp+FuncRtnCxtVar.F_Or_D], 0
+ ."\xDD\xD8"# fstp st(0) pop a FP reg to make space on FPU stack
+ ."\x74\x05"# jz 5 bytes
+ ."\xDD\x45\xF4"# fld qword ptr [ebp+retval] (double)
+ ."\xEB\x03"# jmp 3 bytes
+ ."\xD9\x45\xF4"# fld dword ptr [ebp+retval] (float)
+ #rewind sp to entry sp, no pop push after this point
+ ."\x83\xC4\x24"# add esp, 24h
+ ."\x8B\x45\xF4"# mov eax, dword ptr [ebp+retval]
+ #edx might be garbage, we don't care, caller only looks at volatile
+ #registers that the caller's prototype says the caller does
+ ."\x8B\x55\xF8"# mov edx, dword ptr [ebp+retval+4]
+ #can't use retn op, it requires a immediate count, our count is in a register
+ #only one register available now, this will be complicated
+ ."\x0F\xB7\x4D\xFC"#movzx ecx, word ptr [ebp+FuncRtnCxtVar.unwind_len]
+ ."\x01\xCC"# add esp, ecx , might be zero or more
+ ."\x8B\x4D\x04"# mov ecx, dword ptr [ebp+4] ret address
+ ."\x8B\x6D\x00"# mov ebp, dword ptr [ebp+0] restore BP
+ ."\xFF\xE1")# jmp ecx
+
+
+ #begin x64 part
+ #these packs don't constant fold in < 5.17 :-(
+ #they are here for readability
+ :(''.pack('C', 0b01000000 #REX base
+ | 0b00001000 #REX.W
+ | 0b00000001 #REX.B
+ ).pack('C', 0xB8+2) #mov to r10 register
+ .PackedRVTarget($self)
+ .pack('C', 0b01000000 #REX base
+ | 0b00001000 #REX.W
+ ).pack('C', 0xB8) #mov to rax register
+ .$Stage2FuncPtrPkd
+ ."\xFF\xE0");# jmp rax
+#making a full function in Perl in x64 was removed because RtlAddFunctionTable
+#has no effect on VS 2008 debugger, it is a bug in VS 2008, in WinDbg the C callstack
+#is correct with RtlAddFunctionTable, and broken without RtlAddFunctionTable
+#in VS 2008, the C callstack was always broken since WinDbg and VS 2008 both
+#*only* use Unwind Tables on x64 to calculate C callstacks, they do not, I think,
+#use 32 bit style EBP/RBP walking, x64 VC almost never uses BP addressing anyway.
+#The easiest fix was to not have dynamic machine code in the callstack at all,
+#which is what I did. Having good C callstacks in a debugger with ::API and
+#::Callback are a good goal.
+#
+##--- c:\documents and settings\administrator\desktop\w32api\callback\callback.c -
+# $code .= "\x4C\x8B\xDC";# mov r11,rsp
+# $code .= "\x49\x89\x4B\x08";# mov qword ptr [r11+8],rcx
+# $code .= "\x49\x89\x53\x10";# mov qword ptr [r11+10h],rdx
+# $code .= "\x4D\x89\x43\x18";# mov qword ptr [r11+18h],r8
+# $code .= "\x4D\x89\x4B\x20";# mov qword ptr [r11+20h],r9
+# $code .= "\x48\x83\xEC\x78";# sub rsp,78h
+# #void (*LPerlCallback)(SV *, void *, unsigned __int64 *, void *) =
+# #( void (*)(SV *, void *, unsigned __int64 *, void *)) 0xC0DE00FFFF000001;
+# #__m128 arr [4];
+# #__m128 retval;
+## arr[0].m128_u64[0] = 0xFFFF00000000FF10;
+##00000000022D1017 48 B8 10 FF 00 00 00 00 FF FF mov rax,0FFFF00000000FF10h
+##arr[0].m128_u64[1] = 0xFFFF00000000FF11;
+## arr[1].m128_u64[0] = 0xFFFF00000000FF20;
+## arr[1].m128_u64[1] = 0xFFFF00000000FF21;
+## arr[2].m128_u64[0] = 0xFFFF00000000FF30;
+## arr[2].m128_u64[1] = 0xFFFF00000000FF31;
+## arr[3].m128_u64[0] = 0xFFFF00000000FF40;
+## arr[3].m128_u64[1] = 0xFFFF00000000FF41;
+#
+## LPerlCallback((SV *)0xC0DE00FFFF000002, (void*) arr, (unsigned __int64 *)&retval,
+## (DWORD_PTR)&a);
+##00000000022D1021 4D 8D 4B 08 lea r9,[r11+8] #no 4th param
+# $code .= "\x4D\x8D\x43\xA8";# lea r8,[r11-58h] #&retval param
+##00000000022D1029 49 89 43 B8 mov qword ptr [r11-48h],rax
+##00000000022D102D 48 B8 11 FF 00 00 00 00 FF FF mov rax,0FFFF00000000FF11h
+# $code .= "\x49\x8D\x53\xB8";# lea rdx,[r11-48h] #arr param
+##00000000022D103B 49 89 43 C0 mov qword ptr [r11-40h],rax
+##00000000022D103F 48 B8 20 FF 00 00 00 00 FF FF mov rax,0FFFF00000000FF20h
+##00000000022D1049 48 B9 02 00 00 FF FF 00 DE C0 mov rcx,0C0DE00FFFF000002h
+# $code .= "\x48\xB9".PackedRVTarget($self);# mov rcx, the HV *
+##00000000022D1053 49 89 43 C8 mov qword ptr [r11-38h],rax
+##00000000022D1057 48 B8 21 FF 00 00 00 00 FF FF mov rax,0FFFF00000000FF21h
+##00000000022D1061 49 89 43 D0 mov qword ptr [r11-30h],rax
+##00000000022D1065 48 B8 30 FF 00 00 00 00 FF FF mov rax,0FFFF00000000FF30h
+##00000000022D106F 49 89 43 D8 mov qword ptr [r11-28h],rax
+##00000000022D1073 48 B8 31 FF 00 00 00 00 FF FF mov rax,0FFFF00000000FF31h
+##00000000022D107D 49 89 43 E0 mov qword ptr [r11-20h],rax
+##00000000022D1081 48 B8 40 FF 00 00 00 00 FF FF mov rax,0FFFF00000000FF40h
+##00000000022D108B 49 89 43 E8 mov qword ptr [r11-18h],rax
+##00000000022D108F 48 B8 41 FF 00 00 00 00 FF FF mov rax,0FFFF00000000FF41h
+##00000000022D1099 49 89 43 F0 mov qword ptr [r11-10h],rax
+##00000000022D109D 48 B8 01 00 00 FF FF 00 DE C0 mov rax,0C0DE00FFFF000001h
+# $code .= "\x48\xB8".$Stage2FuncPtrPkd; # mov rax,0C0DE00FFFF000001h
+# $code .= "\xFF\xD0";# call rax
+## return *(void **)&retval;
+# $code .= "\x48\x8B\x44\x24\x20";# mov rax,qword ptr [retval]
+##}
+# $code .= "\x48\x83\xC4\x78";# add rsp,78h
+# $code .= "\xC3";# ret
+
+#$self->{codestr} = $code; #save memory
+#32 bit perl doesn't use DEP in my testing, but use executable heap to be safe
+#a Win32::API::Callback::HeapBlock is a ref to scalar, that scalar has the void *
+my $ptr = ${($self->{codeExecAlloc} = Win32::API::Callback::HeapBlock->new(length($code)))};
+WriteMemory($ptr, $code, length($code));
+return $ptr;
+}
+
+
+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> or the tests in the F<t> directory.
+
+=back
+
+=head1 USAGE
+
+Win32::API::Callback uses a subset of the type letters of Win32::API. C Prototype
+interface isn't supported. Not all the type letters of Win32::API are supported
+in Win32::API::Callback.
+
+=over 4
+
+=item C<I>:
+value is an unsigned integer (unsigned int)
+
+=item C<i>:
+value is an signed integer (signed int or int)
+
+=item C<N>:
+value is a unsigned pointer sized number (unsigned long)
+
+=item C<n>:
+value is a signed pointer sized number (signed long or long)
+
+=item C<Q>:
+value is a unsigned 64 bit integer number (unsigned long long, unsigned __int64)
+See next item for details.
+
+=item C<q>:
+value is a signed 64 bit integer number (long long, __int64)
+If your perl has 'Q'/'q' quads support for L<pack> then Win32::API's 'q'
+is a normal perl numeric scalar. All 64 bit Perls have quad support. Almost no
+32 bit Perls have quad support. On 32 bit Perls, without quad support,
+Win32::API::Callback's 'q'/'Q' letter is a packed 8 byte string.
+So C<0x8000000050000000> from a perl with native Quad support
+would be written as C<"\x00\x00\x00\x50\x00\x00\x00\x80"> on a 32 bit
+Perl without Quad support. To improve the use of 64 bit integers with
+Win32::API::Callback on a 32 bit Perl without Quad support, there is
+a per Win32::API::Callback object setting called L<Win32::API/UseMI64>
+that causes all quads to be accepted as, and returned as L<Math::Int64>
+objects. 4 to 8 byte long pass by copy/return type C aggregate types
+are very rare in Windows, but they are supported as "in" and return
+types by using 'q'/'Q' on 32 and 64 bits. Converting between the C aggregate
+and its representation as a quad is up to the reader. For "out" in
+Win32::API::Callback (not "in"), if the argument is a reference, it will
+automatically be treated as a Math::Int64 object without having to
+previously call this function.
+
+=item C<F>:
+value is a floating point number (float)
+
+=item C<D>:
+value is a double precision number (double)
+
+=item C<Unimplemented types>:
+Unimplemented in Win32::API::Callback types such as shorts, chars, and
+smaller than "machine word size" (32/64bit) numbers can be processed
+by specifying N, then masking off the high bytes.
+For example, to get a char, specify N, then do C<$numeric_char = $_[2] & 0xFF;>
+in your Perl callback sub. To get a short, specify N, then do
+C<$numeric_char = $_[2] & 0xFFFF;> in your Perl callback sub.
+
+=back
+
+=head2 FUNCTIONS
+
+=head3 new
+
+ $CallbackObj = Win32::API::Callback->new( sub { print "hello world";},
+ 'NDF', 'Q', '__cdecl');
+ $CallbackObj = Win32::API::Callback->new( sub { print "hello world";},
+ $in, $out);
+
+Creates and returns a new Win32::API::Callback object. Calling convention
+parameter is optional. Calling convention parameter has same behaviour as
+Win32::API's calling convention parameter. C prototype parsing of Win32::API
+is not available with Win32::API::Callback. If the C caller assumes the
+callback has vararg parameters, and the platform is 64 bits/x64, in the first 4
+parameters, if they are floats or doubles they will be garbage. Note there is
+no way to create a Win32::API::Callback callback with a vararg prototype.
+A workaround is to put "enough" Ns as the in types, and stop looking at the @_
+slices in your Perl sub callback after a certain count. Usually the first
+parameter will somehow indicate how many additional stack parameters you are
+receiving. The Ns in @_ will eventually become garbage, technically they are
+the return address, saved registers, and C stack allocated variables of the
+caller. They are effectivly garbage for your vararg callback. All vararg
+callbacks on 32 bits must supply a calling convention, and it must be '__cdecl'
+or 'WINAPIV'.
+
+=head2 METHODS
+
+=head3 UseMI64
+
+See L<Win32::API/UseMI64>.
+
+=head1 KNOWN ISSUES
+
+=over 4
+
+=item *
+
+Callback is safe across a Win32 psuedo-fork. Callback is not safe across a
+Cygwin fork. On Cygwin, in the child process of the fork, a Segmentation Fault
+will happen if the Win32::API::Callback callback is is called.
+
+=back
+
+=head1 SEE ALSO
+
+L<Win32::API::Callback::IATPatch>
+
+=head1 AUTHOR
+
+Aldo Calpini ( I<dada@perl.it> ).
+Daniel Dragan ( I<bulkdd@cpan.org> ).
+
+=head1 MAINTAINER
+
+Cosimo Streppone ( I<cosimo@cpan.org> ).
+
+=cut
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/API/Callback/IATPatch.pod b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/API/Callback/IATPatch.pod
new file mode 100644
index 0000000000..27eb1af2fb
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/API/Callback/IATPatch.pod
@@ -0,0 +1,181 @@
+=head1 NAME
+
+Win32::API::Callback::IATPatch - Hooking and Patching a DLL's Imported C Functions
+
+=head1 SYNOPSIS
+
+ use Win32::API;
+ use Win32::API::Callback;
+ warn "usually fatally errors on Cygwin" if $^O eq 'cygwin';
+ # do not do a "use" or "require" on Win32::API::Callback::IATPatch
+ # IATPatch comes with Win32::API::Callback
+ my $LoadLibraryExA;
+ my $callback = Win32::API::Callback->new(
+ sub {
+ my $libname = unpack('p', pack('J', $_[0]));
+ print "got $libname\n";
+ return $LoadLibraryExA->Call($libname, $_[1], $_[2]);
+ },
+ 'NNI',
+ 'N'
+ );
+ my $patch = Win32::API::Callback::IATPatch->new(
+ $callback, "perl518.dll", 'kernel32.dll', 'LoadLibraryExA');
+ die "failed to create IATPatch Obj $^E" if ! defined $patch;
+ $LoadLibraryExA = Win32::API::More->new( undef, $patch->GetOriginalFunctionPtr(), '
+ HMODULE
+ WINAPI
+ LoadLibraryExA(
+ LPCSTR lpLibFileName,
+ HANDLE hFile,
+ DWORD dwFlags
+ );
+ ');
+ die "failed to make old function object" if ! defined $LoadLibraryExA;
+ require Encode;
+ #console will get a print of the dll filename now
+
+=head1 DESCRIPTION
+
+Win32::API::Callback::IATPatch allows you to hook a compile time dynamic linked
+function call from any DLL (or EXE, from now on all examples are from a DLL to
+another DLL, but from a EXE to a DLL is implied) in the Perl process, to a
+different DLL in the same Perl process, by placing a Win32::API::Callback object
+in between. This module does B<not> hook B<GetProcAddress> function calls. It
+also will not hook a function call from a DLL to another function in the same
+DLL. The function you want to hook B<must> appear in the B<import table> of the
+DLL you want to use the hook. Functions from delay loaded DLL have their own
+import table, it is different import table from the normal one IATPatch supports.
+IATPatch will not find a delay loaded function and will not patch it. The hook
+occurs at the caller DLL, not the callee DLL. This means your callback will be
+called from all the calls to a one function in different DLL from the one
+particular DLL the IATPatch object patched. The caller DLL is modified at
+runtime, in the Perl process where the IATPatch was created, not on disk,
+not globally among all processes. The callee or exporting DLL is NOT modified,
+so your hook callback will be called from the 1 DLL that you choose to hook with
+1 IATPatch object. You can create multiple IATPatch objects, one for each DLL in
+the Perl process that you want to call your callback and not the original
+destination function. If a new DLL is loaded into the process during runtime,
+you must create a new IATPatch object specifically targeting it. There may be a
+period from when the new DLL is loaded into the process, and when your Perl
+script creates IATPatch object, where calls from that new DLL goto the real
+destination function without hooking. If a DLL is unloaded, then reloaded into
+the process, you must call C<Unpatch(0)> method on the old IATPatch object, then
+create a new IATPatch object. IATPatch has no notification feature that a DLL
+is being loaded or unloaded from the process. Unless you completely control, and
+have the source code of the caller DLL, and understand all of the source code of
+that DLL, there is a high chance that you will B<NOT> hook all calls from that
+DLL to the destination function. If a call to the destination function is
+dangerous or unacceptable, do not use IATPatch. IATPatch is not Microsoft
+Detours or the like in any sense. Detours and its brethern will rewrite the
+machine code in the beginning of the destination function call, hooking all
+calls to that function call process wide, without exception.
+
+Why this module was created? So I could mock kernel32 functions to
+unit test Perl's C function calls to Kernel32.
+
+=head2 CONSTRUCTORS
+
+=head3 new
+
+ my $patch = Win32::API::Callback::IATPatch->new(
+ $A_Win32_API_Callback_Obj, $EXE_or_DLL_hmodule_or_name_to_hook,
+ $import_DLL_name, $import_function_name_or_ordinal);
+
+Creates a new IATPatch object. The Win32::API::Callback will be called as long
+as the IATPatch object exists. When an IATPatch object is DESTROYed, unless
+C<-E<gt>Unpatch(0)> is called first, the patch is undone and the original
+function is directly called from then on by that DLL. The DLL is not reference
+count saved by an IATPatch object, so it may be unloaded at any time. If it is
+unloaded you must call C<-E<gt>Unpatch(0)> before a DESTROY. Otherwise the DESTROY
+will croak when it tries to unpatch the DLL. The DLL to hook must be a valid
+PE file, while in memory. DLL and EXE "packers" can create invalid PE
+files that do load successfully into memory, but they are not full PE files in
+memory. On error, undef is returned and an error code is available through
+L<Win32::GetLastError|Win32/Win32::GetLastError()>/L<perlvar/"$^E">. The error code may be from either
+IATPatch directly, or from a Win32 call that IATPatch made. IATPatch objects
+do not go through a L<perlfunc/"fork"> onto the child interp. IATPatch is fork safe.
+
+The hook dll name can be one of 3 things, if the dllname is multiple things
+(a number and a string), the first format found in the following order is used.
+A string C<"123"> (a very strange DLL name BTW), this DLL is converted to DLL
+HMODULE with GetModuleHandle. If there are 2 DLLs with the same filename,
+refer to GetModuleHandle's
+L<MSDN documentation|http://msdn.microsoft.com/en-us/library/windows/desktop/ms683199%28v=vs.85%29.aspx>
+on what happens. Then if the
+DLL name is an integer C<123456>, it is interpreted as a HMODULE directly.
+If DLL name undefined, the file used to create the calling process will be
+patched (a .exe). Finally if the DLL name is defined, a fatal error croak occurs.
+It is best to use an HMODULE, since things like SxS can create multiple DLLs with
+the same name in the same process. How to get an HMODULE, you are on your own.
+
+C<$import_function_name_or_ordinal> can be one of 2 things. First it is checked if
+it is a string, if so, it is used as the function name to hook. Else it is used
+as an integer ordinal to hook. Importing by ordinal is obsolete in Windows, and
+you shouldn't ever have to use it. The author of IATPatch was unable to test if
+ordinal hooking works correctly in IATPatch.
+
+=head2 METHODS
+
+=head3 Unpatch
+
+ die "failed to undo the patch error: $^E" if !
+ $IATPatch->Unpatch(); #undo the patch
+ #or
+ die "failed to undo the patch error: $^E" if !
+ $IATPatch->Unpatch(1); #undo the patch
+ #or
+ die "failed to undo the patch error: $^E" if !
+ $IATPatch->Unpatch(0); #never undo the patch
+ #or
+ die "failed to undo the patch error: $^E" if !
+ $IATPatch->Unpatch(undef); #never undo the patch
+
+Unpatches the DLL with the original destination function from the L<Win32::API::Callback::IATPatch/"new">
+call. Returns undef on failure with error number available through
+L<Win32::GetLastError|Win32/Win32::GetLastError()>/L<perlvar/"$^E">. If Unpatch was called once already,
+calling it again will fail, and error will be ERROR_NO_MORE_ITEMS.
+
+=head3 GetOriginalFunctionPtr
+
+Returns the original function pointer found in the import table in C<123456>
+format. If the returned pointer is 0, L<Win32::API::Callback::IATPatch/"Unpatch">
+was called earlier. There are no error numbers associated with this method.
+This value can be directly used to create a function pointer based Win32::API
+object to call the original destination function from inside your Perl callback.
+See L<Win32::API::Callback::IATPatch/"SYNOPSIS"> for a usage example.
+
+=head1 BUGS AND LIMITATIONS
+
+=over 4
+
+=item E<nbsp>Cygwin not supported
+
+L<new()|Win32::API::Callback::IATPatch/"new"> usually fatally errors on Cygwin
+with "IATPatch 3GB mode not supported" on Cygwins that allocate the heap at
+0x80000000 or are "Large Address Aware"
+
+=back
+
+=head1 SEE ALSO
+
+L<Win32::API::Callback>
+
+L<Win32::API>
+
+L<http://msdn.microsoft.com/en-us/magazine/cc301808.aspx>
+
+=head1 AUTHOR
+
+Daniel Dragan ( I<bulkdd@cpan.org> ).
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2012 by Daniel Dragan
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself, either Perl version 5.10.0 or,
+at your option, any later version of Perl 5 you may have available.
+
+
+=cut
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/API/Struct.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/API/Struct.pm
new file mode 100644
index 0000000000..85d1f7154d
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/API/Struct.pm
@@ -0,0 +1,755 @@
+#
+# Win32::API::Struct - Perl Win32 API struct Facility
+#
+# Author: Aldo Calpini <dada@perl.it>
+# Maintainer: Cosimo Streppone <cosimo@cpan.org>
+#
+
+package Win32::API::Struct;
+use strict;
+use warnings;
+use vars qw( $VERSION );
+$VERSION = '0.67';
+
+my %Known = ();
+
+#import DEBUG sub
+sub DEBUG;
+*DEBUG = *Win32::API::DEBUG;
+
+#package main;
+#
+#sub userlazyapisub2{
+# userlazyapisub();
+#}
+#sub userlazyapisub {
+# Win32::API::Struct::lazyapisub();
+#}
+#
+#sub userapisub {
+# Win32::API::Struct::apisub();
+#}
+#
+#package Win32::API::Struct;
+#
+#sub lazyapisub {
+# lazycarp('bad');
+#}
+#sub apisub {
+# require Carp;
+# Carp::carp('bad');
+#}
+sub lazycarp {
+ require Carp;
+ Carp::carp(@_);
+}
+
+sub lazycroak {
+ require Carp;
+ Carp::croak(@_);
+}
+
+sub typedef {
+ my $class = shift;
+ my $struct = shift;
+ my ($type, $name, @recog_arr);
+ my $self = {
+ align => undef,
+ typedef => [],
+ };
+ while (defined($type = shift)) {
+ #not compatible with "unsigned foo;"
+ $type .= ' '.shift if $type eq 'unsigned' || $type eq 'signed';
+ $name = shift;
+ #"int foo [8];" instead of "int foo[8];" so tack on the array count
+ {
+ BEGIN{warnings->unimport('uninitialized')}
+ $name .= shift if substr($_[0],0,1) eq '[';
+ }
+ #typedef() takes a list, not a str, for backcompat, this can't be changed
+ #but, should typedef() keep shifting slices until it finds ";" or not?
+ #all the POD examples have ;s, but they are actually optional, should it
+ #be assumed that existing code was nice and used ;s or not? backcompat
+ #breaks if you say ;-less member defs should be allowed and aren't a user
+ #mistake
+ $name =~ s/;$//;
+ @recog_arr = recognize($type, $name);
+#http://perlmonks.org/?node_id=978468, not catching the type not found here,
+#will lead to a div 0 later
+ if(@recog_arr != 3){
+ lazycarp "Win32::API::Struct::typedef: unknown member type=\"$type\", name=\"$name\"";
+ return undef;
+ }
+ push(@{$self->{typedef}}, [@recog_arr]);
+ }
+
+ $Known{$struct} = $self;
+ $Win32::API::Type::Known{$struct} = '>';
+ return 1;
+}
+
+
+#void ck_type($param, $proto, $param_num)
+sub ck_type {
+ my ($param, $proto) = @_;
+ #legacy LP prefix check
+ return if substr($proto, 0, 2) eq 'LP' && substr($proto, 2) eq $param;
+ #check if proto can be converted to base struct name
+ return if exists $Win32::API::Struct::Pointer{$proto} &&
+ $param eq $Win32::API::Struct::Pointer{$proto};
+ #check if proto can have * chopped off to convert to base struct name
+ $proto =~ s/\s*\*$//;
+ return if $proto eq $param;
+ lazycroak("Win32::API::Call: supplied type (LP)\"".
+ $param."\"( *) doesn't match type \"".
+ $_[1]."\" for parameter ".
+ $_[2]." ");
+}
+
+#$basename = to_base_struct($pointername)
+sub to_base_struct {
+ return $Win32::API::Struct::Pointer{$_[0]}
+ if exists $Win32::API::Struct::Pointer{$_[0]};
+ die "Win32::API::Struct::Unpack unknown type";
+}
+
+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" if DEBUGCONST;
+ return ($name, $packing, $type);
+ }
+}
+
+sub new {
+ my $class = shift;
+ my ($type, $name, $packing);
+ my $self = {typedef => [],};
+ if ($#_ == 0) {
+ if (is_known($_[0])) {
+ DEBUG "(PM)Struct::new: got '$_[0]'\n" if DEBUGCONST;
+ if( ! defined ($self->{typedef} = $Known{$_[0]}->{typedef})){
+ lazycarp 'Win32::API::Struct::new: unknown type="'.$_[0].'"';
+ return undef;
+ }
+ foreach my $member (@{$self->{typedef}}) {
+ ($name, $packing, $type) = @$member;
+ next unless defined $name;
+ if ($packing eq '>') {
+ $self->{$name} = Win32::API::Struct->new($type);
+ }
+ }
+ $self->{__typedef__} = $_[0];
+ }
+ else {
+ lazycarp "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}) {
+ lazycarp "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 = '';
+
+ for my $member (@{$self->{typedef}}) {
+ my ($name, $packing, $type) = @{$member};
+ next unless defined $name;
+ if (ref $self->{$name} eq q{Win32::API::Struct}) {
+
+ # If member is a struct, recursively calculate its size
+ # FIXME for subclasses
+ $size += $self->{$name}->sizeof();
+ }
+ else {
+
+ # Member is a simple type (LONG, DWORD, etc...)
+ if ($packing =~ /\w\*(\d+)/) { # Arrays (ex: 'c*260')
+ $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" if DEBUGCONST;
+ }
+ else { # Simple types
+ my $type_size = Win32::API::Type::sizeof($type);
+ $align = $type_size if $type_size > $align;
+ my $type_align = (($size + $type_size) % $type_size);
+ $size += $type_size + $type_align;
+ $first = Win32::API::Type::sizeof($type) unless defined $first;
+ }
+ }
+ }
+
+ my $struct_size = $size;
+ if (defined $align && $align > 0) {
+ $struct_size += ($size % $align);
+ }
+ DEBUG "(PM)Struct::sizeof first=$first totalsize=$struct_size\n" if DEBUGCONST;
+ return $struct_size;
+}
+
+sub align {
+ my $self = shift;
+ my $align = shift;
+
+ if (not defined $align) {
+
+ if (!(defined $self->{align} && $self->{align} eq 'auto')) {
+ return $self->{align};
+ }
+
+ $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 $packed_size = 0;
+ my ($type, $name, $type_size, $type_align);
+ my @items = ();
+ my @recipients = ();
+ my @buffer_ptrs = (); #this contains the struct_ptrs that were placed in the
+ #the struct, its part of "C func changes the struct ptr to a private allocated
+ #struct" code, it is push/poped only for struct ptrs, it is NOT a 1 to
+ #1 mapping between all struct members, so don't access it with indexes
+
+ my $align = $self->align();
+
+ foreach my $member (@{$self->{typedef}}) {
+ my ($name, $type, $orig) = @$member;
+ if ($type eq '>') {
+ my ($subpacking, $subitems, $subrecipients, $subpacksize, $subbuffersptrs) =
+ $self->{$name}->getPack();
+ DEBUG "(PM)Struct::getPack($self->{__typedef__}) ++ $subpacking\n" if DEBUGCONST;
+ push(@items, @$subitems);
+ push(@recipients, @$subrecipients);
+ push(@buffer_ptrs, @$subbuffersptrs);
+ $packing .= $subpacking;
+ $packed_size += $subpacksize;
+ }
+ else {
+ my $repeat = 1;
+ $type_size = Win32::API::Type::sizeof($orig);
+ if ($type =~ /\w\*(\d+)/) {
+ $repeat = $1;
+ $type = 'a'.($repeat*$type_size);
+ }
+
+ DEBUG "(PM)Struct::getPack($self->{__typedef__}) ++ $type\n" if DEBUGCONST;
+
+ if ($type eq 'p') {
+ $type = Win32::API::Type::pointer_pack_type();
+ push(@items, Win32::API::PointerTo($self->{$name}));
+ }
+ elsif ($type eq 'T') {
+ $type = Win32::API::Type::pointer_pack_type();
+ my $structptr;
+ if(ref($self->{$name})){
+ $self->{$name}->Pack();
+ $structptr = Win32::API::PointerTo($self->{$name}->{buffer});
+ }
+ else{
+ $structptr = 0;
+ }
+ push(@items, $structptr);
+ push(@buffer_ptrs, $structptr);
+ }
+ else {
+ push(@items, $self->{$name});
+ }
+ push(@recipients, $self);
+ $type_align = (($packed_size + $type_size) % $type_size);
+ $packing .= "x" x $type_align . $type;
+ $packed_size += ( $type_size * $repeat ) + $type_align;
+ }
+ }
+
+ DEBUG
+ "(PM)Struct::getPack: $self->{__typedef__}(buffer) = pack($packing, $packed_size)\n" if DEBUGCONST;
+
+ return ($packing, [@items], [@recipients], $packed_size, \@buffer_ptrs);
+}
+
+# void $struct->Pack([$priv_warnings_flag]);
+sub Pack {
+ my $self = shift;
+ my ($packing, $items);
+ ($packing, $items, $self->{buffer_recipients},
+ undef, $self->{buffer_ptrs}) = $self->getPack();
+
+ DEBUG "(PM)Struct::Pack: $self->{__typedef__}(buffer) = pack($packing, @$items)\n" if DEBUGCONST;
+
+ if($_[0]){ #Pack() on a new struct, without slice set, will cause lots of uninit
+ #warnings, sometimes its intentional to set up buffer recipients for a
+ #future UnPack()
+ BEGIN{warnings->unimport('uninitialized')}
+ $self->{buffer} = pack($packing, @$items);
+ }
+ else{
+ $self->{buffer} = pack($packing, @$items);
+ }
+ if (DEBUGCONST) {
+ for my $i (0 .. $self->sizeof - 1) {
+ printf "#pack# %3d: 0x%02x\n", $i, ord(substr($self->{buffer}, $i, 1));
+ }
+ }
+}
+
+sub getUnpack {
+ my $self = shift;
+ my $packing = "";
+ my $packed_size = 0;
+ my ($type, $name, $type_size, $type_align, $orig_type);
+ my (@items, @types, @type_names);
+ my $align = $self->align();
+ foreach my $member (@{$self->{typedef}}) {
+ my ($name, $type, $orig) = @$member;
+ if ($type eq '>') {
+ my ($subpacking, $subpacksize, $subitems, $subtypes, $subtype_names) = $self->{$name}->getUnpack();
+ DEBUG "(PM)Struct::getUnpack($self->{__typedef__}) ++ $subpacking\n" if DEBUGCONST;
+ $packing .= $subpacking;
+ $packed_size += $subpacksize;
+ push(@items, @$subitems);
+ push(@types, @$subtypes);
+ push(@type_names, @$subtype_names);
+ }
+ else {
+ if($type eq 'T') {
+ $orig_type = $type;
+ $type = Win32::API::Type::pointer_pack_type();
+ }
+ $type_size = Win32::API::Type::sizeof($orig);
+ my $repeat = 1;
+ if ($type =~ /\w\*(\d+)/) { #some kind of array
+ $repeat = $1;
+ $type =
+ $type_size == 1 ?
+ 'Z'.$repeat #have pack truncate to NULL char
+ :'a'.($repeat*$type_size); #manually truncate to wide NULL char later
+ }
+ DEBUG "(PM)Struct::getUnpack($self->{__typedef__}) ++ $type\n" if DEBUGCONST;
+ $type_align = (($packed_size + $type_size) % $type_size);
+ $packing .= "x" x $type_align . $type;
+ $packed_size += ( $type_size * $repeat ) + $type_align;
+ push(@items, $name);
+ if($orig_type){
+ push(@types, $orig_type);
+ undef($orig_type);
+ }
+ else{
+ push(@types, $type);
+ }
+ push(@type_names, $orig);
+ }
+ }
+ DEBUG "(PM)Struct::getUnpack($self->{__typedef__}): unpack($packing, @items)\n" if DEBUGCONST;
+ return ($packing, $packed_size, \@items, \@types, \@type_names);
+}
+
+sub Unpack {
+ my $self = shift;
+ my ($packing, undef, $items, $types, $type_names) = $self->getUnpack();
+ my @itemvalue = unpack($packing, $self->{buffer});
+ DEBUG "(PM)Struct::Unpack: unpack($packing, buffer) = @itemvalue\n" if DEBUGCONST;
+ foreach my $i (0 .. $#$items) {
+ my $recipient = $self->{buffer_recipients}->[$i];
+ my $item = $$items[$i];
+ my $type = $$types[$i];
+ DEBUG "(PM)Struct::Unpack: %s(%s) = '%s' (0x%08x)\n",
+ $recipient->{__typedef__},
+ $item,
+ $itemvalue[$i],
+ $itemvalue[$i],
+ if DEBUGCONST;
+ if($type eq 'T'){
+my $oldstructptr = pop(@{$self->{buffer_ptrs}});
+my $newstructptr = $itemvalue[$i];
+my $SVMemberRef = \$recipient->{$item};
+
+if(!$newstructptr){ #new ptr is null
+ if($oldstructptr != $newstructptr){ #old ptr was true
+ lazycarp "Win32::API::Struct::Unpack struct pointer".
+ " member \"".$item."\" was changed by C function,".
+ " possible resource leak";
+ }
+ $$SVMemberRef = undef;
+}
+else{ #new ptr is true
+ if($oldstructptr != $newstructptr){#old ptr was true, or null, but has changed, leak warning
+ lazycarp "Win32::API::Struct::Unpack struct pointer".
+ " member \"".$item."\" was changed by C function,".
+ " possible resource leak";
+ }#create a ::Struct if the slice is undef, user had the slice set to undef
+
+ if (!ref($$SVMemberRef)){
+ $$SVMemberRef = Win32::API::Struct->new(to_base_struct($type_names->[$i]));
+ $$SVMemberRef->Pack(1); #buffer_recipients must be generated, no uninit warnings
+ }
+#must fix {buffer} with contents of the new struct, $structptr might be
+#null or might be a SVPV from a ::Struct that was ignored, in any case,
+#a foreign memory allocator is at work here
+ $$SVMemberRef->{buffer} = Win32::API::ReadMemory($newstructptr, $$SVMemberRef->sizeof)
+ if($oldstructptr != $newstructptr);
+#always must be called, if new ptr is not null, at this point, C func, did
+#one of 2 things, filled the old ::Struct's {buffer} PV, or gave a new struct *
+#from its own allocator, there is no way to tell if the struct contents changed
+#so Unpack() must be called
+ $$SVMemberRef->Unpack();
+}
+}
+ else{ #not a struct ptr
+ my $itemvalueref = \$itemvalue[$i];
+ Win32::API::_TruncateToWideNull($$itemvalueref)
+ if substr($type,0,1) eq 'a' && length($type) > 1;
+ $recipient->{$item} = $$itemvalueref;
+
+ # DEBUG "(PM)Struct::Unpack: self.items[$i] = $self->{$$items[$i]}\n";
+ }
+ }
+}
+
+sub FromMemory {
+ my ($self, $addr) = @_;
+ DEBUG "(PM)Struct::FromMemory: doing Pack\n" if DEBUGCONST;
+ $self->Pack();
+ DEBUG "(PM)Struct::FromMemory: doing GetMemory( 0x%08x, %d )\n", $addr, $self->sizeof if DEBUGCONST;
+ $self->{buffer} = Win32::API::ReadMemory($addr, $self->sizeof);
+ $self->Unpack();
+ if(DEBUGCONST) {
+ DEBUG "(PM)Struct::FromMemory: doing Unpack\n";
+ DEBUG "(PM)Struct::FromMemory: structure is now:\n";
+ $self->Dump();
+ DEBUG "\n";
+ }
+}
+
+sub Dump {
+ my $self = shift;
+ my $prefix = shift;
+ foreach my $member (@{$self->{typedef}}) {
+ my ($name, $packing, $type) = @$member;
+ if (ref($self->{$name})) {
+ $self->{$name}->Dump($name);
+ }
+ else {
+ printf "%-20s %-20s %-20s\n", $prefix, $name, $self->{$name};
+ }
+ }
+}
+
+#the LP logic should be moved to parse_prototype, since only
+#::API::Call() ever understood the implied LP prefix, Struct::new never did
+#is_known then can be inlined away and sub deleted, it is not public API
+sub is_known {
+ my $name = shift;
+ if (exists $Known{$name}) {
+ return 1;
+ }
+ else {
+ my $nametest = $name;
+ if ($nametest =~ s/^LP//) {
+ return exists $Known{$nametest};
+ }
+ $nametest = $name;
+ if($nametest =~ s/\*$//){
+ return exists $Known{$nametest};
+ }
+ 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;
+
+__END__
+
+#######################################################################
+# 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/USING STRUCTURES> 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. Win32::API::Struct does B<NOT> support Enums, Unions, or Bitfields.
+C<NAME> must not end in C<*>, typedef creates structs, not struct pointers.
+See L<Win32::API::Type/"typedef">
+on how to create a struct pointer type. Returns true on success, and undef on error.
+On error it L<warns|perlfunc/warn> with the specific reason.
+
+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;
+ };
+
+L<Win32::API/Call> automatically knows that an 'LPNAME' type, refers
+to a 'NAME' type struct. Also see L<Win32::API::Type/"typedef"> on how to declare
+pointers to struct types.
+
+Unlike in Win32::API, a single non-array char or CHAR struct member in a
+struct is numeric, NOT the first character of a string. UTF16 strings pointers
+will be garbage on read back (passing in works, returning doesn't) since
+the NULL character will often be the 2nd byte of the UTF16 string.
+
+=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
+
+=head2 FOREIGN MEMORY ALLOCATORS
+
+Using Win32::API::Struct is not recommended in situations where a C function
+will return results to you by putting a pointer to a string or a pointer to
+another struct into your supplied struct. Win32::API::Struct will do its best
+to detect that a new pointer appeared and to read it contents into Perl, but
+that pointer will be tossed away after being read. If this pointer is
+something you must explicitly free, you have leaked it by using
+Win32::API::Struct to decode it. If this pointer is something you must pass back to
+the C API you are using, you lost/leaked it. If you pass NULL, or a ::Struct
+pointer in a ::Struct to C API, after the C API call, ::Struct will detect the
+pointer changed, it will read the new struct from the new pointer into
+Perl, and a new child ::Struct will appear in the hash slice
+of the parent ::Struct, if you pass this new child ::Struct into the C API
+it will be a B<COPY> of the struct the C API from Perl's allocation placed
+in the parent ::Struct. For C++-like APIs, this will be unacceptable and lead to
+crashes as the C Functions tries to free a memory block that didn't come from the
+allocator of the C Function. Windows has many memory allocators, each CRT
+(VS 2, 3, 4, 5, NT/6, 7.0, 7.1, 8, 9, 10) malloc, LocalAlloc, GlobalAlloc,
+HeapAlloc, (each version of C++ Runtime Library) "new", CoGetMalloc, CoTaskMemAlloc,
+NetApiBufferAllocate, VirtualAlloc, CryptMemAlloc, AllocADsMem, SHAlloc,
+SnmpUtilMemAlloc. None of these allocators' pointers are compatible with Perl's
+allocator. Some C APIs give you static global buffers which never are freed or freed
+automatically in the next call to a function from to that DLL.
+
+With foreign allocators, its best to treat to write a pointer class, bless the
+ref to scalar integer (holding the pointer) into that class to ensure that the
+DESTROY method will free the pointer and you never leak it, and your write
+method accessors using L<perlfunc/pack>, L<Win32::API/ReadMemory> and
+L<Win32::API/WriteMemory> around the pointer.
+
+
+=head1 AUTHOR
+
+Aldo Calpini ( I<dada@perl.it> ).
+
+=head1 MAINTAINER
+
+Cosimo Streppone ( I<cosimo@cpan.org> ).
+
+=cut
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/API/Type.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/API/Type.pm
new file mode 100644
index 0000000000..3c4c4d5fea
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/API/Type.pm
@@ -0,0 +1,590 @@
+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>
+#
+#######################################################################
+
+use strict;
+use warnings;
+use vars qw( %Known %PackSize %Modifier %Pointer $VERSION );
+
+$VERSION = '0.70';
+
+#import DEBUG sub
+sub DEBUG;
+*DEBUG = *Win32::API::DEBUG;
+
+#const optimize
+BEGIN {
+ eval ' sub pointer_pack_type () { \''
+ .(PTRSIZE == 8 ? 'Q' : 'L').
+ '\' }';
+}
+
+%Known = ();
+%PackSize = ();
+%Modifier = ();
+%Pointer = ();
+
+# Initialize data structures at startup.
+# Aldo wants to keep the <DATA> approach.
+#
+my $section = 'nothing';
+foreach (<DATA>) {
+ next if /^\s*(?:#|$)/;
+ chomp;
+ if (/\[(.+)\]/) {
+ $section = $1;
+ next;
+ }
+ if ($section eq 'TYPE') {
+ my ($name, $packing) = split(/\s+/);
+
+ # DEBUG "(PM)Type::INIT: Known('$name') => '$packing'\n";
+ $packing = pointer_pack_type()
+ if ($packing eq '_P');
+ $Known{$name} = $packing;
+ }
+ elsif ($section eq 'POINTER') {
+ my ($pointer, $pointto) = split(/\s+/);
+
+ # DEBUG "(PM)Type::INIT: Pointer('$pointer') => '$pointto'\n";
+ $Pointer{$pointer} = $pointto;
+ }
+ elsif ($section eq 'PACKSIZE') {
+ my ($packing, $size) = split(/\s+/);
+
+ # DEBUG "(PM)Type::INIT: PackSize('$packing') => '$size'\n";
+ $size = PTRSIZE
+ if ($size eq '_P');
+ $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};
+ }
+}
+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) = @_;
+ $type =~ m/^\s*(.*?)\s*$/;
+ $type =~ m/^(.+?)\s*(\*)$/;
+ $type = $1;
+ $type .= $2 if defined $2;
+ $name =~ m/^\s*(.*?)\s*$/;
+ $name =~ m/^(.+?)\s*(\*)$/;
+ $name = $1;
+ $name .= $2 if defined $2;
+ #FIXME BUG, unsigned __int64 * doesn't pase in typedef, it does in parse_prototype
+ my $packing = packing($type, $name); #FIXME BUG
+ if(! defined $packing){
+ warn "Win32::API::Type::typedef: WARNING unknown type '$_[1]'";
+ return undef;
+ }
+ #Win32::API::Struct logic
+ #limitation, this won't alias a new struct type to an existing struct type
+ #this only creates new struct type pointer types to an existing struct type
+ if($packing eq '>'){
+ if(is_pointer($type)){
+ $packing = 'T';
+ $type =~ s/\s*\*$//; #chop off ' *'
+ $Win32::API::Struct::Pointer{$name} = $type;
+ }
+ else{
+ warn "Win32::API::Type::typedef: aliasing struct \"".$_[0]
+ ."\" to struct \"".$_[1]."\" not supported";
+ return undef;
+ }
+ }
+ DEBUG "(PM)Type::typedef: packing='$packing'\n" if DEBUGCONST;
+ if($packing eq 'p'){
+ $Pointer{$name} = $Pointer{$type};
+ }else{
+ $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};
+ }
+ }
+}
+# $packing_letter = packing( [$class = 'Win32::API::Type' ,] $type [, $pass_numeric])
+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;
+ my $pass_numeric = 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/\s*\*$//; #kill whitespace "CHAR " isn't "CHAR"
+
+ 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' or $packing eq 'S')) {
+ $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};
+ if(!$pass_numeric) { #for older num unaware calls
+ substr($packing, 0, length("num"), '');
+ }
+ }
+ 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 = $_[1];
+
+ my $pack_type = packing($type);
+ #print "Pack: type $type pack_type $pack_type\n";
+ if ($pack_type eq 'p') { #char or wide char pointer
+ #$pack_type = 'Z*';
+ return;
+ }
+ elsif(IVSIZE() == 4 && ($pack_type eq 'q' || $pack_type eq 'Q')){
+ if($_[0]->UseMI64() || ref($_[2])){ #un/signed meaningless
+ $_[2] = Math::Int64::int64_to_native($_[2]);
+ }
+ else{
+ if(length($_[2]) < 8){
+ warn("Win32::API::Call value for 64 bit integer is under 8 bytes long");
+ $_[2] = pack('a8', $_[2]);
+ }
+ }
+ return;
+ }
+ $_[2] = pack($pack_type, $_[2]);
+ return;
+}
+
+sub Unpack {
+ my $type = $_[1];
+
+ my $pack_type = packing($type);
+
+ if ($pack_type eq 'p') {
+ DEBUG "(PM)Type::Unpack: got packing 'p': is a pointer\n" if DEBUGCONST;
+ #$pack_type = 'Z*';
+ return;
+ }
+ elsif(IVSIZE() == 4){
+ #todo debugging output
+ if($pack_type eq 'q'){
+ if($_[0]->UseMI64() || ref($_[2])){
+ $_[2] = Math::Int64::native_to_int64($_[2]);
+ DEBUG "(PM)Type::Unpack: returning signed Math::Int64 '".$_[2]."'\n" if DEBUGCONST;
+ }
+ return;
+ }elsif($pack_type eq 'Q'){
+ if($_[0]->UseMI64() || ref($_[2])){
+ $_[2] = Math::Int64::native_to_uint64($_[2]);
+ DEBUG "(PM)Type::Unpack: returning unsigned Math::Int64 '".$_[2]."'\n" if DEBUGCONST;
+ }
+ return;
+ }
+ }
+ DEBUG "(PM)Type::Unpack: unpacking '$pack_type' '$_[2]'\n" if DEBUGCONST;
+ $_[2] = unpack($pack_type, $_[2]);
+ DEBUG "(PM)Type::Unpack: returning '" . ($_[2] || '') . "'\n" if DEBUGCONST;
+}
+
+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.
+
+When C<TYPE> contains a Win32::API::Struct type declared with
+L<Win32::API::Struct/typedef> with " *" postfixed to C<TYPE> parameter,
+C<NAME> will be a alias for the pointer version of the struct type. Creating
+an alias for a struct type is not supported, you have to call
+L<Win32::API::Struct/typedef> again. Passing a struct type as C<TYPE>
+without the " *" postfix is not supported.
+
+L<Warns|perlfunc/warn> and returns undef if C<TYPE> is unknown, else returns true.
+
+=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 recognizes many commonly used types defined in the Win32 Platform
+SDK header files, but not all. Types less than 13 years old are very unlikely
+to be the in built type database.
+
+Please see the source for this module, in the C<__DATA__> section,
+for the full list of builtin supported types.
+
+
+=head2 NOTES ON SELECT TYPES
+
+=over 4
+
+=item LPVOID
+
+Due to poor design, currently LPVOID is a char *, a string, not a number.
+It should really be a number. It is suggested to replace LPVOID in your
+C prototypes passed to Win32::API with UINT_PTR which is a pointer
+sized number.
+
+=item SOMETYPE **
+
+Currently ** types do not parse.
+
+=item void **
+
+Replace void ** in your C prototype that you pass to Win32::API::More with
+LPHANDLE.
+
+=item unsigned char
+
+=item signed char
+
+These 2 types by name force numeric handling. C<97> not C<"a">. C<UCHAR> is
+not a C<unsigned char> for numeric handling purposes.
+
+=back
+
+=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
+DWORD_PTR _P
+FLOAT f
+HACCEL _P
+HANDLE _P
+HBITMAP _P
+HBRUSH _P
+HCOLORSPACE _P
+HCONV _P
+HCONVLIST _P
+HCURSOR _P
+HDC _P
+HDDEDATA _P
+HDESK _P
+HDROP _P
+HDWP _P
+HENHMETAFILE _P
+HFILE _P
+HFONT _P
+HGDIOBJ _P
+HGLOBAL _P
+HHOOK _P
+HICON _P
+HIMC _P
+HINSTANCE _P
+HKEY _P
+HKL _P
+HLOCAL _P
+HMENU _P
+HMETAFILE _P
+HMODULE _P
+HPALETTE _P
+HPEN _P
+HRGN _P
+HRSRC _P
+HSZ _P
+HWINSTA _P
+HWND _P
+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 _P
+LRESULT _P
+NTSTATUS l
+REGSAM L
+SC_HANDLE _P
+SC_LOCK _P
+SERVICE_STATUS_HANDLE _P
+SHORT s
+SIZE_T _P
+SSIZE_T _P
+TBYTE c
+TCHAR C
+UCHAR C
+UINT I
+UINT_PTR _P
+UINT32 I
+UINT64 Q
+ULONG L
+ULONG32 L
+ULONG64 Q
+ULONGLONG Q
+USHORT S
+WCHAR S
+WORD S
+WPARAM _P
+VOID c
+
+int i
+long l
+float f
+double d
+char c
+short s
+void c
+__int64 q
+
+#VOID is a 'c'? huh?
+#making void be a 'c' too, ~bulk88
+#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 _P
+T _P
+t _P
+
+[MODIFIER]
+unsigned int=numI long=numL short=numS char=numC
+signed int=numi long=numl short=nums char=numc
+
+[POINTER]
+INT_PTR INT
+LPBOOL BOOL
+LPBYTE BYTE
+LPCOLORREF COLORREF
+LPCSTR CHAR
+#LPCTSTR CHAR or WCHAR
+LPCTSTR CHAR
+LPCVOID any
+LPCWSTR WCHAR
+LPDOUBLE double
+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
+char* CHAR
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/Console.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/Console.pm
new file mode 100644
index 0000000000..2e41c2a83d
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/Console.pm
@@ -0,0 +1,1463 @@
+#######################################################################
+#
+# Win32::Console - Win32 Console and Character Mode Functions
+#
+#######################################################################
+
+package Win32::Console;
+
+require Exporter;
+require DynaLoader;
+
+$VERSION = "0.10";
+
+@ISA= qw( Exporter DynaLoader );
+@EXPORT = qw(
+ BACKGROUND_BLUE
+ BACKGROUND_GREEN
+ BACKGROUND_INTENSITY
+ BACKGROUND_RED
+ CAPSLOCK_ON
+ CONSOLE_TEXTMODE_BUFFER
+ CTRL_BREAK_EVENT
+ CTRL_C_EVENT
+ ENABLE_ECHO_INPUT
+ ENABLE_LINE_INPUT
+ ENABLE_MOUSE_INPUT
+ ENABLE_PROCESSED_INPUT
+ ENABLE_PROCESSED_OUTPUT
+ ENABLE_WINDOW_INPUT
+ ENABLE_WRAP_AT_EOL_OUTPUT
+ ENHANCED_KEY
+ FILE_SHARE_READ
+ FILE_SHARE_WRITE
+ FOREGROUND_BLUE
+ FOREGROUND_GREEN
+ FOREGROUND_INTENSITY
+ FOREGROUND_RED
+ LEFT_ALT_PRESSED
+ LEFT_CTRL_PRESSED
+ NUMLOCK_ON
+ GENERIC_READ
+ GENERIC_WRITE
+ RIGHT_ALT_PRESSED
+ RIGHT_CTRL_PRESSED
+ SCROLLLOCK_ON
+ SHIFT_PRESSED
+ STD_INPUT_HANDLE
+ STD_OUTPUT_HANDLE
+ STD_ERROR_HANDLE
+ $FG_BLACK
+ $FG_GRAY
+ $FG_BLUE
+ $FG_LIGHTBLUE
+ $FG_RED
+ $FG_LIGHTRED
+ $FG_GREEN
+ $FG_LIGHTGREEN
+ $FG_MAGENTA
+ $FG_LIGHTMAGENTA
+ $FG_CYAN
+ $FG_LIGHTCYAN
+ $FG_BROWN
+ $FG_YELLOW
+ $FG_LIGHTGRAY
+ $FG_WHITE
+ $BG_BLACK
+ $BG_GRAY
+ $BG_BLUE
+ $BG_LIGHTBLUE
+ $BG_RED
+ $BG_LIGHTRED
+ $BG_GREEN
+ $BG_LIGHTGREEN
+ $BG_MAGENTA
+ $BG_LIGHTMAGENTA
+ $BG_CYAN
+ $BG_LIGHTCYAN
+ $BG_BROWN
+ $BG_YELLOW
+ $BG_LIGHTGRAY
+ $BG_WHITE
+ $ATTR_NORMAL
+ $ATTR_INVERSE
+ @CONSOLE_COLORS
+);
+
+
+#######################################################################
+# 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] : 0);
+ if ($! != 0) {
+# if ($! =~ /Invalid/) {
+# $AutoLoader::AUTOLOAD = $AUTOLOAD;
+# goto &AutoLoader::AUTOLOAD;
+# } else {
+ ($pack, $file, $line) = caller; undef $pack;
+ die "Symbol Win32::Console::$constname not defined, used at $file line $line.";
+# }
+ }
+ eval "sub $AUTOLOAD { $val }";
+ goto &$AUTOLOAD;
+}
+
+
+#######################################################################
+# STATIC OBJECT PROPERTIES
+#
+
+# %HandlerRoutineStack = ();
+# $HandlerRoutineRegistered = 0;
+
+#######################################################################
+# PUBLIC METHODS
+#
+
+#========
+sub new {
+#========
+ my($class, $param1, $param2) = @_;
+
+ my $self = {};
+
+ if (defined($param1)
+ and ($param1 == constant("STD_INPUT_HANDLE", 0)
+ or $param1 == constant("STD_OUTPUT_HANDLE", 0)
+ or $param1 == constant("STD_ERROR_HANDLE", 0)))
+ {
+ $self->{'handle'} = _GetStdHandle($param1);
+ }
+ else {
+ $param1 = constant("GENERIC_READ", 0) | constant("GENERIC_WRITE", 0) unless $param1;
+ $param2 = constant("FILE_SHARE_READ", 0) | constant("FILE_SHARE_WRITE", 0) unless $param2;
+ $self->{'handle'} = _CreateConsoleScreenBuffer($param1, $param2,
+ constant("CONSOLE_TEXTMODE_BUFFER", 0));
+ }
+ bless $self, $class;
+ return $self;
+}
+
+#============
+sub Display {
+#============
+ my($self) = @_;
+ return undef unless ref($self);
+ return _SetConsoleActiveScreenBuffer($self->{'handle'});
+}
+
+#===========
+sub Select {
+#===========
+ my($self, $type) = @_;
+ return undef unless ref($self);
+ return _SetStdHandle($type, $self->{'handle'});
+}
+
+#===========
+sub SetIcon {
+#===========
+ my($self, $icon) = @_;
+ $icon = $self unless ref($self);
+ return _SetConsoleIcon($icon);
+}
+
+#==========
+sub Title {
+#==========
+ my($self, $title) = @_;
+ $title = $self unless ref($self);
+
+ if (defined($title)) {
+ return _SetConsoleTitle($title);
+ }
+ else {
+ return _GetConsoleTitle();
+ }
+}
+
+#==============
+sub WriteChar {
+#==============
+ my($self, $text, $col, $row) = @_;
+ return undef unless ref($self);
+ return _WriteConsoleOutputCharacter($self->{'handle'},$text,$col,$row);
+}
+
+#=============
+sub ReadChar {
+#=============
+ my($self, $size, $col, $row) = @_;
+ return undef unless ref($self);
+
+ my $buffer = (" " x $size);
+ if (_ReadConsoleOutputCharacter($self->{'handle'}, $buffer, $size, $col, $row)) {
+ return $buffer;
+ }
+ else {
+ return undef;
+ }
+}
+
+#==============
+sub WriteAttr {
+#==============
+ my($self, $attr, $col, $row) = @_;
+ return undef unless ref($self);
+ return _WriteConsoleOutputAttribute($self->{'handle'}, $attr, $col, $row);
+}
+
+#=============
+sub ReadAttr {
+#=============
+ my($self, $size, $col, $row) = @_;
+ return undef unless ref($self);
+ return _ReadConsoleOutputAttribute($self->{'handle'}, $size, $col, $row);
+}
+
+#==========
+sub Write {
+#==========
+ my($self,$string) = @_;
+ return undef unless ref($self);
+ return _WriteConsole($self->{'handle'}, $string);
+}
+
+#=============
+sub ReadRect {
+#=============
+ my($self, $left, $top, $right, $bottom) = @_;
+ return undef unless ref($self);
+
+ my $col = $right - $left + 1;
+ my $row = $bottom - $top + 1;
+
+ my $buffer = (" " x ($col*$row*4));
+ if (_ReadConsoleOutput($self->{'handle'}, $buffer,
+ $col, $row, 0, 0,
+ $left, $top, $right, $bottom))
+ {
+ return $buffer;
+ }
+ else {
+ return undef;
+ }
+}
+
+#==============
+sub WriteRect {
+#==============
+ my($self, $buffer, $left, $top, $right, $bottom) = @_;
+ return undef unless ref($self);
+
+ my $col = $right - $left + 1;
+ my $row = $bottom - $top + 1;
+
+ return _WriteConsoleOutput($self->{'handle'}, $buffer,
+ $col, $row, 0, 0,
+ $left, $top, $right, $bottom);
+}
+
+#===========
+sub Scroll {
+#===========
+ my($self, $left1, $top1, $right1, $bottom1,
+ $col, $row, $char, $attr,
+ $left2, $top2, $right2, $bottom2) = @_;
+ return undef unless ref($self);
+
+ return _ScrollConsoleScreenBuffer($self->{'handle'},
+ $left1, $top1, $right1, $bottom1,
+ $col, $row, $char, $attr,
+ $left2, $top2, $right2, $bottom2);
+}
+
+#==============
+sub MaxWindow {
+#==============
+ my($self, $flag) = @_;
+ return undef unless ref($self);
+
+ if (not defined($flag)) {
+ my @info = _GetConsoleScreenBufferInfo($self->{'handle'});
+ return $info[9], $info[10];
+ }
+ else {
+ return _GetLargestConsoleWindowSize($self->{'handle'});
+ }
+}
+
+#=========
+sub Info {
+#=========
+ my($self) = @_;
+ return undef unless ref($self);
+ return _GetConsoleScreenBufferInfo($self->{'handle'});
+}
+
+#===========
+sub Window {
+#===========
+ my($self, $flag, $left, $top, $right, $bottom) = @_;
+ return undef unless ref($self);
+
+ if (not defined($flag)) {
+ my @info = _GetConsoleScreenBufferInfo($self->{'handle'});
+ return $info[5], $info[6], $info[7], $info[8];
+ }
+ else {
+ return _SetConsoleWindowInfo($self->{'handle'}, $flag, $left, $top, $right, $bottom);
+ }
+}
+
+#==============
+sub GetEvents {
+#==============
+ my($self) = @_;
+ return undef unless ref($self);
+ return _GetNumberOfConsoleInputEvents($self->{'handle'});
+}
+
+#==========
+sub Flush {
+#==========
+ my($self) = @_;
+ return undef unless ref($self);
+ return _FlushConsoleInputBuffer($self->{'handle'});
+}
+
+#==============
+sub InputChar {
+#==============
+ my($self, $number) = @_;
+ return undef unless ref($self);
+
+ $number = 1 unless defined($number);
+
+ my $buffer = (" " x $number);
+ if (_ReadConsole($self->{'handle'}, $buffer, $number) == $number) {
+ return $buffer;
+ }
+ else {
+ return undef;
+ }
+}
+
+#==========
+sub Input {
+#==========
+ my($self) = @_;
+ return undef unless ref($self);
+ return _ReadConsoleInput($self->{'handle'});
+}
+
+#==============
+sub PeekInput {
+#==============
+ my($self) = @_;
+ return undef unless ref($self);
+ return _PeekConsoleInput($self->{'handle'});
+}
+
+#===============
+sub WriteInput {
+#===============
+ my($self) = shift;
+ return undef unless ref($self);
+ return _WriteConsoleInput($self->{'handle'}, @_);
+}
+
+#=========
+sub Mode {
+#=========
+ my($self, $mode) = @_;
+ return undef unless ref($self);
+ if (defined($mode)) {
+ return _SetConsoleMode($self->{'handle'}, $mode);
+ }
+ else {
+ return _GetConsoleMode($self->{'handle'});
+ }
+}
+
+#========
+sub Cls {
+#========
+ my($self, $attr) = @_;
+ return undef unless ref($self);
+
+ $attr = $ATTR_NORMAL unless defined($attr);
+
+ my ($x, $y) = $self->Size();
+ my($left, $top, $right ,$bottom) = $self->Window();
+ my $vx = $right - $left;
+ my $vy = $bottom - $top;
+ $self->FillChar(" ", $x*$y, 0, 0);
+ $self->FillAttr($attr, $x*$y, 0, 0);
+ $self->Cursor(0, 0);
+ $self->Window(1, 0, 0, $vx, $vy);
+}
+
+#=========
+sub Attr {
+#=========
+ my($self, $attr) = @_;
+ return undef unless ref($self);
+
+ if (not defined($attr)) {
+ return (_GetConsoleScreenBufferInfo($self->{'handle'}))[4];
+ }
+ else {
+ return _SetConsoleTextAttribute($self->{'handle'}, $attr);
+ }
+}
+
+#===========
+sub Cursor {
+#===========
+ my($self, $col, $row, $size, $visi) = @_;
+ return undef unless ref($self);
+
+ my $curr_row = 0;
+ my $curr_col = 0;
+ my $curr_size = 0;
+ my $curr_visi = 0;
+ my $return = 0;
+ my $discard = 0;
+
+
+ if (defined($col)) {
+ $row = -1 if not defined($row);
+ if ($col == -1 or $row == -1) {
+ ($discard, $discard, $curr_col, $curr_row) = _GetConsoleScreenBufferInfo($self->{'handle'});
+ $col=$curr_col if $col==-1;
+ $row=$curr_row if $row==-1;
+ }
+ $return += _SetConsoleCursorPosition($self->{'handle'}, $col, $row);
+ if (defined($size) and defined($visi)) {
+ if ($size == -1 or $visi == -1) {
+ ($curr_size, $curr_visi) = _GetConsoleCursorInfo($self->{'handle'});
+ $size = $curr_size if $size == -1;
+ $visi = $curr_visi if $visi == -1;
+ }
+ $size = 1 if $size < 1;
+ $size = 99 if $size > 99;
+ $return += _SetConsoleCursorInfo($self->{'handle'}, $size, $visi);
+ }
+ return $return;
+ }
+ else {
+ ($discard, $discard, $curr_col, $curr_row) = _GetConsoleScreenBufferInfo($self->{'handle'});
+ ($curr_size, $curr_visi) = _GetConsoleCursorInfo($self->{'handle'});
+ return ($curr_col, $curr_row, $curr_size, $curr_visi);
+ }
+}
+
+#=========
+sub Size {
+#=========
+ my($self, $col, $row) = @_;
+ return undef unless ref($self);
+
+ if (not defined($col)) {
+ ($col, $row) = _GetConsoleScreenBufferInfo($self->{'handle'});
+ return ($col, $row);
+ }
+ else {
+ $row = -1 if not defined($row);
+ if ($col == -1 or $row == -1) {
+ ($curr_col, $curr_row) = _GetConsoleScreenBufferInfo($self->{'handle'});
+ $col=$curr_col if $col==-1;
+ $row=$curr_row if $row==-1;
+ }
+ return _SetConsoleScreenBufferSize($self->{'handle'}, $col, $row);
+ }
+}
+
+#=============
+sub FillAttr {
+#=============
+ my($self, $attr, $number, $col, $row) = @_;
+ return undef unless ref($self);
+
+ $number = 1 unless $number;
+
+ if (!defined($col) or !defined($row) or $col == -1 or $row == -1) {
+ ($discard, $discard,
+ $curr_col, $curr_row) = _GetConsoleScreenBufferInfo($self->{'handle'});
+ $col = $curr_col if !defined($col) or $col == -1;
+ $row = $curr_row if !defined($row) or $row == -1;
+ }
+ return _FillConsoleOutputAttribute($self->{'handle'}, $attr, $number, $col, $row);
+}
+
+#=============
+sub FillChar {
+#=============
+ my($self, $char, $number, $col, $row) = @_;
+ return undef unless ref($self);
+
+ if (!defined($col) or !defined($row) or $col == -1 or $row == -1) {
+ ($discard, $discard,
+ $curr_col, $curr_row) = _GetConsoleScreenBufferInfo($self->{'handle'});
+ $col = $curr_col if !defined($col) or $col == -1;
+ $row = $curr_row if !defined($row) or $row == -1;
+ }
+ return _FillConsoleOutputCharacter($self->{'handle'}, $char, $number, $col, $row);
+}
+
+#============
+sub InputCP {
+#============
+ my($self, $codepage) = @_;
+ $codepage = $self if (defined($self) and ref($self) ne "Win32::Console");
+ if (defined($codepage)) {
+ return _SetConsoleCP($codepage);
+ }
+ else {
+ return _GetConsoleCP();
+ }
+}
+
+#=============
+sub OutputCP {
+#=============
+ my($self, $codepage) = @_;
+ $codepage = $self if (defined($self) and ref($self) ne "Win32::Console");
+ if (defined($codepage)) {
+ return _SetConsoleOutputCP($codepage);
+ }
+ else {
+ return _GetConsoleOutputCP();
+ }
+}
+
+#======================
+sub GenerateCtrlEvent {
+#======================
+ my($self, $type, $pid) = @_;
+ $type = constant("CTRL_C_EVENT", 0) unless defined($type);
+ $pid = 0 unless defined($pid);
+ return _GenerateConsoleCtrlEvent($type, $pid);
+}
+
+#===================
+#sub SetCtrlHandler {
+#===================
+# my($name, $add) = @_;
+# $add = 1 unless defined($add);
+# my @nor = keys(%HandlerRoutineStack);
+# if ($add == 0) {
+# foreach $key (@nor) {
+# delete $HandlerRoutineStack{$key}, last if $HandlerRoutineStack{$key}==$name;
+# }
+# $HandlerRoutineRegistered--;
+# } else {
+# if ($#nor == -1) {
+# my $r = _SetConsoleCtrlHandler();
+# if (!$r) {
+# print "WARNING: SetConsoleCtrlHandler failed...\n";
+# }
+# }
+# $HandlerRoutineRegistered++;
+# $HandlerRoutineStack{$HandlerRoutineRegistered} = $name;
+# }
+#}
+
+#===================
+sub get_Win32_IPC_HANDLE { # So Win32::IPC can wait on a console handle
+#===================
+ $_[0]->{'handle'};
+}
+
+########################################################################
+# PRIVATE METHODS
+#
+
+#================
+#sub CtrlHandler {
+#================
+# my($ctrltype) = @_;
+# my $routine;
+# my $result = 0;
+# CALLEM: foreach $routine (sort { $b <=> $a } keys %HandlerRoutineStack) {
+# #print "CtrlHandler: calling $HandlerRoutineStack{$routine}($ctrltype)\n";
+# $result = &{"main::".$HandlerRoutineStack{$routine}}($ctrltype);
+# last CALLEM if $result;
+# }
+# return $result;
+#}
+
+#============
+sub DESTROY {
+#============
+ my($self) = @_;
+ _CloseHandle($self->{'handle'});
+}
+
+#######################################################################
+# dynamically load in the Console.pll module.
+#
+
+bootstrap Win32::Console;
+
+#######################################################################
+# ADDITIONAL CONSTANTS EXPORTED IN THE MAIN NAMESPACE
+#
+
+$FG_BLACK = 0;
+$FG_GRAY = constant("FOREGROUND_INTENSITY",0);
+$FG_BLUE = constant("FOREGROUND_BLUE",0);
+$FG_LIGHTBLUE = constant("FOREGROUND_BLUE",0)|
+ constant("FOREGROUND_INTENSITY",0);
+$FG_RED = constant("FOREGROUND_RED",0);
+$FG_LIGHTRED = constant("FOREGROUND_RED",0)|
+ constant("FOREGROUND_INTENSITY",0);
+$FG_GREEN = constant("FOREGROUND_GREEN",0);
+$FG_LIGHTGREEN = constant("FOREGROUND_GREEN",0)|
+ constant("FOREGROUND_INTENSITY",0);
+$FG_MAGENTA = constant("FOREGROUND_RED",0)|
+ constant("FOREGROUND_BLUE",0);
+$FG_LIGHTMAGENTA = constant("FOREGROUND_RED",0)|
+ constant("FOREGROUND_BLUE",0)|
+ constant("FOREGROUND_INTENSITY",0);
+$FG_CYAN = constant("FOREGROUND_GREEN",0)|
+ constant("FOREGROUND_BLUE",0);
+$FG_LIGHTCYAN = constant("FOREGROUND_GREEN",0)|
+ constant("FOREGROUND_BLUE",0)|
+ constant("FOREGROUND_INTENSITY",0);
+$FG_BROWN = constant("FOREGROUND_RED",0)|
+ constant("FOREGROUND_GREEN",0);
+$FG_YELLOW = constant("FOREGROUND_RED",0)|
+ constant("FOREGROUND_GREEN",0)|
+ constant("FOREGROUND_INTENSITY",0);
+$FG_LIGHTGRAY = constant("FOREGROUND_RED",0)|
+ constant("FOREGROUND_GREEN",0)|
+ constant("FOREGROUND_BLUE",0);
+$FG_WHITE = constant("FOREGROUND_RED",0)|
+ constant("FOREGROUND_GREEN",0)|
+ constant("FOREGROUND_BLUE",0)|
+ constant("FOREGROUND_INTENSITY",0);
+
+$BG_BLACK = 0;
+$BG_GRAY = constant("BACKGROUND_INTENSITY",0);
+$BG_BLUE = constant("BACKGROUND_BLUE",0);
+$BG_LIGHTBLUE = constant("BACKGROUND_BLUE",0)|
+ constant("BACKGROUND_INTENSITY",0);
+$BG_RED = constant("BACKGROUND_RED",0);
+$BG_LIGHTRED = constant("BACKGROUND_RED",0)|
+ constant("BACKGROUND_INTENSITY",0);
+$BG_GREEN = constant("BACKGROUND_GREEN",0);
+$BG_LIGHTGREEN = constant("BACKGROUND_GREEN",0)|
+ constant("BACKGROUND_INTENSITY",0);
+$BG_MAGENTA = constant("BACKGROUND_RED",0)|
+ constant("BACKGROUND_BLUE",0);
+$BG_LIGHTMAGENTA = constant("BACKGROUND_RED",0)|
+ constant("BACKGROUND_BLUE",0)|
+ constant("BACKGROUND_INTENSITY",0);
+$BG_CYAN = constant("BACKGROUND_GREEN",0)|
+ constant("BACKGROUND_BLUE",0);
+$BG_LIGHTCYAN = constant("BACKGROUND_GREEN",0)|
+ constant("BACKGROUND_BLUE",0)|
+ constant("BACKGROUND_INTENSITY",0);
+$BG_BROWN = constant("BACKGROUND_RED",0)|
+ constant("BACKGROUND_GREEN",0);
+$BG_YELLOW = constant("BACKGROUND_RED",0)|
+ constant("BACKGROUND_GREEN",0)|
+ constant("BACKGROUND_INTENSITY",0);
+$BG_LIGHTGRAY = constant("BACKGROUND_RED",0)|
+ constant("BACKGROUND_GREEN",0)|
+ constant("BACKGROUND_BLUE",0);
+$BG_WHITE = constant("BACKGROUND_RED",0)|
+ constant("BACKGROUND_GREEN",0)|
+ constant("BACKGROUND_BLUE",0)|
+ constant("BACKGROUND_INTENSITY",0);
+
+$ATTR_NORMAL = $FG_LIGHTGRAY|$BG_BLACK;
+$ATTR_INVERSE = $FG_BLACK|$BG_LIGHTGRAY;
+
+for my $fg ($FG_BLACK, $FG_GRAY, $FG_BLUE, $FG_GREEN,
+ $FG_CYAN, $FG_RED, $FG_MAGENTA, $FG_BROWN,
+ $FG_LIGHTBLUE, $FG_LIGHTGREEN, $FG_LIGHTCYAN,
+ $FG_LIGHTRED, $FG_LIGHTMAGENTA, $FG_YELLOW,
+ $FG_LIGHTGRAY, $FG_WHITE)
+{
+ for my $bg ($BG_BLACK, $BG_GRAY, $BG_BLUE, $BG_GREEN,
+ $BG_CYAN, $BG_RED, $BG_MAGENTA, $BG_BROWN,
+ $BG_LIGHTBLUE, $BG_LIGHTGREEN, $BG_LIGHTCYAN,
+ $BG_LIGHTRED, $BG_LIGHTMAGENTA, $BG_YELLOW,
+ $BG_LIGHTGRAY, $BG_WHITE)
+ {
+ push(@CONSOLE_COLORS, $fg|$bg);
+ }
+}
+
+# Preloaded methods go here.
+
+#Currently Autoloading is not implemented in Perl for win32
+# Autoload methods go after __END__, and are processed by the autosplit program.
+
+1;
+
+__END__
+
+=head1 NAME
+
+Win32::Console - Win32 Console and Character Mode Functions
+
+
+=head1 DESCRIPTION
+
+This module implements the Win32 console and character mode
+functions. They give you full control on the console input and output,
+including: support of off-screen console buffers (eg. multiple screen
+pages)
+
+=over
+
+=item *
+
+reading and writing of characters, attributes and whole portions of
+the screen
+
+=item *
+
+complete processing of keyboard and mouse events
+
+=item *
+
+some very funny additional features :)
+
+=back
+
+Those functions should also make possible a port of the Unix's curses
+library; if there is anyone interested (and/or willing to contribute)
+to this project, e-mail me. Thank you.
+
+
+=head1 REFERENCE
+
+
+=head2 Methods
+
+=over
+
+=item Alloc
+
+Allocates a new console for the process. Returns C<undef> on errors, a
+nonzero value on success. A process cannot be associated with more
+than one console, so this method will fail if there is already an
+allocated console. Use Free to detach the process from the console,
+and then call Alloc to create a new console. See also: C<Free>
+
+Example:
+
+ $CONSOLE->Alloc();
+
+=item Attr [attr]
+
+Gets or sets the current console attribute. This attribute is used by
+the Write method.
+
+Example:
+
+ $attr = $CONSOLE->Attr();
+ $CONSOLE->Attr($FG_YELLOW | $BG_BLUE);
+
+=item Close
+
+Closes a shortcut object. Note that it is not "strictly" required to
+close the objects you created, since the Win32::Shortcut objects are
+automatically closed when the program ends (or when you somehow
+destroy such an object).
+
+Example:
+
+ $LINK->Close();
+
+=item Cls [attr]
+
+Clear the console, with the specified I<attr> if given, or using
+ATTR_NORMAL otherwise.
+
+Example:
+
+ $CONSOLE->Cls();
+ $CONSOLE->Cls($FG_WHITE | $BG_GREEN);
+
+=item Cursor [x, y, size, visible]
+
+Gets or sets cursor position and appearance. Returns C<undef> on
+errors, or a 4-element list containing: I<x>, I<y>, I<size>,
+I<visible>. I<x> and I<y> are the current cursor position; ...
+
+Example:
+
+ ($x, $y, $size, $visible) = $CONSOLE->Cursor();
+
+ # Get position only
+ ($x, $y) = $CONSOLE->Cursor();
+
+ $CONSOLE->Cursor(40, 13, 50, 1);
+
+ # Set position only
+ $CONSOLE->Cursor(40, 13);
+
+ # Set size and visibility without affecting position
+ $CONSOLE->Cursor(-1, -1, 50, 1);
+
+=item Display
+
+Displays the specified console on the screen. Returns C<undef> on errors,
+a nonzero value on success.
+
+Example:
+
+ $CONSOLE->Display();
+
+=item FillAttr [attribute, number, col, row]
+
+Fills the specified number of consecutive attributes, beginning at
+I<col>, I<row>, with the value specified in I<attribute>. Returns the
+number of attributes filled, or C<undef> on errors. See also:
+C<FillChar>.
+
+Example:
+
+ $CONSOLE->FillAttr($FG_BLACK | $BG_BLACK, 80*25, 0, 0);
+
+=item FillChar char, number, col, row
+
+Fills the specified number of consecutive characters, beginning at
+I<col>, I<row>, with the character specified in I<char>. Returns the
+number of characters filled, or C<undef> on errors. See also:
+C<FillAttr>.
+
+Example:
+
+ $CONSOLE->FillChar("X", 80*25, 0, 0);
+
+=item Flush
+
+Flushes the console input buffer. All the events in the buffer are
+discarded. Returns C<undef> on errors, a nonzero value on success.
+
+Example:
+
+ $CONSOLE->Flush();
+
+=item Free
+
+Detaches the process from the console. Returns C<undef> on errors, a
+nonzero value on success. See also: C<Alloc>.
+
+Example:
+
+ $CONSOLE->Free();
+
+=item GenerateCtrlEvent [type, processgroup]
+
+Sends a break signal of the specified I<type> to the specified
+I<processgroup>. I<type> can be one of the following constants:
+
+ CTRL_BREAK_EVENT
+ CTRL_C_EVENT
+
+they signal, respectively, the pressing of Control + Break and of
+Control + C; if not specified, it defaults to CTRL_C_EVENT.
+I<processgroup> is the pid of a process sharing the same console. If
+omitted, it defaults to 0 (the current process), which is also the
+only meaningful value that you can pass to this function. Returns
+C<undef> on errors, a nonzero value on success.
+
+Example:
+
+ # break this script now
+ $CONSOLE->GenerateCtrlEvent();
+
+=item GetEvents
+
+Returns the number of unread input events in the console's input
+buffer, or C<undef> on errors. See also: C<Input>, C<InputChar>,
+C<PeekInput>, C<WriteInput>.
+
+Example:
+
+ $events = $CONSOLE->GetEvents();
+
+=item Info
+
+Returns an array of informations about the console (or C<undef> on
+errors), which contains:
+
+=over
+
+=item *
+
+columns (X size) of the console buffer.
+
+=item *
+
+rows (Y size) of the console buffer.
+
+=item *
+
+current column (X position) of the cursor.
+
+=item *
+
+current row (Y position) of the cursor.
+
+=item *
+
+current attribute used for C<Write>.
+
+=item *
+
+left column (X of the starting point) of the current console window.
+
+=item *
+
+top row (Y of the starting point) of the current console window.
+
+=item *
+
+right column (X of the final point) of the current console window.
+
+=item *
+
+bottom row (Y of the final point) of the current console window.
+
+=item *
+
+maximum number of columns for the console window, given the current
+buffer size, font and the screen size.
+
+=item *
+
+maximum number of rows for the console window, given the current
+buffer size, font and the screen size.
+
+=back
+
+See also: C<Attr>, C<Cursor>, C<Size>, C<Window>, C<MaxWindow>.
+
+Example:
+
+ @info = $CONSOLE->Info();
+ print "Cursor at $info[3], $info[4].\n";
+
+=item Input
+
+Reads an event from the input buffer. Returns a list of values, which
+depending on the event's nature are:
+
+=over
+
+=item keyboard event
+
+The list will contain:
+
+=over
+
+=item *
+
+event type: 1 for keyboard
+
+=item *
+
+key down: TRUE if the key is being pressed, FALSE if the key is being released
+
+=item *
+
+repeat count: the number of times the key is being held down
+
+=item *
+
+virtual keycode: the virtual key code of the key
+
+=item *
+
+virtual scancode: the virtual scan code of the key
+
+=item *
+
+char: the ASCII code of the character (if the key is a character key, 0 otherwise)
+
+=item *
+
+control key state: the state of the control keys (SHIFTs, CTRLs, ALTs, etc.)
+
+=back
+
+=item mouse event
+
+The list will contain:
+
+=over
+
+=item *
+
+event type: 2 for mouse
+
+=item *
+
+mouse pos. X: X coordinate (column) of the mouse location
+
+=item *
+
+mouse pos. Y: Y coordinate (row) of the mouse location
+
+=item *
+
+button state: the mouse button(s) which are pressed
+
+=item *
+
+control key state: the state of the control keys (SHIFTs, CTRLs, ALTs, etc.)
+
+=item *
+
+event flags: the type of the mouse event
+
+=back
+
+=back
+
+This method will return C<undef> on errors. Note that the events
+returned are depending on the input C<Mode> of the console; for example,
+mouse events are not intercepted unless ENABLE_MOUSE_INPUT is
+specified. See also: C<GetEvents>, C<InputChar>, C<Mode>,
+C<PeekInput>, C<WriteInput>.
+
+Example:
+
+ @event = $CONSOLE->Input();
+
+=item InputChar number
+
+Reads and returns I<number> characters from the console input buffer,
+or C<undef> on errors. See also: C<Input>, C<Mode>.
+
+Example:
+
+ $key = $CONSOLE->InputChar(1);
+
+=item InputCP [codepage]
+
+Gets or sets the input code page used by the console. Note that this
+doesn't apply to a console object, but to the standard input
+console. This attribute is used by the Write method. See also:
+C<OutputCP>.
+
+Example:
+
+ $codepage = $CONSOLE->InputCP();
+ $CONSOLE->InputCP(437);
+
+ # you may want to use the non-instanciated form to avoid confuzion :)
+ $codepage = Win32::Console::InputCP();
+ Win32::Console::InputCP(437);
+
+=item MaxWindow
+
+Returns the size of the largest possible console window, based on the
+current font and the size of the display. The result is C<undef> on
+errors, otherwise a 2-element list containing col, row.
+
+Example:
+
+ ($maxCol, $maxRow) = $CONSOLE->MaxWindow();
+
+=item Mode [flags]
+
+Gets or sets the input or output mode of a console. I<flags> can be a
+combination of the following constants:
+
+ ENABLE_LINE_INPUT
+ ENABLE_ECHO_INPUT
+ ENABLE_PROCESSED_INPUT
+ ENABLE_WINDOW_INPUT
+ ENABLE_MOUSE_INPUT
+ ENABLE_PROCESSED_OUTPUT
+ ENABLE_WRAP_AT_EOL_OUTPUT
+
+For more informations on the meaning of those flags, please refer to
+the L<"Microsoft's Documentation">.
+
+Example:
+
+ $mode = $CONSOLE->Mode();
+ $CONSOLE->Mode(ENABLE_MOUSE_INPUT | ENABLE_PROCESSED_INPUT);
+
+=item MouseButtons
+
+Returns the number of the buttons on your mouse, or C<undef> on errors.
+
+Example:
+
+ print "Your mouse has ", $CONSOLE->MouseButtons(), " buttons.\n";
+
+=item new Win32::Console standard_handle
+
+=item new Win32::Console [accessmode, sharemode]
+
+Creates a new console object. The first form creates a handle to a
+standard channel, I<standard_handle> can be one of the following:
+
+ STD_OUTPUT_HANDLE
+ STD_ERROR_HANDLE
+ STD_INPUT_HANDLE
+
+The second form, instead, creates a console screen buffer in memory,
+which you can access for reading and writing as a normal console, and
+then redirect on the standard output (the screen) with C<Display>. In
+this case, you can specify one or both of the following values for
+I<accessmode>:
+
+ GENERIC_READ
+ GENERIC_WRITE
+
+which are the permissions you will have on the created buffer, and one
+or both of the following values for I<sharemode>:
+
+ FILE_SHARE_READ
+ FILE_SHARE_WRITE
+
+which affect the way the console can be shared. If you don't specify
+any of those parameters, all 4 flags will be used.
+
+Example:
+
+ $STDOUT = new Win32::Console(STD_OUTPUT_HANDLE);
+ $STDERR = new Win32::Console(STD_ERROR_HANDLE);
+ $STDIN = new Win32::Console(STD_INPUT_HANDLE);
+
+ $BUFFER = new Win32::Console();
+ $BUFFER = new Win32::Console(GENERIC_READ | GENERIC_WRITE);
+
+=item OutputCP [codepage]
+
+Gets or sets the output code page used by the console. Note that this
+doesn't apply to a console object, but to the standard output console.
+See also: C<InputCP>.
+
+Example:
+
+ $codepage = $CONSOLE->OutputCP();
+ $CONSOLE->OutputCP(437);
+
+ # you may want to use the non-instanciated form to avoid confuzion :)
+ $codepage = Win32::Console::OutputCP();
+ Win32::Console::OutputCP(437);
+
+=item PeekInput
+
+Does exactly the same as C<Input>, except that the event read is not
+removed from the input buffer. See also: C<GetEvents>, C<Input>,
+C<InputChar>, C<Mode>, C<WriteInput>.
+
+Example:
+
+ @event = $CONSOLE->PeekInput();
+
+=item ReadAttr [number, col, row]
+
+Reads the specified I<number> of consecutive attributes, beginning at
+I<col>, I<row>, from the console. Returns the attributes read (a
+variable containing one character for each attribute), or C<undef> on
+errors. You can then pass the returned variable to C<WriteAttr> to
+restore the saved attributes on screen. See also: C<ReadChar>,
+C<ReadRect>.
+
+Example:
+
+ $colors = $CONSOLE->ReadAttr(80*25, 0, 0);
+
+=item ReadChar [number, col, row]
+
+Reads the specified I<number> of consecutive characters, beginning at
+I<col>, I<row>, from the console. Returns a string containing the
+characters read, or C<undef> on errors. You can then pass the
+returned variable to C<WriteChar> to restore the saved characters on
+screen. See also: C<ReadAttr>, C<ReadRect>.
+
+Example:
+
+ $chars = $CONSOLE->ReadChar(80*25, 0, 0);
+
+=item ReadRect left, top, right, bottom
+
+Reads the content (characters and attributes) of the rectangle
+specified by I<left>, I<top>, I<right>, I<bottom> from the console.
+Returns a string containing the rectangle read, or C<undef> on errors.
+You can then pass the returned variable to C<WriteRect> to restore the
+saved rectangle on screen (or on another console). See also:
+C<ReadAttr>, C<ReadChar>.
+
+Example:
+
+ $rect = $CONSOLE->ReadRect(0, 0, 80, 25);
+
+=item Scroll left, top, right, bottom, col, row, char, attr,
+ [cleft, ctop, cright, cbottom]
+
+Moves a block of data in a console buffer; the block is identified by
+I<left>, I<top>, I<right>, I<bottom>, while I<row>, I<col> identify
+the new location of the block. The cells left empty as a result of
+the move are filled with the character I<char> and attribute I<attr>.
+Optionally you can specify a clipping region with I<cleft>, I<ctop>,
+I<cright>, I<cbottom>, so that the content of the console outside this
+rectangle are unchanged. Returns C<undef> on errors, a nonzero value
+on success.
+
+Example:
+
+ # scrolls the screen 10 lines down, filling with black spaces
+ $CONSOLE->Scroll(0, 0, 80, 25, 0, 10, " ", $FG_BLACK | $BG_BLACK);
+
+=item Select standard_handle
+
+Redirects a standard handle to the specified console.
+I<standard_handle> can have one of the following values:
+
+ STD_INPUT_HANDLE
+ STD_OUTPUT_HANDLE
+ STD_ERROR_HANDLE
+
+Returns C<undef> on errors, a nonzero value on success.
+
+Example:
+
+ $CONSOLE->Select(STD_OUTPUT_HANDLE);
+
+=item SetIcon icon_file
+
+Sets the icon in the title bar of the current console window.
+
+Example:
+
+ $CONSOLE->SetIcon("C:/My/Path/To/Custom.ico");
+
+=item Size [col, row]
+
+Gets or sets the console buffer size.
+
+Example:
+
+ ($x, $y) = $CONSOLE->Size();
+ $CONSOLE->Size(80, 25);
+
+=item Title [title]
+
+Gets or sets the title of the current console window.
+
+Example:
+
+ $title = $CONSOLE->Title();
+ $CONSOLE->Title("This is a title");
+
+=item Window [flag, left, top, right, bottom]
+
+Gets or sets the current console window size. If called without
+arguments, returns a 4-element list containing the current window
+coordinates in the form of I<left>, I<top>, I<right>, I<bottom>. To
+set the window size, you have to specify an additional I<flag>
+parameter: if it is 0 (zero), coordinates are considered relative to
+the current coordinates; if it is non-zero, coordinates are absolute.
+
+Example:
+
+ ($left, $top, $right, $bottom) = $CONSOLE->Window();
+ $CONSOLE->Window(1, 0, 0, 80, 50);
+
+=item Write string
+
+Writes I<string> on the console, using the current attribute, that you
+can set with C<Attr>, and advancing the cursor as needed. This isn't
+so different from Perl's "print" statement. Returns the number of
+characters written or C<undef> on errors. See also: C<WriteAttr>,
+C<WriteChar>, C<WriteRect>.
+
+Example:
+
+ $CONSOLE->Write("Hello, world!");
+
+=item WriteAttr attrs, col, row
+
+Writes the attributes in the string I<attrs>, beginning at I<col>,
+I<row>, without affecting the characters that are on screen. The
+string attrs can be the result of a C<ReadAttr> function, or you can
+build your own attribute string; in this case, keep in mind that every
+attribute is treated as a character, not a number (see example).
+Returns the number of attributes written or C<undef> on errors. See
+also: C<Write>, C<WriteChar>, C<WriteRect>.
+
+Example:
+
+ $CONSOLE->WriteAttr($attrs, 0, 0);
+
+ # note the use of chr()...
+ $attrs = chr($FG_BLACK | $BG_WHITE) x 80;
+ $CONSOLE->WriteAttr($attrs, 0, 0);
+
+=item WriteChar chars, col, row
+
+Writes the characters in the string I<attr>, beginning at I<col>, I<row>,
+without affecting the attributes that are on screen. The string I<chars>
+can be the result of a C<ReadChar> function, or a normal string. Returns
+the number of characters written or C<undef> on errors. See also:
+C<Write>, C<WriteAttr>, C<WriteRect>.
+
+Example:
+
+ $CONSOLE->WriteChar("Hello, worlds!", 0, 0);
+
+=item WriteInput (event)
+
+Pushes data in the console input buffer. I<(event)> is a list of values,
+for more information see C<Input>. The string chars can be the result of
+a C<ReadChar> function, or a normal string. Returns the number of
+characters written or C<undef> on errors. See also: C<Write>,
+C<WriteAttr>, C<WriteRect>.
+
+Example:
+
+ $CONSOLE->WriteInput(@event);
+
+=item WriteRect rect, left, top, right, bottom
+
+Writes a rectangle of characters and attributes (contained in I<rect>)
+on the console at the coordinates specified by I<left>, I<top>,
+I<right>, I<bottom>. I<rect> can be the result of a C<ReadRect>
+function. Returns C<undef> on errors, otherwise a 4-element list
+containing the coordinates of the affected rectangle, in the format
+I<left>, I<top>, I<right>, I<bottom>. See also: C<Write>,
+C<WriteAttr>, C<WriteChar>.
+
+Example:
+
+ $CONSOLE->WriteRect($rect, 0, 0, 80, 25);
+
+=back
+
+
+=head2 Constants
+
+The following constants are exported in the main namespace of your
+script using Win32::Console:
+
+ BACKGROUND_BLUE
+ BACKGROUND_GREEN
+ BACKGROUND_INTENSITY
+ BACKGROUND_RED
+ CAPSLOCK_ON
+ CONSOLE_TEXTMODE_BUFFER
+ ENABLE_ECHO_INPUT
+ ENABLE_LINE_INPUT
+ ENABLE_MOUSE_INPUT
+ ENABLE_PROCESSED_INPUT
+ ENABLE_PROCESSED_OUTPUT
+ ENABLE_WINDOW_INPUT
+ ENABLE_WRAP_AT_EOL_OUTPUT
+ ENHANCED_KEY
+ FILE_SHARE_READ
+ FILE_SHARE_WRITE
+ FOREGROUND_BLUE
+ FOREGROUND_GREEN
+ FOREGROUND_INTENSITY
+ FOREGROUND_RED
+ LEFT_ALT_PRESSED
+ LEFT_CTRL_PRESSED
+ NUMLOCK_ON
+ GENERIC_READ
+ GENERIC_WRITE
+ RIGHT_ALT_PRESSED
+ RIGHT_CTRL_PRESSED
+ SCROLLLOCK_ON
+ SHIFT_PRESSED
+ STD_INPUT_HANDLE
+ STD_OUTPUT_HANDLE
+ STD_ERROR_HANDLE
+
+Additionally, the following variables can be used:
+
+ $FG_BLACK
+ $FG_GRAY
+ $FG_BLUE
+ $FG_LIGHTBLUE
+ $FG_RED
+ $FG_LIGHTRED
+ $FG_GREEN
+ $FG_LIGHTGREEN
+ $FG_MAGENTA
+ $FG_LIGHTMAGENTA
+ $FG_CYAN
+ $FG_LIGHTCYAN
+ $FG_BROWN
+ $FG_YELLOW
+ $FG_LIGHTGRAY
+ $FG_WHITE
+
+ $BG_BLACK
+ $BG_GRAY
+ $BG_BLUE
+ $BG_LIGHTBLUE
+ $BG_RED
+ $BG_LIGHTRED
+ $BG_GREEN
+ $BG_LIGHTGREEN
+ $BG_MAGENTA
+ $BG_LIGHTMAGENTA
+ $BG_CYAN
+ $BG_LIGHTCYAN
+ $BG_BROWN
+ $BG_YELLOW
+ $BG_LIGHTGRAY
+ $BG_WHITE
+
+ $ATTR_NORMAL
+ $ATTR_INVERSE
+
+ATTR_NORMAL is set to gray foreground on black background (DOS's
+standard colors).
+
+
+=head2 Microsoft's Documentation
+
+Documentation for the Win32 Console and Character mode Functions can
+be found on Microsoft's site at this URL:
+
+http://www.microsoft.com/msdn/sdk/platforms/doc/sdk/win32/sys/src/conchar.htm
+
+A reference of the available functions is at:
+
+http://www.microsoft.com/msdn/sdk/platforms/doc/sdk/win32/sys/src/conchar_34.htm
+
+
+=head1 AUTHOR
+
+Aldo Calpini <a.calpini@romagiubileo.it>
+
+=head1 CREDITS
+
+Thanks to: Jesse Dougherty, Dave Roth, ActiveWare, and the
+Perl-Win32-Users community.
+
+=head1 DISCLAIMER
+
+This program is FREE; you can redistribute, modify, disassemble, or
+even reverse engineer this software at your will. Keep in mind,
+however, that NOTHING IS GUARANTEED to work and everything you do is
+AT YOUR OWN RISK - I will not take responsibility for any damage, loss
+of money and/or health that may arise from the use of this program!
+
+This is distributed under the terms of Larry Wall's Artistic License.
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/OLE.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/OLE.pm
new file mode 100644
index 0000000000..ece534b15f
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/OLE.pm
@@ -0,0 +1,968 @@
+# The documentation is at the __END__
+
+package Win32::OLE;
+
+use strict;
+use vars qw($VERSION @ISA @EXPORT @EXPORT_OK @EXPORT_FAIL $AUTOLOAD
+ $CP $LCID $Warn $LastError $_NewEnum $_Unique);
+
+$VERSION = '0.1712';
+
+use Carp;
+use Exporter;
+use DynaLoader;
+@ISA = qw(Exporter DynaLoader);
+
+@EXPORT = qw();
+@EXPORT_OK = qw(in valof with HRESULT EVENTS OVERLOAD
+ CP_ACP CP_OEMCP CP_MACCP CP_UTF7 CP_UTF8
+ DISPATCH_METHOD DISPATCH_PROPERTYGET
+ DISPATCH_PROPERTYPUT DISPATCH_PROPERTYPUTREF);
+@EXPORT_FAIL = qw(EVENTS OVERLOAD);
+
+sub export_fail {
+ shift;
+ my @unknown;
+ while (@_) {
+ my $symbol = shift;
+ if ($symbol eq 'OVERLOAD') {
+ eval <<'OVERLOAD';
+ use overload '""' => \&valof,
+ '0+' => \&valof,
+ fallback => 1;
+OVERLOAD
+ }
+ elsif ($symbol eq 'EVENTS') {
+ Win32::OLE->Initialize(Win32::OLE::COINIT_OLEINITIALIZE());
+ }
+ else {
+ push @unknown, $symbol;
+ }
+ }
+ return @unknown;
+}
+
+unless (defined &Dispatch) {
+ # Use regular DynaLoader if XS part is not yet initialized
+ bootstrap Win32::OLE;
+ require Win32::OLE::Lite;
+}
+
+1;
+
+########################################################################
+
+__END__
+
+=head1 NAME
+
+Win32::OLE - OLE Automation extensions
+
+=head1 SYNOPSIS
+
+ $ex = Win32::OLE->new('Excel.Application') or die "oops\n";
+ $ex->Amethod("arg")->Bmethod->{'Property'} = "foo";
+ $ex->Cmethod(undef,undef,$Arg3);
+ $ex->Dmethod($RequiredArg1, {NamedArg1 => $Value1, NamedArg2 => $Value2});
+
+ $wd = Win32::OLE->GetObject("D:\\Data\\Message.doc");
+ $xl = Win32::OLE->GetActiveObject("Excel.Application");
+
+=head1 DESCRIPTION
+
+This module provides an interface to OLE Automation from Perl.
+OLE Automation brings VisualBasic like scripting capabilities and
+offers powerful extensibility and the ability to control many Win32
+applications from Perl scripts.
+
+The Win32::OLE module uses the IDispatch interface exclusively. It is
+not possible to access a custom OLE interface. OLE events and OCX's are
+currently not supported.
+
+Actually, that's no longer strictly true. This module now contains
+B<ALPHA> level support for OLE events. This is largely untested and the
+specific interface might still change in the future.
+
+=head2 Methods
+
+=over 8
+
+=item Win32::OLE->new(PROGID[, DESTRUCTOR])
+
+The new() class method starts a new instance of an OLE Automation object.
+It returns a reference to this object or C<undef> if the creation failed.
+
+The PROGID argument must be either the OLE I<program id> or the I<class id>
+of the required application. The optional DESTRUCTOR specifies a DESTROY-like
+method. This can be either a CODE reference or a string containing an OLE
+method name. It can be used to cleanly terminate OLE applications in case the
+Perl program dies.
+
+To create an object via DCOM on a remote server you can use an array
+reference in place of PROGID. The referenced array must contain the
+machine name and the I<program id> or I<class id>. For example:
+
+ my $obj = Win32::OLE->new(['my.machine.com', 'Program.Id']);
+
+If the PROGID is a I<program id> then Win32::OLE will try to resolve the
+corresponding I<class id> locally. If the I<program id> is not registered
+locally then the remote registry is queried. This will only succeed if
+the local process has read access to the remote registry. The safest
+(and fastest) method is to specify the C<class id> directly.
+
+=item Win32::OLE->EnumAllObjects([CALLBACK])
+
+This class method returns the number Win32::OLE objects currently in
+existence. It will call the optional CALLBACK function for each of
+these objects:
+
+ $Count = Win32::OLE->EnumAllObjects(sub {
+ my $Object = shift;
+ my $Class = Win32::OLE->QueryObjectType($Object);
+ printf "# Object=%s Class=%s\n", $Object, $Class;
+ });
+
+The EnumAllObjects() method is primarily a debugging tool. It can be
+used e.g. in an END block to check if all external connections have
+been properly destroyed.
+
+=item Win32::OLE->FreeUnusedLibraries()
+
+The FreeUnusedLibraries() class method unloads all unused OLE
+resources. These are the libraries of those classes of which all
+existing objects have been destroyed. The unloading of object
+libraries is really only important for long running processes that
+might instantiate a huge number of B<different> objects over time.
+
+Be aware that objects implemented in Visual Basic have a buggy
+implementation of this functionality: They pretend to be unloadable
+while they are actually still running their cleanup code. Unloading
+the DLL at that moment typically produces an access violation. The
+probability for this problem can be reduced by calling the
+SpinMessageLoop() method and sleep()ing for a few seconds.
+
+=item Win32::OLE->GetActiveObject(CLASS[, DESTRUCTOR])
+
+The GetActiveObject() class method returns an OLE reference to a
+running instance of the specified OLE automation server. It returns
+C<undef> if the server is not currently active. It will croak if
+the class is not even registered. The optional DESTRUCTOR method takes
+either a method name or a code reference. It is executed when the last
+reference to this object goes away. It is generally considered rude
+to stop applications that you did not start yourself.
+
+=item Win32::OLE->GetObject(MONIKER[, DESTRUCTOR])
+
+The GetObject() class method returns an OLE reference to the specified
+object. The object is specified by a pathname optionally followed by
+additional item subcomponent separated by exclamation marks '!'. The
+optional DESTRUCTOR argument has the same semantics as the DESTRUCTOR in
+new() or GetActiveObject().
+
+=item Win32::OLE->Initialize([COINIT])
+
+The Initialize() class method can be used to specify an alternative
+apartment model for the Perl thread. It must be called B<before> the
+first OLE object is created. If the C<Win32::OLE::Const> module is
+used then the call to the Initialize() method must be made from a BEGIN
+block before the first C<use> statement for the C<Win32::OLE::Const>
+module.
+
+Valid values for COINIT are:
+
+ Win32::OLE::COINIT_APARTMENTTHREADED - single threaded
+ Win32::OLE::COINIT_MULTITHREADED - the default
+ Win32::OLE::COINIT_OLEINITIALIZE - single threaded, additional OLE stuff
+
+COINIT_OLEINITIALIZE is sometimes needed when an OLE object uses
+additional OLE compound document technologies not available from the
+normal COM subsystem (for example MAPI.Session seems to require it).
+Both COINIT_OLEINITIALIZE and COINIT_APARTMENTTHREADED create a hidden
+top level window and a message queue for the Perl process. This may
+create problems with other application, because Perl normally doesn't
+process its message queue. This means programs using synchronous
+communication between applications (such as DDE initiation), may hang
+until Perl makes another OLE method call/property access or terminates.
+This applies to InstallShield setups and many things started to shell
+associations. Please try to utilize the C<Win32::OLE-E<gt>SpinMessageLoop>
+and C<Win32::OLE-E<gt>Uninitialize> methods if you can not use the default
+COINIT_MULTITHREADED model.
+
+=item OBJECT->Invoke(METHOD[, ARGS])
+
+The Invoke() object method is an alternate way to invoke OLE
+methods. It is normally equivalent to C<$OBJECT-E<gt>METHOD(@ARGS)>. This
+function must be used if the METHOD name contains characters not valid
+in a Perl variable name (like foreign language characters). It can
+also be used to invoke the default method of an object even if the
+default method has not been given a name in the type library. In this
+case use <undef> or C<''> as the method name. To invoke an OLE objects
+native Invoke() method (if such a thing exists), please use:
+
+ $Object->Invoke('Invoke', @Args);
+
+=item Win32::OLE->LastError()
+
+The LastError() class method returns the last recorded OLE
+error. This is a dual value like the C<$!> variable: in a numeric
+context it returns the error number and in a string context it returns
+the error message. The error number is a signed HRESULT value. Please
+use the L<HRESULT(ERROR)> function to convert an unsigned hexadecimal
+constant to a signed HRESULT.
+
+The last OLE error is automatically reset by a successful OLE
+call. The numeric value can also explicitly be set by a call (which will
+discard the string value):
+
+ Win32::OLE->LastError(0);
+
+=item OBJECT->LetProperty(NAME,ARGS,VALUE)
+
+In Win32::OLE property assignment using the hash syntax is equivalent
+to the Visual Basic C<Set> syntax (I<by reference> assignment):
+
+ $Object->{Property} = $OtherObject;
+
+corresponds to this Visual Basic statement:
+
+ Set Object.Property = OtherObject
+
+To get the I<by value> treatment of the Visual Basic C<Let> statement
+
+ Object.Property = OtherObject
+
+you have to use the LetProperty() object method in Perl:
+
+ $Object->LetProperty($Property, $OtherObject);
+
+LetProperty() also supports optional arguments for the property assignment.
+See L<OBJECT->SetProperty(NAME,ARGS,VALUE)> for details.
+
+=item Win32::OLE->MessageLoop()
+
+The MessageLoop() class method will run a standard Windows message
+loop, dispatching messages until the QuitMessageLoop() class method is
+called. It is used to wait for OLE events.
+
+=item Win32::OLE->Option(OPTION)
+
+The Option() class method can be used to inspect and modify
+L<Module Options>. The single argument form retrieves the value of
+an option:
+
+ my $CP = Win32::OLE->Option('CP');
+
+A single call can be used to set multiple options simultaneously:
+
+ Win32::OLE->Option(CP => CP_ACP, Warn => 3);
+
+=item Win32::OLE->QueryObjectType(OBJECT)
+
+The QueryObjectType() class method returns a list of the type library
+name and the objects class name. In a scalar context it returns the
+class name only. It returns C<undef> when the type information is not
+available.
+
+=item Win32::OLE->QuitMessageLoop()
+
+The QuitMessageLoop() class method posts a (user-level) "Quit" message
+to the current threads message loop. QuitMessageLoop() is typically
+called from an event handler. The MessageLoop() class method will
+return when it receives this "Quit" method.
+
+=item OBJECT->SetProperty(NAME,ARGS,VALUE)
+
+The SetProperty() method allows to modify properties with arguments,
+which is not supported by the hash syntax. The hash form
+
+ $Object->{Property} = $Value;
+
+is equivalent to
+
+ $Object->SetProperty('Property', $Value);
+
+Arguments must be specified between the property name and the new value:
+
+ $Object->SetProperty('Property', @Args, $Value);
+
+It is not possible to use "named argument" syntax with this function
+because the new value must be the last argument to SetProperty().
+
+This method hides any native OLE object method called SetProperty().
+The native method will still be available through the Invoke() method:
+
+ $Object->Invoke('SetProperty', @Args);
+
+=item Win32::OLE->SpinMessageLoop
+
+This class method retrieves all pending messages from the message queue
+and dispatches them to their respective window procedures. Calling this
+method is only necessary when not using the COINIT_MULTITHREADED model.
+All OLE method calls and property accesses automatically process the
+message queue.
+
+=item Win32::OLE->Uninitialize
+
+The Uninitialize() class method uninitializes the OLE subsystem. It
+also destroys the hidden top level window created by OLE for single
+threaded apartments. All OLE objects will become invalid after this call!
+It is possible to call the Initialize() class method again with a different
+apartment model after shutting down OLE with Uninitialize().
+
+=item Win32::OLE->WithEvents(OBJECT[, HANDLER[, INTERFACE]])
+
+This class method enables and disables the firing of events by the
+specified OBJECT. If no HANDLER is specified, then events are
+disconnected. For some objects Win32::OLE is not able to
+automatically determine the correct event interface. In this case the
+INTERFACE argument must contain either the COCLASS name of the OBJECT
+or the name of the event DISPATCH interface. Please read the L<Events>
+section below for detailed explanation of the Win32::OLE event
+support.
+
+=back
+
+Whenever Perl does not find a method name in the Win32::OLE package it
+is automatically used as the name of an OLE method and this method call
+is dispatched to the OLE server.
+
+There is one special hack built into the module: If a method or property
+name could not be resolved with the OLE object, then the default method
+of the object is called with the method name as its first parameter. So
+
+ my $Sheet = $Worksheets->Table1;
+or
+ my $Sheet = $Worksheets->{Table1};
+
+is resolved as
+
+ my $Sheet = $Worksheet->Item('Table1');
+
+provided that the $Worksheets object does not have a C<Table1> method
+or property. This hack has been introduced to call the default method
+of collections which did not name the method in their type library. The
+recommended way to call the "unnamed" default method is:
+
+ my $Sheet = $Worksheets->Invoke('', 'Table1');
+
+This special hack is disabled under C<use strict 'subs';>.
+
+=head2 Object methods and properties
+
+The object returned by the new() method can be used to invoke
+methods or retrieve properties in the same fashion as described
+in the documentation for the particular OLE class (eg. Microsoft
+Excel documentation describes the object hierarchy along with the
+properties and methods exposed for OLE access).
+
+Optional parameters on method calls can be omitted by using C<undef>
+as a placeholder. A better way is to use named arguments, as the
+order of optional parameters may change in later versions of the OLE
+server application. Named parameters can be specified in a reference
+to a hash as the last parameter to a method call.
+
+Properties can be retrieved or set using hash syntax, while methods
+can be invoked with the usual perl method call syntax. The C<keys>
+and C<each> functions can be used to enumerate an object's properties.
+Beware that a property is not always writable or even readable (sometimes
+raising exceptions when read while being undefined).
+
+If a method or property returns an embedded OLE object, method
+and property access can be chained as shown in the examples below.
+
+=head2 Functions
+
+The following functions are not exported by default.
+
+=over 8
+
+=item HRESULT(ERROR)
+
+The HRESULT() function converts an unsigned number into a signed HRESULT
+error value as used by OLE internally. This is necessary because Perl
+treats all hexadecimal constants as unsigned. To check if the last OLE
+function returned "Member not found" (0x80020003) you can write:
+
+ if (Win32::OLE->LastError == HRESULT(0x80020003)) {
+ # your error recovery here
+ }
+
+=item in(COLLECTION)
+
+If COLLECTION is an OLE collection object then C<in $COLLECTION>
+returns a list of all members of the collection. This is a shortcut
+for C<Win32::OLE::Enum-E<gt>All($COLLECTION)>. It is most commonly used in
+a C<foreach> loop:
+
+ foreach my $value (in $collection) {
+ # do something with $value here
+ }
+
+=item valof(OBJECT)
+
+Normal assignment of Perl OLE objects creates just another reference
+to the OLE object. The valof() function explictly dereferences the
+object (through the default method) and returns the value of the object.
+
+ my $RefOf = $Object;
+ my $ValOf = valof $Object;
+ $Object->{Value} = $NewValue;
+
+Now $ValOf still contains the old value whereas $RefOf would
+resolve to the $NewValue because it is still a reference to
+$Object.
+
+The valof() function can also be used to convert Win32::OLE::Variant
+objects to Perl values.
+
+=item with(OBJECT, PROPERTYNAME => VALUE, ...)
+
+This function provides a concise way to set the values of multiple
+properties of an object. It iterates over its arguments doing
+C<$OBJECT-E<gt>{PROPERTYNAME} = $VALUE> on each trailing pair.
+
+=back
+
+=head2 Overloading
+
+The Win32::OLE objects can be overloaded to automatically convert to
+their values whenever they are used in a bool, numeric or string
+context. This is not enabled by default. You have to request it
+through the OVERLOAD pseudoexport:
+
+ use Win32::OLE qw(in valof with OVERLOAD);
+
+You can still get the original string representation of an object
+(C<Win32::OLE=0xDEADBEEF>), e.g. for debugging, by using the
+C<overload::StrVal()> method:
+
+ print overload::StrVal($object), "\n";
+
+Please note that C<OVERLOAD> is a global setting. If any module enables
+Win32::OLE overloading then it's active everywhere.
+
+=head2 Events
+
+The Win32::OLE module now contains B<ALPHA> level event support. This
+support is only available when Perl is running in a single threaded
+apartment. This can most easily be assured by using the C<EVENTS>
+pseudo-import:
+
+ use Win32::OLE qw(EVENTS);
+
+which implicitly does something like:
+
+ use Win32::OLE;
+ Win32::OLE->Initialize(Win32::OLE::COINIT_OLEINITIALIZE);
+
+The current interface to OLE events should be considered experimental
+and is subject to change. It works as expected for normal OLE
+applications, but OLE control events often don't seem to work yet.
+
+Events must be enabled explicitly for an OLE object through the
+Win32::OLE->WithEvents() class method. The Win32::OLE module uses the
+IProvideClassInfo2 interface to determine the default event source of
+the object. If this interface is not supported, then the user must
+specify the name of the event source explicitly in the WithEvents()
+method call. It is also possible to specify the class name of the
+object as the third parameter. In this case Win32::OLE will try to
+look up the default source interface for this COCLASS.
+
+The HANDLER argument to Win32::OLE->WithEvents() can either be a CODE
+reference or a package name. In the first case, all events will invoke
+this particular function. The first two arguments to this function will
+be the OBJECT itself and the name of the event. The remaining arguments
+will be event specific.
+
+ sub Event {
+ my ($Obj,$Event,@Args) = @_;
+ print "Event triggered: '$Event'\n";
+ }
+ Win32::OLE->WithEvents($Obj, \&Event);
+
+Alternatively the HANDLER argument can specify a package name. When the
+OBJECT fires an event, Win32::OLE will try to find a function of the same
+name as the event in this package. This function will be called with the
+OBJECT as the first argument followed again by the event specific parameters:
+
+ package MyEvents;
+ sub EventName1 {
+ my ($Obj,@Args) = @_;
+ print "EventName1 event triggered\n";
+ }
+
+ package main;
+ Win32::OLE->WithEvents($Obj, 'MyEvents', 'IEventInterface');
+
+If Win32::OLE doesn't find a function with the name of the event then nothing
+happens.
+
+Event parameters passed I<by reference> are handled specially. They are not
+converted to the corresponding Perl datatype but passed as Win32::OLE::Variant
+objects. You can assign a new value to these objects with the help of the
+Put() method. This value will be passed back to the object when the event
+function returns:
+
+ package MyEvents;
+ sub BeforeClose {
+ my ($self,$Cancel) = @_;
+ $Cancel->Put(1) unless $MayClose;
+ }
+
+Direct assignment to $Cancel would have no effect on the original value and
+would therefore not command the object to abort the closing action.
+
+=head2 Module Options
+
+The following module options can be accessed and modified with the
+C<Win32::OLE-E<gt>Option> class method. In earlier versions of the Win32::OLE
+module these options were manipulated directly as class variables. This
+practice is now deprecated.
+
+=over 8
+
+=item CP
+
+This variable is used to determine the codepage used by all
+translations between Perl strings and Unicode strings used by the OLE
+interface. The default value is CP_ACP, which is the default ANSI
+codepage. Other possible values are CP_OEMCP, CP_MACCP, CP_UTF7 and
+CP_UTF8. These constants are not exported by default.
+
+=item LCID
+
+This variable controls the locale identifier used for all OLE calls.
+It is set to LOCALE_NEUTRAL by default. Please check the
+L<Win32::OLE::NLS> module for other locale related information.
+
+=item Variant
+
+This options controls how method calls and property accessors return
+values of type VT_CY and VT_DECIMAL are being returned. By default
+VT_CY values are turned into strings and VT_DECIMAL values into
+floating point numbers. If the C<Variant> option is enabled, these
+values are returned as Win32::OLE::Variant objects, just like VT_DATE
+and VT_ERROR values. If the Win32::OLE::Variant module is also
+loaded, then all values should still behave as before in string and in
+numeric context.
+
+The only reason that the C<Variant> behavior is not the default is that
+this is an incompatible change that might break existing programs.
+
+=item Warn
+
+This variable determines the behavior of the Win32::OLE module when
+an error happens. Valid values are:
+
+ 0 Ignore error, return undef
+ 1 Carp::carp if $^W is set (-w option)
+ 2 always Carp::carp
+ 3 Carp::croak
+
+The error number and message (without Carp line/module info) are
+available through the C<Win32::OLE-E<gt>LastError> class method.
+
+Alternatively the Warn option can be set to a CODE reference. E.g.
+
+ Win32::OLE->Option(Warn => 3);
+
+is equivalent to
+
+ Win32::OLE->Option(Warn => \&Carp::croak);
+
+This can even be used to emulate the VisualBasic C<On Error Goto
+Label> construct:
+
+ Win32::OLE->Option(Warn => sub {goto CheckError});
+ # ... your normal OLE code here ...
+
+ CheckError:
+ # ... your error handling code here ...
+
+=item _NewEnum
+
+This option enables additional enumeration support for collection
+objects. When the C<_NewEnum> option is set, all collections will
+receive one additional property: C<_NewEnum>. The value of this
+property will be a reference to an array containing all the elements
+of the collection. This option can be useful when used in conjunction
+with an automatic tree traversal program, like C<Data::Dumper> or an
+object tree browser. The value of this option should be either 1
+(enabled) or 0 (disabled, default).
+
+ Win32::OLE->Option(_NewEnum => 1);
+ # ...
+ my @sheets = @{$Excel->Worksheets->{_NewEnum}};
+
+In normal application code, this would be better written as:
+
+ use Win32::OLE qw(in);
+ # ...
+ my @sheets = in $Excel->Worksheets;
+
+=item _Unique
+
+The C<_Unique> options guarantees that Win32::OLE will maintain a
+one-to-one mapping between Win32::OLE objects and the native COM/OLE
+objects. Without this option, you can query the same property twice
+and get two different Win32::OLE objects for the same underlying COM
+object.
+
+Using a unique proxy makes life easier for tree traversal algorithms
+to recognize they already visited a particular node. This option
+comes at a price: Win32::OLE has to maintain a global hash of all
+outstanding objects and their corresponding proxies. Identity checks
+on COM objects can also be expensive if the objects reside
+out-of-process or even on a different computer. Therefore this option
+is off by default unless the program is being run in the debugger.
+
+Unfortunately, this option doesn't always help. Some programs will
+return new COM objects for even the same property when asked for it
+multiple times (especially for collections). In this case, there is
+nothing Win32::OLE can do to detect that these objects are in fact
+identical (because they aren't at the COM level).
+
+The C<_Unique> option can be set to either 1 (enabled) or 0 (disabled,
+default).
+
+=back
+
+=head1 EXAMPLES
+
+Here is a simple Microsoft Excel application.
+
+ use Win32::OLE;
+
+ # use existing instance if Excel is already running
+ eval {$ex = Win32::OLE->GetActiveObject('Excel.Application')};
+ die "Excel not installed" if $@;
+ unless (defined $ex) {
+ $ex = Win32::OLE->new('Excel.Application', sub {$_[0]->Quit;})
+ or die "Oops, cannot start Excel";
+ }
+
+ # get a new workbook
+ $book = $ex->Workbooks->Add;
+
+ # write to a particular cell
+ $sheet = $book->Worksheets(1);
+ $sheet->Cells(1,1)->{Value} = "foo";
+
+ # write a 2 rows by 3 columns range
+ $sheet->Range("A8:C9")->{Value} = [[ undef, 'Xyzzy', 'Plugh' ],
+ [ 42, 'Perl', 3.1415 ]];
+
+ # print "XyzzyPerl"
+ $array = $sheet->Range("A8:C9")->{Value};
+ for (@$array) {
+ for (@$_) {
+ print defined($_) ? "$_|" : "<undef>|";
+ }
+ print "\n";
+ }
+
+ # save and exit
+ $book->SaveAs( 'test.xls' );
+ undef $book;
+ undef $ex;
+
+Please note the destructor specified on the Win32::OLE->new method. It ensures
+that Excel will shutdown properly even if the Perl program dies. Otherwise
+there could be a process leak if your application dies after having opened
+an OLE instance of Excel. It is the responsibility of the module user to
+make sure that all OLE objects are cleaned up properly!
+
+Here is an example of using Variant data types.
+
+ use Win32::OLE;
+ use Win32::OLE::Variant;
+ $ex = Win32::OLE->new('Excel.Application', \&OleQuit) or die "oops\n";
+ $ex->{Visible} = 1;
+ $ex->Workbooks->Add;
+ # should generate a warning under -w
+ $ovR8 = Variant(VT_R8, "3 is a good number");
+ $ex->Range("A1")->{Value} = $ovR8;
+ $ex->Range("A2")->{Value} = Variant(VT_DATE, 'Jan 1,1970');
+
+ sub OleQuit {
+ my $self = shift;
+ $self->Quit;
+ }
+
+The above will put value "3" in cell A1 rather than the string
+"3 is a good number". Cell A2 will contain the date.
+
+Similarly, to invoke a method with some binary data, you can
+do the following:
+
+ $obj->Method( Variant(VT_UI1, "foo\000b\001a\002r") );
+
+Here is a wrapper class that basically delegates everything but
+new() and DESTROY(). The wrapper class shown here is another way to
+properly shut down connections if your application is liable to die
+without proper cleanup. Your own wrappers will probably do something
+more specific to the particular OLE object you may be dealing with,
+like overriding the methods that you may wish to enhance with your
+own.
+
+ package Excel;
+ use Win32::OLE;
+
+ sub new {
+ my $s = {};
+ if ($s->{Ex} = Win32::OLE->new('Excel.Application')) {
+ return bless $s, shift;
+ }
+ return undef;
+ }
+
+ sub DESTROY {
+ my $s = shift;
+ if (exists $s->{Ex}) {
+ print "# closing connection\n";
+ $s->{Ex}->Quit;
+ return undef;
+ }
+ }
+
+ sub AUTOLOAD {
+ my $s = shift;
+ $AUTOLOAD =~ s/^.*:://;
+ $s->{Ex}->$AUTOLOAD(@_);
+ }
+
+ 1;
+
+The above module can be used just like Win32::OLE, except that
+it takes care of closing connections in case of abnormal exits.
+Note that the effect of this specific example can be easier accomplished
+using the optional destructor argument of Win32::OLE::new:
+
+ my $Excel = Win32::OLE->new('Excel.Application', sub {$_[0]->Quit;});
+
+Note that the delegation shown in the earlier example is not the same as
+true subclassing with respect to further inheritance of method calls in your
+specialized object. See L<perlobj>, L<perltoot> and L<perlbot> for details.
+True subclassing (available by setting C<@ISA>) is also feasible,
+as the following example demonstrates:
+
+ #
+ # Add error reporting to Win32::OLE
+ #
+
+ package Win32::OLE::Strict;
+ use Carp;
+ use Win32::OLE;
+
+ use strict qw(vars);
+ use vars qw($AUTOLOAD @ISA);
+ @ISA = qw(Win32::OLE);
+
+ sub AUTOLOAD {
+ my $obj = shift;
+ $AUTOLOAD =~ s/^.*:://;
+ my $meth = $AUTOLOAD;
+ $AUTOLOAD = "SUPER::" . $AUTOLOAD;
+ my $retval = $obj->$AUTOLOAD(@_);
+ unless (defined($retval) || $AUTOLOAD eq 'DESTROY') {
+ my $err = Win32::OLE::LastError();
+ croak(sprintf("$meth returned OLE error 0x%08x",$err))
+ if $err;
+ }
+ return $retval;
+ }
+
+ 1;
+
+This package inherits the constructor new() from the Win32::OLE
+package. It is important to note that you cannot later rebless a
+Win32::OLE object as some information about the package is cached by
+the object. Always invoke the new() constructor through the right
+package!
+
+Here's how the above class will be used:
+
+ use Win32::OLE::Strict;
+ my $Excel = Win32::OLE::Strict->new('Excel.Application', 'Quit');
+ my $Books = $Excel->Workbooks;
+ $Books->UnknownMethod(42);
+
+In the sample above the call to UnknownMethod() will be caught with
+
+ UnknownMethod returned OLE error 0x80020009 at test.pl line 5
+
+because the Workbooks object inherits the class C<Win32::OLE::Strict> from the
+C<$Excel> object.
+
+=head1 NOTES
+
+=head2 Hints for Microsoft Office automation
+
+=over 8
+
+=item Documentation
+
+The object model for the Office applications is defined in the Visual Basic
+reference guides for the various applications. These are typically not
+installed by default during the standard installation. They can be added
+later by rerunning the setup program with the custom install option.
+
+=item Class, Method and Property names
+
+The names have been changed between different versions of Office. For
+example C<Application> was a method in Office 95 and is a property in
+Office97. Therefore it will not show up in the list of property names
+C<keys %$object> when querying an Office 95 object.
+
+The class names are not always identical to the method/property names
+producing the object. E.g. the C<Workbook> method returns an object of
+type C<Workbook> in Office 95 and C<_Workbook> in Office 97.
+
+=item Moniker (GetObject support)
+
+Office applications seem to implement file monikers only. For example
+it seems to be impossible to retrieve a specific worksheet object through
+C<GetObject("File.XLS!Sheet")>. Furthermore, in Excel 95 the moniker starts
+a Worksheet object and in Excel 97 it returns a Workbook object. You can use
+either the Win32::OLE::QueryObjectType class method or the $object->{Version}
+property to write portable code.
+
+=item Enumeration of collection objects
+
+Enumerations seem to be incompletely implemented. Office 95 application don't
+seem to support neither the Reset() nor the Clone() methods. The Clone()
+method is still unimplemented in Office 97. A single walk through the
+collection similar to Visual Basics C<for each> construct does work however.
+
+=item Localization
+
+Starting with Office 97 Microsoft has changed the localized class, method and
+property names back into English. Note that string, date and currency
+arguments are still subject to locale specific interpretation. Perl uses the
+system default locale for all OLE transaction whereas Visual Basic uses a
+type library specific locale. A Visual Basic script would use "R1C1" in string
+arguments to specify relative references. A Perl script running on a German
+language Windows would have to use "Z1S1". Set the LCID module option
+to an English locale to write portable scripts. This variable should
+not be changed after creating the OLE objects; some methods seem to randomly
+fail if the locale is changed on the fly.
+
+=item SaveAs method in Word 97 doesn't work
+
+This is an known bug in Word 97. Search the MS knowledge base for Word /
+Foxpro incompatibility. That problem applies to the Perl OLE interface as
+well. A workaround is to use the WordBasic compatibility object. It doesn't
+support all the options of the native method though.
+
+ $Word->WordBasic->FileSaveAs($file);
+
+The problem seems to be fixed by applying the Office 97 Service Release 1.
+
+=item Randomly failing method calls
+
+It seems like modifying objects that are not selected/activated is sometimes
+fragile. Most of these problems go away if the chart/sheet/document is
+selected or activated before being manipulated (just like an interactive
+user would automatically do it).
+
+=back
+
+=head2 Incompatibilities
+
+There are some incompatibilities with the version distributed by Activeware
+(as of build 306).
+
+=over 8
+
+=item 1
+
+The package name has changed from "OLE" to "Win32::OLE".
+
+=item 2
+
+All functions of the form "Win32::OLEFoo" are now "Win32::OLE::Foo",
+though the old names are temporarily accommodated. Win32::OLECreateObject()
+was changed to Win32::OLE::CreateObject(), and is now called
+Win32::OLE::new() bowing to established convention for naming constructors.
+The old names should be considered deprecated, and will be removed in the
+next version.
+
+=item 3
+
+Package "OLE::Variant" is now "Win32::OLE::Variant".
+
+=item 4
+
+The Variant function is new, and is exported by default. So are
+all the VT_XXX type constants.
+
+=item 5
+
+The support for collection objects has been moved into the package
+Win32::OLE::Enum. The C<keys %$object> method is now used to enumerate
+the properties of the object.
+
+=back
+
+=head2 Bugs and Limitations
+
+=over 8
+
+=item *
+
+To invoke a native OLE method with the same name as one of the
+Win32::OLE methods (C<Dispatch>, C<Invoke>, C<SetProperty>, C<DESTROY>,
+etc.), you have to use the C<Invoke> method:
+
+ $Object->Invoke('Dispatch', @AdditionalArgs);
+
+The same is true for names exported by the Exporter or the Dynaloader
+modules, e.g.: C<export>, C<export_to_level>, C<import>,
+C<_push_tags>, C<export_tags>, C<export_ok_tags>, C<export_fail>,
+C<require_version>, C<dl_load_flags>,
+C<croak>, C<bootstrap>, C<dl_findfile>, C<dl_expandspec>,
+C<dl_find_symbol_anywhere>, C<dl_load_file>, C<dl_find_symbol>,
+C<dl_undef_symbols>, C<dl_install_xsub> and C<dl_error>.
+
+=back
+
+=head1 SEE ALSO
+
+The documentation for L<Win32::OLE::Const>, L<Win32::OLE::Enum>,
+L<Win32::OLE::NLS> and L<Win32::OLE::Variant> contains additional
+information about OLE support for Perl on Win32.
+
+=head1 AUTHORS
+
+Originally put together by the kind people at Hip and Activeware.
+
+Gurusamy Sarathy <gsar@cpan.org> subsequently fixed several
+major bugs, memory leaks, and reliability problems, along with some
+redesign of the code.
+
+Jan Dubois <jand@activestate.com> pitched in with yet more massive redesign,
+added support for named parameters, and other significant enhancements.
+He's been hacking on it ever since.
+
+Please send questions about problems with this module to the
+Perl-Win32-Users mailinglist at ActiveState.com. The mailinglist charter
+requests that you put an [OLE] tag somewhere on the subject line (for OLE
+related questions only, of course).
+
+=head1 COPYRIGHT
+
+ (c) 1995 Microsoft Corporation. All rights reserved.
+ Developed by ActiveWare Internet Corp., now known as
+ ActiveState Tool Corp., http://www.ActiveState.com
+
+ Other modifications Copyright (c) 1997-2006 by Gurusamy Sarathy
+ <gsar@cpan.org> and Jan Dubois <jand@activestate.com>
+
+ You may distribute under the terms of either the GNU General Public
+ License or the Artistic License, as specified in the README file.
+
+=head1 VERSION
+
+Version 0.1712 14 May 2014
+
+=cut
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/OLE/Const.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/OLE/Const.pm
new file mode 100644
index 0000000000..d0fe00b9ea
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/OLE/Const.pm
@@ -0,0 +1,201 @@
+# The documentation is at the __END__
+
+package Win32::OLE::Const;
+
+use strict;
+use Carp;
+use Win32::OLE;
+
+my $Typelibs;
+sub _Typelib {
+ my ($clsid,$title,$version,$langid,$filename) = @_;
+ # Filenames might have a resource index appended to it.
+ $filename = $1 if $filename =~ /^(.*\.(?:dll|exe))(\\\d+)$/i;
+ # Ignore if it looks like a file but doesn't exist.
+ # We don't verify existence of monikers or filenames
+ # without a full pathname.
+ return if $filename =~ /^\w:\\.*\.(exe|dll)$/ && !-f $filename;
+ push @$Typelibs, \@_;
+}
+unless (__PACKAGE__->_Typelibs("TypeLib")) {
+ warn("Cannot access HKEY_CLASSES_ROOT\\Typelib");
+}
+# Enumerate 32bit type libraries on Win64
+__PACKAGE__->_Typelibs("Wow6432Node\\TypeLib");
+
+sub import {
+ my ($self,$name,$major,$minor,$language,$codepage) = @_;
+ return unless defined($name) && $name !~ /^\s*$/;
+ $self->Load($name,$major,$minor,$language,$codepage,scalar caller);
+}
+
+sub EnumTypeLibs {
+ my ($self,$callback) = @_;
+ foreach (@$Typelibs) { &$callback(@$_) }
+ return;
+}
+
+sub Load {
+ my ($self,$name,$major,$minor,$language,$codepage,$caller) = @_;
+
+ if (UNIVERSAL::isa($name,'Win32::OLE')) {
+ my $typelib = $name->GetTypeInfo->GetContainingTypeLib;
+ return _Constants($typelib, undef);
+ }
+
+ undef $minor unless defined $major;
+ my $typelib = $self->LoadRegTypeLib($name,$major,$minor,
+ $language,$codepage);
+ return _Constants($typelib, $caller);
+}
+
+sub LoadRegTypeLib {
+ my ($self,$name,$major,$minor,$language,$codepage) = @_;
+ undef $minor unless defined $major;
+
+ unless (defined($name) && $name !~ /^\s*$/) {
+ carp "Win32::OLE::Const->Load: No or invalid type library name";
+ return;
+ }
+
+ my @found;
+ foreach my $Typelib (@$Typelibs) {
+ my ($clsid,$title,$version,$langid,$filename) = @$Typelib;
+ next unless $title =~ /^$name/;
+ next unless $version =~ /^([0-9a-fA-F]+)\.([0-9a-fA-F]+)$/;
+ my ($maj,$min) = (hex($1), hex($2));
+ next if defined($major) && $maj != $major;
+ next if defined($minor) && $min < $minor;
+ next if defined($language) && $language != $langid;
+ push @found, [$clsid,$maj,$min,$langid,$filename];
+ }
+
+ unless (@found) {
+ carp "No type library matching \"$name\" found";
+ return;
+ }
+
+ @found = sort {
+ # Prefer greater version number
+ my $res = $b->[1] <=> $a->[1];
+ $res = $b->[2] <=> $a->[2] if $res == 0;
+ # Prefer default language for equal version numbers
+ $res = -1 if $res == 0 && $a->[3] == 0;
+ $res = 1 if $res == 0 && $b->[3] == 0;
+ $res;
+ } @found;
+
+ #printf "Loading %s\n", join(' ', @{$found[0]});
+ return _LoadRegTypeLib(@{$found[0]},$codepage);
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Win32::OLE::Const - Extract constant definitions from TypeLib
+
+=head1 SYNOPSIS
+
+ use Win32::OLE::Const 'Microsoft Excel';
+ printf "xlMarkerStyleDot = %d\n", xlMarkerStyleDot;
+
+ my $wd = Win32::OLE::Const->Load("Microsoft Word 8\\.0 Object Library");
+ foreach my $key (keys %$wd) {
+ printf "$key = %s\n", $wd->{$key};
+ }
+
+=head1 DESCRIPTION
+
+This modules makes all constants from a registered OLE type library
+available to the Perl program. The constant definitions can be
+imported as functions, providing compile time name checking.
+Alternatively the constants can be returned in a hash reference
+which avoids defining lots of functions of unknown names.
+
+=head2 Functions/Methods
+
+=over 4
+
+=item use Win32::OLE::Const
+
+The C<use> statement can be used to directly import the constant names
+and values into the users namespace.
+
+ use Win32::OLE::Const (TYPELIB,MAJOR,MINOR,LANGUAGE);
+
+The TYPELIB argument specifies a regular expression for searching
+through the registry for the type library. Note that this argument is
+implicitly prefixed with C<^> to speed up matches in the most common
+cases. Use a typelib name like ".*Excel" to match anywhere within the
+description. TYPELIB is the only required argument.
+
+The MAJOR and MINOR arguments specify the requested version of
+the type specification. If the MAJOR argument is used then only
+typelibs with exactly this major version number will be matched. The
+MINOR argument however specifies the minimum acceptable minor version.
+MINOR is ignored if MAJOR is undefined.
+
+If the LANGUAGE argument is used then only typelibs with exactly this
+language id will be matched.
+
+The module will select the typelib with the highest version number
+satisfying the request. If no language id is specified then a the default
+language (0) will be preferred over the others.
+
+Note that only constants with valid Perl variable names will be exported,
+i.e. names matching this regexp: C</^[a-zA-Z_][a-zA-Z0-9_]*$/>.
+
+=item Win32::OLE::Const->Load
+
+The Win32::OLE::Const->Load method returns a reference to a hash of
+constant definitions.
+
+ my $const = Win32::OLE::Const->Load(TYPELIB,MAJOR,MINOR,LANGUAGE);
+
+The parameters are the same as for the C<use> case.
+
+This method is generally preferable when the typelib uses a non-english
+language and the constant names contain locale specific characters not
+allowed in Perl variable names.
+
+Another advantage is that all available constants can now be enumerated.
+
+The load method also accepts an OLE object as a parameter. In this case
+the OLE object is queried about its containing type library and no registry
+search is done at all. Interestingly this seems to be slower.
+
+=back
+
+=head1 EXAMPLES
+
+The first example imports all Excel constants names into the main namespace
+and prints the value of xlMarkerStyleDot (-4118).
+
+ use Win32::OLE::Const ('Microsoft Excel 8.0 Object Library');
+ print "xlMarkerStyleDot = %d\n", xlMarkerStyleDot;
+
+The second example returns all Word constants in a hash ref.
+
+ use Win32::OLE::Const;
+ my $wd = Win32::OLE::Const->Load("Microsoft Word 8.0 Object Library");
+ foreach my $key (keys %$wd) {
+ printf "$key = %s\n", $wd->{$key};
+ }
+ printf "wdGreen = %s\n", $wd->{wdGreen};
+
+The last example uses an OLE object to specify the type library:
+
+ use Win32::OLE;
+ use Win32::OLE::Const;
+ my $Excel = Win32::OLE->new('Excel.Application', 'Quit');
+ my $xl = Win32::OLE::Const->Load($Excel);
+
+
+=head1 AUTHORS/COPYRIGHT
+
+This module is part of the Win32::OLE distribution.
+
+=cut
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/OLE/Enum.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/OLE/Enum.pm
new file mode 100644
index 0000000000..6047d2c827
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/OLE/Enum.pm
@@ -0,0 +1,95 @@
+# The documentation is at the __END__
+
+package Win32::OLE::Enum;
+1;
+
+# everything is pure XS in Win32::OLE::Enum
+# - new
+# - DESTROY
+#
+# - All
+# - Clone
+# - Next
+# - Reset
+# - Skip
+
+__END__
+
+=head1 NAME
+
+Win32::OLE::Enum - OLE Automation Collection Objects
+
+=head1 SYNOPSIS
+
+ my $Sheets = $Excel->Workbooks(1)->Worksheets;
+ my $Enum = Win32::OLE::Enum->new($Sheets);
+ my @Sheets = $Enum->All;
+
+ while (defined(my $Sheet = $Enum->Next)) { ... }
+
+=head1 DESCRIPTION
+
+This module provides an interface to OLE collection objects from
+Perl. It defines an enumerator object closely mirroring the
+functionality of the IEnumVARIANT interface.
+
+Please note that the Reset() method is not available in all implementations
+of OLE collections (like Excel 7). In that case the Enum object is good
+only for a single walk through of the collection.
+
+=head2 Functions/Methods
+
+=over 8
+
+=item Win32::OLE::Enum->new($object)
+
+Creates an enumerator for $object, which must be a valid OLE collection
+object. Note that correctly implemented collection objects must support
+the C<Count> and C<Item> methods, so creating an enumerator is not always
+necessary.
+
+=item $Enum->All()
+
+Returns a list of all objects in the collection. You have to call
+$Enum->Reset() before the enumerator can be used again. The previous
+position in the collection is lost.
+
+This method can also be called as a class method:
+
+ my @list = Win32::OLE::Enum->All($Collection);
+
+=item $Enum->Clone()
+
+Returns a clone of the enumerator maintaining the current position within
+the collection (if possible). Note that the C<Clone> method is often not
+implemented. Use $Enum->Clone() in an eval block to avoid dying if you
+are not sure that Clone is supported.
+
+=item $Enum->Next( [$count] )
+
+Returns the next element of the collection. In a list context the optional
+$count argument specifies the number of objects to be returned. In a scalar
+context only the last of at most $count retrieved objects is returned. The
+default for $count is 1.
+
+=item $Enum->Reset()
+
+Resets the enumeration sequence to the beginning. There is no guarantee that
+the exact same set of objects will be enumerated again (e.g. when enumerating
+files in a directory). The methods return value indicates the success of the
+operation. (Note that the Reset() method seems to be unimplemented in some
+applications like Excel 7. Use it in an eval block to avoid dying.)
+
+=item $Enum->Skip( [$count] )
+
+Skip the next $count elements of the enumeration. The default for $count is 1.
+The functions returns TRUE if at least $count elements could be skipped. It
+returns FALSE if not enough elements were left.
+
+=back
+
+=head1 AUTHORS/COPYRIGHT
+
+This module is part of the Win32::OLE distribution.
+
+=cut
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/OLE/Lite.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/OLE/Lite.pm
new file mode 100644
index 0000000000..66b5e50ac0
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/OLE/Lite.pm
@@ -0,0 +1,224 @@
+package Win32::OLE;
+
+sub _croak { require Carp; Carp::croak(@_) }
+
+unless (defined &Dispatch) {
+ DynaLoader::boot_DynaLoader('DynaLoader')
+ unless defined(&DynaLoader::dl_load_file);
+ my $file;
+ foreach my $dir (@INC) {
+ my $try = "$dir/auto/Win32/OLE/OLE.dll";
+ last if $file = (-f $try && $try);
+ }
+ _croak("Can't locate loadable object for module Win32::OLE".
+ " in \@INC (\@INC contains: @INC)")
+ unless $file; # wording similar to error from 'require'
+
+ my $libref = DynaLoader::dl_load_file($file, 0) or
+ _croak("Can't load '$file' for module Win32::OLE: ".
+ DynaLoader::dl_error()."\n");
+
+ my $boot_symbol_ref = DynaLoader::dl_find_symbol($libref, "boot_Win32__OLE")
+ or _croak("Can't find 'boot_Win32__OLE' symbol in $file\n");
+
+ my $xs = DynaLoader::dl_install_xsub("Win32::OLE::bootstrap",
+ $boot_symbol_ref, $file);
+ &$xs('Win32::OLE');
+}
+
+if (defined &DB::sub && !defined $_Unique) {
+ warn "Win32::OLE operating in debugging mode: _Unique => 1\n";
+ $_Unique = 1;
+}
+
+$Warn = 1;
+
+sub CP_ACP {0;} # ANSI codepage
+sub CP_OEMCP {1;} # OEM codepage
+sub CP_MACCP {2;}
+sub CP_UTF7 {65000;}
+sub CP_UTF8 {65001;}
+
+sub DISPATCH_METHOD {1;}
+sub DISPATCH_PROPERTYGET {2;}
+sub DISPATCH_PROPERTYPUT {4;}
+sub DISPATCH_PROPERTYPUTREF {8;}
+
+sub COINIT_MULTITHREADED {0;} # Default
+sub COINIT_APARTMENTTHREADED {2;} # Use single threaded apartment model
+
+# Bogus COINIT_* values to indicate special cases:
+sub COINIT_OLEINITIALIZE {-1;} # Use OleInitialize instead of CoInitializeEx
+sub COINIT_NO_INITIALIZE {-2;} # We are already initialized, just believe me
+
+sub HRESULT {
+ my $hr = shift;
+ $hr -= 2**32 if $hr & 0x80000000;
+ return $hr;
+}
+
+# CreateObject is defined here only because it is documented in the
+# "Learning Perl on Win32 Systems" Gecko book. Please use Win32::OLE->new().
+sub CreateObject {
+ if (ref($_[0]) && UNIVERSAL::isa($_[0],'Win32::OLE')) {
+ $AUTOLOAD = ref($_[0]) . '::CreateObject';
+ goto &AUTOLOAD;
+ }
+
+ # Hack to allow C<$obj = CreateObject Win32::OLE 'My.App';>. Although this
+ # is contrary to the Gecko, we just make it work since it doesn't hurt.
+ return Win32::OLE->new($_[1]) if $_[0] eq 'Win32::OLE';
+
+ # Gecko form: C<$success = Win32::OLE::CreateObject('My.App',$obj);>
+ $_[1] = Win32::OLE->new($_[0]);
+ return defined $_[1];
+}
+
+sub LastError {
+ unless (defined $_[0]) {
+ # Win32::OLE::LastError() will always return $Win32::OLE::LastError
+ return $LastError;
+ }
+
+ if (ref($_[0]) && UNIVERSAL::isa($_[0],'Win32::OLE')) {
+ $AUTOLOAD = ref($_[0]) . '::LastError';
+ goto &AUTOLOAD;
+ }
+
+ #no strict 'refs';
+ my $LastError = "$_[0]::LastError";
+ $$LastError = $_[1] if defined $_[1];
+ return $$LastError;
+}
+
+my $Options = "^(?:CP|LCID|Warn|Variant|_NewEnum|_Unique)\$";
+
+sub Option {
+ if (ref($_[0]) && UNIVERSAL::isa($_[0],'Win32::OLE')) {
+ $AUTOLOAD = ref($_[0]) . '::Option';
+ goto &AUTOLOAD;
+ }
+
+ my $class = shift;
+
+ if (@_ == 1) {
+ my $option = shift;
+ return ${"${class}::$option"} if $option =~ /$Options/o;
+ _croak("Invalid $class option: $option");
+ }
+
+ while (@_) {
+ my ($option,$value) = splice @_, 0, 2;
+ _croak("Invalid $class option: $option") if $option !~ /$Options/o;
+ ${"${class}::$option"} = $value;
+ $class->_Unique() if $option eq "_Unique";
+ }
+}
+
+sub Invoke {
+ my ($self,$method,@args) = @_;
+ $self->Dispatch($method, my $retval, @args);
+ return $retval;
+}
+
+sub LetProperty {
+ my ($self,$method,@args) = @_;
+ $self->Dispatch([DISPATCH_PROPERTYPUT, $method], my $retval, @args);
+ return $retval;
+}
+
+sub SetProperty {
+ my ($self,$method,@args) = @_;
+ my $wFlags = DISPATCH_PROPERTYPUT;
+ if (@args) {
+ # If the value is an object then it will be set by reference!
+ my $value = $args[-1];
+ if (UNIVERSAL::isa($value, 'Win32::OLE')) {
+ $wFlags = DISPATCH_PROPERTYPUTREF;
+ }
+ elsif (UNIVERSAL::isa($value,'Win32::OLE::Variant')) {
+ my $type = $value->Type & ~0xfff; # VT_TYPEMASK
+ # VT_DISPATCH and VT_UNKNOWN represent COM objects
+ $wFlags = DISPATCH_PROPERTYPUTREF if $type == 9 || $type == 13;
+ }
+ }
+ $self->Dispatch([$wFlags, $method], my $retval, @args);
+ return $retval;
+}
+
+sub AUTOLOAD {
+ my $self = shift;
+ my $autoload = substr $AUTOLOAD, rindex($AUTOLOAD, ':')+1;
+ _croak("Cannot autoload class method \"$autoload\"")
+ unless ref($self) && UNIVERSAL::isa($self, 'Win32::OLE');
+ my $success = $self->Dispatch($autoload, my $retval, @_);
+ unless (defined $success || ($^H & 0x200) != 0) {
+ # Retry default method if C<no strict 'subs';>
+ $self->Dispatch(undef, $retval, $autoload, @_);
+ }
+ return $retval;
+}
+
+sub in {
+ my @res;
+ while (@_) {
+ my $this = shift;
+ if (UNIVERSAL::isa($this, 'Win32::OLE')) {
+ push @res, Win32::OLE::Enum->All($this);
+ }
+ elsif (ref($this) eq 'ARRAY') {
+ push @res, @$this;
+ }
+ else {
+ push @res, $this;
+ }
+ }
+ return @res;
+}
+
+sub valof {
+ my $arg = shift;
+ if (UNIVERSAL::isa($arg, 'Win32::OLE')) {
+ require Win32::OLE::Variant;
+ my ($class) = overload::StrVal($arg) =~ /^([^=]+)=/;
+ #no strict 'refs';
+ local $Win32::OLE::CP = ${"${class}::CP"};
+ local $Win32::OLE::LCID = ${"${class}::LCID"};
+ #use strict 'refs';
+ # VT_EMPTY variant for return code
+ my $variant = Win32::OLE::Variant->new;
+ $arg->Dispatch(undef, $variant);
+ return $variant->Value;
+ }
+ $arg = $arg->Value if UNIVERSAL::can($arg, 'Value');
+ return $arg;
+}
+
+sub with {
+ my $object = shift;
+ while (@_) {
+ my $property = shift;
+ $object->{$property} = shift;
+ }
+}
+
+########################################################################
+
+package Win32::OLE::Tie;
+
+# Only retry default method under C<no strict 'subs';>
+sub FETCH {
+ my ($self,$key) = @_;
+ if ($key eq "_NewEnum") {
+ (my $class = ref $self) =~ s/::Tie$//;
+ return [Win32::OLE::Enum->All($self)] if ${"${class}::_NewEnum"};
+ }
+ $self->Fetch($key, !$Win32::OLE::Strict);
+}
+
+sub STORE {
+ my ($self,$key,$value) = @_;
+ $self->Store($key, $value, !$Win32::OLE::Strict);
+}
+
+1;
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/OLE/NEWS.pod b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/OLE/NEWS.pod
new file mode 100644
index 0000000000..217fe4a6fc
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/OLE/NEWS.pod
@@ -0,0 +1,380 @@
+=pod
+
+=head1 NAME
+
+Win32::OLE::NEWS - What's new in Win32::OLE
+
+This file contains a history of user visible changes to the
+Win32::OLE::* modules. Only new features and major bug fixes that
+might affect backwards compatibility are included.
+
+=head1 Version 0.18
+
+=head2 VT_CY and VT_DECIMAL return values handled differently
+
+The new C<Variant> option enables values of VT_CY or VT_DECIMAL type
+to be returned as Win32::OLE::Variant objects instead of being
+converted into strings and numbers respectively. This is similar to
+the change in Win32::OLE version 0.12 to VT_DATE and VT_ERROR values.
+The Win32::OLE::Variant module must be included to make sure that
+VT_CY and VT_DECIMAL values behave as before in numeric or string
+contexts.
+
+Because the new behavior is potentially incompatible, it must be
+explicitly enabled:
+
+ Win32::OLE->Option(Variant => 1);
+
+
+=head1 Version 0.17
+
+=head2 New nullstring() function in Win32::OLE::Variant
+
+The nullstring() function returns a VT_BSTR variant containing a NULL
+string pointer. Note that this is not the same as a VT_BSTR variant
+containing the empty string "".
+
+The nullstring() return value is equivalent to the Visual Basic
+C<vbNullString> constant.
+
+
+=head1 Version 0.16
+
+=head2 Improved Unicode support
+
+Passing Unicode strings to methods and properties as well as returning
+Unicode strings back to Perl works now with both Perl 5.6 and 5.8.
+Note that the Unicode support in 5.8 is much more complete than in 5.6
+or 5.6.1.
+
+C<Unicode::String> objects can now be passed to methods or assigned to
+properties.
+
+You must enable Unicode support by switching Win32::OLE to the UTF8
+codepage:
+
+ Win32::OLE->Option(CP => Win32::OLE::CP_UTF8());
+
+
+=head1 Version 0.13
+
+=head2 New nothing() function in Win32::OLE::Variant
+
+The nothing() function returns an empty VT_DISPATCH variant. It can be
+used to clear an object reference stored in a property
+
+ use Win32::OLE::Variant qw(:DEFAULT nothing);
+ # ...
+ $object->{Property} = nothing;
+
+This has the same effect as the Visual Basic statement
+
+ Set object.Property = Nothing
+
+=head2 New _NewEnum and _Unique options
+
+There are two new options available for the Win32::OLE->Option class
+method: C<_NewEnum> provides the elements of a collection object
+directly as the value of a C<_NewEnum> property. The C<_Unique>
+option guarantees that Win32::OLE will not create multiple proxy
+objects for the same underlying COM/OLE object.
+
+Both options are only really useful to tree traversal programs or
+during debugging.
+
+
+=head1 Version 0.12
+
+=head2 Additional error handling functionality
+
+The Warn option can now be set to a CODE reference too. For example,
+
+ Win32::OLE->Option(Warn => 3);
+
+could now be written as
+
+ Win32::OLE->Option(Warn => \&Carp::croak);
+
+This can even be used to emulate the VisualBasic C<On Error Goto
+Label> construct:
+
+ Win32::OLE->Option(Warn => sub {goto CheckError});
+ # ... your normal OLE code here ...
+
+ CheckError:
+ # ... your error handling code here ...
+
+=head2 Builtin event loop
+
+Processing OLE events required a polling loop before, e.g.
+
+ my $Quit;
+ #...
+ until ($Quit) {
+ Win32::OLE->SpinMessageLoop;
+ Win32::Sleep(100);
+ }
+ package BrowserEvents;
+ sub OnQuit { $Quit = 1 }
+
+This is inefficient and a bit odd. This version of Win32::OLE now
+supports a standard messageloop:
+
+ Win32::OLE->MessageLoop();
+
+ package BrowserEvents;
+ sub OnQuit { Win32::OLE->QuitMessageLoop }
+
+=head2 Free unused OLE libraries
+
+Previous versions of Win32::OLE would call the CoFreeUnusedLibraries()
+API whenever an OLE object was destroyed. This made sure that OLE
+libraries would be unloaded as soon as they were no longer needed.
+Unfortunately, objects implemented in Visual Basic tend to crash
+during this call, as they pretend to be ready for unloading, when in
+fact, they aren't.
+
+The unloading of object libraries is really only important for long
+running processes that might instantiate a huge number of B<different>
+objects over time. Therefore this API is no longer called
+automatically. The functionality is now available explicitly to those
+who want or need it by calling a Win32::OLE class method:
+
+ Win32::OLE->FreeUnusedLibraries();
+
+=head2 The "Win32::OLE" article from "The Perl Journal #10"
+
+The article is Copyright 1998 by I<The Perl
+Journal>. http://www.tpj.com
+
+It originally appeared in I<The Perl Journal> # 10 and appears here
+courtesy of Jon Orwant and I<The Perl Journal>. The sample code from
+the article is in the F<eg/tpj.pl> file.
+
+=head2 VARIANT->Put() bug fixes
+
+The Put() method didn't work correctly for arrays of type VT_BSTR,
+VT_DISPATH or VT_UNKNOWN. This has been fixed.
+
+=head2 Error message fixes
+
+Previous versions of Win32::OLE gave a wrong argument index for some
+OLE error messages (the number was too large by 1). This should be
+fixed now.
+
+=head2 VT_DATE and VT_ERROR return values handled differently
+
+Method calls and property accesses returning a VT_DATE or VT_ERROR
+value would previously translate the value to string or integer
+format. This has been changed to return a Win32::OLE::Variant object.
+The return values will behave as before if the Win32::OLE::Variant
+module is being used. This module overloads the conversion of
+the objects to strings and numbers.
+
+
+=head1 Version 0.11 (changes since 0.1008)
+
+=head2 new DHTML typelib browser
+
+The Win32::OLE distribution now contains a type library browser. It
+is written in PerlScript, generating dynamic HTML. It requires
+Internet Explorer 4.0 or later. You'll find it in
+F<browser/Browser.html>. It should be available in the ActivePerl
+HTML help under Win32::OLE::Browser.
+
+After selecting a library, type or member you can press F1 to call up
+the corresponding help file at the appropriate location.
+
+=head2 VT_DECIMAL support
+
+The Win32::OLE::Variant module now supports VT_DECIMAL variants too.
+They are not "officially" allowed in OLE Automation calls, but even
+Microsoft's "ActiveX Data Objects" sometimes returns VT_DECIMAL
+values.
+
+VT_DECIMAL variables are stored as 96-bit integers scaled by a
+variable power of 10. The power of 10 scaling factor specifies the
+number of digits to the right of the decimal point, and ranges from 0
+to 28. With a scale of 0 (no decimal places), the largest possible
+value is +/-79,228,162,514,264,337,593,543,950,335. With a 28 decimal
+places, the largest value is +/-7.9228162514264337593543950335 and the
+smallest, non-zero value is +/-0.0000000000000000000000000001.
+
+=head1 Version 0.1008
+
+=head2 new LetProperty() object method
+
+In Win32::OLE property assignment using the hash syntax is equivalent
+to the Visual Basic C<Set> syntax (I<by reference> assignment):
+
+ $Object->{Property} = $OtherObject;
+
+corresponds to this Visual Basic statement:
+
+ Set Object.Property = OtherObject
+
+To get the I<by value> treatment of the Visual Basic C<Let> statement
+
+ Object.Property = OtherObject
+
+you have to use the LetProperty() object method in Perl:
+
+ $Object->LetProperty($Property, $OtherObject);
+
+=head2 new HRESULT() function
+
+The HRESULT() function converts an unsigned number into a signed HRESULT
+error value as used by OLE internally. This is necessary because Perl
+treats all hexadecimal constants as unsigned. To check if the last OLE
+function returned "Member not found" (0x80020003) you can write:
+
+ if (Win32::OLE->LastError == HRESULT(0x80020003)) {
+ # your error recovery here
+ }
+
+=head1 Version 0.1007 (changes since 0.1005)
+
+=head2 OLE Event support
+
+This version of Win32::OLE contains B<ALPHA> level support for OLE events. The
+user interface is still subject to change. There are ActiveX objects / controls
+that don't fire events under the current implementation.
+
+Events are enabled for a specific object with the Win32::OLE->WithEvents()
+class method:
+
+ Win32::OLE->WithEvents(OBJECT, HANDLER, INTERFACE)
+
+Please read further documentation in Win32::OLE.
+
+=head2 GetObject() and GetActiveObject() now support optional DESTRUCTOR argument
+
+It is now possible to specify a DESTRUCTOR argument to the GetObject() and
+GetActiveObject() class methods. They work identical to the new() DESTRUCTOR
+argument.
+
+=head2 Remote object instantiation via DCOM
+
+This has actually been in Win32::OLE since 0.0608, but somehow never got
+documented. You can provide an array reference in place of the usual PROGID
+parameter to Win32::OLE->new():
+
+ OBJ = Win32::OLE->new([MACHINE, PRODID]);
+
+The array must contain two elements: the name of the MACHINE and the PROGID.
+This will try to create the object on the remote MACHINE.
+
+=head2 Enumerate all Win32::OLE objects
+
+This class method returns the number Win32::OLE objects currently in
+existence. It will call the optional CALLBACK function for each of
+these objects:
+
+ $Count = Win32::OLE->EnumAllObjects(sub {
+ my $Object = shift;
+ my $Class = Win32::OLE->QueryObjectType($Object);
+ printf "# Object=%s Class=%s\n", $Object, $Class;
+ });
+
+The EnumAllObjects() method is primarily a debugging tool. It can be
+used e.g. in an END block to check if all external connections have
+been properly destroyed.
+
+=head2 The VARIANT->Put() method now returns the VARIANT object itself
+
+This allows chaining of Put() method calls to set multiple values in an
+array variant:
+
+ $Array->Put(0,0,$First_value)->Put(0,1,$Another_value);
+
+=head2 The VARIANT->Put(ARRAYREF) form allows assignment to a complete SAFEARRAY
+
+This allows automatic conversion from a list of lists to a SAFEARRAY.
+You can now write:
+
+ my $Array = Variant(VT_ARRAY|VT_R8, [1,2], 2);
+ $Array->Put([[1,2], [3,4]]);
+
+instead of the tedious:
+
+ $Array->Put(1,0,1);
+ $Array->Put(1,1,2);
+ $Array->Put(2,0,3);
+ $Array->Put(2,1,4);
+
+=head2 New Variant formatting methods
+
+There are four new methods for formatting variant values: Currency(), Date(),
+Number() and Time(). For example:
+
+ my $v = Variant(VT_DATE, "April 1 99");
+ print $v->Date(DATE_LONGDATE), "\n";
+ print $v->Date("ddd',' MMM dd yy"), "\n";
+
+will print:
+
+ Thursday, April 01, 1999
+ Thu, Apr 01 99
+
+=head2 new Win32::OLE::NLS methods: SendSettingChange() and SetLocaleInfo()
+
+SendSettingChange() sends a WM_SETTINGCHANGE message to all top level windows.
+
+SetLocaleInfo() allows changing elements in the user override section of the
+locale database. Unfortunately these changes are not automatically available
+to further Variant formatting; you have to call SendSettingChange() first.
+
+=head2 Win32::OLE::Const now correctly treats version numbers as hex
+
+The minor and major version numbers of type libraries have been treated as
+decimal. This was wrong. They are now correctly decoded as hex.
+
+=head2 more robust global destruction of Win32::OLE objects
+
+The final destruction of Win32::OLE objects has always been somewhat fragile.
+The reason for this is that Perl doesn't honour reference counts during global
+destruction but destroys objects in seemingly random order. This can lead
+to leaked database connections or unterminated external objects. The only
+solution was to make all objects lexical and hope that no object would be
+trapped in a closure. Alternatively all objects could be explicitly set to
+C<undef>, which doesn't work very well with exception handling.
+
+With version 0.1007 of Win32::OLE this problem should be gone: The module
+keeps a list of active Win32::OLE objects. It uses an END block to destroy
+all objects at program termination I<before> the Perl's global destruction
+starts. Objects still existing at program termination are now destroyed in
+reverse order of creation. The effect is similar to explicitly calling
+Win32::OLE->Uninitialize() just prior to termination.
+
+=head1 Version 0.1005 (changes since 0.1003)
+
+Win32::OLE 0.1005 has been release with ActivePerl build 509. It is also
+included in the I<Perl Resource Kit for Win32> Update.
+
+=head2 optional DESTRUCTOR for GetActiveObject() GetObject() class methods
+
+The GetActiveObject() and GetObject() class method now also support an
+optional DESTRUCTOR parameter just like Win32::OLE->new(). The DESTRUCTOR
+is executed when the last reference to this object goes away. It is
+generally considered C<impolite> to stop applications that you did not
+start yourself.
+
+=head2 new Variant object method: $object->Copy()
+
+See L<Win32::OLE::Variant/Copy([DIM])>.
+
+=head2 new Win32::OLE->Option() class method
+
+The Option() class method can be used to inspect and modify
+L<Win32::OLE/Module Options>. The single argument form retrieves
+the value of an option:
+
+ my $CP = Win32::OLE->Option('CP');
+
+A single call can be used to set multiple options simultaneously:
+
+ Win32::OLE->Option(CP => CP_ACP, Warn => 3);
+
+Currently the following options exist: CP, LCID and C<Warn>.
+
+=cut
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/OLE/NLS.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/OLE/NLS.pm
new file mode 100644
index 0000000000..84ea0c7724
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/OLE/NLS.pm
@@ -0,0 +1,968 @@
+# The documentation is at the __END__
+
+package Win32::OLE::NLS;
+require Win32::OLE; # Make sure the XS bootstrap has been called
+
+use strict;
+use vars qw(@EXPORT @EXPORT_OK %EXPORT_TAGS @ISA);
+
+use Exporter;
+@ISA = qw(Exporter);
+
+@EXPORT = qw(
+ CompareString
+ LCMapString
+ GetLocaleInfo
+ GetStringType
+ GetSystemDefaultLangID
+ GetSystemDefaultLCID
+ GetUserDefaultLangID
+ GetUserDefaultLCID
+
+ MAKELANGID
+ PRIMARYLANGID
+ SUBLANGID
+ LANG_SYSTEM_DEFAULT
+ LANG_USER_DEFAULT
+ MAKELCID
+ LANGIDFROMLCID
+ LOCALE_SYSTEM_DEFAULT
+ LOCALE_USER_DEFAULT
+ );
+
+@EXPORT_OK = qw(SetLocaleInfo SendSettingChange);
+
+%EXPORT_TAGS =
+(
+ CT => [qw(CT_CTYPE1 CT_CTYPE2 CT_CTYPE3)],
+ C1 => [qw(C1_UPPER C1_LOWER C1_DIGIT C1_SPACE C1_PUNCT
+ C1_CNTRL C1_BLANK C1_XDIGIT C1_ALPHA)],
+ C2 => [qw(C2_LEFTTORIGHT C2_RIGHTTOLEFT C2_EUROPENUMBER
+ C2_EUROPESEPARATOR C2_EUROPETERMINATOR C2_ARABICNUMBER
+ C2_COMMONSEPARATOR C2_BLOCKSEPARATOR C2_SEGMENTSEPARATOR
+ C2_WHITESPACE C2_OTHERNEUTRAL C2_NOTAPPLICABLE)],
+ C3 => [qw(C3_NONSPACING C3_DIACRITIC C3_VOWELMARK C3_SYMBOL C3_KATAKANA
+ C3_HIRAGANA C3_HALFWIDTH C3_FULLWIDTH C3_IDEOGRAPH C3_KASHIDA
+ C3_ALPHA C3_NOTAPPLICABLE)],
+ NORM => [qw(NORM_IGNORECASE NORM_IGNORENONSPACE NORM_IGNORESYMBOLS
+ NORM_IGNOREWIDTH NORM_IGNOREKANATYPE NORM_IGNOREKASHIDA)],
+ LCMAP => [qw(LCMAP_LOWERCASE LCMAP_UPPERCASE LCMAP_SORTKEY LCMAP_HALFWIDTH
+ LCMAP_FULLWIDTH LCMAP_HIRAGANA LCMAP_KATAKANA)],
+ LANG => [qw(LANG_NEUTRAL LANG_ALBANIAN LANG_ARABIC LANG_BAHASA
+ LANG_BULGARIAN LANG_CATALAN LANG_CHINESE LANG_CZECH LANG_DANISH
+ LANG_DUTCH LANG_ENGLISH LANG_FINNISH LANG_FRENCH LANG_GERMAN
+ LANG_GREEK LANG_HEBREW LANG_HUNGARIAN LANG_ICELANDIC
+ LANG_ITALIAN LANG_JAPANESE LANG_KOREAN LANG_NORWEGIAN
+ LANG_POLISH LANG_PORTUGUESE LANG_RHAETO_ROMAN LANG_ROMANIAN
+ LANG_RUSSIAN LANG_SERBO_CROATIAN LANG_SLOVAK LANG_SPANISH
+ LANG_SWEDISH LANG_THAI LANG_TURKISH LANG_URDU)],
+ SUBLANG => [qw(SUBLANG_NEUTRAL SUBLANG_DEFAULT SUBLANG_SYS_DEFAULT
+ SUBLANG_CHINESE_SIMPLIFIED SUBLANG_CHINESE_TRADITIONAL
+ SUBLANG_DUTCH SUBLANG_DUTCH_BELGIAN SUBLANG_ENGLISH_US
+ SUBLANG_ENGLISH_UK SUBLANG_ENGLISH_AUS SUBLANG_ENGLISH_CAN
+ SUBLANG_ENGLISH_NZ SUBLANG_ENGLISH_EIRE SUBLANG_FRENCH
+ SUBLANG_FRENCH_BELGIAN SUBLANG_FRENCH_CANADIAN
+ SUBLANG_FRENCH_SWISS SUBLANG_GERMAN SUBLANG_GERMAN_SWISS
+ SUBLANG_GERMAN_AUSTRIAN SUBLANG_ITALIAN SUBLANG_ITALIAN_SWISS
+ SUBLANG_NORWEGIAN_BOKMAL SUBLANG_NORWEGIAN_NYNORSK
+ SUBLANG_PORTUGUESE SUBLANG_PORTUGUESE_BRAZILIAN
+ SUBLANG_SERBO_CROATIAN_CYRILLIC SUBLANG_SERBO_CROATIAN_LATIN
+ SUBLANG_SPANISH SUBLANG_SPANISH_MEXICAN
+ SUBLANG_SPANISH_MODERN)],
+ CTRY => [qw(CTRY_DEFAULT CTRY_AUSTRALIA CTRY_AUSTRIA CTRY_BELGIUM
+ CTRY_BRAZIL CTRY_CANADA CTRY_DENMARK CTRY_FINLAND CTRY_FRANCE
+ CTRY_GERMANY CTRY_ICELAND CTRY_IRELAND CTRY_ITALY CTRY_JAPAN
+ CTRY_MEXICO CTRY_NETHERLANDS CTRY_NEW_ZEALAND CTRY_NORWAY
+ CTRY_PORTUGAL CTRY_PRCHINA CTRY_SOUTH_KOREA CTRY_SPAIN
+ CTRY_SWEDEN CTRY_SWITZERLAND CTRY_TAIWAN CTRY_UNITED_KINGDOM
+ CTRY_UNITED_STATES)],
+ LOCALE => [qw(LOCALE_NOUSEROVERRIDE LOCALE_ILANGUAGE LOCALE_SLANGUAGE
+ LOCALE_SENGLANGUAGE LOCALE_SABBREVLANGNAME
+ LOCALE_SNATIVELANGNAME LOCALE_ICOUNTRY LOCALE_SCOUNTRY
+ LOCALE_SENGCOUNTRY LOCALE_SABBREVCTRYNAME LOCALE_SNATIVECTRYNAME
+ LOCALE_IDEFAULTLANGUAGE LOCALE_IDEFAULTCOUNTRY
+ LOCALE_IDEFAULTCODEPAGE LOCALE_IDEFAULTANSICODEPAGE LOCALE_SLIST
+ LOCALE_IMEASURE LOCALE_SDECIMAL LOCALE_STHOUSAND
+ LOCALE_SGROUPING LOCALE_IDIGITS LOCALE_ILZERO LOCALE_INEGNUMBER
+ LOCALE_SNATIVEDIGITS LOCALE_SCURRENCY LOCALE_SINTLSYMBOL
+ LOCALE_SMONDECIMALSEP LOCALE_SMONTHOUSANDSEP LOCALE_SMONGROUPING
+ LOCALE_ICURRDIGITS LOCALE_IINTLCURRDIGITS LOCALE_ICURRENCY
+ LOCALE_INEGCURR LOCALE_SDATE LOCALE_STIME LOCALE_SSHORTDATE
+ LOCALE_SLONGDATE LOCALE_STIMEFORMAT LOCALE_IDATE LOCALE_ILDATE
+ LOCALE_ITIME LOCALE_ITIMEMARKPOSN LOCALE_ICENTURY LOCALE_ITLZERO
+ LOCALE_IDAYLZERO LOCALE_IMONLZERO LOCALE_S1159 LOCALE_S2359
+ LOCALE_ICALENDARTYPE LOCALE_IOPTIONALCALENDAR
+ LOCALE_IFIRSTDAYOFWEEK LOCALE_IFIRSTWEEKOFYEAR LOCALE_SDAYNAME1
+ LOCALE_SDAYNAME2 LOCALE_SDAYNAME3 LOCALE_SDAYNAME4
+ LOCALE_SDAYNAME5 LOCALE_SDAYNAME6 LOCALE_SDAYNAME7
+ LOCALE_SABBREVDAYNAME1 LOCALE_SABBREVDAYNAME2
+ LOCALE_SABBREVDAYNAME3 LOCALE_SABBREVDAYNAME4
+ LOCALE_SABBREVDAYNAME5 LOCALE_SABBREVDAYNAME6
+ LOCALE_SABBREVDAYNAME7 LOCALE_SMONTHNAME1 LOCALE_SMONTHNAME2
+ LOCALE_SMONTHNAME3 LOCALE_SMONTHNAME4 LOCALE_SMONTHNAME5
+ LOCALE_SMONTHNAME6 LOCALE_SMONTHNAME7 LOCALE_SMONTHNAME8
+ LOCALE_SMONTHNAME9 LOCALE_SMONTHNAME10 LOCALE_SMONTHNAME11
+ LOCALE_SMONTHNAME12 LOCALE_SMONTHNAME13 LOCALE_SABBREVMONTHNAME1
+ LOCALE_SABBREVMONTHNAME2 LOCALE_SABBREVMONTHNAME3
+ LOCALE_SABBREVMONTHNAME4 LOCALE_SABBREVMONTHNAME5
+ LOCALE_SABBREVMONTHNAME6 LOCALE_SABBREVMONTHNAME7
+ LOCALE_SABBREVMONTHNAME8 LOCALE_SABBREVMONTHNAME9
+ LOCALE_SABBREVMONTHNAME10 LOCALE_SABBREVMONTHNAME11
+ LOCALE_SABBREVMONTHNAME12 LOCALE_SABBREVMONTHNAME13
+ LOCALE_SPOSITIVESIGN LOCALE_SNEGATIVESIGN LOCALE_IPOSSIGNPOSN
+ LOCALE_INEGSIGNPOSN LOCALE_IPOSSYMPRECEDES LOCALE_IPOSSEPBYSPACE
+ LOCALE_INEGSYMPRECEDES LOCALE_INEGSEPBYSPACE)],
+ TIME => [qw(TIME_NOMINUTESORSECONDS TIME_NOSECONDS TIME_NOTIMEMARKER
+ TIME_FORCE24HOURFORMAT)],
+ DATE => [qw(DATE_SHORTDATE DATE_LONGDATE DATE_USE_ALT_CALENDAR
+ DATE_YEARMONTH DATE_LTRREADING DATE_RTLREADING)],
+);
+
+foreach my $tag (keys %EXPORT_TAGS) {
+ push @EXPORT_OK, @{$EXPORT_TAGS{$tag}};
+}
+
+# Character Type Flags
+sub CT_CTYPE1 { 0x0001 }
+sub CT_CTYPE2 { 0x0002 }
+sub CT_CTYPE3 { 0x0004 }
+
+# Character Type 1 Bits
+sub C1_UPPER { 0x0001 }
+sub C1_LOWER { 0x0002 }
+sub C1_DIGIT { 0x0004 }
+sub C1_SPACE { 0x0008 }
+sub C1_PUNCT { 0x0010 }
+sub C1_CNTRL { 0x0020 }
+sub C1_BLANK { 0x0040 }
+sub C1_XDIGIT { 0x0080 }
+sub C1_ALPHA { 0x0100 }
+
+# Character Type 2 Bits
+sub C2_LEFTTORIGHT { 0x1 }
+sub C2_RIGHTTOLEFT { 0x2 }
+sub C2_EUROPENUMBER { 0x3 }
+sub C2_EUROPESEPARATOR { 0x4 }
+sub C2_EUROPETERMINATOR { 0x5 }
+sub C2_ARABICNUMBER { 0x6 }
+sub C2_COMMONSEPARATOR { 0x7 }
+sub C2_BLOCKSEPARATOR { 0x8 }
+sub C2_SEGMENTSEPARATOR { 0x9 }
+sub C2_WHITESPACE { 0xA }
+sub C2_OTHERNEUTRAL { 0xB }
+sub C2_NOTAPPLICABLE { 0x0 }
+
+# Character Type 3 Bits
+sub C3_NONSPACING { 0x0001 }
+sub C3_DIACRITIC { 0x0002 }
+sub C3_VOWELMARK { 0x0004 }
+sub C3_SYMBOL { 0x0008 }
+sub C3_KATAKANA { 0x0010 }
+sub C3_HIRAGANA { 0x0020 }
+sub C3_HALFWIDTH { 0x0040 }
+sub C3_FULLWIDTH { 0x0080 }
+sub C3_IDEOGRAPH { 0x0100 }
+sub C3_KASHIDA { 0x0200 }
+sub C3_ALPHA { 0x8000 }
+sub C3_NOTAPPLICABLE { 0x0 }
+
+# String Flags
+sub NORM_IGNORECASE { 0x0001 }
+sub NORM_IGNORENONSPACE { 0x0002 }
+sub NORM_IGNORESYMBOLS { 0x0004 }
+sub NORM_IGNOREWIDTH { 0x0008 }
+sub NORM_IGNOREKANATYPE { 0x0040 }
+sub NORM_IGNOREKASHIDA { 0x40000}
+
+# Locale Dependent Mapping Flags
+sub LCMAP_LOWERCASE { 0x0100 }
+sub LCMAP_UPPERCASE { 0x0200 }
+sub LCMAP_SORTKEY { 0x0400 }
+sub LCMAP_HALFWIDTH { 0x0800 }
+sub LCMAP_FULLWIDTH { 0x1000 }
+sub LCMAP_HIRAGANA { 0x2000 }
+sub LCMAP_KATAKANA { 0x4000 }
+
+# Primary Language Identifier
+sub LANG_NEUTRAL { 0x00 }
+sub LANG_ALBANIAN { 0x1c }
+sub LANG_ARABIC { 0x01 }
+sub LANG_BAHASA { 0x21 }
+sub LANG_BULGARIAN { 0x02 }
+sub LANG_CATALAN { 0x03 }
+sub LANG_CHINESE { 0x04 }
+sub LANG_CZECH { 0x05 }
+sub LANG_DANISH { 0x06 }
+sub LANG_DUTCH { 0x13 }
+sub LANG_ENGLISH { 0x09 }
+sub LANG_FINNISH { 0x0b }
+sub LANG_FRENCH { 0x0c }
+sub LANG_GERMAN { 0x07 }
+sub LANG_GREEK { 0x08 }
+sub LANG_HEBREW { 0x0d }
+sub LANG_HUNGARIAN { 0x0e }
+sub LANG_ICELANDIC { 0x0f }
+sub LANG_ITALIAN { 0x10 }
+sub LANG_JAPANESE { 0x11 }
+sub LANG_KOREAN { 0x12 }
+sub LANG_NORWEGIAN { 0x14 }
+sub LANG_POLISH { 0x15 }
+sub LANG_PORTUGUESE { 0x16 }
+sub LANG_RHAETO_ROMAN { 0x17 }
+sub LANG_ROMANIAN { 0x18 }
+sub LANG_RUSSIAN { 0x19 }
+sub LANG_SERBO_CROATIAN { 0x1a }
+sub LANG_SLOVAK { 0x1b }
+sub LANG_SPANISH { 0x0a }
+sub LANG_SWEDISH { 0x1d }
+sub LANG_THAI { 0x1e }
+sub LANG_TURKISH { 0x1f }
+sub LANG_URDU { 0x20 }
+
+# Sublanguage Identifier
+sub SUBLANG_NEUTRAL { 0x00 }
+sub SUBLANG_DEFAULT { 0x01 }
+sub SUBLANG_SYS_DEFAULT { 0x02 }
+sub SUBLANG_CHINESE_SIMPLIFIED { 0x02 }
+sub SUBLANG_CHINESE_TRADITIONAL { 0x01 }
+sub SUBLANG_DUTCH { 0x01 }
+sub SUBLANG_DUTCH_BELGIAN { 0x02 }
+sub SUBLANG_ENGLISH_US { 0x01 }
+sub SUBLANG_ENGLISH_UK { 0x02 }
+sub SUBLANG_ENGLISH_AUS { 0x03 }
+sub SUBLANG_ENGLISH_CAN { 0x04 }
+sub SUBLANG_ENGLISH_NZ { 0x05 }
+sub SUBLANG_ENGLISH_EIRE { 0x06 }
+sub SUBLANG_FRENCH { 0x01 }
+sub SUBLANG_FRENCH_BELGIAN { 0x02 }
+sub SUBLANG_FRENCH_CANADIAN { 0x03 }
+sub SUBLANG_FRENCH_SWISS { 0x04 }
+sub SUBLANG_GERMAN { 0x01 }
+sub SUBLANG_GERMAN_SWISS { 0x02 }
+sub SUBLANG_GERMAN_AUSTRIAN { 0x03 }
+sub SUBLANG_ITALIAN { 0x01 }
+sub SUBLANG_ITALIAN_SWISS { 0x02 }
+sub SUBLANG_NORWEGIAN_BOKMAL { 0x01 }
+sub SUBLANG_NORWEGIAN_NYNORSK { 0x02 }
+sub SUBLANG_PORTUGUESE { 0x02 }
+sub SUBLANG_PORTUGUESE_BRAZILIAN { 0x01 }
+sub SUBLANG_SERBO_CROATIAN_CYRILLIC { 0x02 }
+sub SUBLANG_SERBO_CROATIAN_LATIN { 0x01 }
+sub SUBLANG_SPANISH { 0x01 }
+sub SUBLANG_SPANISH_MEXICAN { 0x02 }
+sub SUBLANG_SPANISH_MODERN { 0x03 }
+
+# Country codes
+sub CTRY_DEFAULT { 0 }
+sub CTRY_AUSTRALIA { 61 }
+sub CTRY_AUSTRIA { 43 }
+sub CTRY_BELGIUM { 32 }
+sub CTRY_BRAZIL { 55 }
+sub CTRY_CANADA { 2 }
+sub CTRY_DENMARK { 45 }
+sub CTRY_FINLAND { 358 }
+sub CTRY_FRANCE { 33 }
+sub CTRY_GERMANY { 49 }
+sub CTRY_ICELAND { 354 }
+sub CTRY_IRELAND { 353 }
+sub CTRY_ITALY { 39 }
+sub CTRY_JAPAN { 81 }
+sub CTRY_MEXICO { 52 }
+sub CTRY_NETHERLANDS { 31 }
+sub CTRY_NEW_ZEALAND { 64 }
+sub CTRY_NORWAY { 47 }
+sub CTRY_PORTUGAL { 351 }
+sub CTRY_PRCHINA { 86 }
+sub CTRY_SOUTH_KOREA { 82 }
+sub CTRY_SPAIN { 34 }
+sub CTRY_SWEDEN { 46 }
+sub CTRY_SWITZERLAND { 41 }
+sub CTRY_TAIWAN { 886 }
+sub CTRY_UNITED_KINGDOM { 44 }
+sub CTRY_UNITED_STATES { 1 }
+
+# Locale Types
+sub LOCALE_NOUSEROVERRIDE { 0x80000000 }
+sub LOCALE_ILANGUAGE { 0x0001 }
+sub LOCALE_SLANGUAGE { 0x0002 }
+sub LOCALE_SENGLANGUAGE { 0x1001 }
+sub LOCALE_SABBREVLANGNAME { 0x0003 }
+sub LOCALE_SNATIVELANGNAME { 0x0004 }
+sub LOCALE_ICOUNTRY { 0x0005 }
+sub LOCALE_SCOUNTRY { 0x0006 }
+sub LOCALE_SENGCOUNTRY { 0x1002 }
+sub LOCALE_SABBREVCTRYNAME { 0x0007 }
+sub LOCALE_SNATIVECTRYNAME { 0x0008 }
+sub LOCALE_IDEFAULTLANGUAGE { 0x0009 }
+sub LOCALE_IDEFAULTCOUNTRY { 0x000A }
+sub LOCALE_IDEFAULTCODEPAGE { 0x000B }
+sub LOCALE_IDEFAULTANSICODEPAGE { 0x1004 }
+sub LOCALE_SLIST { 0x000C }
+sub LOCALE_IMEASURE { 0x000D }
+sub LOCALE_SDECIMAL { 0x000E }
+sub LOCALE_STHOUSAND { 0x000F }
+sub LOCALE_SGROUPING { 0x0010 }
+sub LOCALE_IDIGITS { 0x0011 }
+sub LOCALE_ILZERO { 0x0012 }
+sub LOCALE_INEGNUMBER { 0x1010 }
+sub LOCALE_SNATIVEDIGITS { 0x0013 }
+sub LOCALE_SCURRENCY { 0x0014 }
+sub LOCALE_SINTLSYMBOL { 0x0015 }
+sub LOCALE_SMONDECIMALSEP { 0x0016 }
+sub LOCALE_SMONTHOUSANDSEP { 0x0017 }
+sub LOCALE_SMONGROUPING { 0x0018 }
+sub LOCALE_ICURRDIGITS { 0x0019 }
+sub LOCALE_IINTLCURRDIGITS { 0x001A }
+sub LOCALE_ICURRENCY { 0x001B }
+sub LOCALE_INEGCURR { 0x001C }
+sub LOCALE_SDATE { 0x001D }
+sub LOCALE_STIME { 0x001E }
+sub LOCALE_SSHORTDATE { 0x001F }
+sub LOCALE_SLONGDATE { 0x0020 }
+sub LOCALE_STIMEFORMAT { 0x1003 }
+sub LOCALE_IDATE { 0x0021 }
+sub LOCALE_ILDATE { 0x0022 }
+sub LOCALE_ITIME { 0x0023 }
+sub LOCALE_ITIMEMARKPOSN { 0x1005 }
+sub LOCALE_ICENTURY { 0x0024 }
+sub LOCALE_ITLZERO { 0x0025 }
+sub LOCALE_IDAYLZERO { 0x0026 }
+sub LOCALE_IMONLZERO { 0x0027 }
+sub LOCALE_S1159 { 0x0028 }
+sub LOCALE_S2359 { 0x0029 }
+sub LOCALE_ICALENDARTYPE { 0x1009 }
+sub LOCALE_IOPTIONALCALENDAR { 0x100B }
+sub LOCALE_IFIRSTDAYOFWEEK { 0x100C }
+sub LOCALE_IFIRSTWEEKOFYEAR { 0x100D }
+sub LOCALE_SDAYNAME1 { 0x002A }
+sub LOCALE_SDAYNAME2 { 0x002B }
+sub LOCALE_SDAYNAME3 { 0x002C }
+sub LOCALE_SDAYNAME4 { 0x002D }
+sub LOCALE_SDAYNAME5 { 0x002E }
+sub LOCALE_SDAYNAME6 { 0x002F }
+sub LOCALE_SDAYNAME7 { 0x0030 }
+sub LOCALE_SABBREVDAYNAME1 { 0x0031 }
+sub LOCALE_SABBREVDAYNAME2 { 0x0032 }
+sub LOCALE_SABBREVDAYNAME3 { 0x0033 }
+sub LOCALE_SABBREVDAYNAME4 { 0x0034 }
+sub LOCALE_SABBREVDAYNAME5 { 0x0035 }
+sub LOCALE_SABBREVDAYNAME6 { 0x0036 }
+sub LOCALE_SABBREVDAYNAME7 { 0x0037 }
+sub LOCALE_SMONTHNAME1 { 0x0038 }
+sub LOCALE_SMONTHNAME2 { 0x0039 }
+sub LOCALE_SMONTHNAME3 { 0x003A }
+sub LOCALE_SMONTHNAME4 { 0x003B }
+sub LOCALE_SMONTHNAME5 { 0x003C }
+sub LOCALE_SMONTHNAME6 { 0x003D }
+sub LOCALE_SMONTHNAME7 { 0x003E }
+sub LOCALE_SMONTHNAME8 { 0x003F }
+sub LOCALE_SMONTHNAME9 { 0x0040 }
+sub LOCALE_SMONTHNAME10 { 0x0041 }
+sub LOCALE_SMONTHNAME11 { 0x0042 }
+sub LOCALE_SMONTHNAME12 { 0x0043 }
+sub LOCALE_SMONTHNAME13 { 0x100E }
+sub LOCALE_SABBREVMONTHNAME1 { 0x0044 }
+sub LOCALE_SABBREVMONTHNAME2 { 0x0045 }
+sub LOCALE_SABBREVMONTHNAME3 { 0x0046 }
+sub LOCALE_SABBREVMONTHNAME4 { 0x0047 }
+sub LOCALE_SABBREVMONTHNAME5 { 0x0048 }
+sub LOCALE_SABBREVMONTHNAME6 { 0x0049 }
+sub LOCALE_SABBREVMONTHNAME7 { 0x004A }
+sub LOCALE_SABBREVMONTHNAME8 { 0x004B }
+sub LOCALE_SABBREVMONTHNAME9 { 0x004C }
+sub LOCALE_SABBREVMONTHNAME10 { 0x004D }
+sub LOCALE_SABBREVMONTHNAME11 { 0x004E }
+sub LOCALE_SABBREVMONTHNAME12 { 0x004F }
+sub LOCALE_SABBREVMONTHNAME13 { 0x100F }
+sub LOCALE_SPOSITIVESIGN { 0x0050 }
+sub LOCALE_SNEGATIVESIGN { 0x0051 }
+sub LOCALE_IPOSSIGNPOSN { 0x0052 }
+sub LOCALE_INEGSIGNPOSN { 0x0053 }
+sub LOCALE_IPOSSYMPRECEDES { 0x0054 }
+sub LOCALE_IPOSSEPBYSPACE { 0x0055 }
+sub LOCALE_INEGSYMPRECEDES { 0x0056 }
+sub LOCALE_INEGSEPBYSPACE { 0x0057 }
+
+# GetTimeFormat Flags
+sub TIME_NOMINUTESORSECONDS { 0x0001 }
+sub TIME_NOSECONDS { 0x0002 }
+sub TIME_NOTIMEMARKER { 0x0004 }
+sub TIME_FORCE24HOURFORMAT { 0x0008 }
+
+# GetDateFormat Flags
+sub DATE_SHORTDATE { 0x0001 }
+sub DATE_LONGDATE { 0x0002 }
+sub DATE_USE_ALT_CALENDAR { 0x0004 }
+sub DATE_YEARMONTH { 0x0008 }
+sub DATE_LTRREADING { 0x0010 }
+sub DATE_RTLREADING { 0x0020 }
+
+# Language Identifier Functions
+sub MAKELANGID { my ($p,$s) = @_; (($s & 0xffff) << 10) | ($p & 0xffff); }
+sub PRIMARYLANGID { my $lgid = shift; $lgid & 0x3ff; }
+sub SUBLANGID { my $lgid = shift; ($lgid >> 10) & 0x3f; }
+
+sub LANG_SYSTEM_DEFAULT { MAKELANGID(LANG_NEUTRAL, SUBLANG_SYS_DEFAULT); }
+sub LANG_USER_DEFAULT { MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT); }
+
+# Locale Identifier Functions
+sub MAKELCID { my $lgid = shift; $lgid & 0xffff; }
+sub LANGIDFROMLCID { my $lcid = shift; $lcid & 0xffff; }
+
+sub LOCALE_SYSTEM_DEFAULT { MAKELCID(LANG_SYSTEM_DEFAULT); }
+sub LOCALE_USER_DEFAULT { MAKELCID(LANG_USER_DEFAULT); }
+
+1;
+
+__END__
+
+=head1 NAME
+
+Win32::OLE::NLS - OLE National Language Support
+
+=head1 SYNOPSIS
+
+ missing
+
+=head1 DESCRIPTION
+
+This module provides access to the national language support features
+in the F<OLENLS.DLL>.
+
+=head2 Functions
+
+=over 8
+
+=item CompareString(LCID,FLAGS,STR1,STR2)
+
+Compare STR1 and STR2 in the LCID locale. FLAGS indicate the character
+traits to be used or ignored when comparing the two strings.
+
+ NORM_IGNORECASE Ignore case
+ NORM_IGNOREKANATYPE Ignore hiragana/katakana character differences
+ NORM_IGNORENONSPACE Ignore accents, diacritics, and vowel marks
+ NORM_IGNORESYMBOLS Ignore symbols
+ NORM_IGNOREWIDTH Ignore character width
+
+Possible return values are:
+
+ 0 Function failed
+ 1 STR1 is less than STR2
+ 2 STR1 is equal to STR2
+ 3 STR1 is greater than STR2
+
+Note that you can subtract 2 from the return code to get values
+comparable to the C<cmp> operator.
+
+=item LCMapString(LCID,FLAGS,STR)
+
+LCMapString translates STR using LCID dependent translation.
+Flags contains a combination of the following options:
+
+ LCMAP_LOWERCASE Lowercase
+ LCMAP_UPPERCASE Uppercase
+ LCMAP_HALFWIDTH Narrow characters
+ LCMAP_FULLWIDTH Wide characters
+ LCMAP_HIRAGANA Hiragana
+ LCMAP_KATAKANA Katakana
+ LCMAP_SORTKEY Character sort key
+
+The following normalization options can be combined with C<LCMAP_SORTKEY>:
+
+ NORM_IGNORECASE Ignore case
+ NORM_IGNOREKANATYPE Ignore hiragana/katakana character differences
+ NORM_IGNORENONSPACE Ignore accents, diacritics, and vowel marks
+ NORM_IGNORESYMBOLS Ignore symbols
+ NORM_IGNOREWIDTH Ignore character width
+
+The return value is the translated string.
+
+=item GetLocaleInfo(LCID,LCTYPE)
+
+Retrieve locale setting LCTYPE from the locale specified by LCID. Use
+LOCALE_NOUSEROVERRIDE | LCTYPE to always query the locale database.
+Otherwise user changes to C<win.ini> through the windows control panel
+take precedence when retrieving values for the system default locale.
+See the documentation below for a list of valid LCTYPE values.
+
+The return value is the contents of the requested locale setting.
+
+=item GetStringType(LCID,TYPE,STR)
+
+Retrieve type information from locale LCID about each character in STR.
+The requested TYPE can be one of the following 3 levels:
+
+ CT_CTYPE1 ANSI C and POSIX type information
+ CT_CTYPE2 Text layout type information
+ CT_CTYPE3 Text processing type information
+
+The return value is a list of values, each of wich is a bitwise OR of
+the applicable type bits from the corresponding table below:
+
+ @ct = GetStringType(LOCALE_SYSTEM_DEFAULT, CT_CTYPE1, "String");
+
+ANSI C and POSIX character type information:
+
+ C1_UPPER Uppercase
+ C1_LOWER Lowercase
+ C1_DIGIT Decimal digits
+ C1_SPACE Space characters
+ C1_PUNCT Punctuation
+ C1_CNTRL Control characters
+ C1_BLANK Blank characters
+ C1_XDIGIT Hexadecimal digits
+ C1_ALPHA Any letter
+
+Text layout type information:
+
+ C2_LEFTTORIGHT Left to right
+ C2_RIGHTTOLEFT Right to left
+ C2_EUROPENUMBER European number, European digit
+ C2_EUROPESEPARATOR European numeric separator
+ C2_EUROPETERMINATOR European numeric terminator
+ C2_ARABICNUMBER Arabic number
+ C2_COMMONSEPARATOR Common numeric separator
+ C2_BLOCKSEPARATOR Block separator
+ C2_SEGMENTSEPARATOR Segment separator
+ C2_WHITESPACE White space
+ C2_OTHERNEUTRAL Other neutrals
+ C2_NOTAPPLICABLE No implicit direction (e.g. ctrl codes)
+
+Text precessing type information:
+
+ C3_NONSPACING Nonspacing mark
+ C3_DIACRITIC Diacritic nonspacing mark
+ C3_VOWELMARK Vowel nonspacing mark
+ C3_SYMBOL Symbol
+ C3_KATAKANA Katakana character
+ C3_HIRAGANA Hiragana character
+ C3_HALFWIDTH Narrow character
+ C3_FULLWIDTH Wide character
+ C3_IDEOGRAPH Ideograph
+ C3_ALPHA Any letter
+ C3_NOTAPPLICABLE Not applicable
+
+
+=item GetSystemDefaultLangID()
+
+Returns the system default language identifier.
+
+=item GetSystemDefaultLCID()
+
+Returns the system default locale identifier.
+
+=item GetUserDefaultLangID()
+
+Returns the user default language identifier.
+
+=item GetUserDefaultLCID()
+
+Returns the user default locale identifier.
+
+=item SendSettingChange()
+
+Sends a WM_SETTINGCHANGE message to all top level windows.
+
+=item SetLocaleInfo(LCID, LCTYPE, LCDATA)
+
+Changes an item in the user override part of the locale setting LCID.
+It doesn't change the system default database. The following LCTYPEs are
+changeable:
+
+ LOCALE_ICALENDARTYPE LOCALE_SDATE
+ LOCALE_ICURRDIGITS LOCALE_SDECIMAL
+ LOCALE_ICURRENCY LOCALE_SGROUPING
+ LOCALE_IDIGITS LOCALE_SLIST
+ LOCALE_IFIRSTDAYOFWEEK LOCALE_SLONGDATE
+ LOCALE_IFIRSTWEEKOFYEAR LOCALE_SMONDECIMALSEP
+ LOCALE_ILZERO LOCALE_SMONGROUPING
+ LOCALE_IMEASURE LOCALE_SMONTHOUSANDSEP
+ LOCALE_INEGCURR LOCALE_SNEGATIVESIGN
+ LOCALE_INEGNUMBER LOCALE_SPOSITIVESIGN
+ LOCALE_IPAPERSIZE LOCALE_SSHORTDATE
+ LOCALE_ITIME LOCALE_STHOUSAND
+ LOCALE_S1159 LOCALE_STIME
+ LOCALE_S2359 LOCALE_STIMEFORMAT
+ LOCALE_SCURRENCY LOCALE_SYEARMONTH
+
+You have to call SendSettingChange() to activate these changes for
+subsequent Win32::OLE::Variant object formatting because the OLE
+subsystem seems to cache locale information.
+
+=item MAKELANGID(LANG,SUBLANG)
+
+Creates a language identifier from a primary language and a sublanguage.
+
+=item PRIMARYLANGID(LANGID)
+
+Retrieves the primary language from a language identifier.
+
+=item SUBLANGID(LANGID)
+
+Retrieves the sublanguage from a language identifier.
+
+=item MAKELCID(LANGID)
+
+Creates a locale identifies from a language identifier.
+
+=item LANGIDFROMLCID(LCID)
+
+Retrieves a language identifier from a locale identifier.
+
+=back
+
+=head2 Locale Types
+
+=over 8
+
+=item LOCALE_ILANGUAGE
+
+The language identifier (in hex).
+
+=item LOCALE_SLANGUAGE
+
+The localized name of the language.
+
+=item LOCALE_SENGLANGUAGE
+
+The ISO Standard 639 English name of the language.
+
+=item LOCALE_SABBREVLANGNAME
+
+The three-letter abbreviated name of the language. The first two
+letters are from the ISO Standard 639 language name abbreviation. The
+third letter indicates the sublanguage type.
+
+=item LOCALE_SNATIVELANGNAME
+
+The native name of the language.
+
+=item LOCALE_ICOUNTRY
+
+The country code, which is based on international phone codes.
+
+=item LOCALE_SCOUNTRY
+
+The localized name of the country.
+
+=item LOCALE_SENGCOUNTRY
+
+The English name of the country.
+
+=item LOCALE_SABBREVCTRYNAME
+
+The ISO Standard 3166 abbreviated name of the country.
+
+=item LOCALE_SNATIVECTRYNAME
+
+The native name of the country.
+
+=item LOCALE_IDEFAULTLANGUAGE
+
+Language identifier for the principal language spoken in this
+locale.
+
+=item LOCALE_IDEFAULTCOUNTRY
+
+Country code for the principal country in this locale.
+
+=item LOCALE_IDEFAULTANSICODEPAGE
+
+The ANSI code page associated with this locale. Format: 4 Unicode
+decimal digits plus a Unicode null terminator.
+
+XXX This should be translated by GetLocaleInfo. XXX
+
+=item LOCALE_IDEFAULTCODEPAGE
+
+The OEM code page associated with the country.
+
+=item LOCALE_SLIST
+
+Characters used to separate list items (often a comma).
+
+=item LOCALE_IMEASURE
+
+Default measurement system:
+
+ 0 metric system (S.I.)
+ 1 U.S. system
+
+=item LOCALE_SDECIMAL
+
+Characters used for the decimal separator (often a dot).
+
+=item LOCALE_STHOUSAND
+
+Characters used as the separator between groups of digits left of the decimal.
+
+=item LOCALE_SGROUPING
+
+Sizes for each group of digits to the left of the decimal. An explicit
+size is required for each group. Sizes are separated by semicolons. If
+the last value is 0, the preceding value is repeated. To group
+thousands, specify 3;0.
+
+=item LOCALE_IDIGITS
+
+The number of fractional digits.
+
+=item LOCALE_ILZERO
+
+Whether to use leading zeros in decimal fields. A setting of 0
+means use no leading zeros; 1 means use leading zeros.
+
+=item LOCALE_SNATIVEDIGITS
+
+The ten characters that are the native equivalent of the ASCII 0-9.
+
+=item LOCALE_INEGNUMBER
+
+Negative number mode.
+
+ 0 (1.1)
+ 1 -1.1
+ 2 -1.1
+ 3 1.1
+ 4 1.1
+
+=item LOCALE_SCURRENCY
+
+The string used as the local monetary symbol.
+
+=item LOCALE_SINTLSYMBOL
+
+Three characters of the International monetary symbol specified in ISO
+4217, Codes for the Representation of Currencies and Funds, followed
+by the character separating this string from the amount.
+
+=item LOCALE_SMONDECIMALSEP
+
+Characters used for the monetary decimal separators.
+
+=item LOCALE_SMONTHOUSANDSEP
+
+Characters used as monetary separator between groups of digits left of
+the decimal.
+
+=item LOCALE_SMONGROUPING
+
+Sizes for each group of monetary digits to the left of the decimal. An
+explicit size is needed for each group. Sizes are separated by
+semicolons. If the last value is 0, the preceding value is
+repeated. To group thousands, specify 3;0.
+
+=item LOCALE_ICURRDIGITS
+
+Number of fractional digits for the local monetary format.
+
+=item LOCALE_IINTLCURRDIGITS
+
+Number of fractional digits for the international monetary format.
+
+=item LOCALE_ICURRENCY
+
+Positive currency mode.
+
+ 0 Prefix, no separation.
+ 1 Suffix, no separation.
+ 2 Prefix, 1-character separation.
+ 3 Suffix, 1-character separation.
+
+=item LOCALE_INEGCURR
+
+Negative currency mode.
+
+ 0 ($1.1)
+ 1 -$1.1
+ 2 $-1.1
+ 3 $1.1-
+ 4 $(1.1$)
+ 5 -1.1$
+ 6 1.1-$
+ 7 1.1$-
+ 8 -1.1 $ (space before $)
+ 9 -$ 1.1 (space after $)
+ 10 1.1 $- (space before $)
+
+=item LOCALE_ICALENDARTYPE
+
+The type of calendar currently in use.
+
+ 1 Gregorian (as in U.S.)
+ 2 Gregorian (always English strings)
+ 3 Era: Year of the Emperor (Japan)
+ 4 Era: Year of the Republic of China
+ 5 Tangun Era (Korea)
+
+=item LOCALE_IOPTIONALCALENDAR
+
+The additional calendar types available for this LCID. Can be a
+null-separated list of all valid optional calendars. Value is
+0 for "None available" or any of the LOCALE_ICALENDARTYPE settings.
+
+XXX null separated list should be translated by GetLocaleInfo XXX
+
+=item LOCALE_SDATE
+
+Characters used for the date separator.
+
+=item LOCALE_STIME
+
+Characters used for the time separator.
+
+=item LOCALE_STIMEFORMAT
+
+Time-formatting string.
+
+=item LOCALE_SSHORTDATE
+
+Short Date_Time formatting strings for this locale.
+
+=item LOCALE_SLONGDATE
+
+Long Date_Time formatting strings for this locale.
+
+=item LOCALE_IDATE
+
+Short Date format-ordering specifier.
+
+ 0 Month - Day - Year
+ 1 Day - Month - Year
+ 2 Year - Month - Day
+
+=item LOCALE_ILDATE
+
+Long Date format ordering specifier. Value can be any of the valid
+LOCALE_IDATE settings.
+
+=item LOCALE_ITIME
+
+Time format specifier.
+
+ 0 AM/PM 12-hour format.
+ 1 24-hour format.
+
+=item LOCALE_ITIMEMARKPOSN
+
+Whether the time marker string (AM|PM) precedes or follows the time
+string.
+ 0 Suffix (9:15 AM).
+ 1 Prefix (AM 9:15).
+
+=item LOCALE_ICENTURY
+
+Whether to use full 4-digit century.
+
+ 0 Two digit.
+ 1 Full century.
+
+=item LOCALE_ITLZERO
+
+Whether to use leading zeros in time fields.
+
+ 0 No leading zeros.
+ 1 Leading zeros for hours.
+
+=item LOCALE_IDAYLZERO
+
+Whether to use leading zeros in day fields. Values as for
+LOCALE_ITLZERO.
+
+=item LOCALE_IMONLZERO
+
+Whether to use leading zeros in month fields. Values as for
+LOCALE_ITLZERO.
+
+=item LOCALE_S1159
+
+String for the AM designator.
+
+=item LOCALE_S2359
+
+String for the PM designator.
+
+=item LOCALE_IFIRSTWEEKOFYEAR
+
+Specifies which week of the year is considered first.
+
+ 0 Week containing 1/1 is the first week of the year.
+ 1 First full week following 1/1is the first week of the year.
+ 2 First week with at least 4 days is the first week of the year.
+
+=item LOCALE_IFIRSTDAYOFWEEK
+
+Specifies the day considered first in the week. Value "0" means
+SDAYNAME1 and value "6" means SDAYNAME7.
+
+=item LOCALE_SDAYNAME1 .. LOCALE_SDAYNAME7
+
+Long name for Monday .. Sunday.
+
+=item LOCALE_SABBREVDAYNAME1 .. LOCALE_SABBREVDAYNAME7
+
+Abbreviated name for Monday .. Sunday.
+
+=item LOCALE_SMONTHNAME1 .. LOCALE_SMONTHNAME12
+
+Long name for January .. December.
+
+=item LOCALE_SMONTHNAME13
+
+Native name for 13th month, if it exists.
+
+=item LOCALE_SABBREVMONTHNAME1 .. LOCALE_SABBREVMONTHNAME12
+
+Abbreviated name for January .. December.
+
+=item LOCALE_SABBREVMONTHNAME13
+
+Native abbreviated name for 13th month, if it exists.
+
+=item LOCALE_SPOSITIVESIGN
+
+String value for the positive sign.
+
+=item LOCALE_SNEGATIVESIGN
+
+String value for the negative sign.
+
+=item LOCALE_IPOSSIGNPOSN
+
+Formatting index for positive values.
+
+ 0 Parentheses surround the amount and the monetary symbol.
+ 1 The sign string precedes the amount and the monetary symbol.
+ 2 The sign string precedes the amount and the monetary symbol.
+ 3 The sign string precedes the amount and the monetary symbol.
+ 4 The sign string precedes the amount and the monetary symbol.
+
+=item LOCALE_INEGSIGNPOSN
+
+Formatting index for negative values. Values as for LOCALE_IPOSSIGNPOSN.
+
+=item LOCALE_IPOSSYMPRECEDES
+
+If the monetary symbol precedes, 1. If it succeeds a positive amount, 0.
+
+=item LOCALE_IPOSSEPBYSPACE
+
+If the monetary symbol is separated by a space from a positive amount,
+1. Otherwise, 0.
+
+=item LOCALE_INEGSYMPRECEDES
+
+If the monetary symbol precedes, 1. If it succeeds a negative amount, 0.
+
+=item LOCALE_INEGSEPBYSPACE
+
+If the monetary symbol is separated by a space from a negative amount,
+1. Otherwise, 0.
+
+=back
+
+=head1 AUTHORS/COPYRIGHT
+
+This module is part of the Win32::OLE distribution.
+
+=cut
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/OLE/TPJ.pod b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/OLE/TPJ.pod
new file mode 100644
index 0000000000..e45770baa4
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/OLE/TPJ.pod
@@ -0,0 +1,798 @@
+=pod
+
+=head1 NAME
+
+The Perl Journal #10 - Win32::OLE by Jan Dubois
+
+=head1 INTRODUCTION
+
+Suppose you're composing a document with Microsoft Word. You want to
+include an Excel spreadsheet. You could save the spreadsheet in some
+image format that Word can understand, and import it into your
+document. But if the spreadsheet changes, your document will be out of
+date.
+
+Microsoft's OLE (Object Linking and Embedding, pronounced "olay") lets
+one program use objects from another. In the above scenario, the
+spreadsheet is the object. As long as Excel makes that spreadsheet
+available as an OLE object, and Word knows to treat it like one, your
+document will always be current.
+
+You can control OLE objects from Perl with the Win32::OLE module, and
+that's what this article is about. First, I'll show you how to "think
+OLE," which mostly involves a lot of jargon. Next, I'll show you the
+mechanics involved in using Win32::OLE. Then we'll go through a Perl
+program that uses OLE to manipulate Microsoft Excel, Microsoft Access,
+and Lotus Notes. Finally, I'll talk about Variants, an internal OLE
+data type.
+
+
+=head1 THE OLE MINDSET
+
+When an application makes an OLE object available for other
+applications to use, that's called OLE I<automation>. The program
+using the object is called the I<controller>, and the application
+providing the object is called the I<server>. OLE automation is guided
+by the OLE Component Object Model (COM) which specifies how those
+objects must behave if they are to be used by other processes and
+machines.
+
+There are two different types of OLE automation servers. I<In-process>
+servers are implemented as dynamic link libraries (DLLs) and run in
+the same process space as the controller. I<Out-of-process> servers
+are more interesting; they are standalone executables that exist as
+separate processes - possibly on a different computer.
+
+The Win32::OLE module lets your Perl program act as an OLE
+controller. It allows Perl to be used in place of other languages like
+Visual Basic or Java to control OLE objects. This makes all OLE
+automation servers immediately available as Perl modules.
+
+Don't confuse ActiveState OLE with Win32::OLE. ActiveState OLE is
+completely different, although future builds of ActiveState Perl (500
+and up) will work with Win32::OLE.
+
+Objects can expose OLE methods, properties, and events to the outside
+world. Methods are functions that the controller can call to make the
+object do something; properties describe the state of the object; and
+events let the controller know about external events affecting the
+object, such as the user clicking on a button. Since events involve
+asynchronous communication with their objects, they require either
+threads or an event loop. They are not yet supported by the Win32::OLE
+module, and for the same reason ActiveX controls (OCXs) are currently
+unsupported as well.
+
+=head1 WORKING WITH WIN32::OLE
+
+The Win32::OLE module doesn't let your Perl program create OLE
+objects. What it does do is let your Perl program act like a remote
+control for other applications-it lets your program be an OLE
+controller. You can take an OLE object from another application
+(Access, Notes, Excel, or anything else that speaks OLE) and invoke
+its methods or manipulate its properties.
+
+=head2 THE FIRST STEP: CREATING AN OLE SERVER OBJECT
+
+First, we need to create a Perl object to represent the OLE
+server. This is a weird idea; what it amounts to is that if we want to
+control OLE objects produced by, say, Excel, we have to create a Perl
+object that represents Excel. So even though our program is an OLE
+controller, it'll contain objects that represent OLE servers.
+
+You can create a new OLE I<server object> with C<< Win32::OLE->new >>.
+This takes a program ID (a human readable string like
+C<'Speech.VoiceText'>) and returns a server object:
+
+ my $server = Win32::OLE->new('Excel.Application', 'Quit');
+
+Some server objects (particularly those for Microsoft Office
+applications) don't automatically terminate when your program no
+longer needs them. They need some kind of Quit method, and that's just
+what our second argument is. It can be either a code reference or a
+method name to be invoked when the object is destroyed. This lets you
+ensure that objects will be properly cleaned up even when the Perl
+program dies abnormally.
+
+To access a server object on a different computer, replace the first
+argument with a reference to a list of the server name and program ID:
+
+ my $server = Win32::OLE->new(['foo.bar.com',
+ 'Excel.Application']);
+
+(To get the requisite permissions, you'll need to configure your
+security settings with F<DCOMCNFG.EXE>.)
+
+You can also directly attach your program to an already running OLE
+server:
+
+ my $server = Win32::OLE->GetActiveObject('Excel.Application');
+
+This fails (returning C<undef>) if no server exists, or if the server
+refuses the connection for some reason. It is also possible to use a
+persistent object moniker (usually a filename) to start the associated
+server and load the object into memory:
+
+ my $doc = Win32::OLE->GetObject("MyDocument.Doc");
+
+=head2 METHOD CALLS
+
+Once you've created one of these server objects, you need to call its
+methods to make the OLE objects sing and dance. OLE methods are
+invoked just like normal Perl object methods:
+
+ $server->Foo(@Arguments);
+
+This is a Perl method call - but it also triggers an OLE method call
+in the object. After your program executes this statement, the
+C<$server> object will execute its Foo() method. The available methods
+are typically documented in the application's I<object model>.
+
+B<Parameters.> By default, all parameters are positional
+(e.g. C<foo($first, $second, $third)>) rather than named (e.g.
+C<< foo(-name => "Yogi", -title => "Coach") >>). The required parameters
+come first, followed by the optional parameters; if you need to
+provide a dummy value for an optional parameter, use undef.
+
+Positional parameters get cumbersome if a method takes a lot of
+them. You can use named arguments instead if you go to a little extra
+trouble - when the last argument is a reference to a hash, the
+key/value pairs of the hash are treated as named parameters:
+
+ $server->Foo($Pos1, $Pos2, {Name1 => $Value1,
+ Name2 => $Value2});
+
+B<Foreign Languages and Default Methods.> Sometimes OLE servers use
+method and property names that are specific to a non-English
+locale. That means they might have non-ASCII characters, which aren't
+allowed in Perl variable names. In German, you might see C<Öffnen> used
+instead of C<Open>. In these cases, you can use the Invoke() method:
+
+ $server->Invoke('Öffnen', @Arguments);
+
+This is necessary because C<< $Server->Öffnen(@Arguments) >> is a syntax
+error in current versions of Perl.
+
+=head2 PROPERTIES
+
+As I said earlier, objects can expose three things to the outside
+world: methods, properties, and events. We've covered methods, and
+Win32::OLE can't handle events. That leaves properties. But as it
+turns out, properties and events are largely interchangeable. Most
+methods have corresponding properties, and vice versa.
+
+An object's properties can be accessed with a hash reference:
+
+ $server->{Bar} = $value;
+ $value = $server->{Bar};
+
+This example sets and queries the value of the property named
+C<Bar>. You could also have called the object's Bar() method to
+achieve the same effect:
+
+ $value = $server->Bar;
+
+However, you can't write the first line as C<< $server->Bar = $value >>,
+because you can't assign to the return value of a method call. In
+Visual Basic, OLE automation distinguishes between assigning the name
+of an object and assigning its value:
+
+ Set Object = OtherObject
+
+ Let Value = Object
+
+The C<Set> statement shown here makes C<Object> refer to the same object as
+C<OtherObject>. The C<Let> statement copies the value instead. (The value of
+an OLE object is what you get when you call the object's default
+method.
+
+In Perl, saying C<< $server1 = $server2 >> always creates another reference,
+just like the C<Set> in Visual Basic. If you want to assign the value
+instead, use the valof() function:
+
+ my $value = valof $server;
+
+This is equivalent to
+
+ my $value = $server->Invoke('');
+
+=head2 SAMPLE APPLICATION
+
+Let's look at how all of this might be used. In Listing: 1 you'll see
+F<T-Bond.pl>, a program that uses Win32::OLE for an almost-real world
+application.
+
+The developer of this application, Mary Lynch, is a financial futures
+broker. Every afternoon, she connects to the Chicago Board of Trade
+(CBoT) web site at http://www.cbot.com and collects the time and sales
+information for U.S. T-bond futures. She wants her program to create a
+chart that depicts the data in 15-minute intervals, and then she wants
+to record the data in a database for later analysis. Then she wants
+her program to send mail to her clients.
+
+Mary's program will use Microsoft Access as a database, Microsoft
+Excel to produce the chart, and Lotus Notes to send the mail. It will
+all be controlled from a single Perl program using OLE automation. In
+this section, we'll go through T-Bond. pl step by step so you can see
+how Win32::OLE lets you control these applications.
+
+=head2 DOWNLOADING A WEB PAGE WITH LWP
+
+However, Mary first needs to amass the raw T-bond data by having her
+Perl program automatically download and parse a web page. That's the
+perfect job for LWP, the libwww-perl bundle available on the CPAN. LWP
+has nothing to do with OLE. But this is a real-world application, and
+it's just what Mary needs to download her data from the Chicago Board
+of Trade.
+
+ use LWP::Simple;
+ my $URL = 'http://www.cbot.com/mplex/quotes/tsfut';
+ my $text = get("$URL/tsf$Contract.htm");
+
+She could also have used the Win32::Internet module:
+
+ use Win32::Internet;
+ my $URL = 'http://www.cbot.com/mplex/quotes/tsfut';
+ my $text = $Win32::Internet->new->FetchURL("$URL/tsf$Contract.htm");
+
+Mary wants to condense the ticker data into 15 minute bars. She's
+interested only in lines that look like this:
+
+ 03/12/1998 US 98Mar 12116 15:28:34 Open
+
+A regular expression can be used to determine whether a line looks
+like this. If it does, the regex can split it up into individual
+fields. The price quoted above, C<12116>, really means 121 16/32, and
+needs to be converted to 121.5. The data is then condensed into 15
+minute intervals and only the first, last, highest, and lowest price
+during each interval are kept. The time series is stored in the array
+C<@Bars>. Each entry in C<@Bars> is a reference to a list of 5 elements:
+Time, Open, High, Low, and Close.
+
+ foreach (split "\n", $text) {
+ # 03/12/1998 US 98Mar 12116 15:28:34 Open
+ my ($Date,$Price,$Hour,$Min,$Sec,$Ind) =
+ m|^\s*(\d+/\d+/\d+) # " 03/12/1998"
+ \s+US\s+\S+\s+(\d+) # " US 98Mar 12116"
+ \s+(\d+):(\d+):(\d+) # " 12:42:40"
+ \s*(.*)$|x; # " Ask"
+ next unless defined $Date;
+ $Day = $Date;
+
+ # Convert from fractional to decimal format
+ $Price = int($Price/100) + ($Price%100)/32;
+
+ # Round up time to next multiple of 15 minutes
+ my $NewTime = int(($Sec+$Min*60+$Hour*3600)/900+1)*900;
+ unless (defined $Time && $NewTime == $Time) {
+ push @Bars, [$hhmm, $Open, $High, $Low, $Close]
+ if defined $Time;
+ $Open = $High = $Low = $Close = undef;
+ $Time = $NewTime;
+ my $Hour = int($Time/3600);
+ $hhmm = sprintf "%02d:%02d", $Hour, $Time/60-$Hour*60;
+ }
+
+ # Update 15 minute bar values
+ $Close = $Price;
+ $Open = $Price unless defined $Open;
+ $High = $Price unless defined $High && $High > $Price;
+ $Low = $Price unless defined $Low && $Low > $Price;
+ }
+
+ die "No data found" unless defined $Time;
+ push @Bars, [$hhmm, $Open, $High, $Low, $Close];
+
+=head2 MICROSOFT ACCESS
+
+Now that Mary has her T-bond quotes, she's ready to use Win32::OLE to
+store them into a Microsoft Access database. This has the advantage
+that she can copy the database to her lap-top and work with it on her
+long New York commute. She's able to create an Access database as
+follows:
+
+ use Win32::ODBC;
+ use Win32::OLE;
+
+ # Include the constants for the Microsoft Access
+ # "Data Access Object".
+
+ use Win32::OLE::Const 'Microsoft DAO';
+
+ my $DSN = 'T-Bonds';
+ my $Driver = 'Microsoft Access Driver (*.mdb)';
+ my $Desc = 'US T-Bond Quotes';
+ my $Dir = 'i:\tmp\tpj';
+ my $File = 'T-Bonds.mdb';
+ my $Fullname = "$Dir\\$File";
+
+ # Remove old database and dataset name
+ unlink $Fullname if -f $Fullname;
+ Win32::ODBC::ConfigDSN(ODBC_REMOVE_DSN, $Driver, "DSN=$DSN")
+ if Win32::ODBC::DataSources($DSN);
+
+ # Create new database
+ my $Access = Win32::OLE->new('Access.Application', 'Quit');
+ my $Workspace = $Access->DBEngine->CreateWorkspace('', 'Admin', '');
+ my $Database = $Workspace->CreateDatabase($Fullname, dbLangGeneral);
+
+ # Add new database name
+ Win32::ODBC::ConfigDSN(ODBC_ADD_DSN, $Driver,
+ "DSN=$DSN", "Description=$Desc", "DBQ=$Fullname",
+ "DEFAULTDIR=$Dir", "UID=", "PWD=");
+
+This uses Win32::ODBC (described in TPJ #9) to remove and create
+F<T-Bonds.mdb>. This lets Mary use the same script on her workstation
+and on her laptop even when the database is stored in different
+locations on each. The program also uses Win32::OLE to make Microsoft
+Access create an empty database.
+
+Every OLE server has some constants that your Perl program will need
+to use, made accessible by the Win32::OLE::Const module. For instance,
+to grab the Excel constants, say C<use Win32::OLE::Const 'Microsoft
+Excel'>.
+
+In the above example, we imported the Data Access Object con-stants
+just so we could use C<dbLangGeneral>.
+
+=head2 MICROSOFT EXCEL
+
+Now Mary uses Win32::OLE a second time, to have Microsoft Excel create
+the chart shown below.
+
+ Figure 1: T-Bond data generated by MicroSoft Excel via Win32::OLE
+
+ # Start Excel and create new workbook with a single sheet
+ use Win32::OLE qw(in valof with);
+ use Win32::OLE::Const 'Microsoft Excel';
+ use Win32::OLE::NLS qw(:DEFAULT :LANG :SUBLANG);
+
+ my $lgid = MAKELANGID(LANG_ENGLISH, SUBLANG_DEFAULT);
+ $Win32::OLE::LCID = MAKELCID($lgid);
+
+ $Win32::OLE::Warn = 3;
+
+Here, Mary sets the locale to American English, which lets her do
+things like use American date formats (e.g. C<"12-30-98"> rather than
+C<"30-12-98">) in her program. It will continue to work even when she's
+visiting one of her international customers and has to run this
+program on their computers.
+
+The value of C<$Win32::OLE::Warn> determines what happens when an OLE
+error occurs. If it's 0, the error is ignored. If it's 2, or if it's 1
+and the script is running under C<-w>, the Win32::OLE module invokes
+C<Carp::carp()>. If C<$Win32::OLE::Warn> is set to 3, C<Carp::croak()>
+is invoked and the program dies immediately.
+
+Now the data can be put into an Excel spreadsheet to produce the
+chart. The following section of the program launches Excel and creates
+a new workbook with a single worksheet. It puts the column titles
+('Time', 'Open', 'High', 'Low', and 'Close') in a bold font on the
+first row of the sheet. The first column displays the timestamp in
+I<hh:mm> format; the next four display prices.
+
+ my $Excel = Win32::OLE->new('Excel.Application', 'Quit');
+ $Excel->{SheetsInNewWorkbook} = 1;
+ my $Book = $Excel->Workbooks->Add;
+ my $Sheet = $Book->Worksheets(1);
+ $Sheet->{Name} = 'Candle';
+
+ # Insert column titles
+ my $Range = $Sheet->Range("A1:E1");
+ $Range->{Value} = [qw(Time Open High Low Close)];
+ $Range->Font->{Bold} = 1;
+
+ $Sheet->Columns("A:A")->{NumberFormat} = "h:mm";
+ # Open/High/Low/Close to be displayed in 32nds
+ $Sheet->Columns("B:E")->{NumberFormat} = "# ?/32";
+
+ # Add 15 minute data to spreadsheet
+ print "Add data\n";
+ $Range = $Sheet->Range(sprintf "A2:E%d", 2+$#Bars);
+ $Range->{Value} = \@Bars;
+
+The last statement shows how to pass arrays to OLE objects. The
+Win32::OLE module automatically translates each array reference to a
+C<SAFEARRAY>, the internal OLE array data type. This translation first
+determines the maximum nesting level used by the Perl array, and then
+creates a C<SAFEARRAY> of the same dimension. The C<@Bars> array
+already contains the data in the correct form for the spreadsheet:
+
+ ([Time1, Open1, High1, Low1, Close1],
+ ...
+ [TimeN, OpenN, HighN, LowN, CloseN])
+
+Now the table in the spreadsheet can be used to create a candle stick
+chart from our bars. Excel automatically chooses the time axis labels
+if they are selected before the chart is created:
+
+ # Create candle stick chart as new object on worksheet
+ $Sheet->Range("A:E")->Select;
+
+ my $Chart = $Book->Charts->Add;
+ $Chart->{ChartType} = xlStockOHLC;
+ $Chart->Location(xlLocationAsObject, $Sheet->{Name});
+ # Excel bug: the old $Chart is now invalid!
+ $Chart = $Excel->ActiveChart;
+
+We can change the type of the chart from a separate sheet to a chart
+object on the spreadsheet page with the C<< $Chart->Location >>
+method. (This invalidates the chart object handle, which might be
+considered a bug in Excel.) Fortunately, this new chart is still the
+'active' chart, so an object handle to it can be reclaimed simply by
+asking Excel.
+
+At this point, our chart still needs a title, the legend is
+meaningless, and the axis has decimals instead of fractions. We can
+fix those with the following code:
+
+ # Add title, remove legend
+ with($Chart, HasLegend => 0, HasTitle => 1);
+ $Chart->ChartTitle->Characters->{Text} = "US T-Bond";
+
+ # Set up daily statistics
+ $Open = $Bars[0][1];
+ $High = $Sheet->Evaluate("MAX(C:C)");
+ $Low = $Sheet->Evaluate("MIN(D:D)");
+ $Close = $Bars[$#Bars][4];
+
+The with() function partially mimics the Visual Basic With statement,
+but allows only property assignments. It's a convenient shortcut for
+this:
+
+ { # open new scope
+ my $Axis = $Chart->Axes(xlValue);
+ $Axis->{HasMajorGridlines} = 1;
+ $Axis->{HasMinorGridlines} = 1;
+ # etc ...
+ }
+
+The C<$High> and C<$Low> for the day are needed to determine the
+minimum and maximum scaling levels. MIN and MAX are spreadsheet
+functions, and aren't automatically available as methods. However,
+Excel provides an Evaluate() method to calculate arbitrary spreadsheet
+functions, so we can use that.
+
+We want the chart to show major gridlines at every fourth tick and
+minor gridlines at every second tick. The minimum and maximum are
+chosen to be whatever multiples of 1/16 we need to do that.
+
+ # Change tickmark spacing from decimal to fractional
+ with($Chart->Axes(xlValue),
+ HasMajorGridlines => 1,
+ HasMinorGridlines => 1,
+ MajorUnit => 1/8,
+ MinorUnit => 1/16,
+ MinimumScale => int($Low*16)/16,
+ MaximumScale => int($High*16+1)/16
+ );
+
+ # Fat candles with only 5% gaps
+ $Chart->ChartGroups(1)->{GapWidth} = 5;
+
+ sub RGB { $_[0] | ($_[1] >> 8) | ($_[2] >> 16) }
+
+ # White background with a solid border
+
+ $Chart->PlotArea->Border->{LineStyle} = xlContinuous;
+ $Chart->PlotArea->Border->{Color} = RGB(0,0,0);
+ $Chart->PlotArea->Interior->{Color} = RGB(255,255,255);
+
+ # Add 1 hour moving average of the Close series
+ my $MovAvg = $Chart->SeriesCollection(4)->Trendlines
+ ->Add({Type => xlMovingAvg, Period => 4});
+ $MovAvg->Border->{Color} = RGB(255,0,0);
+
+Now the finished workbook can be saved to disk as
+F<i:\tmp\tpj\data.xls>. That file most likely still exists from when the
+program ran yesterday, so we'll remove it. (Otherwise, Excel would pop
+up a dialog with a warning, because the SaveAs() method doesn't like
+to overwrite files.)
+
+
+ # Save workbook to file my $Filename = 'i:\tmp\tpj\data.xls';
+ unlink $Filename if -f $Filename;
+ $Book->SaveAs($Filename);
+ $Book->Close;
+
+=head2 ACTIVEX DATA OBJECTS
+
+Mary stores the daily prices in her T-bonds database, keeping the data
+for the different contracts in separate tables. After creating an ADO
+(ActiveX Data Object) connection to the database, she tries to connect
+a record set to the table for the current contract. If this fails, she
+assumes that the table doesn't exists yet and tries to create it:
+
+ use Win32::OLE::Const 'Microsoft ActiveX Data Objects';
+
+ my $Connection = Win32::OLE->new('ADODB.Connection');
+ my $Recordset = Win32::OLE->new('ADODB.Recordset');
+ $Connection->Open('T-Bonds');
+
+ # Open a record set for the table of this contract
+ {
+ local $Win32::OLE::Warn = 0;
+ $Recordset->Open($Contract, $Connection, adOpenKeyset,
+ adLockOptimistic, adCmdTable);
+ }
+
+ # Create table and index if it doesn't exist yet
+ if (Win32::OLE->LastError) {
+ $Connection->Execute(<<"SQL");
+ CREATE TABLE $Contract
+ (
+ Day DATETIME,
+ Open DOUBLE, High DOUBLE, Low DOUBLE, Close DOUBLE
+ )
+ SQL
+ $Connection->Execute(<<"SQL");
+ CREATE INDEX $Contract
+ ON $Contract (Day) WITH PRIMARY
+ SQL
+ $Recordset->Open($Contract, $Connection, adOpenKeyset,
+ adLockOptimistic, adCmdTable);
+ }
+
+C<$Win32::OLE::Warn> is temporarily set to zero, so that if
+C<$Recordset->Open> fails, the failure will be recorded silently without
+terminating the program. C<Win32::OLE->LastError> shows whether the Open
+failed or not. C<LastError> returns the OLE error code in a numeric
+context and the OLE error message in a string context, just like
+Perl's C<$!> variable.
+
+Now Mary can add today's data:
+
+ # Add new record to table
+ use Win32::OLE::Variant;
+ $Win32::OLE::Variant::LCID = $Win32::OLE::LCID;
+
+ my $Fields = [qw(Day Open High Low Close)];
+ my $Values = [Variant(VT_DATE, $Day),
+ $Open, $High, $Low, $Close];
+
+Mary uses the Win32::OLE::Variant module to store C<$Day> as a date
+instead of a mere string. She wants to make sure that it's stored as
+an American-style date, so in the third line shown here she sets the
+locale ID of the Win32::OLE::Variant module to match the Win32::OLE
+module. (C<$Win32::OLE::LCID> had been set earlier to English, since
+that's what the Chicago Board of Trade uses.)
+
+ {
+ local $Win32::OLE::Warn = 0;
+ $Recordset->AddNew($Fields, $Values);
+ }
+
+ # Replace existing record
+ if (Win32::OLE->LastError) {
+ $Recordset->CancelUpdate;
+ $Recordset->Close;
+ $Recordset->Open(<<"SQL", $Connection, adOpenDynamic);
+ SELECT * FROM $Contract
+ WHERE Day = #$Day#
+ SQL
+ $Recordset->Update($Fields, $Values);
+ }
+
+ $Recordset->Close;
+ $Connection->Close;
+
+The program expects to be able to add a new record to the table. It
+fails if a record for this date already exists, because the Day field
+is the primary index and therefore must be unique. If an error occurs,
+the update operation started by AddNew() must first be cancelled with
+C<< $Recordset->CancelUpdate >>; otherwise the record set won't close.
+
+=head2 LOTUS NOTES
+
+Now Mary can use Lotus Notes to mail updates to all her customers
+interested in the T-bond data. (Lotus Notes doesn't provide its
+constants in the OLE type library, so Mary had to determine them by
+playing around with LotusScript.) The actual task is quite simple: A
+Notes session must be started, the mail database must be opened and
+the mail message must be created. The body of the message is created
+as a rich text field, which lets her mix formatted text with object
+attachments.
+
+In her program, Mary extracts the email addresses from her customer
+database and sends separate message to each. Here, we've simplified it
+somewhat.
+
+ sub EMBED_ATTACHMENT {1454;} # from LotusScript
+
+ my $Notes = Win32::OLE->new('Notes.NotesSession');
+ my $Database = $Notes->GetDatabase('', '');
+ $Database->OpenMail;
+ my $Document = $Database->CreateDocument;
+
+ $Document->{Form} = 'Memo';
+ $Document->{SendTo} = ['Jon Orwant >orwant@tpj.com>',
+ 'Jan Dubois >jan.dubois@ibm.net>'];
+ $Document->{Subject} = "US T-Bonds Chart for $Day";
+
+ my $Body = $Document->CreateRichtextItem('Body');
+ $Body->AppendText(<<"EOT");
+ I\'ve attached the latest US T-Bond data and chart for $Day.
+ The daily statistics were:
+
+ \tOpen\t$Open
+ \tHigh\t$High
+ \tLow\t$Low
+ \tClose\t$Close
+
+ Kind regards,
+
+ Mary
+ EOT
+
+ $Body->EmbedObject(EMBED_ATTACHMENT, '', $Filename);
+
+ $Document->Send(0);
+
+=head1 VARIANTS
+
+In this final section, I'll talk about Variants, which are the data
+types that you use to talk to OLE objects. We talked about this line
+earlier:
+
+ my $Values = [Variant(VT_DATE, $Day),
+ $Open, $High, $Low, $Close];
+
+Here, the Variant() function creates a Variant object, of type C<VT_DATE>
+and with the value C<$Day>. Variants are similar in many ways to Perl
+scalars. Arguments to OLE methods are transparently converted from
+their internal Perl representation to Variants and back again by the
+Win32::OLE module.
+
+OLE automation uses a generic C<VARIANT> data type to pass
+parameters. This data type contains type information in addition to
+the actual data value. Only the following data types are valid for OLE
+automation:
+
+ B<Data Type Meaning>
+ VT_EMPTY Not specified
+ VT_NULL Null
+ VT_I2 2 byte signed integer
+ VT_I4 4 byte signed integer
+ VT_R4 4 byte real
+ VT_R8 8 byte real
+ VT_CY Currency
+ VT_DATE Date
+ VT_BSTR Unicode string
+ VT_DISPATCH OLE automation interface
+ VT_ERROR Error
+ VT_BOOL Boolean
+ VT_VARIANT (only valid with VT_BYREF)
+ VT_UNKNOWN Generic COM interface
+ VT_UI1 Unsigned character
+
+The following two flags can also be used:
+
+ VT_ARRAY Array of values
+ VT_BYREF Pass by reference (instead of by value)
+
+B<The Perl to Variant transformation.> The following conversions are
+performed automatically whenever a Perl value must be translated into
+a Variant:
+
+ Perl value Variant
+ Integer values VT_I4
+ Real values VT_R8
+ Strings VT_BSTR
+ undef VT_ERROR (DISP_E_PARAMNOTFOUND)
+ Array reference VT_VARIANT | VT_ARRAY
+ Win32::OLE object VT_DISPATCH
+ Win32::OLE::Variant object Type of the Variant object
+
+What if your Perl value is a list of lists? Those can be irregularly
+shaped in Perl; that is, the subsidiary lists needn't have the same
+number of elements. In this case, the structure will be converted to a
+"rectangular" C<SAFEARRAY> of Variants, with unused slots set to
+C<VT_EMPTY>. Consider this Perl 2-D array:
+
+ [ ["Perl" ], # one element
+ [1, 3.1215, undef] # three elements
+ ]
+
+This will be translated to a 2 by 3 C<SAFEARRAY> that looks like this:
+
+ VT_BSTR("Perl") VT_EMPTY VT_EMPTY
+ VT_I4(1) VT_R8(3.1415) VT_ERROR(DISP_E_PARAMNOTFOUND)
+
+B<The Variant To Perl Transformation.> Automatic conversion from Variants
+to Perl values happens as follows:
+
+ Variant Perl value
+ VT_BOOL, VT_ERROR Integer
+ VT_UI1, VT_I2, VT_I4 Integer
+ VT_R4, VT_R8 Float value
+ VT_BSTR String
+ VT_DISPATCH Win32::OLE object
+
+B<The Win32::OLE::Variant module.> This module provides access to the
+Variant data type, which gives you more control over how these
+arguments to OLE methods are encoded. (This is rarely necessary if you
+have a good grasp of the default conversion rules.) A Variant object
+can be created with the C<< Win32::OLE::Variant->new >> method or the
+equivalent Variant() function:
+
+ use Win32::OLE::Variant;
+ my $var1 = Win32::OLE::Variant->new(VT_DATE, 'Jan 1,1970');
+ my $var2 = Variant(VT_BSTR, 'This is an Unicode string');
+
+Several methods let you inspect and manipulate Variant objects: The
+Type() and Value() methods return the variant type and value; the As()
+method returns the value after converting it to a different variant
+type; ChangeType() coerces the Variant into a different type; and
+Unicode() returns the value of a Variant object as an object of the
+Unicode::String class.
+
+These conversions are more interesting if they can be applied directly
+to the return value of an OLE method call without first mutilating the
+value with default conversions. This is possible with the following
+trick:
+
+ my $RetVal = Variant(VT_EMPTY, undef);
+ $Object->Dispatch($Method, $RetVal, @Arguments);
+
+Normally, you wouldn't call Dispatch() directly; it's executed
+implicitly by either AUTOLOAD() or Invoke(). If Dispatch() realizes
+that the return value is already a Win32::OLE::Variant object, the
+return value is not translated into a Perl representation but rather
+copied verbatim into the Variant object.
+
+Whenever a Win32::OLE::Variant object is used in a numeric or string
+context it is automatically converted into the corresponding format.
+
+ printf "Number: %f and String: %s\n",
+ $Var, $Var;
+
+This is equivalent to:
+
+ printf "Number: %f and String: %s\n",
+ $Var->As(VT_R8), $Var->As(VT_BSTR);
+
+For methods that modify their arguments, you need to use the C<VT_BYREF>
+flag. This lets you create number and string Variants that can be
+modified by OLE methods. Here, Corel's GetSize() method takes two
+integers and stores the C<x> and C<y> dimensions in them:
+
+ my $x = Variant( VT_I4 | VT_BYREF, 0);
+ my $y = Variant( VT_I4 | VT_BYREF, 0);
+ $Corel->GetSize($x, $y);
+
+C<VT_BYREF> support for other Variant types might appear in future
+releases of Win32::OLE.
+
+=head1 FURTHER INFORMATION
+
+=head2 DOCUMENTATION AND EXAMPLE CODE
+
+More information about the OLE modules can be found in the
+documentation bundled with Win32::OLE. The distribution also contains
+other code samples.
+
+The object model for Microsoft Office applications can be found in the
+Visual Basic Reference for Microsoft Access, Excel, Word, or
+PowerPoint. These help files are not installed by default, but they
+can be added later by rerunning F<setup.exe> and choosing I<custom
+setup>. The object model for Microsoft Outlook can be found on the
+Microsoft Office Developer Forum at:
+http://www.microsoft.com/OutlookDev/.
+
+Information about the LotusScript object model can be found at:
+http://www.lotus.com/products/lotusscript.nsf.
+
+=head2 OLE AUTOMATION ON OTHER PLATFORMS
+
+Microsoft also makes OLE technology available for the Mac. DCOM is
+already included in Windows NT 4.0 and can be downloaded for Windows
+95. MVS and some Unix systems can use EntireX to get OLE
+functionality; see
+http://www.softwareag.com/corporat/solutions/entirex/entirex.htm.
+
+=head1 COPYRIGHT
+
+Copyright 1998 I<The Perl Journal>. http://www.tpj.com
+
+This article originally appeared in I<The Perl Journal> #10. It
+appears courtesy of Jon Orwant and I<The Perl Journal>. This document
+may be distributed under the same terms as Perl itself.
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/OLE/TypeInfo.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/OLE/TypeInfo.pm
new file mode 100644
index 0000000000..d95399c1e2
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/OLE/TypeInfo.pm
@@ -0,0 +1,389 @@
+# This module is still experimental and intentionally undocumented.
+# If you don't know why it is here, then you should probably not use it.
+
+package Win32::OLE::TypeInfo;
+
+use strict;
+use vars qw(@ISA @EXPORT @EXPORT_OK);
+use vars qw(@VT %TYPEFLAGS @TYPEKIND %IMPLTYPEFLAGS %PARAMFLAGS
+ %FUNCFLAGS @CALLCONV @FUNCKIND %INVOKEKIND %VARFLAGS
+ %LIBFLAGS @SYSKIND);
+
+use Exporter;
+@ISA = qw(Exporter);
+
+@EXPORT = qw(
+ VT_EMPTY VT_NULL VT_I2 VT_I4 VT_R4 VT_R8 VT_CY VT_DATE
+ VT_BSTR VT_DISPATCH VT_ERROR VT_BOOL VT_VARIANT VT_UNKNOWN
+ VT_DECIMAL VT_I1 VT_UI1 VT_UI2 VT_UI4 VT_I8 VT_UI8 VT_INT
+ VT_UINT VT_VOID VT_HRESULT VT_PTR VT_SAFEARRAY VT_CARRAY
+ VT_USERDEFINED VT_LPSTR VT_LPWSTR VT_FILETIME VT_BLOB
+ VT_STREAM VT_STORAGE VT_STREAMED_OBJECT VT_STORED_OBJECT
+ VT_BLOB_OBJECT VT_CF VT_CLSID VT_VECTOR VT_ARRAY VT_BYREF
+ VT_RESERVED VT_ILLEGAL VT_ILLEGALMASKED VT_TYPEMASK
+
+ TYPEFLAG_FAPPOBJECT TYPEFLAG_FCANCREATE TYPEFLAG_FLICENSED
+ TYPEFLAG_FPREDECLID TYPEFLAG_FHIDDEN TYPEFLAG_FCONTROL
+ TYPEFLAG_FDUAL TYPEFLAG_FNONEXTENSIBLE TYPEFLAG_FOLEAUTOMATION
+ TYPEFLAG_FRESTRICTED TYPEFLAG_FAGGREGATABLE TYPEFLAG_FREPLACEABLE
+ TYPEFLAG_FDISPATCHABLE TYPEFLAG_FREVERSEBIND
+
+ TKIND_ENUM TKIND_RECORD TKIND_MODULE TKIND_INTERFACE TKIND_DISPATCH
+ TKIND_COCLASS TKIND_ALIAS TKIND_UNION TKIND_MAX
+
+ IMPLTYPEFLAG_FDEFAULT IMPLTYPEFLAG_FSOURCE IMPLTYPEFLAG_FRESTRICTED
+ IMPLTYPEFLAG_FDEFAULTVTABLE
+
+ PARAMFLAG_NONE PARAMFLAG_FIN PARAMFLAG_FOUT PARAMFLAG_FLCID
+ PARAMFLAG_FRETVAL PARAMFLAG_FOPT PARAMFLAG_FHASDEFAULT
+
+ FUNCFLAG_FRESTRICTED FUNCFLAG_FSOURCE FUNCFLAG_FBINDABLE
+ FUNCFLAG_FREQUESTEDIT FUNCFLAG_FDISPLAYBIND FUNCFLAG_FDEFAULTBIND
+ FUNCFLAG_FHIDDEN FUNCFLAG_FUSESGETLASTERROR FUNCFLAG_FDEFAULTCOLLELEM
+ FUNCFLAG_FUIDEFAULT FUNCFLAG_FNONBROWSABLE FUNCFLAG_FREPLACEABLE
+ FUNCFLAG_FIMMEDIATEBIND
+
+ CC_FASTCALL CC_CDECL CC_MSCPASCAL CC_PASCAL CC_MACPASCAL CC_STDCALL
+ CC_FPFASTCALL CC_SYSCALL CC_MPWCDECL CC_MPWPASCAL CC_MAX
+
+ INVOKE_FUNC INVOKE_PROPERTYGET INVOKE_PROPERTYPUT INVOKE_PROPERTYPUTREF
+
+ VARFLAG_FREADONLY VARFLAG_FSOURCE VARFLAG_FBINDABLE VARFLAG_FREQUESTEDIT
+ VARFLAG_FDISPLAYBIND VARFLAG_FDEFAULTBIND VARFLAG_FHIDDEN VARFLAG_FRESTRICTED
+ VARFLAG_FDEFAULTCOLLELEM VARFLAG_FUIDEFAULT VARFLAG_FNONBROWSABLE
+ VARFLAG_FREPLACEABLE VARFLAG_FIMMEDIATEBIND
+
+ LIBFLAG_FRESTRICTED LIBFLAG_FCONTROL LIBFLAG_FHIDDEN
+ SYS_WIN16 SYS_WIN32 SYS_MAC
+
+ FUNC_VIRTUAL FUNC_PUREVIRTUAL FUNC_NONVIRTUAL FUNC_STATIC FUNC_DISPATCH
+
+ @VT %TYPEFLAGS @TYPEKIND %IMPLTYPEFLAGS %PARAMFLAGS
+ %FUNCFLAGS @CALLCONV @FUNCKIND %INVOKEKIND %VARFLAGS %LIBFLAGS @SYSKIND
+);
+
+# Lib Flags
+# ---------
+
+sub LIBFLAG_FRESTRICTED () { 0x01; }
+sub LIBFLAG_FCONTROL () { 0x02; }
+sub LIBFLAG_FHIDDEN () { 0x04; }
+
+$LIBFLAGS{LIBFLAG_FRESTRICTED()} = LIBFLAG_FRESTRICTED;
+$LIBFLAGS{LIBFLAG_FCONTROL()} = LIBFLAG_FCONTROL;
+$LIBFLAGS{LIBFLAG_FHIDDEN()} = LIBFLAG_FHIDDEN;
+
+# Sys Kind
+# --------
+
+sub SYS_WIN16 () { 0; }
+sub SYS_WIN32 () { SYS_WIN16() + 1; }
+sub SYS_MAC () { SYS_WIN32() + 1; }
+
+$SYSKIND[SYS_WIN16] = 'SYS_WIN16';
+$SYSKIND[SYS_WIN32] = 'SYS_WIN32';
+$SYSKIND[SYS_MAC] = 'SYS_MAC';
+
+# Type Flags
+# ----------
+
+sub TYPEFLAG_FAPPOBJECT () { 0x1; }
+sub TYPEFLAG_FCANCREATE () { 0x2; }
+sub TYPEFLAG_FLICENSED () { 0x4; }
+sub TYPEFLAG_FPREDECLID () { 0x8; }
+sub TYPEFLAG_FHIDDEN () { 0x10; }
+sub TYPEFLAG_FCONTROL () { 0x20; }
+sub TYPEFLAG_FDUAL () { 0x40; }
+sub TYPEFLAG_FNONEXTENSIBLE () { 0x80; }
+sub TYPEFLAG_FOLEAUTOMATION () { 0x100; }
+sub TYPEFLAG_FRESTRICTED () { 0x200; }
+sub TYPEFLAG_FAGGREGATABLE () { 0x400; }
+sub TYPEFLAG_FREPLACEABLE () { 0x800; }
+sub TYPEFLAG_FDISPATCHABLE () { 0x1000; }
+sub TYPEFLAG_FREVERSEBIND () { 0x2000; }
+
+$TYPEFLAGS{TYPEFLAG_FAPPOBJECT()} = TYPEFLAG_FAPPOBJECT;
+$TYPEFLAGS{TYPEFLAG_FCANCREATE()} = TYPEFLAG_FCANCREATE;
+$TYPEFLAGS{TYPEFLAG_FLICENSED()} = TYPEFLAG_FLICENSED;
+$TYPEFLAGS{TYPEFLAG_FPREDECLID()} = TYPEFLAG_FPREDECLID;
+$TYPEFLAGS{TYPEFLAG_FHIDDEN()} = TYPEFLAG_FHIDDEN;
+$TYPEFLAGS{TYPEFLAG_FCONTROL()} = TYPEFLAG_FCONTROL;
+$TYPEFLAGS{TYPEFLAG_FDUAL()} = TYPEFLAG_FDUAL;
+$TYPEFLAGS{TYPEFLAG_FNONEXTENSIBLE()} = TYPEFLAG_FNONEXTENSIBLE;
+$TYPEFLAGS{TYPEFLAG_FOLEAUTOMATION()} = TYPEFLAG_FOLEAUTOMATION;
+$TYPEFLAGS{TYPEFLAG_FRESTRICTED()} = TYPEFLAG_FRESTRICTED;
+$TYPEFLAGS{TYPEFLAG_FAGGREGATABLE()} = TYPEFLAG_FAGGREGATABLE;
+$TYPEFLAGS{TYPEFLAG_FREPLACEABLE()} = TYPEFLAG_FREPLACEABLE;
+$TYPEFLAGS{TYPEFLAG_FDISPATCHABLE()} = TYPEFLAG_FDISPATCHABLE;
+$TYPEFLAGS{TYPEFLAG_FREVERSEBIND()} = TYPEFLAG_FREVERSEBIND;
+
+# Type Kind
+# ---------
+
+sub TKIND_ENUM () { 0; }
+sub TKIND_RECORD () { TKIND_ENUM() + 1; }
+sub TKIND_MODULE () { TKIND_RECORD() + 1; }
+sub TKIND_INTERFACE () { TKIND_MODULE() + 1; }
+sub TKIND_DISPATCH () { TKIND_INTERFACE() + 1; }
+sub TKIND_COCLASS () { TKIND_DISPATCH() + 1; }
+sub TKIND_ALIAS () { TKIND_COCLASS() + 1; }
+sub TKIND_UNION () { TKIND_ALIAS() + 1; }
+sub TKIND_MAX () { TKIND_UNION() + 1; }
+
+$TYPEKIND[TKIND_ENUM] = 'TKIND_ENUM';
+$TYPEKIND[TKIND_RECORD] = 'TKIND_RECORD';
+$TYPEKIND[TKIND_MODULE] = 'TKIND_MODULE';
+$TYPEKIND[TKIND_INTERFACE] = 'TKIND_INTERFACE';
+$TYPEKIND[TKIND_DISPATCH] = 'TKIND_DISPATCH';
+$TYPEKIND[TKIND_COCLASS] = 'TKIND_COCLASS';
+$TYPEKIND[TKIND_ALIAS] = 'TKIND_ALIAS';
+$TYPEKIND[TKIND_UNION] = 'TKIND_UNION';
+
+# Implemented Type Flags
+# ----------------------
+
+sub IMPLTYPEFLAG_FDEFAULT () { 0x1; }
+sub IMPLTYPEFLAG_FSOURCE () { 0x2; }
+sub IMPLTYPEFLAG_FRESTRICTED () { 0x4; }
+sub IMPLTYPEFLAG_FDEFAULTVTABLE () { 0x800; }
+
+$IMPLTYPEFLAGS{IMPLTYPEFLAG_FDEFAULT()} = IMPLTYPEFLAG_FDEFAULT;
+$IMPLTYPEFLAGS{IMPLTYPEFLAG_FSOURCE()} = IMPLTYPEFLAG_FSOURCE;
+$IMPLTYPEFLAGS{IMPLTYPEFLAG_FRESTRICTED()} = IMPLTYPEFLAG_FRESTRICTED;
+$IMPLTYPEFLAGS{IMPLTYPEFLAG_FDEFAULTVTABLE()} = IMPLTYPEFLAG_FDEFAULTVTABLE;
+
+# Parameter Flags
+# ---------------
+
+sub PARAMFLAG_NONE () { 0; }
+sub PARAMFLAG_FIN () { 0x1; }
+sub PARAMFLAG_FOUT () { 0x2; }
+sub PARAMFLAG_FLCID () { 0x4; }
+sub PARAMFLAG_FRETVAL () { 0x8; }
+sub PARAMFLAG_FOPT () { 0x10; }
+sub PARAMFLAG_FHASDEFAULT () { 0x20; }
+
+$PARAMFLAGS{PARAMFLAG_NONE()} = PARAMFLAG_NONE;
+$PARAMFLAGS{PARAMFLAG_FIN()} = PARAMFLAG_FIN;
+$PARAMFLAGS{PARAMFLAG_FOUT()} = PARAMFLAG_FOUT;
+$PARAMFLAGS{PARAMFLAG_FLCID()} = PARAMFLAG_FLCID;
+$PARAMFLAGS{PARAMFLAG_FRETVAL()} = PARAMFLAG_FRETVAL;
+$PARAMFLAGS{PARAMFLAG_FOPT()} = PARAMFLAG_FOPT;
+$PARAMFLAGS{PARAMFLAG_FHASDEFAULT()} = PARAMFLAG_FHASDEFAULT;
+
+# Function Flags
+# --------------
+
+sub FUNCFLAG_FRESTRICTED () { 0x1; }
+sub FUNCFLAG_FSOURCE () { 0x2; }
+sub FUNCFLAG_FBINDABLE () { 0x4; }
+sub FUNCFLAG_FREQUESTEDIT () { 0x8; }
+sub FUNCFLAG_FDISPLAYBIND () { 0x10; }
+sub FUNCFLAG_FDEFAULTBIND () { 0x20; }
+sub FUNCFLAG_FHIDDEN () { 0x40; }
+sub FUNCFLAG_FUSESGETLASTERROR () { 0x80; }
+sub FUNCFLAG_FDEFAULTCOLLELEM () { 0x100; }
+sub FUNCFLAG_FUIDEFAULT () { 0x200; }
+sub FUNCFLAG_FNONBROWSABLE () { 0x400; }
+sub FUNCFLAG_FREPLACEABLE () { 0x800; }
+sub FUNCFLAG_FIMMEDIATEBIND () { 0x1000; }
+
+$FUNCFLAGS{FUNCFLAG_FRESTRICTED()} = FUNCFLAG_FRESTRICTED;
+$FUNCFLAGS{FUNCFLAG_FSOURCE()} = FUNCFLAG_FSOURCE;
+$FUNCFLAGS{FUNCFLAG_FBINDABLE()} = FUNCFLAG_FBINDABLE;
+$FUNCFLAGS{FUNCFLAG_FREQUESTEDIT()} = FUNCFLAG_FREQUESTEDIT;
+$FUNCFLAGS{FUNCFLAG_FDISPLAYBIND()} = FUNCFLAG_FDISPLAYBIND;
+$FUNCFLAGS{FUNCFLAG_FDEFAULTBIND()} = FUNCFLAG_FDEFAULTBIND;
+$FUNCFLAGS{FUNCFLAG_FHIDDEN()} = FUNCFLAG_FHIDDEN;
+$FUNCFLAGS{FUNCFLAG_FUSESGETLASTERROR()} = FUNCFLAG_FUSESGETLASTERROR;
+$FUNCFLAGS{FUNCFLAG_FDEFAULTCOLLELEM()} = FUNCFLAG_FDEFAULTCOLLELEM;
+$FUNCFLAGS{FUNCFLAG_FUIDEFAULT()} = FUNCFLAG_FUIDEFAULT;
+$FUNCFLAGS{FUNCFLAG_FNONBROWSABLE()} = FUNCFLAG_FNONBROWSABLE;
+$FUNCFLAGS{FUNCFLAG_FREPLACEABLE()} = FUNCFLAG_FREPLACEABLE;
+$FUNCFLAGS{FUNCFLAG_FIMMEDIATEBIND()} = FUNCFLAG_FIMMEDIATEBIND;
+
+# Calling conventions
+# -------------------
+
+sub CC_FASTCALL () { 0; }
+sub CC_CDECL () { 1; }
+sub CC_MSCPASCAL () { CC_CDECL() + 1; }
+sub CC_PASCAL () { CC_MSCPASCAL; }
+sub CC_MACPASCAL () { CC_PASCAL() + 1; }
+sub CC_STDCALL () { CC_MACPASCAL() + 1; }
+sub CC_FPFASTCALL () { CC_STDCALL() + 1; }
+sub CC_SYSCALL () { CC_FPFASTCALL() + 1; }
+sub CC_MPWCDECL () { CC_SYSCALL() + 1; }
+sub CC_MPWPASCAL () { CC_MPWCDECL() + 1; }
+sub CC_MAX () { CC_MPWPASCAL() + 1; }
+
+$CALLCONV[CC_FASTCALL] = 'CC_FASTCALL';
+$CALLCONV[CC_CDECL] = 'CC_CDECL';
+$CALLCONV[CC_PASCAL] = 'CC_PASCAL';
+$CALLCONV[CC_MACPASCAL] = 'CC_MACPASCAL';
+$CALLCONV[CC_STDCALL] = 'CC_STDCALL';
+$CALLCONV[CC_FPFASTCALL] = 'CC_FPFASTCALL';
+$CALLCONV[CC_SYSCALL] = 'CC_SYSCALL';
+$CALLCONV[CC_MPWCDECL] = 'CC_MPWCDECL';
+$CALLCONV[CC_MPWPASCAL] = 'CC_MPWPASCAL';
+
+# Function Kind
+# -------------
+
+sub FUNC_VIRTUAL () { 0; }
+sub FUNC_PUREVIRTUAL () { FUNC_VIRTUAL() + 1; }
+sub FUNC_NONVIRTUAL () { FUNC_PUREVIRTUAL() + 1; }
+sub FUNC_STATIC () { FUNC_NONVIRTUAL() + 1; }
+sub FUNC_DISPATCH () { FUNC_STATIC() + 1; }
+
+$FUNCKIND[FUNC_VIRTUAL] = 'FUNC_VIRTUAL';
+$FUNCKIND[FUNC_PUREVIRTUAL] = 'FUNC_PUREVIRTUAL';
+$FUNCKIND[FUNC_NONVIRTUAL] = 'FUNC_NONVIRTUAL';
+$FUNCKIND[FUNC_STATIC] = 'FUNC_STATIC';
+$FUNCKIND[FUNC_DISPATCH] = 'FUNC_DISPATCH';
+
+# Invoke Kind
+# -----------
+
+sub INVOKE_FUNC () { 1; }
+sub INVOKE_PROPERTYGET () { 2; }
+sub INVOKE_PROPERTYPUT () { 4; }
+sub INVOKE_PROPERTYPUTREF () { 8; }
+
+$INVOKEKIND{INVOKE_FUNC()} = INVOKE_FUNC;
+$INVOKEKIND{INVOKE_PROPERTYGET()} = INVOKE_PROPERTYGET;
+$INVOKEKIND{INVOKE_PROPERTYPUT()} = INVOKE_PROPERTYPUT;
+$INVOKEKIND{INVOKE_PROPERTYPUTREF()} = INVOKE_PROPERTYPUTREF;
+
+# Variable Flags
+# --------------
+
+sub VARFLAG_FREADONLY () { 0x1; }
+sub VARFLAG_FSOURCE () { 0x2; }
+sub VARFLAG_FBINDABLE () { 0x4; }
+sub VARFLAG_FREQUESTEDIT () { 0x8; }
+sub VARFLAG_FDISPLAYBIND () { 0x10; }
+sub VARFLAG_FDEFAULTBIND () { 0x20; }
+sub VARFLAG_FHIDDEN () { 0x40; }
+sub VARFLAG_FRESTRICTED () { 0x80; }
+sub VARFLAG_FDEFAULTCOLLELEM () { 0x100; }
+sub VARFLAG_FUIDEFAULT () { 0x200; }
+sub VARFLAG_FNONBROWSABLE () { 0x400; }
+sub VARFLAG_FREPLACEABLE () { 0x800; }
+sub VARFLAG_FIMMEDIATEBIND () { 0x1000; }
+
+$VARFLAGS{VARFLAG_FREADONLY()} = VARFLAG_FREADONLY;
+$VARFLAGS{VARFLAG_FSOURCE()} = VARFLAG_FSOURCE;
+$VARFLAGS{VARFLAG_FBINDABLE()} = VARFLAG_FBINDABLE;
+$VARFLAGS{VARFLAG_FREQUESTEDIT()} = VARFLAG_FREQUESTEDIT;
+$VARFLAGS{VARFLAG_FDISPLAYBIND()} = VARFLAG_FDISPLAYBIND;
+$VARFLAGS{VARFLAG_FDEFAULTBIND()} = VARFLAG_FDEFAULTBIND;
+$VARFLAGS{VARFLAG_FHIDDEN()} = VARFLAG_FHIDDEN;
+$VARFLAGS{VARFLAG_FRESTRICTED()} = VARFLAG_FRESTRICTED;
+$VARFLAGS{VARFLAG_FDEFAULTCOLLELEM()} = VARFLAG_FDEFAULTCOLLELEM;
+$VARFLAGS{VARFLAG_FUIDEFAULT()} = VARFLAG_FUIDEFAULT;
+$VARFLAGS{VARFLAG_FNONBROWSABLE()} = VARFLAG_FNONBROWSABLE;
+$VARFLAGS{VARFLAG_FREPLACEABLE()} = VARFLAG_FREPLACEABLE;
+$VARFLAGS{VARFLAG_FIMMEDIATEBIND()} = VARFLAG_FIMMEDIATEBIND;
+
+
+# Variant Types
+# -------------
+
+sub VT_EMPTY () { 0; }
+sub VT_NULL () { 1; }
+sub VT_I2 () { 2; }
+sub VT_I4 () { 3; }
+sub VT_R4 () { 4; }
+sub VT_R8 () { 5; }
+sub VT_CY () { 6; }
+sub VT_DATE () { 7; }
+sub VT_BSTR () { 8; }
+sub VT_DISPATCH () { 9; }
+sub VT_ERROR () { 10; }
+sub VT_BOOL () { 11; }
+sub VT_VARIANT () { 12; }
+sub VT_UNKNOWN () { 13; }
+sub VT_DECIMAL () { 14; }
+sub VT_I1 () { 16; }
+sub VT_UI1 () { 17; }
+sub VT_UI2 () { 18; }
+sub VT_UI4 () { 19; }
+sub VT_I8 () { 20; }
+sub VT_UI8 () { 21; }
+sub VT_INT () { 22; }
+sub VT_UINT () { 23; }
+sub VT_VOID () { 24; }
+sub VT_HRESULT () { 25; }
+sub VT_PTR () { 26; }
+sub VT_SAFEARRAY () { 27; }
+sub VT_CARRAY () { 28; }
+sub VT_USERDEFINED () { 29; }
+sub VT_LPSTR () { 30; }
+sub VT_LPWSTR () { 31; }
+sub VT_FILETIME () { 64; }
+sub VT_BLOB () { 65; }
+sub VT_STREAM () { 66; }
+sub VT_STORAGE () { 67; }
+sub VT_STREAMED_OBJECT () { 68; }
+sub VT_STORED_OBJECT () { 69; }
+sub VT_BLOB_OBJECT () { 70; }
+sub VT_CF () { 71; }
+sub VT_CLSID () { 72; }
+sub VT_VECTOR () { 0x1000; }
+sub VT_ARRAY () { 0x2000; }
+sub VT_BYREF () { 0x4000; }
+sub VT_RESERVED () { 0x8000; }
+sub VT_ILLEGAL () { 0xffff; }
+sub VT_ILLEGALMASKED () { 0xfff; }
+sub VT_TYPEMASK () { 0xfff; }
+
+$VT[VT_EMPTY] = 'VT_EMPTY';
+$VT[VT_NULL] = 'VT_NULL';
+$VT[VT_I2] = 'VT_I2';
+$VT[VT_I4] = 'VT_I4';
+$VT[VT_R4] = 'VT_R4';
+$VT[VT_R8] = 'VT_R8';
+$VT[VT_CY] = 'VT_CY';
+$VT[VT_DATE] = 'VT_DATE';
+$VT[VT_BSTR] = 'VT_BSTR';
+$VT[VT_DISPATCH] = 'VT_DISPATCH';
+$VT[VT_ERROR] = 'VT_ERROR';
+$VT[VT_BOOL] = 'VT_BOOL';
+$VT[VT_VARIANT] = 'VT_VARIANT';
+$VT[VT_UNKNOWN] = 'VT_UNKNOWN';
+$VT[VT_DECIMAL] = 'VT_DECIMAL';
+$VT[VT_I1] = 'VT_I1';
+$VT[VT_UI1] = 'VT_UI1';
+$VT[VT_UI2] = 'VT_UI2';
+$VT[VT_UI4] = 'VT_UI4';
+$VT[VT_I8] = 'VT_I8';
+$VT[VT_UI8] = 'VT_UI8';
+$VT[VT_INT] = 'VT_INT';
+$VT[VT_UINT] = 'VT_UINT';
+$VT[VT_VOID] = 'VT_VOID';
+$VT[VT_HRESULT] = 'VT_HRESULT';
+$VT[VT_PTR] = 'VT_PTR';
+$VT[VT_SAFEARRAY] = 'VT_SAFEARRAY';
+$VT[VT_CARRAY] = 'VT_CARRAY';
+$VT[VT_USERDEFINED] = 'VT_USERDEFINED';
+$VT[VT_LPSTR] = 'VT_LPSTR';
+$VT[VT_LPWSTR] = 'VT_LPWSTR';
+$VT[VT_FILETIME] = 'VT_FILETIME';
+$VT[VT_BLOB] = 'VT_BLOB';
+$VT[VT_STREAM] = 'VT_STREAM';
+$VT[VT_STORAGE] = 'VT_STORAGE';
+$VT[VT_STREAMED_OBJECT] = 'VT_STREAMED_OBJECT';
+$VT[VT_STORED_OBJECT] = 'VT_STORED_OBJECT';
+$VT[VT_BLOB_OBJECT] = 'VT_BLOB_OBJECT';
+$VT[VT_CF] = 'VT_CF';
+$VT[VT_CLSID] = 'VT_CLSID';
+$VT[VT_VECTOR] = 'VT_VECTOR';
+$VT[VT_ARRAY] = 'VT_ARRAY';
+$VT[VT_BYREF] = 'VT_BYREF';
+$VT[VT_RESERVED] = 'VT_RESERVED';
+$VT[VT_ILLEGAL] = 'VT_ILLEGAL';
+$VT[VT_ILLEGALMASKED] = 'VT_ILLEGALMASKED';
+$VT[VT_TYPEMASK] = 'VT_TYPEMASK';
+
+1;
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/OLE/Variant.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/OLE/Variant.pm
new file mode 100644
index 0000000000..38fc604820
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/OLE/Variant.pm
@@ -0,0 +1,577 @@
+# The documentation is at the __END__
+
+package Win32::OLE::Variant;
+require Win32::OLE; # Make sure the XS bootstrap has been called
+
+use strict;
+use vars qw(@ISA @EXPORT @EXPORT_OK);
+
+use Exporter;
+@ISA = qw(Exporter);
+
+@EXPORT = qw(
+ Variant
+ VT_EMPTY VT_NULL VT_I2 VT_I4 VT_R4 VT_R8 VT_CY VT_DATE VT_BSTR
+ VT_DISPATCH VT_ERROR VT_BOOL VT_VARIANT VT_UNKNOWN VT_DECIMAL VT_UI1
+ VT_ARRAY VT_BYREF
+ );
+
+@EXPORT_OK = qw(CP_ACP CP_OEMCP nothing nullstring);
+
+# Automation data types.
+sub VT_EMPTY {0;}
+sub VT_NULL {1;}
+sub VT_I2 {2;}
+sub VT_I4 {3;}
+sub VT_R4 {4;}
+sub VT_R8 {5;}
+sub VT_CY {6;}
+sub VT_DATE {7;}
+sub VT_BSTR {8;}
+sub VT_DISPATCH {9;}
+sub VT_ERROR {10;}
+sub VT_BOOL {11;}
+sub VT_VARIANT {12;}
+sub VT_UNKNOWN {13;}
+sub VT_DECIMAL {14;} # Officially not allowed in VARIANTARGs
+sub VT_UI1 {17;}
+
+sub VT_ARRAY {0x2000;}
+sub VT_BYREF {0x4000;}
+
+
+# For backward compatibility
+sub CP_ACP {0;} # ANSI codepage
+sub CP_OEMCP {1;} # OEM codepage
+
+use overload
+ # '+' => 'Add', '-' => 'Sub', '*' => 'Mul', '/' => 'Div',
+ '""' => sub {$_[0]->As(VT_BSTR)},
+ '0+' => sub {$_[0]->As(VT_R8)},
+ fallback => 1;
+
+sub Variant {
+ return Win32::OLE::Variant->new(@_);
+}
+
+sub nothing {
+ return Win32::OLE::Variant->new(VT_DISPATCH);
+}
+
+sub nullstring {
+ return Win32::OLE::Variant->new(VT_BSTR);
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Win32::OLE::Variant - Create and modify OLE VARIANT variables
+
+=head1 SYNOPSIS
+
+ use Win32::OLE::Variant;
+ my $var = Variant(VT_DATE, 'Jan 1,1970');
+ $OleObject->{value} = $var;
+ $OleObject->Method($var);
+
+
+=head1 DESCRIPTION
+
+The IDispatch interface used by the Perl OLE module uses a universal
+argument type called VARIANT. This is basically an object containing
+a data type and the actual data value. The data type is specified by
+the VT_xxx constants.
+
+=head2 Functions
+
+=over 8
+
+=item nothing()
+
+The nothing() function returns an empty VT_DISPATCH variant. It can be
+used to clear an object reference stored in a property
+
+ use Win32::OLE::Variant qw(:DEFAULT nothing);
+ # ...
+ $object->{Property} = nothing;
+
+This has the same effect as the Visual Basic statement
+
+ Set object.Property = Nothing
+
+The nothing() function is B<not> exported by default.
+
+=item nullstring()
+
+The nullstring() function returns a VT_BSTR variant with a NULL string
+pointer. This is B<not> the same as a VT_BSTR variant with an empty
+string "". The nullstring() value is the same as the vbNullString
+constant in Visual Basic.
+
+The nullstring() function is B<not> exported by default.
+
+=item Variant(TYPE, DATA)
+
+This is just a function alias of the C<Win32::OLE::Variant->new()>
+method (see below). This function is exported by default.
+
+=back
+
+=head2 Methods
+
+=over 8
+
+=item new(TYPE, DATA)
+
+This method returns a Win32::OLE::Variant object of the specified
+TYPE that contains the given DATA. The Win32::OLE::Variant object
+can be used to specify data types other than IV, NV or PV (which are
+supported transparently). See L<Variants> below for details.
+
+For VT_EMPTY and VT_NULL variants, the DATA argument may be omitted.
+For all non-VT_ARRAY variants DATA specifies the initial value.
+
+To create a SAFEARRAY variant, you have to specify the VT_ARRAY flag in
+addition to the variant base type of the array elements. In this cases
+DATA must be a list specifying the dimensions of the array. Each element
+can be either an element count (indices 0 to count-1) or an array
+reference pointing to the lower and upper array bounds of this dimension:
+
+ my $Array = Win32::OLE::Variant->new(VT_ARRAY|VT_R8, [1,2], 2);
+
+This creates a 2-dimensional SAFEARRAY of doubles with 4 elements:
+(1,0), (1,1), (2,0) and (2,1).
+
+A special case is the creation of one-dimensional VT_UI1 arrays with
+a string DATA argument:
+
+ my $String = Variant(VT_ARRAY|VT_UI1, "String");
+
+This creates a 6 element character array initialized to "String". For
+backward compatibility VT_UI1 with a string initializer automatically
+implies VT_ARRAY. The next line is equivalent to the previous example:
+
+ my $String = Variant(VT_UI1, "String");
+
+If you really need a single character VT_UI1 variant, you have to create
+it using a numeric intializer:
+
+ my $Char = Variant(VT_UI1, ord('A'));
+
+=item As(TYPE)
+
+C<As> converts the VARIANT to the new type before converting to a
+Perl value. This take the current LCID setting into account. For
+example a string might contain a ',' as the decimal point character.
+Using C<$variant->As(VT_R8)> will correctly return the floating
+point value.
+
+The underlying variant object is NOT changed by this method.
+
+=item ChangeType(TYPE)
+
+This method changes the type of the contained VARIANT in place. It
+returns the object itself, not the converted value.
+
+=item Copy([DIM])
+
+This method creates a copy of the object. If the original variant had
+the VT_BYREF bit set then the new object will contain a copy of the
+referenced data and not a reference to the same old data. The new
+object will not have the VT_BYREF bit set.
+
+ my $Var = Variant(VT_I4|VT_ARRAY|VT_BYREF, [1,5], 3);
+ my $Copy = $Var->Copy;
+
+The type of C<$Copy> is now VT_I4|VT_ARRAY and the value is a copy of
+the other SAFEARRAY. Changes to elements of C<$Var> will not be reflected
+in C<$Copy> and vice versa.
+
+The C<Copy> method can also be used to extract a single element of a
+VT_ARRAY | VT_VARIANT object. In this case the array indices must be
+specified as a list DIM:
+
+ my $Int = $Var->Copy(1, 2);
+
+C<$Int> is now a VT_I4 Variant object containing the value of element (1,2).
+
+=item Currency([FORMAT[, LCID]])
+
+This method converts the VARIANT value into a formatted currency string. The
+FORMAT can be either an integer constant or a hash reference. Valid constants
+are 0 and LOCALE_NOUSEROVERRIDE. You get the value of LOCALE_NOUSEROVERRIDE
+from the Win32::OLE::NLS module:
+
+ use Win32::OLE::NLS qw(:LOCALE);
+
+LOCALE_NOUSEROVERRIDE tells the method to use the system default currency
+format for the specified locale, disregarding any changes that might have
+been made through the control panel application.
+
+The hash reference could contain the following keys:
+
+ NumDigits number of fractional digits
+ LeadingZero whether to use leading zeroes in decimal fields
+ Grouping size of each group of digits to the left of the decimal
+ DecimalSep decimal separator string
+ ThousandSep thousand separator string
+ NegativeOrder see L<Win32::OLE::NLS/LOCALE_ICURRENCY>
+ PositiveOrder see L<Win32::OLE::NLS/LOCALE_INEGCURR>
+ CurrencySymbol currency symbol string
+
+For example:
+
+ use Win32::OLE::Variant;
+ use Win32::OLE::NLS qw(:DEFAULT :LANG :SUBLANG :DATE :TIME);
+ my $lcidGerman = MAKELCID(MAKELANGID(LANG_GERMAN, SUBLANG_NEUTRAL));
+ my $v = Variant(VT_CY, "-922337203685477.5808");
+ print $v->Currency({CurrencySymbol => "Tuits"}, $lcidGerman), "\n";
+
+will print:
+
+ -922.337.203.685.477,58 Tuits
+
+=item Date([FORMAT[, LCID]])
+
+Converts the VARIANT into a formatted date string. FORMAT can be either
+one of the following integer constants or a format string:
+
+ LOCALE_NOUSEROVERRIDE system default date format for this locale
+ DATE_SHORTDATE use the short date format (default)
+ DATE_LONGDATE use the long date format
+ DATE_YEARMONTH use the year/month format
+ DATE_USE_ALT_CALENDAR use the alternate calendar, if one exists
+ DATE_LTRREADING left-to-right reading order layout
+ DATE_RTLREADING right-to left reading order layout
+
+The constants are available from the Win32::OLE::NLS module:
+
+ use Win32::OLE::NLS qw(:LOCALE :DATE);
+
+The following elements can be used to construct a date format string.
+Characters must be specified exactly as given below (e.g. "dd" B<not> "DD").
+Spaces can be inserted anywhere between formatting codes, other verbatim
+text should be included in single quotes.
+
+ d day of month
+ dd day of month with leading zero for single-digit days
+ ddd day of week: three-letter abbreviation (LOCALE_SABBREVDAYNAME)
+ dddd day of week: full name (LOCALE_SDAYNAME)
+ M month
+ MM month with leading zero for single-digit months
+ MMM month: three-letter abbreviation (LOCALE_SABBREVMONTHNAME)
+ MMMM month: full name (LOCALE_SMONTHNAME)
+ y year as last two digits
+ yy year as last two digits with leading zero for years less than 10
+ yyyy year represented by full four digits
+ gg period/era string
+
+For example:
+
+ my $v = Variant(VT_DATE, "April 1 99");
+ print $v->Date(DATE_LONGDATE), "\n";
+ print $v->Date("ddd',' MMM dd yy"), "\n";
+
+will print:
+
+ Thursday, April 01, 1999
+ Thu, Apr 01 99
+
+=item Dim()
+
+Returns a list of array bounds for a VT_ARRAY variant. The list contains
+an array reference for each dimension of the variant's SAFEARRAY. This
+reference points to an array containing the lower and upper bounds for
+this dimension. For example:
+
+ my @Dim = $Var->Dim;
+
+Now C<@Dim> contains the following list: C<([1,5], [0,2])>.
+
+=item Get(DIM)
+
+For normal variants C<Get> returns the value of the variant, just like the
+C<Value> method. For VT_ARRAY variants C<Get> retrieves the value of a single
+array element. In this case C<DIM> must be a list of array indices. E.g.
+
+ my $Val = $Var->Get(2,0);
+
+As a special case for one dimensional VT_UI1|VT_ARRAY variants the C<Get>
+method without arguments returns the character array as a Perl string.
+
+ print $String->Get, "\n";
+
+=item IsNothing()
+
+Tests if the object is an empty VT_DISPATCH variant. See also nothing().
+
+=item IsNullString()
+
+Tests if the object is an empty VT_BSTR variant. See also nullstring().
+
+=item LastError()
+
+The use of the C<Win32::OLE::Variant->LastError()> method is deprecated.
+Please use the C<Win32::OLE->LastError()> class method instead.
+
+=item Number([FORMAT[, LCID]])
+
+This method converts the VARIANT value into a formatted number string. The
+FORMAT can be either an integer constant or a hash reference. Valid constants
+are 0 and LOCALE_NOUSEROVERRIDE. You get the value of LOCALE_NOUSEROVERRIDE
+from the Win32::OLE::NLS module:
+
+ use Win32::OLE::NLS qw(:LOCALE);
+
+LOCALE_NOUSEROVERRIDE tells the method to use the system default number
+format for the specified locale, disregarding any changes that might have
+been made through the control panel application.
+
+The hash reference could contain the following keys:
+
+ NumDigits number of fractional digits
+ LeadingZero whether to use leading zeroes in decimal fields
+ Grouping size of each group of digits to the left of the decimal
+ DecimalSep decimal separator string
+ ThousandSep thousand separator string
+ NegativeOrder see L<Win32::OLE::NLS/LOCALE_INEGNUMBER>
+
+=item Put(DIM, VALUE)
+
+The C<Put> method is used to assign a new value to a variant. The value will
+be coerced into the current type of the variant. E.g.:
+
+ my $Var = Variant(VT_I4, 42);
+ $Var->Put(3.1415);
+
+This changes the value of the variant to C<3> because the type is VT_I4.
+
+For VT_ARRAY type variants the indices for each dimension of the contained
+SAFEARRAY must be specified in front of the new value:
+
+ $Array->Put(1, 1, 2.7);
+
+It is also possible to assign values to *every* element of the SAFEARRAY at
+once using a single Put() method call:
+
+ $Array->Put([[1,2], [3,4]]);
+
+In this case the argument to Put() must be an array reference and the
+dimensions of the Perl list-of-lists must match the dimensions of the
+SAFEARRAY exactly.
+
+The are a few special cases for one-dimensional VT_UI1 arrays: The VALUE
+can be specified as a string instead of a number. This will set the selected
+character to the first character of the string or to '\0' if the string was
+empty:
+
+ my $String = Variant(VT_UI1|VT_ARRAY, "ABCDE");
+ $String->Put(1, "123");
+ $String->Put(3, ord('Z'));
+ $String->Put(4, '');
+
+This will set the value of C<$String> to C<"A1CZ\0">. If the index is omitted
+then the string is copied to the value completely. The string is truncated
+if it is longer than the size of the VT_UI1 array. The result will be padded
+with '\0's if the string is shorter:
+
+ $String->Put("String");
+
+Now C<$String> contains the value "Strin".
+
+C<Put> returns the Variant object itself so that multiple C<Put> calls can be
+chained together:
+
+ $Array->Put(0,0,$First_value)->Put(0,1,$Another_value);
+
+=item Time([FORMAT[, LCID]])
+
+Converts the VARIANT into a formatted time string. FORMAT can be either
+one of the following integer constants or a format string:
+
+ LOCALE_NOUSEROVERRIDE system default time format for this locale
+ TIME_NOMINUTESORSECONDS don't use minutes or seconds
+ TIME_NOSECONDS don't use seconds
+ TIME_NOTIMEMARKER don't use a time marker
+ TIME_FORCE24HOURFORMAT always use a 24-hour time format
+
+The constants are available from the Win32::OLE::NLS module:
+
+ use Win32::OLE::NLS qw(:LOCALE :TIME);
+
+The following elements can be used to construct a time format string.
+Characters must be specified exactly as given below (e.g. "dd" B<not> "DD").
+Spaces can be inserted anywhere between formatting codes, other verbatim
+text should be included in single quotes.
+
+ h hours; 12-hour clock
+ hh hours with leading zero for single-digit hours; 12-hour clock
+ H hours; 24-hour clock
+ HH hours with leading zero for single-digit hours; 24-hour clock
+ m minutes
+ mm minutes with leading zero for single-digit minutes
+ s seconds
+ ss seconds with leading zero for single-digit seconds
+ t one character time marker string, such as A or P
+ tt multicharacter time marker string, such as AM or PM
+
+For example:
+
+ my $v = Variant(VT_DATE, "April 1 99 2:23 pm");
+ print $v->Time, "\n";
+ print $v->Time(TIME_FORCE24HOURFORMAT|TIME_NOTIMEMARKER), "\n";
+ print $v->Time("hh.mm.ss tt"), "\n";
+
+will print:
+
+ 2:23:00 PM
+ 14:23:00
+ 02.23.00 PM
+
+=item Type()
+
+The C<Type> method returns the variant type of the contained VARIANT.
+
+=item Unicode()
+
+The C<Unicode> method returns a C<Unicode::String> object. This contains
+the BSTR value of the variant in network byte order. If the variant is
+not currently in VT_BSTR format then a VT_BSTR copy will be produced first.
+
+=item Value()
+
+The C<Value> method returns the value of the VARIANT as a Perl value. The
+conversion is performed in the same manner as all return values of
+Win32::OLE method calls are converted.
+
+=back
+
+=head2 Overloading
+
+The Win32::OLE::Variant package has overloaded the conversion to
+string and number formats. Therefore variant objects can be used in
+arithmetic and string operations without applying the C<Value>
+method first.
+
+=head2 Class Variables
+
+The Win32::OLE::Variant class used to have its own set of class variables
+like C<$CP>, C<$LCID> and C<$Warn>. In version 0.1003 and later of the
+Win32::OLE module these variables have been eliminated. Now the settings
+of Win32::OLE are used by the Win32::OLE::Variant module too. Please read
+the documentation of the C<Win32::OLE-&gt;Option> class method.
+
+
+=head2 Constants
+
+These constants are exported by default:
+
+ VT_EMPTY
+ VT_NULL
+ VT_I2
+ VT_I4
+ VT_R4
+ VT_R8
+ VT_CY
+ VT_DATE
+ VT_BSTR
+ VT_DISPATCH
+ VT_ERROR
+ VT_BOOL
+ VT_VARIANT
+ VT_UNKNOWN
+ VT_DECIMAL
+ VT_UI1
+
+ VT_ARRAY
+ VT_BYREF
+
+VT_DECIMAL is not on the official list of allowable OLE Automation
+datatypes. But even Microsoft ADO seems to sometimes return values
+of Recordset fields in VT_DECIMAL format.
+
+=head2 Variants
+
+A Variant is a data type that is used to pass data between OLE
+connections.
+
+The default behavior is to convert each perl scalar variable into
+an OLE Variant according to the internal perl representation.
+The following type correspondence holds:
+
+ C type Perl type OLE type
+ ------ --------- --------
+ int IV VT_I4
+ double NV VT_R8
+ char * PV VT_BSTR
+ void * ref to AV VT_ARRAY
+ ? undef VT_ERROR
+ ? Win32::OLE object VT_DISPATCH
+
+Note that VT_BSTR is a wide character or Unicode string. This presents a
+problem if you want to pass in binary data as a parameter as 0x00 is
+inserted between all the bytes in your data. The C<Variant()> method
+provides a solution to this. With Variants the script writer can specify
+the OLE variant type that the parameter should be converted to. Currently
+supported types are:
+
+ VT_UI1 unsigned char
+ VT_I2 signed int (2 bytes)
+ VT_I4 signed int (4 bytes)
+ VT_R4 float (4 bytes)
+ VT_R8 float (8 bytes)
+ VT_DATE OLE Date
+ VT_BSTR OLE String
+ VT_CY OLE Currency
+ VT_BOOL OLE Boolean
+
+When VT_DATE and VT_CY objects are created, the input parameter is treated
+as a Perl string type, which is then converted to VT_BSTR, and finally to
+VT_DATE of VT_CY using the C<VariantChangeType()> OLE API function.
+See L<Win32::OLE/EXAMPLES> for how these types can be used.
+
+=head2 Variant arrays
+
+A variant can not only contain a single value but also a multi-dimensional
+array of values (called a SAFEARRAY). In this case the VT_ARRAY flag must
+be added to the base variant type, e.g. C<VT_I4 | VT_ARRAY> for an array of
+integers. The VT_EMPTY and VT_NULL types are invalid for SAFEARRAYs. It
+is possible to create an array of variants: C<VT_VARIANT | VT_ARRAY>. In this
+case each element of the array can have a different type (including VT_EMPTY
+and VT_NULL). The elements of a VT_VARIANT SAFEARRAY cannot have either of the
+VT_ARRAY or VT_BYREF flags set.
+
+The lower and upper bounds for each dimension can be specified separately.
+They do not have to have all the same lower bound (unlike Perl's arrays).
+
+=head2 Variants by reference
+
+Some OLE servers expect parameters passed by reference so that they
+can be changed in the method call. This allows methods to easily
+return multiple values. There is preliminary support for this in
+the Win32::OLE::Variant module:
+
+ my $x = Variant(VT_I4|VT_BYREF, 0);
+ my $y = Variant(VT_I4|VT_BYREF, 0);
+ $Corel->GetSize($x, $y);
+ print "Size is $x by $y\n";
+
+After the C<GetSize> method call C<$x> and C<$y> will be set to
+the respective sizes. They will still be variants. In the print
+statement the overloading converts them to string representation
+automatically.
+
+VT_BYREF is now supported for all variant types (including SAFEARRAYs).
+It can also be used to pass an OLE object by reference:
+
+ my $Results = $App->CreateResultsObject;
+ $Object->Method(Variant(VT_DISPATCH|VT_BYREF, $Results));
+
+=head1 AUTHORS/COPYRIGHT
+
+This module is part of the Win32::OLE distribution.
+
+=cut
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/Shortcut.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/Shortcut.pm
new file mode 100644
index 0000000000..f284678828
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/Shortcut.pm
@@ -0,0 +1,752 @@
+package Win32::Shortcut;
+#######################################################################
+#
+# Win32::Shortcut - Perl Module for Shell Link Interface
+# ^^^^^^^^^^^^^^^
+# This module creates an object oriented interface to the Win32
+# Shell Links (IShellLink interface).
+#
+#######################################################################
+
+$VERSION = "0.08";
+
+require Exporter;
+require DynaLoader;
+
+@ISA= qw( Exporter DynaLoader );
+@EXPORT = qw(
+ SW_SHOWMAXIMIZED
+ SW_SHOWMINNOACTIVE
+ SW_SHOWNORMAL
+);
+
+
+#######################################################################
+# 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 $!;
+ my $val = constant($constname, @_ ? $_[0] : 0);
+ if ($!) {
+ my(undef, $file, $line) = caller;
+ die "Win32::Shortcut::$constname is not defined, used at $file line $line.";
+ }
+ eval "sub $AUTOLOAD { $val }";
+ goto &$AUTOLOAD;
+}
+
+
+#######################################################################
+# PUBLIC METHODS
+#
+
+#========
+sub new {
+#========
+ my($class, $file) = @_;
+ my($ilink, $ifile) = _Instance();
+ return unless $ilink && $ifile;
+
+ my $self = bless {
+ ilink => $ilink,
+ ifile => $ifile,
+ File => "",
+ Path => "",
+ Arguments => "",
+ WorkingDirectory => "",
+ Description => "",
+ ShowCmd => 0,
+ Hotkey => 0,
+ IconLocation => "",
+ IconNumber => 0,
+ };
+
+
+ if ($file) {
+ $self->{File} = $file;
+ $self->Load($file);
+ }
+
+ return $self;
+}
+
+#=========
+sub Load {
+#=========
+ my($self, $file) = @_;
+ return undef unless ref($self);
+
+ my $result = _Load($self->{'ilink'}, $self->{'ifile'}, $file);
+
+ if ($result) {
+
+ # fill the properties of $self
+ $self->{'File'} = $file;
+ $self->{'Path'} = _GetPath($self->{'ilink'}, $self->{'ifile'},0);
+ $self->{'ShortPath'} = _GetPath($self->{'ilink'}, $self->{'ifile'},1);
+ $self->{'Arguments'} = _GetArguments($self->{'ilink'}, $self->{'ifile'});
+ $self->{'WorkingDirectory'} = _GetWorkingDirectory($self->{'ilink'}, $self->{'ifile'});
+ $self->{'Description'} = _GetDescription($self->{'ilink'}, $self->{'ifile'});
+ $self->{'ShowCmd'} = _GetShowCmd($self->{'ilink'}, $self->{'ifile'});
+ $self->{'Hotkey'} = _GetHotkey($self->{'ilink'}, $self->{'ifile'});
+ ($self->{'IconLocation'},
+ $self->{'IconNumber'}) = _GetIconLocation($self->{'ilink'}, $self->{'ifile'});
+ }
+ return $result;
+}
+
+
+#========
+sub Set {
+#========
+ my($self, $path, $arguments, $dir, $description, $show, $hotkey,
+ $iconlocation, $iconnumber) = @_;
+ return undef unless ref($self);
+
+ $self->{'Path'} = $path;
+ $self->{'Arguments'} = $arguments;
+ $self->{'WorkingDirectory'} = $dir;
+ $self->{'Description'} = $description;
+ $self->{'ShowCmd'} = $show;
+ $self->{'Hotkey'} = $hotkey;
+ $self->{'IconLocation'} = $iconlocation;
+ $self->{'IconNumber'} = $iconnumber;
+ return 1;
+}
+
+
+#=========
+sub Save {
+#=========
+ my($self, $file) = @_;
+ return unless ref($self);
+
+ $file = $self->{'File'} unless $file;
+ return unless $file;
+
+ require Win32 unless defined &Win32::GetFullPathName;
+ $file = Win32::GetFullPathName($file);
+
+ _SetPath($self->{'ilink'}, $self->{'ifile'}, $self->{'Path'});
+ _SetArguments($self->{'ilink'}, $self->{'ifile'}, $self->{'Arguments'});
+ _SetWorkingDirectory($self->{'ilink'}, $self->{'ifile'}, $self->{'WorkingDirectory'});
+ _SetDescription($self->{'ilink'}, $self->{'ifile'}, $self->{'Description'});
+ _SetShowCmd($self->{'ilink'}, $self->{'ifile'}, $self->{'ShowCmd'});
+ _SetHotkey($self->{'ilink'}, $self->{'ifile'}, $self->{'Hotkey'});
+ _SetIconLocation($self->{'ilink'}, $self->{'ifile'},
+ $self->{'IconLocation'}, $self->{'IconNumber'});
+
+ my $result = _Save($self->{'ilink'}, $self->{'ifile'}, $file);
+ if ($result) {
+ $self->{'File'} = $file unless $self->{'File'};
+ }
+ return $result;
+}
+
+#============
+sub Resolve {
+#============
+ my($self, $flags) = @_;
+ return undef unless ref($self);
+ $flags = 1 unless defined($flags);
+ my $result = _Resolve($self->{'ilink'}, $self->{'ifile'}, $flags);
+ return $result;
+}
+
+
+#==========
+sub Close {
+#==========
+ my($self) = @_;
+ return undef unless ref($self);
+
+ my $result = _Release($self->{'ilink'}, $self->{'ifile'});
+ $self->{'released'} = 1;
+ return $result;
+}
+
+#=========
+sub Path {
+#=========
+ my($self, $value) = @_;
+ return undef unless ref($self);
+
+ if(not defined($value)) {
+ return $self->{'Path'};
+ } else {
+ $self->{'Path'} = $value;
+ }
+ return $self->{'Path'};
+}
+
+#==============
+sub ShortPath {
+#==============
+ my($self) = @_;
+ return undef unless ref($self);
+ return $self->{'ShortPath'};
+}
+
+#==============
+sub Arguments {
+#==============
+ my($self, $value) = @_;
+ return undef unless ref($self);
+
+ if(not defined($value)) {
+ return $self->{'Arguments'};
+ } else {
+ $self->{'Arguments'} = $value;
+ }
+ return $self->{'Arguments'};
+}
+
+#=====================
+sub WorkingDirectory {
+#=====================
+ my($self, $value) = @_;
+ return undef unless ref($self);
+
+ if(not defined($value)) {
+ return $self->{'WorkingDirectory'};
+ } else {
+ $self->{'WorkingDirectory'} = $value;
+ }
+ return $self->{'WorkingDirectory'};
+}
+
+
+#================
+sub Description {
+#================
+ my($self, $value) = @_;
+ return undef unless ref($self);
+
+ if(not defined($value)) {
+ return $self->{'Description'};
+ } else {
+ $self->{'Description'} = $value;
+ }
+ return $self->{'Description'};
+}
+
+#============
+sub ShowCmd {
+#============
+ my($self, $value) = @_;
+ return undef unless ref($self);
+
+ if(not defined($value)) {
+ return $self->{'ShowCmd'};
+ } else {
+ $self->{'ShowCmd'} = $value;
+ }
+ return $self->{'ShowCmd'};
+}
+
+#===========
+sub Hotkey {
+#===========
+ my($self, $value) = @_;
+ return undef unless ref($self);
+
+ if(not defined($value)) {
+ return $self->{'Hotkey'};
+ } else {
+ $self->{'Hotkey'} = $value;
+ }
+ return $self->{'Hotkey'};
+}
+
+#=================
+sub IconLocation {
+#=================
+ my($self, $value) = @_;
+ return undef unless ref($self);
+
+ if(not defined($value)) {
+ return $self->{'IconLocation'};
+ } else {
+ $self->{'IconLocation'} = $value;
+ }
+ return $self->{'IconLocation'};
+}
+
+#===============
+sub IconNumber {
+#===============
+ my($self, $value) = @_;
+ return undef unless ref($self);
+
+ if(not defined($value)) {
+ return $self->{'IconNumber'};
+ } else {
+ $self->{'IconNumber'} = $value;
+ }
+ return $self->{'IconNumber'};
+}
+
+#============
+sub Version {
+#============
+ # [dada] to get rid of the "used only once" warning...
+ return $VERSION;
+}
+
+
+#######################################################################
+# PRIVATE METHODS
+#
+
+#============
+sub DESTROY {
+#============
+ my($self) = @_;
+
+ if (not $self->{'released'}) {
+ _Release($self->{'ilink'}, $self->{'ifile'});
+ $self->{'released'} = 1;
+ }
+}
+
+bootstrap Win32::Shortcut;
+
+1;
+
+__END__
+
+=head1 NAME
+
+Win32::Shortcut - Perl Module to deal with Windows Shortcuts
+
+=head1 SYNOPSIS
+
+This module implements the Win32 IShellLink Interface to allow
+management of shortcut files from Perl.
+
+ use Win32::Shortcut;
+
+ $LINK = Win32::Shortcut->new();
+ $LINK->{'Path'} = "C:\\Directory\\Target.exe";
+ $LINK->{'Description'} = "Target executable";
+ $LINK->Save("Target.lnk");
+ $LINK->Close();
+
+=head1 REFERENCE
+
+=head2 General Usage
+
+To use this module, first add the following line at the beginning of
+your script:
+
+ use Win32::Shortcut;
+
+Then, use this command to create a shortcut object:
+
+ $LINK = Win32::Shortcut->new();
+
+This function will create a C<$LINK> object on which you can apply the
+Methods and Properties explained later.
+
+The object is not yet a shortcut file; it is just the definition of a
+shortcut. Basically, you can do 2 things:
+
+=over
+
+=item 1. Load a shortcut file into the object.
+
+=item 2. Save the object into a shortcut file.
+
+=back
+
+For the rest, the object can be accessed as it were a normal
+associative array reference. It has the following keys (here referred
+as properties):
+
+ $LINK->{'File'}
+ $LINK->{'Path'} $LINK->Path()
+ $LINK->{'ShortPath'}
+ $LINK->{'WorkingDirectory'} $LINK->WorkingDirectory()
+ $LINK->{'Arguments'} $LINK->Arguments()
+ $LINK->{'Description'} $LINK->Description()
+ $LINK->{'ShowCmd'} $LINK->ShowCmd()
+ $LINK->{'Hotkey'} $LINK->Hotkey()
+ $LINK->{'IconLocation'} $LINK->IconLocation()
+ $LINK->{'IconNumber'} $LINK->IconNumber()
+
+Thus, assuming you have a shortcut file named C<test.lnk> in your
+current directory, this simple script will tell you where this shortcut
+points to:
+
+ use Win32::Shortcut;
+ $LINK = Win32::Shortcut->new();
+ $LINK->Load("test.lnk");
+ print "Shortcut to: $LINK->{'Path'} $LINK->{'Arguments'} \n";
+ $LINK->Close();
+
+But you can also modify its values:
+
+ use Win32::Shortcut;
+ $LINK = Win32::Shortcut->new();
+ $LINK->Load("test.lnk");
+ $LINK->{'Path'} =~ s/C:/D:/i; # move the target from C: to D:
+ $LINK->{'ShowCmd'} = SW_NORMAL; # runs in a normal window
+
+and then you can save your changes to the shortcut file with this
+command:
+
+ $LINK->Save();
+ $LINK->Close();
+
+or you can save it with another name, creating a new shortcut file:
+
+ $LINK->Save("test2.lnk");
+ $LINK->Close();
+
+Finally, you can create a completely new shortcut:
+
+ $LINK = Win32::Shortcut->new();
+ $LINK->{'Path'} = "C:\\PERL5\\BIN\\PERL.EXE";
+ $LINK->{'Arguments'} = "-v";
+ $LINK->{'WorkingDirectory'} = "C:\PERL5\\BIN";
+ $LINK->{'Description'} = "Prints out the version of Perl";
+ $LINK->{'ShowCmd'} = SW_SHOWMAXIMIZED;
+ $LINK->Save("Perl Version Info.lnk");
+ $LINK->Close();
+
+Note also that in the examples above the two lines:
+
+ $LINK = Win32::Shortcut->new();
+ $LINK->Load("test.lnk");
+
+can be collapsed to:
+
+ $LINK = Win32::Shortcut->new("test.lnk");
+
+
+=head2 Methods
+
+=over
+
+=item B<Close>
+
+Closes a shortcut object. Note that it is not "strictly" required to
+close the objects you created, since the Win32::Shortcut objects are
+automatically closed when the program ends (or when you somehow destroy
+such an object).
+
+Note also that a shortcut is not automatically saved when it is closed,
+even if you modified it. You have to call Save in order to apply
+modifications to a shortcut file.
+
+Example:
+
+ $LINK->Close();
+
+=item B<Load> I<file>
+
+Loads the content of the shortcut file named I<file> in a shortcut
+object and fill the properties of the object with its values. Will
+return B<undef> on errors, or a true value if everything was
+successful.
+
+Example:
+
+ $LINK->Load("test.lnk") or print "test.lnk not found!";
+
+ print join("\n", $LINK->Path,
+ $LINK->ShortPath,
+ $LINK->Arguments,
+ $LINK->WorkingDirectory,
+ $LINK->Description,
+ $LINK->ShowCmd,
+ $LINK->Hotkey,
+ $LINK->IconLocation,
+ $LINK->IconNumber);
+ }
+
+=item B<new Win32::Shortcut> I<[file]>
+
+Creates a new shortcut object. If a filename is passed in I<file>,
+automatically Loads this file also. Returns the object created or
+B<undef> on errors.
+
+Example:
+
+ $LINK = Win32::Shortcut->new();
+
+ $RegEdit = Win32::Shortcut->new("Registry Editor.lnk");
+ die "File not found" if not $RegEdit;
+
+=item B<Resolve> I<[flag]>
+
+Attempts to automatically resolve a shortcut and returns the resolved
+path, or B<undef> on errors; in case no resolution was made, the path
+is returned unchanged. Note that the path is automatically updated in
+the Path property of the shortcut.
+
+By default this method acts quietly, but if you pass a value of 0
+(zero) in the I<flag> parameter, it will eventually post a dialog box
+prompting the user for more information.
+
+Example:
+
+ # if the target doesn't exist...
+ if(! -f $LINK->Path) {
+ # save the actual target for comparison
+ $oldpath = $LINK->Path;
+
+ # try to resolve it (with dialog box)
+ $newpath = $LINK->Resolve(0);
+
+ die "Not resolved..." if $newpath == $oldpath;
+ }
+
+=item B<Save> I<[file]>
+
+Saves the content of the shortcut object into the file named I<file>.
+If I<file> is omitted, it is taken from the File property of the object
+(which, if not changed, is the name of the last Loaded file).
+
+If no file was loaded and the File property doesn't contain a valid
+filename, the method will return B<undef>, which will also be returned
+on errors. A true value will be returned if everything was successful.
+
+Example:
+
+ $LINK->Save();
+ $LINK->Save("Copy of " . $LINK->{'File'});
+
+=item B<Set> I<path, arguments, workingdirectory, description, showcmd,
+hotkey, iconlocation, iconnumber>
+
+Sets all the properties of the shortcut object with a single command.
+This method is supplied for convenience only, you can also set those
+values changing the values of the properties.
+
+Example:
+
+ $LINK->Set("C:\\PERL5\\BIN\\PERL.EXE",
+ "-v",
+ "C:\\PERL5\\BIN",
+ "Prints out the version of Perl",
+ SW_SHOWMAXIMIZED,
+ hex('0x0337'),
+ "C:\\WINDOWS\\SYSTEM\\COOL.DLL",
+ 1);
+
+ # it is the same of...
+ $LINK->Path("C:\\PERL5\\BIN\\PERL.EXE");
+ $LINK->Arguments("-v");
+ $LINK->WorkingDirectory("C:\\PERL5\\BIN");
+ $LINK->Description("Prints out the version of Perl");
+ $LINK->ShowCmd(SW_SHOWMAXIMIZED);
+ $LINK->Hotkey(hex('0x0337'));
+ $LINK->IconLocation("C:\\WINDOWS\\SYSTEM\\COOL.DLL");
+ $LINK->IconNumber(1);
+
+=back
+
+=head2 Properties
+
+The properties of a shortcut object can be accessed as:
+
+ $OBJECT->{'property'}
+
+Eg., assuming that you have created a shortcut object with:
+
+ $LINK=new Win32::Shortcut();
+
+you can for example see its description with:
+
+ print $LINK->{'Description'};
+
+You can of course also set it:
+
+ $LINK->{'Description'}="This is a description";
+
+From version 0.02, those properties have also a corresponding method
+(subroutine), so you can write the 2 lines above using this syntax too:
+
+ print $LINK->Description;
+ $LINK->Description("This is a description");
+
+The properties of a shortcut reflect the content of the Shortcut
+Properties Dialog Box, which can be obtained by clicking the third
+mouse button on a shortcut file in the Windows 95 (or NT 4.0) Explorer
+and choosing "Properties" (well, I hope you already knew :).
+
+The fields corresponding to the single properties are marked in B<bold>
+in the following list.
+
+=over
+
+=item B<Arguments>
+
+The arguments associated with the shell link object. They will be
+passed to the targeted program (see Path) when it gets executed. In
+fact, joined with Path, this parameter forms the "B<Target>" field of a
+Shortcut Properties Dialog Box.
+
+=item B<Description>
+
+An optional description given to the shortcut. Seems to be missing in
+the Shortcut Properties Dialog Box (not yet implemented?).
+
+=item B<File>
+
+The filename of the shortcut file opened with Load, and/or the filename
+under which the shortcut will be saved with Save (if the I<file>
+argument is not specified).
+
+=item B<Hotkey>
+
+The hotkey associated to the shortcut, in the form of a 2-byte number
+of which the first byte identifies the modifiers (Ctrl, Alt, Shift...
+but I didn't find out how it works) and the second is the ASCII code of
+the character key. Correspond to the "B<Shortcut key>" field of a
+Shortcut Properties Dialog Box.
+
+=item B<IconLocation>
+
+The file that contain the icon for the shortcut. Seems actually to
+always return nothing (YMMV, I hope...).
+
+=item B<IconNumber>
+
+The number of the icon for the shortcut in the file pointed by
+IconLocation, in case more that one icon is contained in that file (I
+suppose this, documentation isn't so clear at this point).
+
+=item B<Path>
+
+The target of the shortcut. This is (joined with Arguments) the content
+of the "B<Target>" field in a Shortcut Properties Dialog Box.
+
+=item B<ShortPath>
+
+Same as Path, but expressed in a DOS-readable format (8.3 characters
+filenames). It is available as read-only (well, you can change it, but
+it has no effect on the shortcut; change Path instead) once you Load a
+shortcut file.
+
+=item B<ShowCmd>
+
+The condition of the window in which the program will be executed (can
+be Normal, Minimized or Maximized). Correspond to the "B<Run>" field of
+a Shortcut Properties Dialog Box.
+
+Allowed values are:
+
+B<Value> B<Meaning> B<Constant>
+
+ 1 Normal Window SW_SHOWNORMAL
+ 3 Maximized SW_SHOWMAXIMIZED
+ 7 Minimized SW_SHOWMINNOACTIVE
+
+Any other value (theoretically should) result in a Normal Window
+display.
+
+=item B<WorkingDirectory>
+
+The directory in which the targeted program will be executed.
+Correspond to the "B<Start in>" field of a Shortcut Properties Dialog
+Box.
+
+=back
+
+=head2 Constants
+
+The following constants are exported in the main namespace of your
+script using Win32::Shortcut:
+
+=over
+
+=item * SW_SHOWNORMAL
+
+=item * SW_SHOWMAXIMIZED
+
+=item * SW_SHOWMINNOACTIVE
+
+=back
+
+Those constants are the allowed values for the ShowCmd property.
+
+
+
+=head1 VERSION HISTORY
+
+B<0.03 (07 Apr 1997)>
+
+=over
+
+=item * The PLL file now comes in 2 versions, one for Perl version
+5.001 (build 110) and one for Perl version 5.003 (build 300 and higher,
+EXCEPT 304).
+
+=item * Added an installation program which will automatically copy the
+right files in the right place.
+
+=back
+
+B<0.02 (21 Jan 1997)>
+
+=over
+
+=item * Added methods matching properties to reduce typing overhead
+(eg. Alt-123 and 125...).
+
+=back
+
+B<0.01 (15 Jan 1997)>
+
+=over
+
+=item *
+
+First public release.
+
+=item *
+
+Added "Set" and "Resolve" and the properties "Hotkey", "IconLocation"
+and "IconNumber".
+
+=back
+
+B<0.01a (10 Jan 1997)>
+
+=over
+
+=item *
+
+First implementation of the IShellLink interface (wow, it works!); can
+"Load", "Save", and modify properties of shortcut files.
+
+=back
+
+=head1 AUTHOR
+
+Aldo Calpini L<dada@perl.it>
+
+Distributed under the terms of Larry Wall's Artistic License.
+
+=head1 CREDITS
+
+Thanks to: Jesse Dougherty, Dave Roth, ActiveWare, and the
+Perl-Win32-Users community.
+
+=head1 DISCLAIMER
+
+I<This program is FREE; you can redistribute, modify, disassemble, or
+even reverse engineer this software at your will. Keep in mind,
+however, that NOTHING IS GUARANTEED to work and everything you do is AT
+YOUR OWN RISK - I will not take responsibility for any damage, loss of
+money and/or health that may arise from the use of this program!>
+
+=cut
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/TieRegistry.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/TieRegistry.pm
new file mode 100644
index 0000000000..4cda39e0ce
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/TieRegistry.pm
@@ -0,0 +1,3803 @@
+package Win32::TieRegistry;
+
+# 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.
+#
+use 5.006;
+use strict;
+use Carp;
+use Tie::Hash ();
+
+use vars qw( $PACK $VERSION @ISA @EXPORT @EXPORT_OK );
+BEGIN {
+ $PACK = 'Win32::TieRegistry';
+ $VERSION = '0.30';
+ @ISA = 'Tie::Hash';
+}
+
+# Required other modules:
+use Win32API::Registry 0.24 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
+);
+BEGIN {
+ $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 )= @_;
+ @_ 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,my $nlen1=$nlen,[],[],[],[]) ) {
+ #RegEnumValue modifies $nlen1
+ 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++;
+ my $namSiz1 = $namSiz;
+ while( $self->RegEnumKeyEx(
+ $pos++, $subkey, $namSiz, [], $class, $clsSiz, $time ) ) {
+ push( @subkeys, $subkey );
+ push( @classes, $class );
+ push( @times, $time );
+ $namSiz = $namSiz1; #RegEnumKeyEx modifies $namSiz
+ }
+ 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 distinguish 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;
+ 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__
+
+=pod
+
+=head1 NAME
+
+Win32::TieRegistry - Manipulate the Win32 Registry
+
+=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= $diskKey->{"/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 B<can> be blank and B<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 B<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()> B<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 interpreted 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 consistent 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= Win32::TieRegistry->new("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 B<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 consecutive 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 precede 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 primarily 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 possible 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 interpreted 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 followed by the value to use for that option.
+A Registry virtual root object is created, all of these options are
+set for it, then each variable to be imported/set is associated with
+this object.
+
+In addition, the following special options are supported:
+
+=over
+
+=item ExportLevel
+
+Whether to import variables into your package or some
+package that uses your package. Defaults to the value of
+C<$Exporter::ExportLevel> and has the same meaning. See
+the L<Exporter> module for more information.
+
+=item ExportTo
+
+The name of the package to import variables and constants into.
+Overrides I<ExportLevel>.
+
+=back
+
+=back
+
+=head3 Specifying constants in your Perl code
+
+This module was written with a strong emphasis on the convenience of
+the module user. Therefore, most places where you can specify a
+constant like C<REG_SZ()> also allow you to specify a string
+containing the name of the constant, C<"REG_SZ">. This is convenient
+because you may not have imported that symbolic constant.
+
+Perl also emphasizes programmer convenience so the code C<REG_SZ>
+can be used to mean C<REG_SZ()> or C<"REG_SZ"> or be illegal.
+Note that using C<&REG_SZ> (as we've seen in much Win32 Perl code)
+is not a good idea since it passes the current C<@_> to the
+C<constant()> routine of the module which, at the least, can give
+you a warning under B<-w>.
+
+Although greatly a matter of style, the "safest" practice is probably
+to specifically list all constants in the C<use Win32::TieRegistry>
+statement, specify C<use strict> [or at least C<use strict qw(subs)>],
+and use bare constant names when you want the numeric value. This will
+detect misspelled 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= Win32::TieRegistry->new("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
+
+Because Perl hashes are case sensitive, certain lookups are also
+case sensitive. 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
+
+=head1 COPYRIGHT
+
+Copyright 1999 - 2006 Tye McQueen.
+
+Some parts copyright 2007 - 2009 Adam Kennedy.
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=cut
+
+# Autoload not currently supported by Perl under Windows.
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/WinError.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/WinError.pm
new file mode 100644
index 0000000000..c61347b6ec
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32/WinError.pm
@@ -0,0 +1,1017 @@
+package Win32::WinError;
+
+require Exporter;
+require DynaLoader;
+
+$VERSION = '0.04';
+
+@ISA = qw(Exporter DynaLoader);
+# Items to export into callers namespace by default. Note: do not export
+# names by default without a very good reason. Use EXPORT_OK instead.
+# Do not simply export all your public functions/methods/constants.
+@EXPORT = qw(
+ GetLastError
+ CACHE_E_FIRST
+ CACHE_E_LAST
+ CACHE_E_NOCACHE_UPDATED
+ CACHE_S_FIRST
+ CACHE_S_FORMATETC_NOTSUPPORTED
+ CACHE_S_LAST
+ CACHE_S_SAMECACHE
+ CACHE_S_SOMECACHES_NOTUPDATED
+ CLASSFACTORY_E_FIRST
+ CLASSFACTORY_E_LAST
+ CLASSFACTORY_S_FIRST
+ CLASSFACTORY_S_LAST
+ CLASS_E_CLASSNOTAVAILABLE
+ CLASS_E_NOAGGREGATION
+ CLIENTSITE_E_FIRST
+ CLIENTSITE_E_LAST
+ CLIENTSITE_S_FIRST
+ CLIENTSITE_S_LAST
+ CLIPBRD_E_BAD_DATA
+ CLIPBRD_E_CANT_CLOSE
+ CLIPBRD_E_CANT_EMPTY
+ CLIPBRD_E_CANT_OPEN
+ CLIPBRD_E_CANT_SET
+ CLIPBRD_E_FIRST
+ CLIPBRD_E_LAST
+ CLIPBRD_S_FIRST
+ CLIPBRD_S_LAST
+ CONVERT10_E_FIRST
+ CONVERT10_E_LAST
+ CONVERT10_E_OLESTREAM_BITMAP_TO_DIB
+ CONVERT10_E_OLESTREAM_FMT
+ CONVERT10_E_OLESTREAM_GET
+ CONVERT10_E_OLESTREAM_PUT
+ CONVERT10_E_STG_DIB_TO_BITMAP
+ CONVERT10_E_STG_FMT
+ CONVERT10_E_STG_NO_STD_STREAM
+ CONVERT10_S_FIRST
+ CONVERT10_S_LAST
+ CONVERT10_S_NO_PRESENTATION
+ CO_E_ALREADYINITIALIZED
+ CO_E_APPDIDNTREG
+ CO_E_APPNOTFOUND
+ CO_E_APPSINGLEUSE
+ CO_E_BAD_PATH
+ CO_E_CANTDETERMINECLASS
+ CO_E_CLASSSTRING
+ CO_E_CLASS_CREATE_FAILED
+ CO_E_DLLNOTFOUND
+ CO_E_ERRORINAPP
+ CO_E_ERRORINDLL
+ CO_E_FIRST
+ CO_E_IIDSTRING
+ CO_E_INIT_CLASS_CACHE
+ CO_E_INIT_MEMORY_ALLOCATOR
+ CO_E_INIT_ONLY_SINGLE_THREADED
+ CO_E_INIT_RPC_CHANNEL
+ CO_E_INIT_SCM_EXEC_FAILURE
+ CO_E_INIT_SCM_FILE_MAPPING_EXISTS
+ CO_E_INIT_SCM_MAP_VIEW_OF_FILE
+ CO_E_INIT_SCM_MUTEX_EXISTS
+ CO_E_INIT_SHARED_ALLOCATOR
+ CO_E_INIT_TLS
+ CO_E_INIT_TLS_CHANNEL_CONTROL
+ CO_E_INIT_TLS_SET_CHANNEL_CONTROL
+ CO_E_INIT_UNACCEPTED_USER_ALLOCATOR
+ CO_E_LAST
+ CO_E_NOTINITIALIZED
+ CO_E_OBJISREG
+ CO_E_OBJNOTCONNECTED
+ CO_E_OBJNOTREG
+ CO_E_OBJSRV_RPC_FAILURE
+ CO_E_RELEASED
+ CO_E_SCM_ERROR
+ CO_E_SCM_RPC_FAILURE
+ CO_E_SERVER_EXEC_FAILURE
+ CO_E_SERVER_STOPPING
+ CO_E_WRONGOSFORAPP
+ CO_S_FIRST
+ CO_S_LAST
+ DATA_E_FIRST
+ DATA_E_LAST
+ DATA_S_FIRST
+ DATA_S_LAST
+ DATA_S_SAMEFORMATETC
+ DISP_E_ARRAYISLOCKED
+ DISP_E_BADCALLEE
+ DISP_E_BADINDEX
+ DISP_E_BADPARAMCOUNT
+ DISP_E_BADVARTYPE
+ DISP_E_EXCEPTION
+ DISP_E_MEMBERNOTFOUND
+ DISP_E_NONAMEDARGS
+ DISP_E_NOTACOLLECTION
+ DISP_E_OVERFLOW
+ DISP_E_PARAMNOTFOUND
+ DISP_E_PARAMNOTOPTIONAL
+ DISP_E_TYPEMISMATCH
+ DISP_E_UNKNOWNINTERFACE
+ DISP_E_UNKNOWNLCID
+ DISP_E_UNKNOWNNAME
+ DRAGDROP_E_ALREADYREGISTERED
+ DRAGDROP_E_FIRST
+ DRAGDROP_E_INVALIDHWND
+ DRAGDROP_E_LAST
+ DRAGDROP_E_NOTREGISTERED
+ DRAGDROP_S_CANCEL
+ DRAGDROP_S_DROP
+ DRAGDROP_S_FIRST
+ DRAGDROP_S_LAST
+ DRAGDROP_S_USEDEFAULTCURSORS
+ DV_E_CLIPFORMAT
+ DV_E_DVASPECT
+ DV_E_DVTARGETDEVICE
+ DV_E_DVTARGETDEVICE_SIZE
+ DV_E_FORMATETC
+ DV_E_LINDEX
+ DV_E_NOIVIEWOBJECT
+ DV_E_STATDATA
+ DV_E_STGMEDIUM
+ DV_E_TYMED
+ ENUM_E_FIRST
+ ENUM_E_LAST
+ ENUM_S_FIRST
+ ENUM_S_LAST
+ EPT_S_CANT_CREATE
+ EPT_S_CANT_PERFORM_OP
+ EPT_S_INVALID_ENTRY
+ EPT_S_NOT_REGISTERED
+ ERROR_ACCESS_DENIED
+ ERROR_ACCOUNT_DISABLED
+ ERROR_ACCOUNT_EXPIRED
+ ERROR_ACCOUNT_LOCKED_OUT
+ ERROR_ACCOUNT_RESTRICTION
+ ERROR_ACTIVE_CONNECTIONS
+ ERROR_ADAP_HDW_ERR
+ ERROR_ADDRESS_ALREADY_ASSOCIATED
+ ERROR_ADDRESS_NOT_ASSOCIATED
+ ERROR_ALIAS_EXISTS
+ ERROR_ALLOTTED_SPACE_EXCEEDED
+ ERROR_ALREADY_ASSIGNED
+ ERROR_ALREADY_EXISTS
+ ERROR_ALREADY_REGISTERED
+ ERROR_ALREADY_RUNNING_LKG
+ ERROR_ALREADY_WAITING
+ ERROR_ARENA_TRASHED
+ ERROR_ARITHMETIC_OVERFLOW
+ ERROR_ATOMIC_LOCKS_NOT_SUPPORTED
+ ERROR_AUTODATASEG_EXCEEDS_64k
+ ERROR_BADDB
+ ERROR_BADKEY
+ ERROR_BAD_ARGUMENTS
+ ERROR_BAD_COMMAND
+ ERROR_BAD_DESCRIPTOR_FORMAT
+ ERROR_BAD_DEVICE
+ ERROR_BAD_DEV_TYPE
+ ERROR_BAD_DRIVER
+ ERROR_BAD_DRIVER_LEVEL
+ ERROR_BAD_ENVIRONMENT
+ ERROR_BAD_EXE_FORMAT
+ ERROR_BAD_FORMAT
+ ERROR_BAD_IMPERSONATION_LEVEL
+ ERROR_BAD_INHERITANCE_ACL
+ ERROR_BAD_LENGTH
+ ERROR_BAD_LOGON_SESSION_STATE
+ ERROR_BAD_NETPATH
+ ERROR_BAD_NET_NAME
+ ERROR_BAD_NET_RESP
+ ERROR_BAD_PATHNAME
+ ERROR_BAD_PIPE
+ ERROR_BAD_PROFILE
+ ERROR_BAD_PROVIDER
+ ERROR_BAD_REM_ADAP
+ ERROR_BAD_THREADID_ADDR
+ ERROR_BAD_TOKEN_TYPE
+ ERROR_BAD_UNIT
+ ERROR_BAD_USERNAME
+ ERROR_BAD_VALIDATION_CLASS
+ ERROR_BEGINNING_OF_MEDIA
+ ERROR_BOOT_ALREADY_ACCEPTED
+ ERROR_BROKEN_PIPE
+ ERROR_BUFFER_OVERFLOW
+ ERROR_BUSY
+ ERROR_BUSY_DRIVE
+ ERROR_BUS_RESET
+ ERROR_CALL_NOT_IMPLEMENTED
+ ERROR_CANCELLED
+ ERROR_CANCEL_VIOLATION
+ ERROR_CANNOT_COPY
+ ERROR_CANNOT_FIND_WND_CLASS
+ ERROR_CANNOT_IMPERSONATE
+ ERROR_CANNOT_MAKE
+ ERROR_CANNOT_OPEN_PROFILE
+ ERROR_CANTOPEN
+ ERROR_CANTREAD
+ ERROR_CANTWRITE
+ ERROR_CANT_ACCESS_DOMAIN_INFO
+ ERROR_CANT_DISABLE_MANDATORY
+ ERROR_CANT_OPEN_ANONYMOUS
+ ERROR_CAN_NOT_COMPLETE
+ ERROR_CAN_NOT_DEL_LOCAL_WINS
+ ERROR_CHILD_MUST_BE_VOLATILE
+ ERROR_CHILD_NOT_COMPLETE
+ ERROR_CHILD_WINDOW_MENU
+ ERROR_CIRCULAR_DEPENDENCY
+ ERROR_CLASS_ALREADY_EXISTS
+ ERROR_CLASS_DOES_NOT_EXIST
+ ERROR_CLASS_HAS_WINDOWS
+ ERROR_CLIPBOARD_NOT_OPEN
+ ERROR_CLIPPING_NOT_SUPPORTED
+ ERROR_CONNECTION_ABORTED
+ ERROR_CONNECTION_ACTIVE
+ ERROR_CONNECTION_COUNT_LIMIT
+ ERROR_CONNECTION_INVALID
+ ERROR_CONNECTION_REFUSED
+ ERROR_CONNECTION_UNAVAIL
+ ERROR_CONTROL_ID_NOT_FOUND
+ ERROR_COUNTER_TIMEOUT
+ ERROR_CRC
+ ERROR_CURRENT_DIRECTORY
+ ERROR_DATABASE_DOES_NOT_EXIST
+ ERROR_DC_NOT_FOUND
+ ERROR_DEPENDENT_SERVICES_RUNNING
+ ERROR_DESTROY_OBJECT_OF_OTHER_THREAD
+ ERROR_DEVICE_ALREADY_REMEMBERED
+ ERROR_DEVICE_IN_USE
+ ERROR_DEVICE_NOT_PARTITIONED
+ ERROR_DEV_NOT_EXIST
+ ERROR_DIRECTORY
+ ERROR_DIRECT_ACCESS_HANDLE
+ ERROR_DIR_NOT_EMPTY
+ ERROR_DIR_NOT_ROOT
+ ERROR_DISCARDED
+ ERROR_DISK_CHANGE
+ ERROR_DISK_CORRUPT
+ ERROR_DISK_FULL
+ ERROR_DISK_OPERATION_FAILED
+ ERROR_DISK_RECALIBRATE_FAILED
+ ERROR_DISK_RESET_FAILED
+ ERROR_DLL_INIT_FAILED
+ ERROR_DOMAIN_CONTROLLER_NOT_FOUND
+ ERROR_DOMAIN_EXISTS
+ ERROR_DOMAIN_LIMIT_EXCEEDED
+ ERROR_DOMAIN_TRUST_INCONSISTENT
+ ERROR_DRIVE_LOCKED
+ ERROR_DUPLICATE_SERVICE_NAME
+ ERROR_DUP_DOMAINNAME
+ ERROR_DUP_NAME
+ ERROR_DYNLINK_FROM_INVALID_RING
+ ERROR_EAS_DIDNT_FIT
+ ERROR_EAS_NOT_SUPPORTED
+ ERROR_EA_ACCESS_DENIED
+ ERROR_EA_FILE_CORRUPT
+ ERROR_EA_LIST_INCONSISTENT
+ ERROR_EA_TABLE_FULL
+ ERROR_END_OF_MEDIA
+ ERROR_ENVVAR_NOT_FOUND
+ ERROR_EOM_OVERFLOW
+ ERROR_EVENTLOG_CANT_START
+ ERROR_EVENTLOG_FILE_CHANGED
+ ERROR_EVENTLOG_FILE_CORRUPT
+ ERROR_EXCEPTION_IN_SERVICE
+ ERROR_EXCL_SEM_ALREADY_OWNED
+ ERROR_EXE_MARKED_INVALID
+ ERROR_EXTENDED_ERROR
+ ERROR_FAILED_SERVICE_CONTROLLER_CONNECT
+ ERROR_FAIL_I24
+ ERROR_FILEMARK_DETECTED
+ ERROR_FILENAME_EXCED_RANGE
+ ERROR_FILE_CORRUPT
+ ERROR_FILE_EXISTS
+ ERROR_FILE_INVALID
+ ERROR_FILE_NOT_FOUND
+ ERROR_FLOPPY_BAD_REGISTERS
+ ERROR_FLOPPY_ID_MARK_NOT_FOUND
+ ERROR_FLOPPY_UNKNOWN_ERROR
+ ERROR_FLOPPY_WRONG_CYLINDER
+ ERROR_FULLSCREEN_MODE
+ ERROR_FULL_BACKUP
+ ERROR_GENERIC_NOT_MAPPED
+ ERROR_GEN_FAILURE
+ ERROR_GLOBAL_ONLY_HOOK
+ ERROR_GRACEFUL_DISCONNECT
+ ERROR_GROUP_EXISTS
+ ERROR_HANDLE_DISK_FULL
+ ERROR_HANDLE_EOF
+ ERROR_HOOK_NEEDS_HMOD
+ ERROR_HOOK_NOT_INSTALLED
+ ERROR_HOST_UNREACHABLE
+ ERROR_HOTKEY_ALREADY_REGISTERED
+ ERROR_HOTKEY_NOT_REGISTERED
+ ERROR_HWNDS_HAVE_DIFF_PARENT
+ ERROR_ILL_FORMED_PASSWORD
+ ERROR_INCORRECT_ADDRESS
+ ERROR_INC_BACKUP
+ ERROR_INFLOOP_IN_RELOC_CHAIN
+ ERROR_INSUFFICIENT_BUFFER
+ ERROR_INTERNAL_DB_CORRUPTION
+ ERROR_INTERNAL_DB_ERROR
+ ERROR_INTERNAL_ERROR
+ ERROR_INVALID_ACCEL_HANDLE
+ ERROR_INVALID_ACCESS
+ ERROR_INVALID_ACCOUNT_NAME
+ ERROR_INVALID_ACL
+ ERROR_INVALID_ADDRESS
+ ERROR_INVALID_AT_INTERRUPT_TIME
+ ERROR_INVALID_BLOCK
+ ERROR_INVALID_BLOCK_LENGTH
+ ERROR_INVALID_CATEGORY
+ ERROR_INVALID_COMBOBOX_MESSAGE
+ ERROR_INVALID_COMPUTERNAME
+ ERROR_INVALID_CURSOR_HANDLE
+ ERROR_INVALID_DATA
+ ERROR_INVALID_DATATYPE
+ ERROR_INVALID_DOMAINNAME
+ ERROR_INVALID_DOMAIN_ROLE
+ ERROR_INVALID_DOMAIN_STATE
+ ERROR_INVALID_DRIVE
+ ERROR_INVALID_DWP_HANDLE
+ ERROR_INVALID_EA_HANDLE
+ ERROR_INVALID_EA_NAME
+ ERROR_INVALID_EDIT_HEIGHT
+ ERROR_INVALID_ENVIRONMENT
+ ERROR_INVALID_EVENTNAME
+ ERROR_INVALID_EVENT_COUNT
+ ERROR_INVALID_EXE_SIGNATURE
+ ERROR_INVALID_FILTER_PROC
+ ERROR_INVALID_FLAGS
+ ERROR_INVALID_FLAG_NUMBER
+ ERROR_INVALID_FORM_NAME
+ ERROR_INVALID_FORM_SIZE
+ ERROR_INVALID_FUNCTION
+ ERROR_INVALID_GROUPNAME
+ ERROR_INVALID_GROUP_ATTRIBUTES
+ ERROR_INVALID_GW_COMMAND
+ ERROR_INVALID_HANDLE
+ ERROR_INVALID_HOOK_FILTER
+ ERROR_INVALID_HOOK_HANDLE
+ ERROR_INVALID_ICON_HANDLE
+ ERROR_INVALID_ID_AUTHORITY
+ ERROR_INVALID_INDEX
+ ERROR_INVALID_LB_MESSAGE
+ ERROR_INVALID_LEVEL
+ ERROR_INVALID_LIST_FORMAT
+ ERROR_INVALID_LOGON_HOURS
+ ERROR_INVALID_LOGON_TYPE
+ ERROR_INVALID_MEMBER
+ ERROR_INVALID_MENU_HANDLE
+ ERROR_INVALID_MESSAGE
+ ERROR_INVALID_MESSAGEDEST
+ ERROR_INVALID_MESSAGENAME
+ ERROR_INVALID_MINALLOCSIZE
+ ERROR_INVALID_MODULETYPE
+ ERROR_INVALID_MSGBOX_STYLE
+ ERROR_INVALID_NAME
+ ERROR_INVALID_NETNAME
+ ERROR_INVALID_ORDINAL
+ ERROR_INVALID_OWNER
+ ERROR_INVALID_PARAMETER
+ ERROR_INVALID_PASSWORD
+ ERROR_INVALID_PASSWORDNAME
+ ERROR_INVALID_PIXEL_FORMAT
+ ERROR_INVALID_PRIMARY_GROUP
+ ERROR_INVALID_PRINTER_COMMAND
+ ERROR_INVALID_PRINTER_NAME
+ ERROR_INVALID_PRINTER_STATE
+ ERROR_INVALID_PRIORITY
+ ERROR_INVALID_SCROLLBAR_RANGE
+ ERROR_INVALID_SECURITY_DESCR
+ ERROR_INVALID_SEGDPL
+ ERROR_INVALID_SEGMENT_NUMBER
+ ERROR_INVALID_SEPARATOR_FILE
+ ERROR_INVALID_SERVER_STATE
+ ERROR_INVALID_SERVICENAME
+ ERROR_INVALID_SERVICE_ACCOUNT
+ ERROR_INVALID_SERVICE_CONTROL
+ ERROR_INVALID_SERVICE_LOCK
+ ERROR_INVALID_SHARENAME
+ ERROR_INVALID_SHOWWIN_COMMAND
+ ERROR_INVALID_SID
+ ERROR_INVALID_SIGNAL_NUMBER
+ ERROR_INVALID_SPI_VALUE
+ ERROR_INVALID_STACKSEG
+ ERROR_INVALID_STARTING_CODESEG
+ ERROR_INVALID_SUB_AUTHORITY
+ ERROR_INVALID_TARGET_HANDLE
+ ERROR_INVALID_THREAD_ID
+ ERROR_INVALID_TIME
+ ERROR_INVALID_USER_BUFFER
+ ERROR_INVALID_VERIFY_SWITCH
+ ERROR_INVALID_WINDOW_HANDLE
+ ERROR_INVALID_WINDOW_STYLE
+ ERROR_INVALID_WORKSTATION
+ ERROR_IOPL_NOT_ENABLED
+ ERROR_IO_DEVICE
+ ERROR_IO_INCOMPLETE
+ ERROR_IO_PENDING
+ ERROR_IRQ_BUSY
+ ERROR_IS_JOINED
+ ERROR_IS_JOIN_PATH
+ ERROR_IS_JOIN_TARGET
+ ERROR_IS_SUBSTED
+ ERROR_IS_SUBST_PATH
+ ERROR_IS_SUBST_TARGET
+ ERROR_ITERATED_DATA_EXCEEDS_64k
+ ERROR_JOIN_TO_JOIN
+ ERROR_JOIN_TO_SUBST
+ ERROR_JOURNAL_HOOK_SET
+ ERROR_KEY_DELETED
+ ERROR_KEY_HAS_CHILDREN
+ ERROR_LABEL_TOO_LONG
+ ERROR_LAST_ADMIN
+ ERROR_LB_WITHOUT_TABSTOPS
+ ERROR_LISTBOX_ID_NOT_FOUND
+ ERROR_LM_CROSS_ENCRYPTION_REQUIRED
+ ERROR_LOCAL_USER_SESSION_KEY
+ ERROR_LOCKED
+ ERROR_LOCK_FAILED
+ ERROR_LOCK_VIOLATION
+ ERROR_LOGIN_TIME_RESTRICTION
+ ERROR_LOGIN_WKSTA_RESTRICTION
+ ERROR_LOGON_FAILURE
+ ERROR_LOGON_NOT_GRANTED
+ ERROR_LOGON_SESSION_COLLISION
+ ERROR_LOGON_SESSION_EXISTS
+ ERROR_LOGON_TYPE_NOT_GRANTED
+ ERROR_LOG_FILE_FULL
+ ERROR_LUIDS_EXHAUSTED
+ ERROR_MAPPED_ALIGNMENT
+ ERROR_MAX_THRDS_REACHED
+ ERROR_MEDIA_CHANGED
+ ERROR_MEMBERS_PRIMARY_GROUP
+ ERROR_MEMBER_IN_ALIAS
+ ERROR_MEMBER_IN_GROUP
+ ERROR_MEMBER_NOT_IN_ALIAS
+ ERROR_MEMBER_NOT_IN_GROUP
+ ERROR_METAFILE_NOT_SUPPORTED
+ ERROR_META_EXPANSION_TOO_LONG
+ ERROR_MOD_NOT_FOUND
+ ERROR_MORE_DATA
+ ERROR_MORE_WRITES
+ ERROR_MR_MID_NOT_FOUND
+ ERROR_NEGATIVE_SEEK
+ ERROR_NESTING_NOT_ALLOWED
+ ERROR_NETLOGON_NOT_STARTED
+ ERROR_NETNAME_DELETED
+ ERROR_NETWORK_ACCESS_DENIED
+ ERROR_NETWORK_BUSY
+ ERROR_NETWORK_UNREACHABLE
+ ERROR_NET_WRITE_FAULT
+ ERROR_NOACCESS
+ ERROR_NOLOGON_INTERDOMAIN_TRUST_ACCOUNT
+ ERROR_NOLOGON_SERVER_TRUST_ACCOUNT
+ ERROR_NOLOGON_WORKSTATION_TRUST_ACCOUNT
+ ERROR_NONE_MAPPED
+ ERROR_NON_MDICHILD_WINDOW
+ ERROR_NOTIFY_ENUM_DIR
+ ERROR_NOT_ALL_ASSIGNED
+ ERROR_NOT_CHILD_WINDOW
+ ERROR_NOT_CONNECTED
+ ERROR_NOT_CONTAINER
+ ERROR_NOT_DOS_DISK
+ ERROR_NOT_ENOUGH_MEMORY
+ ERROR_NOT_ENOUGH_QUOTA
+ ERROR_NOT_ENOUGH_SERVER_MEMORY
+ ERROR_NOT_JOINED
+ ERROR_NOT_LOCKED
+ ERROR_NOT_LOGON_PROCESS
+ ERROR_NOT_OWNER
+ ERROR_NOT_READY
+ ERROR_NOT_REGISTRY_FILE
+ ERROR_NOT_SAME_DEVICE
+ ERROR_NOT_SUBSTED
+ ERROR_NOT_SUPPORTED
+ ERROR_NO_BROWSER_SERVERS_FOUND
+ ERROR_NO_DATA
+ ERROR_NO_DATA_DETECTED
+ ERROR_NO_IMPERSONATION_TOKEN
+ ERROR_NO_INHERITANCE
+ ERROR_NO_LOGON_SERVERS
+ ERROR_NO_LOG_SPACE
+ ERROR_NO_MEDIA_IN_DRIVE
+ ERROR_NO_MORE_FILES
+ ERROR_NO_MORE_ITEMS
+ ERROR_NO_MORE_SEARCH_HANDLES
+ ERROR_NO_NETWORK
+ ERROR_NO_NET_OR_BAD_PATH
+ ERROR_NO_PROC_SLOTS
+ ERROR_NO_QUOTAS_FOR_ACCOUNT
+ ERROR_NO_SCROLLBARS
+ ERROR_NO_SECURITY_ON_OBJECT
+ ERROR_NO_SHUTDOWN_IN_PROGRESS
+ ERROR_NO_SIGNAL_SENT
+ ERROR_NO_SPOOL_SPACE
+ ERROR_NO_SUCH_ALIAS
+ ERROR_NO_SUCH_DOMAIN
+ ERROR_NO_SUCH_GROUP
+ ERROR_NO_SUCH_LOGON_SESSION
+ ERROR_NO_SUCH_MEMBER
+ ERROR_NO_SUCH_PACKAGE
+ ERROR_NO_SUCH_PRIVILEGE
+ ERROR_NO_SUCH_USER
+ ERROR_NO_SYSTEM_MENU
+ ERROR_NO_TOKEN
+ ERROR_NO_TRUST_LSA_SECRET
+ ERROR_NO_TRUST_SAM_ACCOUNT
+ ERROR_NO_UNICODE_TRANSLATION
+ ERROR_NO_USER_SESSION_KEY
+ ERROR_NO_VOLUME_LABEL
+ ERROR_NO_WILDCARD_CHARACTERS
+ ERROR_NT_CROSS_ENCRYPTION_REQUIRED
+ ERROR_NULL_LM_PASSWORD
+ ERROR_OPEN_FAILED
+ ERROR_OPEN_FILES
+ ERROR_OPERATION_ABORTED
+ ERROR_OUTOFMEMORY
+ ERROR_OUT_OF_PAPER
+ ERROR_OUT_OF_STRUCTURES
+ ERROR_PARTIAL_COPY
+ ERROR_PARTITION_FAILURE
+ ERROR_PASSWORD_EXPIRED
+ ERROR_PASSWORD_MUST_CHANGE
+ ERROR_PASSWORD_RESTRICTION
+ ERROR_PATH_BUSY
+ ERROR_PATH_NOT_FOUND
+ ERROR_PIPE_BUSY
+ ERROR_PIPE_CONNECTED
+ ERROR_PIPE_LISTENING
+ ERROR_PIPE_NOT_CONNECTED
+ ERROR_POPUP_ALREADY_ACTIVE
+ ERROR_PORT_UNREACHABLE
+ ERROR_POSSIBLE_DEADLOCK
+ ERROR_PRINTER_ALREADY_EXISTS
+ ERROR_PRINTER_DELETED
+ ERROR_PRINTER_DRIVER_ALREADY_INSTALLED
+ ERROR_PRINTER_DRIVER_IN_USE
+ ERROR_PRINTQ_FULL
+ ERROR_PRINT_CANCELLED
+ ERROR_PRINT_MONITOR_ALREADY_INSTALLED
+ ERROR_PRINT_PROCESSOR_ALREADY_INSTALLED
+ ERROR_PRIVATE_DIALOG_INDEX
+ ERROR_PRIVILEGE_NOT_HELD
+ ERROR_PROCESS_ABORTED
+ ERROR_PROC_NOT_FOUND
+ ERROR_PROTOCOL_UNREACHABLE
+ ERROR_READ_FAULT
+ ERROR_REC_NON_EXISTENT
+ ERROR_REDIRECTOR_HAS_OPEN_HANDLES
+ ERROR_REDIR_PAUSED
+ ERROR_REGISTRY_CORRUPT
+ ERROR_REGISTRY_IO_FAILED
+ ERROR_REGISTRY_RECOVERED
+ ERROR_RELOC_CHAIN_XEEDS_SEGLIM
+ ERROR_REMOTE_SESSION_LIMIT_EXCEEDED
+ ERROR_REM_NOT_LIST
+ ERROR_REQUEST_ABORTED
+ ERROR_REQ_NOT_ACCEP
+ ERROR_RESOURCE_DATA_NOT_FOUND
+ ERROR_RESOURCE_LANG_NOT_FOUND
+ ERROR_RESOURCE_NAME_NOT_FOUND
+ ERROR_RESOURCE_TYPE_NOT_FOUND
+ ERROR_RETRY
+ ERROR_REVISION_MISMATCH
+ ERROR_RING2SEG_MUST_BE_MOVABLE
+ ERROR_RING2_STACK_IN_USE
+ ERROR_RPL_NOT_ALLOWED
+ ERROR_RXACT_COMMIT_FAILURE
+ ERROR_RXACT_INVALID_STATE
+ ERROR_SAME_DRIVE
+ ERROR_SCREEN_ALREADY_LOCKED
+ ERROR_SECRET_TOO_LONG
+ ERROR_SECTOR_NOT_FOUND
+ ERROR_SEEK
+ ERROR_SEEK_ON_DEVICE
+ ERROR_SEM_IS_SET
+ ERROR_SEM_NOT_FOUND
+ ERROR_SEM_OWNER_DIED
+ ERROR_SEM_TIMEOUT
+ ERROR_SEM_USER_LIMIT
+ ERROR_SERIAL_NO_DEVICE
+ ERROR_SERVER_DISABLED
+ ERROR_SERVER_HAS_OPEN_HANDLES
+ ERROR_SERVER_NOT_DISABLED
+ ERROR_SERVICE_ALREADY_RUNNING
+ ERROR_SERVICE_CANNOT_ACCEPT_CTRL
+ ERROR_SERVICE_DATABASE_LOCKED
+ ERROR_SERVICE_DEPENDENCY_DELETED
+ ERROR_SERVICE_DEPENDENCY_FAIL
+ ERROR_SERVICE_DISABLED
+ ERROR_SERVICE_DOES_NOT_EXIST
+ ERROR_SERVICE_EXISTS
+ ERROR_SERVICE_LOGON_FAILED
+ ERROR_SERVICE_MARKED_FOR_DELETE
+ ERROR_SERVICE_NEVER_STARTED
+ ERROR_SERVICE_NOT_ACTIVE
+ ERROR_SERVICE_NOT_FOUND
+ ERROR_SERVICE_NO_THREAD
+ ERROR_SERVICE_REQUEST_TIMEOUT
+ ERROR_SERVICE_SPECIFIC_ERROR
+ ERROR_SERVICE_START_HANG
+ ERROR_SESSION_CREDENTIAL_CONFLICT
+ ERROR_SETCOUNT_ON_BAD_LB
+ ERROR_SETMARK_DETECTED
+ ERROR_SHARING_BUFFER_EXCEEDED
+ ERROR_SHARING_PAUSED
+ ERROR_SHARING_VIOLATION
+ ERROR_SHUTDOWN_IN_PROGRESS
+ ERROR_SIGNAL_PENDING
+ ERROR_SIGNAL_REFUSED
+ ERROR_SOME_NOT_MAPPED
+ ERROR_SPECIAL_ACCOUNT
+ ERROR_SPECIAL_GROUP
+ ERROR_SPECIAL_USER
+ ERROR_SPL_NO_ADDJOB
+ ERROR_SPL_NO_STARTDOC
+ ERROR_SPOOL_FILE_NOT_FOUND
+ ERROR_STACK_OVERFLOW
+ ERROR_STATIC_INIT
+ ERROR_SUBST_TO_JOIN
+ ERROR_SUBST_TO_SUBST
+ ERROR_SUCCESS
+ ERROR_SWAPERROR
+ ERROR_SYSTEM_TRACE
+ ERROR_THREAD_1_INACTIVE
+ ERROR_TLW_WITH_WSCHILD
+ ERROR_TOKEN_ALREADY_IN_USE
+ ERROR_TOO_MANY_CMDS
+ ERROR_TOO_MANY_CONTEXT_IDS
+ ERROR_TOO_MANY_LUIDS_REQUESTED
+ ERROR_TOO_MANY_MODULES
+ ERROR_TOO_MANY_MUXWAITERS
+ ERROR_TOO_MANY_NAMES
+ ERROR_TOO_MANY_OPEN_FILES
+ ERROR_TOO_MANY_POSTS
+ ERROR_TOO_MANY_SECRETS
+ ERROR_TOO_MANY_SEMAPHORES
+ ERROR_TOO_MANY_SEM_REQUESTS
+ ERROR_TOO_MANY_SESS
+ ERROR_TOO_MANY_SIDS
+ ERROR_TOO_MANY_TCBS
+ ERROR_TRANSFORM_NOT_SUPPORTED
+ ERROR_TRUSTED_DOMAIN_FAILURE
+ ERROR_TRUSTED_RELATIONSHIP_FAILURE
+ ERROR_TRUST_FAILURE
+ ERROR_UNABLE_TO_LOCK_MEDIA
+ ERROR_UNABLE_TO_UNLOAD_MEDIA
+ ERROR_UNEXP_NET_ERR
+ ERROR_UNKNOWN_PORT
+ ERROR_UNKNOWN_PRINTER_DRIVER
+ ERROR_UNKNOWN_PRINTPROCESSOR
+ ERROR_UNKNOWN_PRINT_MONITOR
+ ERROR_UNKNOWN_REVISION
+ ERROR_UNRECOGNIZED_MEDIA
+ ERROR_UNRECOGNIZED_VOLUME
+ ERROR_USER_EXISTS
+ ERROR_USER_MAPPED_FILE
+ ERROR_VC_DISCONNECTED
+ ERROR_WAIT_NO_CHILDREN
+ ERROR_WINDOW_NOT_COMBOBOX
+ ERROR_WINDOW_NOT_DIALOG
+ ERROR_WINDOW_OF_OTHER_THREAD
+ ERROR_WINS_INTERNAL
+ ERROR_WRITE_FAULT
+ ERROR_WRITE_PROTECT
+ ERROR_WRONG_DISK
+ ERROR_WRONG_PASSWORD
+ E_ABORT
+ E_ACCESSDENIED
+ E_FAIL
+ E_HANDLE
+ E_INVALIDARG
+ E_NOINTERFACE
+ E_NOTIMPL
+ E_OUTOFMEMORY
+ E_POINTER
+ E_UNEXPECTED
+ FACILITY_CONTROL
+ FACILITY_DISPATCH
+ FACILITY_ITF
+ FACILITY_NT_BIT
+ FACILITY_NULL
+ FACILITY_RPC
+ FACILITY_STORAGE
+ FACILITY_WIN32
+ FACILITY_WINDOWS
+ INPLACE_E_FIRST
+ INPLACE_E_LAST
+ INPLACE_E_NOTOOLSPACE
+ INPLACE_E_NOTUNDOABLE
+ INPLACE_S_FIRST
+ INPLACE_S_LAST
+ INPLACE_S_TRUNCATED
+ MARSHAL_E_FIRST
+ MARSHAL_E_LAST
+ MARSHAL_S_FIRST
+ MARSHAL_S_LAST
+ MEM_E_INVALID_LINK
+ MEM_E_INVALID_ROOT
+ MEM_E_INVALID_SIZE
+ MK_E_CANTOPENFILE
+ MK_E_CONNECTMANUALLY
+ MK_E_ENUMERATION_FAILED
+ MK_E_EXCEEDEDDEADLINE
+ MK_E_FIRST
+ MK_E_INTERMEDIATEINTERFACENOTSUPPORTED
+ MK_E_INVALIDEXTENSION
+ MK_E_LAST
+ MK_E_MUSTBOTHERUSER
+ MK_E_NEEDGENERIC
+ MK_E_NOINVERSE
+ MK_E_NOOBJECT
+ MK_E_NOPREFIX
+ MK_E_NOSTORAGE
+ MK_E_NOTBINDABLE
+ MK_E_NOTBOUND
+ MK_E_NO_NORMALIZED
+ MK_E_SYNTAX
+ MK_E_UNAVAILABLE
+ MK_S_FIRST
+ MK_S_HIM
+ MK_S_LAST
+ MK_S_ME
+ MK_S_MONIKERALREADYREGISTERED
+ MK_S_REDUCED_TO_SELF
+ MK_S_US
+ NOERROR
+ NO_ERROR
+ OLEOBJ_E_FIRST
+ OLEOBJ_E_INVALIDVERB
+ OLEOBJ_E_LAST
+ OLEOBJ_E_NOVERBS
+ OLEOBJ_S_CANNOT_DOVERB_NOW
+ OLEOBJ_S_FIRST
+ OLEOBJ_S_INVALIDHWND
+ OLEOBJ_S_INVALIDVERB
+ OLEOBJ_S_LAST
+ OLE_E_ADVF
+ OLE_E_ADVISENOTSUPPORTED
+ OLE_E_BLANK
+ OLE_E_CANTCONVERT
+ OLE_E_CANT_BINDTOSOURCE
+ OLE_E_CANT_GETMONIKER
+ OLE_E_CLASSDIFF
+ OLE_E_ENUM_NOMORE
+ OLE_E_FIRST
+ OLE_E_INVALIDHWND
+ OLE_E_INVALIDRECT
+ OLE_E_LAST
+ OLE_E_NOCACHE
+ OLE_E_NOCONNECTION
+ OLE_E_NOSTORAGE
+ OLE_E_NOTRUNNING
+ OLE_E_NOT_INPLACEACTIVE
+ OLE_E_OLEVERB
+ OLE_E_PROMPTSAVECANCELLED
+ OLE_E_STATIC
+ OLE_E_WRONGCOMPOBJ
+ OLE_S_FIRST
+ OLE_S_LAST
+ OLE_S_MAC_CLIPFORMAT
+ OLE_S_STATIC
+ OLE_S_USEREG
+ REGDB_E_CLASSNOTREG
+ REGDB_E_FIRST
+ REGDB_E_IIDNOTREG
+ REGDB_E_INVALIDVALUE
+ REGDB_E_KEYMISSING
+ REGDB_E_LAST
+ REGDB_E_READREGDB
+ REGDB_E_WRITEREGDB
+ REGDB_S_FIRST
+ REGDB_S_LAST
+ RPC_E_ATTEMPTED_MULTITHREAD
+ RPC_E_CALL_CANCELED
+ RPC_E_CALL_REJECTED
+ RPC_E_CANTCALLOUT_AGAIN
+ RPC_E_CANTCALLOUT_INASYNCCALL
+ RPC_E_CANTCALLOUT_INEXTERNALCALL
+ RPC_E_CANTCALLOUT_ININPUTSYNCCALL
+ RPC_E_CANTPOST_INSENDCALL
+ RPC_E_CANTTRANSMIT_CALL
+ RPC_E_CHANGED_MODE
+ RPC_E_CLIENT_CANTMARSHAL_DATA
+ RPC_E_CLIENT_CANTUNMARSHAL_DATA
+ RPC_E_CLIENT_DIED
+ RPC_E_CONNECTION_TERMINATED
+ RPC_E_DISCONNECTED
+ RPC_E_FAULT
+ RPC_E_INVALIDMETHOD
+ RPC_E_INVALID_CALLDATA
+ RPC_E_INVALID_DATA
+ RPC_E_INVALID_DATAPACKET
+ RPC_E_INVALID_PARAMETER
+ RPC_E_NOT_REGISTERED
+ RPC_E_OUT_OF_RESOURCES
+ RPC_E_RETRY
+ RPC_E_SERVERCALL_REJECTED
+ RPC_E_SERVERCALL_RETRYLATER
+ RPC_E_SERVERFAULT
+ RPC_E_SERVER_CANTMARSHAL_DATA
+ RPC_E_SERVER_CANTUNMARSHAL_DATA
+ RPC_E_SERVER_DIED
+ RPC_E_SERVER_DIED_DNE
+ RPC_E_SYS_CALL_FAILED
+ RPC_E_THREAD_NOT_INIT
+ RPC_E_UNEXPECTED
+ RPC_E_WRONG_THREAD
+ RPC_S_ADDRESS_ERROR
+ RPC_S_ALREADY_LISTENING
+ RPC_S_ALREADY_REGISTERED
+ RPC_S_BINDING_HAS_NO_AUTH
+ RPC_S_BINDING_INCOMPLETE
+ RPC_S_CALL_CANCELLED
+ RPC_S_CALL_FAILED
+ RPC_S_CALL_FAILED_DNE
+ RPC_S_CALL_IN_PROGRESS
+ RPC_S_CANNOT_SUPPORT
+ RPC_S_CANT_CREATE_ENDPOINT
+ RPC_S_COMM_FAILURE
+ RPC_S_DUPLICATE_ENDPOINT
+ RPC_S_ENTRY_ALREADY_EXISTS
+ RPC_S_ENTRY_NOT_FOUND
+ RPC_S_FP_DIV_ZERO
+ RPC_S_FP_OVERFLOW
+ RPC_S_FP_UNDERFLOW
+ RPC_S_GROUP_MEMBER_NOT_FOUND
+ RPC_S_INCOMPLETE_NAME
+ RPC_S_INTERFACE_NOT_FOUND
+ RPC_S_INTERNAL_ERROR
+ RPC_S_INVALID_AUTH_IDENTITY
+ RPC_S_INVALID_BINDING
+ RPC_S_INVALID_BOUND
+ RPC_S_INVALID_ENDPOINT_FORMAT
+ RPC_S_INVALID_NAF_ID
+ RPC_S_INVALID_NAME_SYNTAX
+ RPC_S_INVALID_NETWORK_OPTIONS
+ RPC_S_INVALID_NET_ADDR
+ RPC_S_INVALID_OBJECT
+ RPC_S_INVALID_RPC_PROTSEQ
+ RPC_S_INVALID_STRING_BINDING
+ RPC_S_INVALID_STRING_UUID
+ RPC_S_INVALID_TAG
+ RPC_S_INVALID_TIMEOUT
+ RPC_S_INVALID_VERS_OPTION
+ RPC_S_MAX_CALLS_TOO_SMALL
+ RPC_S_NAME_SERVICE_UNAVAILABLE
+ RPC_S_NOTHING_TO_EXPORT
+ RPC_S_NOT_ALL_OBJS_UNEXPORTED
+ RPC_S_NOT_CANCELLED
+ RPC_S_NOT_LISTENING
+ RPC_S_NOT_RPC_ERROR
+ RPC_S_NO_BINDINGS
+ RPC_S_NO_CALL_ACTIVE
+ RPC_S_NO_CONTEXT_AVAILABLE
+ RPC_S_NO_ENDPOINT_FOUND
+ RPC_S_NO_ENTRY_NAME
+ RPC_S_NO_INTERFACES
+ RPC_S_NO_MORE_BINDINGS
+ RPC_S_NO_MORE_MEMBERS
+ RPC_S_NO_PRINC_NAME
+ RPC_S_NO_PROTSEQS
+ RPC_S_NO_PROTSEQS_REGISTERED
+ RPC_S_OBJECT_NOT_FOUND
+ RPC_S_OUT_OF_RESOURCES
+ RPC_S_PROCNUM_OUT_OF_RANGE
+ RPC_S_PROTOCOL_ERROR
+ RPC_S_PROTSEQ_NOT_FOUND
+ RPC_S_PROTSEQ_NOT_SUPPORTED
+ RPC_S_SEC_PKG_ERROR
+ RPC_S_SERVER_TOO_BUSY
+ RPC_S_SERVER_UNAVAILABLE
+ RPC_S_STRING_TOO_LONG
+ RPC_S_TYPE_ALREADY_REGISTERED
+ RPC_S_UNKNOWN_AUTHN_LEVEL
+ RPC_S_UNKNOWN_AUTHN_SERVICE
+ RPC_S_UNKNOWN_AUTHN_TYPE
+ RPC_S_UNKNOWN_AUTHZ_SERVICE
+ RPC_S_UNKNOWN_IF
+ RPC_S_UNKNOWN_MGR_TYPE
+ RPC_S_UNSUPPORTED_AUTHN_LEVEL
+ RPC_S_UNSUPPORTED_NAME_SYNTAX
+ RPC_S_UNSUPPORTED_TRANS_SYN
+ RPC_S_UNSUPPORTED_TYPE
+ RPC_S_UUID_LOCAL_ONLY
+ RPC_S_UUID_NO_ADDRESS
+ RPC_S_WRONG_KIND_OF_BINDING
+ RPC_S_ZERO_DIVIDE
+ RPC_X_BAD_STUB_DATA
+ RPC_X_BYTE_COUNT_TOO_SMALL
+ RPC_X_ENUM_VALUE_OUT_OF_RANGE
+ RPC_X_INVALID_ES_ACTION
+ RPC_X_NO_MORE_ENTRIES
+ RPC_X_NULL_REF_POINTER
+ RPC_X_SS_CANNOT_GET_CALL_HANDLE
+ RPC_X_SS_CHAR_TRANS_OPEN_FAIL
+ RPC_X_SS_CHAR_TRANS_SHORT_FILE
+ RPC_X_SS_CONTEXT_DAMAGED
+ RPC_X_SS_HANDLES_MISMATCH
+ RPC_X_SS_IN_NULL_CONTEXT
+ RPC_X_WRONG_ES_VERSION
+ RPC_X_WRONG_STUB_VERSION
+ SEVERITY_ERROR
+ SEVERITY_SUCCESS
+ STG_E_ABNORMALAPIEXIT
+ STG_E_ACCESSDENIED
+ STG_E_CANTSAVE
+ STG_E_DISKISWRITEPROTECTED
+ STG_E_EXTANTMARSHALLINGS
+ STG_E_FILEALREADYEXISTS
+ STG_E_FILENOTFOUND
+ STG_E_INSUFFICIENTMEMORY
+ STG_E_INUSE
+ STG_E_INVALIDFLAG
+ STG_E_INVALIDFUNCTION
+ STG_E_INVALIDHANDLE
+ STG_E_INVALIDHEADER
+ STG_E_INVALIDNAME
+ STG_E_INVALIDPARAMETER
+ STG_E_INVALIDPOINTER
+ STG_E_LOCKVIOLATION
+ STG_E_MEDIUMFULL
+ STG_E_NOMOREFILES
+ STG_E_NOTCURRENT
+ STG_E_NOTFILEBASEDSTORAGE
+ STG_E_OLDDLL
+ STG_E_OLDFORMAT
+ STG_E_PATHNOTFOUND
+ STG_E_READFAULT
+ STG_E_REVERTED
+ STG_E_SEEKERROR
+ STG_E_SHAREREQUIRED
+ STG_E_SHAREVIOLATION
+ STG_E_TOOMANYOPENFILES
+ STG_E_UNIMPLEMENTEDFUNCTION
+ STG_E_UNKNOWN
+ STG_E_WRITEFAULT
+ STG_S_CONVERTED
+ S_FALSE
+ S_OK
+ TYPE_E_AMBIGUOUSNAME
+ TYPE_E_BADMODULEKIND
+ TYPE_E_BUFFERTOOSMALL
+ TYPE_E_CANTCREATETMPFILE
+ TYPE_E_CANTLOADLIBRARY
+ TYPE_E_CIRCULARTYPE
+ TYPE_E_DLLFUNCTIONNOTFOUND
+ TYPE_E_DUPLICATEID
+ TYPE_E_ELEMENTNOTFOUND
+ TYPE_E_INCONSISTENTPROPFUNCS
+ TYPE_E_INVALIDID
+ TYPE_E_INVALIDSTATE
+ TYPE_E_INVDATAREAD
+ TYPE_E_IOERROR
+ TYPE_E_LIBNOTREGISTERED
+ TYPE_E_NAMECONFLICT
+ TYPE_E_OUTOFBOUNDS
+ TYPE_E_QUALIFIEDNAMEDISALLOWED
+ TYPE_E_REGISTRYACCESS
+ TYPE_E_SIZETOOBIG
+ TYPE_E_TYPEMISMATCH
+ TYPE_E_UNDEFINEDTYPE
+ TYPE_E_UNKNOWNLCID
+ TYPE_E_UNSUPFORMAT
+ TYPE_E_WRONGTYPEKIND
+ VIEW_E_DRAW
+ VIEW_E_FIRST
+ VIEW_E_LAST
+ VIEW_S_ALREADY_FROZEN
+ VIEW_S_FIRST
+ VIEW_S_LAST
+);
+
+sub AUTOLOAD {
+ # 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.
+
+ my($constname);
+ ($constname = $AUTOLOAD) =~ s/.*:://;
+ #reset $! to zero to reset any current errors.
+ local $! = 0;
+ local $^E = 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::WinError macro $constname, used at $file line $line.";
+ }
+ }
+ eval "sub $AUTOLOAD { $val }";
+ goto &$AUTOLOAD;
+}
+
+bootstrap Win32::WinError;
+
+# Preloaded methods go here.
+
+# Autoload methods go after __END__, and are processed by the autosplit program.
+
+1;
+__END__