diff options
author | Karl Berry <karl@freefriends.org> | 2009-01-30 00:33:26 +0000 |
---|---|---|
committer | Karl Berry <karl@freefriends.org> | 2009-01-30 00:33:26 +0000 |
commit | a5df6b939c049edcc1fcd805b056a002904f6aea (patch) | |
tree | b8725970f457042e324911da4c06732dea9def39 /Master/tlpkg/installer/perllib/Win32 | |
parent | 233e8430afec69ca29c28c798cc0912785ea29d1 (diff) |
add everything from tlperl/lib to installer/perllib except for Tk, unicore, and auto (report from Gregor Zimmermann, 29 Jan 2009 12:38:19)
git-svn-id: svn://tug.org/texlive/trunk@12015 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/installer/perllib/Win32')
25 files changed, 12814 insertions, 0 deletions
diff --git a/Master/tlpkg/installer/perllib/Win32/ChangeNotify.pm b/Master/tlpkg/installer/perllib/Win32/ChangeNotify.pm new file mode 100644 index 00000000000..a86682da376 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Win32/ChangeNotify.pm @@ -0,0 +1,198 @@ +#--------------------------------------------------------------------- +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/installer/perllib/Win32/Client.pl b/Master/tlpkg/installer/perllib/Win32/Client.pl new file mode 100644 index 00000000000..6ae585b7c91 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Win32/Client.pl @@ -0,0 +1,63 @@ +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/installer/perllib/Win32/Clipboard.pm b/Master/tlpkg/installer/perllib/Win32/Clipboard.pm new file mode 100644 index 00000000000..ba4038a5ade --- /dev/null +++ b/Master/tlpkg/installer/perllib/Win32/Clipboard.pm @@ -0,0 +1,369 @@ +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/installer/perllib/Win32/Console.pm b/Master/tlpkg/installer/perllib/Win32/Console.pm new file mode 100644 index 00000000000..1e3876a6a33 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Win32/Console.pm @@ -0,0 +1,1463 @@ +####################################################################### +# +# 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/installer/perllib/Win32/Event.pm b/Master/tlpkg/installer/perllib/Win32/Event.pm new file mode 100644 index 00000000000..5faddf5a76e --- /dev/null +++ b/Master/tlpkg/installer/perllib/Win32/Event.pm @@ -0,0 +1,104 @@ +#--------------------------------------------------------------------- +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/installer/perllib/Win32/EventLog.pm b/Master/tlpkg/installer/perllib/Win32/EventLog.pm new file mode 100644 index 00000000000..141821556e7 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Win32/EventLog.pm @@ -0,0 +1,471 @@ +# +# EventLog.pm +# +# Creates an object oriented interface to the Windows NT Evenlog +# Written by Jesse Dougherty +# + +package Win32::EventLog; + +use strict; +use vars qw($VERSION $AUTOLOAD @ISA @EXPORT $GetMessageText); +$VERSION = '0.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/installer/perllib/Win32/File.pm b/Master/tlpkg/installer/perllib/Win32/File.pm new file mode 100644 index 00000000000..d67a25448c8 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Win32/File.pm @@ -0,0 +1,118 @@ +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/installer/perllib/Win32/FileSecurity.pm b/Master/tlpkg/installer/perllib/Win32/FileSecurity.pm new file mode 100644 index 00000000000..6c6e5865336 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Win32/FileSecurity.pm @@ -0,0 +1,308 @@ +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/installer/perllib/Win32/IPC.pm b/Master/tlpkg/installer/perllib/Win32/IPC.pm new file mode 100644 index 00000000000..c97279b24c5 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Win32/IPC.pm @@ -0,0 +1,195 @@ +#--------------------------------------------------------------------- +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/installer/perllib/Win32/Internet.pm b/Master/tlpkg/installer/perllib/Win32/Internet.pm new file mode 100644 index 00000000000..f6dac3130af --- /dev/null +++ b/Master/tlpkg/installer/perllib/Win32/Internet.pm @@ -0,0 +1,3009 @@ +####################################################################### +# +# 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/installer/perllib/Win32/Job.pm b/Master/tlpkg/installer/perllib/Win32/Job.pm new file mode 100644 index 00000000000..3350f76400d --- /dev/null +++ b/Master/tlpkg/installer/perllib/Win32/Job.pm @@ -0,0 +1,370 @@ +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/installer/perllib/Win32/Mutex.pm b/Master/tlpkg/installer/perllib/Win32/Mutex.pm new file mode 100644 index 00000000000..801c2d35cda --- /dev/null +++ b/Master/tlpkg/installer/perllib/Win32/Mutex.pm @@ -0,0 +1,125 @@ +#--------------------------------------------------------------------- +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/installer/perllib/Win32/NetAdmin.pm b/Master/tlpkg/installer/perllib/Win32/NetAdmin.pm new file mode 100644 index 00000000000..ace31a619e4 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Win32/NetAdmin.pm @@ -0,0 +1,419 @@ +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/installer/perllib/Win32/NetResource.pm b/Master/tlpkg/installer/perllib/Win32/NetResource.pm new file mode 100644 index 00000000000..04ac87acabd --- /dev/null +++ b/Master/tlpkg/installer/perllib/Win32/NetResource.pm @@ -0,0 +1,456 @@ +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/installer/perllib/Win32/ODBC.pm b/Master/tlpkg/installer/perllib/Win32/ODBC.pm new file mode 100644 index 00000000000..a51616388ea --- /dev/null +++ b/Master/tlpkg/installer/perllib/Win32/ODBC.pm @@ -0,0 +1,1493 @@ +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/installer/perllib/Win32/PerfLib.pm b/Master/tlpkg/installer/perllib/Win32/PerfLib.pm new file mode 100644 index 00000000000..2b773d68f4b --- /dev/null +++ b/Master/tlpkg/installer/perllib/Win32/PerfLib.pm @@ -0,0 +1,538 @@ +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/installer/perllib/Win32/Pipe.pm b/Master/tlpkg/installer/perllib/Win32/Pipe.pm new file mode 100644 index 00000000000..a99d5a0da08 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Win32/Pipe.pm @@ -0,0 +1,414 @@ +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/installer/perllib/Win32/Process.pm b/Master/tlpkg/installer/perllib/Win32/Process.pm new file mode 100644 index 00000000000..f07169b4080 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Win32/Process.pm @@ -0,0 +1,217 @@ +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/installer/perllib/Win32/Semaphore.pm b/Master/tlpkg/installer/perllib/Win32/Semaphore.pm new file mode 100644 index 00000000000..2e2096eb6ed --- /dev/null +++ b/Master/tlpkg/installer/perllib/Win32/Semaphore.pm @@ -0,0 +1,128 @@ +#--------------------------------------------------------------------- +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/installer/perllib/Win32/Server.pl b/Master/tlpkg/installer/perllib/Win32/Server.pl new file mode 100644 index 00000000000..ecfb91ba864 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Win32/Server.pl @@ -0,0 +1,48 @@ +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/installer/perllib/Win32/Service.pm b/Master/tlpkg/installer/perllib/Win32/Service.pm new file mode 100644 index 00000000000..0ae33b13ef8 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Win32/Service.pm @@ -0,0 +1,103 @@ +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/installer/perllib/Win32/Sound.pm b/Master/tlpkg/installer/perllib/Win32/Sound.pm new file mode 100644 index 00000000000..a8d52a95117 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Win32/Sound.pm @@ -0,0 +1,582 @@ +####################################################################### +# +# 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/installer/perllib/Win32/Test.pl b/Master/tlpkg/installer/perllib/Win32/Test.pl new file mode 100644 index 00000000000..235e94bdd78 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Win32/Test.pl @@ -0,0 +1,477 @@ +##### +# 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/installer/perllib/Win32/WinError.pm b/Master/tlpkg/installer/perllib/Win32/WinError.pm new file mode 100644 index 00000000000..46028a79321 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Win32/WinError.pm @@ -0,0 +1,1017 @@ +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/installer/perllib/Win32/test-async.pl b/Master/tlpkg/installer/perllib/Win32/test-async.pl new file mode 100644 index 00000000000..c47e2df04ec --- /dev/null +++ b/Master/tlpkg/installer/perllib/Win32/test-async.pl @@ -0,0 +1,129 @@ +# +# 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); + + |