diff options
author | Norbert Preining <preining@logic.at> | 2010-05-12 16:54:37 +0000 |
---|---|---|
committer | Norbert Preining <preining@logic.at> | 2010-05-12 16:54:37 +0000 |
commit | 661c41a09e39a182865e0b51e34cc995a0dc96e8 (patch) | |
tree | 2f79bb1406e22fdcb2587be8ffda6c0c609d7932 /Master/tlpkg/tlperl/lib/Win32 | |
parent | b645030efc22e13c2498a1522083634ab91b2de1 (diff) |
move tlperl.straw to tlperl
git-svn-id: svn://tug.org/texlive/trunk@18210 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Win32')
39 files changed, 10981 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/Win32/API.pm b/Master/tlpkg/tlperl/lib/Win32/API.pm new file mode 100755 index 00000000000..365ce6b46c5 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Win32/API.pm @@ -0,0 +1,778 @@ +# 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> +# +# $Id: API.pm 458 2009-01-17 17:27:43Z cosimo.streppone $ +# +####################################################################### + +package Win32::API; + +require Exporter; # to export the constants to the main:: space +require DynaLoader; # to dynuhlode the module. +@ISA = qw( Exporter DynaLoader ); + +use vars qw( $DEBUG ); +$DEBUG = 0; + +sub DEBUG { + if ($Win32::API::DEBUG) { + printf @_ if @_ or return 1; + } else { + return 0; + } +} + +use Win32::API::Type; +use Win32::API::Struct; +use File::Basename (); + +####################################################################### +# STATIC OBJECT PROPERTIES +# +$VERSION = '0.59'; + +#### some package-global hash to +#### keep track of the imported +#### libraries and procedures +my %Libraries = (); +my %Procedures = (); + + +####################################################################### +# dynamically load in the API extension module. +# +bootstrap Win32::API; + +####################################################################### +# PUBLIC METHODS +# +sub new { + my($class, $dll, $proc, $in, $out, $callconvention) = @_; + my $hdll; + my $self = {}; + + if ($^O eq 'cygwin' and $dll ne File::Basename::basename($dll)) { + # need to convert $dll to win32 path + # isn't there an API for this? + my $newdll = `cygpath -w "$dll"`; + chomp $newdll; + DEBUG "(PM)new: converted '$dll' to\n '$newdll'\n"; + $dll = $newdll; + } + + #### avoid loading a library more than once + if(exists($Libraries{$dll})) { + DEBUG "Win32::API::new: Library '$dll' already loaded, handle=$Libraries{$dll}\n"; + $hdll = $Libraries{$dll}; + } else { + DEBUG "Win32::API::new: Loading library '$dll'\n"; + $hdll = Win32::API::LoadLibrary($dll); +# $Libraries{$dll} = $hdll; + } + + #### if the dll can't be loaded, set $! to Win32's GetLastError() + if(!$hdll) { + $! = Win32::GetLastError(); + DEBUG "FAILED Loading library '$dll': $!\n"; + delete $Libraries{$dll}; + return undef; + } + + #### determine if we have a prototype or not + if( (not defined $in) and (not defined $out) ) { + ($proc, $self->{in}, $self->{intypes}, $self->{out}, $self->{cdecl}) = parse_prototype( $proc ); + return undef unless $proc; + $self->{proto} = 1; + } else { + $self->{in} = []; + if(ref($in) eq 'ARRAY') { + foreach (@$in) { + push(@{ $self->{in} }, type_to_num($_)); + } + } else { + my @in = split '', $in; + foreach (@in) { + push(@{ $self->{in} }, type_to_num($_)); + } + } + $self->{out} = type_to_num($out); + $self->{cdecl} = calltype_to_num($callconvention); + } + + #### first try to import the function of given name... + my $hproc = Win32::API::GetProcAddress($hdll, $proc); + + #### ...then try appending either A or W (for ASCII or Unicode) + if(!$hproc) { + my $tproc = $proc; + $tproc .= (IsUnicode() ? "W" : "A"); + # print "Win32::API::new: procedure not found, trying '$tproc'...\n"; + $hproc = Win32::API::GetProcAddress($hdll, $tproc); + } + + #### ...if all that fails, set $! accordingly + if(!$hproc) { + $! = Win32::GetLastError(); + DEBUG "FAILED GetProcAddress for Proc '$proc': $!\n"; + return undef; + } + DEBUG "GetProcAddress('$proc') = '$hproc'\n"; + + #### ok, let's stuff the object + $self->{procname} = $proc; + $self->{dll} = $hdll; + $self->{dllname} = $dll; + $self->{proc} = $hproc; + + #### keep track of the imported function + $Libraries{$dll} = $hdll; + $Procedures{$dll}++; + + DEBUG "Object blessed!\n"; + + #### cast the spell + bless($self, $class); + return $self; +} + +sub Import { + my($class, $dll, $proc, $in, $out, $callconvention) = @_; + $Imported{"$dll:$proc"} = Win32::API->new($dll, $proc, $in, $out, $callconvention) or return 0; + my $P = (caller)[0]; + eval qq( + sub ${P}::$Imported{"$dll:$proc"}->{procname} { \$Win32::API::Imported{"$dll:$proc"}->Call(\@_); } + ); + return $@ ? 0 : 1; +} + +####################################################################### +# PRIVATE METHODS +# +sub DESTROY { + my($self) = @_; + + #### decrease this library's procedures reference count + $Procedures{$self->{dllname}}--; + + #### once it reaches 0, free it + if($Procedures{$self->{dllname}} == 0) { + DEBUG "Win32::API::DESTROY: Freeing library '$self->{dllname}'\n"; + Win32::API::FreeLibrary($Libraries{$self->{dllname}}); + delete($Libraries{$self->{dllname}}); + } +} + +# Convert calling convention string (_cdecl|__stdcall) +# to an integer (1|0). Unknown counts as __stdcall +# +sub calltype_to_num { + my $type = shift; + + if (!$type || $type eq "__stdcall") { + return 0; + } + elsif ($type eq "_cdecl") { + return 1; + } + else { + warn "unknown calling convention: '$type'"; + return 0; + } +} + +sub type_to_num { + my $type = shift; + my $out = shift; + my $num; + + if( $type eq 'N' + or $type eq 'n' + or $type eq 'l' + or $type eq 'L' + ) { + $num = 1; + } elsif($type eq 'P' + or $type eq 'p' + ) { + $num = 2; + } elsif($type eq 'I' + or $type eq 'i' + ) { + $num = 3; + } elsif($type eq 'f' + or $type eq 'F' + ) { + $num = 4; + } elsif($type eq 'D' + or $type eq 'd' + ) { + $num = 5; + } elsif($type eq 'c' + or $type eq 'C' + ) { + $num = 6; + } else { + $num = 0; + } + unless(defined $out) { + if( $type eq 's' + or $type eq 'S' + ) { + $num = 51; + } elsif($type eq 'b' + or $type eq 'B' + ) { + $num = 22; + } elsif($type eq 'k' + or $type eq 'K' + ) { + $num = 101; + } + } + return $num; +} + +sub parse_prototype { + my($proto) = @_; + + my @in_params = (); + my @in_types = (); + if($proto =~ /^\s*(\S+)(?:\s+(\w+))?\s+(\S+)\s*\(([^\)]*)\)/) { + my $ret = $1; + my $callconvention= $2; + my $proc = $3; + my $params = $4; + + $params =~ s/^\s+//; + $params =~ s/\s+$//; + + DEBUG "(PM)parse_prototype: got PROC '%s'\n", $proc; + DEBUG "(PM)parse_prototype: got PARAMS '%s'\n", $params; + + foreach my $param (split(/\s*,\s*/, $params)) { + my($type, $name); + if($param =~ /(\S+)\s+(\S+)/) { + ($type, $name) = ($1, $2); + } + + if(Win32::API::Type::is_known($type)) { + if(Win32::API::Type::is_pointer($type)) { + DEBUG "(PM)parse_prototype: IN='%s' PACKING='%s' API_TYPE=%d\n", + $type, + Win32::API::Type->packing( $type ), + type_to_num('P'); + push(@in_params, type_to_num('P')); + } else { + DEBUG "(PM)parse_prototype: IN='%s' PACKING='%s' API_TYPE=%d\n", + $type, + Win32::API::Type->packing( $type ), + type_to_num( Win32::API::Type->packing( $type ) ); + push(@in_params, type_to_num( Win32::API::Type->packing( $type ) )); + } + } elsif( Win32::API::Struct::is_known( $type ) ) { + DEBUG "(PM)parse_prototype: IN='%s' PACKING='%s' API_TYPE=%d\n", + $type, 'S', type_to_num('S'); + push(@in_params, type_to_num('S')); + } else { + warn "Win32::API::parse_prototype: WARNING unknown parameter type '$type'"; + push(@in_params, type_to_num('I')); + } + push(@in_types, $type); + + } + DEBUG "parse_prototype: IN=[ @in_params ]\n"; + + + + if(Win32::API::Type::is_known($ret)) { + if(Win32::API::Type::is_pointer($ret)) { + DEBUG "parse_prototype: OUT='%s' PACKING='%s' API_TYPE=%d\n", + $ret, + Win32::API::Type->packing( $ret ), + type_to_num('P'); + return ( $proc, \@in_params, \@in_types, type_to_num('P'), calltype_to_num($callconvention) ); + } else { + DEBUG "parse_prototype: OUT='%s' PACKING='%s' API_TYPE=%d\n", + $ret, + Win32::API::Type->packing( $ret ), + type_to_num( Win32::API::Type->packing( $ret ) ); + return ( $proc, \@in_params, \@in_types, type_to_num(Win32::API::Type->packing($ret)), calltype_to_num($callconvention) ); + } + } else { + warn "Win32::API::parse_prototype: WARNING unknown output parameter type '$ret'"; + return ( $proc, \@in_params, \@in_types, type_to_num('I'), calltype_to_num($callconvention) ); + } + + } else { + warn "Win32::API::parse_prototype: bad prototype '$proto'"; + return undef; + } +} + +1; + +__END__ + +####################################################################### +# DOCUMENTATION +# + +=head1 NAME + +Win32::API - Perl Win32 API Import Facility + +=head1 SYNOPSIS + + #### Method 1: with prototype + + use Win32::API; + $function = Win32::API->new( + 'mydll, 'int sum_integers(int a, int b)', + ); + $return = $function->Call(3, 2); + + #### Method 2: with parameter list + + use Win32::API; + $function = Win32::API->new( + 'mydll', 'sum_integers', 'II', 'I', + ); + $return = $function->Call(3, 2); + + #### Method 3: with Import + + use Win32::API; + Win32::API->Import( + 'mydll', 'int sum_integers(int a, int b)', + ); + $return = sum_integers(3, 2); + + +=for LATER-UNIMPLEMENTED + #### or + use Win32::API mydll => 'int sum_integers(int a, int b)'; + $return = sum_integers(3, 2); + + +=head1 ABSTRACT + +With this module you can import and call arbitrary functions +from Win32's Dynamic Link Libraries (DLL), without having +to write an XS extension. Note, however, that this module +can't do 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->Import("kernel32", "int GetCurrentProcessId()"); + $PID = GetCurrentProcessId(); + +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 object (see L<IMPORTING A FUNCTION>) and then invoke the +C<Call()> method on this object to perform a call to the imported API +(see L<CALLING AN IMPORTED FUNCTION>). + +Starting from version 0.40, you can also avoid creating a Win32::API object +and instead automatically define a Perl sub with the same name of the API +function you're importing. The details of the API definitions are the same, +just the call is different: + + my $GetCurrentProcessId = Win32::API->new( + "kernel32", "int GetCurrentProcessId()" + ); + my $PID = $GetCurrentProcessId->Call(); + + #### vs. + + Win32::API->Import("kernel32", "int GetCurrentProcessId()"); + $PID = GetCurrentProcessId(); + +Note that C<Import> returns 1 on success and 0 on failure (in which case you +can check the content of C<$^E>). + +=head2 IMPORTING A FUNCTION + +You can import a function from a 32 bit Dynamic Link Library (DLL) file +with the C<new()> function. This will create a Perl object that contains the +reference to that function, which you can later C<Call()>. + +What you need to know is the prototype of the function you're going to import +(eg. the definition of the function expressed in C syntax). + +Starting from version 0.40, there are 2 different approaches for this step: +(the preferred) one uses the prototype directly, while the other (now deprecated) +one uses Win32::API's internal representation for parameters. + +=head2 IMPORTING A FUNCTION BY PROTOTYPE + +You need to pass 2 parameters: + +=over 4 + +=item 1. + +The name of the library from which you want to import the function. + +=item 2. + +The C prototype of the function. + +=back + +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. + +=head2 IMPORTING A FUNCTION WITH A PARAMETER LIST + +You need to pass 4 parameters: + +=over 4 + +=item 1. +The name of the library from which you want to import the function. + +=item 2. +The name of the function (as exported by the library). + +=item 3. +The number and types of the arguments the function expects as input. + +=item 4. +The type of the value returned by the function. + +=item 5. +And optionally you can specify the calling convention, this defaults to +'__stdcall', alternatively you can specify '_cdecl'. + +=back + +To better explain their meaning, let's suppose that we +want to import and call the Win32 API C<GetTempPath()>. +This function is defined in C as: + + DWORD WINAPI GetTempPathA( DWORD nBufferLength, LPSTR lpBuffer ); + +This is documented in the B<Win32 SDK Reference>; you can look +for it on the Microsoft's WWW site, or in your C compiler's +documentation, if you own one. + +=over 4 + +=item B<1.> + +The first parameter is the name of the library file that +exports this function; our function resides in the F<KERNEL32.DLL> +system file. + +When specifying this name as parameter, the F<.DLL> extension +is implicit, and if no path is given, the file is searched through +a couple of directories, including: + +=over 4 + +=item 1. The directory from which the application loaded. + +=item 2. The current directory. + +=item 3. The Windows system directory (eg. c:\windows\system or system32). + +=item 4. The Windows directory (eg. c:\windows). + +=item 5. The directories that are listed in the PATH environment variable. + +=back + +So, you don't have to write F<C:\windows\system\kernel32.dll>; +only F<kernel32> is enough: + + $GetTempPath = new Win32::API('kernel32', ... + +=item B<2.> + +Now for the second parameter: the name of the function. +It must be written exactly as it is exported +by the library (case is significant here). +If you are using Windows 95 or NT 4.0, you can use the B<Quick View> +command on the DLL file to see the function it exports. +Remember that you can only import functions from 32 bit DLLs: +in Quick View, the file's characteristics should report +somewhere "32 bit word machine"; as a rule of thumb, +when you see that all the exported functions are in upper case, +the DLL is a 16 bit one and you can't use it. +If their capitalization looks correct, then it's probably a 32 bit +DLL. + +Also note that many Win32 APIs are exported twice, with the addition of +a final B<A> or B<W> to their name, for - respectively - the ASCII +and the Unicode version. +When a function name is not found, Win32::API will actually append +an B<A> to the name and try again; if the extension is built on a +Unicode system, then it will try with the B<W> instead. +So our function name will be: + + $GetTempPath = new Win32::API('kernel32', 'GetTempPath', ... + +In our case C<GetTempPath> is really loaded as C<GetTempPathA>. + +=item B<3.> + +The third parameter, the input parameter list, specifies how many +arguments the function wants, and their types. It can be passed as +a single string, in which each character represents one parameter, +or as a list reference. The following forms are valid: + + "abcd" + [a, b, c, d] + \@LIST + +But those are not: + + (a, b, c, d) + @LIST + +The number of characters, or elements in the list, specifies the number +of parameters, and each character or element specifies the type of an +argument; allowed types are: + +=over 4 + +=item C<I>: +value is an integer (int) + +=item C<N>: +value is a number (long) + +=item C<F>: +value is a floating point number (float) + +=item C<D>: +value is a double precision number (double) + +=item C<C>: +value is a char (char) + +=item C<P>: +value is a pointer (to a string, structure, etc...) + +=item C<S>: +value is a Win32::API::Struct object (see below) + +=item C<K>: +value is a Win32::API::Callback object (see L<Win32::API::Callback>) + +=back + +Our function needs two parameters: a number (C<DWORD>) and a pointer to a +string (C<LPSTR>): + + $GetTempPath = new Win32::API('kernel32', 'GetTempPath', 'NP', ... + +=item B<4.> + +The fourth and final parameter is the type of the value returned by the +function. It can be one of the types seen above, plus another type named B<V> +(for C<void>), used for functions that do not return a value. +In our example the value returned by GetTempPath() is a C<DWORD>, so +our return type will be B<N>: + + $GetTempPath = new Win32::API('kernel32', 'GetTempPath', 'NP', 'N'); + +Now the line is complete, and the GetTempPath() API is ready to be used +in Perl. Before calling it, you should test that $GetTempPath is +C<defined>, otherwise either the function or the library could not be +loaded; in this case, C<$!> will be set to the error message reported +by Windows. +Our definition, with error checking added, should then look like this: + + $GetTempPath = new Win32::API('kernel32', 'GetTempPath', 'NP', 'N'); + if(not defined $GetTempPath) { + die "Can't import API GetTempPath: $!\n"; + } + +=back + +=head2 CALLING AN IMPORTED FUNCTION + +To effectively make a call to an imported function you must use the +Call() method on the Win32::API object you created. +Continuing with the example from the previous paragraph, +the GetTempPath() API can be called using the method: + + $GetTempPath->Call(... + +Of course, parameters have to be passed as defined in the import phase. +In particular, if the number of parameters does not match (in the example, +if GetTempPath() is called with more or less than two parameters), +Perl will C<croak> an error message and C<die>. + +The two parameters needed here are the length of the buffer +that will hold the returned temporary path, and a pointer to the +buffer itself. +For numerical parameters, you can use either a constant expression +or a variable, while B<for pointers you must use a variable name> (no +Perl references, just a plain variable name). +Also note that B<memory must be allocated before calling the function>, +just like in C. +For example, to pass a buffer of 80 characters to GetTempPath(), +it must be initialized before with: + + $lpBuffer = " " x 80; + +This allocates a string of 80 characters. If you don't do so, you'll +probably get C<Runtime exception> errors, and generally nothing will +work. The call should therefore include: + + $lpBuffer = " " x 80; + $GetTempPath->Call(80, $lpBuffer); + +And the result will be stored in the $lpBuffer variable. +Note that you don't need to pass a reference to the variable +(eg. you B<don't need> C<\$lpBuffer>), even if its value will be set +by the function. + +A little problem here is that Perl does not trim the variable, +so $lpBuffer will still contain 80 characters in return; the exceeding +characters will be spaces, because we said C<" " x 80>. + +In this case we're lucky enough, because the value returned by +the GetTempPath() function is the length of the string, so to get +the actual temporary path we can write: + + $lpBuffer = " " x 80; + $return = $GetTempPath->Call(80, $lpBuffer); + $TempPath = substr($lpBuffer, 0, $return); + +If you don't know the length of the string, you can usually +cut it at the C<\0> (ASCII zero) character, which is the string +delimiter in C: + + $TempPath = ((split(/\0/, $lpBuffer))[0]; + # or + $lpBuffer =~ s/\0.*$//; + +=head2 USING STRUCTURES + +Starting from version 0.40, Win32::API comes with a support package +named Win32::API::Struct. The package is loaded automatically with +Win32::API, so you don't need to use it explicitly. + +With this module you can conveniently define structures and use +them as parameters to Win32::API functions. A short example follows: + + + # the 'POINT' structure is defined in C as: + # typedef struct { + # LONG x; + # LONG y; + # } POINT; + + + #### define the structure + Win32::API::Struct->typedef( POINT => qw{ + LONG x; + LONG y; + }); + + #### import an API that uses this structure + Win32::API->Import('user32', 'BOOL GetCursorPos(LPPOINT lpPoint)'); + + #### create a 'POINT' object + my $pt = Win32::API::Struct->new('POINT'); + + #### call the function passing our structure object + GetCursorPos($pt); + + #### and now, access its members + print "The cursor is at: $pt->{x}, $pt->{y}\n"; + +Note that this works only when the function wants a +B<pointer to a structure>: as you can see, our structure is named +'POINT', but the API used 'LPPOINT'. 'LP' is automatically added at +the beginning of the structure name when feeding it to a Win32::API +call. + +For more information, see also L<Win32::API::Struct>. + +If you don't want (or can't) use the C<Win32::API::Struct> facility, +you can still use the low-level approach to use structures: + +=over 4 + +=item 1. + +you have to pack() the required elements in a variable: + + $lpPoint = pack('LL', 0, 0); # store two LONGs + +=item 2. + +to access the values stored in a structure, unpack() it as required: + + ($x, $y) = unpack('LL', $lpPoint); # get the actual values + +=back + +The rest is left as an exercise to the reader... + +=head1 AUTHOR + +Aldo Calpini ( I<dada@perl.it> ). + +=head1 MAINTAINER + +Cosimo Streppone ( I<cosimo@cpan.org> ) + +=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 unvaluable 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/Master/tlpkg/tlperl/lib/Win32/API/Callback.pm b/Master/tlpkg/tlperl/lib/Win32/API/Callback.pm new file mode 100755 index 00000000000..df15786591b --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Win32/API/Callback.pm @@ -0,0 +1,174 @@ +# See the bottom of this file for the POD documentation. Search for the +# string '=head'. + +####################################################################### +# +# Win32::API::Callback - Perl Win32 API Import Facility +# +# Author: Aldo Calpini <dada@perl.it> +# Maintainer: Cosimo Streppone <cosimo@cpan.org> +# +# $Id: Callback.pm 458 2009-01-17 17:27:43Z cosimo.streppone $ +# +####################################################################### + +package Win32::API::Callback; + +$VERSION = '0.59'; + +require Exporter; # to export the constants to the main:: space +require DynaLoader; # to dynuhlode the module. +@ISA = qw( Exporter DynaLoader ); + +sub DEBUG { + if ($WIN32::API::DEBUG) { + printf @_ if @_ or return 1; + } else { + return 0; + } +} + +use Win32::API; +use Win32::API::Type; +use Win32::API::Struct; + +####################################################################### +# This AUTOLOAD is used to 'autoload' constants from the constant() +# XS function. If a constant is not found then control is passed +# to the AUTOLOAD in AutoLoader. +# + +sub AUTOLOAD { + my($constname); + ($constname = $AUTOLOAD) =~ s/.*:://; + #reset $! to zero to reset any current errors. + $!=0; + my $val = constant($constname, @_ ? $_[0] : 0); + if ($! != 0) { + if ($! =~ /Invalid/) { + $AutoLoader::AUTOLOAD = $AUTOLOAD; + goto &AutoLoader::AUTOLOAD; + } else { + ($pack,$file,$line) = caller; + die "Your vendor has not defined Win32::API::Callback macro $constname, used at $file line $line."; + } + } + eval "sub $AUTOLOAD { $val }"; + goto &$AUTOLOAD; +} + + +####################################################################### +# dynamically load in the API extension module. +# +bootstrap Win32::API::Callback; + +####################################################################### +# PUBLIC METHODS +# +sub new { + my($class, $proc, $in, $out) = @_; + my %self = (); + + # printf "(PM)Callback::new: got proc='%s', in='%s', out='%s'\n", $proc, $in, $out; + + $self{in} = []; + if(ref($in) eq 'ARRAY') { + foreach (@$in) { + push(@{ $self{in} }, Win32::API::type_to_num($_)); + } + } else { + my @in = split '', $in; + foreach (@in) { + push(@{ $self{in} }, Win32::API::type_to_num($_)); + } + } + $self{out} = Win32::API::type_to_num($out); + $self{sub} = $proc; + my $self = bless \%self, $class; + + DEBUG "(PM)Callback::new: calling CallbackCreate($self)...\n"; + my $hproc = CallbackCreate($self); + + DEBUG "(PM)Callback::new: hproc=$hproc\n"; + + #### ...if that fails, set $! accordingly + if(!$hproc) { + $! = Win32::GetLastError(); + return undef; + } + + #### ok, let's stuff the object + $self->{code} = $hproc; + $self->{sub} = $proc; + + #### cast the spell + return $self; +} + +sub MakeStruct { + my($self, $n, $addr) = @_; + DEBUG "(PM)Win32::API::Callback::MakeStruct: got self='$self'\n"; + my $struct = Win32::API::Struct->new($self->{intypes}->[$n]); + $struct->FromMemory($addr); + return $struct; +} + +1; + +__END__ + +####################################################################### +# DOCUMENTATION +# + +=head1 NAME + +Win32::API::Callback - Callback support for Win32::API + +=head1 SYNOPSIS + + use Win32::API; + use Win32::API::Callback; + + my $callback = Win32::API::Callback->new( + sub { my($a, $b) = @_; return $a+$b; }, + "NN", "N", + ); + + Win32::API->Import( + 'mydll', 'two_integers_cb', 'KNN', 'N', + ); + + $sum = two_integers_cb( $callback, 3, 2 ); + + +=head1 FOREWORDS + +=over 4 + +=item * +Support for this module is B<highly experimental> at this point. + +=item * +I won't be surprised if it doesn't work for you. + +=item * +Feedback is very appreciated. + +=item * +Documentation is in the work. Either see the SYNOPSIS above +or the samples in the F<samples> directory. + +=back + +=head1 AUTHOR + +Aldo Calpini ( I<dada@perl.it> ). + +=head1 MAINTAINER + +Cosimo Streppone ( I<cosimo@cpan.org> ). + +=cut + diff --git a/Master/tlpkg/tlperl/lib/Win32/API/Struct.pm b/Master/tlpkg/tlperl/lib/Win32/API/Struct.pm new file mode 100755 index 00000000000..9f706671a77 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Win32/API/Struct.pm @@ -0,0 +1,532 @@ +package Win32::API::Struct; + +# See the bottom of this file for the POD documentation. Search for the +# string '=head'. + +####################################################################### +# +# Win32::API::Struct - Perl Win32 API struct Facility +# +# Author: Aldo Calpini <dada@perl.it> +# Maintainer: Cosimo Streppone <cosimo@cpan.org> +# +# $Id: Struct.pm 438 2008-10-02 22:51:55Z cosimo.streppone $ +####################################################################### + +$VERSION = '0.50'; + +use Win32::API::Type; + +use Carp; + +require Exporter; # to export the constants to the main:: space +require DynaLoader; # to dynuhlode the module. +@ISA = qw( Exporter DynaLoader ); + +my %Known = (); + +sub DEBUG { + if ($Win32::API::DEBUG) { + printf @_ if @_ or return 1; + } else { + return 0; + } +} + +sub typedef { + my $class = shift; + my $struct = shift; + my($type, $name); + my $self = { + align => undef, + typedef => [], + }; + while(defined($type = shift)) { + $name = shift; + $name =~ s/;$//; + push( @{ $self->{typedef} }, [ recognize($type, $name) ] ); + } + + $Known{$struct} = $self; + return 1; +} + + +sub recognize { + my($type, $name) = @_; + my($size, $packing); + if(exists $Known{$type}) { + $packing = ">"; + return $name, $packing, $type; + } else { + $packing = Win32::API::Type::packing($type); + return undef unless defined $packing; + if($name =~ s/\[(.*)\]$//) { + $size = $1; + $packing = $packing."*".$size; + } + DEBUG "(PM)Struct::recognize got '$name', '$type' -> '$packing'\n"; + return $name, $packing, $type; + } +} + +sub new { + my $class = shift; + my($type, $name); + my $self = { + typedef => [], + }; + if($#_ == 0) { + if(exists $Known{$_[0]}) { + DEBUG "(PM)Struct::new: got '$_[0]'\n"; + $self->{typedef} = $Known{$_[0]}->{typedef}; + foreach my $member (@{ $self->{typedef} }) { + ($name, $packing, $type) = @$member; + if($packing eq '>') { + $self->{$name} = Win32::API::Struct->new($type); + } + } + $self->{__typedef__} = $_[0]; + } else { + carp "Unknown Win32::API::Struct '$_[0]'"; + return undef; + } + } else { + while(defined($type = shift)) { + $name = shift; + # print "new: found member $name ($type)\n"; + if(not exists $Win32::API::Type::Known{$type}) { + warn "Unknown Win32::API::Struct type '$type'"; + return undef; + } else { + push( @{ $self->{typedef} }, [ $name, $Win32::API::Type::Known{$type}, $type ] ); + } + } + } + return bless $self; +} + +sub members { + my $self = shift; + return map {$_->[0]} @{ $self->{typedef} }; +} + +sub sizeof { + my $self = shift; + my $size = 0; + my $align = 0; + my $first = undef; + foreach my $member (@{ $self->{typedef} }) { + my($name, $packing, $type) = @$member; + + if(ref( $self->{$name} ) eq "Win32::API::Struct") { + $size += $self->{$name}->sizeof(); + # $align = $self->{$name}->sizeof() if $self->{$name}->sizeof() > $align; + } else { + if($packing =~ /\w\*(\d+)/) { + $size += Win32::API::Type::sizeof($type) * $1; + $first = Win32::API::Type::sizeof($type) * $1 unless defined $first; + DEBUG "(PM)Struct::sizeof: sizeof with member($name) now = ". $size. "\n"; + } else { + $size += Win32::API::Type::sizeof($type); + $first = Win32::API::Type::sizeof($type) unless defined $first; + $align = Win32::API::Type::sizeof($type) + if Win32::API::Type::sizeof($type) > $align; + DEBUG "(PM)Struct::sizeof: sizeof with member($name) now = ". $size. "\n"; + } + } + } + DEBUG "(PM)Struct::sizeof first=$first align=$align\n"; + #DEBUG "(PM)Struct::sizeof returning %d\n", $first + (scalar(@{ $self->{typedef} })-1) * $align; + #return $first + (scalar(@{ $self->{typedef} })-1) * $align; + DEBUG "(PM)Struct::sizeof returning %d\n", scalar(@{ $self->{typedef} }) * $align; + if(defined $align and $align > 0) { + return scalar(@{ $self->{typedef} }) * $align; + } else { + return $size; + } + return $size; +} + +sub align { + my $self = shift; + my $align = shift; + + if(not defined $align) { + return $self->{align} unless $self->{align} eq 'auto'; + $align = 0; + foreach my $member (@{ $self->{typedef} }) { + my($name, $packing, $type) = @$member; + + if(ref( $self->{$name} ) eq "Win32::API::Struct") { + #### ???? + } else { + if($packing =~ /\w\*(\d+)/) { + #### ???? + } else { + $align = Win32::API::Type::sizeof($type) + if Win32::API::Type::sizeof($type) > $align; + } + } + } + return $align; + } else { + $self->{align} = $align; + + } +} + +sub getPack { + my $self = shift; + my $packing = ""; + my($type, $name); + my @items = (); + my @recipients = (); + + my $align = $self->align(); + + foreach my $member (@{ $self->{typedef} }) { + ($name, $type, $orig) = @$member; + if($type eq '>') { + my($subpacking, $subitems, $subrecipients) = $self->{$name}->getPack(); + + DEBUG "(PM)Struct::getPack($self->{__typedef__}) ++ $subpacking\n"; + + $packing .= $subpacking; + push(@items, @$subitems); + push(@recipients, @$subrecipients); + } else { + if($type =~ /\w\*(\d+)/) { + my $size = $1; + $type = "a$size"; + } + + DEBUG "(PM)Struct::getPack($self->{__typedef__}) ++ $type\n"; + + if($type eq 'p') { + $type = "L"; + push(@items, Win32::API::PointerTo($self->{$name})); + } else { + push(@items, $self->{$name}); + } + $packing .= $type; + + if($Win32::API::Type::PackSize{$type} < $align) { + $packing .= ("x" x ($align - $Win32::API::Type::PackSize{$type})); + } + + push(@recipients, $self); + } + } + DEBUG "(PM)Struct::getPack: $self->{__typedef__}(buffer) = pack($packing, @items)\n"; + return($packing, [@items], [@recipients]); +} + + +sub Pack { + my $self = shift; + my($packing, $items, $recipients) = $self->getPack(); + DEBUG "(PM)Struct::Pack: $self->{__typedef__}(buffer) = pack($packing, @$items)\n"; + $self->{buffer} = pack($packing, @$items); + if(DEBUG) { + for my $i (0..$self->sizeof-1) { + printf " %3d: 0x%02x\n", $i, ord(substr($self->{buffer}, $i, 1)); + } + } + $self->{buffer_recipients} = $recipients +} + +sub getUnpack { + my $self = shift; + my $packing = ""; + my($type, $name); + my @items = (); + my $align = $self->align(); + foreach my $member (@{ $self->{typedef} }) { + ($name, $type, $orig) = @$member; + if($type eq '>') { + my($subpacking, @subitems) = $self->{$name}->getUnpack(); + + DEBUG "(PM)Struct::getUnpack($self->{__typedef__}) ++ $subpacking\n"; + $packing .= $subpacking; + + + push(@items, @subitems); + } else { + if($type =~ /\w\*(\d+)/) { + my $size = $1; + $type = "Z$size"; + } + + #if($type eq 'p') { + # $packing .= 'Z*'; + # DEBUG "(PM)Struct::getUnpack($self->{__typedef__}) ++ Z*\n"; + #} else { + $packing .= $type; + DEBUG "(PM)Struct::getUnpack($self->{__typedef__}) ++ $type\n"; + #} + if($type ne 'p' and $type !~ /^Z(\d+)/ and $Win32::API::Type::PackSize{$type} < $align) { + DEBUG "(PM)Struct::getUnpack %s(%d) < %d\n", + $type, $Win32::API::Type::PackSize{$type}, $align + ; + $packing .= ("x" x ($align - $Win32::API::Type::PackSize{$type})); + } + + push(@items, $name); + } + } + DEBUG "(PM)Struct::getUnpack($self->{__typedef__}): unpack($packing, @items)\n"; + return($packing, @items); +} + +sub Unpack { + my $self = shift; + my($packing, @items) = $self->getUnpack(); + my @itemvalue = unpack($packing, $self->{buffer}); + DEBUG "(PM)Struct::Unpack: unpack($packing, buffer) = @itemvalue\n"; + foreach my $i (0..$#items) { + my $recipient = $self->{buffer_recipients}->[$i]; + DEBUG "(PM)Struct::Unpack: %s(%s) = '%s' (0x%08x)\n", + $recipient->{__typedef__}, + $items[$i], + $itemvalue[$i], + $itemvalue[$i], + ; + $recipient->{$items[$i]} = $itemvalue[$i]; + DEBUG "(PM)Struct::Unpack: self.$items[$i] = $self->{$items[$i]}\n"; + } +} + +sub FromMemory { + my($self, $addr) = @_; + DEBUG "(PM)Struct::FromMemory: doing Pack\n"; + $self->Pack(); + DEBUG "(PM)Struct::FromMemory: doing GetMemory( 0x%08x, %d )\n", $addr, $self->sizeof; + $self->{buffer} = Win32::API::ReadMemory( $addr, $self->sizeof ); + $self->Unpack(); + DEBUG "(PM)Struct::FromMemory: doing Unpack\n"; + DEBUG "(PM)Struct::FromMemory: structure is now:\n"; + $self->Dump() if DEBUG; + DEBUG "\n"; +} + +sub Dump { + my $self = shift; + my $prefix = shift; + foreach my $member (@{ $self->{typedef} }) { + ($name, $packing, $type) = @$member; + if( ref($self->{$name}) ) { + $self->{$name}->Dump($name); + } else { + printf "%-20s %-20s %-20s\n", $prefix, $name, $self->{$name}; + } + } +} + + +sub is_known { + my $name = shift; + if(exists $Known{ $name }) { + return 1; + } else { + if($name =~ s/^LP//) { + return exists $Known{ $name }; + } + return 0; + } +} + +sub TIEHASH { + return Win32::API::Struct::new(@_); +} + +sub EXISTS { + +} + +sub FETCH { + my $self = shift; + my $key = shift; + + if($key eq 'sizeof') { + return $self->sizeof; + } + my @members = map { $_->[0] } @{ $self->{typedef} }; + if(grep(/^\Q$key\E$/, @members)) { + return $self->{$key}; + } else { + warn "'$key' is not a member of Win32::API::Struct $self->{__typedef__}"; + } +} + +sub STORE { + my $self = shift; + my($key, $val) = @_; + my @members = map { $_->[0] } @{ $self->{typedef} }; + if(grep(/^\Q$key\E$/, @members)) { + $self->{$key} = $val; + } else { + warn "'$key' is not a member of Win32::API::Struct $self->{__typedef__}"; + } +} + +sub FIRSTKEY { + my $self = shift; + my @members = map { $_->[0] } @{ $self->{typedef} }; + return $members[0]; +} + +sub NEXTKEY { + my $self = shift; + my $key = shift; + my @members = map { $_->[0] } @{ $self->{typedef} }; + for my $i (0..$#members-1) { + return $members[$i+1] if $members[$i] eq $key; + } + return undef; +} + +1; + +####################################################################### +# DOCUMENTATION +# + +=head1 NAME + +Win32::API::Struct - C struct support package for Win32::API + +=head1 SYNOPSIS + + use Win32::API; + + Win32::API::Struct->typedef( 'POINT', qw( + LONG x; + LONG y; + )); + + my $Point = Win32::API::Struct->new( 'POINT' ); + $Point->{x} = 1024; + $Point->{y} = 768; + + #### alternatively + + tie %Point, 'Win32::API::Struct', 'POINT'; + $Point{x} = 1024; + $Point{y} = 768; + + +=head1 ABSTRACT + +This module enables you to define C structs for use with +Win32::API. + +See L<Win32::API> for more info about its usage. + +=head1 DESCRIPTION + +This module is automatically imported by Win32::API, so you don't +need to 'use' it explicitly. The main methods are C<typedef> and +C<new>, which are documented below. + +=over 4 + +=item C<typedef NAME, TYPE, MEMBER, TYPE, MEMBER, ...> + +This method defines a structure named C<NAME>. The definition consists +of types and member names, just like in C. In fact, most of the +times you can cut the C definition for a structure and paste it +verbatim to your script, enclosing it in a C<qw()> block. The +function takes care of removing the semicolon after the member +name. + +The synopsis example could be written like this: + + Win32::API::Struct->typedef('POINT', 'LONG', 'x', 'LONG', 'y'); + +But it could also be written like this (note the indirect object +syntax), which is pretty cool: + + typedef Win32::API::Struct POINT => qw{ + LONG x; + LONG y; + }; + +Also note that C<typedef> automatically defines an 'LPNAME' type, +which holds a pointer to your structure. In the example above, +'LPPOINT' is also defined and can be used in a call to a +Win32::API (in fact, this is what you're really going to use when +doing API calls). + +=item C<new NAME> + +This creates a structure (a Win32::API::Struct object) of the +type C<NAME> (it must have been defined with C<typedef>). In Perl, +when you create a structure, all the members are undefined. But +when you use that structure in C (eg. a Win32::API call), you +can safely assume that they will be treated as zero (or NULL). + +=item C<sizeof> + +This returns the size, in bytes, of the structure. Acts just like +the C function of the same name. It is particularly useful for +structures that need a member to be initialized to the structure's +own size. + +=item C<align [SIZE]> + +Sets or returns the structure alignment (eg. how the structure is +stored in memory). This is a very advanced option, and you normally +don't need to mess with it. +All structures in the Win32 Platform SDK should work without it. +But if you define your own structure, you may need to give it an +explicit alignment. In most cases, passing a C<SIZE> of 'auto' +should keep the world happy. + +=back + +=head2 THE C<tie> INTERFACE + +Instead of creating an object with the C<new> method, you can +tie a hash, which will hold the desired structure, using the +C<tie> builtin function: + + tie %structure, Win32::API::Struct => 'NAME'; + +The differences between the tied and non-tied approaches are: + +=over 4 + +=item * +with tied structures, you can access members directly as +hash lookups, eg. + + # tied # non-tied + $Point{x} vs. $Point->{x} + +=item * +with tied structures, when you try to fetch or store a +member that is not part of the structure, it will result +in a warning, eg. + + print $Point{z}; + # this will warn: 'z' is not a member of Win32::API::Struct POINT + +=item * +when you pass a tied structure as a Win32::API parameter, +remember to backslash it, eg. + + # tied # non-tied + GetCursorPos( \%Point ) vs. GetCursorPos( $Point ) + +=back + +=head1 AUTHOR + +Aldo Calpini ( I<dada@perl.it> ). + +=head1 MAINTAINER + +Cosimo Streppone ( I<cosimo@cpan.org> ). + +=cut diff --git a/Master/tlpkg/tlperl/lib/Win32/API/Test.pm b/Master/tlpkg/tlperl/lib/Win32/API/Test.pm new file mode 100755 index 00000000000..0b21ced6927 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Win32/API/Test.pm @@ -0,0 +1,111 @@ +# +# Win32::API::Test - Test helper package for Win32::API +# +# Cosimo Streppone <cosimo@cpan.org> +# +# $Id: Test.pm 438 2008-10-02 22:51:55Z cosimo.streppone $ + +package Win32::API::Test; + +sub compiler_name () { + use Config; + my $cc = $Config{ccname}; + if($cc eq 'cl' || $cc eq 'cl.exe') + { + $cc = 'cl'; + } + return($cc); +} + +sub compiler_version () { + use Config; + my $ver = $Config{ccversion} || 0; + if( $ver =~ /^(\d+\.\d+)/ ) + { + $ver = 0 + $1; + } + return($ver); +} + +# +# Run the compiler and get version from there... +# User might be running a compiler different from +# that used to build perl. +# For example, Cosimo does. For testing, of course. +# +sub compiler_version_from_shell () { + my $cc = compiler_name(); + my $ver; + # MSVC + if($cc eq 'cl') + { + my @ver = `$cc 2>&1`; # Interesting output in STDERR + $ver = join('',@ver); + #print 'VER:'.$ver.':'."\n"; + if($ver =~ /Version (\d[\d\.]+)/ms ) + { + $ver = $1; + } + } + # GCC + elsif($cc eq 'cc' || $cc eq 'gcc' || $cc eq 'winegcc' ) + { + $ver = join('', `$cc --version`); + if($ver =~ /gcc.*(\d[\d+]+)/ms ) + { + $ver = $1; + } + } + # Borland C + elsif($cc eq 'bcc32' || $cc eq 'bcc') + { + $ver = join('', `$cc 2>&1`); + if($ver =~ /Borland C\+\+ (\d[\d\.]+)/ms ) + { + $ver = $1; + } + } + return($ver); +} + +sub find_test_dll () { + require File::Spec; + my $dll_name = $_[0]; + my @paths = qw(.. ../t ../t/dll . ./dll ./t/dll); + while(my $path = shift @paths) + { + $dll = File::Spec->catfile($path, $dll_name); + return $dll if -s $dll; + } + return(undef); +} + +1; + +__END__ + + +####################################################################### +# DOCUMENTATION +# + +=head1 NAME + +Win32::API::Test - Test helper package for Win32::API + +=head1 SYNOPSIS + + my $test_dll = Win32::API::Test::find_test_dll('API_test.dll'); + +Check the t/*.t test scripts for more details. + +=head1 DESCRIPTION + +Simple package to hold Win32::API test suite helper functions. +No more, no less. + +=head1 AUTHOR + +Cosimo Streppone ( I<cosimo@cpan.org> ) + +=cut diff --git a/Master/tlpkg/tlperl/lib/Win32/API/Type.pm b/Master/tlpkg/tlperl/lib/Win32/API/Type.pm new file mode 100755 index 00000000000..48f0ce1a32f --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Win32/API/Type.pm @@ -0,0 +1,453 @@ +package Win32::API::Type; + +# See the bottom of this file for the POD documentation. Search for the +# string '=head'. + +####################################################################### +# +# Win32::API::Type - Perl Win32 API type definitions +# +# Author: Aldo Calpini <dada@perl.it> +# Maintainer: Cosimo Streppone <cosimo@cpan.org> +# +# $Id: Type.pm 458 2009-01-17 17:27:43Z cosimo.streppone $ +# +####################################################################### + +$VERSION = '0.59'; + +use Carp; + +require Exporter; # to export the constants to the main:: space +require DynaLoader; # to dynuhlode the module. +@ISA = qw( Exporter DynaLoader ); + +use vars qw( %Known %PackSize %Modifier %Pointer ); + +sub DEBUG { + if ($Win32::API::DEBUG) { + printf @_ if @_ or return 1; + } else { + return 0; + } +} + +%Known = (); +%PackSize = (); +%Modifier = (); +%Pointer = (); + +# Initialize data structures at startup. +# Aldo wants to keep the <DATA> approach. +# +my $section = 'nothing'; +foreach (<DATA>) { + next if /^\s*#/ or /^\s*$/; + chomp; + if( /\[(.+)\]/) { + $section = $1; + next; + } + if($section eq 'TYPE') { + my($name, $packing) = split(/\s+/); + # DEBUG "(PM)Type::INIT: Known('$name') => '$packing'\n"; + $Known{$name} = $packing; + } elsif($section eq 'PACKSIZE') { + my($packing, $size) = split(/\s+/); + # DEBUG "(PM)Type::INIT: PackSize('$packing') => '$size'\n"; + $PackSize{$packing} = $size; + } elsif($section eq 'MODIFIER') { + my($modifier, $mapto) = split(/\s+/, $_, 2); + my %maps = (); + foreach my $item (split(/\s+/, $mapto)) { + my($k, $v) = split(/=/, $item); + $maps{$k} = $v; + } + # DEBUG "(PM)Type::INIT: Modifier('$modifier') => '%maps'\n"; + $Modifier{$modifier} = { %maps }; + } elsif($section eq 'POINTER') { + my($pointer, $pointto) = split(/\s+/); + # DEBUG "(PM)Type::INIT: Pointer('$pointer') => '$pointto'\n"; + $Pointer{$pointer} = $pointto; + } +} +close(DATA); + +sub new { + my $class = shift; + my($type) = @_; + my $packing = packing($type); + my $size = sizeof($type); + my $self = { + type => $type, + packing => $packing, + size => $size, + }; + return bless $self; +} + +sub typedef { + my $class = shift; + my($name, $type) = @_; + my $packing = packing($type, $name); + DEBUG "(PM)Type::typedef: packing='$packing'\n"; + my $size = sizeof($type); + $Known{$name} = $packing; + return 1; +} + + +sub is_known { + my $self = shift; + my $type = shift; + $type = $self unless defined $type; + if(ref($type) =~ /Win32::API::Type/) { + return 1; + } else { + return defined packing($type); + } +} + +sub sizeof { + my $self = shift; + my $type = shift; + $type = $self unless defined $type; + if(ref($type) =~ /Win32::API::Type/) { + return $self->{size}; + } else { + my $packing = packing($type); + if($packing =~ /(\w)\*(\d+)/) { + return $PackSize{ $1 } * $2; + } else { + return $PackSize{ $packing }; + } + } +} + +sub packing { + # DEBUG "(PM)Type::packing: called by ". join("::", (caller(1))[0,3]). "\n"; + my $self = shift; + my $is_pointer = 0; + if(ref($self) =~ /Win32::API::Type/) { + # DEBUG "(PM)Type::packing: got an object\n"; + return $self->{packing}; + } + my $type = ($self eq 'Win32::API::Type') ? shift : $self; + my $name = shift; + + # DEBUG "(PM)Type::packing: got '$type', '$name'\n"; + my($modifier, $size, $packing); + if(exists $Pointer{$type}) { + # DEBUG "(PM)Type::packing: got '$type', is really '$Pointer{$type}'\n"; + $type = $Pointer{$type}; + $is_pointer = 1; + } elsif($type =~ /(\w+)\s+(\w+)/) { + $modifier = $1; + $type = $2; + # DEBUG "(PM)packing: got modifier '$modifier', type '$type'\n"; + } + + $type =~ s/\*$//; + + if(exists $Known{$type}) { + if(defined $name and $name =~ s/\[(.*)\]$//) { + $size = $1; + $packing = $Known{$type}[0]."*".$size; + # DEBUG "(PM)Type::packing: composite packing: '$packing' '$size'\n"; + } else { + $packing = $Known{$type}; + if($is_pointer and $packing eq 'c') { + $packing = "p"; + } + # DEBUG "(PM)Type::packing: simple packing: '$packing'\n"; + } + if(defined $modifier and exists $Modifier{$modifier}->{$type}) { + # DEBUG "(PM)Type::packing: applying modifier '$modifier' -> '$Modifier{$modifier}->{$type}'\n"; + $packing = $Modifier{$modifier}->{$type}; + } + return $packing; + } else { + # DEBUG "(PM)Type::packing: NOT FOUND\n"; + return undef; + } +} + + +sub is_pointer { + my $self = shift; + my $type = shift; + $type = $self unless defined $type; + if(ref($type) =~ /Win32::API::Type/) { + return 1; + } else { + if($type =~ /\*$/) { + return 1; + } else { + return exists $Pointer{$type}; + } + } +} + +sub Pack { + my ($type, $arg) = @_; + + my $pack_type = packing($type); + + if($pack_type eq 'p') { + $pack_type = 'Z*'; + } + + $arg = pack($pack_type, $arg); + + return $arg; +} + +sub Unpack { + my ($type, $arg) = @_; + + my $pack_type = packing($type); + + if($pack_type eq 'p') { + DEBUG "(PM)Type::Unpack: got packing 'p': is a pointer\n"; + $pack_type = 'Z*'; + } + + DEBUG "(PM)Type::Unpack: unpacking '$pack_type' '$arg'\n"; + $arg = unpack($pack_type, $arg); + DEBUG "(PM)Type::Unpack: returning '" . ($arg || '') . "'\n"; + return $arg; +} + +1; + +####################################################################### +# DOCUMENTATION +# + +=head1 NAME + +Win32::API::Type - C type support package for Win32::API + +=head1 SYNOPSIS + + use Win32::API; + + Win32::API::Type->typedef( 'my_number', 'LONG' ); + + +=head1 ABSTRACT + +This module is a support package for Win32::API that implements +C types for the import with prototype functionality. + +See L<Win32::API> for more info about its usage. + +=head1 DESCRIPTION + +This module is automatically imported by Win32::API, so you don't +need to 'use' it explicitly. These are the methods of this package: + +=over 4 + +=item C<typedef NAME, TYPE> + +This method defines a new type named C<NAME>. This actually just +creates an alias for the already-defined type C<TYPE>, which you +can use as a parameter in a Win32::API call. + +=item C<sizeof TYPE> + +This returns the size, in bytes, of C<TYPE>. Acts just like +the C function of the same name. + +=item C<is_known TYPE> + +Returns true if C<TYPE> is known by Win32::API::Type, false +otherwise. + +=back + +=head2 SUPPORTED TYPES + +This module should recognize all the types defined in the +Win32 Platform SDK header files. +Please see the source for this module, in the C<__DATA__> section, +for the full list. + +=head1 AUTHOR + +Aldo Calpini ( I<dada@perl.it> ). + +=head1 MAINTAINER + +Cosimo Streppone ( I<cosimo@cpan.org> ). + +=cut + + +__DATA__ + +[TYPE] +ATOM s +BOOL L +BOOLEAN c +BYTE C +CHAR c +COLORREF L +DWORD L +DWORD32 L +DWORD64 Q +FLOAT f +HACCEL L +HANDLE L +HBITMAP L +HBRUSH L +HCOLORSPACE L +HCONV L +HCONVLIST L +HCURSOR L +HDC L +HDDEDATA L +HDESK L +HDROP L +HDWP L +HENHMETAFILE L +HFILE L +HFONT L +HGDIOBJ L +HGLOBAL L +HHOOK L +HICON L +HIMC L +HINSTANCE L +HKEY L +HKL L +HLOCAL L +HMENU L +HMETAFILE L +HMODULE L +HPALETTE L +HPEN L +HRGN L +HRSRC L +HSZ L +HWINSTA L +HWND L +INT i +INT32 i +INT64 q +LANGID s +LCID L +LCSCSTYPE L +LCSGAMUTMATCH L +LCTYPE L +LONG l +LONG32 l +LONG64 q +LONGLONG q +LPARAM L +LRESULT L +REGSAM L +SC_HANDLE L +SC_LOCK L +SERVICE_STATUS_HANDLE L +SHORT s +SIZE_T L +SSIZE_T L +TBYTE c +TCHAR C +UCHAR C +UINT I +UINT_PTR L +UINT32 I +UINT64 Q +ULONG L +ULONG32 L +ULONG64 Q +ULONGLONG Q +USHORT S +WCHAR S +WORD S +WPARAM L +VOID c + +int i +long l +float f +double d +char c + +#CRITICAL_SECTION 24 -- a structure +#LUID ? 8 -- a structure +#VOID 0 +#CONST 4 +#FILE_SEGMENT_ELEMENT 8 -- a structure + +[PACKSIZE] +c 1 +C 1 +d 8 +f 4 +i 4 +I 4 +l 4 +L 4 +q 8 +Q 8 +s 2 +S 2 +p 4 + +[MODIFIER] +unsigned int=I long=L short=S char=C + +[POINTER] +INT_PTR INT +LPBOOL BOOL +LPBYTE BYTE +LPCOLORREF COLORREF +LPCSTR CHAR +#LPCTSTR CHAR or WCHAR +LPCTSTR CHAR +LPCVOID any +LPCWSTR WCHAR +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 diff --git a/Master/tlpkg/tlperl/lib/Win32/DBIODBC.pm b/Master/tlpkg/tlperl/lib/Win32/DBIODBC.pm new file mode 100755 index 00000000000..e3262c09d99 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Win32/DBIODBC.pm @@ -0,0 +1,248 @@ +package # hide this package from CPAN indexer + Win32::ODBC; + +#use strict; + +use DBI; + +# once we've been loaded we don't want perl to load the real Win32::ODBC +$INC{'Win32/ODBC.pm'} = $INC{'Win32/DBIODBC.pm'} || 1; + +#my $db = new Win32::ODBC("DSN=$self->{'DSN'};UID=$self->{'UID'};PWD=$self->{'PWD'};"); + +#EMU --- my $db = new Win32::ODBC("DSN=$DSN;UID=$login;PWD=$password;"); +sub new +{ + shift; + my $connect_line= shift; + +# [R] self-hack to allow empty UID and PWD + my $temp_connect_line; + $connect_line=~/DSN=\w+/; + $temp_connect_line="$&;"; + if ($connect_line=~/UID=\w?/) + {$temp_connect_line.="$&;";} + else {$temp_connect_line.="UID=;";}; + if ($connect_line=~/PWD=\w?/) + {$temp_connect_line.="$&;";} + else {$temp_connect_line.="PWD=;";}; + $connect_line=$temp_connect_line; +# -[R]- + + my $self= {}; + + + $_=$connect_line; + /^(DSN=)(.*)(;UID=)(.*)(;PWD=)(.*)(;)$/; + + #---- DBI CONNECTION VARIABLES + + $self->{ODBC_DSN}=$2; + $self->{ODBC_UID}=$4; + $self->{ODBC_PWD}=$6; + + + #---- DBI CONNECTION VARIABLES + $self->{DBI_DBNAME}=$self->{ODBC_DSN}; + $self->{DBI_USER}=$self->{ODBC_UID}; + $self->{DBI_PASSWORD}=$self->{ODBC_PWD}; + $self->{DBI_DBD}='ODBC'; + + #---- DBI CONNECTION + $self->{'DBI_DBH'}=DBI->connect($self->{'DBI_DBNAME'}, + $self->{'DBI_USER'},$self->{'DBI_PASSWORD'},$self->{'DBI_DBD'}); + + warn "Error($DBI::err) : $DBI::errstr\n" if ! $self->{'DBI_DBH'}; + + + #---- RETURN + + bless $self; +} + + +#EMU --- $db->Sql('SELECT * FROM DUAL'); +sub Sql +{ + my $self= shift; + my $SQL_statment=shift; + + # print " SQL : $SQL_statment \n"; + + $self->{'DBI_SQL_STATMENT'}=$SQL_statment; + + my $dbh=$self->{'DBI_DBH'}; + + # print " DBH : $dbh \n"; + + my $sth=$dbh->prepare("$SQL_statment"); + + # print " STH : $sth \n"; + + $self->{'DBI_STH'}=$sth; + + if ($sth) + { + $sth->execute(); + } + + #--- GET ERROR MESSAGES + $self->{DBI_ERR}=$DBI::err; + $self->{DBI_ERRSTR}=$DBI::errstr; + + if ($sth) + { + #--- GET COLUMNS NAMES + $self->{'DBI_NAME'} = $sth->{NAME}; + } + +# [R] provide compatibility with Win32::ODBC's way of identifying erraneous SQL statements + return ($self->{'DBI_ERR'})?1:undef; +# -[R]- +} + + +#EMU --- $db->FetchRow()) +sub FetchRow +{ + my $self= shift; + + my $sth=$self->{'DBI_STH'}; + if ($sth) + { + my @row=$sth->fetchrow_array; + $self->{'DBI_ROW'}=\@row; + + if (scalar(@row)>0) + { + #-- the row of result is not nul + #-- return somthing nothing will be return else + return 1; + } + } + return undef; +} + +# [R] provide compatibility with Win32::ODBC's Data() method. +sub Data +{ + my $self=shift; + my @array=@{$self->{'DBI_ROW'}}; + foreach my $element (@array) + { + # remove padding of spaces by DBI + $element=~s/(\s*$)//; + }; + return (wantarray())?@array:join('', @array); +}; +# -[R]- + +#EMU --- %record = $db->DataHash; +sub DataHash +{ + my $self= shift; + + my $p_name=$self->{'DBI_NAME'}; + my $p_row=$self->{'DBI_ROW'}; + + my @name=@$p_name; + my @row=@$p_row; + + my %DataHash; +#print @name; print "\n"; print @row; +# [R] new code that seems to work consistent with Win32::ODBC + while (@name) + { + my $name=shift(@name); + my $value=shift(@row); + + # remove padding of spaces by DBI + $name=~s/(\s*$)//; + $value=~s/(\s*$)//; + + $DataHash{$name}=$value; + }; +# -[R]- + +# [R] old code that didn't appear to work +# foreach my $name (@name) +# { +# $name=~s/(^\s*)|(\s*$)//; +# my @arr=@$name; +# foreach (@arr) +# { +# print "lot $name name col $_ or ROW= 0 $row[0] 1 $row[1] 2 $row[2] \n "; +# $DataHash{$name}=shift(@row); +# } +# } +# -[R]- + + #--- Return Hash + return %DataHash; +} + + +#EMU --- $db->Error() +sub Error +{ + my $self= shift; + + if ($self->{'DBI_ERR'} ne '') + { + #--- Return error message + $self->{'DBI_ERRSTR'}; + } + + #-- else good no error message + +} + +# [R] provide compatibility with Win32::ODBC's Close() method. +sub Close +{ + my $self=shift; + + my $dbh=$self->{'DBI_DBH'}; + $dbh->disconnect; +} +# -[R]- + +1; + +__END__ + +# [R] to -[R]- indicate sections edited by me, Roy Lee + +=head1 NAME + +Win32::DBIODBC - Win32::ODBC emulation layer for the DBI + +=head1 SYNOPSIS + + use Win32::DBIODBC; # instead of use Win32::ODBC + +=head1 DESCRIPTION + +This is a I<very> basic I<very> alpha quality Win32::ODBC emulation +for the DBI. To use it just replace + + use Win32::ODBC; + +in your scripts with + + use Win32::DBIODBC; + +or, while experimenting, you can pre-load this module without changing your +scripts by doing + + perl -MWin32::DBIODBC your_script_name + +=head1 TO DO + +Error handling is virtually non-existant. + +=head1 AUTHOR + +Tom Horen <tho@melexis.com> + +=cut diff --git a/Master/tlpkg/tlperl/lib/Win32/EventLog.pm b/Master/tlpkg/tlperl/lib/Win32/EventLog.pm new file mode 100755 index 00000000000..bf840723a6a --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Win32/EventLog.pm @@ -0,0 +1,471 @@ +# +# EventLog.pm +# +# Creates an object oriented interface to the Windows NT Evenlog +# Written by Jesse Dougherty +# + +package Win32::EventLog; + +use strict; +use vars qw($VERSION $AUTOLOAD @ISA @EXPORT $GetMessageText); +$VERSION = '0.076'; + +require Exporter; +require DynaLoader; + +die "The Win32::Eventlog module works only on Windows NT" + unless Win32::IsWinNT(); + +@ISA= qw(Exporter DynaLoader); +@EXPORT = qw( + EVENTLOG_AUDIT_FAILURE + EVENTLOG_AUDIT_SUCCESS + EVENTLOG_BACKWARDS_READ + EVENTLOG_END_ALL_PAIRED_EVENTS + EVENTLOG_END_PAIRED_EVENT + EVENTLOG_ERROR_TYPE + EVENTLOG_FORWARDS_READ + EVENTLOG_INFORMATION_TYPE + EVENTLOG_PAIRED_EVENT_ACTIVE + EVENTLOG_PAIRED_EVENT_INACTIVE + EVENTLOG_SEEK_READ + EVENTLOG_SEQUENTIAL_READ + EVENTLOG_START_PAIRED_EVENT + EVENTLOG_SUCCESS + EVENTLOG_WARNING_TYPE +); + +$GetMessageText=0; + +sub AUTOLOAD { + my($constname); + ($constname = $AUTOLOAD) =~ s/.*:://; + # reset $! to zero to reset any current errors. + local $! = 0; + my $val = constant($constname, @_ ? $_[0] : 0); + if ($!) { + if ($! =~ /Invalid/) { + $AutoLoader::AUTOLOAD = $AUTOLOAD; + goto &AutoLoader::AUTOLOAD; + } + else { + my ($pack,$file,$line) = caller; + die "Unknown Win32::EventLog macro $constname, at $file line $line.\n"; + } + } + eval "sub $AUTOLOAD { $val }"; + goto &$AUTOLOAD; +} + +# +# new() +# +# Win32::EventLog->new("source name", "ServerName"); +# +sub new { + die "usage: PACKAGE->new(SOURCENAME[, SERVERNAME])\n" unless @_ > 1; + my ($class,$source,$server) = @_; + my $handle; + + # Create new handle + if ($source !~ /\\/) { + OpenEventLog($handle, $server, $source); + } + else { + OpenBackupEventLog($handle, $server, $source); + } + return bless {handle => $handle, + Source => $source, + Computer => $server} => $class; +} + +sub DESTROY {shift->Close} + +# +# Open (the rather braindead old way) +# A variable initialized to empty must be supplied as the first +# arg, followed by whatever new() takes +# +sub Open { + $_[0] = Win32::EventLog->new($_[1],$_[2]); +} + +sub OpenBackup { + my ($class,$source,$server) = @_; + OpenBackupEventLog(my $handle, $server, $source); + return bless {handle => $handle, + Source => $source, + Computer => $server} => $class; +} + +sub Backup { + die " usage: OBJECT->Backup(FILENAME)\n" unless @_ == 2; + my ($self,$file) = @_; + return BackupEventLog($self->{handle}, $file); +} + +sub Close { + my $self = shift; + CloseEventLog($self->{handle}); + $self->{handle} = 0; +} + +# Read +# Note: the EventInfo arguement requires a hash reference. +sub Read { + my $self = shift; + + die "usage: OBJECT->Read(FLAGS, RECORDOFFSET, HASHREF)\n" unless @_ == 3; + + my ($readflags,$recordoffset) = @_; + # The following is stolen shamelessly from Wyt's tests for the registry. + my $result = ReadEventLog($self->{handle}, $readflags, $recordoffset, + my $header, my $source, my $computer, my $sid, + my $data, my $strings); + my ($length, + $reserved, + $recordnumber, + $timegenerated, + $timewritten, + $eventid, + $eventtype, + $numstrings, + $eventcategory, + $reservedflags, + $closingrecordnumber, + $stringoffset, + $usersidlength, + $usersidoffset, + $datalength, + $dataoffset) = unpack('l6s4l6', $header); + + # make a hash out of the values returned from ReadEventLog. + my %h = ( Source => $source, + Computer => $computer, + Length => $datalength, + Category => $eventcategory, + RecordNumber => $recordnumber, + TimeGenerated => $timegenerated, + Timewritten => $timewritten, + EventID => $eventid, + EventType => $eventtype, + ClosingRecordNumber => $closingrecordnumber, + User => $sid, + Strings => $strings, + Data => $data, + ); + + # get the text message here + if ($result and $GetMessageText) { + GetEventLogText($source, $eventid, $strings, $numstrings, my $message); + $h{Message} = $message; + } + + if (ref($_[2]) eq 'HASH') { + %{$_[2]} = %h; # this needed for Read(...,\%foo) case + } + else { + $_[2] = \%h; + } + return $result; +} + +sub GetMessageText { + my $self = shift; + local $^W; + GetEventLogText($self->{Source}, + $self->{EventID}, + $self->{Strings}, + $self->{Strings} =~ tr/\0/\0/, + my $message); + + $self->{Message} = $message; + return $message; +} + +sub Report { + die "usage: OBJECT->Report( HASHREF )\n" unless @_ == 2; + my ($self,$EventInfo) = @_; + + die "Win32::EventLog::Report requires a hash reference as arg 2\n" + unless ref($EventInfo) eq "HASH"; + + my $computer = $EventInfo->{Computer} ? $EventInfo->{Computer} + : $self->{Computer}; + my $source = exists($EventInfo->{Source}) ? $EventInfo->{Source} + : $self->{Source}; + + return WriteEventLog($computer, $source, $EventInfo->{EventType}, + $EventInfo->{Category}, $EventInfo->{EventID}, 0, + $EventInfo->{Data}, split(/\0/, $EventInfo->{Strings})); + +} + +sub GetOldest { + my $self = shift; + die "usage: OBJECT->GetOldest( SCALAREF )\n" unless @_ == 1; + return GetOldestEventLogRecord($self->{handle},$_[0]); +} + +sub GetNumber { + my $self = shift; + die "usage: OBJECT->GetNumber( SCALARREF )\n" unless @_ == 1; + return GetNumberOfEventLogRecords($self->{handle}, $_[0]); +} + +sub Clear { + my ($self,$file) = @_; + die "usage: OBJECT->Clear( FILENAME )\n" unless @_ == 2; + return ClearEventLog($self->{handle}, $file); +} + +bootstrap Win32::EventLog; + +1; +__END__ + +=head1 NAME + +Win32::EventLog - Process Win32 Event Logs from Perl + +=head1 SYNOPSIS + + use Win32::EventLog + $handle=Win32::EventLog->new("Application"); + +=head1 DESCRIPTION + +This module implements most of the functionality available from the +Win32 API for accessing and manipulating Win32 Event Logs. The access +to the EventLog routines is divided into those that relate to an +EventLog object and its associated methods and those that relate other +EventLog tasks (like adding an EventLog record). + +=head1 The EventLog Object and its Methods + +The following methods are available to open, read, close and backup +EventLogs. + +=over 4 + +=item Win32::EventLog->new(SOURCENAME [,SERVERNAME]); + +The new() method creates a new EventLog object and returns a handle +to it. This hande is then used to call the methods below. + +The method is overloaded in that if the supplied SOURCENAME +argument contains one or more literal '\' characters (an illegal +character in a SOURCENAME), it assumes that you are trying to open +a backup eventlog and uses SOURCENAME as the backup eventlog to +open. Note that when opening a backup eventlog, the SERVERNAME +argument is ignored (as it is in the underlying Win32 API). For +EventLogs on remote machines, the SOURCENAME parameter must +therefore be specified as a UNC path. + +=item $handle->Backup(FILENAME); + +The Backup() method backs up the EventLog represented by $handle. It +takes a single arguemt, FILENAME. When $handle represents an +EventLog on a remote machine, FILENAME is filename on the remote +machine and cannot be a UNC path (i.e you must use F<C:\TEMP\App.EVT>). +The method will fail if the log file already exists. + +=item $handle->Read(FLAGS, OFFSET, HASHREF); + +The Read() method read an EventLog entry from the EventLog represented +by $handle. + +=item $handle->Close(); + +The Close() method closes the EventLog represented by $handle. After +Close() has been called, any further attempt to use the EventLog +represented by $handle will fail. + +=item $handle->GetOldest(SCALARREF); + +The GetOldest() method number of the the oldest EventLog record in +the EventLog represented by $handle. This is required to correctly +compute the OFFSET required by the Read() method. + +=item $handle->GetNumber(SCALARREF); + +The GetNumber() method returns the number of EventLog records in +the EventLog represented by $handle. The number of the most recent +record in the EventLog is therefore computed by + + $handle->GetOldest($oldest); + $handle->GetNumber($lastRec); + $lastRecOffset=$oldest+$lastRec; + +=item $handle->Clear(FILENAME); + +The Clear() method clears the EventLog represented by $handle. If +you provide a non-null FILENAME, the EventLog will be backed up +into FILENAME before the EventLog is cleared. The method will fail +if FILENAME is specified and the file refered to exists. Note also +that FILENAME specifies a file local to the machine on which the +EventLog resides and cannot be specified as a UNC name. + +=item $handle->Report(HASHREF); + +The Report() method generates an EventLog entry. The HASHREF should +contain the following keys: + +=over 4 + +=item C<Computer> + +The C<Computer> field specfies which computer you want the EventLog +entry recorded. If this key doesn't exist, the server name used to +create the $handle is used. + +=item C<Source> + +The C<Source> field specifies the source that generated the EventLog +entry. If this key doesn't exist, the source name used to create the +$handle is used. + +=item C<EventType> + +The C<EventType> field should be one of the constants + +=over 4 + +=item C<EVENTLOG_ERROR_TYPE> + +An Error event is being logged. + +=item C<EVENTLOG_WARNING_TYPE> + +A Warning event is being logged. + +=item C<EVENTLOG_INFORMATION_TYPE> + +An Information event is being logged. + +=item C<EVENTLOG_AUDIT_SUCCESS> + +A Success Audit event is being logged (typically in the Security +EventLog). + +=item C<EVENTLOG_AUDIT_FAILURE> + +A Failure Audit event is being logged (typically in the Security +EventLog). + +=back + +These constants are exported into the main namespace by default. + +=item C<Category> + +The C<Category> field can have any value you want. It is specific to +the particular Source. + +=item C<EventID> + +The C<EventID> field should contain the ID of the message that this +event pertains too. This assumes that you have an associated message +file (indirectly referenced by the field C<Source>). + +=item C<Data> + +The C<Data> field contains raw data associated with this event. + +=item C<Strings> + +The C<Strings> field contains the single string that itself contains +NUL terminated sub-strings. This are used with the EventID to generate +the message as seen from (for example) the Event Viewer application. + +=back + +=back + +=head1 Other Win32::EventLog functions. + +The following functions are part of the Win32::EventLog package but +are not callable from an EventLog object. + +=over 4 + +=item GetMessageText(HASHREF); + +The GetMessageText() function assumes that HASHREF was obtained by +a call to C<$handle-E<gt>Read()>. It returns the formatted string that +represents the fully resolved text of the EventLog message (such as +would be seen in the Windows NT Event Viewer). For convenience, the +key 'Message' in the supplied HASHREF is also set to the return value +of this function. + +If you set the variable $Win32::EventLog::GetMessageText to 1 then +each call to C<$handle-E<gt>Read()> will call this function automatically. + +=back + +=head1 Example 1 + +The following example illustrates the way in which the EventLog module +can be used. It opens the System EventLog and reads through it from +oldest to newest records. For each record from the B<Source> EventLog +it extracts the full text of the Entry and prints the EventLog message +text out. + + use Win32::EventLog; + + $handle=Win32::EventLog->new("System", $ENV{ComputerName}) + or die "Can't open Application EventLog\n"; + $handle->GetNumber($recs) + or die "Can't get number of EventLog records\n"; + $handle->GetOldest($base) + or die "Can't get number of oldest EventLog record\n"; + + while ($x < $recs) { + $handle->Read(EVENTLOG_FORWARDS_READ|EVENTLOG_SEEK_READ, + $base+$x, + $hashRef) + or die "Can't read EventLog entry #$x\n"; + if ($hashRef->{Source} eq "EventLog") { + Win32::EventLog::GetMessageText($hashRef); + print "Entry $x: $hashRef->{Message}\n"; + } + $x++; + } + +=head1 Example 2 + +To backup and clear the EventLogs on a remote machine, do the following :- + + use Win32::EventLog; + + $myServer="\\\\my-server"; # your servername here. + my($date)=join("-", ((split(/\s+/, scalar(localtime)))[0,1,2,4])); + my($dest); + + for my $eventLog ("Application", "System", "Security") { + $handle=Win32::EventLog->new($eventLog, $myServer) + or die "Can't open Application EventLog on $myServer\n"; + + $dest="C:\\BackupEventLogs\\$eventLog\\$date.evt"; + $handle->Backup($dest) + or warn "Could not backup and clear the $eventLog EventLog on $myServer ($^E)\n"; + + $handle->Close; + } + +Note that only the Clear method is required. Note also that if the +file $dest exists, the function will fail. + +=head1 BUGS + +None currently known. + +The test script for 'make test' should be re-written to use the +EventLog object. + +=head1 AUTHOR + +Original code by Jesse Dougherty for HiP Communications. Additional +fixes and updates attributed to Martin Pauley +<martin.pauley@ulsterbank.ltd.uk>) and Bret Giddings (bret@essex.ac.uk). diff --git a/Master/tlpkg/tlperl/lib/Win32/Exe.pm b/Master/tlpkg/tlperl/lib/Win32/Exe.pm new file mode 100755 index 00000000000..023946025c7 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Win32/Exe.pm @@ -0,0 +1,308 @@ +package Win32::Exe; +$Win32::Exe::VERSION = '0.11'; + +=head1 NAME + +Win32::Exe - Manipulate Win32 executable files + +=head1 VERSION + +This document describes version 0.10 of Win32::Exe, released +January 14, 2007. + +=head1 SYNOPSIS + + use Win32::Exe; + my $exe = Win32::Exe->new('c:/windows/notepad.exe'); + + # Get version information + print $exe->version_info->get('FileDescription'), ": ", + $exe->version_info->get('LegalCopyright'), "\n"; + + # Dump icons in an executable + foreach my $icon ($exe->icons) { + printf "Icon: %s x %s (%s colors)\n", + $icon->Width, $icon->Height, 2 ** $icon->BitCount; + } + + # Import icons from a .exe or .ico file and writes back the file + $exe->update( icon => '/c/windows/taskman.exe' ); + + # Change it to a console application, then save to another .exe + $exe->SetSubsystem('console'); + $exe->write('c:/windows/another.exe'); + + # Add a manifest section + $exe->update( manifest => $mymanifestxml ); + # or a default + $exe->update( defaultmanifest => 1 ); + + +=head1 DESCRIPTION + +This module parses and manipulating Win32 PE/COFF executable headers, +including version information, icons and other resources. + +More documentation will be provided in due time. For now, please look +at the test files in the source distributions F<t/> directory for examples +of using this module. + +=cut + +use strict; +use base 'Win32::Exe::Base'; +use constant FORMAT => ( + Magic => 'a2', # "MZ" + _ => 'a58', + PosPE => 'V', + _ => 'a{($PosPE > 64) ? $PosPE - 64 : "*"}', + PESig => 'a4', + Data => 'a*', +); +use constant DELEGATE_SUBS => ( + 'IconFile' => [ 'dump_iconfile', 'write_iconfile' ], +); +use constant DISPATCH_FIELD => 'PESig'; +use constant DISPATCH_TABLE => ( + "PE\0\0" => "PE", + '*' => sub { die "Incorrect PE header -- not a valid .exe file" }, +); +use constant DEBUG_INDEX => 6; +use constant DEBUG_ENTRY_SIZE => 28; + +use File::Basename (); +use Win32::Exe::IconFile; +use Win32::Exe::DebugTable; + +sub resource_section { + my ($self) = @_; + $self->first_member('Resources'); +} + +sub sections { + my ($self) = @_; + my $method = (wantarray ? 'members' : 'first_member'); + return $self->members('Section'); +} + +sub data_directories { + my ($self) = @_; + return $self->members('DataDirectory'); +} + +sub update_debug_directory { + my ($self, $boundary, $extra) = @_; + + $self->SetSymbolTable( $self->SymbolTable + $extra ) + if ($boundary <= $self->SymbolTable); + + my @dirs = $self->data_directories; + return if DEBUG_INDEX > $#dirs; + + my $dir = $dirs[DEBUG_INDEX] or return; + my $size = $dir->Size; + my $addr = $dir->VirtualAddress; + + return unless $size or $addr; + + my $count = $size / DEBUG_ENTRY_SIZE or return; + + (($size % DEBUG_ENTRY_SIZE) == 0) or return; + + foreach my $section ($self->sections) { + my $offset = $section->FileOffset; + my $f_size = $section->FileSize; + my $v_addr = $section->VirtualAddress; + + next unless $v_addr <= $addr; + next unless $addr < ($v_addr + $f_size); + next unless ($addr + $size) < ($v_addr + $f_size); + + $offset += $addr - $v_addr; + my $data = $self->substr($offset, $size); + + my $table = Win32::Exe::DebugTable->new(\$data); + + foreach my $dir ($table->members) { + next unless $boundary <= $dir->Offset; + + $dir->SetOffset($dir->Offset + $extra); + $dir->SetVirtualAddress($dir->VirtualAddress + $extra) + if $dir->VirtualAddress > 0; + } + + $self->substr($offset, $size, $table->dump); + last; + } +} + +sub default_info { + my $self = shift; + + my $filename = File::Basename::basename($self->filename); + + return join(';', + "CompanyName=", + "FileDescription=", + "FileVersion=0.0.0.0", + "InternalName=$filename", + "LegalCopyright=", + "LegalTrademarks=", + "OriginalFilename=$filename", + "ProductName=", + "ProductVersion=0.0.0.0", + ); +} + +sub update { + my ($self, %args) = @_; + + if ($args{defaultmanifest}) { + $self->add_default_manifest(); + } + + if (my $manifest = $args{manifest}) { + $self->set_manifest($manifest); + } + + if (my $icon = $args{icon}) { + my @icons = Win32::Exe::IconFile->new($icon)->icons; + $self->set_icons(\@icons) if @icons; + } + + if (my $info = $args{info}) { + my @info = ($self->default_info, @$info); + + my @pairs; + foreach my $pairs (map split(/\s*;\s*(?=[\w\\\/]+\s*=)/, $_), @info) { + my ($key, $val) = split(/\s*=\s*/, $pairs, 2); + next if $key =~ /language/i; + + if ($key =~ /^(product|file)version$/i) { + $key = "\u$1Version"; + $val =~ /^(?:\d+\.)+\d+$/ or die "$key cannot be '$val'"; + $val .= '.0' while $val =~ y/.,// < 3; + + push(@pairs, + [ $key => $val ], + [ "/StringFileInfo/#1/$key", $val ]); + } + else { + push(@pairs, [ $key => $val ]); + } + } + + $self->set_version_info(\@pairs) if @pairs; + } + + die "'gui' and 'console' cannot both be true" + if $args{gui} and $args{console}; + + $self->SetSubsystem("windows") if $args{gui}; + $self->SetSubsystem("console") if $args{console}; + $self->write; +} + +sub icons { + my ($self) = @_; + my $rsrc = $self->resource_section or return; + my @icons = map $_->members, $rsrc->objects('GroupIcon'); + wantarray ? @icons : \@icons; +} + +sub set_icons { + my ($self, $icons) = @_; + + my $rsrc = $self->resource_section; + my $name = eval { $rsrc->first_object('GroupIcon')->PathName } + || '/#RT_GROUP_ICON/#1/#0'; + + $rsrc->remove('/#RT_GROUP_ICON'); + $rsrc->remove('/#RT_ICON'); + + my $group = $self->require_class('Resource::GroupIcon')->new; + $group->SetPathName($name); + $group->set_parent($rsrc); + $rsrc->insert($group->PathName, $group); + + $group->set_icons($icons); + $group->refresh; +} + +sub version_info { + my ($self) = @_; + my $rsrc = $self->resource_section or return; + + # XXX - return a hash in list context? + + return $rsrc->first_object('Version'); +} + +sub set_version_info { + my ($self, $pairs) = @_; + my $rsrc = $self->resource_section or return; + my $version = $rsrc->first_object('Version'); + $version->set(@$_) for @$pairs; + $version->refresh; +} + +sub manifest { + my ($self) = @_; + my $rsrc = $self->resource_section or return; + if( my $obj = $rsrc->first_object('Manifest') ) { + return $obj; + } else { + return $self->require_class('Resource::Manifest')->new; + } +} + +sub set_manifest { + my ($self, $xml) = @_; + my $rsrc = $self->resource_section; + my $name = eval { $rsrc->first_object('Manifest')->PathName } || '/#RT_MANIFEST/#1/#0'; + $rsrc->remove( $name ); + my $manifest = $self->require_class('Resource::Manifest')->new; + $manifest->SetPathName( $name ); + $manifest->set_parent( $rsrc ); + $manifest->update_manifest( $xml ); + $rsrc->insert($manifest->PathName, $manifest); + $rsrc->refresh; +} + +sub add_default_manifest { + my ($self) = @_; + my $rsrc = $self->resource_section; + my $name = eval { $rsrc->first_object('Manifest')->PathName } || '/#RT_MANIFEST/#1/#0'; + $rsrc->remove( $name ); + my $manifest = $self->require_class('Resource::Manifest')->new; + my $xml = $manifest->default_manifest; + $manifest->SetPathName( $name ); + $manifest->set_parent( $rsrc ); + $manifest->update_manifest( $xml ); + $rsrc->insert($manifest->PathName, $manifest); + $rsrc->refresh; + $self->write; +} + +1; + +__END__ + +=head1 AUTHORS + +Audrey Tang E<lt>cpan@audreyt.orgE<gt> + +Mark Dootson + +Steffen Mueller E<lt>smueller@cpan.orgE<gt> + +=head1 COPYRIGHT + +Copyright 2004-2007 by Audrey Tang E<lt>cpan@audreyt.orgE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See L<http://www.perl.com/perl/misc/Artistic.html> + +=cut diff --git a/Master/tlpkg/tlperl/lib/Win32/Exe/Base.pm b/Master/tlpkg/tlperl/lib/Win32/Exe/Base.pm new file mode 100755 index 00000000000..a90ec19c451 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Win32/Exe/Base.pm @@ -0,0 +1,35 @@ +# $File: //local/member/autrijus/Win32-Exe/lib/Win32/Exe/Base.pm $ $Author: autrijus $ +# $Revision: #8 $ $Change: 1130 $ $Date: 2004-02-17T15:40:29.640821Z $ + +package Win32::Exe::Base; + +use strict; +use base 'Parse::Binary'; +use constant BASE_CLASS => 'Win32::Exe'; +use constant FORMAT => ( + Data => 'a', +); + +sub align { + my ($self, $value, $boundary) = @_; + my $n = ($value % $boundary) or return $value; + return($value + $boundary - $n); +} + +sub pad { + my ($self, $value, $bounary) = @_; + my $x = length($value) % $bounary or return ''; + return "\0" x ($bounary - $x); +} + +sub decode_ucs2 { + my ($self, $string) = @_; + return join('', map chr($_), unpack("v*", $string)); +} + +sub encode_ucs2 { + my ($self, $string) = @_; + return pack("v*", map ord($_), split(//, $string)); +} + +1; diff --git a/Master/tlpkg/tlperl/lib/Win32/Exe/DataDirectory.pm b/Master/tlpkg/tlperl/lib/Win32/Exe/DataDirectory.pm new file mode 100755 index 00000000000..e544ed372a3 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Win32/Exe/DataDirectory.pm @@ -0,0 +1,13 @@ +# $File: //local/member/autrijus/Win32-Exe/lib/Win32/Exe/DataDirectory.pm $ $Author: autrijus $ +# $Revision: #6 $ $Change: 1130 $ $Date: 2004-02-17T15:40:29.640821Z $ + +package Win32::Exe::DataDirectory; + +use strict; +use base 'Win32::Exe::Base'; +use constant FORMAT => ( + VirtualAddress => 'V', + Size => 'V', +); + +1; diff --git a/Master/tlpkg/tlperl/lib/Win32/Exe/DebugDirectory.pm b/Master/tlpkg/tlperl/lib/Win32/Exe/DebugDirectory.pm new file mode 100755 index 00000000000..f87cc0062be --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Win32/Exe/DebugDirectory.pm @@ -0,0 +1,19 @@ +# $File: //local/member/autrijus/Win32-Exe/lib/Win32/Exe/DebugDirectory.pm $ $Author: autrijus $ +# $Revision: #5 $ $Change: 1130 $ $Date: 2004-02-17T15:40:29.640821Z $ + +package Win32::Exe::DebugDirectory; + +use strict; +use base 'Win32::Exe::Base'; +use constant FORMAT => ( + Flags => 'V', + TimeStamp => 'V', + VersionMajor => 'v', + VersionMinor => 'v', + Type => 'V', + Size => 'V', + VirtualAddress => 'V', + Offset => 'V', +); + +1; diff --git a/Master/tlpkg/tlperl/lib/Win32/Exe/DebugTable.pm b/Master/tlpkg/tlperl/lib/Win32/Exe/DebugTable.pm new file mode 100755 index 00000000000..c861ee2397b --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Win32/Exe/DebugTable.pm @@ -0,0 +1,12 @@ +# $File: //local/member/autrijus/Win32-Exe/lib/Win32/Exe/DebugTable.pm $ $Author: autrijus $ +# $Revision: #6 $ $Change: 1130 $ $Date: 2004-02-17T15:40:29.640821Z $ + +package Win32::Exe::DebugTable; + +use strict; +use base 'Win32::Exe::Base'; +use constant FORMAT => ( + 'DebugDirectory' => [ 'a28', '*', 1 ], +); + +1; diff --git a/Master/tlpkg/tlperl/lib/Win32/Exe/IconFile.pm b/Master/tlpkg/tlperl/lib/Win32/Exe/IconFile.pm new file mode 100755 index 00000000000..8c24160951d --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Win32/Exe/IconFile.pm @@ -0,0 +1,60 @@ +# $File: //local/member/autrijus/Win32-Exe/lib/Win32/Exe/IconFile.pm $ $Author: autrijus $ +# $Revision: #9 $ $Change: 1130 $ $Date: 2004-02-17T15:40:29.640821Z $ + +package Win32::Exe::IconFile; + +use strict; +use base 'Win32::Exe::Base'; +use constant FORMAT => ( + Magic => 'a2', + Type => 'v', + Count => 'v', + 'Resource::Icon' => [ 'a16', '{$Count}', 1 ], + Data => 'a*', +); +use constant DEFAULT_ARGS => ( + Magic => "\0\0", + Type => 1, + Count => 0, + Data => '', +); +use constant DISPATCH_FIELD => 'Magic'; +use constant DISPATCH_TABLE => ( + "\0\0" => '', + "MZ" => '__BASE__', + '*' => sub { die "Invalid icon file header: $_[1]" }, +); + +sub icons { + my $self = shift; + $self->members(@_); +} + +sub set_icons { + my ($self, $icons) = @_; + $self->SetCount(scalar @$icons); + $self->set_members('Resource::Icon' => $icons); + $self->refresh; + + foreach my $idx (0 .. $#{$icons}) { + $self->icons->[$idx]->SetImageOffset(length($self->dump)); + $self->SetData( $self->Data . $icons->[$idx]->Data ); + } + + $self->refresh; +} + +sub dump_iconfile { + my $self = shift; + my @icons = $self->icons; + my $obj = $self->require_class('IconFile')->new; + $obj->set_icons(\@icons); + return $obj->dump; +} + +sub write_iconfile { + my ($self, $filename) = @_; + $self->write_file($filename, $self->dump_iconfile); +} + +1; diff --git a/Master/tlpkg/tlperl/lib/Win32/Exe/PE.pm b/Master/tlpkg/tlperl/lib/Win32/Exe/PE.pm new file mode 100755 index 00000000000..55251562786 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Win32/Exe/PE.pm @@ -0,0 +1,24 @@ +# $File: //local/member/autrijus/Win32-Exe/lib/Win32/Exe/PE.pm $ $Author: autrijus $ +# $Revision: #6 $ $Change: 1130 $ $Date: 2004-02-17T15:40:29.640821Z $ + +package Win32::Exe::PE; + +use strict; +use base 'Win32::Exe'; +use constant SUBFORMAT => ( + Machine => 'v', + NumSections => 'v', + TimeStamp => 'V', + SymbolTable => 'V', + _ => 'a4', + OptHeaderSize => 'v', + Characteristics => 'v', + Data => 'a*', +); +use constant DISPATCH_FIELD => 'OptHeaderSize'; +use constant DISPATCH_TABLE => ( + '0' => '', + '*' => 'PE::Header', +); + +1; diff --git a/Master/tlpkg/tlperl/lib/Win32/Exe/PE/Header.pm b/Master/tlpkg/tlperl/lib/Win32/Exe/PE/Header.pm new file mode 100755 index 00000000000..03888fedbd8 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Win32/Exe/PE/Header.pm @@ -0,0 +1,26 @@ +# $File: //local/member/autrijus/Win32-Exe/lib/Win32/Exe/PE/Header.pm $ $Author: autrijus $ +# $Revision: #5 $ $Change: 1130 $ $Date: 2004-02-17T15:40:29.640821Z $ + +package Win32::Exe::PE::Header; + +use strict; +use base 'Win32::Exe::PE'; +use constant SUBFORMAT => ( + Magic2 => 'v', + LMajor => 'C', + LMinor => 'C', + CodeSize => 'V', + IDataSize => 'V', + UDataSize => 'V', + EntryPointRVA => 'V', + BaseOfCode => 'V', + Data => 'a*', +); +use constant MEMBER_CLASS => 'Data'; +use constant DISPATCH_FIELD => 'Magic2'; +use constant DISPATCH_TABLE => ( + 0x20b => 'PE::Header::PE32Plus', + '*' => 'PE::Header::PE32', +); + +1; diff --git a/Master/tlpkg/tlperl/lib/Win32/Exe/PE/Header/PE32.pm b/Master/tlpkg/tlperl/lib/Win32/Exe/PE/Header/PE32.pm new file mode 100755 index 00000000000..ad8e641f40b --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Win32/Exe/PE/Header/PE32.pm @@ -0,0 +1,69 @@ +# $File: //local/member/autrijus/Win32-Exe/lib/Win32/Exe/PE/Header/PE32.pm $ $Author: autrijus $ +# $Revision: #8 $ $Change: 1130 $ $Date: 2004-02-17T15:40:29.640821Z $ + +package Win32::Exe::PE::Header::PE32; + +use strict; +use base 'Win32::Exe::PE::Header'; +use constant SUBFORMAT => ( + BaseOfData => 'V', + ImageBase => 'V', + SectionAlign => 'V', + FileAlign => 'V', + OSMajor => 'v', + OSMinor => 'v', + UserMajor => 'v', + UserMinor => 'v', + SubsysMajor => 'v', + SubsysMinor => 'v', + _ => 'a4', + ImageSize => 'V', + HeaderSize => 'V', + FileChecksum => 'V', + SubsystemTypeId => 'v', + DLLFlags => 'v', + StackReserve => 'V', + StackCommit => 'V', + HeapReserve => 'V', + HeapCommit => 'V', + LoaderFlags => 'V', + NumDataDirs => 'V', + 'DataDirectory' => [ + 'a8', '{$NumDataDirs}', 1 + ], + 'Section' => [ + 'a40', '{$NumSections}', 1 + ], + Data => 'a*', +); +use constant SUBSYSTEM_TYPES => [qw( + _ native windows console _ + _ _ posix _ windowsce +)]; +use constant ST_TO_ID => { + map { (SUBSYSTEM_TYPES->[$_] => $_) } (0 .. $#{+SUBSYSTEM_TYPES}) +}; +use constant ID_TO_ST => { reverse %{+ST_TO_ID} }; + +sub st_to_id { + my ($self, $name) = @_; + return $name unless $name =~ /\D/; + return(+ST_TO_ID->{lc($name)} || die "No such type: $name"); +} + +sub id_to_st { + my ($self, $id) = @_; + return(+ID_TO_ST->{$id} || $id); +} + +sub Subsystem { + my ($self) = @_; + return $self->id_to_st($self->SubsystemTypeId); +} + +sub SetSubsystem { + my ($self, $type) = @_; + $self->SetSubsystemTypeId($self->st_to_id($type)); +} + +1; diff --git a/Master/tlpkg/tlperl/lib/Win32/Exe/Resource.pm b/Master/tlpkg/tlperl/lib/Win32/Exe/Resource.pm new file mode 100755 index 00000000000..433be495ea6 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Win32/Exe/Resource.pm @@ -0,0 +1,38 @@ +# $File: //local/member/autrijus/Win32-Exe/lib/Win32/Exe/Resource.pm $ $Author: autrijus $ +# $Revision: #7 $ $Change: 1130 $ $Date: 2004-02-17T15:40:29.640821Z $ + +package Win32::Exe::Resource; + +use strict; +use base 'Win32::Exe::Base'; + +sub object { + my ($self) = @_; + return $self; +} + +sub path { + my ($self) = @_; + return $self->parent->path; +} + +sub CodePage { + return 1252; +} + +sub PathName { + my ($self) = @_; + return $self->{pathname} || $self->first_parent('ResourceEntry')->PathName; +} + +sub SetPathName { + my ($self, $value) = @_; + $self->{pathname} = $value; +} + +sub Data { + my ($self) = @_; + return $self->dump; +} + +1; diff --git a/Master/tlpkg/tlperl/lib/Win32/Exe/Resource/GroupIcon.pm b/Master/tlpkg/tlperl/lib/Win32/Exe/Resource/GroupIcon.pm new file mode 100755 index 00000000000..c2349ec7383 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Win32/Exe/Resource/GroupIcon.pm @@ -0,0 +1,57 @@ +# $File: //local/member/autrijus/Win32-Exe/lib/Win32/Exe/Resource/GroupIcon.pm $ $Author: autrijus $ +# $Revision: #5 $ $Change: 1130 $ $Date: 2004-02-17T15:40:29.640821Z $ + +package Win32::Exe::Resource::GroupIcon; + +use strict; +use base 'Win32::Exe::Resource'; +use constant FORMAT => ( + Magic => 'a2', + Type => 'v', + Count => 'v', + 'Resource::Icon' => [ 'a14', '{$Count}', 1 ], +); +use constant DEFAULT_ARGS => ( + Magic => "\0\0", + Type => 1, + Count => 0, +); +use constant DELEGATE_SUBS => ( + 'IconFile' => [ 'dump_iconfile', 'write_iconfile' ], +); + +sub icons { + my $self = shift; + $self->members(@_); +} + +sub set_icons { + my ($self, $icons) = @_; + + $self->SetCount(scalar @$icons); + $self->set_members('Resource::Icon' => $icons); + + my $rsrc = $self->first_parent('Resources') or return; + + foreach my $idx (0 .. $#{$icons}) { + my $icon = $self->icons->[$idx]; + $icon->SetId($idx+1); + $rsrc->insert($self->icon_name($icon->Id), $icons->[$idx]); + } +} + +sub substr { + my ($self, $id) = @_; + my $section = $self->first_parent('Resources'); + return $section->res_data($self->icon_name($id)); +} + +sub icon_name { + my ($self, $id) = @_; + my @icon_name = split("/", $self->PathName, -1); + $icon_name[1] = "#RT_ICON"; + $icon_name[2] = "#$id"; + return join("/", @icon_name); +} + +1; diff --git a/Master/tlpkg/tlperl/lib/Win32/Exe/Resource/Icon.pm b/Master/tlpkg/tlperl/lib/Win32/Exe/Resource/Icon.pm new file mode 100755 index 00000000000..a6b5348acbf --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Win32/Exe/Resource/Icon.pm @@ -0,0 +1,54 @@ +# $File: //local/member/autrijus/Win32-Exe/lib/Win32/Exe/Resource/Icon.pm $ $Author: autrijus $ +# $Revision: #6 $ $Change: 1130 $ $Date: 2004-02-17T15:40:29.640821Z $ + +package Win32::Exe::Resource::Icon; + +use strict; +use base 'Win32::Exe::Resource'; +use constant FORMAT => ( + Width => 'C', + Height => 'C', + ColorCount => 'C', + _ => 'C', + Planes => 'v', + BitCount => 'v', + ImageSize => 'V', + I_RVA1 => 'v', + I_RVA2 => 'v', +); + +sub Id { + my ($self) = @_; + return $self->I_RVA1; +} + +sub SetId { + my ($self, $value) = @_; + return $self->SetI_RVA1($value); +} + +sub ImageOffset { + my ($self) = @_; + return $self->I_RVA1 + (($self->I_RVA2 || 0) * 65536); +} + +sub SetImageOffset { + my ($self, $value) = @_; + $self->SetI_RVA1($value % 65536); + $self->SetI_RVA2(int($value / 65536)); +} + +sub Data { + my ($self) = @_; + return $self->parent->substr($self->ImageOffset, $self->ImageSize); +} + +sub dump { + my ($self) = @_; + my $parent = $self->parent; + my $dump = $self->SUPER::dump; + substr($dump, -2, 2, '') unless $parent->is_type('IconFile'); + return $dump; +} + +1; diff --git a/Master/tlpkg/tlperl/lib/Win32/Exe/Resource/Manifest.pm b/Master/tlpkg/tlperl/lib/Win32/Exe/Resource/Manifest.pm new file mode 100755 index 00000000000..28d6ecaeff4 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Win32/Exe/Resource/Manifest.pm @@ -0,0 +1,60 @@ +package Win32::Exe::Resource::Manifest; + +use strict; +use base 'Win32::Exe::Resource'; +use constant FORMAT => ( + Data => 'a*', +); + +sub get_manifest { + my ($self ) = @_; + return $self->dump; +} + +sub set_manifest { + my ( $self, $xmltext ) = @_; + $self->SetData( $self->encode_manifest($xmltext) ); + my $rsrc = $self->first_parent('Resources'); + $rsrc->remove("/#RT_MANIFEST"); + $rsrc->insert("/#RT_MANIFEST/#1/#0" => $self); + $rsrc->refresh; +} + +sub update_manifest { + my ( $self, $xmltext ) = @_; + $self->SetData( $self->encode_manifest($xmltext) ); +} + +sub encode_manifest { + my ($self, $string) = @_; + return pack("a*", $string); +} + +sub default_manifest { + my ( $self ) = @_; + my $defman = <<'W32EXEDEFAULTMANIFEST' +<?xml version="1.0" encoding="UTF-8" standalone="yes"?> +<assembly xmlns="urn:schemas-microsoft-com:asm.v1" manifestVersion="1.0"> + <assemblyIdentity processorArchitecture="x86" version="0.0.0.0" type="win32" name="Win32.Exe.Application" /> + <description>Win32.Exe.Application</description> + <trustInfo xmlns="urn:schemas-microsoft-com:asm.v3"> + <security> + <requestedPrivileges> + <requestedExecutionLevel level="asInvoker" uiAccess="false" /> + </requestedPrivileges> + </security> + </trustInfo> + <dependency> + <dependentAssembly> + <assemblyIdentity type="win32" name="Microsoft.Windows.Common-Controls" version="6.0.0.0" publicKeyToken="6595b64144ccf1df" language="*" processorArchitecture="x86" /> + </dependentAssembly> + </dependency> +</assembly> +W32EXEDEFAULTMANIFEST +; + + + return $defman; +} + +1; diff --git a/Master/tlpkg/tlperl/lib/Win32/Exe/Resource/Version.pm b/Master/tlpkg/tlperl/lib/Win32/Exe/Resource/Version.pm new file mode 100755 index 00000000000..98adfbb9b22 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Win32/Exe/Resource/Version.pm @@ -0,0 +1,364 @@ +# $File: //local/member/autrijus/Win32-Exe/lib/Win32/Exe/Resource/Version.pm $ $Author: autrijus $ +# $Revision: #6 $ $Change: 1130 $ $Date: 2004-02-17T15:40:29.640821Z $ + +package Win32::Exe::Resource::Version; + +use strict; +use base 'Win32::Exe::Resource'; +use constant FORMAT => ( + Data => 'a*', +); +use constant FIXED_INFO => [qw( + Signature StrucVersion FileVersionMS FileVersionLS + ProductVersionMS ProductVersionLS FileFlagsMask FileFlags + FileOS FileType FileSubtype FileDateMS FileDateLS +)]; +use constant STRING_INFO => [qw( + Comments CompanyName FileDescription FileVersion InternalName + LegalCopyright LegalTrademarks OriginalFilename PrivateBuild + ProductName ProductVersion SpecialBuild FileNumber ProductNumber +)]; +use constant FI_TO_ID => { + map { (FIXED_INFO->[$_] => $_) } (0 .. $#{+FIXED_INFO}) +}; +use constant LC_TO_SI => { + (map { (lc($_) => $_) } @{+STRING_INFO}, keys %{+FI_TO_ID}), + (map { (lc($_) => $_) } map { /^(.+)MS$/ ? $1 : () } keys %{+FI_TO_ID}), +}; + +sub fi_to_id { + my ($self, $name) = @_; + return(+FI_TO_ID->{$name}); +} + +sub lc_to_si { + my ($self, $name) = @_; + return(+LC_TO_SI->{lc($name)} || $name); +} + +sub info { + my ($self) = @_; + return $self->{info}; +} + +sub set_info { + my ($self, $info) = @_; + $self->{info} = $info; +} + +sub initialize { + my ($self) = @_; + $self->set_info($self->decode_info($self->Data)); + die 'Invalid structure' unless $self->check; +} + +sub refresh { + my ($self) = @_; + $self->SetData($self->encode_info($self->info)); + my $rsrc = $self->first_parent('Resources'); + $rsrc->remove("/#RT_VERSION"); + $rsrc->insert("/#RT_VERSION/#1/#0" => $self); + $rsrc->refresh; + $self->initialize; +} + +sub encode_info { + my ($self, $info) = @_; + + my $key = shift(@$info); + $key = $self->encode_ucs2("$key\0"); + + my $val = shift(@$info); + my ($type, $vallen); + + if (ref $val) { + $type = 0; # binary + $val = pack('V*', @$val); + $vallen = length($val); + } + elsif (length $val) { + $type = 1; # text; + $val = $self->encode_ucs2("$val\0"); + $vallen = length($val) / 2; + } + else { + $type = 1; + $vallen = 0; + } + + my @sub_objects; + foreach my $sub_info (@$info) { + my $obj = $self->encode_info($sub_info); + push(@sub_objects, $obj); + } + + my $buf = pack('v3', 0, $vallen, $type) . $key; + $buf .= $self->pad($buf, 4); + $buf .= $val; + + foreach my $sub_object (@sub_objects) { + $buf .= $self->pad($buf, 4); + $buf .= $sub_object; + } + + substr($buf, 0, 2, pack('v', length($buf))); + return $buf; +} + +sub decode_info { + my $self = shift; + my $level = $_[1] || 1; + + my ($len, $vallen, $type) = unpack('v3', $_[0]); + die 'No record length' unless $len; + die 'Long length' if $len > length($_[0]); + + my $buf = substr($_[0], 0, $len); + substr($_[0], 0, $self->align($len, 4)) = ''; + + my $endkey = index($buf, "\0\0", 6); + while ($endkey > 0 and ($endkey % 2)) { + $endkey = index($buf, "\0\0", $endkey + 1); + } + + die 'Invalid endkey' if $endkey < 6 or $endkey > $len - $vallen;; + + my $key = substr($buf, 6, $endkey - 6); + my $u8_key = $self->decode_ucs2($key); + + my @res = ($u8_key); + $endkey = $self->align($endkey + 2, 4); + substr($buf, 0, $endkey, ''); + + if ($vallen) { + $vallen *= 2 if $level == 4; # only for strings + my $val = substr($buf, 0, $vallen); + if ($type) { + $val = $self->decode_ucs2($val); + $val =~ s/\0\z//; + } + else { + $val = [ unpack('V*', $val) ]; + } + push(@res, $val); + $vallen = $self->align($vallen, 4); + + substr($buf, 0, $vallen) = ''; + } + else { + push(@res, ''); + } + + while (length $buf) { + push(@res, $self->decode_info($buf, $level + 1)); + } + + return \@res; +} + +sub empty_info { + [ 'VS_VERSION_INFO', [ 0xFEEF04BD, 1 << 16, (0) x 11 ] ]; +} + +sub check_info { + my ($self, $info) = @_; + return 0 unless $info->[0] eq 'VS_VERSION_INFO'; + return 0 unless ref($info->[1]); + return 0 unless $info->[1][0] == 0xFEEF04BD; + return 0 unless $self->check_sub_info($info); + return 1; +} + +sub check_sub_info { + my ($self, $info) = @_; + return unless UNIVERSAL::isa($info, 'ARRAY'); + return if @$info < 2; + return unless defined($info->[0]) and defined($info->[1]); + return unless !ref($info->[0]) and length($info->[0]); + return unless !ref($info->[1]) or UNIVERSAL::isa($info->[1], 'ARRAY'); + foreach my $idx (2 .. @$info - 1) { + return 0 unless $self->check_sub_info($info->[$idx]); + } + return 1; +} + +sub get { + my ($self, $name) = @_; + $name =~ s!\\!/!g; + $name = $self->lc_to_si($name); + my $info = $self->info; + + if ($name eq '/') { + return undef unless ref $info->[1]; + return $info->[1]; + } + + my $fixed = $self->fi_to_id($name); + if (defined $fixed) { + my $struct = $info->[1]; + return undef unless $struct && ref($struct); + return $struct->[$fixed]; + } + + $fixed = $self->fi_to_id($name.'MS'); + if (defined $fixed) { + my $struct = $info->[1]; + return undef unless $struct && ref($struct); + my $ms = $struct->[$fixed]; + my $ls = $struct->[ $self->fi_to_id($name.'LS') ]; + return join(',', $self->split_dword($ms), $self->split_dword($ls)); + } + + my $s; + if ($name =~ s!^/!!) { + $s = $info; + while ($name =~ s!^([^/]+)/!!) { + $s = $self->find_info($s, $1) or return undef; + } + } + else { + $s = $self->find_info($info, 'StringFileInfo') or return undef; + if (my $cur_trans = $self->{cur_trans}) { + $s = $self->find_info($s, $cur_trans, 1) or return undef; + } + else { + $s = $s->[2] or return undef; + $self->{cur_trans} = $s->[0]; + } + } + + $s = $self->find_info($s, $name) or return undef; + return $s->[1]; +} + +sub set { + my ($self, $name, $value) = @_; + $name =~ s!\\!/!g; + $name = $self->lc_to_si($name); + my $info = $self->info; + + if ($name eq '/') { + if (!defined $value) { + $info->[1] = ''; + } + elsif (UNIVERSAL::isa($value, 'ARRAY') and @$value == 13) { + $info->[1] = $value; + } + else { + die 'Invalid array assigned'; + } + } + + my $fixed = $self->fi_to_id($name); + if (defined $fixed) { + $value = oct($value) if $value =~ /^0/; + $info->[1][$fixed] = $value; + return; + } + + $fixed = $self->fi_to_id($name.'MS'); + if (defined $fixed) { + my @value = split(/[,.]/, $value, -1); + if (@value == 4) { + $value[0] = ($value[0] << 16) | $value[1]; + $value[1] = ($value[2] << 16) | $value[3]; + splice(@value, 2); + } + + die 'Invalid MS/LS value' if @value != 2; + $info->[1][$fixed] = $value[0] || 0; + $info->[1][$self->fi_to_id($name.'LS')] = $value[1] || 0; + return; + } + + my $container = $info; + + if ($name =~ s!^/!!) { + while ($name =~ s!^([^/]+)/!!) { + my $n = $1; + my $s = $self->find_info($container, $n); + unless ($s) { + $s = [ $n => '' ]; + push(@$container, $s); + } + $container = $s; + } + } + else { + my $s = $self->find_info($container, 'StringFileInfo'); + unless ($s) { + $s = [ StringFileInfo => '' ]; + push(@$container, $s); + } + $container = $s; + + my $cur_trans = $self->{cur_trans}; + unless ($cur_trans) { + if (@$container > 2) { + $cur_trans = $container->[2][0]; + } + else { + $cur_trans = '000004B0'; # Language Neutral && CP 1200 = Unicode + } + $self->{cur_trans} = $cur_trans; + } + + $s = $self->find_info($container, $cur_trans, 1); + unless ($s) { + $s = [ $cur_trans => '' ]; + push(@$container, $s); + } + $container = $s; + } + + my ($kv, $kv_index) = $self->find_info($container, $name); + unless ($kv) { + push(@$container, [ $name => $value ]) if defined $value; + return; + } + + if (defined $value) { + $kv->[1] = $value; + } + else { + splice(@$container, $kv_index, 1); + } +} + +sub check { + my $self = shift; + return $self->check_info($self->info); +} + +sub find_info { + my ($self, $info, $name, $ignore) = @_; + my $index; + + if ($name =~ /^#(\d+)$/) { + $index = $1 - 1 + 2; + $index = undef if $index < 2 || $index >= @$info; + } + else { + for (2 .. @$info - 1) { + my $e = $info->[$_]; + if ($e->[0] eq $name or $ignore && lc($e->[0]) eq lc($name)) { + $index = $_; + last; + } + } + } + if ($index) { + return $info->[$index] unless wantarray; + return ($info->[$index], $index); + } + + return undef unless wantarray; + return (undef, undef); +} + +sub split_dword { + my ($self, $dword) = @_; + return ($dword >> 16), ($dword & 0xFFFF); +} + +1; diff --git a/Master/tlpkg/tlperl/lib/Win32/Exe/ResourceData.pm b/Master/tlpkg/tlperl/lib/Win32/Exe/ResourceData.pm new file mode 100755 index 00000000000..b33647d519c --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Win32/Exe/ResourceData.pm @@ -0,0 +1,58 @@ +# $File: //local/member/autrijus/Win32-Exe/lib/Win32/Exe/ResourceData.pm $ $Author: autrijus $ +# $Revision: #6 $ $Change: 1130 $ $Date: 2004-02-17T15:40:29.640821Z $ + +package Win32::Exe::ResourceData; + +use strict; +use base 'Win32::Exe::Base'; +use constant FORMAT => ( + VirtualAddress => 'V', + Size => 'V', + CodePage => 'V', +); + +sub Data { + my ($self) = @_; + return $self->{data} if defined $self->{data}; + + my $section = $self->first_parent('Resources'); + my $addr = $self->VirtualAddress or return; + return $section->substr( + $addr - $section->VirtualAddress, + $self->Size + ); +} + +sub SetData { + my ($self, $data) = @_; + $self->{data} = $data; +} + +sub object { + my ($self) = @_; + return $self->{object}; +} + +sub path { + my ($self) = @_; + return $self->parent->path; +} + +sub initialize { + my ($self) = @_; + + my ($base) = $self->path or return; + $base =~ /^#RT_(?!ICON$)(\w+)$/ or return; + $self->VirtualAddress or return; + + my $data = $self->Data; + my $class = ucfirst(lc($1)); + $class =~ s/_(\w)/\U$1/g; + $class = $self->require_class("Resource::$class") or return; + + my $obj = $class->new(\$data, { parent => $self }); + $obj->initialize; + $self->{object} = $obj; +} + +1; diff --git a/Master/tlpkg/tlperl/lib/Win32/Exe/ResourceEntry.pm b/Master/tlpkg/tlperl/lib/Win32/Exe/ResourceEntry.pm new file mode 100755 index 00000000000..a44a65daf3d --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Win32/Exe/ResourceEntry.pm @@ -0,0 +1,69 @@ +# $File: //local/member/autrijus/Win32-Exe/lib/Win32/Exe/ResourceEntry.pm $ $Author: autrijus $ +# $Revision: #7 $ $Change: 1130 $ $Date: 2004-02-17T15:40:29.640821Z $ + +package Win32::Exe::ResourceEntry; + +use strict; +use base 'Win32::Exe::Base'; +use constant FORMAT => ( + Data => 'V', + E_RVA => 'V', +); +use constant HIGH_BIT => 0x80_00_00_00; +use Win32::Exe::ResourceData; + +sub high_bit { + my ($self) = @_; + return +HIGH_BIT; +} + +sub path { + my ($self) = @_; + return $self->parent->path; +} + +sub PathName { + my ($self) = @_; + return join('/', '', $self->path, $self->Name); +} + +sub VirtualAddress { + my ($self) = @_; + $self->E_RVA & ~($self->high_bit); +} + +sub SetVirtualAddress { + my ($self, $data) = @_; + $self->SetE_RVA($data | $self->IsDirectory); +} + +sub IsDirectory { + my ($self) = @_; + $self->E_RVA & ($self->high_bit); +} + +sub initialize { + my ($self) = @_; + my $section = $self->first_parent('Resources'); + my $data = $section->substr($self->VirtualAddress, 12); + my $res_data = Win32::Exe::ResourceData->new(\$data, { parent => $self }); + $res_data->initialize; + $self->{res_data} = $res_data; +} + +sub Data { + my ($self) = @_; + return $self->{res_data}->Data; +} + +sub CodePage { + my ($self) = @_; + return $self->{res_data}->CodePage; +} + +sub object { + my ($self) = @_; + return $self->{res_data}->object; +} + +1; diff --git a/Master/tlpkg/tlperl/lib/Win32/Exe/ResourceEntry/Id.pm b/Master/tlpkg/tlperl/lib/Win32/Exe/ResourceEntry/Id.pm new file mode 100755 index 00000000000..39e35b4000d --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Win32/Exe/ResourceEntry/Id.pm @@ -0,0 +1,47 @@ +# $File: //local/member/autrijus/Win32-Exe/lib/Win32/Exe/ResourceEntry/Id.pm $ $Author: autrijus $ +# $Revision: #6 $ $Change: 1130 $ $Date: 2004-02-17T15:40:29.640821Z $ + +package Win32::Exe::ResourceEntry::Id; + +use strict; +use base 'Win32::Exe::ResourceEntry'; +use constant SUBFORMAT => ( + Id => 'V', +); +use constant RESOURCE_TYPES => [qw( + _ CURSOR BITMAP ICON MENU + DIALOG STRING FONTDIR FONT ACCELERATOR + RCDATA MESSAGETABLE GROUP_CURSOR _ GROUP_ICON + _ VERSION DLGINCLUDE _ PLUGPLAY + VXD ANICURSOR ANIICON HTML MANIFEST +)]; +use constant RT_TO_ID => { + map { ('RT_'.RESOURCE_TYPES->[$_] => $_) } + (0 .. $#{+RESOURCE_TYPES}) +}; +use constant ID_TO_RT => { reverse %{+RT_TO_ID} }; + +sub Name { + my ($self) = @_; + my $id = $_[0]->Id; + $id = $self->id_to_rt($id) if $self->parent->depth < 1; + return "#$id"; +} + +sub SetName { + my ($self, $name) = @_; + $name =~ s/^#//; + $self->SetId( $self->rt_to_id($name) ); +} + +sub id_to_rt { + my ($self, $id) = @_; + return(+ID_TO_RT->{$id} || $id); +} + +sub rt_to_id { + my ($self, $rt) = @_; + return(+RT_TO_ID->{$rt} || $rt); +} + +1; diff --git a/Master/tlpkg/tlperl/lib/Win32/Exe/ResourceEntry/Name.pm b/Master/tlpkg/tlperl/lib/Win32/Exe/ResourceEntry/Name.pm new file mode 100755 index 00000000000..8f6cd1d8784 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Win32/Exe/ResourceEntry/Name.pm @@ -0,0 +1,42 @@ +# $File: //local/member/autrijus/Win32-Exe/lib/Win32/Exe/ResourceEntry/Name.pm $ $Author: autrijus $ +# $Revision: #6 $ $Change: 1130 $ $Date: 2004-02-17T15:40:29.640821Z $ + +package Win32::Exe::ResourceEntry::Name; + +use strict; +use base 'Win32::Exe::ResourceEntry'; +use constant SUBFORMAT => ( + N_RVA => 'V', +); + +sub NameAddress { + my ($self) = @_; + $self->N_RVA & ~($self->high_bit); +} + +sub SetNameAddress { + my ($self, $data) = @_; + $self->SetN_RVA($data | $self->IsDirectory); +} + +sub IsEscaped { + my ($self) = @_; + $self->N_RVA & ($self->high_bit); +} + +sub Name { + my ($self) = @_; + my $section = $self->first_parent('Resources'); + my $addr = $self->NameAddress; + my $size = unpack('v', $section->substr($addr, 2)); + my $ustr = $section->substr($addr + 2, $size * 2); + my $name = $self->decode_ucs2($ustr); + $name =~ s{([%#/])}{sprintf('%%%02X', ord($1))}eg; + return $name; +} + +sub SetName { + die "XXX unimplemented"; +} + +1; diff --git a/Master/tlpkg/tlperl/lib/Win32/Exe/ResourceTable.pm b/Master/tlpkg/tlperl/lib/Win32/Exe/ResourceTable.pm new file mode 100755 index 00000000000..7fe9fa1d5dd --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Win32/Exe/ResourceTable.pm @@ -0,0 +1,35 @@ +# $File: //local/member/autrijus/Win32-Exe/lib/Win32/Exe/ResourceTable.pm $ $Author: autrijus $ +# $Revision: #5 $ $Change: 1130 $ $Date: 2004-02-17T15:40:29.640821Z $ + +package Win32::Exe::ResourceTable; + +use strict; +use base 'Win32::Exe::Base'; +use constant FORMAT => ( + DebugDirectory => 'V', + TimeStamp => 'V', + VersionMajor => 'v', + VersionMinor => 'v', + NumNameEntry => 'v', + NumIdEntry => 'v', + 'ResourceEntry::Name' => [ 'a8', '{$NumNameEntry}', 1 ], + 'ResourceEntry::Id' => [ 'a8', '{$NumIdEntry}', 1 ], +); + +sub set_path { + my ($self, $path) = @_; + $self->{path} = $path; +} + +sub path { + my ($self) = @_; + wantarray ? @{$self->{path}} : $self->{path}; +} + +sub depth { + my ($self) = @_; + scalar @{$self->{path}}; +} + + +1; diff --git a/Master/tlpkg/tlperl/lib/Win32/Exe/Section.pm b/Master/tlpkg/tlperl/lib/Win32/Exe/Section.pm new file mode 100755 index 00000000000..d08f91590f7 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Win32/Exe/Section.pm @@ -0,0 +1,154 @@ +# $File: //local/member/autrijus/Win32-Exe/lib/Win32/Exe/Section.pm $ $Author: autrijus $ +# $Revision: #9 $ $Change: 1130 $ $Date: 2004-02-17T15:40:29.640821Z $ + +package Win32::Exe::Section; + +use strict; +use base 'Win32::Exe::Base'; +use constant FORMAT => ( + Name => 'Z8', + VirtualSize => 'V', + VirtualAddress => 'V', + FileSize => 'V', + FileOffset => 'V', + RelocOffset => 'V', + LineNumOffset => 'V', + NumReloc => 'v', + NumLineNum => 'v', + Flags => 'V', +); +use constant DISPATCH_FIELD => 'Name'; +use constant DISPATCH_TABLE => ( + '.text' => 'Section::Code', + '.debug' => 'Section::Debug', + '.data' => 'Section::Data', + '.rdata' => 'Section::Data', + '.bss' => 'Section::Data', + '.edata' => 'Section::Exports', + '.idata' => 'Section::Imports', + '.rsrc' => 'Section::Resources', +); + +use constant CONTAINS_CODE => 0x20; +use constant CONTAINS_IDATA => 0x40; +use constant CONTAINS_UDATA => 0x80; + +sub Data { + my ($self) = @_; + $self->{data} ||= do { + my $v_size = $self->VirtualSize; + my $f_size = $self->FileSize or return("\0" x $v_size); + + $f_size = $v_size if $v_size < $f_size; + + my $data = $self->parent->substr($self->FileOffset, $f_size); + $data .= ("\x0" x ($v_size - length($data))); + $data; + } +} + +sub SetData { + my ($self, $data) = @_; + my $pad_size = length($1) if $data =~ s/(\0*)\z//; + + my $exe = $self->parent; + $exe->OptHeaderSize == 224 or die "Unsupported binary format"; + + my $index = $self->sibling_index; + my $data_size = length($data); + + my $f_size = $self->align($data_size, $exe->FileAlign); + my $v_size = $self->align($data_size, $exe->SectionAlign); + my $f_extra = $f_size - $self->FileSize; + my $v_extra = $v_size - $self->align($self->VirtualSize, $exe->SectionAlign); + + $self->pad_data($f_extra, $v_extra) if $f_extra; + + $self->SetVirtualSize($data_size + $pad_size); + $data .= ("\0" x ($self->FileSize - $data_size)); + + $exe->substr($self->FileOffset, length($data), $data); + $self->update_size; +} + +sub update_size { + my ($self) = @_; + + my $exe = $self->parent; + my $v_addr = $self->VirtualAddress; + my $v_size = $self->VirtualSize; + + foreach my $dir ($exe->data_directories) { + next unless $dir->VirtualAddress == $v_addr; + $dir->SetSize($v_size); + $dir->refresh; + } +} + +sub pad_data { + my ($self, $f_extra, $v_extra) = @_; + + my $exe = $self->parent; + my $offset = $self->FileOffset + $self->FileSize; + + $exe->update_debug_directory($offset, $f_extra); + + my $exe_size = $exe->size; + if ($exe_size > $offset) { + my $buf = $exe->substr($offset, ($exe_size - $offset)); + $exe->substr($offset + $f_extra, length($buf), $buf); + } + + $exe->set_size($exe_size + $f_extra); + if ($f_extra > 0) { + $exe->SetData($exe->Data . ("\0" x $f_extra)); + } + else { + $exe->SetData(substr($exe->Data, 0, $f_extra)); + } + + my $index = $self->sibling_index; + foreach my $section (@{$self->siblings}) { + next if $section->sibling_index <= $index; + $section->update_offset($f_extra, $v_extra); + } + + $self->SetFileSize($self->FileSize + $f_extra); + $exe->SetImageSize($exe->ImageSize + $v_extra); + + my $flags = $self->Flags; + $exe->SetCodeSize($exe->CodeSize + $f_extra) if $flags & CONTAINS_CODE; + $exe->SetIDataSize($exe->IDataSize + $f_extra) if $flags & CONTAINS_IDATA; + $exe->SetUDataSize($exe->UDataSize + $f_extra) if $flags & CONTAINS_UDATA; +} + +sub update_offset { + my ($self, $f_extra, $v_extra) = @_; + return unless $f_extra > 0; + + my $exe = $self->parent; + my $v_addr = $self->VirtualAddress; + + $self->SetVirtualAddress( $v_addr + $v_extra ); + $self->SetFileOffset( $self->FileOffset + $f_extra ); + + foreach my $dir ($exe->data_directories) { + next unless $dir->VirtualAddress == $v_addr; + $dir->SetVirtualAddress($self->VirtualAddress); + } +} + +sub substr { + my $self = shift; + my $data = $self->Data; + my $offset = shift; + my $length = @_ ? shift(@_) : (length($data) - $offset); + my $replace = shift; + + return substr($data, $offset, $length) if !defined $replace; + + substr($data, $offset, $length, $replace); + $self->SetData($data); +} + +1; diff --git a/Master/tlpkg/tlperl/lib/Win32/Exe/Section/Code.pm b/Master/tlpkg/tlperl/lib/Win32/Exe/Section/Code.pm new file mode 100755 index 00000000000..726707c3064 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Win32/Exe/Section/Code.pm @@ -0,0 +1,9 @@ +# $File: //local/member/autrijus/Win32-Exe/lib/Win32/Exe/Section/Code.pm $ $Author: autrijus $ +# $Revision: #4 $ $Change: 1130 $ $Date: 2004-02-17T15:40:29.640821Z $ + +package Win32::Exe::Section::Code; + +use strict; +use base 'Win32::Exe::Section'; + +1; diff --git a/Master/tlpkg/tlperl/lib/Win32/Exe/Section/Data.pm b/Master/tlpkg/tlperl/lib/Win32/Exe/Section/Data.pm new file mode 100755 index 00000000000..033d8f504e3 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Win32/Exe/Section/Data.pm @@ -0,0 +1,9 @@ +# $File: //local/member/autrijus/Win32-Exe/lib/Win32/Exe/Section/Data.pm $ $Author: autrijus $ +# $Revision: #4 $ $Change: 1130 $ $Date: 2004-02-17T15:40:29.640821Z $ + +package Win32::Exe::Section::Data; + +use strict; +use base 'Win32::Exe::Section'; + +1; diff --git a/Master/tlpkg/tlperl/lib/Win32/Exe/Section/Debug.pm b/Master/tlpkg/tlperl/lib/Win32/Exe/Section/Debug.pm new file mode 100755 index 00000000000..e59ac4b3287 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Win32/Exe/Section/Debug.pm @@ -0,0 +1,9 @@ +# $File: //local/member/autrijus/Win32-Exe/lib/Win32/Exe/Section/Debug.pm $ $Author: autrijus $ +# $Revision: #4 $ $Change: 1130 $ $Date: 2004-02-17T15:40:29.640821Z $ + +package Win32::Exe::Section::Debug; + +use strict; +use base 'Win32::Exe::Section'; + +1; diff --git a/Master/tlpkg/tlperl/lib/Win32/Exe/Section/Exports.pm b/Master/tlpkg/tlperl/lib/Win32/Exe/Section/Exports.pm new file mode 100755 index 00000000000..9d1d5117555 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Win32/Exe/Section/Exports.pm @@ -0,0 +1,9 @@ +# $File: //local/member/autrijus/Win32-Exe/lib/Win32/Exe/Section/Exports.pm $ $Author: autrijus $ +# $Revision: #4 $ $Change: 1130 $ $Date: 2004-02-17T15:40:29.640821Z $ + +package Win32::Exe::Section::Exports; + +use strict; +use base 'Win32::Exe::Section'; + +1; diff --git a/Master/tlpkg/tlperl/lib/Win32/Exe/Section/Imports.pm b/Master/tlpkg/tlperl/lib/Win32/Exe/Section/Imports.pm new file mode 100755 index 00000000000..e736a043f15 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Win32/Exe/Section/Imports.pm @@ -0,0 +1,9 @@ +# $File: //local/member/autrijus/Win32-Exe/lib/Win32/Exe/Section/Imports.pm $ $Author: autrijus $ +# $Revision: #4 $ $Change: 1130 $ $Date: 2004-02-17T15:40:29.640821Z $ + +package Win32::Exe::Section::Imports; + +use strict; +use base 'Win32::Exe::Section'; + +1; diff --git a/Master/tlpkg/tlperl/lib/Win32/Exe/Section/Resources.pm b/Master/tlpkg/tlperl/lib/Win32/Exe/Section/Resources.pm new file mode 100755 index 00000000000..afbc41e7309 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Win32/Exe/Section/Resources.pm @@ -0,0 +1,260 @@ +# $File: //local/member/autrijus/Win32-Exe/lib/Win32/Exe/Section/Resources.pm $ $Author: autrijus $ +# $Revision: #10 $ $Change: 1130 $ $Date: 2004-02-17T15:40:29.640821Z $ + +package Win32::Exe::Section::Resources; + +use strict; +use base 'Win32::Exe::Section'; +use constant DELEGATE_SUBS => ( + 'ResourceEntry' => [ 'high_bit' ], + 'ResourceEntry::Id' => [ 'rt_to_id', 'id_to_rt' ], +); + +sub initialize { + my $self = shift; + $self->make_table(0); + return $self; +} + +sub table { + my $self = shift; + return $self->{table}; +} + +sub make_table { + my ($self, $offset, @path) = @_; + my $image = $self->substr($offset); + my $table = $self->require_class('ResourceTable')->new( + \$image, { + parent => $self, + path => \@path + }, + ); + + foreach my $entry ($table->members) { + if ($entry->IsDirectory) { + $self->make_table($entry->VirtualAddress, @path, $entry->Name); + } + else { + $self->{table}{$entry->PathName} = $entry; + } + } +} + +sub names { + my ($self) = @_; + my @rv = sort keys %{$self->{table}}; + wantarray ? @rv : \@rv; +} + +sub resources { + my ($self, $name) = @_; + my @rv = map $self->{table}{$_}, $self->names; + wantarray ? @rv : \@rv; +} + +sub remove { + my ($self, $name) = @_; + delete $self->{table}{$_} for grep /^\Q$name\E/, $self->names; +} + +sub insert { + my ($self, $name, $res) = @_; + $self->{table}{$name} = $res; +} + +sub res { + my ($self, $name) = @_; + return $self->{table}{$name}; +} + +sub res_data { + my ($self, $name) = @_; + my $res = $self->res($name) or return; + return $res->Data; +} + +sub res_codepage { + my ($self, $name) = @_; + my $res = $self->res($name) or return; + return $res->CodePage; +} + +sub res_object { + my ($self, $name) = @_; + my $res = $self->res($name) or return; + return $res->object; +} + +sub res_image { + my ($self, $name) = @_; + my $res = $self->res($name) or return; + my $object = $res->object or return $res->Data; + return $object->dump; +} + +sub first_object { + my ($self, $type) = @_; + foreach my $object (grep $_, map $_->object, $self->resources) { + return $object if !$type or $object->is_type($type); + } + return undef; +} + +sub objects { + my ($self, $type) = @_; + return grep { $type ? $_->is_type($type) : 1 } + grep { $_ } map { $_->object } $self->resources; +} + +sub refresh { + my $self = shift; + + my $res_num = @{$self->resources} or return pack('V*', (0) x 4); + my $entry_size = $self->entry_size(scalar $self->names); + my $data_entry_size = 16 * $res_num; + + my %str_addr; + my $str_image = ''; + my $str_offset = $entry_size + $data_entry_size; + + foreach my $name ($self->names) { + $name =~ s!^/!!; + foreach my $chunk (split("/", $name, -1)) { + $chunk =~ /^#/ and next; + $chunk =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg; + next if exists $str_addr{$chunk}; + + die "String too long" if length($chunk) > 0xFFFF; + + my $addr = length($str_image); + my $str = $self->encode_ucs2($chunk); + $str_image .= pack('v', length($str) / 2) . $str; + + $str_addr{$chunk} = $addr + $str_offset; + } + } + $str_image .= $self->pad($str_image, 8); + + my %data_entry_addr; + my $data_entry_image = ''; + my $data_image = ''; + my $data_offset = $str_offset + length($str_image); + + foreach my $name ($self->names) { + $data_entry_addr{$name} = $entry_size + length($data_entry_image); + + my $data_addr = $data_offset + length($data_image) + $self->VirtualAddress; + $data_entry_image .= pack( + 'V4', + $data_addr, + length($self->res_data($name)), + $self->res_codepage($name), + 0, + ); + $data_image .= $self->res_data($name); + $data_image .= $self->pad($data_image, 8); + } + + my $entry_image = ''; + $self->make_entry( + \$entry_image, + '', + [$self->names], + \%str_addr, + \%data_entry_addr, + ); + + length($entry_image) == $entry_size or die "Wrong size"; + + $self->SetData( + join('', $entry_image, $data_entry_image, $str_image, $data_image) + ); +} + +sub entry_size { + my ($self, $names) = @_; + + my %entries; + foreach my $name (grep length, @$names) { + $name =~ m!^/([^/]*)(.*)! or next; + push(@{ $entries{$1} }, $2); + } + + my $count = keys %entries or return 0; + my $size = 8 * ($count + 2); + $size += $self->entry_size($_) for values %entries; + return $size; +} + +sub make_entry { + my ($self, $image_ref, $prefix, $names, $str_addr, $data_entry_addr) = @_; + + if (@$names == 1 and !length($names->[0])) { + return $data_entry_addr->{$prefix}; + } + + my %entries; + foreach my $name (@$names) { + $name =~ m!^/([^/]*)(.*)! or next; + my ($path, $name) = ($1, $2); + my $type = ($path =~ /^#/) ? 'id' : 'name'; + push(@{ $entries{$type}{$path} }, $name); + } + + my $addr = length($$image_ref); + my $num_name = keys %{ $entries{name} }; + my $num_id = keys %{ $entries{id} }; + $$image_ref .= pack('V3vv', 0, 0, 0, $num_name, $num_id); + + my $entry_offset = length($$image_ref); + $$image_ref .= pack('V*', (0) x (($num_name + $num_id) * 2)); + + foreach my $entry ($self->sort_entry(\%entries)) { + my ($type, $name) = @$entry; + my $id; + if ($type eq 'id') { + $id = $name; + $id =~ s/^#//; + $id = $self->rt_to_id($id); + } + else { + (my $n = $name) =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg; + $id = $str_addr->{$n} | $self->high_bit; + } + + my $rva = $self->make_entry( + $image_ref, + "$prefix/$name", + $entries{$type}{$name}, + $str_addr, + $data_entry_addr, + ); + + substr($$image_ref, $entry_offset, 8) = pack('VV', $id, $rva); + $entry_offset += 8; + } + + return ($addr | $self->high_bit); +} + +sub sort_entry { + my ($self, $entries) = @_; + + my @names = map { $_->[1] } sort { $a->[0] cmp $b->[0] } map { + my $name = lc($_); + $name =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg; + [ $name => $_ ]; + } keys %{ $entries->{name} }; + + my @ids = map "#$_", sort { + $self->rt_to_id($a) <=> $self->rt_to_id($b) + } map substr($_, 1), keys %{ $entries->{id} }; + + return( + (map [ name => $_ ], @names), + (map [ id => $_ ], @ids), + ); +} + +1; diff --git a/Master/tlpkg/tlperl/lib/Win32/File.pm b/Master/tlpkg/tlperl/lib/Win32/File.pm new file mode 100755 index 00000000000..811e3ccb114 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Win32/File.pm @@ -0,0 +1,118 @@ +package Win32::File; + +# +# File.pm +# Written by Douglas_Lankshear@ActiveWare.com +# +# subsequent hacks: +# Gurusamy Sarathy +# + +$VERSION = '0.06'; + +require Exporter; +require DynaLoader; + +@ISA= qw( Exporter DynaLoader ); +@EXPORT = qw( + ARCHIVE + COMPRESSED + DIRECTORY + HIDDEN + NORMAL + OFFLINE + READONLY + SYSTEM + TEMPORARY + ); +@EXPORT_OK = qw(GetAttributes SetAttributes); + +=head1 NAME + +Win32::File - Manage file attributes in perl + +=head1 SYNOPSIS + + use Win32::File; + +=head1 DESCRIPTION + +This module offers the retrieval and setting of file attributes. + +=head1 Functions + +=head2 NOTE + +All of the functions return FALSE (0) if they fail, unless otherwise noted. +The function names are exported into the caller's namespace by request. + +=over 10 + +=item GetAttributes(filename, returnedAttributes) + +Gets the attributes of a file or directory. returnedAttributes will be set +to the OR-ed combination of the filename attributes. + +=item SetAttributes(filename, newAttributes) + +Sets the attributes of a file or directory. newAttributes must be an OR-ed +combination of the attributes. + +=back + +=head1 Constants + +The following constants are exported by default. + +=over 10 + +=item ARCHIVE + +=item COMPRESSED + +=item DIRECTORY + +=item HIDDEN + +=item NORMAL + +=item OFFLINE + +=item READONLY + +=item SYSTEM + +=item TEMPORARY + +=back + +=cut + +sub AUTOLOAD +{ + my($constname); + ($constname = $AUTOLOAD) =~ s/.*:://; + #reset $! to zero to reset any current errors. + local $! = 0; + my $val = constant($constname); + if($! != 0) + { + if($! =~ /Invalid/) + { + $AutoLoader::AUTOLOAD = $AUTOLOAD; + goto &AutoLoader::AUTOLOAD; + } + else + { + ($pack,$file,$line) = caller; + die "Your vendor has not defined Win32::File macro $constname, used in $file at line $line."; + } + } + eval "sub $AUTOLOAD { $val }"; + goto &$AUTOLOAD; +} + +bootstrap Win32::File; + +1; +__END__ diff --git a/Master/tlpkg/tlperl/lib/Win32/File/Object.pm b/Master/tlpkg/tlperl/lib/Win32/File/Object.pm new file mode 100755 index 00000000000..bb4aa90ecdc --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Win32/File/Object.pm @@ -0,0 +1,450 @@ +package Win32::File::Object; + +=pod + +=head1 NAME + +Win32::File::Object - Simplified object abstraction over Win32::File + +=head1 SYNOPSIS + + # Get a handle for the file. + my $object = Win32::File::Object->new( $filename, $autowrite ); + + # Read a property flag for the file. + my $readonly = $object->readonly; + + # Set a propertly flag for the file. + $object->readonly(1); + + # If autowrite is false, write the changes to the file. + $object->write; + +=head1 DESCRIPTION + +L<Win32::File> is an interface to the Win32 API for file +attributes. + +Unfortunately it is a B<direct> interface to the underlying Win32 API, +with a completely non-Perlish interface involving CamelCase function +names, bit-field flags and return-by-param. + +B<Win32::File::Object> is a straight-forward object-oriented Perlish +wrapper around the raw underlying API wrapper. + +=head1 METHODS + +=cut + +use 5.006; +use strict; +use Carp (); +use Win32::File (); + +use vars qw{$VERSION}; +BEGIN { + $VERSION = '0.02'; +} + + + + + +##################################################################### +# Constructor + +=pod + +=head2 new + + my $file = Win32::File::Object->new( $path, $autowrite ); + +The C<new> constructor creates a new handle to the Win32 filesystem +attributes of an existing file or directory. + +The compulsory C<$filename> parameter is the name of the file or +directory to create the handle on. + +The optional C<$autowrite> parameter, if true, indicates that the +object should write the filesystem attributes to the file every +time the method is called to set the property. + +If the C<$autowrite> param is false or not provided, you will +need to call an explicit C<write> method in order to apply the +changes to the file. + +=cut + +sub new { + my $class = shift; + my $path = shift; + my $autowrite = !! shift; + unless ( $path ) { + Carp::croak("Did not provide a file name"); + } + unless ( -f $path ) { + Carp::croak("File '$path' does not exist"); + } + + # Create the object + my $self = bless { + path => $path, + autowrite => $autowrite, + rollback => ! 1, + }, $class; + + # Get the attributes + $self->read; + + return $self; +} + +=pod + +=head2 path + +The C<path> accessor returns the original file path as provided to +the constructor as a string. + +=cut + +sub path { + $_[0]->{path}; +} + +=pod + +=head2 autowrite + +The C<autowrite> accessor returns true if the object will +automatically write changes to the filesystem, or false if +not. + +=cut + +sub autowrite { + $_[0]->{autowrite}; +} + + + + + +##################################################################### +# Main Methods + +=pod + +=head2 read + +the C<read> method reads (updates) the filesystem attributes, in case +they have been updated since the object was originally created. + +Returns true on success or throws an exception (dies) on error. + +=cut + +sub read { + my $self = shift; + + # Read the bitfield + my $bits; + my $path = $self->path; + unless ( Win32::File::GetAttributes( $self->path => $bits ) ) { + Carp::croak("GetAttributes failed for '$path'"); + } + + # Read the flags + $self->{archive} = ( $bits & Win32::File::ARCHIVE() ) ? 1 : 0; + $self->{compressed} = ( $bits & Win32::File::COMPRESSED() ) ? 1 : 0; + $self->{directory} = ( $bits & Win32::File::DIRECTORY() ) ? 1 : 0; + $self->{hidden} = ( $bits & Win32::File::HIDDEN() ) ? 1 : 0; + $self->{normal} = ( $bits & Win32::File::NORMAL() ) ? 1 : 0; + $self->{offline} = ( $bits & Win32::File::OFFLINE() ) ? 1 : 0; + $self->{readonly} = ( $bits & Win32::File::READONLY() ) ? 1 : 0; + $self->{system} = ( $bits & Win32::File::SYSTEM() ) ? 1 : 0; + $self->{temporary} = ( $bits & Win32::File::TEMPORARY() ) ? 1 : 0; + + return 1; +} + +=pod + +=head2 write + +the C<write> method writes the object attributes back to the filesystem. + +Returns true on success or throws an exception (dies) on error. + +=cut + +sub write { + my $self = shift; + + # Generate the bitfield from the attributes + my $bits = 0; + if ( $self->archive ) { + $bits += Win32::File::ARCHIVE(); + } + if ( $self->compressed ) { + $bits += Win32::File::COMPRESSED(); + } + if ( $self->directory ) { + $bits += Win32::File::DIRECTORY(); + } + if ( $self->hidden ) { + $bits += Win32::File::HIDDEN(); + } + if ( $self->normal ) { + $bits += Win32::File::NORMAL(); + } + if ( $self->offline ) { + $bits += Win32::File::OFFLINE(); + } + if ( $self->readonly ) { + $bits += Win32::File::READONLY(); + } + if ( $self->system ) { + $bits += Win32::File::SYSTEM(); + } + if ( $self->temporary ) { + $bits += Win32::File::TEMPORARY(); + } + + # Apply the attributes to the file + my $path = $self->path; + unless ( Win32::File::SetAttributes( $path, $bits ) ) { + Carp::croak("SetAttributes failed for '$path'"); + } + + return 1; +} + + + + + +##################################################################### +# Attribute Methods + +=pod + +=head2 archive + + # Get the value + my $archive = $file->archive; + + # Set the value + $file->archive(1); + +The C<archive> accessor gets or set the Win32 "archive" status for +the file. + +=cut + +sub archive { + shift->_attr( archive => @_ ); +} + +=pod + +=head2 compressed + + # Get the value + my $compressed = $file->compressed; + + # Set the value + $file->compressed(1); + +The C<compressed> accessor gets or set the Win32 "compressed" status +for the file. + +=cut + +sub compressed { + shift->_attr( compressed => @_ ); +} + +=pod + +=head2 directory + + # Get the value + my $directory = $file->directory; + + # Set the value + $file->directory(1); + +The C<directory> accessor gets or set the Win32 "directory" status for +the file. + +=cut + +sub directory { + shift->_attr( directory => @_ ); +} + +=pod + +=head2 hidden + + # Get the value + my $hidden = $file->hidden; + + # Set the value + $file->hidden(1); + +The C<hidden> accessor gets or set the Win32 "hidden" status for +the file. + +=cut + +sub hidden { + shift->_attr( hidden => @_ ); +} + +=pod + +=head2 normal + + # Get the value + my $normal = $file->normal; + + # Set the value + $file->normal(1); + +The C<normal> accessor gets or set the Win32 "normal" status for +the file. + +=cut + +sub normal { + shift->_attr( normal => @_ ); +} + +=pod + +=head2 offline + + # Get the value + my $offline = $file->offline; + + # Set the value + $file->offline(1); + +The C<offline> accessor gets or set the Win32 "offline" status for +the file. + +=cut + +sub offline { + shift->_attr( offline => @_ ); +} + +=pod + +=head2 readonly + + # Get the value + my $readonly = $file->readonly; + + # Set the value + $file->readonly(1); + +The C<readonly> accessor gets or set the Win32 "readonly" status for +the file. + +=cut + +sub readonly { + shift->_attr( readonly => @_ ); +} + +=pod + +=head2 system + + # Get the value + my $system = $file->system; + + # Set the value + $file->system(1); + +The C<system> accessor gets or set the Win32 "system" status for +the file. + +=cut + +sub system { + shift->_attr( system => @_ ); +} + +=pod + +=head2 temporary + + # Get the value + my $temporary = $file->temporary; + + # Set the value + $file->temporary(1); + +The C<temporary> accessor gets or set the Win32 "temporary" status for +the file. + +=cut + +sub temporary { + shift->_attr( temporary => @_ ); +} + +sub _attr { + my $self = shift; + my $name = shift; + my $new = $_[0] ? 1 : 0; + return $self->{$name} unless @_; + return $self->{$name} if $new == $self->{$name}; + + # Set the rollback if needed + if ( $self->{rollback} and ! exists $self->{rollback}->{$name} ) { + $self->{rollback}->{$name} = $new; + } + + # Set the new value + $self->{$name} = $new; + $self->write if $self->autowrite; + + return $self->{$name}; +} + +1; + +=pod + +=head1 SUPPORT + +Bugs should be reported via the CPAN bug tracker at + +L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Win32-File-Object> + +For other issues, or commercial enhancement or support, contact the author. + +=head1 AUTHOR + +Adam Kennedy E<lt>adamk@cpan.orgE<gt> + +=head1 SEE ALSO + +L<Win32::File> + +=head1 COPYRIGHT + +Copyright 2008 - 2009 Adam Kennedy. + +This program is free software; you can redistribute +it and/or modify it under the same terms as Perl itself. + +The full text of the license can be found in the +LICENSE file included with this module. + +=cut diff --git a/Master/tlpkg/tlperl/lib/Win32/Process.pm b/Master/tlpkg/tlperl/lib/Win32/Process.pm new file mode 100755 index 00000000000..24c017a94a4 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Win32/Process.pm @@ -0,0 +1,219 @@ +package Win32::Process; + +require Exporter; +require DynaLoader; +@ISA = qw(Exporter DynaLoader); + +$VERSION = '0.14'; + +# 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( + CREATE_DEFAULT_ERROR_MODE + CREATE_NEW_CONSOLE + CREATE_NEW_PROCESS_GROUP + CREATE_NO_WINDOW + CREATE_SEPARATE_WOW_VDM + CREATE_SUSPENDED + CREATE_UNICODE_ENVIRONMENT + DEBUG_ONLY_THIS_PROCESS + DEBUG_PROCESS + DETACHED_PROCESS + HIGH_PRIORITY_CLASS + IDLE_PRIORITY_CLASS + INFINITE + NORMAL_PRIORITY_CLASS + REALTIME_PRIORITY_CLASS + THREAD_PRIORITY_ABOVE_NORMAL + THREAD_PRIORITY_BELOW_NORMAL + THREAD_PRIORITY_ERROR_RETURN + THREAD_PRIORITY_HIGHEST + THREAD_PRIORITY_IDLE + THREAD_PRIORITY_LOWEST + THREAD_PRIORITY_NORMAL + THREAD_PRIORITY_TIME_CRITICAL +); + +@EXPORT_OK = qw( + STILL_ACTIVE + ABOVE_NORMAL_PRIORITY_CLASS + BELOW_NORMAL_PRIORITY_CLASS +); + +sub AUTOLOAD { + # This AUTOLOAD is used to 'autoload' constants from the constant() + # XS function. + my($constname); + ($constname = $AUTOLOAD) =~ s/.*:://; + local $! = 0; + my $val = constant($constname); + if ($! != 0) { + my ($pack,$file,$line) = caller; + die "Your vendor has not defined Win32::Process macro $constname, used at $file line $line."; + } + eval "sub $AUTOLOAD { $val }"; + goto &$AUTOLOAD; +} # end AUTOLOAD + +bootstrap Win32::Process; + +# Win32::IPC > 1.02 uses the get_Win32_IPC_HANDLE method: +*get_Win32_IPC_HANDLE = \&get_process_handle; + +1; +__END__ + +=head1 NAME + +Win32::Process - Create and manipulate processes. + +=head1 SYNOPSIS + + use Win32::Process; + use Win32; + + sub ErrorReport{ + print Win32::FormatMessage( Win32::GetLastError() ); + } + + Win32::Process::Create($ProcessObj, + "C:\\winnt\\system32\\notepad.exe", + "notepad temp.txt", + 0, + NORMAL_PRIORITY_CLASS, + ".")|| die ErrorReport(); + + $ProcessObj->Suspend(); + $ProcessObj->Resume(); + $ProcessObj->Wait(INFINITE); + +=head1 DESCRIPTION + +This module provides access to the process control functions in the +Win32 API. + +=head1 METHODS + +=over 8 + +=item Win32::Process::Create($obj,$appname,$cmdline,$iflags,$cflags,$curdir) + +Creates a new process. + + Args: + + $obj container for process object + $appname full path name of executable module + $cmdline command line args + $iflags flag: inherit calling processes handles or not + $cflags flags for creation (see exported vars below) + $curdir working dir of new process + +Returns non-zero on success, 0 on failure. + +=item Win32::Process::Open($obj,$pid,$iflags) + +Creates a handle Perl can use to an existing process as identified by $pid. +The $iflags is the inherit flag that is passed to OpenProcess. Currently +Win32::Process objects created using Win32::Process::Open cannot Suspend +or Resume the process. All other calls should work. + +Win32::Process::Open returns non-zero on success, 0 on failure. + +=item Win32::Process::KillProcess($pid, $exitcode) + +Terminates any process identified by $pid. $exitcode will be set to +the exit code of the process. + +=item $ProcessObj->Suspend() + +Suspend the process associated with the $ProcessObj. + +=item $ProcessObj->Resume() + +Resume a suspended process. + +=item $ProcessObj->Kill($exitcode) + +Kill the associated process, have it terminate with exit code $ExitCode. + +=item $ProcessObj->GetPriorityClass($class) + +Get the priority class of the process. + +=item $ProcessObj->SetPriorityClass($class) + +Set the priority class of the process (see exported values below for +options). Note that the ABOVE_NORMAL_PRIORITY_CLASS and +BELOW_NORMAL_PRIORITY_CLASS classes only work on Windows 2000 +and later. + +=item $ProcessObj->GetProcessAffinityMask($processAffinityMask, $systemAffinityMask) + +Get the process affinity mask. This is a bitvector in which each bit +represents the processors that a process is allowed to run on. + +=item $ProcessObj->SetProcessAffinityMask($processAffinityMask) + +Set the process affinity mask. Only available on Windows NT. + +=item $ProcessObj->GetExitCode($exitcode) + +Retrieve the exitcode of the process. Will return STILL_ACTIVE if the +process is still running. The STILL_ACTIVE constant is only exported +by explicit request. + +=item $ProcessObj->Wait($timeout) + +Wait for the process to die. $timeout should be specified in milliseconds. +To wait forever, specify the constant C<INFINITE>. + +=item $ProcessObj->GetProcessID() + +Returns the Process ID. + +=item Win32::Process::GetCurrentProcessID() + +Returns the current process ID, which is the same as $$. But not on cygwin, +where $$ is the cygwin-internal PID and not the windows PID. +On cygwin GetCurrentProcessID() returns the windows PID as needed for all +the Win32::Process functions. + +=back + +=head1 EXPORTS + +The following constants are exported by default: + + CREATE_DEFAULT_ERROR_MODE + CREATE_NEW_CONSOLE + CREATE_NEW_PROCESS_GROUP + CREATE_NO_WINDOW + CREATE_SEPARATE_WOW_VDM + CREATE_SUSPENDED + CREATE_UNICODE_ENVIRONMENT + DEBUG_ONLY_THIS_PROCESS + DEBUG_PROCESS + DETACHED_PROCESS + HIGH_PRIORITY_CLASS + IDLE_PRIORITY_CLASS + INFINITE + NORMAL_PRIORITY_CLASS + REALTIME_PRIORITY_CLASS + THREAD_PRIORITY_ABOVE_NORMAL + THREAD_PRIORITY_BELOW_NORMAL + THREAD_PRIORITY_ERROR_RETURN + THREAD_PRIORITY_HIGHEST + THREAD_PRIORITY_IDLE + THREAD_PRIORITY_LOWEST + THREAD_PRIORITY_NORMAL + THREAD_PRIORITY_TIME_CRITICAL + +The following additional constants are exported by request only: + + ABOVE_NORMAL_PRIORITY_CLASS + BELOW_NORMAL_PRIORITY_CLASS + STILL_ACTIVE + +=cut diff --git a/Master/tlpkg/tlperl/lib/Win32/Shortcut.pm b/Master/tlpkg/tlperl/lib/Win32/Shortcut.pm new file mode 100755 index 00000000000..00200dead1f --- /dev/null +++ b/Master/tlpkg/tlperl/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.07"; + +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 elsehow 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> + +=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 responsability 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. + +=cut diff --git a/Master/tlpkg/tlperl/lib/Win32/TieRegistry.pm b/Master/tlpkg/tlperl/lib/Win32/TieRegistry.pm new file mode 100755 index 00000000000..19f9fdf4ae5 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Win32/TieRegistry.pm @@ -0,0 +1,3809 @@ +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.26'; + @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,$nlen,[],[],[],[]) ) { + push( @names, $name ); + } + if( ! _NoMoreItems() ) { + return (); + } + $self->{VALUES}= \@names; + return 1; +} + + +sub ValueNames +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + @_ and croak "Usage: \@names= \$key->ValueNames;"; + $self->_enumValues unless $self->{VALUES}; + return @{$self->{VALUES}}; +} + + +sub _enumSubKeys +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + my( @subkeys, @classes, @times )= (); + my $pos= 0; + my( $subkey, $class, $time )= ("","",""); + my( $namSiz, $clsSiz )= $self->Information( + qw( MaxSubKeyLen MaxSubClassLen )); + $namSiz++; $clsSiz++; + while( $self->RegEnumKeyEx( + $pos++, $subkey, $namSiz, [], $class, $clsSiz, $time ) ) { + push( @subkeys, $subkey ); + push( @classes, $class ); + push( @times, $time ); + } + if( ! _NoMoreItems() ) { + return (); + } + $self->{SUBKEYS}= \@subkeys; + $self->{SUBCLASSES}= \@classes; + $self->{SUBTIMES}= \@times; + return 1; +} + + +sub SubKeyNames +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + @_ and croak "Usage: \@names= \$key->SubKeyNames;"; + $self->_enumSubKeys unless $self->{SUBKEYS}; + return @{$self->{SUBKEYS}}; +} + + +sub SubKeyClasses +{ + my $self= shift(@_); + @_ and croak "Usage: \@classes= \$key->SubKeyClasses;"; + $self->_enumSubKeys unless $self->{SUBCLASSES}; + return @{$self->{SUBCLASSES}}; +} + + +sub SubKeyTimes +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + @_ and croak "Usage: \@times= \$key->SubKeyTimes;"; + $self->_enumSubKeys unless $self->{SUBTIMES}; + return @{$self->{SUBTIMES}}; +} + + +sub _MemberNames +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + @_ and croak "Usage: \$arrayRef= \$key->_MemberNames;"; + if( ! $self->{MEMBERS} ) { + $self->_enumValues unless $self->{VALUES}; + $self->_enumSubKeys unless $self->{SUBKEYS}; + my( @members )= ( map( $_.$self->{DELIM}, @{$self->{SUBKEYS}} ), + map( $self->{DELIM}.$_, @{$self->{VALUES}} ) ); + $self->{MEMBERS}= \@members; + } + return $self->{MEMBERS}; +} + + +sub _MembersHash +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + @_ and croak "Usage: \$hashRef= \$key->_MembersHash;"; + if( ! $self->{MEMBHASH} ) { + my $aRef= $self->_MemberNames; + $self->{MEMBHASH}= {}; + @{$self->{MEMBHASH}}{@$aRef}= (1) x @$aRef; + } + return $self->{MEMBHASH}; +} + + +sub MemberNames +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + @_ and croak "Usage: \@members= \$key->MemberNames;"; + return @{$self->_MemberNames}; +} + + +sub Information +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + my( $time, $nkeys, $nvals, $xsec, $xkey, $xcls, $xname, $xdata )= + ("",0,0,0,0,0,0,0); + my $clen= 8; + if( ! $self->RegQueryInfoKey( [], [], $nkeys, $xkey, $xcls, + $nvals, $xname, $xdata, $xsec, $time ) ) { + return (); + } + if( defined($self->{Class}) ) { + $clen= length($self->{Class}); + } else { + $self->{Class}= ""; + } + while( ! $self->RegQueryInfoKey( $self->{Class}, $clen, + [],[],[],[],[],[],[],[],[]) + && _MoreData ) { + $clen *= 2; + } + my( %info ); + @info{ qw( LastWrite CntSubKeys CntValues SecurityLen + MaxValDataLen MaxSubKeyLen MaxSubClassLen MaxValNameLen ) + }= ( $time, $nkeys, $nvals, $xsec, + $xdata, $xkey, $xcls, $xname ); + if( @_ ) { + my( %check ); + @check{keys(%info)}= keys(%info); + my( @err )= grep( ! $check{$_}, @_ ); + if( @err ) { + croak "${PACK}::Information- Invalid info requested (@err)"; + } + return @info{@_}; + } else { + return %info; + } +} + + +sub Delimiter +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + $self= $RegObj unless ref($self); + my( $oldDelim )= $self->{DELIM}; + if( 1 == @_ && "" ne "$_[0]" ) { + delete $self->{MEMBERS}; + delete $self->{MEMBHASH}; + $self->{DELIM}= "$_[0]"; + } elsif( 0 != @_ ) { + croak "Usage: \$oldDelim= \$key->Delimiter(\$newDelim);"; + } + return $oldDelim; +} + + +sub Handle +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + @_ and croak "Usage: \$handle= \$key->Handle;"; + $self= $RegObj unless ref($self); + return $self->{HANDLE}; +} + + +sub Path +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + @_ and croak "Usage: \$path= \$key->Path;"; + my $delim= $self->{DELIM}; + $self= $RegObj unless ref($self); + if( "" eq $self->{MACHINE} ) { + return( $delim . join( $delim, @{$self->{PATH}} ) . $delim ); + } else { + return( $delim x 2 + . join( $delim, $self->{MACHINE}, @{$self->{PATH}} ) + . $delim ); + } +} + + +sub _Path +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + @_ and croak "Usage: \$arrRef= \$key->_Path;"; + $self= $RegObj unless ref($self); + return $self->{PATH}; +} + + +sub Machine +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + @_ and croak "Usage: \$machine= \$key->Machine;"; + $self= $RegObj unless ref($self); + return $self->{MACHINE}; +} + + +sub Access +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + @_ and croak "Usage: \$access= \$key->Access;"; + $self= $RegObj unless ref($self); + return $self->{ACCESS}; +} + + +sub OS_Delimiter +{ + my $self= shift(@_); + @_ and croak "Usage: \$backslash= \$key->OS_Delimiter;"; + return $self->{OS_DELIM}; +} + + +sub _Roots +{ + my $self= shift(@_); + $self= tied(%$self) if ref($self) && tied(%$self); + @_ and croak "Usage: \$varName= \$key->_Roots;"; + $self= $RegObj unless ref($self); + return $self->{ROOTS}; +} + + +sub Roots +{ + my $self= shift(@_); + $self= tied(%$self) if ref($self) && tied(%$self); + @_ and croak "Usage: \$hashRef= \$key->Roots;"; + $self= $RegObj unless ref($self); + return eval "\\%$self->{ROOTS}"; +} + + +sub TIEHASH +{ + my( $this )= shift(@_); + $this= tied(%$this) if ref($this) && tied(%$this); + my( $key )= @_; + if( 1 == @_ && ref($key) && "$key" =~ /=/ ) { + return $key; # $key is already an object (blessed reference). + } + return $this->new( @_ ); +} + + +sub Tie +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + my( $hRef )= @_; + if( 1 != @_ || ! ref($hRef) || "$hRef" !~ /(^|=)HASH\(/ ) { + croak "Usage: \$key->Tie(\\\%hash);"; + } + return tie %$hRef, ref($self), $self; +} + + +sub TiedRef +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + my $hRef= @_ ? shift(@_) : {}; + return () if ! defined($self); + $self->Tie($hRef); + bless $hRef, ref($self); + return $hRef; +} + + +sub _Flags +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + my $oldFlags= $self->{FLAGS}; + if( 1 == @_ ) { + $self->{FLAGS}= shift(@_); + } elsif( 0 != @_ ) { + croak "Usage: \$oldBits= \$key->_Flags(\$newBits);"; + } + return $oldFlags; +} + + +sub ArrayValues +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + my $oldFlag= $Flag_ArrVal == ( $Flag_ArrVal & $self->{FLAGS} ); + if( 1 == @_ ) { + my $bool= shift(@_); + if( $bool ) { + $self->{FLAGS} |= $Flag_ArrVal; + } else { + $self->{FLAGS} &= ~( $Flag_ArrVal | $Flag_TieVal ); + } + } elsif( 0 != @_ ) { + croak "Usage: \$oldBool= \$key->ArrayValues(\$newBool);"; + } + return $oldFlag; +} + + +sub TieValues +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + my $oldFlag= $Flag_TieVal == ( $Flag_TieVal & $self->{FLAGS} ); + if( 1 == @_ ) { + my $bool= shift(@_); + if( $bool ) { + croak "${PACK}->TieValues cannot be enabled with this version"; + $self->{FLAGS} |= $Flag_TieVal; + } else { + $self->{FLAGS} &= ~$Flag_TieVal; + } + } elsif( 0 != @_ ) { + croak "Usage: \$oldBool= \$key->TieValues(\$newBool);"; + } + return $oldFlag; +} + + +sub FastDelete +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + my $oldFlag= $Flag_FastDel == ( $Flag_FastDel & $self->{FLAGS} ); + if( 1 == @_ ) { + my $bool= shift(@_); + if( $bool ) { + $self->{FLAGS} |= $Flag_FastDel; + } else { + $self->{FLAGS} &= ~$Flag_FastDel; + } + } elsif( 0 != @_ ) { + croak "Usage: \$oldBool= \$key->FastDelete(\$newBool);"; + } + return $oldFlag; +} + + +sub SplitMultis +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + my $oldFlag= $Flag_Split == ( $Flag_Split & $self->{FLAGS} ); + if( 1 == @_ ) { + my $bool= shift(@_); + if( $bool ) { + $self->{FLAGS} |= $Flag_Split; + } else { + $self->{FLAGS} &= ~$Flag_Split; + } + } elsif( 0 != @_ ) { + croak "Usage: \$oldBool= \$key->SplitMultis(\$newBool);"; + } + return $oldFlag; +} + + +sub DWordsToHex +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + my $oldFlag= $Flag_HexDWord == ( $Flag_HexDWord & $self->{FLAGS} ); + if( 1 == @_ ) { + my $bool= shift(@_); + if( $bool ) { + $self->{FLAGS} |= $Flag_HexDWord; + } else { + $self->{FLAGS} &= ~$Flag_HexDWord; + } + } elsif( 0 != @_ ) { + croak "Usage: \$oldBool= \$key->DWordsToHex(\$newBool);"; + } + return $oldFlag; +} + + +sub FixSzNulls +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + my $oldFlag= $Flag_FixNulls == ( $Flag_FixNulls & $self->{FLAGS} ); + if( 1 == @_ ) { + my $bool= shift(@_); + if( $bool ) { + $self->{FLAGS} |= $Flag_FixNulls; + } else { + $self->{FLAGS} &= ~$Flag_FixNulls; + } + } elsif( 0 != @_ ) { + croak "Usage: \$oldBool= \$key->FixSzNulls(\$newBool);"; + } + return $oldFlag; +} + + +sub DualTypes +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + my $oldFlag= $Flag_DualTyp == ( $Flag_DualTyp & $self->{FLAGS} ); + if( 1 == @_ ) { + my $bool= shift(@_); + if( $bool ) { + croak "${PACK}->DualTypes cannot be enabled since ", + "SetDualVar module not installed" + unless $_SetDualVar; + $self->{FLAGS} |= $Flag_DualTyp; + } else { + $self->{FLAGS} &= ~$Flag_DualTyp; + } + } elsif( 0 != @_ ) { + croak "Usage: \$oldBool= \$key->DualTypes(\$newBool);"; + } + return $oldFlag; +} + + +sub DualBinVals +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + my $oldFlag= $Flag_DualBin == ( $Flag_DualBin & $self->{FLAGS} ); + if( 1 == @_ ) { + my $bool= shift(@_); + if( $bool ) { + croak "${PACK}->DualBinVals cannot be enabled since ", + "SetDualVar module not installed" + unless $_SetDualVar; + $self->{FLAGS} |= $Flag_DualBin; + } else { + $self->{FLAGS} &= ~$Flag_DualBin; + } + } elsif( 0 != @_ ) { + croak "Usage: \$oldBool= \$key->DualBinVals(\$newBool);"; + } + return $oldFlag; +} + + +sub GetOptions +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + my( $opt, $meth ); + if( ! @_ || 1 == @_ && "HASH" eq ref($_[0]) ) { + my $href= @_ ? $_[0] : {}; + foreach $opt ( grep !/^Allow/, @_opt_subs ) { + $meth= $_opt_subs{$opt}; + $href->{$opt}= $self->$meth(); + } + return @_ ? $self : $href; + } + my @old; + foreach $opt ( @_ ) { + $meth= $_opt_subs{$opt}; + if( defined $meth ) { + if( $opt eq "AllowLoad" || $opt eq "AllowSave" ) { + croak "${PACK}->GetOptions: Getting current setting of $opt ", + "not supported in this release"; + } + push( @old, $self->$meth() ); + } else { + croak "${PACK}->GetOptions: Invalid option ($opt) ", + "not one of ( ", join(" ",grep !/^Allow/, @_opt_subs), " )"; + } + } + return wantarray ? @old : $old[-1]; +} + + +sub SetOptions +{ + my $self= shift(@_); + # Don't get object if hash ref so "ref" returns original ref. + my( $opt, $meth, @old ); + while( @_ ) { + $opt= shift(@_); + $meth= $_opt_subs{$opt}; + if( ! @_ ) { + croak "${PACK}->SetOptions: Option value missing ", + "after option name ($opt)"; + } elsif( defined $meth ) { + push( @old, $self->$meth( shift(@_) ) ); + } elsif( $opt eq substr("reference",0,length($opt)) ) { + shift(@_) if @_; + push( @old, $self ); + } else { + croak "${PACK}->SetOptions: Invalid option ($opt) ", + "not one of ( @_opt_subs )"; + } + } + return wantarray ? @old : $old[-1]; +} + + +sub _parseTiedEnt +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + my $ent= shift(@_); + my $delim= shift(@_); + my $dlen= length( $delim ); + my $parent= @_ ? shift(@_) : 0; + my $off; + if( $delim x 2 eq substr($ent,0,2*$dlen) && "NONE" eq $self->Handle ) { + if( 0 <= ( $off= index( $ent, $delim x 2, 2*$dlen ) ) ) { + return( substr( $ent, 0, $off ), substr( $ent, 2*$dlen+$off ) ); + } elsif( $delim eq substr($ent,-$dlen) ) { + return( substr($ent,0,-$dlen) ); + } elsif( 2*$dlen <= ( $off= rindex( $ent, $delim ) ) ) { + return( substr( $ent, 0, $off ), + undef, substr( $ent, $dlen+$off ) ); + } elsif( $parent ) { + return(); + } else { + return( $ent ); + } + } elsif( $delim eq substr($ent,0,$dlen) && "NONE" ne $self->Handle ) { + return( undef, substr($ent,$dlen) ); + } elsif( $self->{MEMBERS} && $self->_MembersHash->{$ent} ) { + return( substr($ent,0,-$dlen) ); + } elsif( 0 <= ( $off= index( $ent, $delim x 2 ) ) ) { + return( substr( $ent, 0, $off ), substr( $ent, 2*$dlen+$off ) ); + } elsif( $delim eq substr($ent,-$dlen) ) { + if( $parent + && 0 <= ( $off= rindex( $ent, $delim, length($ent)-2*$dlen ) ) ) { + return( substr($ent,0,$off), + undef, undef, substr($ent,$dlen+$off,-$dlen) ); + } else { + return( substr($ent,0,-$dlen) ); + } + } elsif( 0 <= ( $off= rindex( $ent, $delim ) ) ) { + return( + substr( $ent, 0, $off ), undef, substr( $ent, $dlen+$off ) ); + } else { + return( undef, undef, $ent ); + } +} + + +sub _FetchValue +{ + my $self= shift( @_ ); + my( $val, $createKey )= @_; + my( $data, $type ); + if( ( $data, $type )= $self->GetValue( $val ) ) { + return $self->ArrayValues ? [ $data, $type ] + : wantarray ? ( $data, $type ) + : $data; + } elsif( $createKey and $data= $self->new($val) ) { + return $data->TiedRef; + } else { + return (); + } +} + + +sub FETCH +{ + my $self= shift(@_); + my $ent= shift(@_); + my $delim= $self->Delimiter; + my( $key, $val, $ambig )= $self->_parseTiedEnt( $ent, $delim, 0 ); + my $sub; + if( defined($key) ) { + if( defined($self->{MEMBHASH}) + && $self->{MEMBHASH}->{$key.$delim} + && 0 <= index($key,$delim) ) { + return () + unless $sub= $self->new( $key, + {"Delimiter"=>$self->OS_Delimiter} ); + $sub->Delimiter($delim); + } else { + return () + unless $sub= $self->new( $key ); + } + } else { + $sub= $self; + } + if( defined($val) ) { + return $sub->_FetchValue( $val ); + } elsif( ! defined($ambig) ) { + return $sub->TiedRef; + } elsif( defined($key) ) { + return $sub->FETCH( $ambig ); + } else { + return $sub->_FetchValue( $ambig, "" ne $ambig ); + } +} + + +sub _FetchOld +{ + my( $self, $key )= @_; + my $old= $self->FETCH($key); + if( $old ) { + my $copy= {}; + %$copy= %$old; + return $copy; + } + # return $^E; + return _Err; +} + + +sub DELETE +{ + my $self= shift(@_); + my $ent= shift(@_); + my $delim= $self->Delimiter; + my( $key, $val, $ambig, $subkey )= $self->_parseTiedEnt( $ent, $delim, 1 ); + my $sub; + my $fast= defined(wantarray) ? $self->FastDelete : 2; + my $old= 1; # Value returned if FastDelete is set. + if( defined($key) + && ( defined($val) || defined($ambig) || defined($subkey) ) ) { + return () + unless $sub= $self->new( $key ); + } else { + $sub= $self; + } + if( defined($val) ) { + $old= $sub->GetValue($val) || _Err unless 2 <= $fast; + $sub->RegDeleteValue( $val ); + } elsif( defined($subkey) ) { + $old= $sub->_FetchOld( $subkey.$delim ) unless $fast; + $sub->RegDeleteKey( $subkey ); + } elsif( defined($ambig) ) { + if( defined($key) ) { + $old= $sub->DELETE($ambig); + } else { + $old= $sub->GetValue($ambig) || _Err unless 2 <= $fast; + if( defined( $old ) ) { + $sub->RegDeleteValue( $ambig ); + } else { + $old= $sub->_FetchOld( $ambig.$delim ) unless $fast; + $sub->RegDeleteKey( $ambig ); + } + } + } elsif( defined($key) ) { + $old= $sub->_FetchOld( $key.$delim ) unless $fast; + $sub->RegDeleteKey( $key ); + } else { + croak "${PACK}->DELETE: Key ($ent) can never be deleted"; + } + return $old; +} + + +sub SetValue +{ + my $self= shift(@_); + $self= tied(%$self) if tied(%$self); + my $name= shift(@_); + my $data= shift(@_); + my( $type )= @_; + my $size; + if( ! defined($type) ) { + if( "ARRAY" eq ref($data) ) { + croak "${PACK}->SetValue: Value is array reference but ", + "no data type given" + unless 2 == @$data; + ( $data, $type )= @$data; + } else { + $type= REG_SZ; + } + } + $type= _constant($type,"registry value data type") if $type =~ /^REG_/; + if( REG_MULTI_SZ == $type && "ARRAY" eq ref($data) ) { + $data= join( "\0", @$data ) . "\0\0"; + ## $data= pack( "a*" x (1+@$data), map( $_."\0", @$data, "" ) ); + } elsif( ( REG_SZ == $type || REG_EXPAND_SZ == $type ) + && $self->FixSzNulls ) { + $data .= "\0" unless "\0" eq substr($data,0,-1); + } elsif( REG_DWORD == $type && $data =~ /^0x[0-9a-fA-F]{3,}$/ ) { + $data= pack( "L", hex($data) ); + # We could to $data=pack("L",$data) for REG_DWORD but I see + # no nice way to always destinguish when to do this or not. + } + return $self->RegSetValueEx( $name, 0, $type, $data, length($data) ); +} + + +sub StoreKey +{ + my $this= shift(@_); + $this= tied(%$this) if ref($this) && tied(%$this); + my $subKey= shift(@_); + my $data= shift(@_); + my $ent; + my $self; + if( ! ref($data) || "$data" !~ /(^|=)HASH/ ) { + croak "${PACK}->StoreKey: For ", $this->Path.$subKey, ",\n", + " subkey data must be a HASH reference"; + } + if( defined( $$data{""} ) && "HASH" eq ref($$data{""}) ) { + $self= $this->CreateKey( $subKey, delete $$data{""} ); + } else { + $self= $this->CreateKey( $subKey ); + } + return () if ! defined($self); + foreach $ent ( keys(%$data) ) { + return () + unless $self->STORE( $ent, $$data{$ent} ); + } + return $self; +} + + +# = { "" => {OPT=>VAL}, "val"=>[], "key"=>{} } creates a new key +# = "string" creates a new REG_SZ value +# = [ data, type ] creates a new value +sub STORE +{ + my $self= shift(@_); + my $ent= shift(@_); + my $data= shift(@_); + my $delim= $self->Delimiter; + my( $key, $val, $ambig, $subkey )= $self->_parseTiedEnt( $ent, $delim, 1 ); + my $sub; + if( defined($key) + && ( defined($val) || defined($ambig) || defined($subkey) ) ) { + return () + unless $sub= $self->new( $key ); + } else { + $sub= $self; + } + if( defined($val) ) { + croak "${PACK}->STORE: For ", $sub->Path.$delim.$val, ",\n", + " value data cannot be a HASH reference" + if ref($data) && "$data" =~ /(^|=)HASH/; + $sub->SetValue( $val, $data ); + } elsif( defined($subkey) ) { + croak "${PACK}->STORE: For ", $sub->Path.$subkey.$delim, ",\n", + " subkey data must be a HASH reference" + unless ref($data) && "$data" =~ /(^|=)HASH/; + $sub->StoreKey( $subkey, $data ); + } elsif( defined($ambig) ) { + if( ref($data) && "$data" =~ /(^|=)HASH/ ) { + $sub->StoreKey( $ambig, $data ); + } else { + $sub->SetValue( $ambig, $data ); + } + } elsif( defined($key) ) { + croak "${PACK}->STORE: For ", $sub->Path.$key.$delim, ",\n", + " subkey data must be a HASH reference" + unless ref($data) && "$data" =~ /(^|=)HASH/; + $sub->StoreKey( $key, $data ); + } else { + croak "${PACK}->STORE: Key ($ent) can never be created nor set"; + } +} + + +sub EXISTS +{ + my $self= shift(@_); + my $ent= shift(@_); + return defined( $self->FETCH($ent) ); +} + + +sub FIRSTKEY +{ + my $self= shift(@_); + my $members= $self->_MemberNames; + $self->{PREVIDX}= 0; + return @{$members} ? $members->[0] : undef; +} + + +sub NEXTKEY +{ + my $self= shift(@_); + my $prev= shift(@_); + my $idx= $self->{PREVIDX}; + my $members= $self->_MemberNames; + if( ! defined($idx) || $prev ne $members->[$idx] ) { + $idx= 0; + while( $idx < @$members && $prev ne $members->[$idx] ) { + $idx++; + } + } + $self->{PREVIDX}= ++$idx; + return $members->[$idx]; +} + + +sub DESTROY +{ + my $self= shift(@_); + return if tied(%$self); + my $unload; + 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= $key->{"/Information"} + or die "Can't read LMachine/System/Disk//Information value: $^E\n"; + $remoteKey= $Registry->{"//ServerA/LMachine/System/"} + or die "Can't read //ServerA/LMachine/System/ key: $^E\n"; + $remoteData= $remoteKey->{"Disk//Information"} + or die "Can't read ServerA's System/Disk//Information value: $^E\n"; + foreach $entry ( keys(%$diskKey) ) { + ... + } + foreach $subKey ( $diskKey->SubKeyNames ) { + ... + } + $diskKey->AllowSave( 1 ); + $diskKey->RegSaveKey( "C:/TEMP/DiskReg", [] ); + +=head1 DESCRIPTION + +The I<Win32::TieRegistry> module lets you manipulate the Registry +via objects [as in "object oriented"] or via tied hashes. But +you will probably mostly use a combination reference, that is, a +reference to a tied hash that has also been made an object so that +you can mix both access methods [as shown above]. + +If you did not get this module as part of L<libwin32>, you might +want to get a recent version of L<libwin32> from CPAN which should +include this module and the I<Win32API::Registry> module that it +uses. + +Skip to the L<SUMMARY> section if you just want to dive in and start +using the Registry from Perl. + +Accessing and manipulating the registry is extremely simple using +I<Win32::TieRegistry>. A single, simple expression can return +you almost any bit of information stored in the Registry. +I<Win32::TieRegistry> also gives you full access to the "raw" +underlying API calls so that you can do anything with the Registry +in Perl that you could do in C. But the "simple" interface has +been carefully designed to handle almost all operations itself +without imposing arbitrary limits while providing sensible +defaults so you can list only the parameters you care about. + +But first, an overview of the Registry itself. + +=head2 The Registry + +The Registry is a forest: a collection of several tree structures. +The root of each tree is a key. These root keys are identified by +predefined constants whose names start with "HKEY_". Although all +keys have a few attributes associated with each [a class, a time +stamp, and security information], the most important aspect of keys +is that each can contain subkeys and can contain values. + +Each subkey has a name: a string which cannot be blank and cannot +contain the delimiter character [backslash: C<'\\'>] nor nul +[C<'\0'>]. Each subkey is also a key and so can contain subkeys +and values [and has a class, time stamp, and security information]. + +Each value has a name: a string which 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 intepreted is governed by the +following cases, in the order listed. These cases are designed +to "do what you mean". Most of the time you won't have to think +about them, especially if you follow the two simple rules above. +After the list of cases we give several examples which should be +clear enough so feel free to skip to them unless you are worried +about the details. + +=over + +=item Remote machines + +If the hash is tied to the virtual root of the registry [or the +virtual root of a remote machine's registry], then we treat hash +key strings which start with the delimiter character specially. + +If the hash key string starts with two delimiters in a row, then +those should be immediately followed by the name of a remote +machine whose registry we wish to connect to. That can be +followed by a delimiter and more subkey names, etc. If the +machine name is not following by anything, then a virtual root +for the remote machine's registry is created, a hash is tied to +it, and a reference to that hash it is returned. + +=item Hash key string starts with the delimiter + +If the hash is tied to a virtual root key, then the leading +delimiter is ignored. It should be followed by a valid Registry +root key name [either a short-hand name like C<"LMachine">, an +I<HKEY_*> value, or a numeric value]. This alternate notation is +allowed in order to be more consistant with the C<Open()> method +function. + +For all other Registry keys, the leading delimiter indicates +that the rest of the string is a value name. The leading +delimiter is stripped and the rest of the string [which can +be empty and can contain more delimiters] is used as a value +name with no further parsing. + +=item Exact match with direct subkey name followed by delimiter + +If you have already called the Perl C<keys> function on the tied +hash [or have already called C<MemberNames> on the object] and the +hash key string exactly matches one of the strings returned, then +no further parsing is done. In other words, if the key string +exactly matches the name of a direct subkey with a delimiter +appended, then a reference to a hash tied to that subkey is +returned [but only if C<keys> or C<MemberNames> has already +been called for that tied hash]. + +This is only important if you have selected a delimiter other than +the system default delimiter and one of the subkey names contains +the delimiter you have chosen. This rule allows you to deal with +subkeys which contain your chosen delimiter in their name as long +as you only traverse subkeys one level at a time and always +enumerate the list of members before doing so. + +The main advantage of this is that Perl code which recursively +traverses a hash will work on hashes tied to Registry keys even if +a non-default delimiter has been selected. + +=item Hash key string contains two delimiters in a row + +If the hash key string contains two [or more] delimiters in a row, +then the string is split between the first pair of delimiters. +The first part is interpreted as a subkey name or a path of subkey +names separated by delimiters and with a trailing delimiter. The +second part is interpreted as a value name with one leading +delimiter [any extra delimiters are considered part of the value +name]. + +=item Hash key string ends with a delimiter + +If the key string ends with a delimiter, then it is treated +as a subkey name or path of subkey names separated by delimiters. + +=item Hash key string contains a delimiter + +If the key string contains a delimiter, then it is split after +the last delimiter. The first part is treated as a subkey name or +path of subkey names separated by delimiters. The second part +is ambiguous and is treated as outlined in the next item. + +=item Hash key string contains no delimiters + +If the hash key string contains no delimiters, then it is ambiguous. + +If you are reading from the hash [fetching], then we first use the +key string as a value name. If there is a value with a matching +name in the Registry key which the hash is tied to, then the value +data string [and possibly the value data type] is returned. +Otherwise, we retry by using the hash key string as a subkey name. +If there is a subkey with a matching name, then we return a +reference to a hash tied to that subkey. Otherwise we return +C<undef>. + +If you are writing to the hash [storing], then we use the key +string as a subkey name only if the value you are storing is a +reference to a hash value. Otherwise we use the key string as +a value name. + +=back + +=head3 Examples + +Here are some examples showing different ways of accessing Registry +information using references to tied hashes: + +=over + +=item Canonical value fetch + + $tip18= $Registry->{"HKEY_LOCAL_MACHINE\\Software\\Microsoft\\" + . 'Windows\\CurrentVersion\\Explorer\\Tips\\\\18'}; + +Should return the text of important tip number 18. Note that two +backslashes, C<"\\">, are required to get a single backslash into +a Perl double-quoted or single-qouted string. Note that C<"\\"> +is appended to each key name [C<"HKEY_LOCAL_MACHINE"> through +C<"Tips">] and C<"\\"> is prepended to the value name, C<"18">. + +=item Changing your delimiter + + $Registry->Delimiter("/"); + $tip18= $Registry->{"HKEY_LOCAL_MACHINE/Software/Microsoft/" + . 'Windows/CurrentVersion/Explorer/Tips//18'}; + +This usually makes things easier to read when working in Perl. +All remaining examples will assume the delimiter has been changed +as above. + +=item Using intermediate keys + + $ms= $Registry->{"LMachine/Software/Microsoft/"}; + $tips= $ms->{"Windows/CurrentVersion/Explorer/Tips/"}; + $tip18= $winlogon->{"/18"}; + +Same as above but opens more keys into the Registry which lets you +efficiently re-access those intermediate keys. This is slightly +less efficient if you never reuse those intermediate keys. + +=item Chaining in a single statement + + $tip18= $Registry->{"LMachine/Software/Microsoft/"}-> + {"Windows/CurrentVersion/Explorer/Tips/"}->{"/18"}; + +Like above, this creates intermediate key objects then uses +them to access other data. Once this statement finishes, the +intermediate key objects are destroyed. Several handles into +the Registry are opened and closed by this statement so it is +less efficient but there are times when this will be useful. + +=item Even less efficient example of chaining + + $tip18= $Registry->{"LMachine/Software/Microsoft"}-> + {"Windows/CurrentVersion/Explorer/Tips"}->{"/18"}; + +Because we left off the trailing delimiters, I<Win32::TieRegistry> +doesn't know whether final names, C<"Microsoft"> and C<"Tips">, +are subkey names or value names. So this statement ends up +executing the same code as the next one. + +=item What the above really does + + $tip18= $Registry->{"LMachine/Software/"}->{"Microsoft"}-> + {"Windows/CurrentVersion/Explorer/"}->{"Tips"}->{"/18"}; + +With more chains to go through, more temporary objects are created +and later destroyed than in our first chaining example. Also, +when C<"Microsoft"> is looked up, I<Win32::TieRegistry> first +tries to open it as a value and fails then tries it as a subkey. +The same is true for when it looks up C<"Tips">. + +=item Getting all of the tips + + $tips= $Registry->{"LMachine/Software/Microsoft/"}-> + {"Windows/CurrentVersion/Explorer/Tips/"} + or die "Can't find the Windows tips: $^E\n"; + foreach( keys %$tips ) { + print "$_: ", $tips->{$_}, "\n"; + } + +First notice that we actually check for failure for the first +time. We are assuming that the C<"Tips"> key contains no subkeys. +Otherwise the C<print> statement would show something like +C<"Win32::TieRegistry=HASH(0xc03ebc)"> for each subkey. + +The output from the above code will start something like: + + /0: If you don't know how to do something,[...] + +=back + +=head3 Deleting items + +You can use the Perl C<delete> function to delete a value from a +Registry key or to delete a subkey as long that subkey contains +no subkeys of its own. See L<More Examples>, below, for more +information. + +=head3 Storing items + +You can use the Perl assignment operator [C<=>] to create new +keys, create new values, or replace values. The values you store +should be in the same format as the values you would fetch from a +tied hash. For example, you can use a single assignment statement +to copy an entire Registry tree. The following statement: + + $Registry->{"LMachine/Software/Classes/Tie_Registry/"}= + $Registry->{"LMachine/Software/Classes/batfile/"}; + +creates a C<"Tie_Registry"> subkey under the C<"Software\\Classes"> +subkey of the C<HKEY_LOCAL_MACHINE> key. Then it populates it +with copies of all of the subkeys and values in the C<"batfile"> +subkey and all of its subkeys. Note that you need to have +called C<$Registry-E<gt>ArrayValues(1)> for the proper value data +type information to be copied. Note also that this release of +I<Win32::TieRegistry> does not copy key attributes such as class +name and security information [this is planned for a future release]. + +The following statement creates a whole subtree in the Registry: + + $Registry->{"LMachine/Software/FooCorp/"}= { + "FooWriter/" => { + "/Version" => "4.032", + "Startup/" => { + "/Title" => "Foo Writer Deluxe ][", + "/WindowSize" => [ pack("LL",$wid,$ht), "REG_BINARY" ], + "/TaskBarIcon" => [ "0x0001", "REG_DWORD" ], + }, + "Compatibility/" => { + "/AutoConvert" => "Always", + "/Default Palette" => "Windows Colors", + }, + }, + "/License", => "0123-9C8EF1-09-FC", + }; + +Note that all but the last Registry key used on the left-hand +side of the assignment [that is, "LMachine/Software/" but not +"FooCorp/"] must already exist for this statement to succeed. + +By using the leading a trailing delimiters on each subkey name and +value name, I<Win32::TieRegistry> will tell you if you try to assign +subkey information to a value or visa-versa. + +=head3 More examples + +=over + +=item Adding a new tip + + $tips= $Registry->{"LMachine/Software/Microsoft/"}-> + {"Windows/CurrentVersion/Explorer/Tips/"} + or die "Can't find the Windows tips: $^E\n"; + $tips{'/186'}= "Be very careful when making changes to the Registry!"; + +=item Deleting our new tip + + $tips= $Registry->{"LMachine/Software/Microsoft/"}-> + {"Windows/CurrentVersion/Explorer/Tips/"} + or die "Can't find the Windows tips: $^E\n"; + $tip186= delete $tips{'/186'}; + +Note that Perl's C<delete> function returns the value that was deleted. + +=item Adding a new tip differently + + $Registry->{"LMachine/Software/Microsoft/" . + "Windows/CurrentVersion/Explorer/Tips//186"}= + "Be very careful when making changes to the Registry!"; + +=item Deleting differently + + $tip186= delete $Registry->{"LMachine/Software/Microsoft/Windows/" . + "CurrentVersion/Explorer/Tips//186"}; + +Note that this only deletes the tail of what we looked up, the +C<"186"> value, not any of the keys listed. + +=item Deleting a key + +WARNING: The following code will delete all information about the +current user's tip preferences. Actually executing this command +would probably cause the user to see the Welcome screen the next +time they log in and may cause more serious problems. This +statement is shown as an example only and should not be used when +experimenting. + + $tips= delete $Registry->{"CUser/Software/Microsoft/Windows/" . + "CurrentVersion/Explorer/Tips/"}; + +This deletes the C<"Tips"> key and the values it contains. The +C<delete> function will return a reference to a hash [not a tied +hash] containing the value names and value data that were deleted. + +The information to be returned is copied from the Registry into a +regular Perl hash before the key is deleted. If the key has many +subkeys, this copying could take a significant amount of memory +and/or processor time. So you can disable this process by calling +the C<FastDelete> member function: + + $prevSetting= $regKey->FastDelete(1); + +which will cause all subsequent delete operations via C<$regKey> +to simply return a true value if they succeed. This optimization +is automatically done if you use C<delete> in a void context. + +=item Technical notes on deleting + +If you use C<delete> to delete a Registry key or value and use +the return value, then I<Win32::TieRegistry> usually looks up the +current contents of that key or value so they can be returned if +the deletion is successful. If the deletion succeeds but the +attempt to lookup the old contents failed, then the return value +of C<delete> will be C<$^E> from the failed part of the operation. + +=item Undeleting a key + + $Registry->{"LMachine/Software/Microsoft/Windows/" . + "CurrentVersion/Explorer/Tips/"}= $tips; + +This adds back what we just deleted. Note that this version of +I<Win32::TieRegistry> will use defaults for the key attributes +[such as class name and security] and will not restore the +previous attributes. + +=item Not deleting a key + +WARNING: Actually executing the following code could cause +serious problems. This statement is shown as an example only and +should not be used when experimenting. + + $res= delete $Registry->{"CUser/Software/Microsoft/Windows/"} + defined($res) || die "Can't delete URL key: $^E\n"; + +Since the "Windows" key should contain subkeys, that C<delete> +statement should make no changes to the Registry, return C<undef>, +and set C<$^E> to "Access is denied". + +=item Not deleting again + + $tips= $Registry->{"CUser/Software/Microsoft/Windows/" . + "CurrentVersion/Explorer/Tips/"}; + delete $tips; + +The Perl C<delete> function requires that its argument be an +expression that ends in a hash element lookup [or hash slice], +which is not the case here. The C<delete> function doesn't +know which hash $tips came from and so can't delete it. + +=back + +=head2 Objects Documentation + +The following member functions are defined for use on +I<Win32::TieRegistry> objects: + +=over + +=item new + +The C<new> method creates a new I<Win32::TieRegistry> object. +C<new> is mostly a synonym for C<Open()> so see C<Open()> below for +information on what arguments to pass in. Examples: + + $machKey= new Win32::TieRegistry "LMachine" + or die "Can't access HKEY_LOCAL_MACHINE key: $^E\n"; + $userKey= Win32::TieRegistry->new("CUser") + or die "Can't access HKEY_CURRENT_USER key: $^E\n"; + +Note that calling C<new> via a reference to a tied hash returns +a simple object, not a reference to a tied hash. + +=item Open + +=item $subKey= $key->Open( $sSubKey, $rhOptions ) + +The C<Open> method opens a Registry key and returns a new +I<Win32::TieRegistry> object associated with that Registry key. +If C<Open> is called via a reference to a tied hash, then C<Open> +returns another reference to a tied hash. Otherwise C<Open> +returns a simple object and you should then use C<TiedRef> to get +a reference to a tied hash. + +C<$sSubKey> is a string specifying a subkey to be opened. +Alternately C<$sSubKey> can be a reference to an array value +containing the list of increasingly deep subkeys specifying the +path to the subkey to be opened. + +C<$rhOptions> is an optional reference to a hash containing extra +options. The C<Open> method supports two options, C<"Delimiter"> +and C<"Access">, and C<$rhOptions> should have only have zero or +more of these strings as keys. See the "Examples" section below +for more information. + +The C<"Delimiter"> option specifies what string [usually a single +character] will be used as the delimiter to be appended to subkey +names and prepended to value names. If this option is not specified, +the new key [C<$subKey>] inherits the delimiter of the old key +[C<$key>]. + +The C<"Access"> option specifies what level of access to the +Registry key you wish to have once it has been opened. If this +option is not specified, the new key [C<$subKey>] is opened with +the same access level used when the old key [C<$key>] was opened. +The virtual root of the Registry pretends it was opened with +access C<KEY_READ()|KEY_WRITE()> so this is the default access when +opening keys directory via C<$Registry>. If you don't plan on +modifying a key, you should open it with C<KEY_READ> access as +you may not have C<KEY_WRITE> access to it or some of its subkeys. + +If the C<"Access"> option value is a string that starts with +C<"KEY_">, then it should match 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 consectutive delimiters, then those +must be followed by a machine name which causes the C<Connect()> +method function to be called. + +Examples: + + $machKey= $Registry->Open( "LMachine", {Access=>KEY_READ(),Delimiter=>"/"} ) + or die "Can't open HKEY_LOCAL_MACHINE key: $^E\n"; + $swKey= $machKey->Open( "Software" ); + $logonKey= $swKey->Open( "Microsoft/Windows NT/CurrentVersion/Winlogon/" ); + $NTversKey= $swKey->Open( ["Microsoft","Windows NT","CurrentVersion"] ); + $versKey= $swKey->Open( qw(Microsoft Windows CurrentVersion) ); + + $remoteKey= $Registry->Open( "//HostA/LMachine/System/", {Delimiter=>"/"} ) + or die "Can't connect to HostA or can't open subkey: $^E\n"; + +=item Clone + +=item $copy= $key->Clone + +Creates a new object that is associated with the same Registry key +as the invoking object. + +=item Connect + +=item $remoteKey= $Registry->Connect( $sMachineName, $sKeyPath, $rhOptions ) + +The C<Connect> method connects to the Registry of a remote machine, +and opens a key within it, then returns a new I<Win32::TieRegistry> +object associated with that remote Registry key. If C<Connect> +was called using a reference to a tied hash, then the return value +will also be a reference to a tied hash [or C<undef>]. Otherwise, +if you wish to use the returned object as a tied hash [not just as +an object], then use the C<TiedRef> method function after C<Connect>. + +C<$sMachineName> is the name of the remote machine. You don't have +to preceed the machine name with two delimiter characters. + +C<$sKeyPath> is a string specifying the remote key to be opened. +Alternately C<$sKeyPath> can be a reference to an array value +containing the list of increasingly deep keys specifying the path +to the key to be opened. + +C<$rhOptions> is an optional reference to a hash containing extra +options. The C<Connect> method supports two options, C<"Delimiter"> +and C<"Access">. See the C<Open> method documentation for more +information on these options. + +C<$sKeyPath> is already relative to the virtual root of the Registry +of the remote machine. A single leading delimiter on C<sKeyPath> +will be ignored and is not required. + +C<$sKeyPath> can be empty in which case C<Connect> will return an +object representing the virtual root key of the remote Registry. +Each subsequent use of C<Open> on this virtual root key will call +the system C<RegConnectRegistry> function. + +The C<Connect> method can be called via any I<Win32::TieRegistry> +object, not just C<$Registry>. Attributes such as the desired +level of access and the delimiter will be inherited from the +object used but the C<$sKeyPath> will always be relative to the +virtual root of the remote machine's registry. + +Examples: + + $remMachKey= $Registry->Connect( "HostA", "LMachine", {Delimiter->"/"} ) + or die "Can't connect to HostA's HKEY_LOCAL_MACHINE key: $^E\n"; + + $remVersKey= $remMachKey->Connect( "www.microsoft.com", + "LMachine/Software/Microsoft/Inetsrv/CurrentVersion/", + { Access=>KEY_READ, Delimiter=>"/" } ) + or die "Can't check what version of IIS Microsoft is running: $^E\n"; + + $remVersKey= $remMachKey->Connect( "www", + qw(LMachine Software Microsoft Inetsrv CurrentVersion) ) + or die "Can't check what version of IIS we are running: $^E\n"; + +=item ObjectRef + +=item $object_ref= $obj_or_hash_ref->ObjectRef + +For a simple object, just returns itself [C<$obj == $obj->ObjectRef>]. + +For a reference to a tied hash [if it is also an object], C<ObjectRef> +returns the simple object that the hash is tied to. + +This is primarilly useful when debugging since typing C<x $Registry> +will try to display your I<entire> registry contents to your screen. +But the debugger command C<x $Registry->ObjectRef> will just dump +the implementation details of the underlying object to your screen. + +=item Flush( $bFlush ) + +Flushes all cached information about the Registry key so that future +uses will get fresh data from the Registry. + +If the optional C<$bFlush> is specified and a true value, then +C<RegFlushKey()> will be called, which is almost never necessary. + +=item GetValue + +=item $ValueData= $key->GetValue( $sValueName ) + +=item ($ValueData,$ValueType)= $key->GetValue( $sValueName ) + +Gets a Registry value's data and data type. + +C<$ValueData> is usually just a Perl string that contains the +value data [packed into it]. For certain types of data, however, +C<$ValueData> may be processed as described below. + +C<$ValueType> is the C<REG_*> constant describing the type of value +data stored in C<$ValueData>. If the C<DualTypes()> option is on, +then C<$ValueType> will be a dual value. That is, when used in a +numeric context, C<$ValueType> will give the numeric value of a +C<REG_*> constant. However, when used in a non-numeric context, +C<$ValueType> will return the name of the C<REG_*> constant, for +example C<"REG_SZ"> [note the quotes]. So both of the following +can be true at the same time: + + $ValueType == REG_SZ() + $ValueType eq "REG_SZ" + +=over + +=item REG_SZ and REG_EXPAND_SZ + +If the C<FixSzNulls()> option is on, then the trailing C<'\0'> will be +stripped [unless there isn't one] before values of type C<REG_SZ> +and C<REG_EXPAND_SZ> are returned. Note that C<SetValue()> will add +a trailing C<'\0'> under similar circumstances. + +=item REG_MULTI_SZ + +If the C<SplitMultis()> option is on, then values of this type are +returned as a reference to an array containing the strings. For +example, a value that, with C<SplitMultis()> off, would be returned as: + + "Value1\000Value2\000\000" + +would be returned, with C<SplitMultis()> on, as: + + [ "Value1", "Value2" ] + +=item REG_DWORD + +If the C<DualBinVals()> option is on, then the value is returned +as a scalar containing both a string and a number [much like +the C<$!> variable -- see the L<SetDualVar> module for more +information] where the number part is the "unpacked" value. +Use the returned value in a numeric context to access this part +of the value. For example: + + $num= 0 + $Registry->{"CUser/Console//ColorTable01"}; + +If the C<DWordsToHex()> option is off, the string part of the +returned value is a packed, 4-byte string [use C<unpack("L",$value)> +to get the numeric value. + +If C<DWordsToHex()> is on, the string part of the returned value is +a 10-character hex strings [with leading "0x"]. You can use +C<hex($value)> to get the numeric value. + +Note that C<SetValue()> will properly understand each of these +returned value formats no matter how C<DualBinVals()> is set. + +=back + +=item ValueNames + +=item @names= $key->ValueNames + +Returns the list of value names stored directly in a Registry key. +Note that the names returned do I<not> have a delimiter prepended +to them like with C<MemberNames()> and tied hashes. + +Once you request this information, it is cached in the object and +future requests will always return the same list unless C<Flush()> +has been called. + +=item SubKeyNames + +=item @key_names= $key->SubKeyNames + +Returns the list of subkey names stored directly in a Registry key. +Note that the names returned do I<not> have a delimiter appended +to them like with C<MemberNames()> and tied hashes. + +Once you request this information, it is cached in the object and +future requests will always return the same list unless C<Flush()> +has been called. + +=item SubKeyClasses + +=item @classes= $key->SubKeyClasses + +Returns the list of classes for subkeys stored directly in a +Registry key. The classes are returned in the same order as +the subkey names returned by C<SubKeyNames()>. + +=item SubKeyTimes + +=item @times= $key->SubKeyTimes + +Returns the list of last-modified times for subkeys stored +directly in a Registry key. The times are returned in the same +order as the subkey names returned by C<SubKeyNames()>. Each +time is a C<FILETIME> structure packed into a Perl string. + +Once you request this information, it is cached in the object and +future requests will always return the same list unless C<Flush()> +has been called. + +=item MemberNames + +=item @members= $key->MemberNames + +Returns the list of subkey names and value names stored directly +in a Registry key. Subkey names have a delimiter appended to the +end and value names have a delimiter prepended to the front. + +Note that a value name could end in a delimiter [or could be C<""> +so that the member name returned is just a delimiter] so the +presence or absence of the leading delimiter is what should be +used to determine whether a particular name is for a subkey or a +value, not the presence or absence of a trailing delimiter. + +Once you request this information, it is cached in the object and +future requests will always return the same list unless C<Flush()> +has been called. + +=item Information + +=item %info= $key->Information + +=item @items= $key->Information( @itemNames ); + +Returns the following information about a Registry key: + +=over + +=item LastWrite + +A C<FILETIME> structure indicating when the key was last modified +and packed into a Perl string. + +=item CntSubKeys + +The number of subkeys stored directly in this key. + +=item CntValues + +The number of values stored directly in this key. + +=item SecurityLen + +The length [in bytes] of the largest[?] C<SECURITY_DESCRIPTOR> +associated with the Registry key. + +=item MaxValDataLen + +The length [in bytes] of the longest value data associated with +a value stored in this key. + +=item MaxSubKeyLen + +The length [in chars] of the longest subkey name associated with +a subkey stored in this key. + +=item MaxSubClassLen + +The length [in chars] of the longest class name associated with +a subkey stored directly in this key. + +=item MaxValNameLen + +The length [in chars] of the longest value name associated with +a value stored in this key. + +=back + +With no arguments, returns a hash [not a reference to a hash] where +the keys are the names for the items given above and the values +are the information describe above. For example: + + %info= ( "CntValues" => 25, # Key contains 25 values. + "MaxValNameLen" => 20, # One of which has a 20-char name. + "MaxValDataLen" => 42, # One of which has a 42-byte value. + "CntSubKeys" => 1, # Key has 1 immediate subkey. + "MaxSubKeyLen" => 13, # One of which has a 12-char name. + "MaxSubClassLen" => 0, # All of which have class names of "". + "SecurityLen" => 232, # One SECURITY_DESCRIPTOR is 232 bytes. + "LastWrite" => "\x90mZ\cX{\xA3\xBD\cA\c@\cA" + # Key was last modifed 1998/06/01 16:29:32 GMT + ); + +With arguments, each one must be the name of a item given above. +The return value is the information associated with the listed +names. In other words: + + return $key->Information( @names ); + +returns the same list as: + + %info= $key->Information; + return @info{@names}; + +=item Delimiter + +=item $oldDelim= $key->Delimiter + +=item $oldDelim= $key->Delimiter( $newDelim ) + +Gets and possibly changes the delimiter used for this object. The +delimiter is appended to subkey names and prepended to value names +in many return values. It is also used when parsing keys passed +to tied hashes. + +The delimiter defaults to backslash (C<'\\'>) but is inherited from +the object used to create a new object and can be specified by an +option when a new object is created. + +=item Handle + +=item $handle= $key->Handle + +Returns the raw C<HKEY> handle for the associated Registry key as +an integer value. This value can then be used to Reg*() calls +from I<Win32API::Registry>. However, it is usually easier to just +call the I<Win32API::Registry> calls directly via: + + $key->RegNotifyChangeKeyValue( ... ); + +For the virtual root of the local or a remote Registry, +C<Handle()> return C<"NONE">. + +=item Path + +=item $path= $key->Path + +Returns a string describing the path of key names to this +Registry key. The string is built so that if it were passed +to C<$Registry->Open()>, it would reopen the same Registry key +[except in the rare case where one of the key names contains +C<$key->Delimiter>]. + +=item Machine + +=item $computerName= $key->Machine + +Returns the name of the computer [or "machine"] on which this Registry +key resides. Returns C<""> for local Registry keys. + +=item Access + +Returns the numeric value of the bit mask used to specify the +types of access requested when this Registry key was opened. Can +be compared to C<KEY_*> values. + +=item OS_Delimiter + +Returns the delimiter used by the operating system's RegOpenKeyEx() +call. For Win32, this is always backslash (C<"\\">). + +=item Roots + +Returns the mapping from root key names like C<"LMachine"> to their +associated C<HKEY_*> constants. Primarily for internal use and +subject to change. + +=item Tie + +=item $key->Tie( \%hash ); + +Ties the referenced hash to that Registry key. Pretty much the +same as + + tie %hash, ref($key), $key; + +Since C<ref($key)> is the class [package] to tie the hash to and +C<TIEHASH()> just returns its argument, C<$key>, [without calling +C<new()>] when it sees that it is already a blessed object. + +=item TiedRef + +=item $TiedHashRef= $hash_or_obj_ref->TiedRef + +For a simple object, returns a reference to a hash tied to the +object. Used to promote a simple object into a combined object +and hash ref. + +If already a reference to a tied hash [that is also an object], +it just returns itself [C<$ref == $ref->TiedRef>]. + +Mostly used internally. + +=item ArrayValues + +=item $oldBool= $key->ArrayValues + +=item $oldBool= $key->ArrayValues( $newBool ) + +Gets the current setting of the C<ArrayValues> option and possibly +turns it on or off. + +When off, Registry values fetched via a tied hash are returned as +just a value scalar [the same as C<GetValue()> in a scalar context]. +When on, they are returned as a reference to an array containing +the value data as the C<[0]> element and the data type as the C<[1]> +element. + +=item TieValues + +=item $oldBool= TieValues + +=item $oldBool= TieValues( $newBool ) + +Gets the current setting of the C<TieValues> option and possibly +turns it on or off. + +Turning this option on is not yet supported in this release of +I<Win32::TieRegistry>. In a future release, turning this option +on will cause Registry values returned from a tied hash to be +a tied array that you can use to modify the value in the Registry. + +=item FastDelete + +=item $oldBool= $key->FastDelete + +=item $oldBool= $key->FastDelete( $newBool ) + +Gets the current setting of the C<FastDelete> option and possibly +turns it on or off. + +When on, successfully deleting a Registry key [via a tied hash] +simply returns C<1>. + +When off, successfully deleting a Registry key [via a tied hash +and not in a void context] returns a reference to a hash that +contains the values present in the key when it was deleted. This +hash is just like that returned when referencing the key before it +was deleted except that it is an ordinary hash, not one tied to +the I<Win32::TieRegistry> package. + +Note that deleting either a Registry key or value via a tied hash +I<in a void context> prevents any overhead in trying to build an +appropriate return value. + +Note that deleting a Registry I<value> via a tied hash [not in +a void context] returns the value data even if <FastDelete> is on. + +=item SplitMultis + +=item $oldBool= $key->SplitMultis + +=item $oldBool= $key->SplitMultis( $newBool ) + +Gets the current setting of the C<SplitMultis> option and possibly +turns it on or off. + +If on, Registry values of type C<REG_MULTI_SZ> are returned as +a reference to an array of strings. See C<GetValue()> for more +information. + +=item DWordsToHex + +=item $oldBool= $key->DWordsToHex + +=item $oldBool= $key->DWordsToHex( $newBool ) + +Gets the current setting of the C<DWordsToHex> option and possibly +turns it on or off. + +If on, Registry values of type C<REG_DWORD> are returned as a hex +string with leading C<"0x"> and longer than 4 characters. See +C<GetValue()> for more information. + +=item FixSzNulls + +=item $oldBool= $key->FixSzNulls + +=item $oldBool= $key->FixSzNulls( $newBool ) + +Gets the current setting of the C<FixSzNulls> option and possibly +turns it on or off. + +If on, Registry values of type C<REG_SZ> and C<REG_EXPAND_SZ> have +trailing C<'\0'>s added before they are set and stripped before +they are returned. See C<GetValue()> and C<SetValue()> for more +information. + +=item DualTypes + +=item $oldBool= $key->DualTypes + +=item $oldBool= $key->DualTypes( $newBool ) + +Gets the current setting of the C<DualTypes> option and possibly +turns it on or off. + +If on, data types are returned as a combined numeric/string value +holding both the numeric value of a C<REG_*> constant and the +string value of the constant's name. See C<GetValue()> for +more information. + +=item DualBinVals + +=item $oldBool= $key->DualBinVals + +=item $oldBool= $key->DualBinVals( $newBool ) + +Gets the current setting of the C<DualBinVals> option and possibly +turns it on or off. + +If on, Registry value data of type C<REG_BINARY> and no more than +4 bytes long and Registry values of type C<REG_DWORD> are returned +as a combined numeric/string value where the numeric value is the +"unpacked" binary value as returned by: + + hex reverse unpack( "h*", $valData ) + +on a "little-endian" computer. [Would be C<hex unpack("H*",$valData)> +on a "big-endian" computer if this module is ever ported to one.] + +See C<GetValue()> for more information. + +=item GetOptions + +=item @oldOptValues= $key->GetOptions( @optionNames ) + +=item $refHashOfOldOpts= $key->GetOptions() + +=item $key->GetOptions( \%hashForOldOpts ) + +Returns the current setting of any of the following options: + + Delimiter FixSzNulls DWordsToHex + ArrayValues SplitMultis DualBinVals + TieValues FastDelete DualTypes + +Pass in one or more of the above names (as strings) to get back +an array of the corresponding current settings in the same order: + + my( $fastDel, $delim )= $key->GetOptions("FastDelete","Delimiter"); + +Pass in no arguments to get back a reference to a hash where +the above option names are the keys and the values are +the corresponding current settings for each option: + + my $href= $key->GetOptions(); + my $delim= $href->{Delimiter}; + +Pass in a single reference to a hash to have the above key/value +pairs I<added> to the referenced hash. For this case, the +return value is the original object so further methods can be +chained after the call to GetOptions: + + my %oldOpts; + $key->GetOptions( \%oldOpts )->SetOptions( Delimiter => "/" ); + +=item SetOptions + +=item @oldOpts= $key->SetOptions( optNames=>$optValue,... ) + +Changes the current setting of any of the following options, +returning the previous setting(s): + + Delimiter FixSzNulls DWordsToHex AllowLoad + ArrayValues SplitMultis DualBinVals AllowSave + TieValues FastDelete DualTypes + +For C<AllowLoad> and C<AllowSave>, instead of the previous +setting, C<SetOptions> returns whether or not the change was +successful. + +In a scalar context, returns only the last item. The last +option can also be specified as C<"ref"> or C<"r"> [which doesn't +need to be followed by a value] to allow chaining: + + $key->SetOptions(AllowSave=>1,"ref")->RegSaveKey(...) + +=item SetValue + +=item $okay= $key->SetValue( $ValueName, $ValueData ); + +=item $okay= $key->SetValue( $ValueName, $ValueData, $ValueType ); + +Adds or replaces a Registry value. Returns a true value if +successfully, false otherwise. + +C<$ValueName> is the name of the value to add or replace and +should I<not> have a delimiter prepended to it. Case is ignored. + +C<$ValueType> is assumed to be C<REG_SZ> if it is omitted. Otherwise, +it should be one the C<REG_*> constants. + +C<$ValueData> is the data to be stored in the value, probably packed +into a Perl string. Other supported formats for value data are +listed below for each posible C<$ValueType>. + +=over + +=item REG_SZ or REG_EXPAND_SZ + +The only special processing for these values is the addition of +the required trailing C<'\0'> if it is missing. This can be +turned off by disabling the C<FixSzNulls> option. + +=item REG_MULTI_SZ + +These values can also be specified as a reference to a list of +strings. For example, the following two lines are equivalent: + + $key->SetValue( "Val1\000Value2\000LastVal\000\000", "REG_MULTI_SZ" ); + $key->SetValue( ["Val1","Value2","LastVal"], "REG_MULTI_SZ" ); + +Note that if the required two trailing nulls (C<"\000\000">) are +missing, then this release of C<SetValue()> will I<not> add them. + +=item REG_DWORD + +These values can also be specified as a hex value with the leading +C<"0x"> included and totaling I<more than> 4 bytes. These will be +packed into a 4-byte string via: + + $data= pack( "L", hex($data) ); + +=item REG_BINARY + +This value type is listed just to emphasize that no alternate +format is supported for it. In particular, you should I<not> pass +in a numeric value for this type of data. C<SetValue()> cannot +distinguish such from a packed string that just happens to match +a numeric value and so will treat it as a packed string. + +=back + +An alternate calling format: + + $okay= $key->SetValue( $ValueName, [ $ValueData, $ValueType ] ); + +[two arguments, the second of which is a reference to an array +containing the value data and value type] is supported to ease +using tied hashes with C<SetValue()>. + +=item CreateKey + +=item $newKey= $key->CreateKey( $subKey ); + +=item $newKey= $key->CreateKey( $subKey, { Option=>OptVal,... } ); + +Creates a Registry key or just updates attributes of one. Calls +C<RegCreateKeyEx()> then, if it succeeded, creates an object +associated with the [possibly new] subkey. + +C<$subKey> is the name of a subkey [or a path to one] to be +created or updated. It can also be a reference to an array +containing a list of subkey names. + +The second argument, if it exists, should be a reference to a +hash specifying options either to be passed to C<RegCreateKeyEx()> +or to be used when creating the associated object. The following +items are the supported keys for this options hash: + +=over + +=item Delimiter + +Specifies the delimiter to be used to parse C<$subKey> and to be +used in the new object. Defaults to C<$key->Delimiter>. + +=item Access + +Specifies the types of access requested when the subkey is opened. +Should be a numeric bit mask that combines one or more C<KEY_*> +constant values. + +=item Class + +The name to assign as the class of the new or updated subkey. +Defaults to C<""> as we have never seen a use for this information. + +=item Disposition + +Lets you specify a reference to a scalar where, upon success, will be +stored either C<REG_CREATED_NEW_KEY()> or C<REG_OPENED_EXISTING_KEY()> +depending on whether a new key was created or an existing key was +opened. + +If you, for example, did C<use Win32::TieRegistry qw(REG_CREATED_NEW_KEY)> +then you can use C<REG_CREATED_NEW_KEY()> to compare against the numeric +value stored in the referenced scalar. + +If the C<DualTypes> option is enabled, then in addition to the +numeric value described above, the referenced scalar will also +have a string value equal to either C<"REG_CREATED_NEW_KEY"> or +C<"REG_OPENED_EXISTING_KEY">, as appropriate. + +=item Security + +Lets you specify a C<SECURITY_ATTRIBUTES> structure packed into a +Perl string. See C<Win32API::Registry::RegCreateKeyEx()> for more +information. + +=item Volatile + +If true, specifies that the new key should be volatile, that is, +stored only in memory and not backed by a hive file [and not saved +if the computer is rebooted]. This option is ignored under +Windows 95. Specifying C<Volatile=E<gt>1> is the same as +specifying C<Options=E<gt>REG_OPTION_VOLATILE>. + +=item Backup + +If true, specifies that the new key should be opened for +backup/restore access. The C<Access> option is ignored. If the +calling process has enabled C<"SeBackupPrivilege">, then the +subkey is opened with C<KEY_READ> access as the C<"LocalSystem"> +user which should have access to all subkeys. If the calling +process has enabled C<"SeRestorePrivilege">, then the subkey is +opened with C<KEY_WRITE> access as the C<"LocalSystem"> user which +should have access to all subkeys. + +This option is ignored under Windows 95. Specifying C<Backup=E<gt>1> +is the same as specifying C<Options=E<gt>REG_OPTION_BACKUP_RESTORE>. + +=item Options + +Lets you specify options to the C<RegOpenKeyEx()> call. The value +for this option should be a numeric value combining zero or more +of the C<REG_OPTION_*> bit masks. You may with to used the +C<Volatile> and/or C<Backup> options instead of this one. + +=back + +=item StoreKey + +=item $newKey= $key->StoreKey( $subKey, \%Contents ); + +Primarily for internal use. + +Used to create or update a Registry key and any number of subkeys +or values under it or its subkeys. + +C<$subKey> is the name of a subkey to be created [or a path of +subkey names separated by delimiters]. If that subkey already +exists, then it is updated. + +C<\%Contents> is a reference to a hash containing pairs of +value names with value data and/or subkey names with hash +references similar to C<\%Contents>. Each of these cause +a value or subkey of C<$subKey> to be created or updated. + +If C<$Contents{""}> exists and is a reference to a hash, then +it used as the options argument when C<CreateKey()> is called +for C<$subKey>. This allows you to specify ... + + if( defined( $$data{""} ) && "HASH" eq ref($$data{""}) ) { + $self= $this->CreateKey( $subKey, delete $$data{""} ); + +=item Load + +=item $newKey= $key->Load( $file ) + +=item $newKey= $key->Load( $file, $newSubKey ) + +=item $newKey= $key->Load( $file, $newSubKey, { Option=>OptVal... } ) + +=item $newKey= $key->Load( $file, { Option=>OptVal... } ) + +Loads a hive file into a Registry. That is, creates a new subkey +and associates a hive file with it. + +C<$file> is a hive file, that is a file created by calling +C<RegSaveKey()>. The C<$file> path is interpreted relative to +C<%SystemRoot%/System32/config> on the machine where C<$key> +resides. + +C<$newSubKey> is the name to be given to the new subkey. If +C<$newSubKey> is specified, then C<$key> must be +C<HKEY_LOCAL_MACHINE> or C<HKEY_USERS> of the local computer +or a remote computer and C<$newSubKey> should not contain any +occurrences of either the delimiter or the OS delimiter. + +If C<$newSubKey> is not specified, then it is as if C<$key> +was C<$Registry-E<gt>{LMachine}> and C<$newSubKey> is +C<"PerlTie:999"> where C<"999"> is actually a sequence number +incremented each time this process calls C<Load()>. + +You can specify as the last argument a reference to a hash +containing options. You can specify the same options that you +can specify to C<Open()>. See C<Open()> for more information on +those. In addition, you can specify the option C<"NewSubKey">. +The value of this option is interpretted exactly as if it was +specified as the C<$newSubKey> parameter and overrides the +C<$newSubKey> if one was specified. + +The hive is automatically unloaded when the returned object +[C<$newKey>] is destroyed. Registry key objects opened within +the hive will keep a reference to the C<$newKey> object so that +it will not be destroyed before these keys are closed. + +=item UnLoad + +=item $okay= $key->UnLoad + +Unloads a hive that was loaded via C<Load()>. Cannot unload other +hives. C<$key> must be the return from a previous call to C<Load()>. +C<$key> is closed and then the hive is unloaded. + +=item AllowSave + +=item $okay= AllowSave( $bool ) + +Enables or disables the C<"ReBackupPrivilege"> privilege for the +current process. You will probably have to enable this privilege +before you can use C<RegSaveKey()>. + +The return value indicates whether the operation succeeded, not +whether the privilege was previously enabled. + +=item AllowLoad + +=item $okay= AllowLoad( $bool ) + +Enables or disables the C<"ReRestorePrivilege"> privilege for the +current process. You will probably have to enable this privilege +before you can use C<RegLoadKey()>, C<RegUnLoadKey()>, +C<RegReplaceKey()>, or C<RegRestoreKey> and thus C<Load()> and +C<UnLoad()>. + +The return value indicates whether the operation succeeded, not +whether the privilege was previously enabled. + +=back + +=head2 Exports [C<use> and C<import()>] + +To have nothing imported into your package, use something like: + + use Win32::TieRegistry 0.20 (); + +which would verify that you have at least version 0.20 but wouldn't +call C<import()>. The F<Changes> file can be useful in figuring out +which, if any, prior versions of I<Win32::TieRegistry> you want to +support in your script. + +The code + + use Win32::TieRegistry; + +imports the variable C<$Registry> into your package and sets it +to be a reference to a hash tied to a copy of the master Registry +virtual root object with the default options. One disadvantage +to this "default" usage is that Perl does not support checking +the module version when you use it. + +Alternately, you can specify a list of arguments on the C<use> +line that will be passed to the C<Win32::TieRegistry->import()> +method to control what items to import into your package. These +arguments fall into the following broad categories: + +=over + +=item Import a reference to a hash tied to a Registry virtual root + +You can request that a scalar variable be imported (possibly) +and set to be a reference to a hash tied to a Registry virtual root +using any of the following types of arguments or argument pairs: + +=over + +=item "TiedRef", '$scalar' + +=item "TiedRef", '$pack::scalar' + +=item "TiedRef", 'scalar' + +=item "TiedRef", 'pack::scalar' + +All of the above import a scalar named C<$scalar> into your package +(or the package named "pack") and then sets it. + +=item '$scalar' + +=item '$pack::scalar' + +These are equivalent to the previous items to support a more +traditional appearance to the list of exports. Note that the +scalar name cannot be "RegObj" here. + +=item "TiedRef", \$scalar + +=item \$scalar + +These versions don't import anything but set the referenced C<$scalar>. + +=back + +=item Import a hash tied to the Registry virtual root + +You can request that a hash variable be imported (possibly) +and tied to a Registry virtual root using any of the following +types of arguments or argument pairs: + +=over + +=item "TiedHash", '%hash' + +=item "TiedHash", '%pack::hash' + +=item "TiedHash", 'hash' + +=item "TiedHash", 'pack::hash' + +All of the above import a hash named C<%hash> into your package +(or the package named "pack") and then sets it. + +=item '%hash' + +=item '%pack::hash' + +These are equivalent to the previous items to support a more +traditional appearance to the list of exports. + +=item "TiedHash", \%hash + +=item \%hash + +These versions don't import anything but set the referenced C<%hash>. + +=back + +=item Import a Registry virtual root object + +You can request that a scalar variable be imported (possibly) +and set to be a Registry virtual root object using any of the +following types of arguments or argument pairs: + +=over + +=item "ObjectRef", '$scalar' + +=item "ObjectRef", '$pack::scalar' + +=item "ObjectRef", 'scalar' + +=item "ObjectRef", 'pack::scalar' + +All of the above import a scalar named C<$scalar> into your package +(or the package named "pack") and then sets it. + +=item '$RegObj' + +This is equivalent to the previous items for backward compatibility. + +=item "ObjectRef", \$scalar + +This version doesn't import anything but sets the referenced C<$scalar>. + +=back + +=item Import constant(s) exported by I<Win32API::Registry> + +You can list any constants that are exported by I<Win32API::Registry> +to have them imported into your package. These constants have names +starting with "KEY_" or "REG_" (or even "HKEY_"). + +You can also specify C<":KEY_">, C<":REG_">, and even C<":HKEY_"> to +import a whole set of constants. + +See I<Win32API::Registry> documentation for more information. + +=item Options + +You can list any option names that can be listed in the C<SetOptions()> +method call, each folowed by the value to use for that option. +A Registry virtual root object is created, all of these options are +set for it, then each variable to be imported/set is associated with +this object. + +In addition, the following special options are supported: + +=over + +=item ExportLevel + +Whether to import variables into your package or some +package that uses your package. Defaults to the value of +C<$Exporter::ExportLevel> and has the same meaning. See +the L<Exporter> module for more information. + +=item ExportTo + +The name of the package to import variables and constants into. +Overrides I<ExportLevel>. + +=back + +=back + +=head3 Specifying constants in your Perl code + +This module was written with a strong emphasis on the convenience of +the module user. Therefore, most places where you can specify a +constant like C<REG_SZ()> also allow you to specify a string +containing the name of the constant, C<"REG_SZ">. This is convenient +because you may not have imported that symbolic constant. + +Perl also emphasizes programmer convenience so the code C<REG_SZ> +can be used to mean C<REG_SZ()> or C<"REG_SZ"> or be illegal. +Note that using C<®_SZ> (as we've seen in much Win32 Perl code) +is not a good idea since it passes the current C<@_> to the +C<constant()> routine of the module which, at the least, can give +you a warning under B<-w>. + +Although greatly a matter of style, the "safest" practice is probably +to specifically list all constants in the C<use Win32::TieRegistry> +statement, specify C<use strict> [or at least C<use strict qw(subs)>], +and use bare constant names when you want the numeric value. This will +detect mispelled constant names at compile time. + + use strict; + my $Registry; + use Win32::TieRegistry 0.20 ( + TiedRef => \$Registry, Delimiter => "/", ArrayValues => 1, + SplitMultis => 1, AllowLoad => 1, + qw( REG_SZ REG_EXPAND_SZ REG_DWORD REG_BINARY REG_MULTI_SZ + KEY_READ KEY_WRITE KEY_ALL_ACCESS ), + ); + $Registry->{"LMachine/Software/FooCorp/"}= { + "FooWriter/" => { + "/Fonts" => [ ["Times","Courier","Lucinda"], REG_MULTI_SZ ], + "/WindowSize" => [ pack("LL",24,80), REG_BINARY ], + "/TaskBarIcon" => [ "0x0001", REG_DWORD ], + }, + } or die "Can't create Software/FooCorp/: $^E\n"; + +If you don't want to C<use strict qw(subs)>, the second safest practice +is similar to the above but use the C<REG_SZ()> form for constants +when possible and quoted constant names when required. Note that +C<qw()> is a form of quoting. + + use Win32::TieRegistry 0.20 qw( + TiedRef $Registry + Delimiter / ArrayValues 1 SplitMultis 1 AllowLoad 1 + REG_SZ REG_EXPAND_SZ REG_DWORD REG_BINARY REG_MULTI_SZ + KEY_READ KEY_WRITE KEY_ALL_ACCESS + ); + $Registry->{"LMachine/Software/FooCorp/"}= { + "FooWriter/" => { + "/Fonts" => [ ["Times","Courier","Lucinda"], REG_MULTI_SZ() ], + "/WindowSize" => [ pack("LL",24,80), REG_BINARY() ], + "/TaskBarIcon" => [ "0x0001", REG_DWORD() ], + }, + } or die "Can't create Software/FooCorp/: $^E\n"; + +The examples in this document mostly use quoted constant names +(C<"REG_SZ">) since that works regardless of which constants +you imported and whether or not you have C<use strict> in your +script. It is not the best choice for you to use for real +scripts (vs. examples) because it is less efficient and is not +supported by most other similar modules. + +=head1 SUMMARY + +Most things can be done most easily via tied hashes. Skip down to the +the L<Tied Hashes Summary> to get started quickly. + +=head2 Objects Summary + +Here are quick examples that document the most common functionality +of all of the method functions [except for a few almost useless ones]. + + # Just another way of saying Open(): + $key= new Win32::TieRegistry "LMachine\\Software\\", + { Access=>KEY_READ()|KEY_WRITE(), Delimiter=>"\\" }; + + # Open a Registry key: + $subKey= $key->Open( "SubKey/SubSubKey/", + { Access=>KEY_ALL_ACCESS, Delimiter=>"/" } ); + + # Connect to a remote Registry key: + $remKey= $Registry->Connect( "MachineName", "LMachine/", + { Access=>KEY_READ, Delimiter=>"/" } ); + + # Get value data: + $valueString= $key->GetValue("ValueName"); + ( $valueString, $valueType )= $key->GetValue("ValueName"); + + # Get list of value names: + @valueNames= $key->ValueNames; + + # Get list of subkey names: + @subKeyNames= $key->SubKeyNames; + + # Get combined list of value names (with leading delimiters) + # and subkey names (with trailing delimiters): + @memberNames= $key->MemberNames; + + # Get all information about a key: + %keyInfo= $key->Information; + # keys(%keyInfo)= qw( Class LastWrite SecurityLen + # CntSubKeys MaxSubKeyLen MaxSubClassLen + # CntValues MaxValNameLen MaxValDataLen ); + + # Get selected information about a key: + ( $class, $cntSubKeys )= $key->Information( "Class", "CntSubKeys" ); + + # Get and/or set delimiter: + $delim= $key->Delimiter; + $oldDelim= $key->Delimiter( $newDelim ); + + # Get "path" for an open key: + $path= $key->Path; + # For example, "/CUser/Control Panel/Mouse/" + # or "//HostName/LMachine/System/DISK/". + + # Get name of machine where key is from: + $mach= $key->Machine; + # Will usually be "" indicating key is on local machine. + + # Control different options (see main documentation for descriptions): + $oldBool= $key->ArrayValues( $newBool ); + $oldBool= $key->FastDelete( $newBool ); + $oldBool= $key->FixSzNulls( $newBool ); + $oldBool= $key->SplitMultis( $newBool ); + $oldBool= $key->DWordsToHex( $newBool ); + $oldBool= $key->DualBinVals( $newBool ); + $oldBool= $key->DualTypes( $newBool ); + @oldBools= $key->SetOptions( ArrayValues=>1, FastDelete=>1, FixSzNulls=>0, + Delimiter=>"/", AllowLoad=>1, AllowSave=>1 ); + @oldBools= $key->GetOptions( ArrayValues, FastDelete, FixSzNulls ); + + # Add or set a value: + $key->SetValue( "ValueName", $valueDataString ); + $key->SetValue( "ValueName", pack($format,$valueData), "REG_BINARY" ); + + # Add or set a key: + $key->CreateKey( "SubKeyName" ); + $key->CreateKey( "SubKeyName", + { Access=>"KEY_ALL_ACCESS", Class=>"ClassName", + Delimiter=>"/", Volatile=>1, Backup=>1 } ); + + # Load an off-line Registry hive file into the on-line Registry: + $newKey= $Registry->Load( "C:/Path/To/Hive/FileName" ); + $newKey= $key->Load( "C:/Path/To/Hive/FileName", "NewSubKeyName", + { Access=>"KEY_READ" } ); + # Unload a Registry hive file loaded via the Load() method: + $newKey->UnLoad; + + # (Dis)Allow yourself to load Registry hive files: + $success= $Registry->AllowLoad( $bool ); + + # (Dis)Allow yourself to save a Registry key to a hive file: + $success= $Registry->AllowSave( $bool ); + + # Save a Registry key to a new hive file: + $key->RegSaveKey( "C:/Path/To/Hive/FileName", [] ); + +=head3 Other Useful Methods + +See I<Win32API::Registry> for more information on these methods. +These methods are provided for coding convenience and are +identical to the I<Win32API::Registry> functions except that these +don't take a handle to a Registry key, instead getting the handle +from the invoking object [C<$key>]. + + $key->RegGetKeySecurity( $iSecInfo, $sSecDesc, $lenSecDesc ); + $key->RegLoadKey( $sSubKeyName, $sPathToFile ); + $key->RegNotifyChangeKeyValue( + $bWatchSubtree, $iNotifyFilter, $hEvent, $bAsync ); + $key->RegQueryMultipleValues( + $structValueEnts, $cntValueEnts, $Buffer, $lenBuffer ); + $key->RegReplaceKey( $sSubKeyName, $sPathToNewFile, $sPathToBackupFile ); + $key->RegRestoreKey( $sPathToFile, $iFlags ); + $key->RegSetKeySecurity( $iSecInfo, $sSecDesc ); + $key->RegUnLoadKey( $sSubKeyName ); + +=head2 Tied Hashes Summary + +For fast learners, this may be the only section you need to read. +Always append one delimiter to the end of each Registry key name +and prepend one delimiter to the front of each Registry value name. + +=head3 Opening keys + + use Win32::TieRegistry ( Delimiter=>"/", ArrayValues=>1 ); + $Registry->Delimiter("/"); # Set delimiter to "/". + $swKey= $Registry->{"LMachine/Software/"}; + $winKey= $swKey->{"Microsoft/Windows/CurrentVersion/"}; + $userKey= $Registry-> + {"CUser/Software/Microsoft/Windows/CurrentVersion/"}; + $remoteKey= $Registry->{"//HostName/LMachine/"}; + +=head3 Reading values + + $progDir= $winKey->{"/ProgramFilesDir"}; # "C:\\Program Files" + $tip21= $winKey->{"Explorer/Tips//21"}; # Text of tip #21. + + $winKey->ArrayValues(1); + ( $devPath, $type )= $winKey->{"/DevicePath"}; + # $devPath eq "%SystemRoot%\\inf" + # $type eq "REG_EXPAND_SZ" [if you have SetDualVar.pm installed] + # $type == REG_EXPAND_SZ() [if did C<use Win32::TieRegistry qw(:REG_)>] + +=head3 Setting values + + $winKey->{"Setup//SourcePath"}= "\\\\SwServer\\SwShare\\Windows"; + # Simple. Assumes data type of REG_SZ. + + $winKey->{"Setup//Installation Sources"}= + [ "D:\x00\\\\SwServer\\SwShare\\Windows\0\0", "REG_MULTI_SZ" ]; + # "\x00" and "\0" used to mark ends of each string and end of list. + + $winKey->{"Setup//Installation Sources"}= + [ ["D:","\\\\SwServer\\SwShare\\Windows"], "REG_MULTI_SZ" ]; + # Alternate method that is easier to read. + + $userKey->{"Explorer/Tips//DisplayInitialTipWindow"}= + [ pack("L",0), "REG_DWORD" ]; + $userKey->{"Explorer/Tips//Next"}= [ pack("S",3), "REG_BINARY" ]; + $userKey->{"Explorer/Tips//Show"}= [ pack("L",0), "REG_BINARY" ]; + +=head3 Adding keys + + $swKey->{"FooCorp/"}= { + "FooWriter/" => { + "/Version" => "4.032", + "Startup/" => { + "/Title" => "Foo Writer Deluxe ][", + "/WindowSize" => [ pack("LL",$wid,$ht), "REG_BINARY" ], + "/TaskBarIcon" => [ "0x0001", "REG_DWORD" ], + }, + "Compatibility/" => { + "/AutoConvert" => "Always", + "/Default Palette" => "Windows Colors", + }, + }, + "/License", => "0123-9C8EF1-09-FC", + }; + +=head3 Listing all subkeys and values + + @members= keys( %{$swKey} ); + @subKeys= grep( m#^/#, keys( %{$swKey->{"Classes/batfile/"}} ) ); + # @subKeys= ( "/", "/EditFlags" ); + @valueNames= grep( ! m#^/#, keys( %{$swKey->{"Classes/batfile/"}} ) ); + # @valueNames= ( "DefaultIcon/", "shell/", "shellex/" ); + +=head3 Deleting values or keys with no subkeys + + $oldValue= delete $userKey->{"Explorer/Tips//Next"}; + + $oldValues= delete $userKey->{"Explorer/Tips/"}; + # $oldValues will be reference to hash containing deleted keys values. + +=head3 Closing keys + + undef $swKey; # Explicit way to close a key. + $winKey= "Anything else"; # Implicitly closes a key. + exit 0; # Implicitly closes all keys. + +=head2 Tie::Registry + +This module was originally called I<Tie::Registry>. Changing code +that used I<Tie::Registry> over to I<Win32::TieRegistry> is trivial +as the module name should only be mentioned once, in the C<use> +line. However, finding all of the places that used I<Tie::Registry> +may not be completely trivial so we have included F<Tie/Registry.pm> +which you can install to provide backward compatibility. + +=head1 AUTHOR + +Tye McQueen. See http://www.metronet.com/~tye/ or e-mail +tye@metronet.com with bug reports. + +=head1 SEE ALSO + +I<Win32API::Registry> - Provides access to C<Reg*()>, C<HKEY_*>, +C<KEY_*>, C<REG_*> [required]. + +I<Win32::WinError> - Defines C<ERROR_*> values [optional]. + +L<SetDualVar> - For returning C<REG_*> values as combined +string/integer values [optional]. + +=head1 BUGS + +Perl5.004_02 has bugs that make I<Win32::TieRegistry> fail in +strange and subtle ways. + +Using I<Win32::TieRegistry> with versions of Perl prior to 5.005 +can be tricky or impossible. Most notes about this have been +removed from the documentation (they get rather complicated +and confusing). This includes references to C<$^E> perhaps not +being meaningful. + +Because Perl hashes are case sensitive, certain lookups are also +case sensistive. In particular, the root keys ("Classes", "CUser", +"LMachine", "Users", "PerfData", "CConfig", "DynData", and HKEY_*) +must always be entered without changing between upper and lower +case letters. Also, the special rule for matching subkey names +that contain the user-selected delimiter only works if case is +matched. All other key name and value name lookups should be case +insensitive because the underlying Reg*() calls ignore case. + +Information about each key is cached when using a tied hash. +This cache is not flushed nor updated when changes are made, +I<even when the same tied hash is used> to make the changes. + +Current implementations of Perl's "global destruction" phase can +cause objects returned by C<Load()> to be destroyed while keys +within the hive are still open, if the objects still exist when +the script starts to exit. When this happens, the automatic +C<UnLoad()> will report a failure and the hive will remain loaded +in the Registry. + +Trying to C<Load()> a hive file that is located on a remote network +share may silently delete all data from the hive. This is a bug +in the Win32 APIs, not any Perl code or modules. This module does +not try to protect you from this bug. + +There is no test suite. + +=head1 FUTURE DIRECTIONS + +The following items are desired by the author and may appear in a +future release of this module. + +=over + +=item TieValues option + +Currently described in main documentation but no yet implemented. + +=item AutoRefresh option + +Trigger use of C<RegNotifyChangeKeyValue()> to keep tied hash +caches up-to-date even when other programs make changes. + +=item Error options + +Allow the user to have unchecked calls (calls in a "void context") +to automatically report errors via C<warn> or C<die>. + +For complex operations, such a copying an entire subtree, provide +access to detailed information about errors (and perhaps some +warnings) that were encountered. Let the user control whether +the complex operation continues in spite of errors. + +=back + +=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/Master/tlpkg/tlperl/lib/Win32/WinError.pm b/Master/tlpkg/tlperl/lib/Win32/WinError.pm new file mode 100755 index 00000000000..4ea0091685d --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Win32/WinError.pm @@ -0,0 +1,1017 @@ +package Win32::WinError; + +require Exporter; +require DynaLoader; + +$VERSION = '0.03'; + +@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__ |