12 my ($root, $parent_fetcher, $cache) = @_;
15 my @STACK; # stack for simulating recursion
17 my $pfetcher_is_coderef = ref($parent_fetcher) eq 'CODE';
19 unless ($pfetcher_is_coderef or $root->can($parent_fetcher)) {
20 confess "Could not find method $parent_fetcher in $root";
23 my $current_root = $root;
24 my $current_parents = [ $root->$parent_fetcher ];
25 my $recurse_mergeout = [];
30 if($i < @$current_parents) {
31 my $new_root = $current_parents->[$i++];
32 die "Infinite loop detected" if $seen{$new_root};
35 unless ($pfetcher_is_coderef or $new_root->can($parent_fetcher)) {
36 confess "Could not find method $parent_fetcher in $new_root";
46 $current_root = $new_root;
47 $current_parents = $cache->{pfetch}->{$current_root} ||= [ $current_root->$parent_fetcher ];
48 $recurse_mergeout = [];
53 $seen{$current_root} = 0;
55 my $mergeout = $cache->{merge}->{$current_root} ||= do {
57 # This do-block is the code formerly known as the function
58 # that was a perl-port of the python code at
59 # http://www.python.org/2.3/mro.html :)
61 # Initial set (make sure everything is copied - it will be modded)
62 my @seqs = map { [@$_] } (@$recurse_mergeout, $current_parents);
64 # Construct the tail-checking hash
66 foreach my $seq (@seqs) {
67 $tails{$_}++ for (@$seq[1..$#$seq]);
70 my @res = ( $current_root );
76 if(!$winner) { # looking for a winner
77 $cand = $_->[0]; # seq head is candidate
78 next if $tails{$cand}; # he loses if in %tails
79 push @res => $winner = $cand;
81 if($_->[0] eq $winner) {
82 shift @$_; # strip off our winner
83 $tails{$_->[0]}-- if @$_; # keep %tails sane
87 die q{Inconsistent hierarchy found while merging '}
88 . $current_root . qq{':\n\t}
89 . qq{current merge results [\n\t\t}
90 . (join ",\n\t\t" => @res)
91 . qq{\n\t]\n\t} . qq{merging failed on '$cand'\n}
97 return @$mergeout if !@STACK;
99 ($current_root, $current_parents, $recurse_mergeout, $i)
102 push(@$recurse_mergeout, $mergeout);
114 Algorithm::C3 - A module for merging hierarchies using the C3 algorithm
120 # merging a classic diamond
121 # inheritence graph like this:
129 my @merged = Algorithm::C3::merge(
132 # extract the ISA array
139 print join ", " => @merged; # prints D, B, C, A
143 This module implements the C3 algorithm. I have broken this out
144 into it's own module because I found myself copying and pasting
145 it way too often for various needs. Most of the uses I have for
146 C3 revolve around class building and metamodels, but it could
147 also be used for things like dependency resolution as well since
148 it tends to do such a nice job of preserving local precendence
151 Below is a brief explanation of C3 taken from the L<Class::C3>
152 module. For more detailed information, see the L<SEE ALSO> section
157 C3 is the name of an algorithm which aims to provide a sane method
158 resolution order under multiple inheritence. It was first introduced
159 in the langauge Dylan (see links in the L<SEE ALSO> section), and
160 then later adopted as the prefered MRO (Method Resolution Order)
161 for the new-style classes in Python 2.3. Most recently it has been
162 adopted as the 'canonical' MRO for Perl 6 classes, and the default
163 MRO for Parrot objects as well.
165 =head2 How does C3 work.
167 C3 works by always preserving local precendence ordering. This
168 essentially means that no class will appear before any of it's
169 subclasses. Take the classic diamond inheritence pattern for
178 The standard Perl 5 MRO would be (D, B, A, C). The result being that
179 B<A> appears before B<C>, even though B<C> is the subclass of B<A>.
180 The C3 MRO algorithm however, produces the following MRO (D, B, C, A),
181 which does not have this same issue.
183 This example is fairly trival, for more complex examples and a deeper
184 explaination, see the links in the L<SEE ALSO> section.
190 =item B<merge ($root, $func_to_fetch_parent, $cache)>
192 This takes a C<$root> node, which can be anything really it
193 is up to you. Then it takes a C<$func_to_fetch_parent> which
194 can be either a CODE reference (see L<SYNOPSIS> above for an
195 example), or a string containing a method name to be called
196 on all the items being linearized. An example of how this
212 our @ISA = ('B', 'C');
215 print join ", " => Algorithm::C3::merge('D', 'supers');
217 The purpose of C<$func_to_fetch_parent> is to provide a way
218 for C<merge> to extract the parents of C<$root>. This is
219 needed for C3 to be able to do it's work.
221 The C<$cache> parameter is an entirely optional performance
222 measure, and should not change behavior.
224 If supplied, it should be a hashref that merge can use as a
225 private cache between runs to speed things up. Generally
226 speaking, if you will be calling merge many times on related
227 things, and the parent fetching function will return constant
228 results given the same arguments during all of these calls,
229 you can and should reuse the same shared cache hash for all
230 of the calls. Example:
232 sub do_some_merging {
234 my @foo_mro = Algorithm::C3::Merge('Foo', \&get_supers, \%merge_cache);
235 my @bar_mro = Algorithm::C3::Merge('Bar', \&get_supers, \%merge_cache);
236 my @baz_mro = Algorithm::C3::Merge('Baz', \&get_supers, \%merge_cache);
237 my @quux_mro = Algorithm::C3::Merge('Quux', \&get_supers, \%merge_cache);
245 I use B<Devel::Cover> to test the code coverage of my tests, below
246 is the B<Devel::Cover> report on this module's test suite.
248 ------------------------ ------ ------ ------ ------ ------ ------ ------
249 File stmt bran cond sub pod time total
250 ------------------------ ------ ------ ------ ------ ------ ------ ------
251 Algorithm/C3.pm 100.0 100.0 100.0 100.0 100.0 100.0 100.0
252 ------------------------ ------ ------ ------ ------ ------ ------ ------
253 Total 100.0 100.0 100.0 100.0 100.0 100.0 100.0
254 ------------------------ ------ ------ ------ ------ ------ ------ ------
258 =head2 The original Dylan paper
262 =item L<http://www.webcom.com/haahr/dylan/linearization-oopsla96.html>
266 =head2 The prototype Perl 6 Object Model uses C3
270 =item L<http://svn.openfoundry.org/pugs/perl5/Perl6-MetaModel/>
274 =head2 Parrot now uses C3
278 =item L<http://aspn.activestate.com/ASPN/Mail/Message/perl6-internals/2746631>
280 =item L<http://use.perl.org/~autrijus/journal/25768>
284 =head2 Python 2.3 MRO related links
288 =item L<http://www.python.org/2.3/mro.html>
290 =item L<http://www.python.org/2.2.2/descrintro.html#mro>
294 =head2 C3 for TinyCLOS
298 =item L<http://www.call-with-current-continuation.org/eggs/c3.html>
304 Stevan Little, E<lt>stevan@iinteractive.comE<gt>
306 Brandon L. Black, E<lt>blblack@gmail.comE<gt>
308 =head1 COPYRIGHT AND LICENSE
310 Copyright 2006 by Infinity Interactive, Inc.
312 L<http://www.iinteractive.com>
314 This library is free software; you can redistribute it and/or modify
315 it under the same terms as Perl itself.