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