#! perl -slw
use strict;
package Devel::MemWatch;
use threads;
use Thread::Queue;
use Win32::API::Prototype;
our %OPTS = (
LINES => 100,
THRESHHOLD => 100 *1024,
FREQUENCY => 2000,
);
sub import {
for ( @_[ 1 .. $#_ ] ) {
my( $key, $value ) = split '=';
$OPTS{ $key } = $value || '1';
}
warn "@{[ %OPTS ]}\n";
}
ApiLink( 'Kernel32', q[
HANDLE GetCurrentProcess( void )
] ) or die $^E;
ApiLink( 'Kernel32', q[
BOOL GetProcessHandleCount( DWORD h, LPDWORD c)]
) or die $^E;
ApiLink( 'PSAPI', q[
BOOL GetProcessMemoryInfo(
HANDLE Process, LPVOID p, DWORD cb
)
] ) or die $^E;
sub getProcessMemoryInfo {
my $hProcess = GetCurrentProcess( [] );
my $buf = pack 'L10', 40, (0) x 9;
my $size = 40;
if( GetProcessMemoryInfo( $hProcess, $buf, $size ) ){
# warn __LINE__;
my( @MemStats ) = unpack( "L10", $buf );
my $memusage = int( $MemStats[3] / 1024 );
my $peak_memusage = int( $MemStats[2] / 1024 );
my $vmsize = int( $MemStats[8] / 1024 );
return wantarray ? ( $memusage, $peak_memusage, $vmsize ) : $memusage;
}
else {
die "GPMI: $^E";
}
}
my $Q;
BEGIN{ $Q = new Thread::Queue }
sub DB::DB {
# warn caller;
my( $package, $file, $line ) = caller;
scalar $Q->dequeue if $Q->pending > $OPTS{ LINES };
$Q->enqueue( "$package $file $line" );
return;
}
sub _dump {
warn $Q->dequeue() . "\n" while $Q->pending;
}
async {
warn "Watchthread started\n";
while( Win32::Sleep( $OPTS{ FREQUENCY } ) ) {
my $mem = getProcessMemoryInfo();
# warn "Watchthread awoke:$mem\n";
if( $mem > $OPTS{ THRESHHOLD } ) {
warn "Memsize: $mem\n";
$OPTS{ THRESHHOLD } *= 2;
_dump()
}
}
}->detach;
1;
####
perl -d:MemWatch=LINES=100,THRESHHOLD=100*1024,FREQUENCY=2000 yourscript.pl
##
##
C:\test>perl -d:MemWatch=FREQUENCY=5000 junk9.pl
FREQUENCY 5000 LINES 100 THRESHHOLD 102400
Watchthread started
Memsize: 103156
main junk9.pl 8
main junk9.pl 9
main junk9.pl 9
main junk9.pl 8
main junk9.pl 9
main junk9.pl 9
...