summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Win32
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Win32')
-rw-r--r--Master/tlpkg/tlperl/lib/Win32/API.pm745
-rw-r--r--Master/tlpkg/tlperl/lib/Win32/API.pm.orig741
-rw-r--r--Master/tlpkg/tlperl/lib/Win32/API/Callback.pm174
-rw-r--r--Master/tlpkg/tlperl/lib/Win32/API/Struct.pm532
-rw-r--r--Master/tlpkg/tlperl/lib/Win32/API/Test.pm120
-rw-r--r--Master/tlpkg/tlperl/lib/Win32/API/Type.pm446
-rw-r--r--Master/tlpkg/tlperl/lib/Win32/ChangeNotify.pm198
-rw-r--r--Master/tlpkg/tlperl/lib/Win32/Client.pl63
-rw-r--r--Master/tlpkg/tlperl/lib/Win32/Clipboard.pm369
-rw-r--r--Master/tlpkg/tlperl/lib/Win32/Console.pm1463
-rw-r--r--Master/tlpkg/tlperl/lib/Win32/Event.pm104
-rw-r--r--Master/tlpkg/tlperl/lib/Win32/EventLog.pm471
-rw-r--r--Master/tlpkg/tlperl/lib/Win32/File.pm118
-rw-r--r--Master/tlpkg/tlperl/lib/Win32/FileSecurity.pm308
-rw-r--r--Master/tlpkg/tlperl/lib/Win32/IPC.pm195
-rw-r--r--Master/tlpkg/tlperl/lib/Win32/Internet.pm3009
-rw-r--r--Master/tlpkg/tlperl/lib/Win32/Job.pm370
-rw-r--r--Master/tlpkg/tlperl/lib/Win32/Mutex.pm125
-rw-r--r--Master/tlpkg/tlperl/lib/Win32/NetAdmin.pm419
-rw-r--r--Master/tlpkg/tlperl/lib/Win32/NetResource.pm456
-rw-r--r--Master/tlpkg/tlperl/lib/Win32/ODBC.pm1493
-rw-r--r--Master/tlpkg/tlperl/lib/Win32/PerfLib.pm538
-rw-r--r--Master/tlpkg/tlperl/lib/Win32/Pipe.pm414
-rw-r--r--Master/tlpkg/tlperl/lib/Win32/Process.pm217
-rw-r--r--Master/tlpkg/tlperl/lib/Win32/Registry.pm547
-rw-r--r--Master/tlpkg/tlperl/lib/Win32/Semaphore.pm128
-rw-r--r--Master/tlpkg/tlperl/lib/Win32/Server.pl48
-rw-r--r--Master/tlpkg/tlperl/lib/Win32/Service.pm103
-rw-r--r--Master/tlpkg/tlperl/lib/Win32/Shortcut.pm323
-rw-r--r--Master/tlpkg/tlperl/lib/Win32/Sound.pm582
-rw-r--r--Master/tlpkg/tlperl/lib/Win32/Test.pl477
-rw-r--r--Master/tlpkg/tlperl/lib/Win32/TieRegistry.pm3801
-rw-r--r--Master/tlpkg/tlperl/lib/Win32/WinError.pm1017
-rw-r--r--Master/tlpkg/tlperl/lib/Win32/test-async.pl129
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<&REG_SZ> (as we've seen in much Win32 Perl code)
-is not a good idea since it passes the current C<@_> to the
-C<constant()> routine of the module which, at the least, can give
-you a warning under B<-w>.
-
-Although greatly a matter of style, the "safest" practice is probably
-to specifically list all constants in the C<use Win32::TieRegistry>
-statement, specify C<use strict> [or at least C<use strict qw(subs)>],
-and use bare constant names when you want the numeric value. This will
-detect 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);
-
-