summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Win32/Process/Info/NT.pm
blob: 26dd7ccba6ecc73e86ba62b7ec6d6a844f84e0f1 (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
=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::NT 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.

This package returns Windows process IDs, even under Cygwin.

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.020';

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 $my_pid = $self->My_Pid();
my %sid_to_name;
my @trydac = (
    PROCESS_QUERY_INFORMATION | PROCESS_VM_READ,
    PROCESS_QUERY_INFORMATION,
    );

foreach my $pid (map {$_ eq '.' ? $my_pid : $_} @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;
my $my_pid = $self->My_Pid();
@args and $filter = {
    map { ($_ eq '.' ? $my_pid : $_) => 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.
#
#	Interestingly enough in February 2013 I found (fairly easily)
#	ConvertSidToStringSid(), which seems to do what I need, and
#	seems to have the same vintage as the other calls used above.
#	But in September of 2002 when I was writing this code I never
#	found it - certainly the docs cited never mentioned it.

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;
# Occasionally we end up with an undef value here, which indicates a
# failure. The docs say this only happens with an invalid SID, but what
# do they know?
defined( $sia = unpack 'P6', $sia )
    or return;


#	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, 2013 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;
}