culled a dead branch, Devel::Cover back to 100%, 0.07 released

[gitmo/Algorithm-C3.git] / lib / Algorithm / C3.pm

diff --git a/lib/Algorithm/C3.pm b/lib/Algorithm/C3.pm
index be88dc5..cc3b856 100644 (file)
--- a/lib/Algorithm/C3.pm
+++ b/lib/Algorithm/C3.pm
@@ -6,13 +6,14 @@ use warnings;
 
 use Carp 'confess';
 
-our $VERSION = '0.05';
+our $VERSION = '0.07';
 
 sub merge {
     my ($root, $parent_fetcher, $cache) = @_;
 
     $cache ||= {};
-    my @STACK;  # stack for simulating recursion
+
+    my @STACK; # stack for simulating recursion
 
     my $pfetcher_is_coderef = ref($parent_fetcher) eq 'CODE';
 
@@ -24,21 +25,31 @@ sub merge {
     my $current_parents = [ $root->$parent_fetcher ];
     my $recurse_mergeout = [];
     my $i = 0;
+    my %seen = ( $root => 1 );
 
+    my ($new_root, $mergeout, %tails);
     while(1) {
         if($i < @$current_parents) {
-            my $new_root = $current_parents->[$i++];
+            $new_root = $current_parents->[$i++];
+
+            if($seen{$new_root}) {
+                my @isastack;
+                my $reached;
+                for(my $i = 0; $i < $#STACK; $i += 4) {
+                    if($reached || ($reached = ($STACK[$i] eq $new_root))) {
+                        push(@isastack, $STACK[$i]);
+                    }
+                }
+                my $isastack = join(q{ -> }, @isastack, $current_root, $new_root);
+                die "Infinite loop detected in parents of '$root': $isastack";
+            }
+            $seen{$new_root} = 1;
 
             unless ($pfetcher_is_coderef or $new_root->can($parent_fetcher)) {
                 confess "Could not find method $parent_fetcher in $new_root";
             }
 
-            push(@STACK, [
-                $current_root,
-                $current_parents,
-                $recurse_mergeout,
-                $i,
-            ]);
+            push(@STACK, $current_root, $current_parents, $recurse_mergeout, $i);
 
             $current_root = $new_root;
             $current_parents = $cache->{pfetch}->{$current_root} ||= [ $current_root->$parent_fetcher ];
@@ -47,19 +58,22 @@ sub merge {
             next;
         }
 
-        my $mergeout = $cache->{merge}->{$current_root} ||= do {
+        $seen{$current_root} = 0;
+
+        $mergeout = $cache->{merge}->{$current_root} ||= do {
 
             # This do-block is the code formerly known as the function
             # that was a perl-port of the python code at
             # http://www.python.org/2.3/mro.html :)
 
             # Initial set (make sure everything is copied - it will be modded)
-            my @seqs = map { [@$_] } (@$recurse_mergeout, $current_parents);
+            my @seqs = map { [@$_] } @$recurse_mergeout;
+            push(@seqs, [@$current_parents]) if @$current_parents;
 
-            # Construct the tail-checking hash
-            my %tails;
+            # Construct the tail-checking hash (actually, it's cheaper and still
+            #   correct to re-use it throughout this function)
             foreach my $seq (@seqs) {
-                $tails{$_}++ for (@$seq[1..$#$seq]);
+                $tails{$seq->[$_]}++ for (1..$#$seq);
             }
 
             my @res = ( $current_root );
@@ -71,13 +85,24 @@ sub merge {
                     if(!$winner) {              # looking for a winner
                         $cand = $_->[0];        # seq head is candidate
                         next if $tails{$cand};  # he loses if in %tails
+                        
+                        # Handy warn to give a output like the ones on
+                        # http://www.python.org/download/releases/2.3/mro/
+                        #warn " = " . join(' + ', @res) . "  + merge([" . join('] [',  map { join(', ', @$_) } grep { @$_ } @seqs) . "])\n";
                         push @res => $winner = $cand;
+                        shift @$_;                # strip off our winner
+                        $tails{$_->[0]}-- if @$_; # keep %tails sane
                     }
-                    if($_->[0] eq $winner) {
+                    elsif($_->[0] eq $winner) {
                         shift @$_;                # strip off our winner
                         $tails{$_->[0]}-- if @$_; # keep %tails sane
                     }
                 }
+                
+                # Handy warn to give a output like the ones on
+                # http://www.python.org/download/releases/2.3/mro/
+                #warn " = " . join(' + ', @res) . "\n" if !$cand; 
+                
                 last if !$cand;
                 die q{Inconsistent hierarchy found while merging '}
                     . $current_root . qq{':\n\t}
@@ -91,8 +116,10 @@ sub merge {
 
         return @$mergeout if !@STACK;
 
-        ($current_root, $current_parents, $recurse_mergeout, $i)
-            = @{pop @STACK};
+        $i = pop(@STACK);
+        $recurse_mergeout = pop(@STACK);
+        $current_parents = pop(@STACK);
+        $current_root = pop(@STACK);
 
         push(@$recurse_mergeout, $mergeout);
     }