#  NT_ProcessList2.pl
#  Example 7.16:
#  ----------------------------------------
#  From "Win32 Perl Scripting: Administrators Handbook" by Dave Roth
#  Published by New Riders Publishing.
#  ISBN # 1-57870-215-1
#
#  This script demonstrates how the NT process list can be procured
#  by talking directly to the Registry.
#
print "From the book 'Win32 Perl Scripting: The Administrator's Handbook' by Dave Roth\n\n";


use Getopt::Long;
use Win32API::Registry qw( :ALL );

%FLAG = (
    friendly    =>  'f',    # Show memory sizes in M or K
);

Configure( \%Config, @ARGV );
if( $Config->{help} )
{
    Syntax();
    exit();
}

$STRINGS_KEY = 'SOFTWARE\Microsoft\Windows NT\CurrentVersion\Perflib\009';
$hRootKey =  HKEY_LOCAL_MACHINE;
%STRUCT = (
    process             =>  "L2pLplL4",
    counter             =>  "L2LLLlL4",
    counter_block       =>  "L",
    instance            =>  "L3lL2",
    perf_object         =>  "a8L6lL10A10",
    perf_object_type    =>  "L4PLPL2l2LL8",
);

if( "" ne $Config{machine} )
{
    if( ! RegConnectRegistry( $Config{machine}, $hRootKey, $hRootKey ) )
    {
        print "Unable to connect to $Config{machine}.\n";
        exit();
    }
}

if( RegOpenKeyEx( $hRootKey, $STRINGS_KEY, 0, KEY_READ, $hKey ) )
{
    $Data = GetKeyValue( $hKey, 'Counters' );
    RegCloseKey( $hKey );
}

