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 = [];
27 my %seen = ( $root => 1 );
29 my ($new_root, $mergeout, %tails);
31 if($i < @$current_parents) {
32 $new_root = $current_parents->[$i++];
34 if($seen{$new_root}) {
36 (map { $_->[0] } @STACK),
40 shift @isastack while $isastack[0] ne $new_root;
41 my $isastack = join(q{ -> }, @isastack);
42 die "Infinite loop detected in parents of '$root': $isastack";
46 unless ($pfetcher_is_coderef or $new_root->can($parent_fetcher)) {
47 confess "Could not find method $parent_fetcher in $new_root";
57 $current_root = $new_root;
58 $current_parents = $cache->{pfetch}->{$current_root} ||= [ $current_root->$parent_fetcher ];
59 $recurse_mergeout = [];
64 $seen{$current_root} = 0;
66 $mergeout = $cache->{merge}->{$current_root} ||= do {
68 # This do-block is the code formerly known as the function
69 # that was a perl-port of the python code at
70 # http://www.python.org/2.3/mro.html :)
72 # Initial set (make sure everything is copied - it will be modded)
73 my @seqs = map { [@$_] } @$recurse_mergeout;
74 push(@seqs, [@$current_parents]) if @$current_parents;
76 # Construct the tail-checking hash (actually, it's cheaper and still
77 # correct to re-use it throughout this function)
78 foreach my $seq (@seqs) {
79 $tails{$seq->[$_]}++ for (1..$#$seq);
82 my @res = ( $current_root );
88 if(!$winner) { # looking for a winner
89 $cand = $_->[0]; # seq head is candidate
90 next if $tails{$cand}; # he loses if in %tails
92 # Handy warn to give a output like the ones on
93 # http://www.python.org/download/releases/2.3/mro/
94 #warn " = " . join(' + ', @res) . " + merge([" . join('] [', map { join(', ', @$_) } grep { @$_ } @seqs) . "])\n";
95 push @res => $winner = $cand;
96 shift @$_; # strip off our winner
97 $tails{$_->[0]}-- if @$_; # keep %tails sane
99 elsif($_->[0] eq $winner) {
100 shift @$_; # strip off our winner
101 $tails{$_->[0]}-- if @$_; # keep %tails sane
105 # Handy warn to give a output like the ones on
106 # http://www.python.org/download/releases/2.3/mro/
107 #warn " = " . join(' + ', @res) . "\n" if !$cand;
110 die q{Inconsistent hierarchy found while merging '}
111 . $current_root . qq{':\n\t}
112 . qq{current merge results [\n\t\t}
113 . (join ",\n\t\t" => @res)
114 . qq{\n\t]\n\t} . qq{merging failed on '$cand'\n}
120 return @$mergeout if !@STACK;
122 ($current_root, $current_parents, $recurse_mergeout, $i)
125 push(@$recurse_mergeout, $mergeout) if @$mergeout;
137 Algorithm::C3 - A module for merging hierarchies using the C3 algorithm
143 # merging a classic diamond
144 # inheritence graph like this:
152 my @merged = Algorithm::C3::merge(
155 # extract the ISA array
162 print join ", " => @merged; # prints D, B, C, A
166 This module implements the C3 algorithm. I have broken this out
167 into it's own module because I found myself copying and pasting
168 it way too often for various needs. Most of the uses I have for
169 C3 revolve around class building and metamodels, but it could
170 also be used for things like dependency resolution as well since
171 it tends to do such a nice job of preserving local precendence
174 Below is a brief explanation of C3 taken from the L<Class::C3>
175 module. For more detailed information, see the L<SEE ALSO> section
180 C3 is the name of an algorithm which aims to provide a sane method
181 resolution order under multiple inheritence. It was first introduced
182 in the langauge Dylan (see links in the L<SEE ALSO> section), and
183 then later adopted as the prefered MRO (Method Resolution Order)
184 for the new-style classes in Python 2.3. Most recently it has been
185 adopted as the 'canonical' MRO for Perl 6 classes, and the default
186 MRO for Parrot objects as well.
188 =head2 How does C3 work.
190 C3 works by always preserving local precendence ordering. This
191 essentially means that no class will appear before any of it's
192 subclasses. Take the classic diamond inheritence pattern for
201 The standard Perl 5 MRO would be (D, B, A, C). The result being that
202 B<A> appears before B<C>, even though B<C> is the subclass of B<A>.
203 The C3 MRO algorithm however, produces the following MRO (D, B, C, A),
204 which does not have this same issue.
206 This example is fairly trival, for more complex examples and a deeper
207 explaination, see the links in the L<SEE ALSO> section.
213 =item B<merge ($root, $func_to_fetch_parent, $cache)>
215 This takes a C<$root> node, which can be anything really it
216 is up to you. Then it takes a C<$func_to_fetch_parent> which
217 can be either a CODE reference (see L<SYNOPSIS> above for an
218 example), or a string containing a method name to be called
219 on all the items being linearized. An example of how this
235 our @ISA = ('B', 'C');
238 print join ", " => Algorithm::C3::merge('D', 'supers');
240 The purpose of C<$func_to_fetch_parent> is to provide a way
241 for C<merge> to extract the parents of C<$root>. This is
242 needed for C3 to be able to do it's work.
244 The C<$cache> parameter is an entirely optional performance
245 measure, and should not change behavior.
247 If supplied, it should be a hashref that merge can use as a
248 private cache between runs to speed things up. Generally
249 speaking, if you will be calling merge many times on related
250 things, and the parent fetching function will return constant
251 results given the same arguments during all of these calls,
252 you can and should reuse the same shared cache hash for all
253 of the calls. Example:
255 sub do_some_merging {
257 my @foo_mro = Algorithm::C3::Merge('Foo', \&get_supers, \%merge_cache);
258 my @bar_mro = Algorithm::C3::Merge('Bar', \&get_supers, \%merge_cache);
259 my @baz_mro = Algorithm::C3::Merge('Baz', \&get_supers, \%merge_cache);
260 my @quux_mro = Algorithm::C3::Merge('Quux', \&get_supers, \%merge_cache);
268 I use B<Devel::Cover> to test the code coverage of my tests, below
269 is the B<Devel::Cover> report on this module's test suite.
271 ------------------------ ------ ------ ------ ------ ------ ------ ------
272 File stmt bran cond sub pod time total
273 ------------------------ ------ ------ ------ ------ ------ ------ ------
274 Algorithm/C3.pm 100.0 100.0 100.0 100.0 100.0 100.0 100.0
275 ------------------------ ------ ------ ------ ------ ------ ------ ------
276 Total 100.0 100.0 100.0 100.0 100.0 100.0 100.0
277 ------------------------ ------ ------ ------ ------ ------ ------ ------
281 =head2 The original Dylan paper
285 =item L<http://www.webcom.com/haahr/dylan/linearization-oopsla96.html>
289 =head2 The prototype Perl 6 Object Model uses C3
293 =item L<http://svn.openfoundry.org/pugs/perl5/Perl6-MetaModel/>
297 =head2 Parrot now uses C3
301 =item L<http://aspn.activestate.com/ASPN/Mail/Message/perl6-internals/2746631>
303 =item L<http://use.perl.org/~autrijus/journal/25768>
307 =head2 Python 2.3 MRO related links
311 =item L<http://www.python.org/2.3/mro.html>
313 =item L<http://www.python.org/2.2.2/descrintro.html#mro>
317 =head2 C3 for TinyCLOS
321 =item L<http://www.call-with-current-continuation.org/eggs/c3.html>
327 Stevan Little, E<lt>stevan@iinteractive.comE<gt>
329 Brandon L. Black, E<lt>blblack@gmail.comE<gt>
331 =head1 COPYRIGHT AND LICENSE
333 Copyright 2006 by Infinity Interactive, Inc.
335 L<http://www.iinteractive.com>
337 This library is free software; you can redistribute it and/or modify
338 it under the same terms as Perl itself.