diff options
author | Norbert Preining <preining@logic.at> | 2010-05-12 16:51:27 +0000 |
---|---|---|
committer | Norbert Preining <preining@logic.at> | 2010-05-12 16:51:27 +0000 |
commit | b645030efc22e13c2498a1522083634ab91b2de1 (patch) | |
tree | c75c7a71998200d419af56eb755dac2f5115b585 /Master/tlpkg/tlperl/lib/Win32 | |
parent | 44ccd4efc5352f9eb1099ba357708e7b5ff03b83 (diff) |
move tlperl to tlperl.old
git-svn-id: svn://tug.org/texlive/trunk@18209 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Win32')
34 files changed, 0 insertions, 20243 deletions
diff --git a/Master/tlpkg/tlperl/lib/Win32/API.pm b/Master/tlpkg/tlperl/lib/Win32/API.pm deleted file mode 100644 index e1bac5cda48..00000000000 --- a/Master/tlpkg/tlperl/lib/Win32/API.pm +++ /dev/null @@ -1,745 +0,0 @@ -package Win32::API; - -# See the bottom of this file for the POD documentation. Search for the -# string '=head'. - -####################################################################### -# -# Win32::API - Perl Win32 API Import Facility -# -# Version: 0.47 -# Date: 12 Nov 2007 -# Author: Aldo Calpini <dada@perl.it> -# Maintainer: Cosimo Streppone <cosimo@cpan.org> -# -# Changes for gcc/cygwin: Daniel Risacher <magnus@alum.mit.edu> -# ported from 0.41 based on Daniel's patch by Reini Urban <rurban@x-ray.at> -# -# $Id: API.pm,v 1.0 2001/10/30 13:57:31 dada Exp $ -# -####################################################################### - -require Exporter; # to export the constants to the main:: space -require DynaLoader; # to dynuhlode the module. -@ISA = qw( Exporter DynaLoader ); - -use vars qw( $DEBUG ); -$DEBUG = 0; - -sub DEBUG { - if ($Win32::API::DEBUG) { - printf @_ if @_ or return 1; - } else { - return 0; - } -} - -use Win32::API::Type; -use Win32::API::Struct; -BEGIN { - if ($^O eq 'cygwin') { - require File::Basename; - } -} - -####################################################################### -# STATIC OBJECT PROPERTIES -# -$VERSION = '0.47'; - -#### some package-global hash to -#### keep track of the imported -#### libraries and procedures -my %Libraries = (); -my %Procedures = (); - - -####################################################################### -# dynamically load in the API extension module. -# -bootstrap Win32::API; - -####################################################################### -# PUBLIC METHODS -# -sub new { - my($class, $dll, $proc, $in, $out) = @_; - my $hdll; - my $self = {}; - - if ($^O eq 'cygwin' and $dll ne File::Basename::basename($dll)) { - # need to convert $dll to win32 path - # isn't there an API for this? - my $newdll = `cygpath -w "$dll"`; - chomp $newdll; - DEBUG "(PM)new: converted '$dll' to\n '$newdll'\n"; - $dll = $newdll; - } - - #### avoid loading a library more than once - if(exists($Libraries{$dll})) { - DEBUG "Win32::API::new: Library '$dll' already loaded, handle=$Libraries{$dll}\n"; - $hdll = $Libraries{$dll}; - } else { - DEBUG "Win32::API::new: Loading library '$dll'\n"; - $hdll = Win32::API::LoadLibrary($dll); -# $Libraries{$dll} = $hdll; - } - - #### if the dll can't be loaded, set $! to Win32's GetLastError() - if(!$hdll) { - $! = Win32::GetLastError(); - DEBUG "FAILED Loading library '$dll': $!\n"; - delete $Libraries{$dll}; - return undef; - } - - #### determine if we have a prototype or not - if( (not defined $in) and (not defined $out) ) { - ($proc, $self->{in}, $self->{intypes}, $self->{out}) = parse_prototype( $proc ); - return undef unless $proc; - $self->{proto} = 1; - } else { - $self->{in} = []; - if(ref($in) eq 'ARRAY') { - foreach (@$in) { - push(@{ $self->{in} }, type_to_num($_)); - } - } else { - my @in = split '', $in; - foreach (@in) { - push(@{ $self->{in} }, type_to_num($_)); - } - } - $self->{out} = type_to_num($out); - } - - #### first try to import the function of given name... - my $hproc = Win32::API::GetProcAddress($hdll, $proc); - - #### ...then try appending either A or W (for ASCII or Unicode) - if(!$hproc) { - my $tproc = $proc; - $tproc .= (IsUnicode() ? "W" : "A"); - # print "Win32::API::new: procedure not found, trying '$tproc'...\n"; - $hproc = Win32::API::GetProcAddress($hdll, $tproc); - } - - #### ...if all that fails, set $! accordingly - if(!$hproc) { - $! = Win32::GetLastError(); - DEBUG "FAILED GetProcAddress for Proc '$proc': $!\n"; - return undef; - } - DEBUG "GetProcAddress('$proc') = '$hproc'\n"; - - #### ok, let's stuff the object - $self->{procname} = $proc; - $self->{dll} = $hdll; - $self->{dllname} = $dll; - $self->{proc} = $hproc; - - #### keep track of the imported function - $Libraries{$dll} = $hdll; - $Procedures{$dll}++; - - DEBUG "Object blessed!\n"; - - #### cast the spell - bless($self, $class); - return $self; -} - -sub Import { - my($class, $dll, $proc, $in, $out) = @_; - $Imported{"$dll:$proc"} = Win32::API->new($dll, $proc, $in, $out) or return 0; - my $P = (caller)[0]; - eval qq( - sub ${P}::$Imported{"$dll:$proc"}->{procname} { \$Win32::API::Imported{"$dll:$proc"}->Call(\@_); } - ); - return $@ ? 0 : 1; -} - - -####################################################################### -# PRIVATE METHODS -# -sub DESTROY { - my($self) = @_; - - #### decrease this library's procedures reference count - $Procedures{$self->{dllname}}--; - - #### once it reaches 0, free it - if($Procedures{$self->{dllname}} == 0) { - DEBUG "Win32::API::DESTROY: Freeing library '$self->{dllname}'\n"; - Win32::API::FreeLibrary($Libraries{$self->{dllname}}); - delete($Libraries{$self->{dllname}}); - } -} - -sub type_to_num { - my $type = shift; - my $out = shift; - my $num; - - if( $type eq 'N' - or $type eq 'n' - or $type eq 'l' - or $type eq 'L' - ) { - $num = 1; - } elsif($type eq 'P' - or $type eq 'p' - ) { - $num = 2; - } elsif($type eq 'I' - or $type eq 'i' - ) { - $num = 3; - } elsif($type eq 'f' - or $type eq 'F' - ) { - $num = 4; - } elsif($type eq 'D' - or $type eq 'd' - ) { - $num = 5; - } elsif($type eq 'c' - or $type eq 'C' - ) { - $num = 6; - } else { - $num = 0; - } - unless(defined $out) { - if( $type eq 's' - or $type eq 'S' - ) { - $num = 51; - } elsif($type eq 'b' - or $type eq 'B' - ) { - $num = 22; - } elsif($type eq 'k' - or $type eq 'K' - ) { - $num = 101; - } - } - return $num; -} - -sub parse_prototype { - my($proto) = @_; - - my @in_params = (); - my @in_types = (); - if($proto =~ /^\s*(\S+)\s+(\S+)\s*\(([^\)]*)\)/) { - my $ret = $1; - my $proc = $2; - my $params = $3; - - $params =~ s/^\s+//; - $params =~ s/\s+$//; - - DEBUG "(PM)parse_prototype: got PROC '%s'\n", $proc; - DEBUG "(PM)parse_prototype: got PARAMS '%s'\n", $params; - - foreach my $param (split(/\s*,\s*/, $params)) { - my($type, $name); - if($param =~ /(\S+)\s+(\S+)/) { - ($type, $name) = ($1, $2); - } - - if(Win32::API::Type::is_known($type)) { - if(Win32::API::Type::is_pointer($type)) { - DEBUG "(PM)parse_prototype: IN='%s' PACKING='%s' API_TYPE=%d\n", - $type, - Win32::API::Type->packing( $type ), - type_to_num('P'); - push(@in_params, type_to_num('P')); - } else { - DEBUG "(PM)parse_prototype: IN='%s' PACKING='%s' API_TYPE=%d\n", - $type, - Win32::API::Type->packing( $type ), - type_to_num( Win32::API::Type->packing( $type ) ); - push(@in_params, type_to_num( Win32::API::Type->packing( $type ) )); - } - } elsif( Win32::API::Struct::is_known( $type ) ) { - DEBUG "(PM)parse_prototype: IN='%s' PACKING='%s' API_TYPE=%d\n", - $type, 'S', type_to_num('S'); - push(@in_params, type_to_num('S')); - } else { - warn "Win32::API::parse_prototype: WARNING unknown parameter type '$type'"; - push(@in_params, type_to_num('I')); - } - push(@in_types, $type); - - } - DEBUG "parse_prototype: IN=[ @in_params ]\n"; - - - - if(Win32::API::Type::is_known($ret)) { - if(Win32::API::Type::is_pointer($ret)) { - DEBUG "parse_prototype: OUT='%s' PACKING='%s' API_TYPE=%d\n", - $ret, - Win32::API::Type->packing( $ret ), - type_to_num('P'); - return ( $proc, \@in_params, \@in_types, type_to_num('P') ); - } else { - DEBUG "parse_prototype: OUT='%s' PACKING='%s' API_TYPE=%d\n", - $ret, - Win32::API::Type->packing( $ret ), - type_to_num( Win32::API::Type->packing( $ret ) ); - return ( $proc, \@in_params, \@in_types, type_to_num(Win32::API::Type->packing($ret)) ); - } - } else { - warn "Win32::API::parse_prototype: WARNING unknown output parameter type '$ret'"; - return ( $proc, \@in_params, \@in_types, type_to_num('I') ); - } - - } else { - warn "Win32::API::parse_prototype: bad prototype '$proto'"; - return undef; - } -} - -1; - -__END__ - -####################################################################### -# DOCUMENTATION -# - -=head1 NAME - -Win32::API - Perl Win32 API Import Facility - -=head1 SYNOPSIS - - #### Method 1: with prototype - - use Win32::API; - $function = Win32::API->new( - 'mydll, 'int sum_integers(int a, int b)', - ); - $return = $function->Call(3, 2); - - #### Method 2: with parameter list - - use Win32::API; - $function = Win32::API->new( - 'mydll', 'sum_integers', 'II', 'I', - ); - $return = $function->Call(3, 2); - - #### Method 3: with Import - - use Win32::API; - Win32::API->Import( - 'mydll', 'int sum_integers(int a, int b)', - ); - $return = sum_integers(3, 2); - - -=for LATER-UNIMPLEMENTED - #### or - use Win32::API mydll => 'int sum_integers(int a, int b)'; - $return = sum_integers(3, 2); - - -=head1 ABSTRACT - -With this module you can import and call arbitrary functions -from Win32's Dynamic Link Libraries (DLL), without having -to write an XS extension. Note, however, that this module -can't do anything (parameters input and output is limited -to simpler cases), and anyway a regular XS extension is -always safer and faster. - -The current version of Win32::API is available at my website: - - http://dada.perl.it/ - -It's also available on your nearest CPAN mirror (but allow a few days -for worldwide spreading of the latest version) reachable at: - - http://www.perl.com/CPAN/authors/Aldo_Calpini/ - -A short example of how you can use this module (it just gets the PID of -the current process, eg. same as Perl's internal C<$$>): - - use Win32::API; - Win32::API->Import("kernel32", "int GetCurrentProcessId()"); - $PID = GetCurrentProcessId(); - -The possibilities are nearly infinite (but not all are good :-). -Enjoy it. - - -=head1 CREDITS - -All the credits go to Andrea Frosini -for the neat assembler trick that makes this thing work. -I've also used some work by Dave Roth for the prototyping stuff. -A big thank you also to Gurusamy Sarathy for his -unvaluable help in XS development, and to all the Perl community for -being what it is. - - -=head1 DESCRIPTION - -To use this module put the following line at the beginning of your script: - - use Win32::API; - -You can now use the C<new()> function of the Win32::API module to create a -new Win32::API object (see L<IMPORTING A FUNCTION>) and then invoke the -C<Call()> method on this object to perform a call to the imported API -(see L<CALLING AN IMPORTED FUNCTION>). - -Starting from version 0.40, you can also avoid creating a Win32::API object -and instead automatically define a Perl sub with the same name of the API -function you're importing. The details of the API definitions are the same, -just the call is different: - - my $GetCurrentProcessId = Win32::API->new( - "kernel32", "int GetCurrentProcessId()" - ); - my $PID = $GetCurrentProcessId->Call(); - - #### vs. - - Win32::API->Import("kernel32", "int GetCurrentProcessId()"); - $PID = GetCurrentProcessId(); - -Note that C<Import> returns 1 on success and 0 on failure (in which case you -can check the content of C<$^E>). - -=head2 IMPORTING A FUNCTION - -You can import a function from a 32 bit Dynamic Link Library (DLL) file -with the C<new()> function. This will create a Perl object that contains the -reference to that function, which you can later C<Call()>. - -What you need to know is the prototype of the function you're going to import -(eg. the definition of the function expressed in C syntax). - -Starting from version 0.40, there are 2 different approaches for this step: -(the preferred) one uses the prototype directly, while the other (now deprecated) -one uses Win32::API's internal representation for parameters. - -=head2 IMPORTING A FUNCTION BY PROTOTYPE - -You need to pass 2 parameters: - -=over 4 - -=item 1. -The name of the library from which you want to import the function. - -=item 2. -The C prototype of the function. - -=back - -See L<Win32::API::Type> for a list of the known parameter types and -L<Win32::API::Struct> for information on how to define a structure. - -=head2 IMPORTING A FUNCTION WITH A PARAMETER LIST - -You need to pass 4 parameters: - -=over 4 - -=item 1. -The name of the library from which you want to import the function. - -=item 2. -The name of the function (as exported by the library). - -=item 3. -The number and types of the arguments the function expects as input. - -=item 4. -The type of the value returned by the function. - -=back - -To better explain their meaning, let's suppose that we -want to import and call the Win32 API C<GetTempPath()>. -This function is defined in C as: - - DWORD WINAPI GetTempPathA( DWORD nBufferLength, LPSTR lpBuffer ); - -This is documented in the B<Win32 SDK Reference>; you can look -for it on the Microsoft's WWW site, or in your C compiler's -documentation, if you own one. - -=over 4 - -=item B<1.> - -The first parameter is the name of the library file that -exports this function; our function resides in the F<KERNEL32.DLL> -system file. -When specifying this name as parameter, the F<.DLL> extension -is implicit, and if no path is given, the file is searched through -a couple of directories, including: - -=over 4 - -=item 1. The directory from which the application loaded. - -=item 2. The current directory. - -=item 3. The Windows system directory (eg. c:\windows\system or system32). - -=item 4. The Windows directory (eg. c:\windows). - -=item 5. The directories that are listed in the PATH environment variable. - -=back - -So, you don't have to write F<C:\windows\system\kernel32.dll>; -only F<kernel32> is enough: - - $GetTempPath = new Win32::API('kernel32', ... - -=item B<2.> - -Now for the second parameter: the name of the function. -It must be written exactly as it is exported -by the library (case is significant here). -If you are using Windows 95 or NT 4.0, you can use the B<Quick View> -command on the DLL file to see the function it exports. -Remember that you can only import functions from 32 bit DLLs: -in Quick View, the file's characteristics should report -somewhere "32 bit word machine"; as a rule of thumb, -when you see that all the exported functions are in upper case, -the DLL is a 16 bit one and you can't use it. -If their capitalization looks correct, then it's probably a 32 bit -DLL. - -Also note that many Win32 APIs are exported twice, with the addition of -a final B<A> or B<W> to their name, for - respectively - the ASCII -and the Unicode version. -When a function name is not found, Win32::API will actually append -an B<A> to the name and try again; if the extension is built on a -Unicode system, then it will try with the B<W> instead. -So our function name will be: - - $GetTempPath = new Win32::API('kernel32', 'GetTempPath', ... - -In our case C<GetTempPath> is really loaded as C<GetTempPathA>. - -=item B<3.> - -The third parameter, the input parameter list, specifies how many -arguments the function wants, and their types. It can be passed as -a single string, in which each character represents one parameter, -or as a list reference. The following forms are valid: - - "abcd" - [a, b, c, d] - \@LIST - -But those are not: - - (a, b, c, d) - @LIST - -The number of characters, or elements in the list, specifies the number -of parameters, and each character or element specifies the type of an -argument; allowed types are: - -=over 4 - -=item C<I>: -value is an integer (int) - -=item C<N>: -value is a number (long) - -=item C<F>: -value is a floating point number (float) - -=item C<D>: -value is a double precision number (double) - -=item C<C>: -value is a char (char) - -=item C<P>: -value is a pointer (to a string, structure, etc...) - -=item C<S>: -value is a Win32::API::Struct object (see below) - -=item C<K>: -value is a Win32::API::Callback object (see L<Win32::API::Callback>) - -=back - -Our function needs two parameters: a number (C<DWORD>) and a pointer to a -string (C<LPSTR>): - - $GetTempPath = new Win32::API('kernel32', 'GetTempPath', 'NP', ... - -=item B<4.> - -The fourth and final parameter is the type of the value returned by the -function. It can be one of the types seen above, plus another type named B<V> -(for C<void>), used for functions that do not return a value. -In our example the value returned by GetTempPath() is a C<DWORD>, so -our return type will be B<N>: - - $GetTempPath = new Win32::API('kernel32', 'GetTempPath', 'NP', 'N'); - -Now the line is complete, and the GetTempPath() API is ready to be used -in Perl. Before calling it, you should test that $GetTempPath is -C<defined>, otherwise either the function or the library could not be -loaded; in this case, C<$!> will be set to the error message reported -by Windows. -Our definition, with error checking added, should then look like this: - - $GetTempPath = new Win32::API('kernel32', 'GetTempPath', 'NP', 'N'); - if(not defined $GetTempPath) { - die "Can't import API GetTempPath: $!\n"; - } - -=back - -=head2 CALLING AN IMPORTED FUNCTION - -To effectively make a call to an imported function you must use the -Call() method on the Win32::API object you created. -Continuing with the example from the previous paragraph, -the GetTempPath() API can be called using the method: - - $GetTempPath->Call(... - -Of course, parameters have to be passed as defined in the import phase. -In particular, if the number of parameters does not match (in the example, -if GetTempPath() is called with more or less than two parameters), -Perl will C<croak> an error message and C<die>. - -The two parameters needed here are the length of the buffer -that will hold the returned temporary path, and a pointer to the -buffer itself. -For numerical parameters, you can use either a constant expression -or a variable, while B<for pointers you must use a variable name> (no -Perl references, just a plain variable name). -Also note that B<memory must be allocated before calling the function>, -just like in C. -For example, to pass a buffer of 80 characters to GetTempPath(), -it must be initialized before with: - - $lpBuffer = " " x 80; - -This allocates a string of 80 characters. If you don't do so, you'll -probably get C<Runtime exception> errors, and generally nothing will -work. The call should therefore include: - - $lpBuffer = " " x 80; - $GetTempPath->Call(80, $lpBuffer); - -And the result will be stored in the $lpBuffer variable. -Note that you don't need to pass a reference to the variable -(eg. you B<don't need> C<\$lpBuffer>), even if its value will be set -by the function. - -A little problem here is that Perl does not trim the variable, -so $lpBuffer will still contain 80 characters in return; the exceeding -characters will be spaces, because we said C<" " x 80>. - -In this case we're lucky enough, because the value returned by -the GetTempPath() function is the length of the string, so to get -the actual temporary path we can write: - - $lpBuffer = " " x 80; - $return = $GetTempPath->Call(80, $lpBuffer); - $TempPath = substr($lpBuffer, 0, $return); - -If you don't know the length of the string, you can usually -cut it at the C<\0> (ASCII zero) character, which is the string -delimiter in C: - - $TempPath = ((split(/\0/, $lpBuffer))[0]; - # or - $lpBuffer =~ s/\0.*$//; - -=head2 USING STRUCTURES - -Starting from version 0.40, Win32::API comes with a support package -named Win32::API::Struct. The package is loaded automatically with -Win32::API, so you don't need to use it explicitly. - -With this module you can conveniently define structures and use -them as parameters to Win32::API functions. A short example follows: - - - # the 'POINT' structure is defined in C as: - # typedef struct { - # LONG x; - # LONG y; - # } POINT; - - - #### define the structure - Win32::API::Struct->typedef( POINT => qw{ - LONG x; - LONG y; - }); - - #### import an API that uses this structure - Win32::API->Import('user32', 'BOOL GetCursorPos(LPPOINT lpPoint)'); - - #### create a 'POINT' object - my $pt = Win32::API::Struct->new('POINT'); - - #### call the function passing our structure object - GetCursorPos($pt); - - #### and now, access its members - print "The cursor is at: $pt->{x}, $pt->{y}\n"; - -Note that this works only when the function wants a -B<pointer to a structure>: as you can see, our structure is named -'POINT', but the API used 'LPPOINT'. 'LP' is automatically added at -the beginning of the structure name when feeding it to a Win32::API -call. - -For more information, see also L<Win32::API::Struct>. - -If you don't want (or can't) use the Win32::API::Struct facility, -you can still use the low-level approach to use structures: - - -=over 4 - -=item 1. -you have to pack() the required elements in a variable: - - $lpPoint = pack('LL', 0, 0); # store two LONGs - -=item 2. to access the values stored in a structure, unpack() it as required: - - ($x, $y) = unpack('LL', $lpPoint); # get the actual values - -=back - -The rest is left as an exercise to the reader... - -=head1 AUTHOR - -Aldo Calpini ( I<dada@perl.it> ). - -=head1 MAINTAINER - -Cosimo Streppone ( I<cosimo@cpan.org> ) - -=cut diff --git a/Master/tlpkg/tlperl/lib/Win32/API.pm.orig b/Master/tlpkg/tlperl/lib/Win32/API.pm.orig deleted file mode 100644 index 9e4accd8bf6..00000000000 --- a/Master/tlpkg/tlperl/lib/Win32/API.pm.orig +++ /dev/null @@ -1,741 +0,0 @@ -package Win32::API;
-
-# See the bottom of this file for the POD documentation. Search for the
-# string '=head'.
-
-#######################################################################
-#
-# Win32::API - Perl Win32 API Import Facility
-#
-# Version: 0.47
-# Date: 12 Nov 2007
-# Author: Aldo Calpini <dada@perl.it>
-# Maintainer: Cosimo Streppone <cosimo@cpan.org>
-#
-# Changes for gcc/cygwin: Daniel Risacher <magnus@alum.mit.edu>
-# ported from 0.41 based on Daniel's patch by Reini Urban <rurban@x-ray.at>
-#
-# $Id: API.pm,v 1.0 2001/10/30 13:57:31 dada Exp $
-#
-#######################################################################
-
-require Exporter; # to export the constants to the main:: space
-require DynaLoader; # to dynuhlode the module.
-@ISA = qw( Exporter DynaLoader );
-
-use vars qw( $DEBUG );
-$DEBUG = 0;
-
-sub DEBUG {
- if ($Win32::API::DEBUG) {
- printf @_ if @_ or return 1;
- } else {
- return 0;
- }
-}
-
-use Win32::API::Type;
-use Win32::API::Struct;
-use File::Basename ();
-
-#######################################################################
-# STATIC OBJECT PROPERTIES
-#
-$VERSION = '0.47';
-
-#### some package-global hash to
-#### keep track of the imported
-#### libraries and procedures
-my %Libraries = ();
-my %Procedures = ();
-
-
-#######################################################################
-# dynamically load in the API extension module.
-#
-bootstrap Win32::API;
-
-#######################################################################
-# PUBLIC METHODS
-#
-sub new {
- my($class, $dll, $proc, $in, $out) = @_;
- my $hdll;
- my $self = {};
-
- if ($^O eq 'cygwin' and $dll ne File::Basename::basename($dll)) {
- # need to convert $dll to win32 path
- # isn't there an API for this?
- my $newdll = `cygpath -w "$dll"`;
- chomp $newdll;
- DEBUG "(PM)new: converted '$dll' to\n '$newdll'\n";
- $dll = $newdll;
- }
-
- #### avoid loading a library more than once
- if(exists($Libraries{$dll})) {
- DEBUG "Win32::API::new: Library '$dll' already loaded, handle=$Libraries{$dll}\n";
- $hdll = $Libraries{$dll};
- } else {
- DEBUG "Win32::API::new: Loading library '$dll'\n";
- $hdll = Win32::API::LoadLibrary($dll);
-# $Libraries{$dll} = $hdll;
- }
-
- #### if the dll can't be loaded, set $! to Win32's GetLastError()
- if(!$hdll) {
- $! = Win32::GetLastError();
- DEBUG "FAILED Loading library '$dll': $!\n";
- delete $Libraries{$dll};
- return undef;
- }
-
- #### determine if we have a prototype or not
- if( (not defined $in) and (not defined $out) ) {
- ($proc, $self->{in}, $self->{intypes}, $self->{out}) = parse_prototype( $proc );
- return undef unless $proc;
- $self->{proto} = 1;
- } else {
- $self->{in} = [];
- if(ref($in) eq 'ARRAY') {
- foreach (@$in) {
- push(@{ $self->{in} }, type_to_num($_));
- }
- } else {
- my @in = split '', $in;
- foreach (@in) {
- push(@{ $self->{in} }, type_to_num($_));
- }
- }
- $self->{out} = type_to_num($out);
- }
-
- #### first try to import the function of given name...
- my $hproc = Win32::API::GetProcAddress($hdll, $proc);
-
- #### ...then try appending either A or W (for ASCII or Unicode)
- if(!$hproc) {
- my $tproc = $proc;
- $tproc .= (IsUnicode() ? "W" : "A");
- # print "Win32::API::new: procedure not found, trying '$tproc'...\n";
- $hproc = Win32::API::GetProcAddress($hdll, $tproc);
- }
-
- #### ...if all that fails, set $! accordingly
- if(!$hproc) {
- $! = Win32::GetLastError();
- DEBUG "FAILED GetProcAddress for Proc '$proc': $!\n";
- return undef;
- }
- DEBUG "GetProcAddress('$proc') = '$hproc'\n";
-
- #### ok, let's stuff the object
- $self->{procname} = $proc;
- $self->{dll} = $hdll;
- $self->{dllname} = $dll;
- $self->{proc} = $hproc;
-
- #### keep track of the imported function
- $Libraries{$dll} = $hdll;
- $Procedures{$dll}++;
-
- DEBUG "Object blessed!\n";
-
- #### cast the spell
- bless($self, $class);
- return $self;
-}
-
-sub Import {
- my($class, $dll, $proc, $in, $out) = @_;
- $Imported{"$dll:$proc"} = Win32::API->new($dll, $proc, $in, $out) or return 0;
- my $P = (caller)[0];
- eval qq(
- sub ${P}::$Imported{"$dll:$proc"}->{procname} { \$Win32::API::Imported{"$dll:$proc"}->Call(\@_); }
- );
- return $@ ? 0 : 1;
-}
-
-
-#######################################################################
-# PRIVATE METHODS
-#
-sub DESTROY {
- my($self) = @_;
-
- #### decrease this library's procedures reference count
- $Procedures{$self->{dllname}}--;
-
- #### once it reaches 0, free it
- if($Procedures{$self->{dllname}} == 0) {
- DEBUG "Win32::API::DESTROY: Freeing library '$self->{dllname}'\n";
- Win32::API::FreeLibrary($Libraries{$self->{dllname}});
- delete($Libraries{$self->{dllname}});
- }
-}
-
-sub type_to_num {
- my $type = shift;
- my $out = shift;
- my $num;
-
- if( $type eq 'N'
- or $type eq 'n'
- or $type eq 'l'
- or $type eq 'L'
- ) {
- $num = 1;
- } elsif($type eq 'P'
- or $type eq 'p'
- ) {
- $num = 2;
- } elsif($type eq 'I'
- or $type eq 'i'
- ) {
- $num = 3;
- } elsif($type eq 'f'
- or $type eq 'F'
- ) {
- $num = 4;
- } elsif($type eq 'D'
- or $type eq 'd'
- ) {
- $num = 5;
- } elsif($type eq 'c'
- or $type eq 'C'
- ) {
- $num = 6;
- } else {
- $num = 0;
- }
- unless(defined $out) {
- if( $type eq 's'
- or $type eq 'S'
- ) {
- $num = 51;
- } elsif($type eq 'b'
- or $type eq 'B'
- ) {
- $num = 22;
- } elsif($type eq 'k'
- or $type eq 'K'
- ) {
- $num = 101;
- }
- }
- return $num;
-}
-
-sub parse_prototype {
- my($proto) = @_;
-
- my @in_params = ();
- my @in_types = ();
- if($proto =~ /^\s*(\S+)\s+(\S+)\s*\(([^\)]*)\)/) {
- my $ret = $1;
- my $proc = $2;
- my $params = $3;
-
- $params =~ s/^\s+//;
- $params =~ s/\s+$//;
-
- DEBUG "(PM)parse_prototype: got PROC '%s'\n", $proc;
- DEBUG "(PM)parse_prototype: got PARAMS '%s'\n", $params;
-
- foreach my $param (split(/\s*,\s*/, $params)) {
- my($type, $name);
- if($param =~ /(\S+)\s+(\S+)/) {
- ($type, $name) = ($1, $2);
- }
-
- if(Win32::API::Type::is_known($type)) {
- if(Win32::API::Type::is_pointer($type)) {
- DEBUG "(PM)parse_prototype: IN='%s' PACKING='%s' API_TYPE=%d\n",
- $type,
- Win32::API::Type->packing( $type ),
- type_to_num('P');
- push(@in_params, type_to_num('P'));
- } else {
- DEBUG "(PM)parse_prototype: IN='%s' PACKING='%s' API_TYPE=%d\n",
- $type,
- Win32::API::Type->packing( $type ),
- type_to_num( Win32::API::Type->packing( $type ) );
- push(@in_params, type_to_num( Win32::API::Type->packing( $type ) ));
- }
- } elsif( Win32::API::Struct::is_known( $type ) ) {
- DEBUG "(PM)parse_prototype: IN='%s' PACKING='%s' API_TYPE=%d\n",
- $type, 'S', type_to_num('S');
- push(@in_params, type_to_num('S'));
- } else {
- warn "Win32::API::parse_prototype: WARNING unknown parameter type '$type'";
- push(@in_params, type_to_num('I'));
- }
- push(@in_types, $type);
-
- }
- DEBUG "parse_prototype: IN=[ @in_params ]\n";
-
-
-
- if(Win32::API::Type::is_known($ret)) {
- if(Win32::API::Type::is_pointer($ret)) {
- DEBUG "parse_prototype: OUT='%s' PACKING='%s' API_TYPE=%d\n",
- $ret,
- Win32::API::Type->packing( $ret ),
- type_to_num('P');
- return ( $proc, \@in_params, \@in_types, type_to_num('P') );
- } else {
- DEBUG "parse_prototype: OUT='%s' PACKING='%s' API_TYPE=%d\n",
- $ret,
- Win32::API::Type->packing( $ret ),
- type_to_num( Win32::API::Type->packing( $ret ) );
- return ( $proc, \@in_params, \@in_types, type_to_num(Win32::API::Type->packing($ret)) );
- }
- } else {
- warn "Win32::API::parse_prototype: WARNING unknown output parameter type '$ret'";
- return ( $proc, \@in_params, \@in_types, type_to_num('I') );
- }
-
- } else {
- warn "Win32::API::parse_prototype: bad prototype '$proto'";
- return undef;
- }
-}
-
-1;
-
-__END__
-
-#######################################################################
-# DOCUMENTATION
-#
-
-=head1 NAME
-
-Win32::API - Perl Win32 API Import Facility
-
-=head1 SYNOPSIS
-
- #### Method 1: with prototype
-
- use Win32::API;
- $function = Win32::API->new(
- 'mydll, 'int sum_integers(int a, int b)',
- );
- $return = $function->Call(3, 2);
-
- #### Method 2: with parameter list
-
- use Win32::API;
- $function = Win32::API->new(
- 'mydll', 'sum_integers', 'II', 'I',
- );
- $return = $function->Call(3, 2);
-
- #### Method 3: with Import
-
- use Win32::API;
- Win32::API->Import(
- 'mydll', 'int sum_integers(int a, int b)',
- );
- $return = sum_integers(3, 2);
-
-
-=for LATER-UNIMPLEMENTED
- #### or
- use Win32::API mydll => 'int sum_integers(int a, int b)';
- $return = sum_integers(3, 2);
-
-
-=head1 ABSTRACT
-
-With this module you can import and call arbitrary functions
-from Win32's Dynamic Link Libraries (DLL), without having
-to write an XS extension. Note, however, that this module
-can't do anything (parameters input and output is limited
-to simpler cases), and anyway a regular XS extension is
-always safer and faster.
-
-The current version of Win32::API is available at my website:
-
- http://dada.perl.it/
-
-It's also available on your nearest CPAN mirror (but allow a few days
-for worldwide spreading of the latest version) reachable at:
-
- http://www.perl.com/CPAN/authors/Aldo_Calpini/
-
-A short example of how you can use this module (it just gets the PID of
-the current process, eg. same as Perl's internal C<$$>):
-
- use Win32::API;
- Win32::API->Import("kernel32", "int GetCurrentProcessId()");
- $PID = GetCurrentProcessId();
-
-The possibilities are nearly infinite (but not all are good :-).
-Enjoy it.
-
-
-=head1 CREDITS
-
-All the credits go to Andrea Frosini
-for the neat assembler trick that makes this thing work.
-I've also used some work by Dave Roth for the prototyping stuff.
-A big thank you also to Gurusamy Sarathy for his
-unvaluable help in XS development, and to all the Perl community for
-being what it is.
-
-
-=head1 DESCRIPTION
-
-To use this module put the following line at the beginning of your script:
-
- use Win32::API;
-
-You can now use the C<new()> function of the Win32::API module to create a
-new Win32::API object (see L<IMPORTING A FUNCTION>) and then invoke the
-C<Call()> method on this object to perform a call to the imported API
-(see L<CALLING AN IMPORTED FUNCTION>).
-
-Starting from version 0.40, you can also avoid creating a Win32::API object
-and instead automatically define a Perl sub with the same name of the API
-function you're importing. The details of the API definitions are the same,
-just the call is different:
-
- my $GetCurrentProcessId = Win32::API->new(
- "kernel32", "int GetCurrentProcessId()"
- );
- my $PID = $GetCurrentProcessId->Call();
-
- #### vs.
-
- Win32::API->Import("kernel32", "int GetCurrentProcessId()");
- $PID = GetCurrentProcessId();
-
-Note that C<Import> returns 1 on success and 0 on failure (in which case you
-can check the content of C<$^E>).
-
-=head2 IMPORTING A FUNCTION
-
-You can import a function from a 32 bit Dynamic Link Library (DLL) file
-with the C<new()> function. This will create a Perl object that contains the
-reference to that function, which you can later C<Call()>.
-
-What you need to know is the prototype of the function you're going to import
-(eg. the definition of the function expressed in C syntax).
-
-Starting from version 0.40, there are 2 different approaches for this step:
-(the preferred) one uses the prototype directly, while the other (now deprecated)
-one uses Win32::API's internal representation for parameters.
-
-=head2 IMPORTING A FUNCTION BY PROTOTYPE
-
-You need to pass 2 parameters:
-
-=over 4
-
-=item 1.
-The name of the library from which you want to import the function.
-
-=item 2.
-The C prototype of the function.
-
-=back
-
-See L<Win32::API::Type> for a list of the known parameter types and
-L<Win32::API::Struct> for information on how to define a structure.
-
-=head2 IMPORTING A FUNCTION WITH A PARAMETER LIST
-
-You need to pass 4 parameters:
-
-=over 4
-
-=item 1.
-The name of the library from which you want to import the function.
-
-=item 2.
-The name of the function (as exported by the library).
-
-=item 3.
-The number and types of the arguments the function expects as input.
-
-=item 4.
-The type of the value returned by the function.
-
-=back
-
-To better explain their meaning, let's suppose that we
-want to import and call the Win32 API C<GetTempPath()>.
-This function is defined in C as:
-
- DWORD WINAPI GetTempPathA( DWORD nBufferLength, LPSTR lpBuffer );
-
-This is documented in the B<Win32 SDK Reference>; you can look
-for it on the Microsoft's WWW site, or in your C compiler's
-documentation, if you own one.
-
-=over 4
-
-=item B<1.>
-
-The first parameter is the name of the library file that
-exports this function; our function resides in the F<KERNEL32.DLL>
-system file.
-When specifying this name as parameter, the F<.DLL> extension
-is implicit, and if no path is given, the file is searched through
-a couple of directories, including:
-
-=over 4
-
-=item 1. The directory from which the application loaded.
-
-=item 2. The current directory.
-
-=item 3. The Windows system directory (eg. c:\windows\system or system32).
-
-=item 4. The Windows directory (eg. c:\windows).
-
-=item 5. The directories that are listed in the PATH environment variable.
-
-=back
-
-So, you don't have to write F<C:\windows\system\kernel32.dll>;
-only F<kernel32> is enough:
-
- $GetTempPath = new Win32::API('kernel32', ...
-
-=item B<2.>
-
-Now for the second parameter: the name of the function.
-It must be written exactly as it is exported
-by the library (case is significant here).
-If you are using Windows 95 or NT 4.0, you can use the B<Quick View>
-command on the DLL file to see the function it exports.
-Remember that you can only import functions from 32 bit DLLs:
-in Quick View, the file's characteristics should report
-somewhere "32 bit word machine"; as a rule of thumb,
-when you see that all the exported functions are in upper case,
-the DLL is a 16 bit one and you can't use it.
-If their capitalization looks correct, then it's probably a 32 bit
-DLL.
-
-Also note that many Win32 APIs are exported twice, with the addition of
-a final B<A> or B<W> to their name, for - respectively - the ASCII
-and the Unicode version.
-When a function name is not found, Win32::API will actually append
-an B<A> to the name and try again; if the extension is built on a
-Unicode system, then it will try with the B<W> instead.
-So our function name will be:
-
- $GetTempPath = new Win32::API('kernel32', 'GetTempPath', ...
-
-In our case C<GetTempPath> is really loaded as C<GetTempPathA>.
-
-=item B<3.>
-
-The third parameter, the input parameter list, specifies how many
-arguments the function wants, and their types. It can be passed as
-a single string, in which each character represents one parameter,
-or as a list reference. The following forms are valid:
-
- "abcd"
- [a, b, c, d]
- \@LIST
-
-But those are not:
-
- (a, b, c, d)
- @LIST
-
-The number of characters, or elements in the list, specifies the number
-of parameters, and each character or element specifies the type of an
-argument; allowed types are:
-
-=over 4
-
-=item C<I>:
-value is an integer (int)
-
-=item C<N>:
-value is a number (long)
-
-=item C<F>:
-value is a floating point number (float)
-
-=item C<D>:
-value is a double precision number (double)
-
-=item C<C>:
-value is a char (char)
-
-=item C<P>:
-value is a pointer (to a string, structure, etc...)
-
-=item C<S>:
-value is a Win32::API::Struct object (see below)
-
-=item C<K>:
-value is a Win32::API::Callback object (see L<Win32::API::Callback>)
-
-=back
-
-Our function needs two parameters: a number (C<DWORD>) and a pointer to a
-string (C<LPSTR>):
-
- $GetTempPath = new Win32::API('kernel32', 'GetTempPath', 'NP', ...
-
-=item B<4.>
-
-The fourth and final parameter is the type of the value returned by the
-function. It can be one of the types seen above, plus another type named B<V>
-(for C<void>), used for functions that do not return a value.
-In our example the value returned by GetTempPath() is a C<DWORD>, so
-our return type will be B<N>:
-
- $GetTempPath = new Win32::API('kernel32', 'GetTempPath', 'NP', 'N');
-
-Now the line is complete, and the GetTempPath() API is ready to be used
-in Perl. Before calling it, you should test that $GetTempPath is
-C<defined>, otherwise either the function or the library could not be
-loaded; in this case, C<$!> will be set to the error message reported
-by Windows.
-Our definition, with error checking added, should then look like this:
-
- $GetTempPath = new Win32::API('kernel32', 'GetTempPath', 'NP', 'N');
- if(not defined $GetTempPath) {
- die "Can't import API GetTempPath: $!\n";
- }
-
-=back
-
-=head2 CALLING AN IMPORTED FUNCTION
-
-To effectively make a call to an imported function you must use the
-Call() method on the Win32::API object you created.
-Continuing with the example from the previous paragraph,
-the GetTempPath() API can be called using the method:
-
- $GetTempPath->Call(...
-
-Of course, parameters have to be passed as defined in the import phase.
-In particular, if the number of parameters does not match (in the example,
-if GetTempPath() is called with more or less than two parameters),
-Perl will C<croak> an error message and C<die>.
-
-The two parameters needed here are the length of the buffer
-that will hold the returned temporary path, and a pointer to the
-buffer itself.
-For numerical parameters, you can use either a constant expression
-or a variable, while B<for pointers you must use a variable name> (no
-Perl references, just a plain variable name).
-Also note that B<memory must be allocated before calling the function>,
-just like in C.
-For example, to pass a buffer of 80 characters to GetTempPath(),
-it must be initialized before with:
-
- $lpBuffer = " " x 80;
-
-This allocates a string of 80 characters. If you don't do so, you'll
-probably get C<Runtime exception> errors, and generally nothing will
-work. The call should therefore include:
-
- $lpBuffer = " " x 80;
- $GetTempPath->Call(80, $lpBuffer);
-
-And the result will be stored in the $lpBuffer variable.
-Note that you don't need to pass a reference to the variable
-(eg. you B<don't need> C<\$lpBuffer>), even if its value will be set
-by the function.
-
-A little problem here is that Perl does not trim the variable,
-so $lpBuffer will still contain 80 characters in return; the exceeding
-characters will be spaces, because we said C<" " x 80>.
-
-In this case we're lucky enough, because the value returned by
-the GetTempPath() function is the length of the string, so to get
-the actual temporary path we can write:
-
- $lpBuffer = " " x 80;
- $return = $GetTempPath->Call(80, $lpBuffer);
- $TempPath = substr($lpBuffer, 0, $return);
-
-If you don't know the length of the string, you can usually
-cut it at the C<\0> (ASCII zero) character, which is the string
-delimiter in C:
-
- $TempPath = ((split(/\0/, $lpBuffer))[0];
- # or
- $lpBuffer =~ s/\0.*$//;
-
-=head2 USING STRUCTURES
-
-Starting from version 0.40, Win32::API comes with a support package
-named Win32::API::Struct. The package is loaded automatically with
-Win32::API, so you don't need to use it explicitly.
-
-With this module you can conveniently define structures and use
-them as parameters to Win32::API functions. A short example follows:
-
-
- # the 'POINT' structure is defined in C as:
- # typedef struct {
- # LONG x;
- # LONG y;
- # } POINT;
-
-
- #### define the structure
- Win32::API::Struct->typedef( POINT => qw{
- LONG x;
- LONG y;
- });
-
- #### import an API that uses this structure
- Win32::API->Import('user32', 'BOOL GetCursorPos(LPPOINT lpPoint)');
-
- #### create a 'POINT' object
- my $pt = Win32::API::Struct->new('POINT');
-
- #### call the function passing our structure object
- GetCursorPos($pt);
-
- #### and now, access its members
- print "The cursor is at: $pt->{x}, $pt->{y}\n";
-
-Note that this works only when the function wants a
-B<pointer to a structure>: as you can see, our structure is named
-'POINT', but the API used 'LPPOINT'. 'LP' is automatically added at
-the beginning of the structure name when feeding it to a Win32::API
-call.
-
-For more information, see also L<Win32::API::Struct>.
-
-If you don't want (or can't) use the Win32::API::Struct facility,
-you can still use the low-level approach to use structures:
-
-
-=over 4
-
-=item 1.
-you have to pack() the required elements in a variable:
-
- $lpPoint = pack('LL', 0, 0); # store two LONGs
-
-=item 2. to access the values stored in a structure, unpack() it as required:
-
- ($x, $y) = unpack('LL', $lpPoint); # get the actual values
-
-=back
-
-The rest is left as an exercise to the reader...
-
-=head1 AUTHOR
-
-Aldo Calpini ( I<dada@perl.it> ).
-
-=head1 MAINTAINER
-
-Cosimo Streppone ( I<cosimo@cpan.org> )
-
-=cut
diff --git a/Master/tlpkg/tlperl/lib/Win32/API/Callback.pm b/Master/tlpkg/tlperl/lib/Win32/API/Callback.pm deleted file mode 100644 index 22de9d4f46a..00000000000 --- a/Master/tlpkg/tlperl/lib/Win32/API/Callback.pm +++ /dev/null @@ -1,174 +0,0 @@ -package Win32::API::Callback; - -# See the bottom of this file for the POD documentation. Search for the -# string '=head'. - -####################################################################### -# -# Win32::API::Callback - Perl Win32 API Import Facility -# -# Author: Aldo Calpini <dada@perl.it> -# Maintainer: Cosimo Streppone <cosimo@cpan.org> -# -# $Id: Callback.pm,v 1.0 2001/10/30 13:57:31 dada Exp $ -# -####################################################################### - -$VERSION = '0.47'; - -require Exporter; # to export the constants to the main:: space -require DynaLoader; # to dynuhlode the module. -@ISA = qw( Exporter DynaLoader ); - -sub DEBUG { - if ($WIN32::API::DEBUG) { - printf @_ if @_ or return 1; - } else { - return 0; - } -} - -use Win32::API; -use Win32::API::Type; -use Win32::API::Struct; - -####################################################################### -# This AUTOLOAD is used to 'autoload' constants from the constant() -# XS function. If a constant is not found then control is passed -# to the AUTOLOAD in AutoLoader. -# - -sub AUTOLOAD { - my($constname); - ($constname = $AUTOLOAD) =~ s/.*:://; - #reset $! to zero to reset any current errors. - $!=0; - my $val = constant($constname, @_ ? $_[0] : 0); - if ($! != 0) { - if ($! =~ /Invalid/) { - $AutoLoader::AUTOLOAD = $AUTOLOAD; - goto &AutoLoader::AUTOLOAD; - } else { - ($pack,$file,$line) = caller; - die "Your vendor has not defined Win32::API::Callback macro $constname, used at $file line $line."; - } - } - eval "sub $AUTOLOAD { $val }"; - goto &$AUTOLOAD; -} - - -####################################################################### -# dynamically load in the API extension module. -# -bootstrap Win32::API::Callback; - -####################################################################### -# PUBLIC METHODS -# -sub new { - my($class, $proc, $in, $out) = @_; - my %self = (); - - # printf "(PM)Callback::new: got proc='%s', in='%s', out='%s'\n", $proc, $in, $out; - - $self{in} = []; - if(ref($in) eq 'ARRAY') { - foreach (@$in) { - push(@{ $self{in} }, Win32::API::type_to_num($_)); - } - } else { - my @in = split '', $in; - foreach (@in) { - push(@{ $self{in} }, Win32::API::type_to_num($_)); - } - } - $self{out} = Win32::API::type_to_num($out); - $self{sub} = $proc; - my $self = bless \%self, $class; - - DEBUG "(PM)Callback::new: calling CallbackCreate($self)...\n"; - my $hproc = CallbackCreate($self); - - DEBUG "(PM)Callback::new: hproc=$hproc\n"; - - #### ...if that fails, set $! accordingly - if(!$hproc) { - $! = Win32::GetLastError(); - return undef; - } - - #### ok, let's stuff the object - $self->{code} = $hproc; - $self->{sub} = $proc; - - #### cast the spell - return $self; -} - -sub MakeStruct { - my($self, $n, $addr) = @_; - DEBUG "(PM)Win32::API::Callback::MakeStruct: got self='$self'\n"; - my $struct = Win32::API::Struct->new($self->{intypes}->[$n]); - $struct->FromMemory($addr); - return $struct; -} - -1; - -__END__ - -####################################################################### -# DOCUMENTATION -# - -=head1 NAME - -Win32::API::Callback - Callback support for Win32::API - -=head1 SYNOPSIS - - use Win32::API; - use Win32::API::Callback; - - my $callback = Win32::API::Callback->new( - sub { my($a, $b) = @_; return $a+$b; }, - "NN", "N", - ); - - Win32::API->Import( - 'mydll', 'two_integers_cb', 'KNN', 'N', - ); - - $sum = two_integers_cb( $callback, 3, 2 ); - - -=head1 FOREWORDS - -=over 4 - -=item * -Support for this module is B<highly experimental> at this point. - -=item * -I won't be surprised if it doesn't work for you. - -=item * -Feedback is very appreciated. - -=item * -Documentation is in the work. Either see the SYNOPSIS above -or the samples in the F<samples> directory. - -=back - -=head1 AUTHOR - -Aldo Calpini ( I<dada@perl.it> ). - -=head1 MAINTAINER - -Cosimo Streppone ( I<cosimo@cpan.org> ). - -=cut - diff --git a/Master/tlpkg/tlperl/lib/Win32/API/Struct.pm b/Master/tlpkg/tlperl/lib/Win32/API/Struct.pm deleted file mode 100644 index 05a4c8c60a5..00000000000 --- a/Master/tlpkg/tlperl/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,v 1.0 2001/10/30 13:57:31 dada Exp $ -####################################################################### - -$VERSION = '0.47'; - -use Win32::API::Type; - -use Carp; - -require Exporter; # to export the constants to the main:: space -require DynaLoader; # to dynuhlode the module. -@ISA = qw( Exporter DynaLoader ); - -my %Known = (); - -sub DEBUG { - if ($Win32::API::DEBUG) { - printf @_ if @_ or return 1; - } else { - return 0; - } -} - -sub typedef { - my $class = shift; - my $struct = shift; - my($type, $name); - my $self = { - align => undef, - typedef => [], - }; - while(defined($type = shift)) { - $name = shift; - $name =~ s/;$//; - push( @{ $self->{typedef} }, [ recognize($type, $name) ] ); - } - - $Known{$struct} = $self; - return 1; -} - - -sub recognize { - my($type, $name) = @_; - my($size, $packing); - if(exists $Known{$type}) { - $packing = ">"; - return $name, $packing, $type; - } else { - $packing = Win32::API::Type::packing($type); - return undef unless defined $packing; - if($name =~ s/\[(.*)\]$//) { - $size = $1; - $packing = $packing."*".$size; - } - DEBUG "(PM)Struct::recognize got '$name', '$type' -> '$packing'\n"; - return $name, $packing, $type; - } -} - -sub new { - my $class = shift; - my($type, $name); - my $self = { - typedef => [], - }; - if($#_ == 0) { - if(exists $Known{$_[0]}) { - DEBUG "(PM)Struct::new: got '$_[0]'\n"; - $self->{typedef} = $Known{$_[0]}->{typedef}; - foreach my $member (@{ $self->{typedef} }) { - ($name, $packing, $type) = @$member; - if($packing eq '>') { - $self->{$name} = Win32::API::Struct->new($type); - } - } - $self->{__typedef__} = $_[0]; - } else { - carp "Unknown Win32::API::Struct '$_[0]'"; - return undef; - } - } else { - while(defined($type = shift)) { - $name = shift; - # print "new: found member $name ($type)\n"; - if(not exists $Win32::API::Type::Known{$type}) { - warn "Unknown Win32::API::Struct type '$type'"; - return undef; - } else { - push( @{ $self->{typedef} }, [ $name, $Win32::API::Type::Known{$type}, $type ] ); - } - } - } - return bless $self; -} - -sub members { - my $self = shift; - return map {$_->[0]} @{ $self->{typedef} }; -} - -sub sizeof { - my $self = shift; - my $size = 0; - my $align = 0; - my $first = undef; - foreach my $member (@{ $self->{typedef} }) { - my($name, $packing, $type) = @$member; - - if(ref( $self->{$name} ) eq "Win32::API::Struct") { - $size += $self->{$name}->sizeof(); - # $align = $self->{$name}->sizeof() if $self->{$name}->sizeof() > $align; - } else { - if($packing =~ /\w\*(\d+)/) { - $size += Win32::API::Type::sizeof($type) * $1; - $first = Win32::API::Type::sizeof($type) * $1 unless defined $first; - DEBUG "(PM)Struct::sizeof: sizeof with member($name) now = ". $size. "\n"; - } else { - $size += Win32::API::Type::sizeof($type); - $first = Win32::API::Type::sizeof($type) unless defined $first; - $align = Win32::API::Type::sizeof($type) - if Win32::API::Type::sizeof($type) > $align; - DEBUG "(PM)Struct::sizeof: sizeof with member($name) now = ". $size. "\n"; - } - } - } - DEBUG "(PM)Struct::sizeof first=$first align=$align\n"; - #DEBUG "(PM)Struct::sizeof returning %d\n", $first + (scalar(@{ $self->{typedef} })-1) * $align; - #return $first + (scalar(@{ $self->{typedef} })-1) * $align; - DEBUG "(PM)Struct::sizeof returning %d\n", scalar(@{ $self->{typedef} }) * $align; - if(defined $align and $align > 0) { - return scalar(@{ $self->{typedef} }) * $align; - } else { - return $size; - } - return $size; -} - -sub align { - my $self = shift; - my $align = shift; - - if(not defined $align) { - return $self->{align} unless $self->{align} eq 'auto'; - $align = 0; - foreach my $member (@{ $self->{typedef} }) { - my($name, $packing, $type) = @$member; - - if(ref( $self->{$name} ) eq "Win32::API::Struct") { - #### ???? - } else { - if($packing =~ /\w\*(\d+)/) { - #### ???? - } else { - $align = Win32::API::Type::sizeof($type) - if Win32::API::Type::sizeof($type) > $align; - } - } - } - return $align; - } else { - $self->{align} = $align; - - } -} - -sub getPack { - my $self = shift; - my $packing = ""; - my($type, $name); - my @items = (); - my @recipients = (); - - my $align = $self->align(); - - foreach my $member (@{ $self->{typedef} }) { - ($name, $type, $orig) = @$member; - if($type eq '>') { - my($subpacking, $subitems, $subrecipients) = $self->{$name}->getPack(); - - DEBUG "(PM)Struct::getPack($self->{__typedef__}) ++ $subpacking\n"; - - $packing .= $subpacking; - push(@items, @$subitems); - push(@recipients, @$subrecipients); - } else { - if($type =~ /\w\*(\d+)/) { - my $size = $1; - $type = "a$size"; - } - - DEBUG "(PM)Struct::getPack($self->{__typedef__}) ++ $type\n"; - - if($type eq 'p') { - $type = "L"; - push(@items, Win32::API::PointerTo($self->{$name})); - } else { - push(@items, $self->{$name}); - } - $packing .= $type; - - if($Win32::API::Type::PackSize{$type} < $align) { - $packing .= ("x" x ($align - $Win32::API::Type::PackSize{$type})); - } - - push(@recipients, $self); - } - } - DEBUG "(PM)Struct::getPack: $self->{__typedef__}(buffer) = pack($packing, @items)\n"; - return($packing, [@items], [@recipients]); -} - - -sub Pack { - my $self = shift; - my($packing, $items, $recipients) = $self->getPack(); - DEBUG "(PM)Struct::Pack: $self->{__typedef__}(buffer) = pack($packing, @$items)\n"; - $self->{buffer} = pack($packing, @$items); - if(DEBUG) { - for my $i (0..$self->sizeof-1) { - printf " %3d: 0x%02x\n", $i, ord(substr($self->{buffer}, $i, 1)); - } - } - $self->{buffer_recipients} = $recipients -} - -sub getUnpack { - my $self = shift; - my $packing = ""; - my($type, $name); - my @items = (); - my $align = $self->align(); - foreach my $member (@{ $self->{typedef} }) { - ($name, $type, $orig) = @$member; - if($type eq '>') { - my($subpacking, @subitems) = $self->{$name}->getUnpack(); - - DEBUG "(PM)Struct::getUnpack($self->{__typedef__}) ++ $subpacking\n"; - $packing .= $subpacking; - - - push(@items, @subitems); - } else { - if($type =~ /\w\*(\d+)/) { - my $size = $1; - $type = "Z$size"; - } - - #if($type eq 'p') { - # $packing .= 'Z*'; - # DEBUG "(PM)Struct::getUnpack($self->{__typedef__}) ++ Z*\n"; - #} else { - $packing .= $type; - DEBUG "(PM)Struct::getUnpack($self->{__typedef__}) ++ $type\n"; - #} - if($type ne 'p' and $type !~ /^Z(\d+)/ and $Win32::API::Type::PackSize{$type} < $align) { - DEBUG "(PM)Struct::getUnpack %s(%d) < %d\n", - $type, $Win32::API::Type::PackSize{$type}, $align - ; - $packing .= ("x" x ($align - $Win32::API::Type::PackSize{$type})); - } - - push(@items, $name); - } - } - DEBUG "(PM)Struct::getUnpack($self->{__typedef__}): unpack($packing, @items)\n"; - return($packing, @items); -} - -sub Unpack { - my $self = shift; - my($packing, @items) = $self->getUnpack(); - my @itemvalue = unpack($packing, $self->{buffer}); - DEBUG "(PM)Struct::Unpack: unpack($packing, buffer) = @itemvalue\n"; - foreach my $i (0..$#items) { - my $recipient = $self->{buffer_recipients}->[$i]; - DEBUG "(PM)Struct::Unpack: %s(%s) = '%s' (0x%08x)\n", - $recipient->{__typedef__}, - $items[$i], - $itemvalue[$i], - $itemvalue[$i], - ; - $recipient->{$items[$i]} = $itemvalue[$i]; - DEBUG "(PM)Struct::Unpack: self.$items[$i] = $self->{$items[$i]}\n"; - } -} - -sub FromMemory { - my($self, $addr) = @_; - DEBUG "(PM)Struct::FromMemory: doing Pack\n"; - $self->Pack(); - DEBUG "(PM)Struct::FromMemory: doing GetMemory( 0x%08x, %d )\n", $addr, $self->sizeof; - $self->{buffer} = Win32::API::ReadMemory( $addr, $self->sizeof ); - $self->Unpack(); - DEBUG "(PM)Struct::FromMemory: doing Unpack\n"; - DEBUG "(PM)Struct::FromMemory: structure is now:\n"; - $self->Dump() if DEBUG; - DEBUG "\n"; -} - -sub Dump { - my $self = shift; - my $prefix = shift; - foreach my $member (@{ $self->{typedef} }) { - ($name, $packing, $type) = @$member; - if( ref($self->{$name}) ) { - $self->{$name}->Dump($name); - } else { - printf "%-20s %-20s %-20s\n", $prefix, $name, $self->{$name}; - } - } -} - - -sub is_known { - my $name = shift; - if(exists $Known{ $name }) { - return 1; - } else { - if($name =~ s/^LP//) { - return exists $Known{ $name }; - } - return 0; - } -} - -sub TIEHASH { - return Win32::API::Struct::new(@_); -} - -sub EXISTS { - -} - -sub FETCH { - my $self = shift; - my $key = shift; - - if($key eq 'sizeof') { - return $self->sizeof; - } - my @members = map { $_->[0] } @{ $self->{typedef} }; - if(grep(/^\Q$key\E$/, @members)) { - return $self->{$key}; - } else { - warn "'$key' is not a member of Win32::API::Struct $self->{__typedef__}"; - } -} - -sub STORE { - my $self = shift; - my($key, $val) = @_; - my @members = map { $_->[0] } @{ $self->{typedef} }; - if(grep(/^\Q$key\E$/, @members)) { - $self->{$key} = $val; - } else { - warn "'$key' is not a member of Win32::API::Struct $self->{__typedef__}"; - } -} - -sub FIRSTKEY { - my $self = shift; - my @members = map { $_->[0] } @{ $self->{typedef} }; - return $members[0]; -} - -sub NEXTKEY { - my $self = shift; - my $key = shift; - my @members = map { $_->[0] } @{ $self->{typedef} }; - for my $i (0..$#members-1) { - return $members[$i+1] if $members[$i] eq $key; - } - return undef; -} - -1; - -####################################################################### -# DOCUMENTATION -# - -=head1 NAME - -Win32::API::Struct - C struct support package for Win32::API - -=head1 SYNOPSIS - - use Win32::API; - - Win32::API::Struct->typedef( 'POINT', qw( - LONG x; - LONG y; - )); - - my $Point = Win32::API::Struct->new( 'POINT' ); - $Point->{x} = 1024; - $Point->{y} = 768; - - #### alternatively - - tie %Point, 'Win32::API::Struct', 'POINT'; - $Point{x} = 1024; - $Point{y} = 768; - - -=head1 ABSTRACT - -This module enables you to define C structs for use with -Win32::API. - -See L<Win32::API> for more info about its usage. - -=head1 DESCRIPTION - -This module is automatically imported by Win32::API, so you don't -need to 'use' it explicitly. The main methods are C<typedef> and -C<new>, which are documented below. - -=over 4 - -=item C<typedef NAME, TYPE, MEMBER, TYPE, MEMBER, ...> - -This method defines a structure named C<NAME>. The definition consists -of types and member names, just like in C. In fact, most of the -times you can cut the C definition for a structure and paste it -verbatim to your script, enclosing it in a C<qw()> block. The -function takes care of removing the semicolon after the member -name. - -The synopsis example could be written like this: - - Win32::API::Struct->typedef('POINT', 'LONG', 'x', 'LONG', 'y'); - -But it could also be written like this (note the indirect object -syntax), which is pretty cool: - - typedef Win32::API::Struct POINT => qw{ - LONG x; - LONG y; - }; - -Also note that C<typedef> automatically defines an 'LPNAME' type, -which holds a pointer to your structure. In the example above, -'LPPOINT' is also defined and can be used in a call to a -Win32::API (in fact, this is what you're really going to use when -doing API calls). - -=item C<new NAME> - -This creates a structure (a Win32::API::Struct object) of the -type C<NAME> (it must have been defined with C<typedef>). In Perl, -when you create a structure, all the members are undefined. But -when you use that structure in C (eg. a Win32::API call), you -can safely assume that they will be treated as zero (or NULL). - -=item C<sizeof> - -This returns the size, in bytes, of the structure. Acts just like -the C function of the same name. It is particularly useful for -structures that need a member to be initialized to the structure's -own size. - -=item C<align [SIZE]> - -Sets or returns the structure alignment (eg. how the structure is -stored in memory). This is a very advanced option, and you normally -don't need to mess with it. -All structures in the Win32 Platform SDK should work without it. -But if you define your own structure, you may need to give it an -explicit alignment. In most cases, passing a C<SIZE> of 'auto' -should keep the world happy. - -=back - -=head2 THE C<tie> INTERFACE - -Instead of creating an object with the C<new> method, you can -tie a hash, which will hold the desired structure, using the -C<tie> builtin function: - - tie %structure, Win32::API::Struct => 'NAME'; - -The differences between the tied and non-tied approaches are: - -=over 4 - -=item * -with tied structures, you can access members directly as -hash lookups, eg. - - # tied # non-tied - $Point{x} vs. $Point->{x} - -=item * -with tied structures, when you try to fetch or store a -member that is not part of the structure, it will result -in a warning, eg. - - print $Point{z}; - # this will warn: 'z' is not a member of Win32::API::Struct POINT - -=item * -when you pass a tied structure as a Win32::API parameter, -remember to backslash it, eg. - - # tied # non-tied - GetCursorPos( \%Point ) vs. GetCursorPos( $Point ) - -=back - -=head1 AUTHOR - -Aldo Calpini ( I<dada@perl.it> ). - -=head1 MAINTAINER - -Cosimo Streppone ( I<cosimo@cpan.org> ). - -=cut diff --git a/Master/tlpkg/tlperl/lib/Win32/API/Test.pm b/Master/tlpkg/tlperl/lib/Win32/API/Test.pm deleted file mode 100644 index 6cbeed6bfac..00000000000 --- a/Master/tlpkg/tlperl/lib/Win32/API/Test.pm +++ /dev/null @@ -1,120 +0,0 @@ -# -# Win32::API::Test - Test helper package for Win32::API -# -# Version: 0.01 -# Date: 23 Dec 2006 -# Author: Cosimo Streppone <cosimo@cpan.org> -# -# $Id: API.pm,v 1.0 2001/10/30 13:57:31 dada Exp $ -# -package Win32::API::Test; - -sub compiler_name () { - use Config; - my $cc = $Config{ccname}; - if($cc eq 'cl' || $cc eq 'cl.exe') - { - $cc = 'cl'; - } - return($cc); -} - -sub compiler_version () { - use Config; - my $ver = $Config{ccversion} || 0; - if( $ver =~ /^(\d+\.\d+)/ ) - { - $ver = 0 + $1; - } - return($ver); -} - -# -# Run the compiler and get version from there... -# User might be running a compiler different from -# that used to build perl. -# For example, Cosimo does. For testing, of course. -# -# *** -# *** IT DOES NOT WORK NOW. -# *** FOR REASONS I DON'T KNOW, CL.EXE OUTPUTS ITS -# *** VERSION STRING IN THE FIRST TWO LINES THAT -# *** I'M NOT ABLE TO CATCH... -# *** -# -sub compiler_version_from_shell () { - my $cc = compiler_name(); - my $ver; - # MSVC - if($cc eq 'cl') - { - my @ver = `$cc`; - my $ver = join('',@ver); - print 'VER:'.$ver.':'."\n"; - if($ver =~ /Version (\d[\d\.]+)/ms ) - { - $ver = $1; - } - } - # GCC - elsif($cc eq 'cc' || $cc eq 'gcc' || $cc eq 'winegcc' ) - { - $ver = join('', `$cc --version`); - if($ver =~ /gcc.*(\d[\d+]+)/ms ) - { - $ver = $1; - } - } - # Borland C - elsif($cc eq 'bcc32' || $cc eq 'bcc') - { - $ver = join('', `$cc`); - if($ver =~ /Borland C\+\+ (\d[\d\.]+)/ms ) - { - $ver = $1; - } - } - return($ver); -} - -sub find_test_dll () { - require File::Spec; - my $dll_name = $_[0]; - my @paths = qw(.. ../t ../t/dll . ./dll ./t/dll); - while(my $path = shift @paths) - { - $dll = File::Spec->catfile($path, $dll_name); - return $dll if -s $dll; - } - return(undef); -} - -1; - -__END__ - - -####################################################################### -# DOCUMENTATION -# - -=head1 NAME - -Win32::API::Test - Test helper package for Win32::API - -=head1 SYNOPSIS - - my $test_dll = Win32::API::Test::find_test_dll('API_test.dll'); - -Check the t/*.t test scripts for more details. - -=head1 DESCRIPTION - -Simple package to hold Win32::API test suite helper functions. -No more, no less. - -=head1 AUTHOR - -Cosimo Streppone ( I<cosimo@cpan.org> ) - -=cut diff --git a/Master/tlpkg/tlperl/lib/Win32/API/Type.pm b/Master/tlpkg/tlperl/lib/Win32/API/Type.pm deleted file mode 100644 index 334b0b731e1..00000000000 --- a/Master/tlpkg/tlperl/lib/Win32/API/Type.pm +++ /dev/null @@ -1,446 +0,0 @@ -package Win32::API::Type; - -# See the bottom of this file for the POD documentation. Search for the -# string '=head'. - -####################################################################### -# -# Win32::API::Type - Perl Win32 API type definitions -# -# Author: Aldo Calpini <dada@perl.it> -# Maintainer: Cosimo Streppone <cosimo@cpan.org> -# -# $Id: Type.pm,v 1.0 2001/10/30 13:57:31 dada Exp $ -####################################################################### - -$VERSION = '0.47'; - -use Carp; - -require Exporter; # to export the constants to the main:: space -require DynaLoader; # to dynuhlode the module. -@ISA = qw( Exporter DynaLoader ); - -use vars qw( %Known %PackSize %Modifier %Pointer ); - -sub DEBUG { - if ($Win32::API::DEBUG) { - printf @_ if @_ or return 1; - } else { - return 0; - } -} - -%Known = (); -%PackSize = (); -%Modifier = (); -%Pointer = (); - -# Initialize data structures at startup. -# Aldo wants to keep the <DATA> approach. -# -my $section = 'nothing'; -foreach (<DATA>) { - next if /^\s*#/ or /^\s*$/; - chomp; - if( /\[(.+)\]/) { - $section = $1; - next; - } - if($section eq 'TYPE') { - my($name, $packing) = split(/\s+/); - # DEBUG "(PM)Type::INIT: Known('$name') => '$packing'\n"; - $Known{$name} = $packing; - } elsif($section eq 'PACKSIZE') { - my($packing, $size) = split(/\s+/); - # DEBUG "(PM)Type::INIT: PackSize('$packing') => '$size'\n"; - $PackSize{$packing} = $size; - } elsif($section eq 'MODIFIER') { - my($modifier, $mapto) = split(/\s+/, $_, 2); - my %maps = (); - foreach my $item (split(/\s+/, $mapto)) { - my($k, $v) = split(/=/, $item); - $maps{$k} = $v; - } - # DEBUG "(PM)Type::INIT: Modifier('$modifier') => '%maps'\n"; - $Modifier{$modifier} = { %maps }; - } elsif($section eq 'POINTER') { - my($pointer, $pointto) = split(/\s+/); - # DEBUG "(PM)Type::INIT: Pointer('$pointer') => '$pointto'\n"; - $Pointer{$pointer} = $pointto; - } -} -close(DATA); - -sub new { - my $class = shift; - my($type) = @_; - my $packing = packing($type); - my $size = sizeof($type); - my $self = { - type => $type, - packing => $packing, - size => $size, - }; - return bless $self; -} - -sub typedef { - my $class = shift; - my($name, $type) = @_; - my $packing = packing($type, $name); - DEBUG "(PM)Type::typedef: packing='$packing'\n"; - my $size = sizeof($type); - $Known{$name} = $packing; - return 1; -} - - -sub is_known { - my $self = shift; - my $type = shift; - $type = $self unless defined $type; - if(ref($type) =~ /Win32::API::Type/) { - return 1; - } else { - return defined packing($type); - } -} - -sub sizeof { - my $self = shift; - my $type = shift; - $type = $self unless defined $type; - if(ref($type) =~ /Win32::API::Type/) { - return $self->{size}; - } else { - my $packing = packing($type); - if($packing =~ /(\w)\*(\d+)/) { - return $PackSize{ $1 } * $2; - } else { - return $PackSize{ $packing }; - } - } -} - -sub packing { - # DEBUG "(PM)Type::packing: called by ". join("::", (caller(1))[0,3]). "\n"; - my $self = shift; - my $is_pointer = 0; - if(ref($self) =~ /Win32::API::Type/) { - # DEBUG "(PM)Type::packing: got an object\n"; - return $self->{packing}; - } - my $type = ($self eq 'Win32::API::Type') ? shift : $self; - my $name = shift; - - # DEBUG "(PM)Type::packing: got '$type', '$name'\n"; - my($modifier, $size, $packing); - if(exists $Pointer{$type}) { - # DEBUG "(PM)Type::packing: got '$type', is really '$Pointer{$type}'\n"; - $type = $Pointer{$type}; - $is_pointer = 1; - } elsif($type =~ /(\w+)\s+(\w+)/) { - $modifier = $1; - $type = $2; - # DEBUG "(PM)packing: got modifier '$modifier', type '$type'\n"; - } - - $type =~ s/\*$//; - - if(exists $Known{$type}) { - if(defined $name and $name =~ s/\[(.*)\]$//) { - $size = $1; - $packing = $Known{$type}[0]."*".$size; - # DEBUG "(PM)Type::packing: composite packing: '$packing' '$size'\n"; - } else { - $packing = $Known{$type}; - if($is_pointer and $packing eq 'c') { - $packing = "p"; - } - # DEBUG "(PM)Type::packing: simple packing: '$packing'\n"; - } - if(defined $modifier and exists $Modifier{$modifier}->{$type}) { - # DEBUG "(PM)Type::packing: applying modifier '$modifier' -> '$Modifier{$modifier}->{$type}'\n"; - $packing = $Modifier{$modifier}->{$type}; - } - return $packing; - } else { - # DEBUG "(PM)Type::packing: NOT FOUND\n"; - return undef; - } -} - - -sub is_pointer { - my $self = shift; - my $type = shift; - $type = $self unless defined $type; - if(ref($type) =~ /Win32::API::Type/) { - return 1; - } else { - if($type =~ /\*$/) { - return 1; - } else { - return exists $Pointer{$type}; - } - } -} - -sub Pack { - my $type = $_[0]; - - if(packing($type) eq 'c' and is_pointer($type)) { - $_[1] = pack("Z*", $_[1]); - return $_[1]; - } - $_[1] = pack( packing($type), $_[1]); - return $_[1]; -} - -sub Unpack { - my $type = $_[0]; - if(packing($type) eq 'c' and is_pointer($type)) { - DEBUG "(PM)Type::Unpack: got packing 'c', is a pointer, unpacking 'Z*' '$_[1]'\n"; - $_[1] = unpack("Z*", $_[1]); - DEBUG "(PM)Type::Unpack: returning '$_[1]'\n"; - return $_[1]; - } - DEBUG "(PM)Type::Unpack: unpacking '".packing($type)."' '$_[1]'\n"; - $_[1] = unpack( packing($type), $_[1]); - DEBUG "(PM)Type::Unpack: returning '$_[1]'\n"; - return $_[1]; -} - -1; - -####################################################################### -# DOCUMENTATION -# - -=head1 NAME - -Win32::API::Type - C type support package for Win32::API - -=head1 SYNOPSIS - - use Win32::API; - - Win32::API::Type->typedef( 'my_number', 'LONG' ); - - -=head1 ABSTRACT - -This module is a support package for Win32::API that implements -C types for the import with prototype functionality. - -See L<Win32::API> for more info about its usage. - -=head1 DESCRIPTION - -This module is automatically imported by Win32::API, so you don't -need to 'use' it explicitly. These are the methods of this package: - -=over 4 - -=item C<typedef NAME, TYPE> - -This method defines a new type named C<NAME>. This actually just -creates an alias for the already-defined type C<TYPE>, which you -can use as a parameter in a Win32::API call. - -=item C<sizeof TYPE> - -This returns the size, in bytes, of C<TYPE>. Acts just like -the C function of the same name. - -=item C<is_known TYPE> - -Returns true if C<TYPE> is known by Win32::API::Type, false -otherwise. - -=back - -=head2 SUPPORTED TYPES - -This module should recognize all the types defined in the -Win32 Platform SDK header files. -Please see the source for this module, in the C<__DATA__> section, -for the full list. - -=head1 AUTHOR - -Aldo Calpini ( I<dada@perl.it> ). - -=head1 MAINTAINER - -Cosimo Streppone ( I<cosimo@cpan.org> ). - -=cut - - -__DATA__ - -[TYPE] -ATOM s -BOOL L -BOOLEAN c -BYTE C -CHAR c -COLORREF L -DWORD L -DWORD32 L -DWORD64 Q -FLOAT f -HACCEL L -HANDLE L -HBITMAP L -HBRUSH L -HCOLORSPACE L -HCONV L -HCONVLIST L -HCURSOR L -HDC L -HDDEDATA L -HDESK L -HDROP L -HDWP L -HENHMETAFILE L -HFILE L -HFONT L -HGDIOBJ L -HGLOBAL L -HHOOK L -HICON L -HIMC L -HINSTANCE L -HKEY L -HKL L -HLOCAL L -HMENU L -HMETAFILE L -HMODULE L -HPALETTE L -HPEN L -HRGN L -HRSRC L -HSZ L -HWINSTA L -HWND L -INT i -INT32 i -INT64 q -LANGID s -LCID L -LCSCSTYPE L -LCSGAMUTMATCH L -LCTYPE L -LONG l -LONG32 l -LONG64 q -LONGLONG q -LPARAM L -LRESULT L -REGSAM L -SC_HANDLE L -SC_LOCK L -SERVICE_STATUS_HANDLE L -SHORT s -SIZE_T L -SSIZE_T L -TBYTE c -TCHAR C -UCHAR C -UINT I -UINT_PTR L -UINT32 I -UINT64 Q -ULONG L -ULONG32 L -ULONG64 Q -ULONGLONG Q -USHORT S -WCHAR S -WORD S -WPARAM L -VOID c - -int i -long l -float f -double d -char c - -#CRITICAL_SECTION 24 -- a structure -#LUID ? 8 -- a structure -#VOID 0 -#CONST 4 -#FILE_SEGMENT_ELEMENT 8 -- a structure - -[PACKSIZE] -c 1 -C 1 -d 8 -f 4 -i 4 -I 4 -l 4 -L 4 -q 8 -Q 8 -s 2 -S 2 -p 4 - -[MODIFIER] -unsigned int=I long=L short=S char=C - -[POINTER] -INT_PTR INT -LPBOOL BOOL -LPBYTE BYTE -LPCOLORREF COLORREF -LPCSTR CHAR -#LPCTSTR CHAR or WCHAR -LPCTSTR CHAR -LPCVOID any -LPCWSTR WCHAR -LPDWORD DWORD -LPHANDLE HANDLE -LPINT INT -LPLONG LONG -LPSTR CHAR -#LPTSTR CHAR or WCHAR -LPTSTR CHAR -LPVOID VOID -LPWORD WORD -LPWSTR WCHAR - -PBOOL BOOL -PBOOLEAN BOOL -PBYTE BYTE -PCHAR CHAR -PCSTR CSTR -PCWCH CWCH -PCWSTR CWSTR -PDWORD DWORD -PFLOAT FLOAT -PHANDLE HANDLE -PHKEY HKEY -PINT INT -PLCID LCID -PLONG LONG -PSHORT SHORT -PSTR CHAR -#PTBYTE TBYTE -- -#PTCHAR TCHAR -- -#PTSTR CHAR or WCHAR -PTSTR CHAR -PUCHAR UCHAR -PUINT UINT -PULONG ULONG -PUSHORT USHORT -PVOID VOID -PWCHAR WCHAR -PWORD WORD -PWSTR WCHAR diff --git a/Master/tlpkg/tlperl/lib/Win32/ChangeNotify.pm b/Master/tlpkg/tlperl/lib/Win32/ChangeNotify.pm deleted file mode 100644 index a86682da376..00000000000 --- a/Master/tlpkg/tlperl/lib/Win32/ChangeNotify.pm +++ /dev/null @@ -1,198 +0,0 @@ -#--------------------------------------------------------------------- -package Win32::ChangeNotify; -# -# Copyright 1998 Christopher J. Madsen -# -# Created: 3 Feb 1998 from the ActiveWare version -# (c) 1995 Microsoft Corporation. All rights reserved. -# Developed by ActiveWare Internet Corp., http://www.ActiveWare.com -# -# Other modifications (c) 1997 by Gurusamy Sarathy <gsar@activestate.com> -# -# Author: Christopher J. Madsen <cjm@pobox.com> -# Version: 1.02 (13-Jun-1999) -# -# This program is free software; you can redistribute it and/or modify -# it under the same terms as Perl itself. -# -# This program is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See either the -# GNU General Public License or the Artistic License for more details. -# -# Monitor directory for changes -#--------------------------------------------------------------------- -# 1.04 -Minor changes by Yves Orton to fix the trueness of $subtree (Dec 2002) - -$VERSION = '1.05'; - -use Carp; -use Win32::IPC 1.00 '/./'; # Import everything -require Exporter; -require DynaLoader; - -@ISA = qw(Exporter DynaLoader Win32::IPC); -# 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( - FILE_NOTIFY_CHANGE_ATTRIBUTES - FILE_NOTIFY_CHANGE_DIR_NAME - FILE_NOTIFY_CHANGE_FILE_NAME - FILE_NOTIFY_CHANGE_LAST_WRITE - FILE_NOTIFY_CHANGE_SECURITY - FILE_NOTIFY_CHANGE_SIZE - INFINITE -); -@EXPORT_OK = qw( - wait_all wait_any -); - -sub AUTOLOAD { - # This AUTOLOAD is used to 'autoload' constants from the constant() - # XS function. - - my $constname; - ($constname = $AUTOLOAD) =~ s/.*:://; - if ($constname =~ /^(?:FILE_NOTIFY_CHANGE_|INFINITE)/) { - local $! = 0; - my $val = constant($constname); - croak("$constname is not defined by Win32::ChangeNotify") if $! != 0; - eval "sub $AUTOLOAD { $val }"; - goto &$AUTOLOAD; - } -} # end AUTOLOAD - -bootstrap Win32::ChangeNotify; - -sub new { - my ($class,$path,$subtree,$filter) = @_; - - if ($filter =~ /\A[\s|A-Z_]+\Z/i) { - $filter = 0; - foreach (split(/[\s|]+/, $_[3])) { - $filter |= constant("FILE_NOTIFY_CHANGE_" . uc $_); - carp "Invalid filter $_" if $!; - } - } - _new($class,$path,$subtree,$filter); -} # end new - -sub Close { &close } - -sub FindFirst { $_[0] = Win32::ChangeNotify->_new(@_[1..3]); } - -sub FindNext { &reset } - -1; -__END__ - -=head1 NAME - -Win32::ChangeNotify - Monitor events related to files and directories - -=head1 SYNOPSIS - - require Win32::ChangeNotify; - - $notify = Win32::ChangeNotify->new($Path,$WatchSubTree,$Events); - $notify->wait or warn "Something failed: $!\n"; - # There has been a change. - -=head1 DESCRIPTION - -This module allows the user to use a Win32 change notification event -object from Perl. This allows the Perl program to monitor events -relating to files and directory trees. - -Unfortunately, the Win32 API which implements this feature does not -provide any indication of I<what> triggered the notification (as far -as I know). If you're monitoring a directory for file changes, and -you need to know I<which> file changed, you'll have to find some other -way of determining that. Depending on exactly what you're trying to -do, you may be able to check file timestamps to find recently changed -files. Or, you may need to cache the directory contents somewhere and -compare the current contents to your cached copy when you receive a -change notification. - -The C<wait> method and C<wait_all> & C<wait_any> functions are -inherited from the L<"Win32::IPC"> module. - -=head2 Methods - -=over 4 - -=item $notify = Win32::ChangeNotify->new($path, $subtree, $filter) - -Constructor for a new ChangeNotification object. C<$path> is the -directory to monitor. If C<$subtree> is true, then all directories -under C<$path> will be monitored. C<$filter> indicates what events -should trigger a notification. It should be a string containing any -of the following flags (separated by whitespace and/or C<|>). - - ATTRIBUTES Any attribute change - DIR_NAME Any directory name change - FILE_NAME Any file name change (creating/deleting/renaming) - LAST_WRITE Any change to a file's last write time - SECURITY Any security descriptor change - SIZE Any change in a file's size - -(C<$filter> can also be an integer composed from the -C<FILE_NOTIFY_CHANGE_*> constants.) - -=item $notify->close - -Shut down monitoring. You could just C<undef $notify> instead (but -C<close> works even if there are other copies of the object). This -happens automatically when your program exits. - -=item $notify->reset - -Resets the ChangeNotification object after a change has been detected. -The object will become signalled again after the next change. (It is -OK to call this immediately after C<new>, but it is not required.) - -=item $notify->wait - -See L<"Win32::IPC">. Remember to call C<reset> afterwards if you want -to continue monitoring. - -=back - -=head2 Deprecated Functions and Methods - -B<Win32::ChangeNotify> still supports the ActiveWare syntax, but its -use is deprecated. - -=over 4 - -=item FindFirst($Obj,$PathName,$WatchSubTree,$Filter) - -Use - - $Obj = Win32::ChangeNotify->new($PathName,$WatchSubTree,$Filter) - -instead. - -=item $obj->FindNext() - -Use C<$obj-E<gt>reset> instead. - -=item $obj->Close() - -Use C<$obj-E<gt>close> instead. - -=back - -=head1 AUTHOR - -Christopher J. Madsen E<lt>F<cjm@pobox.com>E<gt> - -Loosely based on the original module by ActiveWare Internet Corp., -F<http://www.ActiveWare.com> - -=cut - -# Local Variables: -# tmtrack-file-task: "Win32::ChangeNotify" -# End: diff --git a/Master/tlpkg/tlperl/lib/Win32/Client.pl b/Master/tlpkg/tlperl/lib/Win32/Client.pl deleted file mode 100644 index 6ae585b7c91..00000000000 --- a/Master/tlpkg/tlperl/lib/Win32/Client.pl +++ /dev/null @@ -1,63 +0,0 @@ -use strict; -use Win32::Pipe; - -#### -# You may notice that named pipe names are case INsensitive! -#### - -my $PipeName = "\\\\.\\pipe\\TEST this LoNG Named Pipe!"; - -print "I am falling asleep for few seconds, so that we give time\nFor the server to get up and running.\n"; -sleep(4); -print "\nOpening a pipe ...\n"; - -if (my $Pipe = Win32::Pipe->new($PipeName)) { - print "\n\nPipe has been opened, writing data to it...\n"; - print "-------------------------------------------\n"; - $Pipe->Write("\n" . Win32::Pipe::Credit() . "\n\n"); - while () { - print "\nCommands:\n"; - print " FILE:xxxxx Dumps the file xxxxx.\n"; - print " Credit Dumps the credit screen.\n"; - print " Quit Quits this client (server remains running).\n"; - print " Exit Exits both client and server.\n"; - print " -----------------------------------------\n"; - - my $In = <STDIN>; - chop($In); - - if ((my $File = $In) =~ s/^file:(.*)/$1/i){ - if (-s $File) { - if (open(FILE, "< $File")) { - while ($File = <FILE>) { - $In .= $File; - }; - close(FILE); - } - } - } - - if ($In =~ /^credit$/i){ - $In = "\n" . Win32::Pipe::Credit() . "\n\n"; - } - - unless ($Pipe->Write($In)) { - print "Writing to pipe failed.\n"; - last; - } - - if ($In =~ /^(exit|quit)$/i) { - print "\nATTENTION: Closing due to user request.\n"; - last; - } - } - print "Closing...\n"; - $Pipe->Close(); -} -else { - my($Error, $ErrorText) = Win32::Pipe::Error(); - print "Error:$Error \"$ErrorText\"\n"; - sleep(4); -} - -print "Done...\n"; diff --git a/Master/tlpkg/tlperl/lib/Win32/Clipboard.pm b/Master/tlpkg/tlperl/lib/Win32/Clipboard.pm deleted file mode 100644 index ba4038a5ade..00000000000 --- a/Master/tlpkg/tlperl/lib/Win32/Clipboard.pm +++ /dev/null @@ -1,369 +0,0 @@ -package Win32::Clipboard; -####################################################################### -# -# Win32::Clipboard - Interaction with the Windows clipboard -# -# Version: 0.52 -# Author: Aldo Calpini <dada@perl.it> -# -# Modified by: Hideyo Imazu <himazu@gmail.com> -# -####################################################################### - -require Exporter; # to export the constants to the main:: space -require DynaLoader; # to dynuhlode the module. - -@ISA = qw( Exporter DynaLoader ); -@EXPORT = qw( - CF_TEXT - CF_BITMAP - CF_METAFILEPICT - CF_SYLK - CF_DIF - CF_TIFF - CF_OEMTEXT - CF_DIB - CF_PALETTE - CF_PENDATA - CF_RIFF - CF_WAVE - CF_UNICODETEXT - CF_ENHMETAFILE - CF_HDROP - CF_LOCALE -); - -####################################################################### -# This AUTOLOAD is used to 'autoload' constants from the constant() -# XS function. If a constant is not found then control is passed -# to the AUTOLOAD in AutoLoader. -# - -sub AUTOLOAD { - my($constname); - ($constname = $AUTOLOAD) =~ s/.*:://; - #reset $! to zero to reset any current errors. - local $! = 0; - my $val = constant($constname, @_ ? $_[0] : 0); - if ($! != 0) { - if ($! =~ /Invalid/) { - $AutoLoader::AUTOLOAD = $AUTOLOAD; - goto &AutoLoader::AUTOLOAD; - } else { - my ($pack, $file, $line) = caller; - die "Win32::Clipboard::$constname is not defined, used at $file line $line."; - } - } - eval "sub $AUTOLOAD { $val }"; - goto &$AUTOLOAD; -} - - -####################################################################### -# STATIC OBJECT PROPERTIES -# -$VERSION = "0.5201"; - -####################################################################### -# FUNCTIONS -# - -sub new { - my($class, $value) = @_; - my $self = "I'm the Clipboard!"; - Set($value) if defined($value); - return bless(\$self); -} - -sub Version { - return $VERSION; -} - -sub Get { - if( IsBitmap() ) { return GetBitmap(); } - elsif( IsFiles() ) { return GetFiles(); } - else { return GetText(); } -} - -sub TIESCALAR { - my $class = shift; - my $value = shift; - Set($value) if defined $value; - my $self = "I'm the Clipboard!"; - return bless \$self, $class; -} - -sub FETCH { Get() } -sub STORE { shift; Set(@_) } - -sub DESTROY { - my($self) = @_; - undef $self; - StopClipboardViewer(); -} - -END { - StopClipboardViewer(); -} - -####################################################################### -# dynamically load in the Clipboard.pll module. -# - -bootstrap Win32::Clipboard; - -####################################################################### -# a little hack to use the module itself as a class. -# - -sub main::Win32::Clipboard { - my($value) = @_; - my $self={}; - my $result = Win32::Clipboard::Set($value) if defined($value); - return bless($self, "Win32::Clipboard"); -} - -1; - -__END__ - -=head1 NAME - -Win32::Clipboard - Interaction with the Windows clipboard - -=head1 SYNOPSIS - - use Win32::Clipboard; - - $CLIP = Win32::Clipboard(); - - print "Clipboard contains: ", $CLIP->Get(), "\n"; - - $CLIP->Set("some text to copy into the clipboard"); - - $CLIP->Empty(); - - $CLIP->WaitForChange(); - print "Clipboard has changed!\n"; - - -=head1 DESCRIPTION - -This module lets you interact with the Windows clipboard: you can get its content, -set it, empty it, or let your script sleep until it changes. -This version supports 3 formats for clipboard data: - -=over 4 - -=item * -text (C<CF_TEXT>) - -The clipboard contains some text; this is the B<only> format you can use to set -clipboard data; you get it as a single string. - -Example: - - $text = Win32::Clipboard::GetText(); - print $text; - -=item * -bitmap (C<CF_DIB>) - -The clipboard contains an image, either a bitmap or a picture copied in the -clipboard from a graphic application. The data you get is a binary buffer -ready to be written to a bitmap (BMP format) file. - -Example: - - $image = Win32::Clipboard::GetBitmap(); - open BITMAP, ">some.bmp"; - binmode BITMAP; - print BITMAP $image; - close BITMAP; - -=item * -list of files (C<CF_HDROP>) - -The clipboard contains files copied or cutted from an Explorer-like -application; you get a list of filenames. - -Example: - - @files = Win32::Clipboard::GetFiles(); - print join("\n", @files); - -=back - -=head2 REFERENCE - -All the functions can be used either with their full name (eg. B<Win32::Clipboard::Get>) -or as methods of a C<Win32::Clipboard> object. -For the syntax, refer to L</SYNOPSIS> above. Note also that you can create a clipboard -object and set its content at the same time with: - - $CLIP = Win32::Clipboard("blah blah blah"); - -or with the more common form: - - $CLIP = new Win32::Clipboard("blah blah blah"); - -If you prefer, you can even tie the Clipboard to a variable like this: - - tie $CLIP, 'Win32::Clipboard'; - - print "Clipboard content: $CLIP\n"; - - $CLIP = "some text to copy to the clipboard..."; - -In this case, you can still access other methods using the tied() function: - - tied($CLIP)->Empty; - print "got the picture" if tied($CLIP)->IsBitmap; - -=over 4 - -=item Empty() - -Empty the clipboard. - -=for html <P> - -=item EnumFormats() - -Returns an array of identifiers describing the format for the data currently in the -clipboard. Formats can be standard ones (described in the L</CONSTANTS> section) or -application-defined custom ones. See also IsFormatAvailable(). - -=for html <P> - -=item Get() - -Returns the clipboard content; note that the result depends on the nature of -clipboard data; to ensure that you get only the desired format, you should use -GetText(), GetBitmap() or GetFiles() instead. Get() is in fact implemented as: - - if( IsBitmap() ) { return GetBitmap(); } - elsif( IsFiles() ) { return GetFiles(); } - else { return GetText(); } - -See also IsBitmap(), IsFiles(), IsText(), EnumFormats() and IsFormatAvailable() -to check the clipboard format before getting data. - -=for html <P> - -=item GetAs(FORMAT) - -Returns the clipboard content in the desired FORMAT (can be one of the constants -defined in the L</CONSTANTS> section or a custom format). Note that the only -meaningful identifiers are C<CF_TEXT>, C<CF_DIB> and C<CF_HDROP>; any other -format is treated as a string. - -=for html <P> - -=item GetBitmap() - -Returns the clipboard content as an image, or C<undef> on errors. - -=for html <P> - -=item GetFiles() - -Returns the clipboard content as a list of filenames, or C<undef> on errors. - -=for html <P> - -=item GetFormatName(FORMAT) - -Returns the name of the specified custom clipboard format, or C<undef> on errors; -note that you cannot get the name of the standard formats (described in the -L</CONSTANTS> section). - -=for html <P> - -=item GetText() - -Returns the clipboard content as a string, or C<undef> on errors. - -=for html <P> - -=item IsBitmap() - -Returns a boolean value indicating if the clipboard contains an image. -See also GetBitmap(). - -=for html <P> - -=item IsFiles() - -Returns a boolean value indicating if the clipboard contains a list of -files. See also GetFiles(). - -=for html <P> - -=item IsFormatAvailable(FORMAT) - -Checks if the clipboard data matches the specified FORMAT (one of the constants -described in the L</CONSTANTS> section); returns zero if the data does not match, -a nonzero value if it matches. - -=for html <P> - -=item IsText() - -Returns a boolean value indicating if the clipboard contains text. -See also GetText(). - -=for html <P> - -=item Set(VALUE) - -Set the clipboard content to the specified string. - -=for html <P> - -=item WaitForChange([TIMEOUT]) - -This function halts the script until the clipboard content changes. If you specify -a C<TIMEOUT> value (in milliseconds), the function will return when this timeout -expires, even if the clipboard hasn't changed. If no value is given, it will wait -indefinitely. Returns 1 if the clipboard has changed, C<undef> on errors. - -=back - -=head2 CONSTANTS - -These constants are the standard clipboard formats recognized by Win32::Clipboard: - - CF_TEXT 1 - CF_DIB 8 - CF_HDROP 15 - -The following formats are B<not recognized> by Win32::Clipboard; they are, -however, exported constants and can eventually be used with the EnumFormats(), -IsFormatAvailable() and GetAs() functions: - - CF_BITMAP 2 - CF_METAFILEPICT 3 - CF_SYLK 4 - CF_DIF 5 - CF_TIFF 6 - CF_OEMTEXT 7 - CF_PALETTE 9 - CF_PENDATA 10 - CF_RIFF 11 - CF_WAVE 12 - CF_UNICODETEXT 13 - CF_ENHMETAFILE 14 - CF_LOCALE 16 - -=head1 AUTHOR - -This version was released by Hideyo Imazu <F<himazu@gmail.com>>. - -Aldo Calpini <F<dada@perl.it>> was the former maintainer. - -Original XS porting by Gurusamy Sarathy <F<gsar@activestate.com>>. - -=cut - - diff --git a/Master/tlpkg/tlperl/lib/Win32/Console.pm b/Master/tlpkg/tlperl/lib/Win32/Console.pm deleted file mode 100644 index 1e3876a6a33..00000000000 --- a/Master/tlpkg/tlperl/lib/Win32/Console.pm +++ /dev/null @@ -1,1463 +0,0 @@ -####################################################################### -# -# Win32::Console - Win32 Console and Character Mode Functions -# -####################################################################### - -package Win32::Console; - -require Exporter; -require DynaLoader; - -$VERSION = "0.07"; - -@ISA= qw( Exporter DynaLoader ); -@EXPORT = qw( - BACKGROUND_BLUE - BACKGROUND_GREEN - BACKGROUND_INTENSITY - BACKGROUND_RED - CAPSLOCK_ON - CONSOLE_TEXTMODE_BUFFER - CTRL_BREAK_EVENT - CTRL_C_EVENT - ENABLE_ECHO_INPUT - ENABLE_LINE_INPUT - ENABLE_MOUSE_INPUT - ENABLE_PROCESSED_INPUT - ENABLE_PROCESSED_OUTPUT - ENABLE_WINDOW_INPUT - ENABLE_WRAP_AT_EOL_OUTPUT - ENHANCED_KEY - FILE_SHARE_READ - FILE_SHARE_WRITE - FOREGROUND_BLUE - FOREGROUND_GREEN - FOREGROUND_INTENSITY - FOREGROUND_RED - LEFT_ALT_PRESSED - LEFT_CTRL_PRESSED - NUMLOCK_ON - GENERIC_READ - GENERIC_WRITE - RIGHT_ALT_PRESSED - RIGHT_CTRL_PRESSED - SCROLLLOCK_ON - SHIFT_PRESSED - STD_INPUT_HANDLE - STD_OUTPUT_HANDLE - STD_ERROR_HANDLE - $FG_BLACK - $FG_GRAY - $FG_BLUE - $FG_LIGHTBLUE - $FG_RED - $FG_LIGHTRED - $FG_GREEN - $FG_LIGHTGREEN - $FG_MAGENTA - $FG_LIGHTMAGENTA - $FG_CYAN - $FG_LIGHTCYAN - $FG_BROWN - $FG_YELLOW - $FG_LIGHTGRAY - $FG_WHITE - $BG_BLACK - $BG_GRAY - $BG_BLUE - $BG_LIGHTBLUE - $BG_RED - $BG_LIGHTRED - $BG_GREEN - $BG_LIGHTGREEN - $BG_MAGENTA - $BG_LIGHTMAGENTA - $BG_CYAN - $BG_LIGHTCYAN - $BG_BROWN - $BG_YELLOW - $BG_LIGHTGRAY - $BG_WHITE - $ATTR_NORMAL - $ATTR_INVERSE - @CONSOLE_COLORS -); - - -####################################################################### -# This AUTOLOAD is used to 'autoload' constants from the constant() -# XS function. If a constant is not found then control is passed -# to the AUTOLOAD in AutoLoader. -# - -sub AUTOLOAD { - my($constname); - ($constname = $AUTOLOAD) =~ s/.*:://; - #reset $! to zero to reset any current errors. - local $! = 0; - my $val = constant($constname, @_ ? $_[0] : 0); - if ($! != 0) { -# if ($! =~ /Invalid/) { -# $AutoLoader::AUTOLOAD = $AUTOLOAD; -# goto &AutoLoader::AUTOLOAD; -# } else { - ($pack, $file, $line) = caller; undef $pack; - die "Symbol Win32::Console::$constname not defined, used at $file line $line."; -# } - } - eval "sub $AUTOLOAD { $val }"; - goto &$AUTOLOAD; -} - - -####################################################################### -# STATIC OBJECT PROPERTIES -# - -# %HandlerRoutineStack = (); -# $HandlerRoutineRegistered = 0; - -####################################################################### -# PUBLIC METHODS -# - -#======== -sub new { -#======== - my($class, $param1, $param2) = @_; - - my $self = {}; - - if (defined($param1) - and ($param1 == constant("STD_INPUT_HANDLE", 0) - or $param1 == constant("STD_OUTPUT_HANDLE", 0) - or $param1 == constant("STD_ERROR_HANDLE", 0))) - { - $self->{'handle'} = _GetStdHandle($param1); - } - else { - $param1 = constant("GENERIC_READ", 0) | constant("GENERIC_WRITE", 0) unless $param1; - $param2 = constant("FILE_SHARE_READ", 0) | constant("FILE_SHARE_WRITE", 0) unless $param2; - $self->{'handle'} = _CreateConsoleScreenBuffer($param1, $param2, - constant("CONSOLE_TEXTMODE_BUFFER", 0)); - } - bless $self, $class; - return $self; -} - -#============ -sub Display { -#============ - my($self) = @_; - return undef unless ref($self); - return _SetConsoleActiveScreenBuffer($self->{'handle'}); -} - -#=========== -sub Select { -#=========== - my($self, $type) = @_; - return undef unless ref($self); - return _SetStdHandle($type, $self->{'handle'}); -} - -#=========== -sub SetIcon { -#=========== - my($self, $icon) = @_; - $icon = $self unless ref($self); - return _SetConsoleIcon($icon); -} - -#========== -sub Title { -#========== - my($self, $title) = @_; - $title = $self unless ref($self); - - if (defined($title)) { - return _SetConsoleTitle($title); - } - else { - return _GetConsoleTitle(); - } -} - -#============== -sub WriteChar { -#============== - my($self, $text, $col, $row) = @_; - return undef unless ref($self); - return _WriteConsoleOutputCharacter($self->{'handle'},$text,$col,$row); -} - -#============= -sub ReadChar { -#============= - my($self, $size, $col, $row) = @_; - return undef unless ref($self); - - my $buffer = (" " x $size); - if (_ReadConsoleOutputCharacter($self->{'handle'}, $buffer, $size, $col, $row)) { - return $buffer; - } - else { - return undef; - } -} - -#============== -sub WriteAttr { -#============== - my($self, $attr, $col, $row) = @_; - return undef unless ref($self); - return _WriteConsoleOutputAttribute($self->{'handle'}, $attr, $col, $row); -} - -#============= -sub ReadAttr { -#============= - my($self, $size, $col, $row) = @_; - return undef unless ref($self); - return _ReadConsoleOutputAttribute($self->{'handle'}, $size, $col, $row); -} - -#========== -sub Write { -#========== - my($self,$string) = @_; - return undef unless ref($self); - return _WriteConsole($self->{'handle'}, $string); -} - -#============= -sub ReadRect { -#============= - my($self, $left, $top, $right, $bottom) = @_; - return undef unless ref($self); - - my $col = $right - $left + 1; - my $row = $bottom - $top + 1; - - my $buffer = (" " x ($col*$row*4)); - if (_ReadConsoleOutput($self->{'handle'}, $buffer, - $col, $row, 0, 0, - $left, $top, $right, $bottom)) - { - return $buffer; - } - else { - return undef; - } -} - -#============== -sub WriteRect { -#============== - my($self, $buffer, $left, $top, $right, $bottom) = @_; - return undef unless ref($self); - - my $col = $right - $left + 1; - my $row = $bottom - $top + 1; - - return _WriteConsoleOutput($self->{'handle'}, $buffer, - $col, $row, 0, 0, - $left, $top, $right, $bottom); -} - -#=========== -sub Scroll { -#=========== - my($self, $left1, $top1, $right1, $bottom1, - $col, $row, $char, $attr, - $left2, $top2, $right2, $bottom2) = @_; - return undef unless ref($self); - - return _ScrollConsoleScreenBuffer($self->{'handle'}, - $left1, $top1, $right1, $bottom1, - $col, $row, $char, $attr, - $left2, $top2, $right2, $bottom2); -} - -#============== -sub MaxWindow { -#============== - my($self, $flag) = @_; - return undef unless ref($self); - - if (not defined($flag)) { - my @info = _GetConsoleScreenBufferInfo($self->{'handle'}); - return $info[9], $info[10]; - } - else { - return _GetLargestConsoleWindowSize($self->{'handle'}); - } -} - -#========= -sub Info { -#========= - my($self) = @_; - return undef unless ref($self); - return _GetConsoleScreenBufferInfo($self->{'handle'}); -} - -#=========== -sub Window { -#=========== - my($self, $flag, $left, $top, $right, $bottom) = @_; - return undef unless ref($self); - - if (not defined($flag)) { - my @info = _GetConsoleScreenBufferInfo($self->{'handle'}); - return $info[5], $info[6], $info[7], $info[8]; - } - else { - return _SetConsoleWindowInfo($self->{'handle'}, $flag, $left, $top, $right, $bottom); - } -} - -#============== -sub GetEvents { -#============== - my($self) = @_; - return undef unless ref($self); - return _GetNumberOfConsoleInputEvents($self->{'handle'}); -} - -#========== -sub Flush { -#========== - my($self) = @_; - return undef unless ref($self); - return _FlushConsoleInputBuffer($self->{'handle'}); -} - -#============== -sub InputChar { -#============== - my($self, $number) = @_; - return undef unless ref($self); - - $number = 1 unless defined($number); - - my $buffer = (" " x $number); - if (_ReadConsole($self->{'handle'}, $buffer, $number) == $number) { - return $buffer; - } - else { - return undef; - } -} - -#========== -sub Input { -#========== - my($self) = @_; - return undef unless ref($self); - return _ReadConsoleInput($self->{'handle'}); -} - -#============== -sub PeekInput { -#============== - my($self) = @_; - return undef unless ref($self); - return _PeekConsoleInput($self->{'handle'}); -} - -#=============== -sub WriteInput { -#=============== - my($self) = shift; - return undef unless ref($self); - return _WriteConsoleInput($self->{'handle'}, @_); -} - -#========= -sub Mode { -#========= - my($self, $mode) = @_; - return undef unless ref($self); - if (defined($mode)) { - return _SetConsoleMode($self->{'handle'}, $mode); - } - else { - return _GetConsoleMode($self->{'handle'}); - } -} - -#======== -sub Cls { -#======== - my($self, $attr) = @_; - return undef unless ref($self); - - $attr = $ATTR_NORMAL unless defined($attr); - - my ($x, $y) = $self->Size(); - my($left, $top, $right ,$bottom) = $self->Window(); - my $vx = $right - $left; - my $vy = $bottom - $top; - $self->FillChar(" ", $x*$y, 0, 0); - $self->FillAttr($attr, $x*$y, 0, 0); - $self->Cursor(0, 0); - $self->Window(1, 0, 0, $vx, $vy); -} - -#========= -sub Attr { -#========= - my($self, $attr) = @_; - return undef unless ref($self); - - if (not defined($attr)) { - return (_GetConsoleScreenBufferInfo($self->{'handle'}))[4]; - } - else { - return _SetConsoleTextAttribute($self->{'handle'}, $attr); - } -} - -#=========== -sub Cursor { -#=========== - my($self, $col, $row, $size, $visi) = @_; - return undef unless ref($self); - - my $curr_row = 0; - my $curr_col = 0; - my $curr_size = 0; - my $curr_visi = 0; - my $return = 0; - my $discard = 0; - - - if (defined($col)) { - $row = -1 if not defined($row); - if ($col == -1 or $row == -1) { - ($discard, $discard, $curr_col, $curr_row) = _GetConsoleScreenBufferInfo($self->{'handle'}); - $col=$curr_col if $col==-1; - $row=$curr_row if $row==-1; - } - $return += _SetConsoleCursorPosition($self->{'handle'}, $col, $row); - if (defined($size) and defined($visi)) { - if ($size == -1 or $visi == -1) { - ($curr_size, $curr_visi) = _GetConsoleCursorInfo($self->{'handle'}); - $size = $curr_size if $size == -1; - $visi = $curr_visi if $visi == -1; - } - $size = 1 if $size < 1; - $size = 99 if $size > 99; - $return += _SetConsoleCursorInfo($self->{'handle'}, $size, $visi); - } - return $return; - } - else { - ($discard, $discard, $curr_col, $curr_row) = _GetConsoleScreenBufferInfo($self->{'handle'}); - ($curr_size, $curr_visi) = _GetConsoleCursorInfo($self->{'handle'}); - return ($curr_col, $curr_row, $curr_size, $curr_visi); - } -} - -#========= -sub Size { -#========= - my($self, $col, $row) = @_; - return undef unless ref($self); - - if (not defined($col)) { - ($col, $row) = _GetConsoleScreenBufferInfo($self->{'handle'}); - return ($col, $row); - } - else { - $row = -1 if not defined($row); - if ($col == -1 or $row == -1) { - ($curr_col, $curr_row) = _GetConsoleScreenBufferInfo($self->{'handle'}); - $col=$curr_col if $col==-1; - $row=$curr_row if $row==-1; - } - return _SetConsoleScreenBufferSize($self->{'handle'}, $col, $row); - } -} - -#============= -sub FillAttr { -#============= - my($self, $attr, $number, $col, $row) = @_; - return undef unless ref($self); - - $number = 1 unless $number; - - if (!defined($col) or !defined($row) or $col == -1 or $row == -1) { - ($discard, $discard, - $curr_col, $curr_row) = _GetConsoleScreenBufferInfo($self->{'handle'}); - $col = $curr_col if !defined($col) or $col == -1; - $row = $curr_row if !defined($row) or $row == -1; - } - return _FillConsoleOutputAttribute($self->{'handle'}, $attr, $number, $col, $row); -} - -#============= -sub FillChar { -#============= - my($self, $char, $number, $col, $row) = @_; - return undef unless ref($self); - - if (!defined($col) or !defined($row) or $col == -1 or $row == -1) { - ($discard, $discard, - $curr_col, $curr_row) = _GetConsoleScreenBufferInfo($self->{'handle'}); - $col = $curr_col if !defined($col) or $col == -1; - $row = $curr_row if !defined($row) or $row == -1; - } - return _FillConsoleOutputCharacter($self->{'handle'}, $char, $number, $col, $row); -} - -#============ -sub InputCP { -#============ - my($self, $codepage) = @_; - $codepage = $self if (defined($self) and ref($self) ne "Win32::Console"); - if (defined($codepage)) { - return _SetConsoleCP($codepage); - } - else { - return _GetConsoleCP(); - } -} - -#============= -sub OutputCP { -#============= - my($self, $codepage) = @_; - $codepage = $self if (defined($self) and ref($self) ne "Win32::Console"); - if (defined($codepage)) { - return _SetConsoleOutputCP($codepage); - } - else { - return _GetConsoleOutputCP(); - } -} - -#====================== -sub GenerateCtrlEvent { -#====================== - my($self, $type, $pid) = @_; - $type = constant("CTRL_C_EVENT", 0) unless defined($type); - $pid = 0 unless defined($pid); - return _GenerateConsoleCtrlEvent($type, $pid); -} - -#=================== -#sub SetCtrlHandler { -#=================== -# my($name, $add) = @_; -# $add = 1 unless defined($add); -# my @nor = keys(%HandlerRoutineStack); -# if ($add == 0) { -# foreach $key (@nor) { -# delete $HandlerRoutineStack{$key}, last if $HandlerRoutineStack{$key}==$name; -# } -# $HandlerRoutineRegistered--; -# } else { -# if ($#nor == -1) { -# my $r = _SetConsoleCtrlHandler(); -# if (!$r) { -# print "WARNING: SetConsoleCtrlHandler failed...\n"; -# } -# } -# $HandlerRoutineRegistered++; -# $HandlerRoutineStack{$HandlerRoutineRegistered} = $name; -# } -#} - -#=================== -sub get_Win32_IPC_HANDLE { # So Win32::IPC can wait on a console handle -#=================== - $_[0]->{'handle'}; -} - -######################################################################## -# PRIVATE METHODS -# - -#================ -#sub CtrlHandler { -#================ -# my($ctrltype) = @_; -# my $routine; -# my $result = 0; -# CALLEM: foreach $routine (sort { $b <=> $a } keys %HandlerRoutineStack) { -# #print "CtrlHandler: calling $HandlerRoutineStack{$routine}($ctrltype)\n"; -# $result = &{"main::".$HandlerRoutineStack{$routine}}($ctrltype); -# last CALLEM if $result; -# } -# return $result; -#} - -#============ -sub DESTROY { -#============ - my($self) = @_; - _CloseHandle($self->{'handle'}); -} - -####################################################################### -# dynamically load in the Console.pll module. -# - -bootstrap Win32::Console; - -####################################################################### -# ADDITIONAL CONSTANTS EXPORTED IN THE MAIN NAMESPACE -# - -$FG_BLACK = 0; -$FG_GRAY = constant("FOREGROUND_INTENSITY",0); -$FG_BLUE = constant("FOREGROUND_BLUE",0); -$FG_LIGHTBLUE = constant("FOREGROUND_BLUE",0)| - constant("FOREGROUND_INTENSITY",0); -$FG_RED = constant("FOREGROUND_RED",0); -$FG_LIGHTRED = constant("FOREGROUND_RED",0)| - constant("FOREGROUND_INTENSITY",0); -$FG_GREEN = constant("FOREGROUND_GREEN",0); -$FG_LIGHTGREEN = constant("FOREGROUND_GREEN",0)| - constant("FOREGROUND_INTENSITY",0); -$FG_MAGENTA = constant("FOREGROUND_RED",0)| - constant("FOREGROUND_BLUE",0); -$FG_LIGHTMAGENTA = constant("FOREGROUND_RED",0)| - constant("FOREGROUND_BLUE",0)| - constant("FOREGROUND_INTENSITY",0); -$FG_CYAN = constant("FOREGROUND_GREEN",0)| - constant("FOREGROUND_BLUE",0); -$FG_LIGHTCYAN = constant("FOREGROUND_GREEN",0)| - constant("FOREGROUND_BLUE",0)| - constant("FOREGROUND_INTENSITY",0); -$FG_BROWN = constant("FOREGROUND_RED",0)| - constant("FOREGROUND_GREEN",0); -$FG_YELLOW = constant("FOREGROUND_RED",0)| - constant("FOREGROUND_GREEN",0)| - constant("FOREGROUND_INTENSITY",0); -$FG_LIGHTGRAY = constant("FOREGROUND_RED",0)| - constant("FOREGROUND_GREEN",0)| - constant("FOREGROUND_BLUE",0); -$FG_WHITE = constant("FOREGROUND_RED",0)| - constant("FOREGROUND_GREEN",0)| - constant("FOREGROUND_BLUE",0)| - constant("FOREGROUND_INTENSITY",0); - -$BG_BLACK = 0; -$BG_GRAY = constant("BACKGROUND_INTENSITY",0); -$BG_BLUE = constant("BACKGROUND_BLUE",0); -$BG_LIGHTBLUE = constant("BACKGROUND_BLUE",0)| - constant("BACKGROUND_INTENSITY",0); -$BG_RED = constant("BACKGROUND_RED",0); -$BG_LIGHTRED = constant("BACKGROUND_RED",0)| - constant("BACKGROUND_INTENSITY",0); -$BG_GREEN = constant("BACKGROUND_GREEN",0); -$BG_LIGHTGREEN = constant("BACKGROUND_GREEN",0)| - constant("BACKGROUND_INTENSITY",0); -$BG_MAGENTA = constant("BACKGROUND_RED",0)| - constant("BACKGROUND_BLUE",0); -$BG_LIGHTMAGENTA = constant("BACKGROUND_RED",0)| - constant("BACKGROUND_BLUE",0)| - constant("BACKGROUND_INTENSITY",0); -$BG_CYAN = constant("BACKGROUND_GREEN",0)| - constant("BACKGROUND_BLUE",0); -$BG_LIGHTCYAN = constant("BACKGROUND_GREEN",0)| - constant("BACKGROUND_BLUE",0)| - constant("BACKGROUND_INTENSITY",0); -$BG_BROWN = constant("BACKGROUND_RED",0)| - constant("BACKGROUND_GREEN",0); -$BG_YELLOW = constant("BACKGROUND_RED",0)| - constant("BACKGROUND_GREEN",0)| - constant("BACKGROUND_INTENSITY",0); -$BG_LIGHTGRAY = constant("BACKGROUND_RED",0)| - constant("BACKGROUND_GREEN",0)| - constant("BACKGROUND_BLUE",0); -$BG_WHITE = constant("BACKGROUND_RED",0)| - constant("BACKGROUND_GREEN",0)| - constant("BACKGROUND_BLUE",0)| - constant("BACKGROUND_INTENSITY",0); - -$ATTR_NORMAL = $FG_LIGHTGRAY|$BG_BLACK; -$ATTR_INVERSE = $FG_BLACK|$BG_LIGHTGRAY; - -for my $fg ($FG_BLACK, $FG_GRAY, $FG_BLUE, $FG_GREEN, - $FG_CYAN, $FG_RED, $FG_MAGENTA, $FG_BROWN, - $FG_LIGHTBLUE, $FG_LIGHTGREEN, $FG_LIGHTCYAN, - $FG_LIGHTRED, $FG_LIGHTMAGENTA, $FG_YELLOW, - $FG_LIGHTGRAY, $FG_WHITE) -{ - for my $bg ($BG_BLACK, $BG_GRAY, $BG_BLUE, $BG_GREEN, - $BG_CYAN, $BG_RED, $BG_MAGENTA, $BG_BROWN, - $BG_LIGHTBLUE, $BG_LIGHTGREEN, $BG_LIGHTCYAN, - $BG_LIGHTRED, $BG_LIGHTMAGENTA, $BG_YELLOW, - $BG_LIGHTGRAY, $BG_WHITE) - { - push(@CONSOLE_COLORS, $fg|$bg); - } -} - -# Preloaded methods go here. - -#Currently Autoloading is not implemented in Perl for win32 -# Autoload methods go after __END__, and are processed by the autosplit program. - -1; - -__END__ - -=head1 NAME - -Win32::Console - Win32 Console and Character Mode Functions - - -=head1 DESCRIPTION - -This module implements the Win32 console and character mode -functions. They give you full control on the console input and output, -including: support of off-screen console buffers (eg. multiple screen -pages) - -=over - -=item * - -reading and writing of characters, attributes and whole portions of -the screen - -=item * - -complete processing of keyboard and mouse events - -=item * - -some very funny additional features :) - -=back - -Those functions should also make possible a port of the Unix's curses -library; if there is anyone interested (and/or willing to contribute) -to this project, e-mail me. Thank you. - - -=head1 REFERENCE - - -=head2 Methods - -=over - -=item Alloc - -Allocates a new console for the process. Returns C<undef> on errors, a -nonzero value on success. A process cannot be associated with more -than one console, so this method will fail if there is already an -allocated console. Use Free to detach the process from the console, -and then call Alloc to create a new console. See also: C<Free> - -Example: - - $CONSOLE->Alloc(); - -=item Attr [attr] - -Gets or sets the current console attribute. This attribute is used by -the Write method. - -Example: - - $attr = $CONSOLE->Attr(); - $CONSOLE->Attr($FG_YELLOW | $BG_BLUE); - -=item Close - -Closes a shortcut object. Note that it is not "strictly" required to -close the objects you created, since the Win32::Shortcut objects are -automatically closed when the program ends (or when you elsehow -destroy such an object). - -Example: - - $LINK->Close(); - -=item Cls [attr] - -Clear the console, with the specified I<attr> if given, or using -ATTR_NORMAL otherwise. - -Example: - - $CONSOLE->Cls(); - $CONSOLE->Cls($FG_WHITE | $BG_GREEN); - -=item Cursor [x, y, size, visible] - -Gets or sets cursor position and appearance. Returns C<undef> on -errors, or a 4-element list containing: I<x>, I<y>, I<size>, -I<visible>. I<x> and I<y> are the current cursor position; ... - -Example: - - ($x, $y, $size, $visible) = $CONSOLE->Cursor(); - - # Get position only - ($x, $y) = $CONSOLE->Cursor(); - - $CONSOLE->Cursor(40, 13, 50, 1); - - # Set position only - $CONSOLE->Cursor(40, 13); - - # Set size and visibility without affecting position - $CONSOLE->Cursor(-1, -1, 50, 1); - -=item Display - -Displays the specified console on the screen. Returns C<undef> on errors, -a nonzero value on success. - -Example: - - $CONSOLE->Display(); - -=item FillAttr [attribute, number, col, row] - -Fills the specified number of consecutive attributes, beginning at -I<col>, I<row>, with the value specified in I<attribute>. Returns the -number of attributes filled, or C<undef> on errors. See also: -C<FillChar>. - -Example: - - $CONSOLE->FillAttr($FG_BLACK | $BG_BLACK, 80*25, 0, 0); - -=item FillChar char, number, col, row - -Fills the specified number of consecutive characters, beginning at -I<col>, I<row>, with the character specified in I<char>. Returns the -number of characters filled, or C<undef> on errors. See also: -C<FillAttr>. - -Example: - - $CONSOLE->FillChar("X", 80*25, 0, 0); - -=item Flush - -Flushes the console input buffer. All the events in the buffer are -discarded. Returns C<undef> on errors, a nonzero value on success. - -Example: - - $CONSOLE->Flush(); - -=item Free - -Detaches the process from the console. Returns C<undef> on errors, a -nonzero value on success. See also: C<Alloc>. - -Example: - - $CONSOLE->Free(); - -=item GenerateCtrlEvent [type, processgroup] - -Sends a break signal of the specified I<type> to the specified -I<processgroup>. I<type> can be one of the following constants: - - CTRL_BREAK_EVENT - CTRL_C_EVENT - -they signal, respectively, the pressing of Control + Break and of -Control + C; if not specified, it defaults to CTRL_C_EVENT. -I<processgroup> is the pid of a process sharing the same console. If -omitted, it defaults to 0 (the current process), which is also the -only meaningful value that you can pass to this function. Returns -C<undef> on errors, a nonzero value on success. - -Example: - - # break this script now - $CONSOLE->GenerateCtrlEvent(); - -=item GetEvents - -Returns the number of unread input events in the console's input -buffer, or C<undef> on errors. See also: C<Input>, C<InputChar>, -C<PeekInput>, C<WriteInput>. - -Example: - - $events = $CONSOLE->GetEvents(); - -=item Info - -Returns an array of informations about the console (or C<undef> on -errors), which contains: - -=over - -=item * - -columns (X size) of the console buffer. - -=item * - -rows (Y size) of the console buffer. - -=item * - -current column (X position) of the cursor. - -=item * - -current row (Y position) of the cursor. - -=item * - -current attribute used for C<Write>. - -=item * - -left column (X of the starting point) of the current console window. - -=item * - -top row (Y of the starting point) of the current console window. - -=item * - -right column (X of the final point) of the current console window. - -=item * - -bottom row (Y of the final point) of the current console window. - -=item * - -maximum number of columns for the console window, given the current -buffer size, font and the screen size. - -=item * - -maximum number of rows for the console window, given the current -buffer size, font and the screen size. - -=back - -See also: C<Attr>, C<Cursor>, C<Size>, C<Window>, C<MaxWindow>. - -Example: - - @info = $CONSOLE->Info(); - print "Cursor at $info[3], $info[4].\n"; - -=item Input - -Reads an event from the input buffer. Returns a list of values, which -depending on the event's nature are: - -=over - -=item keyboard event - -The list will contain: - -=over - -=item * - -event type: 1 for keyboard - -=item * - -key down: TRUE if the key is being pressed, FALSE if the key is being released - -=item * - -repeat count: the number of times the key is being held down - -=item * - -virtual keycode: the virtual key code of the key - -=item * - -virtual scancode: the virtual scan code of the key - -=item * - -char: the ASCII code of the character (if the key is a character key, 0 otherwise) - -=item * - -control key state: the state of the control keys (SHIFTs, CTRLs, ALTs, etc.) - -=back - -=item mouse event - -The list will contain: - -=over - -=item * - -event type: 2 for mouse - -=item * - -mouse pos. X: X coordinate (column) of the mouse location - -=item * - -mouse pos. Y: Y coordinate (row) of the mouse location - -=item * - -button state: the mouse button(s) which are pressed - -=item * - -control key state: the state of the control keys (SHIFTs, CTRLs, ALTs, etc.) - -=item * - -event flags: the type of the mouse event - -=back - -=back - -This method will return C<undef> on errors. Note that the events -returned are depending on the input C<Mode> of the console; for example, -mouse events are not intercepted unless ENABLE_MOUSE_INPUT is -specified. See also: C<GetEvents>, C<InputChar>, C<Mode>, -C<PeekInput>, C<WriteInput>. - -Example: - - @event = $CONSOLE->Input(); - -=item InputChar number - -Reads and returns I<number> characters from the console input buffer, -or C<undef> on errors. See also: C<Input>, C<Mode>. - -Example: - - $key = $CONSOLE->InputChar(1); - -=item InputCP [codepage] - -Gets or sets the input code page used by the console. Note that this -doesn't apply to a console object, but to the standard input -console. This attribute is used by the Write method. See also: -C<OutputCP>. - -Example: - - $codepage = $CONSOLE->InputCP(); - $CONSOLE->InputCP(437); - - # you may want to use the non-instanciated form to avoid confuzion :) - $codepage = Win32::Console::InputCP(); - Win32::Console::InputCP(437); - -=item MaxWindow - -Returns the size of the largest possible console window, based on the -current font and the size of the display. The result is C<undef> on -errors, otherwise a 2-element list containing col, row. - -Example: - - ($maxCol, $maxRow) = $CONSOLE->MaxWindow(); - -=item Mode [flags] - -Gets or sets the input or output mode of a console. I<flags> can be a -combination of the following constants: - - ENABLE_LINE_INPUT - ENABLE_ECHO_INPUT - ENABLE_PROCESSED_INPUT - ENABLE_WINDOW_INPUT - ENABLE_MOUSE_INPUT - ENABLE_PROCESSED_OUTPUT - ENABLE_WRAP_AT_EOL_OUTPUT - -For more informations on the meaning of those flags, please refer to -the L<"Microsoft's Documentation">. - -Example: - - $mode = $CONSOLE->Mode(); - $CONSOLE->Mode(ENABLE_MOUSE_INPUT | ENABLE_PROCESSED_INPUT); - -=item MouseButtons - -Returns the number of the buttons on your mouse, or C<undef> on errors. - -Example: - - print "Your mouse has ", $CONSOLE->MouseButtons(), " buttons.\n"; - -=item new Win32::Console standard_handle - -=item new Win32::Console [accessmode, sharemode] - -Creates a new console object. The first form creates a handle to a -standard channel, I<standard_handle> can be one of the following: - - STD_OUTPUT_HANDLE - STD_ERROR_HANDLE - STD_INPUT_HANDLE - -The second form, instead, creates a console screen buffer in memory, -which you can access for reading and writing as a normal console, and -then redirect on the standard output (the screen) with C<Display>. In -this case, you can specify one or both of the following values for -I<accessmode>: - - GENERIC_READ - GENERIC_WRITE - -which are the permissions you will have on the created buffer, and one -or both of the following values for I<sharemode>: - - FILE_SHARE_READ - FILE_SHARE_WRITE - -which affect the way the console can be shared. If you don't specify -any of those parameters, all 4 flags will be used. - -Example: - - $STDOUT = new Win32::Console(STD_OUTPUT_HANDLE); - $STDERR = new Win32::Console(STD_ERROR_HANDLE); - $STDIN = new Win32::Console(STD_INPUT_HANDLE); - - $BUFFER = new Win32::Console(); - $BUFFER = new Win32::Console(GENERIC_READ | GENERIC_WRITE); - -=item OutputCP [codepage] - -Gets or sets the output code page used by the console. Note that this -doesn't apply to a console object, but to the standard output console. -See also: C<InputCP>. - -Example: - - $codepage = $CONSOLE->OutputCP(); - $CONSOLE->OutputCP(437); - - # you may want to use the non-instanciated form to avoid confuzion :) - $codepage = Win32::Console::OutputCP(); - Win32::Console::OutputCP(437); - -=item PeekInput - -Does exactly the same as C<Input>, except that the event read is not -removed from the input buffer. See also: C<GetEvents>, C<Input>, -C<InputChar>, C<Mode>, C<WriteInput>. - -Example: - - @event = $CONSOLE->PeekInput(); - -=item ReadAttr [number, col, row] - -Reads the specified I<number> of consecutive attributes, beginning at -I<col>, I<row>, from the console. Returns the attributes read (a -variable containing one character for each attribute), or C<undef> on -errors. You can then pass the returned variable to C<WriteAttr> to -restore the saved attributes on screen. See also: C<ReadChar>, -C<ReadRect>. - -Example: - - $colors = $CONSOLE->ReadAttr(80*25, 0, 0); - -=item ReadChar [number, col, row] - -Reads the specified I<number> of consecutive characters, beginning at -I<col>, I<row>, from the console. Returns a string containing the -characters read, or C<undef> on errors. You can then pass the -returned variable to C<WriteChar> to restore the saved characters on -screen. See also: C<ReadAttr>, C<ReadRect>. - -Example: - - $chars = $CONSOLE->ReadChar(80*25, 0, 0); - -=item ReadRect left, top, right, bottom - -Reads the content (characters and attributes) of the rectangle -specified by I<left>, I<top>, I<right>, I<bottom> from the console. -Returns a string containing the rectangle read, or C<undef> on errors. -You can then pass the returned variable to C<WriteRect> to restore the -saved rectangle on screen (or on another console). See also: -C<ReadAttr>, C<ReadChar>. - -Example: - - $rect = $CONSOLE->ReadRect(0, 0, 80, 25); - -=item Scroll left, top, right, bottom, col, row, char, attr, - [cleft, ctop, cright, cbottom] - -Moves a block of data in a console buffer; the block is identified by -I<left>, I<top>, I<right>, I<bottom>, while I<row>, I<col> identify -the new location of the block. The cells left empty as a result of -the move are filled with the character I<char> and attribute I<attr>. -Optionally you can specify a clipping region with I<cleft>, I<ctop>, -I<cright>, I<cbottom>, so that the content of the console outside this -rectangle are unchanged. Returns C<undef> on errors, a nonzero value -on success. - -Example: - - # scrolls the screen 10 lines down, filling with black spaces - $CONSOLE->Scroll(0, 0, 80, 25, 0, 10, " ", $FG_BLACK | $BG_BLACK); - -=item Select standard_handle - -Redirects a standard handle to the specified console. -I<standard_handle> can have one of the following values: - - STD_INPUT_HANDLE - STD_OUTPUT_HANDLE - STD_ERROR_HANDLE - -Returns C<undef> on errors, a nonzero value on success. - -Example: - - $CONSOLE->Select(STD_OUTPUT_HANDLE); - -=item SetIcon icon_file - -Sets the icon in the title bar of the current console window. - -Example: - - $CONSOLE->SetIcon("C:/My/Path/To/Custom.ico"); - -=item Size [col, row] - -Gets or sets the console buffer size. - -Example: - - ($x, $y) = $CONSOLE->Size(); - $CONSOLE->Size(80, 25); - -=item Title [title] - -Gets or sets the title of the current console window. - -Example: - - $title = $CONSOLE->Title(); - $CONSOLE->Title("This is a title"); - -=item Window [flag, left, top, right, bottom] - -Gets or sets the current console window size. If called without -arguments, returns a 4-element list containing the current window -coordinates in the form of I<left>, I<top>, I<right>, I<bottom>. To -set the window size, you have to specify an additional I<flag> -parameter: if it is 0 (zero), coordinates are considered relative to -the current coordinates; if it is non-zero, coordinates are absolute. - -Example: - - ($left, $top, $right, $bottom) = $CONSOLE->Window(); - $CONSOLE->Window(1, 0, 0, 80, 50); - -=item Write string - -Writes I<string> on the console, using the current attribute, that you -can set with C<Attr>, and advancing the cursor as needed. This isn't -so different from Perl's "print" statement. Returns the number of -characters written or C<undef> on errors. See also: C<WriteAttr>, -C<WriteChar>, C<WriteRect>. - -Example: - - $CONSOLE->Write("Hello, world!"); - -=item WriteAttr attrs, col, row - -Writes the attributes in the string I<attrs>, beginning at I<col>, -I<row>, without affecting the characters that are on screen. The -string attrs can be the result of a C<ReadAttr> function, or you can -build your own attribute string; in this case, keep in mind that every -attribute is treated as a character, not a number (see example). -Returns the number of attributes written or C<undef> on errors. See -also: C<Write>, C<WriteChar>, C<WriteRect>. - -Example: - - $CONSOLE->WriteAttr($attrs, 0, 0); - - # note the use of chr()... - $attrs = chr($FG_BLACK | $BG_WHITE) x 80; - $CONSOLE->WriteAttr($attrs, 0, 0); - -=item WriteChar chars, col, row - -Writes the characters in the string I<attr>, beginning at I<col>, I<row>, -without affecting the attributes that are on screen. The string I<chars> -can be the result of a C<ReadChar> function, or a normal string. Returns -the number of characters written or C<undef> on errors. See also: -C<Write>, C<WriteAttr>, C<WriteRect>. - -Example: - - $CONSOLE->WriteChar("Hello, worlds!", 0, 0); - -=item WriteInput (event) - -Pushes data in the console input buffer. I<(event)> is a list of values, -for more information see C<Input>. The string chars can be the result of -a C<ReadChar> function, or a normal string. Returns the number of -characters written or C<undef> on errors. See also: C<Write>, -C<WriteAttr>, C<WriteRect>. - -Example: - - $CONSOLE->WriteInput(@event); - -=item WriteRect rect, left, top, right, bottom - -Writes a rectangle of characters and attributes (contained in I<rect>) -on the console at the coordinates specified by I<left>, I<top>, -I<right>, I<bottom>. I<rect> can be the result of a C<ReadRect> -function. Returns C<undef> on errors, otherwise a 4-element list -containing the coordinates of the affected rectangle, in the format -I<left>, I<top>, I<right>, I<bottom>. See also: C<Write>, -C<WriteAttr>, C<WriteChar>. - -Example: - - $CONSOLE->WriteRect($rect, 0, 0, 80, 25); - -=back - - -=head2 Constants - -The following constants are exported in the main namespace of your -script using Win32::Console: - - BACKGROUND_BLUE - BACKGROUND_GREEN - BACKGROUND_INTENSITY - BACKGROUND_RED - CAPSLOCK_ON - CONSOLE_TEXTMODE_BUFFER - ENABLE_ECHO_INPUT - ENABLE_LINE_INPUT - ENABLE_MOUSE_INPUT - ENABLE_PROCESSED_INPUT - ENABLE_PROCESSED_OUTPUT - ENABLE_WINDOW_INPUT - ENABLE_WRAP_AT_EOL_OUTPUT - ENHANCED_KEY - FILE_SHARE_READ - FILE_SHARE_WRITE - FOREGROUND_BLUE - FOREGROUND_GREEN - FOREGROUND_INTENSITY - FOREGROUND_RED - LEFT_ALT_PRESSED - LEFT_CTRL_PRESSED - NUMLOCK_ON - GENERIC_READ - GENERIC_WRITE - RIGHT_ALT_PRESSED - RIGHT_CTRL_PRESSED - SCROLLLOCK_ON - SHIFT_PRESSED - STD_INPUT_HANDLE - STD_OUTPUT_HANDLE - STD_ERROR_HANDLE - -Additionally, the following variables can be used: - - $FG_BLACK - $FG_GRAY - $FG_BLUE - $FG_LIGHTBLUE - $FG_RED - $FG_LIGHTRED - $FG_GREEN - $FG_LIGHTGREEN - $FG_MAGENTA - $FG_LIGHTMAGENTA - $FG_CYAN - $FG_LIGHTCYAN - $FG_BROWN - $FG_YELLOW - $FG_LIGHTGRAY - $FG_WHITE - - $BG_BLACK - $BG_GRAY - $BG_BLUE - $BG_LIGHTBLUE - $BG_RED - $BG_LIGHTRED - $BG_GREEN - $BG_LIGHTGREEN - $BG_MAGENTA - $BG_LIGHTMAGENTA - $BG_CYAN - $BG_LIGHTCYAN - $BG_BROWN - $BG_YELLOW - $BG_LIGHTGRAY - $BG_WHITE - - $ATTR_NORMAL - $ATTR_INVERSE - -ATTR_NORMAL is set to gray foreground on black background (DOS's -standard colors). - - -=head2 Microsoft's Documentation - -Documentation for the Win32 Console and Character mode Functions can -be found on Microsoft's site at this URL: - -http://www.microsoft.com/msdn/sdk/platforms/doc/sdk/win32/sys/src/conchar.htm - -A reference of the available functions is at: - -http://www.microsoft.com/msdn/sdk/platforms/doc/sdk/win32/sys/src/conchar_34.htm - - -=head1 AUTHOR - -Aldo Calpini <a.calpini@romagiubileo.it> - -=head1 CREDITS - -Thanks to: Jesse Dougherty, Dave Roth, ActiveWare, and the -Perl-Win32-Users community. - -=head1 DISCLAIMER - -This program is FREE; you can redistribute, modify, disassemble, or -even reverse engineer this software at your will. Keep in mind, -however, that NOTHING IS GUARANTEED to work and everything you do is -AT YOUR OWN RISK - I will not take responsibility for any damage, loss -of money and/or health that may arise from the use of this program! - -This is distributed under the terms of Larry Wall's Artistic License. diff --git a/Master/tlpkg/tlperl/lib/Win32/Event.pm b/Master/tlpkg/tlperl/lib/Win32/Event.pm deleted file mode 100644 index 5faddf5a76e..00000000000 --- a/Master/tlpkg/tlperl/lib/Win32/Event.pm +++ /dev/null @@ -1,104 +0,0 @@ -#--------------------------------------------------------------------- -package Win32::Event; -# -# Copyright 1998 Christopher J. Madsen -# -# Author: Christopher J. Madsen <cjm@pobox.com> -# Created: 3 Feb 1998 from the ActiveWare version -# Version: 1.00 (6-Feb-1998) -# -# This program is free software; you can redistribute it and/or modify -# it under the same terms as Perl itself. -# -# This program is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See either the -# GNU General Public License or the Artistic License for more details. -# -# Use Win32 event objects for synchronization -#--------------------------------------------------------------------- - -$VERSION = '1.01'; - -use Win32::IPC 1.00 '/./'; # Import everything -require Exporter; -require DynaLoader; - -@ISA = qw(Exporter DynaLoader Win32::IPC); -@EXPORT_OK = qw( - wait_all wait_any INFINITE -); - -bootstrap Win32::Event; - -1; -__END__ - -=head1 NAME - -Win32::Event - Use Win32 event objects from Perl - -=head1 SYNOPSIS - - use Win32::Event; - - $event = Win32::Event->new($manual,$initial,$name); - $event->wait(); - -=head1 DESCRIPTION - -This module allows access to the Win32 event objects. The C<wait> -method and C<wait_all> & C<wait_any> functions are inherited from the -L<"Win32::IPC"> module. - -=head2 Methods - -=over 4 - -=item $event = Win32::Event->new([$manual, [$initial, [$name]]]) - -Constructor for a new event object. If C<$manual> is true, you must -manually reset the event after it is signalled (the default is false). -If C<$initial> is true, the initial state of the object is signalled -(default false). If C<$name> is omitted, creates an unnamed event -object. - -If C<$name> signifies an existing event object, then C<$manual> and -C<$initial> are ignored and the object is opened. If this happens, -C<$^E> will be set to 183 (ERROR_ALREADY_EXISTS). - -=item $event = Win32::Event->open($name) - -Constructor for opening an existing event object. - -=item $event->pulse - -Signal the C<$event> and then immediately reset it. If C<$event> is a -manual-reset event, releases all threads currently blocking on it. If -it's an auto-reset event, releases just one thread. - -If no threads are waiting, just resets the event. - -=item $event->reset - -Reset the C<$event> to nonsignalled. - -=item $event->set - -Set the C<$event> to signalled. - -=item $event->wait([$timeout]) - -Wait for C<$event> to be signalled. See L<"Win32::IPC">. - -=back - -=head1 AUTHOR - -Christopher J. Madsen E<lt>F<cjm@pobox.com>E<gt> - -=cut - -# Local Variables: -# tmtrack-file-task: "Win32::Event" -# End: diff --git a/Master/tlpkg/tlperl/lib/Win32/EventLog.pm b/Master/tlpkg/tlperl/lib/Win32/EventLog.pm deleted file mode 100644 index 141821556e7..00000000000 --- a/Master/tlpkg/tlperl/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.074'; - -require Exporter; -require DynaLoader; - -die "The Win32::Eventlog module works only on Windows NT" - unless Win32::IsWinNT(); - -@ISA= qw(Exporter DynaLoader); -@EXPORT = qw( - EVENTLOG_AUDIT_FAILURE - EVENTLOG_AUDIT_SUCCESS - EVENTLOG_BACKWARDS_READ - EVENTLOG_END_ALL_PAIRED_EVENTS - EVENTLOG_END_PAIRED_EVENT - EVENTLOG_ERROR_TYPE - EVENTLOG_FORWARDS_READ - EVENTLOG_INFORMATION_TYPE - EVENTLOG_PAIRED_EVENT_ACTIVE - EVENTLOG_PAIRED_EVENT_INACTIVE - EVENTLOG_SEEK_READ - EVENTLOG_SEQUENTIAL_READ - EVENTLOG_START_PAIRED_EVENT - EVENTLOG_SUCCESS - EVENTLOG_WARNING_TYPE -); - -$GetMessageText=0; - -sub AUTOLOAD { - my($constname); - ($constname = $AUTOLOAD) =~ s/.*:://; - # reset $! to zero to reset any current errors. - local $! = 0; - my $val = constant($constname, @_ ? $_[0] : 0); - if ($!) { - if ($! =~ /Invalid/) { - $AutoLoader::AUTOLOAD = $AUTOLOAD; - goto &AutoLoader::AUTOLOAD; - } - else { - my ($pack,$file,$line) = caller; - die "Unknown Win32::EventLog macro $constname, at $file line $line.\n"; - } - } - eval "sub $AUTOLOAD { $val }"; - goto &$AUTOLOAD; -} - -# -# new() -# -# Win32::EventLog->new("source name", "ServerName"); -# -sub new { - die "usage: PACKAGE->new(SOURCENAME[, SERVERNAME])\n" unless @_ > 1; - my ($class,$source,$server) = @_; - my $handle; - - # Create new handle - if ($source !~ /\\/) { - OpenEventLog($handle, $server, $source); - } - else { - OpenBackupEventLog($handle, $server, $source); - } - return bless {handle => $handle, - Source => $source, - Computer => $server} => $class; -} - -sub DESTROY {shift->Close} - -# -# Open (the rather braindead old way) -# A variable initialized to empty must be supplied as the first -# arg, followed by whatever new() takes -# -sub Open { - $_[0] = Win32::EventLog->new($_[1],$_[2]); -} - -sub OpenBackup { - my ($class,$source,$server) = @_; - OpenBackupEventLog(my $handle, $server, $source); - return bless {handle => $handle, - Source => $source, - Computer => $server} => $class; -} - -sub Backup { - die " usage: OBJECT->Backup(FILENAME)\n" unless @_ == 2; - my ($self,$file) = @_; - return BackupEventLog($self->{handle}, $file); -} - -sub Close { - my $self = shift; - CloseEventLog($self->{handle}); - $self->{handle} = 0; -} - -# Read -# Note: the EventInfo arguement requires a hash reference. -sub Read { - my $self = shift; - - die "usage: OBJECT->Read(FLAGS, RECORDOFFSET, HASHREF)\n" unless @_ == 3; - - my ($readflags,$recordoffset) = @_; - # The following is stolen shamelessly from Wyt's tests for the registry. - my $result = ReadEventLog($self->{handle}, $readflags, $recordoffset, - my $header, my $source, my $computer, my $sid, - my $data, my $strings); - my ($length, - $reserved, - $recordnumber, - $timegenerated, - $timewritten, - $eventid, - $eventtype, - $numstrings, - $eventcategory, - $reservedflags, - $closingrecordnumber, - $stringoffset, - $usersidlength, - $usersidoffset, - $datalength, - $dataoffset) = unpack('l6s4l6', $header); - - # make a hash out of the values returned from ReadEventLog. - my %h = ( Source => $source, - Computer => $computer, - Length => $datalength, - Category => $eventcategory, - RecordNumber => $recordnumber, - TimeGenerated => $timegenerated, - Timewritten => $timewritten, - EventID => $eventid, - EventType => $eventtype, - ClosingRecordNumber => $closingrecordnumber, - User => $sid, - Strings => $strings, - Data => $data, - ); - - # get the text message here - if ($result and $GetMessageText) { - GetEventLogText($source, $eventid, $strings, $numstrings, my $message); - $h{Message} = $message; - } - - if (ref($_[2]) eq 'HASH') { - %{$_[2]} = %h; # this needed for Read(...,\%foo) case - } - else { - $_[2] = \%h; - } - return $result; -} - -sub GetMessageText { - my $self = shift; - local $^W; - GetEventLogText($self->{Source}, - $self->{EventID}, - $self->{Strings}, - $self->{Strings} =~ tr/\0/\0/, - my $message); - - $self->{Message} = $message; - return $message; -} - -sub Report { - die "usage: OBJECT->Report( HASHREF )\n" unless @_ == 2; - my ($self,$EventInfo) = @_; - - die "Win32::EventLog::Report requires a hash reference as arg 2\n" - unless ref($EventInfo) eq "HASH"; - - my $computer = $EventInfo->{Computer} ? $EventInfo->{Computer} - : $self->{Computer}; - my $source = exists($EventInfo->{Source}) ? $EventInfo->{Source} - : $self->{Source}; - - return WriteEventLog($computer, $source, $EventInfo->{EventType}, - $EventInfo->{Category}, $EventInfo->{EventID}, 0, - $EventInfo->{Data}, split(/\0/, $EventInfo->{Strings})); - -} - -sub GetOldest { - my $self = shift; - die "usage: OBJECT->GetOldest( SCALAREF )\n" unless @_ == 1; - return GetOldestEventLogRecord($self->{handle},$_[0]); -} - -sub GetNumber { - my $self = shift; - die "usage: OBJECT->GetNumber( SCALARREF )\n" unless @_ == 1; - return GetNumberOfEventLogRecords($self->{handle}, $_[0]); -} - -sub Clear { - my ($self,$file) = @_; - die "usage: OBJECT->Clear( FILENAME )\n" unless @_ == 2; - return ClearEventLog($self->{handle}, $file); -} - -bootstrap Win32::EventLog; - -1; -__END__ - -=head1 NAME - -Win32::EventLog - Process Win32 Event Logs from Perl - -=head1 SYNOPSIS - - use Win32::EventLog - $handle=Win32::EventLog->new("Application"); - -=head1 DESCRIPTION - -This module implements most of the functionality available from the -Win32 API for accessing and manipulating Win32 Event Logs. The access -to the EventLog routines is divided into those that relate to an -EventLog object and its associated methods and those that relate other -EventLog tasks (like adding an EventLog record). - -=head1 The EventLog Object and its Methods - -The following methods are available to open, read, close and backup -EventLogs. - -=over 4 - -=item Win32::EventLog->new(SOURCENAME [,SERVERNAME]); - -The new() method creates a new EventLog object and returns a handle -to it. This hande is then used to call the methods below. - -The method is overloaded in that if the supplied SOURCENAME -argument contains one or more literal '\' characters (an illegal -character in a SOURCENAME), it assumes that you are trying to open -a backup eventlog and uses SOURCENAME as the backup eventlog to -open. Note that when opening a backup eventlog, the SERVERNAME -argument is ignored (as it is in the underlying Win32 API). For -EventLogs on remote machines, the SOURCENAME parameter must -therefore be specified as a UNC path. - -=item $handle->Backup(FILENAME); - -The Backup() method backs up the EventLog represented by $handle. It -takes a single arguemt, FILENAME. When $handle represents an -EventLog on a remote machine, FILENAME is filename on the remote -machine and cannot be a UNC path (i.e you must use F<C:\TEMP\App.EVT>). -The method will fail if the log file already exists. - -=item $handle->Read(FLAGS, OFFSET, HASHREF); - -The Read() method read an EventLog entry from the EventLog represented -by $handle. - -=item $handle->Close(); - -The Close() method closes the EventLog represented by $handle. After -Close() has been called, any further attempt to use the EventLog -represented by $handle will fail. - -=item $handle->GetOldest(SCALARREF); - -The GetOldest() method number of the the oldest EventLog record in -the EventLog represented by $handle. This is required to correctly -compute the OFFSET required by the Read() method. - -=item $handle->GetNumber(SCALARREF); - -The GetNumber() method returns the number of EventLog records in -the EventLog represented by $handle. The number of the most recent -record in the EventLog is therefore computed by - - $handle->GetOldest($oldest); - $handle->GetNumber($lastRec); - $lastRecOffset=$oldest+$lastRec; - -=item $handle->Clear(FILENAME); - -The Clear() method clears the EventLog represented by $handle. If -you provide a non-null FILENAME, the EventLog will be backed up -into FILENAME before the EventLog is cleared. The method will fail -if FILENAME is specified and the file refered to exists. Note also -that FILENAME specifies a file local to the machine on which the -EventLog resides and cannot be specified as a UNC name. - -=item $handle->Report(HASHREF); - -The Report() method generates an EventLog entry. The HASHREF should -contain the following keys: - -=over 4 - -=item C<Computer> - -The C<Computer> field specfies which computer you want the EventLog -entry recorded. If this key doesn't exist, the server name used to -create the $handle is used. - -=item C<Source> - -The C<Source> field specifies the source that generated the EventLog -entry. If this key doesn't exist, the source name used to create the -$handle is used. - -=item C<EventType> - -The C<EventType> field should be one of the constants - -=over 4 - -=item C<EVENTLOG_ERROR_TYPE> - -An Error event is being logged. - -=item C<EVENTLOG_WARNING_TYPE> - -A Warning event is being logged. - -=item C<EVENTLOG_INFORMATION_TYPE> - -An Information event is being logged. - -=item C<EVENTLOG_AUDIT_SUCCESS> - -A Success Audit event is being logged (typically in the Security -EventLog). - -=item C<EVENTLOG_AUDIT_FAILURE> - -A Failure Audit event is being logged (typically in the Security -EventLog). - -=back - -These constants are exported into the main namespace by default. - -=item C<Category> - -The C<Category> field can have any value you want. It is specific to -the particular Source. - -=item C<EventID> - -The C<EventID> field should contain the ID of the message that this -event pertains too. This assumes that you have an associated message -file (indirectly referenced by the field C<Source>). - -=item C<Data> - -The C<Data> field contains raw data associated with this event. - -=item C<Strings> - -The C<Strings> field contains the single string that itself contains -NUL terminated sub-strings. This are used with the EventID to generate -the message as seen from (for example) the Event Viewer application. - -=back - -=back - -=head1 Other Win32::EventLog functions. - -The following functions are part of the Win32::EventLog package but -are not callable from an EventLog object. - -=over 4 - -=item GetMessageText(HASHREF); - -The GetMessageText() function assumes that HASHREF was obtained by -a call to C<$handle-E<gt>Read()>. It returns the formatted string that -represents the fully resolved text of the EventLog message (such as -would be seen in the Windows NT Event Viewer). For convenience, the -key 'Message' in the supplied HASHREF is also set to the return value -of this function. - -If you set the variable $Win32::EventLog::GetMessageText to 1 then -each call to C<$handle-E<gt>Read()> will call this function automatically. - -=back - -=head1 Example 1 - -The following example illustrates the way in which the EventLog module -can be used. It opens the System EventLog and reads through it from -oldest to newest records. For each record from the B<Source> EventLog -it extracts the full text of the Entry and prints the EventLog message -text out. - - use Win32::EventLog; - - $handle=Win32::EventLog->new("System", $ENV{ComputerName}) - or die "Can't open Application EventLog\n"; - $handle->GetNumber($recs) - or die "Can't get number of EventLog records\n"; - $handle->GetOldest($base) - or die "Can't get number of oldest EventLog record\n"; - - while ($x < $recs) { - $handle->Read(EVENTLOG_FORWARDS_READ|EVENTLOG_SEEK_READ, - $base+$x, - $hashRef) - or die "Can't read EventLog entry #$x\n"; - if ($hashRef->{Source} eq "EventLog") { - Win32::EventLog::GetMessageText($hashRef); - print "Entry $x: $hashRef->{Message}\n"; - } - $x++; - } - -=head1 Example 2 - -To backup and clear the EventLogs on a remote machine, do the following :- - - use Win32::EventLog; - - $myServer="\\\\my-server"; # your servername here. - my($date)=join("-", ((split(/\s+/, scalar(localtime)))[0,1,2,4])); - my($dest); - - for my $eventLog ("Application", "System", "Security") { - $handle=Win32::EventLog->new($eventLog, $myServer) - or die "Can't open Application EventLog on $myServer\n"; - - $dest="C:\\BackupEventLogs\\$eventLog\\$date.evt"; - $handle->Backup($dest) - or warn "Could not backup and clear the $eventLog EventLog on $myServer ($^E)\n"; - - $handle->Close; - } - -Note that only the Clear method is required. Note also that if the -file $dest exists, the function will fail. - -=head1 BUGS - -None currently known. - -The test script for 'make test' should be re-written to use the -EventLog object. - -=head1 AUTHOR - -Original code by Jesse Dougherty for HiP Communications. Additional -fixes and updates attributed to Martin Pauley -<martin.pauley@ulsterbank.ltd.uk>) and Bret Giddings (bret@essex.ac.uk). diff --git a/Master/tlpkg/tlperl/lib/Win32/File.pm b/Master/tlpkg/tlperl/lib/Win32/File.pm deleted file mode 100644 index d67a25448c8..00000000000 --- a/Master/tlpkg/tlperl/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.05'; - -require Exporter; -require DynaLoader; - -@ISA= qw( Exporter DynaLoader ); -@EXPORT = qw( - ARCHIVE - COMPRESSED - DIRECTORY - HIDDEN - NORMAL - OFFLINE - READONLY - SYSTEM - TEMPORARY - ); -@EXPORT_OK = qw(GetAttributes SetAttributes); - -=head1 NAME - -Win32::File - manage file attributes in perl - -=head1 SYNOPSIS - - use Win32::File; - -=head1 DESCRIPTION - -This module offers the retrieval and setting of file attributes. - -=head1 Functions - -=head2 NOTE - -All of the functions return FALSE (0) if they fail, unless otherwise noted. -The function names are exported into the caller's namespace by request. - -=over 10 - -=item GetAttributes(filename, returnedAttributes) - -Gets the attributes of a file or directory. returnedAttributes will be set -to the OR-ed combination of the filename attributes. - -=item SetAttributes(filename, newAttributes) - -Sets the attributes of a file or directory. newAttributes must be an OR-ed -combination of the attributes. - -=back - -=head1 Constants - -The following constants are exported by default. - -=over 10 - -=item ARCHIVE - -=item COMPRESSED - -=item DIRECTORY - -=item HIDDEN - -=item NORMAL - -=item OFFLINE - -=item READONLY - -=item SYSTEM - -=item TEMPORARY - -=back - -=cut - -sub AUTOLOAD -{ - my($constname); - ($constname = $AUTOLOAD) =~ s/.*:://; - #reset $! to zero to reset any current errors. - local $! = 0; - my $val = constant($constname); - if($! != 0) - { - if($! =~ /Invalid/) - { - $AutoLoader::AUTOLOAD = $AUTOLOAD; - goto &AutoLoader::AUTOLOAD; - } - else - { - ($pack,$file,$line) = caller; - die "Your vendor has not defined Win32::File macro $constname, used in $file at line $line."; - } - } - eval "sub $AUTOLOAD { $val }"; - goto &$AUTOLOAD; -} - -bootstrap Win32::File; - -1; -__END__ diff --git a/Master/tlpkg/tlperl/lib/Win32/FileSecurity.pm b/Master/tlpkg/tlperl/lib/Win32/FileSecurity.pm deleted file mode 100644 index 6c6e5865336..00000000000 --- a/Master/tlpkg/tlperl/lib/Win32/FileSecurity.pm +++ /dev/null @@ -1,308 +0,0 @@ -package Win32::FileSecurity; - -# -# FileSecurity.pm -# By Monte Mitzelfelt, monte@conchas.nm.org -# Larry Wall's Artistic License applies to all related Perl -# and C code for this module -# Thanks to the guys at ActiveWare! -# ver 0.67 ALPHA 1997.07.07 -# - -require Exporter; -require DynaLoader; -use Carp ; - -$VERSION = '1.04'; - -require Win32 unless defined &Win32::IsWinNT; -croak "The Win32::FileSecurity module works only on Windows NT" unless Win32::IsWinNT(); - -@ISA= qw( Exporter DynaLoader ); - -require Exporter ; -require DynaLoader ; - -@ISA = qw(Exporter DynaLoader) ; -@EXPORT_OK = qw( - Get - Set - EnumerateRights - MakeMask - DELETE - READ_CONTROL - WRITE_DAC - WRITE_OWNER - SYNCHRONIZE - STANDARD_RIGHTS_REQUIRED - STANDARD_RIGHTS_READ - STANDARD_RIGHTS_WRITE - STANDARD_RIGHTS_EXECUTE - STANDARD_RIGHTS_ALL - SPECIFIC_RIGHTS_ALL - ACCESS_SYSTEM_SECURITY - MAXIMUM_ALLOWED - GENERIC_READ - GENERIC_WRITE - GENERIC_EXECUTE - GENERIC_ALL - F - FULL - R - READ - C - CHANGE - A - ADD - ) ; - -sub AUTOLOAD { - local($constname); - ($constname = $AUTOLOAD) =~ s/.*:://; - #reset $! to zero to reset any current errors. - local $! = 0; - $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::FileSecurity macro " - ."$constname, used in $file at line $line."; - } - } - eval "sub $AUTOLOAD { $val }"; - goto &$AUTOLOAD; -} - -bootstrap Win32::FileSecurity; - -1; - -__END__ - -=head1 NAME - -Win32::FileSecurity - manage FileSecurity Discretionary Access Control Lists in perl - -=head1 SYNOPSIS - - use Win32::FileSecurity; - -=head1 DESCRIPTION - -This module offers control over the administration of system FileSecurity DACLs. -You may want to use Get and EnumerateRights to get an idea of what mask values -correspond to what rights as viewed from File Manager. - -=head1 CONSTANTS - - DELETE, READ_CONTROL, WRITE_DAC, WRITE_OWNER, - SYNCHRONIZE, STANDARD_RIGHTS_REQUIRED, - STANDARD_RIGHTS_READ, STANDARD_RIGHTS_WRITE, - STANDARD_RIGHTS_EXECUTE, STANDARD_RIGHTS_ALL, - SPECIFIC_RIGHTS_ALL, ACCESS_SYSTEM_SECURITY, - MAXIMUM_ALLOWED, GENERIC_READ, GENERIC_WRITE, - GENERIC_EXECUTE, GENERIC_ALL, F, FULL, R, READ, - C, CHANGE - -=head1 FUNCTIONS - -=head2 NOTE: - -All of the functions return false if they fail, unless otherwise noted. -Errors returned via $! containing both Win32 GetLastError() and a text message -indicating Win32 function that failed. - -=over 10 - -=item constant( $name, $set ) - -Stores the value of named constant $name into $set. -Same as C<$set = Win32::FileSecurity::NAME_OF_CONSTANT();>. - -=item Get( $filename, \%permisshash ) - -Gets the DACLs of a file or directory. - -=item Set( $filename, \%permisshash ) - -Sets the DACL for a file or directory. - -=item EnumerateRights( $mask, \@rightslist ) - -Turns the bitmask in $mask into a list of strings in @rightslist. - -=item MakeMask( qw( DELETE READ_CONTROL ) ) - -Takes a list of strings representing constants and returns a bitmasked -integer value. - -=back - -=head2 %permisshash - -Entries take the form $permisshash{USERNAME} = $mask ; - -=head1 EXAMPLE1 - - # Gets the rights for all files listed on the command line. - use Win32::FileSecurity qw(Get EnumerateRights); - - foreach( @ARGV ) { - next unless -e $_ ; - if ( Get( $_, \%hash ) ) { - while( ($name, $mask) = each %hash ) { - print "$name:\n\t"; - EnumerateRights( $mask, \@happy ) ; - print join( "\n\t", @happy ), "\n"; - } - } - else { - print( "Error #", int( $! ), ": $!" ) ; - } - } - -=head1 EXAMPLE2 - - # Gets existing DACL and modifies Administrator rights - use Win32::FileSecurity qw(MakeMask Get Set); - - # These masks show up as Full Control in File Manager - $file = MakeMask( qw( FULL ) ); - - $dir = MakeMask( qw( - FULL - GENERIC_ALL - ) ); - - foreach( @ARGV ) { - s/\\$//; - next unless -e; - Get( $_, \%hash ) ; - $hash{Administrator} = ( -d ) ? $dir : $file ; - Set( $_, \%hash ) ; - } - -=head1 COMMON MASKS FROM CACLS AND WINFILE - -=head2 READ - - MakeMask( qw( FULL ) ); # for files - MakeMask( qw( READ GENERIC_READ GENERIC_EXECUTE ) ); # for directories - -=head2 CHANGE - - MakeMask( qw( CHANGE ) ); # for files - MakeMask( qw( CHANGE GENERIC_WRITE GENERIC_READ GENERIC_EXECUTE ) ); # for directories - -=head2 ADD & READ - - MakeMask( qw( ADD GENERIC_READ GENERIC_EXECUTE ) ); # for directories only! - -=head2 FULL - - MakeMask( qw( FULL ) ); # for files - MakeMask( qw( FULL GENERIC_ALL ) ); # for directories - -=head1 RESOURCES - -From Microsoft: check_sd - http://premium.microsoft.com/download/msdn/samples/2760.exe - -(thanks to Guert Schimmel at Sybase for turning me on to this one) - -=head1 VERSION - -1.03 ALPHA 97-12-14 - -=head1 REVISION NOTES - -=over 10 - -=item 1.03 ALPHA 1998.01.11 - -Imported diffs from 0.67 (parent) version - -=item 1.02 ALPHA 1997.12.14 - -Pod fixes, @EXPORT list additions <gsar@activestate.com> - -Fix unitialized vars on unknown ACLs <jmk@exc.bybyte.de> - -=item 1.01 ALPHA 1997.04.25 - -CORE Win32 version imported from 0.66 <gsar@activestate.com> - -=item 0.67 ALPHA 1997.07.07 - -Kludged bug in mapping bits to separate ACE's. Notably, this screwed -up CHANGE access by leaving out a delete bit in the -C<INHERIT_ONLY_ACE | OBJECT_INHERIT_ACE> Access Control Entry. - -May need to rethink... - -=item 0.66 ALPHA 1997.03.13 - -Fixed bug in memory allocation check - -=item 0.65 ALPHA 1997.02.25 - -Tested with 5.003 build 303 - -Added ISA exporter, and @EXPORT_OK - -Added F, FULL, R, READ, C, CHANGE as composite pre-built mask names. - -Added server\ to keys returned in hash from Get - -Made constants and MakeMask case insensitive (I don't know why I did that) - -Fixed mask comparison in ListDacl and Enumerate Rights from simple & mask -to exact bit match ! ( ( x & y ) ^ x ) makes sure all bits in x -are set in y - -Fixed some "wild" pointers - -=item 0.60 ALPHA 1996.07.31 - -Now suitable for file and directory permissions - -Included ListDacl.exe in bundle for debugging - -Added "intuitive" inheritance for directories, basically functions like FM -triggered by presence of GENERIC_ rights this may need to change - -see EXAMPLE2 - -Changed from AddAccessAllowedAce to AddAce for control over inheritance - -=item 0.51 ALPHA 1996.07.20 - -Fixed memory allocation bug - -=item 0.50 ALPHA 1996.07.29 - -Base functionality - -Using AddAccessAllowedAce - -Suitable for file permissions - -=back - -=head1 KNOWN ISSUES / BUGS - -=over 10 - -=item 1 - -May not work on remote drives. - -=item 2 - -Errors croak, don't return via $! as documented. - -=cut diff --git a/Master/tlpkg/tlperl/lib/Win32/IPC.pm b/Master/tlpkg/tlperl/lib/Win32/IPC.pm deleted file mode 100644 index c97279b24c5..00000000000 --- a/Master/tlpkg/tlperl/lib/Win32/IPC.pm +++ /dev/null @@ -1,195 +0,0 @@ -#--------------------------------------------------------------------- -package Win32::IPC; -# -# Copyright 1998 Christopher J. Madsen -# -# Created: 3 Feb 1998 from the ActiveWare version -# (c) 1995 Microsoft Corporation. All rights reserved. -# Developed by ActiveWare Internet Corp., http://www.ActiveWare.com -# -# Other modifications (c) 1997 by Gurusamy Sarathy <gsar@activestate.com> -# -# Author: Christopher J. Madsen <cjm@pobox.com> -# Version: 1.03 (11-Jul-2003) -# -# This program is free software; you can redistribute it and/or modify -# it under the same terms as Perl itself. -# -# This program is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See either the -# GNU General Public License or the Artistic License for more details. -# -# Base class for Win32 synchronization objects -#--------------------------------------------------------------------- - -$VERSION = '1.03'; - -require Exporter; -require DynaLoader; -use strict; -use vars qw($AUTOLOAD $VERSION @ISA @EXPORT @EXPORT_OK); - -@ISA = qw(Exporter DynaLoader); -@EXPORT = qw( - INFINITE - WaitForMultipleObjects -); -@EXPORT_OK = qw( - wait_any wait_all -); - -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::IPC macro $constname, used at $file line $line."; - } - eval "sub $AUTOLOAD { $val }"; - goto &$AUTOLOAD; -} # end AUTOLOAD - -bootstrap Win32::IPC; - -# How's this for cryptic? Use wait_any or wait_all! -sub WaitForMultipleObjects -{ - my $result = (($_[1] ? wait_all($_[0], $_[2]) - : wait_any($_[0], $_[2])) - ? 1 - : 0); - @{$_[0]} = (); # Bug for bug compatibility! Use wait_any or wait_all! - $result; -} # end WaitForMultipleObjects - -1; -__END__ - -=head1 NAME - -Win32::IPC - Base class for Win32 synchronization objects - -=head1 SYNOPSIS - - use Win32::Event 1.00 qw(wait_any); - #Create objects. - - wait_any(@ListOfObjects,$timeout); - -=head1 DESCRIPTION - -This module is loaded by the other Win32 synchronization modules. You -shouldn't need to load it yourself. It supplies the wait functions to -those modules. - -The synchronization modules are L<"Win32::ChangeNotify">, -L<"Win32::Event">, L<"Win32::Mutex">, & L<"Win32::Semaphore">. - -In addition, you can use C<wait_any> and C<wait_all> with -L<"Win32::Console"> and L<"Win32::Process"> objects. (However, those -modules do not export the wait functions; you must load one of the -synchronization modules (or just Win32::IPC)). - -=head2 Methods - -B<Win32::IPC> supplies one method to all synchronization objects. - -=over 4 - -=item $obj->wait([$timeout]) - -Waits for C<$obj> to become signalled. C<$timeout> is the maximum time -to wait (in milliseconds). If C<$timeout> is omitted, waits forever. -If C<$timeout> is 0, returns immediately. - -Returns: - - +1 The object is signalled - -1 The object is an abandoned mutex - 0 Timed out - undef An error occurred - -=back - -=head2 Functions - -=over 4 - -=item wait_any(@objects, [$timeout]) - -Waits for at least one of the C<@objects> to become signalled. -C<$timeout> is the maximum time to wait (in milliseconds). If -C<$timeout> is omitted, waits forever. If C<$timeout> is 0, returns -immediately. - -The return value indicates which object ended the wait: - - +N $object[N-1] is signalled - -N $object[N-1] is an abandoned mutex - 0 Timed out - undef An error occurred - -If more than one object became signalled, the one with the lowest -index is used. - -=item wait_all(@objects, [$timeout]) - -This is the same as C<wait_any>, but it waits for all the C<@objects> -to become signalled. The return value indicates the last object to -become signalled, and is negative if at least one of the C<@objects> -is an abandoned mutex. - -=back - -=head2 Deprecated Functions and Methods - -B<Win32::IPC> still supports the ActiveWare syntax, but its use is -deprecated. - -=over 4 - -=item INFINITE - -Constant value for an infinite timeout. Omit the C<$timeout> argument -instead. - -=item WaitForMultipleObjects(\@objects, $wait_all, $timeout) - -Warning: C<WaitForMultipleObjects> erases C<@objects>! -Use C<wait_all> or C<wait_any> instead. - -=item $obj->Wait($timeout) - -Similar to C<not $obj-E<gt>wait($timeout)>. - -=back - -=head1 INTERNALS - -The C<wait_any> and C<wait_all> functions support two kinds of -objects. Objects derived from C<Win32::IPC> are expected to consist -of a reference to a scalar containing the Win32 HANDLE as an IV. - -Other objects (for which C<UNIVERSAL::isa($object, "Win32::IPC")> is -false), are expected to implement a C<get_Win32_IPC_HANDLE> method. -When called in scalar context with no arguments, this method should -return a Win32 HANDLE (as an IV) suitable for passing to the Win32 -WaitForMultipleObjects API function. - -=head1 AUTHOR - -Christopher J. Madsen E<lt>F<cjm@pobox.com>E<gt> - -Loosely based on the original module by ActiveWare Internet Corp., -F<http://www.ActiveWare.com> - -=cut - -# Local Variables: -# tmtrack-file-task: "Win32::IPC" -# End: diff --git a/Master/tlpkg/tlperl/lib/Win32/Internet.pm b/Master/tlpkg/tlperl/lib/Win32/Internet.pm deleted file mode 100644 index f6dac3130af..00000000000 --- a/Master/tlpkg/tlperl/lib/Win32/Internet.pm +++ /dev/null @@ -1,3009 +0,0 @@ -####################################################################### -# -# Win32::Internet - Perl Module for Internet Extensions -# ^^^^^^^^^^^^^^^ -# This module creates an object oriented interface to the Win32 -# Internet Functions (WININET.DLL). -# -# Version: 0.08 (14 Feb 1997) -# Version: 0.081 (25 Sep 1999) -# Version: 0.082 (04 Sep 2001) -# -####################################################################### - -# changes: -# - fixed 2 bugs in Option(s) related subs -# - works with build 30x also - -package Win32::Internet; - -require Exporter; # to export the constants to the main:: space -require DynaLoader; # to dynuhlode the module. - -# use Win32::WinError; # for windows constants. - -@ISA= qw( Exporter DynaLoader ); -@EXPORT = qw( - HTTP_ADDREQ_FLAG_ADD - HTTP_ADDREQ_FLAG_REPLACE - HTTP_QUERY_ALLOW - HTTP_QUERY_CONTENT_DESCRIPTION - HTTP_QUERY_CONTENT_ID - HTTP_QUERY_CONTENT_LENGTH - HTTP_QUERY_CONTENT_TRANSFER_ENCODING - HTTP_QUERY_CONTENT_TYPE - HTTP_QUERY_COST - HTTP_QUERY_CUSTOM - HTTP_QUERY_DATE - HTTP_QUERY_DERIVED_FROM - HTTP_QUERY_EXPIRES - HTTP_QUERY_FLAG_REQUEST_HEADERS - HTTP_QUERY_FLAG_SYSTEMTIME - HTTP_QUERY_LANGUAGE - HTTP_QUERY_LAST_MODIFIED - HTTP_QUERY_MESSAGE_ID - HTTP_QUERY_MIME_VERSION - HTTP_QUERY_PRAGMA - HTTP_QUERY_PUBLIC - HTTP_QUERY_RAW_HEADERS - HTTP_QUERY_RAW_HEADERS_CRLF - HTTP_QUERY_REQUEST_METHOD - HTTP_QUERY_SERVER - HTTP_QUERY_STATUS_CODE - HTTP_QUERY_STATUS_TEXT - HTTP_QUERY_URI - HTTP_QUERY_USER_AGENT - HTTP_QUERY_VERSION - HTTP_QUERY_WWW_LINK - ICU_BROWSER_MODE - ICU_DECODE - ICU_ENCODE_SPACES_ONLY - ICU_ESCAPE - ICU_NO_ENCODE - ICU_NO_META - ICU_USERNAME - INTERNET_FLAG_PASSIVE - INTERNET_FLAG_ASYNC - INTERNET_HYPERLINK - INTERNET_FLAG_KEEP_CONNECTION - INTERNET_FLAG_MAKE_PERSISTENT - INTERNET_FLAG_NO_AUTH - INTERNET_FLAG_NO_AUTO_REDIRECT - INTERNET_FLAG_NO_CACHE_WRITE - INTERNET_FLAG_NO_COOKIES - INTERNET_FLAG_READ_PREFETCH - INTERNET_FLAG_RELOAD - INTERNET_FLAG_RESYNCHRONIZE - INTERNET_FLAG_TRANSFER_ASCII - INTERNET_FLAG_TRANSFER_BINARY - INTERNET_INVALID_PORT_NUMBER - INTERNET_INVALID_STATUS_CALLBACK - INTERNET_OPEN_TYPE_DIRECT - INTERNET_OPEN_TYPE_PROXY - INTERNET_OPEN_TYPE_PROXY_PRECONFIG - INTERNET_OPTION_CONNECT_BACKOFF - INTERNET_OPTION_CONNECT_RETRIES - INTERNET_OPTION_CONNECT_TIMEOUT - INTERNET_OPTION_CONTROL_SEND_TIMEOUT - INTERNET_OPTION_CONTROL_RECEIVE_TIMEOUT - INTERNET_OPTION_DATA_SEND_TIMEOUT - INTERNET_OPTION_DATA_RECEIVE_TIMEOUT - INTERNET_OPTION_HANDLE_SIZE - INTERNET_OPTION_LISTEN_TIMEOUT - INTERNET_OPTION_PASSWORD - INTERNET_OPTION_READ_BUFFER_SIZE - INTERNET_OPTION_USER_AGENT - INTERNET_OPTION_USERNAME - INTERNET_OPTION_VERSION - INTERNET_OPTION_WRITE_BUFFER_SIZE - INTERNET_SERVICE_FTP - INTERNET_SERVICE_GOPHER - INTERNET_SERVICE_HTTP - INTERNET_STATUS_CLOSING_CONNECTION - INTERNET_STATUS_CONNECTED_TO_SERVER - INTERNET_STATUS_CONNECTING_TO_SERVER - INTERNET_STATUS_CONNECTION_CLOSED - INTERNET_STATUS_HANDLE_CLOSING - INTERNET_STATUS_HANDLE_CREATED - INTERNET_STATUS_NAME_RESOLVED - INTERNET_STATUS_RECEIVING_RESPONSE - INTERNET_STATUS_REDIRECT - INTERNET_STATUS_REQUEST_COMPLETE - INTERNET_STATUS_REQUEST_SENT - INTERNET_STATUS_RESOLVING_NAME - INTERNET_STATUS_RESPONSE_RECEIVED - INTERNET_STATUS_SENDING_REQUEST -); - - -####################################################################### -# This AUTOLOAD is used to 'autoload' constants from the constant() -# XS function. If a constant is not found then control is passed -# to the AUTOLOAD in AutoLoader. -# - -sub AUTOLOAD { - my($constname); - ($constname = $AUTOLOAD) =~ s/.*:://; - #reset $! to zero to reset any current errors. - local $! = 0; - my $val = constant($constname, @_ ? $_[0] : 0); - if ($! != 0) { - - # [dada] This results in an ugly Autoloader error - #if ($! =~ /Invalid/) { - # $AutoLoader::AUTOLOAD = $AUTOLOAD; - # goto &AutoLoader::AUTOLOAD; - #} else { - - # [dada] ... I prefer this one :) - - ($pack,$file,$line) = caller; undef $pack; - die "Win32::Internet::$constname is not defined, used at $file line $line."; - - #} - } - eval "sub $AUTOLOAD { $val }"; - goto &$AUTOLOAD; -} - - -####################################################################### -# STATIC OBJECT PROPERTIES -# -$VERSION = "0.082"; - -%callback_code = (); -%callback_info = (); - - -####################################################################### -# PUBLIC METHODS -# - -#======== ### CLASS CONSTRUCTOR -sub new { -#======== - my($class, $useragent, $opentype, $proxy, $proxybypass, $flags) = @_; - my $self = {}; - - if(ref($useragent) and ref($useragent) eq "HASH") { - $opentype = $useragent->{'opentype'}; - $proxy = $useragent->{'proxy'}; - $proxybypass = $useragent->{'proxybypass'}; - $flags = $useragent->{'flags'}; - my $myuseragent = $useragent->{'useragent'}; - undef $useragent; - $useragent = $myuseragent; - } - - $useragent = "Perl-Win32::Internet/".$VERSION unless defined($useragent); - $opentype = constant("INTERNET_OPEN_TYPE_DIRECT",0) unless defined($opentype); - $proxy = "" unless defined($proxy); - $proxybypass = "" unless defined($proxybypass); - $flags = 0 unless defined($flags); - - - my $handle = InternetOpen($useragent, $opentype, $proxy, $proxybypass, $flags); - if ($handle) { - $self->{'connections'} = 0; - $self->{'pasv'} = 0; - $self->{'handle'} = $handle; - $self->{'useragent'} = $useragent; - $self->{'proxy'} = $proxy; - $self->{'proxybypass'} = $proxybypass; - $self->{'flags'} = $flags; - $self->{'Type'} = "Internet"; - - # [dada] I think it's better to call SetStatusCallback explicitly... - #if($flags & constant("INTERNET_FLAG_ASYNC",0)) { - # my $callbackresult=InternetSetStatusCallback($handle); - # if($callbackresult==&constant("INTERNET_INVALID_STATUS_CALLBACK",0)) { - # $self->{'Error'} = -2; - # } - #} - - bless $self; - } else { - $self->{'handle'} = undef; - bless $self; - } - $self; -} - - -#============ -sub OpenURL { -#============ - my($self,$new,$URL) = @_; - return undef unless ref($self); - - my $newhandle=InternetOpenUrl($self->{'handle'},$URL,"",0,0,0); - if(!$newhandle) { - $self->{'Error'} = "Cannot open URL."; - return undef; - } else { - $self->{'connections'}++; - $_[1] = _new($newhandle); - $_[1]->{'Type'} = "URL"; - $_[1]->{'URL'} = $URL; - return $newhandle; - } -} - - -#================ -sub TimeConvert { -#================ - my($self, $sec, $min, $hour, $day, $mon, $year, $wday, $rfc) = @_; - return undef unless ref($self); - - if(!defined($rfc)) { - return InternetTimeToSystemTime($sec); - } else { - return InternetTimeFromSystemTime($sec, $min, $hour, - $day, $mon, $year, - $wday, $rfc); - } -} - - -#======================= -sub QueryDataAvailable { -#======================= - my($self) = @_; - return undef unless ref($self); - - return InternetQueryDataAvailable($self->{'handle'}); -} - - -#============= -sub ReadFile { -#============= - my($self, $buffersize) = @_; - return undef unless ref($self); - - my $howmuch = InternetQueryDataAvailable($self->{'handle'}); - $buffersize = $howmuch unless defined($buffersize); - return InternetReadFile($self->{'handle'}, ($howmuch<$buffersize) ? $howmuch - : $buffersize); -} - - -#=================== -sub ReadEntireFile { -#=================== - my($handle) = @_; - my $content = ""; - my $buffersize = 16000; - my $howmuch = 0; - my $buffer = ""; - - $handle = $handle->{'handle'} if defined($handle) and ref($handle); - - $howmuch = InternetQueryDataAvailable($handle); - # print "\nReadEntireFile: $howmuch bytes to read...\n"; - - while($howmuch>0) { - $buffer = InternetReadFile($handle, ($howmuch<$buffersize) ? $howmuch - : $buffersize); - # print "\nReadEntireFile: ", length($buffer), " bytes read...\n"; - - if(!defined($buffer)) { - return undef; - } else { - $content .= $buffer; - } - $howmuch = InternetQueryDataAvailable($handle); - # print "\nReadEntireFile: still $howmuch bytes to read...\n"; - - } - return $content; -} - - -#============= -sub FetchURL { -#============= - # (OpenURL+Read+Close)... - my($self, $URL) = @_; - return undef unless ref($self); - - my $newhandle = InternetOpenUrl($self->{'handle'}, $URL, "", 0, 0, 0); - if(!$newhandle) { - $self->{'Error'} = "Cannot open URL."; - return undef; - } else { - my $content = ReadEntireFile($newhandle); - InternetCloseHandle($newhandle); - return $content; - } -} - - -#================ -sub Connections { -#================ - my($self) = @_; - return undef unless ref($self); - - return $self->{'connections'} if $self->{'Type'} eq "Internet"; - return undef; -} - - -#================ -sub GetResponse { -#================ - my($num, $text) = InternetGetLastResponseInfo(); - return $text; -} - -#=========== -sub Option { -#=========== - my($self, $option, $value) = @_; - return undef unless ref($self); - - my $retval = 0; - - $option = constant("INTERNET_OPTION_USER_AGENT", 0) unless defined($option); - - if(!defined($value)) { - $retval = InternetQueryOption($self->{'handle'}, $option); - } else { - $retval = InternetSetOption($self->{'handle'}, $option, $value); - } - return $retval; -} - - -#============== -sub UserAgent { -#============== - my($self, $value) = @_; - return undef unless ref($self); - - return Option($self, constant("INTERNET_OPTION_USER_AGENT", 0), $value); -} - - -#============= -sub Username { -#============= - my($self, $value) = @_; - return undef unless ref($self); - - if($self->{'Type'} ne "HTTP" and $self->{'Type'} ne "FTP") { - $self->{'Error'} = "Username() only on FTP or HTTP sessions."; - return undef; - } - - return Option($self, constant("INTERNET_OPTION_USERNAME", 0), $value); -} - - -#============= -sub Password { -#============= - my($self, $value)=@_; - return undef unless ref($self); - - if($self->{'Type'} ne "HTTP" and $self->{'Type'} ne "FTP") { - $self->{'Error'} = "Password() only on FTP or HTTP sessions."; - return undef; - } - - return Option($self, constant("INTERNET_OPTION_PASSWORD", 0), $value); -} - - -#=================== -sub ConnectTimeout { -#=================== - my($self, $value) = @_; - return undef unless ref($self); - - return Option($self, constant("INTERNET_OPTION_CONNECT_TIMEOUT", 0), $value); -} - - -#=================== -sub ConnectRetries { -#=================== - my($self, $value) = @_; - return undef unless ref($self); - - return Option($self, constant("INTERNET_OPTION_CONNECT_RETRIES", 0), $value); -} - - -#=================== -sub ConnectBackoff { -#=================== - my($self,$value)=@_; - return undef unless ref($self); - - return Option($self, constant("INTERNET_OPTION_CONNECT_BACKOFF", 0), $value); -} - - -#==================== -sub DataSendTimeout { -#==================== - my($self,$value) = @_; - return undef unless ref($self); - - return Option($self, constant("INTERNET_OPTION_DATA_SEND_TIMEOUT", 0), $value); -} - - -#======================= -sub DataReceiveTimeout { -#======================= - my($self, $value) = @_; - return undef unless ref($self); - - return Option($self, constant("INTERNET_OPTION_DATA_RECEIVE_TIMEOUT", 0), $value); -} - - -#========================== -sub ControlReceiveTimeout { -#========================== - my($self, $value) = @_; - return undef unless ref($self); - - return Option($self, constant("INTERNET_OPTION_CONTROL_RECEIVE_TIMEOUT", 0), $value); -} - - -#======================= -sub ControlSendTimeout { -#======================= - my($self, $value) = @_; - return undef unless ref($self); - - return Option($self, constant("INTERNET_OPTION_CONTROL_SEND_TIMEOUT", 0), $value); -} - - -#================ -sub QueryOption { -#================ - my($self, $option) = @_; - return undef unless ref($self); - - return InternetQueryOption($self->{'handle'}, $option); -} - - -#============== -sub SetOption { -#============== - my($self, $option, $value) = @_; - return undef unless ref($self); - - return InternetSetOption($self->{'handle'}, $option, $value); -} - - -#============= -sub CrackURL { -#============= - my($self, $URL, $flags) = @_; - return undef unless ref($self); - - $flags = constant("ICU_ESCAPE", 0) unless defined($flags); - - my @newurl = InternetCrackUrl($URL, $flags); - - if(!defined($newurl[0])) { - $self->{'Error'} = "Cannot crack URL."; - return undef; - } else { - return @newurl; - } -} - - -#============== -sub CreateURL { -#============== - my($self, $scheme, $hostname, $port, - $username, $password, - $path, $extrainfo, $flags) = @_; - return undef unless ref($self); - - if(ref($scheme) and ref($scheme) eq "HASH") { - $flags = $hostname; - $hostname = $scheme->{'hostname'}; - $port = $scheme->{'port'}; - $username = $scheme->{'username'}; - $password = $scheme->{'password'}; - $path = $scheme->{'path'}; - $extrainfo = $scheme->{'extrainfo'}; - my $myscheme = $scheme->{'scheme'}; - undef $scheme; - $scheme = $myscheme; - } - - $hostname = "" unless defined($hostname); - $port = 0 unless defined($port); - $username = "" unless defined($username); - $password = "" unless defined($password); - $path = "" unless defined($path); - $extrainfo = "" unless defined($extrainfo); - $flags = constant("ICU_ESCAPE", 0) unless defined($flags); - - my $newurl = InternetCreateUrl($scheme, $hostname, $port, - $username, $password, - $path, $extrainfo, $flags); - if(!defined($newurl)) { - $self->{'Error'} = "Cannot create URL."; - return undef; - } else { - return $newurl; - } -} - - -#==================== -sub CanonicalizeURL { -#==================== - my($self, $URL, $flags) = @_; - return undef unless ref($self); - - my $newurl = InternetCanonicalizeUrl($URL, $flags); - if(!defined($newurl)) { - $self->{'Error'} = "Cannot canonicalize URL."; - return undef; - } else { - return $newurl; - } -} - - -#=============== -sub CombineURL { -#=============== - my($self, $baseURL, $relativeURL, $flags) = @_; - return undef unless ref($self); - - my $newurl = InternetCombineUrl($baseURL, $relativeURL, $flags); - if(!defined($newurl)) { - $self->{'Error'} = "Cannot combine URL(s)."; - return undef; - } else { - return $newurl; - } -} - - -#====================== -sub SetStatusCallback { -#====================== - my($self) = @_; - return undef unless ref($self); - - my $callback = InternetSetStatusCallback($self->{'handle'}); - print "callback=$callback, constant=",constant("INTERNET_INVALID_STATUS_CALLBACK", 0), "\n"; - if($callback == constant("INTERNET_INVALID_STATUS_CALLBACK", 0)) { - return undef; - } else { - return $callback; - } -} - - -#====================== -sub GetStatusCallback { -#====================== - my($self, $context) = @_; - $context = $self if not defined $context; - return($callback_code{$context}, $callback_info{$context}); -} - - -#========== -sub Error { -#========== - my($self) = @_; - return undef unless ref($self); - - require Win32 unless defined &Win32::GetLastError; - my $errtext = ""; - my $tmp = ""; - my $errnum = Win32::GetLastError(); - - if($errnum < 12000) { - $errtext = Win32::FormatMessage($errnum); - $errtext =~ s/[\r\n]//g; - } elsif($errnum == 12003) { - ($tmp, $errtext) = InternetGetLastResponseInfo(); - chomp $errtext; - 1 while($errtext =~ s/(.*)\n//); # the last line should be significative... - # otherwise call GetResponse() to get it whole - } elsif($errnum >= 12000) { - $errtext = FormatMessage($errnum); - $errtext =~ s/[\r\n]//g; - } else { - $errtext="Error"; - } - if($errnum == 0 and defined($self->{'Error'})) { - if($self->{'Error'} == -2) { - $errnum = -2; - $errtext = "Asynchronous operations not available."; - } else { - $errnum = -1; - $errtext = $self->{'Error'}; - } - } - return (wantarray)? ($errnum, $errtext) : "\[".$errnum."\] ".$errtext; -} - - -#============ -sub Version { -#============ - my $dll = InternetDllVersion(); - $dll =~ s/\0//g; - return (wantarray)? ($Win32::Internet::VERSION, $dll) - : $Win32::Internet::VERSION."/".$dll; -} - - -#========== -sub Close { -#========== - my($self, $handle) = @_; - if(!defined($handle)) { - return undef unless ref($self); - $handle = $self->{'handle'}; - } - InternetCloseHandle($handle); -} - - - -####################################################################### -# FTP CLASS METHODS -# - -#======== ### FTP CONSTRUCTOR -sub FTP { -#======== - my($self, $new, $server, $username, $password, $port, $pasv, $context) = @_; - return undef unless ref($self); - - if(ref($server) and ref($server) eq "HASH") { - $port = $server->{'port'}; - $username = $server->{'username'}; - $password = $password->{'host'}; - my $myserver = $server->{'server'}; - $pasv = $server->{'pasv'}; - $context = $server->{'context'}; - undef $server; - $server = $myserver; - } - - $server = "" unless defined($server); - $username = "anonymous" unless defined($username); - $password = "" unless defined($password); - $port = 21 unless defined($port); - $context = 0 unless defined($context); - - $pasv = $self->{'pasv'} unless defined $pasv; - $pasv = $pasv ? constant("INTERNET_FLAG_PASSIVE",0) : 0; - - my $newhandle = InternetConnect($self->{'handle'}, $server, $port, - $username, $password, - constant("INTERNET_SERVICE_FTP", 0), - $pasv, $context); - if($newhandle) { - $self->{'connections'}++; - $_[1] = _new($newhandle); - $_[1]->{'Type'} = "FTP"; - $_[1]->{'Mode'} = "bin"; - $_[1]->{'pasv'} = $pasv; - $_[1]->{'username'} = $username; - $_[1]->{'password'} = $password; - $_[1]->{'server'} = $server; - return $newhandle; - } else { - return undef; - } -} - -#======== -sub Pwd { -#======== - my($self) = @_; - return undef unless ref($self); - - if($self->{'Type'} ne "FTP" or !defined($self->{'handle'})) { - $self->{'Error'} = "Pwd() only on FTP sessions."; - return undef; - } - - return FtpGetCurrentDirectory($self->{'handle'}); -} - - -#======= -sub Cd { -#======= - my($self, $path) = @_; - return undef unless ref($self); - - if($self->{'Type'} ne "FTP" || !defined($self->{'handle'})) { - $self->{'Error'} = "Cd() only on FTP sessions."; - return undef; - } - - my $retval = FtpSetCurrentDirectory($self->{'handle'}, $path); - if(!defined($retval)) { - return undef; - } else { - return $path; - } -} -#==================== -sub Cwd { Cd(@_); } -sub Chdir { Cd(@_); } -#==================== - - -#========== -sub Mkdir { -#========== - my($self, $path) = @_; - return undef unless ref($self); - - if($self->{'Type'} ne "FTP" or !defined($self->{'handle'})) { - $self->{'Error'} = "Mkdir() only on FTP sessions."; - return undef; - } - - my $retval = FtpCreateDirectory($self->{'handle'}, $path); - $self->{'Error'} = "Can't create directory." unless defined($retval); - return $retval; -} -#==================== -sub Md { Mkdir(@_); } -#==================== - - -#========= -sub Mode { -#========= - my($self, $value) = @_; - return undef unless ref($self); - - if($self->{'Type'} ne "FTP" or !defined($self->{'handle'})) { - $self->{'Error'} = "Mode() only on FTP sessions."; - return undef; - } - - if(!defined($value)) { - return $self->{'Mode'}; - } else { - my $modesub = ($value =~ /^a/i) ? "Ascii" : "Binary"; - $self->$modesub($_[0]); - } - return $self->{'Mode'}; -} - - -#========== -sub Rmdir { -#========== - my($self, $path) = @_; - return undef unless ref($self); - - if($self->{'Type'} ne "FTP" or !defined($self->{'handle'})) { - $self->{'Error'} = "Rmdir() only on FTP sessions."; - return undef; - } - my $retval = FtpRemoveDirectory($self->{'handle'}, $path); - $self->{'Error'} = "Can't remove directory." unless defined($retval); - return $retval; -} -#==================== -sub Rd { Rmdir(@_); } -#==================== - - -#========= -sub Pasv { -#========= - my($self, $value) = @_; - return undef unless ref($self); - - if(defined($value) and $self->{'Type'} eq "Internet") { - if($value == 0) { - $self->{'pasv'} = 0; - } else { - $self->{'pasv'} = 1; - } - } - return $self->{'pasv'}; -} - -#========= -sub List { -#========= - my($self, $pattern, $retmode) = @_; - return undef unless ref($self); - - my $retval = ""; - my $size = ""; - my $attr = ""; - my $ctime = ""; - my $atime = ""; - my $mtime = ""; - my $csec = 0; my $cmin = 0; my $chou = 0; my $cday = 0; my $cmon = 0; my $cyea = 0; - my $asec = 0; my $amin = 0; my $ahou = 0; my $aday = 0; my $amon = 0; my $ayea = 0; - my $msec = 0; my $mmin = 0; my $mhou = 0; my $mday = 0; my $mmon = 0; my $myea = 0; - my $newhandle = 0; - my $nextfile = 1; - my @results = (); - my ($filename, $altname, $file); - - if($self->{'Type'} ne "FTP") { - $self->{'Error'} = "List() only on FTP sessions."; - return undef; - } - - $pattern = "" unless defined($pattern); - $retmode = 1 unless defined($retmode); - - if($retmode == 2) { - - ( $newhandle,$filename, $altname, $size, $attr, - $csec, $cmin, $chou, $cday, $cmon, $cyea, - $asec, $amin, $ahou, $aday, $amon, $ayea, - $msec, $mmin, $mhou, $mday, $mmon, $myea - ) = FtpFindFirstFile($self->{'handle'}, $pattern, 0, 0); - - if(!$newhandle) { - $self->{'Error'} = "Can't read FTP directory."; - return undef; - } else { - - while($nextfile) { - $ctime = join(",", ($csec, $cmin, $chou, $cday, $cmon, $cyea)); - $atime = join(",", ($asec, $amin, $ahou, $aday, $amon, $ayea)); - $mtime = join(",", ($msec, $mmin, $mhou, $mday, $mmon, $myea)); - push(@results, $filename, $altname, $size, $attr, $ctime, $atime, $mtime); - - ( $nextfile, $filename, $altname, $size, $attr, - $csec, $cmin, $chou, $cday, $cmon, $cyea, - $asec, $amin, $ahou, $aday, $amon, $ayea, - $msec, $mmin, $mhou, $mday, $mmon, $myea - ) = InternetFindNextFile($newhandle); - - } - InternetCloseHandle($newhandle); - return @results; - - } - - } elsif($retmode == 3) { - - ( $newhandle,$filename, $altname, $size, $attr, - $csec, $cmin, $chou, $cday, $cmon, $cyea, - $asec, $amin, $ahou, $aday, $amon, $ayea, - $msec, $mmin, $mhou, $mday, $mmon, $myea - ) = FtpFindFirstFile($self->{'handle'}, $pattern, 0, 0); - - if(!$newhandle) { - $self->{'Error'} = "Can't read FTP directory."; - return undef; - - } else { - - while($nextfile) { - $ctime = join(",", ($csec, $cmin, $chou, $cday, $cmon, $cyea)); - $atime = join(",", ($asec, $amin, $ahou, $aday, $amon, $ayea)); - $mtime = join(",", ($msec, $mmin, $mhou, $mday, $mmon, $myea)); - $file = { "name" => $filename, - "altname" => $altname, - "size" => $size, - "attr" => $attr, - "ctime" => $ctime, - "atime" => $atime, - "mtime" => $mtime, - }; - push(@results, $file); - - ( $nextfile, $filename, $altname, $size, $attr, - $csec, $cmin, $chou, $cday, $cmon, $cyea, - $asec, $amin, $ahou, $aday, $amon, $ayea, - $msec, $mmin, $mhou, $mday, $mmon, $myea - ) = InternetFindNextFile($newhandle); - - } - InternetCloseHandle($newhandle); - return @results; - } - - } else { - - ($newhandle, $filename) = FtpFindFirstFile($self->{'handle'}, $pattern, 0, 0); - - if(!$newhandle) { - $self->{'Error'} = "Can't read FTP directory."; - return undef; - - } else { - - while($nextfile) { - push(@results, $filename); - - ($nextfile, $filename) = InternetFindNextFile($newhandle); - # print "List.no more files\n" if !$nextfile; - - } - InternetCloseHandle($newhandle); - return @results; - } - } -} -#==================== -sub Ls { List(@_); } -sub Dir { List(@_); } -#==================== - - -#================= -sub FileAttrInfo { -#================= - my($self,$attr) = @_; - my @attrinfo = (); - push(@attrinfo, "READONLY") if $attr & 1; - push(@attrinfo, "HIDDEN") if $attr & 2; - push(@attrinfo, "SYSTEM") if $attr & 4; - push(@attrinfo, "DIRECTORY") if $attr & 16; - push(@attrinfo, "ARCHIVE") if $attr & 32; - push(@attrinfo, "NORMAL") if $attr & 128; - push(@attrinfo, "TEMPORARY") if $attr & 256; - push(@attrinfo, "COMPRESSED") if $attr & 2048; - return (wantarray)? @attrinfo : join(" ", @attrinfo); -} - - -#=========== -sub Binary { -#=========== - my($self) = @_; - return undef unless ref($self); - - if($self->{'Type'} ne "FTP") { - $self->{'Error'} = "Binary() only on FTP sessions."; - return undef; - } - $self->{'Mode'} = "bin"; - return undef; -} -#====================== -sub Bin { Binary(@_); } -#====================== - - -#========== -sub Ascii { -#========== - my($self) = @_; - return undef unless ref($self); - - if($self->{'Type'} ne "FTP") { - $self->{'Error'} = "Ascii() only on FTP sessions."; - return undef; - } - $self->{'Mode'} = "asc"; - return undef; -} -#===================== -sub Asc { Ascii(@_); } -#===================== - - -#======== -sub Get { -#======== - my($self, $remote, $local, $overwrite, $flags, $context) = @_; - return undef unless ref($self); - - if($self->{'Type'} ne "FTP") { - $self->{'Error'} = "Get() only on FTP sessions."; - return undef; - } - my $mode = ($self->{'Mode'} eq "asc" ? 1 : 2); - - $remote = "" unless defined($remote); - $local = $remote unless defined($local); - $overwrite = 0 unless defined($overwrite); - $flags = 0 unless defined($flags); - $context = 0 unless defined($context); - - my $retval = FtpGetFile($self->{'handle'}, - $remote, - $local, - $overwrite, - $flags, - $mode, - $context); - $self->{'Error'} = "Can't get file." unless defined($retval); - return $retval; -} - - -#=========== -sub Rename { -#=========== - my($self, $oldname, $newname) = @_; - return undef unless ref($self); - - if($self->{'Type'} ne "FTP") { - $self->{'Error'} = "Rename() only on FTP sessions."; - return undef; - } - - my $retval = FtpRenameFile($self->{'handle'}, $oldname, $newname); - $self->{'Error'} = "Can't rename file." unless defined($retval); - return $retval; -} -#====================== -sub Ren { Rename(@_); } -#====================== - - -#=========== -sub Delete { -#=========== - my($self, $filename) = @_; - return undef unless ref($self); - - if($self->{'Type'} ne "FTP") { - $self->{'Error'} = "Delete() only on FTP sessions."; - return undef; - } - my $retval = FtpDeleteFile($self->{'handle'}, $filename); - $self->{'Error'} = "Can't delete file." unless defined($retval); - return $retval; -} -#====================== -sub Del { Delete(@_); } -#====================== - - -#======== -sub Put { -#======== - my($self, $local, $remote, $context) = @_; - return undef unless ref($self); - - if($self->{'Type'} ne "FTP") { - $self->{'Error'} = "Put() only on FTP sessions."; - return undef; - } - my $mode = ($self->{'Mode'} eq "asc" ? 1 : 2); - - $context = 0 unless defined($context); - - my $retval = FtpPutFile($self->{'handle'}, $local, $remote, $mode, $context); - $self->{'Error'} = "Can't put file." unless defined($retval); - return $retval; -} - - -####################################################################### -# HTTP CLASS METHODS -# - -#========= ### HTTP CONSTRUCTOR -sub HTTP { -#========= - my($self, $new, $server, $username, $password, $port, $flags, $context) = @_; - return undef unless ref($self); - - if(ref($server) and ref($server) eq "HASH") { - my $myserver = $server->{'server'}; - $username = $server->{'username'}; - $password = $password->{'host'}; - $port = $server->{'port'}; - $flags = $server->{'flags'}; - $context = $server->{'context'}; - undef $server; - $server = $myserver; - } - - $server = "" unless defined($server); - $username = "anonymous" unless defined($username); - $password = "" unless defined($password); - $port = 80 unless defined($port); - $flags = 0 unless defined($flags); - $context = 0 unless defined($context); - - my $newhandle = InternetConnect($self->{'handle'}, $server, $port, - $username, $password, - constant("INTERNET_SERVICE_HTTP", 0), - $flags, $context); - if($newhandle) { - $self->{'connections'}++; - $_[1] = _new($newhandle); - $_[1]->{'Type'} = "HTTP"; - $_[1]->{'username'} = $username; - $_[1]->{'password'} = $password; - $_[1]->{'server'} = $server; - $_[1]->{'accept'} = "text/*\0image/gif\0image/jpeg\0\0"; - return $newhandle; - } else { - return undef; - } -} - - -#================ -sub OpenRequest { -#================ - # alternatively to Request: - # it creates a new HTTP_Request object - # you can act upon it with AddHeader, SendRequest, ReadFile, QueryInfo, Close, ... - - my($self, $new, $path, $method, $version, $referer, $accept, $flags, $context) = @_; - return undef unless ref($self); - - if($self->{'Type'} ne "HTTP") { - $self->{'Error'} = "OpenRequest() only on HTTP sessions."; - return undef; - } - - if(ref($path) and ref($path) eq "HASH") { - $method = $path->{'method'}; - $version = $path->{'version'}; - $referer = $path->{'referer'}; - $accept = $path->{'accept'}; - $flags = $path->{'flags'}; - $context = $path->{'context'}; - my $mypath = $path->{'path'}; - undef $path; - $path = $mypath; - } - - $method = "GET" unless defined($method); - $path = "/" unless defined($path); - $version = "HTTP/1.0" unless defined($version); - $referer = "" unless defined($referer); - $accept = $self->{'accept'} unless defined($accept); - $flags = 0 unless defined($flags); - $context = 0 unless defined($context); - - $path = "/".$path if substr($path,0,1) ne "/"; - # accept string list needs to be terminated by double-NULL - $accept .= "\0\0" unless $accept =~ /\0\0\z/; - - my $newhandle = HttpOpenRequest($self->{'handle'}, - $method, - $path, - $version, - $referer, - $accept, - $flags, - $context); - if($newhandle) { - $_[1] = _new($newhandle); - $_[1]->{'Type'} = "HTTP_Request"; - $_[1]->{'method'} = $method; - $_[1]->{'request'} = $path; - $_[1]->{'accept'} = $accept; - return $newhandle; - } else { - return undef; - } -} - -#================ -sub SendRequest { -#================ - my($self, $postdata) = @_; - return undef unless ref($self); - - if($self->{'Type'} ne "HTTP_Request") { - $self->{'Error'} = "SendRequest() only on HTTP requests."; - return undef; - } - - $postdata = "" unless defined($postdata); - - return HttpSendRequest($self->{'handle'}, "", $postdata); -} - - -#============== -sub AddHeader { -#============== - my($self, $header, $flags) = @_; - return undef unless ref($self); - - if($self->{'Type'} ne "HTTP_Request") { - $self->{'Error'} = "AddHeader() only on HTTP requests."; - return undef; - } - - $flags = constant("HTTP_ADDREQ_FLAG_ADD", 0) if (!defined($flags) or $flags == 0); - - return HttpAddRequestHeaders($self->{'handle'}, $header, $flags); -} - - -#============== -sub QueryInfo { -#============== - my($self, $header, $flags) = @_; - return undef unless ref($self); - - if($self->{'Type'} ne "HTTP_Request") { - $self->{'Error'}="QueryInfo() only on HTTP requests."; - return undef; - } - - $flags = constant("HTTP_QUERY_CUSTOM", 0) if (!defined($flags) and defined($header)); - my @queryresult = HttpQueryInfo($self->{'handle'}, $flags, $header); - return (wantarray)? @queryresult : join(" ", @queryresult); -} - - -#============ -sub Request { -#============ - # HttpOpenRequest+HttpAddHeaders+HttpSendRequest+InternetReadFile+HttpQueryInfo - my($self, $path, $method, $version, $referer, $accept, $flags, $postdata) = @_; - return undef unless ref($self); - - if($self->{'Type'} ne "HTTP") { - $self->{'Error'} = "Request() only on HTTP sessions."; - return undef; - } - - if(ref($path) and ref($path) eq "HASH") { - $method = $path->{'method'}; - $version = $path->{'version'}; - $referer = $path->{'referer'}; - $accept = $path->{'accept'}; - $flags = $path->{'flags'}; - $postdata = $path->{'postdata'}; - my $mypath = $path->{'path'}; - undef $path; - $path = $mypath; - } - - my $content = ""; - my $result = ""; - my @queryresult = (); - my $statuscode = ""; - my $headers = ""; - - $path = "/" unless defined($path); - $method = "GET" unless defined($method); - $version = "HTTP/1.0" unless defined($version); - $referer = "" unless defined($referer); - $accept = $self->{'accept'} unless defined($accept); - $flags = 0 unless defined($flags); - $postdata = "" unless defined($postdata); - - $path = "/".$path if substr($path,0,1) ne "/"; - # accept string list needs to be terminated by double-NULL - $accept .= "\0\0" unless $accept =~ /\0\0\z/; - - my $newhandle = HttpOpenRequest($self->{'handle'}, - $method, - $path, - $version, - $referer, - $accept, - $flags, - 0); - - if($newhandle) { - - $result = HttpSendRequest($newhandle, "", $postdata); - - if(defined($result)) { - $statuscode = HttpQueryInfo($newhandle, - constant("HTTP_QUERY_STATUS_CODE", 0), ""); - $headers = HttpQueryInfo($newhandle, - constant("HTTP_QUERY_RAW_HEADERS_CRLF", 0), ""); - $content = ReadEntireFile($newhandle); - - InternetCloseHandle($newhandle); - - return($statuscode, $headers, $content); - } else { - return undef; - } - } else { - return undef; - } -} - - -####################################################################### -# END OF THE PUBLIC METHODS -# - - -#========= ### SUB-CLASSES CONSTRUCTOR -sub _new { -#========= - my $self = {}; - if ($_[0]) { - $self->{'handle'} = $_[0]; - bless $self; - } else { - undef($self); - } - $self; -} - - -#============ ### CLASS DESTRUCTOR -sub DESTROY { -#============ - my($self) = @_; - # print "Closing handle $self->{'handle'}...\n"; - InternetCloseHandle($self->{'handle'}); - # [dada] rest in peace -} - - -#============= -sub callback { -#============= - my($name, $status, $info) = @_; - $callback_code{$name} = $status; - $callback_info{$name} = $info; -} - -####################################################################### -# dynamically load in the Internet.pll module. -# - -bootstrap Win32::Internet; - -# Preloaded methods go here. - -#Currently Autoloading is not implemented in Perl for win32 -# Autoload methods go after __END__, and are processed by the autosplit program. - -1; -__END__ - -=head1 NAME - -Win32::Internet - Access to WININET.DLL functions - -=head1 INTRODUCTION - -This extension to Perl implements the Win32 Internet APIs (found in -F<WININET.DLL>). They give a complete support for HTTP, FTP and GOPHER -connections. - -See the L<"Version History"> and the L<"Functions Table"> for a list -of the currently supported features. You should also get a copy of the -L<"Microsoft Win32 Internet Functions"> documentation. - -=head1 REFERENCE - -To use this module, first add the following line at the beginning of -your script: - - use Win32::Internet; - -Then you have to open an Internet connection with this command: - - $Connection = new Win32::Internet(); - -This is required to use any of the function of this module. It will -create an Internet object in Perl on which you can act upon with the -L<"General Internet Functions"> explained later. - -The objects available are: - -=over - -=item * - -Internet connections (the main object, see C<new>) - -=item * - -URLs (see C<OpenURL>) - -=item * - -FTP sessions (see C<FTP>) - -=item * - -HTTP sessions (see C<HTTP>) - -=item * - -HTTP requests (see C<OpenRequest>) - -=back - -As in the good Perl tradition, there are in this extension different -ways to do the same thing; there are, in fact, different levels of -implementation of the Win32 Internet Functions. Some routines use -several Win32 API functions to perform a complex task in a single -call; they are simpler to use, but of course less powerful. - -There are then other functions that implement nothing more and nothing -less than the corresponding API function, so you can use all of their -power, but with some additional programming steps. - -To make an example, there is a function called C<FetchURL> that you -can use to fetch the content of any HTTP, FTP or GOPHER URL with this -simple commands: - - $INET = new Win32::Internet(); - $file = $INET->FetchURL("http://www.yahoo.com"); - -You can have the same result (and this is actually what is done by -C<FetchURL>) this way: - - $INET = new Win32::Internet(); - $URL = $INET->OpenURL("http://www.yahoo.com"); - $file = $URL->ReadFile(); - $URL->Close(); - -Or, you can open a complete HTTP session: - - $INET = new Win32::Internet(); - $HTTP = $INET->HTTP("www.yahoo.com", "anonymous", "dada@divinf.it"); - ($statuscode, $headers, $file) = $HTTP->Request("/"); - $HTTP->Close(); - -Finally, you can choose to manage even the HTTP request: - - $INET = new Win32::Internet(); - $HTTP = $INET->HTTP("www.yahoo.com", "anonymous", "dada@divinf.it"); - $HTTP->OpenRequest($REQ, "/"); - $REQ->AddHeader("If-Modified-Since: Saturday, 16-Nov-96 15:58:50 GMT"); - $REQ->SendRequest(); - $statuscode = $REQ->QueryInfo("",HTTP_QUERY_STATUS_CODE); - $lastmodified = $REQ->QueryInfo("Last-Modified"); - $file = $REQ->ReadEntireFile(); - $REQ->Close(); - $HTTP->Close(); - -To open and control a complete FTP session, type: - - $Connection->FTP($Session, "ftp://ftp.activeware.com", "anonymous", "dada\@divinf.it"); - -This will create an FTP object in Perl to which you can apply the L<"FTP -functions"> provided by the package: - - $Session->Cd("/ntperl/perl5.001m/CurrentBuild"); - $Session->Ascii(); - $Session->Get("110-i86.zip"); - $Session->Close(); - -For a more complete example, see the TEST.PL file that comes with the -package. - -=head2 General Internet Functions - -B<General Note> - -All methods assume that you have the line: - - use Win32::Internet; - -somewhere before the method calls, and that you have an Internet -object called $INET which was created using this call: - - $INET = new Win32::Internet(); - -See C<new> for more information. - -B<Methods> - -=over - -=item CanonicalizeURL URL, [flags] - -Converts a URL to a canonical format, which includes converting unsafe -characters to escape sequences. Returns the canonicalized URL or -C<undef> on errors. For the possible values of I<flags>, refer to the -L<"Microsoft Win32 Internet Functions"> document. See also -C<CombineURL> and C<OpenURL>. - -Example: - - $cURL = $INET->CanonicalizeURL($URL); - $URL = $INET->CanonicalizeURL($cURL, ICU_DECODE); - -=item Close - -=item Close object - -Closes an Internet connection. This can be applied to any -Win32::Internet object (Internet connections, URLs, FTP sessions, -etc.). Note that it is not "strictly" required to close the -connections you create, since the Win32::Internet objects are -automatically closed when the program ends (or when you elsehow -destroy such an object). - -Example: - - $INET->Close(); - $FTP->Close(); - $INET->Close($FTP); # same as above... - -=item CombineURL baseURL, relativeURL, [flags] - -Combines a base and relative URL into a single URL. Returns the -(canonicalized) combined URL or C<undef> on errors. For the possible -values of I<flags>, refer to the L<"Microsoft Win32 Internet -Functions"> document. See also C<CombineURL> and C<OpenURL>. - -Example: - - $URL = $INET->CombineURL("http://www.divinf.it/dada/perl/internet", ".."); - -=item ConnectBackoff [value] - -Reads or sets the delay value, in milliseconds, to wait between -connection retries. If no I<value> parameter is specified, the -current value is returned; otherwise, the delay between retries is set -to I<value>. See also C<ConnectTimeout>, C<ConnectRetries>, -C<QueryOption> and C<SetOption>. - -Example: - - $HTTP->ConnectBackoff(2000); - $backoff = $HTTP->ConnectBackoff(); - -=item ConnectRetries [value] - -Reads or sets the number of times a connection is retried before -considering it failed. If no I<value> parameter is specified, the -current value is returned; otherwise, the number of retries is set to -I<value>. The default value for C<ConnectRetries> is 5. See also -C<ConnectBackoff>, C<ConnectTimeout>, C<QueryOption> and C<SetOption>. - -Example: - - $HTTP->ConnectRetries(20); - $retries = $HTTP->ConnectRetries(); - -=item ConnectTimeout [value] - -Reads or sets the timeout value (in milliseconds) before a connection -is considered failed. If no I<value> parameter is specified, the -current value is returned; otherwise, the timeout is set to I<value>. -The default value for C<ConnectTimeout> is infinite. See also -C<ConnectBackoff>, C<ConnectRetries>, C<QueryOption> and C<SetOption>. - -Example: - - $HTTP->ConnectTimeout(10000); - $timeout = $HTTP->ConnectTimeout(); - -=item ControlReceiveTimeout [value] - -Reads or sets the timeout value (in milliseconds) to use for non-data -(control) receive requests before they are canceled. Currently, this -value has meaning only for C<FTP> sessions. If no I<value> parameter -is specified, the current value is returned; otherwise, the timeout is -set to I<value>. The default value for C<ControlReceiveTimeout> is -infinite. See also C<ControlSendTimeout>, C<QueryOption> and -C<SetOption>. - -Example: - - $HTTP->ControlReceiveTimeout(10000); - $timeout = $HTTP->ControlReceiveTimeout(); - -=item ControlSendTimeout [value] - -Reads or sets the timeout value (in milliseconds) to use for non-data -(control) send requests before they are canceled. Currently, this -value has meaning only for C<FTP> sessions. If no I<value> parameter -is specified, the current value is returned; otherwise, the timeout is -set to I<value>. The default value for C<ControlSendTimeout> is -infinite. See also C<ControlReceiveTimeout>, C<QueryOption> and -C<SetOption>. - -Example: - - $HTTP->ControlSendTimeout(10000); - $timeout = $HTTP->ControlSendTimeout(); - -=item CrackURL URL, [flags] - -Splits an URL into its component parts and returns them in an array. -Returns C<undef> on errors, otherwise the array will contain the -following values: I<scheme, host, port, username, password, path, -extrainfo>. - -For example, the URL "http://www.divinf.it/index.html#top" can be -splitted in: - - http, www.divinf.it, 80, anonymous, dada@divinf.it, /index.html, #top - -If you don't specify a I<flags> parameter, ICU_ESCAPE will be used by -default; for the possible values of I<flags> refer to the L<"Microsoft -Win32 Internet Functions"> documentation. See also C<CreateURL>. - -Example: - - @parts=$INET->CrackURL("http://www.activeware.com"); - ($scheme, $host, $port, $user, $pass, $path, $extra) = - $INET->CrackURL("http://www.divinf.it:80/perl-win32/index.sht#feedback"); - -=item CreateURL scheme, hostname, port, username, password, path, extrainfo, [flags] - -=item CreateURL hashref, [flags] - -Creates a URL from its component parts. Returns C<undef> on errors, -otherwise the created URL. - -If you pass I<hashref> (a reference to an hash array), the following -values are taken from the array: - - %hash=( - "scheme" => "scheme", - "hostname" => "hostname", - "port" => port, - "username" => "username", - "password" => "password", - "path" => "path", - "extrainfo" => "extrainfo", - ); - -If you don't specify a I<flags> parameter, ICU_ESCAPE will be used by -default; for the other possible values of I<flags> refer to the -L<"Microsoft Win32 Internet Functions"> documentation. See also -C<CrackURL>. - -Example: - - $URL=$I->CreateURL("http", "www.divinf.it", 80, "", "", "/perl-win32/index.sht", "#feedback"); - $URL=$I->CreateURL(\%params); - -=item DataReceiveTimeout [value] - -Reads or sets the timeout value (in milliseconds) to use for data -receive requests before they are canceled. If no I<value> parameter -is specified, the current value is returned; otherwise, the timeout is -set to I<value>. The default value for DataReceiveTimeout is -infinite. See also C<DataSendTimeout>, C<QueryOption> and -C<SetOption>. - -Example: - - $HTTP->DataReceiveTimeout(10000); - $timeout = $HTTP->DataReceiveTimeout(); - -=item DataSendTimeout [value] - -Reads or sets the timeout value (in milliseconds) to use for data send -requests before they are canceled. If no I<value> parameter is -specified, the current value is returned; otherwise, the timeout is -set to I<value>. The default value for DataSendTimeout is infinite. -See also C<DataReceiveTimeout>, C<QueryOption> and C<SetOption>. - -Example: - - $HTTP->DataSendTimeout(10000); - $timeout = $HTTP->DataSendTimeout(); - -=item Error - -Returns the last recorded error in the form of an array or string -(depending upon the context) containing the error number and an error -description. Can be applied on any Win32::Internet object (FTP -sessions, etc.). There are 3 types of error you can encounter; they -are recognizable by the error number returned: - -=over - -=item * -1 - -A "trivial" error has occurred in the package. For example, you tried -to use a method on the wrong type of object. - -=item * 1 .. 11999 - -A generic error has occurred and the Win32::GetLastError error message -is returned. - -=item * 12000 and higher - -An Internet error has occurred; the extended Win32 Internet API error -message is returned. - -=back - -See also C<GetResponse>. - -Example: - - die $INET->Error(), qq(\n); - ($ErrNum, $ErrText) = $INET->Error(); - -=item FetchURL URL - -Fetch the content of an HTTP, FTP or GOPHER URL. Returns the content -of the file read (or C<undef> if there was an error and nothing was -read). See also C<OpenURL> and C<ReadFile>. - -Example: - - $file = $INET->FetchURL("http://www.yahoo.com/"); - $file = $INET->FetchURL("ftp://www.activeware.com/contrib/internet.zip"); - -=item FTP ftpobject, server, username, password, [port, pasv, context] - -=item FTP ftpobject, hashref - -Opens an FTP connection to server logging in with the given -I<username> and I<password>. - -The parameters and their values are: - -=over - -=item * server - -The server to connect to. Default: I<none>. - -=item * username - -The username used to login to the server. Default: anonymous. - -=item * password - -The password used to login to the server. Default: I<none>. - -=item * port - -The port of the FTP service on the server. Default: 21. - -=item * pasv - -If it is a value other than 0, use passive transfer mode. Default is -taken from the parent Internet connection object; you can set this -value with the C<Pasv> method. - -=item * context - -A number to identify this operation if it is asynchronous. See -C<SetStatusCallback> and C<GetStatusCallback> for more info on -asynchronous operations. Default: I<none>. - -=back - -If you pass I<hashref> (a reference to an hash array), the following -values are taken from the array: - - %hash=( - "server" => "server", - "username" => "username", - "password" => "password", - "port" => port, - "pasv" => pasv, - "context" => context, - ); - -This method returns C<undef> if the connection failed, a number -otherwise. You can then call any of the L<"FTP functions"> as methods -of the newly created I<ftpobject>. - -Example: - - $result = $INET->FTP($FTP, "ftp.activeware.com", "anonymous", "dada\@divinf.it"); - # and then for example... - $FTP->Cd("/ntperl/perl5.001m/CurrentBuild"); - - $params{"server"} = "ftp.activeware.com"; - $params{"password"} = "dada\@divinf.it"; - $params{"pasv"} = 0; - $result = $INET->FTP($FTP,\%params); - -=item GetResponse - -Returns the text sent by a remote server in response to the last -function executed. It applies on any Win32::Internet object, -particularly of course on L<FTP sessions|"FTP functions">. See also -the C<Error> function. - -Example: - - print $INET->GetResponse(); - $INET->FTP($FTP, "ftp.activeware.com", "anonymous", "dada\@divinf.it"); - print $FTP->GetResponse(); - -=item GetStatusCallback context - -Returns information about the progress of the asynchronous operation -identified by I<context>; those informations consist of two values: a -status code (one of the INTERNET_STATUS_* L<"Constants">) and an -additional value depending on the status code; for example, if the -status code returned is INTERNET_STATUS_HANDLE_CREATED, the second -value will hold the handle just created. For more informations on -those values, please refer to the L<"Microsoft Win32 Internet -Functions"> documentation. See also C<SetStatusCallback>. - -Example: - - ($status, $info) = $INET->GetStatusCallback(1); - -=item HTTP httpobject, server, username, password, [port, flags, context] - -=item HTTP httpobject, hashref - -Opens an HTTP connection to I<server> logging in with the given -I<username> and I<password>. - -The parameters and their values are: - -=over - -=item * server - -The server to connect to. Default: I<none>. - -=item * username - -The username used to login to the server. Default: anonymous. - -=item * password - -The password used to login to the server. Default: I<none>. - -=item * port - -The port of the HTTP service on the server. Default: 80. - -=item * flags - -Additional flags affecting the behavior of the function. Default: -I<none>. - -=item * context - -A number to identify this operation if it is asynchronous. See -C<SetStatusCallback> and C<GetStatusCallback> for more info on -asynchronous operations. Default: I<none>. - -=back - -Refer to the L<"Microsoft Win32 Internet Functions"> documentation for -more details on those parameters. - -If you pass I<hashref> (a reference to an hash array), the following -values are taken from the array: - - %hash=( - "server" => "server", - "username" => "username", - "password" => "password", - "port" => port, - "flags" => flags, - "context" => context, - ); - -This method returns C<undef> if the connection failed, a number -otherwise. You can then call any of the L<"HTTP functions"> as -methods of the newly created I<httpobject>. - -Example: - - $result = $INET->HTTP($HTTP,"www.activeware.com","anonymous","dada\@divinf.it"); - # and then for example... - ($statuscode, $headers, $file) = $HTTP->Request("/gifs/camel.gif"); - - $params{"server"} = "www.activeware.com"; - $params{"password"} = "dada\@divinf.it"; - $params{"flags"} = INTERNET_FLAG_RELOAD; - $result = $INET->HTTP($HTTP,\%params); - -=item new Win32::Internet [useragent, opentype, proxy, proxybypass, flags] - -=item new Win32::Internet [hashref] - -Creates a new Internet object and initializes the use of the Internet -functions; this is required before any of the functions of this -package can be used. Returns C<undef> if the connection fails, a number -otherwise. The parameters and their values are: - -=over - -=item * useragent - -The user agent passed to HTTP requests. See C<OpenRequest>. Default: -Perl-Win32::Internet/I<version>. - -=item * opentype - -How to access to the Internet (eg. directly or using a proxy). -Default: INTERNET_OPEN_TYPE_DIRECT. - -=item * proxy - -Name of the proxy server (or servers) to use. Default: I<none>. - -=item * proxybypass - -Optional list of host names or IP addresses, or both, that are known -locally. Default: I<none>. - -=item * flags - -Additional flags affecting the behavior of the function. Default: -I<none>. - -=back - -Refer to the L<"Microsoft Win32 Internet Functions"> documentation for -more details on those parameters. If you pass I<hashref> (a reference to -an hash array), the following values are taken from the array: - - %hash=( - "useragent" => "useragent", - "opentype" => "opentype", - "proxy" => "proxy", - "proxybypass" => "proxybypass", - "flags" => flags, - ); - -Example: - - $INET = new Win32::Internet(); - die qq(Cannot connect to Internet...\n) if ! $INET; - - $INET = new Win32::Internet("Mozilla/3.0", INTERNET_OPEN_TYPE_PROXY, "www.microsoft.com", ""); - - $params{"flags"} = INTERNET_FLAG_ASYNC; - $INET = new Win32::Internet(\%params); - -=item OpenURL urlobject, URL - -Opens a connection to an HTTP, FTP or GOPHER Uniform Resource Location -(URL). Returns C<undef> on errors or a number if the connection was -succesful. You can then retrieve the URL content by applying the -methods C<QueryDataAvailable> and C<ReadFile> on the newly created -I<urlobject>. See also C<FetchURL>. - -Example: - - $INET->OpenURL($URL, "http://www.yahoo.com/"); - $bytes = $URL->QueryDataAvailable(); - $file = $URL->ReadEntireFile(); - $URL->Close(); - -=item Password [password] - -Reads or sets the password used for an C<FTP> or C<HTTP> connection. -If no I<password> parameter is specified, the current value is -returned; otherwise, the password is set to I<password>. See also -C<Username>, C<QueryOption> and C<SetOption>. - -Example: - - $HTTP->Password("splurfgnagbxam"); - $password = $HTTP->Password(); - -=item QueryDataAvailable - -Returns the number of bytes of data that are available to be read -immediately by a subsequent call to C<ReadFile> (or C<undef> on -errors). Can be applied to URL or HTTP request objects. See -C<OpenURL> or C<OpenRequest>. - -Example: - - $INET->OpenURL($URL, "http://www.yahoo.com/"); - $bytes = $URL->QueryDataAvailable(); - -=item QueryOption option - -Queries an Internet option. For the possible values of I<option>, -refer to the L<"Microsoft Win32 Internet Functions"> document. See -also C<SetOption>. - -Example: - - $value = $INET->QueryOption(INTERNET_OPTION_CONNECT_TIMEOUT); - $value = $HTTP->QueryOption(INTERNET_OPTION_USERNAME); - -=item ReadEntireFile - -Reads all the data available from an opened URL or HTTP request -object. Returns what have been read or C<undef> on errors. See also -C<OpenURL>, C<OpenRequest> and C<ReadFile>. - -Example: - - $INET->OpenURL($URL, "http://www.yahoo.com/"); - $file = $URL->ReadEntireFile(); - -=item ReadFile bytes - -Reads I<bytes> bytes of data from an opened URL or HTTP request -object. Returns what have been read or C<undef> on errors. See also -C<OpenURL>, C<OpenRequest>, C<QueryDataAvailable> and -C<ReadEntireFile>. - -B<Note:> be careful to keep I<bytes> to an acceptable value (eg. don't -tell him to swallow megabytes at once...). C<ReadEntireFile> in fact -uses C<QueryDataAvailable> and C<ReadFile> in a loop to read no more -than 16k at a time. - -Example: - - $INET->OpenURL($URL, "http://www.yahoo.com/"); - $chunk = $URL->ReadFile(16000); - -=item SetOption option, value - -Sets an Internet option. For the possible values of I<option>, refer to -the L<"Microsoft Win32 Internet Functions"> document. See also -C<QueryOption>. - -Example: - - $INET->SetOption(INTERNET_OPTION_CONNECT_TIMEOUT,10000); - $HTTP->SetOption(INTERNET_OPTION_USERNAME,"dada"); - -=item SetStatusCallback - -Initializes the callback routine used to return data about the -progress of an asynchronous operation. - -Example: - - $INET->SetStatusCallback(); - -This is one of the step required to perform asynchronous operations; -the complete procedure is: - - # use the INTERNET_FLAG_ASYNC when initializing - $params{'flags'}=INTERNET_FLAG_ASYNC; - $INET = new Win32::Internet(\%params); - - # initialize the callback routine - $INET->SetStatusCallback(); - - # specify the context parameter (the last 1 in this case) - $INET->HTTP($HTTP, "www.yahoo.com", "anonymous", "dada\@divinf.it", 80, 0, 1); - -At this point, control returns immediately to Perl and $INET->Error() -will return 997, which means an asynchronous I/O operation is -pending. Now, you can call - - $HTTP->GetStatusCallback(1); - -in a loop to verify what's happening; see also C<GetStatusCallback>. - -=item TimeConvert time - -=item TimeConvert seconds, minute, hours, day, month, year, - day_of_week, RFC - -The first form takes a HTTP date/time string and returns the date/time -converted in the following array: I<seconds, minute, hours, day, -month, year, day_of_week>. - -The second form does the opposite (or at least it should, because -actually seems to be malfunctioning): it takes the values and returns -an HTTP date/time string, in the RFC format specified by the I<RFC> -parameter (OK, I didn't find yet any accepted value in the range -0..2000, let me know if you have more luck with it). - -Example: - - ($sec, $min, $hour, $day, $mday, $year, $wday) = - $INET->TimeConvert("Sun, 26 Jan 1997 20:01:52 GMT"); - - # the opposite DOESN'T WORK! which value should $RFC have??? - $time = $INET->TimeConvert(52, 1, 20, 26, 1, 1997, 0, $RFC); - -=item UserAgent [name] - -Reads or sets the user agent used for HTTP requests. If no I<name> -parameter is specified, the current value is returned; otherwise, the -user agent is set to I<name>. See also C<QueryOption> and -C<SetOption>. - -Example: - - $INET->UserAgent("Mozilla/3.0"); - $useragent = $INET->UserAgent(); - -=item Username [name] - -Reads or sets the username used for an C<FTP> or C<HTTP> connection. -If no I<name> parameter is specified, the current value is returned; -otherwise, the username is set to I<name>. See also C<Password>, -C<QueryOption> and SetOption. - -Example: - - $HTTP->Username("dada"); - $username = $HTTP->Username(); - -=item Version - -Returns the version numbers for the Win32::Internet package and the -WININET.DLL version, as an array or string, depending on the context. -The string returned will contain "package_version/DLL_version", while -the array will contain: "package_version", "DLL_version". - -Example: - - $version = $INET->Version(); # should return "0.06/4.70.1215" - @version = $INET->Version(); # should return ("0.06", "4.70.1215") - -=back - - -=head2 FTP Functions - -B<General Note> - -All methods assume that you have the following lines: - - use Win32::Internet; - $INET = new Win32::Internet(); - $INET->FTP($FTP, "hostname", "username", "password"); - -somewhere before the method calls; in other words, we assume that you -have an Internet object called $INET and an open FTP session called -$FTP. - -See C<new> and C<FTP> for more information. - - -B<Methods> - -=over - -=item Ascii - -=item Asc - -Sets the ASCII transfer mode for this FTP session. It will be applied -to the subsequent C<Get> functions. See also the C<Binary> and -C<Mode> function. - -Example: - - $FTP->Ascii(); - -=item Binary - -=item Bin - -Sets the binary transfer mode for this FTP session. It will be -applied to the subsequent C<Get> functions. See also the C<Ascii> and -C<Mode> function. - -Example: - - $FTP->Binary(); - -=item Cd path - -=item Cwd path - -=item Chdir path - -Changes the current directory on the FTP remote host. Returns I<path> -or C<undef> on error. - -Example: - - $FTP->Cd("/pub"); - -=item Delete file - -=item Del file - -Deletes a file on the FTP remote host. Returns C<undef> on error. - -Example: - - $FTP->Delete("110-i86.zip"); - -=item Get remote, [local, overwrite, flags, context] - -Gets the I<remote> FTP file and saves it locally in I<local>. If -I<local> is not specified, it will be the same name as I<remote>. -Returns C<undef> on error. The parameters and their values are: - -=over - -=item * remote - -The name of the remote file on the FTP server. Default: I<none>. - -=item * local - -The name of the local file to create. Default: remote. - -=item * overwrite - -If 0, overwrites I<local> if it exists; with any other value, the -function fails if the I<local> file already exists. Default: 0. - -=item * flags - -Additional flags affecting the behavior of the function. Default: -I<none>. - -=item * context - -A number to identify this operation if it is asynchronous. See -C<SetStatusCallback> and C<GetStatusCallback> for more info on -asynchronous operations. Default: I<none>. - -=back - -Refer to the L<"Microsoft Win32 Internet Functions"> documentation for -more details on those parameters. - -Example: - - $FTP->Get("110-i86.zip"); - $FTP->Get("/pub/perl/languages/CPAN/00index.html", "CPAN_index.html"); - -=item List [pattern, listmode] - -=item Ls [pattern, listmode] - -=item Dir [pattern, listmode] - -Returns a list containing the files found in this directory, -eventually matching the given I<pattern> (which, if omitted, is -considered "*.*"). The content of the returned list depends on the -I<listmode> parameter, which can have the following values: - -=over - -=item * listmode=1 (or omitted) - -the list contains the names of the files found. Example: - - @files = $FTP->List(); - @textfiles = $FTP->List("*.txt"); - foreach $file (@textfiles) { - print "Name: ", $file, "\n"; - } - -=item * listmode=2 - -the list contains 7 values for each file, which respectively are: - -=over - -=item * the file name - -=item * the DOS short file name, aka 8.3 - -=item * the size - -=item * the attributes - -=item * the creation time - -=item * the last access time - -=item * the last modified time - -=back - -Example: - - @files = $FTP->List("*.*", 2); - for($i=0; $i<=$#files; $i+=7) { - print "Name: ", @files[$i], "\n"; - print "Size: ", @files[$i+2], "\n"; - print "Attr: ", @files[$i+3], "\n"; - } - -=item * listmode=3 - -the list contains a reference to an hash array for each found file; -each hash contains: - -=over - -=item * name => the file name - -=item * altname => the DOS short file name, aka 8.3 - -=item * size => the size - -=item * attr => the attributes - -=item * ctime => the creation time - -=item * atime => the last access time - -=item * mtime => the last modified time - -=back - -Example: - - @files = $FTP->List("*.*", 3); - foreach $file (@files) { - print $file->{'name'}, " ", $file->{'size'}, " ", $file->{'attr'}, "\n"; - } - -B<Note:> all times are reported as strings of the following format: -I<second, hour, minute, day, month, year>. - -Example: - - $file->{'mtime'} == "0,10,58,9,12,1996" stands for 09 Dec 1996 at 10:58:00 - -=back - -=item Mkdir name - -=item Md name - -Creates a directory on the FTP remote host. Returns C<undef> on error. - -Example: - - $FTP->Mkdir("NextBuild"); - -=item Mode [mode] - -If called with no arguments, returns the current transfer mode for -this FTP session ("asc" for ASCII or "bin" for binary). The I<mode> -argument can be "asc" or "bin", in which case the appropriate transfer -mode is selected. See also the Ascii and Binary functions. Returns -C<undef> on errors. - -Example: - - print "Current mode is: ", $FTP->Mode(); - $FTP->Mode("asc"); # ... same as $FTP->Ascii(); - -=item Pasv [mode] - -If called with no arguments, returns 1 if the current FTP session has -passive transfer mode enabled, 0 if not. - -You can call it with a I<mode> parameter (0/1) only as a method of a -Internet object (see C<new>), in which case it will set the default -value for the next C<FTP> objects you create (read: set it before, -because you can't change this value once you opened the FTP session). - -Example: - - print "Pasv is: ", $FTP->Pasv(); - - $INET->Pasv(1); - $INET->FTP($FTP,"ftp.activeware.com", "anonymous", "dada\@divinf.it"); - $FTP->Pasv(0); # this will be ignored... - -=item Put local, [remote, context] - -Upload the I<local> file to the FTP server saving it under the name -I<remote>, which if if omitted is the same name as I<local>. Returns -C<undef> on error. - -I<context> is a number to identify this operation if it is asynchronous. -See C<SetStatusCallback> and C<GetStatusCallback> for more info on -asynchronous operations. - -Example: - - $FTP->Put("internet.zip"); - $FTP->Put("d:/users/dada/temp.zip", "/temp/dada.zip"); - -=item Pwd - -Returns the current directory on the FTP server or C<undef> on errors. - -Example: - - $path = $FTP->Pwd(); - -=item Rename oldfile, newfile - -=item Ren oldfile, newfile - -Renames a file on the FTP remote host. Returns C<undef> on error. - -Example: - - $FTP->Rename("110-i86.zip", "68i-011.zip"); - -=item Rmdir name - -=item Rd name - -Removes a directory on the FTP remote host. Returns C<undef> on error. - -Example: - - $FTP->Rmdir("CurrentBuild"); - -=back - -=head2 HTTP Functions - -B<General Note> - -All methods assume that you have the following lines: - - use Win32::Internet; - $INET = new Win32::Internet(); - $INET->HTTP($HTTP, "hostname", "username", "password"); - -somewhere before the method calls; in other words, we assume that you -have an Internet object called $INET and an open HTTP session called -$HTTP. - -See C<new> and C<HTTP> for more information. - - -B<Methods> - -=over - -=item AddHeader header, [flags] - -Adds HTTP request headers to an HTTP request object created with -C<OpenRequest>. For the possible values of I<flags> refer to the -L<"Microsoft Win32 Internet Functions"> document. - -Example: - - $HTTP->OpenRequest($REQUEST,"/index.html"); - $REQUEST->AddHeader("If-Modified-Since: Sunday, 17-Nov-96 11:40:03 GMT"); - $REQUEST->AddHeader("Accept: text/html\r\n", HTTP_ADDREQ_FLAG_REPLACE); - -=item OpenRequest requestobject, [path, method, version, referer, accept, flags, context] - -=item OpenRequest requestobject, hashref - -Opens an HTTP request. Returns C<undef> on errors or a number if the -connection was succesful. You can then use one of the C<AddHeader>, -C<SendRequest>, C<QueryInfo>, C<QueryDataAvailable> and C<ReadFile> -methods on the newly created I<requestobject>. The parameters and -their values are: - -=over - -=item * path - -The object to request. This is generally a file name, an executable -module, etc. Default: / - -=item * method - -The method to use; can actually be GET, POST, HEAD or PUT. Default: -GET - -=item * version - -The HTTP version. Default: HTTP/1.0 - -=item * referer - -The URL of the document from which the URL in the request was -obtained. Default: I<none> - -=item * accept - -A single string with "\0" (ASCII zero) delimited list of content -types accepted. The string must be terminated by "\0\0". -Default: "text/*\0image/gif\0image/jpeg\0\0" - -=item * flags - -Additional flags affecting the behavior of the function. Default: -I<none> - -=item * context - -A number to identify this operation if it is asynchronous. See -C<SetStatusCallback> and C<GetStatusCallback> for more info on -asynchronous operations. Default: I<none> - -=back - -Refer to the L<"Microsoft Win32 Internet Functions"> documentation for -more details on those parameters. If you pass I<hashref> (a reference to -an hash array), the following values are taken from the array: - - %hash=( - "path" => "path", - "method" => "method", - "version" => "version", - "referer" => "referer", - "accept" => "accept", - "flags" => flags, - "context" => context, - ); - -See also C<Request>. - -Example: - - $HTTP->OpenRequest($REQUEST, "/index.html"); - $HTTP->OpenRequest($REQUEST, "/index.html", "GET", "HTTP/0.9"); - - $params{"path"} = "/index.html"; - $params{"flags"} = " - $HTTP->OpenRequest($REQUEST, \%params); - -=item QueryInfo header, [flags] - -Queries information about an HTTP request object created with -C<OpenRequest>. You can specify an I<header> (for example, -"Content-type") and/or one or more I<flags>. If you don't specify -I<flags>, HTTP_QUERY_CUSTOM will be used by default; this means that -I<header> should contain a valid HTTP header name. For the possible -values of I<flags> refer to the L<"Microsoft Win32 Internet -Functions"> document. - -Example: - - $HTTP->OpenRequest($REQUEST,"/index.html"); - $statuscode = $REQUEST->QueryInfo("", HTTP_QUERY_STATUS_CODE); - $headers = $REQUEST->QueryInfo("", HTTP_QUERY_RAW_HEADERS_CRLF); # will get all the headers - $length = $REQUEST->QueryInfo("Content-length"); - -=item Request [path, method, version, referer, accept, flags] - -=item Request hashref - -Performs an HTTP request and returns an array containing the status -code, the headers and the content of the file. It is a one-step -procedure that makes an C<OpenRequest>, a C<SendRequest>, some -C<QueryInfo>, C<ReadFile> and finally C<Close>. For a description of -the parameters, see C<OpenRequest>. - -Example: - - ($statuscode, $headers, $file) = $HTTP->Request("/index.html"); - ($s, $h, $f) = $HTTP->Request("/index.html", "GET", "HTTP/1.0"); - -=item SendRequest [postdata] - -Send an HTTP request to the destination server. I<postdata> are any -optional data to send immediately after the request header; this is -generally used for POST or PUT requests. See also C<OpenRequest>. - -Example: - - $HTTP->OpenRequest($REQUEST, "/index.html"); - $REQUEST->SendRequest(); - - # A POST request... - $HTTP->OpenRequest($REQUEST, "/cgi-bin/somescript.pl", "POST"); - - #This line is a must -> (thanks Philip :) - $REQUEST->AddHeader("Content-Type: application/x-www-form-urlencoded"); - - $REQUEST->SendRequest("key1=value1&key2=value2&key3=value3"); - -=back - - -=head1 APPENDIX - - -=head2 Microsoft Win32 Internet Functions - -Complete documentation for the Microsoft Win32 Internet Functions can -be found, in both HTML and zipped Word format, at this address: - - http://www.microsoft.com/intdev/sdk/docs/wininet/ - -=head2 Functions Table - -This table reports the correspondence between the functions offered by -WININET.DLL and their implementation in the Win32::Internet -extension. Functions showing a "---" are not currently -implemented. Functions enclosed in parens ( ) aren't implemented -straightforwardly, but in a higher-level routine, eg. together with -other functions. - - WININET.DLL Win32::Internet - - InternetOpen new Win32::Internet - InternetConnect FTP / HTTP - InternetCloseHandle Close - InternetQueryOption QueryOption - InternetSetOption SetOption - InternetSetOptionEx --- - InternetSetStatusCallback SetStatusCallback - InternetStatusCallback GetStatusCallback - InternetConfirmZoneCrossing --- - InternetTimeFromSystemTime TimeConvert - InternetTimeToSystemTime TimeConvert - InternetAttemptConnect --- - InternetReadFile ReadFile - InternetSetFilePointer --- - InternetFindNextFile (List) - InternetQueryDataAvailable QueryDataAvailable - InternetGetLastResponseInfo GetResponse - InternetWriteFile --- - InternetCrackUrl CrackURL - InternetCreateUrl CreateURL - InternetCanonicalizeUrl CanonicalizeURL - InternetCombineUrl CombineURL - InternetOpenUrl OpenURL - FtpFindFirstFile (List) - FtpGetFile Get - FtpPutFile Put - FtpDeleteFile Delete - FtpRenameFile Rename - FtpOpenFile --- - FtpCreateDirectory Mkdir - FtpRemoveDirectory Rmdir - FtpSetCurrentDirectory Cd - FtpGetCurrentDirectory Pwd - HttpOpenRequest OpenRequest - HttpAddRequestHeaders AddHeader - HttpSendRequest SendRequest - HttpQueryInfo QueryInfo - InternetErrorDlg --- - - -Actually, I don't plan to add support for Gopher, Cookie and Cache -functions. I will if there will be consistent requests to do so. - -There are a number of higher-level functions in the Win32::Internet -that simplify some usual procedures, calling more that one WININET API -function. This table reports those functions and the relative WININET -functions they use. - - Win32::Internet WININET.DLL - - FetchURL InternetOpenUrl - InternetQueryDataAvailable - InternetReadFile - InternetCloseHandle - - ReadEntireFile InternetQueryDataAvailable - InternetReadFile - - Request HttpOpenRequest - HttpSendRequest - HttpQueryInfo - InternetQueryDataAvailable - InternetReadFile - InternetCloseHandle - - List FtpFindFirstFile - InternetFindNextFile - - -=head2 Constants - -Those are the constants exported by the package in the main namespace -(eg. you can use them in your scripts); for their meaning and proper -use, refer to the Microsoft Win32 Internet Functions document. - - HTTP_ADDREQ_FLAG_ADD - HTTP_ADDREQ_FLAG_REPLACE - HTTP_QUERY_ALLOW - HTTP_QUERY_CONTENT_DESCRIPTION - HTTP_QUERY_CONTENT_ID - HTTP_QUERY_CONTENT_LENGTH - HTTP_QUERY_CONTENT_TRANSFER_ENCODING - HTTP_QUERY_CONTENT_TYPE - HTTP_QUERY_COST - HTTP_QUERY_CUSTOM - HTTP_QUERY_DATE - HTTP_QUERY_DERIVED_FROM - HTTP_QUERY_EXPIRES - HTTP_QUERY_FLAG_REQUEST_HEADERS - HTTP_QUERY_FLAG_SYSTEMTIME - HTTP_QUERY_LANGUAGE - HTTP_QUERY_LAST_MODIFIED - HTTP_QUERY_MESSAGE_ID - HTTP_QUERY_MIME_VERSION - HTTP_QUERY_PRAGMA - HTTP_QUERY_PUBLIC - HTTP_QUERY_RAW_HEADERS - HTTP_QUERY_RAW_HEADERS_CRLF - HTTP_QUERY_REQUEST_METHOD - HTTP_QUERY_SERVER - HTTP_QUERY_STATUS_CODE - HTTP_QUERY_STATUS_TEXT - HTTP_QUERY_URI - HTTP_QUERY_USER_AGENT - HTTP_QUERY_VERSION - HTTP_QUERY_WWW_LINK - ICU_BROWSER_MODE - ICU_DECODE - ICU_ENCODE_SPACES_ONLY - ICU_ESCAPE - ICU_NO_ENCODE - ICU_NO_META - ICU_USERNAME - INTERNET_FLAG_PASSIVE - INTERNET_FLAG_ASYNC - INTERNET_FLAG_HYPERLINK - INTERNET_FLAG_KEEP_CONNECTION - INTERNET_FLAG_MAKE_PERSISTENT - INTERNET_FLAG_NO_AUTH - INTERNET_FLAG_NO_AUTO_REDIRECT - INTERNET_FLAG_NO_CACHE_WRITE - INTERNET_FLAG_NO_COOKIES - INTERNET_FLAG_READ_PREFETCH - INTERNET_FLAG_RELOAD - INTERNET_FLAG_RESYNCHRONIZE - INTERNET_FLAG_TRANSFER_ASCII - INTERNET_FLAG_TRANSFER_BINARY - INTERNET_INVALID_PORT_NUMBER - INTERNET_INVALID_STATUS_CALLBACK - INTERNET_OPEN_TYPE_DIRECT - INTERNET_OPEN_TYPE_PROXY - INTERNET_OPEN_TYPE_PROXY_PRECONFIG - INTERNET_OPTION_CONNECT_BACKOFF - INTERNET_OPTION_CONNECT_RETRIES - INTERNET_OPTION_CONNECT_TIMEOUT - INTERNET_OPTION_CONTROL_SEND_TIMEOUT - INTERNET_OPTION_CONTROL_RECEIVE_TIMEOUT - INTERNET_OPTION_DATA_SEND_TIMEOUT - INTERNET_OPTION_DATA_RECEIVE_TIMEOUT - INTERNET_OPTION_HANDLE_TYPE - INTERNET_OPTION_LISTEN_TIMEOUT - INTERNET_OPTION_PASSWORD - INTERNET_OPTION_READ_BUFFER_SIZE - INTERNET_OPTION_USER_AGENT - INTERNET_OPTION_USERNAME - INTERNET_OPTION_VERSION - INTERNET_OPTION_WRITE_BUFFER_SIZE - INTERNET_SERVICE_FTP - INTERNET_SERVICE_GOPHER - INTERNET_SERVICE_HTTP - INTERNET_STATUS_CLOSING_CONNECTION - INTERNET_STATUS_CONNECTED_TO_SERVER - INTERNET_STATUS_CONNECTING_TO_SERVER - INTERNET_STATUS_CONNECTION_CLOSED - INTERNET_STATUS_HANDLE_CLOSING - INTERNET_STATUS_HANDLE_CREATED - INTERNET_STATUS_NAME_RESOLVED - INTERNET_STATUS_RECEIVING_RESPONSE - INTERNET_STATUS_REDIRECT - INTERNET_STATUS_REQUEST_COMPLETE - INTERNET_STATUS_REQUEST_SENT - INTERNET_STATUS_RESOLVING_NAME - INTERNET_STATUS_RESPONSE_RECEIVED - INTERNET_STATUS_SENDING_REQUEST - - -=head1 VERSION HISTORY - -=over - -=item * 0.082 (4 Sep 2001) - -=over - -=item * - -Fix passive FTP mode. INTERNET_FLAG_PASSIVE was misspelled in earlier -versions (as INTERNET_CONNECT_FLAG_PASSIVE) and wouldn't work. Found -by Steve Raynesford <stever@evolvecomm.com>. - -=back - -=item * 0.081 (25 Sep 1999) - -=over - -=item * - -Documentation converted to pod format by Jan Dubois <JanD@ActiveState.com>. - -=item * - -Minor changes from Perl 5.005xx compatibility. - -=back - -=item * 0.08 (14 Feb 1997) - -=over - -=item * - -fixed 2 more bugs in Option(s) related subs (thanks to Brian -Helterline!). - -=item * - -Error() now gets error messages directly from WININET.DLL. - -=item * - -The PLL file now comes in 2 versions, one for Perl version 5.001 -(build 100) and one for Perl version 5.003 (build 300 and -higher). Everybody should be happy now :) - -=item * - -added an installation program. - -=back - -=item * 0.07 (10 Feb 1997) - -=over - -=item * - -fixed a bug in Version() introduced with 0.06... - -=item * - -completely reworked PM file, fixed *lots* of minor bugs, and removed -almost all the warnings with "perl -w". - -=back - -=item * 0.06 (26 Jan 1997) - -=over - -=item * - -fixed another hideous bug in "new" (the 'class' parameter was still -missing). - -=item * - -added support for asynchronous operations (work still in embryo). - -=item * - -removed the ending \0 (ASCII zero) from the DLL version returned by -"Version". - -=item * - -added a lot of constants. - -=item * - -added safefree() after every safemalloc() in C... wonder why I didn't -it before :) - -=item * - -added TimeConvert, which actually works one way only. - -=back - -=item * 0.05f (29 Nov 1996) - -=over - -=item * - -fixed a bug in "new" (parameters passed were simply ignored). - -=item * - -fixed another bug: "Chdir" and "Cwd" were aliases of RMDIR instead of -CD.. - -=back - -=item * 0.05 (29 Nov 1996) - -=over - -=item * - -added "CrackURL" and "CreateURL". - -=item * - -corrected an error in TEST.PL (there was a GetUserAgent instead of -UserAgent). - -=back - -=item * 0.04 (25 Nov 1996) - -=over - -=item * - -added "Version" to retrieve package and DLL versions. - -=item * - -added proxies and other options to "new". - -=item * - -changed "OpenRequest" and "Request" to read parameters from a hash. - -=item * - -added "SetOption/QueryOption" and a lot of relative functions -(connect, username, password, useragent, etc.). - -=item * - -added "CanonicalizeURL" and "CombineURL". - -=item * - -"Error" covers a wider spectrum of errors. - -=back - -=item * 0.02 (18 Nov 1996) - -=over - -=item * - -added support for HTTP sessions and requests. - -=back - -=item * 0.01 (11 Nov 1996) - -=over - -=item * - -fetching of HTTP, FTP and GOPHER URLs. - -=item * - -complete set of commands to manage an FTP session. - -=back - -=back - -=head1 AUTHOR - -Version 0.08 (14 Feb 1997) by Aldo Calpini <a.calpini@romagiubileo.it> - - -=head1 CREDITS - -Win32::Internet is based on the Win32::Registry code written by Jesse -Dougherty. - -Additional thanks to: Carl Tichler for his help in the initial -development; Tore Haraldsen, Brian Helterline for the bugfixes; Dave -Roth for his great source code examples. - - -=head1 DISCLAIMER - -This program is FREE; you can redistribute, modify, disassemble, or -even reverse engineer this software at your will. Keep in mind, -however, that NOTHING IS GUARANTEED to work and everything you do is -AT YOUR OWN RISK - I will not take 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. diff --git a/Master/tlpkg/tlperl/lib/Win32/Job.pm b/Master/tlpkg/tlperl/lib/Win32/Job.pm deleted file mode 100644 index 3350f76400d..00000000000 --- a/Master/tlpkg/tlperl/lib/Win32/Job.pm +++ /dev/null @@ -1,370 +0,0 @@ -package Win32::Job; - -use strict; -use base qw(DynaLoader); -use vars qw($VERSION); - -$VERSION = '0.01'; - -use constant WIN32s => 0; -use constant WIN9X => 1; -use constant WINNT => 2; - -require Win32 unless defined &Win32::GetOSVersion; -my @ver = Win32::GetOSVersion; -die "Win32::Job is not supported on $ver[0]" unless ( - $ver[4] == WINNT and ( - $ver[1] > 5 or - ($ver[1] == 5 and $ver[2] > 0) or - ($ver[1] == 5 and $ver[2] == 0 and $ver[3] >= 0) - ) -); - -Win32::Job->bootstrap($VERSION); - -1; - -__END__ - -=head1 NAME - -Win32::Job - Run sub-processes in a "job" environment - -=head1 SYNOPSIS - - use Win32::Job; - - my $job = Win32::Job->new; - - # Run 'perl Makefile.PL' for 10 seconds - $job->spawn($Config{perlpath}, "perl Makefile.PL"); - $job->run(10); - -=head1 PLATFORMS - -Win32::Job requires Windows 2000 or later. Windows 95, 98, NT, and Me are not -supported. - -=head1 DESCRIPTION - -Windows 2000 introduced the concept of a "job": a collection of processes -which can be controlled as a single unit. For example, you can reliably kill a -process and all of its children by launching the process in a job, then -telling Windows to kill all processes in the job. Win32::Job makes this -feature available to Perl. - -For example, imagine you want to allow 2 minutes for a process to complete. -If you have control over the child process, you can probably just run it in -the background, then poll every second to see if it has finished. - -That's fine as long as the child process doesn't spawn any child processes. -What if it does? If you wrote the child process yourself and made an effort to -clean up your child processes before terminating, you don't have to worry. -If not, you will leave hanging processes (called "zombie" processes in Unix). - -With Win32::Job, just create a new Job, then use the job to spawn the child -process. All I<its> children will also be created in the new Job. When you -time out, just call the job's kill() method and the entire process tree will -be terminated. - -=head1 Using Win32::Job - -The following methods are available: - -=over 4 - -=item 1 - -new() - - new(); - -Creates a new Job object using the Win32 API call CreateJobObject(). The job -is created with a default security context, and is unnamed. - -Note: this method returns C<undef> if CreateJobObject() fails. Look at C<$^E> -for more detailed error information. - -=item 2 - -spawn() - - spawn($exe, $args, \%opts); - -Creates a new process and associates it with the Job. The process is initially -suspended, and can be resumed with one of the other methods. Uses the Win32 -API call CreateProcess(). Returns the PID of the newly created process. - -Note: this method returns C<undef> if CreateProcess() fails. See C<$^E> for -more detailed error information. One reason this will fail is if the calling -process is itself part of a job, and the job's security context does not allow -child processes to be created in a different job context than the parent. - -The arguments are described here: - -=over 4 - -=item 1 - -$exe - -The executable program to run. This may be C<undef>, in which case the first -argument in $args is the program to run. - -If this has path information in it, it is used "as is" and passed to -CreateProcess(), which interprets it as either an absolute path, or a -path relative to the current drive and directory. If you did not specify an -extension, ".exe" is assumed. - -If there are no path separators (either backslashes or forward slashes), -then Win32::Job will search the current directory and your PATH, looking -for the file. In addition, if you did not specify an extension, then -Win32::Job checks ".exe", ".com", and ".bat" in order. If it finds a ".bat" -file, Win32::Job will actually call F<cmd.exe> and prepend "cmd.exe" to the -$args. - -For example, assuming a fairly normal PATH: - - spawn(q{c:\winnt\system\cmd.exe}, q{cmd /C "echo %PATH%"}) - exefile: c:\winnt\system\cmd.exe - cmdline: cmd /C "echo %PATH%" - - spawn("cmd.exe", q{cmd /C "echo %PATH%"}) - exefile: c:\winnt\system\cmd.exe - cmdline: cmd /C "echo %PATH%" - -=item 2 - -$args - -The commandline to pass to the executable program. The first word will be -C<argv[0]> to an EXE file, so you should repeat the command name in $args. - -For example: - - $job->spawn($Config{perlpath}, "perl foo.pl"); - -In this case, the "perl" is ignored, since perl.exe doesn't use it. - -=item 3 - -%opts - -A hash reference for advanced options. This parameter is optional. -the following keys are recognized: - -=over 4 - -=item cwd - -A string specifying the current directory of the new process. - -By default, the process shares the parent's current directory, C<.>. - -=item new_console - -A boolean; if true, the process is started in a new console window. - -By default, the process shares the parent's console. This has no effect on GUI -programs which do not interact with the console. - -=item window_attr - -Either C<minimized>, which displays the new window minimized; C<maximimzed>, -which shows the new window maximized; or C<hidden>, which does not display the -new window. - -By default, the window is displayed using its application's defaults. - -=item new_group - -A boolean; if true, the process is the root of a new process group. This -process group includes all descendents of the child. - -By default, the process is in the parent's process group (but in a new job). - -=item no_window - -A boolean; if true, the process is run without a console window. This flag is -only valid when starting a console application, otherwise it is ignored. If you -are launching a GUI application, use the C<window_attr> tag instead. - -By default, the process shares its parent's console. - -=item stdin - -An open input filehandle, or the name of an existing file. The resulting -filehandle will be used for the child's standard input handle. - -By default, the child process shares the parent's standard input. - -=item stdout - -An open output filehandle or filename (will be opened for append). The -resulting filehandle will be used for the child's standard output handle. - -By default, the child process shares the parent's standard output. - -=item stderr - -An open output filehandle or filename (will be opened for append). The -resulting filehandle will be used for the child's standard error handle. - -By default, the child process shares the parent's standard error. - -=back - -Unrecognized keys are ignored. - -=back - -=item 3 - -run() - - run($timeout, $which); - -Provides a simple way to run the programs with a time limit. The -$timeout is in seconds with millisecond accuracy. This call blocks for -up to $timeout seconds, or until the processes finish. - -The $which parameter specifies whether to wait for I<all> processes to -complete within the $timeout, or whether to wait for I<any> process to -complete. You should set this to a boolean, where a true value means to -wait for I<all> the processes to complete, and a false value to wait -for I<any>. If you do not specify $which, it defaults to true (C<all>). - -Returns a boolean indicating whether the processes exited by themselves, -or whether the time expired. A true return value means the processes -exited normally; a false value means one or more processes was killed -will $timeout. - -You can get extended information on process exit codes using the -status() method. - -For example, this is how to build two perl modules at the same time, -with a 5 minute timeout: - - use Win32::Job; - $job = Win32::Job->new; - $job->spawn("cmd", q{cmd /C "cd Mod1 && nmake"}); - $job->spawn("cmd", q{cmd /C "cd Mod2 && nmake"}); - $ok = $job->run(5 * 60); - print "Mod1 and Mod2 built ok!\n" if $ok; - -=item 4 - -watch() - - watch(\&handler, $interval, $which); - - handler($job); - -Provides more fine-grained control over how to stop the programs. You specify -a callback and an interval in seconds, and Win32::Job will call the "watchdog" -function at this interval, either until the processes finish or your watchdog -tells Win32::Job to stop. You must return a value indicating whether to stop: a -true value means to terminate the processes immediately. - -The $which parameter has the same meaning as run()'s. - -Returns a boolean with the same meaning as run()'s. - -The handler may do anything it wants. One useful application of the watch() -method is to check the filesize of the output file, and terminate the Job if -the file becomes larger than a certain limit: - - use Win32::Job; - $job = Win32::Job->new; - $job->spawn("cmd", q{cmd /C "cd Mod1 && nmake"}, { - stdin => 'NUL', # the NUL device - stdout => 'stdout.log', - stderr => 'stdout.log', - }); - $ok = $job->watch(sub { - return 1 if -s "stdout.log" > 1_000_000; - }, 1); - print "Mod1 built ok!\n" if $ok; - -=item 5 - -status() - - status() - -Returns a hash containing information about the processes in the job. -Only returns valid information I<after> calling either run() or watch(); -returns an empty hash if you have not yet called them. May be called from a -watch() callback, in which case the C<exitcode> field should be ignored. - -The keys of the hash are the process IDs; the values are a subhash -containing the following keys: - -=over 4 - -=item exitcode - -The exit code returned by the process. If the process was killed because -of a timeout, the value is 293. - -=item time - -The time accumulated by the process. This is yet another subhash containing -the subkeys (i) C<user>, the amount of time the process spent in user -space; (ii) C<kernel>, the amount of time the process spent in kernel space; -and (iii) C<elapsed>, the total time the process was running. - -=back - -=item 6 - -kill() - - kill(); - -Kills all processes and subprocesses in the Job. Has no return value. -Sets the exit code to all processes killed to 293, which you can check -for in the status() return value. - -=back - -=head1 SEE ALSO - -For more information about jobs, see Microsoft's online help at - - http://msdn.microsoft.com/ - -For other modules which do similar things (but not as well), see: - -=over 4 - -=item 1 - -Win32::Process - -Low-level access to creating processes in Win32. See L<Win32::Process>. - -=item 2 - -Win32::Console - -Low-level access to consoles in Win32. See L<Win32::Console>. - -=item 3 - -Win32::ProcFarm - -Manage pools of threads to perform CPU-intensive tasks on Windows. See -L<Win32::ProcFarm>. - -=back - -=head1 AUTHOR - -ActiveState (support@ActiveState.com) - -=head1 COPYRIGHT - -Copyright (c) 2002, ActiveState Corporation. All Rights Reserved. - -=cut diff --git a/Master/tlpkg/tlperl/lib/Win32/Mutex.pm b/Master/tlpkg/tlperl/lib/Win32/Mutex.pm deleted file mode 100644 index 801c2d35cda..00000000000 --- a/Master/tlpkg/tlperl/lib/Win32/Mutex.pm +++ /dev/null @@ -1,125 +0,0 @@ -#--------------------------------------------------------------------- -package Win32::Mutex; -# -# Copyright 1998 Christopher J. Madsen -# -# Created: 3 Feb 1998 from the ActiveWare version -# (c) 1995 Microsoft Corporation. All rights reserved. -# Developed by ActiveWare Internet Corp., http://www.ActiveWare.com -# -# Other modifications (c) 1997 by Gurusamy Sarathy <gsar@activestate.com> -# -# Author: Christopher J. Madsen <cjm@pobox.com> -# Version: 1.00 (6-Feb-1998) -# -# This program is free software; you can redistribute it and/or modify -# it under the same terms as Perl itself. -# -# This program is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See either the -# GNU General Public License or the Artistic License for more details. -# -# Use Win32 mutex objects for synchronization -#--------------------------------------------------------------------- - -$VERSION = '1.02'; - -use Win32::IPC 1.00 '/./'; # Import everything -require Exporter; -require DynaLoader; - -@ISA = qw(Exporter DynaLoader Win32::IPC); -@EXPORT_OK = qw( - wait_all wait_any -); - -bootstrap Win32::Mutex; - -sub Create { $_[0] = Win32::Mutex->new(@_[1..2]) } -sub Open { $_[0] = Win32::Mutex->open($_[1]) } -sub Release { &release } - -1; -__END__ - -=head1 NAME - -Win32::Mutex - Use Win32 mutex objects from Perl - -=head1 SYNOPSIS - - require Win32::Mutex; - - $mutex = Win32::Mutex->new($initial,$name); - $mutex->wait; - -=head1 DESCRIPTION - -This module allows access to the Win32 mutex objects. The C<wait> -method and C<wait_all> & C<wait_any> functions are inherited from the -L<"Win32::IPC"> module. - -=head2 Methods - -=over 4 - -=item $mutex = Win32::Mutex->new([$initial, [$name]]) - -Constructor for a new mutex object. If C<$initial> is true, requests -immediate ownership of the mutex (default false). If C<$name> is -omitted, creates an unnamed mutex object. - -If C<$name> signifies an existing mutex object, then C<$initial> is -ignored and the object is opened. If this happens, C<$^E> will be set -to 183 (ERROR_ALREADY_EXISTS). - -=item $mutex = Win32::Mutex->open($name) - -Constructor for opening an existing mutex object. - -=item $mutex->release - -Release ownership of a C<$mutex>. You should have obtained ownership -of the mutex through C<new> or one of the wait functions. Returns -true if successful. - -=item $mutex->wait([$timeout]) - -Wait for ownership of C<$mutex>. See L<"Win32::IPC">. - -=back - -=head2 Deprecated Functions and Methods - -B<Win32::Mutex> still supports the ActiveWare syntax, but its use is -deprecated. - -=over 4 - -=item Create($MutObj,$Initial,$Name) - -Use C<$MutObj = Win32::Mutex-E<gt>new($Initial,$Name)> instead. - -=item Open($MutObj,$Name) - -Use C<$MutObj = Win32::Mutex-E<gt>open($Name)> instead. - -=item $MutObj->Release() - -Use C<$MutObj-E<gt>release> instead. - -=back - -=head1 AUTHOR - -Christopher J. Madsen E<lt>F<cjm@pobox.com>E<gt> - -Loosely based on the original module by ActiveWare Internet Corp., -F<http://www.ActiveWare.com> - -=cut - -# Local Variables: -# tmtrack-file-task: "Win32::Mutex" -# End: diff --git a/Master/tlpkg/tlperl/lib/Win32/NetAdmin.pm b/Master/tlpkg/tlperl/lib/Win32/NetAdmin.pm deleted file mode 100644 index ace31a619e4..00000000000 --- a/Master/tlpkg/tlperl/lib/Win32/NetAdmin.pm +++ /dev/null @@ -1,419 +0,0 @@ -package Win32::NetAdmin; - -# -#NetAdmin.pm -#Written by Douglas_Lankshear@ActiveWare.com -# - -$VERSION = '0.08'; - -require Exporter; -require DynaLoader; - -require Win32 unless defined &Win32::IsWinNT; -die "The Win32::NetAdmin module works only on Windows NT" unless Win32::IsWinNT(); - -@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( - DOMAIN_ALIAS_RID_ACCOUNT_OPS - DOMAIN_ALIAS_RID_ADMINS - DOMAIN_ALIAS_RID_BACKUP_OPS - DOMAIN_ALIAS_RID_GUESTS - DOMAIN_ALIAS_RID_POWER_USERS - DOMAIN_ALIAS_RID_PRINT_OPS - DOMAIN_ALIAS_RID_REPLICATOR - DOMAIN_ALIAS_RID_SYSTEM_OPS - DOMAIN_ALIAS_RID_USERS - DOMAIN_GROUP_RID_ADMINS - DOMAIN_GROUP_RID_GUESTS - DOMAIN_GROUP_RID_USERS - DOMAIN_USER_RID_ADMIN - DOMAIN_USER_RID_GUEST - FILTER_TEMP_DUPLICATE_ACCOUNT - FILTER_NORMAL_ACCOUNT - FILTER_INTERDOMAIN_TRUST_ACCOUNT - FILTER_WORKSTATION_TRUST_ACCOUNT - FILTER_SERVER_TRUST_ACCOUNT - SV_TYPE_WORKSTATION - SV_TYPE_SERVER - SV_TYPE_SQLSERVER - SV_TYPE_DOMAIN_CTRL - SV_TYPE_DOMAIN_BAKCTRL - SV_TYPE_TIMESOURCE - SV_TYPE_AFP - SV_TYPE_NOVELL - SV_TYPE_DOMAIN_MEMBER - SV_TYPE_PRINT - SV_TYPE_PRINTQ_SERVER - SV_TYPE_DIALIN - SV_TYPE_DIALIN_SERVER - SV_TYPE_XENIX_SERVER - SV_TYPE_NT - SV_TYPE_WFW - SV_TYPE_POTENTIAL_BROWSER - SV_TYPE_BACKUP_BROWSER - SV_TYPE_MASTER_BROWSER - SV_TYPE_DOMAIN_MASTER - SV_TYPE_DOMAIN_ENUM - SV_TYPE_SERVER_UNIX - SV_TYPE_SERVER_MFPN - SV_TYPE_SERVER_NT - SV_TYPE_SERVER_OSF - SV_TYPE_SERVER_VMS - SV_TYPE_WINDOWS - SV_TYPE_DFS - SV_TYPE_ALTERNATE_XPORT - SV_TYPE_LOCAL_LIST_ONLY - SV_TYPE_ALL - UF_TEMP_DUPLICATE_ACCOUNT - UF_NORMAL_ACCOUNT - UF_INTERDOMAIN_TRUST_ACCOUNT - UF_WORKSTATION_TRUST_ACCOUNT - UF_SERVER_TRUST_ACCOUNT - UF_MACHINE_ACCOUNT_MASK - UF_ACCOUNT_TYPE_MASK - UF_DONT_EXPIRE_PASSWD - UF_SETTABLE_BITS - UF_SCRIPT - UF_ACCOUNTDISABLE - UF_HOMEDIR_REQUIRED - UF_LOCKOUT - UF_PASSWD_NOTREQD - UF_PASSWD_CANT_CHANGE - USE_FORCE - USE_LOTS_OF_FORCE - USE_NOFORCE - USER_PRIV_MASK - USER_PRIV_GUEST - USER_PRIV_USER - USER_PRIV_ADMIN -); - -@EXPORT_OK = qw( - GetError - GetDomainController - GetAnyDomainController - UserCreate - UserDelete - UserGetAttributes - UserSetAttributes - UserChangePassword - UsersExist - GetUsers - GroupCreate - GroupDelete - GroupGetAttributes - GroupSetAttributes - GroupAddUsers - GroupDeleteUsers - GroupIsMember - GroupGetMembers - LocalGroupCreate - LocalGroupDelete - LocalGroupGetAttributes - LocalGroupSetAttributes - LocalGroupIsMember - LocalGroupGetMembers - LocalGroupGetMembersWithDomain - LocalGroupAddUsers - LocalGroupDeleteUsers - GetServers - GetTransports - LoggedOnUsers - GetAliasFromRID - GetUserGroupFromRID - GetServerDisks -); -$EXPORT_TAGS{ALL}= \@EXPORT_OK; - -=head1 NAME - -Win32::NetAdmin - manage network groups and users in perl - -=head1 SYNOPSIS - - use Win32::NetAdmin; - -=head1 DESCRIPTION - -This module offers control over the administration of groups and users over a -network. - -=head1 FUNCTIONS - -=head2 NOTE - -All of the functions return false if they fail, unless otherwise noted. -When a function fails call Win32::NetAdmin::GetError() rather than -GetLastError() or $^E to retrieve the error code. - -C<server> is optional for all the calls below. If not given the local machine is -assumed. - -=over 10 - -=item GetError() - -Returns the error code of the last call to this module. - -=item GetDomainController(server, domain, returnedName) - -Returns the name of the domain controller for server. - -=item GetAnyDomainController(server, domain, returnedName) - -Returns the name of any domain controller for a domain that is directly trusted -by the server. - -=item UserCreate(server, userName, password, passwordAge, privilege, homeDir, comment, flags, scriptPath) - -Creates a user on server with password, passwordAge, privilege, homeDir, comment, -flags, and scriptPath. - -=item UserDelete(server, user) - -Deletes a user from server. - -=item UserGetAttributes(server, userName, password, passwordAge, privilege, homeDir, comment, flags, scriptPath) - -Gets password, passwordAge, privilege, homeDir, comment, flags, and scriptPath -for user. - -=item UserSetAttributes(server, userName, password, passwordAge, privilege, homeDir, comment, flags, scriptPath) - -Sets password, passwordAge, privilege, homeDir, comment, flags, and scriptPath -for user. - -=item UserChangePassword(domainname, username, oldpassword, newpassword) - -Changes a users password. Can be run under any account. - -=item UsersExist(server, userName) - -Checks if a user exists. - -=item GetUsers(server, filter, userRef) - -Fills userRef with user names if it is an array reference and with the user -names and the full names if it is a hash reference. - -=item GroupCreate(server, group, comment) - -Creates a group. - -=item GroupDelete(server, group) - -Deletes a group. - -=item GroupGetAttributes(server, groupName, comment) - -Gets the comment. - -=item GroupSetAttributes(server, groupName, comment) - -Sets the comment. - -=item GroupAddUsers(server, groupName, users) - -Adds a user to a group. - -=item GroupDeleteUsers(server, groupName, users) - -Deletes a users from a group. - -=item GroupIsMember(server, groupName, user) - -Returns TRUE if user is a member of groupName. - -=item GroupGetMembers(server, groupName, userArrayRef) - -Fills userArrayRef with the members of groupName. - -=item LocalGroupCreate(server, group, comment) - -Creates a local group. - -=item LocalGroupDelete(server, group) - -Deletes a local group. - -=item LocalGroupGetAttributes(server, groupName, comment) - -Gets the comment. - -=item LocalGroupSetAttributes(server, groupName, comment) - -Sets the comment. - -=item LocalGroupIsMember(server, groupName, user) - -Returns TRUE if user is a member of groupName. - -=item LocalGroupGetMembers(server, groupName, userArrayRef) - -Fills userArrayRef with the members of groupName. - -=item LocalGroupGetMembersWithDomain(server, groupName, userRef) - -This function is similar LocalGroupGetMembers but accepts an array or -a hash reference. Unlike LocalGroupGetMembers it returns each user name -as C<DOMAIN\USERNAME>. If a hash reference is given, the function -returns to each user or group name the type (group, user, alias etc.). -The possible types are as follows: - - $SidTypeUser = 1; - $SidTypeGroup = 2; - $SidTypeDomain = 3; - $SidTypeAlias = 4; - $SidTypeWellKnownGroup = 5; - $SidTypeDeletedAccount = 6; - $SidTypeInvalid = 7; - $SidTypeUnknown = 8; - -=item LocalGroupAddUsers(server, groupName, users) - -Adds a user to a group. - -=item LocalGroupDeleteUsers(server, groupName, users) - -Deletes a users from a group. - -=item GetServers(server, domain, flags, serverRef) - -Gets an array of server names or an hash with the server names and the -comments as seen in the Network Neighborhood or the server manager. -For flags, see SV_TYPE_* constants. - -=item GetTransports(server, transportRef) - -Enumerates the network transports of a computer. If transportRef is an array -reference, it is filled with the transport names. If transportRef is a hash -reference then a hash of hashes is filled with the data for the transports. - -=item LoggedOnUsers(server, userRef) - -Gets an array or hash with the users logged on at the specified computer. If -userRef is a hash reference, the value is a semikolon separated string of -username, logon domain and logon server. - -=item GetAliasFromRID(server, RID, returnedName) - -=item GetUserGroupFromRID(server, RID, returnedName) - -Retrieves the name of an alias (i.e local group) or a user group for a RID -from the specified server. These functions can be used for example to get the -account name for the administrator account if it is renamed or localized. - -Possible values for C<RID>: - - DOMAIN_ALIAS_RID_ACCOUNT_OPS - DOMAIN_ALIAS_RID_ADMINS - DOMAIN_ALIAS_RID_BACKUP_OPS - DOMAIN_ALIAS_RID_GUESTS - DOMAIN_ALIAS_RID_POWER_USERS - DOMAIN_ALIAS_RID_PRINT_OPS - DOMAIN_ALIAS_RID_REPLICATOR - DOMAIN_ALIAS_RID_SYSTEM_OPS - DOMAIN_ALIAS_RID_USERS - DOMAIN_GROUP_RID_ADMINS - DOMAIN_GROUP_RID_GUESTS - DOMAIN_GROUP_RID_USERS - DOMAIN_USER_RID_ADMIN - DOMAIN_USER_RID_GUEST - -=item GetServerDisks(server, arrayRef) - -Returns an array with the disk drives of the specified server. The array -contains two-character strings (drive letter followed by a colon). - -=back - -=head1 EXAMPLE - - # Simple script using Win32::NetAdmin to set the login script for - # all members of the NT group "Domain Users". Only works if you - # run it on the PDC. (From Robert Spier <rspier@seas.upenn.edu>) - # - # FILTER_TEMP_DUPLICATE_ACCOUNTS - # Enumerates local user account data on a domain controller. - # - # FILTER_NORMAL_ACCOUNT - # Enumerates global user account data on a computer. - # - # FILTER_INTERDOMAIN_TRUST_ACCOUNT - # Enumerates domain trust account data on a domain controller. - # - # FILTER_WORKSTATION_TRUST_ACCOUNT - # Enumerates workstation or member server account data on a domain - # controller. - # - # FILTER_SERVER_TRUST_ACCOUNT - # Enumerates domain controller account data on a domain controller. - - - use Win32::NetAdmin qw(GetUsers GroupIsMember - UserGetAttributes UserSetAttributes); - - my %hash; - GetUsers("", FILTER_NORMAL_ACCOUNT , \%hash) - or die "GetUsers() failed: $^E"; - - foreach (keys %hash) { - my ($password, $passwordAge, $privilege, - $homeDir, $comment, $flags, $scriptPath); - if (GroupIsMember("", "Domain Users", $_)) { - print "Updating $_ ($hash{$_})\n"; - UserGetAttributes("", $_, $password, $passwordAge, $privilege, - $homeDir, $comment, $flags, $scriptPath) - or die "UserGetAttributes() failed: $^E"; - $scriptPath = "dnx_login.bat"; # this is the new login script - UserSetAttributes("", $_, $password, $passwordAge, $privilege, - $homeDir, $comment, $flags, $scriptPath) - or die "UserSetAttributes() failed: $^E"; - } - } - -=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::NetAdmin macro $constname, used in $file at line $line."; - } - } - eval "sub $AUTOLOAD { $val }"; - goto &$AUTOLOAD; -} - -$SidTypeUser = 1; -$SidTypeGroup = 2; -$SidTypeDomain = 3; -$SidTypeAlias = 4; -$SidTypeWellKnownGroup = 5; -$SidTypeDeletedAccount = 6; -$SidTypeInvalid = 7; -$SidTypeUnknown = 8; - -sub GetError() { - our $__lastError; - $__lastError; -} - -bootstrap Win32::NetAdmin; - -1; -__END__ - diff --git a/Master/tlpkg/tlperl/lib/Win32/NetResource.pm b/Master/tlpkg/tlperl/lib/Win32/NetResource.pm deleted file mode 100644 index 04ac87acabd..00000000000 --- a/Master/tlpkg/tlperl/lib/Win32/NetResource.pm +++ /dev/null @@ -1,456 +0,0 @@ -package Win32::NetResource; - -require Exporter; -require DynaLoader; -require AutoLoader; - -$VERSION = '0.053'; - -@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( - RESOURCEDISPLAYTYPE_DOMAIN - RESOURCEDISPLAYTYPE_FILE - RESOURCEDISPLAYTYPE_GENERIC - RESOURCEDISPLAYTYPE_GROUP - RESOURCEDISPLAYTYPE_SERVER - RESOURCEDISPLAYTYPE_SHARE - RESOURCEDISPLAYTYPE_TREE - RESOURCETYPE_ANY - RESOURCETYPE_DISK - RESOURCETYPE_PRINT - RESOURCETYPE_UNKNOWN - RESOURCEUSAGE_CONNECTABLE - RESOURCEUSAGE_CONTAINER - RESOURCEUSAGE_RESERVED - RESOURCE_CONNECTED - RESOURCE_GLOBALNET - RESOURCE_REMEMBERED - STYPE_DISKTREE - STYPE_PRINTQ - STYPE_DEVICE - STYPE_IPC - STYPE_SPECIAL - SHARE_NETNAME_PARMNUM - SHARE_TYPE_PARMNUM - SHARE_REMARK_PARMNUM - SHARE_PERMISSIONS_PARMNUM - SHARE_MAX_USES_PARMNUM - SHARE_CURRENT_USES_PARMNUM - SHARE_PATH_PARMNUM - SHARE_PASSWD_PARMNUM - SHARE_FILE_SD_PARMNUM -); - -@EXPORT_OK = qw( - GetSharedResources - AddConnection - CancelConnection - WNetGetLastError - GetError - GetUNCName - NetShareAdd - NetShareCheck - NetShareDel - NetShareGetInfo - NetShareSetInfo -); - -=head1 NAME - -Win32::NetResource - manage network resources in perl - -=head1 SYNOPSIS - - use Win32::NetResource; - - $ShareInfo = { - 'path' => "C:\\MyShareDir", - 'netname' => "MyShare", - 'remark' => "It is good to share", - 'passwd' => "", - 'current-users' =>0, - 'permissions' => 0, - 'maxusers' => -1, - 'type' => 0, - }; - - Win32::NetResource::NetShareAdd( $ShareInfo,$parm ) - or die "unable to add share"; - - -=head1 DESCRIPTION - -This module offers control over the network resources of Win32.Disks, -printers etc can be shared over a network. - -=head1 DATA TYPES - -There are two main data types required to control network resources. -In Perl these are represented by hash types. - -=over 4 - -=item %NETRESOURCE - - KEY VALUE - - 'Scope' => Scope of an Enumeration - RESOURCE_CONNECTED, - RESOURCE_GLOBALNET, - RESOURCE_REMEMBERED. - - 'Type' => The type of resource to Enum - RESOURCETYPE_ANY All resources - RESOURCETYPE_DISK Disk resources - RESOURCETYPE_PRINT Print resources - - 'DisplayType' => The way the resource should be displayed. - RESOURCEDISPLAYTYPE_DOMAIN - The object should be displayed as a domain. - RESOURCEDISPLAYTYPE_GENERIC - The method used to display the object does not matter. - RESOURCEDISPLAYTYPE_SERVER - The object should be displayed as a server. - RESOURCEDISPLAYTYPE_SHARE - The object should be displayed as a sharepoint. - - 'Usage' => Specifies the Resources usage: - RESOURCEUSAGE_CONNECTABLE - RESOURCEUSAGE_CONTAINER. - - 'LocalName' => Name of the local device the resource is - connected to. - - 'RemoteName' => The network name of the resource. - - 'Comment' => A string comment. - - 'Provider' => Name of the provider of the resource. - -=back - -=item %SHARE_INFO - -This hash represents the SHARE_INFO_502 struct. - -=over 4 - - KEY VALUE - 'netname' => Name of the share. - 'type' => type of share. - 'remark' => A string comment. - 'permissions' => Permissions value - 'maxusers' => the max # of users. - 'current-users' => the current # of users. - 'path' => The path of the share. - 'passwd' => A password if one is req'd - -=back - -=head1 FUNCTIONS - -=head2 NOTE - -All of the functions return false if they fail. - -=over 4 - -=item GetSharedResources(\@Resources,dwType,\%NetResource = NULL) - -Creates a list in @Resources of %NETRESOURCE hash references. - -The return value indicates whether there was an error in accessing -any of the shared resources. All the shared resources that were -encountered (until the point of an error, if any) are pushed into -@Resources as references to %NETRESOURCE hashes. See example -below. The \%NetResource argument is optional. If it is not supplied, -the root (that is, the topmost container) of the network is assumed, -and all network resources available from the toplevel container will -be enumerated. - -=item AddConnection(\%NETRESOURCE,$Password,$UserName,$Connection) - -Makes a connection to a network resource specified by %NETRESOURCE - -=item CancelConnection($Name,$Connection,$Force) - -Cancels a connection to a network resource connected to local device -$name.$Connection is either 1 - persistent connection or 0, non-persistent. - -=item WNetGetLastError($ErrorCode,$Description,$Name) - -Gets the Extended Network Error. - -=item GetError( $ErrorCode ) - -Gets the last Error for a Win32::NetResource call. - -=item GetUNCName( $UNCName, $LocalPath ); - -Returns the UNC name of the disk share connected to $LocalPath in $UNCName. -$LocalPath should be a drive based path. e.g. "C:\\share\\subdir" - -=back - -=head2 NOTE - -$servername is optional for all the calls below. (if not given the -local machine is assumed.) - -=over 4 - -=item NetShareAdd(\%SHARE,$parm_err,$servername = NULL ) - -Add a share for sharing. - -=item NetShareCheck($device,$type,$servername = NULL ) - -Check if a directory or a device is available for connection from the -network through a share. This includes all directories that are -reachable through a shared directory or device, meaning that if C:\foo -is shared, C:\foo\bar is also available for sharing. This means that -this function is pretty useless, given that by default every disk -volume has an administrative share such as "C$" associated with its -root directory. - -$device must be a drive name, directory, or a device. For example, -"C:", "C:\dir", "LPT1", "D$", "IPC$" are all valid as the $device -argument. $type is an output argument that will be set to one of -the following constants that describe the type of share: - - STYPE_DISKTREE Disk drive - STYPE_PRINTQ Print queue - STYPE_DEVICE Communication device - STYPE_IPC Interprocess communication (IPC) - STYPE_SPECIAL Special share reserved for interprocess - communication (IPC$) or remote administration - of the server (ADMIN$). Can also refer to - administrative shares such as C$, D$, etc. - -=item NetShareDel( $netname, $servername = NULL ) - -Remove a share from a machines list of shares. - -=item NetShareGetInfo( $netname, \%SHARE,$servername=NULL ) - -Get the %SHARE_INFO information about the share $netname on the -server $servername. - -=item NetShareSetInfo( $netname,\%SHARE,$parm_err,$servername=NULL) - -Set the information for share $netname. - -=back - -=head1 EXAMPLE - -=over 4 - -=item Enumerating all resources on the network - - # - # This example displays all the share points in the entire - # visible part of the network. - # - - use strict; - use Win32::NetResource qw(:DEFAULT GetSharedResources GetError); - my $resources = []; - unless(GetSharedResources($resources, RESOURCETYPE_ANY)) { - my $err; - GetError($err); - warn Win32::FormatMessage($err); - } - - foreach my $href (@$resources) { - next if ($$href{DisplayType} != RESOURCEDISPLAYTYPE_SHARE); - print "-----\n"; - foreach( keys %$href){ - print "$_: $href->{$_}\n"; - } - } - -=item Enumerating all resources on a particular host - - # - # This example displays all the share points exported by the local - # host. - # - - use strict; - use Win32::NetResource qw(:DEFAULT GetSharedResources GetError); - if (GetSharedResources(my $resources, RESOURCETYPE_ANY, - { RemoteName => "\\\\" . Win32::NodeName() })) - { - foreach my $href (@$resources) { - print "-----\n"; - foreach(keys %$href) { print "$_: $href->{$_}\n"; } - } - } - -=back - -=head1 AUTHOR - -Jesse Dougherty for Hip Communications. - -Additional general cleanups and bug fixes by Gurusamy Sarathy <gsar@activestate.com>. - -=cut - -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; - 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::NetResource macro $constname, used at $file line $line. -"; - } - } - eval "sub $AUTOLOAD { $val }"; - goto &$AUTOLOAD; -} - -sub AddConnection -{ - my $h = $_[0]; - die "AddConnection: HASH reference required" unless ref($h) eq "HASH"; - - # - # The last four items *must* not be deallocated until the - # _AddConnection() completes (since the packed structure is - # pointing into these values. - # - my $netres = pack( 'i4 p4', $h->{Scope}, - $h->{Type}, - $h->{DisplayType}, - $h->{Usage}, - $h->{LocalName}, - $h->{RemoteName}, - $h->{Comment}, - $h->{Provider}); - _AddConnection($netres,$_[1],$_[2],$_[3]); -} - -#use Data::Dumper; - -sub GetSharedResources -{ - die "GetSharedResources: ARRAY reference required" - if defined $_[0] and ref($_[0]) ne "ARRAY"; - - my $aref = []; - - # Get the shared resources. - - my $ret; - - if (@_ > 2 and $_[2]) { - my $netres = pack('i4 p4', @{$_[2]}{qw(Scope - Type - DisplayType - Usage - LocalName - RemoteName - Comment - Provider)}); - $ret = _GetSharedResources( $aref , $_[1], $netres ); - } - else { - $ret = _GetSharedResources( $aref , $_[1] ); - } - - # build the array of hashes in $_[0] -# print Dumper($aref); - foreach ( @$aref ) { - my %hash; - @hash{'Scope', - 'Type', - 'DisplayType', - 'Usage', - 'LocalName', - 'RemoteName', - 'Comment', - 'Provider'} = split /\001/, $_; - push @{$_[0]}, \%hash; - } - - $ret; -} - -sub NetShareAdd -{ - my $shareinfo = _hash2SHARE( $_[0] ); - _NetShareAdd($shareinfo,$_[1], $_[2] || ""); -} - -sub NetShareGetInfo -{ - my ($netinfo,$val); - $val = _NetShareGetInfo( $_[0],$netinfo,$_[2] || ""); - %{$_[1]} = %{_SHARE2hash( $netinfo )}; - $val; -} - -sub NetShareSetInfo -{ - my $shareinfo = _hash2SHARE( $_[1] ); - _NetShareSetInfo( $_[0],$shareinfo,$_[2],$_[3] || ""); -} - - -# These are private functions to work with the ShareInfo structure. -# please note that the implementation of these calls requires the -# SHARE_INFO_502 level of information. - -sub _SHARE2hash -{ - my %hash = (); - @hash{'type', - 'permissions', - 'maxusers', - 'current-users', - 'remark', - 'netname', - 'path', - 'passwd'} = unpack('i4 A257 A81 A257 A257',$_[0]); - - return \%hash; -} - -sub _hash2SHARE -{ - my $h = $_[0]; - die "Argument must be a HASH reference" unless ref($h) eq "HASH"; - - return pack 'i4 a257 a81 a257 a257', - @$h{'type', - 'permissions', - 'maxusers', - 'current-users', - 'remark', - 'netname', - 'path', - 'passwd'}; -} - - -bootstrap Win32::NetResource; - -1; -__END__ diff --git a/Master/tlpkg/tlperl/lib/Win32/ODBC.pm b/Master/tlpkg/tlperl/lib/Win32/ODBC.pm deleted file mode 100644 index a51616388ea..00000000000 --- a/Master/tlpkg/tlperl/lib/Win32/ODBC.pm +++ /dev/null @@ -1,1493 +0,0 @@ -package Win32::ODBC; - -$VERSION = '0.032'; - -# Win32::ODBC.pm -# +==========================================================+ -# | | -# | ODBC.PM package | -# | --------------- | -# | | -# | Copyright (c) 1996, 1997 Dave Roth. All rights reserved. | -# | This program is free software; you can redistribute | -# | it and/or modify it under the same terms as Perl itself. | -# | | -# +==========================================================+ -# -# -# based on original code by Dan DeMaggio (dmag@umich.edu) -# -# Use under GNU General Public License or Larry Wall's "Artistic License" -# -# Check the README.TXT file that comes with this package for details about -# it's history. -# - -require Exporter; -require DynaLoader; - -$ODBCPackage = "Win32::ODBC"; -$ODBCPackage::Version = 970208; -$::ODBC = $ODBCPackage; -$CacheConnection = 0; - - # Reserve ODBC in the main namespace for US! -*ODBC::=\%Win32::ODBC::; - - -@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( - ODBC_ADD_DSN - ODBC_REMOVE_DSN - ODBC_CONFIG_DSN - ODBC_ADD_SYS_DSN - ODBC_REMOVE_SYS_DSN - ODBC_CONFIG_SYS_DSN - - SQL_DONT_CLOSE - SQL_DROP - SQL_CLOSE - SQL_UNBIND - SQL_RESET_PARAMS - - SQL_FETCH_NEXT - SQL_FETCH_FIRST - SQL_FETCH_LAST - SQL_FETCH_PRIOR - SQL_FETCH_ABSOLUTE - SQL_FETCH_RELATIVE - SQL_FETCH_BOOKMARK - - SQL_COLUMN_COUNT - SQL_COLUMN_NAME - SQL_COLUMN_TYPE - SQL_COLUMN_LENGTH - SQL_COLUMN_PRECISION - SQL_COLUMN_SCALE - SQL_COLUMN_DISPLAY_SIZE - SQL_COLUMN_NULLABLE - SQL_COLUMN_UNSIGNED - SQL_COLUMN_MONEY - SQL_COLUMN_UPDATABLE - SQL_COLUMN_AUTO_INCREMENT - SQL_COLUMN_CASE_SENSITIVE - SQL_COLUMN_SEARCHABLE - SQL_COLUMN_TYPE_NAME - SQL_COLUMN_TABLE_NAME - SQL_COLUMN_OWNER_NAME - SQL_COLUMN_QUALIFIER_NAME - SQL_COLUMN_LABEL - SQL_COLATT_OPT_MAX - SQL_COLUMN_DRIVER_START - SQL_COLATT_OPT_MIN - SQL_ATTR_READONLY - SQL_ATTR_WRITE - SQL_ATTR_READWRITE_UNKNOWN - SQL_UNSEARCHABLE - SQL_LIKE_ONLY - SQL_ALL_EXCEPT_LIKE - SQL_SEARCHABLE - ); - #The above are included for backward compatibility - - -sub new -{ - my ($n, $self); - my ($type) = shift; - my ($DSN) = shift; - my (@Results) = @_; - - if (ref $DSN){ - @Results = ODBCClone($DSN->{'connection'}); - }else{ - @Results = ODBCConnect($DSN, @Results); - } - @Results = processError(-1, @Results); - if (! scalar(@Results)){ - return undef; - } - $self = bless {}; - $self->{'connection'} = $Results[0]; - $ErrConn = $Results[0]; - $ErrText = $Results[1]; - $ErrNum = 0; - $self->{'DSN'} = $DSN; - $self; -} - -#### -# Close this ODBC session (or all sessions) -#### -sub Close -{ - my ($self, $Result) = shift; - $Result = DESTROY($self); - $self->{'connection'} = -1; - return $Result; -} - -#### -# Auto-Kill an instance of this module -#### -sub DESTROY -{ - my ($self) = shift; - my (@Results) = (0); - if($self->{'connection'} > -1){ - @Results = ODBCDisconnect($self->{'connection'}); - @Results = processError($self, @Results); - if ($Results[0]){ - undef $self->{'DSN'}; - undef @{$self->{'fnames'}}; - undef %{$self->{'field'}}; - undef %{$self->{'connection'}}; - } - } - return $Results[0]; -} - - -sub sql{ - return (Sql(@_)); -} - -#### -# Submit an SQL Execute statement for processing -#### -sub Sql{ - my ($self, $Sql, @Results) = @_; - @Results = ODBCExecute($self->{'connection'}, $Sql); - return updateResults($self, @Results); -} - -#### -# Retrieve data from a particular field -#### -sub Data{ - - # Change by JOC 06-APR-96 - # Altered by Dave Roth <dave@roth.net> 96.05.07 - my($self) = shift; - my(@Fields) = @_; - my(@Results, $Results, $Field); - - if ($self->{'Dirty'}){ - GetData($self); - $self->{'Dirty'} = 0; - } - @Fields = @{$self->{'fnames'}} if (! scalar(@Fields)); - foreach $Field (@Fields) { - if (wantarray) { - push(@Results, data($self, $Field)); - } else { - $Results .= data($self, $Field); - } - } - return wantarray ? @Results : $Results; -} - -sub DataHash{ - my($self, @Results) = @_; - my(%Results, $Element); - - if ($self->{'Dirty'}){ - GetData($self); - $self->{'Dirty'} = 0; - } - @Results = @{$self->{'fnames'}} if (! scalar(@Results)); - foreach $Element (@Results) { - $Results{$Element} = data($self, $Element); - } - - return %Results; -} - -#### -# Retrieve data from the data buffer -#### -sub data -{ $_[0]->{'data'}->{$_[1]}; } - - -sub fetchrow{ - return (FetchRow(@_)); -} -#### -# Put a row from an ODBC data set into data buffer -#### -sub FetchRow{ - my ($self, @Results) = @_; - my ($item, $num, $sqlcode); - # Added by JOC 06-APR-96 - # $num = 0; - $num = 0; - undef $self->{'data'}; - - - @Results = ODBCFetch($self->{'connection'}, @Results); - if (! (@Results = processError($self, @Results))){ - #### - # There should be an innocuous error "No records remain" - # This indicates no more records in the dataset - #### - return undef; - } - # Set the Dirty bit so we will go and extract data via the - # ODBCGetData function. Otherwise use the cache. - $self->{'Dirty'} = 1; - - # Return the array of field Results. - return @Results; -} - -sub GetData{ - my($self) = @_; - my @Results; - my $num = 0; - - @Results = ODBCGetData($self->{'connection'}); - if (!(@Results = processError($self, @Results))){ - return undef; - } - #### - # This is a special case. Do not call processResults - #### - ClearError(); - foreach (@Results){ - s/ +$// if defined $_; # HACK - $self->{'data'}->{ ${$self->{'fnames'}}[$num] } = $_; - $num++; - } - # return is a hack to interface with a assoc array. - return wantarray? (1, 1): 1; -} - -#### -# See if any more ODBC Results Sets -# Added by Brian Dunfordshore <Brian_Dunfordshore@bridge.com> -# 96.07.10 -#### -sub MoreResults{ - my ($self) = @_; - - my(@Results) = ODBCMoreResults($self->{'connection'}); - return (processError($self, @Results))[0]; -} - -#### -# Retrieve the catalog from the current DSN -# NOTE: All Field names are uppercase!!! -#### -sub Catalog{ - my ($self) = shift; - my ($Qualifier, $Owner, $Name, $Type) = @_; - my (@Results) = ODBCTableList($self->{'connection'}, $Qualifier, $Owner, $Name, $Type); - - # If there was an error return 0 else 1 - return (updateResults($self, @Results) != 1); -} - -#### -# Return an array of names from the catalog for the current DSN -# TableList($Qualifier, $Owner, $Name, $Type) -# Return: (array of names of tables) -# NOTE: All Field names are uppercase!!! -#### -sub TableList{ - my ($self) = shift; - my (@Results) = @_; - if (! scalar(@Results)){ - @Results = ("", "", "%", "TABLE"); - } - - if (! Catalog($self, @Results)){ - return undef; - } - undef @Results; - while (FetchRow($self)){ - push(@Results, Data($self, "TABLE_NAME")); - } - return sort(@Results); -} - - -sub fieldnames{ - return (FieldNames(@_)); -} -#### -# Return an array of fieldnames extracted from the current dataset -#### -sub FieldNames { $self = shift; return @{$self->{'fnames'}}; } - - -#### -# Closes this connection. This is used mostly for testing. You should -# probably use Close(). -#### -sub ShutDown{ - my($self) = @_; - print "\nClosing connection $self->{'connection'}..."; - $self->Close(); - print "\nDone\n"; -} - -#### -# Return this connection number -#### -sub Connection{ - my($self) = @_; - return $self->{'connection'}; -} - -#### -# Returns the current connections that are in use. -#### -sub GetConnections{ - return ODBCGetConnections(); -} - -#### -# Set the Max Buffer Size for this connection. This determines just how much -# ram can be allocated when a fetch() is performed that requires a HUGE amount -# of memory. The default max is 10k and the absolute max is 100k. -# This will probably never be used but I put it in because I noticed a fetch() -# of a MEMO field in an Access table was something like 4Gig. Maybe I did -# something wrong, but after checking several times I decided to impliment -# this limit thingie. -#### -sub SetMaxBufSize{ - my($self, $Size) = @_; - my(@Results) = ODBCSetMaxBufSize($self->{'connection'}, $Size); - return (processError($self, @Results))[0]; -} - -#### -# Returns the Max Buffer Size for this connection. See SetMaxBufSize(). -#### -sub GetMaxBufSize{ - my($self) = @_; - my(@Results) = ODBCGetMaxBufSize($self->{'connection'}); - return (processError($self, @Results))[0]; -} - - -#### -# Returns the DSN for this connection as an associative array. -#### -sub GetDSN{ - my($self, $DSN) = @_; - if(! ref($self)){ - $DSN = $self; - $self = 0; - } - if (! $DSN){ - $self = $self->{'connection'}; - } - my(@Results) = ODBCGetDSN($self, $DSN); - return (processError($self, @Results)); -} - -#### -# Returns an associative array of $XXX{'DSN'}=Description -#### -sub DataSources{ - my($self, $DSN) = @_; - if(! ref $self){ - $DSN = $self; - $self = 0; - } - my(@Results) = ODBCDataSources($DSN); - return (processError($self, @Results)); -} - -#### -# Returns an associative array of $XXX{'Driver Name'}=Driver Attributes -#### -sub Drivers{ - my($self) = @_; - if(! ref $self){ - $self = 0; - } - my(@Results) = ODBCDrivers(); - return (processError($self, @Results)); -} - -#### -# Returns the number of Rows that were affected by the previous SQL command. -#### -sub RowCount{ - my($self, $Connection) = @_; - if (! ref($self)){ - $Connection = $self; - $self = 0; - } - if (! $Connection){$Connection = $self->{'connection'};} - my(@Results) = ODBCRowCount($Connection); - return (processError($self, @Results))[0]; -} - -#### -# Returns the Statement Close Type -- how does ODBC Close a statment. -# Types: -# SQL_DROP -# SQL_CLOSE -# SQL_UNBIND -# SQL_RESET_PARAMS -#### -sub GetStmtCloseType{ - my($self, $Connection) = @_; - if (! ref($self)){ - $Connection = $self; - $self = 0; - } - if (! $Connection){$Connection = $self->{'connection'};} - my(@Results) = ODBCGetStmtCloseType($Connection); - return (processError($self, @Results)); -} - -#### -# Sets the Statement Close Type -- how does ODBC Close a statment. -# Types: -# SQL_DROP -# SQL_CLOSE -# SQL_UNBIND -# SQL_RESET_PARAMS -# Returns the newly set value. -#### -sub SetStmtCloseType{ - my($self, $Type, $Connection) = @_; - if (! ref($self)){ - $Connection = $Type; - $Type = $self; - $self = 0; - } - if (! $Connection){$Connection = $self->{'connection'};} - my(@Results) = ODBCSetStmtCloseType($Connection, $Type); - return (processError($self, @Results))[0]; -} - -sub ColAttributes{ - my($self, $Type, @Field) = @_; - my(%Results, @Results, $Results, $Attrib, $Connection, $Temp); - if (! ref($self)){ - $Type = $Field; - $Field = $self; - $self = 0; - } - $Connection = $self->{'connection'}; - if (! scalar(@Field)){ @Field = $self->fieldnames;} - foreach $Temp (@Field){ - @Results = ODBCColAttributes($Connection, $Temp, $Type); - ($Attrib) = processError($self, @Results); - if (wantarray){ - $Results{$Temp} = $Attrib; - }else{ - $Results .= "$Temp"; - } - } - return wantarray? %Results:$Results; -} - -sub GetInfo{ - my($self, $Type) = @_; - my($Connection, @Results); - if(! ref $self){ - $Type = $self; - $self = 0; - $Connection = 0; - }else{ - $Connection = $self->{'connection'}; - } - @Results = ODBCGetInfo($Connection, $Type); - return (processError($self, @Results))[0]; -} - -sub GetConnectOption{ - my($self, $Type) = @_; - my(@Results); - if(! ref $self){ - $Type = $self; - $self = 0; - } - @Results = ODBCGetConnectOption($self->{'connection'}, $Type); - return (processError($self, @Results))[0]; -} - -sub SetConnectOption{ - my($self, $Type, $Value) = @_; - if(! ref $self){ - $Value = $Type; - $Type = $self; - $self = 0; - } - my(@Results) = ODBCSetConnectOption($self->{'connection'}, $Type, $Value); - return (processError($self, @Results))[0]; -} - - -sub Transact{ - my($self, $Type) = @_; - my(@Results); - if(! ref $self){ - $Type = $self; - $self = 0; - } - @Results = ODBCTransact($self->{'connection'}, $Type); - return (processError($self, @Results))[0]; -} - - -sub SetPos{ - my($self, @Results) = @_; - @Results = ODBCSetPos($self->{'connection'}, @Results); - $self->{'Dirty'} = 1; - return (processError($self, @Results))[0]; -} - -sub ConfigDSN{ - my($self) = shift @_; - my($Type, $Connection); - if(! ref $self){ - $Type = $self; - $Connection = 0; - $self = 0; - }else{ - $Type = shift @_; - $Connection = $self->{'connection'}; - } - my($Driver, @Attributes) = @_; - @Results = ODBCConfigDSN($Connection, $Type, $Driver, @Attributes); - return (processError($self, @Results))[0]; -} - - -sub Version{ - my($self, @Packages) = @_; - my($Temp, @Results); - if (! ref($self)){ - push(@Packages, $self); - } - my($ExtName, $ExtVersion) = Info(); - if (! scalar(@Packages)){ - @Packages = ("ODBC.PM", "ODBC.PLL"); - } - foreach $Temp (@Packages){ - if ($Temp =~ /pll/i){ - push(@Results, "ODBC.PM:$Win32::ODBC::Version"); - }elsif ($Temp =~ /pm/i){ - push(@Results, "ODBC.PLL:$ExtVersion"); - } - } - return @Results; -} - - -sub SetStmtOption{ - my($self, $Option, $Value) = @_; - if(! ref $self){ - $Value = $Option; - $Option = $self; - $self = 0; - } - my(@Results) = ODBCSetStmtOption($self->{'connection'}, $Option, $Value); - return (processError($self, @Results))[0]; -} - -sub GetStmtOption{ - my($self, $Type) = @_; - if(! ref $self){ - $Type = $self; - $self = 0; - } - my(@Results) = ODBCGetStmtOption($self->{'connection'}, $Type); - return (processError($self, @Results))[0]; -} - -sub GetFunctions{ - my($self, @Results)=@_; - @Results = ODBCGetFunctions($self->{'connection'}, @Results); - return (processError($self, @Results)); -} - -sub DropCursor{ - my($self) = @_; - my(@Results) = ODBCDropCursor($self->{'connection'}); - return (processError($self, @Results))[0]; -} - -sub SetCursorName{ - my($self, $Name) = @_; - my(@Results) = ODBCSetCursorName($self->{'connection'}, $Name); - return (processError($self, @Results))[0]; -} - -sub GetCursorName{ - my($self) = @_; - my(@Results) = ODBCGetCursorName($self->{'connection'}); - return (processError($self, @Results))[0]; -} - -sub GetSQLState{ - my($self) = @_; - my(@Results) = ODBCGetSQLState($self->{'connection'}); - return (processError($self, @Results))[0]; -} - - -# ----------- R e s u l t P r o c e s s i n g F u n c t i o n s ---------- -#### -# Generic processing of data into associative arrays -#### -sub updateResults{ - my ($self, $Error, @Results) = @_; - - undef %{$self->{'field'}}; - - ClearError($self); - if ($Error){ - SetError($self, $Results[0], $Results[1]); - return ($Error); - } - - @{$self->{'fnames'}} = @Results; - - foreach (0..$#{$self->{'fnames'}}){ - s/ +$//; - $self->{'field'}->{${$self->{'fnames'}}[$_]} = $_; - } - return undef; -} - -# ---------------------------------------------------------------------------- -# ----------------- D e b u g g i n g F u n c t i o n s -------------------- - -sub Debug{ - my($self, $iDebug, $File) = @_; - my(@Results); - if (! ref($self)){ - if (defined $self){ - $File = $iDebug; - $iDebug = $self; - } - $Connection = 0; - $self = 0; - }else{ - $Connection = $self->{'connection'}; - } - push(@Results, ($Connection, $iDebug)); - push(@Results, $File) if ($File ne ""); - @Results = ODBCDebug(@Results); - return (processError($self, @Results))[0]; -} - -#### -# Prints out the current dataset (used mostly for testing) -#### -sub DumpData { - my($self) = @_; my($f, $goo); - - # Changed by JOC 06-Apr-96 - # print "\nDumping Data for connection: $conn->{'connection'}\n"; - print "\nDumping Data for connection: $self->{'connection'}\n"; - print "Error: \""; - print $self->Error(); - print "\"\n"; - if (! $self->Error()){ - foreach $f ($self->FieldNames){ - print $f . " "; - $goo .= "-" x length($f); - $goo .= " "; - } - print "\n$goo\n"; - while ($self->FetchRow()){ - foreach $f ($self->FieldNames){ - print $self->Data($f) . " "; - } - print "\n"; - } - } -} - -sub DumpError{ - my($self) = @_; - my($ErrNum, $ErrText, $ErrConn); - my($Temp); - - print "\n---------- Error Report: ----------\n"; - if (ref $self){ - ($ErrNum, $ErrText, $ErrConn) = $self->Error(); - ($Temp = $self->GetDSN()) =~ s/.*DSN=(.*?);.*/$1/i; - print "Errors for \"$Temp\" on connection " . $self->{'connection'} . ":\n"; - }else{ - ($ErrNum, $ErrText, $ErrConn) = Error(); - print "Errors for the package:\n"; - } - - print "Connection Number: $ErrConn\nError number: $ErrNum\nError message: \"$ErrText\"\n"; - print "-----------------------------------\n"; - -} - -#### -# Submit an SQL statement and print data about it (used mostly for testing) -#### -sub Run{ - my($self, $Sql) = @_; - - print "\nExcecuting connection $self->{'connection'}\nsql statement: \"$Sql\"\n"; - $self->Sql($Sql); - print "Error: \""; - print $self->error; - print "\"\n"; - print "--------------------\n\n"; -} - -# ---------------------------------------------------------------------------- -# ----------- E r r o r P r o c e s s i n g F u n c t i o n s ------------ - -#### -# Process Errors returned from a call to ODBCxxxx(). -# It is assumed that the Win32::ODBC function returned the following structure: -# ($ErrorNumber, $ResultsText, ...) -# $ErrorNumber....0 = No Error -# >0 = Error Number -# $ResultsText.....if no error then this is the first Results element. -# if error then this is the error text. -#### -sub processError{ - my($self, $Error, @Results) = @_; - if ($Error){ - SetError($self, $Results[0], $Results[1]); - undef @Results; - } - return @Results; -} - -#### -# Return the last recorded error message -#### -sub error{ - return (Error(@_)); -} - -sub Error{ - my($self) = @_; - if(ref($self)){ - if($self->{'ErrNum'}){ - my($State) = ODBCGetSQLState($self->{'connection'}); - return (wantarray)? ($self->{'ErrNum'}, $self->{'ErrText'}, $self->{'connection'}, $State) :"[$self->{'ErrNum'}] [$self->{'connection'}] [$State] \"$self->{'ErrText'}\""; - } - }elsif ($ErrNum){ - return (wantarray)? ($ErrNum, $ErrText, $ErrConn):"[$ErrNum] [$ErrConn] \"$ErrText\""; - } - return undef -} - -#### -# SetError: -# Assume that if $self is not a reference then it is just a placeholder -# and should be ignored. -#### -sub SetError{ - my($self, $Num, $Text, $Conn) = @_; - if (ref $self){ - $self->{'ErrNum'} = $Num; - $self->{'ErrText'} = $Text; - $Conn = $self->{'connection'} if ! $Conn; - } - $ErrNum = $Num; - $ErrText = $Text; - - #### - # Test Section Begin - #### -# $! = ($Num, $Text); - #### - # Test Section End - #### - - $ErrConn = $Conn; -} - -sub ClearError{ - my($self, $Num, $Text) = @_; - if (ref $self){ - undef $self->{'ErrNum'}; - undef $self->{'ErrText'}; - }else{ - undef $ErrConn; - undef $ErrNum; - undef $ErrText; - } - ODBCCleanError(); - return 1; -} - - -sub GetError{ - my($self, $Connection) = @_; - my(@Results); - if (! ref($self)){ - $Connection = $self; - $self = 0; - }else{ - if (! defined($Connection)){ - $Connection = $self->{'connection'}; - } - } - - @Results = ODBCGetError($Connection); - return @Results; -} - - - - -# ---------------------------------------------------------------------------- -# ------------------ A U T O L O A D F U N C T I O N ----------------------- - -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; - $val = constant($constname); - - if ($! != 0) { - if ($! =~ /Invalid/) { - $AutoLoader::AUTOLOAD = $AUTOLOAD; - goto &AutoLoader::AUTOLOAD; - } - else { - - # Added by JOC 06-APR-96 - # $pack = 0; - $pack = 0; - ($pack,$file,$line) = caller; - print "Your vendor has not defined Win32::ODBC macro $constname, used in $file at line $line."; - } - } - eval "sub $AUTOLOAD { $val }"; - goto &$AUTOLOAD; -} - - - # -------------------------------------------------------------- - # - # - # Make sure that we shutdown ODBC and free memory even if we are - # using perlis.dll on Win32 platform! -END{ -# ODBCShutDown() unless $CacheConnection; -} - - -bootstrap Win32::ODBC; - -# Preloaded methods go here. - -# Autoload methods go after __END__, and are processed by the autosplit program. - -1; -__END__ - -=head1 NAME - -Win32::ODBC - ODBC Extension for Win32 - -=head1 SYNOPSIS - -To use this module, include the following statement at the top of your -script: - - use Win32::ODBC; - -Next, create a data connection to your DSN: - - $Data = new Win32::ODBC("MyDSN"); - -B<NOTE>: I<MyDSN> can be either the I<DSN> as defined in the ODBC -Administrator, I<or> it can be an honest-to-God I<DSN Connect String>. - - Example: "DSN=My Database;UID=Brown Cow;PWD=Moo;" - -You should check to see if C<$Data> is indeed defined, otherwise there -has been an error. - -You can now send SQL queries and retrieve info to your heart's -content! See the description of the methods provided by this module -below and also the file F<TEST.PL> as referred to in L<INSTALLATION -NOTES> to see how it all works. - -Finally, B<MAKE SURE> that you close your connection when you are -finished: - - $Data->Close(); - -=head1 DESCRIPTION - -=head2 Background - -This is a hack of Dan DeMaggio's <dmag@umich.edu> F<NTXS.C> ODBC -implementation. I have recoded and restructured most of it including -most of the F<ODBC.PM> package, but its very core is still based on -Dan's code (thanks Dan!). - -The history of this extension is found in the file F<HISTORY.TXT> that -comes with the original archive (see L<INSTALLATION NOTES> below). - -=head2 Benefits - -And what are the benefits of this module? - -=over - -=item * - -The number of ODBC connections is limited by memory and ODBC itself -(have as many as you want!). - -=item * - -The working limit for the size of a field is 10,240 bytes, but you can -increase that limit (if needed) to a max of 2,147,483,647 bytes. (You -can always recompile to increase the max limit.) - -=item * - -You can open a connection by either specifing a DSN or a connection -string! - -=item * - -You can open and close the connections in any order! - -=item * - -Other things that I can not think of right now... :) - -=back - -=head1 CONSTANTS - -This package defines a number of constants. You may refer to each of -these constants using the notation C<ODBC::xxxxx>, where C<xxxxx> is -the constant. - -Example: - - print ODBC::SQL_SQL_COLUMN_NAME, "\n"; - -=head1 SPECIAL NOTATION - -For the method documentation that follows, an B<*> following the -method parameters indicates that that method is new or has been -modified for this version. - -=head1 CONSTRUCTOR - -=over - -=item new ( ODBC_OBJECT | DSN [, (OPTION1, VALUE1), (OPTION2, VALUE2) ...] ) -* - -Creates a new ODBC connection based on C<DSN>, or, if you specify an -already existing ODBC object, then a new ODBC object will be created -but using the ODBC Connection specified by C<ODBC_OBJECT>. (The new -object will be a new I<hstmt> using the I<hdbc> connection in -C<ODBC_OBJECT>.) - -C<DSN> is I<Data Source Name> or a proper C<ODBCDriverConnect> string. - -You can specify SQL Connect Options that are implemented before the -actual connection to the DSN takes place. These option/values are the -same as specified in C<GetConnectOption>/C<SetConnectOption> (see -below) and are defined in the ODBC API specs. - -Returns a handle to the database on success, or I<undef> on failure. - -=back - -=head1 METHODS - -=over - -=item Catalog ( QUALIFIER, OWNER, NAME, TYPE ) - -Tells ODBC to create a data set that contains table information about -the DSN. Use C<Fetch> and C<Data> or C<DataHash> to retrieve the data. -The returned format is: - - [Qualifier] [Owner] [Name] [Type] - -Returns I<true> on error. - -=item ColAttributes ( ATTRIBUTE [, FIELD_NAMES ] ) - -Returns the attribute C<ATTRIBUTE> on each of the fields in the list -C<FIELD_NAMES> in the current record set. If C<FIELD_NAMES> is empty, -then all fields are assumed. The attributes are returned as an -associative array. - -=item ConfigDSN ( OPTION, DRIVER, ATTRIBUTE1 [, ATTRIBUTE2, ATTRIBUTE3, ... -] ) - -Configures a DSN. C<OPTION> takes on one of the following values: - - ODBC_ADD_DSN.......Adds a new DSN. - ODBC_MODIFY_DSN....Modifies an existing DSN. - ODBC_REMOVE_DSN....Removes an existing DSN. - - ODBC_ADD_SYS_DSN.......Adds a new System DSN. - ODBC_MODIFY_SYS_DSN....Modifies an existing System DSN. - ODBC_REMOVE_SYS_DSN....Removes an existing System DSN. - -You must specify the driver C<DRIVER> (which can be retrieved by using -C<DataSources> or C<Drivers>). - -C<ATTRIBUTE1> B<should> be I<"DSN=xxx"> where I<xxx> is the name of -the DSN. Other attributes can be any DSN attribute such as: - - "UID=Cow" - "PWD=Moo" - "Description=My little bitty Data Source Name" - -Returns I<true> on success, I<false> on failure. - -B<NOTE 1>: If you use C<ODBC_ADD_DSN>, then you must include at least -I<"DSN=xxx"> and the location of the database. - -Example: For MS Access databases, you must specify the -I<DatabaseQualifier>: - - "DBQ=c:\\...\\MyDatabase.mdb" - -B<NOTE 2>: If you use C<ODBC_MODIFY_DSN>, then you need only specify -the I<"DNS=xxx"> attribute. Any other attribute you include will be -changed to what you specify. - -B<NOTE 3>: If you use C<ODBC_REMOVE_DSN>, then you need only specify -the I<"DSN=xxx"> attribute. - -=item Connection () - -Returns the connection number associated with the ODBC connection. - -=item Close () - -Closes the ODBC connection. No return value. - -=item Data ( [ FIELD_NAME ] ) - -Returns the contents of column name C<FIELD_NAME> or the current row -(if nothing is specified). - -=item DataHash ( [ FIELD1, FIELD2, ... ] ) - -Returns the contents for C<FIELD1, FIELD2, ...> or the entire row (if -nothing is specified) as an associative array consisting of: - - {Field Name} => Field Data - -=item DataSources () - -Returns an associative array of Data Sources and ODBC remarks about them. -They are returned in the form of: - - $ArrayName{'DSN'}=Driver - -where I<DSN> is the Data Source Name and ODBC Driver used. - -=item Debug ( [ 1 | 0 ] ) - -Sets the debug option to on or off. If nothing is specified, then -nothing is changed. - -Returns the debugging value (I<1> or I<0>). - -=item Drivers () - -Returns an associative array of ODBC Drivers and their attributes. -They are returned in the form of: - - $ArrayName{'DRIVER'}=Attrib1;Attrib2;Attrib3;... - -where I<DRIVER> is the ODBC Driver Name and I<AttribX> are the -driver-defined attributes. - -=item DropCursor ( [ CLOSE_TYPE ] ) - -Drops the cursor associated with the ODBC object. This forces the -cursor to be deallocated. This overrides C<SetStmtCloseType>, but the -ODBC object does not lose the C<StmtCloseType> setting. C<CLOSE_TYPE> -can be any valid C<SmtpCloseType> and will perform a close on the stmt -using the specified close type. - -Returns I<true> on success, I<false> on failure. - -=item DumpData () - -Dumps to the screen the fieldnames and all records of the current data -set. Used primarily for debugging. No return value. - -=item Error () - -Returns the last encountered error. The returned value is context -dependent: - -If called in a I<scalar> context, then a I<3-element array> is -returned: - - ( ERROR_NUMBER, ERROR_TEXT, CONNECTION_NUMBER ) - -If called in a I<string> context, then a I<string> is returned: - - "[ERROR_NUMBER] [CONNECTION_NUMBER] [ERROR_TEXT]" - -If debugging is on then two more variables are returned: - - ( ..., FUNCTION, LEVEL ) - -where C<FUNCTION> is the name of the function in which the error -occurred, and C<LEVEL> represents extra information about the error -(usually the location of the error). - -=item FetchRow ( [ ROW [, TYPE ] ] ) - -Retrieves the next record from the keyset. When C<ROW> and/or C<TYPE> -are specified, the call is made using C<SQLExtendedFetch> instead of -C<SQLFetch>. - -B<NOTE 1>: If you are unaware of C<SQLExtendedFetch> and its -implications, stay with just regular C<FetchRow> with no parameters. - -B<NOTE 2>: The ODBC API explicitly warns against mixing calls to -C<SQLFetch> and C<SQLExtendedFetch>; use one or the other but not -both. - -If I<ROW> is specified, it moves the keyset B<RELATIVE> C<ROW> number -of rows. - -If I<ROW> is specified and C<TYPE> is B<not>, then the type used is -B<RELATIVE>. - -Returns I<true> when another record is available to read, and I<false> -when there are no more records. - -=item FieldNames () - -Returns an array of fieldnames found in the current data set. There is -no guarantee on order. - -=item GetConnections () - -Returns an array of connection numbers showing what connections are -currently open. - -=item GetConnectOption ( OPTION ) - -Returns the value of the specified connect option C<OPTION>. Refer to -ODBC documentation for more information on the options and values. - -Returns a string or scalar depending upon the option specified. - -=item GetCursorName () - -Returns the name of the current cursor as a string or I<undef>. - -=item GetData () - -Retrieves the current row from the dataset. This is not generally -used by users; it is used internally. - -Returns an array of field data where the first element is either -I<false> (if successful) and I<true> (if B<not> successful). - -=item getDSN ( [ DSN ] ) - -Returns an associative array indicating the configuration for the -specified DSN. - -If no DSN is specified then the current connection is used. - -The returned associative array consists of: - - keys=DSN keyword; values=Keyword value. $Data{$Keyword}=Value - -=item GetFunctions ( [ FUNCTION1, FUNCTION2, ... ] ) - -Returns an associative array indicating the ability of the ODBC Driver -to support the specified functions. If no functions are specified, -then a 100 element associative array is returned containing all -possible functions and their values. - -C<FUNCTION> must be in the form of an ODBC API constant like -C<SQL_API_SQLTRANSACT>. - -The returned array will contain the results like: - - $Results{SQL_API_SQLTRANSACT}=Value - -Example: - - $Results = $O->GetFunctions( - $O->SQL_API_SQLTRANSACT, - SQL_API_SQLSETCONNECTOPTION - ); - $ConnectOption = $Results{SQL_API_SQLSETCONNECTOPTION}; - $Transact = $Results{SQL_API_SQLTRANSACT}; - -=item GetInfo ( OPTION ) - -Returns a string indicating the value of the particular -option specified. - -=item GetMaxBufSize () - -Returns the current allocated limit for I<MaxBufSize>. For more info, -see C<SetMaxBufSize>. - -=item GetSQLState () * - -Returns a string indicating the SQL state as reported by ODBC. The SQL -state is a code that the ODBC Manager or ODBC Driver returns after the -execution of a SQL function. This is helpful for debugging purposes. - -=item GetStmtCloseType ( [ CONNECTION ] ) - -Returns a string indicating the type of closure that will be used -everytime the I<hstmt> is freed. See C<SetStmtCloseType> for details. - -By default, the connection of the current object will be used. If -C<CONNECTION> is a valid connection number, then it will be used. - -=item GetStmtOption ( OPTION ) - -Returns the value of the specified statement option C<OPTION>. Refer -to ODBC documentation for more information on the options and values. - -Returns a string or scalar depending upon the option specified. - -=item MoreResults () - -This will report whether there is data yet to be retrieved from the -query. This can happen if the query was a multiple select. - -Example: - - "SELECT * FROM [foo] SELECT * FROM [bar]" - -B<NOTE>: Not all drivers support this. - -Returns I<1> if there is more data, I<undef> otherwise. - -=item RowCount ( CONNECTION ) - -For I<UPDATE>, I<INSERT> and I<DELETE> statements, the returned value -is the number of rows affected by the request or I<-1> if the number -of affected rows is not available. - -B<NOTE 1>: This function is not supported by all ODBC drivers! Some -drivers do support this but not for all statements (e.g., it is -supported for I<UPDATE>, I<INSERT> and I<DELETE> commands but not for -the I<SELECT> command). - -B<NOTE 2>: Many data sources cannot return the number of rows in a -result set before fetching them; for maximum interoperability, -applications should not rely on this behavior. - -Returns the number of affected rows, or I<-1> if not supported by the -driver in the current context. - -=item Run ( SQL ) - -Executes the SQL command B<SQL> and dumps to the screen info about -it. Used primarily for debugging. - -No return value. - -=item SetConnectOption ( OPTION ) * - -Sets the value of the specified connect option B<OPTION>. Refer to -ODBC documentation for more information on the options and values. - -Returns I<true> on success, I<false> otherwise. - -=item SetCursorName ( NAME ) * - -Sets the name of the current cursor. - -Returns I<true> on success, I<false> otherwise. - -=item SetPos ( ROW [, OPTION, LOCK ] ) * - -Moves the cursor to the row C<ROW> within the current keyset (B<not> -the current data/result set). - -Returns I<true> on success, I<false> otherwise. - -=item SetMaxBufSize ( SIZE ) - -This sets the I<MaxBufSize> for a particular connection. This will -most likely never be needed but... - -The amount of memory that is allocated to retrieve the field data of a -record is dynamic and changes when it need to be larger. I found that -a memo field in an MS Access database ended up requesting 4 Gig of -space. This was a bit much so there is an imposed limit (2,147,483,647 -bytes) that can be allocated for data retrieval. - -Since it is possible that someone has a database with field data -greater than 10,240, you can use this function to increase the limit -up to a ceiling of 2,147,483,647 (recompile if you need more). - -Returns the max number of bytes. - -=item SetStmtCloseType ( TYPE [, CONNECTION ] ) - -Sets a particular I<hstmt> close type for the connection. This is the -same as C<ODBCFreeStmt(hstmt, TYPE)>. By default, the connection of -the current object will be used. If C<CONNECTION> is a valid -connection number, then it will be used. - -C<TYPE> may be one of: - - SQL_CLOSE - SQL_DROP - SQL_UNBIND - SQL_RESET_PARAMS - -Returns a string indicating the newly set type. - -=item SetStmtOption ( OPTION ) * - -Sets the value of the specified statement option C<OPTION>. Refer to -ODBC documentation for more information on the options and values. - -Returns I<true> on success, I<false> otherwise. - -=item ShutDown () - -Closes the ODBC connection and dumps to the screen info about -it. Used primarily for debugging. - -No return value. - -=item Sql ( SQL_STRING ) - -Executes the SQL command C<SQL_STRING> on the current connection. - -Returns I<?> on success, or an error number on failure. - -=item TableList ( QUALIFIER, OWNER, NAME, TYPE ) - -Returns the catalog of tables that are available in the DSN. For an -unknown parameter, just specify the empty string I<"">. - -Returns an array of table names. - -=item Transact ( TYPE ) * - -Forces the ODBC connection to perform a I<rollback> or I<commit> -transaction. - -C<TYPE> may be one of: - - SQL_COMMIT - SQL_ROLLBACK - -B<NOTE>: This only works with ODBC drivers that support transactions. -Your driver supports it if I<true> is returned from: - - $O->GetFunctions($O->SQL_API_SQLTRANSACT)[1] - -(See C<GetFunctions> for more details.) - -Returns I<true> on success, I<false> otherwise. - -=item Version ( PACKAGES ) - -Returns an array of version numbers for the requested packages -(F<ODBC.pm> or F<ODBC.PLL>). If the list C<PACKAGES> is empty, then -all version numbers are returned. - -=back - -=head1 LIMITATIONS - -What known problems does this thing have? - -=over - -=item * - -If the account under which the process runs does not have write -permission on the default directory (for the process, not the ODBC -DSN), you will probably get a runtime error during a -C<SQLConnection>. I don't think that this is a problem with the code, -but more like a problem with ODBC. This happens because some ODBC -drivers need to write a temporary file. I noticed this using the MS -Jet Engine (Access Driver). - -=item * - -This module has been neither optimized for speed nor optimized for -memory consumption. - -=back - -=head1 INSTALLATION NOTES - -If you wish to use this module with a build of Perl other than -ActivePerl, you may wish to fetch the original source distribution for -this module at: - - ftp://ftp.roth.net:/pub/ntperl/ODBC/970208/Bin/Win32_ODBC_Build_CORE.zip - -or one of the other archives at that same location. See the included -README for hints on installing this module manually, what to do if you -get a I<parse exception>, and a pointer to a test script for this -module. - -=head1 OTHER DOCUMENTATION - -Find a FAQ for Win32::ODBC at: - - http://www.roth.net/odbc/odbcfaq.htm - -=head1 AUTHOR - -Dave Roth <rothd@roth.net> - -=head1 CREDITS - -Based on original code by Dan DeMaggio <dmag@umich.edu> - -=head1 DISCLAIMER - -I do not guarantee B<ANYTHING> with this package. If you use it you -are doing so B<AT YOUR OWN RISK>! I may or may not support this -depending on my time schedule. - -=head1 HISTORY - -Last Modified 1999.09.25. - -=head1 COPYRIGHT - -Copyright (c) 1996-1998 Dave Roth. All rights reserved. - -Courtesy of Roth Consulting: http://www.roth.net/consult/ - -Use under GNU General Public License. Details can be found at: -http://www.gnu.org/copyleft/gpl.html - -=cut diff --git a/Master/tlpkg/tlperl/lib/Win32/PerfLib.pm b/Master/tlpkg/tlperl/lib/Win32/PerfLib.pm deleted file mode 100644 index 2b773d68f4b..00000000000 --- a/Master/tlpkg/tlperl/lib/Win32/PerfLib.pm +++ /dev/null @@ -1,538 +0,0 @@ -package Win32::PerfLib; - -use strict; -use Carp; -use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $AUTOLOAD); - -require Exporter; -require DynaLoader; -require AutoLoader; - -@ISA = qw(Exporter DynaLoader); - -@EXPORT = qw( - PERF_100NSEC_MULTI_TIMER - PERF_100NSEC_MULTI_TIMER_INV - PERF_100NSEC_TIMER - PERF_100NSEC_TIMER_INV - PERF_AVERAGE_BASE - PERF_AVERAGE_BULK - PERF_AVERAGE_TIMER - PERF_COUNTER_BASE - PERF_COUNTER_BULK_COUNT - PERF_COUNTER_COUNTER - PERF_COUNTER_DELTA - PERF_COUNTER_ELAPSED - PERF_COUNTER_FRACTION - PERF_COUNTER_HISTOGRAM - PERF_COUNTER_HISTOGRAM_TYPE - PERF_COUNTER_LARGE_DELTA - PERF_COUNTER_LARGE_QUEUELEN_TYPE - PERF_COUNTER_LARGE_RAWCOUNT - PERF_COUNTER_LARGE_RAWCOUNT_HEX - PERF_COUNTER_MULTI_BASE - PERF_COUNTER_MULTI_TIMER - PERF_COUNTER_MULTI_TIMER_INV - PERF_COUNTER_NODATA - PERF_COUNTER_QUEUELEN - PERF_COUNTER_QUEUELEN_TYPE - PERF_COUNTER_RATE - PERF_COUNTER_RAWCOUNT - PERF_COUNTER_RAWCOUNT_HEX - PERF_COUNTER_TEXT - PERF_COUNTER_TIMER - PERF_COUNTER_TIMER_INV - PERF_COUNTER_VALUE - PERF_DATA_REVISION - PERF_DATA_VERSION - PERF_DELTA_BASE - PERF_DELTA_COUNTER - PERF_DETAIL_ADVANCED - PERF_DETAIL_EXPERT - PERF_DETAIL_NOVICE - PERF_DETAIL_WIZARD - PERF_DISPLAY_NOSHOW - PERF_DISPLAY_NO_SUFFIX - PERF_DISPLAY_PERCENT - PERF_DISPLAY_PER_SEC - PERF_DISPLAY_SECONDS - PERF_ELAPSED_TIME - PERF_INVERSE_COUNTER - PERF_MULTI_COUNTER - PERF_NO_INSTANCES - PERF_NO_UNIQUE_ID - PERF_NUMBER_DECIMAL - PERF_NUMBER_DEC_1000 - PERF_NUMBER_HEX - PERF_OBJECT_TIMER - PERF_RAW_BASE - PERF_RAW_FRACTION - PERF_SAMPLE_BASE - PERF_SAMPLE_COUNTER - PERF_SAMPLE_FRACTION - PERF_SIZE_DWORD - PERF_SIZE_LARGE - PERF_SIZE_VARIABLE_LEN - PERF_SIZE_ZERO - PERF_TEXT_ASCII - PERF_TEXT_UNICODE - PERF_TIMER_100NS - PERF_TIMER_TICK - PERF_TYPE_COUNTER - PERF_TYPE_NUMBER - PERF_TYPE_TEXT - PERF_TYPE_ZERO - ); - -$VERSION = '0.05'; - -sub AUTOLOAD { - - my $constname; - ($constname = $AUTOLOAD) =~ s/.*:://; - local $! = 0; - my $val = constant($constname); - if ($! != 0) { - if ($! =~ /Invalid/) { - $AutoLoader::AUTOLOAD = $AUTOLOAD; - goto &AutoLoader::AUTOLOAD; - } - else { - croak "Your vendor has not defined Win32::PerfLib macro $constname"; - } - } - eval "sub $AUTOLOAD { $val }"; - goto &$AUTOLOAD; -} - -bootstrap Win32::PerfLib $VERSION; - -# Preloaded methods go here. - -sub new -{ - my $proto = shift; - my $class = ref($proto) || $proto; - my $comp = shift; - my $handle; - my $self = {}; - if(PerfLibOpen($comp,$handle)) - { - $self->{handle} = $handle; - bless $self, $class; - return $self; - } - else - { - return undef; - } - -} - -sub Close -{ - my $self = shift; - return PerfLibClose($self->{handle}); -} - -sub DESTROY -{ - my $self = shift; - if(!PerfLibClose($self->{handle})) - { - croak "Error closing handle!\n"; - } -} - -sub GetCounterNames -{ - my($machine,$href) = @_; - if(ref $href ne "HASH") - { - croak("usage: Win32::PerfLib::GetCounterNames(machine,hashRef)\n"); - } - my($data,@data,$num,$name); - my $retval = PerfLibGetNames($machine,$data); - if($retval) - { - @data = split(/\0/, $data); - while(@data) - { - $num = shift @data; - $name = shift @data; - $href->{$num} = $name; - } - } - $retval; -} - -sub GetCounterHelp -{ - my($machine,$href) = @_; - if(ref $href ne "HASH") - { - croak("usage: Win32::PerfLib::GetCounterHelp(machine,hashRef)\n"); - } - my($data,@data,$num,$name); - my $retval = PerfLibGetHelp($machine,$data); - if($retval) - { - @data = split(/\0/, $data); - while(@data) - { - $num = shift @data; - $name = shift @data; - $href->{$num} = $name; - } - } - $retval; -} - -sub GetObjectList -{ - my $self = shift; - my $object = shift; - my $data = shift; - if(ref $data ne "HASH") - { - croak("reference isn't a hash reference!\n"); - } - return PerfLibGetObjects($self->{handle}, $object, $data); -} - -sub GetCounterType -{ - my $type = shift; - my $retval; - if( &Win32::PerfLib::PERF_100NSEC_MULTI_TIMER == $type ) - { - $retval = "PERF_100NSEC_MULTI_TIMER"; - } - elsif( &Win32::PerfLib::PERF_100NSEC_MULTI_TIMER_INV == $type ) - { - $retval = "PERF_100NSEC_MULTI_TIMER_INV"; - } - elsif( &Win32::PerfLib::PERF_100NSEC_TIMER == $type ) - { - $retval = "PERF_100NSEC_TIMER"; - } - elsif( &Win32::PerfLib::PERF_100NSEC_TIMER_INV == $type ) - { - $retval = "PERF_100NSEC_TIMER_INV"; - } - elsif( &Win32::PerfLib::PERF_AVERAGE_BASE == $type ) - { - $retval = "PERF_AVERAGE_BASE"; - } - elsif( &Win32::PerfLib::PERF_AVERAGE_BULK == $type ) - { - $retval = "PERF_AVERAGE_BULK"; - } - elsif( &Win32::PerfLib::PERF_AVERAGE_TIMER == $type ) - { - $retval = "PERF_AVERAGE_TIMER"; - } - elsif( &Win32::PerfLib::PERF_COUNTER_BULK_COUNT == $type ) - { - $retval = "PERF_COUNTER_BULK_COUNT"; - } - elsif( &Win32::PerfLib::PERF_COUNTER_COUNTER == $type ) - { - $retval = "PERF_COUNTER_COUNTER"; - } - elsif( &Win32::PerfLib::PERF_COUNTER_DELTA == $type ) - { - $retval = "PERF_COUNTER_DELTA"; - } - elsif( &Win32::PerfLib::PERF_COUNTER_LARGE_DELTA == $type ) - { - $retval = "PERF_COUNTER_LARGE_DELTA"; - } - elsif( &Win32::PerfLib::PERF_COUNTER_LARGE_QUEUELEN_TYPE == $type ) - { - $retval = "PERF_COUNTER_LARGE_QUEUELEN_TYPE"; - } - elsif( &Win32::PerfLib::PERF_COUNTER_LARGE_RAWCOUNT == $type ) - { - $retval = "PERF_COUNTER_LARGE_RAWCOUNT"; - } - elsif( &Win32::PerfLib::PERF_COUNTER_LARGE_RAWCOUNT_HEX == $type ) - { - $retval = "PERF_COUNTER_LARGE_RAWCOUNT_HEX"; - } - elsif( &Win32::PerfLib::PERF_COUNTER_MULTI_BASE == $type ) - { - $retval = "PERF_COUNTER_MULTI_BASE"; - } - elsif( &Win32::PerfLib::PERF_COUNTER_MULTI_TIMER == $type ) - { - $retval = "PERF_COUNTER_MULTI_TIMER"; - } - elsif( &Win32::PerfLib::PERF_COUNTER_MULTI_TIMER_INV == $type ) - { - $retval = "PERF_COUNTER_MULTI_TIMER_INV"; - } - elsif( &Win32::PerfLib::PERF_COUNTER_NODATA == $type ) - { - $retval = "PERF_COUNTER_NODATA"; - } - elsif( &Win32::PerfLib::PERF_COUNTER_QUEUELEN_TYPE == $type ) - { - $retval = "PERF_COUNTER_QUEUELEN_TYPE"; - } - elsif( &Win32::PerfLib::PERF_COUNTER_RAWCOUNT == $type ) - { - $retval = "PERF_COUNTER_RAWCOUNT"; - } - elsif( &Win32::PerfLib::PERF_COUNTER_RAWCOUNT_HEX == $type ) - { - $retval = "PERF_COUNTER_RAWCOUNT_HEX"; - } - elsif( &Win32::PerfLib::PERF_COUNTER_TEXT == $type ) - { - $retval = "PERF_COUNTER_TEXT"; - } - elsif( &Win32::PerfLib::PERF_COUNTER_TIMER == $type ) - { - $retval = "PERF_COUNTER_TIMER"; - } - elsif( &Win32::PerfLib::PERF_COUNTER_TIMER_INV == $type ) - { - $retval = "PERF_COUNTER_TIMER_INV"; - } - elsif( &Win32::PerfLib::PERF_ELAPSED_TIME == $type ) - { - $retval = "PERF_ELAPSED_TIME"; - } - elsif( &Win32::PerfLib::PERF_RAW_BASE == $type ) - { - $retval = "PERF_RAW_BASE"; - } - elsif( &Win32::PerfLib::PERF_RAW_FRACTION == $type ) - { - $retval = "PERF_RAW_FRACTION"; - } - elsif( &Win32::PerfLib::PERF_SAMPLE_BASE == $type ) - { - $retval = "PERF_SAMPLE_BASE"; - } - elsif( &Win32::PerfLib::PERF_SAMPLE_COUNTER == $type ) - { - $retval = "PERF_SAMPLE_COUNTER"; - } - elsif( &Win32::PerfLib::PERF_SAMPLE_FRACTION == $type ) - { - $retval = "PERF_SAMPLE_FRACTION"; - } - $retval; -} - - - -1; -__END__ - -=head1 NAME - -Win32::PerfLib - accessing the Windows NT Performance Counter - -=head1 SYNOPSIS - - use Win32::PerfLib; - my $server = ""; - Win32::PerfLib::GetCounterNames($server, \%counter); - %r_counter = map { $counter{$_} => $_ } keys %counter; - # retrieve the id for process object - $process_obj = $r_counter{Process}; - # retrieve the id for the process ID counter - $process_id = $r_counter{'ID Process'}; - - # create connection to $server - $perflib = new Win32::PerfLib($server); - $proc_ref = {}; - # get the performance data for the process object - $perflib->GetObjectList($process_obj, $proc_ref); - $perflib->Close(); - $instance_ref = $proc_ref->{Objects}->{$process_obj}->{Instances}; - foreach $p (sort keys %{$instance_ref}) - { - $counter_ref = $instance_ref->{$p}->{Counters}; - foreach $i (keys %{$counter_ref}) - { - if($counter_ref->{$i}->{CounterNameTitleIndex} == $process_id) - { - printf( "% 6d %s\n", $counter_ref->{$i}->{Counter}, - $instance_ref->{$p}->{Name} - ); - } - } - } - -=head1 DESCRIPTION - -This module allows to retrieve the performance counter of any computer -(running Windows NT) in the network. - -=head1 FUNCTIONS - -=head2 NOTE - -All of the functions return false if they fail, unless otherwise noted. -If the $server argument is undef the local machine is assumed. - -=over 10 - -=item Win32::PerfLib::GetCounterNames($server,$hashref) - -Retrieves the counter names and their indices from the registry and stores them -in the hash reference - -=item Win32::PerfLib::GetCounterHelp($server,$hashref) - -Retrieves the counter help strings and their indices from the registry and -stores them in the hash reference - -=item $perflib = Win32::PerfLib->new ($server) - -Creates a connection to the performance counters of the given server - -=item $perflib->GetObjectList($objectid,$hashref) - -retrieves the object and counter list of the given performance object. - -=item $perflib->Close($hashref) - -closes the connection to the performance counters - -=item Win32::PerfLib::GetCounterType(countertype) - -converts the counter type to readable string as referenced in L<calc.html> so -that it is easier to find the appropriate formula to calculate the raw counter -data. - -=back - -=head1 Datastructures - -The performance data is returned in the following data structure: - -=over 10 - -=item Level 1 - - $hashref = { - 'NumObjectTypes' => VALUE - 'Objects' => HASHREF - 'PerfFreq' => VALUE - 'PerfTime' => VALUE - 'PerfTime100nSec' => VALUE - 'SystemName' => STRING - 'SystemTime' => VALUE - } - -=item Level 2 - -The hash reference $hashref->{Objects} has the returned object ID(s) as keys and -a hash reference to the object counter data as value. Even there is only one -object requested in the call to GetObjectList there may be more than one object -in the result. - - $hashref->{Objects} = { - <object1> => HASHREF - <object2> => HASHREF - ... - } - -=item Level 3 - -Each returned object ID has object-specific performance information. If an -object has instances like the process object there is also a reference to -the instance information. - - $hashref->{Objects}->{<object1>} = { - 'DetailLevel' => VALUE - 'Instances' => HASHREF - 'Counters' => HASHREF - 'NumCounters' => VALUE - 'NumInstances' => VALUE - 'ObjectHelpTitleIndex' => VALUE - 'ObjectNameTitleIndex' => VALUE - 'PerfFreq' => VALUE - 'PerfTime' => VALUE - } - -=item Level 4 - -If there are instance information for the object available they are stored in -the 'Instances' hashref. If the object has no instances there is an 'Counters' -key instead. The instances or counters are numbered. - - $hashref->{Objects}->{<object1>}->{Instances} = { - <1> => HASHREF - <2> => HASHREF - ... - <n> => HASHREF - } - or - $hashref->{Objects}->{<object1>}->{Counters} = { - <1> => HASHREF - <2> => HASHREF - ... - <n> => HASHREF - } - -=item Level 5 - - $hashref->{Objects}->{<object1>}->{Instances}->{<1>} = { - Counters => HASHREF - Name => STRING - ParentObjectInstance => VALUE - ParentObjectTitleIndex => VALUE - } - or - $hashref->{Objects}->{<object1>}->{Counters}->{<1>} = { - Counter => VALUE - CounterHelpTitleIndex => VALUE - CounterNameTitleIndex => VALUE - CounterSize => VALUE - CounterType => VALUE - DefaultScale => VALUE - DetailLevel => VALUE - Display => STRING - } - -=item Level 6 - - $hashref->{Objects}->{<object1>}->{Instances}->{<1>}->{Counters} = { - <1> => HASHREF - <2> => HASHREF - ... - <n> => HASHREF - } - -=item Level 7 - - $hashref->{Objects}->{<object1>}->{Instances}->{<1>}->{Counters}->{<1>} = { - Counter => VALUE - CounterHelpTitleIndex => VALUE - CounterNameTitleIndex => VALUE - CounterSize => VALUE - CounterType => VALUE - DefaultScale => VALUE - DetailLevel => VALUE - Display => STRING - } - -Depending on the B<CounterType> there are calculations to do (see calc.html). - -=back - -=head1 AUTHOR - -Jutta M. Klebe, jmk@bybyte.de - -=head1 SEE ALSO - -perl(1). - -=cut diff --git a/Master/tlpkg/tlperl/lib/Win32/Pipe.pm b/Master/tlpkg/tlperl/lib/Win32/Pipe.pm deleted file mode 100644 index a99d5a0da08..00000000000 --- a/Master/tlpkg/tlperl/lib/Win32/Pipe.pm +++ /dev/null @@ -1,414 +0,0 @@ -package Win32::Pipe; - -$VERSION = '0.022'; - -# Win32::Pipe.pm -# +==========================================================+ -# | | -# | PIPE.PM package | -# | --------------- | -# | Release v96.05.11 | -# | | -# | Copyright (c) 1996 Dave Roth. All rights reserved. | -# | This program is free software; you can redistribute | -# | it and/or modify it under the same terms as Perl itself. | -# | | -# +==========================================================+ -# -# -# Use under GNU General Public License or Larry Wall's "Artistic License" -# -# Check the README.TXT file that comes with this package for details about -# it's history. -# - -require Exporter; -require DynaLoader; - -@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(); - -$ErrorNum = 0; -$ErrorText = ""; - -sub new -{ - my ($self, $Pipe); - my ($Type, $Name, $Time) = @_; - - if (! $Time){ - $Time = DEFAULT_WAIT_TIME(); - } - $Pipe = PipeCreate($Name, $Time); - if ($Pipe){ - $self = bless {}; - $self->{'Pipe'} = $Pipe; - }else{ - ($ErrorNum, $ErrorText) = PipeError(); - return undef; - } - $self; -} - -sub Write{ - my($self, $Data) = @_; - $Data = PipeWrite($self->{'Pipe'}, $Data); - return $Data; -} - -sub Read{ - my($self) = @_; - my($Data); - $Data = PipeRead($self->{'Pipe'}); - return $Data; -} - -sub Error{ - my($self) = @_; - my($MyError, $MyErrorText, $Temp); - if (! ref($self)){ - undef $Temp; - }else{ - $Temp = $self->{'Pipe'}; - } - ($MyError, $MyErrorText) = PipeError($Temp); - return wantarray? ($MyError, $MyErrorText):"[$MyError] \"$MyErrorText\""; -} - - -sub Close{ - my ($self) = shift; - PipeClose($self->{'Pipe'}); - $self->{'Pipe'} = 0; -} - -sub Connect{ - my ($self) = @_; - my ($Result); - $Result = PipeConnect($self->{'Pipe'}); - return $Result; -} - -sub Disconnect{ - my ($self, $iPurge) = @_; - my ($Result); - if (! $iPurge){ - $iPurge = 1; - } - $Result = PipeDisconnect($self->{'Pipe'}, $iPurge); - return $Result; -} - -sub BufferSize{ - my($self) = @_; - my($Result) = PipeBufferSize($self->{'Pipe'}); - return $Result; -} - -sub ResizeBuffer{ - my($self, $Size) = @_; - my($Result) = PipeResizeBuffer($self->{'Pipe'}, $Size); - return $Result; -} - - -#### -# Auto-Kill an instance of this module -#### -sub DESTROY -{ - my ($self) = shift; - Close($self); -} - - -sub Credit{ - my($Name, $Version, $Date, $Author, $CompileDate, $CompileTime, $Credits) = Win32::Pipe::Info(); - my($Out, $iWidth); - $iWidth = 60; - $Out .= "\n"; - $Out .= " +". "=" x ($iWidth). "+\n"; - $Out .= " |". Center("", $iWidth). "|\n"; - $Out .= " |" . Center("", $iWidth). "|\n"; - $Out .= " |". Center("$Name", $iWidth). "|\n"; - $Out .= " |". Center("-" x length("$Name"), $iWidth). "|\n"; - $Out .= " |". Center("", $iWidth). "|\n"; - - $Out .= " |". Center("Version $Version ($Date)", $iWidth). "|\n"; - $Out .= " |". Center("by $Author", $iWidth). "|\n"; - $Out .= " |". Center("Compiled on $CompileDate at $CompileTime.", $iWidth). "|\n"; - $Out .= " |". Center("", $iWidth). "|\n"; - $Out .= " |". Center("Credits:", $iWidth). "|\n"; - $Out .= " |". Center(("-" x length("Credits:")), $iWidth). "|\n"; - foreach $Temp (split("\n", $Credits)){ - $Out .= " |". Center("$Temp", $iWidth). "|\n"; - } - $Out .= " |". Center("", $iWidth). "|\n"; - $Out .= " +". "=" x ($iWidth). "+\n"; - return $Out; -} - -sub Center{ - local($Temp, $Width) = @_; - local($Len) = ($Width - length($Temp)) / 2; - return " " x int($Len) . $Temp . " " x (int($Len) + (($Len != int($Len))? 1:0)); -} - -# ------------------ A U T O L O A D F U N C T I O N --------------------- - -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; - $val = constant($constname, @_ ? $_[0] : 0); - - if ($! != 0) { - if ($! =~ /Invalid/) { - $AutoLoader::AUTOLOAD = $AUTOLOAD; - goto &AutoLoader::AUTOLOAD; - } - else { - - # Added by JOC 06-APR-96 - # $pack = 0; - $pack = 0; - ($pack,$file,$line) = caller; - print "Your vendor has not defined Win32::Pipe macro $constname, used in $file at line $line."; - } - } - eval "sub $AUTOLOAD { $val }"; - goto &$AUTOLOAD; -} - -bootstrap Win32::Pipe; - -1; -__END__ - -=head1 NAME - -Win32::Pipe - Win32 Named Pipe - -=head1 SYNOPSIS - -To use this extension, follow these basic steps. First, you need to -'use' the pipe extension: - - use Win32::Pipe; - -Then you need to create a server side of a named pipe: - - $Pipe = new Win32::Pipe("My Pipe Name"); - -or if you are going to connect to pipe that has already been created: - - $Pipe = new Win32::Pipe("\\\\server\\pipe\\My Pipe Name"); - - NOTE: The "\\\\server\\pipe\\" is necessary when connecting - to an existing pipe! If you are accessing the same - machine you could use "\\\\.\\pipe\\" but either way - works fine. - -You should check to see if C<$Pipe> is indeed defined otherwise there -has been an error. - -Whichever end is the server, it must now wait for a connection... - - $Result = $Pipe->Connect(); - - NOTE: The client end does not do this! When the client creates - the pipe it has already connected! - -Now you can read and write data from either end of the pipe: - - $Data = $Pipe->Read(); - - $Result = $Pipe->Write("Howdy! This is cool!"); - -When the server is finished it must disconnect: - - $Pipe->Disconnect(); - -Now the server could C<Connect> again (and wait for another client) or -it could destroy the named pipe... - - $Data->Close(); - -The client should C<Close> in order to properly end the session. - -=head1 DESCRIPTION - -=head2 General Use - -This extension gives Win32 Perl the ability to use Named Pipes. Why? -Well considering that Win32 Perl does not (yet) have the ability to -C<fork> I could not see what good the C<pipe(X,Y)> was. Besides, where -I am as an admin I must have several perl daemons running on several -NT Servers. It dawned on me one day that if I could pipe all these -daemons' output to my workstation (across the net) then it would be -much easier to monitor. This was the impetus for an extension using -Named Pipes. I think that it is kinda cool. :) - -=head2 Benefits - -And what are the benefits of this module? - -=over - -=item * - -You may create as many named pipes as you want (uh, well, as many as -your resources will allow). - -=item * - -Currently there is a limit of 256 instances of a named pipe (once a -pipe is created you can have 256 client/server connections to that -name). - -=item * - -The default buffer size is 512 bytes; this can be altered by the -C<ResizeBuffer> method. - -=item * - -All named pipes are byte streams. There is currently no way to alter a -pipe to be message based. - -=item * - -Other things that I cannot think of right now... :) - -=back - -=head1 CONSTRUCTOR - -=over - -=item new ( NAME ) - -Creates a named pipe if used in server context or a connection to the -specified named pipe if used in client context. Client context is -determined by prepending $Name with "\\\\". - -Returns I<true> on success, I<false> on failure. - -=back - -=head1 METHODS - -=over - -=item BufferSize () - -Returns the size of the instance of the buffer of the named pipe. - -=item Connect () - -Tells the named pipe to create an instance of the named pipe and wait -until a client connects. Returns I<true> on success, I<false> on -failure. - -=item Close () - -Closes the named pipe. - -=item Disconnect () - -Disconnects (and destroys) the instance of the named pipe from the -client. Returns I<true> on success, I<false> on failure. - -=item Error () - -Returns the last error messages pertaining to the named pipe. If used -in context to the package. Returns a list containing C<ERROR_NUMBER> -and C<ERROR_TEXT>. - -=item Read () - -Reads from the named pipe. Returns data read from the pipe on success, -undef on failure. - -=item ResizeBuffer ( SIZE ) - -Sets the size of the buffer of the instance of the named pipe to -C<SIZE>. Returns the size of the buffer on success, I<false> on -failure. - -=item Write ( DATA ) - -Writes C<DATA> to the named pipe. Returns I<true> on success, I<false> -on failure. - -=back - -=head1 LIMITATIONS - -What known problems does this thing have? - -=over - -=item * - -If someone is waiting on a C<Read> and the other end terminates then -you will wait for one B<REALLY> long time! (If anyone has an idea on -how I can detect the termination of the other end let me know!) - -=item * - -All pipes are blocking. I am considering using threads and callbacks -into Perl to perform async IO but this may be too much for my time -stress. ;) - -=item * - -There is no security placed on these pipes. - -=item * - -This module has neither been optimized for speed nor optimized for -memory consumption. This may run into memory bloat. - -=back - -=head1 INSTALLATION NOTES - -If you wish to use this module with a build of Perl other than -ActivePerl, you may wish to fetch the source distribution for this -module. The source is included as part of the C<libwin32> bundle, -which you can find in any CPAN mirror here: - - modules/by-authors/Gurusamy_Sarathy/libwin32-0.151.tar.gz - -The source distribution also contains a pair of sample client/server -test scripts. For the latest information on this module, consult the -following web site: - - http://www.roth.net/perl - -=head1 AUTHOR - -Dave Roth <rothd@roth.net> - -=head1 DISCLAIMER - -I do not guarantee B<ANYTHING> with this package. If you use it you -are doing so B<AT YOUR OWN RISK>! I may or may not support this -depending on my time schedule. - -=head1 COPYRIGHT - -Copyright (c) 1996 Dave Roth. All rights reserved. -This program is free software; you can redistribute -it and/or modify it under the same terms as Perl itself. - -=cut diff --git a/Master/tlpkg/tlperl/lib/Win32/Process.pm b/Master/tlpkg/tlperl/lib/Win32/Process.pm deleted file mode 100644 index f07169b4080..00000000000 --- a/Master/tlpkg/tlperl/lib/Win32/Process.pm +++ /dev/null @@ -1,217 +0,0 @@ -package Win32::Process; - -require Exporter; -require DynaLoader; -@ISA = qw(Exporter DynaLoader); - -$VERSION = '0.10'; - -# 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 -); - -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). - -=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: - - STILL_ACTIVE - -=cut - -# Local Variables: -# tmtrack-file-task: "Win32::Process" -# End: diff --git a/Master/tlpkg/tlperl/lib/Win32/Registry.pm b/Master/tlpkg/tlperl/lib/Win32/Registry.pm deleted file mode 100644 index c83fca5a3b1..00000000000 --- a/Master/tlpkg/tlperl/lib/Win32/Registry.pm +++ /dev/null @@ -1,547 +0,0 @@ -package Win32::Registry; - -=head1 NAME - -Win32::Registry - accessing the Windows registry [obsolete, use Win32::TieRegistry] - -=head1 SYNOPSIS - - use Win32::Registry; - my $tips; - $::HKEY_LOCAL_MACHINE->Open("SOFTWARE\\Microsoft\\Windows" - ."\\CurrentVersion\\Explorer\\Tips", $tips) - or die "Can't open tips: $^E"; - my ($type, $value); - $tips->QueryValueEx("18", $type, $value) or die "No tip #18: $^E"; - print "Here's a tip: $value\n"; - -=head1 DESCRIPTION - - NOTE: This module provides a very klunky interface to access the - Windows registry, and is not currently being developed actively. It - only exists for backward compatibility with old code that uses it. - For more powerful and flexible ways to access the registry, use - Win32::TieRegistry. - -Win32::Registry provides an object oriented interface to the Windows -Registry. - -The following "root" registry objects are exported to the main:: name -space. Additional keys must be opened by calling the provided methods -on one of these. - - $HKEY_CLASSES_ROOT - $HKEY_CURRENT_USER - $HKEY_LOCAL_MACHINE - $HKEY_USERS - $HKEY_PERFORMANCE_DATA - $HKEY_CURRENT_CONFIG - $HKEY_DYN_DATA - -=cut - -use strict; -require Exporter; -require DynaLoader; -use Win32::WinError; - -require Win32 unless defined &Win32::GetLastError; - -use vars qw($VERSION $AUTOLOAD @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); - -$VERSION = '0.07'; - -@ISA = qw( Exporter DynaLoader ); -@EXPORT = qw( - HKEY_CLASSES_ROOT - HKEY_CURRENT_USER - HKEY_LOCAL_MACHINE - HKEY_PERFORMANCE_DATA - HKEY_CURRENT_CONFIG - HKEY_DYN_DATA - HKEY_USERS - KEY_ALL_ACCESS - KEY_CREATE_LINK - KEY_CREATE_SUB_KEY - KEY_ENUMERATE_SUB_KEYS - KEY_EXECUTE - KEY_NOTIFY - KEY_QUERY_VALUE - KEY_READ - KEY_SET_VALUE - KEY_WRITE - REG_BINARY - REG_CREATED_NEW_KEY - REG_DWORD - REG_DWORD_BIG_ENDIAN - REG_DWORD_LITTLE_ENDIAN - REG_EXPAND_SZ - REG_FULL_RESOURCE_DESCRIPTOR - REG_LEGAL_CHANGE_FILTER - REG_LEGAL_OPTION - REG_LINK - REG_MULTI_SZ - REG_NONE - REG_NOTIFY_CHANGE_ATTRIBUTES - REG_NOTIFY_CHANGE_LAST_SET - REG_NOTIFY_CHANGE_NAME - REG_NOTIFY_CHANGE_SECURITY - REG_OPENED_EXISTING_KEY - REG_OPTION_BACKUP_RESTORE - REG_OPTION_CREATE_LINK - REG_OPTION_NON_VOLATILE - REG_OPTION_RESERVED - REG_OPTION_VOLATILE - REG_REFRESH_HIVE - REG_RESOURCE_LIST - REG_RESOURCE_REQUIREMENTS_LIST - REG_SZ - REG_WHOLE_HIVE_VOLATILE -); - -@EXPORT_OK = qw( - RegCloseKey - RegConnectRegistry - RegCreateKey - RegCreateKeyEx - RegDeleteKey - RegDeleteValue - RegEnumKey - RegEnumValue - RegFlushKey - RegGetKeySecurity - RegLoadKey - RegNotifyChangeKeyValue - RegOpenKey - RegOpenKeyEx - RegQueryInfoKey - RegQueryValue - RegQueryValueEx - RegReplaceKey - RegRestoreKey - RegSaveKey - RegSetKeySecurity - RegSetValue - RegSetValueEx - RegUnLoadKey -); -$EXPORT_TAGS{ALL}= \@EXPORT_OK; - -bootstrap Win32::Registry; - -sub import { - my $pkg = shift; - if ($_[0] && "Win32" eq $_[0]) { - Exporter::export($pkg, "Win32", @EXPORT_OK); - shift; - } - Win32::Registry->export_to_level(1+$Exporter::ExportLevel, $pkg, @_); -} - -####################################################################### -# This AUTOLOAD is used to 'autoload' constants from the constant() -# XS function. If a constant is not found then control is passed -# to the AUTOLOAD in AutoLoader. - -sub AUTOLOAD { - my($constname); - ($constname = $AUTOLOAD) =~ s/.*:://; - #reset $! to zero to reset any current errors. - local $! = 0; - my $val = constant($constname, 0); - if ($! != 0) { - if ($! =~ /Invalid/) { - $AutoLoader::AUTOLOAD = $AUTOLOAD; - goto &AutoLoader::AUTOLOAD; - } - else { - my ($pack,$file,$line) = caller; - die "Unknown constant $constname in Win32::Registry " - . "at $file line $line.\n"; - } - } - eval "sub $AUTOLOAD { $val }"; - goto &$AUTOLOAD; -} - -####################################################################### -# _new is a private constructor, not intended for public use. -# - -sub _new { - my $self; - if ($_[0]) { - $self->{'handle'} = $_[0]; - bless $self; - } - $self; -} - -#define the basic registry objects to be exported. -#these had to be hardwired unfortunately. -# XXX Yuck! - -{ - package main; - use vars qw( - $HKEY_CLASSES_ROOT - $HKEY_CURRENT_USER - $HKEY_LOCAL_MACHINE - $HKEY_USERS - $HKEY_PERFORMANCE_DATA - $HKEY_CURRENT_CONFIG - $HKEY_DYN_DATA - ); -} - -$::HKEY_CLASSES_ROOT = _new(&HKEY_CLASSES_ROOT); -$::HKEY_CURRENT_USER = _new(&HKEY_CURRENT_USER); -$::HKEY_LOCAL_MACHINE = _new(&HKEY_LOCAL_MACHINE); -$::HKEY_USERS = _new(&HKEY_USERS); -$::HKEY_PERFORMANCE_DATA = _new(&HKEY_PERFORMANCE_DATA); -$::HKEY_CURRENT_CONFIG = _new(&HKEY_CURRENT_CONFIG); -$::HKEY_DYN_DATA = _new(&HKEY_DYN_DATA); - -=head2 Methods - -The following methods are supported. Note that subkeys can be -specified as a path name, separated by backslashes (which may -need to be doubled if you put them in double quotes). - -=over 8 - -=item Open - - $reg_obj->Open($sub_key_name, $sub_reg_obj); - -Opens a subkey of a registry object, returning the new registry object -in $sub_reg_obj. - -=cut - -sub Open { - my $self = shift; - die 'usage: $obj->Open($sub_key_name, $sub_reg_obj)' if @_ != 2; - - my ($subkey) = @_; - my ($result,$subhandle); - - $result = RegOpenKey($self->{'handle'},$subkey,$subhandle); - $_[1] = _new($subhandle); - - return 0 unless $_[1]; - $! = Win32::GetLastError() unless $result; - return $result; -} - -=item Close - - $reg_obj->Close(); - -Closes an open registry key. - -=cut - -sub Close { - my $self = shift; - die 'usage: $obj->Close()' if @_ != 0; - - return unless exists $self->{'handle'}; - my $result = RegCloseKey($self->{'handle'}); - if ($result) { - delete $self->{'handle'}; - } - else { - $! = Win32::GetLastError(); - } - return $result; -} - -sub DESTROY { - my $self = shift; - return unless exists $self->{'handle'}; - RegCloseKey($self->{'handle'}); - delete $self->{'handle'}; -} - - -=item Connect - - $reg_obj->Connect($node_name, $new_reg_obj); - -Connects to a remote Registry on the node specified by $node_name, -returning it in $new_reg_obj. Returns false if it fails. - -=cut - -sub Connect { - my $self = shift; - die 'usage: $obj->Connect($node_name, $new_reg_obj)' if @_ != 2; - - my ($node) = @_; - my ($result,$subhandle); - - $result = RegConnectRegistry ($node, $self->{'handle'}, $subhandle); - $_[1] = _new($subhandle); - - return 0 unless $_[1]; - $! = Win32::GetLastError() unless $result; - return $result; -} - -=item Create - - $reg_obj->Create($sub_key_name, $new_reg_obj); - -Opens the subkey specified by $sub_key_name, returning the new registry -object in $new_reg_obj. If the specified subkey doesn't exist, it is -created. - -=cut - -sub Create { - my $self = shift; - die 'usage: $obj->Create($sub_key_name, $new_reg_obj)' if @_ != 2; - - my ($subkey) = @_; - my ($result,$subhandle); - - $result = RegCreateKey($self->{'handle'},$subkey,$subhandle); - $_[1] = _new ($subhandle); - - return 0 unless $_[1]; - $! = Win32::GetLastError() unless $result; - return $result; -} - -=item SetValue - - $reg_obj->SetValue($sub_key_name, $type, $value); - -Sets the default value for a subkey specified by $sub_key_name. - -=cut - -sub SetValue { - my $self = shift; - die 'usage: $obj->SetValue($subkey, $type, $value)' if @_ != 3; - my $result = RegSetValue($self->{'handle'}, @_); - $! = Win32::GetLastError() unless $result; - return $result; -} - -=item SetValueEx - - $reg_obj->SetValueEx($value_name, $reserved, $type, $value); - -Sets the value for the value name identified by $value_name -in the key specified by $reg_obj. - -=cut - -sub SetValueEx { - my $self = shift; - die 'usage: $obj->SetValueEx($value_name, $reserved, $type, $value)' if @_ != 4; - my $result = RegSetValueEx($self->{'handle'}, @_); - $! = Win32::GetLastError() unless $result; - return $result; -} - -=item QueryValue - - $reg_obj->QueryValue($sub_key_name, $value); - -Gets the default value of the subkey specified by $sub_key_name. - -=cut - -sub QueryValue { - my $self = shift; - die 'usage: $obj->QueryValue($sub_key_name, $value)' if @_ != 2; - my $result = RegQueryValue($self->{'handle'}, $_[0], $_[1]); - $! = Win32::GetLastError() unless $result; - return $result; -} - -=item QueryKey - - $reg_obj->QueryKey($classref, $number_of_subkeys, $number_of_values); - -Gets information on a key specified by $reg_obj. - -=cut - -sub QueryKey { - my $garbage; - my $self = shift; - die 'usage: $obj->QueryKey($classref, $number_of_subkeys, $number_of_values)' - if @_ != 3; - - my $result = RegQueryInfoKey($self->{'handle'}, $_[0], - $garbage, $garbage, $_[1], - $garbage, $garbage, $_[2], - $garbage, $garbage, $garbage, $garbage); - - $! = Win32::GetLastError() unless $result; - return $result; -} - -=item QueryValueEx - - $reg_obj->QueryValueEx($value_name, $type, $value); - -Gets the value for the value name identified by $value_name -in the key specified by $reg_obj. - -=cut - -sub QueryValueEx { - my $self = shift; - die 'usage: $obj->QueryValueEx($value_name, $type, $value)' if @_ != 3; - my $result = RegQueryValueEx($self->{'handle'}, $_[0], undef, $_[1], $_[2]); - $! = Win32::GetLastError() unless $result; - return $result; -} - -=item GetKeys - - my @keys; - $reg_obj->GetKeys(\@keys); - -Populates the supplied array reference with the names of all the keys -within the registry object $reg_obj. - -=cut - -sub GetKeys { - my $self = shift; - die 'usage: $obj->GetKeys($arrayref)' if @_ != 1 or ref($_[0]) ne 'ARRAY'; - - my ($result, $i, $keyname); - $keyname = "DummyVal"; - $i = 0; - $result = 1; - - while ( $result ) { - $result = RegEnumKey( $self->{'handle'},$i++, $keyname ); - if ($result) { - push( @{$_[0]}, $keyname ); - } - } - return(1); -} - -=item GetValues - - my %values; - $reg_obj->GetValues(\%values); - -Populates the supplied hash reference with entries of the form - - $value_name => [ $value_name, $type, $data ] - -for each value in the registry object $reg_obj. - -=cut - -sub GetValues { - my $self = shift; - die 'usage: $obj->GetValues($hashref)' if @_ != 1; - - my ($result,$name,$type,$data,$i); - $name = "DummyVal"; - $i = 0; - while ( $result=RegEnumValue( $self->{'handle'}, - $i++, - $name, - undef, - $type, - $data )) - { - $_[0]->{$name} = [ $name, $type, $data ]; - } - return(1); -} - -=item DeleteKey - - $reg_obj->DeleteKey($sub_key_name); - -Deletes a subkey specified by $sub_key_name from the registry. - -=cut - -sub DeleteKey { - my $self = shift; - die 'usage: $obj->DeleteKey($sub_key_name)' if @_ != 1; - my $result = RegDeleteKey($self->{'handle'}, @_); - $! = Win32::GetLastError() unless $result; - return $result; -} - -=item DeleteValue - - $reg_obj->DeleteValue($value_name); - -Deletes a value identified by $value_name from the registry. - -=cut - -sub DeleteValue { - my $self = shift; - die 'usage: $obj->DeleteValue($value_name)' if @_ != 1; - my $result = RegDeleteValue($self->{'handle'}, @_); - $! = Win32::GetLastError() unless $result; - return $result; -} - -=item Save - - $reg_obj->Save($filename); - -Saves the hive specified by $reg_obj to a file. - -=cut - -sub Save { - my $self = shift; - die 'usage: $obj->Save($filename)' if @_ != 1; - my $result = RegSaveKey($self->{'handle'}, @_); - $! = Win32::GetLastError() unless $result; - return $result; -} - -=item Load - - $reg_obj->Load($sub_key_name, $file_name); - -Loads a key specified by $sub_key_name from a file. - -=cut - -sub Load { - my $self = shift; - die 'usage: $obj->Load($sub_key_name, $file_name)' if @_ != 2; - my $result = RegLoadKey($self->{'handle'}, @_); - $! = Win32::GetLastError() unless $result; - return $result; -} - -=item UnLoad - - $reg_obj->Unload($sub_key_name); - -Unloads a registry hive. - -=cut - -sub UnLoad { - my $self = shift; - die 'usage: $obj->UnLoad($sub_key_name)' if @_ != 1; - my $result = RegUnLoadKey($self->{'handle'}, @_); - $! = Win32::GetLastError() unless $result; - return $result; -} - -1; -__END__ diff --git a/Master/tlpkg/tlperl/lib/Win32/Semaphore.pm b/Master/tlpkg/tlperl/lib/Win32/Semaphore.pm deleted file mode 100644 index 2e2096eb6ed..00000000000 --- a/Master/tlpkg/tlperl/lib/Win32/Semaphore.pm +++ /dev/null @@ -1,128 +0,0 @@ -#--------------------------------------------------------------------- -package Win32::Semaphore; -# -# Copyright 1998 Christopher J. Madsen -# -# Created: 3 Feb 1998 from the ActiveWare version -# (c) 1995 Microsoft Corporation. All rights reserved. -# Developed by ActiveWare Internet Corp., http://www.ActiveWare.com -# -# Other modifications (c) 1997 by Gurusamy Sarathy <gsar@activestate.com> -# -# Author: Christopher J. Madsen <cjm@pobox.com> -# Version: 1.00 (6-Feb-1998) -# -# This program is free software; you can redistribute it and/or modify -# it under the same terms as Perl itself. -# -# This program is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See either the -# GNU General Public License or the Artistic License for more details. -# -# Use Win32 semaphore objects for synchronization -#--------------------------------------------------------------------- - -$VERSION = '1.02'; - -use Win32::IPC 1.00 '/./'; # Import everything -require Exporter; -require DynaLoader; - -@ISA = qw(Exporter DynaLoader Win32::IPC); -@EXPORT_OK = qw( - wait_all wait_any -); - -bootstrap Win32::Semaphore; - -sub Create { $_[0] = new('Win32::Semaphore',@_[1..3]) } -sub Open { $_[0] = Win32::Semaphore->open($_[1]) } -sub Release { &release } - -1; -__END__ - -=head1 NAME - -Win32::Semaphore - Use Win32 semaphore objects from Perl - -=head1 SYNOPSIS - require Win32::Semaphore; - - $sem = Win32::Semaphore->new($initial,$maximum,$name); - $sem->wait; - -=head1 DESCRIPTION - -This module allows access to Win32 semaphore objects. The C<wait> -method and C<wait_all> & C<wait_any> functions are inherited from the -L<"Win32::IPC"> module. - -=head2 Methods - -=over 4 - -=item $semaphore = Win32::Semaphore->new($initial, $maximum, [$name]) - -Constructor for a new semaphore object. C<$initial> is the initial -count, and C<$maximum> is the maximum count for the semaphore. If -C<$name> is omitted, creates an unnamed semaphore object. - -If C<$name> signifies an existing semaphore object, then C<$initial> -and C<$maximum> are ignored and the object is opened. If this -happens, C<$^E> will be set to 183 (ERROR_ALREADY_EXISTS). - -=item $semaphore = Win32::Semaphore->open($name) - -Constructor for opening an existing semaphore object. - -=item $semaphore->release([$increment, [$previous]]) - -Increment the count of C<$semaphore> by C<$increment> (default 1). -If C<$increment> plus the semaphore's current count is more than its -maximum count, the count is not changed. Returns true if the -increment is successful. - -The semaphore's count (before incrementing) is stored in the second -argument (if any). - -It is not necessary to wait on a semaphore before calling C<release>, -but you'd better know what you're doing. - -=item $semaphore->wait([$timeout]) - -Wait for C<$semaphore>'s count to be nonzero, then decrement it by 1. -See L<"Win32::IPC">. - -=back - -=head2 Deprecated Functions and Methods - -B<Win32::Semaphore> still supports the ActiveWare syntax, but its use -is deprecated. - -=over 4 - -=item Win32::Semaphore::Create($SemObject,$Initial,$Max,$Name) - -Use C<$SemObject = Win32::Semaphore-E<gt>new($Initial,$Max,$Name)> instead. - -=item Win32::Semaphore::Open($SemObject, $Name) - -Use C<$SemObject = Win32::Semaphore-E<gt>open($Name)> instead. - -=item $SemObj->Release($Count,$LastVal) - -Use C<$SemObj-E<gt>release($Count,$LastVal)> instead. - -=back - -=head1 AUTHOR - -Christopher J. Madsen E<lt>F<cjm@pobox.com>E<gt> - -Loosely based on the original module by ActiveWare Internet Corp., -F<http://www.ActiveWare.com> - -=cut diff --git a/Master/tlpkg/tlperl/lib/Win32/Server.pl b/Master/tlpkg/tlperl/lib/Win32/Server.pl deleted file mode 100644 index ecfb91ba864..00000000000 --- a/Master/tlpkg/tlperl/lib/Win32/Server.pl +++ /dev/null @@ -1,48 +0,0 @@ -use strict; -use Win32::Pipe; - -my $PipeName = "TEST this long named pipe!"; -my $NewSize = 2048; -my $iMessage; - -while () { - print "Creating pipe \"$PipeName\".\n"; - if (my $Pipe = new Win32::Pipe($PipeName)) { - my $PipeSize = $Pipe->BufferSize(); - print "This pipe's current size is $PipeSize byte" . (($PipeSize == 1)? "":"s") . ".\nWe shall change it to $NewSize ..."; - print +(($Pipe->ResizeBuffer($NewSize) == $NewSize)? "Successful":"Unsucessful") . "!\n\n"; - - print "\n\nR e a d y f o r r e a d i n g :\n"; - print "-----------------------------------\n"; - - print "Openning the pipe...\n"; - while ($Pipe->Connect()) { - while () { - ++$iMessage; - print "Reading Message #$iMessage: "; - my $In = $Pipe->Read(); - unless ($In) { - print "Recieved no data, closing connection....\n"; - last; - } - if ($In =~ /^quit/i){ - print "\n\nQuitting this connection....\n"; - last; - } - elsif ($In =~ /^exit/i){ - print "\n\nExitting.....\n"; - exit; - } - else{ - print "\"$In\"\n"; - } - } - print "Disconnecting...\n"; - $Pipe->Disconnect(); - } - print "Closing...\n"; - $Pipe->Close(); - } -} - -print "You can't get here...\n"; diff --git a/Master/tlpkg/tlperl/lib/Win32/Service.pm b/Master/tlpkg/tlperl/lib/Win32/Service.pm deleted file mode 100644 index 0ae33b13ef8..00000000000 --- a/Master/tlpkg/tlperl/lib/Win32/Service.pm +++ /dev/null @@ -1,103 +0,0 @@ -package Win32::Service; - -# -# Service.pm -# Written by Douglas_Lankshear@ActiveWare.com -# -# subsequently hacked by Gurusamy Sarathy <gsar@activestate.com> -# - -$VERSION = '0.05'; - -require Exporter; -require DynaLoader; - -require Win32 unless defined &Win32::IsWinNT; -die "The Win32::Service module works only on Windows NT" unless Win32::IsWinNT(); - -@ISA= qw( Exporter DynaLoader ); -@EXPORT_OK = - qw( - StartService - StopService - GetStatus - PauseService - ResumeService - GetServices - ); - -=head1 NAME - -Win32::Service - manage system services in perl - -=head1 SYNOPSIS - - use Win32::Service; - -=head1 DESCRIPTION - -This module offers control over the administration of system services. - -=head1 FUNCTIONS - -=head2 NOTE: - -All of the functions return false if they fail, unless otherwise noted. -If hostName is an empty string, the local machine is assumed. - -=over 10 - -=item StartService(hostName, serviceName) - -Start the service serviceName on machine hostName. - -=item StopService(hostName, serviceName) - -Stop the service serviceName on the machine hostName. - -=item GetStatus(hostName, serviceName, status) - -Get the status of a service. The third argument must be a hash -reference that will be populated with entries corresponding -to the SERVICE_STATUS structure of the Win32 API. See the -Win32 Platform SDK documentation for details of this structure. - -=item PauseService(hostName, serviceName) - -=item ResumeService(hostName, serviceName) - -=item GetServices(hostName, hashref) - -Enumerates both active and inactive Win32 services at the specified host. -The hashref is populated with the descriptive service names as keys -and the short names as the values. - -=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::Service macro $constname, used in $file at line $line."; - } - } - eval "sub $AUTOLOAD { $val }"; - goto &$AUTOLOAD; -} - -bootstrap Win32::Service; - -1; -__END__ diff --git a/Master/tlpkg/tlperl/lib/Win32/Shortcut.pm b/Master/tlpkg/tlperl/lib/Win32/Shortcut.pm deleted file mode 100644 index d4dadafdcf2..00000000000 --- a/Master/tlpkg/tlperl/lib/Win32/Shortcut.pm +++ /dev/null @@ -1,323 +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.04"; - -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 $self = {}; - my $ilink = 0; - my $ifile = 0; - - ($ilink, $ifile) = _Instance(); - - if($ilink and $ifile) { - $self->{'ilink'} = $ilink; - $self->{'ifile'} = $ifile; - bless $self; - # Initialize properties - $self->{'File'} = ""; - $self->{'Path'} = ""; - $self->{'Arguments'} = ""; - $self->{'WorkingDirectory'} = ""; - $self->{'Description'} = ""; - $self->{'ShowCmd'} = 0; - $self->{'Hotkey'} = 0; - $self->{'IconLocation'} = ""; - $self->{'IconNumber'} = 0; - - $self->Load($file) if $file; - - } else { - return undef; - } - $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; diff --git a/Master/tlpkg/tlperl/lib/Win32/Sound.pm b/Master/tlpkg/tlperl/lib/Win32/Sound.pm deleted file mode 100644 index a8d52a95117..00000000000 --- a/Master/tlpkg/tlperl/lib/Win32/Sound.pm +++ /dev/null @@ -1,582 +0,0 @@ -####################################################################### -# -# Win32::Sound - An extension to play with Windows sounds -# -# Author: Aldo Calpini <dada@divinf.it> -# Version: 0.47 -# Info: -# http://www.divinf.it/dada/perl -# http://www.perl.com/CPAN/authors/Aldo_Calpini -# -####################################################################### -# Version history: -# 0.01 (19 Nov 1996) file created -# 0.03 (08 Apr 1997) first release -# 0.30 (20 Oct 1998) added Volume/Format/Devices/DeviceInfo -# (thanks Dave Roth!) -# 0.40 (16 Mar 1999) added the WaveOut object -# 0.45 (09 Apr 1999) added $! support, documentation et goodies -# 0.46 (25 Sep 1999) fixed small bug in DESTROY, wo was used without being -# initialized (Gurusamy Sarathy <gsar@activestate.com>) -# 0.47 (22 May 2000) support for passing Unicode string to Play() -# (Doug Lankshear <dougl@activestate.com>) - -package Win32::Sound; - -# See the bottom of this file for the POD documentation. -# Search for the string '=head'. - -require Exporter; # to export the constants to the main:: space -require DynaLoader; # to dynuhlode the module. - -@ISA= qw( Exporter DynaLoader ); -@EXPORT = qw( - SND_ASYNC - SND_NODEFAULT - SND_LOOP - SND_NOSTOP -); - -####################################################################### -# This AUTOLOAD is used to 'autoload' constants from the constant() -# XS function. If a constant is not found then control is passed -# to the AUTOLOAD in AutoLoader. -# - -sub AUTOLOAD { - my($constname); - ($constname = $AUTOLOAD) =~ s/.*:://; - #reset $! to zero to reset any current errors. - local $! = 0; - my $val = constant($constname, @_ ? $_[0] : 0); - if ($! != 0) { - - # [dada] This results in an ugly Autoloader error - - #if ($! =~ /Invalid/) { - # $AutoLoader::AUTOLOAD = $AUTOLOAD; - # goto &AutoLoader::AUTOLOAD; - #} else { - - # [dada] ... I prefer this one :) - - ($pack, $file, $line) = caller; - undef $pack; # [dada] and get rid of "used only once" warning... - die "Win32::Sound::$constname is not defined, used at $file line $line."; - - #} - } - eval "sub $AUTOLOAD { $val }"; - goto &$AUTOLOAD; -} - - -####################################################################### -# STATIC OBJECT PROPERTIES -# -$VERSION="0.47"; -undef unless $VERSION; # [dada] to avoid "possible typo" warning - -####################################################################### -# METHODS -# - -sub Version { $VERSION } - -sub Volume { - my(@in) = @_; - # Allows '0%'..'100%' - $in[0] =~ s{ ([\d\.]+)%$ }{ int($1*100/255) }ex if defined $in[0]; - $in[1] =~ s{ ([\d\.]+)%$ }{ int($1*100/255) }ex if defined $in[1]; - _Volume(@in); -} - -####################################################################### -# dynamically load in the Sound.dll module. -# - -bootstrap Win32::Sound; - -####################################################################### -# Win32::Sound::WaveOut -# - -package Win32::Sound::WaveOut; - -sub new { - my($class, $one, $two, $three) = @_; - my $self = {}; - bless($self, $class); - - if($one !~ /^\d+$/ - and not defined($two) - and not defined($three)) { - # Looks like a file - $self->Open($one); - } else { - # Default format if not given - $self->{samplerate} = ($one or 44100); - $self->{bits} = ($two or 16); - $self->{channels} = ($three or 2); - $self->OpenDevice(); - } - return $self; -} - -sub Volume { - my(@in) = @_; - # Allows '0%'..'100%' - $in[0] =~ s{ ([\d\.]+)%$ }{ int($1*255/100) }ex if defined $in[0]; - $in[1] =~ s{ ([\d\.]+)%$ }{ int($1*255/100) }ex if defined $in[1]; - _Volume(@in); -} - -sub Pitch { - my($self, $pitch) = @_; - my($int, $frac); - if(defined($pitch)) { - $pitch =~ /(\d+).?(\d+)?/; - $int = $1; - $frac = $2 or 0; - $int = $int << 16; - $frac = eval("0.$frac * 65536"); - $pitch = $int + $frac; - return _Pitch($self, $pitch); - } else { - $pitch = _Pitch($self); - $int = ($pitch & 0xFFFF0000) >> 16; - $frac = $pitch & 0x0000FFFF; - return eval("$int.$frac"); - } -} - -sub PlaybackRate { - my($self, $rate) = @_; - my($int, $frac); - if(defined($rate)) { - $rate =~ /(\d+).?(\d+)?/; - $int = $1; - $frac = $2 or 0; - $int = $int << 16; - $frac = eval("0.$frac * 65536"); - $rate = $int + $frac; - return _PlaybackRate($self, $rate); - } else { - $rate = _PlaybackRate($self); - $int = ($rate & 0xFFFF0000) >> 16; - $frac = $rate & 0x0000FFFF; - return eval("$int.$frac"); - } -} - -# Preloaded methods go here. - -#Currently Autoloading is not implemented in Perl for win32 -# Autoload methods go after __END__, and are processed by the autosplit program. - -1; -__END__ - - -=head1 NAME - -Win32::Sound - An extension to play with Windows sounds - -=head1 SYNOPSIS - - use Win32::Sound; - Win32::Sound::Volume('100%'); - Win32::Sound::Play("file.wav"); - Win32::Sound::Stop(); - - # ...and read on for more fun ;-) - -=head1 FUNCTIONS - -=over 4 - -=item B<Win32::Sound::Play(SOUND, [FLAGS])> - -Plays the specified sound: SOUND can the be name of a WAV file -or one of the following predefined sound names: - - SystemDefault - SystemAsterisk - SystemExclamation - SystemExit - SystemHand - SystemQuestion - SystemStart - -Additionally, if the named sound could not be found, the -function plays the system default sound (unless you specify the -C<SND_NODEFAULT> flag). If no parameters are given, this function -stops the sound actually playing (see also Win32::Sound::Stop). - -FLAGS can be a combination of the following constants: - -=over 4 - -=item C<SND_ASYNC> - -The sound is played asynchronously and the function -returns immediately after beginning the sound -(if this flag is not specified, the sound is -played synchronously and the function returns -when the sound ends). - -=item C<SND_LOOP> - -The sound plays repeatedly until it is stopped. -You must also specify C<SND_ASYNC> flag. - -=item C<SND_NODEFAULT> - -No default sound is used. If the specified I<sound> -cannot be found, the function returns without -playing anything. - -=item C<SND_NOSTOP> - -If a sound is already playing, the function fails. -By default, any new call to the function will stop -previously playing sounds. - -=back - -=item B<Win32::Sound::Stop()> - -Stops the sound currently playing. - -=item B<Win32::Sound::Volume()> - -Returns the wave device volume; if -called in an array context, returns left -and right values. Otherwise, returns a single -32 bit value (left in the low word, right -in the high word). -In case of error, returns C<undef> and sets -$!. - -Examples: - - ($L, $R) = Win32::Sound::Volume(); - if( not defined Win32::Sound::Volume() ) { - die "Can't get volume: $!"; - } - -=item B<Win32::Sound::Volume(LEFT, [RIGHT])> - -Sets the wave device volume; if two arguments -are given, sets left and right channels -independently, otherwise sets them both to -LEFT (eg. RIGHT=LEFT). Values range from -0 to 65535 (0xFFFF), but they can also be -given as percentage (use a string containing -a number followed by a percent sign). - -Returns C<undef> and sets $! in case of error, -a true value if successful. - -Examples: - - Win32::Sound::Volume('50%'); - Win32::Sound::Volume(0xFFFF, 0x7FFF); - Win32::Sound::Volume('100%', '50%'); - Win32::Sound::Volume(0); - -=item B<Win32::Sound::Format(filename)> - -Returns information about the specified WAV file format; -the array contains: - -=over - -=item * sample rate (in Hz) - -=item * bits per sample (8 or 16) - -=item * channels (1 for mono, 2 for stereo) - -=back - -Example: - - ($hz, $bits, $channels) - = Win32::Sound::Format("file.wav"); - - -=item B<Win32::Sound::Devices()> - -Returns all the available sound devices; -their names contain the type of the -device (WAVEOUT, WAVEIN, MIDIOUT, -MIDIIN, AUX or MIXER) and -a zero-based ID number: valid devices -names are for example: - - WAVEOUT0 - WAVEOUT1 - WAVEIN0 - MIDIOUT0 - MIDIIN0 - AUX0 - AUX1 - AUX2 - -There are also two special device -names, C<WAVE_MAPPER> and C<MIDI_MAPPER> -(the default devices for wave output -and midi output). - -Example: - - @devices = Win32::Sound::Devices(); - -=item Win32::Sound::DeviceInfo(DEVICE) - -Returns an associative array of information -about the sound device named DEVICE (the -same format of Win32::Sound::Devices). - -The content of the array depends on the device -type queried. Each device type returns B<at least> -the following information: - - manufacturer_id - product_id - name - driver_version - -For additional data refer to the following -table: - - WAVEIN..... formats - channels - - WAVEOUT.... formats - channels - support - - MIDIOUT.... technology - voices - notes - channels - support - - AUX........ technology - support - - MIXER...... destinations - support - -The meaning of the fields, where not -obvious, can be evinced from the -Microsoft SDK documentation (too long -to report here, maybe one day... :-). - -Example: - - %info = Win32::Sound::DeviceInfo('WAVE_MAPPER'); - print "$info{name} version $info{driver_version}\n"; - -=back - -=head1 THE WaveOut PACKAGE - -Win32::Sound also provides a different, more -powerful approach to wave audio data with its -C<WaveOut> package. It has methods to load and -then play WAV files, with the additional feature -of specifying the start and end range, so you -can play only a portion of an audio file. - -Furthermore, it is possible to load arbitrary -binary data to the soundcard to let it play and -save them back into WAV files; in a few words, -you can do some sound synthesis work. - -=head2 FUNCTIONS - -=over - -=item new Win32::Sound::WaveOut(FILENAME) - -=item new Win32::Sound::WaveOut(SAMPLERATE, BITS, CHANNELS) - -=item new Win32::Sound::WaveOut() - -This function creates a C<WaveOut> object; the -first form opens the specified wave file (see -also C<Open()> ), so you can directly C<Play()> it. - -The second (and third) form opens the -wave output device with the format given -(or if none given, defaults to 44.1kHz, -16 bits, stereo); to produce something -audible you can either C<Open()> a wave file -or C<Load()> binary data to the soundcard -and then C<Write()> it. - -=item Close() - -Closes the wave file currently opened. - -=item CloseDevice() - -Closes the wave output device; you can change -format and reopen it with C<OpenDevice()>. - -=item GetErrorText(ERROR) - -Returns the error text associated with -the specified ERROR number; note it only -works for wave-output-specific errors. - -=item Load(DATA) - -Loads the DATA buffer in the soundcard. -The format of the data buffer depends -on the format used; for example, with -8 bit mono each sample is one character, -while with 16 bit stereo each sample is -four characters long (two 16 bit values -for left and right channels). The sample -rate defines how much samples are in one -second of sound. For example, to fit one -second at 44.1kHz 16 bit stereo your buffer -must contain 176400 bytes (44100 * 4). - -=item Open(FILE) - -Opens the specified wave FILE. - -=item OpenDevice() - -Opens the wave output device with the -current sound format (not needed unless -you used C<CloseDevice()>). - -=item Pause() - -Pauses the sound currently playing; -use C<Restart()> to continue playing. - -=item Play( [FROM, TO] ) - -Plays the opened wave file. You can optionally -specify a FROM - TO range, where FROM and TO -are expressed in samples (or use FROM=0 for the -first sample and TO=-1 for the last sample). -Playback happens always asynchronously, eg. in -the background. - -=item Position() - -Returns the sample number currently playing; -note that the play position is not zeroed -when the sound ends, so you have to call a -C<Reset()> between plays to receive the -correct position in the current sound. - -=item Reset() - -Stops playing and resets the play position -(see C<Position()>). - -=item Restart() - -Continues playing the sound paused by C<Pause()>. - -=item Save(FILE, [DATA]) - -Writes the DATA buffer (if not given, uses the -buffer currently loaded in the soundcard) -to the specified wave FILE. - -=item Status() - -Returns 0 if the soundcard is currently playing, -1 if it's free, or C<undef> on errors. - -=item Unload() - -Frees the soundcard from the loaded data. - -=item Volume( [LEFT, RIGHT] ) - -Gets or sets the volume for the wave output device. -It works the same way as Win32::Sound::Volume. - -=item Write() - -Plays the data currently loaded in the soundcard; -playback happens always asynchronously, eg. in -the background. - -=back - -=head2 THE SOUND FORMAT - -The sound format is stored in three properties of -the C<WaveOut> object: C<samplerate>, C<bits> and -C<channels>. -If you need to change them without creating a -new object, you should close before and reopen -afterwards the device. - - $WAV->CloseDevice(); - $WAV->{samplerate} = 44100; # 44.1kHz - $WAV->{bits} = 8; # 8 bit - $WAV->{channels} = 1; # mono - $WAV->OpenDevice(); - -You can also use the properties to query the -sound format currently used. - -=head2 EXAMPLE - -This small example produces a 1 second sinusoidal -wave at 440Hz and saves it in F<sinus.wav>: - - use Win32::Sound; - - # Create the object - $WAV = new Win32::Sound::WaveOut(44100, 8, 2); - - $data = ""; - $counter = 0; - $increment = 440/44100; - - # Generate 44100 samples ( = 1 second) - for $i (1..44100) { - - # Calculate the pitch - # (range 0..255 for 8 bits) - $v = sin($counter/2*3.14) * 128 + 128; - - # "pack" it twice for left and right - $data .= pack("cc", $v, $v); - - $counter += $increment; - } - - $WAV->Load($data); # get it - $WAV->Write(); # hear it - 1 until $WAV->Status(); # wait for completion - $WAV->Save("sinus.wav"); # write to disk - $WAV->Unload(); # drop it - -=head1 VERSION - -Win32::Sound version 0.46, 25 Sep 1999. - -=head1 AUTHOR - -Aldo Calpini, C<dada@divinf.it> - -Parts of the code provided and/or suggested by Dave Roth. - -=cut - - diff --git a/Master/tlpkg/tlperl/lib/Win32/Test.pl b/Master/tlpkg/tlperl/lib/Win32/Test.pl deleted file mode 100644 index 235e94bdd78..00000000000 --- a/Master/tlpkg/tlperl/lib/Win32/Test.pl +++ /dev/null @@ -1,477 +0,0 @@ -##### -# T E S T . P L -# ------------- -# A test script for exercising the Win32::ODBC extension. Install -# the ODBC.PLL extension and the ODBC.PM wrapper, set up an ODBC -# DSN (Data Source Name) by the ODBC administrator, then give this a try! -# -# READ THE DOCUMENTATION -- I AM NOT RESPOSIBLE FOR ANY PROBLEMS THAT -# THIS MAY CAUSE WHATSOEVER. BY USING THIS OR ANY --- -# OF THE WIN32::ODBC PARTS FOUND IN THE DISTRIBUTION YOU ARE AGREEING -# WITH THE TERMS OF THIS DISTRIBUTION!!!!! -# -# -# You have been warned. -# --- ---- ---- ------ -# -# Updated to test newest version v961007. Dave Roth <rothd@roth.net> -# This version contains a small sample database (in MS Access 7.0 -# format) called ODBCTest.mdb. Place this database in the same -# directory as this test.pl file. -# -# -------------------------------------------------------------------- -# -# SYNTAX: -# perl test.pl ["DSN Name" [Max Rows]] -# -# DSN Name....Name of DSN that will be used. If this is -# omitted then we will use the obnoxious default DSN. -# Max Rows....Maximum number of rows wanted to be retrieved from -# the DSN. -# - If this is 0 then the request is to retrieve as -# many as possible. -# - If this is a value greater than that which the DSN -# driver can handle the value will be the greatest -# the DSN driver allows. -# - If omitted then we use the default value. -##### - - use Win32::ODBC; - - - $TempDSN = "Win32 ODBC Test --123xxYYzz987--"; - $iTempDSN = 1; - - if (!($DSN = $ARGV[0])){ - $DSN = $TempDSN; - } - $MaxRows = 8 unless defined ($MaxRows = $ARGV[1]); - - $DriverType = "Microsoft Access Driver (*.mdb)"; - $Desc = "Description=The Win32::ODBC Test DSN for Perl"; - $Dir = Win32::GetCwd(); - $DBase = "ODBCTest.mdb"; - - $iWidth=60; - %SQLStmtTypes = (SQL_CLOSE, "SQL_CLOSE", SQL_DROP, "SQL_DROP", SQL_UNBIND, "SQL_UNBIND", SQL_RESET_PARAMS, "SQL_RESET_PARAMS"); - -# Initialize(); - - ($Name, $Version, $Date, $Author, $CompileDate, $CompileTime, $Credits) = Win32::ODBC::Info(); - print "\n"; - print "\t+", "=" x ($iWidth), "+\n"; - print "\t|", Center("", $iWidth), "|\n"; - print "\t|", Center("", $iWidth), "|\n"; - print "\t|", Center("$Name", $iWidth), "|\n"; - print "\t|", Center("-" x length("$Name"), $iWidth), "|\n"; - print "\t|", Center("", $iWidth), "|\n"; - - print "\t|", Center("Version $Version ($Date)", $iWidth), "|\n"; - print "\t|", Center("by $Author", $iWidth), "|\n"; - print "\t|", Center("Compiled on $CompileDate at $CompileTime.", $iWidth), "|\n"; - print "\t|", Center("", $iWidth), "|\n"; - print "\t|", Center("Credits:", $iWidth), "|\n"; - print "\t|", Center(("-" x length("Credits:")), $iWidth), "|\n"; - foreach $Temp (split("\n", $Credits)){ - print "\t|", Center("$Temp", $iWidth), "|\n"; - } - print "\t|", Center("", $iWidth), "|\n"; - print "\t+", "=" x ($iWidth), "+\n"; - -#### -# T E S T 1 -#### - PrintTest(1, "Dump available ODBC Drivers"); - print "\nAvailable ODBC Drivers:\n"; - if (!(%Drivers = Win32::ODBC::Drivers())){ - $Failed{'Test 1'} = "Drivers(): " . Win32::ODBC::Error(); - } - foreach $Driver (keys(%Drivers)){ - print " Driver=\"$Driver\"\n Attributes: ", join("\n" . " "x14, sort(split(';', $Drivers{$Driver}))), "\n\n"; - } - - -#### -# T E S T 2 -#### - PrintTest(2,"Dump available datasources"); - - #### - # Notice you don't need an instantiated object to use this... - #### - print "\nHere are the available datasources...\n"; - if (!(%DSNs = Win32::ODBC::DataSources())){ - $Failed{'Test 2'} = "DataSources(): " . Win32::ODBC::Error(); - } - foreach $Temp (keys(%DSNs)){ - if (($Temp eq $TempDSN) && ($DSNs{$Temp} eq $DriverType)){ - $iTempDSNExists++; - } - if ($DSN =~ /$Temp/i){ - $iTempDSN = 0; - $DriverType = $DSNs{$Temp}; - } - print "\tDSN=\"$Temp\" (\"$DSNs{$Temp}\")\n"; - } - -#### -# T E S T 2.5 -#### - # IF WE DO NOT find the DSN the user specified... - if ($iTempDSN){ - PrintTest("2.5", "Create a Temporary DSN"); - - print "\n\tCould not find the DSN (\"$DSN\") so we will\n\tuse a temporary one (\"$TempDSN\")...\n\n"; - - $DSN = $TempDSN; - - if (! $iTempDSNExists){ - print "\tAdding DSN \"$DSN\"..."; - if (Win32::ODBC::ConfigDSN(ODBC_ADD_DSN, $DriverType, ("DSN=$DSN", "Description=The Win32 ODBC Test DSN for Perl", "DBQ=$Dir\\$DBase", "DEFAULTDIR=$Dir", "UID=", "PWD="))){ - print "Successful!\n"; - }else{ - print "Failure\n"; - $Failed{'Test 2.5'} = "ConfigDSN(): Could not add \"$DSN\": " . Win32::ODBC::Error(); - # If we failed here then use the last DSN we listed in Test 2 - $DriverType = $DSNs{$Temp}; - $DSN = $Temp; - print "\n\tCould not add a temporary DSN so using the last one listed:\n"; - print "\t\t$DSN ($DriverType)\n"; - - } - } - } - -#### -# Report What Driver/DSN we are using -#### - - print "\n\nWe are using the DSN:\n\tDSN = \"$DSN\"\n"; - print "\tDriver = \"$DriverType\"\n\n"; - - -#### -# T E S T 3 -#### - PrintTest(3, "Open several ODBC connections"); - print "\n\tOpening ODBC connection for \"$DSN\"...\n\t\t"; - if (!($O = new Win32::ODBC($DSN))){ - print "Failure. \n\n"; - $Failed{'Test 3a'} = "new(): " . Win32::ODBC::Error(); - PresentErrors(); - exit(); - }else{ - print "Success (connection #", $O->Connection(), ")\n\n"; - } - - print "\tOpening ODBC connection for \"$DSN\"...\n\t\t"; - if (!($O2 = new Win32::ODBC($DSN))){ - $Failed{'Test 3b'} = "new(): " . Win32::ODBC::Error(); - print "Failure. \n\n"; - }else{ - print "Success (connection #", $O2->Connection(), ")\n\n"; - } - - print "\tOpening ODBC connection for \"$DSN\"\n\t\t"; - if (!($O3 = new Win32::ODBC($DSN))){ - $Failed{'Test 3c'} = "new(): " . Win32::ODBC::Error(); - print "Failure. \n\n"; - }else{ - print "Success (connection #", $O3->Connection(), ")\n\n"; - } - - -#### -# T E S T 4 -#### - PrintTest(4, "Close all but one connection"); - - print "\n\tCurrently open ODBC connections are: \"", join(", ", sort($O2->GetConnections())), "\"\n"; - print "\tClosing ODBC connection #", $O2->Connection(), "...\n"; - print "\t\t...", (($O2->Close())? "Successful.":"Failure."), "\n"; - - print "\n\tCurrently open ODBC connections are: \"", join(", ", sort($O3->GetConnections())), "\"\n"; - print "\tClosing ODBC connection #", $O3->Connection(), "...\n"; - print "\t\t...", (($O3->Close())? "Successful.":"Failure."), "\n"; - - print "\n\tCurrently open ODBC connections are: \"", join(", ", sort($O2->GetConnections())), "\"\n"; - -#### -# T E S T 5 -#### - PrintTest(5, "Set/query Max Buffer size for a connection"); - - srand(time); - $Temp = int(rand(10240)) + 10240; - print "\nMaximum Buffer Size for connection #", $O->Connection(), ":\n"; - print "\tValue set at ", $O->GetMaxBufSize(), "\n"; - - print "\tSetting Maximum Buffer Size to $Temp... it has been set to ", $O->SetMaxBufSize($Temp), "\n"; - print "\tValue set at ", $O->GetMaxBufSize(), "\n"; - - $Temp += int(rand(10240)) + 102400; - print "\tSetting Maximum Buffer Size to $Temp... (can not be more than 102400)\n\t\t...it has been set to ", $O->SetMaxBufSize($Temp), "\n"; - print "\tValue set at ", $O->GetMaxBufSize(), "\n"; - - $Temp = int(rand(1024)) + 2048; - print "\tSetting Maximum Buffer Size to $Temp... it has been set to ", $O->SetMaxBufSize($Temp), "\n"; - - print "\tValue set at ", $O->GetMaxBufSize(), "\n"; - - -#### -# T E S T 6 -#### - PrintTest(6, "Set/query Stmt Close Type"); - - print "\n\tStatement Close Type is currently set as ", $O->GetStmtCloseType(), " " . $O->Error . "\n"; - print "\tSetting Statement Close Type to SQL_CLOSE: (returned code of ", $O->SetStmtCloseType(SQL_CLOSE), ")" . $O->Error . "\n"; - print "\tStatement Close Type is currently set as ", $O->GetStmtCloseType(), " " . $O->Error ."\n"; - - -#### -# T E S T 7 -#### - PrintTest(7, "Dump DSN for current connection"); - - if (! (%DSNAttributes = $O->GetDSN())){ - $Failed{'Test 7'} = "GetDSN(): " . $O->Error(); - }else{ - print"\nThe DSN for connection #", $O->Connection(), ":\n"; - print "\tDSN...\n"; - foreach (sort(keys(%DSNAttributes))){ - print "\t$_ = \"$DSNAttributes{$_}\"\n"; - } - } - - - -#### -# T E S T 8 -#### - PrintTest(8, "Dump list of ALL tables in datasource"); - - print "\nList of tables for \"$DSN\"\n\n"; - $Num = 0; - if ($O->Catalog("", "", "%", "'TABLE','VIEW','SYSTEM TABLE', 'GLOBAL TEMPORARY','LOCAL TEMPORARY','ALIAS','SYNONYM'")){ - - print "\tCursor is currently named \"", $O->GetCursorName(), "\".\n"; - print "\tRenaming cursor to \"TestCursor\"...", (($O->SetCursorName("TestCursor"))? "Success":"Failure"), ".\n"; - print "\tCursor is currently named \"", $O->GetCursorName(), "\".\n\n"; - - @FieldNames = $O->FieldNames(); - - $~ = "Test_8_Header"; - write; - - $~ = "Test_8_Body"; - while($O->FetchRow()){ - undef %Data; - %Data = $O->DataHash(); - write; - } - } - print "\n\tTotal number of tables displayed: $Num\n"; - - - -#### -# T E S T 9 -#### - PrintTest(9, "Dump list of non-system tables and views in datasource"); - - print "\n"; - $Num = 0; - - foreach $Temp ($O->TableList("", "", "%", "TABLE, VIEW, SYSTEM_TABLE")){ - $Table = $Temp; - print "\t", ++$Num, ".) \"$Temp\"\n"; - } - print "\n\tTotal number of tables displayed: $Num\n"; - - -#### -# T E S T 10 -#### - PrintTest(10, "Dump contents of the table: \"$Table\""); - - print "\n"; - - print "\tResetting (dropping) cursor...", (($O->DropCursor())? "Successful":"Failure"), ".\n\n"; - - print "\tCurrently the cursor type is: ", $O->GetStmtOption($O->SQL_CURSOR_TYPE), "\n"; - print "\tSetting Cursor to Dynamic (", ($O->SQL_CURSOR_DYNAMIC), ")...", (($O->SetStmtOption($O->SQL_CURSOR_TYPE, $O->SQL_CURSOR_DYNAMIC))? "Success":"Failure"), ".\n"; - print "\t\tThis may have failed depending on your ODBC Driver.\n"; - print "\t\tThis is not really a problem, it will default to another value.\n"; - print "\tUsing the cursor type of: ", $O->GetStmtOption($O->SQL_CURSOR_TYPE), "\n\n"; - - print "\tSetting the connection to only grab $MaxRows row", ($MaxRows == 1)? "":"s", " maximum..."; - if ($O->SetStmtOption($O->SQL_MAX_ROWS, $MaxRows)){ - print "Success!\n"; - }else{ - $Failed{'Test 10a'} = "SetStmtOption(): " . Win32::ODBC::Error(); - print "Failure.\n"; - } - - $iTemp = $O->GetStmtOption($O->SQL_MAX_ROWS); - print "\tUsing the maximum rows: ", (($iTemp)? $iTemp:"No maximum limit"), "\n\n"; - - print "\tCursor is currently named \"", $O->GetCursorName(), "\".\n"; - print "\tRenaming cursor to \"TestCursor\"...", (($O->SetCursorName("TestCursor"))? "Success":"Failure"), ".\n"; - print "\tCursor is currently named \"", $O->GetCursorName(), "\".\n\n"; - - if (! $O->Sql("SELECT * FROM [$Table]")){ - @FieldNames = $O->FieldNames(); - $Cols = $#FieldNames + 1; - $Cols = 8 if ($Cols > 8); - - $FmH = "format Test_10_Header =\n"; - $FmH2 = ""; - $FmH3 = ""; - $FmB = "format Test_10_Body = \n"; - $FmB2 = ""; - - for ($iTemp = 0; $iTemp < $Cols; $iTemp++){ - $FmH .= "@" . "<" x (80/$Cols - 2) . " "; - $FmH2 .= "\$FieldNames[$iTemp],"; - $FmH3 .= "-" x (80/$Cols - 1) . " "; - - $FmB .= "@" . "<" x (80/$Cols - 2) . " "; - $FmB2 .= "\$Data{\$FieldNames[$iTemp]},"; - } - chop $FmH2; - chop $FmB2; - - eval"$FmH\n$FmH2\n$FmH3\n.\n"; - eval "$FmB\n$FmB2\n.\n"; - - $~ = "Test_10_Header"; - write(); - $~ = "Test_10_Body"; - - # Fetch the next rowset - while($O->FetchRow()){ - undef %Data; - %Data = $O->DataHash(); - write(); - } - #### - # THE preceeding block could have been written like this: - # ------------------------------------------------------ - # - # print "\tCurrently the cursor type is: ", $O->GetStmtOption($O->SQL_CURSOR_TYPE), "\n"; - # print "\tSetting Cursor to Dynamic (", ($O->SQL_CURSOR_DYNAMIC), ")...", (($O->SetStmtOption($O->SQL_CURSOR_TYPE, $O->SQL_CURSOR_DYNAMIC))? "Success":"Failure"), ".\n"; - # print "\t\tThis may have failed depending on your ODBC Driver. No real problem.\n"; - # print "\tUsing the cursor type of: ", $O->GetStmtOption($O->SQL_CURSOR_TYPE), "\n\n"; - # - # print "\tSetting rowset size = 15 ...", (($O->SetStmtOption($O->SQL_ROWSET_SIZE, 15))? "Success":"Failure"), ".\n"; - # print "\tGetting rowset size: ", $O->GetStmtOption($O->SQL_ROWSET_SIZE), "\n\n"; - # - # while($O->FetchRow()){ - # $iNum = 1; - # # Position yourself in the rowset - # while($O->SetPos($iNum++ ,$O->SQL_POSITION, $O->SQL_LOCK_NO_CHANGE)){ - # undef %Data; - # %Data = $O->DataHash(); - # write(); - # } - # print "\t\tNext rowset...\n"; - # } - # - # The reason I didn't write it that way (which is easier) is to - # show that we can now SetPos(). Also Fetch() now uses - # SQLExtendedFetch() so it can position itself and retrieve - # rowsets. Notice earlier in this Test 10 we set the - # SQL_ROWSET_SIZE. If this was not set it would default to - # no limit (depending upon your ODBC Driver). - #### - - print "\n\tNo more records available.\n"; - }else{ - $Failed{'Test 10'} = "Sql(): " . $O->Error(); - } - - $O->Close(); - -#### -# T E S T 11 -#### - if ($iTempDSN){ - PrintTest(11, "Remove the temporary DSN"); - print "\n\tRemoving the temporary DSN:\n"; - print "\t\tDSN = \"$DSN\"\n\t\tDriver = \"$DriverType\"\n"; - - if (Win32::ODBC::ConfigDSN(ODBC_REMOVE_DSN, $DriverType, "DSN=$DSN")){ - print "\tSuccessful!\n"; - }else{ - print "\tFailed.\n"; - $Failed{'Test 11'} = "ConfigDSN(): Could not remove \"$DSN\":" . Win32::ODBC::Error(); - } - } - - - PrintTest("E N D O F T E S T"); - PresentErrors(); - - - -#----------------------- F U N C T I O N S --------------------------- - -sub Error{ - my($Data) = @_; - $Data->DumpError() if ref($Data); - Win32::ODBC::DumpError() if ! ref($Data); -} - - -sub Center{ - local($Temp, $Width) = @_; - local($Len) = ($Width - length($Temp)) / 2; - return " " x int($Len), $Temp, " " x (int($Len) + (($Len != int($Len))? 1:0)); -} - -sub PrintTest{ - my($Num, $String) = @_; - my($Temp); - if (length($String)){ - $Temp = " T E S T $Num $String "; - }else{ - $Temp = " $Num "; - } - $Len = length($Temp); - print "\n", "-" x ((79 - $Len)/2), $Temp, "-" x ((79 - $Len)/2 - 1), "\n"; - print "\t$String\n"; -} - -sub PresentErrors{ - PrintTest("", "Error Report:"); - if (keys(%Failed)){ - print "The following were errors:\n"; - foreach (sort(keys(%Failed))){ - print "$_ = $Failed{$_}\n"; - } - }else{ - print "\n\nThere were no errors reported during this test.\n\n"; - } -} - - -sub Initialize{ -format Test_8_Header = - @<<<<<<<<<<<<<<<<<<<<<<<<<<< @|||||||||||| @|||||||||||| @||||||||||| - $FieldNames[0], $FieldNames[1], $FieldNames[2], $FieldNames[3] - ---------------------------- ------------- ------------- ------------ -. -format Test_8_Body = - @>. @<<<<<<<<<<<<<<<<<<<<<<<<<<< @<<<<<<<<<<<< @<<<<<<<<<<<< @<<<<<<<<<<< - ++$Num, $Data{$FieldNames[0]}, $Data{$FieldNames[1]}, $Data{$FieldNames[2]}, $Data{$FieldNames[3]} -. -format Test_9_Header = - @<<<<<<<<<<<<<<<<<< @<<<<<<<<<<<<<< @<<<<<<<<<<<<<< @<<<<<<<<<<<<<< - $FieldNames[0], $FieldNames[1], $FieldNames[2], $FieldNames[3] -. -format Test_9_Body = - @<<<<<<<<<<<<<<<<<< @<<<<<<<<<<<<<< @<<<<<<<<<<<<<< @<<<<<<<<<<<<<< - $Data{$FieldNames[0]}, $Data{$FieldNames[1]}, $Data{$FieldNames[2]}, $Data{$FieldNames[3]} -. -} diff --git a/Master/tlpkg/tlperl/lib/Win32/TieRegistry.pm b/Master/tlpkg/tlperl/lib/Win32/TieRegistry.pm deleted file mode 100644 index 0abbbddb6b8..00000000000 --- a/Master/tlpkg/tlperl/lib/Win32/TieRegistry.pm +++ /dev/null @@ -1,3801 +0,0 @@ -# Win32/TieRegistry.pm -- Perl module to easily use a Registry -# (on Win32 systems so far). -# by Tye McQueen, tye@metronet.com, see http://www.metronet.com/~tye/. - -# -# Skip to "=head" line for user documentation. -# - - -package Win32::TieRegistry; - - -use strict; -use vars qw( $PACK $VERSION @ISA @EXPORT @EXPORT_OK ); - -$PACK= "Win32::TieRegistry"; # Used in error messages. -$VERSION= '0.26'; - - -use Carp; - -require Tie::Hash; -@ISA= qw(Tie::Hash); - -# Required other modules: -use Win32API::Registry 0.12 qw( :KEY_ :HKEY_ :REG_ ); - -#Optional other modules: -use vars qw( $_NoMoreItems $_FileNotFound $_TooSmall $_MoreData $_SetDualVar ); - -if( eval { require Win32::WinError } ) { - $_NoMoreItems= Win32::WinError::constant("ERROR_NO_MORE_ITEMS",0); - $_FileNotFound= Win32::WinError::constant("ERROR_FILE_NOT_FOUND",0); - $_TooSmall= Win32::WinError::constant("ERROR_INSUFFICIENT_BUFFER",0); - $_MoreData= Win32::WinError::constant("ERROR_MORE_DATA",0); -} else { - $_NoMoreItems= "^No more data"; - $_FileNotFound= "cannot find the file"; - $_TooSmall= " data area passed to "; - $_MoreData= "^more data is avail"; -} -if( $_SetDualVar= eval { require SetDualVar } ) { - import SetDualVar; -} - - -#Implementation details: -# When opened: -# HANDLE long; actual handle value -# MACHINE string; name of remote machine ("" if local) -# PATH list ref; machine-relative full path for this key: -# ["LMachine","System","Disk"] -# ["HKEY_LOCAL_MACHINE","System","Disk"] -# DELIM char; delimiter used to separate subkeys (def="\\") -# OS_DELIM char; always "\\" for Win32 -# ACCESS long; usually KEY_ALL_ACCESS, perhaps KEY_READ, etc. -# ROOTS string; var name for "Lmachine"->HKEY_LOCAL_MACHINE map -# FLAGS int; bits to control certain options -# Often: -# VALUES ref to list of value names (data/type never cached) -# SUBKEYS ref to list of subkey names -# SUBCLASSES ref to list of subkey classes -# SUBTIMES ref to list of subkey write times -# MEMBERS ref to list of subkey_name.DELIM's, DELIM.value_name's -# MEMBHASH hash ref to with MEMBERS as keys and 1's as values -# Once Key "Info" requested: -# Class CntSubKeys CntValues MaxSubKeyLen MaxSubClassLen -# MaxValNameLen MaxValDataLen SecurityLen LastWrite -# If is tied to a hash and iterating over key values: -# PREVIDX int; index of last MEMBERS element return -# If is the key object returned by Load(): -# UNLOADME list ref; information about Load()ed key -# If is a subkey of a "loaded" key other than the one returned by Load(): -# DEPENDON obj ref; object that can't be destroyed before us - - -#Package-local variables: - -# Option flag bits: -use vars qw( $Flag_ArrVal $Flag_TieVal $Flag_DualTyp $Flag_DualBin - $Flag_FastDel $Flag_HexDWord $Flag_Split $Flag_FixNulls ); -$Flag_ArrVal= 0x0001; -$Flag_TieVal= 0x0002; -$Flag_FastDel= 0x0004; -$Flag_HexDWord= 0x0008; -$Flag_Split= 0x0010; -$Flag_DualTyp= 0x0020; -$Flag_DualBin= 0x0040; -$Flag_FixNulls= 0x0080; - - -use vars qw( $RegObj %_Roots %RegHash $Registry ); - -# Short-hand for HKEY_* constants: -%_Roots= ( - "Classes" => HKEY_CLASSES_ROOT, - "CUser" => HKEY_CURRENT_USER, - "LMachine" => HKEY_LOCAL_MACHINE, - "Users" => HKEY_USERS, - "PerfData" => HKEY_PERFORMANCE_DATA, # Too picky to be useful - "CConfig" => HKEY_CURRENT_CONFIG, - "DynData" => HKEY_DYN_DATA, # Too picky to be useful -); - -# Basic master Registry object: -$RegObj= {}; -@$RegObj{qw( HANDLE MACHINE PATH DELIM OS_DELIM ACCESS FLAGS ROOTS )}= ( - "NONE", "", [], "\\", "\\", - KEY_READ|KEY_WRITE, $Flag_HexDWord|$Flag_FixNulls, "${PACK}::_Roots" ); -$RegObj->{FLAGS} |= $Flag_DualTyp|$Flag_DualBin if $_SetDualVar; -bless $RegObj; - -# Fill cache for master Registry object: -@$RegObj{qw( VALUES SUBKEYS SUBCLASSES SUBTIMES )}= ( - [], [ keys(%_Roots) ], [], [] ); -grep( s#$#$RegObj->{DELIM}#, - @{ $RegObj->{MEMBERS}= [ @{$RegObj->{SUBKEYS}} ] } ); -@$RegObj{qw( Class MaxSubKeyLen MaxSubClassLen MaxValNameLen - MaxValDataLen SecurityLen LastWrite CntSubKeys CntValues )}= - ( "", 0, 0, 0, 0, 0, 0, 0, 0 ); - -# Create master Registry tied hash: -$RegObj->Tie( \%RegHash ); - -# Create master Registry combination object and tied hash reference: -$Registry= \%RegHash; -bless $Registry; - - -# Preloaded methods go here. - - -# Map option names to name of subroutine that controls that option: -use vars qw( @_opt_subs %_opt_subs ); -@_opt_subs= qw( Delimiter ArrayValues TieValues SplitMultis DWordsToHex - FastDelete FixSzNulls DualTypes DualBinVals AllowLoad AllowSave ); -@_opt_subs{@_opt_subs}= @_opt_subs; - -sub import -{ - my $pkg= shift(@_); - my $level= $Exporter::ExportLevel; - my $expto= caller($level); - my @export= (); - my @consts= (); - my $registry= $Registry->Clone; - local( $_ ); - while( @_ ) { - $_= shift(@_); - if( /^\$(\w+::)*\w+$/ ) { - push( @export, "ObjVar" ) if /^\$RegObj$/; - push( @export, $_ ); - } elsif( /^\%(\w+::)*\w+$/ ) { - push( @export, $_ ); - } elsif( /^[$%]/ ) { - croak "${PACK}->import: Invalid variable name ($_)"; - } elsif( /^:/ || /^(H?KEY|REG)_/ ) { - push( @consts, $_ ); - } elsif( ! @_ ) { - croak "${PACK}->import: Missing argument after option ($_)"; - } elsif( exists $_opt_subs{$_} ) { - $_= $_opt_subs{$_}; - $registry->$_( shift(@_) ); - } elsif( /^TiedRef$/ ) { - $_= shift(@_); - if( ! ref($_) && /^(\$?)(\w+::)*\w+$/ ) { - $_= '$'.$_ unless '$' eq $1; - } elsif( "SCALAR" ne ref($_) ) { - croak "${PACK}->import: Invalid var after TiedRef ($_)"; - } - push( @export, $_ ); - } elsif( /^TiedHash$/ ) { - $_= shift(@_); - if( ! ref($_) && /^(\%?)(\w+::)*\w+$/ ) { - $_= '%'.$_ unless '%' eq $1; - } elsif( "HASH" ne ref($_) ) { - croak "${PACK}->import: Invalid var after TiedHash ($_)"; - } - push( @export, $_ ); - } elsif( /^ObjectRef$/ ) { - $_= shift(@_); - if( ! ref($_) && /^(\$?)(\w+::)*\w+$/ ) { - push( @export, "ObjVar" ); - $_= '$'.$_ unless '$' eq $1; - } elsif( "SCALAR" eq ref($_) ) { - push( @export, "ObjRef" ); - } else { - croak "${PACK}->import: Invalid var after ObjectRef ($_)"; - } - push( @export, $_ ); - } elsif( /^ExportLevel$/ ) { - $level= shift(@_); - $expto= caller($level); - } elsif( /^ExportTo$/ ) { - undef $level; - $expto= caller($level); - } else { - croak "${PACK}->import: Invalid option ($_)"; - } - } - Win32API::Registry->export( $expto, @consts ) if @consts; - @export= ('$Registry') unless @export; - while( @export ) { - $_= shift( @export ); - if( /^\$((?:\w+::)*)(\w+)$/ ) { - my( $pack, $sym )= ( $1, $2 ); - $pack= $expto unless defined($pack) && "" ne $pack; - no strict 'refs'; - *{"${pack}::$sym"}= \${"${pack}::$sym"}; - ${"${pack}::$sym"}= $registry; - } elsif( /^\%((?:\w+::)*)(\w+)$/ ) { - my( $pack, $sym )= ( $1, $2 ); - $pack= $expto unless defined($pack) && "" ne $pack; - no strict 'refs'; - *{"${pack}::$sym"}= \%{"${pack}::$sym"}; - $registry->Tie( \%{"${pack}::$sym"} ); - } elsif( "SCALAR" eq ref($_) ) { - $$_= $registry; - } elsif( "HASH" eq ref($_) ) { - $registry->Tie( $_ ); - } elsif( /^ObjVar$/ ) { - $_= shift( @_ ); - /^\$((?:\w+::)*)(\w+)$/; - my( $pack, $sym )= ( $1, $2 ); - $pack= $expto unless defined($pack) && "" ne $pack; - no strict 'refs'; - *{"${pack}::$sym"}= \${"${pack}::$sym"}; - ${"${pack}::$sym"}= $registry->ObjectRef; - } elsif( /^ObjRef$/ ) { - ${shift(@_)}= $registry->ObjectRef; - } else { - die "Impossible var to export ($_)"; - } - } -} - - -use vars qw( @_new_Opts %_new_Opts ); -@_new_Opts= qw( ACCESS DELIM MACHINE DEPENDON ); -@_new_Opts{@_new_Opts}= (1) x @_new_Opts; - -sub _new -{ - my $this= shift( @_ ); - $this= tied(%$this) if ref($this) && tied(%$this); - my $class= ref($this) || $this; - my $self= {}; - my( $handle, $rpath, $opts )= @_; - if( @_ < 2 || "ARRAY" ne ref($rpath) || 3 < @_ - || 3 == @_ && "HASH" ne ref($opts) ) { - croak "Usage: ${PACK}->_new( \$handle, \\\@path, {OPT=>VAL,...} );\n", - " options: @_new_Opts\nCalled"; - } - @$self{qw( HANDLE PATH )}= ( $handle, $rpath ); - @$self{qw( MACHINE ACCESS DELIM OS_DELIM ROOTS FLAGS )}= - ( $this->Machine, $this->Access, $this->Delimiter, - $this->OS_Delimiter, $this->_Roots, $this->_Flags ); - if( ref($opts) ) { - my @err= grep( ! $_new_Opts{$_}, keys(%$opts) ); - @err and croak "${PACK}->_new: Invalid options (@err)"; - @$self{ keys(%$opts) }= values(%$opts); - } - bless $self, $class; - return $self; -} - - -sub _split -{ - my $self= shift( @_ ); - $self= tied(%$self) if tied(%$self); - my $path= shift( @_ ); - my $delim= @_ ? shift(@_) : $self->Delimiter; - my $list= [ split( /\Q$delim/, $path ) ]; - return $list; -} - - -sub _rootKey -{ - my $self= shift(@_); - $self= tied(%$self) if tied(%$self); - my $keyPath= shift(@_); - my $delim= @_ ? shift(@_) : $self->Delimiter; - my( $root, $subPath ); - if( "ARRAY" eq ref($keyPath) ) { - $subPath= $keyPath; - } else { - $subPath= $self->_split( $keyPath, $delim ); - } - $root= shift( @$subPath ); - if( $root =~ /^HKEY_/ ) { - my $handle= Win32API::Registry::constant($root,0); - $handle or croak "Invalid HKEY_ constant ($root): $!"; - return( $self->_new( $handle, [$root], {DELIM=>$delim} ), - $subPath ); - } elsif( $root =~ /^([-+]|0x)?\d/ ) { - return( $self->_new( $root, [sprintf("0x%lX",$root)], - {DELIM=>$delim} ), - $subPath ); - } else { - my $roots= $self->Roots; - if( $roots->{$root} ) { - return( $self->_new( $roots->{$root}, [$root], {DELIM=>$delim} ), - $subPath ); - } - croak "No such root key ($root)"; - } -} - - -sub _open -{ - my $this= shift(@_); - $this= tied(%$this) if ref($this) && tied(%$this); - my $subPath= shift(@_); - my $sam= @_ ? shift(@_) : $this->Access; - my $subKey= join( $this->OS_Delimiter, @$subPath ); - my $handle= 0; - $this->RegOpenKeyEx( $subKey, 0, $sam, $handle ) - or return (); - return $this->_new( $handle, [ @{$this->_Path}, @$subPath ], - { ACCESS=>$sam, ( defined($this->{UNLOADME}) ? ("DEPENDON",$this) - : defined($this->{DEPENDON}) ? ("DEPENDON",$this->{DEPENDON}) : () ) - } ); -} - - -sub ObjectRef -{ - my $self= shift(@_); - $self= tied(%$self) if tied(%$self); - return $self; -} - - -sub _constant -{ - my( $name, $desc )= @_; - my $value= Win32API::Registry::constant( $name, 0 ); - my $func= (caller(1))[3]; - if( 0 == $value ) { - if( $! =~ /invalid/i ) { - croak "$func: Invalid $desc ($name)"; - } elsif( 0 != $! ) { - croak "$func: \u$desc ($name) not support on this platform"; - } - } - return $value; -} - - -sub _connect -{ - my $this= shift(@_); - $this= tied(%$this) if ref($this) && tied(%$this); - my $subPath= pop(@_); - $subPath= $this->_split( $subPath ) unless ref($subPath); - my $machine= @_ ? shift(@_) : shift(@$subPath); - my $handle= 0; - my( $temp )= $this->_rootKey( [@$subPath] ); - $temp->RegConnectRegistry( $machine, $temp->Handle, $handle ) - or return (); - my $self= $this->_new( $handle, [shift(@$subPath)], {MACHINE=>$machine} ); - return( $self, $subPath ); -} - - -use vars qw( @Connect_Opts %Connect_Opts ); -@Connect_Opts= qw(Access Delimiter); -@Connect_Opts{@Connect_Opts}= (1) x @Connect_Opts; - -sub Connect -{ - my $this= shift(@_); - my $tied= ref($this) && tied(%$this); - $this= tied(%$this) if $tied; - my( $machine, $key, $opts )= @_; - my $delim= ""; - my $sam; - my $subPath; - if( @_ < 2 || 3 < @_ - || 3 == @_ && "HASH" ne ref($opts) ) { - croak "Usage: \$obj= ${PACK}->Connect(", - " \$Machine, \$subKey, { OPT=>VAL,... } );\n", - " options: @Connect_Opts\nCalled"; - } - if( ref($opts) ) { - my @err= grep( ! $Connect_Opts{$_}, keys(%$opts) ); - @err and croak "${PACK}->Connect: Invalid options (@err)"; - } - $delim= "$opts->{Delimiter}" if defined($opts->{Delimiter}); - $delim= $this->Delimiter if "" eq $delim; - $sam= defined($opts->{Access}) ? $opts->{Access} : $this->Access; - $sam= _constant($sam,"key access type") if $sam =~ /^KEY_/; - ( $this, $subPath )= $this->_connect( $machine, $key ); - return () unless defined($this); - my $self= $this->_open( $subPath, $sam ); - return () unless defined($self); - $self->Delimiter( $delim ); - $self= $self->TiedRef if $tied; - return $self; -} - - -my @_newVirtual_keys= qw( MEMBERS VALUES SUBKEYS SUBTIMES SUBCLASSES - Class SecurityLen LastWrite CntValues CntSubKeys - MaxValNameLen MaxValDataLen MaxSubKeyLen MaxSubClassLen ); - -sub _newVirtual -{ - my $self= shift(@_); - my( $rPath, $root, $opts )= @_; - my $new= $self->_new( "NONE", $rPath, $opts ) - or return (); - @{$new}{@_newVirtual_keys}= @{$root->ObjectRef}{@_newVirtual_keys}; - return $new; -} - - -#$key= new Win32::TieRegistry "LMachine/System/Disk"; -#$key= new Win32::TieRegistry "//Server1/LMachine/System/Disk"; -#Win32::TieRegistry->new( HKEY_LOCAL_MACHINE, {DELIM=>"/",ACCESS=>KEY_READ} ); -#Win32::TieRegistry->new( [ HKEY_LOCAL_MACHINE, ".../..." ], {DELIM=>$DELIM} ); -#$key->new( ... ); - -use vars qw( @new_Opts %new_Opts ); -@new_Opts= qw(Access Delimiter); -@new_Opts{@new_Opts}= (1) x @new_Opts; - -sub new -{ - my $this= shift( @_ ); - $this= tied(%$this) if ref($this) && tied(%$this); - if( ! ref($this) ) { - no strict "refs"; - my $self= ${"${this}::Registry"}; - croak "${this}->new failed since ${PACK}::new sees that ", - "\$${this}::Registry is not an object." - if ! ref($self); - $this= $self->Clone; - } - my( $subKey, $opts )= @_; - my $delim= ""; - my $dlen; - my $sam; - my $subPath; - if( @_ < 1 || 2 < @_ - || 2 == @_ && "HASH" ne ref($opts) ) { - croak "Usage: \$obj= ${PACK}->new( \$subKey, { OPT=>VAL,... } );\n", - " options: @new_Opts\nCalled"; - } - if( defined($opts) ) { - my @err= grep( ! $new_Opts{$_}, keys(%$opts) ); - @err and die "${PACK}->new: Invalid options (@err)"; - } - $delim= "$opts->{Delimiter}" if defined($opts->{Delimiter}); - $delim= $this->Delimiter if "" eq $delim; - $dlen= length($delim); - $sam= defined($opts->{Access}) ? $opts->{Access} : $this->Access; - $sam= _constant($sam,"key access type") if $sam =~ /^KEY_/; - if( "ARRAY" eq ref($subKey) ) { - $subPath= $subKey; - if( "NONE" eq $this->Handle && @$subPath ) { - ( $this, $subPath )= $this->_rootKey( $subPath ); - } - } elsif( $delim x 2 eq substr($subKey,0,2*$dlen) ) { - my $path= $this->_split( substr($subKey,2*$dlen), $delim ); - my $mach= shift(@$path); - if( ! @$path ) { - return $this->_newVirtual( $path, $Registry, - {MACHINE=>$mach,DELIM=>$delim,ACCESS=>$sam} ); - } - ( $this, $subPath )= $this->_connect( $mach, $path ); - return () if ! defined($this); - if( 0 == @$subPath ) { - $this->Delimiter( $delim ); - return $this; - } - } elsif( $delim eq substr($subKey,0,$dlen) ) { - ( $this, $subPath )= $this->_rootKey( substr($subKey,$dlen), $delim ); - } elsif( "NONE" eq $this->Handle && "" ne $subKey ) { - my( $mach )= $this->Machine; - if( $mach ) { - ( $this, $subPath )= $this->_connect( $mach, $subKey ); - } else { - ( $this, $subPath )= $this->_rootKey( $subKey, $delim ); - } - } else { - $subPath= $this->_split( $subKey, $delim ); - } - return () unless defined($this); - if( 0 == @$subPath && "NONE" eq $this->Handle ) { - return $this->_newVirtual( $this->_Path, $this, - { DELIM=>$delim, ACCESS=>$sam } ); - } - my $self= $this->_open( $subPath, $sam ); - return () unless defined($self); - $self->Delimiter( $delim ); - return $self; -} - - -sub Open -{ - my $self= shift(@_); - my $tied= ref($self) && tied(%$self); - $self= tied(%$self) if $tied; - $self= $self->new( @_ ); - $self= $self->TiedRef if defined($self) && $tied; - return $self; -} - - -sub Clone -{ - my $self= shift( @_ ); - my $new= $self->Open(""); - return $new; -} - - -{ my @flush; - sub Flush - { - my $self= shift(@_); - $self= tied(%$self) if tied(%$self); - my( $flush )= shift(@_); - @_ and croak "Usage: \$key->Flush( \$bFlush );"; - return 0 if "NONE" eq $self->Handle; - @flush= qw( VALUES SUBKEYS SUBCLASSES SUBTIMES MEMBERS Class - CntSubKeys CntValues MaxSubKeyLen MaxSubClassLen - MaxValNameLen MaxValDataLen SecurityLen LastWrite PREVIDX ) - unless @flush; - delete( @$self{@flush} ); - if( defined($flush) && $flush ) { - return $self->RegFlushKey(); - } else { - return 1; - } - } -} - - -sub _DualVal -{ - my( $hRef, $num )= @_; - if( $_SetDualVar && $$hRef{$num} ) { - &SetDualVar( $num, "$$hRef{$num}", 0+$num ); - } - return $num; -} - - -use vars qw( @_RegDataTypes %_RegDataTypes ); -@_RegDataTypes= qw( REG_SZ REG_EXPAND_SZ REG_BINARY REG_LINK REG_MULTI_SZ - REG_DWORD_LITTLE_ENDIAN REG_DWORD_BIG_ENDIAN REG_DWORD - REG_RESOURCE_LIST REG_FULL_RESOURCE_DESCRIPTOR - REG_RESOURCE_REQUIREMENTS_LIST REG_NONE ); -# Make sure that REG_DWORD appears _after_ other REG_DWORD_* -# items above and that REG_NONE appears _last_. -foreach( @_RegDataTypes ) { - $_RegDataTypes{Win32API::Registry::constant($_,0)}= $_; -} - -sub GetValue -{ - my $self= shift(@_); - $self= tied(%$self) if tied(%$self); - 1 == @_ or croak "Usage: (\$data,\$type)= \$key->GetValue('ValName');"; - my( $valName )= @_; - my( $valType, $valData, $dLen )= (0,"",0); - return () if "NONE" eq $self->Handle; - $self->RegQueryValueEx( $valName, [], $valType, $valData, - $dLen= ( defined($self->{MaxValDataLen}) ? $self->{MaxValDataLen} : 0 ) - ) or return (); - if( REG_DWORD == $valType ) { - my $val= unpack("L",$valData); - $valData= sprintf "0x%08.8lX", $val if $self->DWordsToHex; - &SetDualVar( $valData, $valData, $val ) if $self->DualBinVals - } elsif( REG_BINARY == $valType && length($valData) <= 4 ) { - &SetDualVar( $valData, $valData, hex reverse unpack("h*",$valData) ) - if $self->DualBinVals; - } elsif( ( REG_SZ == $valType || REG_EXPAND_SZ == $valType ) - && $self->FixSzNulls ) { - substr($valData,-1)= "" if "\0" eq substr($valData,-1); - } elsif( REG_MULTI_SZ == $valType && $self->SplitMultis ) { - ## $valData =~ s/\0\0$//; # Why does this often fail?? - substr($valData,-2)= "" if "\0\0" eq substr($valData,-2); - $valData= [ split( /\0/, $valData, -1 ) ] - } - if( ! wantarray ) { - return $valData; - } elsif( ! $self->DualTypes ) { - return( $valData, $valType ); - } else { - return( $valData, _DualVal( \%_RegDataTypes, $valType ) ); - } -} - - -sub _ErrNum -{ - # return $^E; - return Win32::GetLastError(); -} - - -sub _ErrMsg -{ - # return $^E; - return Win32::FormatMessage( Win32::GetLastError() ); -} - -sub _Err -{ - my $err; - # return $^E; - return _ErrMsg if ! $_SetDualVar; - return &SetDualVar( $err, _ErrMsg, _ErrNum ); -} - -sub _NoMoreItems -{ - return - $_NoMoreItems =~ /^\d/ - ? _ErrNum == $_NoMoreItems - : _ErrMsg =~ /$_NoMoreItems/io; -} - - -sub _FileNotFound -{ - return - $_FileNotFound =~ /^\d/ - ? _ErrNum == $_FileNotFound - : _ErrMsg =~ /$_FileNotFound/io; -} - - -sub _TooSmall -{ - return - $_TooSmall =~ /^\d/ - ? _ErrNum == $_TooSmall - : _ErrMsg =~ /$_TooSmall/io; -} - - -sub _MoreData -{ - return - $_MoreData =~ /^\d/ - ? _ErrNum == $_MoreData - : _ErrMsg =~ /$_MoreData/io; -} - - -sub _enumValues -{ - my $self= shift(@_); - $self= tied(%$self) if tied(%$self); - my( @names )= (); - my $pos= 0; - my $name= ""; - my $nlen= 1+$self->Information("MaxValNameLen"); - while( $self->RegEnumValue($pos++,$name,$nlen,[],[],[],[]) ) { - push( @names, $name ); - } - if( ! _NoMoreItems() ) { - return (); - } - $self->{VALUES}= \@names; - return 1; -} - - -sub ValueNames -{ - my $self= shift(@_); - $self= tied(%$self) if tied(%$self); - @_ and croak "Usage: \@names= \$key->ValueNames;"; - $self->_enumValues unless $self->{VALUES}; - return @{$self->{VALUES}}; -} - - -sub _enumSubKeys -{ - my $self= shift(@_); - $self= tied(%$self) if tied(%$self); - my( @subkeys, @classes, @times )= (); - my $pos= 0; - my( $subkey, $class, $time )= ("","",""); - my( $namSiz, $clsSiz )= $self->Information( - qw( MaxSubKeyLen MaxSubClassLen )); - $namSiz++; $clsSiz++; - while( $self->RegEnumKeyEx( - $pos++, $subkey, $namSiz, [], $class, $clsSiz, $time ) ) { - push( @subkeys, $subkey ); - push( @classes, $class ); - push( @times, $time ); - } - if( ! _NoMoreItems() ) { - return (); - } - $self->{SUBKEYS}= \@subkeys; - $self->{SUBCLASSES}= \@classes; - $self->{SUBTIMES}= \@times; - return 1; -} - - -sub SubKeyNames -{ - my $self= shift(@_); - $self= tied(%$self) if tied(%$self); - @_ and croak "Usage: \@names= \$key->SubKeyNames;"; - $self->_enumSubKeys unless $self->{SUBKEYS}; - return @{$self->{SUBKEYS}}; -} - - -sub SubKeyClasses -{ - my $self= shift(@_); - @_ and croak "Usage: \@classes= \$key->SubKeyClasses;"; - $self->_enumSubKeys unless $self->{SUBCLASSES}; - return @{$self->{SUBCLASSES}}; -} - - -sub SubKeyTimes -{ - my $self= shift(@_); - $self= tied(%$self) if tied(%$self); - @_ and croak "Usage: \@times= \$key->SubKeyTimes;"; - $self->_enumSubKeys unless $self->{SUBTIMES}; - return @{$self->{SUBTIMES}}; -} - - -sub _MemberNames -{ - my $self= shift(@_); - $self= tied(%$self) if tied(%$self); - @_ and croak "Usage: \$arrayRef= \$key->_MemberNames;"; - if( ! $self->{MEMBERS} ) { - $self->_enumValues unless $self->{VALUES}; - $self->_enumSubKeys unless $self->{SUBKEYS}; - my( @members )= ( map( $_.$self->{DELIM}, @{$self->{SUBKEYS}} ), - map( $self->{DELIM}.$_, @{$self->{VALUES}} ) ); - $self->{MEMBERS}= \@members; - } - return $self->{MEMBERS}; -} - - -sub _MembersHash -{ - my $self= shift(@_); - $self= tied(%$self) if tied(%$self); - @_ and croak "Usage: \$hashRef= \$key->_MembersHash;"; - if( ! $self->{MEMBHASH} ) { - my $aRef= $self->_MemberNames; - $self->{MEMBHASH}= {}; - @{$self->{MEMBHASH}}{@$aRef}= (1) x @$aRef; - } - return $self->{MEMBHASH}; -} - - -sub MemberNames -{ - my $self= shift(@_); - $self= tied(%$self) if tied(%$self); - @_ and croak "Usage: \@members= \$key->MemberNames;"; - return @{$self->_MemberNames}; -} - - -sub Information -{ - my $self= shift(@_); - $self= tied(%$self) if tied(%$self); - my( $time, $nkeys, $nvals, $xsec, $xkey, $xcls, $xname, $xdata )= - ("",0,0,0,0,0,0,0); - my $clen= 8; - if( ! $self->RegQueryInfoKey( [], [], $nkeys, $xkey, $xcls, - $nvals, $xname, $xdata, $xsec, $time ) ) { - return (); - } - if( defined($self->{Class}) ) { - $clen= length($self->{Class}); - } else { - $self->{Class}= ""; - } - while( ! $self->RegQueryInfoKey( $self->{Class}, $clen, - [],[],[],[],[],[],[],[],[]) - && _MoreData ) { - $clen *= 2; - } - my( %info ); - @info{ qw( LastWrite CntSubKeys CntValues SecurityLen - MaxValDataLen MaxSubKeyLen MaxSubClassLen MaxValNameLen ) - }= ( $time, $nkeys, $nvals, $xsec, - $xdata, $xkey, $xcls, $xname ); - if( @_ ) { - my( %check ); - @check{keys(%info)}= keys(%info); - my( @err )= grep( ! $check{$_}, @_ ); - if( @err ) { - croak "${PACK}::Information- Invalid info requested (@err)"; - } - return @info{@_}; - } else { - return %info; - } -} - - -sub Delimiter -{ - my $self= shift(@_); - $self= tied(%$self) if tied(%$self); - $self= $RegObj unless ref($self); - my( $oldDelim )= $self->{DELIM}; - if( 1 == @_ && "" ne "$_[0]" ) { - delete $self->{MEMBERS}; - delete $self->{MEMBHASH}; - $self->{DELIM}= "$_[0]"; - } elsif( 0 != @_ ) { - croak "Usage: \$oldDelim= \$key->Delimiter(\$newDelim);"; - } - return $oldDelim; -} - - -sub Handle -{ - my $self= shift(@_); - $self= tied(%$self) if tied(%$self); - @_ and croak "Usage: \$handle= \$key->Handle;"; - $self= $RegObj unless ref($self); - return $self->{HANDLE}; -} - - -sub Path -{ - my $self= shift(@_); - $self= tied(%$self) if tied(%$self); - @_ and croak "Usage: \$path= \$key->Path;"; - my $delim= $self->{DELIM}; - $self= $RegObj unless ref($self); - if( "" eq $self->{MACHINE} ) { - return( $delim . join( $delim, @{$self->{PATH}} ) . $delim ); - } else { - return( $delim x 2 - . join( $delim, $self->{MACHINE}, @{$self->{PATH}} ) - . $delim ); - } -} - - -sub _Path -{ - my $self= shift(@_); - $self= tied(%$self) if tied(%$self); - @_ and croak "Usage: \$arrRef= \$key->_Path;"; - $self= $RegObj unless ref($self); - return $self->{PATH}; -} - - -sub Machine -{ - my $self= shift(@_); - $self= tied(%$self) if tied(%$self); - @_ and croak "Usage: \$machine= \$key->Machine;"; - $self= $RegObj unless ref($self); - return $self->{MACHINE}; -} - - -sub Access -{ - my $self= shift(@_); - $self= tied(%$self) if tied(%$self); - @_ and croak "Usage: \$access= \$key->Access;"; - $self= $RegObj unless ref($self); - return $self->{ACCESS}; -} - - -sub OS_Delimiter -{ - my $self= shift(@_); - @_ and croak "Usage: \$backslash= \$key->OS_Delimiter;"; - return $self->{OS_DELIM}; -} - - -sub _Roots -{ - my $self= shift(@_); - $self= tied(%$self) if ref($self) && tied(%$self); - @_ and croak "Usage: \$varName= \$key->_Roots;"; - $self= $RegObj unless ref($self); - return $self->{ROOTS}; -} - - -sub Roots -{ - my $self= shift(@_); - $self= tied(%$self) if ref($self) && tied(%$self); - @_ and croak "Usage: \$hashRef= \$key->Roots;"; - $self= $RegObj unless ref($self); - return eval "\\%$self->{ROOTS}"; -} - - -sub TIEHASH -{ - my( $this )= shift(@_); - $this= tied(%$this) if ref($this) && tied(%$this); - my( $key )= @_; - if( 1 == @_ && ref($key) && "$key" =~ /=/ ) { - return $key; # $key is already an object (blessed reference). - } - return $this->new( @_ ); -} - - -sub Tie -{ - my $self= shift(@_); - $self= tied(%$self) if tied(%$self); - my( $hRef )= @_; - if( 1 != @_ || ! ref($hRef) || "$hRef" !~ /(^|=)HASH\(/ ) { - croak "Usage: \$key->Tie(\\\%hash);"; - } - return tie %$hRef, ref($self), $self; -} - - -sub TiedRef -{ - my $self= shift(@_); - $self= tied(%$self) if tied(%$self); - my $hRef= @_ ? shift(@_) : {}; - return () if ! defined($self); - $self->Tie($hRef); - bless $hRef, ref($self); - return $hRef; -} - - -sub _Flags -{ - my $self= shift(@_); - $self= tied(%$self) if tied(%$self); - my $oldFlags= $self->{FLAGS}; - if( 1 == @_ ) { - $self->{FLAGS}= shift(@_); - } elsif( 0 != @_ ) { - croak "Usage: \$oldBits= \$key->_Flags(\$newBits);"; - } - return $oldFlags; -} - - -sub ArrayValues -{ - my $self= shift(@_); - $self= tied(%$self) if tied(%$self); - my $oldFlag= $Flag_ArrVal == ( $Flag_ArrVal & $self->{FLAGS} ); - if( 1 == @_ ) { - my $bool= shift(@_); - if( $bool ) { - $self->{FLAGS} |= $Flag_ArrVal; - } else { - $self->{FLAGS} &= ~( $Flag_ArrVal | $Flag_TieVal ); - } - } elsif( 0 != @_ ) { - croak "Usage: \$oldBool= \$key->ArrayValues(\$newBool);"; - } - return $oldFlag; -} - - -sub TieValues -{ - my $self= shift(@_); - $self= tied(%$self) if tied(%$self); - my $oldFlag= $Flag_TieVal == ( $Flag_TieVal & $self->{FLAGS} ); - if( 1 == @_ ) { - my $bool= shift(@_); - if( $bool ) { - croak "${PACK}->TieValues cannot be enabled with this version"; - $self->{FLAGS} |= $Flag_TieVal; - } else { - $self->{FLAGS} &= ~$Flag_TieVal; - } - } elsif( 0 != @_ ) { - croak "Usage: \$oldBool= \$key->TieValues(\$newBool);"; - } - return $oldFlag; -} - - -sub FastDelete -{ - my $self= shift(@_); - $self= tied(%$self) if tied(%$self); - my $oldFlag= $Flag_FastDel == ( $Flag_FastDel & $self->{FLAGS} ); - if( 1 == @_ ) { - my $bool= shift(@_); - if( $bool ) { - $self->{FLAGS} |= $Flag_FastDel; - } else { - $self->{FLAGS} &= ~$Flag_FastDel; - } - } elsif( 0 != @_ ) { - croak "Usage: \$oldBool= \$key->FastDelete(\$newBool);"; - } - return $oldFlag; -} - - -sub SplitMultis -{ - my $self= shift(@_); - $self= tied(%$self) if tied(%$self); - my $oldFlag= $Flag_Split == ( $Flag_Split & $self->{FLAGS} ); - if( 1 == @_ ) { - my $bool= shift(@_); - if( $bool ) { - $self->{FLAGS} |= $Flag_Split; - } else { - $self->{FLAGS} &= ~$Flag_Split; - } - } elsif( 0 != @_ ) { - croak "Usage: \$oldBool= \$key->SplitMultis(\$newBool);"; - } - return $oldFlag; -} - - -sub DWordsToHex -{ - my $self= shift(@_); - $self= tied(%$self) if tied(%$self); - my $oldFlag= $Flag_HexDWord == ( $Flag_HexDWord & $self->{FLAGS} ); - if( 1 == @_ ) { - my $bool= shift(@_); - if( $bool ) { - $self->{FLAGS} |= $Flag_HexDWord; - } else { - $self->{FLAGS} &= ~$Flag_HexDWord; - } - } elsif( 0 != @_ ) { - croak "Usage: \$oldBool= \$key->DWordsToHex(\$newBool);"; - } - return $oldFlag; -} - - -sub FixSzNulls -{ - my $self= shift(@_); - $self= tied(%$self) if tied(%$self); - my $oldFlag= $Flag_FixNulls == ( $Flag_FixNulls & $self->{FLAGS} ); - if( 1 == @_ ) { - my $bool= shift(@_); - if( $bool ) { - $self->{FLAGS} |= $Flag_FixNulls; - } else { - $self->{FLAGS} &= ~$Flag_FixNulls; - } - } elsif( 0 != @_ ) { - croak "Usage: \$oldBool= \$key->FixSzNulls(\$newBool);"; - } - return $oldFlag; -} - - -sub DualTypes -{ - my $self= shift(@_); - $self= tied(%$self) if tied(%$self); - my $oldFlag= $Flag_DualTyp == ( $Flag_DualTyp & $self->{FLAGS} ); - if( 1 == @_ ) { - my $bool= shift(@_); - if( $bool ) { - croak "${PACK}->DualTypes cannot be enabled since ", - "SetDualVar module not installed" - unless $_SetDualVar; - $self->{FLAGS} |= $Flag_DualTyp; - } else { - $self->{FLAGS} &= ~$Flag_DualTyp; - } - } elsif( 0 != @_ ) { - croak "Usage: \$oldBool= \$key->DualTypes(\$newBool);"; - } - return $oldFlag; -} - - -sub DualBinVals -{ - my $self= shift(@_); - $self= tied(%$self) if tied(%$self); - my $oldFlag= $Flag_DualBin == ( $Flag_DualBin & $self->{FLAGS} ); - if( 1 == @_ ) { - my $bool= shift(@_); - if( $bool ) { - croak "${PACK}->DualBinVals cannot be enabled since ", - "SetDualVar module not installed" - unless $_SetDualVar; - $self->{FLAGS} |= $Flag_DualBin; - } else { - $self->{FLAGS} &= ~$Flag_DualBin; - } - } elsif( 0 != @_ ) { - croak "Usage: \$oldBool= \$key->DualBinVals(\$newBool);"; - } - return $oldFlag; -} - - -sub GetOptions -{ - my $self= shift(@_); - $self= tied(%$self) if tied(%$self); - my( $opt, $meth ); - if( ! @_ || 1 == @_ && "HASH" eq ref($_[0]) ) { - my $href= @_ ? $_[0] : {}; - foreach $opt ( grep !/^Allow/, @_opt_subs ) { - $meth= $_opt_subs{$opt}; - $href->{$opt}= $self->$meth(); - } - return @_ ? $self : $href; - } - my @old; - foreach $opt ( @_ ) { - $meth= $_opt_subs{$opt}; - if( defined $meth ) { - if( $opt eq "AllowLoad" || $opt eq "AllowSave" ) { - croak "${PACK}->GetOptions: Getting current setting of $opt ", - "not supported in this release"; - } - push( @old, $self->$meth() ); - } else { - croak "${PACK}->GetOptions: Invalid option ($opt) ", - "not one of ( ", join(" ",grep !/^Allow/, @_opt_subs), " )"; - } - } - return wantarray ? @old : $old[-1]; -} - - -sub SetOptions -{ - my $self= shift(@_); - # Don't get object if hash ref so "ref" returns original ref. - my( $opt, $meth, @old ); - while( @_ ) { - $opt= shift(@_); - $meth= $_opt_subs{$opt}; - if( ! @_ ) { - croak "${PACK}->SetOptions: Option value missing ", - "after option name ($opt)"; - } elsif( defined $meth ) { - push( @old, $self->$meth( shift(@_) ) ); - } elsif( $opt eq substr("reference",0,length($opt)) ) { - shift(@_) if @_; - push( @old, $self ); - } else { - croak "${PACK}->SetOptions: Invalid option ($opt) ", - "not one of ( @_opt_subs )"; - } - } - return wantarray ? @old : $old[-1]; -} - - -sub _parseTiedEnt -{ - my $self= shift(@_); - $self= tied(%$self) if tied(%$self); - my $ent= shift(@_); - my $delim= shift(@_); - my $dlen= length( $delim ); - my $parent= @_ ? shift(@_) : 0; - my $off; - if( $delim x 2 eq substr($ent,0,2*$dlen) && "NONE" eq $self->Handle ) { - if( 0 <= ( $off= index( $ent, $delim x 2, 2*$dlen ) ) ) { - return( substr( $ent, 0, $off ), substr( $ent, 2*$dlen+$off ) ); - } elsif( $delim eq substr($ent,-$dlen) ) { - return( substr($ent,0,-$dlen) ); - } elsif( 2*$dlen <= ( $off= rindex( $ent, $delim ) ) ) { - return( substr( $ent, 0, $off ), - undef, substr( $ent, $dlen+$off ) ); - } elsif( $parent ) { - return(); - } else { - return( $ent ); - } - } elsif( $delim eq substr($ent,0,$dlen) && "NONE" ne $self->Handle ) { - return( undef, substr($ent,$dlen) ); - } elsif( $self->{MEMBERS} && $self->_MembersHash->{$ent} ) { - return( substr($ent,0,-$dlen) ); - } elsif( 0 <= ( $off= index( $ent, $delim x 2 ) ) ) { - return( substr( $ent, 0, $off ), substr( $ent, 2*$dlen+$off ) ); - } elsif( $delim eq substr($ent,-$dlen) ) { - if( $parent - && 0 <= ( $off= rindex( $ent, $delim, length($ent)-2*$dlen ) ) ) { - return( substr($ent,0,$off), - undef, undef, substr($ent,$dlen+$off,-$dlen) ); - } else { - return( substr($ent,0,-$dlen) ); - } - } elsif( 0 <= ( $off= rindex( $ent, $delim ) ) ) { - return( - substr( $ent, 0, $off ), undef, substr( $ent, $dlen+$off ) ); - } else { - return( undef, undef, $ent ); - } -} - - -sub _FetchValue -{ - my $self= shift( @_ ); - my( $val, $createKey )= @_; - my( $data, $type ); - if( ( $data, $type )= $self->GetValue( $val ) ) { - return $self->ArrayValues ? [ $data, $type ] - : wantarray ? ( $data, $type ) - : $data; - } elsif( $createKey and $data= $self->new($val) ) { - return $data->TiedRef; - } else { - return (); - } -} - - -sub FETCH -{ - my $self= shift(@_); - my $ent= shift(@_); - my $delim= $self->Delimiter; - my( $key, $val, $ambig )= $self->_parseTiedEnt( $ent, $delim, 0 ); - my $sub; - if( defined($key) ) { - if( defined($self->{MEMBHASH}) - && $self->{MEMBHASH}->{$key.$delim} - && 0 <= index($key,$delim) ) { - return () - unless $sub= $self->new( $key, - {"Delimiter"=>$self->OS_Delimiter} ); - $sub->Delimiter($delim); - } else { - return () - unless $sub= $self->new( $key ); - } - } else { - $sub= $self; - } - if( defined($val) ) { - return $sub->_FetchValue( $val ); - } elsif( ! defined($ambig) ) { - return $sub->TiedRef; - } elsif( defined($key) ) { - return $sub->FETCH( $ambig ); - } else { - return $sub->_FetchValue( $ambig, "" ne $ambig ); - } -} - - -sub _FetchOld -{ - my( $self, $key )= @_; - my $old= $self->FETCH($key); - if( $old ) { - my $copy= {}; - %$copy= %$old; - return $copy; - } - # return $^E; - return _Err; -} - - -sub DELETE -{ - my $self= shift(@_); - my $ent= shift(@_); - my $delim= $self->Delimiter; - my( $key, $val, $ambig, $subkey )= $self->_parseTiedEnt( $ent, $delim, 1 ); - my $sub; - my $fast= defined(wantarray) ? $self->FastDelete : 2; - my $old= 1; # Value returned if FastDelete is set. - if( defined($key) - && ( defined($val) || defined($ambig) || defined($subkey) ) ) { - return () - unless $sub= $self->new( $key ); - } else { - $sub= $self; - } - if( defined($val) ) { - $old= $sub->GetValue($val) || _Err unless 2 <= $fast; - $sub->RegDeleteValue( $val ); - } elsif( defined($subkey) ) { - $old= $sub->_FetchOld( $subkey.$delim ) unless $fast; - $sub->RegDeleteKey( $subkey ); - } elsif( defined($ambig) ) { - if( defined($key) ) { - $old= $sub->DELETE($ambig); - } else { - $old= $sub->GetValue($ambig) || _Err unless 2 <= $fast; - if( defined( $old ) ) { - $sub->RegDeleteValue( $ambig ); - } else { - $old= $sub->_FetchOld( $ambig.$delim ) unless $fast; - $sub->RegDeleteKey( $ambig ); - } - } - } elsif( defined($key) ) { - $old= $sub->_FetchOld( $key.$delim ) unless $fast; - $sub->RegDeleteKey( $key ); - } else { - croak "${PACK}->DELETE: Key ($ent) can never be deleted"; - } - return $old; -} - - -sub SetValue -{ - my $self= shift(@_); - $self= tied(%$self) if tied(%$self); - my $name= shift(@_); - my $data= shift(@_); - my( $type )= @_; - my $size; - if( ! defined($type) ) { - if( "ARRAY" eq ref($data) ) { - croak "${PACK}->SetValue: Value is array reference but ", - "no data type given" - unless 2 == @$data; - ( $data, $type )= @$data; - } else { - $type= REG_SZ; - } - } - $type= _constant($type,"registry value data type") if $type =~ /^REG_/; - if( REG_MULTI_SZ == $type && "ARRAY" eq ref($data) ) { - $data= join( "\0", @$data ) . "\0\0"; - ## $data= pack( "a*" x (1+@$data), map( $_."\0", @$data, "" ) ); - } elsif( ( REG_SZ == $type || REG_EXPAND_SZ == $type ) - && $self->FixSzNulls ) { - $data .= "\0" unless "\0" eq substr($data,0,-1); - } elsif( REG_DWORD == $type && $data =~ /^0x[0-9a-fA-F]{3,}$/ ) { - $data= pack( "L", hex($data) ); - # We could to $data=pack("L",$data) for REG_DWORD but I see - # no nice way to always destinguish when to do this or not. - } - return $self->RegSetValueEx( $name, 0, $type, $data, length($data) ); -} - - -sub StoreKey -{ - my $this= shift(@_); - $this= tied(%$this) if ref($this) && tied(%$this); - my $subKey= shift(@_); - my $data= shift(@_); - my $ent; - my $self; - if( ! ref($data) || "$data" !~ /(^|=)HASH/ ) { - croak "${PACK}->StoreKey: For ", $this->Path.$subKey, ",\n", - " subkey data must be a HASH reference"; - } - if( defined( $$data{""} ) && "HASH" eq ref($$data{""}) ) { - $self= $this->CreateKey( $subKey, delete $$data{""} ); - } else { - $self= $this->CreateKey( $subKey ); - } - return () if ! defined($self); - foreach $ent ( keys(%$data) ) { - return () - unless $self->STORE( $ent, $$data{$ent} ); - } - return $self; -} - - -# = { "" => {OPT=>VAL}, "val"=>[], "key"=>{} } creates a new key -# = "string" creates a new REG_SZ value -# = [ data, type ] creates a new value -sub STORE -{ - my $self= shift(@_); - my $ent= shift(@_); - my $data= shift(@_); - my $delim= $self->Delimiter; - my( $key, $val, $ambig, $subkey )= $self->_parseTiedEnt( $ent, $delim, 1 ); - my $sub; - if( defined($key) - && ( defined($val) || defined($ambig) || defined($subkey) ) ) { - return () - unless $sub= $self->new( $key ); - } else { - $sub= $self; - } - if( defined($val) ) { - croak "${PACK}->STORE: For ", $sub->Path.$delim.$val, ",\n", - " value data cannot be a HASH reference" - if ref($data) && "$data" =~ /(^|=)HASH/; - $sub->SetValue( $val, $data ); - } elsif( defined($subkey) ) { - croak "${PACK}->STORE: For ", $sub->Path.$subkey.$delim, ",\n", - " subkey data must be a HASH reference" - unless ref($data) && "$data" =~ /(^|=)HASH/; - $sub->StoreKey( $subkey, $data ); - } elsif( defined($ambig) ) { - if( ref($data) && "$data" =~ /(^|=)HASH/ ) { - $sub->StoreKey( $ambig, $data ); - } else { - $sub->SetValue( $ambig, $data ); - } - } elsif( defined($key) ) { - croak "${PACK}->STORE: For ", $sub->Path.$key.$delim, ",\n", - " subkey data must be a HASH reference" - unless ref($data) && "$data" =~ /(^|=)HASH/; - $sub->StoreKey( $key, $data ); - } else { - croak "${PACK}->STORE: Key ($ent) can never be created nor set"; - } -} - - -sub EXISTS -{ - my $self= shift(@_); - my $ent= shift(@_); - return defined( $self->FETCH($ent) ); -} - - -sub FIRSTKEY -{ - my $self= shift(@_); - my $members= $self->_MemberNames; - $self->{PREVIDX}= 0; - return @{$members} ? $members->[0] : undef; -} - - -sub NEXTKEY -{ - my $self= shift(@_); - my $prev= shift(@_); - my $idx= $self->{PREVIDX}; - my $members= $self->_MemberNames; - if( ! defined($idx) || $prev ne $members->[$idx] ) { - $idx= 0; - while( $idx < @$members && $prev ne $members->[$idx] ) { - $idx++; - } - } - $self->{PREVIDX}= ++$idx; - return $members->[$idx]; -} - - -sub DESTROY -{ - my $self= shift(@_); - return if tied(%$self); - my $unload; - local $@; - eval { $unload= $self->{UNLOADME}; 1 } - or return; - my $debug= $ENV{DEBUG_TIE_REGISTRY}; - if( defined($debug) ) { - if( 1 < $debug ) { - my $hand= $self->Handle; - my $dep= $self->{DEPENDON}; - carp "${PACK} destroying ", $self->Path, " (", - "NONE" eq $hand ? $hand : sprintf("0x%lX",$hand), ")", - defined($dep) ? (" [depends on ",$dep->Path,"]") : (); - } else { - warn "${PACK} destroying ", $self->Path, ".\n"; - } - } - $self->RegCloseKey - unless "NONE" eq $self->Handle; - if( defined($unload) ) { - if( defined($debug) && 1 < $debug ) { - my( $obj, $subKey, $file )= @$unload; - warn "Unloading ", $self->Path, - " (from ", $obj->Path, ", $subKey)...\n"; - } - $self->UnLoad - || warn "Couldn't unload ", $self->Path, ": ", _ErrMsg, "\n"; - ## carp "Never unloaded ${PACK}::Load($$unload[2])"; - } - #delete $self->{DEPENDON}; -} - - -use vars qw( @CreateKey_Opts %CreateKey_Opts %_KeyDispNames ); -@CreateKey_Opts= qw( Access Class Options Delimiter - Disposition Security Volatile Backup ); -@CreateKey_Opts{@CreateKey_Opts}= (1) x @CreateKey_Opts; -%_KeyDispNames= ( REG_CREATED_NEW_KEY() => "REG_CREATED_NEW_KEY", - REG_OPENED_EXISTING_KEY() => "REG_OPENED_EXISTING_KEY" ); - -sub CreateKey -{ - my $self= shift(@_); - my $tied= tied(%$self); - $self= tied(%$self) if $tied; - my( $subKey, $opts )= @_; - my( $sam )= $self->Access; - my( $delim )= $self->Delimiter; - my( $class )= ""; - my( $flags )= 0; - my( $secure )= []; - my( $garb )= []; - my( $result )= \$garb; - my( $handle )= 0; - if( @_ < 1 || 2 < @_ - || 2 == @_ && "HASH" ne ref($opts) ) { - croak "Usage: \$new= \$old->CreateKey( \$subKey, {OPT=>VAL,...} );\n", - " options: @CreateKey_Opts\nCalled"; - } - if( defined($opts) ) { - $sam= $opts->{"Access"} if defined($opts->{"Access"}); - $class= $opts->{Class} if defined($opts->{Class}); - $flags= $opts->{Options} if defined($opts->{Options}); - $delim= $opts->{"Delimiter"} if defined($opts->{"Delimiter"}); - $secure= $opts->{Security} if defined($opts->{Security}); - if( defined($opts->{Disposition}) ) { - "SCALAR" eq ref($opts->{Disposition}) - or croak "${PACK}->CreateKey option `Disposition'", - " must provide a scalar reference"; - $result= $opts->{Disposition}; - } - if( 0 == $flags ) { - $flags |= REG_OPTION_VOLATILE - if defined($opts->{Volatile}) && $opts->{Volatile}; - $flags |= REG_OPTION_BACKUP_RESTORE - if defined($opts->{Backup}) && $opts->{Backup}; - } - } - my $subPath= ref($subKey) ? $subKey : $self->_split($subKey,$delim); - $subKey= join( $self->OS_Delimiter, @$subPath ); - $self->RegCreateKeyEx( $subKey, 0, $class, $flags, $sam, - $secure, $handle, $$result ) - or return (); - if( ! ref($$result) && $self->DualTypes ) { - $$result= _DualVal( \%_KeyDispNames, $$result ); - } - my $new= $self->_new( $handle, [ @{$self->_Path}, @{$subPath} ] ); - $new->{ACCESS}= $sam; - $new->{DELIM}= $delim; - $new= $new->TiedRef if $tied; - return $new; -} - - -use vars qw( $Load_Cnt @Load_Opts %Load_Opts ); -$Load_Cnt= 0; -@Load_Opts= qw(NewSubKey); -@Load_Opts{@Load_Opts}= (1) x @Load_Opts; - -sub Load -{ - my $this= shift(@_); - my $tied= ref($this) && tied(%$this); - $this= tied(%$this) if $tied; - my( $file, $subKey, $opts )= @_; - if( 2 == @_ && "HASH" eq ref($subKey) ) { - $opts= $subKey; - undef $subKey; - } - @_ < 1 || 3 < @_ || defined($opts) && "HASH" ne ref($opts) - and croak "Usage: \$key= ", - "${PACK}->Load( \$fileName, [\$newSubKey,] {OPT=>VAL...} );\n", - " options: @Load_Opts @new_Opts\nCalled"; - if( defined($opts) && exists($opts->{NewSubKey}) ) { - $subKey= delete $opts->{NewSubKey}; - } - if( ! defined( $subKey ) ) { - if( "" ne $this->Machine ) { - ( $this )= $this->_connect( [$this->Machine,"LMachine"] ); - } else { - ( $this )= $this->_rootKey( "LMachine" ); # Could also be "Users" - } - $subKey= "PerlTie:$$." . ++$Load_Cnt; - } - $this->RegLoadKey( $subKey, $file ) - or return (); - my $self= $this->new( $subKey, defined($opts) ? $opts : () ); - if( ! defined( $self ) ) { - { my $err= Win32::GetLastError(); - #{ local( $^E ); #} - $this->RegUnLoadKey( $subKey ) or carp - "Can't unload $subKey from ", $this->Path, ": ", _ErrMsg, "\n"; - Win32::SetLastError($err); - } - return (); - } - $self->{UNLOADME}= [ $this, $subKey, $file ]; - $self= $self->TiedRef if $tied; - return $self; -} - - -sub UnLoad -{ - my $self= shift(@_); - $self= tied(%$self) if tied(%$self); - @_ and croak "Usage: \$key->UnLoad;"; - my $unload= $self->{UNLOADME}; - "ARRAY" eq ref($unload) - or croak "${PACK}->UnLoad called on a key which was not Load()ed"; - my( $obj, $subKey, $file )= @$unload; - $self->RegCloseKey; - return Win32API::Registry::RegUnLoadKey( $obj->Handle, $subKey ); -} - - -sub AllowSave -{ - my $self= shift(@_); - $self= tied(%$self) if tied(%$self); - return $self->AllowPriv( "SeBackupPrivilege", @_ ); -} - - -sub AllowLoad -{ - my $self= shift(@_); - $self= tied(%$self) if tied(%$self); - return $self->AllowPriv( "SeRestorePrivilege", @_ ); -} - - -# RegNotifyChangeKeyValue( hKey, bWatchSubtree, iNotifyFilter, hEvent, bAsync ) - - -sub RegCloseKey { my $self= shift(@_); - Win32API::Registry::RegCloseKey $self->Handle, @_; } -sub RegConnectRegistry { my $self= shift(@_); - Win32API::Registry::RegConnectRegistry @_; } -sub RegCreateKey { my $self= shift(@_); - Win32API::Registry::RegCreateKey $self->Handle, @_; } -sub RegCreateKeyEx { my $self= shift(@_); - Win32API::Registry::RegCreateKeyEx $self->Handle, @_; } -sub RegDeleteKey { my $self= shift(@_); - Win32API::Registry::RegDeleteKey $self->Handle, @_; } -sub RegDeleteValue { my $self= shift(@_); - Win32API::Registry::RegDeleteValue $self->Handle, @_; } -sub RegEnumKey { my $self= shift(@_); - Win32API::Registry::RegEnumKey $self->Handle, @_; } -sub RegEnumKeyEx { my $self= shift(@_); - Win32API::Registry::RegEnumKeyEx $self->Handle, @_; } -sub RegEnumValue { my $self= shift(@_); - Win32API::Registry::RegEnumValue $self->Handle, @_; } -sub RegFlushKey { my $self= shift(@_); - Win32API::Registry::RegFlushKey $self->Handle, @_; } -sub RegGetKeySecurity { my $self= shift(@_); - Win32API::Registry::RegGetKeySecurity $self->Handle, @_; } -sub RegLoadKey { my $self= shift(@_); - Win32API::Registry::RegLoadKey $self->Handle, @_; } -sub RegNotifyChangeKeyValue { my $self= shift(@_); - Win32API::Registry::RegNotifyChangeKeyValue $self->Handle, @_; } -sub RegOpenKey { my $self= shift(@_); - Win32API::Registry::RegOpenKey $self->Handle, @_; } -sub RegOpenKeyEx { my $self= shift(@_); - Win32API::Registry::RegOpenKeyEx $self->Handle, @_; } -sub RegQueryInfoKey { my $self= shift(@_); - Win32API::Registry::RegQueryInfoKey $self->Handle, @_; } -sub RegQueryMultipleValues { my $self= shift(@_); - Win32API::Registry::RegQueryMultipleValues $self->Handle, @_; } -sub RegQueryValue { my $self= shift(@_); - Win32API::Registry::RegQueryValue $self->Handle, @_; } -sub RegQueryValueEx { my $self= shift(@_); - Win32API::Registry::RegQueryValueEx $self->Handle, @_; } -sub RegReplaceKey { my $self= shift(@_); - Win32API::Registry::RegReplaceKey $self->Handle, @_; } -sub RegRestoreKey { my $self= shift(@_); - Win32API::Registry::RegRestoreKey $self->Handle, @_; } -sub RegSaveKey { my $self= shift(@_); - Win32API::Registry::RegSaveKey $self->Handle, @_; } -sub RegSetKeySecurity { my $self= shift(@_); - Win32API::Registry::RegSetKeySecurity $self->Handle, @_; } -sub RegSetValue { my $self= shift(@_); - Win32API::Registry::RegSetValue $self->Handle, @_; } -sub RegSetValueEx { my $self= shift(@_); - Win32API::Registry::RegSetValueEx $self->Handle, @_; } -sub RegUnLoadKey { my $self= shift(@_); - Win32API::Registry::RegUnLoadKey $self->Handle, @_; } -sub AllowPriv { my $self= shift(@_); - Win32API::Registry::AllowPriv @_; } - - -# Autoload methods go after =cut, and are processed by the autosplit program. - -1; -__END__ - -=head1 NAME - -Win32::TieRegistry - Powerful and easy ways to manipulate a registry -[on Win32 for now]. - -=head1 SYNOPSIS - - use Win32::TieRegistry 0.20 ( UseOptionName=>UseOptionValue[,...] ); - - $Registry->SomeMethodCall(arg1,...); - - $subKey= $Registry->{"Key\\SubKey\\"}; - $valueData= $Registry->{"Key\\SubKey\\\\ValueName"}; - $Registry->{"Key\\SubKey\\"}= { "NewSubKey" => {...} }; - $Registry->{"Key\\SubKey\\\\ValueName"}= "NewValueData"; - $Registry->{"\\ValueName"}= [ pack("fmt",$data), REG_DATATYPE ]; - -=head1 EXAMPLES - - use Win32::TieRegistry( Delimiter=>"#", ArrayValues=>0 ); - $pound= $Registry->Delimiter("/"); - $diskKey= $Registry->{"LMachine/System/Disk/"} - or die "Can't read LMachine/System/Disk key: $^E\n"; - $data= $key->{"/Information"} - or die "Can't read LMachine/System/Disk//Information value: $^E\n"; - $remoteKey= $Registry->{"//ServerA/LMachine/System/"} - or die "Can't read //ServerA/LMachine/System/ key: $^E\n"; - $remoteData= $remoteKey->{"Disk//Information"} - or die "Can't read ServerA's System/Disk//Information value: $^E\n"; - foreach $entry ( keys(%$diskKey) ) { - ... - } - foreach $subKey ( $diskKey->SubKeyNames ) { - ... - } - $diskKey->AllowSave( 1 ); - $diskKey->RegSaveKey( "C:/TEMP/DiskReg", [] ); - -=head1 DESCRIPTION - -The I<Win32::TieRegistry> module lets you manipulate the Registry -via objects [as in "object oriented"] or via tied hashes. But -you will probably mostly use a combination reference, that is, a -reference to a tied hash that has also been made an object so that -you can mix both access methods [as shown above]. - -If you did not get this module as part of L<libwin32>, you might -want to get a recent version of L<libwin32> from CPAN which should -include this module and the I<Win32API::Registry> module that it -uses. - -Skip to the L<SUMMARY> section if you just want to dive in and start -using the Registry from Perl. - -Accessing and manipulating the registry is extremely simple using -I<Win32::TieRegistry>. A single, simple expression can return -you almost any bit of information stored in the Registry. -I<Win32::TieRegistry> also gives you full access to the "raw" -underlying API calls so that you can do anything with the Registry -in Perl that you could do in C. But the "simple" interface has -been carefully designed to handle almost all operations itself -without imposing arbitrary limits while providing sensible -defaults so you can list only the parameters you care about. - -But first, an overview of the Registry itself. - -=head2 The Registry - -The Registry is a forest: a collection of several tree structures. -The root of each tree is a key. These root keys are identified by -predefined constants whose names start with "HKEY_". Although all -keys have a few attributes associated with each [a class, a time -stamp, and security information], the most important aspect of keys -is that each can contain subkeys and can contain values. - -Each subkey has a name: a string which cannot be blank and cannot -contain the delimiter character [backslash: C<'\\'>] nor nul -[C<'\0'>]. Each subkey is also a key and so can contain subkeys -and values [and has a class, time stamp, and security information]. - -Each value has a name: a string which E<can> be blank and E<can> -contain the delimiter character [backslash: C<'\\'>] and any -character except for null, C<'\0'>. Each value also has data -associated with it. Each value's data is a contiguous chunk of -bytes, which is exactly what a Perl string value is so Perl -strings will usually be used to represent value data. - -Each value also has a data type which says how to interpret the -value data. The primary data types are: - -=over - -=item REG_SZ - -A null-terminated string. - -=item REG_EXPAND_SZ - -A null-terminated string which contains substrings consisting of a -percent sign [C<'%'>], an environment variable name, then a percent -sign, that should be replaced with the value associate with that -environment variable. The system does I<not> automatically do this -substitution. - -=item REG_BINARY - -Some arbitrary binary value. You can think of these as being -"packed" into a string. - -If your system has the L<SetDualVar> module installed, -the C<DualBinVals()> option wasn't turned off, and you -fetch a C<REG_BINARY> value of 4 bytes or fewer, then -you can use the returned value in a numeric context to -get at the "unpacked" numeric value. See C<GetValue()> -for more information. - -=item REG_MULTI_SZ - -Several null-terminated strings concatenated together with an -extra trailing C<'\0'> at the end of the list. Note that the list -can include empty strings so use the value's length to determine -the end of the list, not the first occurrence of C<'\0\0'>. -It is best to set the C<SplitMultis()> option so I<Win32::TieRegistry> -will split these values into an array of strings for you. - -=item REG_DWORD - -A long [4-byte] integer value. These values are expected either -packed into a 4-character string or as a hex string of E<more than> -4 characters [but I<not> as a numeric value, unfortunately, as there is -no sure way to tell a numeric value from a packed 4-byte string that -just happens to be a string containing a valid numeric value]. - -How such values are returned depends on the C<DualBinVals()> and -C<DWordsToHex()> options. See C<GetValue()> for details. - -=back - -In the underlying Registry calls, most places which take a -subkey name also allow you to pass in a subkey "path" -- a -string of several subkey names separated by the delimiter -character, backslash [C<'\\'>]. For example, doing -C<RegOpenKeyEx(HKEY_LOCAL_MACHINE,"SYSTEM\\DISK",...)> is much -like opening the C<"SYSTEM"> subkey of C<HKEY_LOCAL_MACHINE>, -then opening its C<"DISK"> subkey, then closing the C<"SYSTEM"> -subkey. - -All of the I<Win32::TieRegistry> features allow you to use your -own delimiter in place of the system's delimiter, [C<'\\'>]. In -most of our examples we will use a forward slash [C<'/'>] as our -delimiter as it is easier to read and less error prone to use when -writing Perl code since you have to type two backslashes for each -backslash you want in a string. Note that this is true even when -using single quotes -- C<'\\HostName\LMachine\'> is an invalid -string and must be written as C<'\\\\HostName\\LMachine\\'>. - -You can also connect to the registry of other computers on your -network. This will be discussed more later. - -Although the Registry does not have a single root key, the -I<Win32::TieRegistry> module creates a virtual root key for you -which has all of the I<HKEY_*> keys as subkeys. - -=head2 Tied Hashes Documentation - -Before you can use a tied hash, you must create one. One way to -do that is via: - - use Win32::TieRegistry ( TiedHash => '%RegHash' ); - -which exports a C<%RegHash> variable into your package and ties it -to the virtual root key of the Registry. An alternate method is: - - my %RegHash; - use Win32::TieRegistry ( TiedHash => \%RegHash ); - -There are also several ways you can tie a hash variable to any -other key of the Registry, which are discussed later. - -Note that you will most likely use C<$Registry> instead of using -a tied hash. C<$Registry> is a reference to a hash that has -been tied to the virtual root of your computer's Registry [as if, -C<$Registry= \%RegHash>]. So you would use C<$Registry-E<gt>{Key}> -rather than C<$RegHash{Key}> and use C<keys %{$Registry}> rather -than C<keys %RegHash>, for example. - -For each hash which has been tied to a Registry key, the Perl -C<keys> function will return a list containing the name of each -of the key's subkeys with a delimiter character appended to it and -containing the name of each of the key's values with a delimiter -prepended to it. For example: - - keys( %{ $Registry->{"HKEY_CLASSES_ROOT\\batfile\\"} } ) - -might yield the following list value: - - ( "DefaultIcon\\", # The subkey named "DefaultIcon" - "shell\\", # The subkey named "shell" - "shellex\\", # The subkey named "shellex" - "\\", # The default value [named ""] - "\\EditFlags" ) # The value named "EditFlags" - -For the virtual root key, short-hand subkey names are used as -shown below. You can use the short-hand name, the regular -I<HKEY_*> name, or any numeric value to access these keys, but -the short-hand names are all that will be returned by the C<keys> -function. - -=over - -=item "Classes" for HKEY_CLASSES_ROOT - -Contains mappings between file name extensions and the uses -for such files along with configuration information for COM -[MicroSoft's Common Object Model] objects. Usually a link to -the C<"SOFTWARE\\Classes"> subkey of the C<HKEY_LOCAL_MACHINE> -key. - -=item "CUser" for HKEY_CURRENT_USER - -Contains information specific to the currently logged-in user. -Mostly software configuration information. Usually a link to -a subkey of the C<HKEY_USERS> key. - -=item "LMachine" for HKEY_LOCAL_MACHINE - -Contains all manner of information about the computer. - -=item "Users" for HKEY_USERS - -Contains one subkey, C<".DEFAULT">, which gets copied to a new -subkey whenever a new user is added. Also contains a subkey for -each user of the system, though only those for active users -[usually only one] are loaded at any given time. - -=item "PerfData" for HKEY_PERFORMANCE_DATA - -Used to access data about system performance. Access via this key -is "special" and all but the most carefully constructed calls will -fail, usually with C<ERROR_INSUFFICIENT_BUFFER>. For example, you -can't enumerate key names without also enumerating values which -require huge buffers but the exact buffer size required cannot be -determined beforehand because C<RegQueryInfoKey()> E<always> fails -with C<ERROR_INSUFFICIENT_BUFFER> for C<HKEY_PERFORMANCE_DATA> no -matter how it is called. So it is currently not very useful to -tie a hash to this key. You can use it to create an object to use -for making carefully constructed calls to the underlying Reg*() -routines. - -=item "CConfig" for HKEY_CURRENT_CONFIG - -Contains minimal information about the computer's current -configuration that is required very early in the boot process. -For example, setting for the display adapter such as screen -resolution and refresh rate are found in here. - -=item "DynData" for HKEY_DYN_DATA - -Dynamic data. We have found no documentation for this key. - -=back - -A tied hash is much like a regular hash variable in Perl -- you give -it a key string inside braces, [C<{> and C<}>], and it gives you -back a value [or lets you set a value]. For I<Win32::TieRegistry> -hashes, there are two types of values that will be returned. - -=over - -=item SubKeys - -If you give it a string which represents a subkey, then it will -give you back a reference to a hash which has been tied to that -subkey. It can't return the hash itself, so it returns a -reference to it. It also blesses that reference so that it is -also an object so you can use it to call method functions. - -=item Values - -If you give it a string which is a value name, then it will give -you back a string which is the data for that value. Alternately, -you can request that it give you both the data value string and -the data value type [we discuss how to request this later]. In -this case, it would return a reference to an array where the value -data string is element C<[0]> and the value data type is element -C<[1]>. - -=back - -The key string which you use in the tied hash must be interpreted -to determine whether it is a value name or a key name or a path -that combines several of these or even other things. There are -two simple rules that make this interpretation easy and -unambiguous: - - Put a delimiter after each key name. - Put a delimiter in front of each value name. - -Exactly how the key string will be intepreted is governed by the -following cases, in the order listed. These cases are designed -to "do what you mean". Most of the time you won't have to think -about them, especially if you follow the two simple rules above. -After the list of cases we give several examples which should be -clear enough so feel free to skip to them unless you are worried -about the details. - -=over - -=item Remote machines - -If the hash is tied to the virtual root of the registry [or the -virtual root of a remote machine's registry], then we treat hash -key strings which start with the delimiter character specially. - -If the hash key string starts with two delimiters in a row, then -those should be immediately followed by the name of a remote -machine whose registry we wish to connect to. That can be -followed by a delimiter and more subkey names, etc. If the -machine name is not following by anything, then a virtual root -for the remote machine's registry is created, a hash is tied to -it, and a reference to that hash it is returned. - -=item Hash key string starts with the delimiter - -If the hash is tied to a virtual root key, then the leading -delimiter is ignored. It should be followed by a valid Registry -root key name [either a short-hand name like C<"LMachine">, an -I<HKEY_*> value, or a numeric value]. This alternate notation is -allowed in order to be more consistant with the C<Open()> method -function. - -For all other Registry keys, the leading delimiter indicates -that the rest of the string is a value name. The leading -delimiter is stripped and the rest of the string [which can -be empty and can contain more delimiters] is used as a value -name with no further parsing. - -=item Exact match with direct subkey name followed by delimiter - -If you have already called the Perl C<keys> function on the tied -hash [or have already called C<MemberNames> on the object] and the -hash key string exactly matches one of the strings returned, then -no further parsing is done. In other words, if the key string -exactly matches the name of a direct subkey with a delimiter -appended, then a reference to a hash tied to that subkey is -returned [but only if C<keys> or C<MemberNames> has already -been called for that tied hash]. - -This is only important if you have selected a delimiter other than -the system default delimiter and one of the subkey names contains -the delimiter you have chosen. This rule allows you to deal with -subkeys which contain your chosen delimiter in their name as long -as you only traverse subkeys one level at a time and always -enumerate the list of members before doing so. - -The main advantage of this is that Perl code which recursively -traverses a hash will work on hashes tied to Registry keys even if -a non-default delimiter has been selected. - -=item Hash key string contains two delimiters in a row - -If the hash key string contains two [or more] delimiters in a row, -then the string is split between the first pair of delimiters. -The first part is interpreted as a subkey name or a path of subkey -names separated by delimiters and with a trailing delimiter. The -second part is interpreted as a value name with one leading -delimiter [any extra delimiters are considered part of the value -name]. - -=item Hash key string ends with a delimiter - -If the key string ends with a delimiter, then it is treated -as a subkey name or path of subkey names separated by delimiters. - -=item Hash key string contains a delimiter - -If the key string contains a delimiter, then it is split after -the last delimiter. The first part is treated as a subkey name or -path of subkey names separated by delimiters. The second part -is ambiguous and is treated as outlined in the next item. - -=item Hash key string contains no delimiters - -If the hash key string contains no delimiters, then it is ambiguous. - -If you are reading from the hash [fetching], then we first use the -key string as a value name. If there is a value with a matching -name in the Registry key which the hash is tied to, then the value -data string [and possibly the value data type] is returned. -Otherwise, we retry by using the hash key string as a subkey name. -If there is a subkey with a matching name, then we return a -reference to a hash tied to that subkey. Otherwise we return -C<undef>. - -If you are writing to the hash [storing], then we use the key -string as a subkey name only if the value you are storing is a -reference to a hash value. Otherwise we use the key string as -a value name. - -=back - -=head3 Examples - -Here are some examples showing different ways of accessing Registry -information using references to tied hashes: - -=over - -=item Canonical value fetch - - $tip18= $Registry->{"HKEY_LOCAL_MACHINE\\Software\\Microsoft\\" - . 'Windows\\CurrentVersion\\Explorer\\Tips\\\\18'}; - -Should return the text of important tip number 18. Note that two -backslashes, C<"\\">, are required to get a single backslash into -a Perl double-quoted or single-qouted string. Note that C<"\\"> -is appended to each key name [C<"HKEY_LOCAL_MACHINE"> through -C<"Tips">] and C<"\\"> is prepended to the value name, C<"18">. - -=item Changing your delimiter - - $Registry->Delimiter("/"); - $tip18= $Registry->{"HKEY_LOCAL_MACHINE/Software/Microsoft/" - . 'Windows/CurrentVersion/Explorer/Tips//18'}; - -This usually makes things easier to read when working in Perl. -All remaining examples will assume the delimiter has been changed -as above. - -=item Using intermediate keys - - $ms= $Registry->{"LMachine/Software/Microsoft/"}; - $tips= $ms->{"Windows/CurrentVersion/Explorer/Tips/"}; - $tip18= $winlogon->{"/18"}; - -Same as above but opens more keys into the Registry which lets you -efficiently re-access those intermediate keys. This is slightly -less efficient if you never reuse those intermediate keys. - -=item Chaining in a single statement - - $tip18= $Registry->{"LMachine/Software/Microsoft/"}-> - {"Windows/CurrentVersion/Explorer/Tips/"}->{"/18"}; - -Like above, this creates intermediate key objects then uses -them to access other data. Once this statement finishes, the -intermediate key objects are destroyed. Several handles into -the Registry are opened and closed by this statement so it is -less efficient but there are times when this will be useful. - -=item Even less efficient example of chaining - - $tip18= $Registry->{"LMachine/Software/Microsoft"}-> - {"Windows/CurrentVersion/Explorer/Tips"}->{"/18"}; - -Because we left off the trailing delimiters, I<Win32::TieRegistry> -doesn't know whether final names, C<"Microsoft"> and C<"Tips">, -are subkey names or value names. So this statement ends up -executing the same code as the next one. - -=item What the above really does - - $tip18= $Registry->{"LMachine/Software/"}->{"Microsoft"}-> - {"Windows/CurrentVersion/Explorer/"}->{"Tips"}->{"/18"}; - -With more chains to go through, more temporary objects are created -and later destroyed than in our first chaining example. Also, -when C<"Microsoft"> is looked up, I<Win32::TieRegistry> first -tries to open it as a value and fails then tries it as a subkey. -The same is true for when it looks up C<"Tips">. - -=item Getting all of the tips - - $tips= $Registry->{"LMachine/Software/Microsoft/"}-> - {"Windows/CurrentVersion/Explorer/Tips/"} - or die "Can't find the Windows tips: $^E\n"; - foreach( keys %$tips ) { - print "$_: ", $tips->{$_}, "\n"; - } - -First notice that we actually check for failure for the first -time. We are assuming that the C<"Tips"> key contains no subkeys. -Otherwise the C<print> statement would show something like -C<"Win32::TieRegistry=HASH(0xc03ebc)"> for each subkey. - -The output from the above code will start something like: - - /0: If you don't know how to do something,[...] - -=back - -=head3 Deleting items - -You can use the Perl C<delete> function to delete a value from a -Registry key or to delete a subkey as long that subkey contains -no subkeys of its own. See L<More Examples>, below, for more -information. - -=head3 Storing items - -You can use the Perl assignment operator [C<=>] to create new -keys, create new values, or replace values. The values you store -should be in the same format as the values you would fetch from a -tied hash. For example, you can use a single assignment statement -to copy an entire Registry tree. The following statement: - - $Registry->{"LMachine/Software/Classes/Tie_Registry/"}= - $Registry->{"LMachine/Software/Classes/batfile/"}; - -creates a C<"Tie_Registry"> subkey under the C<"Software\\Classes"> -subkey of the C<HKEY_LOCAL_MACHINE> key. Then it populates it -with copies of all of the subkeys and values in the C<"batfile"> -subkey and all of its subkeys. Note that you need to have -called C<$Registry-E<gt>ArrayValues(1)> for the proper value data -type information to be copied. Note also that this release of -I<Win32::TieRegistry> does not copy key attributes such as class -name and security information [this is planned for a future release]. - -The following statement creates a whole subtree in the Registry: - - $Registry->{"LMachine/Software/FooCorp/"}= { - "FooWriter/" => { - "/Version" => "4.032", - "Startup/" => { - "/Title" => "Foo Writer Deluxe ][", - "/WindowSize" => [ pack("LL",$wid,$ht), "REG_BINARY" ], - "/TaskBarIcon" => [ "0x0001", "REG_DWORD" ], - }, - "Compatibility/" => { - "/AutoConvert" => "Always", - "/Default Palette" => "Windows Colors", - }, - }, - "/License", => "0123-9C8EF1-09-FC", - }; - -Note that all but the last Registry key used on the left-hand -side of the assignment [that is, "LMachine/Software/" but not -"FooCorp/"] must already exist for this statement to succeed. - -By using the leading a trailing delimiters on each subkey name and -value name, I<Win32::TieRegistry> will tell you if you try to assign -subkey information to a value or visa-versa. - -=head3 More examples - -=over - -=item Adding a new tip - - $tips= $Registry->{"LMachine/Software/Microsoft/"}-> - {"Windows/CurrentVersion/Explorer/Tips/"} - or die "Can't find the Windows tips: $^E\n"; - $tips{'/186'}= "Be very careful when making changes to the Registry!"; - -=item Deleting our new tip - - $tips= $Registry->{"LMachine/Software/Microsoft/"}-> - {"Windows/CurrentVersion/Explorer/Tips/"} - or die "Can't find the Windows tips: $^E\n"; - $tip186= delete $tips{'/186'}; - -Note that Perl's C<delete> function returns the value that was deleted. - -=item Adding a new tip differently - - $Registry->{"LMachine/Software/Microsoft/" . - "Windows/CurrentVersion/Explorer/Tips//186"}= - "Be very careful when making changes to the Registry!"; - -=item Deleting differently - - $tip186= delete $Registry->{"LMachine/Software/Microsoft/Windows/" . - "CurrentVersion/Explorer/Tips//186"}; - -Note that this only deletes the tail of what we looked up, the -C<"186"> value, not any of the keys listed. - -=item Deleting a key - -WARNING: The following code will delete all information about the -current user's tip preferences. Actually executing this command -would probably cause the user to see the Welcome screen the next -time they log in and may cause more serious problems. This -statement is shown as an example only and should not be used when -experimenting. - - $tips= delete $Registry->{"CUser/Software/Microsoft/Windows/" . - "CurrentVersion/Explorer/Tips/"}; - -This deletes the C<"Tips"> key and the values it contains. The -C<delete> function will return a reference to a hash [not a tied -hash] containing the value names and value data that were deleted. - -The information to be returned is copied from the Registry into a -regular Perl hash before the key is deleted. If the key has many -subkeys, this copying could take a significant amount of memory -and/or processor time. So you can disable this process by calling -the C<FastDelete> member function: - - $prevSetting= $regKey->FastDelete(1); - -which will cause all subsequent delete operations via C<$regKey> -to simply return a true value if they succeed. This optimization -is automatically done if you use C<delete> in a void context. - -=item Technical notes on deleting - -If you use C<delete> to delete a Registry key or value and use -the return value, then I<Win32::TieRegistry> usually looks up the -current contents of that key or value so they can be returned if -the deletion is successful. If the deletion succeeds but the -attempt to lookup the old contents failed, then the return value -of C<delete> will be C<$^E> from the failed part of the operation. - -=item Undeleting a key - - $Registry->{"LMachine/Software/Microsoft/Windows/" . - "CurrentVersion/Explorer/Tips/"}= $tips; - -This adds back what we just deleted. Note that this version of -I<Win32::TieRegistry> will use defaults for the key attributes -[such as class name and security] and will not restore the -previous attributes. - -=item Not deleting a key - -WARNING: Actually executing the following code could cause -serious problems. This statement is shown as an example only and -should not be used when experimenting. - - $res= delete $Registry->{"CUser/Software/Microsoft/Windows/"} - defined($res) || die "Can't delete URL key: $^E\n"; - -Since the "Windows" key should contain subkeys, that C<delete> -statement should make no changes to the Registry, return C<undef>, -and set C<$^E> to "Access is denied". - -=item Not deleting again - - $tips= $Registry->{"CUser/Software/Microsoft/Windows/" . - "CurrentVersion/Explorer/Tips/"}; - delete $tips; - -The Perl C<delete> function requires that its argument be an -expression that ends in a hash element lookup [or hash slice], -which is not the case here. The C<delete> function doesn't -know which hash $tips came from and so can't delete it. - -=back - -=head2 Objects Documentation - -The following member functions are defined for use on -I<Win32::TieRegistry> objects: - -=over - -=item new - -The C<new> method creates a new I<Win32::TieRegistry> object. -C<new> is mostly a synonym for C<Open()> so see C<Open()> below for -information on what arguments to pass in. Examples: - - $machKey= new Win32::TieRegistry "LMachine" - or die "Can't access HKEY_LOCAL_MACHINE key: $^E\n"; - $userKey= Win32::TieRegistry->new("CUser") - or die "Can't access HKEY_CURRENT_USER key: $^E\n"; - -Note that calling C<new> via a reference to a tied hash returns -a simple object, not a reference to a tied hash. - -=item Open - -=item $subKey= $key->Open( $sSubKey, $rhOptions ) - -The C<Open> method opens a Registry key and returns a new -I<Win32::TieRegistry> object associated with that Registry key. -If C<Open> is called via a reference to a tied hash, then C<Open> -returns another reference to a tied hash. Otherwise C<Open> -returns a simple object and you should then use C<TiedRef> to get -a reference to a tied hash. - -C<$sSubKey> is a string specifying a subkey to be opened. -Alternately C<$sSubKey> can be a reference to an array value -containing the list of increasingly deep subkeys specifying the -path to the subkey to be opened. - -C<$rhOptions> is an optional reference to a hash containing extra -options. The C<Open> method supports two options, C<"Delimiter"> -and C<"Access">, and C<$rhOptions> should have only have zero or -more of these strings as keys. See the "Examples" section below -for more information. - -The C<"Delimiter"> option specifies what string [usually a single -character] will be used as the delimiter to be appended to subkey -names and prepended to value names. If this option is not specified, -the new key [C<$subKey>] inherits the delimiter of the old key -[C<$key>]. - -The C<"Access"> option specifies what level of access to the -Registry key you wish to have once it has been opened. If this -option is not specified, the new key [C<$subKey>] is opened with -the same access level used when the old key [C<$key>] was opened. -The virtual root of the Registry pretends it was opened with -access C<KEY_READ()|KEY_WRITE()> so this is the default access when -opening keys directory via C<$Registry>. If you don't plan on -modifying a key, you should open it with C<KEY_READ> access as -you may not have C<KEY_WRITE> access to it or some of its subkeys. - -If the C<"Access"> option value is a string that starts with -C<"KEY_">, then it should match E<one> of the predefined access -levels [probably C<"KEY_READ">, C<"KEY_WRITE">, or -C<"KEY_ALL_ACCESS">] exported by the I<Win32API::Registry> module. -Otherwise, a numeric value is expected. For maximum flexibility, -include C<use Win32::TieRegistry qw(:KEY_);>, for example, near -the top of your script so you can specify more complicated access -levels such as C<KEY_READ()|KEY_WRITE()>. - -If C<$sSubKey> does not begin with the delimiter [or C<$sSubKey> -is an array reference], then the path to the subkey to be opened -will be relative to the path of the original key [C<$key>]. If -C<$sSubKey> begins with a single delimiter, then the path to the -subkey to be opened will be relative to the virtual root of the -Registry on whichever machine the original key resides. If -C<$sSubKey> begins with two consectutive delimiters, then those -must be followed by a machine name which causes the C<Connect()> -method function to be called. - -Examples: - - $machKey= $Registry->Open( "LMachine", {Access=>KEY_READ(),Delimiter=>"/"} ) - or die "Can't open HKEY_LOCAL_MACHINE key: $^E\n"; - $swKey= $machKey->Open( "Software" ); - $logonKey= $swKey->Open( "Microsoft/Windows NT/CurrentVersion/Winlogon/" ); - $NTversKey= $swKey->Open( ["Microsoft","Windows NT","CurrentVersion"] ); - $versKey= $swKey->Open( qw(Microsoft Windows CurrentVersion) ); - - $remoteKey= $Registry->Open( "//HostA/LMachine/System/", {Delimiter=>"/"} ) - or die "Can't connect to HostA or can't open subkey: $^E\n"; - -=item Clone - -=item $copy= $key->Clone - -Creates a new object that is associated with the same Registry key -as the invoking object. - -=item Connect - -=item $remoteKey= $Registry->Connect( $sMachineName, $sKeyPath, $rhOptions ) - -The C<Connect> method connects to the Registry of a remote machine, -and opens a key within it, then returns a new I<Win32::TieRegistry> -object associated with that remote Registry key. If C<Connect> -was called using a reference to a tied hash, then the return value -will also be a reference to a tied hash [or C<undef>]. Otherwise, -if you wish to use the returned object as a tied hash [not just as -an object], then use the C<TiedRef> method function after C<Connect>. - -C<$sMachineName> is the name of the remote machine. You don't have -to preceed the machine name with two delimiter characters. - -C<$sKeyPath> is a string specifying the remote key to be opened. -Alternately C<$sKeyPath> can be a reference to an array value -containing the list of increasingly deep keys specifying the path -to the key to be opened. - -C<$rhOptions> is an optional reference to a hash containing extra -options. The C<Connect> method supports two options, C<"Delimiter"> -and C<"Access">. See the C<Open> method documentation for more -information on these options. - -C<$sKeyPath> is already relative to the virtual root of the Registry -of the remote machine. A single leading delimiter on C<sKeyPath> -will be ignored and is not required. - -C<$sKeyPath> can be empty in which case C<Connect> will return an -object representing the virtual root key of the remote Registry. -Each subsequent use of C<Open> on this virtual root key will call -the system C<RegConnectRegistry> function. - -The C<Connect> method can be called via any I<Win32::TieRegistry> -object, not just C<$Registry>. Attributes such as the desired -level of access and the delimiter will be inherited from the -object used but the C<$sKeyPath> will always be relative to the -virtual root of the remote machine's registry. - -Examples: - - $remMachKey= $Registry->Connect( "HostA", "LMachine", {Delimiter->"/"} ) - or die "Can't connect to HostA's HKEY_LOCAL_MACHINE key: $^E\n"; - - $remVersKey= $remMachKey->Connect( "www.microsoft.com", - "LMachine/Software/Microsoft/Inetsrv/CurrentVersion/", - { Access=>KEY_READ, Delimiter=>"/" } ) - or die "Can't check what version of IIS Microsoft is running: $^E\n"; - - $remVersKey= $remMachKey->Connect( "www", - qw(LMachine Software Microsoft Inetsrv CurrentVersion) ) - or die "Can't check what version of IIS we are running: $^E\n"; - -=item ObjectRef - -=item $object_ref= $obj_or_hash_ref->ObjectRef - -For a simple object, just returns itself [C<$obj == $obj->ObjectRef>]. - -For a reference to a tied hash [if it is also an object], C<ObjectRef> -returns the simple object that the hash is tied to. - -This is primarilly useful when debugging since typing C<x $Registry> -will try to display your I<entire> registry contents to your screen. -But the debugger command C<x $Registry->ObjectRef> will just dump -the implementation details of the underlying object to your screen. - -=item Flush( $bFlush ) - -Flushes all cached information about the Registry key so that future -uses will get fresh data from the Registry. - -If the optional C<$bFlush> is specified and a true value, then -C<RegFlushKey()> will be called, which is almost never necessary. - -=item GetValue - -=item $ValueData= $key->GetValue( $sValueName ) - -=item ($ValueData,$ValueType)= $key->GetValue( $sValueName ) - -Gets a Registry value's data and data type. - -C<$ValueData> is usually just a Perl string that contains the -value data [packed into it]. For certain types of data, however, -C<$ValueData> may be processed as described below. - -C<$ValueType> is the C<REG_*> constant describing the type of value -data stored in C<$ValueData>. If the C<DualTypes()> option is on, -then C<$ValueType> will be a dual value. That is, when used in a -numeric context, C<$ValueType> will give the numeric value of a -C<REG_*> constant. However, when used in a non-numeric context, -C<$ValueType> will return the name of the C<REG_*> constant, for -example C<"REG_SZ"> [note the quotes]. So both of the following -can be true at the same time: - - $ValueType == REG_SZ() - $ValueType eq "REG_SZ" - -=over - -=item REG_SZ and REG_EXPAND_SZ - -If the C<FixSzNulls()> option is on, then the trailing C<'\0'> will be -stripped [unless there isn't one] before values of type C<REG_SZ> -and C<REG_EXPAND_SZ> are returned. Note that C<SetValue()> will add -a trailing C<'\0'> under similar circumstances. - -=item REG_MULTI_SZ - -If the C<SplitMultis()> option is on, then values of this type are -returned as a reference to an array containing the strings. For -example, a value that, with C<SplitMultis()> off, would be returned as: - - "Value1\000Value2\000\000" - -would be returned, with C<SplitMultis()> on, as: - - [ "Value1", "Value2" ] - -=item REG_DWORD - -If the C<DualBinVals()> option is on, then the value is returned -as a scalar containing both a string and a number [much like -the C<$!> variable -- see the L<SetDualVar> module for more -information] where the number part is the "unpacked" value. -Use the returned value in a numeric context to access this part -of the value. For example: - - $num= 0 + $Registry->{"CUser/Console//ColorTable01"}; - -If the C<DWordsToHex()> option is off, the string part of the -returned value is a packed, 4-byte string [use C<unpack("L",$value)> -to get the numeric value. - -If C<DWordsToHex()> is on, the string part of the returned value is -a 10-character hex strings [with leading "0x"]. You can use -C<hex($value)> to get the numeric value. - -Note that C<SetValue()> will properly understand each of these -returned value formats no matter how C<DualBinVals()> is set. - -=back - -=item ValueNames - -=item @names= $key->ValueNames - -Returns the list of value names stored directly in a Registry key. -Note that the names returned do I<not> have a delimiter prepended -to them like with C<MemberNames()> and tied hashes. - -Once you request this information, it is cached in the object and -future requests will always return the same list unless C<Flush()> -has been called. - -=item SubKeyNames - -=item @key_names= $key->SubKeyNames - -Returns the list of subkey names stored directly in a Registry key. -Note that the names returned do I<not> have a delimiter appended -to them like with C<MemberNames()> and tied hashes. - -Once you request this information, it is cached in the object and -future requests will always return the same list unless C<Flush()> -has been called. - -=item SubKeyClasses - -=item @classes= $key->SubKeyClasses - -Returns the list of classes for subkeys stored directly in a -Registry key. The classes are returned in the same order as -the subkey names returned by C<SubKeyNames()>. - -=item SubKeyTimes - -=item @times= $key->SubKeyTimes - -Returns the list of last-modified times for subkeys stored -directly in a Registry key. The times are returned in the same -order as the subkey names returned by C<SubKeyNames()>. Each -time is a C<FILETIME> structure packed into a Perl string. - -Once you request this information, it is cached in the object and -future requests will always return the same list unless C<Flush()> -has been called. - -=item MemberNames - -=item @members= $key->MemberNames - -Returns the list of subkey names and value names stored directly -in a Registry key. Subkey names have a delimiter appended to the -end and value names have a delimiter prepended to the front. - -Note that a value name could end in a delimiter [or could be C<""> -so that the member name returned is just a delimiter] so the -presence or absence of the leading delimiter is what should be -used to determine whether a particular name is for a subkey or a -value, not the presence or absence of a trailing delimiter. - -Once you request this information, it is cached in the object and -future requests will always return the same list unless C<Flush()> -has been called. - -=item Information - -=item %info= $key->Information - -=item @items= $key->Information( @itemNames ); - -Returns the following information about a Registry key: - -=over - -=item LastWrite - -A C<FILETIME> structure indicating when the key was last modified -and packed into a Perl string. - -=item CntSubKeys - -The number of subkeys stored directly in this key. - -=item CntValues - -The number of values stored directly in this key. - -=item SecurityLen - -The length [in bytes] of the largest[?] C<SECURITY_DESCRIPTOR> -associated with the Registry key. - -=item MaxValDataLen - -The length [in bytes] of the longest value data associated with -a value stored in this key. - -=item MaxSubKeyLen - -The length [in chars] of the longest subkey name associated with -a subkey stored in this key. - -=item MaxSubClassLen - -The length [in chars] of the longest class name associated with -a subkey stored directly in this key. - -=item MaxValNameLen - -The length [in chars] of the longest value name associated with -a value stored in this key. - -=back - -With no arguments, returns a hash [not a reference to a hash] where -the keys are the names for the items given above and the values -are the information describe above. For example: - - %info= ( "CntValues" => 25, # Key contains 25 values. - "MaxValNameLen" => 20, # One of which has a 20-char name. - "MaxValDataLen" => 42, # One of which has a 42-byte value. - "CntSubKeys" => 1, # Key has 1 immediate subkey. - "MaxSubKeyLen" => 13, # One of which has a 12-char name. - "MaxSubClassLen" => 0, # All of which have class names of "". - "SecurityLen" => 232, # One SECURITY_DESCRIPTOR is 232 bytes. - "LastWrite" => "\x90mZ\cX{\xA3\xBD\cA\c@\cA" - # Key was last modifed 1998/06/01 16:29:32 GMT - ); - -With arguments, each one must be the name of a item given above. -The return value is the information associated with the listed -names. In other words: - - return $key->Information( @names ); - -returns the same list as: - - %info= $key->Information; - return @info{@names}; - -=item Delimiter - -=item $oldDelim= $key->Delimiter - -=item $oldDelim= $key->Delimiter( $newDelim ) - -Gets and possibly changes the delimiter used for this object. The -delimiter is appended to subkey names and prepended to value names -in many return values. It is also used when parsing keys passed -to tied hashes. - -The delimiter defaults to backslash (C<'\\'>) but is inherited from -the object used to create a new object and can be specified by an -option when a new object is created. - -=item Handle - -=item $handle= $key->Handle - -Returns the raw C<HKEY> handle for the associated Registry key as -an integer value. This value can then be used to Reg*() calls -from I<Win32API::Registry>. However, it is usually easier to just -call the I<Win32API::Registry> calls directly via: - - $key->RegNotifyChangeKeyValue( ... ); - -For the virtual root of the local or a remote Registry, -C<Handle()> return C<"NONE">. - -=item Path - -=item $path= $key->Path - -Returns a string describing the path of key names to this -Registry key. The string is built so that if it were passed -to C<$Registry->Open()>, it would reopen the same Registry key -[except in the rare case where one of the key names contains -C<$key->Delimiter>]. - -=item Machine - -=item $computerName= $key->Machine - -Returns the name of the computer [or "machine"] on which this Registry -key resides. Returns C<""> for local Registry keys. - -=item Access - -Returns the numeric value of the bit mask used to specify the -types of access requested when this Registry key was opened. Can -be compared to C<KEY_*> values. - -=item OS_Delimiter - -Returns the delimiter used by the operating system's RegOpenKeyEx() -call. For Win32, this is always backslash (C<"\\">). - -=item Roots - -Returns the mapping from root key names like C<"LMachine"> to their -associated C<HKEY_*> constants. Primarily for internal use and -subject to change. - -=item Tie - -=item $key->Tie( \%hash ); - -Ties the referenced hash to that Registry key. Pretty much the -same as - - tie %hash, ref($key), $key; - -Since C<ref($key)> is the class [package] to tie the hash to and -C<TIEHASH()> just returns its argument, C<$key>, [without calling -C<new()>] when it sees that it is already a blessed object. - -=item TiedRef - -=item $TiedHashRef= $hash_or_obj_ref->TiedRef - -For a simple object, returns a reference to a hash tied to the -object. Used to promote a simple object into a combined object -and hash ref. - -If already a reference to a tied hash [that is also an object], -it just returns itself [C<$ref == $ref->TiedRef>]. - -Mostly used internally. - -=item ArrayValues - -=item $oldBool= $key->ArrayValues - -=item $oldBool= $key->ArrayValues( $newBool ) - -Gets the current setting of the C<ArrayValues> option and possibly -turns it on or off. - -When off, Registry values fetched via a tied hash are returned as -just a value scalar [the same as C<GetValue()> in a scalar context]. -When on, they are returned as a reference to an array containing -the value data as the C<[0]> element and the data type as the C<[1]> -element. - -=item TieValues - -=item $oldBool= TieValues - -=item $oldBool= TieValues( $newBool ) - -Gets the current setting of the C<TieValues> option and possibly -turns it on or off. - -Turning this option on is not yet supported in this release of -I<Win32::TieRegistry>. In a future release, turning this option -on will cause Registry values returned from a tied hash to be -a tied array that you can use to modify the value in the Registry. - -=item FastDelete - -=item $oldBool= $key->FastDelete - -=item $oldBool= $key->FastDelete( $newBool ) - -Gets the current setting of the C<FastDelete> option and possibly -turns it on or off. - -When on, successfully deleting a Registry key [via a tied hash] -simply returns C<1>. - -When off, successfully deleting a Registry key [via a tied hash -and not in a void context] returns a reference to a hash that -contains the values present in the key when it was deleted. This -hash is just like that returned when referencing the key before it -was deleted except that it is an ordinary hash, not one tied to -the I<Win32::TieRegistry> package. - -Note that deleting either a Registry key or value via a tied hash -I<in a void context> prevents any overhead in trying to build an -appropriate return value. - -Note that deleting a Registry I<value> via a tied hash [not in -a void context] returns the value data even if <FastDelete> is on. - -=item SplitMultis - -=item $oldBool= $key->SplitMultis - -=item $oldBool= $key->SplitMultis( $newBool ) - -Gets the current setting of the C<SplitMultis> option and possibly -turns it on or off. - -If on, Registry values of type C<REG_MULTI_SZ> are returned as -a reference to an array of strings. See C<GetValue()> for more -information. - -=item DWordsToHex - -=item $oldBool= $key->DWordsToHex - -=item $oldBool= $key->DWordsToHex( $newBool ) - -Gets the current setting of the C<DWordsToHex> option and possibly -turns it on or off. - -If on, Registry values of type C<REG_DWORD> are returned as a hex -string with leading C<"0x"> and longer than 4 characters. See -C<GetValue()> for more information. - -=item FixSzNulls - -=item $oldBool= $key->FixSzNulls - -=item $oldBool= $key->FixSzNulls( $newBool ) - -Gets the current setting of the C<FixSzNulls> option and possibly -turns it on or off. - -If on, Registry values of type C<REG_SZ> and C<REG_EXPAND_SZ> have -trailing C<'\0'>s added before they are set and stripped before -they are returned. See C<GetValue()> and C<SetValue()> for more -information. - -=item DualTypes - -=item $oldBool= $key->DualTypes - -=item $oldBool= $key->DualTypes( $newBool ) - -Gets the current setting of the C<DualTypes> option and possibly -turns it on or off. - -If on, data types are returned as a combined numeric/string value -holding both the numeric value of a C<REG_*> constant and the -string value of the constant's name. See C<GetValue()> for -more information. - -=item DualBinVals - -=item $oldBool= $key->DualBinVals - -=item $oldBool= $key->DualBinVals( $newBool ) - -Gets the current setting of the C<DualBinVals> option and possibly -turns it on or off. - -If on, Registry value data of type C<REG_BINARY> and no more than -4 bytes long and Registry values of type C<REG_DWORD> are returned -as a combined numeric/string value where the numeric value is the -"unpacked" binary value as returned by: - - hex reverse unpack( "h*", $valData ) - -on a "little-endian" computer. [Would be C<hex unpack("H*",$valData)> -on a "big-endian" computer if this module is ever ported to one.] - -See C<GetValue()> for more information. - -=item GetOptions - -=item @oldOptValues= $key->GetOptions( @optionNames ) - -=item $refHashOfOldOpts= $key->GetOptions() - -=item $key->GetOptions( \%hashForOldOpts ) - -Returns the current setting of any of the following options: - - Delimiter FixSzNulls DWordsToHex - ArrayValues SplitMultis DualBinVals - TieValues FastDelete DualTypes - -Pass in one or more of the above names (as strings) to get back -an array of the corresponding current settings in the same order: - - my( $fastDel, $delim )= $key->GetOptions("FastDelete","Delimiter"); - -Pass in no arguments to get back a reference to a hash where -the above option names are the keys and the values are -the corresponding current settings for each option: - - my $href= $key->GetOptions(); - my $delim= $href->{Delimiter}; - -Pass in a single reference to a hash to have the above key/value -pairs I<added> to the referenced hash. For this case, the -return value is the original object so further methods can be -chained after the call to GetOptions: - - my %oldOpts; - $key->GetOptions( \%oldOpts )->SetOptions( Delimiter => "/" ); - -=item SetOptions - -=item @oldOpts= $key->SetOptions( optNames=>$optValue,... ) - -Changes the current setting of any of the following options, -returning the previous setting(s): - - Delimiter FixSzNulls DWordsToHex AllowLoad - ArrayValues SplitMultis DualBinVals AllowSave - TieValues FastDelete DualTypes - -For C<AllowLoad> and C<AllowSave>, instead of the previous -setting, C<SetOptions> returns whether or not the change was -successful. - -In a scalar context, returns only the last item. The last -option can also be specified as C<"ref"> or C<"r"> [which doesn't -need to be followed by a value] to allow chaining: - - $key->SetOptions(AllowSave=>1,"ref")->RegSaveKey(...) - -=item SetValue - -=item $okay= $key->SetValue( $ValueName, $ValueData ); - -=item $okay= $key->SetValue( $ValueName, $ValueData, $ValueType ); - -Adds or replaces a Registry value. Returns a true value if -successfully, false otherwise. - -C<$ValueName> is the name of the value to add or replace and -should I<not> have a delimiter prepended to it. Case is ignored. - -C<$ValueType> is assumed to be C<REG_SZ> if it is omitted. Otherwise, -it should be one the C<REG_*> constants. - -C<$ValueData> is the data to be stored in the value, probably packed -into a Perl string. Other supported formats for value data are -listed below for each posible C<$ValueType>. - -=over - -=item REG_SZ or REG_EXPAND_SZ - -The only special processing for these values is the addition of -the required trailing C<'\0'> if it is missing. This can be -turned off by disabling the C<FixSzNulls> option. - -=item REG_MULTI_SZ - -These values can also be specified as a reference to a list of -strings. For example, the following two lines are equivalent: - - $key->SetValue( "Val1\000Value2\000LastVal\000\000", "REG_MULTI_SZ" ); - $key->SetValue( ["Val1","Value2","LastVal"], "REG_MULTI_SZ" ); - -Note that if the required two trailing nulls (C<"\000\000">) are -missing, then this release of C<SetValue()> will I<not> add them. - -=item REG_DWORD - -These values can also be specified as a hex value with the leading -C<"0x"> included and totaling I<more than> 4 bytes. These will be -packed into a 4-byte string via: - - $data= pack( "L", hex($data) ); - -=item REG_BINARY - -This value type is listed just to emphasize that no alternate -format is supported for it. In particular, you should I<not> pass -in a numeric value for this type of data. C<SetValue()> cannot -distinguish such from a packed string that just happens to match -a numeric value and so will treat it as a packed string. - -=back - -An alternate calling format: - - $okay= $key->SetValue( $ValueName, [ $ValueData, $ValueType ] ); - -[two arguments, the second of which is a reference to an array -containing the value data and value type] is supported to ease -using tied hashes with C<SetValue()>. - -=item CreateKey - -=item $newKey= $key->CreateKey( $subKey ); - -=item $newKey= $key->CreateKey( $subKey, { Option=>OptVal,... } ); - -Creates a Registry key or just updates attributes of one. Calls -C<RegCreateKeyEx()> then, if it succeeded, creates an object -associated with the [possibly new] subkey. - -C<$subKey> is the name of a subkey [or a path to one] to be -created or updated. It can also be a reference to an array -containing a list of subkey names. - -The second argument, if it exists, should be a reference to a -hash specifying options either to be passed to C<RegCreateKeyEx()> -or to be used when creating the associated object. The following -items are the supported keys for this options hash: - -=over - -=item Delimiter - -Specifies the delimiter to be used to parse C<$subKey> and to be -used in the new object. Defaults to C<$key->Delimiter>. - -=item Access - -Specifies the types of access requested when the subkey is opened. -Should be a numeric bit mask that combines one or more C<KEY_*> -constant values. - -=item Class - -The name to assign as the class of the new or updated subkey. -Defaults to C<""> as we have never seen a use for this information. - -=item Disposition - -Lets you specify a reference to a scalar where, upon success, will be -stored either C<REG_CREATED_NEW_KEY()> or C<REG_OPENED_EXISTING_KEY()> -depending on whether a new key was created or an existing key was -opened. - -If you, for example, did C<use Win32::TieRegistry qw(REG_CREATED_NEW_KEY)> -then you can use C<REG_CREATED_NEW_KEY()> to compare against the numeric -value stored in the referenced scalar. - -If the C<DualTypes> option is enabled, then in addition to the -numeric value described above, the referenced scalar will also -have a string value equal to either C<"REG_CREATED_NEW_KEY"> or -C<"REG_OPENED_EXISTING_KEY">, as appropriate. - -=item Security - -Lets you specify a C<SECURITY_ATTRIBUTES> structure packed into a -Perl string. See C<Win32API::Registry::RegCreateKeyEx()> for more -information. - -=item Volatile - -If true, specifies that the new key should be volatile, that is, -stored only in memory and not backed by a hive file [and not saved -if the computer is rebooted]. This option is ignored under -Windows 95. Specifying C<Volatile=E<GT>1> is the same as -specifying C<Options=E<GT>REG_OPTION_VOLATILE>. - -=item Backup - -If true, specifies that the new key should be opened for -backup/restore access. The C<Access> option is ignored. If the -calling process has enabled C<"SeBackupPrivilege">, then the -subkey is opened with C<KEY_READ> access as the C<"LocalSystem"> -user which should have access to all subkeys. If the calling -process has enabled C<"SeRestorePrivilege">, then the subkey is -opened with C<KEY_WRITE> access as the C<"LocalSystem"> user which -should have access to all subkeys. - -This option is ignored under Windows 95. Specifying C<Backup=E<GT>1> -is the same as specifying C<Options=E<GT>REG_OPTION_BACKUP_RESTORE>. - -=item Options - -Lets you specify options to the C<RegOpenKeyEx()> call. The value -for this option should be a numeric value combining zero or more -of the C<REG_OPTION_*> bit masks. You may with to used the -C<Volatile> and/or C<Backup> options instead of this one. - -=back - -=item StoreKey - -=item $newKey= $key->StoreKey( $subKey, \%Contents ); - -Primarily for internal use. - -Used to create or update a Registry key and any number of subkeys -or values under it or its subkeys. - -C<$subKey> is the name of a subkey to be created [or a path of -subkey names separated by delimiters]. If that subkey already -exists, then it is updated. - -C<\%Contents> is a reference to a hash containing pairs of -value names with value data and/or subkey names with hash -references similar to C<\%Contents>. Each of these cause -a value or subkey of C<$subKey> to be created or updated. - -If C<$Contents{""}> exists and is a reference to a hash, then -it used as the options argument when C<CreateKey()> is called -for C<$subKey>. This allows you to specify ... - - if( defined( $$data{""} ) && "HASH" eq ref($$data{""}) ) { - $self= $this->CreateKey( $subKey, delete $$data{""} ); - -=item Load - -=item $newKey= $key->Load( $file ) - -=item $newKey= $key->Load( $file, $newSubKey ) - -=item $newKey= $key->Load( $file, $newSubKey, { Option=>OptVal... } ) - -=item $newKey= $key->Load( $file, { Option=>OptVal... } ) - -Loads a hive file into a Registry. That is, creates a new subkey -and associates a hive file with it. - -C<$file> is a hive file, that is a file created by calling -C<RegSaveKey()>. The C<$file> path is interpreted relative to -C<%SystemRoot%/System32/config> on the machine where C<$key> -resides. - -C<$newSubKey> is the name to be given to the new subkey. If -C<$newSubKey> is specified, then C<$key> must be -C<HKEY_LOCAL_MACHINE> or C<HKEY_USERS> of the local computer -or a remote computer and C<$newSubKey> should not contain any -occurrences of either the delimiter or the OS delimiter. - -If C<$newSubKey> is not specified, then it is as if C<$key> -was C<$Registry-E<GT>{LMachine}> and C<$newSubKey> is -C<"PerlTie:999"> where C<"999"> is actually a sequence number -incremented each time this process calls C<Load()>. - -You can specify as the last argument a reference to a hash -containing options. You can specify the same options that you -can specify to C<Open()>. See C<Open()> for more information on -those. In addition, you can specify the option C<"NewSubKey">. -The value of this option is interpretted exactly as if it was -specified as the C<$newSubKey> parameter and overrides the -C<$newSubKey> if one was specified. - -The hive is automatically unloaded when the returned object -[C<$newKey>] is destroyed. Registry key objects opened within -the hive will keep a reference to the C<$newKey> object so that -it will not be destroyed before these keys are closed. - -=item UnLoad - -=item $okay= $key->UnLoad - -Unloads a hive that was loaded via C<Load()>. Cannot unload other -hives. C<$key> must be the return from a previous call to C<Load()>. -C<$key> is closed and then the hive is unloaded. - -=item AllowSave - -=item $okay= AllowSave( $bool ) - -Enables or disables the C<"ReBackupPrivilege"> privilege for the -current process. You will probably have to enable this privilege -before you can use C<RegSaveKey()>. - -The return value indicates whether the operation succeeded, not -whether the privilege was previously enabled. - -=item AllowLoad - -=item $okay= AllowLoad( $bool ) - -Enables or disables the C<"ReRestorePrivilege"> privilege for the -current process. You will probably have to enable this privilege -before you can use C<RegLoadKey()>, C<RegUnLoadKey()>, -C<RegReplaceKey()>, or C<RegRestoreKey> and thus C<Load()> and -C<UnLoad()>. - -The return value indicates whether the operation succeeded, not -whether the privilege was previously enabled. - -=back - -=head2 Exports [C<use> and C<import()>] - -To have nothing imported into your package, use something like: - - use Win32::TieRegistry 0.20 (); - -which would verify that you have at least version 0.20 but wouldn't -call C<import()>. The F<Changes> file can be useful in figuring out -which, if any, prior versions of I<Win32::TieRegistry> you want to -support in your script. - -The code - - use Win32::TieRegistry; - -imports the variable C<$Registry> into your package and sets it -to be a reference to a hash tied to a copy of the master Registry -virtual root object with the default options. One disadvantage -to this "default" usage is that Perl does not support checking -the module version when you use it. - -Alternately, you can specify a list of arguments on the C<use> -line that will be passed to the C<Win32::TieRegistry->import()> -method to control what items to import into your package. These -arguments fall into the following broad categories: - -=over - -=item Import a reference to a hash tied to a Registry virtual root - -You can request that a scalar variable be imported (possibly) -and set to be a reference to a hash tied to a Registry virtual root -using any of the following types of arguments or argument pairs: - -=over - -=item "TiedRef", '$scalar' - -=item "TiedRef", '$pack::scalar' - -=item "TiedRef", 'scalar' - -=item "TiedRef", 'pack::scalar' - -All of the above import a scalar named C<$scalar> into your package -(or the package named "pack") and then sets it. - -=item '$scalar' - -=item '$pack::scalar' - -These are equivalent to the previous items to support a more -traditional appearance to the list of exports. Note that the -scalar name cannot be "RegObj" here. - -=item "TiedRef", \$scalar - -=item \$scalar - -These versions don't import anything but set the referenced C<$scalar>. - -=back - -=item Import a hash tied to the Registry virtual root - -You can request that a hash variable be imported (possibly) -and tied to a Registry virtual root using any of the following -types of arguments or argument pairs: - -=over - -=item "TiedHash", '%hash' - -=item "TiedHash", '%pack::hash' - -=item "TiedHash", 'hash' - -=item "TiedHash", 'pack::hash' - -All of the above import a hash named C<%hash> into your package -(or the package named "pack") and then sets it. - -=item '%hash' - -=item '%pack::hash' - -These are equivalent to the previous items to support a more -traditional appearance to the list of exports. - -=item "TiedHash", \%hash - -=item \%hash - -These versions don't import anything but set the referenced C<%hash>. - -=back - -=item Import a Registry virtual root object - -You can request that a scalar variable be imported (possibly) -and set to be a Registry virtual root object using any of the -following types of arguments or argument pairs: - -=over - -=item "ObjectRef", '$scalar' - -=item "ObjectRef", '$pack::scalar' - -=item "ObjectRef", 'scalar' - -=item "ObjectRef", 'pack::scalar' - -All of the above import a scalar named C<$scalar> into your package -(or the package named "pack") and then sets it. - -=item '$RegObj' - -This is equivalent to the previous items for backward compatibility. - -=item "ObjectRef", \$scalar - -This version doesn't import anything but sets the referenced C<$scalar>. - -=back - -=item Import constant(s) exported by I<Win32API::Registry> - -You can list any constants that are exported by I<Win32API::Registry> -to have them imported into your package. These constants have names -starting with "KEY_" or "REG_" (or even "HKEY_"). - -You can also specify C<":KEY_">, C<":REG_">, and even C<":HKEY_"> to -import a whole set of constants. - -See I<Win32API::Registry> documentation for more information. - -=item Options - -You can list any option names that can be listed in the C<SetOptions()> -method call, each folowed by the value to use for that option. -A Registry virtual root object is created, all of these options are -set for it, then each variable to be imported/set is associated with -this object. - -In addition, the following special options are supported: - -=over - -=item ExportLevel - -Whether to import variables into your package or some -package that uses your package. Defaults to the value of -C<$Exporter::ExportLevel> and has the same meaning. See -the L<Exporter> module for more information. - -=item ExportTo - -The name of the package to import variables and constants into. -Overrides I<ExportLevel>. - -=back - -=back - -=head3 Specifying constants in your Perl code - -This module was written with a strong emphasis on the convenience of -the module user. Therefore, most places where you can specify a -constant like C<REG_SZ()> also allow you to specify a string -containing the name of the constant, C<"REG_SZ">. This is convenient -because you may not have imported that symbolic constant. - -Perl also emphasizes programmer convenience so the code C<REG_SZ> -can be used to mean C<REG_SZ()> or C<"REG_SZ"> or be illegal. -Note that using C<®_SZ> (as we've seen in much Win32 Perl code) -is not a good idea since it passes the current C<@_> to the -C<constant()> routine of the module which, at the least, can give -you a warning under B<-w>. - -Although greatly a matter of style, the "safest" practice is probably -to specifically list all constants in the C<use Win32::TieRegistry> -statement, specify C<use strict> [or at least C<use strict qw(subs)>], -and use bare constant names when you want the numeric value. This will -detect mispelled constant names at compile time. - - use strict; - my $Registry; - use Win32::TieRegistry 0.20 ( - TiedRef => \$Registry, Delimiter => "/", ArrayValues => 1, - SplitMultis => 1, AllowLoad => 1, - qw( REG_SZ REG_EXPAND_SZ REG_DWORD REG_BINARY REG_MULTI_SZ - KEY_READ KEY_WRITE KEY_ALL_ACCESS ), - ); - $Registry->{"LMachine/Software/FooCorp/"}= { - "FooWriter/" => { - "/Fonts" => [ ["Times","Courier","Lucinda"], REG_MULTI_SZ ], - "/WindowSize" => [ pack("LL",24,80), REG_BINARY ], - "/TaskBarIcon" => [ "0x0001", REG_DWORD ], - }, - } or die "Can't create Software/FooCorp/: $^E\n"; - -If you don't want to C<use strict qw(subs)>, the second safest practice -is similar to the above but use the C<REG_SZ()> form for constants -when possible and quoted constant names when required. Note that -C<qw()> is a form of quoting. - - use Win32::TieRegistry 0.20 qw( - TiedRef $Registry - Delimiter / ArrayValues 1 SplitMultis 1 AllowLoad 1 - REG_SZ REG_EXPAND_SZ REG_DWORD REG_BINARY REG_MULTI_SZ - KEY_READ KEY_WRITE KEY_ALL_ACCESS - ); - $Registry->{"LMachine/Software/FooCorp/"}= { - "FooWriter/" => { - "/Fonts" => [ ["Times","Courier","Lucinda"], REG_MULTI_SZ() ], - "/WindowSize" => [ pack("LL",24,80), REG_BINARY() ], - "/TaskBarIcon" => [ "0x0001", REG_DWORD() ], - }, - } or die "Can't create Software/FooCorp/: $^E\n"; - -The examples in this document mostly use quoted constant names -(C<"REG_SZ">) since that works regardless of which constants -you imported and whether or not you have C<use strict> in your -script. It is not the best choice for you to use for real -scripts (vs. examples) because it is less efficient and is not -supported by most other similar modules. - -=head1 SUMMARY - -Most things can be done most easily via tied hashes. Skip down to the -the L<Tied Hashes Summary> to get started quickly. - -=head2 Objects Summary - -Here are quick examples that document the most common functionality -of all of the method functions [except for a few almost useless ones]. - - # Just another way of saying Open(): - $key= new Win32::TieRegistry "LMachine\\Software\\", - { Access=>KEY_READ()|KEY_WRITE(), Delimiter=>"\\" }; - - # Open a Registry key: - $subKey= $key->Open( "SubKey/SubSubKey/", - { Access=>KEY_ALL_ACCESS, Delimiter=>"/" } ); - - # Connect to a remote Registry key: - $remKey= $Registry->Connect( "MachineName", "LMachine/", - { Access=>KEY_READ, Delimiter=>"/" } ); - - # Get value data: - $valueString= $key->GetValue("ValueName"); - ( $valueString, $valueType )= $key->GetValue("ValueName"); - - # Get list of value names: - @valueNames= $key->ValueNames; - - # Get list of subkey names: - @subKeyNames= $key->SubKeyNames; - - # Get combined list of value names (with leading delimiters) - # and subkey names (with trailing delimiters): - @memberNames= $key->MemberNames; - - # Get all information about a key: - %keyInfo= $key->Information; - # keys(%keyInfo)= qw( Class LastWrite SecurityLen - # CntSubKeys MaxSubKeyLen MaxSubClassLen - # CntValues MaxValNameLen MaxValDataLen ); - - # Get selected information about a key: - ( $class, $cntSubKeys )= $key->Information( "Class", "CntSubKeys" ); - - # Get and/or set delimiter: - $delim= $key->Delimiter; - $oldDelim= $key->Delimiter( $newDelim ); - - # Get "path" for an open key: - $path= $key->Path; - # For example, "/CUser/Control Panel/Mouse/" - # or "//HostName/LMachine/System/DISK/". - - # Get name of machine where key is from: - $mach= $key->Machine; - # Will usually be "" indicating key is on local machine. - - # Control different options (see main documentation for descriptions): - $oldBool= $key->ArrayValues( $newBool ); - $oldBool= $key->FastDelete( $newBool ); - $oldBool= $key->FixSzNulls( $newBool ); - $oldBool= $key->SplitMultis( $newBool ); - $oldBool= $key->DWordsToHex( $newBool ); - $oldBool= $key->DualBinVals( $newBool ); - $oldBool= $key->DualTypes( $newBool ); - @oldBools= $key->SetOptions( ArrayValues=>1, FastDelete=>1, FixSzNulls=>0, - Delimiter=>"/", AllowLoad=>1, AllowSave=>1 ); - @oldBools= $key->GetOptions( ArrayValues, FastDelete, FixSzNulls ); - - # Add or set a value: - $key->SetValue( "ValueName", $valueDataString ); - $key->SetValue( "ValueName", pack($format,$valueData), "REG_BINARY" ); - - # Add or set a key: - $key->CreateKey( "SubKeyName" ); - $key->CreateKey( "SubKeyName", - { Access=>"KEY_ALL_ACCESS", Class=>"ClassName", - Delimiter=>"/", Volatile=>1, Backup=>1 } ); - - # Load an off-line Registry hive file into the on-line Registry: - $newKey= $Registry->Load( "C:/Path/To/Hive/FileName" ); - $newKey= $key->Load( "C:/Path/To/Hive/FileName", "NewSubKeyName", - { Access=>"KEY_READ" } ); - # Unload a Registry hive file loaded via the Load() method: - $newKey->UnLoad; - - # (Dis)Allow yourself to load Registry hive files: - $success= $Registry->AllowLoad( $bool ); - - # (Dis)Allow yourself to save a Registry key to a hive file: - $success= $Registry->AllowSave( $bool ); - - # Save a Registry key to a new hive file: - $key->RegSaveKey( "C:/Path/To/Hive/FileName", [] ); - -=head3 Other Useful Methods - -See I<Win32API::Registry> for more information on these methods. -These methods are provided for coding convenience and are -identical to the I<Win32API::Registry> functions except that these -don't take a handle to a Registry key, instead getting the handle -from the invoking object [C<$key>]. - - $key->RegGetKeySecurity( $iSecInfo, $sSecDesc, $lenSecDesc ); - $key->RegLoadKey( $sSubKeyName, $sPathToFile ); - $key->RegNotifyChangeKeyValue( - $bWatchSubtree, $iNotifyFilter, $hEvent, $bAsync ); - $key->RegQueryMultipleValues( - $structValueEnts, $cntValueEnts, $Buffer, $lenBuffer ); - $key->RegReplaceKey( $sSubKeyName, $sPathToNewFile, $sPathToBackupFile ); - $key->RegRestoreKey( $sPathToFile, $iFlags ); - $key->RegSetKeySecurity( $iSecInfo, $sSecDesc ); - $key->RegUnLoadKey( $sSubKeyName ); - -=head2 Tied Hashes Summary - -For fast learners, this may be the only section you need to read. -Always append one delimiter to the end of each Registry key name -and prepend one delimiter to the front of each Registry value name. - -=head3 Opening keys - - use Win32::TieRegistry ( Delimiter=>"/", ArrayValues=>1 ); - $Registry->Delimiter("/"); # Set delimiter to "/". - $swKey= $Registry->{"LMachine/Software/"}; - $winKey= $swKey->{"Microsoft/Windows/CurrentVersion/"}; - $userKey= $Registry-> - {"CUser/Software/Microsoft/Windows/CurrentVersion/"}; - $remoteKey= $Registry->{"//HostName/LMachine/"}; - -=head3 Reading values - - $progDir= $winKey->{"/ProgramFilesDir"}; # "C:\\Program Files" - $tip21= $winKey->{"Explorer/Tips//21"}; # Text of tip #21. - - $winKey->ArrayValues(1); - ( $devPath, $type )= $winKey->{"/DevicePath"}; - # $devPath eq "%SystemRoot%\\inf" - # $type eq "REG_EXPAND_SZ" [if you have SetDualVar.pm installed] - # $type == REG_EXPAND_SZ() [if did C<use Win32::TieRegistry qw(:REG_)>] - -=head3 Setting values - - $winKey->{"Setup//SourcePath"}= "\\\\SwServer\\SwShare\\Windows"; - # Simple. Assumes data type of REG_SZ. - - $winKey->{"Setup//Installation Sources"}= - [ "D:\x00\\\\SwServer\\SwShare\\Windows\0\0", "REG_MULTI_SZ" ]; - # "\x00" and "\0" used to mark ends of each string and end of list. - - $winKey->{"Setup//Installation Sources"}= - [ ["D:","\\\\SwServer\\SwShare\\Windows"], "REG_MULTI_SZ" ]; - # Alternate method that is easier to read. - - $userKey->{"Explorer/Tips//DisplayInitialTipWindow"}= - [ pack("L",0), "REG_DWORD" ]; - $userKey->{"Explorer/Tips//Next"}= [ pack("S",3), "REG_BINARY" ]; - $userKey->{"Explorer/Tips//Show"}= [ pack("L",0), "REG_BINARY" ]; - -=head3 Adding keys - - $swKey->{"FooCorp/"}= { - "FooWriter/" => { - "/Version" => "4.032", - "Startup/" => { - "/Title" => "Foo Writer Deluxe ][", - "/WindowSize" => [ pack("LL",$wid,$ht), "REG_BINARY" ], - "/TaskBarIcon" => [ "0x0001", "REG_DWORD" ], - }, - "Compatibility/" => { - "/AutoConvert" => "Always", - "/Default Palette" => "Windows Colors", - }, - }, - "/License", => "0123-9C8EF1-09-FC", - }; - -=head3 Listing all subkeys and values - - @members= keys( %{$swKey} ); - @subKeys= grep( m#^/#, keys( %{$swKey->{"Classes/batfile/"}} ) ); - # @subKeys= ( "/", "/EditFlags" ); - @valueNames= grep( ! m#^/#, keys( %{$swKey->{"Classes/batfile/"}} ) ); - # @valueNames= ( "DefaultIcon/", "shell/", "shellex/" ); - -=head3 Deleting values or keys with no subkeys - - $oldValue= delete $userKey->{"Explorer/Tips//Next"}; - - $oldValues= delete $userKey->{"Explorer/Tips/"}; - # $oldValues will be reference to hash containing deleted keys values. - -=head3 Closing keys - - undef $swKey; # Explicit way to close a key. - $winKey= "Anything else"; # Implicitly closes a key. - exit 0; # Implicitly closes all keys. - -=head2 Tie::Registry - -This module was originally called I<Tie::Registry>. Changing code -that used I<Tie::Registry> over to I<Win32::TieRegistry> is trivial -as the module name should only be mentioned once, in the C<use> -line. However, finding all of the places that used I<Tie::Registry> -may not be completely trivial so we have included F<Tie/Registry.pm> -which you can install to provide backward compatibility. - -=head1 AUTHOR - -Tye McQueen. See http://www.metronet.com/~tye/ or e-mail -tye@metronet.com with bug reports. - -=head1 SEE ALSO - -I<Win32API::Registry> - Provides access to C<Reg*()>, C<HKEY_*>, -C<KEY_*>, C<REG_*> [required]. - -I<Win32::WinError> - Defines C<ERROR_*> values [optional]. - -L<SetDualVar> - For returning C<REG_*> values as combined -string/integer values [optional]. - -=head1 BUGS - -Perl5.004_02 has bugs that make I<Win32::TieRegistry> fail in -strange and subtle ways. - -Using I<Win32::TieRegistry> with versions of Perl prior to 5.005 -can be tricky or impossible. Most notes about this have been -removed from the documentation (they get rather complicated -and confusing). This includes references to C<$^E> perhaps not -being meaningful. - -Because Perl hashes are case sensitive, certain lookups are also -case sensistive. In particular, the root keys ("Classes", "CUser", -"LMachine", "Users", "PerfData", "CConfig", "DynData", and HKEY_*) -must always be entered without changing between upper and lower -case letters. Also, the special rule for matching subkey names -that contain the user-selected delimiter only works if case is -matched. All other key name and value name lookups should be case -insensitive because the underlying Reg*() calls ignore case. - -Information about each key is cached when using a tied hash. -This cache is not flushed nor updated when changes are made, -I<even when the same tied hash is used> to make the changes. - -Current implementations of Perl's "global destruction" phase can -cause objects returned by C<Load()> to be destroyed while keys -within the hive are still open, if the objects still exist when -the script starts to exit. When this happens, the automatic -C<UnLoad()> will report a failure and the hive will remain loaded -in the Registry. - -Trying to C<Load()> a hive file that is located on a remote network -share may silently delete all data from the hive. This is a bug -in the Win32 APIs, not any Perl code or modules. This module does -not try to protect you from this bug. - -There is no test suite. - -=head1 FUTURE DIRECTIONS - -The following items are desired by the author and may appear in a -future release of this module. - -=over - -=item TieValues option - -Currently described in main documentation but no yet implemented. - -=item AutoRefresh option - -Trigger use of C<RegNotifyChangeKeyValue()> to keep tied hash -caches up-to-date even when other programs make changes. - -=item Error options - -Allow the user to have unchecked calls (calls in a "void context") -to automatically report errors via C<warn> or C<die>. - -For complex operations, such a copying an entire subtree, provide -access to detailed information about errors (and perhaps some -warnings) that were encountered. Let the user control whether -the complex operation continues in spite of errors. - -=back - -=cut - -# Autoload not currently supported by Perl under Windows. diff --git a/Master/tlpkg/tlperl/lib/Win32/WinError.pm b/Master/tlpkg/tlperl/lib/Win32/WinError.pm deleted file mode 100644 index 46028a79321..00000000000 --- a/Master/tlpkg/tlperl/lib/Win32/WinError.pm +++ /dev/null @@ -1,1017 +0,0 @@ -package Win32::WinError; - -require Exporter; -require DynaLoader; - -$VERSION = '0.02'; - -@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__ diff --git a/Master/tlpkg/tlperl/lib/Win32/test-async.pl b/Master/tlpkg/tlperl/lib/Win32/test-async.pl deleted file mode 100644 index c47e2df04ec..00000000000 --- a/Master/tlpkg/tlperl/lib/Win32/test-async.pl +++ /dev/null @@ -1,129 +0,0 @@ -# -# TEST-ASYNC.PL -# Test Win32::Internet's Asynchronous Operations -# by Aldo Calpini <dada@divinf.it> -# -# WARNING: this code is most likely to fail with almost-random errors -# I don't know what is wrong here, any hint will be greatly -# appreciated! - -use Win32::Internet; - -$params{'flags'} = INTERNET_FLAG_ASYNC; -$params{'opentype'} = INTERNET_OPEN_TYPE_DIRECT; -$I = new Win32::Internet(\%params); - -# print "Error: ", $I->Error(), "\n"; -print "I.handle=", $I->{'handle'}, "\n"; - -$return = $I->SetStatusCallback(); -print "SetStatusCallback=$return"; -print "ERROR" if $return eq undef; -print "\n"; - -$buffer = $I->QueryOption(INTERNET_OPTION_READ_BUFFER_SIZE); -print "Buffer=$buffer\n"; - -$host = "ftp.activeware.com"; -$user = "anonymous"; -$pass = "dada\@divinf.it"; - - -print "Doing FTP()...\n"; - -$handle2 = $I->FTP($FTP, $host, $user, $pass, 21, 1); - -print "Returned from FTP()...\n"; - -($n, $t) = $I->Error(); - -if($n == 997) { - print "Going asynchronous...\n"; - ($status, $info) = $I->GetStatusCallback(1); - while($status != 100 and $status != 70) { - if($oldstatus != $status) { - if($status == 60) { - $FTP->{'handle'} = $info; - } elsif($status == 10) { - print "resolving name... \n"; - } elsif($status == 11) { - print "name resolved... \n"; - } elsif($status == 20) { - print "connecting... \n"; - } elsif($status == 21) { - print "connected... \n"; - } elsif($status == 30) { - print "sending... \n"; - } elsif($status == 31) { - print "$info bytes sent. \n"; - } elsif($status == 40) { - print "receiving... \n"; - } elsif($status == 41) { - print "$info bytes received. \n"; - } else { - print "status=$status\n"; - } - } - $oldstatus = $status; - ($status, $info) = $I->GetStatusCallback(1); - } -} else { - print "Error=", $I->Error(), "\n"; -} -print "FTP.handle=", $FTP->{'handle'}, "\n"; -print "STATUS(after FTP)=", $I->GetStatusCallback(1), "\n"; - -# "/pub/microsoft/sdk/activex13.exe", - -print "Doing Get()...\n"; - -$file = "/Perl-Win32/perl5.001m/currentBuild/110-i86.zip"; - -$FTP->Get($file, "110-i86.zip", 1, 0, 2); - -print "Returned from Get()...\n"; - -($n, $t) = $I->Error(); -if($n == 997) { - print "Going asynchronous...\n"; - $bytes = 0; - $oldstatus = 0; - ($status, $info) = $I->GetStatusCallback(2); - while($status != 100 and $status != 70) { - # print "status=$status info=$info\n"; - # if($oldstatus!=$status) { - if($status == 10) { - print "resolving name... \n"; - } elsif($status == 11) { - print "name resolved... \n"; - } elsif($status == 20) { - print "connecting... \n"; - } elsif($status == 21) { - print "connected... \n"; - #} elsif($status == 30) { - # print "sending... \n"; - } elsif($status == 31) { - print "$info bytes sent. \n"; - #} elsif($status == 40) { - # print "receiving... \n"; - } elsif($status == 41) { - $bytes = $bytes+$info; - print "$bytes bytes received. \n"; - #} else { - # print "status=$status\n"; - } - # } - $oldstatus = $status; - undef $status, $info; - ($status, $info) = $I->GetStatusCallback(2); - } -} else { - print "Error=[$n] $t\n"; -} -print "\n"; -($status, $info) = $I->GetStatusCallback(2); -print "STATUS(after Get)=$status\n"; -print "Error=", $I->Error(), "\n"; -exit(0); - - |