Win32SnapWalk

[t0mas]

Category:

Win32 Stuff

Description:

A package to list the currently running processes on a Win32 box. It uses Win32::API.

#!/usr/local/bin/perl -w
#
# Win32SnapWalk package
# by [e-mail]
#

package Win32SnapWalk;

use strict;
use Win32::API;

use constant TH32CS_SNAPPROCESS => 0x00000002;
use constant DWORD_SIZE => 4;
use constant LONG_SIZE => 4;
use constant MAX_PATH_SIZE => 260;

######################################################################
sub GetProcessList { 

    #
    # Get list of processes, return as an array of hashes
    #

    my $hProcessSnap; 
    my $pe32; 
    my @pList;
    my $process;
 
    # Import required functions
    my $CreateToolhelp32Snapshot = new Win32::API(
        "kernel32", 
        "CreateToolhelp32Snapshot", 
        ["N", "N"], 
        "I");

    if (! defined $CreateToolhelp32Snapshot) {
        die "Can't import CreateToolhelp32Snapshot";
    }

    my $Process32First = new Win32::API(
        "kernel32", 
        "Process32First", 
        ["I", "P"], 
        "I");

    if (! defined $Process32First) {
        die "Can't import Process32First";
    }


    my $Process32Next = new Win32::API(
        "kernel32", 
        "Process32Next", 
        ["I", "P"], 
        "I");

    if (! defined $Process32Next) {
        die "Can't import Process32Next";
    }

    my $CloseHandle = new Win32::API(
        "kernel32", 
        "CloseHandle", 
        ["I"], 
        "V");

    if (! defined $CloseHandle) {
        die "Can't import CloseHandle";
    }

    # Take a snapshot of all processes in the system. 
    $hProcessSnap = $CreateToolhelp32Snapshot->Call(TH32CS_SNAPPROCESS
+, 0); 

    if (! $hProcessSnap) {
        die "Unable to get process list";
    } 

    # Fill in the size of the structure with blanks before using it. 
    # Should be sizeof(PROCESSENTRY32) but I just guess here...; 
    $pe32 = " " x (DWORD_SIZE*8+LONG_SIZE+MAX_PATH_SIZE); 
 
    #  Walk the snapshot of the processes, and for each process, 
    #  push to list. 
    if ($Process32First->Call($hProcessSnap, $pe32)) {

        do {
            # Empty hash
            $process={};

            # Unpack structure to hash
            ($process->{dwSize},
            $process->{cntUsage},
            $process->{th32ProcessID},
            $process->{th32DefaultHeapID},
            $process->{th32ModuleID},
            $process->{cntThreads},
            $process->{th32ParentProcessID},
            $process->{pcPriClassBase},
            $process->{dwFlags},
            $process->{szExeFile}) = unpack("LLLLLLLlLA*",$pe32);

            # Push process to list
            push(@pList,$process); 

            # Fill in the size of the structure again with blanks. 
            $pe32 = " " x (DWORD_SIZE*8+LONG_SIZE+MAX_PATH_SIZE); 

        } while ($Process32Next->Call($hProcessSnap, $pe32)); 
    }

    # Close handle
    $CloseHandle->Call($hProcessSnap);

    # Return process list
    return @pList;
};
 
######################################################################
1;

__END__


=head1 NAME

Win32SnapWalk - List processes running on a Win32 box

=head1 DESCRIPTION

A package that lists processes running on a Win32 box.

=head1 SYNOPSIS

Example:

 #!/usr/local/bin/perl -w
 use Win32SnapWalk;

 my @processes=Win32SnapWalk::GetProcessList();

 for my $href ( @processes ) {
    print "{\n";
    for my $name ( keys %$href ) {
       print "  $name=$href->{$name}\n";
    }
    print "}\n";
 }

=head1 SEE ALSO

L<Win32::API>

=head1 BUGS

The hash element dwSize is wrong and meaningless. Its supposed to hold
+ the size
of the process structure (sizeof(PROCESSENTRY32)) and shold be set bef
+ore 
calling Process32First if you do it in C/C++.

This package is only tested on Win2k, and it may behave faulty on the 
+other 
Win* flavours 

Probably a few...  

=head1 FUTURE DEVELOPMENT

Module, heap, and thread walking seems like logical improvements.

=head1 DISCLAIMER

I do not guarantee B<ANYTHING> with this package. If you use it you
are doing so B<AT YOUR OWN RISK>! I may or may not support this
depending on my time schedule...

=head1 AUTHOR

[e-mail]

=head1 COPYRIGHT

Copyright 1999-2000, [e-mail]

This package is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.