12 my ($root, $parent_fetcher, $cache) = @_;
16 # stacks for simulating recursion
22 my $pfetcher_is_coderef = ref($parent_fetcher) eq 'CODE';
24 unless ($pfetcher_is_coderef or $root->can($parent_fetcher)) {
25 confess "Could not find method $parent_fetcher in $root";
28 my $current_root = $root;
29 my $current_parents = [ $root->$parent_fetcher ];
30 my $recurse_mergeout = [];
32 my %seen = ( $root => 1 );
34 my ($new_root, $mergeout, %tails);
36 if($i < @$current_parents) {
37 $new_root = $current_parents->[$i++];
39 if($seen{$new_root}) {
45 shift @isastack while $isastack[0] ne $new_root;
46 my $isastack = join(q{ -> }, @isastack);
47 die "Infinite loop detected in parents of '$root': $isastack";
51 unless ($pfetcher_is_coderef or $new_root->can($parent_fetcher)) {
52 confess "Could not find method $parent_fetcher in $new_root";
55 push(@RSTACK, $current_root);
56 push(@PSTACK, $current_parents);
57 push(@MSTACK, $recurse_mergeout);
60 $current_root = $new_root;
61 $current_parents = $cache->{pfetch}->{$current_root} ||= [ $current_root->$parent_fetcher ];
62 $recurse_mergeout = [];
67 $seen{$current_root} = 0;
69 $mergeout = $cache->{merge}->{$current_root} ||= do {
71 # This do-block is the code formerly known as the function
72 # that was a perl-port of the python code at
73 # http://www.python.org/2.3/mro.html :)
75 # Initial set (make sure everything is copied - it will be modded)
76 my @seqs = map { [@$_] } @$recurse_mergeout;
77 push(@seqs, [@$current_parents]) if @$current_parents;
79 # Construct the tail-checking hash (actually, it's cheaper and still
80 # correct to re-use it throughout this function)
81 foreach my $seq (@seqs) {
82 $tails{$seq->[$_]}++ for (1..$#$seq);
85 my @res = ( $current_root );
91 if(!$winner) { # looking for a winner
92 $cand = $_->[0]; # seq head is candidate
93 next if $tails{$cand}; # he loses if in %tails
95 # Handy warn to give a output like the ones on
96 # http://www.python.org/download/releases/2.3/mro/
97 #warn " = " . join(' + ', @res) . " + merge([" . join('] [', map { join(', ', @$_) } grep { @$_ } @seqs) . "])\n";
98 push @res => $winner = $cand;
99 shift @$_; # strip off our winner
100 $tails{$_->[0]}-- if @$_; # keep %tails sane
102 elsif($_->[0] eq $winner) {
103 shift @$_; # strip off our winner
104 $tails{$_->[0]}-- if @$_; # keep %tails sane
108 # Handy warn to give a output like the ones on
109 # http://www.python.org/download/releases/2.3/mro/
110 #warn " = " . join(' + ', @res) . "\n" if !$cand;
113 die q{Inconsistent hierarchy found while merging '}
114 . $current_root . qq{':\n\t}
115 . qq{current merge results [\n\t\t}
116 . (join ",\n\t\t" => @res)
117 . qq{\n\t]\n\t} . qq{merging failed on '$cand'\n}
123 return @$mergeout if !@ISTACK;
125 $current_root = pop(@RSTACK);
126 $current_parents = pop(@PSTACK);
127 $recurse_mergeout = pop(@MSTACK);
130 push(@$recurse_mergeout, $mergeout) if @$mergeout;
142 Algorithm::C3 - A module for merging hierarchies using the C3 algorithm
148 # merging a classic diamond
149 # inheritence graph like this:
157 my @merged = Algorithm::C3::merge(
160 # extract the ISA array
167 print join ", " => @merged; # prints D, B, C, A
171 This module implements the C3 algorithm. I have broken this out
172 into it's own module because I found myself copying and pasting
173 it way too often for various needs. Most of the uses I have for
174 C3 revolve around class building and metamodels, but it could
175 also be used for things like dependency resolution as well since
176 it tends to do such a nice job of preserving local precendence
179 Below is a brief explanation of C3 taken from the L<Class::C3>
180 module. For more detailed information, see the L<SEE ALSO> section
185 C3 is the name of an algorithm which aims to provide a sane method
186 resolution order under multiple inheritence. It was first introduced
187 in the langauge Dylan (see links in the L<SEE ALSO> section), and
188 then later adopted as the prefered MRO (Method Resolution Order)
189 for the new-style classes in Python 2.3. Most recently it has been
190 adopted as the 'canonical' MRO for Perl 6 classes, and the default
191 MRO for Parrot objects as well.
193 =head2 How does C3 work.
195 C3 works by always preserving local precendence ordering. This
196 essentially means that no class will appear before any of it's
197 subclasses. Take the classic diamond inheritence pattern for
206 The standard Perl 5 MRO would be (D, B, A, C). The result being that
207 B<A> appears before B<C>, even though B<C> is the subclass of B<A>.
208 The C3 MRO algorithm however, produces the following MRO (D, B, C, A),
209 which does not have this same issue.
211 This example is fairly trival, for more complex examples and a deeper
212 explaination, see the links in the L<SEE ALSO> section.
218 =item B<merge ($root, $func_to_fetch_parent, $cache)>
220 This takes a C<$root> node, which can be anything really it
221 is up to you. Then it takes a C<$func_to_fetch_parent> which
222 can be either a CODE reference (see L<SYNOPSIS> above for an
223 example), or a string containing a method name to be called
224 on all the items being linearized. An example of how this
240 our @ISA = ('B', 'C');
243 print join ", " => Algorithm::C3::merge('D', 'supers');
245 The purpose of C<$func_to_fetch_parent> is to provide a way
246 for C<merge> to extract the parents of C<$root>. This is
247 needed for C3 to be able to do it's work.
249 The C<$cache> parameter is an entirely optional performance
250 measure, and should not change behavior.
252 If supplied, it should be a hashref that merge can use as a
253 private cache between runs to speed things up. Generally
254 speaking, if you will be calling merge many times on related
255 things, and the parent fetching function will return constant
256 results given the same arguments during all of these calls,
257 you can and should reuse the same shared cache hash for all
258 of the calls. Example:
260 sub do_some_merging {
262 my @foo_mro = Algorithm::C3::Merge('Foo', \&get_supers, \%merge_cache);
263 my @bar_mro = Algorithm::C3::Merge('Bar', \&get_supers, \%merge_cache);
264 my @baz_mro = Algorithm::C3::Merge('Baz', \&get_supers, \%merge_cache);
265 my @quux_mro = Algorithm::C3::Merge('Quux', \&get_supers, \%merge_cache);
273 I use B<Devel::Cover> to test the code coverage of my tests, below
274 is the B<Devel::Cover> report on this module's test suite.
276 ------------------------ ------ ------ ------ ------ ------ ------ ------
277 File stmt bran cond sub pod time total
278 ------------------------ ------ ------ ------ ------ ------ ------ ------
279 Algorithm/C3.pm 100.0 100.0 100.0 100.0 100.0 100.0 100.0
280 ------------------------ ------ ------ ------ ------ ------ ------ ------
281 Total 100.0 100.0 100.0 100.0 100.0 100.0 100.0
282 ------------------------ ------ ------ ------ ------ ------ ------ ------
286 =head2 The original Dylan paper
290 =item L<http://www.webcom.com/haahr/dylan/linearization-oopsla96.html>
294 =head2 The prototype Perl 6 Object Model uses C3
298 =item L<http://svn.openfoundry.org/pugs/perl5/Perl6-MetaModel/>
302 =head2 Parrot now uses C3
306 =item L<http://aspn.activestate.com/ASPN/Mail/Message/perl6-internals/2746631>
308 =item L<http://use.perl.org/~autrijus/journal/25768>
312 =head2 Python 2.3 MRO related links
316 =item L<http://www.python.org/2.3/mro.html>
318 =item L<http://www.python.org/2.2.2/descrintro.html#mro>
322 =head2 C3 for TinyCLOS
326 =item L<http://www.call-with-current-continuation.org/eggs/c3.html>
332 Stevan Little, E<lt>stevan@iinteractive.comE<gt>
334 Brandon L. Black, E<lt>blblack@gmail.comE<gt>
336 =head1 COPYRIGHT AND LICENSE
338 Copyright 2006 by Infinity Interactive, Inc.
340 L<http://www.iinteractive.com>
342 This library is free software; you can redistribute it and/or modify
343 it under the same terms as Perl itself.