12 my ($root, $_parent_fetcher) = @_;
14 my $parent_fetcher = $_parent_fetcher;
15 unless (ref($parent_fetcher) && ref($parent_fetcher) eq 'CODE') {
16 $parent_fetcher = $root->can($_parent_fetcher)
17 || confess "Could not find method $_parent_fetcher in $root";
19 [ $parent_fetcher->($root) ];
23 my ($root, $parent_fetcher) = @_;
25 my @STACK; # stack for simulating recursion
26 my %fcache; # cache of _fetcher results
27 my %mcache; # cache of merge do-block results
29 my $current_root = $root;
30 my $current_parents = $fcache{$root} ||= _fetcher($root, $parent_fetcher);
31 my $recurse_mergeout = [];
35 if($i < @$current_parents) {
36 my $new_root = $current_parents->[$i++];
45 $current_root = $new_root;
46 $current_parents = $fcache{$current_root}
47 ||= _fetcher($current_root, $parent_fetcher);
48 $recurse_mergeout = [];
53 my $mergeout = $mcache{$current_root} ||= do {
55 # This do-block is the code formerly known as the function
56 # that was a perl-port of the python code at
57 # http://www.python.org/2.3/mro.html :)
60 my @seqs = ([$current_root], @$recurse_mergeout, $current_parents);
62 # Construct the tail-checking hash
64 foreach my $seq (@seqs) {
65 $tails{$_}++ for (@$seq[1..$#$seq]);
74 if(!$winner) { # looking for a winner
75 $cand = $_->[0]; # seq head is candidate
76 next if $tails{$cand}; # he loses if in %tails
77 push @res => $winner = $cand;
79 if($_->[0] eq $winner) {
80 shift @$_; # strip off our winner
81 $tails{$_->[0]}-- if @$_; # keep %tails sane
85 die q{Inconsistent hierarchy found while merging '}
86 . $current_root . qq{':\n\t}
87 . qq{current merge results [\n\t\t}
88 . (join ",\n\t\t" => @res)
89 . qq{\n\t]\n\t} . qq{merging failed on '$cand'\n}
95 return @$mergeout if !@STACK;
97 ($current_root, $current_parents, $recurse_mergeout, $i)
100 push(@$recurse_mergeout, $mergeout);
112 Algorithm::C3 - A module for merging hierarchies using the C3 algorithm
118 # merging a classic diamond
119 # inheritence graph like this:
127 my @merged = Algorithm::C3::merge(
130 # extract the ISA array
137 print join ", " => @merged; # prints D, B, C, A
141 This module implements the C3 algorithm. I have broken this out
142 into it's own module because I found myself copying and pasting
143 it way too often for various needs. Most of the uses I have for
144 C3 revolve around class building and metamodels, but it could
145 also be used for things like dependency resolution as well since
146 it tends to do such a nice job of preserving local precendence
149 Below is a brief explanation of C3 taken from the L<Class::C3>
150 module. For more detailed information, see the L<SEE ALSO> section
155 C3 is the name of an algorithm which aims to provide a sane method
156 resolution order under multiple inheritence. It was first introduced
157 in the langauge Dylan (see links in the L<SEE ALSO> section), and
158 then later adopted as the prefered MRO (Method Resolution Order)
159 for the new-style classes in Python 2.3. Most recently it has been
160 adopted as the 'canonical' MRO for Perl 6 classes, and the default
161 MRO for Parrot objects as well.
163 =head2 How does C3 work.
165 C3 works by always preserving local precendence ordering. This
166 essentially means that no class will appear before any of it's
167 subclasses. Take the classic diamond inheritence pattern for
176 The standard Perl 5 MRO would be (D, B, A, C). The result being that
177 B<A> appears before B<C>, even though B<C> is the subclass of B<A>.
178 The C3 MRO algorithm however, produces the following MRO (D, B, C, A),
179 which does not have this same issue.
181 This example is fairly trival, for more complex examples and a deeper
182 explaination, see the links in the L<SEE ALSO> section.
188 =item B<merge ($root, $func_to_fetch_parent)>
190 This takes a C<$root> node, which can be anything really it
191 is up to you. Then it takes a C<$func_to_fetch_parent> which
192 can be either a CODE reference (see L<SYNOPSIS> above for an
193 example), or a string containing a method name to be called
194 on all the items being linearized. An example of how this
210 our @ISA = ('B', 'C');
213 print join ", " => Algorithm::C3::merge('D', 'supers');
215 The purpose of C<$func_to_fetch_parent> is to provide a way
216 for C<merge> to extract the parents of C<$root>. This is
217 needed for C3 to be able to do it's work.
223 I use B<Devel::Cover> to test the code coverage of my tests, below
224 is the B<Devel::Cover> report on this module's test suite.
226 ------------------------ ------ ------ ------ ------ ------ ------ ------
227 File stmt bran cond sub pod time total
228 ------------------------ ------ ------ ------ ------ ------ ------ ------
229 Algorithm/C3.pm 100.0 100.0 55.6 100.0 100.0 100.0 94.4
230 ------------------------ ------ ------ ------ ------ ------ ------ ------
231 Total 100.0 100.0 55.6 100.0 100.0 100.0 94.4
232 ------------------------ ------ ------ ------ ------ ------ ------ ------
236 =head2 The original Dylan paper
240 =item L<http://www.webcom.com/haahr/dylan/linearization-oopsla96.html>
244 =head2 The prototype Perl 6 Object Model uses C3
248 =item L<http://svn.openfoundry.org/pugs/perl5/Perl6-MetaModel/>
252 =head2 Parrot now uses C3
256 =item L<http://aspn.activestate.com/ASPN/Mail/Message/perl6-internals/2746631>
258 =item L<http://use.perl.org/~autrijus/journal/25768>
262 =head2 Python 2.3 MRO related links
266 =item L<http://www.python.org/2.3/mro.html>
268 =item L<http://www.python.org/2.2.2/descrintro.html#mro>
272 =head2 C3 for TinyCLOS
276 =item L<http://www.call-with-current-continuation.org/eggs/c3.html>
282 Stevan Little, E<lt>stevan@iinteractive.comE<gt>
284 =head1 COPYRIGHT AND LICENSE
286 Copyright 2006 by Infinity Interactive, Inc.
288 L<http://www.iinteractive.com>
290 This library is free software; you can redistribute it and/or modify
291 it under the same terms as Perl itself.