Test::Memory::Cycle - Check for memory leaks and circular memory references

Test-Memory-Cycle documentation Contained in the Test-Memory-Cycle distribution.

Index

Code Index:

NAME

Top

Test::Memory::Cycle - Check for memory leaks and circular memory references

VERSION

Top

Version 1.04

SYNOPSIS

Top

Perl's garbage collection has one big problem: Circular references can't get cleaned up. A circular reference can be as simple as two reference that refer to each other:

    my $mom = {
        name => "Marilyn Lester",
    };

    my $me = {
        name => "Andy Lester",
        mother => $mom,
    };
    $mom->{son} = $me;

Test::Memory::Cycle is built on top of Devel::Cycle to give you an easy way to check for these circular references.

    use Test::Memory::Cycle;

    my $object = new MyObject;
    # Do stuff with the object.
    memory_cycle_ok( $object );

You can also use memory_cycle_exists() to make sure that you have a cycle where you expect to have one.

FUNCTIONS

Top

memory_cycle_ok( $reference, $msg )

Checks that $reference doesn't have any circular memory references.

memory_cycle_exists( $reference, $msg )

Checks that $reference does have any circular memory references.

weakened_memory_cycle_ok( $reference, $msg )

Checks that $reference doesn't have any circular memory references, but unlike memory_cycle_ok this will also check for weakened cycles produced with Scalar::Util's weaken.

weakened_memory_cycle_exists( $reference, $msg )

Checks that $reference does have any circular memory references, but unlike memory_cycle_exists this will also check for weakened cycles produced with Scalar::Util's weaken.

AUTHOR

Top

Written by Andy Lester, <andy @ petdance.com>.

BUGS

Top

Please report any bugs or feature requests to bug-test-memory-cycle at rt.cpan.org, or through the web interface at http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Memory-Cycle. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.

SUPPORT

Top

You can find documentation for this module with the perldoc command.

    perldoc Test::Memory::Cycle

You can also look for information at:

* AnnoCPAN: Annotated CPAN documentation

http://annocpan.org/dist/Test-Memory-Cycle

* CPAN Ratings

http://cpanratings.perl.org/d/Test-Memory-Cycle

* RT: CPAN's request tracker

http://rt.cpan.org/NoAuth/Bugs.html?Dist=Test-Memory-Cycle

* Search CPAN

http://search.cpan.org/dist/Test-Memory-Cycle

ACKNOWLEDGEMENTS

Top

Thanks to the contributions of Stevan Little, and to Lincoln Stein for writing Devel::Cycle.

COPYRIGHT

Top

Copyright 2006, Andy Lester, All Rights Reserved.

You may use, modify, and distribute this package under the same terms as Perl itself.

Test-Memory-Cycle documentation Contained in the Test-Memory-Cycle distribution. 
package Test::Memory::Cycle;

use strict;
use warnings;


our $VERSION = '1.04';


use Devel::Cycle qw( find_cycle find_weakened_cycle );
use Test::Builder;

my $Test = Test::Builder->new;

sub import {
    my $self = shift;
    my $caller = caller;
    no strict 'refs';
    *{$caller.'::memory_cycle_ok'}              = \&memory_cycle_ok;
    *{$caller.'::memory_cycle_exists'}          = \&memory_cycle_exists;

    *{$caller.'::weakened_memory_cycle_ok'}     = \&weakened_memory_cycle_ok;
    *{$caller.'::weakened_memory_cycle_exists'} = \&weakened_memory_cycle_exists;
    *{$caller.'::memory_cycle_exists'}          = \&memory_cycle_exists;

    *{$caller.'::weakened_memory_cycle_ok'}     = \&weakened_memory_cycle_ok;
    *{$caller.'::weakened_memory_cycle_exists'} = \&weakened_memory_cycle_exists;

    $Test->exported_to($caller);
    $Test->plan(@_);

    return;
}


