summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Win32/Process/Info/PT.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Win32/Process/Info/PT.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/Win32/Process/Info/PT.pm287
1 files changed, 287 insertions, 0 deletions
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;