summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Win32/Process/Info.pm
blob: 6164c18d37b12e590bc0ea9795a3247209940278 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
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 :