sub memory_cycle_ok {
    my $ref = shift;
    my $msg = shift;

    my $cycle_no = 0;
    my @diags;

    # Callback function that is called once for each memory cycle found.
    my $callback = sub {
        my $path = shift;
        $cycle_no++;
        push( @diags, "Cycle #$cycle_no" );
        foreach (@$path) {
            my ($type,$index,$ref,$value) = @$_;

            my $str = 'Unknown! This should never happen!';
            my $refdisp = _ref_shortname( $ref );
            my $valuedisp = _ref_shortname( $value );

            $str = sprintf( '    %s => %s', $refdisp, $valuedisp )               if $type eq 'SCALAR';
            $str = sprintf( '    %s => %s', "${refdisp}->[$index]", $valuedisp ) if $type eq 'ARRAY';
            $str = sprintf( '    %s => %s', "${refdisp}->{$index}", $valuedisp ) if $type eq 'HASH';
            $str = sprintf( '    closure %s => %s', "${refdisp}, $index", $valuedisp ) if $type eq 'CODE';

            push( @diags, $str );
        }
    };

    find_cycle( $ref, $callback );
    my $ok = !$cycle_no;
    $Test->ok( $ok, $msg );
    $Test->diag( join( "\n", @diags, '' ) ) unless $ok;

    return $ok;
} # memory_cycle_ok


sub memory_cycle_exists {
    my $ref = shift;
    my $msg = shift;

    my $cycle_no = 0;

    # Callback function that is called once for each memory cycle found.
    my $callback = sub { $cycle_no++ };

    find_cycle( $ref, $callback );
    my $ok = $cycle_no;
    $Test->ok( $ok, $msg );

    return $ok;
} # memory_cycle_exists


sub weakened_memory_cycle_ok {
    my $ref = shift;
    my $msg = shift;

    my $cycle_no = 0;
    my @diags;

    # Callback function that is called once for each memory cycle found.
    my $callback = sub {
        my $path = shift;
        $cycle_no++;
        push( @diags, "Cycle #$cycle_no" );
        foreach (@$path) {
            my ($type,$index,$ref,$value,$is_weakened) = @$_;

            my $str = "Unknown! This should never happen!";
            my $refdisp = _ref_shortname( $ref );
            my $valuedisp = _ref_shortname( $value );
            my $weak = $is_weakened ? 'w->' : '';

            $str = sprintf( '    %s%s => %s', $weak, $refdisp, $valuedisp )               if $type eq 'SCALAR';
            $str = sprintf( '    %s%s => %s', $weak, "${refdisp}->[$index]", $valuedisp ) if $type eq 'ARRAY';
            $str = sprintf( '    %s%s => %s', $weak, "${refdisp}->{$index}", $valuedisp ) if $type eq 'HASH';

            push( @diags, $str );
        }
    };

    find_weakened_cycle( $ref, $callback );
    my $ok = !$cycle_no;
    $Test->ok( $ok, $msg );
    $Test->diag( join( "\n", @diags, "" ) ) unless $ok;

    return $ok;
} # weakened_memory_cycle_ok


sub weakened_memory_cycle_exists {
    my $ref = shift;
    my $msg = shift;

    my $cycle_no = 0;

    # Callback function that is called once for each memory cycle found.
    my $callback = sub { $cycle_no++ };

    find_weakened_cycle( $ref, $callback );
    my $ok = $cycle_no;
    $Test->ok( $ok, $msg );

    return $ok;
} # weakened_memory_cycle_exists


my %shortnames;
my $new_shortname = "A";

sub _ref_shortname {
    my $ref = shift;
    my $refstr = "$ref";
    my $refdisp = $shortnames{ $refstr };
    if ( !$refdisp ) {
        my $sigil = ref($ref) . " ";
        $sigil = '%' if $sigil eq "HASH ";
        $sigil = '@' if $sigil eq "ARRAY ";
        $sigil = '$' if $sigil eq "REF ";
        $sigil = '&' if $sigil eq "CODE ";
        $refdisp = $shortnames{ $refstr } = $sigil . $new_shortname++;
    }

    return $refdisp;
}


1;