Re: Win32::API::Struct problem

Thu, 15 Dec 2005 06:14:20 -0800

Many thanks Bill, I had got into my head the idea that I had to walk thru the proceeses to get to the threads i.e. a hierarchy of threads within processes - whereas as you point out I go straight to the threads via TH32CS_SNAPTHREAD (a flat structure). The code I ended up with follows. Many thanks for your patience, this was my first sight of the Win32 API. 

#===========================================================================
# set first thread for $pid to $hThreadPriority
my $pid = 952;
my $hThreadPriority = 0;
my $retcode;
my $hThreadSnap;
my $hThread;
my $Point;

 use Data::Dumper;
 use strict;
 use Win32::API;

Win32::API->Import( 'Kernel32', q[ DWORD GetLastError( ) ] );

$retcode = Win32::API->Import( 'Kernel32',
       q[ HANDLE CreateToolhelp32Snapshot
      ( DWORD dwFlags, DWORD th32ProcessID ) ] );
print "import CreateToolhelp32Snapshot code $retcode \n";

use constant TH32CS_SNAPTHREAD => 0x4;

$hThreadSnap=CreateToolhelp32Snapshot(TH32CS_SNAPTHREAD, 0);
$retcode = GetLastError();
print "CreateToolhelp32Snapshot error code $retcode \n";
print "hThreadSnap = $hThreadSnap \n";

# typedef for THREADENTRY32
typedef Win32::API::Struct TE32 => qw{
  DWORD dwSize;
  DWORD cntUsage;
  DWORD th32ThreadID;
  DWORD th32OwnerProcessID;
  LONG tpBasePri;
  LONG tpDeltaPri;
  DWORD dwFlags;
  };

$retcode = Win32::API->Import( 'Kernel32',
                   q[ BOOL Thread32First
                   ( HANDLE hSnapshot, LPTE32 lpte)]);
print "import thread32first code $retcode \n";

$Point = Win32::API::Struct->new( 'TE32' );
$Point->{dwSize}=28;

Thread32First($hThreadSnap, $Point);
$retcode = GetLastError();
print "thread32first error $retcode \n";
print "pid = $Point->{th32OwnerProcessID} \n";

$retcode = Win32::API->Import( 'Kernel32',
                   q[ BOOL Thread32Next
                   ( HANDLE hSnapshot, LPTE32 lpte)]);
print "import threadnext code $retcode \n";


until ( $Point->{th32OwnerProcessID} == $pid ) {
         Thread32Next($hThreadSnap, $Point);
         $retcode = GetLastError();
         print "thread32next error $retcode \n";
         print "pid = $Point->{th32OwnerProcessID} \n";
}


$retcode = Win32::API->Import( 'Kernel32', q[HANDLE OpenThread(
               DWORD dwDesiredAccess,
               BOOL bInheritHandle,
               DWORD dwThreadId
               ) ] );
print "import openthread code $retcode \n";

use constant THREAD_SET_INFORMATION => 0x0020;
use constant THREAD_QUERY_INFORMATION => 0x0040;

$hThread = OpenThread(
              THREAD_SET_INFORMATION|THREAD_QUERY_INFORMATION,
              0,
              $Point->{th32ThreadID}
              );
$retcode = GetLastError();
print "openthread error code $retcode \n";

$retcode = Win32::API->Import( 'Kernel32', q[BOOL SetThreadPriority(
               HANDLE hThread,
               int nPriority
               ) ] );
print "import openthread code $retcode \n";

SetThreadPriority(
              $hThread,
              $hThreadPriority
              );
$retcode = GetLastError();
print "setthreadpriority error code $retcode \n";
#========================================================================

$Bill Luebkert wrote:

Try this one:


#!perl --

use strict;
use warnings;

use Data::Dumper; $Data::Dumper::Indent=1; $Data::Dumper::Sortkeys=1;
# print Data::Dumper->Dump([$var], [qw($var)]);
$| = 1; binmode STDOUT; select ((select (STDERR), $| = 1)[0]); binmode STDERR;

