12 my ($root, $parent_fetcher, $cache) = @_;
16 my @STACK; # stack for simulating recursion
18 my $pfetcher_is_coderef = ref($parent_fetcher) eq 'CODE';
20 unless ($pfetcher_is_coderef or $root->can($parent_fetcher)) {
21 confess "Could not find method $parent_fetcher in $root";
24 my $current_root = $root;
25 my $current_parents = [ $root->$parent_fetcher ];
26 my $recurse_mergeout = [];
28 my %seen = ( $root => 1 );
30 my ($new_root, $mergeout, %tails);
32 if($i < @$current_parents) {
33 $new_root = $current_parents->[$i++];
35 if($seen{$new_root}) {
38 for(my $i = 0; $i < $#STACK; $i += 4) {
39 if($reached || ($reached = ($STACK[$i] eq $new_root))) {
40 push(@isastack, $STACK[$i]);
43 my $isastack = join(q{ -> }, @isastack, $current_root, $new_root);
44 die "Infinite loop detected in parents of '$root': $isastack";
48 unless ($pfetcher_is_coderef or $new_root->can($parent_fetcher)) {
49 confess "Could not find method $parent_fetcher in $new_root";
52 push(@STACK, $current_root, $current_parents, $recurse_mergeout, $i);
54 $current_root = $new_root;
55 $current_parents = $cache->{pfetch}->{$current_root} ||= [ $current_root->$parent_fetcher ];
56 $recurse_mergeout = [];
61 $seen{$current_root} = 0;
63 $mergeout = $cache->{merge}->{$current_root} ||= do {
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 :)
69 # Initial set (make sure everything is copied - it will be modded)
70 my @seqs = map { [@$_] } @$recurse_mergeout;
71 push(@seqs, [@$current_parents]) if @$current_parents;
73 # Construct the tail-checking hash (actually, it's cheaper and still
74 # correct to re-use it throughout this function)
75 foreach my $seq (@seqs) {
76 $tails{$seq->[$_]}++ for (1..$#$seq);
79 my @res = ( $current_root );
85 if(!$winner) { # looking for a winner
86 $cand = $_->[0]; # seq head is candidate
87 next if $tails{$cand}; # he loses if in %tails
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 push @res => $winner = $cand;
93 shift @$_; # strip off our winner
94 $tails{$_->[0]}-- if @$_; # keep %tails sane
96 elsif($_->[0] eq $winner) {
97 shift @$_; # strip off our winner
98 $tails{$_->[0]}-- if @$_; # keep %tails sane
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;
107 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}
117 return @$mergeout if !@STACK;
120 $recurse_mergeout = pop(@STACK);
121 $current_parents = pop(@STACK);
122 $current_root = pop(@STACK);
124 push(@$recurse_mergeout, $mergeout) if @$mergeout;
136 Algorithm::C3 - A module for merging hierarchies using the C3 algorithm
142 # merging a classic diamond
143 # inheritence graph like this:
151 my @merged = Algorithm::C3::merge(
154 # extract the ISA array
161 print join ", " => @merged; # prints D, B, C, A
165 This module implements the C3 algorithm. I have broken this out
166 into it's own module because I found myself copying and pasting
167 it way too often for various needs. Most of the uses I have for
168 C3 revolve around class building and metamodels, but it could
169 also be used for things like dependency resolution as well since
170 it tends to do such a nice job of preserving local precendence
173 Below is a brief explanation of C3 taken from the L<Class::C3>
174 module. For more detailed information, see the L<SEE ALSO> section
179 C3 is the name of an algorithm which aims to provide a sane method
180 resolution order under multiple inheritence. It was first introduced
181 in the langauge Dylan (see links in the L<SEE ALSO> section), and
182 then later adopted as the prefered MRO (Method Resolution Order)
183 for the new-style classes in Python 2.3. Most recently it has been
184 adopted as the 'canonical' MRO for Perl 6 classes, and the default
185 MRO for Parrot objects as well.
187 =head2 How does C3 work.
189 C3 works by always preserving local precendence ordering. This
190 essentially means that no class will appear before any of it's
191 subclasses. Take the classic diamond inheritence pattern for
200 The standard Perl 5 MRO would be (D, B, A, C). The result being that
201 B<A> appears before B<C>, even though B<C> is the subclass of B<A>.
202 The C3 MRO algorithm however, produces the following MRO (D, B, C, A),
203 which does not have this same issue.
205 This example is fairly trival, for more complex examples and a deeper
206 explaination, see the links in the L<SEE ALSO> section.
212 =item B<merge ($root, $func_to_fetch_parent, $cache)>
214 This takes a C<$root> node, which can be anything really it
215 is up to you. Then it takes a C<$func_to_fetch_parent> which
216 can be either a CODE reference (see L<SYNOPSIS> above for an
217 example), or a string containing a method name to be called
218 on all the items being linearized. An example of how this
234 our @ISA = ('B', 'C');
237 print join ", " => Algorithm::C3::merge('D', 'supers');
239 The purpose of C<$func_to_fetch_parent> is to provide a way
240 for C<merge> to extract the parents of C<$root>. This is
241 needed for C3 to be able to do it's work.
243 The C<$cache> parameter is an entirely optional performance
244 measure, and should not change behavior.
246 If supplied, it should be a hashref that merge can use as a
247 private cache between runs to speed things up. Generally
248 speaking, if you will be calling merge many times on related
249 things, and the parent fetching function will return constant
250 results given the same arguments during all of these calls,
251 you can and should reuse the same shared cache hash for all
252 of the calls. Example:
254 sub do_some_merging {
256 my @foo_mro = Algorithm::C3::Merge('Foo', \&get_supers, \%merge_cache);
257 my @bar_mro = Algorithm::C3::Merge('Bar', \&get_supers, \%merge_cache);
258 my @baz_mro = Algorithm::C3::Merge('Baz', \&get_supers, \%merge_cache);
259 my @quux_mro = Algorithm::C3::Merge('Quux', \&get_supers, \%merge_cache);
267 I use B<Devel::Cover> to test the code coverage of my tests, below
268 is the B<Devel::Cover> report on this module's test suite.
270 ------------------------ ------ ------ ------ ------ ------ ------ ------
271 File stmt bran cond sub pod time total
272 ------------------------ ------ ------ ------ ------ ------ ------ ------
273 Algorithm/C3.pm 100.0 100.0 100.0 100.0 100.0 100.0 100.0
274 ------------------------ ------ ------ ------ ------ ------ ------ ------
275 Total 100.0 100.0 100.0 100.0 100.0 100.0 100.0
276 ------------------------ ------ ------ ------ ------ ------ ------ ------
280 =head2 The original Dylan paper
284 =item L<http://www.webcom.com/haahr/dylan/linearization-oopsla96.html>
288 =head2 The prototype Perl 6 Object Model uses C3
292 =item L<http://svn.openfoundry.org/pugs/perl5/Perl6-MetaModel/>
296 =head2 Parrot now uses C3
300 =item L<http://aspn.activestate.com/ASPN/Mail/Message/perl6-internals/2746631>
302 =item L<http://use.perl.org/~autrijus/journal/25768>
306 =head2 Python 2.3 MRO related links
310 =item L<http://www.python.org/2.3/mro.html>
312 =item L<http://www.python.org/2.2.2/descrintro.html#mro>
316 =head2 C3 for TinyCLOS
320 =item L<http://www.call-with-current-continuation.org/eggs/c3.html>
326 Stevan Little, E<lt>stevan@iinteractive.comE<gt>
328 Brandon L. Black, E<lt>blblack@gmail.comE<gt>
330 =head1 COPYRIGHT AND LICENSE
332 Copyright 2006 by Infinity Interactive, Inc.
334 L<http://www.iinteractive.com>
336 This library is free software; you can redistribute it and/or modify
337 it under the same terms as Perl itself.