import Devel::Cycle 1.09 from CPAN

git-cpan-module: Devel::Cycle git-cpan-version: 1.09
rafl · Jun 27, 2009 · 2365659 · 2365659
1 parent 5fcd857
commit 2365659
Show file tree

Hide file tree

Showing 5 changed files with 106 additions and 36 deletions.
diff --git a/Changes b/Changes
@@ -1,4 +1,7 @@
 Revision history for Perl extension Devel::Cycle.
+1.09 Mon Apr 14 12:54:56 EDT 2008
+     	 -Dave Rolsky identified and fixed bug 25360.
+
 1.08 Fri Apr 11 17:55:59 EDT 2008
      	- Peter Brakemeier identified and patched bug in which stringified objects could
            create false positives. Thanks Peter!

diff --git a/META.yml b/META.yml
@@ -1,6 +1,6 @@
 --- #YAML:1.0
 name:                Devel-Cycle
-version:             1.08
+version:             1.09
 abstract:            Find memory cycles in objects
 license:             ~
 author:              
@@ -9,6 +9,7 @@ generated_by:        ExtUtils::MakeMaker version 6.44
 distribution_type:   module
 requires:     
     Scalar::Util:                  0
+    Test::More:                    0
 meta-spec:
     url:     http://module-build.sourceforge.net/META-spec-v1.3.html
     version: 1.3
diff --git a/Makefile.PL b/Makefile.PL
@@ -5,7 +5,9 @@ use ExtUtils::MakeMaker;
 WriteMakefile(
     NAME              => 'Devel::Cycle',
     VERSION_FROM      => 'lib/Devel/Cycle.pm', # finds $VERSION
-    PREREQ_PM         => {'Scalar::Util' => 0}, # e.g., Module::Name => 1.1
+    PREREQ_PM         => {'Scalar::Util' => 0,
+			  'Test::More'   => 0,
+    }, # e.g., Module::Name => 1.1
     ($] >= 5.005 ?     ## Add these new keywords supported since 5.005
       (ABSTRACT_FROM  => 'lib/Devel/Cycle.pm', # retrieve abstract from module
        AUTHOR         => 'Lincoln Stein <lstein@cshl.edu>') : ()),

diff --git a/lib/Devel/Cycle.pm b/lib/Devel/Cycle.pm
@@ -1,5 +1,5 @@
 package Devel::Cycle;
-# $Id: Cycle.pm,v 1.11 2008/04/11 21:57:13 lstein Exp $
+# $Id: Cycle.pm,v 1.12 2008/04/14 17:01:37 lstein Exp $
 
 use 5.006001;
 use strict;
@@ -17,7 +17,7 @@ require Exporter;
 our @ISA = qw(Exporter);
 our @EXPORT = qw(find_cycle find_weakened_cycle);
 our @EXPORT_OK = qw($FORMATTING);
-our $VERSION = '1.08';
+our $VERSION = '1.09';
 our $FORMATTING = 'roasted';
 our $QUIET   = 0;
 
@@ -55,7 +55,7 @@ sub find_weakened_cycle {
       _do_report(++$counter,shift)
     }
   }
-  _find_cycle($ref,{},$callback,1,());
+  _find_cycle($ref,{},$callback,1,{},());
 }
 
 sub find_cycle {
@@ -67,15 +67,15 @@ sub find_cycle {
       _do_report(++$counter,shift)
     }
   }
-  _find_cycle($ref,{},$callback,0,());
+  _find_cycle($ref,{},$callback,0,{},());
 }
 
 sub _find_cycle {
   my $current   = shift;
   my $seenit    = shift;
   my $callback  = shift;
   my $inc_weak_refs = shift;
-  my %complain;
+  my $complain = shift;
   my @report  = @_;
 
   return unless ref $current;
@@ -94,40 +94,82 @@ sub _find_cycle {
   }
   $seenit->{refaddr $current}++;
 
-  my $type = _get_type($current);
+  _find_cycle_dispatch($current,{%$seenit},$callback,$inc_weak_refs,$complain,@report);
+}
 