# our ($pt0, $timeit); BEGIN { $timeit = 1; }   # time the script
# BEGIN { if ($timeit) { print scalar (localtime), "\n";
#   $pt0 = Win32::GetTickCount (); } }
# END { if ($timeit) { print scalar (localtime);
#   printf " %.3f seconds\n", (Win32::GetTickCount () - $pt0) / 1000; } }

our %A;         # get commandline switches into %A
for (my $ii = 0; $ii < @ARGV; ) {
        last if $ARGV[$ii] =~ /^--$/;
        if ($ARGV[$ii] !~ /^-{1,2}(.*)$/) { $ii++; next; }
        my $arg = $1; splice @ARGV, $ii, 1;
        if ($arg =~ /^([\w]+)=(.*)$/) { exists ($A{$1}) ? ($A{$1} .= "|$2") :
          ($A{$1} = $2); } else { $A{$1}++; }
}

my $debug = $A{d} || 0; print Data::Dumper->Dump([\%A], [qw(\%A)]) if $debug;
my $verbose = $A{v} || 0;

(my $prog = $0) =~ s/^.*[\\\/]//;
my $usage = <<EOD;

Usage: $prog [-d] [-p] [-t]
        -d      debug
        -p      process dump
        -t      thread dump

EOD
die $usage if $A{h} or $A{help};

#- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

use Win32::API;
use Win32::API::Struct;

# HANDLE WINAPI CreateToolhelp32Snapshot(DWORD dwFlags, DWORD th32ProcessID);

Win32::API->Import('kernel32',
  'HANDLE CreateToolhelp32Snapshot(DWORD dwFlags, DWORD th32ProcessID)')
  or die "import CreateToolhelp32Snapshot: $! ($^E)";

use constant TH32CS_SNAPHEAPLIST => 0x1;
use constant TH32CS_SNAPPROCESS => 0x2;
use constant TH32CS_SNAPTHREAD => 0x4;
use constant TH32CS_SNAPMODULE => 0x8;
use constant TH32CS_SNAPALL => TH32CS_SNAPHEAPLIST | TH32CS_SNAPPROCESS |
  TH32CS_SNAPTHREAD | TH32CS_SNAPMODULE;

my $flags = TH32CS_SNAPPROCESS;
$flags = TH32CS_SNAPTHREAD if $A{t};
my $hProcessSnap = CreateToolhelp32Snapshot ($flags, 0);
die "CreateToolhelp32Snapshot: $! ($^E)" if $hProcessSnap == -1;
print Data::Dumper->Dump([$hProcessSnap], [qw($hProcessSnap)]);

use constant ERROR_NO_MORE_FILES => 18;

