find_leaked_refs.pl

#!perl

my $lol = bless { string => "test_string" };
$lol->{cycle}{reference}[0] = $lol;

my $lol1 = bless [];
$lol1->[0]{yet}{another}{cycle}{reference} = $lol1;

use strict;
require Devel::Gladiator;
my $all = Devel::Gladiator::walk_arena();
if ($all) {
    require B;
    require Devel::Cycle;
    *B::SV::blessed = sub {
        return $_[0]->FLAGS & 0x00100000;    #SVs_OBJECT;
    };
}

foreach my $sv (@$all) {
    my $obj = B::svref_2object($sv);

    if ( ( ref $obj eq 'B::HV' ) ) {

        #next if ref $obj eq 'B::HV' && $obj->NAME;
        #if has a name, this object is STASH e.g: main:: $obj->NAME
        if ( $obj->blessed ) {
            run($sv);
        }
    }
    elsif ( ref $obj eq 'B::AV' ) {
        if ( $obj->blessed ) {
            run($sv);
        }
    }
}

sub run {
    my $sv = shift;
    Devel::Cycle::find_cycle(
        $sv,
        get_processor(
            sub {
                printf("First SV: %s, Second SV %s, text_path: %s\n", @_);
            }
        )
    );
}

sub get_processor {
    my $cb = shift;
    return sub {
        leaked_scalars_info( @_, $cb );
    };
}

sub leaked_scalars_info {

    #[['REFTYPE',$index,$reference,$reference_value]]
    my @scalars_array = @{ +shift };
    my $info_cb       = shift;
    my $pos           = 0;
    my $first_sv;
    my $second_sv;
    my $text_path;
    foreach my $sv (@scalars_array) {
        my ( $ref_type, $index_or_key, $reference, $reference_value ) = @$sv;
        if ( $ref_type eq 'HASH' ) {
            $text_path .= "{'$index_or_key'}";
        }
        elsif ( $ref_type eq 'ARRAY' ) {
            $text_path .= "[$index_or_key]";
        }
        else {
            warn 'Non processed reference: ' . $ref_type;
        }

        if ( $pos == 0 ) {
            $first_sv = $reference;
        }
        if ( $pos == $#scalars_array ) {
            $second_sv = $reference_value;
        }

        $pos++;
    }

    $info_cb->( $first_sv, $second_sv, $text_path );
}

warn "Live objects count: " . scalar @$all;
@$all = ();
__DATA__
call Perl_do_sv_dump(Perl_get_context(),0,Perl_PerlIO_stderr(Perl_get_context()),(SV*)0x7fd688229f70,0,4,0,0)