Hi, Andy, I know you subscribe to perl-qa so I didn't CC.
These two patches add support for detecting cycles in code references, using PadWalker, to Devel::Cycle and Test::Memory::Cycle. Currently this will silently stop working if PadWalker is not installed to keep things tidy - I personally feel that this be a bit louder, but whatever Lincoln feels is best is his own choice. Anyway, have fun. -- Yuval Kogman <[EMAIL PROTECTED]> http://nothingmuch.woobling.org 0xEBD27418
diff -Nur Devel-Cycle-1.04/lib/Devel/Cycle.pm
Devel-Cycle-with_code/lib/Devel/Cycle.pm
--- Devel-Cycle-1.04/lib/Devel/Cycle.pm 2005-04-27 17:40:16.000000000 +0300
+++ Devel-Cycle-with_code/lib/Devel/Cycle.pm 2006-04-24 00:57:11.000000000
+0300
@@ -19,6 +19,11 @@
our $VERSION = '1.04';
our $FORMATTING = 'roasted';
+BEGIN {
+ require constant;
+ constant->import( HAVE_PADWALKER => eval { require PadWalker; 1 } );
+}
+
sub find_weakened_cycle {
my $ref = shift;
my $callback = shift;
@@ -88,6 +93,15 @@
(@report,['HASH',$key,$current =>
$current->{$key},$inc_weak_refs?isweak($current->{$key}):()]));
}
}
+ elsif (HAVE_PADWALKER && $type eq 'CODE') {
+ my $closed_vars = PadWalker::closed_over( $current );
+ foreach my $varname ( sort keys %$closed_vars ) {
+ my $value = $closed_vars->{$varname};
+ next if !$inc_weak_refs && isweak($$value);
+ _find_cycle( $$value,{%$seenit},$callback,$inc_weak_refs,
+ (@report,['CODE',$varname,$current =>
$$value,$inc_weak_refs?isweak($$value):()]));
+ }
+ }
}
sub _do_report {
@@ -118,21 +132,25 @@
return $sygil . ($sygil ? '$' : '$$'). $prefix . $shortname . $suffix if
$type eq 'SCALAR';
return $sygil . ($sygil ? '@' : '$') . $prefix . $shortname . $suffix if
$type eq 'ARRAY';
return $sygil . ($sygil ? '%' : '$') . $prefix . $shortname . $suffix if
$type eq 'HASH';
+ return $sygil . ($sygil ? '&' : '$') . $prefix . $shortname . $suffix if
$type eq 'CODE';
}
}
+# why not Scalar::Util::reftype?
sub _get_type {
my $thingy = shift;
return unless ref $thingy;
return 'SCALAR' if UNIVERSAL::isa($thingy,'SCALAR') ||
UNIVERSAL::isa($thingy,'REF');
return 'ARRAY' if UNIVERSAL::isa($thingy,'ARRAY');
return 'HASH' if UNIVERSAL::isa($thingy,'HASH');
+ return 'CODE' if UNIVERSAL::isa($thingy,'CODE');
}
sub _format_index {
my ($type,$index) = @_;
return "->[$index]" if $type eq 'ARRAY';
return "->{'$index'}" if $type eq 'HASH';
+ return " variable $index" if $type eq 'CODE';
return;
}
diff -Nur Test-Memory-Cycle-1.02/Cycle.pm Test-Memory-Cycle-with_code/Cycle.pm
--- Test-Memory-Cycle-1.02/Cycle.pm 2005-05-17 19:02:39.000000000 +0300
+++ Test-Memory-Cycle-with_code/Cycle.pm 2006-04-24 00:54:16.000000000
+0300
@@ -98,6 +98,7 @@
$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 );
}
@@ -213,6 +214,7 @@
$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++;
}
diff -Nur Test-Memory-Cycle-1.02/lib/Test/Memory/Cycle.pm
Test-Memory-Cycle-with_code/lib/Test/Memory/Cycle.pm
--- Test-Memory-Cycle-1.02/lib/Test/Memory/Cycle.pm 1970-01-01
02:00:00.000000000 +0200
+++ Test-Memory-Cycle-with_code/lib/Test/Memory/Cycle.pm 2006-04-24
00:54:16.000000000 +0300
@@ -0,0 +1,241 @@
+package Test::Memory::Cycle;
+
+=head1 NAME
+
+Test::Memory::Cycle - Check for memory leaks and circular memory references
+
+=head1 VERSION
+
+Version 1.02
+
+=cut
+
+our $VERSION = "1.02";
+
+=head1 SYNOPSIS
+
+Perl's garbage collection has one big problem: Circular references
+can't get cleaned up. A circular reference can be as simple as two
+objects that refer to each other:
+
+ my $mom = {
+ name => "Marilyn Lester",
+ };
+
+ my $me = {
+ name => "Andy Lester",
+ mother => $mom,
+ };
+ $mom->{son} = $me;
+
+C<Test::Memory::Cycle> is built on top of C<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 C<memory_cycle_exists()> to make sure that you have a
+cycle where you expect to have one.
+
+=cut
+
+use strict;
+use warnings;
+
+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(@_);
+}
+
+=head1 FUNCTIONS
+
+=head2 C<memory_cycle_ok( I<$object>, I<$msg> )>
+
+Checks that I<$object> doesn't have any circular memory references.
+
+=cut
+
+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
+
+=head2 C<memory_cycle_exists( I<$object>, I<$msg> )>
+
+Checks that I<$object> B<does> have any circular memory references.
+
+=cut
+
+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
+
+=head2 C<weakened_memory_cycle_ok( I<$object>, I<$msg> )>
+
+Checks that I<$object> doesn't have any circular memory references, but unlike
+C<memory_cycle_ok> this will also check for weakened cycles produced with
+Scalar::Util's C<weaken>.
+
+=cut
+
+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 );
+
+ $str = sprintf(" %s => %s",($is_weakened ?
'w->':'').$refdisp,$valuedisp) if $type eq 'SCALAR';
+ $str = sprintf(" %s => %s",($is_weakened ?
'w->':'')."${refdisp}->[$index]",$valuedisp) if $type eq 'ARRAY';
+ $str = sprintf(" %s => %s",($is_weakened ?
'w->':'')."${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
+
+=head2 C<weakened_memory_cycle_exists( I<$object>, I<$msg> )>
+
+Checks that I<$object> B<does> have any circular memory references, but unlike
+C<memory_cycle_exists> this will also check for weakened cycles produced with
+Scalar::Util's C<weaken>.
+
+=cut
+
+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;
+}
+
+=head1 AUTHOR
+
+Written by Andy Lester, C<< <andy @ petdance.com> >>.
+
+=head1 ACKNOWLEDGEMENTS
+
+Thanks to the contributions of Stevan Little, and to Lincoln Stein for writing
Devel::Cycle.
+
+=head1 COPYRIGHT
+
+Copyright 2005, Andy Lester, All Rights Reserved.
+
+You may use, modify, and distribute this package under the
+same terms as Perl itself.
+
+=cut
+
+1;
diff -Nur Test-Memory-Cycle-1.02/t/family-code.t
Test-Memory-Cycle-with_code/t/family-code.t
--- Test-Memory-Cycle-1.02/t/family-code.t 1970-01-01 02:00:00.000000000
+0200
+++ Test-Memory-Cycle-with_code/t/family-code.t 2006-04-24 00:55:14.000000000
+0300
@@ -0,0 +1,34 @@
+#!perl -T
+
+use strict;
+use warnings FATAL => 'all';
+
+use Scalar::Util qw( weaken );
+
+use Test::More tests => 4;
+#use Test::Builder::Tester; # not used yet
+
+# use ok "Test::Memory::Cycle";
+BEGIN {
+ use_ok( 'Test::Memory::Cycle' );
+}
+
+my $code_refs_parent = { };
+$code_refs_parent->{child} = sub { $code_refs_parent };
+
+my $code_refs_self;
+$code_refs_self = sub { $code_refs_self };
+
+my $code_refs_parent_weak = { };
+$code_refs_parent_weak->{child} = do {
+ my $weak_parent = $code_refs_parent_weak;
+ weaken( $weak_parent );
+ sub { $weak_parent };
+};
+
+memory_cycle_exists( $code_refs_parent, "code refs referencing containers" );
+memory_cycle_exists( $code_refs_self, "code refs referencing themselves" );
+memory_cycle_ok( $code_refs_parent_weak, "code refs with weak refs to
containers" );
+
+# the output can be tested later if someone cares
+
pgpwVvnKjcZCw.pgp
Description: PGP signature