if ($A{t}) {

#     DWORD  dwSize;
#     DWORD  cntUsage;
#     DWORD  th32ThreadID;
#     DWORD  th32OwnerProcessID;
#     LONG   tpBasePri;
#     LONG   tpDeltaPri;
#     DWORD  dwFlags;

        my $TE32 = pack 'LLLLLLL', 28, 0, 0, 0, 0, 0, 0, 0;
        print Data::Dumper->Dump([$TE32], [qw($TE32)]) if $debug;

#       BOOL WINAPI Thread32First(HANDLE hSnapshot, LPPROCESSENTRY32 lppe);

        Win32::API->Import('kernel32', 'Thread32First', 'IP', 'I') or
          die "import Thread32First: $! ($^E)";

        my $ret = Thread32First ($hProcessSnap, $TE32) or
          die "Thread32First: $! ($^E)";
        my @TE32 = unpack 'LLLLLLL', $TE32;
        formatprint (@TE32);
        print Data::Dumper->Dump([$ret, [EMAIL PROTECTED], [qw($ret [EMAIL 
PROTECTED])]) if $debug;

#       BOOL WINAPI Thread32Next (HANDLE hSnapshot, LPPROCESSENTRY32 lppe);

        Win32::API->Import('kernel32', 'Thread32Next', 'IP', 'I') or
          die "import Thread32Next: $! ($^E)";

        while (1) {

                $TE32 = pack 'LLLLLLL', 28, 0, 0, 0, 0, 0, 0, 0;
                $ret = Thread32Next ($hProcessSnap, $TE32);
                if ($ret == 0) {
                        if (Win32::GetLastError() == ERROR_NO_MORE_FILES) {
                                print "No more files - all is well\n";
                                last;
                        } else {
                                die "Thread32Next: $! ($^E)";
                        }
                }
                my @TE32 = unpack 'LLLLLLL', $TE32;
                formatprint (@TE32);
                print Data::Dumper->Dump([$ret, [EMAIL PROTECTED], [qw($ret 
[EMAIL PROTECTED])]) if
                  $debug;
        }
}

if ($A{p} or not $A{t}) {

#     DWORD   dwSize;
#     DWORD   cntUsage;
#     DWORD   th32ProcessID;
#     DWORD   th32DefaultHeapID;
#     DWORD   th32ModuleID;
#     DWORD   cntThreads;
#     DWORD   th32ParentProcessID;
#     LONG    pcPriClassBase;
#     DWORD   dwFlags;
#     char    szExeFile[260];

        my $PE32 = pack 'LLLLLLLLLZ*', 296, 0, 0, 0, 0, 0, 0, 0, 0,
          ' ' x 259 . "\0";
        print Data::Dumper->Dump([$PE32], [qw($PE32)]) if $debug;

#       BOOL WINAPI Process32First(HANDLE hSnapshot, LPPROCESSENTRY32 lppe);

        Win32::API->Import('kernel32', 'Process32First', 'IP', 'I') or
          die "import Process32First: $! ($^E)";

        my $ret = Process32First ($hProcessSnap, $PE32) or
          die "Process32First: $! ($^E)";
        my @PE32 = unpack 'LLLLLLLLLZ*', $PE32;
        formatprint (@PE32);
        print Data::Dumper->Dump([$ret, [EMAIL PROTECTED], [qw($ret [EMAIL 
PROTECTED])]) if $debug;

#       BOOL WINAPI Process32Next (HANDLE hSnapshot, LPPROCESSENTRY32 lppe);

        Win32::API->Import('kernel32', 'Process32Next', 'IP', 'I') or
          die "import Process32Next: $! ($^E)";

        use constant ERROR_NO_MORE_FILES => 18;

        while (1) {

                my $PE32 = pack 'LLLLLLLLLZ*', 296, 0, 0, 0, 0, 0, 0, 0, 0,
                  ' ' x 259 . "\0";
                $ret = Process32Next ($hProcessSnap, $PE32);
                if ($ret == 0) {
                        if (Win32::GetLastError() == ERROR_NO_MORE_FILES) {
                                print "No more files - all is well\n";
                                last;
                        } else {
                                die "Process32Next: $! ($^E)";
                        }
                }
                my @PE32 = unpack 'LLLLLLLLLZ*', $PE32;
                formatprint (@PE32);
                print Data::Dumper->Dump([$ret, [EMAIL PROTECTED], [qw($ret 
[EMAIL PROTECTED])]) if
                  $debug;
        }
}
print "Done\n";

#- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

sub formatprint {
        
if (@_ == 7) {          # threads
        print "\tdwSize=", $_[0], "\n";
        print "\tcntUsage=", $_[1], "\n";
        print "\tth32ThreadID=", $_[2], "\n";
        print "\tth32OwnerProcessID=", $_[3], "\n";
        print "\ttpBasePri=", $_[4], "\n";
        print "\ttpDeltaPri=", $_[5], "\n";
        print "\tdwFlags=", $_[6], "\n";
        print "\n";
} elsif (@_ == 9) {     # processes
        print "\tdwSize=", $_[0], "\n";
        print "\tcntUsage=", $_[1], "\n";
        print "\tth32ProcessID=", $_[2], "\n";
        print "\tth32DefaultHeapID=", $_[3], "\n";
        print "\tth32ModuleID=", $_[4], "\n";
        print "\tcntThreads=", $_[5], "\n";
        print "\tth32ParentProcessID=", $_[6], "\n";
        print "\tpcPriClassBase=", $_[7], "\n";
        print "\tdwFlags=", $_[8], "\n";
        print "\tszExeFile=", $_[9], "\n";
        print "\n";
}

}

__END__




_______________________________________________
Perl-Win32-Users mailing list
Perl-Win32-Users@listserv.ActiveState.com
To unsubscribe: http://listserv.ActiveState.com/mailman/mysubs

Reply via email to