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)
74 foreach (@$recurse_mergeout, $current_parents) {
75 push(@seqs, [@$_]) if @$_;
78 # Construct the tail-checking hash (actually, it's cheaper and still
79 # correct to re-use it throughout this function)
80 foreach my $seq (@seqs) {
81 $tails{$seq->[$_]}++ for (1..$#$seq);
84 my @res = ( $current_root );
90 if(!$winner) { # looking for a winner
91 $cand = $_->[0]; # seq head is candidate
92 next if $tails{$cand}; # he loses if in %tails
94 # Handy warn to give a output like the ones on
95 # http://www.python.org/download/releases/2.3/mro/
96 #warn " = " . join(' + ', @res) . " + merge([" . join('] [', map { join(', ', @$_) } grep { @$_ } @seqs) . "])\n";
97 push @res => $winner = $cand;
98 shift @$_; # strip off our winner
99 $tails{$_->[0]}-- if @$_; # keep %tails sane
101 elsif($_->[0] eq $winner) {
102 shift @$_; # strip off our winner
103 $tails{$_->[0]}-- if @$_; # keep %tails sane
107 # Handy warn to give a output like the ones on
108 # http://www.python.org/download/releases/2.3/mro/
109 #warn " = " . join(' + ', @res) . "\n" if !$cand;
112 die q{Inconsistent hierarchy found while merging '}
113 . $current_root . qq{':\n\t}
114 . qq{current merge results [\n\t\t}
115 . (join ",\n\t\t" => @res)
116 . qq{\n\t]\n\t} . qq{merging failed on '$cand'\n}
122 return @$mergeout if !@STACK;
124 ($current_root, $current_parents, $recurse_mergeout, $i)
127 push(@$recurse_mergeout, $mergeout);
139 Algorithm::C3 - A module for merging hierarchies using the C3 algorithm
145 # merging a classic diamond
146 # inheritence graph like this:
154 my @merged = Algorithm::C3::merge(
157 # extract the ISA array
164 print join ", " => @merged; # prints D, B, C, A
168 This module implements the C3 algorithm. I have broken this out
169 into it's own module because I found myself copying and pasting
170 it way too often for various needs. Most of the uses I have for
171 C3 revolve around class building and metamodels, but it could
172 also be used for things like dependency resolution as well since
173 it tends to do such a nice job of preserving local precendence
176 Below is a brief explanation of C3 taken from the L<Class::C3>
177 module. For more detailed information, see the L<SEE ALSO> section
182 C3 is the name of an algorithm which aims to provide a sane method
183 resolution order under multiple inheritence. It was first introduced
184 in the langauge Dylan (see links in the L<SEE ALSO> section), and
185 then later adopted as the prefered MRO (Method Resolution Order)
186 for the new-style classes in Python 2.3. Most recently it has been
187 adopted as the 'canonical' MRO for Perl 6 classes, and the default
188 MRO for Parrot objects as well.
190 =head2 How does C3 work.
192 C3 works by always preserving local precendence ordering. This
193 essentially means that no class will appear before any of it's
194 subclasses. Take the classic diamond inheritence pattern for
203 The standard Perl 5 MRO would be (D, B, A, C). The result being that
204 B<A> appears before B<C>, even though B<C> is the subclass of B<A>.
205 The C3 MRO algorithm however, produces the following MRO (D, B, C, A),
206 which does not have this same issue.
208 This example is fairly trival, for more complex examples and a deeper
209 explaination, see the links in the L<SEE ALSO> section.
215 =item B<merge ($root, $func_to_fetch_parent, $cache)>
217 This takes a C<$root> node, which can be anything really it
218 is up to you. Then it takes a C<$func_to_fetch_parent> which
219 can be either a CODE reference (see L<SYNOPSIS> above for an
220 example), or a string containing a method name to be called
221 on all the items being linearized. An example of how this
237 our @ISA = ('B', 'C');
240 print join ", " => Algorithm::C3::merge('D', 'supers');
242 The purpose of C<$func_to_fetch_parent> is to provide a way
243 for C<merge> to extract the parents of C<$root>. This is
244 needed for C3 to be able to do it's work.
246 The C<$cache> parameter is an entirely optional performance
247 measure, and should not change behavior.
249 If supplied, it should be a hashref that merge can use as a
250 private cache between runs to speed things up. Generally
251 speaking, if you will be calling merge many times on related
252 things, and the parent fetching function will return constant
253 results given the same arguments during all of these calls,
254 you can and should reuse the same shared cache hash for all
255 of the calls. Example:
257 sub do_some_merging {
259 my @foo_mro = Algorithm::C3::Merge('Foo', \&get_supers, \%merge_cache);
260 my @bar_mro = Algorithm::C3::Merge('Bar', \&get_supers, \%merge_cache);
261 my @baz_mro = Algorithm::C3::Merge('Baz', \&get_supers, \%merge_cache);
262 my @quux_mro = Algorithm::C3::Merge('Quux', \&get_supers, \%merge_cache);
270 I use B<Devel::Cover> to test the code coverage of my tests, below
271 is the B<Devel::Cover> report on this module's test suite.
273 ------------------------ ------ ------ ------ ------ ------ ------ ------
274 File stmt bran cond sub pod time total
275 ------------------------ ------ ------ ------ ------ ------ ------ ------
276 Algorithm/C3.pm 100.0 100.0 100.0 100.0 100.0 100.0 100.0
277 ------------------------ ------ ------ ------ ------ ------ ------ ------
278 Total 100.0 100.0 100.0 100.0 100.0 100.0 100.0
279 ------------------------ ------ ------ ------ ------ ------ ------ ------
283 =head2 The original Dylan paper
287 =item L<http://www.webcom.com/haahr/dylan/linearization-oopsla96.html>
291 =head2 The prototype Perl 6 Object Model uses C3
295 =item L<http://svn.openfoundry.org/pugs/perl5/Perl6-MetaModel/>
299 =head2 Parrot now uses C3
303 =item L<http://aspn.activestate.com/ASPN/Mail/Message/perl6-internals/2746631>
305 =item L<http://use.perl.org/~autrijus/journal/25768>
309 =head2 Python 2.3 MRO related links
313 =item L<http://www.python.org/2.3/mro.html>
315 =item L<http://www.python.org/2.2.2/descrintro.html#mro>
319 =head2 C3 for TinyCLOS
323 =item L<http://www.call-with-current-continuation.org/eggs/c3.html>
329 Stevan Little, E<lt>stevan@iinteractive.comE<gt>
331 Brandon L. Black, E<lt>blblack@gmail.comE<gt>
333 =head1 COPYRIGHT AND LICENSE
335 Copyright 2006 by Infinity Interactive, Inc.
337 L<http://www.iinteractive.com>
339 This library is free software; you can redistribute it and/or modify
340 it under the same terms as Perl itself.