diff options
author | Norbert Preining <norbert@preining.info> | 2019-09-02 13:46:59 +0900 |
---|---|---|
committer | Norbert Preining <norbert@preining.info> | 2019-09-02 13:46:59 +0900 |
commit | e0c6872cf40896c7be36b11dcc744620f10adf1d (patch) | |
tree | 60335e10d2f4354b0674ec22d7b53f0f8abee672 /systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32 |
Initial commit
Diffstat (limited to 'systems/texlive/tlnet/tlpkg/tlperl/site/lib/Win32')
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->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<®_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__ |