use Carp 'confess';
-our $VERSION = '0.02';
+our $VERSION = '0.07';
sub merge {
- my ($root, $parent_fetcher) = @_;
+ my ($root, $parent_fetcher, $cache) = @_;
- my @STACK; # stack for simulating recursion
- my %fcache; # cache of _fetcher results
- my %mcache; # cache of merge do-block results
+ $cache ||= {};
+
+ my @STACK; # stack for simulating recursion
my $pfetcher_is_coderef = ref($parent_fetcher) eq 'CODE';
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 = $fcache{$current_root} ||= [ $current_root->$parent_fetcher ];
+ $current_parents = $cache->{pfetch}->{$current_root} ||= [ $current_root->$parent_fetcher ];
$recurse_mergeout = [];
$i = 0;
next;
}
- my $mergeout = $mcache{$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
- my @seqs = ([$current_root], @$recurse_mergeout, $current_parents);
+ # Initial set (make sure everything is copied - it will be modded)
+ 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;
+ my @res = ( $current_root );
while (1) {
my $cand;
my $winner;
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}
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);
}
=over 4
-=item B<merge ($root, $func_to_fetch_parent)>
+=item B<merge ($root, $func_to_fetch_parent, $cache)>
This takes a C<$root> node, which can be anything really it
is up to you. Then it takes a C<$func_to_fetch_parent> which
for C<merge> to extract the parents of C<$root>. This is
needed for C3 to be able to do it's work.
+The C<$cache> parameter is an entirely optional performance
+measure, and should not change behavior.
+
+If supplied, it should be a hashref that merge can use as a
+private cache between runs to speed things up. Generally
+speaking, if you will be calling merge many times on related
+things, and the parent fetching function will return constant
+results given the same arguments during all of these calls,
+you can and should reuse the same shared cache hash for all
+of the calls. Example:
+
+ sub do_some_merging {
+ my %merge_cache;
+ my @foo_mro = Algorithm::C3::Merge('Foo', \&get_supers, \%merge_cache);
+ my @bar_mro = Algorithm::C3::Merge('Bar', \&get_supers, \%merge_cache);
+ my @baz_mro = Algorithm::C3::Merge('Baz', \&get_supers, \%merge_cache);
+ my @quux_mro = Algorithm::C3::Merge('Quux', \&get_supers, \%merge_cache);
+ # ...
+ }
+
=back
=head1 CODE COVERAGE