view release on metacpan or  search on metacpan

lib/Plack/Middleware/Debug/RefCounts.pm  view on Meta::CPAN

#pod     \%diff_list = $self->calculate_arena_refs;
#pod
#pod Walks the arena (of Perl variables) via L<Devel::Gladiator/walk_arena>, and
#pod catalogs all non-SCALAR/REFs into ref types and memory locations.  Returns a
#pod diff list hashref.
#pod
#pod I<After> the first (initializing) run, if L</PLACK_MW_DEBUG_REFCOUNTS_DUMP_RE>
#pod is set, newly discovered matching variables will be dumped to C<STDERR>.
#pod
#pod =cut

sub calculate_arena_refs {
    my $self    = shift;
    my $dump_re = $PLACK_MW_DEBUG_REFCOUNTS_DUMP_RE;

    # To save on memory with this memory-intensive operation, we operate against
    # $Arena_Ref as the sole storage mechanism for variable type/addresses.  The $all
    # variable has the arena, but it's strictly a pointer without any memory usage.

    $dump_re = undef unless %$Arena_Refs;  # don't dump the first run

    # refs start out "deleted", until they are found again
    $Arena_Refs->{$_} = -1 for keys %$Arena_Refs;

    # This creates string address lists of all of the existing arena variables.
    # This is much cleaner and memory-friendly than storing real refs.
    my $all = Devel::Gladiator::walk_arena();
    foreach my $it (@$all) {
        my $type = ref $it;

        # There are so many of these that even cataloging the memory addresses
        # of these is enough to cause an OOM in some systems.
        next if $type eq 'SCALAR' || $type eq 'REF';

        # Get the pointer address
        my $addr = sprintf '%x', refaddr $it;
        my $id   = "$type/$addr";

        unless ($Arena_Refs->{$id}) {
            # New ref
            if ($dump_re && $type =~ /$dump_re/) {
                # Sometimes this dies. If so, just move on to the next one.
                eval {
                    local $Data::Dumper::Maxdepth = 2;
                    print STDERR "+$id = ".Dumper($it);
                };
                if ($@) {
                    print STDERR "+$id > ERROR: $@";
                }
            }
        }
        # either equalize to 0 for an existing ref, or go to 1 for a new one
        $Arena_Refs->{$id}++;

        $it = undef;
    }
    $all = undef;

    my %diff_list;
    foreach my $id (keys %$Arena_Refs) {
        my ($type, $addr) = split m!/!, $id, 2;
        my $cmp = $Arena_Refs->{$id};

        # Process the diff list
        $diff_list{$type}   //= [0,0,0];
        $diff_list{$type}[0] += $cmp;              # diff
        $diff_list{$type}[1]++ unless $cmp ==  1;  # count_a
        $diff_list{$type}[2]++ unless $cmp == -1;  # count_b

        # Also dump the removed refs, if requested
        if ($dump_re && $type =~ /$dump_re/ && $cmp == -1) {
            say STDERR "-$id";
        }

        # Remove any deleted references
        delete $Arena_Refs->{$id} if $cmp == -1;
    }

    say STDERR '' if $dump_re;

    return \%diff_list;
}

#pod =head2 compare_arena_counts
#pod
#pod     @lines = $self->compare_arena_counts(\%diff_list);
#pod
#pod Using a diff list from L</calculate_arena_refs>, this displays the new ref
#pod counts on STDERR, and returns those displayed lines.
#pod
#pod Anything listed here has either shrunk or grown the variables within the arena.
#pod
#pod Example output:
#pod
#pod     === Reference growth counts ===
#pod     +4    (diff) =>       4 (now) => Class::MOP::Class::Immutable::Moose::Meta::Class
#pod     +1    (diff) =>       1 (now) => Class::MOP::Method::Wrapped
#pod     +12   (diff) =>      19 (now) => DBD::mysql::st_mem
#pod     +24   (diff) =>      38 (now) => DBI::st
#pod     +1    (diff) =>       1 (now) => Data::Visitor::Callback
#pod     +4    (diff) =>       4 (now) => DateTime
#pod     +1    (diff) =>       1 (now) => DateTime::TimeZone::America::New_York
#pod     +1    (diff) =>       1 (now) => Devel::StackTrace
#pod     +1    (diff) =>       1 (now) => FCGI
#pod     +3    (diff) =>       3 (now) => FCGI::Stream
#pod
#pod =cut

sub compare_arena_counts {
    my ($self, $diff_list) = @_;

    my @lines = ( "=== Reference growth counts ===\n" );

    foreach my $key (sort keys %$diff_list) {
        my ($diff, $count_a, $count_b) = @{ $diff_list->{$key} };

        next unless $diff;
        push @lines, sprintf "%+-5d (diff) => %7d (now) => %-s\n", $diff, $count_b, $key;
    }

    print STDERR $_ for @lines, "\n";