summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Win32
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Win32')
-rw-r--r--Master/tlpkg/tlperl/lib/Win32/API.pm2
-rw-r--r--Master/tlpkg/tlperl/lib/Win32/API/Callback.pm14
-rw-r--r--Master/tlpkg/tlperl/lib/Win32/API/Callback/IATPatch.pod181
-rw-r--r--Master/tlpkg/tlperl/lib/Win32/Console.pm1463
-rw-r--r--Master/tlpkg/tlperl/lib/Win32/OLE.pm4
-rw-r--r--Master/tlpkg/tlperl/lib/Win32/OLE/NEWS.pod380
-rw-r--r--Master/tlpkg/tlperl/lib/Win32/OLE/TPJ.pod798
-rw-r--r--Master/tlpkg/tlperl/lib/Win32/Process/Info.pm1005
-rw-r--r--Master/tlpkg/tlperl/lib/Win32/Process/Info/NT.pm865
-rw-r--r--Master/tlpkg/tlperl/lib/Win32/Process/Info/PT.pm306
-rw-r--r--Master/tlpkg/tlperl/lib/Win32/Process/Info/WMI.pm430
-rw-r--r--Master/tlpkg/tlperl/lib/Win32/TieRegistry.pm51
-rw-r--r--Master/tlpkg/tlperl/lib/Win32/WinError.pm1017
13 files changed, 3882 insertions, 2634 deletions
diff --git a/Master/tlpkg/tlperl/lib/Win32/API.pm b/Master/tlpkg/tlperl/lib/Win32/API.pm
index 6accc691db8..ba94cac4736 100644
--- a/Master/tlpkg/tlperl/lib/Win32/API.pm
+++ b/Master/tlpkg/tlperl/lib/Win32/API.pm
@@ -77,7 +77,7 @@ my %Procedures = ();
# dynamically load in the API extension module.
# BEGIN required for constant subs in BOOT:
BEGIN {
- $VERSION = '0.77';
+ $VERSION = '0.80';
bootstrap Win32::API;
}
diff --git a/Master/tlpkg/tlperl/lib/Win32/API/Callback.pm b/Master/tlpkg/tlperl/lib/Win32/API/Callback.pm
index b96d938265e..41b7cc9d6b7 100644
--- a/Master/tlpkg/tlperl/lib/Win32/API/Callback.pm
+++ b/Master/tlpkg/tlperl/lib/Win32/API/Callback.pm
@@ -16,7 +16,7 @@ use strict;
use warnings;
use vars qw( $VERSION @ISA $Stage2FuncPtrPkd );
-$VERSION = '0.77';
+$VERSION = '0.80';
require Exporter; # to export the constants to the main:: space
@@ -561,6 +561,18 @@ or 'WINAPIV'.
See L<Win32::API/UseMI64>.
+=head1 KNOWN ISSUES
+
+=over 4
+
+=item *
+
+Callback is safe across a Win32 psuedo-fork. Callback is not safe across a
+Cygwin fork. On Cygwin, in the child process of the fork, a Segmentation Fault
+will happen if the Win32::API::Callback callback is is called.
+
+=back
+
=head1 SEE ALSO
L<Win32::API::Callback::IATPatch>
diff --git a/Master/tlpkg/tlperl/lib/Win32/API/Callback/IATPatch.pod b/Master/tlpkg/tlperl/lib/Win32/API/Callback/IATPatch.pod
new file mode 100644
index 00000000000..27eb1af2fb6
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Win32/API/Callback/IATPatch.pod
@@ -0,0 +1,181 @@
+=head1 NAME
+
+Win32::API::Callback::IATPatch - Hooking and Patching a DLL's Imported C Functions
+
+=head1 SYNOPSIS
+
+ use Win32::API;
+ use Win32::API::Callback;
+ warn "usually fatally errors on Cygwin" if $^O eq 'cygwin';
+ # do not do a "use" or "require" on Win32::API::Callback::IATPatch
+ # IATPatch comes with Win32::API::Callback
+ my $LoadLibraryExA;
+ my $callback = Win32::API::Callback->new(
+ sub {
+ my $libname = unpack('p', pack('J', $_[0]));
+ print "got $libname\n";
+ return $LoadLibraryExA->Call($libname, $_[1], $_[2]);
+ },
+ 'NNI',
+ 'N'
+ );
+ my $patch = Win32::API::Callback::IATPatch->new(
+ $callback, "perl518.dll", 'kernel32.dll', 'LoadLibraryExA');
+ die "failed to create IATPatch Obj $^E" if ! defined $patch;
+ $LoadLibraryExA = Win32::API::More->new( undef, $patch->GetOriginalFunctionPtr(), '
+ HMODULE
+ WINAPI
+ LoadLibraryExA(
+ LPCSTR lpLibFileName,
+ HANDLE hFile,
+ DWORD dwFlags
+ );
+ ');
+ die "failed to make old function object" if ! defined $LoadLibraryExA;
+ require Encode;
+ #console will get a print of the dll filename now
+
+=head1 DESCRIPTION
+
+Win32::API::Callback::IATPatch allows you to hook a compile time dynamic linked
+function call from any DLL (or EXE, from now on all examples are from a DLL to
+another DLL, but from a EXE to a DLL is implied) in the Perl process, to a
+different DLL in the same Perl process, by placing a Win32::API::Callback object
+in between. This module does B<not> hook B<GetProcAddress> function calls. It
+also will not hook a function call from a DLL to another function in the same
+DLL. The function you want to hook B<must> appear in the B<import table> of the
+DLL you want to use the hook. Functions from delay loaded DLL have their own
+import table, it is different import table from the normal one IATPatch supports.
+IATPatch will not find a delay loaded function and will not patch it. The hook
+occurs at the caller DLL, not the callee DLL. This means your callback will be
+called from all the calls to a one function in different DLL from the one
+particular DLL the IATPatch object patched. The caller DLL is modified at
+runtime, in the Perl process where the IATPatch was created, not on disk,
+not globally among all processes. The callee or exporting DLL is NOT modified,
+so your hook callback will be called from the 1 DLL that you choose to hook with
+1 IATPatch object. You can create multiple IATPatch objects, one for each DLL in
+the Perl process that you want to call your callback and not the original
+destination function. If a new DLL is loaded into the process during runtime,
+you must create a new IATPatch object specifically targeting it. There may be a
+period from when the new DLL is loaded into the process, and when your Perl
+script creates IATPatch object, where calls from that new DLL goto the real
+destination function without hooking. If a DLL is unloaded, then reloaded into
+the process, you must call C<Unpatch(0)> method on the old IATPatch object, then
+create a new IATPatch object. IATPatch has no notification feature that a DLL
+is being loaded or unloaded from the process. Unless you completely control, and
+have the source code of the caller DLL, and understand all of the source code of
+that DLL, there is a high chance that you will B<NOT> hook all calls from that
+DLL to the destination function. If a call to the destination function is
+dangerous or unacceptable, do not use IATPatch. IATPatch is not Microsoft
+Detours or the like in any sense. Detours and its brethern will rewrite the
+machine code in the beginning of the destination function call, hooking all
+calls to that function call process wide, without exception.
+
+Why this module was created? So I could mock kernel32 functions to
+unit test Perl's C function calls to Kernel32.
+
+=head2 CONSTRUCTORS
+
+=head3 new
+
+ my $patch = Win32::API::Callback::IATPatch->new(
+ $A_Win32_API_Callback_Obj, $EXE_or_DLL_hmodule_or_name_to_hook,
+ $import_DLL_name, $import_function_name_or_ordinal);
+
+Creates a new IATPatch object. The Win32::API::Callback will be called as long
+as the IATPatch object exists. When an IATPatch object is DESTROYed, unless
+C<-E<gt>Unpatch(0)> is called first, the patch is undone and the original
+function is directly called from then on by that DLL. The DLL is not reference
+count saved by an IATPatch object, so it may be unloaded at any time. If it is
+unloaded you must call C<-E<gt>Unpatch(0)> before a DESTROY. Otherwise the DESTROY
+will croak when it tries to unpatch the DLL. The DLL to hook must be a valid
+PE file, while in memory. DLL and EXE "packers" can create invalid PE
+files that do load successfully into memory, but they are not full PE files in
+memory. On error, undef is returned and an error code is available through
+L<Win32::GetLastError|Win32/Win32::GetLastError()>/L<perlvar/"$^E">. The error code may be from either
+IATPatch directly, or from a Win32 call that IATPatch made. IATPatch objects
+do not go through a L<perlfunc/"fork"> onto the child interp. IATPatch is fork safe.
+
+The hook dll name can be one of 3 things, if the dllname is multiple things
+(a number and a string), the first format found in the following order is used.
+A string C<"123"> (a very strange DLL name BTW), this DLL is converted to DLL
+HMODULE with GetModuleHandle. If there are 2 DLLs with the same filename,
+refer to GetModuleHandle's
+L<MSDN documentation|http://msdn.microsoft.com/en-us/library/windows/desktop/ms683199%28v=vs.85%29.aspx>
+on what happens. Then if the
+DLL name is an integer C<123456>, it is interpreted as a HMODULE directly.
+If DLL name undefined, the file used to create the calling process will be
+patched (a .exe). Finally if the DLL name is defined, a fatal error croak occurs.
+It is best to use an HMODULE, since things like SxS can create multiple DLLs with
+the same name in the same process. How to get an HMODULE, you are on your own.
+
+C<$import_function_name_or_ordinal> can be one of 2 things. First it is checked if
+it is a string, if so, it is used as the function name to hook. Else it is used
+as an integer ordinal to hook. Importing by ordinal is obsolete in Windows, and
+you shouldn't ever have to use it. The author of IATPatch was unable to test if
+ordinal hooking works correctly in IATPatch.
+
+=head2 METHODS
+
+=head3 Unpatch
+
+ die "failed to undo the patch error: $^E" if !
+ $IATPatch->Unpatch(); #undo the patch
+ #or
+ die "failed to undo the patch error: $^E" if !
+ $IATPatch->Unpatch(1); #undo the patch
+ #or
+ die "failed to undo the patch error: $^E" if !
+ $IATPatch->Unpatch(0); #never undo the patch
+ #or
+ die "failed to undo the patch error: $^E" if !
+ $IATPatch->Unpatch(undef); #never undo the patch
+
+Unpatches the DLL with the original destination function from the L<Win32::API::Callback::IATPatch/"new">
+call. Returns undef on failure with error number available through
+L<Win32::GetLastError|Win32/Win32::GetLastError()>/L<perlvar/"$^E">. If Unpatch was called once already,
+calling it again will fail, and error will be ERROR_NO_MORE_ITEMS.
+
+=head3 GetOriginalFunctionPtr
+
+Returns the original function pointer found in the import table in C<123456>
+format. If the returned pointer is 0, L<Win32::API::Callback::IATPatch/"Unpatch">
+was called earlier. There are no error numbers associated with this method.
+This value can be directly used to create a function pointer based Win32::API
+object to call the original destination function from inside your Perl callback.
+See L<Win32::API::Callback::IATPatch/"SYNOPSIS"> for a usage example.
+
+=head1 BUGS AND LIMITATIONS
+
+=over 4
+
+=item E<nbsp>Cygwin not supported
+
+L<new()|Win32::API::Callback::IATPatch/"new"> usually fatally errors on Cygwin
+with "IATPatch 3GB mode not supported" on Cygwins that allocate the heap at
+0x80000000 or are "Large Address Aware"
+
+=back
+
+=head1 SEE ALSO
+
+L<Win32::API::Callback>
+
+L<Win32::API>
+
+L<http://msdn.microsoft.com/en-us/magazine/cc301808.aspx>
+
+=head1 AUTHOR
+
+Daniel Dragan ( I<bulkdd@cpan.org> ).
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2012 by Daniel Dragan
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself, either Perl version 5.10.0 or,
+at your option, any later version of Perl 5 you may have available.
+
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/Win32/Console.pm b/Master/tlpkg/tlperl/lib/Win32/Console.pm
new file mode 100644
index 00000000000..2e41c2a83d5
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Win32/Console.pm
@@ -0,0 +1,1463 @@
+#######################################################################
+#
+# Win32::Console - Win32 Console and Character Mode Functions
+#
+#######################################################################
+
+package Win32::Console;
+
+require Exporter;
+require DynaLoader;
+
+$VERSION = "0.10";
+
+@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 somehow
+destroy such an object).
+
+Example:
+
+ $LINK->Close();
+
+=item Cls [attr]
+
+Clear the console, with the specified I<attr> if given, or using
+ATTR_NORMAL otherwise.
+
+Example:
+
+ $CONSOLE->Cls();
+ $CONSOLE->Cls($FG_WHITE | $BG_GREEN);
+
+=item Cursor [x, y, size, visible]
+
+Gets or sets cursor position and appearance. Returns C<undef> on
+errors, or a 4-element list containing: I<x>, I<y>, I<size>,
+I<visible>. I<x> and I<y> are the current cursor position; ...
+
+Example:
+
+ ($x, $y, $size, $visible) = $CONSOLE->Cursor();
+
+ # Get position only
+ ($x, $y) = $CONSOLE->Cursor();
+
+ $CONSOLE->Cursor(40, 13, 50, 1);
+
+ # Set position only
+ $CONSOLE->Cursor(40, 13);
+
+ # Set size and visibility without affecting position
+ $CONSOLE->Cursor(-1, -1, 50, 1);
+
+=item Display
+
+Displays the specified console on the screen. Returns C<undef> on errors,
+a nonzero value on success.
+
+Example:
+
+ $CONSOLE->Display();
+
+=item FillAttr [attribute, number, col, row]
+
+Fills the specified number of consecutive attributes, beginning at
+I<col>, I<row>, with the value specified in I<attribute>. Returns the
+number of attributes filled, or C<undef> on errors. See also:
+C<FillChar>.
+
+Example:
+
+ $CONSOLE->FillAttr($FG_BLACK | $BG_BLACK, 80*25, 0, 0);
+
+=item FillChar char, number, col, row
+
+Fills the specified number of consecutive characters, beginning at
+I<col>, I<row>, with the character specified in I<char>. Returns the
+number of characters filled, or C<undef> on errors. See also:
+C<FillAttr>.
+
+Example:
+
+ $CONSOLE->FillChar("X", 80*25, 0, 0);
+
+=item Flush
+
+Flushes the console input buffer. All the events in the buffer are
+discarded. Returns C<undef> on errors, a nonzero value on success.
+
+Example:
+
+ $CONSOLE->Flush();
+
+=item Free
+
+Detaches the process from the console. Returns C<undef> on errors, a
+nonzero value on success. See also: C<Alloc>.
+
+Example:
+
+ $CONSOLE->Free();
+
+=item GenerateCtrlEvent [type, processgroup]
+
+Sends a break signal of the specified I<type> to the specified
+I<processgroup>. I<type> can be one of the following constants:
+
+ CTRL_BREAK_EVENT
+ CTRL_C_EVENT
+
+they signal, respectively, the pressing of Control + Break and of
+Control + C; if not specified, it defaults to CTRL_C_EVENT.
+I<processgroup> is the pid of a process sharing the same console. If
+omitted, it defaults to 0 (the current process), which is also the
+only meaningful value that you can pass to this function. Returns
+C<undef> on errors, a nonzero value on success.
+
+Example:
+
+ # break this script now
+ $CONSOLE->GenerateCtrlEvent();
+
+=item GetEvents
+
+Returns the number of unread input events in the console's input
+buffer, or C<undef> on errors. See also: C<Input>, C<InputChar>,
+C<PeekInput>, C<WriteInput>.
+
+Example:
+
+ $events = $CONSOLE->GetEvents();
+
+=item Info
+
+Returns an array of informations about the console (or C<undef> on
+errors), which contains:
+
+=over
+
+=item *
+
+columns (X size) of the console buffer.
+
+=item *
+
+rows (Y size) of the console buffer.
+
+=item *
+
+current column (X position) of the cursor.
+
+=item *
+
+current row (Y position) of the cursor.
+
+=item *
+
+current attribute used for C<Write>.
+
+=item *
+
+left column (X of the starting point) of the current console window.
+
+=item *
+
+top row (Y of the starting point) of the current console window.
+
+=item *
+
+right column (X of the final point) of the current console window.
+
+=item *
+
+bottom row (Y of the final point) of the current console window.
+
+=item *
+
+maximum number of columns for the console window, given the current
+buffer size, font and the screen size.
+
+=item *
+
+maximum number of rows for the console window, given the current
+buffer size, font and the screen size.
+
+=back
+
+See also: C<Attr>, C<Cursor>, C<Size>, C<Window>, C<MaxWindow>.
+
+Example:
+
+ @info = $CONSOLE->Info();
+ print "Cursor at $info[3], $info[4].\n";
+
+=item Input
+
+Reads an event from the input buffer. Returns a list of values, which
+depending on the event's nature are:
+
+=over
+
+=item keyboard event
+
+The list will contain:
+
+=over
+
+=item *
+
+event type: 1 for keyboard
+
+=item *
+
+key down: TRUE if the key is being pressed, FALSE if the key is being released
+
+=item *
+
+repeat count: the number of times the key is being held down
+
+=item *
+
+virtual keycode: the virtual key code of the key
+
+=item *
+
+virtual scancode: the virtual scan code of the key
+
+=item *
+
+char: the ASCII code of the character (if the key is a character key, 0 otherwise)
+
+=item *
+
+control key state: the state of the control keys (SHIFTs, CTRLs, ALTs, etc.)
+
+=back
+
+=item mouse event
+
+The list will contain:
+
+=over
+
+=item *
+
+event type: 2 for mouse
+
+=item *
+
+mouse pos. X: X coordinate (column) of the mouse location
+
+=item *
+
+mouse pos. Y: Y coordinate (row) of the mouse location
+
+=item *
+
+button state: the mouse button(s) which are pressed
+
+=item *
+
+control key state: the state of the control keys (SHIFTs, CTRLs, ALTs, etc.)
+
+=item *
+
+event flags: the type of the mouse event
+
+=back
+
+=back
+
+This method will return C<undef> on errors. Note that the events
+returned are depending on the input C<Mode> of the console; for example,
+mouse events are not intercepted unless ENABLE_MOUSE_INPUT is
+specified. See also: C<GetEvents>, C<InputChar>, C<Mode>,
+C<PeekInput>, C<WriteInput>.
+
+Example:
+
+ @event = $CONSOLE->Input();
+
+=item InputChar number
+
+Reads and returns I<number> characters from the console input buffer,
+or C<undef> on errors. See also: C<Input>, C<Mode>.
+
+Example:
+
+ $key = $CONSOLE->InputChar(1);
+
+=item InputCP [codepage]
+
+Gets or sets the input code page used by the console. Note that this
+doesn't apply to a console object, but to the standard input
+console. This attribute is used by the Write method. See also:
+C<OutputCP>.
+
+Example:
+
+ $codepage = $CONSOLE->InputCP();
+ $CONSOLE->InputCP(437);
+
+ # you may want to use the non-instanciated form to avoid confuzion :)
+ $codepage = Win32::Console::InputCP();
+ Win32::Console::InputCP(437);
+
+=item MaxWindow
+
+Returns the size of the largest possible console window, based on the
+current font and the size of the display. The result is C<undef> on
+errors, otherwise a 2-element list containing col, row.
+
+Example:
+
+ ($maxCol, $maxRow) = $CONSOLE->MaxWindow();
+
+=item Mode [flags]
+
+Gets or sets the input or output mode of a console. I<flags> can be a
+combination of the following constants:
+
+ ENABLE_LINE_INPUT
+ ENABLE_ECHO_INPUT
+ ENABLE_PROCESSED_INPUT
+ ENABLE_WINDOW_INPUT
+ ENABLE_MOUSE_INPUT
+ ENABLE_PROCESSED_OUTPUT
+ ENABLE_WRAP_AT_EOL_OUTPUT
+
+For more informations on the meaning of those flags, please refer to
+the L<"Microsoft's Documentation">.
+
+Example:
+
+ $mode = $CONSOLE->Mode();
+ $CONSOLE->Mode(ENABLE_MOUSE_INPUT | ENABLE_PROCESSED_INPUT);
+
+=item MouseButtons
+
+Returns the number of the buttons on your mouse, or C<undef> on errors.
+
+Example:
+
+ print "Your mouse has ", $CONSOLE->MouseButtons(), " buttons.\n";
+
+=item new Win32::Console standard_handle
+
+=item new Win32::Console [accessmode, sharemode]
+
+Creates a new console object. The first form creates a handle to a
+standard channel, I<standard_handle> can be one of the following:
+
+ STD_OUTPUT_HANDLE
+ STD_ERROR_HANDLE
+ STD_INPUT_HANDLE
+
+The second form, instead, creates a console screen buffer in memory,
+which you can access for reading and writing as a normal console, and
+then redirect on the standard output (the screen) with C<Display>. In
+this case, you can specify one or both of the following values for
+I<accessmode>:
+
+ GENERIC_READ
+ GENERIC_WRITE
+
+which are the permissions you will have on the created buffer, and one
+or both of the following values for I<sharemode>:
+
+ FILE_SHARE_READ
+ FILE_SHARE_WRITE
+
+which affect the way the console can be shared. If you don't specify
+any of those parameters, all 4 flags will be used.
+
+Example:
+
+ $STDOUT = new Win32::Console(STD_OUTPUT_HANDLE);
+ $STDERR = new Win32::Console(STD_ERROR_HANDLE);
+ $STDIN = new Win32::Console(STD_INPUT_HANDLE);
+
+ $BUFFER = new Win32::Console();
+ $BUFFER = new Win32::Console(GENERIC_READ | GENERIC_WRITE);
+
+=item OutputCP [codepage]
+
+Gets or sets the output code page used by the console. Note that this
+doesn't apply to a console object, but to the standard output console.
+See also: C<InputCP>.
+
+Example:
+
+ $codepage = $CONSOLE->OutputCP();
+ $CONSOLE->OutputCP(437);
+
+ # you may want to use the non-instanciated form to avoid confuzion :)
+ $codepage = Win32::Console::OutputCP();
+ Win32::Console::OutputCP(437);
+
+=item PeekInput
+
+Does exactly the same as C<Input>, except that the event read is not
+removed from the input buffer. See also: C<GetEvents>, C<Input>,
+C<InputChar>, C<Mode>, C<WriteInput>.
+
+Example:
+
+ @event = $CONSOLE->PeekInput();
+
+=item ReadAttr [number, col, row]
+
+Reads the specified I<number> of consecutive attributes, beginning at
+I<col>, I<row>, from the console. Returns the attributes read (a
+variable containing one character for each attribute), or C<undef> on
+errors. You can then pass the returned variable to C<WriteAttr> to
+restore the saved attributes on screen. See also: C<ReadChar>,
+C<ReadRect>.
+
+Example:
+
+ $colors = $CONSOLE->ReadAttr(80*25, 0, 0);
+
+=item ReadChar [number, col, row]
+
+Reads the specified I<number> of consecutive characters, beginning at
+I<col>, I<row>, from the console. Returns a string containing the
+characters read, or C<undef> on errors. You can then pass the
+returned variable to C<WriteChar> to restore the saved characters on
+screen. See also: C<ReadAttr>, C<ReadRect>.
+
+Example:
+
+ $chars = $CONSOLE->ReadChar(80*25, 0, 0);
+
+=item ReadRect left, top, right, bottom
+
+Reads the content (characters and attributes) of the rectangle
+specified by I<left>, I<top>, I<right>, I<bottom> from the console.
+Returns a string containing the rectangle read, or C<undef> on errors.
+You can then pass the returned variable to C<WriteRect> to restore the
+saved rectangle on screen (or on another console). See also:
+C<ReadAttr>, C<ReadChar>.
+
+Example:
+
+ $rect = $CONSOLE->ReadRect(0, 0, 80, 25);
+
+=item Scroll left, top, right, bottom, col, row, char, attr,
+ [cleft, ctop, cright, cbottom]
+
+Moves a block of data in a console buffer; the block is identified by
+I<left>, I<top>, I<right>, I<bottom>, while I<row>, I<col> identify
+the new location of the block. The cells left empty as a result of
+the move are filled with the character I<char> and attribute I<attr>.
+Optionally you can specify a clipping region with I<cleft>, I<ctop>,
+I<cright>, I<cbottom>, so that the content of the console outside this
+rectangle are unchanged. Returns C<undef> on errors, a nonzero value
+on success.
+
+Example:
+
+ # scrolls the screen 10 lines down, filling with black spaces
+ $CONSOLE->Scroll(0, 0, 80, 25, 0, 10, " ", $FG_BLACK | $BG_BLACK);
+
+=item Select standard_handle
+
+Redirects a standard handle to the specified console.
+I<standard_handle> can have one of the following values:
+
+ STD_INPUT_HANDLE
+ STD_OUTPUT_HANDLE
+ STD_ERROR_HANDLE
+
+Returns C<undef> on errors, a nonzero value on success.
+
+Example:
+
+ $CONSOLE->Select(STD_OUTPUT_HANDLE);
+
+=item SetIcon icon_file
+
+Sets the icon in the title bar of the current console window.
+
+Example:
+
+ $CONSOLE->SetIcon("C:/My/Path/To/Custom.ico");
+
+=item Size [col, row]
+
+Gets or sets the console buffer size.
+
+Example:
+
+ ($x, $y) = $CONSOLE->Size();
+ $CONSOLE->Size(80, 25);
+
+=item Title [title]
+
+Gets or sets the title of the current console window.
+
+Example:
+
+ $title = $CONSOLE->Title();
+ $CONSOLE->Title("This is a title");
+
+=item Window [flag, left, top, right, bottom]
+
+Gets or sets the current console window size. If called without
+arguments, returns a 4-element list containing the current window
+coordinates in the form of I<left>, I<top>, I<right>, I<bottom>. To
+set the window size, you have to specify an additional I<flag>
+parameter: if it is 0 (zero), coordinates are considered relative to
+the current coordinates; if it is non-zero, coordinates are absolute.
+
+Example:
+
+ ($left, $top, $right, $bottom) = $CONSOLE->Window();
+ $CONSOLE->Window(1, 0, 0, 80, 50);
+
+=item Write string
+
+Writes I<string> on the console, using the current attribute, that you
+can set with C<Attr>, and advancing the cursor as needed. This isn't
+so different from Perl's "print" statement. Returns the number of
+characters written or C<undef> on errors. See also: C<WriteAttr>,
+C<WriteChar>, C<WriteRect>.
+
+Example:
+
+ $CONSOLE->Write("Hello, world!");
+
+=item WriteAttr attrs, col, row
+
+Writes the attributes in the string I<attrs>, beginning at I<col>,
+I<row>, without affecting the characters that are on screen. The
+string attrs can be the result of a C<ReadAttr> function, or you can
+build your own attribute string; in this case, keep in mind that every
+attribute is treated as a character, not a number (see example).
+Returns the number of attributes written or C<undef> on errors. See
+also: C<Write>, C<WriteChar>, C<WriteRect>.
+
+Example:
+
+ $CONSOLE->WriteAttr($attrs, 0, 0);
+
+ # note the use of chr()...
+ $attrs = chr($FG_BLACK | $BG_WHITE) x 80;
+ $CONSOLE->WriteAttr($attrs, 0, 0);
+
+=item WriteChar chars, col, row
+
+Writes the characters in the string I<attr>, beginning at I<col>, I<row>,
+without affecting the attributes that are on screen. The string I<chars>
+can be the result of a C<ReadChar> function, or a normal string. Returns
+the number of characters written or C<undef> on errors. See also:
+C<Write>, C<WriteAttr>, C<WriteRect>.
+
+Example:
+
+ $CONSOLE->WriteChar("Hello, worlds!", 0, 0);
+
+=item WriteInput (event)
+
+Pushes data in the console input buffer. I<(event)> is a list of values,
+for more information see C<Input>. The string chars can be the result of
+a C<ReadChar> function, or a normal string. Returns the number of
+characters written or C<undef> on errors. See also: C<Write>,
+C<WriteAttr>, C<WriteRect>.
+
+Example:
+
+ $CONSOLE->WriteInput(@event);
+
+=item WriteRect rect, left, top, right, bottom
+
+Writes a rectangle of characters and attributes (contained in I<rect>)
+on the console at the coordinates specified by I<left>, I<top>,
+I<right>, I<bottom>. I<rect> can be the result of a C<ReadRect>
+function. Returns C<undef> on errors, otherwise a 4-element list
+containing the coordinates of the affected rectangle, in the format
+I<left>, I<top>, I<right>, I<bottom>. See also: C<Write>,
+C<WriteAttr>, C<WriteChar>.
+
+Example:
+
+ $CONSOLE->WriteRect($rect, 0, 0, 80, 25);
+
+=back
+
+
+=head2 Constants
+
+The following constants are exported in the main namespace of your
+script using Win32::Console:
+
+ BACKGROUND_BLUE
+ BACKGROUND_GREEN
+ BACKGROUND_INTENSITY
+ BACKGROUND_RED
+ CAPSLOCK_ON
+ CONSOLE_TEXTMODE_BUFFER
+ ENABLE_ECHO_INPUT
+ ENABLE_LINE_INPUT
+ ENABLE_MOUSE_INPUT
+ ENABLE_PROCESSED_INPUT
+ ENABLE_PROCESSED_OUTPUT
+ ENABLE_WINDOW_INPUT
+ ENABLE_WRAP_AT_EOL_OUTPUT
+ ENHANCED_KEY
+ FILE_SHARE_READ
+ FILE_SHARE_WRITE
+ FOREGROUND_BLUE
+ FOREGROUND_GREEN
+ FOREGROUND_INTENSITY
+ FOREGROUND_RED
+ LEFT_ALT_PRESSED
+ LEFT_CTRL_PRESSED
+ NUMLOCK_ON
+ GENERIC_READ
+ GENERIC_WRITE
+ RIGHT_ALT_PRESSED
+ RIGHT_CTRL_PRESSED
+ SCROLLLOCK_ON
+ SHIFT_PRESSED
+ STD_INPUT_HANDLE
+ STD_OUTPUT_HANDLE
+ STD_ERROR_HANDLE
+
+Additionally, the following variables can be used:
+
+ $FG_BLACK
+ $FG_GRAY
+ $FG_BLUE
+ $FG_LIGHTBLUE
+ $FG_RED
+ $FG_LIGHTRED
+ $FG_GREEN
+ $FG_LIGHTGREEN
+ $FG_MAGENTA
+ $FG_LIGHTMAGENTA
+ $FG_CYAN
+ $FG_LIGHTCYAN
+ $FG_BROWN
+ $FG_YELLOW
+ $FG_LIGHTGRAY
+ $FG_WHITE
+
+ $BG_BLACK
+ $BG_GRAY
+ $BG_BLUE
+ $BG_LIGHTBLUE
+ $BG_RED
+ $BG_LIGHTRED
+ $BG_GREEN
+ $BG_LIGHTGREEN
+ $BG_MAGENTA
+ $BG_LIGHTMAGENTA
+ $BG_CYAN
+ $BG_LIGHTCYAN
+ $BG_BROWN
+ $BG_YELLOW
+ $BG_LIGHTGRAY
+ $BG_WHITE
+
+ $ATTR_NORMAL
+ $ATTR_INVERSE
+
+ATTR_NORMAL is set to gray foreground on black background (DOS's
+standard colors).
+
+
+=head2 Microsoft's Documentation
+
+Documentation for the Win32 Console and Character mode Functions can
+be found on Microsoft's site at this URL:
+
+http://www.microsoft.com/msdn/sdk/platforms/doc/sdk/win32/sys/src/conchar.htm
+
+A reference of the available functions is at:
+
+http://www.microsoft.com/msdn/sdk/platforms/doc/sdk/win32/sys/src/conchar_34.htm
+
+
+=head1 AUTHOR
+
+Aldo Calpini <a.calpini@romagiubileo.it>
+
+=head1 CREDITS
+
+Thanks to: Jesse Dougherty, Dave Roth, ActiveWare, and the
+Perl-Win32-Users community.
+
+=head1 DISCLAIMER
+
+This program is FREE; you can redistribute, modify, disassemble, or
+even reverse engineer this software at your will. Keep in mind,
+however, that NOTHING IS GUARANTEED to work and everything you do is
+AT YOUR OWN RISK - I will not take responsibility for any damage, loss
+of money and/or health that may arise from the use of this program!
+
+This is distributed under the terms of Larry Wall's Artistic License.
diff --git a/Master/tlpkg/tlperl/lib/Win32/OLE.pm b/Master/tlpkg/tlperl/lib/Win32/OLE.pm
index 45158f6278f..ece534b15fa 100644
--- a/Master/tlpkg/tlperl/lib/Win32/OLE.pm
+++ b/Master/tlpkg/tlperl/lib/Win32/OLE.pm
@@ -6,7 +6,7 @@ use strict;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK @EXPORT_FAIL $AUTOLOAD
$CP $LCID $Warn $LastError $_NewEnum $_Unique);
-$VERSION = '0.1711';
+$VERSION = '0.1712';
use Carp;
use Exporter;
@@ -963,6 +963,6 @@ related questions only, of course).
=head1 VERSION
-Version 0.1711 21 December 2013
+Version 0.1712 14 May 2014
=cut
diff --git a/Master/tlpkg/tlperl/lib/Win32/OLE/NEWS.pod b/Master/tlpkg/tlperl/lib/Win32/OLE/NEWS.pod
new file mode 100644
index 00000000000..217fe4a6fcc
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Win32/OLE/NEWS.pod
@@ -0,0 +1,380 @@
+=pod
+
+=head1 NAME
+
+Win32::OLE::NEWS - What's new in Win32::OLE
+
+This file contains a history of user visible changes to the
+Win32::OLE::* modules. Only new features and major bug fixes that
+might affect backwards compatibility are included.
+
+=head1 Version 0.18
+
+=head2 VT_CY and VT_DECIMAL return values handled differently
+
+The new C<Variant> option enables values of VT_CY or VT_DECIMAL type
+to be returned as Win32::OLE::Variant objects instead of being
+converted into strings and numbers respectively. This is similar to
+the change in Win32::OLE version 0.12 to VT_DATE and VT_ERROR values.
+The Win32::OLE::Variant module must be included to make sure that
+VT_CY and VT_DECIMAL values behave as before in numeric or string
+contexts.
+
+Because the new behavior is potentially incompatible, it must be
+explicitly enabled:
+
+ Win32::OLE->Option(Variant => 1);
+
+
+=head1 Version 0.17
+
+=head2 New nullstring() function in Win32::OLE::Variant
+
+The nullstring() function returns a VT_BSTR variant containing a NULL
+string pointer. Note that this is not the same as a VT_BSTR variant
+containing the empty string "".
+
+The nullstring() return value is equivalent to the Visual Basic
+C<vbNullString> constant.
+
+
+=head1 Version 0.16
+
+=head2 Improved Unicode support
+
+Passing Unicode strings to methods and properties as well as returning
+Unicode strings back to Perl works now with both Perl 5.6 and 5.8.
+Note that the Unicode support in 5.8 is much more complete than in 5.6
+or 5.6.1.
+
+C<Unicode::String> objects can now be passed to methods or assigned to
+properties.
+
+You must enable Unicode support by switching Win32::OLE to the UTF8
+codepage:
+
+ Win32::OLE->Option(CP => Win32::OLE::CP_UTF8());
+
+
+=head1 Version 0.13
+
+=head2 New nothing() function in Win32::OLE::Variant
+
+The nothing() function returns an empty VT_DISPATCH variant. It can be
+used to clear an object reference stored in a property
+
+ use Win32::OLE::Variant qw(:DEFAULT nothing);
+ # ...
+ $object->{Property} = nothing;
+
+This has the same effect as the Visual Basic statement
+
+ Set object.Property = Nothing
+
+=head2 New _NewEnum and _Unique options
+
+There are two new options available for the Win32::OLE->Option class
+method: C<_NewEnum> provides the elements of a collection object
+directly as the value of a C<_NewEnum> property. The C<_Unique>
+option guarantees that Win32::OLE will not create multiple proxy
+objects for the same underlying COM/OLE object.
+
+Both options are only really useful to tree traversal programs or
+during debugging.
+
+
+=head1 Version 0.12
+
+=head2 Additional error handling functionality
+
+The Warn option can now be set to a CODE reference too. For example,
+
+ Win32::OLE->Option(Warn => 3);
+
+could now be written as
+
+ Win32::OLE->Option(Warn => \&Carp::croak);
+
+This can even be used to emulate the VisualBasic C<On Error Goto
+Label> construct:
+
+ Win32::OLE->Option(Warn => sub {goto CheckError});
+ # ... your normal OLE code here ...
+
+ CheckError:
+ # ... your error handling code here ...
+
+=head2 Builtin event loop
+
+Processing OLE events required a polling loop before, e.g.
+
+ my $Quit;
+ #...
+ until ($Quit) {
+ Win32::OLE->SpinMessageLoop;
+ Win32::Sleep(100);
+ }
+ package BrowserEvents;
+ sub OnQuit { $Quit = 1 }
+
+This is inefficient and a bit odd. This version of Win32::OLE now
+supports a standard messageloop:
+
+ Win32::OLE->MessageLoop();
+
+ package BrowserEvents;
+ sub OnQuit { Win32::OLE->QuitMessageLoop }
+
+=head2 Free unused OLE libraries
+
+Previous versions of Win32::OLE would call the CoFreeUnusedLibraries()
+API whenever an OLE object was destroyed. This made sure that OLE
+libraries would be unloaded as soon as they were no longer needed.
+Unfortunately, objects implemented in Visual Basic tend to crash
+during this call, as they pretend to be ready for unloading, when in
+fact, they aren't.
+
+The unloading of object libraries is really only important for long
+running processes that might instantiate a huge number of B<different>
+objects over time. Therefore this API is no longer called
+automatically. The functionality is now available explicitly to those
+who want or need it by calling a Win32::OLE class method:
+
+ Win32::OLE->FreeUnusedLibraries();
+
+=head2 The "Win32::OLE" article from "The Perl Journal #10"
+
+The article is Copyright 1998 by I<The Perl
+Journal>. http://www.tpj.com
+
+It originally appeared in I<The Perl Journal> # 10 and appears here
+courtesy of Jon Orwant and I<The Perl Journal>. The sample code from
+the article is in the F<eg/tpj.pl> file.
+
+=head2 VARIANT->Put() bug fixes
+
+The Put() method didn't work correctly for arrays of type VT_BSTR,
+VT_DISPATH or VT_UNKNOWN. This has been fixed.
+
+=head2 Error message fixes
+
+Previous versions of Win32::OLE gave a wrong argument index for some
+OLE error messages (the number was too large by 1). This should be
+fixed now.
+
+=head2 VT_DATE and VT_ERROR return values handled differently
+
+Method calls and property accesses returning a VT_DATE or VT_ERROR
+value would previously translate the value to string or integer
+format. This has been changed to return a Win32::OLE::Variant object.
+The return values will behave as before if the Win32::OLE::Variant
+module is being used. This module overloads the conversion of
+the objects to strings and numbers.
+
+
+=head1 Version 0.11 (changes since 0.1008)
+
+=head2 new DHTML typelib browser
+
+The Win32::OLE distribution now contains a type library browser. It
+is written in PerlScript, generating dynamic HTML. It requires
+Internet Explorer 4.0 or later. You'll find it in
+F<browser/Browser.html>. It should be available in the ActivePerl
+HTML help under Win32::OLE::Browser.
+
+After selecting a library, type or member you can press F1 to call up
+the corresponding help file at the appropriate location.
+
+=head2 VT_DECIMAL support
+
+The Win32::OLE::Variant module now supports VT_DECIMAL variants too.
+They are not "officially" allowed in OLE Automation calls, but even
+Microsoft's "ActiveX Data Objects" sometimes returns VT_DECIMAL
+values.
+
+VT_DECIMAL variables are stored as 96-bit integers scaled by a
+variable power of 10. The power of 10 scaling factor specifies the
+number of digits to the right of the decimal point, and ranges from 0
+to 28. With a scale of 0 (no decimal places), the largest possible
+value is +/-79,228,162,514,264,337,593,543,950,335. With a 28 decimal
+places, the largest value is +/-7.9228162514264337593543950335 and the
+smallest, non-zero value is +/-0.0000000000000000000000000001.
+
+=head1 Version 0.1008
+
+=head2 new LetProperty() object method
+
+In Win32::OLE property assignment using the hash syntax is equivalent
+to the Visual Basic C<Set> syntax (I<by reference> assignment):
+
+ $Object->{Property} = $OtherObject;
+
+corresponds to this Visual Basic statement:
+
+ Set Object.Property = OtherObject
+
+To get the I<by value> treatment of the Visual Basic C<Let> statement
+
+ Object.Property = OtherObject
+
+you have to use the LetProperty() object method in Perl:
+
+ $Object->LetProperty($Property, $OtherObject);
+
+=head2 new HRESULT() function
+
+The HRESULT() function converts an unsigned number into a signed HRESULT
+error value as used by OLE internally. This is necessary because Perl
+treats all hexadecimal constants as unsigned. To check if the last OLE
+function returned "Member not found" (0x80020003) you can write:
+
+ if (Win32::OLE->LastError == HRESULT(0x80020003)) {
+ # your error recovery here
+ }
+
+=head1 Version 0.1007 (changes since 0.1005)
+
+=head2 OLE Event support
+
+This version of Win32::OLE contains B<ALPHA> level support for OLE events. The
+user interface is still subject to change. There are ActiveX objects / controls
+that don't fire events under the current implementation.
+
+Events are enabled for a specific object with the Win32::OLE->WithEvents()
+class method:
+
+ Win32::OLE->WithEvents(OBJECT, HANDLER, INTERFACE)
+
+Please read further documentation in Win32::OLE.
+
+=head2 GetObject() and GetActiveObject() now support optional DESTRUCTOR argument
+
+It is now possible to specify a DESTRUCTOR argument to the GetObject() and
+GetActiveObject() class methods. They work identical to the new() DESTRUCTOR
+argument.
+
+=head2 Remote object instantiation via DCOM
+
+This has actually been in Win32::OLE since 0.0608, but somehow never got
+documented. You can provide an array reference in place of the usual PROGID
+parameter to Win32::OLE->new():
+
+ OBJ = Win32::OLE->new([MACHINE, PRODID]);
+
+The array must contain two elements: the name of the MACHINE and the PROGID.
+This will try to create the object on the remote MACHINE.
+
+=head2 Enumerate all Win32::OLE objects
+
+This class method returns the number Win32::OLE objects currently in
+existence. It will call the optional CALLBACK function for each of
+these objects:
+
+ $Count = Win32::OLE->EnumAllObjects(sub {
+ my $Object = shift;
+ my $Class = Win32::OLE->QueryObjectType($Object);
+ printf "# Object=%s Class=%s\n", $Object, $Class;
+ });
+
+The EnumAllObjects() method is primarily a debugging tool. It can be
+used e.g. in an END block to check if all external connections have
+been properly destroyed.
+
+=head2 The VARIANT->Put() method now returns the VARIANT object itself
+
+This allows chaining of Put() method calls to set multiple values in an
+array variant:
+
+ $Array->Put(0,0,$First_value)->Put(0,1,$Another_value);
+
+=head2 The VARIANT->Put(ARRAYREF) form allows assignment to a complete SAFEARRAY
+
+This allows automatic conversion from a list of lists to a SAFEARRAY.
+You can now write:
+
+ my $Array = Variant(VT_ARRAY|VT_R8, [1,2], 2);
+ $Array->Put([[1,2], [3,4]]);
+
+instead of the tedious:
+
+ $Array->Put(1,0,1);
+ $Array->Put(1,1,2);
+ $Array->Put(2,0,3);
+ $Array->Put(2,1,4);
+
+=head2 New Variant formatting methods
+
+There are four new methods for formatting variant values: Currency(), Date(),
+Number() and Time(). For example:
+
+ my $v = Variant(VT_DATE, "April 1 99");
+ print $v->Date(DATE_LONGDATE), "\n";
+ print $v->Date("ddd',' MMM dd yy"), "\n";
+
+will print:
+
+ Thursday, April 01, 1999
+ Thu, Apr 01 99
+
+=head2 new Win32::OLE::NLS methods: SendSettingChange() and SetLocaleInfo()
+
+SendSettingChange() sends a WM_SETTINGCHANGE message to all top level windows.
+
+SetLocaleInfo() allows changing elements in the user override section of the
+locale database. Unfortunately these changes are not automatically available
+to further Variant formatting; you have to call SendSettingChange() first.
+
+=head2 Win32::OLE::Const now correctly treats version numbers as hex
+
+The minor and major version numbers of type libraries have been treated as
+decimal. This was wrong. They are now correctly decoded as hex.
+
+=head2 more robust global destruction of Win32::OLE objects
+
+The final destruction of Win32::OLE objects has always been somewhat fragile.
+The reason for this is that Perl doesn't honour reference counts during global
+destruction but destroys objects in seemingly random order. This can lead
+to leaked database connections or unterminated external objects. The only
+solution was to make all objects lexical and hope that no object would be
+trapped in a closure. Alternatively all objects could be explicitly set to
+C<undef>, which doesn't work very well with exception handling.
+
+With version 0.1007 of Win32::OLE this problem should be gone: The module
+keeps a list of active Win32::OLE objects. It uses an END block to destroy
+all objects at program termination I<before> the Perl's global destruction
+starts. Objects still existing at program termination are now destroyed in
+reverse order of creation. The effect is similar to explicitly calling
+Win32::OLE->Uninitialize() just prior to termination.
+
+=head1 Version 0.1005 (changes since 0.1003)
+
+Win32::OLE 0.1005 has been release with ActivePerl build 509. It is also
+included in the I<Perl Resource Kit for Win32> Update.
+
+=head2 optional DESTRUCTOR for GetActiveObject() GetObject() class methods
+
+The GetActiveObject() and GetObject() class method now also support an
+optional DESTRUCTOR parameter just like Win32::OLE->new(). The DESTRUCTOR
+is executed when the last reference to this object goes away. It is
+generally considered C<impolite> to stop applications that you did not
+start yourself.
+
+=head2 new Variant object method: $object->Copy()
+
+See L<Win32::OLE::Variant/Copy([DIM])>.
+
+=head2 new Win32::OLE->Option() class method
+
+The Option() class method can be used to inspect and modify
+L<Win32::OLE/Module Options>. The single argument form retrieves
+the value of an option:
+
+ my $CP = Win32::OLE->Option('CP');
+
+A single call can be used to set multiple options simultaneously:
+
+ Win32::OLE->Option(CP => CP_ACP, Warn => 3);
+
+Currently the following options exist: CP, LCID and C<Warn>.
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/Win32/OLE/TPJ.pod b/Master/tlpkg/tlperl/lib/Win32/OLE/TPJ.pod
new file mode 100644
index 00000000000..e45770baa42
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Win32/OLE/TPJ.pod
@@ -0,0 +1,798 @@
+=pod
+
+=head1 NAME
+
+The Perl Journal #10 - Win32::OLE by Jan Dubois
+
+=head1 INTRODUCTION
+
+Suppose you're composing a document with Microsoft Word. You want to
+include an Excel spreadsheet. You could save the spreadsheet in some
+image format that Word can understand, and import it into your
+document. But if the spreadsheet changes, your document will be out of
+date.
+
+Microsoft's OLE (Object Linking and Embedding, pronounced "olay") lets
+one program use objects from another. In the above scenario, the
+spreadsheet is the object. As long as Excel makes that spreadsheet
+available as an OLE object, and Word knows to treat it like one, your
+document will always be current.
+
+You can control OLE objects from Perl with the Win32::OLE module, and
+that's what this article is about. First, I'll show you how to "think
+OLE," which mostly involves a lot of jargon. Next, I'll show you the
+mechanics involved in using Win32::OLE. Then we'll go through a Perl
+program that uses OLE to manipulate Microsoft Excel, Microsoft Access,
+and Lotus Notes. Finally, I'll talk about Variants, an internal OLE
+data type.
+
+
+=head1 THE OLE MINDSET
+
+When an application makes an OLE object available for other
+applications to use, that's called OLE I<automation>. The program
+using the object is called the I<controller>, and the application
+providing the object is called the I<server>. OLE automation is guided
+by the OLE Component Object Model (COM) which specifies how those
+objects must behave if they are to be used by other processes and
+machines.
+
+There are two different types of OLE automation servers. I<In-process>
+servers are implemented as dynamic link libraries (DLLs) and run in
+the same process space as the controller. I<Out-of-process> servers
+are more interesting; they are standalone executables that exist as
+separate processes - possibly on a different computer.
+
+The Win32::OLE module lets your Perl program act as an OLE
+controller. It allows Perl to be used in place of other languages like
+Visual Basic or Java to control OLE objects. This makes all OLE
+automation servers immediately available as Perl modules.
+
+Don't confuse ActiveState OLE with Win32::OLE. ActiveState OLE is
+completely different, although future builds of ActiveState Perl (500
+and up) will work with Win32::OLE.
+
+Objects can expose OLE methods, properties, and events to the outside
+world. Methods are functions that the controller can call to make the
+object do something; properties describe the state of the object; and
+events let the controller know about external events affecting the
+object, such as the user clicking on a button. Since events involve
+asynchronous communication with their objects, they require either
+threads or an event loop. They are not yet supported by the Win32::OLE
+module, and for the same reason ActiveX controls (OCXs) are currently
+unsupported as well.
+
+=head1 WORKING WITH WIN32::OLE
+
+The Win32::OLE module doesn't let your Perl program create OLE
+objects. What it does do is let your Perl program act like a remote
+control for other applications-it lets your program be an OLE
+controller. You can take an OLE object from another application
+(Access, Notes, Excel, or anything else that speaks OLE) and invoke
+its methods or manipulate its properties.
+
+=head2 THE FIRST STEP: CREATING AN OLE SERVER OBJECT
+
+First, we need to create a Perl object to represent the OLE
+server. This is a weird idea; what it amounts to is that if we want to
+control OLE objects produced by, say, Excel, we have to create a Perl
+object that represents Excel. So even though our program is an OLE
+controller, it'll contain objects that represent OLE servers.
+
+You can create a new OLE I<server object> with C<< Win32::OLE->new >>.
+This takes a program ID (a human readable string like
+C<'Speech.VoiceText'>) and returns a server object:
+
+ my $server = Win32::OLE->new('Excel.Application', 'Quit');
+
+Some server objects (particularly those for Microsoft Office
+applications) don't automatically terminate when your program no
+longer needs them. They need some kind of Quit method, and that's just
+what our second argument is. It can be either a code reference or a
+method name to be invoked when the object is destroyed. This lets you
+ensure that objects will be properly cleaned up even when the Perl
+program dies abnormally.
+
+To access a server object on a different computer, replace the first
+argument with a reference to a list of the server name and program ID:
+
+ my $server = Win32::OLE->new(['foo.bar.com',
+ 'Excel.Application']);
+
+(To get the requisite permissions, you'll need to configure your
+security settings with F<DCOMCNFG.EXE>.)
+
+You can also directly attach your program to an already running OLE
+server:
+
+ my $server = Win32::OLE->GetActiveObject('Excel.Application');
+
+This fails (returning C<undef>) if no server exists, or if the server
+refuses the connection for some reason. It is also possible to use a
+persistent object moniker (usually a filename) to start the associated
+server and load the object into memory:
+
+ my $doc = Win32::OLE->GetObject("MyDocument.Doc");
+
+=head2 METHOD CALLS
+
+Once you've created one of these server objects, you need to call its
+methods to make the OLE objects sing and dance. OLE methods are
+invoked just like normal Perl object methods:
+
+ $server->Foo(@Arguments);
+
+This is a Perl method call - but it also triggers an OLE method call
+in the object. After your program executes this statement, the
+C<$server> object will execute its Foo() method. The available methods
+are typically documented in the application's I<object model>.
+
+B<Parameters.> By default, all parameters are positional
+(e.g. C<foo($first, $second, $third)>) rather than named (e.g.
+C<< foo(-name => "Yogi", -title => "Coach") >>). The required parameters
+come first, followed by the optional parameters; if you need to
+provide a dummy value for an optional parameter, use undef.
+
+Positional parameters get cumbersome if a method takes a lot of
+them. You can use named arguments instead if you go to a little extra
+trouble - when the last argument is a reference to a hash, the
+key/value pairs of the hash are treated as named parameters:
+
+ $server->Foo($Pos1, $Pos2, {Name1 => $Value1,
+ Name2 => $Value2});
+
+B<Foreign Languages and Default Methods.> Sometimes OLE servers use
+method and property names that are specific to a non-English
+locale. That means they might have non-ASCII characters, which aren't
+allowed in Perl variable names. In German, you might see C<Öffnen> used
+instead of C<Open>. In these cases, you can use the Invoke() method:
+
+ $server->Invoke('Öffnen', @Arguments);
+
+This is necessary because C<< $Server->Öffnen(@Arguments) >> is a syntax
+error in current versions of Perl.
+
+=head2 PROPERTIES
+
+As I said earlier, objects can expose three things to the outside
+world: methods, properties, and events. We've covered methods, and
+Win32::OLE can't handle events. That leaves properties. But as it
+turns out, properties and events are largely interchangeable. Most
+methods have corresponding properties, and vice versa.
+
+An object's properties can be accessed with a hash reference:
+
+ $server->{Bar} = $value;
+ $value = $server->{Bar};
+
+This example sets and queries the value of the property named
+C<Bar>. You could also have called the object's Bar() method to
+achieve the same effect:
+
+ $value = $server->Bar;
+
+However, you can't write the first line as C<< $server->Bar = $value >>,
+because you can't assign to the return value of a method call. In
+Visual Basic, OLE automation distinguishes between assigning the name
+of an object and assigning its value:
+
+ Set Object = OtherObject
+
+ Let Value = Object
+
+The C<Set> statement shown here makes C<Object> refer to the same object as
+C<OtherObject>. The C<Let> statement copies the value instead. (The value of
+an OLE object is what you get when you call the object's default
+method.
+
+In Perl, saying C<< $server1 = $server2 >> always creates another reference,
+just like the C<Set> in Visual Basic. If you want to assign the value
+instead, use the valof() function:
+
+ my $value = valof $server;
+
+This is equivalent to
+
+ my $value = $server->Invoke('');
+
+=head2 SAMPLE APPLICATION
+
+Let's look at how all of this might be used. In Listing: 1 you'll see
+F<T-Bond.pl>, a program that uses Win32::OLE for an almost-real world
+application.
+
+The developer of this application, Mary Lynch, is a financial futures
+broker. Every afternoon, she connects to the Chicago Board of Trade
+(CBoT) web site at http://www.cbot.com and collects the time and sales
+information for U.S. T-bond futures. She wants her program to create a
+chart that depicts the data in 15-minute intervals, and then she wants
+to record the data in a database for later analysis. Then she wants
+her program to send mail to her clients.
+
+Mary's program will use Microsoft Access as a database, Microsoft
+Excel to produce the chart, and Lotus Notes to send the mail. It will
+all be controlled from a single Perl program using OLE automation. In
+this section, we'll go through T-Bond. pl step by step so you can see
+how Win32::OLE lets you control these applications.
+
+=head2 DOWNLOADING A WEB PAGE WITH LWP
+
+However, Mary first needs to amass the raw T-bond data by having her
+Perl program automatically download and parse a web page. That's the
+perfect job for LWP, the libwww-perl bundle available on the CPAN. LWP
+has nothing to do with OLE. But this is a real-world application, and
+it's just what Mary needs to download her data from the Chicago Board
+of Trade.
+
+ use LWP::Simple;
+ my $URL = 'http://www.cbot.com/mplex/quotes/tsfut';
+ my $text = get("$URL/tsf$Contract.htm");
+
+She could also have used the Win32::Internet module:
+
+ use Win32::Internet;
+ my $URL = 'http://www.cbot.com/mplex/quotes/tsfut';
+ my $text = $Win32::Internet->new->FetchURL("$URL/tsf$Contract.htm");
+
+Mary wants to condense the ticker data into 15 minute bars. She's
+interested only in lines that look like this:
+
+ 03/12/1998 US 98Mar 12116 15:28:34 Open
+
+A regular expression can be used to determine whether a line looks
+like this. If it does, the regex can split it up into individual
+fields. The price quoted above, C<12116>, really means 121 16/32, and
+needs to be converted to 121.5. The data is then condensed into 15
+minute intervals and only the first, last, highest, and lowest price
+during each interval are kept. The time series is stored in the array
+C<@Bars>. Each entry in C<@Bars> is a reference to a list of 5 elements:
+Time, Open, High, Low, and Close.
+
+ foreach (split "\n", $text) {
+ # 03/12/1998 US 98Mar 12116 15:28:34 Open
+ my ($Date,$Price,$Hour,$Min,$Sec,$Ind) =
+ m|^\s*(\d+/\d+/\d+) # " 03/12/1998"
+ \s+US\s+\S+\s+(\d+) # " US 98Mar 12116"
+ \s+(\d+):(\d+):(\d+) # " 12:42:40"
+ \s*(.*)$|x; # " Ask"
+ next unless defined $Date;
+ $Day = $Date;
+
+ # Convert from fractional to decimal format
+ $Price = int($Price/100) + ($Price%100)/32;
+
+ # Round up time to next multiple of 15 minutes
+ my $NewTime = int(($Sec+$Min*60+$Hour*3600)/900+1)*900;
+ unless (defined $Time && $NewTime == $Time) {
+ push @Bars, [$hhmm, $Open, $High, $Low, $Close]
+ if defined $Time;
+ $Open = $High = $Low = $Close = undef;
+ $Time = $NewTime;
+ my $Hour = int($Time/3600);
+ $hhmm = sprintf "%02d:%02d", $Hour, $Time/60-$Hour*60;
+ }
+
+ # Update 15 minute bar values
+ $Close = $Price;
+ $Open = $Price unless defined $Open;
+ $High = $Price unless defined $High && $High > $Price;
+ $Low = $Price unless defined $Low && $Low > $Price;
+ }
+
+ die "No data found" unless defined $Time;
+ push @Bars, [$hhmm, $Open, $High, $Low, $Close];
+
+=head2 MICROSOFT ACCESS
+
+Now that Mary has her T-bond quotes, she's ready to use Win32::OLE to
+store them into a Microsoft Access database. This has the advantage
+that she can copy the database to her lap-top and work with it on her
+long New York commute. She's able to create an Access database as
+follows:
+
+ use Win32::ODBC;
+ use Win32::OLE;
+
+ # Include the constants for the Microsoft Access
+ # "Data Access Object".
+
+ use Win32::OLE::Const 'Microsoft DAO';
+
+ my $DSN = 'T-Bonds';
+ my $Driver = 'Microsoft Access Driver (*.mdb)';
+ my $Desc = 'US T-Bond Quotes';
+ my $Dir = 'i:\tmp\tpj';
+ my $File = 'T-Bonds.mdb';
+ my $Fullname = "$Dir\\$File";
+
+ # Remove old database and dataset name
+ unlink $Fullname if -f $Fullname;
+ Win32::ODBC::ConfigDSN(ODBC_REMOVE_DSN, $Driver, "DSN=$DSN")
+ if Win32::ODBC::DataSources($DSN);
+
+ # Create new database
+ my $Access = Win32::OLE->new('Access.Application', 'Quit');
+ my $Workspace = $Access->DBEngine->CreateWorkspace('', 'Admin', '');
+ my $Database = $Workspace->CreateDatabase($Fullname, dbLangGeneral);
+
+ # Add new database name
+ Win32::ODBC::ConfigDSN(ODBC_ADD_DSN, $Driver,
+ "DSN=$DSN", "Description=$Desc", "DBQ=$Fullname",
+ "DEFAULTDIR=$Dir", "UID=", "PWD=");
+
+This uses Win32::ODBC (described in TPJ #9) to remove and create
+F<T-Bonds.mdb>. This lets Mary use the same script on her workstation
+and on her laptop even when the database is stored in different
+locations on each. The program also uses Win32::OLE to make Microsoft
+Access create an empty database.
+
+Every OLE server has some constants that your Perl program will need
+to use, made accessible by the Win32::OLE::Const module. For instance,
+to grab the Excel constants, say C<use Win32::OLE::Const 'Microsoft
+Excel'>.
+
+In the above example, we imported the Data Access Object con-stants
+just so we could use C<dbLangGeneral>.
+
+=head2 MICROSOFT EXCEL
+
+Now Mary uses Win32::OLE a second time, to have Microsoft Excel create
+the chart shown below.
+
+ Figure 1: T-Bond data generated by MicroSoft Excel via Win32::OLE
+
+ # Start Excel and create new workbook with a single sheet
+ use Win32::OLE qw(in valof with);
+ use Win32::OLE::Const 'Microsoft Excel';
+ use Win32::OLE::NLS qw(:DEFAULT :LANG :SUBLANG);
+
+ my $lgid = MAKELANGID(LANG_ENGLISH, SUBLANG_DEFAULT);
+ $Win32::OLE::LCID = MAKELCID($lgid);
+
+ $Win32::OLE::Warn = 3;
+
+Here, Mary sets the locale to American English, which lets her do
+things like use American date formats (e.g. C<"12-30-98"> rather than
+C<"30-12-98">) in her program. It will continue to work even when she's
+visiting one of her international customers and has to run this
+program on their computers.
+
+The value of C<$Win32::OLE::Warn> determines what happens when an OLE
+error occurs. If it's 0, the error is ignored. If it's 2, or if it's 1
+and the script is running under C<-w>, the Win32::OLE module invokes
+C<Carp::carp()>. If C<$Win32::OLE::Warn> is set to 3, C<Carp::croak()>
+is invoked and the program dies immediately.
+
+Now the data can be put into an Excel spreadsheet to produce the
+chart. The following section of the program launches Excel and creates
+a new workbook with a single worksheet. It puts the column titles
+('Time', 'Open', 'High', 'Low', and 'Close') in a bold font on the
+first row of the sheet. The first column displays the timestamp in
+I<hh:mm> format; the next four display prices.
+
+ my $Excel = Win32::OLE->new('Excel.Application', 'Quit');
+ $Excel->{SheetsInNewWorkbook} = 1;
+ my $Book = $Excel->Workbooks->Add;
+ my $Sheet = $Book->Worksheets(1);
+ $Sheet->{Name} = 'Candle';
+
+ # Insert column titles
+ my $Range = $Sheet->Range("A1:E1");
+ $Range->{Value} = [qw(Time Open High Low Close)];
+ $Range->Font->{Bold} = 1;
+
+ $Sheet->Columns("A:A")->{NumberFormat} = "h:mm";
+ # Open/High/Low/Close to be displayed in 32nds
+ $Sheet->Columns("B:E")->{NumberFormat} = "# ?/32";
+
+ # Add 15 minute data to spreadsheet
+ print "Add data\n";
+ $Range = $Sheet->Range(sprintf "A2:E%d", 2+$#Bars);
+ $Range->{Value} = \@Bars;
+
+The last statement shows how to pass arrays to OLE objects. The
+Win32::OLE module automatically translates each array reference to a
+C<SAFEARRAY>, the internal OLE array data type. This translation first
+determines the maximum nesting level used by the Perl array, and then
+creates a C<SAFEARRAY> of the same dimension. The C<@Bars> array
+already contains the data in the correct form for the spreadsheet:
+
+ ([Time1, Open1, High1, Low1, Close1],
+ ...
+ [TimeN, OpenN, HighN, LowN, CloseN])
+
+Now the table in the spreadsheet can be used to create a candle stick
+chart from our bars. Excel automatically chooses the time axis labels
+if they are selected before the chart is created:
+
+ # Create candle stick chart as new object on worksheet
+ $Sheet->Range("A:E")->Select;
+
+ my $Chart = $Book->Charts->Add;
+ $Chart->{ChartType} = xlStockOHLC;
+ $Chart->Location(xlLocationAsObject, $Sheet->{Name});
+ # Excel bug: the old $Chart is now invalid!
+ $Chart = $Excel->ActiveChart;
+
+We can change the type of the chart from a separate sheet to a chart
+object on the spreadsheet page with the C<< $Chart->Location >>
+method. (This invalidates the chart object handle, which might be
+considered a bug in Excel.) Fortunately, this new chart is still the
+'active' chart, so an object handle to it can be reclaimed simply by
+asking Excel.
+
+At this point, our chart still needs a title, the legend is
+meaningless, and the axis has decimals instead of fractions. We can
+fix those with the following code:
+
+ # Add title, remove legend
+ with($Chart, HasLegend => 0, HasTitle => 1);
+ $Chart->ChartTitle->Characters->{Text} = "US T-Bond";
+
+ # Set up daily statistics
+ $Open = $Bars[0][1];
+ $High = $Sheet->Evaluate("MAX(C:C)");
+ $Low = $Sheet->Evaluate("MIN(D:D)");
+ $Close = $Bars[$#Bars][4];
+
+The with() function partially mimics the Visual Basic With statement,
+but allows only property assignments. It's a convenient shortcut for
+this:
+
+ { # open new scope
+ my $Axis = $Chart->Axes(xlValue);
+ $Axis->{HasMajorGridlines} = 1;
+ $Axis->{HasMinorGridlines} = 1;
+ # etc ...
+ }
+
+The C<$High> and C<$Low> for the day are needed to determine the
+minimum and maximum scaling levels. MIN and MAX are spreadsheet
+functions, and aren't automatically available as methods. However,
+Excel provides an Evaluate() method to calculate arbitrary spreadsheet
+functions, so we can use that.
+
+We want the chart to show major gridlines at every fourth tick and
+minor gridlines at every second tick. The minimum and maximum are
+chosen to be whatever multiples of 1/16 we need to do that.
+
+ # Change tickmark spacing from decimal to fractional
+ with($Chart->Axes(xlValue),
+ HasMajorGridlines => 1,
+ HasMinorGridlines => 1,
+ MajorUnit => 1/8,
+ MinorUnit => 1/16,
+ MinimumScale => int($Low*16)/16,
+ MaximumScale => int($High*16+1)/16
+ );
+
+ # Fat candles with only 5% gaps
+ $Chart->ChartGroups(1)->{GapWidth} = 5;
+
+ sub RGB { $_[0] | ($_[1] >> 8) | ($_[2] >> 16) }
+
+ # White background with a solid border
+
+ $Chart->PlotArea->Border->{LineStyle} = xlContinuous;
+ $Chart->PlotArea->Border->{Color} = RGB(0,0,0);
+ $Chart->PlotArea->Interior->{Color} = RGB(255,255,255);
+
+ # Add 1 hour moving average of the Close series
+ my $MovAvg = $Chart->SeriesCollection(4)->Trendlines
+ ->Add({Type => xlMovingAvg, Period => 4});
+ $MovAvg->Border->{Color} = RGB(255,0,0);
+
+Now the finished workbook can be saved to disk as
+F<i:\tmp\tpj\data.xls>. That file most likely still exists from when the
+program ran yesterday, so we'll remove it. (Otherwise, Excel would pop
+up a dialog with a warning, because the SaveAs() method doesn't like
+to overwrite files.)
+
+
+ # Save workbook to file my $Filename = 'i:\tmp\tpj\data.xls';
+ unlink $Filename if -f $Filename;
+ $Book->SaveAs($Filename);
+ $Book->Close;
+
+=head2 ACTIVEX DATA OBJECTS
+
+Mary stores the daily prices in her T-bonds database, keeping the data
+for the different contracts in separate tables. After creating an ADO
+(ActiveX Data Object) connection to the database, she tries to connect
+a record set to the table for the current contract. If this fails, she
+assumes that the table doesn't exists yet and tries to create it:
+
+ use Win32::OLE::Const 'Microsoft ActiveX Data Objects';
+
+ my $Connection = Win32::OLE->new('ADODB.Connection');
+ my $Recordset = Win32::OLE->new('ADODB.Recordset');
+ $Connection->Open('T-Bonds');
+
+ # Open a record set for the table of this contract
+ {
+ local $Win32::OLE::Warn = 0;
+ $Recordset->Open($Contract, $Connection, adOpenKeyset,
+ adLockOptimistic, adCmdTable);
+ }
+
+ # Create table and index if it doesn't exist yet
+ if (Win32::OLE->LastError) {
+ $Connection->Execute(<<"SQL");
+ CREATE TABLE $Contract
+ (
+ Day DATETIME,
+ Open DOUBLE, High DOUBLE, Low DOUBLE, Close DOUBLE
+ )
+ SQL
+ $Connection->Execute(<<"SQL");
+ CREATE INDEX $Contract
+ ON $Contract (Day) WITH PRIMARY
+ SQL
+ $Recordset->Open($Contract, $Connection, adOpenKeyset,
+ adLockOptimistic, adCmdTable);
+ }
+
+C<$Win32::OLE::Warn> is temporarily set to zero, so that if
+C<$Recordset->Open> fails, the failure will be recorded silently without
+terminating the program. C<Win32::OLE->LastError> shows whether the Open
+failed or not. C<LastError> returns the OLE error code in a numeric
+context and the OLE error message in a string context, just like
+Perl's C<$!> variable.
+
+Now Mary can add today's data:
+
+ # Add new record to table
+ use Win32::OLE::Variant;
+ $Win32::OLE::Variant::LCID = $Win32::OLE::LCID;
+
+ my $Fields = [qw(Day Open High Low Close)];
+ my $Values = [Variant(VT_DATE, $Day),
+ $Open, $High, $Low, $Close];
+
+Mary uses the Win32::OLE::Variant module to store C<$Day> as a date
+instead of a mere string. She wants to make sure that it's stored as
+an American-style date, so in the third line shown here she sets the
+locale ID of the Win32::OLE::Variant module to match the Win32::OLE
+module. (C<$Win32::OLE::LCID> had been set earlier to English, since
+that's what the Chicago Board of Trade uses.)
+
+ {
+ local $Win32::OLE::Warn = 0;
+ $Recordset->AddNew($Fields, $Values);
+ }
+
+ # Replace existing record
+ if (Win32::OLE->LastError) {
+ $Recordset->CancelUpdate;
+ $Recordset->Close;
+ $Recordset->Open(<<"SQL", $Connection, adOpenDynamic);
+ SELECT * FROM $Contract
+ WHERE Day = #$Day#
+ SQL
+ $Recordset->Update($Fields, $Values);
+ }
+
+ $Recordset->Close;
+ $Connection->Close;
+
+The program expects to be able to add a new record to the table. It
+fails if a record for this date already exists, because the Day field
+is the primary index and therefore must be unique. If an error occurs,
+the update operation started by AddNew() must first be cancelled with
+C<< $Recordset->CancelUpdate >>; otherwise the record set won't close.
+
+=head2 LOTUS NOTES
+
+Now Mary can use Lotus Notes to mail updates to all her customers
+interested in the T-bond data. (Lotus Notes doesn't provide its
+constants in the OLE type library, so Mary had to determine them by
+playing around with LotusScript.) The actual task is quite simple: A
+Notes session must be started, the mail database must be opened and
+the mail message must be created. The body of the message is created
+as a rich text field, which lets her mix formatted text with object
+attachments.
+
+In her program, Mary extracts the email addresses from her customer
+database and sends separate message to each. Here, we've simplified it
+somewhat.
+
+ sub EMBED_ATTACHMENT {1454;} # from LotusScript
+
+ my $Notes = Win32::OLE->new('Notes.NotesSession');
+ my $Database = $Notes->GetDatabase('', '');
+ $Database->OpenMail;
+ my $Document = $Database->CreateDocument;
+
+ $Document->{Form} = 'Memo';
+ $Document->{SendTo} = ['Jon Orwant >orwant@tpj.com>',
+ 'Jan Dubois >jan.dubois@ibm.net>'];
+ $Document->{Subject} = "US T-Bonds Chart for $Day";
+
+ my $Body = $Document->CreateRichtextItem('Body');
+ $Body->AppendText(<<"EOT");
+ I\'ve attached the latest US T-Bond data and chart for $Day.
+ The daily statistics were:
+
+ \tOpen\t$Open
+ \tHigh\t$High
+ \tLow\t$Low
+ \tClose\t$Close
+
+ Kind regards,
+
+ Mary
+ EOT
+
+ $Body->EmbedObject(EMBED_ATTACHMENT, '', $Filename);
+
+ $Document->Send(0);
+
+=head1 VARIANTS
+
+In this final section, I'll talk about Variants, which are the data
+types that you use to talk to OLE objects. We talked about this line
+earlier:
+
+ my $Values = [Variant(VT_DATE, $Day),
+ $Open, $High, $Low, $Close];
+
+Here, the Variant() function creates a Variant object, of type C<VT_DATE>
+and with the value C<$Day>. Variants are similar in many ways to Perl
+scalars. Arguments to OLE methods are transparently converted from
+their internal Perl representation to Variants and back again by the
+Win32::OLE module.
+
+OLE automation uses a generic C<VARIANT> data type to pass
+parameters. This data type contains type information in addition to
+the actual data value. Only the following data types are valid for OLE
+automation:
+
+ B<Data Type Meaning>
+ VT_EMPTY Not specified
+ VT_NULL Null
+ VT_I2 2 byte signed integer
+ VT_I4 4 byte signed integer
+ VT_R4 4 byte real
+ VT_R8 8 byte real
+ VT_CY Currency
+ VT_DATE Date
+ VT_BSTR Unicode string
+ VT_DISPATCH OLE automation interface
+ VT_ERROR Error
+ VT_BOOL Boolean
+ VT_VARIANT (only valid with VT_BYREF)
+ VT_UNKNOWN Generic COM interface
+ VT_UI1 Unsigned character
+
+The following two flags can also be used:
+
+ VT_ARRAY Array of values
+ VT_BYREF Pass by reference (instead of by value)
+
+B<The Perl to Variant transformation.> The following conversions are
+performed automatically whenever a Perl value must be translated into
+a Variant:
+
+ Perl value Variant
+ Integer values VT_I4
+ Real values VT_R8
+ Strings VT_BSTR
+ undef VT_ERROR (DISP_E_PARAMNOTFOUND)
+ Array reference VT_VARIANT | VT_ARRAY
+ Win32::OLE object VT_DISPATCH
+ Win32::OLE::Variant object Type of the Variant object
+
+What if your Perl value is a list of lists? Those can be irregularly
+shaped in Perl; that is, the subsidiary lists needn't have the same
+number of elements. In this case, the structure will be converted to a
+"rectangular" C<SAFEARRAY> of Variants, with unused slots set to
+C<VT_EMPTY>. Consider this Perl 2-D array:
+
+ [ ["Perl" ], # one element
+ [1, 3.1215, undef] # three elements
+ ]
+
+This will be translated to a 2 by 3 C<SAFEARRAY> that looks like this:
+
+ VT_BSTR("Perl") VT_EMPTY VT_EMPTY
+ VT_I4(1) VT_R8(3.1415) VT_ERROR(DISP_E_PARAMNOTFOUND)
+
+B<The Variant To Perl Transformation.> Automatic conversion from Variants
+to Perl values happens as follows:
+
+ Variant Perl value
+ VT_BOOL, VT_ERROR Integer
+ VT_UI1, VT_I2, VT_I4 Integer
+ VT_R4, VT_R8 Float value
+ VT_BSTR String
+ VT_DISPATCH Win32::OLE object
+
+B<The Win32::OLE::Variant module.> This module provides access to the
+Variant data type, which gives you more control over how these
+arguments to OLE methods are encoded. (This is rarely necessary if you
+have a good grasp of the default conversion rules.) A Variant object
+can be created with the C<< Win32::OLE::Variant->new >> method or the
+equivalent Variant() function:
+
+ use Win32::OLE::Variant;
+ my $var1 = Win32::OLE::Variant->new(VT_DATE, 'Jan 1,1970');
+ my $var2 = Variant(VT_BSTR, 'This is an Unicode string');
+
+Several methods let you inspect and manipulate Variant objects: The
+Type() and Value() methods return the variant type and value; the As()
+method returns the value after converting it to a different variant
+type; ChangeType() coerces the Variant into a different type; and
+Unicode() returns the value of a Variant object as an object of the
+Unicode::String class.
+
+These conversions are more interesting if they can be applied directly
+to the return value of an OLE method call without first mutilating the
+value with default conversions. This is possible with the following
+trick:
+
+ my $RetVal = Variant(VT_EMPTY, undef);
+ $Object->Dispatch($Method, $RetVal, @Arguments);
+
+Normally, you wouldn't call Dispatch() directly; it's executed
+implicitly by either AUTOLOAD() or Invoke(). If Dispatch() realizes
+that the return value is already a Win32::OLE::Variant object, the
+return value is not translated into a Perl representation but rather
+copied verbatim into the Variant object.
+
+Whenever a Win32::OLE::Variant object is used in a numeric or string
+context it is automatically converted into the corresponding format.
+
+ printf "Number: %f and String: %s\n",
+ $Var, $Var;
+
+This is equivalent to:
+
+ printf "Number: %f and String: %s\n",
+ $Var->As(VT_R8), $Var->As(VT_BSTR);
+
+For methods that modify their arguments, you need to use the C<VT_BYREF>
+flag. This lets you create number and string Variants that can be
+modified by OLE methods. Here, Corel's GetSize() method takes two
+integers and stores the C<x> and C<y> dimensions in them:
+
+ my $x = Variant( VT_I4 | VT_BYREF, 0);
+ my $y = Variant( VT_I4 | VT_BYREF, 0);
+ $Corel->GetSize($x, $y);
+
+C<VT_BYREF> support for other Variant types might appear in future
+releases of Win32::OLE.
+
+=head1 FURTHER INFORMATION
+
+=head2 DOCUMENTATION AND EXAMPLE CODE
+
+More information about the OLE modules can be found in the
+documentation bundled with Win32::OLE. The distribution also contains
+other code samples.
+
+The object model for Microsoft Office applications can be found in the
+Visual Basic Reference for Microsoft Access, Excel, Word, or
+PowerPoint. These help files are not installed by default, but they
+can be added later by rerunning F<setup.exe> and choosing I<custom
+setup>. The object model for Microsoft Outlook can be found on the
+Microsoft Office Developer Forum at:
+http://www.microsoft.com/OutlookDev/.
+
+Information about the LotusScript object model can be found at:
+http://www.lotus.com/products/lotusscript.nsf.
+
+=head2 OLE AUTOMATION ON OTHER PLATFORMS
+
+Microsoft also makes OLE technology available for the Mac. DCOM is
+already included in Windows NT 4.0 and can be downloaded for Windows
+95. MVS and some Unix systems can use EntireX to get OLE
+functionality; see
+http://www.softwareag.com/corporat/solutions/entirex/entirex.htm.
+
+=head1 COPYRIGHT
+
+Copyright 1998 I<The Perl Journal>. http://www.tpj.com
+
+This article originally appeared in I<The Perl Journal> #10. It
+appears courtesy of Jon Orwant and I<The Perl Journal>. This document
+may be distributed under the same terms as Perl itself.
diff --git a/Master/tlpkg/tlperl/lib/Win32/Process/Info.pm b/Master/tlpkg/tlperl/lib/Win32/Process/Info.pm
deleted file mode 100644
index a9d9c8c91f5..00000000000
--- a/Master/tlpkg/tlperl/lib/Win32/Process/Info.pm
+++ /dev/null
@@ -1,1005 +0,0 @@
-=head1 NAME
-
-Win32::Process::Info - Provide process information for Windows 32 systems.
-
-=head1 SYNOPSIS
-
- use Win32::Process::Info;
- $pi = Win32::Process::Info->new ();
- $pi->Set (elapsed_in_seconds => 0); # In clunks, not seconds.
- @pids = $pi->ListPids (); # Get all known PIDs
- @info = $pi->GetProcInfo (); # Get the max
- %subs = $pi->Subprocesses (); # Figure out subprocess relationships.
- @info = grep {
- defined $_->{Name} &&
- $_->{Name} =~ m/perl/
- } $pi->GetProcInfo (); # All processes with 'perl' in name.
-
-=head1 NOTICE
-
-This package covers a multitude of sins - as many as Microsoft has
-invented ways to get process info and I have resources and gumption
-to code. The key to this mess is the 'variant' argument to the 'new'
-method (q.v.).
-
-The WMI variant has various problems, known or suspected to be inherited
-from Win32::OLE. See L</BUGS> for the gory details. The worst of these
-is that if you use fork(), you B<must> disallow WMI completely by
-loading this module as follows:
-
- use Win32::Process::Info qw{NT};
-
-This method of controlling things must be considered experimental until
-I can confirm it causes no unexpected insurmountable problems. If I am
-forced to change it, the change will be flagged prominently in the
-documentation.
-
-This change is somewhat incompatible with 1.006 and earlier because it
-requires the import() method to be called in the correct place with the
-correct arguments. If you C<require Win32::Process::Info>, you B<must>
-explicitly call Win32::Process::Info->import().
-
-See the import() documentation below for the details.
-
-B<YOU HAVE BEEN WARNED!>
-
-=head1 DESCRIPTION
-
-The main purpose of the Win32::Process::Info package is to get whatever
-information is convenient (for the author!) about one or more Windows
-32 processes. L</GetProcInfo> is therefore the most-important
-method in the package. See it for more information.
-
-The process IDs made available are those returned by the variant in
-use. See the documentation to the individual variants for details,
-especially if you are a Cygwin user.
-
-Unless explicitly stated otherwise, modules, variables, and so
-on are considered private. That is, the author reserves the right
-to make arbitrary changes in the way they work, without telling
-anyone. For methods, variables, and so on which are considered
-public, the author will make an effort keep them stable, and failing
-that to call attention to changes.
-
-The following methods should be considered public:
-
-=over 4
-
-=cut
-
-package Win32::Process::Info;
-
-use 5.006;
-
-use strict;
-use warnings;
-
-our $VERSION = '1.020';
-
-use Carp;
-use File::Spec;
-use Time::Local;
-
-our %static = (
- elapsed_in_seconds => 1,
- variant => $ENV{PERL_WIN32_PROCESS_INFO_VARIANT},
- );
-
-# The real reason for the %variant_support hash is to deal with
-# the apparant inability of Win32::API to be 'require'-d anywhere
-# but in a BEGIN block. The 'unsupported' key is intended to be
-# used as a 'necessary but not required' criterion; that is, if
-# 'unsupported' is true, there's no reason to bother; but if it's
-# false, there may still be problems of some sort. This is par-
-# ticularly true of WMI, where the full check is rather elephan-
-# tine.
-#
-# The actual 'necessary but not required' check has moved to
-# {check_support}, with {unsupported} simply holding the result of
-# the check. The {check_support} key is code to be executed when
-# the import() hook is called when the module is loaded.
-#
-# While I was at it, I decided to consolidate all the variant-
-# specific information in one spot and, while I was at it, write
-# a variant checker utility.
-
-my %variant_support;
-BEGIN {
- # Cygwin has its own idea of what a process ID is, independent of
- # the underlying operating system. The Cygwin Perl implements this,
- # so if we're Cygwin we need to compensate. This MUST return the
- # Windows-native form under Cygwin, which means any variant which
- # needs another form must override.
-
- if ( $^O eq 'cygwin' ) {
- *My_Pid = sub {
- return Cygwin::pid_to_winpid( $$ );
- };
- } else {
- *My_Pid = sub {
- return $$;
- };
- }
- %variant_support = (
- NT => {
- check_support => sub {
- local $@;
- eval {
- require Win32;
- Win32->can( 'IsWinNT' ) && Win32::IsWinNT();
- } or return "$^O is not a member of the Windows NT family";
- eval { require Win32::API; 1 }
- or return 'I can not find Win32::API';
- my @path = File::Spec->path();
-DLL_LOOP:
- foreach my $dll (qw{PSAPI.DLL ADVAPI32.DLL KERNEL32.DLL}) {
- foreach my $loc (@path) {
- next DLL_LOOP if -e File::Spec->catfile ($loc, $dll);
- }
- return "I can not find $dll";
- }
- return 0;
- },
- make => sub {
- require Win32::Process::Info::NT;
- Win32::Process::Info::NT->new (@_);
- },
- unsupported => "Disallowed on load of @{[__PACKAGE__]}.",
- },
- PT => {
- check_support => sub {
- local $@;
- return "Unable to load Proc::ProcessTable"
- unless eval {require Proc::ProcessTable; 1};
- return 0;
- },
- make => sub {
- require Win32::Process::Info::PT;
- Win32::Process::Info::PT->new (@_);
- },
- unsupported => "Disallowed on load of @{[__PACKAGE__]}.",
- },
- WMI => {
- check_support => sub {
- local $@;
- _isReactOS()
- and return 'Unsupported under ReactOS';
- eval {
- require Win32::OLE;
- 1;
- } or return 'Unable to load Win32::OLE';
- my ( $wmi, $proc );
- my $old_warn = Win32::OLE->Option( 'Warn' );
- eval {
- Win32::OLE->Option( Warn => 0 );
- $wmi = Win32::OLE->GetObject(
- 'winmgmts:{impersonationLevel=impersonate,(Debug)}!//./root/cimv2'
- );
- $wmi and $proc = $wmi->Get(
- sprintf q{Win32_Process='%s'}, __PACKAGE__->My_Pid()
- );
- };
- Win32::OLE->Option( Warn => $old_warn );
- $wmi or return 'Unable to get WMI object';
- $proc or return 'WMI broken: unable to get process object';
- return 0;
- },
- make => sub {
- require Win32::Process::Info::WMI;
- Win32::Process::Info::WMI->new (@_);
- },
- unsupported => "Disallowed on load of @{[__PACKAGE__]}.",
- },
- );
-}
-
-our %mutator = (
- elapsed_in_seconds => sub {$_[2]},
- variant => sub {
- ref $_[0]
- and eval { $_[0]->isa( 'Win32::Process::Info' ) }
- or croak 'Variant can not be set on an instance';
- foreach (split '\W+', $_[2]) {
- my $status;
- $status = variant_support_status( $_ )
- and croak "Variant '$_' unsupported on your configuration; ",
- $status;
- }
- $_[2]
- },
-);
-
-
-=item $pi = Win32::Process::Info->new ([machine], [variant], [hash])
-
-This method instantiates a process information object, connected
-to the given machine, and using the given variant.
-
-The following variants are currently supported:
-
-NT - Uses the NT-native mechanism. Good on any NT, including
-Windows 2000. This variant does not support connecting to
-another machine, so the 'machine' argument must be an
-empty string (or undef, if you prefer).
-
-PT - Uses Dan Urist's Proc::ProcessTable, making it possible
-(paradoxically) to use this module on other operating systems than
-Windows. Only those Proc::ProcessTable::Process fields which seem
-to correspond to WMI items are returned. B<Caveat:> the PT variant
-is to be considered experimental, and may be changed or retracted
-in future releases.
-
-WMI - Uses the Windows Management Implementation. Good on Win2K, ME,
-and possibly others, depending on their vintage and whether
-WMI has been retrofitted.
-
-The initial default variant comes from environment variable
-PERL_WIN32_PROCESS_INFO_VARIANT. If this is not found, it will be
-'WMI,NT,PT', which means to try WMI first, NT if WMI fails, and PT as a
-last resort. This can be changed using Win32::Process::Info->Set
-(variant => whatever).
-
-The hash argument is a hash reference to additional arguments, if
-any. The hash reference can actually appear anywhere in the argument
-list, though positional arguments are illegal after the hash reference.
-
-The following hash keys are supported:
-
- variant => corresponds to the 'variant' argument (all)
- assert_debug_priv => assert debug if available (all) This
- only has effect under WMI. The NT variant always
- asserts debug. You want to be careful doing this
- under WMI if you're fetching the process owner
- information, since the script can be badly behaved
- (i.e. die horribly) for those processes whose
- ExecutablePath is only available with the debug
- privilege turned on.
- host => corresponds to the 'machine' argument (WMI)
- user => username to perform operation under (WMI)
- password => password corresponding to the given
- username (WMI)
-
-ALL hash keys are optional. SOME hash keys are only supported under
-certain variants. These are indicated in parentheses after the
-description of the key. It is an error to specify a key that the
-variant in use does not support.
-
-=cut
-
-my @argnam = qw{host variant};
-sub new {
- my ($class, @params) = @_;
- $class = ref $class if ref $class;
- my %arg;
- my ( $self, @probs );
-
- my $inx = 0;
- foreach my $inp (@params) {
- if (ref $inp eq 'HASH') {
- foreach my $key (keys %$inp) {$arg{$key} = $inp->{$key}}
- } elsif (ref $inp) {
- croak "Argument may not be @{[ref $inp]} reference.";
- } elsif ($argnam[$inx]) {
- $arg{$argnam[$inx]} = $inp;
- } else {
- croak "Too many positional arguments.";
- }
- $inx++;
- }
-
- _import_done()
- or croak __PACKAGE__,
- '->import() must be called before calling ', __PACKAGE__,
- '->new()';
- my $mach = $arg{host} or delete $arg{host};
- my $try = $arg{variant} || $static{variant} || 'WMI,NT,PT';
- foreach my $variant (grep {$_} split '\W+', $try) {
- my $status;
- $status = variant_support_status( $variant ) and do {
- push @probs, $status;
- next;
- };
- my $self;
- $self = $variant_support{$variant}{make}->( \%arg ) and do {
- $static{variant} ||= $self->{variant} = $variant;
- };
- return $self;
- }
- croak join '; ', @probs;
-}
-
-=item @values = $pi->Get (attributes ...)
-
-This method returns the values of the listed attributes. If
-called in scalar context, it returns the value of the first
-attribute specified, or undef if none was. An exception is
-raised if you specify a non-existent attribute.
-
-This method can also be called as a class method (that is, as
-Win32::Process::Info->Get ()) to return default attributes values.
-
-The relevant attribute names are:
-
-B<elapsed_as_seconds> is TRUE to convert elapsed user and
-kernel times to seconds. If FALSE, they are returned in
-clunks (that is, hundreds of nanoseconds). The default is
-TRUE.
-
-B<variant> is the variant of the Process::Info code in use,
-and should be zero or more of 'WMI' or 'NT', separated by
-commas. 'WMI' selects the Windows Management Implementation, and
-'NT' selects the Windows NT native interface.
-
-B<machine> is the name of the machine connected to. This is
-not available as a class attribute.
-
-=cut
-
-sub Get {
-my ($self, @args) = @_;
-$self = \%static unless ref $self;
-my @vals;
-foreach my $name (@args) {
- croak "Error - Attribute '$name' does not exist."
- unless exists $self->{$name};
- croak "Error - Attribute '$name' is private."
- if $name =~ m/^_/;
- push @vals, $self->{$name};
- }
-return wantarray ? @vals : $vals[0];
-}
-
-=item @values = $pi->Set (attribute => value ...)
-
-This method sets the values of the listed attributes,
-returning the values of all attributes listed if called in
-list context, or of the first attribute listed if called
-in scalar context.
-
-This method can also be called as a class method (that is, as
-Win32::Process::Info->Set ()) to change default attribute values.
-
-The relevant attribute names are the same as for Get.
-However:
-
-B<variant> is read-only at the instance level. That is,
-Win32::Process::Info->Set (variant => 'NT') is OK, but
-$pi->Set (variant => 'NT') will raise an exception. If
-you set B<variant> to an empty string (the default), the
-next "new" will iterate over all possibilities (or the
-contents of environment variable
-PERL_WIN32_PROCESS_INFO_VARIANT if present), and set
-B<variant> to the first one that actually works.
-
-B<machine> is not available as a class attribute, and is
-read-only as an instance attribute. It is B<not> useful for
-discovering your machine name - if you instantiated the
-object without specifying a machine name, you will get
-nothing useful back.
-
-=cut
-
-sub Set {
-my ($self, @args) = @_;
-croak "Error - Set requires an even number of arguments."
- if @args % 2;
-$self = \%static unless ref $self;
-my $mutr = $self->{_mutator} || \%mutator;
-my @vals;
-while (@args) {
- my $name = shift @args;
- my $val = shift @args;
- croak "Error - Attribute '$name' does not exist."
- unless exists $self->{$name};
- croak "Error - Attribute '$name' is read-only."
- unless exists $mutr->{$name};
- $self->{$name} = $mutr->{$name}->($self, $name, $val);
- push @vals, $self->{$name};
- }
-return wantarray ? @vals : $vals[0];
-}
-
-=item @pids = $pi->ListPids ();
-
-This method lists all known process IDs in the system. If
-called in scalar context, it returns a reference to the
-list of PIDs. If you pass in a list of pids, the return will
-be the intersection of the argument list and the actual PIDs
-in the system.
-
-=cut
-
-sub ListPids {
- confess
- "Error - Whoever coded this forgot to override ListPids.";
-}
-
-=item @info = $pi->GetProcInfo ();
-
-This method returns a list of anonymous hashes, each containing
-information on one process. If no arguments are passed, the
-list represents all processes in the system. You can pass a
-list of process IDs, and get out a list of the attributes of
-all such processes that actually exist. If you call this
-method in scalar context, you get a reference to the list.
-
-What keys are available depends on the variant in use.
-You can hope to get at least the following keys for a
-"normal" process (i.e. not the idle process, which is PID 0,
-nor the system, which is some small indeterminate PID) to
-which you have access:
-
- CreationDate
- ExecutablePath
- KernelModeTime
- MaximumWorkingSetSize
- MinimumWorkingSetSize
- Name (generally the name of the executable file)
- ProcessId
- UserModeTime
-
-You may find other keys available as well, depending on which
-operating system you're using, and which variant of Process::Info
-you're using.
-
-This method also optionally takes as its first argument a reference
-to a hash of option values. The only supported key is:
-
- no_user_info => 1
- Do not return keys Owner and OwnerSid, even if available.
- These tend to be time-consuming, and can cause problems
- under the WMI variant.
-
-=cut
-
-sub GetProcInfo {
- confess
- "Programming Error - Whoever coded this forgot to override GetProcInfo.";
-}
-
-=item Win32::Process::Info->import ()
-
-The purpose of this static method is to specify which variants of the
-functionality are legal to use. Possible arguments are 'NT', 'WMI',
-'PT', or some combination of these (e.g. ('NT', 'WMI')). Unrecognized
-arguments are ignored, though this may change if this class becomes a
-subclass of Exporter. If called with no arguments, it is as though it
-were called with arguments ('NT', 'WMI', 'PT'). See L</BUGS>, below, for
-why this mess was introduced in the first place.
-
-This method must be called at least once, B<in a BEGIN block>, or B<no>
-variants will be legal to use. Usually it does B<not> need to be
-explicitly called by the user, since it is called implicitly when you
-C<use Win32::Process::Info;>. If you C<require Win32::Process::Info;>
-you B<will> have to call this method explicitly.
-
-If this method is called more than once, the second and subsequent calls
-will have no effect on what variants are available. The reason for this
-will be made clear (I hope!) under L</USE IN OTHER MODULES>, below.
-
-The only time a user of this module needs to do anything different
-versus version 1.006 and previous of this module is if this module is
-being loaded in such a way that this method is not implicitly called.
-This can happen two ways:
-
- use Win32::Process::Info ();
-
-explicitly bypasses the implicit call of this method. Don't do that.
-
- require Win32::Process::Info;
-
-also does not call this method. If you must load this module using
-require rather than use, follow the require with
-
- Win32::Process::Info->import ();
-
-passing any necessary arguments.
-
-=cut
-
-{ # Begin local symbol block.
-
- my $idempotent;
-
- sub import { ## no critic (RequireArgUnpacking)
- my ($pkg, @params) = @_;
- my (@args, @vars);
- foreach (@params) {
- if (exists $variant_support{$_}) {
- push @vars, $_;
- } else {
- push @args, $_;
- }
- }
-
- if ($idempotent++) {
- # Warning here maybe?
- } else {
- @vars or push @vars, keys %variant_support;
- foreach my $try (@vars) {
- $variant_support{$try} or next;
- $variant_support{$try}{unsupported} = eval {
- $variant_support{$try}{check_support}->()} || $@;
- }
- }
-
- return;
-
-# Do this if we become a subclass of Exporter
-# @_ = ( $pkg, @args );
-# goto &Exporter::import;;
- }
-
- # Return the number of times import() done.
- sub _import_done {
- return $idempotent;
- }
-
-} # End local symbol block.
-
-
-{
- my $is_reactos = $^O eq 'MSWin32' &&
- defined $ENV{OS} && lc $ENV{OS} eq 'reactos';
- sub _isReactOS {
- return $is_reactos;
- }
-}
-
-
-=item %subs = $pi->Subprocesses ([pid ...])
-
-This method takes as its argument a list of PIDs, and returns a hash
-indexed by PID and containing, for each PID, a reference to a list of
-all subprocesses of that process. If those processes have subprocesses
-as well, you will get the sub-sub processes, and so ad infinitum, so
-you may well get back more hash keys than you passed process IDs. Note
-that the process of finding the sub-sub processes is iterative, not
-recursive; so you don't get back a tree.
-
-If no argument is passed, you get all processes in the system.
-
-If called in scalar context you get a reference to the hash.
-
-This method works off the ParentProcessId attribute. Not all variants
-support this. If the variant you're using doesn't support this
-attribute, you get back an empty hash. Specifically:
-
- NT -> unsupported
- PT -> supported
- WMI -> supported
-
-=cut
-
-sub Subprocesses {
-my ($self, @args) = @_;
-my %prox = map {($_->{ProcessId} => $_)}
- @{$self->GetProcInfo ({no_user_info => 1})};
-my %subs;
-my $rslt = \%subs;
-my $key_found;
-foreach my $proc (values %prox) {
- $subs{$proc->{ProcessId}} ||= [];
- # TRW 1.011_01 next unless $proc->{ParentProcessId};
- defined (my $pop = $proc->{ParentProcessId}) or next; # TRW 1.011_01
- $key_found++;
- # TRW 1.011_01 next unless $prox{$proc->{ParentProcessId}};
- $prox{$pop} or next; # TRW 1.011_01
-# TRW 1.012_02 $proc->{CreationDate} >= $prox{$pop}{CreationDate} or next; # TRW 1.011_01
- (defined($proc->{CreationDate}) &&
- defined($prox{$pop}{CreationDate}) &&
- $proc->{CreationDate} >= $prox{$pop}{CreationDate})
- or next; # TRW 1.012_02
- # TRW 1.011_01 push @{$subs{$proc->{ParentProcessId}}}, $proc->{ProcessId};
- push @{$subs{$pop}}, $proc->{ProcessId};
- }
-my %listed;
-return %listed unless $key_found;
-if (@args) {
- $rslt = \%listed;
- while (@args) {
- my $pid = shift @args;
- next unless $subs{$pid}; # TRW 1.006
- next if $listed{$pid};
- $listed{$pid} = $subs{$pid};
- push @args, @{$subs{$pid}};
- }
- }
-return wantarray ? %$rslt : $rslt;
-}
-
-=item @info = $pi->SubProcInfo ();
-
-This is a convenience method which wraps GetProcInfo(). It has the same
-calling sequence, and returns generally the same data. But the data
-returned by this method will also have the {subProcesses} key, which
-will contain a reference to an array of hash references representing the
-data on subprocesses of each process.
-
-Unlike the data returned from Subprocesses(), the data here are not
-flattened; so if you specify one or more process IDs as arguments, you
-will get back at most the number of process IDs you specified; fewer if
-some of the specified processes do not exist.
-
-B<Note well> that a given process can occur more than once in the
-output. If you call SubProcInfo without arguments, the @info array will
-contain every process in the system, even those which are also in some
-other process' {subProcesses} array.
-
-Also unlike Subprocesses(), you will get an exception if you use this
-method with a variant that does not support the ParentProcessId key.
-
-=cut
-
-sub SubProcInfo {
- my ($self, @args) = @_;
- my $opt = ref $args[0] eq 'HASH' ? shift @args : {};
- my @data = $self->GetProcInfo ($opt);
- my %subs = map {$_->{ProcessId} => $_} @data;
- my $bingo;
- foreach my $proc (@data) {
- exists $proc->{ParentProcessId} or next;
- $proc->{subProcesses} ||= [];
- $bingo++;
- defined (my $dad = $subs{$proc->{ParentProcessId}}) or next;
- (defined $dad->{CreationDate} && defined $proc->{CreationDate})
- or next;
- $dad->{CreationDate} > $proc->{CreationDate} and next;
- push @{$dad->{subProcesses} ||= []}, $proc;
- }
- $bingo or croak "Error - Variant '@{[$self->Get('variant')
- ]}' does not support the ParentProcessId key";
- if (@args) {
- return (map {exists $subs{$_} ? $subs{$_} : ()} @args);
- } else {
- return @data;
- }
-}
-
-=item $pid = $pi->My_Pid()
-
-This convenience method returns the process ID of the current process,
-in a form appropriate to the operating system and the variant in use.
-Normally, it simply returns C<$$>. But Cygwin has its own idea of what
-the process ID is, which may differ from Windows. Worse than that, under
-Cygwin the NT and WMI variants return Windows PIDs, while PT appears to
-return Cygwin PIDs.
-
-=cut
-
-# This is defined above, trickily, as an assignment to *My_Pid, so we
-# don't have to test $^O every time. It's above because code in a BEGIN
-# block needs it.
-
-=item $text = Win32::Process::Info->variant_support_status($variant);
-
-This static method returns the support status of the given variant. The
-return is false if the variant is supported, or an appropriate message
-if the variant is unsupported.
-
-This method can also be called as a normal method, or even as a
-subroutine.
-
-=cut
-
-sub variant_support_status {
- my @args = @_;
- my $variant = pop @args or croak "Variant not specified";
- exists $variant_support{$variant}
- or croak "Variant '$variant' is unknown";
- _import_done()
- or croak __PACKAGE__,
- '->import() must be called before calling ', __PACKAGE__,
- '->variant_support_status()';
- return $variant_support{$variant}{unsupported};
-}
-
-=item print "$pi Version = @{[$pi->Version ()]}\n"
-
-This method just returns the version number of the
-Win32::Process::Info object.
-
-=cut
-
-sub Version {
-return $Win32::Process::Info::VERSION;
-}
-
-#
-# $self->_build_hash ([hashref], key, value ...)
-# builds a process info hash out of the given keys and values.
-# The keys are assumed to be the WMI keys, and will be trans-
-# formed if needed. The values will also be transformed if
-# needed. The resulting hash entries will be placed into the
-# given hash if one is present, or into a new hash if not.
-# Either way, the hash is returned.
-
-sub _build_hash {
-my ($self, $hash, @args) = @_;
-$hash ||= {};
-while (@args) {
- my $key = shift @args;
- my $val = shift @args;
- $val = $self->{_xfrm}{$key}->($self, $val)
- if (exists $self->{_xfrm}{$key});
- $hash->{$key} = $val;
- }
-return $hash;
-}
-
-
-# $self->_clunks_to_desired (clunks ...)
-# converts elapsed times in clunks to elapsed times in
-# seconds, PROVIDED $self->{elapsed_in_seconds} is TRUE.
-# Otherwise it simply returns its arguments unmodified.
-
-sub _clunks_to_desired {
-my $self = shift;
-@_ = map {defined $_ ? $_ / 10_000_000 : undef} @_ if $self->{elapsed_in_seconds};
-return wantarray ? @_ : $_[0];
-}
-
-# $self->_date_to_time_t (date ...)
-# converts the input dates (assumed YYYYmmddhhMMss) to
-# Perl internal time, returning the results. The "self"
-# argument is unused.
-
-
-sub _date_to_time_t {
-my ($self, @args) = @_;
-my @result;
-local $^W = 0; # Prevent Time::Local 1.1 from complaining. This appears
- # to be fixed in 1.11, but since Time::Local is part of
- # the ActivePerl core, there's no PPM installer for it.
- # At least, not that I can find.
-foreach (@args) {
- if ($_) {
- my ($yr, $mo, $da, $hr, $mi, $sc) = m/^(\d{4})(\d{2})(\d{2})(\d{2})(\d{2})(\d{2})/;
- --$mo;
- my $val = timelocal ($sc, $mi, $hr, $da, $mo, $yr);
- push @result, $val;
- }
- else {
- push @result, undef;
- }
- }
-return @result if wantarray;
-return $result[0];
-}
-
-1;
-__END__
-
-=back
-
-=head1 USE IN OTHER MODULES
-
-Other modules that use this module are also subject to the effects of
-the collision between Win32::OLE and the emulated fork call, and to the
-requirements of the import() method. I will not address subclassing,
-since I am not sure how well this module subclasses (the variants are
-implemented as subclasses of this module).
-
-Modules that simply make use of this module (the 'has-a' relationship)
-should work as before, B<provided> they 'use Win32::Process::Info'. Note
-that the phrase 'as before' is literal, and means (among other things),
-that you can't use the emulated fork.
-
-If you as the author of a module that uses Win32::Process::Info wish to
-allow emulated forks, you have a number of options.
-
-The easiest way to go is
-
- use Win32::Process::Info qw{NT};
-
-if this provides enough information for your module.
-
-If you would prefer the extra information provided by WMI but can
-operate in a degraded mode if needed, you can do something like
-
- use Win32::Process::Info ();
-
- sub import {
- my $pkg = shift;
- $pkg->SUPER::import (@_); # Optional (see below)
- Win32::Process::Info->import (@_);
- }
-
-The call to $pkg->SUPER::import is needed only if your package is a
-subclass of Exporter.
-
-Note to users of modules that require this module:
-
-If the above 'rules' are violated, the symptoms will be either that you
-cannot instantiate an object (because there are no legal variants) or
-that you cannot use fork (because the WMI variant was enabled by
-default). The workaround for you is to
-
- use Win32::Process::Info;
-
-before you 'use' the problematic module. If the problem is coexistence
-with fork, you will of course need to
-
- use Win32::Process::Info qw{NT};
-
-This is why only the first import() sets the possible variants.
-
-=head1 ENVIRONMENT
-
-This package is sensitive to a number of environment variables.
-Note that these are normally consulted only when the package
-is initialized (i.e. when it's "used" or "required").
-
-PERL_WIN32_PROCESS_INFO_VARIANT
-
-If present, specifies which variant(s) are tried, in which
-order. The default behavior is equivalent to specifying
-'WMI,NT'. This environment variable is consulted when you
-"use Win32::Process::Info;". If you want to change it in
-your Perl code you should use the static Set () method.
-
-PERL_WIN32_PROCESS_INFO_WMI_DEBUG
-
-If present and containing a value Perl recognizes as true,
-causes the WMI variant to assert the "Debug" privilege.
-This has the advantage of returning more full paths, but
-the disadvantage of tending to cause Perl to die when
-trying to get the owner information on the newly-accessible
-processes.
-
-PERL_WIN32_PROCESS_INFO_WMI_PARIAH
-
-If present, should contain a semicolon-delimited list of process names
-for which the package should not attempt to get owner information. '*'
-is a special case meaning 'all'. You will probably need to use this if
-you assert PERL_WIN32_PROCESS_INFO_WMI_DEBUG.
-
-=head1 REQUIREMENTS
-
-It should be obvious that this library must run under some
-flavor of Windows.
-
-This library uses the following libraries:
-
- Carp
- Time::Local
- Proc::ProcessTable (if using the PT variant)
- Win32::API (if using the NT-native variant)
- Win32API::Registry (if using the NT-native variant)
- Win32::ODBC (if using the WMI variant)
-
-As of ActivePerl 630, none of this uses any packages that are not
-included with ActivePerl. Carp and Time::Local have been in the core
-since at least 5.004. Your mileage may, of course, vary.
-
-=head1 BUGS
-
-The WMI variant leaks memory - badly for 1.001 and earlier. After
-1.001 it only leaks badly if you retrieve the process owner
-information. If you're trying to write a daemon, the NT variant
-is recommended. If you're stuck with WMI, set the no_user_info flag
-when you call GetProcInfo. This won't stop the leaks, but it minimizes
-them, at the cost of not returning the username or SID.
-
-If you intend to use fork (), your script will die horribly unless you
-load this module as
-
- use Win32::Process::Info qw{NT};
-
-The problem is that fork() and Win32::OLE (used by the WMI variant) do
-not play B<at all> nicely together. This appears to be an acknowledged
-problem with Win32::OLE, which is brought on simply by loading the
-module. See import() above for the gory details.
-
-The use of the NT and WMI variants under non-Microsoft systems is
-unsupported. ReactOS 0.3.3 is known to lock up when GetProcInfo() is
-called; since this works on the Microsoft OSes, I am inclined to
-attribute this to the acknowledged alpha-ness of ReactOS. I have no idea
-what happens under Wine. B<Caveat user.>
-
-Bugs can be reported to the author by mail, or through
-L<http://rt.cpan.org>.
-
-=head1 RESTRICTIONS
-
-You can not C<require> this module except in a BEGIN block. This is a
-consequence of the use of Win32::API, which has the same restriction, at
-least in some versions.
-
-If you C<require> this module, you B<must> explicitly call C<<
-Win32::Process::Info->import() >>, so that the module will know what
-variants are available.
-
-If your code calls fork (), you must load this module as
-
- use Win32::Process::Info qw{NT};
-
-This renders the WMI variant unavailable. See L</BUGS>.
-
-=head1 RELATED MODULES
-
-Win32::Process::Info focuses on returning static data about a process.
-If this module doesn't do what you want, maybe one of the following
-ones will.
-
-=over 4
-
-=item Proc::ProcessTable by Dan Urist
-
-This module does not as of this writing support Windows, though there
-is a minimal Cygwin version that might serve as a starting point. The
-'PT' variant makes use of this module.
-
-=item Win32::PerfLib by Jutta M. Klebe
-
-This module focuses on performance counters. It is a ".xs" module,
-and requires Visual C++ 6.0 to install. But it's also part of LibWin32,
-and should come with ActivePerl.
-
-=item Win32::IProc by Amine Moulay Ramdane
-
-This module is no longer supported, which is a shame because it returns
-per-thread information as well. As of December 27, 2004, Jenda Krynicky
-(F<http://jenda.krynicky.cz/>) was hosting a PPM kit in PPM repository
-F<http://jenda.krynicky.cz/perl/>, which may be usable. But the source
-for the DLL files is missing, so if some Windows upgrade breaks it
-you're out of luck.
-
-=item Win32API::ProcessStatus, by Ferdinand Prantl
-
-This module focuses on the .exe and .dll files used by the process. It
-is a ".xs" module, requiring Visual C++ 6.0 and psapi.h to install.
-
-=item pulist
-
-This is not a Perl module, it's an executable that comes with the NT
-resource kit.
-
-=back
-
-=head1 ACKNOWLEDGMENTS
-
-This module would not exist without the following people:
-
-Aldo Calpini, who gave us Win32::API.
-
-Jenda Krynicky, whose "How2 create a PPM distribution"
-(F<http://jenda.krynicky.cz/perl/PPM.html>) gave me a leg up on
-both PPM and tar distributions.
-
-Dave Roth, F<http://www.roth.net/perl/>, author of
-B<Win32 Perl Programming: Administrators Handbook>, which is
-published by Macmillan Technical Publishing, ISBN 1-57870-215-1
-
-Dan Sugalski F<sugalskd@osshe.edu>, author of VMS::Process, where
-I got (for good or ill) the idea of just grabbing all the data
-I could find on a process and smashing it into a big hash.
-
-The folks of Cygwin (F<http://www.cygwin.com/>), especially Christopher
-G. Faylor, author of ps.cc.
-
-Judy Hawkins of Pitney Bowes, for providing testing and patches for
-NT 4.0 without WMI.
-
-=head1 AUTHOR
-
-Thomas R. Wyant, III (F<wyant at cpan dot org>)
-
-=head1 COPYRIGHT AND LICENSE
-
-Copyright (C) 2001-2005 by E. I. DuPont de Nemours and Company, Inc. All
-rights reserved.
-
-Copyright (C) 2007-2011, 2013 by Thomas R. Wyant, III
-
-This program is free software; you can redistribute it and/or modify it
-under the same terms as Perl 5.10.0. For more details, see the full text
-of the licenses in the directory LICENSES.
-
-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.
-
-=cut
-
-# ex: set textwidth=72 :
diff --git a/Master/tlpkg/tlperl/lib/Win32/Process/Info/NT.pm b/Master/tlpkg/tlperl/lib/Win32/Process/Info/NT.pm
deleted file mode 100644
index 26dd7ccba6e..00000000000
--- a/Master/tlpkg/tlperl/lib/Win32/Process/Info/NT.pm
+++ /dev/null
@@ -1,865 +0,0 @@
-=head1 NAME
-
-Win32::Process::Info::NT - Provide process information via NT-native calls.
-
-=head1 SYNOPSIS
-
-
-This package fetches process information on a given Windows
-machine, using Microsoft Windows NT's native process
-information calls.
-
- use Win32::Process::Info
- $pi = Win32::Process::Info->new (undef, 'NT');
- $pi->Set (elapsed_as_seconds => 0); # In clunks, not seconds.
- @pids = $pi->ListPids (); # Get all known PIDs
- @info = $pi->GetProcInfo (); # Get the max
-
-CAVEAT USER:
-
-This package does not support access to a remote machine,
-because the underlying API doesn't. If you specify a machine
-name (other than '', 0, or undef) when you instantiate a
-new Win32::Process::Info::NT object, you will get an exception.
-
-This package is B<not> intended to be used independently;
-instead, it is a subclass of Win32::Process::Info, and should
-only be called via that package.
-
-=head1 DESCRIPTION
-
-The main purpose of the Win32::Process::Info::NT package is to get whatever
-information is convenient (for the author!) about one or more Windows
-32 processes. GetProcInfo (which see) is therefore the most-important
-subroutine in the package. See it for more information.
-
-This package returns Windows process IDs, even under Cygwin.
-
-Unless explicitly stated otherwise, modules, variables, and so
-on are considered private. That is, the author reserves the right
-to make arbitrary changes in the way they work, without telling
-anyone. For subroutines, variables, and so on which are considered
-public, the author will make an effort keep them stable, and failing
-that to call attention to changes.
-
-Nothing is exported by default, though all the public subroutines are
-exportable, either by name or by using the :all tag.
-
-The following subroutines should be considered public:
-
-=over 4
-
-=cut
-
-
-package Win32::Process::Info::NT;
-
-use 5.006;
-
-use strict;
-use warnings;
-
-# The purpose of this is to provide a dummy Call
-# method for those cases where we might not be able
-# to map a subroutine.
-
-sub Win32::Process::Info::DummyRoutine::new {
-my $class = shift;
-$class = ref $class if ref $class;
-my $self = {};
-bless $self, $class;
-return $self;
-}
-
-sub Win32::Process::Info::DummyRoutine::Call {
-return undef; ## no critic (ProhibitExplicitReturnUndef)
-}
-
-use base qw{ Win32::Process::Info };
-
-our $VERSION = '1.020';
-
-our $AdjustTokenPrivileges;
-our $CloseHandle;
-our $elapsed_in_seconds;
-our $EnumProcesses;
-our $EnumProcessModules;
-our $FileTimeToSystemTime;
-our $GetCurrentProcess;
-our $GetModuleFileNameEx;
-our $GetPriorityClass;
-our $GetProcessAffinityMask;
-our $GetProcessIoCounters;
-our $GetProcessWorkingSetSize;
-our $GetProcessTimes;
-our $GetProcessVersion;
-our $GetTokenInformation;
-our $LookupAccountSid;
-our $LookupPrivilegeValue;
-our $OpenProcess;
-our $OpenProcessToken;
-
-our $GetSidIdentifierAuthority;
-our $GetSidSubAuthority;
-our $GetSidSubAuthorityCount;
-our $IsValidSid;
-
-use Carp;
-use File::Basename;
-use Win32;
-use Win32::API;
-
-use constant TokenUser => 1; # PER MSDN
-use constant TokenOwner => 4;
-
-my $setpriv;
-eval {
- require Win32API::Registry and
- $setpriv = sub {
- Win32API::Registry::AllowPriv (
- Win32API::Registry::SE_DEBUG_NAME (), 1)
- };
- };
-$setpriv ||= sub {};
-##0.013 use Win32API::Registry qw{:Func :SE_};
-
-
-my %_transform = (
- CreationDate => \&Win32::Process::Info::_date_to_time_t,
- KernelModeTime => \&Win32::Process::Info::_clunks_to_desired,
- UserModeTime => \&Win32::Process::Info::_clunks_to_desired,
- );
-
-sub _map {
-return Win32::API->new (@_) ||
- croak "Error - Failed to map $_[1] from $_[0]: $^E";
-}
-
-sub _map_opt {
-return Win32::API->new (@_) ||
- Win32::Process::Info::DummyRoutine->new ();
-}
-
-my %lglarg = map {($_, 1)} qw{assert_debug_priv variant};
-
-sub new {
-my $class = shift;
-$class = ref $class if ref $class;
-croak "Error - Win32::Process::Info::NT is unsupported under this flavor of Windows."
- unless Win32::IsWinNT ();
-my $arg = shift;
-if (ref $arg eq 'HASH') {
- my @ilg = grep {!$lglarg{$_}} keys %$arg;
- @ilg and
- croak "Error - Win32::Process::Info::NT argument(s) (@ilg) illegal";
- }
- else {
- croak "Error - Win32::Process::Info::NT does not support remote operation."
- if $arg;
- }
-my $self = {%Win32::Process::Info::static};
-delete $self->{variant};
-$self->{_xfrm} = \%_transform;
-bless $self, $class;
-# We want to fail silently, since that's probably better than nothing.
-##0.013 AllowPriv (SE_DEBUG_NAME, 1)
-$setpriv->() if $setpriv; ##0.013 ##1.005
-$setpriv = undef; ##1.005
-## or croak "Error - Failed to (try to) assert privilege @{[
-## SE_DEBUG_NAME]}; $^E"
- ;
-return $self;
-}
-
-
-=item @info = $pi->GetProcInfo ();
-
-This method returns a list of anonymous hashes, each containing
-information on one process. If no arguments are passed, the
-list represents all processes in the system. You can pass a
-list of process IDs, and get out a list of the attributes of
-all such processes that actually exist. If you call this
-method in scalar context, you get a reference to the list.
-
-What keys are available depend on the variant in use. With the NT
-variant you can hope to get at least the following keys for a "normal"
-process (i.e. not the idle process, which is PID 0, nor the system,
-which is _usually_ PID 8) to which you have access:
-
- CreationDate
- ExecutablePath
- KernelModeTime
- MaximumWorkingSetSize
- MinimumWorkingSetSize
- Name (generally the name of the executable file)
- OtherOperationCount
- OtherTransferCount (= number of bytes transferred)
- ProcessId
- ReadOperationCount
- ReadTransferCount (= number of bytes read)
- UserModeTime
- WriteOperationCount
- WriteTransferCount (= number of bytes read)
-
-All returns are Perl scalars. The I/O statistic keys represent counts
-if named *OperationCount, or bytes if named *TransferCount.
-
-Note that:
-
-- The I/O statistic keys will only be present on Windows 2000.
-
-- The MinimumWorkingSetSize and MaximumWorkingSetSize keys have
-no apparent relationship to the amount of memory actually
-consumed by the process.
-
-The output will contain all processes for which information was
-requested, but will not necessarily contain all information for
-all processes.
-
-The _status key of the process hash contains the status of
-GetProcInfo's request(s) for information. If all information is
-present, the status element of the hash will be zero. If there
-was any problem getting any of the information, the _status element
-will contain the Windows error code ($^E + 0, to be precise). You
-might want to look at it - or not count on the hashes being fully
-populated (or both!).
-
-Note that GetProcInfo is not, at the moment, able to duplicate the
-information returned by the resource kit tool pulist.exe. And it may
-never do so. Pulist.exe relies on the so-called internal APIs, which
-for NT are found in ntdll.dll, which may not be linked against.
-Pulist.exe gets around this by loading it at run time, and calling
-NtQuerySystemInformation. The required constants and structure
-definitions are in Winternl.h, which doesn't come with VCC. The caveat
-at http://msdn.microsoft.com/library/default.asp?url=/library/en-us/
-devnotes/winprog/calling_internal_apis.asp claims that they reserve
-the right to change this without notice, so I hesitate to program
-against it. Sorry. I guess the real purpose of this paragraph is to
-say that I _did_ try.
-
-=cut
-
-
-# The following manifest constants are from windef.h
-
-use constant MAX_PATH => 260;
-
-
-# The following manifest constants are from winerror.h
-
-use constant ERROR_ACCESS_DENIED => 5;
-
-
-# The following manifest constants are from winnt.h
-
-use constant READ_CONTROL => 0x00020000;
-use constant SYNCHRONIZE => 0x00100000;
-use constant STANDARD_RIGHTS_REQUIRED => 0x000F0000;
-use constant STANDARD_RIGHTS_READ => READ_CONTROL;
-use constant STANDARD_RIGHTS_WRITE => READ_CONTROL;
-use constant STANDARD_RIGHTS_EXECUTE => READ_CONTROL;
-
-use constant PROCESS_TERMINATE => 0x0001;
-use constant PROCESS_CREATE_THREAD => 0x0002;
-use constant PROCESS_VM_OPERATION => 0x0008;
-use constant PROCESS_VM_READ => 0x0010;
-use constant PROCESS_VM_WRITE => 0x0020;
-use constant PROCESS_DUP_HANDLE => 0x0040;
-use constant PROCESS_CREATE_PROCESS => 0x0080;
-use constant PROCESS_SET_QUOTA => 0x0100;
-use constant PROCESS_SET_INFORMATION => 0x0200;
-use constant PROCESS_QUERY_INFORMATION => 0x0400;
-use constant PROCESS_ALL_ACCESS => STANDARD_RIGHTS_REQUIRED | SYNCHRONIZE |
- 0xFFF;
-
-use constant SID_REVISION => 1; # Current revision level
-use constant SID_MAX_SUB_AUTHORITIES => 15;
-
-use constant TOKEN_ASSIGN_PRIMARY => 0x0001;
-use constant TOKEN_DUPLICATE => 0x0002;
-use constant TOKEN_IMPERSONATE => 0x0004;
-use constant TOKEN_QUERY => 0x0008;
-use constant TOKEN_QUERY_SOURCE => 0x0010;
-use constant TOKEN_ADJUST_PRIVILEGES => 0x0020;
-use constant TOKEN_ADJUST_GROUPS => 0x0040;
-use constant TOKEN_ADJUST_DEFAULT => 0x0080;
-use constant TOKEN_ADJUST_SESSIONID => 0x0100;
-
-use constant TOKEN_ALL_ACCESS => STANDARD_RIGHTS_REQUIRED |
- TOKEN_ASSIGN_PRIMARY | TOKEN_DUPLICATE |
- TOKEN_IMPERSONATE | TOKEN_QUERY |
- TOKEN_QUERY_SOURCE | TOKEN_ADJUST_PRIVILEGES |
- TOKEN_ADJUST_GROUPS | TOKEN_ADJUST_SESSIONID |
- TOKEN_ADJUST_DEFAULT;
-
-
-use constant TOKEN_READ => STANDARD_RIGHTS_READ | TOKEN_QUERY;
-
-
-use constant TOKEN_WRITE => STANDARD_RIGHTS_WRITE | TOKEN_ADJUST_PRIVILEGES |
- TOKEN_ADJUST_GROUPS | TOKEN_ADJUST_DEFAULT;
-
-use constant TOKEN_EXECUTE => STANDARD_RIGHTS_EXECUTE;
-
-
-# Crib notes:
-# MS type Perl type
-# Handle N
-# Bool I
-# DWord I
-# Pointer P
-
-sub GetProcInfo {
-my ( $self, @args ) = @_;
-my $opt = ref $args[0] eq 'HASH' ? shift @args : {};
-
-$CloseHandle ||= _map ('KERNEL32', 'CloseHandle', [qw{N}], 'V');
-$GetModuleFileNameEx ||=
- _map ('PSAPI', 'GetModuleFileNameEx', [qw{N N P N}], 'I');
-$GetPriorityClass ||=
- _map ('KERNEL32', 'GetPriorityClass', [qw{N}], 'I');
-$GetProcessAffinityMask ||=
- _map ('KERNEL32', 'GetProcessAffinityMask', [qw{N P P}], 'I');
-$GetProcessIoCounters ||=
- _map_opt ('KERNEL32', 'GetProcessIoCounters', [qw{N P}], 'I');
-$GetProcessTimes ||=
- _map ('KERNEL32', 'GetProcessTimes', [qw{N P P P P}], 'I');
-$GetProcessWorkingSetSize ||=
- _map ('KERNEL32', 'GetProcessWorkingSetSize', [qw{N P P}], 'I');
-$GetTokenInformation ||=
- _map ('ADVAPI32', 'GetTokenInformation', [qw{N N P N P}], 'I');
-$LookupAccountSid ||=
- _map ('ADVAPI32', 'LookupAccountSid', [qw{P P P P P P P}], 'I');
-$OpenProcess ||= _map ('KERNEL32', 'OpenProcess', [qw{N I N}], 'N');
-$OpenProcessToken ||=
- _map ('ADVAPI32', 'OpenProcessToken', [qw{N N P}], 'I');
-$EnumProcessModules ||=
- _map ('PSAPI', 'EnumProcessModules', [qw{N P N P}], 'I');
-
-
-my $dac = PROCESS_QUERY_INFORMATION | PROCESS_VM_READ;
-my $tac = TOKEN_READ;
-
-@args or @args = ListPids ($self);
-
-my @pinf;
-
-my $dat;
-my $my_pid = $self->My_Pid();
-my %sid_to_name;
-my @trydac = (
- PROCESS_QUERY_INFORMATION | PROCESS_VM_READ,
- PROCESS_QUERY_INFORMATION,
- );
-
-foreach my $pid (map {$_ eq '.' ? $my_pid : $_} @args) {
-
- local $^E = 0;
- $dat = $self->_build_hash (undef, ProcessId => $pid);
- $self->_build_hash ($dat, Name => 'System Idle Process')
- unless $pid;
-
- push @pinf, $dat;
-
- my $prchdl;
- foreach my $dac (@trydac) {
- $prchdl = $OpenProcess->Call ($dac, 0, $pid) and last;
- }
- next unless $prchdl;
-
- my ($cretim, $exttim, $knltim, $usrtim);
- $cretim = $exttim = $knltim = $usrtim = ' ' x 8;
- if ($GetProcessTimes->Call ($prchdl, $cretim, $exttim, $knltim, $usrtim)) {
- my $time = _to_char_date ($cretim);
- $self->_build_hash ($dat, CreationDate => $time) if $time;
- $self->_build_hash ($dat,
- KernelModeTime => _ll_to_bigint ($knltim),
- UserModeTime => _ll_to_bigint ($usrtim));
- }
-
- my ($minws, $maxws);
- $minws = $maxws = ' ';
- if ($GetProcessWorkingSetSize->Call ($prchdl, $minws, $maxws)) {
- $self->_build_hash ($dat,
- MinimumWorkingSetSize => unpack ('L', $minws),
- MaximumWorkingSetSize => unpack ('L', $maxws));
- }
-
- my $procio = ' ' x 6; # structure is 6 longlongs.
- if ($GetProcessIoCounters->Call ($prchdl, $procio)) {
- my ($ro, $wo, $oo, $rb, $wb, $ob) = _ll_to_bigint ($procio);
- $self->_build_hash ($dat,
- ReadOperationCount => $ro,
- ReadTransferCount => $rb,
- WriteOperationCount => $wo,
- WriteTransferCount => $wb,
- OtherOperationCount => $oo,
- OtherTransferCount => $ob);
- }
-
- my $modhdl = ' '; # Module handle better be 4 bytes.
- my $modgot = ' ';
-
- if ($EnumProcessModules->Call ($prchdl, $modhdl, length $modhdl, $modgot)) {
- $modhdl = unpack ('L', $modhdl);
- my $mfn = ' ' x MAX_PATH;
- if ($GetModuleFileNameEx->Call ($prchdl, $modhdl, $mfn, length $mfn)) {
- $mfn =~ s/\0.*//;
- $mfn =~ s/^\\(\w+)/$ENV{$1} ? $ENV{$1} : "\\$1"/ex;
- $mfn =~ s/^\\\?\?\\//;
- $self->_build_hash ($dat,
- ExecutablePath => $mfn);
- my $base = basename ($mfn);
- $self->_build_hash ($dat, Name => $base) if $base;
- }
- }
-
- my ($tokhdl);
- $tokhdl = ' ' x 4; # Token handle better be 4 bytes.
- { # Start block, to use as single-iteration loop
- last if $opt->{no_user_info};
- $OpenProcessToken->Call ($prchdl, $tac, $tokhdl)
- or do {$tokhdl = undef; last; };
- my ($dsize, $size_in, $size_out, $sid, $stat, $use, $void);
- $tokhdl = unpack 'L', $tokhdl;
-
- $size_out = ' ' x 4;
- $void = pack 'p', undef;
- my $token_type = TokenUser;
- $GetTokenInformation->Call ($tokhdl, $token_type, $void, 0, $size_out);
- $size_in = unpack 'L', $size_out;
- my $tokinf = ' ' x $size_in;
- $GetTokenInformation->Call ($tokhdl, $token_type, $tokinf, $size_in, $size_out)
- or last;
- my $sidadr = unpack "P$size_in", $tokinf;
-## NO! my $sidadr = unpack "P4", $tokinf;
-
- $sid = _text_sid ($sidadr) or last;
- $self->_build_hash ($dat, OwnerSid => $sid);
- if ($sid_to_name{$sid}) {
- $self->_build_hash ($dat, Owner => $sid_to_name{$sid});
- last;
- }
-
- $size_out = $dsize = pack 'L', 0;
- $use = pack 'S', 0;
- $stat = $LookupAccountSid->Call ($void, $sidadr, $void, $size_out, $void, $dsize, $use);
- my ($name, $domain);
- $name = " " x (unpack 'L', $size_out);
- $domain = " " x (unpack 'L', $dsize);
- my $pname = pack 'p', $name;
- my $pdom = pack 'p', $domain;
- $LookupAccountSid->Call ($void, $sidadr, $name, $size_out, $domain, $dsize, $use)
- or last;
- $size_out = unpack 'L', $size_out;
- $dsize = unpack 'L', $dsize;
- my $user = (substr ($domain, 0, $dsize) . "\\" .
- substr ($name, 0, $size_out));
- $sid_to_name{$sid} = $user;
- $self->_build_hash ($dat, Owner => $user);
- }
-
- $CloseHandle->Call ($tokhdl) if $tokhdl && $tokhdl ne ' ';
- $CloseHandle->Call ($prchdl);
- }
- continue {
- $self->_build_hash ($dat, _status => $^E + 0);
- }
-return wantarray ? @pinf : \@pinf;
-}
-
-sub _to_char_date {
-my @args = @_;
-my @result;
-( $FileTimeToSystemTime ||=
- Win32::API->new ('KERNEL32', 'FileTimeToSystemTime', [qw{P P}], 'I') )
- or croak "Error - Failed to map FileTimeToSystemTime: $^E";
-my $systim = ' ' x 8;
-foreach (@args) {
- $FileTimeToSystemTime->Call ($_, $systim) or
- croak "Error - FileTimeToSystemTime failed: $^E";
- my $time;
- my ($yr, $mo, $dow, $day, $hr, $min, $sec, $ms) = unpack ('S*', $systim);
- if ($yr == 1601 && $mo == 1 && $day == 1) {
- $time = undef;
- }
- else {
- $time = sprintf ('%04d%02d%02d%02d%02d%02d',
- $yr, $mo, $day, $hr, $min, $sec);
- }
- push @result, $time;
- }
-return @result if wantarray;
-return $result[0];
-}
-
-sub _ll_to_bigint {
-my @args = @_;
-my @result;
-foreach (@args) {
- my @data = unpack 'L*', $_;
- while (@data) {
- my $low = shift @data;
- my $high = shift @data;
- push @result, ($high <<= 32) + $low;
- }
- }
-return @result if wantarray;
-return $result[0];
-}
-
-sub _clunks_to_secs {
-my @args = @_;
-my @result;
-foreach (_ll_to_bigint (@args)) {
- push @result, $_ / 10_000_000;
- }
-return @result if wantarray;
-return $result[0];
-}
-
-=item @pids = $pi->ListPids ()
-
-This subroutine returns a list of all known process IDs in the
-system, in no particular order. If called in list context, the
-list of process IDs itself is returned. In scalar context, a
-reference to the list is returned.
-
-=cut
-
-sub ListPids {
-my ( $self, @args ) = @_;
-my $filter = undef;
-my $my_pid = $self->My_Pid();
-@args and $filter = {
- map { ($_ eq '.' ? $my_pid : $_) => 1 } @args
-};
-$EnumProcesses ||= _map ('PSAPI', 'EnumProcesses', [qw{P N P}], 'I');
-my $psiz = 4;
-my $bsiz = 0;
- {
- $bsiz += 1024;
- my $pidbuf = ' ' x $bsiz;
- my $pidgot = ' ';
- $EnumProcesses->Call ($pidbuf, $bsiz, $pidgot) or
- croak "Error - Failed to call EnumProcesses: $^E";
-# Note - 122 = The data area passed to a system call is too small
- my $pidnum = unpack ('L', $pidgot);
- redo unless $pidnum < $bsiz;
- $pidnum /= 4;
- my @pids;
- if ($filter) {
- @pids = grep {$filter->{$_}} unpack ("L$pidnum", $pidbuf);
- }
- else {
- @pids = unpack ("L$pidnum", $pidbuf);
- }
- return wantarray ? @pids : \@pids;
- }
-confess 'Programming error - should not get here';
-}
-
-
-
-# _text_sid (pointer to SID)
-
-# This subroutine translates the given sid in to a string.
-# The algorithm is from http://msdn.microsoft.com/library/
-# default.asp?url=/library/en-us/security/security/
-# converting_a_binary_sid_to_string_format.asp)
-#
-# As a general note: The SID is represented internally by an
-# opaque structure, which contains a bunch of things that we
-# need to know to format it. Rather than publishing the
-# structure, or providing a formatting routine, Microsoft
-# provided a bunch of subroutines which return pointers to the
-# various pieces/parts of the structure that we need to do it
-# ourselves. This presents us with with the situation of an
-# opaque structure, essentially all of whose parts are public.
-# This, I presume, is an example of the superior engineering that
-# makes Microsoft the darling of the industry.
-#
-# It also means we play some serious games, since Win32::API has
-# no mechanism to return a pointer. The next best thing is to
-# tell Win32::API that the return is a number of the appropriate
-# size, "pack" the number to get an honest-to-God pointer, and
-# then unpack again as a pointer to a structure of the
-# appropriate size. A further unpack may be necessary to extract
-# data from the finally-obtained structure. You'll be seeing a
-# lot of this pack/unpack idiom in the code that follows.
-#
-# Interestingly enough in February 2013 I found (fairly easily)
-# ConvertSidToStringSid(), which seems to do what I need, and
-# seems to have the same vintage as the other calls used above.
-# But in September of 2002 when I was writing this code I never
-# found it - certainly the docs cited never mentioned it.
-
-sub _text_sid {
-my $sid = shift;
-
-
-# Make sure we have a valid SID
-
-$IsValidSid ||= _map ('ADVAPI32', 'IsValidSid', [qw{P}], 'I');
-my $stat = $IsValidSid->Call ($sid)
- or return;
-
-
-# Get the identifier authority.
-
-$GetSidIdentifierAuthority ||=
- _map ('ADVAPI32', 'GetSidIdentifierAuthority', [qw{P}], 'N');
-my $sia = $GetSidIdentifierAuthority->Call ($sid);
-$sia = pack 'L', $sia;
-# Occasionally we end up with an undef value here, which indicates a
-# failure. The docs say this only happens with an invalid SID, but what
-# do they know?
-defined( $sia = unpack 'P6', $sia )
- or return;
-
-
-# Get the number of subauthorities.
-
-$GetSidSubAuthorityCount ||=
- _map ('ADVAPI32', 'GetSidSubAuthorityCount', [qw{P}], 'N');
-my $subauth = $GetSidSubAuthorityCount->Call ($sid);
-$subauth = pack 'L', $subauth;
-$subauth = unpack 'P1', $subauth;
-$subauth = unpack 'C*', $subauth;
-
-
-# Start by formatting the revision number. Note that this is
-# hard-coded. It's in a .h file if you're using "C". The
-# revision is actually in the SID if you trust the include
-# file, but the docs make it look like the SID structure is
-# supposed to be opaque, and in Microsoft's example comes from
-# the .h
-
-my $sidout = sprintf 'S-%lu', SID_REVISION;
-
-
-# Format the identifier authority. The rules are different
-# depending on whether the first 2 bytes are in use.
-
-if (unpack 'S', $sia) {
- $sidout .= sprintf ('-0x%s', unpack 'H*', $sia);
- }
- else {
- $sidout .= sprintf '-%lu', unpack 'x2N', $sia;
- }
-
-
-# Now tack on all the subauthorities. Because of Microsoft's
-# high-quality design, the subauthorities are in a different
-# byte order than the identifier authority.
-
-$GetSidSubAuthority ||=
- _map ('ADVAPI32', 'GetSidSubAuthority', [qw{P I}], 'N');
-for (my $subctr = 0; $subctr < $subauth; $subctr++) {
- my $subid = $GetSidSubAuthority->Call ($sid, $subctr);
- $subid = pack 'L', $subid;
- $subid = unpack 'P4', $subid;
- $sidout .= sprintf '-%lu', unpack 'L', $subid;
- }
-
-
-# Return the formatted string.
-
-return $sidout;
-}
-
-=back
-
-=head1 REQUIREMENTS
-
-This library uses the following libraries:
-
- Carp
- Time::Local
- Win32
- Win32::API
- Win32API::Registry (if available)
-
-As of this writing, all but Win32 and Win32::API are part of the
-standard Perl distribution. Win32 is not part of the standard Perl
-distribution, but comes with the ActivePerl distribution. Win32::API
-comes with ActivePerl as of about build 630, but did not come with
-earlier versions. It must be installed before installing this module.
-
-=head1 ACKNOWLEDGMENTS
-
-This module would not exist without the following people:
-
-Aldo Calpini, who gave us Win32::API.
-
-The folks of Cygwin (F<http://www.cygwin.com/>), especially Christopher
-Faylor, author of ps.cc.
-
-Jenda Krynicky, whose "How2 create a PPM distribution"
-(F<http://jenda.krynicky.cz/perl/PPM.html>) gave me a leg up on
-both PPM and tar distributions.
-
-Judy Hawkins of Pitney Bowes, for providing testing and patches for
-NT 4.0 without WMI.
-
-=head1 AUTHOR
-
-Thomas R. Wyant, III (F<wyant at cpan dot org>)
-
-=head1 COPYRIGHT AND LICENSE
-
-Copyright (C) 2001-2003 by E. I. DuPont de Nemours and Company, Inc.
-
-Copyright (C) 2007-2011, 2013 by Thomas R. Wyant, III
-
-This program is free software; you can redistribute it and/or modify it
-under the same terms as Perl 5.10.0. For more details, see the full text
-of the licenses in the directory LICENSES.
-
-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.
-
-=cut
-
-1;
-__END__
-
-Sample code from MSDN
-
-Set privilege (http://msdn.microsoft.com/library/default.asp?url=/library/en-us/security/security/enabling_and_disabling_privileges.asp)
-
-BOOL SetPrivilege(
- HANDLE hToken, // access token handle
- LPCTSTR lpszPrivilege, // name of privilege to enable/disable
- BOOL bEnablePrivilege // to enable or disable privilege
- )
-{
-TOKEN_PRIVILEGES tp;
-LUID luid; // 64-bit identifier
-
-if ( !LookupPrivilegeValue(
- NULL, // lookup privilege on local system
- lpszPrivilege, // privilege to lookup
- &luid ) ) // receives LUID of privilege
-{
- printf("LookupPrivilegeValue error: %u\n", GetLastError() );
- return FALSE;
-}
-
-tp.PrivilegeCount = 1;
-tp.Privileges[0].Luid = luid;
-if (bEnablePrivilege)
- tp.Privileges[0].Attributes = SE_PRIVILEGE_ENABLED;
-else
- tp.Privileges[0].Attributes = 0;
-
-// Enable the privilege or disable all privileges.
-
-if ( !AdjustTokenPrivileges(
- hToken,
- FALSE,
- &tp,
- sizeof(TOKEN_PRIVILEGES),
- (PTOKEN_PRIVILEGES) NULL,
- (PDWORD) NULL) )
-{
- printf("AdjustTokenPrivileges error: %u\n", GetLastError() );
- return FALSE;
-}
-
-return TRUE;
-}
-
-
-# _set_priv ([priv_name, ...])
-
-# This subroutine turns on the desired privilege (or privileges).
-# If no arguments are passed it turns on the "Debug" privilege.
-# The algorithm is from
-# http://msdn.microsoft.com/library/default.asp?url=/library/
-# en-us/security/security/enabling_and_disabling_privileges.asp
-#
-# We return zero for success, or $^E if an error occurs.
-#
-# The complication _here_ is that there is no standard internal
-# representation of a privilege. Microsoft encodes them as LUIDs
-# (locally-unique identifiers), which means we have to take as
-# input the strings representing the names of the privileges, and
-# translate each to a LUID, since LUIDS are _local_ to a given
-# instance of an operating system.
-
-sub _set_priv {
-
-my $self = shift;
-@_ = (SE_DEBUG_NAME ()) unless @_;
-
-
-# First we have to get our own access token, because that's what
-# we actually set the privilege on. And we'd better declare the
-# correct access intent ahead of time, or Microsoft will be very
-# upset.
-
-$GetCurrentProcess ||= _map ('KERNEL32', 'GetCurrentProcess', [], 'N');
-my $prchdl = $GetCurrentProcess->Call () or return $^E + 0;
-$OpenProcessToken ||=
- _map ('ADVAPI32', 'OpenProcessToken', [qw{N N P}], 'I');
-my $tokhdl;
-$tokhdl = ' ' x 4; # Token handle better be 4 bytes.
-my $tac = TOKEN_READ | TOKEN_ADJUST_PRIVILEGES;
-$OpenProcessToken->Call ($prchdl, $tac, $tokhdl) or return $^E + 0;
-$tokhdl = unpack 'L', $tokhdl;
-
-
-# OK, now we get to build up a TOKEN_PRIVILEGES structure
-# representing the privileges we want to assert. This looks like:
-# A dword count (number of privileges)
-# The specified number of LUID_AND_ATTRIBUTES structures,
-# each of which looks like:
-# Luid (64 bits = 8 bytes, as noted above)
-# Attributes (4 bytes).
-# Each LUID gets looked up and slapped on the end of the growing
-# TOKEN_PRIVILEGES structure.
-
-my $enab = pack 'L', SE_PRIVILEGE_ENABLED ();
-my %gotprv;
-$LookupPrivilegeValue ||=
- _map ('ADVAPI32', 'LookupPrivilegeValue', [qw{P P P}], 'I');
-my $null = pack 'p', undef;
-my $num = 0;
-my $tp = '';
-foreach my $priv (@_) {
- next if $gotprv{$priv};
- my $luid = '.' x 8; # An LUID is 64 bits.
- $LookupPrivilegeValue->Call ($null, $priv, $luid) or
- return $^E + 0;
- $gotprv{$priv} = $luid;
- $num++;
- $tp .= $luid . $enab;
- }
-
-
-# Okay, the TOKEN_PRIVILEGES structure needs the number of
-# privileges slapped on the front. So:
-
-$num = pack 'L', $num;
-$tp = $num . $tp;
-
-
-# At long last we turn on the desired privileges. As another
-# example of Microsoft's inspired design, note that we need to
-# tell the subroutine how big the structure is, even though the
-# structure contains the number of elements. Or, alternately,
-# that we have to pass the number of elements even though we told
-# the subroutine how big the structure is.
-
-$AdjustTokenPrivileges ||=
- _map ('ADVAPI32', 'AdjustTokenPrivileges', [qw{N I P N P P}], 'I');
-$AdjustTokenPrivileges->Call (
- $tokhdl, 0, $tp, length $tp, $null, $null) or
- return $^E + 0;
-
-
-return 0;
-}
-
diff --git a/Master/tlpkg/tlperl/lib/Win32/Process/Info/PT.pm b/Master/tlpkg/tlperl/lib/Win32/Process/Info/PT.pm
deleted file mode 100644
index 17a9643dc05..00000000000
--- a/Master/tlpkg/tlperl/lib/Win32/Process/Info/PT.pm
+++ /dev/null
@@ -1,306 +0,0 @@
-=head1 NAME
-
-Win32::Process::Info::PT - Provide process information via Proc::ProcessTable.
-
-=head1 SYNOPSIS
-
-This package fetches process information on a given machine, using Dan
-Urist's B<Proc::ProcessTable>. This makes the 'Win32::' part of our name
-bogus, but lets one use the same basic interface under a wider range of
-operating systems.
-
- use Win32::Process::Info
- $pi = Win32::Process::Info->new (undef, 'PT');
- $pi->Set (elapsed_as_seconds => 0); # In clunks, not seconds.
- @pids = $pi->ListPids (); # Get all known PIDs
- @info = $pi->GetProcInfo (); # Get the max
-
-CAVEAT USER:
-
-This package does not support access to a remote machine,
-because the underlying API doesn't. If you specify a machine
-name (other than '', 0, or undef) when you instantiate a
-new Win32::Process::Info::PT object, you will get an exception.
-
-This package is B<not> intended to be used independently;
-instead, it is a subclass of Win32::Process::Info, and should
-only be called via that package.
-
-=head1 DESCRIPTION
-
-The main purpose of the Win32::Process::Info::PT package is to get
-whatever information is convenient (for the author!) about one or more
-processes. GetProcInfo (which see) is therefore the most-important
-method in the package. See it for more information.
-
-This package returns whatever process IDs are made available by
-Proc::ProcessTable. Under Cygwin, this seems to mean Cygwin process IDs,
-not Windows process IDs.
-
-Unless explicitly stated otherwise, modules, variables, and so
-on are considered private. That is, the author reserves the right
-to make arbitrary changes in the way they work, without telling
-anyone. For subroutines, variables, and so on which are considered
-public, the author will make an effort keep them stable, and failing
-that to call attention to changes.
-
-Nothing is exported by default, though all the public subroutines are
-exportable, either by name or by using the :all tag.
-
-The following subroutines should be considered public:
-
-=over
-
-=cut
-
-# 0.001 18-Sep-2007 T. R. Wyant
-# Initial release.
-# 0.001_01 01-Apr-2009 T. R. Wyant
-# Make Perl::Critic compliant (to -stern, with my own profile)
-# 0.002 02-Apr-2009 T. R. Wyant
-# Production version.
-# 0.002_01 07-Apr-2009 T. R. Wyant
-# Use $self->_build_hash(), so that we test it.
-
-package Win32::Process::Info::PT;
-
-use strict;
-use warnings;
-
-use base qw{ Win32::Process::Info };
-
-our $VERSION = '1.020';
-
-use Carp;
-use File::Basename;
-use Proc::ProcessTable;
-
-# TODO figure out what we need to do here.
-
-my %_transform = (
-## CreationDate => \&Win32::Process::Info::_date_to_time_t,
- KernelModeTime => \&Win32::Process::Info::_clunks_to_desired,
- UserModeTime => \&Win32::Process::Info::_clunks_to_desired,
- );
-
-my %lglarg = map {($_, 1)} qw{assert_debug_priv variant};
-
-sub new {
- my $class = shift;
- $class = ref $class if ref $class;
- my $arg = shift;
- if (ref $arg eq 'HASH') {
- my @ilg = grep {!$lglarg{$_}} keys %$arg;
- @ilg and
- croak "Error - Win32::Process::Info::PT argument(s) (@ilg) illegal";
- } else {
- croak "Error - Win32::Process::Info::PT does not support remote operation."
- if $arg;
- }
- no warnings qw{once};
- my $self = {%Win32::Process::Info::static};
- use warnings qw{once};
- delete $self->{variant};
- $self->{_xfrm} = \%_transform;
- bless $self, $class;
- return $self;
-}
-
-
-=item @info = $pi->GetProcInfo ();
-
-This method returns a list of anonymous hashes, each containing
-information on one process. If no arguments are passed, the
-list represents all processes in the system. You can pass a
-list of process IDs, and get out a list of the attributes of
-all such processes that actually exist. If you call this
-method in scalar context, you get a reference to the list.
-
-What keys are available depend on the variant in use. With the PT
-variant you can hope to get at most the following keys. The caveat is
-that the Win32::Process::Info keys are derived from
-Proc::ProcessTable::Process fields, and if your OS does not support the
-underlying field, you will not get it. Here are the possible keys and
-the fields from which they are derived:
-
- CreationDate: start
- Description: cmndline
- ExecutablePath: fname (note 1)
- KernelModeTime: stime (note 2)
- Name: basename (fname)
- Owner: '\' . getpwuid (uid) (note 3)
- OwnerSid: uid (note 4)
- ParentProcessId: ppid
- ProcessId: pid
- UserModeTime: utime (note 2)
-
-Notes:
-
-1) ExecutablePath may not be an absolute pathname.
-
-2) We assume that Proc::ProcessTable::Process returns stime and utime in
-microseconds, and multiply by 10 to get clunks. This may be wrong under
-some operating systems.
-
-3) Owner has a backslash prefixed because Windows returns domain\user. I
-don't see a good way to get domain, but I wanted to be consistent (read:
-I was too lazy to special-case the test script).
-
-4) Note that under Cygwin this is B<not> the same as the Windows PID,
-which is returned in field 'winpid'. But the Subprocesses method needs
-the ProcessId and ParentProcessId to be consistent, and there was no
-documented 'winppid' field.
-
-The output will contain all processes for which information was
-requested, but will not necessarily contain all information for
-all processes.
-
-The _status key of the process hash contains the status of
-GetProcInfo's request(s) for information. In the case of
-Win32::Process::Info::PT, this will always be 0, but is provided
-to be consistent with the other variants.
-
-=cut
-
-{
-
- my %pw_uid;
- my %fld_map = (
- cmndline => 'Description',
- fname => sub {
- my ($info, $proc) = @_;
- $info->{Name} = basename (
- $info->{ExecutablePath} = $proc->fname ());
- },
- pid => 'ProcessId',
- ppid => 'ParentProcessId',
- start => 'CreationDate',
-## stime => 'KernelModeTime',
-## utime => 'UserModeTime',
- stime => sub {
- my ($info, $proc) = @_;
- $info->{KernelModeTime} = $proc->stime() * 10;
- },
- utime => sub {
- my ($info, $proc) = @_;
- $info->{UserModeTime} = $proc->utime() * 10;
- },
- uid => sub {
- my ($info, $proc) = @_;
- $info->{OwnerSid} = my $uid = $proc->uid ();
- $info->{Owner} = $pw_uid{$uid} ||= '\\' . getpwuid($uid);
- },
- );
- my @fld_sup = grep { defined $_ } Proc::ProcessTable->new ()->fields ();
-
- sub GetProcInfo {
- my ($self, @args) = @_;
-
- my $my_pid = $self->My_Pid();
- my $opt = ref $args[0] eq 'HASH' ? shift @args : {};
- my $tbl = Proc::ProcessTable->new ()->table ();
-
- if (@args) {
- my %filter = map {
- ($_ eq '.' ? $my_pid : $_) => 1
- } @args;
- $tbl = [grep {$filter{$_->pid ()}} @$tbl];
- }
- my @pinf;
- foreach my $proc (@$tbl) {
- my $info = {_status => 0};
- foreach my $key (@fld_sup) {
- my $name = $fld_map{$key} or next;
- if (ref $name eq 'CODE') {
- $name->($info, $proc);
- } else {
- # Yes, we could just plop the information into the
- # hash. But _build_hash() needs to be called in
- # every variant so it gets tested under any
- # variant.
- $self->_build_hash($info, $name, $proc->$key());
- }
- }
- push @pinf, $info;
- }
- return wantarray ? @pinf : \@pinf;
- }
-
-}
-
-=item @pids = $pi->ListPids ()
-
-This subroutine returns a list of all known process IDs in the
-system, in no particular order. If called in list context, the
-list of process IDs itself is returned. In scalar context, a
-reference to the list is returned.
-
-=cut
-
-sub ListPids {
- my ($self, @args) = @_;
-
- my $tbl = Proc::ProcessTable->new ()->table ();
- my $my_pid = $self->My_Pid();
- my @pids;
-
- if (@args) {
- my %filter = map {
- ($_ eq '.' ? $my_pid : $_) => 1
- } @args;
- @pids = grep {$filter{$_}} map {$_->pid} @$tbl;
- } else {
- @pids = map {$_->pid} @$tbl;
- }
- return wantarray ? @pids : \@pids;
-}
-
-sub My_Pid {
- return $$;
-}
-
-=back
-
-=head1 REQUIREMENTS
-
-This library uses the following libraries:
-
- Carp
- Time::Local
- Proc::ProcessTable
-
-As of this writing, all but Proc::ProcessTable are part of the
-standard Perl distribution.
-
-=head1 ACKNOWLEDGMENTS
-
-This module would not exist without the following people
-
-Dan Urist, author (or at least coordinator) of the Proc::ProcessTable
-module, upon which this is based.
-
-Jenda Krynicky, whose "How2 create a PPM distribution"
-(F<http://jenda.krynicky.cz/perl/PPM.html>) gave me a leg up on
-both PPM and tar distributions.
-
-=head1 AUTHOR
-
-Thomas R. Wyant, III (F<wyant at cpan dot org>)
-
-=head1 COPYRIGHT AND LICENSE
-
-Copyright (C) 2007, 2009-2011, 2013 by Thomas R. Wyant, III
-
-This program is free software; you can redistribute it and/or modify it
-under the same terms as Perl 5.10.0. For more details, see the full text
-of the licenses in the directory LICENSES.
-
-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.
-
-=cut
-
-# ex: set textwidth=72 :
-
-1;
diff --git a/Master/tlpkg/tlperl/lib/Win32/Process/Info/WMI.pm b/Master/tlpkg/tlperl/lib/Win32/Process/Info/WMI.pm
deleted file mode 100644
index ccebb6254f3..00000000000
--- a/Master/tlpkg/tlperl/lib/Win32/Process/Info/WMI.pm
+++ /dev/null
@@ -1,430 +0,0 @@
-=head1 NAME
-
-Win32::Process::Info::WMI - Provide process information via WMI.
-
-=head1 SYNOPSIS
-
-This package fetches process information on a given Windows
-machine, using Microsoft's Windows Management Implementation.
-
- use Win32::Process::Info
- $pi = Win32::Process::Info->new (undef, 'WMI');
- $pi->Set (elapsed_as_seconds => 0); # In clunks, not seconds.
- @pids = $pi->ListPids (); # Get all known PIDs
- @info = $pi->GetProcInfo (); # Get the max
-
-CAVEAT USER:
-
-This package is B<not> intended to be used independently;
-instead, it is a subclass of Win32::Process::Info, and should
-only be called via that package.
-
-=head1 DESCRIPTION
-
-This package implements the WMI-specific methods of
-Win32::Process::Info.
-
-This package returns Windows process IDs, even under Cygwin.
-
-The following methods should be considered public:
-
-=over 4
-
-=cut
-
-package Win32::Process::Info::WMI;
-
-use strict;
-use warnings;
-
-use base qw{ Win32::Process::Info };
-
-our $VERSION = '1.020';
-
-use vars qw{%mutator};
-use Carp;
-use Time::Local;
-use Win32::OLE qw{in with};
-use Win32::OLE::Const;
-use Win32::OLE::Variant;
-
-
-%mutator = %Win32::Procecss::Info::mutator;
-
-my %pariah = map {($_ => 1)} grep {$_} split ';',
- lc ($ENV{PERL_WIN32_PROCESS_INFO_WMI_PARIAH} || '');
-my $no_user_info = $ENV{PERL_WIN32_PROCESS_INFO_WMI_PARIAH} &&
- $ENV{PERL_WIN32_PROCESS_INFO_WMI_PARIAH} eq '*';
-my $assert_debug_priv = $ENV{PERL_WIN32_PROCESS_INFO_WMI_DEBUG};
-
-
-# note that "new" is >>>NOT<<< considered a public
-# method.
-
-my $wmi_const;
-
-my %lglarg = map {($_, 1)} qw{assert_debug_priv host password user variant};
-
-sub new {
-my $class = shift;
-$class = ref $class if ref $class;
-
-my $arg = shift;
-my @ilg = grep {!$lglarg{$_}} keys %$arg;
-@ilg and
- croak "Error - Win32::Process::Info::WMI argument(s) (@ilg) illegal";
-
-my $mach = $arg->{host} || '';
-$mach =~ s|^[\\/]+||;
-my $user = $arg->{user} || '';
-my $pass = $arg->{password} || '';
-$arg->{assert_debug_priv} ||= $assert_debug_priv;
-
-my $old_warn = Win32::OLE->Option ('Warn');
-Win32::OLE->Option (Warn => 0);
-
-
-# Under at least some circumstances, I have found that I have
-# access when using the monicker, and not if using the locator;
-# especially under NT 4.0 with the retrofitted WMI. So use the
-# monicker unless I have a username/password.
-
-my $wmi;
-
-if ($user) {
- my $locator = Win32::OLE->new ('WbemScripting.SWbemLocator') or do {
- Win32::OLE->Option (Warn => $old_warn);
- croak "Error - Win32::Process::Info::WMI failed to get SWBemLocator object:\n",
- Win32::OLE->LastError;
- };
-
- $wmi_const ||= Win32::OLE::Const->Load ($locator) or do {
- Win32::OLE->Option (Warn => $old_warn);
- croak "Error - Win32::Process::Info::WMI failed to load WMI type library:\n",
- Win32::OLE->LastError;
- };
-
-
-# Note that MSDN says that the following doesn't work under NT 4.0.
-##$wmi->Security_->Privileges->AddAsString ('SeDebugPrivilege', 1);
-
- $locator->{Security_}{ImpersonationLevel} =
- $wmi_const->{wbemImpersonationLevelImpersonate};
- $locator->{Security_}{Privileges}->Add ($wmi_const->{wbemPrivilegeDebug})
- if $arg->{assert_debug_priv};
-
- $wmi = $locator->ConnectServer (
- $mach, # Server
- 'root/cimv2', # Namespace
- $user, # User (with optional domain)
- $pass, # Password
- '', # Locale
- '', # Authority
-## wbemConnectFlagUseMaxWait, # Flag
- );
- }
- else {
- my $mm = $mach || '.';
- $wmi = Win32::OLE->GetObject (
- "winmgmts:{impersonationLevel=impersonate@{[
- $arg->{assert_debug_priv} ? ',(Debug)' : '']}}!//$mm/root/cimv2");
- }
-
-$wmi or do {
- Win32::OLE->Option (Warn => $old_warn);
- croak "Error - Win32::Process::Info::WMI failed to get winmgs object:\n",
- Win32::OLE->LastError;
- };
-
-$wmi_const ||= Win32::OLE::Const->Load ($wmi) or do {
- Win32::OLE->Option (Warn => $old_warn);
- croak "Error - Win32::Process::Info::WMI failed to load WMI type library:\n",
- Win32::OLE->LastError;
- };
-
-
-# Whew! we're through with that! Manufacture and return the
-# desired object.
-
-Win32::OLE->Option (Warn => $old_warn);
-my $self = {%Win32::Process::Info::static};
-$self->{machine} = $mach;
-$self->{password} = $pass;
-$self->{user} = $pass;
-$self->{wmi} = $wmi;
-$self->{_attr} = undef; # Cache for keys.
-bless $self, $class;
-return $self;
-}
-
-
-=item @info = $pi->GetProcInfo ();
-
-This method returns a list of anonymous hashes, each containing
-information on one process. If no arguments are passed, the
-list represents all processes in the system. You can pass a
-list of process IDs, and get out a list of the attributes of
-all such processes that actually exist. If you call this
-method in scalar context, you get a reference to the list.
-
-What keys are available depend both on the variant in use and
-the setting of b<use_wmi_names>. Assuming B<use_wmi_names> is
-TRUE, you can hope to get at least the following keys for a
-"normal" process (i.e. not the idle process, which is PID 0,
-nor the system, which is PID 8) to which you have access:
-
- CSCreationClassName
- CSName (= machine name)
- Caption (seems to generally equal Name)
- CreationClassName
- CreationDate
- Description (seems to equal Caption)
- ExecutablePath
- KernelModeTime
- MaximumWorkingSetSize
- MinimumWorkingSetSize
- Name
- OSCreationClassName
- OSName
- OtherOperationCount
- OtherTransferCount
- Owner (*)
- OwnerSid (*)
- PageFaults
- ParentProcessId
- PeakWorkingSetSize
- ProcessId
- ReadOperationCount
- ReadTransferCount
- UserModeTime
- WindowsVersion
- WorkingSetSize
- WriteOperationCount
- WriteTransferCount
-
-You may find other keys available as well.
-
-* - Keys marked with an asterisk are computed, and may not always
-be present.
-
-=cut
-
-sub _get_proc_objects {
-my $self = shift;
-my $my_pid = $self->My_Pid();
-my @procs = @_ ?
- map {
- my $pi = $_ eq '.' ? $my_pid : $_;
- my $obj = $self->{wmi}->Get ("Win32_Process='$pi'");
- Win32::OLE->LastError ? () : ($obj)
- } @_ :
- (in $self->{wmi}->InstancesOf ('Win32_Process'));
-
-if (@procs && !$self->{_attr}) {
- my $atls = $self->{_attr} = [];
- $self->{_xfrm} = {
- KernelModeTime => \&Win32::Process::Info::_clunks_to_desired,
- UserModeTime => \&Win32::Process::Info::_clunks_to_desired,
- };
-
- foreach my $attr (in $procs[0]->{Properties_}) {
- my $name = $attr->{Name};
- my $type = $attr->{CIMType};
- push @$atls, $name;
- $self->{_xfrm}{$name} = \&Win32::Process::Info::_date_to_time_t
- if $type == $wmi_const->{wbemCimtypeDatetime};
- }
- }
-$self->{_attr} = {map {($_->{Name}, $_->{CIMType})}
- in $procs[0]->{Properties_}}
- if (@procs && !$self->{_attr});
-
-return @procs;
-}
-
-sub GetProcInfo {
-my $self = shift;
-my $opt = ref $_[0] eq 'HASH' ? shift : {};
-my @pinf;
-my %username;
-my ($sid, $user, $domain);
-my $old_warn = Win32::OLE->Option ('Warn');
-Win32::OLE->Option (Warn => 0);
-
-my $skip_user = $no_user_info || $opt->{no_user_info};
-unless ($skip_user) {
- $sid = Variant (VT_BYREF | VT_BSTR, '');
-## $sid = Variant (VT_BSTR, '');
- $user = Variant (VT_BYREF | VT_BSTR, '');
- $domain = Variant (VT_BYREF | VT_BSTR, '');
-#
-# The following plausable ways of caching the variant to try to
-# stem the associated memory leak result in an access violation
-# the second time through (i.e. the first time the object is
-# retrieved from cache rather than being manufactured). God knows
-# why, but so far He has not let me in on the secret. Sometimes
-# There's an OLE type mismatch error before the access violation
-# is reported, but sometimes not.
-#
-## $sid = $self->{_variant}{sid} ||= Variant (VT_BYREF | VT_BSTR, '');
-## $user = $self->{_variant}{user} ||= Variant (VT_BYREF | VT_BSTR, '');
-## $domain = $self->{_variant}{domain} ||= Variant (VT_BYREF | VT_BSTR, '');
-## $sid = $Win32::Process::Info::WMI::sid ||= Variant (VT_BYREF | VT_BSTR, '');
-## $user = $Win32::Process::Info::WMI::user ||= Variant (VT_BYREF | VT_BSTR, '');
-## $domain = $Win32::Process::Info::WMI::domain ||= Variant (VT_BYREF | VT_BSTR, '');
- }
-
-foreach my $proc (_get_proc_objects ($self, @_)) {
- my $phash = $self->_build_hash (
- undef, map {($_, $proc->{$_})} @{$self->{_attr}});
- push @pinf, $phash;
- my $oid;
-
-# The test for executable path is extremely ad-hoc, but the best
-# way I have come up with so far to strain out the System and
-# Idle processes. The methods can misbehave badly on these, and
-# I have found no other way of identifying them. Idle is always
-# process 0, but it seems to me that I have seen once a system
-# whose System process ID was not 8. This test was actually
-# removed at one point, but is reinstated since finding a set of
-# slides on the NT startup which bolsters my confidence in it.
-# But it still looks like ad-hocery to me.
-
- eval {
- return unless $proc->{ExecutablePath};
- return if $skip_user || $pariah{lc $proc->{Name}};
- $sid->Put ('');
- $proc->GetOwnerSid ($sid);
- $oid = $sid->Get ();
- return unless $oid;
- $phash->{OwnerSid} = $oid;
- unless ($username{$oid}) {
- $username{$oid} =
- $proc->GetOwner ($user, $domain) ? $oid :
- "@{[$domain->Get ()]}\\@{[$user->Get ()]}";
- }
- $phash->{Owner} = $username{$oid};
- };
- }
-Win32::OLE->Option (Warn => $old_warn);
-return wantarray ? @pinf : \@pinf;
-}
-
-=item @pids = $pi->ListPids ();
-
-This method lists all known process IDs in the system. If
-called in scalar context, it returns a reference to the
-list of PIDs. If you pass in a list of pids, the return will
-be the intersection of the argument list and the actual PIDs
-in the system.
-
-=cut
-
-sub ListPids {
-my $self = shift;
-my @pinf;
-foreach my $proc (_get_proc_objects ($self, @_)) {
- push @pinf, $proc->{ProcessId};
- }
-return wantarray ? @pinf : \@pinf;
-}
-1;
-__END__
-source of the following list:
-http://msdn.microsoft.com/library/default.asp?url=/library/en-us/wmisdk/r_32os5_02er.asp
- string Caption ;
- string CreationClassName ;
- datetime CreationDate ;
- string CSCreationClassName ;
- string CSName ;
- string Description ;
- string ExecutablePath ;
- uint16 ExecutionState ;
- string Handle ;
- uint32 HandleCount ;
- datetime InstallDate ;
- uint64 KernelModeTime ;
- uint32 MaximumWorkingSetSize ;
- uint32 MinimumWorkingSetSize ;
- string Name ;
- string OSCreationClassName ;
- string OSName ;
- uint64 OtherOperationCount ;
- uint64 OtherTransferCount ;
- uint32 PageFaults ;
- uint32 PageFileUsage ;
- uint32 ParentProcessId ;
- uint32 PeakPageFileUsage ;
- uint64 PeakVirtualSize ;
- uint32 PeakWorkingSetSize ;
- uint32 Priority ;
- uint64 PrivatePageCount ;
- uint32 ProcessId ;
- uint32 QuotaNonPagedPoolUsage ;
- uint32 QuotaPagedPoolUsage ;
- uint32 QuotaPeakNonPagedPoolUsage ;
- uint32 QuotaPeakPagedPoolUsage ;
- uint64 ReadOperationCount ;
- uint64 ReadTransferCount ;
- uint32 SessionId ;
- string Status ;
- datetime TerminationDate ;
- uint32 ThreadCount ;
- uint64 UserModeTime ;
- uint64 VirtualSize ;
- string WindowsVersion ;
- uint64 WorkingSetSize ;
- uint64 WriteOperationCount ;
- uint64 WriteTransferCount ;
-
-=back
-
-=head1 REQUIREMENTS
-
-It should be obvious that this library must run under some
-flavor of Windows.
-
-This library uses the following libraries:
-
- Carp
- Time::Local
- Win32::OLE
- use Win32::OLE::Const;
- use Win32::OLE::Variant;
-
-As of ActivePerl 630, none of the variant libraries use any libraries
-that are not included with ActivePerl. Your mileage may vary.
-
-=head1 ACKNOWLEDGMENTS
-
-This module would not exist without the following people:
-
-Jenda Krynicky, whose "How2 create a PPM distribution"
-(F<http://jenda.krynicky.cz/perl/PPM.html>) gave me a leg up on
-both PPM and tar distributions.
-
-Dave Roth, F<http://www.roth.net/perl/>, author of
-B<Win32 Perl Programming: Administrators Handbook>, which is
-published by Macmillan Technical Publishing, ISBN 1-57870-215-1
-
-=head1 AUTHOR
-
-Thomas R. Wyant, III (F<wyant at cpan dot org>)
-
-=head1 COPYRIGHT AND LICENSE
-
-Copyright (C) 2001-2005 by E. I. DuPont de Nemours and Company, Inc.
-
-Copyright (C) 2007, 2010-2011, 2013 by Thomas R. Wyant, III
-
-This program is free software; you can redistribute it and/or modify it
-under the same terms as Perl 5.10.0. For more details, see the full text
-of the licenses in the directory LICENSES.
-
-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.
-
-=cut
-
-# ex: set textwidth=72 :
diff --git a/Master/tlpkg/tlperl/lib/Win32/TieRegistry.pm b/Master/tlpkg/tlperl/lib/Win32/TieRegistry.pm
index 19f9fdf4ae5..0f7031af323 100644
--- a/Master/tlpkg/tlperl/lib/Win32/TieRegistry.pm
+++ b/Master/tlpkg/tlperl/lib/Win32/TieRegistry.pm
@@ -15,7 +15,7 @@ use Tie::Hash ();
use vars qw( $PACK $VERSION @ISA @EXPORT @EXPORT_OK );
BEGIN {
$PACK = 'Win32::TieRegistry';
- $VERSION = '0.26';
+ $VERSION = '0.29';
@ISA = 'Tie::Hash';
}
@@ -662,7 +662,8 @@ sub _enumValues
my $pos= 0;
my $name= "";
my $nlen= 1+$self->Information("MaxValNameLen");
- while( $self->RegEnumValue($pos++,$name,$nlen,[],[],[],[]) ) {
+ while( $self->RegEnumValue($pos++,$name,my $nlen1=$nlen,[],[],[],[]) ) {
+ #RegEnumValue modifies $nlen1
push( @names, $name );
}
if( ! _NoMoreItems() ) {
@@ -693,11 +694,13 @@ sub _enumSubKeys
my( $namSiz, $clsSiz )= $self->Information(
qw( MaxSubKeyLen MaxSubClassLen ));
$namSiz++; $clsSiz++;
+ my $namSiz1 = $namSiz;
while( $self->RegEnumKeyEx(
$pos++, $subkey, $namSiz, [], $class, $clsSiz, $time ) ) {
push( @subkeys, $subkey );
push( @classes, $class );
push( @times, $time );
+ $namSiz = $namSiz1; #RegEnumKeyEx modifies $namSiz
}
if( ! _NoMoreItems() ) {
return ();
@@ -1366,7 +1369,7 @@ sub SetValue
} elsif( REG_DWORD == $type && $data =~ /^0x[0-9a-fA-F]{3,}$/ ) {
$data= pack( "L", hex($data) );
# We could to $data=pack("L",$data) for REG_DWORD but I see
- # no nice way to always destinguish when to do this or not.
+ # no nice way to always distinguish when to do this or not.
}
return $self->RegSetValueEx( $name, 0, $type, $data, length($data) );
}
@@ -1740,7 +1743,7 @@ Win32::TieRegistry - Manipulate the Win32 Registry
$pound= $Registry->Delimiter("/");
$diskKey= $Registry->{"LMachine/System/Disk/"}
or die "Can't read LMachine/System/Disk key: $^E\n";
- $data= $key->{"/Information"}
+ $data= $diskKey->{"/Information"}
or die "Can't read LMachine/System/Disk//Information value: $^E\n";
$remoteKey= $Registry->{"//ServerA/LMachine/System/"}
or die "Can't read //ServerA/LMachine/System/ key: $^E\n";
@@ -2015,7 +2018,7 @@ unambiguous:
Put a delimiter after each key name.
Put a delimiter in front of each value name.
-Exactly how the key string will be intepreted is governed by the
+Exactly how the key string will be interpreted is governed by the
following cases, in the order listed. These cases are designed
to "do what you mean". Most of the time you won't have to think
about them, especially if you follow the two simple rules above.
@@ -2045,7 +2048,7 @@ If the hash is tied to a virtual root key, then the leading
delimiter is ignored. It should be followed by a valid Registry
root key name [either a short-hand name like C<"LMachine">, an
I<HKEY_*> value, or a numeric value]. This alternate notation is
-allowed in order to be more consistant with the C<Open()> method
+allowed in order to be more consistent with the C<Open()> method
function.
For all other Registry keys, the leading delimiter indicates
@@ -2381,7 +2384,7 @@ The C<new> method creates a new I<Win32::TieRegistry> object.
C<new> is mostly a synonym for C<Open()> so see C<Open()> below for
information on what arguments to pass in. Examples:
- $machKey= new Win32::TieRegistry "LMachine"
+ $machKey= Win32::TieRegistry->new("LMachine")
or die "Can't access HKEY_LOCAL_MACHINE key: $^E\n";
$userKey= Win32::TieRegistry->new("CUser")
or die "Can't access HKEY_CURRENT_USER key: $^E\n";
@@ -2442,7 +2445,7 @@ will be relative to the path of the original key [C<$key>]. If
C<$sSubKey> begins with a single delimiter, then the path to the
subkey to be opened will be relative to the virtual root of the
Registry on whichever machine the original key resides. If
-C<$sSubKey> begins with two consectutive delimiters, then those
+C<$sSubKey> begins with two consecutive delimiters, then those
must be followed by a machine name which causes the C<Connect()>
method function to be called.
@@ -2478,7 +2481,7 @@ if you wish to use the returned object as a tied hash [not just as
an object], then use the C<TiedRef> method function after C<Connect>.
C<$sMachineName> is the name of the remote machine. You don't have
-to preceed the machine name with two delimiter characters.
+to precede the machine name with two delimiter characters.
C<$sKeyPath> is a string specifying the remote key to be opened.
Alternately C<$sKeyPath> can be a reference to an array value
@@ -2523,14 +2526,14 @@ Examples:
=item $object_ref= $obj_or_hash_ref->ObjectRef
-For a simple object, just returns itself [C<$obj == $obj->ObjectRef>].
+For a simple object, just returns itself [C<<$obj == $obj->ObjectRef>>].
For a reference to a tied hash [if it is also an object], C<ObjectRef>
returns the simple object that the hash is tied to.
-This is primarilly useful when debugging since typing C<x $Registry>
+This is primarily useful when debugging since typing C<x $Registry>
will try to display your I<entire> registry contents to your screen.
-But the debugger command C<x $Registry->ObjectRef> will just dump
+But the debugger command C<<x $Registry->ObjectRef>> will just dump
the implementation details of the underlying object to your screen.
=item Flush( $bFlush )
@@ -2784,9 +2787,9 @@ C<Handle()> return C<"NONE">.
Returns a string describing the path of key names to this
Registry key. The string is built so that if it were passed
-to C<$Registry->Open()>, it would reopen the same Registry key
+to C<< $Registry->Open() >>, it would reopen the same Registry key
[except in the rare case where one of the key names contains
-C<$key->Delimiter>].
+C<< $key->Delimiter >>].
=item Machine
@@ -2834,7 +2837,7 @@ object. Used to promote a simple object into a combined object
and hash ref.
If already a reference to a tied hash [that is also an object],
-it just returns itself [C<$ref == $ref->TiedRef>].
+it just returns itself [C<< $ref == $ref->TiedRef >>].
Mostly used internally.
@@ -3040,7 +3043,7 @@ it should be one the C<REG_*> constants.
C<$ValueData> is the data to be stored in the value, probably packed
into a Perl string. Other supported formats for value data are
-listed below for each posible C<$ValueType>.
+listed below for each possible C<$ValueType>.
=over
@@ -3111,7 +3114,7 @@ items are the supported keys for this options hash:
=item Delimiter
Specifies the delimiter to be used to parse C<$subKey> and to be
-used in the new object. Defaults to C<$key->Delimiter>.
+used in the new object. Defaults to C<< $key->Delimiter >>.
=item Access
@@ -3235,7 +3238,7 @@ You can specify as the last argument a reference to a hash
containing options. You can specify the same options that you
can specify to C<Open()>. See C<Open()> for more information on
those. In addition, you can specify the option C<"NewSubKey">.
-The value of this option is interpretted exactly as if it was
+The value of this option is interpreted exactly as if it was
specified as the C<$newSubKey> parameter and overrides the
C<$newSubKey> if one was specified.
@@ -3300,7 +3303,7 @@ to this "default" usage is that Perl does not support checking
the module version when you use it.
Alternately, you can specify a list of arguments on the C<use>
-line that will be passed to the C<Win32::TieRegistry->import()>
+line that will be passed to the C<< Win32::TieRegistry->import() >>
method to control what items to import into your package. These
arguments fall into the following broad categories:
@@ -3418,7 +3421,7 @@ See I<Win32API::Registry> documentation for more information.
=item Options
You can list any option names that can be listed in the C<SetOptions()>
-method call, each folowed by the value to use for that option.
+method call, each followed by the value to use for that option.
A Registry virtual root object is created, all of these options are
set for it, then each variable to be imported/set is associated with
this object.
@@ -3462,7 +3465,7 @@ Although greatly a matter of style, the "safest" practice is probably
to specifically list all constants in the C<use Win32::TieRegistry>
statement, specify C<use strict> [or at least C<use strict qw(subs)>],
and use bare constant names when you want the numeric value. This will
-detect mispelled constant names at compile time.
+detect misspelled constant names at compile time.
use strict;
my $Registry;
@@ -3517,8 +3520,8 @@ Here are quick examples that document the most common functionality
of all of the method functions [except for a few almost useless ones].
# Just another way of saying Open():
- $key= new Win32::TieRegistry "LMachine\\Software\\",
- { Access=>KEY_READ()|KEY_WRITE(), Delimiter=>"\\" };
+ $key= Win32::TieRegistry->new("LMachine\\Software\\",
+ { Access=>KEY_READ()|KEY_WRITE(), Delimiter=>"\\" });
# Open a Registry key:
$subKey= $key->Open( "SubKey/SubSubKey/",
@@ -3741,7 +3744,7 @@ and confusing). This includes references to C<$^E> perhaps not
being meaningful.
Because Perl hashes are case sensitive, certain lookups are also
-case sensistive. In particular, the root keys ("Classes", "CUser",
+case sensitive. In particular, the root keys ("Classes", "CUser",
"LMachine", "Users", "PerfData", "CConfig", "DynData", and HKEY_*)
must always be entered without changing between upper and lower
case letters. Also, the special rule for matching subkey names
diff --git a/Master/tlpkg/tlperl/lib/Win32/WinError.pm b/Master/tlpkg/tlperl/lib/Win32/WinError.pm
new file mode 100644
index 00000000000..c61347b6ec6
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Win32/WinError.pm
@@ -0,0 +1,1017 @@
+package Win32::WinError;
+
+require Exporter;
+require DynaLoader;
+
+$VERSION = '0.04';
+
+@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__
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-21 07:51:08 +0000