diff options
Diffstat (limited to 'Master')
| -rw-r--r-- | Master/source/tlperl/Win32-Process-Info-1.018.tar.gz | bin | 0 -> 49941 bytes | |||
| -rw-r--r-- | Master/source/tlperl/tlperl.README | 1 | ||||
| -rw-r--r-- | Master/tlpkg/tlperl/lib/Win32/Process/Info.pm | 964 | ||||
| -rw-r--r-- | Master/tlpkg/tlperl/lib/Win32/Process/Info/NT.pm | 849 | ||||
| -rw-r--r-- | Master/tlpkg/tlperl/lib/Win32/Process/Info/PT.pm | 287 | ||||
| -rw-r--r-- | Master/tlpkg/tlperl/lib/Win32/Process/Info/WMI.pm | 426 |
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 Binary files differnew file mode 100644 index 00000000000..eb5c8487d82 --- /dev/null +++ b/Master/source/tlperl/Win32-Process-Info-1.018.tar.gz 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 : |