view release on metacpan or  search on metacpan

lib/Dash/Leak.pm  view on Meta::CPAN

use 5.008008;
use strict;
use warnings;

=head1 NAME

Dash::Leak - Track memory allocation

=cut

our $VERSION = '0.06';

=head1 SYNOPSIS

Quick summary of what the module does.


    BEGIN {
        # enables operation of Dash::Leak, leaksz is a nop without this
        $ENV{DEBUG_MEM} = 1;
    }

    use Dash::Leak;
    
    {
        leaksz "block label";
        # some code, that may leak
    }
    # If your code leaked, you'll be noticed about change
    # of process vsize after leaving block
    
    leaksz "tests begin";
    some_operation($arg);
    leaksz "some_operation", sub {
        warn sprintf "We leaked after some_operation($arg) by %+d kilobytes;", shift
    };
    another_operation();
    leaksz "another_operation";
    # ...

    use Dash::Leak sub { ... }; # Will call this cb for every alloc, instead of warn

=head1 EXPORT

Export of this module is "virtual", by using L<Devel::Declare>.
When C<$ENV{DEBUG_MEM}> is true, it will work, when false, this opcodes will be ignored, like with C<leaksz ... if 0>;

=head1 FUNCTIONS

=head2 leaksz $label, [$cb->($delta)]

Starts tracking current block.
If something changed since last note, notice will be warned.
If callback is passed, it will be invoked instead of warn.

=cut

use Devel::Declare ();
use Guard;

sub sz();

BEGIN {
	if ($^O eq 'freebsd') {
		require BSD::Process;
		*sz = sub () { BSD::Process->new->{size} };
	}
	elsif ($^O eq 'linux') {
		require Proc::ProcessTable;
		*sz = sub () { (map { $_->{size} } grep { $_->{pid} == $$ } @{Proc::ProcessTable->new->table})[0] };
	} else {
		require Win32::Process::Info;
		Win32::Process::Info->import( 'WMI' );

		my $pi = Win32::Process::Info->new;
		$pi->Set( elapsed_in_seconds => 0 );

		*sz = sub () { $pi->GetProcInfo( { no_user_info => 1 }, $$ )->[0]->{PrivatePageCount} };
	}
}

our $cmem = 0;
our $SUBNAME = 'leaksz';
our $idx;
our $OUT = 0;

BEGIN {
	if ($ENV{DEBUG_MEM}) {
		my $debug = $ENV{DEBUG_MEM};
		*DEBUG = sub () { $debug };
	} else {
		*DEBUG = sub () { 0 };
	}
}

our $FIRST;
our %CBS;
sub import{
	my $class = shift;
	my $caller = caller;
	my $cb = shift if @_;
	check("use $class from @{[ (caller)[1,2] ]}",$cb ? $cb : ()) if DEBUG;
	if (DEBUG and $cb) {
		$FIRST ||= $cb;
		$CBS{$caller} = $cb;
	}
	Devel::Declare->setup_for(
		$caller,
		{ $SUBNAME => { const => \&parse } }
	);
	{
		no strict 'refs';
		*{$caller.'::'.$SUBNAME } = sub() { DEBUG };
	}
}

sub check(@) {
	use integer;
	my $cb;
	$cb = pop if @_ > 1 and UNIVERSAL::isa( $_[-1], 'CODE' );
	my $op = "@_";