view release on metacpan or  search on metacpan

lib/Devel/LeakGuard/Object.pm  view on Meta::CPAN

    no strict 'refs';
    return if $DESTROY_NEXT{$class};

    $DESTROY_NEXT{$class} = {};

    my @stack = ( $class );
    my %seen  = ( UNIVERSAL => 1 );
    my @queue = ();

    while ( my $c = pop @stack ) {
        next if $seen{$c}++;

        my $has_destroy
        = $DESTROY_STUBBED{$c}
        ? exists $DESTROY_ORIGINAL{$c}
        : ( exists ${"${c}::"}{DESTROY} and *{"${c}::DESTROY"}{CODE} );

        if ( $has_destroy ) {
            $DESTROY_NEXT{$class}{$_} = $c for @queue;
            @queue = ();
        }
        else {
            push @queue, $c;
        }

        push @stack, reverse @{"${c}::ISA"};
    }

    $DESTROY_NEXT{$class}{$_} = '' for @queue;
}

=head2 C<status>

Print out a L<Devel::Leak::Object> style summary of current object
allocations. If you

  use Devel::LeakGuard::Object qw( GLOBAL_bless :at_end );

then C<status> will be called at program exit to dump a summary of
outstanding allocations.

=cut

sub status {
    my $fh = $OPTIONS{stderr} ? *STDERR : *STDOUT;
    print $fh "Tracked objects by class:\n";
    for ( sort keys %OBJECT_COUNT ) {
        next unless $OBJECT_COUNT{$_};    # Don't list class with count zero
        print $fh sprintf "%-40s %d\n", $_, $OBJECT_COUNT{$_};
    }
}

END { status() if $OPTIONS{at_end} }

1;

__END__

=head1 DEPENDENCIES

L<List::Util>, L<Scalar::Util>, L<Test::Differences>, L<Test::More>

=head1 SEE ALSO

L<Devel::Leak::Object>

=head1 INCOMPATIBILITIES

None reported.

=head1 BUGS AND LIMITATIONS

Please report any bugs or feature requests via
C<https://github.com/AndyA/Devel--LeakGuard--Object/issues>.

=head1 AUTHOR

Andy Armstrong  C<< <andy@hexten.net> >>

Based on code taken from Adam Kennedy's L<Devel::Leak::Object> which
carries this copyright notice:

  Copyright 2007 Adam Kennedy.

  Rewritten from original copyright 2004 Ivor Williams.

  Some documentation also copyright 2004 Ivor Williams.

=head1 LICENCE AND COPYRIGHT

Copyright (c) 2009-2015, Andy Armstrong C<< <andy@hexten.net> >>.

This module is free software; you can redistribute it and/or
modify it under the same terms as Perl itself. See L<perlartistic>.

=cut

# vim: expandtab shiftwidth=4