#  ModuleList.pl
#  Example: 7.17
#  ----------------------------------------
#  From "Win32 Perl Scripting: Administrators Handbook" by Dave Roth
#  Published by New Riders Publishing.
#  ISBN # 1-57870-215-1
#
#  This script demonstrates the PSAPI by listing all loaded DLL (module) files
#  that each process has.

use Win32::API;

# Define some contants
$DWORD_SIZE = 4;
$PROC_ARRAY_SIZE = 100;
$MODULE_LIST_SIZE = 100;

# Define some Win32 API constants
$PROCESS_QUERY_INFORMATION = 0x0400;
$PROCESS_VM_READ = 0x0010;

foreach $Param ( @ARGV )
{
    push( @PidList, $Param ) if( $Param =~ /^\d+$/ );
}
$OpenProcess = new Win32::API( 'kernel32.dll', 'OpenProcess', [N,I,N], N ) || die "Can not link to open proc";
$CloseHandle = new Win32::API( 'kernel32.dll', 'CloseHandle', [N], I ) || die "Can not link to CloseHandle()";
$EnumProcesses = new Win32::API( 'psapi.dll', 'EnumProcesses', [P,N,P], I ) || die;
$EnumProcessModules = new Win32::API( 'psapi.dll', 'EnumProcessModules', [N,P,N,P], I ) || die "Can not link EnumProcessModules";
$GetModuleBaseName = new Win32::API( 'psapi.dll', 'GetModuleBaseName', [N,N,P,N], N ) || die "Can not link to GetModuleBaseName\n";
$GetModuleFileNameEx = new Win32::API( 'psapi.dll', 'GetModuleFileNameEx', [N,N,P,N], N ) || die "Could not link to GetModuleFileNameEx\n";
$GetProcessMemoryInfo = new Win32::API( 'psapi.dll', 'GetProcessMemoryInfo', [N,P,N], I ) || die "Can not link GetProcessMemoryInfo()\n";

if( 0 == scalar @PidList )
{
    @PidList = GetPidList();
}
if( Win32::IsWinNT() )
{
    my $iTotal = 0;

    # Create a buffer
    $ProcArray = MakeBuffer( $DWORD_SIZE * $PROC_ARRAY_SIZE );
    $ProcNum = MakeBuffer( $DWORD_SIZE );

    foreach $Pid ( @PidList )
    {
        my $iModuleCount = 0;
        my $ProcInfo = GetProcessInfo( $Pid );
        print "\n$ProcInfo->{pid} ($ProcInfo->{name})\n";
        if( scalar @{$ProcInfo->{modules}} )
        {
            printf( " Current memory use: %s\n Peak memory use: %s\n",
                    FormatNumber( $ProcInfo->{workingset} ),
                    FormatNumber( $ProcInfo->{workingsetpeak} ) );
            print " Module list:\n";
            foreach $Module ( @{$ProcInfo->{modules}} )
            {
                printf( "    %03d) %s\n", ++$iModuleCount, $Module );
            }
        }
        else
        {
            print " Unable to get process information.\n";
        }
    }
}

sub GetPidList()
{
    my( @PidList );

    # Create a buffer
    $ProcArray = MakeBuffer( $DWORD_SIZE * $PROC_ARRAY_SIZE );
    $ProcNum = MakeBuffer( $DWORD_SIZE );
    if( 0 != $EnumProcesses->Call( $ProcArray, $PROC_ARRAY_SIZE, $ProcNum ) )
    {
        # Get the number of bytes used in the array
        # Check this out -- divide by the number of bytes in a DWORD
        # and we have the number of processes returned!
        $ProcNum = unpack( "L", $ProcNum ) / $DWORD_SIZE;

        # Let's play with each PID
        # First we must unpack each PID from the returned array
        @PidList = unpack( "L$ProcNum", $ProcArray );
    }
    return( @PidList );
}

sub GetProcessInfo()
{
    my( $Pid ) = @_;
    my( %ProcInfo );

    $ProcInfo{name} = "unknown";
    $ProcInfo{pid} = $Pid;
    @{$ProcInfo{modules}} = ();

    # We can not open the system Idle process so just hack it.
    $ProcInfo{name} = "Idle" if( 0 == $Pid );

    my( $hProcess ) = $OpenProcess->Call( $PROCESS_QUERY_INFORMATION | $PROCESS_VM_READ, 0, $Pid );
    if( $hProcess )
    {
        my( $BufferSize ) = $MODULE_LIST_SIZE * $DWORD_SIZE;
        my( $MemStruct ) = MakeBuffer( $BufferSize );
        my( $iReturned ) = MakeBuffer( $BufferSize );

        if( $EnumProcessModules->Call( $hProcess, $MemStruct, $BufferSize, $iReturned ) )
        {
            my( $StringSize ) = 255 * ( ( Win32::API::IsUnicode() )? 2 : 1 );
            my( $ModuleName ) = MakeBuffer( $StringSize );
            my( @ModuleList ) = unpack( "L*", $MemStruct );
            my $hModule = $ModuleList[0];
            my $TotalChars;

            # Like EnumProcesses() divide $Returned by the # of bytes in an HMODULE
            # (which is the same as a DWORD)
            # and that is the number of module handles returned.
            # In this case we only want 1; the first returned in the array is
            # always the module of the process (typically an executable).
            $iReturned = unpack( "L", $iReturned ) / $DWORD_SIZE;

            if( $TotalChars = $GetModuleBaseName->Call( $hProcess, $hModule, $ModuleName, $StringSize ) )
            {
                $ProcInfo{name} = FixString( $ModuleName );
            }
            else
            {
                $ProcInfo{name} = "unknown";
            }
            for( $iIndex = 0; $iIndex < $iReturned; $iIndex++ )
            {
                $hModule = $ModuleList[$iIndex];
                $ModuleName = MakeBuffer( $StringSize );
                if( $GetModuleFileNameEx->Call( $hProcess,
                                            $hModule,
                                            $ModuleName,
                                            $StringSize ) )
                {
                    if( 0 == $iIndex )
                    {
                        $ProcInfo{fullname} = FixString( $ModuleName );
                    }
                    push( @{$ProcInfo{modules}}, FixString( $ModuleName ) );
                }
            }
        }
        $BufSize = 10 * $DWORD_SIZE;
        $MemStruct = pack( "L10", ( $BufSize, split( "", 0 x 9 ) ) );
        if( $GetProcessMemoryInfo->Call( $hProcess, $MemStruct, $BufSize ) )
        {
         my( @MemStats ) = unpack( "L10", $MemStruct );
         $ProcInfo{workingsetpeak} = $MemStats[2];
         $ProcInfo{workingset} = $MemStats[3];
         $ProcInfo{pagefileuse} = $MemStats[8];
         $ProcInfo{pagefileusepeak} = $MemStats[9];

        }
        $CloseHandle->Call( $hProcess );
    }
    return( \%ProcInfo );
}

sub MakeBuffer
{
    my( $BufferSize ) = @_;
    return( "\x00" x $BufferSize );
}

sub FixString
{
    my( $String ) = @_;
    $String =~ s/(.)\x00/$1/g if( Win32::API::IsUnicode() );
    return( unpack( "A*", $String ) );
}

sub FormatNumber
{
    my( $Number ) = @_;
    while ($Number =~ s/^(-?\d+)(\d{3})/$1,$2/){};
    return( $Number );
}