-  if ($type eq 'SCALAR') {
-     return if !$inc_weak_refs && isweak($current);
-    _find_cycle($$current,{%$seenit},$callback,$inc_weak_refs,
-		(@report,['SCALAR',undef,$current => $$current,$inc_weak_refs?isweak($current):()]));
-  }
+sub _find_cycle_dispatch {
+  my $type = _get_type($_[0]);
+
+  my $sub = do { no strict 'refs'; \&{"_find_cycle_$type"} };
+  die "Invalid type: $type" unless $sub;
+
+  $sub->(@_);
+}
+
+sub _find_cycle_SCALAR {
+  my $current   = shift;
+  my $seenit    = shift;
+  my $callback  = shift;
+  my $inc_weak_refs = shift;
+  my $complain  = shift;
+  my @report  = @_;
 
-  elsif ($type eq 'ARRAY') {
-    for (my $i=0; $i<@$current; $i++) {
-      next if !$inc_weak_refs && isweak($current->[$i]);
-      _find_cycle($current->[$i],{%$seenit},$callback,$inc_weak_refs,
-		  (@report,['ARRAY',$i,$current => $current->[$i],$inc_weak_refs?isweak($current->[$i]):()]));
+  return if !$inc_weak_refs && isweak($current);
+  _find_cycle($$current,{%$seenit},$callback,$inc_weak_refs,$complain,
+              (@report,['SCALAR',undef,$current => $$current,$inc_weak_refs?isweak($current):()]));
+}
+
+sub _find_cycle_ARRAY {
+  my $current   = shift;
+  my $seenit    = shift;
+  my $callback  = shift;
+  my $inc_weak_refs = shift;
+  my $complain  = shift;
+  my @report  = @_;
+
+  for (my $i=0; $i<@$current; $i++) {
+    next if !$inc_weak_refs && isweak($current->[$i]);
+    _find_cycle($current->[$i],{%$seenit},$callback,$inc_weak_refs,$complain,
+                (@report,['ARRAY',$i,$current => $current->[$i],$inc_weak_refs?isweak($current->[$i]):()]));
     }
-  }
-  elsif ($type eq 'HASH') {
-    for my $key (sort keys %$current) {
-       next if !$inc_weak_refs && isweak($current->{$key});
-      _find_cycle($current->{$key},{%$seenit},$callback,$inc_weak_refs,
-		  (@report,['HASH',$key,$current => $current->{$key},$inc_weak_refs?isweak($current->{$key}):()]));
+}
+
+sub _find_cycle_HASH {
+  my $current   = shift;
+  my $seenit    = shift;
+  my $callback  = shift;
+  my $inc_weak_refs = shift;
+  my $complain  = shift;
+  my @report  = @_;
+
+  for my $key (sort keys %$current) {
+    next if !$inc_weak_refs && isweak($current->{$key});
+    _find_cycle($current->{$key},{%$seenit},$callback,$inc_weak_refs,$complain,
+                (@report,['HASH',$key,$current => $current->{$key},$inc_weak_refs?isweak($current->{$key}):()]));
     }
-  }
-  elsif ($type eq 'CODE') {
-    if (HAVE_PADWALKER) {
-      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):()]));
-      }
-    } elsif (!$complain{$current}++ && !$QUIET) {
+}
+
+sub _find_cycle_CODE {
+  my $current   = shift;
+  my $seenit    = shift;
+  my $callback  = shift;
+  my $inc_weak_refs = shift;
+  my $complain  = shift;
+  my @report  = @_;
+
+  unless (HAVE_PADWALKER) {
+    if (!$complain->{$current} && !$QUIET) {
       carp "A code closure was detected in but we cannot check it unless the PadWalker module is installed";
     }
+
+    return;
+  }
+
+  my $closed_vars = PadWalker::closed_over( $current );
+  foreach my $varname ( sort keys %$closed_vars ) {
+    my $value = $closed_vars->{$varname};
+    _find_cycle_dispatch($value,{%$seenit},$callback,$inc_weak_refs,$complain,
+                         (@report,['CODE',$varname,$current => $value]));
   }
 }
 

diff --git a/t/Devel-Cycle.t b/t/Devel-Cycle.t
@@ -5,7 +5,7 @@
 
 # change 'tests => 1' to 'tests => last_test_to_print';
 
-use Test::More tests => 8;
+use Test::More tests => 9;
 use Scalar::Util qw(weaken isweak);
 BEGIN { use_ok('Devel::Cycle') };
 
@@ -64,6 +64,28 @@ $counter = 0;
 find_cycle($a,sub {$counter++});
 is($counter,0,'found no cycles in reference stringified on purpose to create a false alarm');
 
+SKIP:
+{
+    skip 'These tests require PadWalker 1.0+', 1
+        unless Devel::Cycle::HAVE_PADWALKER;
+
+    $counter = 0;
+
+    my %cyclical = ( a => [],
+                     b => {},
+                   );
+    $cyclical{a}[0]   = $cyclical{a};
+    $cyclical{b}{key} = $cyclical{a};
+
+    my @cyclical = [];
+    $cyclical[0] = \@cyclical;
+
+    my $sub = sub { return \@cyclical, \%cyclical; };
+
+    find_cycle($sub,sub {$counter++});
+    is($counter,3,'found three cycles in $cyclical closure');
+}
+
 package foo;
 use overload q("") => sub{ return 1 };  # show false alarm