File Coverage

blib/lib/Algorithm/C3.pm
Criterion Covered Total %
statement 69 69 100.0
branch 30 30 100.0
condition 16 16 100.0
subroutine 4 4 100.0
pod 1 1 100.0
total 120 120 100.0


line stmt bran cond sub pod time code
1              
2             package Algorithm::C3;
3              
4 12     12   247031 use strict;
  12         30  
  12         419  
5 12     12   55 use warnings;
  12         21  
  12         423  
6              
7 12     12   78 use Carp 'confess';
  12         50  
  12         8658  
8              
9             our $VERSION = '0.10';
10              
11             sub merge {
12 66     66 1 5223 my ($root, $parent_fetcher, $cache) = @_;
13              
14 66   100     235 $cache ||= {};
15              
16 66         71 my @STACK; # stack for simulating recursion
17              
18 66         119 my $pfetcher_is_coderef = ref($parent_fetcher) eq 'CODE';
19              
20 66 100 100     331 unless ($pfetcher_is_coderef or $root->can($parent_fetcher)) {
21 1         205 confess "Could not find method $parent_fetcher in $root";
22             }
23              
24 65         76 my $current_root = $root;
25 65         161 my $current_parents = [ $root->$parent_fetcher ];
26 65         422 my $recurse_mergeout = [];
27 65         77 my $i = 0;
28 65         128 my %seen = ( $root => 1 );
29              
30 65         76 my ($new_root, $mergeout, %tails);
31 65         66 while(1) {
32 794 100       1451 if($i < @$current_parents) {
33 387         570 $new_root = $current_parents->[$i++];
34              
35 387 100       705 if($seen{$new_root}) {
36 8         11 my @isastack;
37             my $reached;
38 8         26 for(my $i = 0; $i < $#STACK; $i += 4) {
39 27 100 100     100 if($reached || ($reached = ($STACK[$i] eq $new_root))) {
40 14         34 push(@isastack, $STACK[$i]);
41             }
42             }
43 8         16 my $isastack = join(q{ -> }, @isastack, $current_root, $new_root);
44 8         167 die "Infinite loop detected in parents of '$root': $isastack";
45             }
46 379         462 $seen{$new_root} = 1;
47              
48 379 100 100     946 unless ($pfetcher_is_coderef or $new_root->can($parent_fetcher)) {
49 1         145 confess "Could not find method $parent_fetcher in $new_root";
50             }
51              
52 378         527 push(@STACK, $current_root, $current_parents, $recurse_mergeout, $i);
53              
54 378         373 $current_root = $new_root;
55 378   100     1194 $current_parents = $cache->{pfetch}->{$current_root} ||= [ $current_root->$parent_fetcher ];
56 378         1465 $recurse_mergeout = [];
57 378         385 $i = 0;
58 378         377 next;
59             }
60              
61 407         452 $seen{$current_root} = 0;
62              
63 407   100     962 $mergeout = $cache->{merge}->{$current_root} ||= do {
64              
65             # This do-block is the code formerly known as the function
66             # that was a perl-port of the python code at
67             # http://www.python.org/2.3/mro.html :)
68              
69             # Initial set (make sure everything is copied - it will be modded)
70 221         412 my @seqs = map { [@$_] } @$recurse_mergeout;
  210         482  
71 221 100       498 push(@seqs, [@$current_parents]) if @$current_parents;
72              
73             # Construct the tail-checking hash (actually, it's cheaper and still
74             # correct to re-use it throughout this function)
75 221         307 foreach my $seq (@seqs) {
76 339         1062 $tails{$seq->[$_]}++ for (1..$#$seq);
77             }
78              
79 221         359 my @res = ( $current_root );
80 221         219 while (1) {
81 750         651 my $cand;
82             my $winner;
83 750         882 foreach (@seqs) {
84 1879 100       2944 next if !@$_;
85 1129 100       1852 if(!$winner) { # looking for a winner
    100          
86 601         670 $cand = $_->[0]; # seq head is candidate
87 601 100       1060 next if $tails{$cand}; # he loses if in %tails
88              
89             # Handy warn to give a output like the ones on
90             # http://www.python.org/download/releases/2.3/mro/
91             #warn " = " . join(' + ', @res) . " + merge([" . join('] [', map { join(', ', @$_) } grep { @$_ } @seqs) . "])\n";
92 529         612 push @res => $winner = $cand;
93 529         587 shift @$_; # strip off our winner
94 529 100       1120 $tails{$_->[0]}-- if @$_; # keep %tails sane
95             }
96             elsif($_->[0] eq $winner) {
97 296         838 shift @$_; # strip off our winner
98 296 100       697 $tails{$_->[0]}-- if @$_; # keep %tails sane
99             }
100             }
101              
102             # Handy warn to give a output like the ones on
103             # http://www.python.org/download/releases/2.3/mro/
104             #warn " = " . join(' + ', @res) . "\n" if !$cand;
105              
106 750 100       1382 last if !$cand;
107 530 100       862 die q{Inconsistent hierarchy found while merging '}
108             . $current_root . qq{':\n\t}
109             . qq{current merge results [\n\t\t}
110             . (join ",\n\t\t" => @res)
111             . qq{\n\t]\n\t} . qq{merging failed on '$cand'\n}
112             if !$winner;
113             }
114 220         663 \@res;
115             };
116              
117 406 100       1238 return @$mergeout if !@STACK;
118              
119 351         368 $i = pop(@STACK);
120 351         350 $recurse_mergeout = pop(@STACK);
121 351         412 $current_parents = pop(@STACK);
122 351         347 $current_root = pop(@STACK);
123              
124 351         444 push(@$recurse_mergeout, $mergeout);
125             }
126             }
127              
128             1;
129              
130             __END__