File Coverage

blib/lib/Internals/CountObjects.pm

Criterion	Covered	Total	%
statement	32	32	100.0
branch	6	6	100.0
condition	3	6	50.0
subroutine	7	7	100.0
pod	1	1	100.0
total	49	52	94.2

package Internals::CountObjects;
BEGIN {
  $Internals::CountObjects::VERSION = '0.05';
}
# ABSTRACT: Report all allocated perl objects

use strict;
use vars qw( @ISA @EXPORT_OK %EXPORT_TAGS );

require XSLoader;
XSLoader::load( __PACKAGE__, $Internals::CountObjects::VERSION );

use Exporter;
@ISA = 'Exporter';
@EXPORT_OK = qw(
    objects
    dump_objects
);
%EXPORT_TAGS = (
    all => \ @EXPORT_OK,
);

# Provided by CountObjects.xs
sub objects;

sub dump_objects {
    local $@;
    return
        $_[0]
            ? _dump_objects_delta( $_[0] )
            : _dump_objects();
}

sub _dump_objects {
    my $objects = objects();
    return
        join '',
            "Memory stats\n",
            map { "=$$= $_: $objects->{$_}\n" }
            sort { $objects->{$b} <=> $objects->{$a} }
            keys %$objects;
}

sub _dump_objects_delta {
    my $prev_objects = $_[0];
    my $objects = objects();

    my %delta;
    @delta{
        keys( %$objects ),
        keys( %$prev_objects ),
    } = ();

    for ( keys %delta ) {
        my $prev = $prev_objects->{$_} || 0;
        my $now  = $objects     ->{$_} || 0;
        $delta{$_} = $now - $prev;
    }

    return
        join '',
            "Memory stats (delta from previous)\n",
            map {
                my $prev = $prev_objects->{$_};
                my $now  = $objects     ->{$_} || 0;
                my $d = $delta{$_};
                if ($d > 0) {
                    $d = "+$d";
                }

                $d
                    ? "=$$= $_: $now ($d)\n"
                    : "=$$= $_: $now\n";
            }
            sort { $delta{$b} <=> $delta{$a} }
            keys %delta;
}

'Insisting on maintaining dignity at all costs is paralyzing. Mistakes are informative, and so is playing the fool'

__END__