diff options
author | Siep Kroonenberg <siepo@cybercomm.nl> | 2011-04-24 16:09:50 +0000 |
---|---|---|
committer | Siep Kroonenberg <siepo@cybercomm.nl> | 2011-04-24 16:09:50 +0000 |
commit | be4bfe8362d7eec07140f543f8d44120395de88b (patch) | |
tree | 5319d8f2eb70aee0c9767da1162f3f4beeb455bd /Master/tlpkg/tlperl0/lib/Win32 | |
parent | 9d5bc14f41bbd9219da5d024b1d6a164b51c8525 (diff) |
2nd try to remove old tlperl0
git-svn-id: svn://tug.org/texlive/trunk@22185 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/tlperl0/lib/Win32')
39 files changed, 0 insertions, 10981 deletions
diff --git a/Master/tlpkg/tlperl0/lib/Win32/API.pm b/Master/tlpkg/tlperl0/lib/Win32/API.pm deleted file mode 100755 index 365ce6b46c5..00000000000 --- a/Master/tlpkg/tlperl0/lib/Win32/API.pm +++ /dev/null @@ -1,778 +0,0 @@ -# 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/tlperl0/lib/Win32/API/Callback.pm b/Master/tlpkg/tlperl0/lib/Win32/API/Callback.pm deleted file mode 100755 index df15786591b..00000000000 --- a/Master/tlpkg/tlperl0/lib/Win32/API/Callback.pm +++ /dev/null @@ -1,174 +0,0 @@ -# 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/tlperl0/lib/Win32/API/Struct.pm b/Master/tlpkg/tlperl0/lib/Win32/API/Struct.pm deleted file mode 100755 index 9f706671a77..00000000000 --- a/Master/tlpkg/tlperl0/lib/Win32/API/Struct.pm +++ /dev/null @@ -1,532 +0,0 @@ -package Win32::API::Struct; - -# See the bottom of this file for the POD documentation. Search for the -# string '=head'. - -####################################################################### -# -# Win32::API::Struct - Perl Win32 API struct Facility -# -# Author: Aldo Calpini <dada@perl.it> -# Maintainer: Cosimo Streppone <cosimo@cpan.org> -# -# $Id: Struct.pm 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/tlperl0/lib/Win32/API/Test.pm b/Master/tlpkg/tlperl0/lib/Win32/API/Test.pm deleted file mode 100755 index 0b21ced6927..00000000000 --- a/Master/tlpkg/tlperl0/lib/Win32/API/Test.pm +++ /dev/null @@ -1,111 +0,0 @@ -# -# 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/tlperl0/lib/Win32/API/Type.pm b/Master/tlpkg/tlperl0/lib/Win32/API/Type.pm deleted file mode 100755 index 48f0ce1a32f..00000000000 --- a/Master/tlpkg/tlperl0/lib/Win32/API/Type.pm +++ /dev/null @@ -1,453 +0,0 @@ -package Win32::API::Type; - -# See the bottom of this file for the POD documentation. Search for the -# string '=head'. - -####################################################################### -# -# Win32::API::Type - Perl Win32 API type definitions -# -# Author: Aldo Calpini <dada@perl.it> -# Maintainer: Cosimo Streppone <cosimo@cpan.org> -# -# $Id: Type.pm 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/tlperl0/lib/Win32/DBIODBC.pm b/Master/tlpkg/tlperl0/lib/Win32/DBIODBC.pm deleted file mode 100755 index e3262c09d99..00000000000 --- a/Master/tlpkg/tlperl0/lib/Win32/DBIODBC.pm +++ /dev/null @@ -1,248 +0,0 @@ -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/tlperl0/lib/Win32/EventLog.pm b/Master/tlpkg/tlperl0/lib/Win32/EventLog.pm deleted file mode 100755 index bf840723a6a..00000000000 --- a/Master/tlpkg/tlperl0/lib/Win32/EventLog.pm +++ /dev/null @@ -1,471 +0,0 @@ -# -# 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/tlperl0/lib/Win32/Exe.pm b/Master/tlpkg/tlperl0/lib/Win32/Exe.pm deleted file mode 100755 index 023946025c7..00000000000 --- a/Master/tlpkg/tlperl0/lib/Win32/Exe.pm +++ /dev/null @@ -1,308 +0,0 @@ -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/tlperl0/lib/Win32/Exe/Base.pm b/Master/tlpkg/tlperl0/lib/Win32/Exe/Base.pm deleted file mode 100755 index a90ec19c451..00000000000 --- a/Master/tlpkg/tlperl0/lib/Win32/Exe/Base.pm +++ /dev/null @@ -1,35 +0,0 @@ -# $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/tlperl0/lib/Win32/Exe/DataDirectory.pm b/Master/tlpkg/tlperl0/lib/Win32/Exe/DataDirectory.pm deleted file mode 100755 index e544ed372a3..00000000000 --- a/Master/tlpkg/tlperl0/lib/Win32/Exe/DataDirectory.pm +++ /dev/null @@ -1,13 +0,0 @@ -# $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/tlperl0/lib/Win32/Exe/DebugDirectory.pm b/Master/tlpkg/tlperl0/lib/Win32/Exe/DebugDirectory.pm deleted file mode 100755 index f87cc0062be..00000000000 --- a/Master/tlpkg/tlperl0/lib/Win32/Exe/DebugDirectory.pm +++ /dev/null @@ -1,19 +0,0 @@ -# $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/tlperl0/lib/Win32/Exe/DebugTable.pm b/Master/tlpkg/tlperl0/lib/Win32/Exe/DebugTable.pm deleted file mode 100755 index c861ee2397b..00000000000 --- a/Master/tlpkg/tlperl0/lib/Win32/Exe/DebugTable.pm +++ /dev/null @@ -1,12 +0,0 @@ -# $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/tlperl0/lib/Win32/Exe/IconFile.pm b/Master/tlpkg/tlperl0/lib/Win32/Exe/IconFile.pm deleted file mode 100755 index 8c24160951d..00000000000 --- a/Master/tlpkg/tlperl0/lib/Win32/Exe/IconFile.pm +++ /dev/null @@ -1,60 +0,0 @@ -# $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/tlperl0/lib/Win32/Exe/PE.pm b/Master/tlpkg/tlperl0/lib/Win32/Exe/PE.pm deleted file mode 100755 index 55251562786..00000000000 --- a/Master/tlpkg/tlperl0/lib/Win32/Exe/PE.pm +++ /dev/null @@ -1,24 +0,0 @@ -# $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/tlperl0/lib/Win32/Exe/PE/Header.pm b/Master/tlpkg/tlperl0/lib/Win32/Exe/PE/Header.pm deleted file mode 100755 index 03888fedbd8..00000000000 --- a/Master/tlpkg/tlperl0/lib/Win32/Exe/PE/Header.pm +++ /dev/null @@ -1,26 +0,0 @@ -# $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/tlperl0/lib/Win32/Exe/PE/Header/PE32.pm b/Master/tlpkg/tlperl0/lib/Win32/Exe/PE/Header/PE32.pm deleted file mode 100755 index ad8e641f40b..00000000000 --- a/Master/tlpkg/tlperl0/lib/Win32/Exe/PE/Header/PE32.pm +++ /dev/null @@ -1,69 +0,0 @@ -# $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/tlperl0/lib/Win32/Exe/Resource.pm b/Master/tlpkg/tlperl0/lib/Win32/Exe/Resource.pm deleted file mode 100755 index 433be495ea6..00000000000 --- a/Master/tlpkg/tlperl0/lib/Win32/Exe/Resource.pm +++ /dev/null @@ -1,38 +0,0 @@ -# $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/tlperl0/lib/Win32/Exe/Resource/GroupIcon.pm b/Master/tlpkg/tlperl0/lib/Win32/Exe/Resource/GroupIcon.pm deleted file mode 100755 index c2349ec7383..00000000000 --- a/Master/tlpkg/tlperl0/lib/Win32/Exe/Resource/GroupIcon.pm +++ /dev/null @@ -1,57 +0,0 @@ -# $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/tlperl0/lib/Win32/Exe/Resource/Icon.pm b/Master/tlpkg/tlperl0/lib/Win32/Exe/Resource/Icon.pm deleted file mode 100755 index a6b5348acbf..00000000000 --- a/Master/tlpkg/tlperl0/lib/Win32/Exe/Resource/Icon.pm +++ /dev/null @@ -1,54 +0,0 @@ -# $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/tlperl0/lib/Win32/Exe/Resource/Manifest.pm b/Master/tlpkg/tlperl0/lib/Win32/Exe/Resource/Manifest.pm deleted file mode 100755 index 28d6ecaeff4..00000000000 --- a/Master/tlpkg/tlperl0/lib/Win32/Exe/Resource/Manifest.pm +++ /dev/null @@ -1,60 +0,0 @@ -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/tlperl0/lib/Win32/Exe/Resource/Version.pm b/Master/tlpkg/tlperl0/lib/Win32/Exe/Resource/Version.pm deleted file mode 100755 index 98adfbb9b22..00000000000 --- a/Master/tlpkg/tlperl0/lib/Win32/Exe/Resource/Version.pm +++ /dev/null @@ -1,364 +0,0 @@ -# $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/tlperl0/lib/Win32/Exe/ResourceData.pm b/Master/tlpkg/tlperl0/lib/Win32/Exe/ResourceData.pm deleted file mode 100755 index b33647d519c..00000000000 --- a/Master/tlpkg/tlperl0/lib/Win32/Exe/ResourceData.pm +++ /dev/null @@ -1,58 +0,0 @@ -# $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/tlperl0/lib/Win32/Exe/ResourceEntry.pm b/Master/tlpkg/tlperl0/lib/Win32/Exe/ResourceEntry.pm deleted file mode 100755 index a44a65daf3d..00000000000 --- a/Master/tlpkg/tlperl0/lib/Win32/Exe/ResourceEntry.pm +++ /dev/null @@ -1,69 +0,0 @@ -# $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/tlperl0/lib/Win32/Exe/ResourceEntry/Id.pm b/Master/tlpkg/tlperl0/lib/Win32/Exe/ResourceEntry/Id.pm deleted file mode 100755 index 39e35b4000d..00000000000 --- a/Master/tlpkg/tlperl0/lib/Win32/Exe/ResourceEntry/Id.pm +++ /dev/null @@ -1,47 +0,0 @@ -# $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/tlperl0/lib/Win32/Exe/ResourceEntry/Name.pm b/Master/tlpkg/tlperl0/lib/Win32/Exe/ResourceEntry/Name.pm deleted file mode 100755 index 8f6cd1d8784..00000000000 --- a/Master/tlpkg/tlperl0/lib/Win32/Exe/ResourceEntry/Name.pm +++ /dev/null @@ -1,42 +0,0 @@ -# $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/tlperl0/lib/Win32/Exe/ResourceTable.pm b/Master/tlpkg/tlperl0/lib/Win32/Exe/ResourceTable.pm deleted file mode 100755 index 7fe9fa1d5dd..00000000000 --- a/Master/tlpkg/tlperl0/lib/Win32/Exe/ResourceTable.pm +++ /dev/null @@ -1,35 +0,0 @@ -# $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/tlperl0/lib/Win32/Exe/Section.pm b/Master/tlpkg/tlperl0/lib/Win32/Exe/Section.pm deleted file mode 100755 index d08f91590f7..00000000000 --- a/Master/tlpkg/tlperl0/lib/Win32/Exe/Section.pm +++ /dev/null @@ -1,154 +0,0 @@ -# $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/tlperl0/lib/Win32/Exe/Section/Code.pm b/Master/tlpkg/tlperl0/lib/Win32/Exe/Section/Code.pm deleted file mode 100755 index 726707c3064..00000000000 --- a/Master/tlpkg/tlperl0/lib/Win32/Exe/Section/Code.pm +++ /dev/null @@ -1,9 +0,0 @@ -# $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/tlperl0/lib/Win32/Exe/Section/Data.pm b/Master/tlpkg/tlperl0/lib/Win32/Exe/Section/Data.pm deleted file mode 100755 index 033d8f504e3..00000000000 --- a/Master/tlpkg/tlperl0/lib/Win32/Exe/Section/Data.pm +++ /dev/null @@ -1,9 +0,0 @@ -# $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/tlperl0/lib/Win32/Exe/Section/Debug.pm b/Master/tlpkg/tlperl0/lib/Win32/Exe/Section/Debug.pm deleted file mode 100755 index e59ac4b3287..00000000000 --- a/Master/tlpkg/tlperl0/lib/Win32/Exe/Section/Debug.pm +++ /dev/null @@ -1,9 +0,0 @@ -# $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/tlperl0/lib/Win32/Exe/Section/Exports.pm b/Master/tlpkg/tlperl0/lib/Win32/Exe/Section/Exports.pm deleted file mode 100755 index 9d1d5117555..00000000000 --- a/Master/tlpkg/tlperl0/lib/Win32/Exe/Section/Exports.pm +++ /dev/null @@ -1,9 +0,0 @@ -# $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/tlperl0/lib/Win32/Exe/Section/Imports.pm b/Master/tlpkg/tlperl0/lib/Win32/Exe/Section/Imports.pm deleted file mode 100755 index e736a043f15..00000000000 --- a/Master/tlpkg/tlperl0/lib/Win32/Exe/Section/Imports.pm +++ /dev/null @@ -1,9 +0,0 @@ -# $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/tlperl0/lib/Win32/Exe/Section/Resources.pm b/Master/tlpkg/tlperl0/lib/Win32/Exe/Section/Resources.pm deleted file mode 100755 index afbc41e7309..00000000000 --- a/Master/tlpkg/tlperl0/lib/Win32/Exe/Section/Resources.pm +++ /dev/null @@ -1,260 +0,0 @@ -# $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/tlperl0/lib/Win32/File.pm b/Master/tlpkg/tlperl0/lib/Win32/File.pm deleted file mode 100755 index 811e3ccb114..00000000000 --- a/Master/tlpkg/tlperl0/lib/Win32/File.pm +++ /dev/null @@ -1,118 +0,0 @@ -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/tlperl0/lib/Win32/File/Object.pm b/Master/tlpkg/tlperl0/lib/Win32/File/Object.pm deleted file mode 100755 index bb4aa90ecdc..00000000000 --- a/Master/tlpkg/tlperl0/lib/Win32/File/Object.pm +++ /dev/null @@ -1,450 +0,0 @@ -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/tlperl0/lib/Win32/Process.pm b/Master/tlpkg/tlperl0/lib/Win32/Process.pm deleted file mode 100755 index 24c017a94a4..00000000000 --- a/Master/tlpkg/tlperl0/lib/Win32/Process.pm +++ /dev/null @@ -1,219 +0,0 @@ -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/tlperl0/lib/Win32/Shortcut.pm b/Master/tlpkg/tlperl0/lib/Win32/Shortcut.pm deleted file mode 100755 index 00200dead1f..00000000000 --- a/Master/tlpkg/tlperl0/lib/Win32/Shortcut.pm +++ /dev/null @@ -1,752 +0,0 @@ -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/tlperl0/lib/Win32/TieRegistry.pm b/Master/tlpkg/tlperl0/lib/Win32/TieRegistry.pm deleted file mode 100755 index 19f9fdf4ae5..00000000000 --- a/Master/tlpkg/tlperl0/lib/Win32/TieRegistry.pm +++ /dev/null @@ -1,3809 +0,0 @@ -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/tlperl0/lib/Win32/WinError.pm b/Master/tlpkg/tlperl0/lib/Win32/WinError.pm deleted file mode 100755 index 4ea0091685d..00000000000 --- a/Master/tlpkg/tlperl0/lib/Win32/WinError.pm +++ /dev/null @@ -1,1017 +0,0 @@ -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__ |