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 );
30 if($i < @$current_parents) {
31 my $new_root = $current_parents->[$i++];
33 if($seen{$new_root}) {
35 (map { $_->[0] } @STACK),
39 shift @isastack while $isastack[0] ne $new_root;
40 my $isastack = join(q{ -> }, @isastack);
41 die "Infinite loop detected in parents of '$root': $isastack";
45 unless ($pfetcher_is_coderef or $new_root->can($parent_fetcher)) {
46 confess "Could not find method $parent_fetcher in $new_root";
56 $current_root = $new_root;
57 $current_parents = $cache->{pfetch}->{$current_root} ||= [ $current_root->$parent_fetcher ];
58 $recurse_mergeout = [];
63 $seen{$current_root} = 0;
65 my $mergeout = $cache->{merge}->{$current_root} ||= do {
67 # This do-block is the code formerly known as the function
68 # that was a perl-port of the python code at
69 # http://www.python.org/2.3/mro.html :)
71 # Initial set (make sure everything is copied - it will be modded)
72 my @seqs = map { [@$_] } (@$recurse_mergeout, $current_parents);
74 # Construct the tail-checking hash
76 foreach my $seq (@seqs) {
77 $tails{$_}++ for (@$seq[1..$#$seq]);
80 my @res = ( $current_root );
86 if(!$winner) { # looking for a winner
87 $cand = $_->[0]; # seq head is candidate
88 next if $tails{$cand}; # he loses if in %tails
90 # Handy warn to give a output like the ones on
91 # http://www.python.org/download/releases/2.3/mro/
92 #warn " = " . join(' + ', @res) . " + merge([" . join('] [', map { join(', ', @$_) } grep { @$_ } @seqs) . "])\n";
93 push @res => $winner = $cand;
95 if($_->[0] eq $winner) {
96 shift @$_; # strip off our winner
97 $tails{$_->[0]}-- if @$_; # keep %tails sane
101 # Handy warn to give a output like the ones on
102 # http://www.python.org/download/releases/2.3/mro/
103 #warn " = " . join(' + ', @res) . "\n" if !$cand;
106 die q{Inconsistent hierarchy found while merging '}
107 . $current_root . qq{':\n\t}
108 . qq{current merge results [\n\t\t}
109 . (join ",\n\t\t" => @res)
110 . qq{\n\t]\n\t} . qq{merging failed on '$cand'\n}
116 return @$mergeout if !@STACK;
118 ($current_root, $current_parents, $recurse_mergeout, $i)
121 push(@$recurse_mergeout, $mergeout);
133 Algorithm::C3 - A module for merging hierarchies using the C3 algorithm
139 # merging a classic diamond
140 # inheritence graph like this:
148 my @merged = Algorithm::C3::merge(
151 # extract the ISA array
158 print join ", " => @merged; # prints D, B, C, A
162 This module implements the C3 algorithm. I have broken this out
163 into it's own module because I found myself copying and pasting
164 it way too often for various needs. Most of the uses I have for
165 C3 revolve around class building and metamodels, but it could
166 also be used for things like dependency resolution as well since
167 it tends to do such a nice job of preserving local precendence
170 Below is a brief explanation of C3 taken from the L<Class::C3>
171 module. For more detailed information, see the L<SEE ALSO> section
176 C3 is the name of an algorithm which aims to provide a sane method
177 resolution order under multiple inheritence. It was first introduced
178 in the langauge Dylan (see links in the L<SEE ALSO> section), and
179 then later adopted as the prefered MRO (Method Resolution Order)
180 for the new-style classes in Python 2.3. Most recently it has been
181 adopted as the 'canonical' MRO for Perl 6 classes, and the default
182 MRO for Parrot objects as well.
184 =head2 How does C3 work.
186 C3 works by always preserving local precendence ordering. This
187 essentially means that no class will appear before any of it's
188 subclasses. Take the classic diamond inheritence pattern for
197 The standard Perl 5 MRO would be (D, B, A, C). The result being that
198 B<A> appears before B<C>, even though B<C> is the subclass of B<A>.
199 The C3 MRO algorithm however, produces the following MRO (D, B, C, A),
200 which does not have this same issue.
202 This example is fairly trival, for more complex examples and a deeper
203 explaination, see the links in the L<SEE ALSO> section.
209 =item B<merge ($root, $func_to_fetch_parent, $cache)>
211 This takes a C<$root> node, which can be anything really it
212 is up to you. Then it takes a C<$func_to_fetch_parent> which
213 can be either a CODE reference (see L<SYNOPSIS> above for an
214 example), or a string containing a method name to be called
215 on all the items being linearized. An example of how this
231 our @ISA = ('B', 'C');
234 print join ", " => Algorithm::C3::merge('D', 'supers');
236 The purpose of C<$func_to_fetch_parent> is to provide a way
237 for C<merge> to extract the parents of C<$root>. This is
238 needed for C3 to be able to do it's work.
240 The C<$cache> parameter is an entirely optional performance
241 measure, and should not change behavior.
243 If supplied, it should be a hashref that merge can use as a
244 private cache between runs to speed things up. Generally
245 speaking, if you will be calling merge many times on related
246 things, and the parent fetching function will return constant
247 results given the same arguments during all of these calls,
248 you can and should reuse the same shared cache hash for all
249 of the calls. Example:
251 sub do_some_merging {
253 my @foo_mro = Algorithm::C3::Merge('Foo', \&get_supers, \%merge_cache);
254 my @bar_mro = Algorithm::C3::Merge('Bar', \&get_supers, \%merge_cache);
255 my @baz_mro = Algorithm::C3::Merge('Baz', \&get_supers, \%merge_cache);
256 my @quux_mro = Algorithm::C3::Merge('Quux', \&get_supers, \%merge_cache);
264 I use B<Devel::Cover> to test the code coverage of my tests, below
265 is the B<Devel::Cover> report on this module's test suite.
267 ------------------------ ------ ------ ------ ------ ------ ------ ------
268 File stmt bran cond sub pod time total
269 ------------------------ ------ ------ ------ ------ ------ ------ ------
270 Algorithm/C3.pm 100.0 100.0 100.0 100.0 100.0 100.0 100.0
271 ------------------------ ------ ------ ------ ------ ------ ------ ------
272 Total 100.0 100.0 100.0 100.0 100.0 100.0 100.0
273 ------------------------ ------ ------ ------ ------ ------ ------ ------
277 =head2 The original Dylan paper
281 =item L<http://www.webcom.com/haahr/dylan/linearization-oopsla96.html>
285 =head2 The prototype Perl 6 Object Model uses C3
289 =item L<http://svn.openfoundry.org/pugs/perl5/Perl6-MetaModel/>
293 =head2 Parrot now uses C3
297 =item L<http://aspn.activestate.com/ASPN/Mail/Message/perl6-internals/2746631>
299 =item L<http://use.perl.org/~autrijus/journal/25768>
303 =head2 Python 2.3 MRO related links
307 =item L<http://www.python.org/2.3/mro.html>
309 =item L<http://www.python.org/2.2.2/descrintro.html#mro>
313 =head2 C3 for TinyCLOS
317 =item L<http://www.call-with-current-continuation.org/eggs/c3.html>
323 Stevan Little, E<lt>stevan@iinteractive.comE<gt>
325 Brandon L. Black, E<lt>blblack@gmail.comE<gt>
327 =head1 COPYRIGHT AND LICENSE
329 Copyright 2006 by Infinity Interactive, Inc.
331 L<http://www.iinteractive.com>
333 This library is free software; you can redistribute it and/or modify
334 it under the same terms as Perl itself.