#! 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 ) : $m
+emusage;
    }
    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;
[download]