Re: taking memory snapshots with perl

[PrakashK]

I haven't tested this under mod_perl, but I have used the following in FastCGI environment. It uses the Devel::Leak module.

It does not give you the exact size of the memory allocated, rather gives you a number indicating a count of "things", where things mean scalar values, array and hash values etc. Check the man page for Devel::Leak for more info.

package MemLeak;

use strict;
use vars qw(@ISA @EXPORT_OK);
@ISA = qw(Exporter);
@EXPORT_OK = qw(mlprint mlprintc);

=head1 NAME

MemLeak - Helper functions to track memory leaks

=head1 SYNOPSIS

    use MemLeak qw(mlprint mlprintc);

    mlprint('BEGIN');
    my $a = 5;
    mlprint('after $a');
    my @a = (1..10);
    mlprintc('BEGIN', 'after @a');
    my %a;
    @a{@a} = @a;
    mlprintc('BEGIN', 'after %a');

=cut

use Devel::Leak;

sub _time_now
{
    my ($sec, $min, $hour, $day, $mon, $year) = localtime(time);

    return sprintf "%02d:%02d:%02d %02d/%02d/%02d",
    $hour, $min, $sec, $mon + 1, $day, $year - 100;
}

my $last_count = 0;

my %CHECK_POINTS = (
    _LAST    => 0,
);

sub _get_counts
{
    my ($chkpt) = @_;

    my $handle;
    my $count = Devel::Leak::NoteSV($handle);
    my $delta = $count - $CHECK_POINTS{_LAST};
    $CHECK_POINTS{_LAST} = $count;

    my $delta_cp;
    if ($chkpt) {
    if (exists $CHECK_POINTS{$chkpt}) {
        $delta_cp = $count - $CHECK_POINTS{$chkpt};
        delete $CHECK_POINTS{$chkpt};
    } else {
        $CHECK_POINTS{$chkpt} = $count;
    }
    }

    return ($count, $delta, $delta_cp);
}

=head1 DESCRIPTION

=head2 mlprint(@args)

    print current SV count and change since last count

=cut

sub mlprint
{
    my (@args) = @_;

    my ($count, $delta) = _get_counts;

    my $msg = join "", @args;
    chomp $msg if $msg;

    warn sprintf "[%d - %s] SV# = %d (%+d); %s\n",
        $$, _time_now, $count, $delta, $msg;
}

=pod

=head2 mlprintc($chkpt, @args)

    print current SV count and changes since last count
    and since the checkpoint specified

=cut

sub mlprintc
{
    my ($check_pt, @args) = @_;

    my ($count, $delta, $delta_cp) = _get_counts($check_pt);

    my $msg = join "", @args;
    chomp $msg if $msg;

    if (defined $delta_cp) {
    warn sprintf "[%d - %s] SV# = %d (%+d/%s: %+d); %s\n",
        $$, _time_now, $count, $delta, $check_pt, $delta_cp, $msg;
    } else {
    warn sprintf "[%d - %s] SV# = %d (%+d); %s: %s\n",
        $$, _time_now, $count, $delta, $check_pt, $msg;
    }
}

1;

Here's the output of the test snippet shown under SYNOPSIS above (on my debian GNU/Linux system):

[32134 - 13:56:14 03/21/02] SV# = 4418 (+4418); BEGIN
[32134 - 13:56:14 03/21/02] SV# = 4418 (+0); after $a
[32134 - 13:56:14 03/21/02] SV# = 4428 (+10); BEGIN: after @a
[32134 - 13:56:14 03/21/02] SV# = 4439 (+11/BEGIN: +11); after %a

Add calls to mlprint and mlprintc at strategic places in your code to find out where memory is being allocated most.

HTH,
/prakash