@Data = split( "\c@", $Data );
for( $iIndex = 0; $iIndex < $#Data; $iIndex += 2  )
{
    $STRINGS{lc $Data[$iIndex + 1]} = $Data[$iIndex];
    $STRINGS_INDEX{$Data[$iIndex]} = $Data[$iIndex + 1];
}
$hRootKey = HKEY_PERFORMANCE_DATA;
if( "" ne $Config{machine} )
{
    if( ! RegConnectRegistry( $Config{machine}, $hRootKey, $hRootKey ) )
    {
        print "Unable to connect to $Config{machine}.\n";
        exit();
    }
}

$Data = GetKeyValue( $hRootKey, $STRINGS{process} );

# We did not open the key since it is a performance data key (no need to
# open it). However we must close it so the system knows we are no
# longer monitoring.
RegCloseKey( $hRootKey );

# Okay we have the data now let's walk through it...
# First get the PerfObject structure...
UnpackPerfObject( $Data, \%Object );
$Data = Offset( $Data, $Object{HeaderLength} );

# Now that we have the PerfObject walk through each
# object until we find the one we want...
$iIndex = $Object{NumObjectTypes};
while( $iIndex-- )
{
    # Next we need to get an ObjectType structure so we have to
    # move to the the ObjectType structure in our $Data...
    UnpackObjectType( $Data, \%Type );
    if( $STRINGS{process} eq $Type{ObjectNameTitleIndex} )
    {
        ParseProcesses( $Data, \%Processes );
        last;
    }
    $Data = Offset( $Data, $Type{HeaderLength} );    
}

$~ = PROCESS_HEADER;
write;

$~ = PROCESS_INFO;
foreach $Process ( keys( %Processes ) )
{
    # Don't make $Proc lexicaly scoped since it is used in a formatted
    # write.
    $Proc = $Processes{$Process};
    write;
}

format PROCESS_HEADER =
@||| @||||||||| @||||||||||||| @|||||| @|||||||||||| @|||||||||||| @||||||||
"PID", "Parent PID", "Process Name", "Threads", "Memory", "Memory Peak", "Priority"
---- ---------- -------------- ------- ------------- ------------- ---------
.

format PROCESS_INFO =
@||| @||||||||| @<<<<<<<<<<<<< @>>>>>> @>>>>>>>>>>>> @>>>>>>>>>>>> @>>>>>>>>
$Proc->{'ID Process'}, $Proc->{'Creating Process ID'}, $Proc->{Title}, $Proc->{'Thread Count'}, FormatNumber( $Proc->{'Working Set'} ), FormatNumber( $Proc->{'Working Set Peak'} ), $Proc->{'Priority Base'}
.

sub ParseProcesses
{
    my( $Data, $Processes ) = @_;
    my %Type;
    my $pTypeData = $Data;
    my $iIndex;
    my( $pCounterBlock, $pThisProcess );
 
    # Here we walk through each process and collect info about it.
    # We already had one but we did not pass it into this sub.
    UnpackObjectType( $pTypeData, \%Type );
    
    # Move to the first process instance...
    $pThisProcess = Offset( $Data, $Type{DefinitionLength} );

    # We have the object type so let's move the $Data to the next structure
    # we need...
    $Data = Offset( $Data, $Type{DefinitionLength} );

    $iIndex = 0;

    print "Collecting process data for $Config{machine} ...    0%";

    while( $iIndex++ < $Type{NumInstances} )
    {
        my( %Instance, %CounterBlock );
        my $Percent;

        UnpackInstance( $pThisProcess, \%Instance );
        if( ( 0 < $Instance{NameLength} ) && ( 0 < $Instance{NameOffset} ) )
        {
            my $TempProcess;
            my $Title;
            my $pTempInstance;
        
            $pTempInstance = Offset( $pThisProcess, $Instance{NameOffset} );
            $Title = unpack( "a$Instance{NameLength}", $pTempInstance );
            $Title =~ s/\x00//g;
            CollectCounterValues( $pThisProcess, $pTypeData, \%{$Processes->{lc $Title}} );
            $Processes->{lc $Title}->{Title} = $Title;
        }
        $pCounterBlock = Offset( $pThisProcess, $Instance{ByteLength} );
        UnpackCounterBlock( $pCounterBlock, \%CounterBlock );
        $pThisProcess = Offset( $pCounterBlock, $CounterBlock{ByteLength} );
        
        print "\ch" x 5;
        printf( "% 4d%%", int( $iIndex / $Type{NumInstances} * 100 ) );
    }
    print "\n";
}

sub CollectCounterValues
{
    my( $Data, $ObjectData, $Process ) = @_;
    my( %Type, %Instance );
    my( $iIndex, $pCounterBlock, $pThisCounterDef );

    UnpackInstance( $Data, \%Instance );
    UnpackObjectType( $ObjectData, \%Type );
    
    $pThisCounterDef = Offset( $ObjectData, $Type{HeaderLength} );

    $pCounterBlock = Offset( $Data, $Instance{ByteLength} );
    $iIndex = $Type{NumInstances} - 1;
    
    while( --$iIndex )
    {
        my( $pThisCounter, %ThisCounterDef, $iIndex, $Property );
        my $Value = 0;
        my $CounterType = 0;

        UnpackCounter( $pThisCounterDef, \%ThisCounterDef );
        $pThisCounter = Offset( $pCounterBlock, $ThisCounterDef{CounterOffset} );
        # $pThisCounter now points to the counter data

        $Property = $STRINGS_INDEX{ $ThisCounterDef{CounterNameTitleIndex} };
        # Let's assume that the information we seek is always 
        # an unsigned long (a DWORD)   
        $CounterType = 0x300 & $ThisCounterDef{CounterType};
        if( 0x300 == $CounterType )
        {
            # The length of the value is defined in $ThisCounterDef
            # We don't do variable length in this version
        }
        elsif( 0x200 == $CounterType )
        {
            # How odd; in this case the counter has a length of 0
            $Value = 0;    
        }
        elsif( 0x100 == $CounterType )
        {
            # We have a 64 bit value
            my( $Lo, $Hi) = unpack( "L2", $pThisCounter );
            $Value = ( $Hi * 0xFFFFFFFF ) + $Lo;
        }
        else
        {
            # The value is a 32 DWORD
            $Value = unpack( "L", $pThisCounter );
        }
        $Process->{$Property} = $Value;
        $pThisCounterDef = Offset( $pThisCounterDef, $ThisCounterDef{ByteLength} );
    }
}

sub UnpackCounter
{
    my( $Data, $Counter ) = @_;
    my( @Perf ) = unpack( $STRUCT{counter}, $Data );
    my $iIndex = 0;
    $Counter->{ByteLength}              = $Perf[$iIndex++];
    $Counter->{CounterNameTitleIndex}   = $Perf[$iIndex++];
    $Counter->{CounterNameTitle}        = $Perf[$iIndex++];
    $Counter->{CounterHelpTitleIndex}   = $Perf[$iIndex++];
    $Counter->{CounterHelpTitle}        = $Perf[$iIndex++];
    $Counter->{DefaultScale}            = $Perf[$iIndex++];
    $Counter->{DetailLevel}             = $Perf[$iIndex++];
    $Counter->{CounterType}             = $Perf[$iIndex++];
    $Counter->{CounterSize}             = $Perf[$iIndex++];
    $Counter->{CounterOffset}           = $Perf[$iIndex++];
    $Counter->{Title}                   = $STRINGS_INDEX{$Counter->{CounterNameTitleIndex}};
}

sub UnpackInstance
{
    my( $Data, $Instance ) = @_;
    my( @Perf ) = unpack( $STRUCT{instance}, $Data );
    my $iIndex = 0;

    $Instance->{ByteLength}              = $Perf[$iIndex++];
    $Instance->{ParentObjectTitleIndex}  = $Perf[$iIndex++];
    $Instance->{ParentObjectInstance}    = $Perf[$iIndex++];
    $Instance->{UniqueID}                = $Perf[$iIndex++];
    $Instance->{NameOffset}              = $Perf[$iIndex++];
    $Instance->{NameLength}              = $Perf[$iIndex++];
}

sub UnpackPerfObject
{
    my( $Data, $Object ) = @_;
    my( @Perf ) = unpack( $STRUCT{perf_object}, $Data );
    # Check the signature of the data structure
    if( "P\x00E\x00R\x00F\x00" eq $Perf[0] )
    {
        my $iIndex = 0;

        $Object->{Signature}            = $Perf[$iIndex++];
        $Object->{LittleEndian}         = $Perf[$iIndex++];
        $Object->{Version}              = $Perf[$iIndex++];
        $Object->{Revision}             = $Perf[$iIndex++];
        $Object->{TotalByteLength}      = $Perf[$iIndex++];
        $Object->{HeaderLength}         = $Perf[$iIndex++];
        $Object->{NumObjectTypes}       = $Perf[$iIndex++];
        $Object->{DefaultObjectType}    = $Perf[$iIndex++];
        $Object->{SystemTime}           = 0xFFFFFFFF * $Perf[$iIndex++] + $Perf[$iIndex++];
        $Object->{PerfTime}             = 0xFFFFFFFF * $Perf[$iIndex++] + $Perf[$iIndex++];
        $Object->{PerfFreq}             = 0xFFFFFFFF * $Perf[$iIndex++] + $Perf[$iIndex++];
        $Object->{PerfTime100nSec}      = 0xFFFFFFFF * $Perf[$iIndex++] + $Perf[$iIndex++];
        $Object->{SystemNameLength}     = $Perf[$iIndex++];
        $Object->{SystemNameOffset}     = $Perf[$iIndex++];
        $Object->{Name}                 = $Perf[$iIndex++];
    }
}

sub UnpackObjectType
{
    my( $Data, $Type ) = @_;
    my( @Perf ) = unpack( $STRUCT{perf_object_type}, $Data );
    my $iIndex = 0;

    $Type->{TotalByteLength}        = $Perf[$iIndex++];
    $Type->{DefinitionLength}       = $Perf[$iIndex++];
    $Type->{HeaderLength}           = $Perf[$iIndex++];
    $Type->{ObjectNameTitleIndex}   = $Perf[$iIndex++];
    $Type->{ObjectNameTitle}        = $Perf[$iIndex++];
    $Type->{ObjectHelpTitleIndex}   = $Perf[$iIndex++];
    $Type->{ObjectHelpTitle}        = $Perf[$iIndex++];
    $Type->{DetailLevel}            = $Perf[$iIndex++];
    $Type->{NumCounters}            = $Perf[$iIndex++];
    $Type->{DefaultCounter}         = $Perf[$iIndex++];
    $Type->{NumInstances}           = $Perf[$iIndex++];
    $Type->{CodePage}               = $Perf[$iIndex++];
    $Type->{PerfTime}               = 0xFFFFFFFF * $Perf[$iIndex++] + $Perf[$iIndex++];
    $Type->{PerfFreq}               = 0xFFFFFFFF * $Perf[$iIndex++] + $Perf[$iIndex++];
}

sub UnpackCounterBlock
{
    my( $Data, $Block ) = @_;
    my( @Perf ) = unpack( $STRUCT{counter_block}, $Data );
    my $iIndex = 0;

    $Block->{ByteLength}        = $Perf[$iIndex++];
}

sub GetKeyValue
{
    my( $hKey, $Value ) = @_;
    my $Data;
    my $BufferSize = 0;
    my $CurrentBufferSize = 10240;

    # If a call to RegQueryValueEx() is made with too small a buffer it
    # will fail but set $BufferSize to the size it should be.
    # However it is possible that by the time a call is re-issued the
    # buffersize requirements will have changed. Therefore we continue to
    # increase the buffer until it works.
    do
    {
        $BufferSize = $CurrentBufferSize += $BufferSize;
    }
    while( ! RegQueryValueEx( $hKey, $Value, [], $Type, $Data, $BufferSize ) );
    return( $Data );
}

sub Offset
{
    my( $Data, $Offset ) = @_;
    my( $Temp );
    ($Temp, $Data) = unpack( "a" . $Offset . "a*", $Data );
    return( $Data );
}

sub FormatNumber
{
    my( $Number ) = @_;
    my( $Suffix ) = "";

    if( defined $Config{$FLAG{friendly}} )
    {
        my( $K, $M ) = ( 1024, ( 1024 * 1024 ) );
        if( ( $K <= $Number ) && ( $M > $Number ) )
        {
            $Suffix = " K";
            $Number /= $K;
        }
        elsif ( $M <= $Number )
        {
            $Suffix = " M";
            $Number /= $M;
        }
    }
    $Number =~ s/(\.\d{0,2})\d*$/$1/;

    while($Number =~ s/^(-?\d+)(\d{3})/$1,$2/){};

    return( $Number . $Suffix );
}

sub Configure
{
    my( $Config, @Args ) = @_;
    my $Result;

    $Config->{machine} = Win32::NodeName();
    Getopt::Long::Configure( "prefix_pattern=(-|\/)" );
    $Result = GetOptions( $Config, 
                          qw( f help|?|h ) );

    $Config->{machine} = shift @ARGV if( scalar @ARGV );
    $Config->{help} = 1 unless( $Result );
}

sub Syntax
{
    my( $Script ) = ( $0 =~ /([^\\\/]*?)$/ );
    my( $Line ) = "-" x length( $Script );

    print <<EOT;

$Script
$Line
Displays the list of running processes.

Syntax:
    perl $Script [-f] [Machine]
        -f..........Display memory values in a "friendly" format of
                    Megabytes or Kilobytes.
        Machine.....Name of a machine to procure the list of processes.
                    Defaults to local machine.
EOT
}