summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Master/source/tlperl/Win32-Process-Info-1.018.tar.gzbin0 -> 49941 bytes
-rw-r--r--Master/source/tlperl/tlperl.README1
-rw-r--r--Master/tlpkg/tlperl/lib/Win32/Process/Info.pm964
-rw-r--r--Master/tlpkg/tlperl/lib/Win32/Process/Info/NT.pm849
-rw-r--r--Master/tlpkg/tlperl/lib/Win32/Process/Info/PT.pm287
-rw-r--r--Master/tlpkg/tlperl/lib/Win32/Process/Info/WMI.pm426
6 files changed, 2527 insertions, 0 deletions
diff --git a/Master/source/tlperl/Win32-Process-Info-1.018.tar.gz b/Master/source/tlperl/Win32-Process-Info-1.018.tar.gz
new file mode 100644
index 00000000000..eb5c8487d82
--- /dev/null
+++ b/Master/source/tlperl/Win32-Process-Info-1.018.tar.gz
Binary files differ
diff --git a/Master/source/tlperl/tlperl.README b/Master/source/tlperl/tlperl.README
index ed0d905e5fd..0ba6ab73301 100644
--- a/Master/source/tlperl/tlperl.README
+++ b/Master/source/tlperl/tlperl.README
@@ -91,6 +91,7 @@ Windows-specific:
Win32-Shortcut-0.07.tar.gz
Win32API-Registry-0.32.tar.gz
Win32-TieRegistry-0.26.tar.gz
+ Win32-Process-Info-1.018.tar.gz
Perl/Tk:
diff --git a/Master/tlpkg/tlperl/lib/Win32/Process/Info.pm b/Master/tlpkg/tlperl/lib/Win32/Process/Info.pm
new file mode 100644
index 00000000000..6164c18d37b
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Win32/Process/Info.pm
@@ -0,0 +1,964 @@
+=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.
+
+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.018';
+
+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 {
+ %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( "Win32_Process='$$'" );
+ };
+ 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 {
+ my ($pkg, @params) = @_;
+ my (@args, @vars);
+ foreach (@params) {
+ if (exists $variant_support{$_}) {
+ push @vars, $_;
+ } else {
+ push @args, $_;
+ }
+ }
+ # Note that if we ever become a subclass of Exporter
+ # we will have to call __PACKAGE__->SUPER::import (@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;
+ }
+
+ # Return the number of times import() done.
+ sub _import_done {
+ return $idempotent;
+ }
+
+} # End local symbol block.
+
+
+{
+ my $is_reactos = $^O eq 'MSWin32' && 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 $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 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
new file mode 100644
index 00000000000..022d1442b33
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Win32/Process/Info/NT.pm
@@ -0,0 +1,849 @@
+=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 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.
+
+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.018';
+
+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 %sid_to_name;
+my @trydac = (
+ PROCESS_QUERY_INFORMATION | PROCESS_VM_READ,
+ PROCESS_QUERY_INFORMATION,
+ );
+
+foreach my $pid (map {$_ eq '.' ? $$ : $_} @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;
+@args and $filter = {map {(($_ eq '.' ? $$ : $_), 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.
+
+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;
+$sia = unpack 'P6', $sia;
+
+
+# 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 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
new file mode 100644
index 00000000000..b2b6326b0a4
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Win32/Process/Info/PT.pm
@@ -0,0 +1,287 @@
+=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 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.
+
+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.018';
+
+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 $opt = ref $args[0] eq 'HASH' ? shift @args : {};
+ my $tbl = Proc::ProcessTable->new ()->table ();
+ if (@args) {
+ my %filter = map {(($_ eq '.' ? $$ : $_), 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 @pids;
+ if (@args) {
+ my %filter = map {(($_ eq '.' ? $$ : $_), 1)} @args;
+ @pids = grep {$filter{$_}} map {$_->pid} @$tbl;
+ } else {
+ @pids = map {$_->pid} @$tbl;
+ }
+ return wantarray ? @pids : \@pids;
+}
+
+=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 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
new file mode 100644
index 00000000000..3edb3a262f6
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Win32/Process/Info/WMI.pm
@@ -0,0 +1,426 @@
+=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.
+
+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.018';
+
+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 @procs = @_ ?
+ map {
+ my $pi = $_ eq '.' ? $$ : $_;
+ 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 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 :