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;