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++];
33 if($seen{$new_root}) {
34 # XXX Can we give them a better diagnostic, with a list from $root => $new_root => foo => $new_root ??
35 die "Infinite loop detected, $new_root appears"
36 . " twice in a bad way in the parents of $root"
40 unless ($pfetcher_is_coderef or $new_root->can($parent_fetcher)) {
41 confess "Could not find method $parent_fetcher in $new_root";
51 $current_root = $new_root;
52 $current_parents = $cache->{pfetch}->{$current_root} ||= [ $current_root->$parent_fetcher ];
53 $recurse_mergeout = [];
58 $seen{$current_root} = 0;
60 my $mergeout = $cache->{merge}->{$current_root} ||= do {
62 # This do-block is the code formerly known as the function
63 # that was a perl-port of the python code at
64 # http://www.python.org/2.3/mro.html :)
66 # Initial set (make sure everything is copied - it will be modded)
67 my @seqs = map { [@$_] } (@$recurse_mergeout, $current_parents);
69 # Construct the tail-checking hash
71 foreach my $seq (@seqs) {
72 $tails{$_}++ for (@$seq[1..$#$seq]);
75 my @res = ( $current_root );
81 if(!$winner) { # looking for a winner
82 $cand = $_->[0]; # seq head is candidate
83 next if $tails{$cand}; # he loses if in %tails
84 push @res => $winner = $cand;
86 if($_->[0] eq $winner) {
87 shift @$_; # strip off our winner
88 $tails{$_->[0]}-- if @$_; # keep %tails sane
92 die q{Inconsistent hierarchy found while merging '}
93 . $current_root . qq{':\n\t}
94 . qq{current merge results [\n\t\t}
95 . (join ",\n\t\t" => @res)
96 . qq{\n\t]\n\t} . qq{merging failed on '$cand'\n}
102 return @$mergeout if !@STACK;
104 ($current_root, $current_parents, $recurse_mergeout, $i)
107 push(@$recurse_mergeout, $mergeout);
119 Algorithm::C3 - A module for merging hierarchies using the C3 algorithm
125 # merging a classic diamond
126 # inheritence graph like this:
134 my @merged = Algorithm::C3::merge(
137 # extract the ISA array
144 print join ", " => @merged; # prints D, B, C, A
148 This module implements the C3 algorithm. I have broken this out
149 into it's own module because I found myself copying and pasting
150 it way too often for various needs. Most of the uses I have for
151 C3 revolve around class building and metamodels, but it could
152 also be used for things like dependency resolution as well since
153 it tends to do such a nice job of preserving local precendence
156 Below is a brief explanation of C3 taken from the L<Class::C3>
157 module. For more detailed information, see the L<SEE ALSO> section
162 C3 is the name of an algorithm which aims to provide a sane method
163 resolution order under multiple inheritence. It was first introduced
164 in the langauge Dylan (see links in the L<SEE ALSO> section), and
165 then later adopted as the prefered MRO (Method Resolution Order)
166 for the new-style classes in Python 2.3. Most recently it has been
167 adopted as the 'canonical' MRO for Perl 6 classes, and the default
168 MRO for Parrot objects as well.
170 =head2 How does C3 work.
172 C3 works by always preserving local precendence ordering. This
173 essentially means that no class will appear before any of it's
174 subclasses. Take the classic diamond inheritence pattern for
183 The standard Perl 5 MRO would be (D, B, A, C). The result being that
184 B<A> appears before B<C>, even though B<C> is the subclass of B<A>.
185 The C3 MRO algorithm however, produces the following MRO (D, B, C, A),
186 which does not have this same issue.
188 This example is fairly trival, for more complex examples and a deeper
189 explaination, see the links in the L<SEE ALSO> section.
195 =item B<merge ($root, $func_to_fetch_parent, $cache)>
197 This takes a C<$root> node, which can be anything really it
198 is up to you. Then it takes a C<$func_to_fetch_parent> which
199 can be either a CODE reference (see L<SYNOPSIS> above for an
200 example), or a string containing a method name to be called
201 on all the items being linearized. An example of how this
217 our @ISA = ('B', 'C');
220 print join ", " => Algorithm::C3::merge('D', 'supers');
222 The purpose of C<$func_to_fetch_parent> is to provide a way
223 for C<merge> to extract the parents of C<$root>. This is
224 needed for C3 to be able to do it's work.
226 The C<$cache> parameter is an entirely optional performance
227 measure, and should not change behavior.
229 If supplied, it should be a hashref that merge can use as a
230 private cache between runs to speed things up. Generally
231 speaking, if you will be calling merge many times on related
232 things, and the parent fetching function will return constant
233 results given the same arguments during all of these calls,
234 you can and should reuse the same shared cache hash for all
235 of the calls. Example:
237 sub do_some_merging {
239 my @foo_mro = Algorithm::C3::Merge('Foo', \&get_supers, \%merge_cache);
240 my @bar_mro = Algorithm::C3::Merge('Bar', \&get_supers, \%merge_cache);
241 my @baz_mro = Algorithm::C3::Merge('Baz', \&get_supers, \%merge_cache);
242 my @quux_mro = Algorithm::C3::Merge('Quux', \&get_supers, \%merge_cache);
250 I use B<Devel::Cover> to test the code coverage of my tests, below
251 is the B<Devel::Cover> report on this module's test suite.
253 ------------------------ ------ ------ ------ ------ ------ ------ ------
254 File stmt bran cond sub pod time total
255 ------------------------ ------ ------ ------ ------ ------ ------ ------
256 Algorithm/C3.pm 100.0 100.0 100.0 100.0 100.0 100.0 100.0
257 ------------------------ ------ ------ ------ ------ ------ ------ ------
258 Total 100.0 100.0 100.0 100.0 100.0 100.0 100.0
259 ------------------------ ------ ------ ------ ------ ------ ------ ------
263 =head2 The original Dylan paper
267 =item L<http://www.webcom.com/haahr/dylan/linearization-oopsla96.html>
271 =head2 The prototype Perl 6 Object Model uses C3
275 =item L<http://svn.openfoundry.org/pugs/perl5/Perl6-MetaModel/>
279 =head2 Parrot now uses C3
283 =item L<http://aspn.activestate.com/ASPN/Mail/Message/perl6-internals/2746631>
285 =item L<http://use.perl.org/~autrijus/journal/25768>
289 =head2 Python 2.3 MRO related links
293 =item L<http://www.python.org/2.3/mro.html>
295 =item L<http://www.python.org/2.2.2/descrintro.html#mro>
299 =head2 C3 for TinyCLOS
303 =item L<http://www.call-with-current-continuation.org/eggs/c3.html>
309 Stevan Little, E<lt>stevan@iinteractive.comE<gt>
311 Brandon L. Black, E<lt>blblack@gmail.comE<gt>
313 =head1 COPYRIGHT AND LICENSE
315 Copyright 2006 by Infinity Interactive, Inc.
317 L<http://www.iinteractive.com>
319 This library is free software; you can redistribute it and/or modify
320 it under the same terms as Perl itself.