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__ |