12 my ($root, $parent_fetcher) = @_;
14 my @STACK; # stack for simulating recursion
15 my %fcache; # cache of _fetcher results
16 my %mcache; # cache of merge do-block results
18 my $pfetcher_is_coderef = ref($parent_fetcher) eq 'CODE';
20 unless ($pfetcher_is_coderef or $root->can($parent_fetcher)) {
21 confess "Could not find method $parent_fetcher in $root";
24 my $current_root = $root;
25 my $current_parents = [ $root->$parent_fetcher ];
26 my $recurse_mergeout = [];
30 if($i < @$current_parents) {
31 my $new_root = $current_parents->[$i++];
33 unless ($pfetcher_is_coderef or $new_root->can($parent_fetcher)) {
34 confess "Could not find method $parent_fetcher in $new_root";
44 $current_root = $new_root;
45 $current_parents = $fcache{$current_root} ||= [ $current_root->$parent_fetcher ];
46 $recurse_mergeout = [];
51 my $mergeout = $mcache{$current_root} ||= do {
53 # This do-block is the code formerly known as the function
54 # that was a perl-port of the python code at
55 # http://www.python.org/2.3/mro.html :)
57 # Initial set (make sure everything is copied - it will be modded)
58 my @seqs = map { [@$_] } (@$recurse_mergeout, $current_parents);
60 # Construct the tail-checking hash
62 foreach my $seq (@seqs) {
63 $tails{$_}++ for (@$seq[1..$#$seq]);
66 my @res = ( $current_root );
72 if(!$winner) { # looking for a winner
73 $cand = $_->[0]; # seq head is candidate
74 next if $tails{$cand}; # he loses if in %tails
75 push @res => $winner = $cand;
77 if($_->[0] eq $winner) {
78 shift @$_; # strip off our winner
79 $tails{$_->[0]}-- if @$_; # keep %tails sane
83 die q{Inconsistent hierarchy found while merging '}
84 . $current_root . qq{':\n\t}
85 . qq{current merge results [\n\t\t}
86 . (join ",\n\t\t" => @res)
87 . qq{\n\t]\n\t} . qq{merging failed on '$cand'\n}
93 return @$mergeout if !@STACK;
95 ($current_root, $current_parents, $recurse_mergeout, $i)
98 push(@$recurse_mergeout, $mergeout);
110 Algorithm::C3 - A module for merging hierarchies using the C3 algorithm
116 # merging a classic diamond
117 # inheritence graph like this:
125 my @merged = Algorithm::C3::merge(
128 # extract the ISA array
135 print join ", " => @merged; # prints D, B, C, A
139 This module implements the C3 algorithm. I have broken this out
140 into it's own module because I found myself copying and pasting
141 it way too often for various needs. Most of the uses I have for
142 C3 revolve around class building and metamodels, but it could
143 also be used for things like dependency resolution as well since
144 it tends to do such a nice job of preserving local precendence
147 Below is a brief explanation of C3 taken from the L<Class::C3>
148 module. For more detailed information, see the L<SEE ALSO> section
153 C3 is the name of an algorithm which aims to provide a sane method
154 resolution order under multiple inheritence. It was first introduced
155 in the langauge Dylan (see links in the L<SEE ALSO> section), and
156 then later adopted as the prefered MRO (Method Resolution Order)
157 for the new-style classes in Python 2.3. Most recently it has been
158 adopted as the 'canonical' MRO for Perl 6 classes, and the default
159 MRO for Parrot objects as well.
161 =head2 How does C3 work.
163 C3 works by always preserving local precendence ordering. This
164 essentially means that no class will appear before any of it's
165 subclasses. Take the classic diamond inheritence pattern for
174 The standard Perl 5 MRO would be (D, B, A, C). The result being that
175 B<A> appears before B<C>, even though B<C> is the subclass of B<A>.
176 The C3 MRO algorithm however, produces the following MRO (D, B, C, A),
177 which does not have this same issue.
179 This example is fairly trival, for more complex examples and a deeper
180 explaination, see the links in the L<SEE ALSO> section.
186 =item B<merge ($root, $func_to_fetch_parent)>
188 This takes a C<$root> node, which can be anything really it
189 is up to you. Then it takes a C<$func_to_fetch_parent> which
190 can be either a CODE reference (see L<SYNOPSIS> above for an
191 example), or a string containing a method name to be called
192 on all the items being linearized. An example of how this
208 our @ISA = ('B', 'C');
211 print join ", " => Algorithm::C3::merge('D', 'supers');
213 The purpose of C<$func_to_fetch_parent> is to provide a way
214 for C<merge> to extract the parents of C<$root>. This is
215 needed for C3 to be able to do it's work.
221 I use B<Devel::Cover> to test the code coverage of my tests, below
222 is the B<Devel::Cover> report on this module's test suite.
224 ------------------------ ------ ------ ------ ------ ------ ------ ------
225 File stmt bran cond sub pod time total
226 ------------------------ ------ ------ ------ ------ ------ ------ ------
227 Algorithm/C3.pm 100.0 100.0 100.0 100.0 100.0 100.0 100.0
228 ------------------------ ------ ------ ------ ------ ------ ------ ------
229 Total 100.0 100.0 100.0 100.0 100.0 100.0 100.0
230 ------------------------ ------ ------ ------ ------ ------ ------ ------
234 =head2 The original Dylan paper
238 =item L<http://www.webcom.com/haahr/dylan/linearization-oopsla96.html>
242 =head2 The prototype Perl 6 Object Model uses C3
246 =item L<http://svn.openfoundry.org/pugs/perl5/Perl6-MetaModel/>
250 =head2 Parrot now uses C3
254 =item L<http://aspn.activestate.com/ASPN/Mail/Message/perl6-internals/2746631>
256 =item L<http://use.perl.org/~autrijus/journal/25768>
260 =head2 Python 2.3 MRO related links
264 =item L<http://www.python.org/2.3/mro.html>
266 =item L<http://www.python.org/2.2.2/descrintro.html#mro>
270 =head2 C3 for TinyCLOS
274 =item L<http://www.call-with-current-continuation.org/eggs/c3.html>
280 Stevan Little, E<lt>stevan@iinteractive.comE<gt>
282 Brandon L. Black, E<lt>blblack@gmail.comE<gt>
284 =head1 COPYRIGHT AND LICENSE
286 Copyright 2006 by Infinity Interactive, Inc.
288 L<http://www.iinteractive.com>
290 This library is free software; you can redistribute it and/or modify
291 it under the same terms as Perl itself.