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 = [];
29 if($i < @$current_parents) {
30 my $new_root = $current_parents->[$i++];
32 unless ($pfetcher_is_coderef or $new_root->can($parent_fetcher)) {
33 confess "Could not find method $parent_fetcher in $new_root";
43 $current_root = $new_root;
44 $current_parents = $cache->{pfetch}->{$current_root} ||= [ $current_root->$parent_fetcher ];
45 $recurse_mergeout = [];
50 my $mergeout = $cache->{merge}->{$current_root} ||= do {
52 # This do-block is the code formerly known as the function
53 # that was a perl-port of the python code at
54 # http://www.python.org/2.3/mro.html :)
56 # Initial set (make sure everything is copied - it will be modded)
57 my @seqs = map { [@$_] } (@$recurse_mergeout, $current_parents);
59 # Construct the tail-checking hash
61 foreach my $seq (@seqs) {
62 $tails{$_}++ for (@$seq[1..$#$seq]);
65 my @res = ( $current_root );
71 if(!$winner) { # looking for a winner
72 $cand = $_->[0]; # seq head is candidate
73 next if $tails{$cand}; # he loses if in %tails
74 push @res => $winner = $cand;
76 if($_->[0] eq $winner) {
77 shift @$_; # strip off our winner
78 $tails{$_->[0]}-- if @$_; # keep %tails sane
82 die q{Inconsistent hierarchy found while merging '}
83 . $current_root . qq{':\n\t}
84 . qq{current merge results [\n\t\t}
85 . (join ",\n\t\t" => @res)
86 . qq{\n\t]\n\t} . qq{merging failed on '$cand'\n}
92 return @$mergeout if !@STACK;
94 ($current_root, $current_parents, $recurse_mergeout, $i)
97 push(@$recurse_mergeout, $mergeout);
109 Algorithm::C3 - A module for merging hierarchies using the C3 algorithm
115 # merging a classic diamond
116 # inheritence graph like this:
124 my @merged = Algorithm::C3::merge(
127 # extract the ISA array
134 print join ", " => @merged; # prints D, B, C, A
138 This module implements the C3 algorithm. I have broken this out
139 into it's own module because I found myself copying and pasting
140 it way too often for various needs. Most of the uses I have for
141 C3 revolve around class building and metamodels, but it could
142 also be used for things like dependency resolution as well since
143 it tends to do such a nice job of preserving local precendence
146 Below is a brief explanation of C3 taken from the L<Class::C3>
147 module. For more detailed information, see the L<SEE ALSO> section
152 C3 is the name of an algorithm which aims to provide a sane method
153 resolution order under multiple inheritence. It was first introduced
154 in the langauge Dylan (see links in the L<SEE ALSO> section), and
155 then later adopted as the prefered MRO (Method Resolution Order)
156 for the new-style classes in Python 2.3. Most recently it has been
157 adopted as the 'canonical' MRO for Perl 6 classes, and the default
158 MRO for Parrot objects as well.
160 =head2 How does C3 work.
162 C3 works by always preserving local precendence ordering. This
163 essentially means that no class will appear before any of it's
164 subclasses. Take the classic diamond inheritence pattern for
173 The standard Perl 5 MRO would be (D, B, A, C). The result being that
174 B<A> appears before B<C>, even though B<C> is the subclass of B<A>.
175 The C3 MRO algorithm however, produces the following MRO (D, B, C, A),
176 which does not have this same issue.
178 This example is fairly trival, for more complex examples and a deeper
179 explaination, see the links in the L<SEE ALSO> section.
185 =item B<merge ($root, $func_to_fetch_parent, $cache)>
187 This takes a C<$root> node, which can be anything really it
188 is up to you. Then it takes a C<$func_to_fetch_parent> which
189 can be either a CODE reference (see L<SYNOPSIS> above for an
190 example), or a string containing a method name to be called
191 on all the items being linearized. An example of how this
207 our @ISA = ('B', 'C');
210 print join ", " => Algorithm::C3::merge('D', 'supers');
212 The purpose of C<$func_to_fetch_parent> is to provide a way
213 for C<merge> to extract the parents of C<$root>. This is
214 needed for C3 to be able to do it's work.
216 The C<$cache> parameter is an entirely optional performance
217 measure, and should not change behavior.
219 If supplied, it should be a hashref that merge can use as a
220 private cache between runs to speed things up. Generally
221 speaking, if you will be calling merge many times on related
222 things, and the parent fetching function will return constant
223 results given the same arguments during all of these calls,
224 you can and should reuse the same shared cache hash for all
225 of the calls. Example:
227 sub do_some_merging {
229 my @foo_mro = Algorithm::C3::Merge('Foo', \&get_supers, \%merge_cache);
230 my @bar_mro = Algorithm::C3::Merge('Bar', \&get_supers, \%merge_cache);
231 my @baz_mro = Algorithm::C3::Merge('Baz', \&get_supers, \%merge_cache);
232 my @quux_mro = Algorithm::C3::Merge('Quux', \&get_supers, \%merge_cache);
240 I use B<Devel::Cover> to test the code coverage of my tests, below
241 is the B<Devel::Cover> report on this module's test suite.
243 ------------------------ ------ ------ ------ ------ ------ ------ ------
244 File stmt bran cond sub pod time total
245 ------------------------ ------ ------ ------ ------ ------ ------ ------
246 Algorithm/C3.pm 100.0 100.0 100.0 100.0 100.0 100.0 100.0
247 ------------------------ ------ ------ ------ ------ ------ ------ ------
248 Total 100.0 100.0 100.0 100.0 100.0 100.0 100.0
249 ------------------------ ------ ------ ------ ------ ------ ------ ------
253 =head2 The original Dylan paper
257 =item L<http://www.webcom.com/haahr/dylan/linearization-oopsla96.html>
261 =head2 The prototype Perl 6 Object Model uses C3
265 =item L<http://svn.openfoundry.org/pugs/perl5/Perl6-MetaModel/>
269 =head2 Parrot now uses C3
273 =item L<http://aspn.activestate.com/ASPN/Mail/Message/perl6-internals/2746631>
275 =item L<http://use.perl.org/~autrijus/journal/25768>
279 =head2 Python 2.3 MRO related links
283 =item L<http://www.python.org/2.3/mro.html>
285 =item L<http://www.python.org/2.2.2/descrintro.html#mro>
289 =head2 C3 for TinyCLOS
293 =item L<http://www.call-with-current-continuation.org/eggs/c3.html>
299 Stevan Little, E<lt>stevan@iinteractive.comE<gt>
301 Brandon L. Black, E<lt>blblack@gmail.comE<gt>
303 =head1 COPYRIGHT AND LICENSE
305 Copyright 2006 by Infinity Interactive, Inc.
307 L<http://www.iinteractive.com>
309 This library is free software; you can redistribute it and/or modify
310 it under the same terms as Perl itself.