MemProfile.pm

gistfile1.txt

package Devel::MemProfile;
use strict;
use warnings;
use utf8;
use 5.010_001;
use Devel::Symdump;
use B::Size2::Terse;

sub new {
    my $class = shift;

    my @packages = Devel::Symdump->rnew("main")->packages;
    my $size;

    for my $package ("main", @packages) {
        my($subs, $opcount, $opsize) = B::Size2::Terse::package_size($package);
        $size->{$package} = $opsize;
    }
    return bless $size, $class;
}

sub diff {
    my ($self, $after) = @_;
    $after ||= $self->new();

    my $diff = {};
    for my $pkg (keys %$after) {
        $diff->{$pkg} = $after->{$pkg} - ($self->{$pkg} || 0);
    }
    return $diff;
}

sub dump_diff {
    my ($self, $after, $opts) = @_;
    $after ||= $self->new();
    my $diff = $self->diff($after);
    $opts->{order} ||= 'diff';
    my $out = *STDERR || $opts->{out};

    my @pkgs = keys %$after;
    if ($opts->{order} eq 'after') {
        @pkgs = sort { $after->{$b} <=> $after->{$a}} @pkgs;
    } elsif ($opts->{order} eq 'diff') {
        @pkgs = sort { $diff->{$b} <=> $diff->{$a}} @pkgs;
    } else {
        die "Unknown sort order: '$opts->{order}'";
    }

    print STDERR sprintf(
        "%-32s %8s = %8s - %8s [KB]\n",
        'pkg', 'diff', 'after', 'before',
    );
    my $i = 0;
    for my $pkg (@pkgs) {
        if ($opts->{skip_zero} && $opts->{order} eq 'diff' && $diff->{$pkg} == 0) {
            last;
        }

        print STDERR sprintf(
            "%-32s %8d = %8d - %8d [KB]\n",
            _abbr($pkg, 32),
            $diff->{$pkg} / 1024,
            ($after->{$pkg}||0) / 1024,
            ($self->{$pkg}||0) / 1024,
        );
        $i++;
        last if defined($opts->{limit}) && $i >= $opts->{limit};
    }
}

sub dump {
    my ($self, $opts) = @_;
    $opts->{order} ||= 'diff';
    my $out = *STDERR || $opts->{out};

    my @pkgs = keys %$self;
    @pkgs = sort { $self->{$b} <=> $self->{$a}} @pkgs;

    print STDERR sprintf(
        "%-32s %8s [KB]\n",
        'Pakcage', 'memory',
    );
    my $i = 0;
    for my $pkg (@pkgs) {
        print STDERR sprintf(
            "%-32s %8d [KB]\n",
            _abbr($pkg, 32),
            $self->{$pkg} / 1024,
        );
        $i++;
        last if defined($opts->{limit}) && $i >= $opts->{limit};
    }
}

sub _abbr {
    my ($pkg, $len) = @_;
    if (length($pkg) > $len) {
        if ($pkg =~ /\A(.*)::(.*?)\z/) {
            my ($prefix, $moniker) = ($1, $2);
            $prefix =~ s/([^:])([^:]+)/$1/g;
            return substr($prefix . "::" . $moniker, 0, $len);
        } else {
            return substr($pkg, 0, $len);
        }
    } else {
        return $pkg;
    }
}

1;