File Coverage

blib/lib/Algorithm/C3.pm
Criterion Covered Total %
statement 66 66 100.0
branch 24 24 100.0
condition 13 13 100.0
subroutine 4 4 100.0
pod 1 1 100.0
total 108 108 100.0


line stmt bran cond sub pod time code
1              
2             package Algorithm::C3;
3              
4 13     13   177 use strict;
  13         165  
  13         253  
5 13     13   219 use warnings;
  13         117  
  13         211  
6              
7 13     13   225 use Carp 'confess';
  13         111  
  13         293  
8              
9             our $VERSION = '0.06';
10              
11             sub merge {
12 66     66 1 9811     my ($root, $parent_fetcher, $cache) = @_;
13              
14 66   100     2746     $cache ||= {};
15 66         609     my @STACK; # stack for simulating recursion
16              
17 66         1008     my $pfetcher_is_coderef = ref($parent_fetcher) eq 'CODE';
18              
19 66 100 100     1227     unless ($pfetcher_is_coderef or $root->can($parent_fetcher)) {
20 1         15         confess "Could not find method $parent_fetcher in $root";
21                 }
22              
23 65         584     my $current_root = $root;
24 65         1406     my $current_parents = [ $root->$parent_fetcher ];
25 65         1542     my $recurse_mergeout = [];
26 65         632     my $i = 0;
27 65         836     my %seen = ( $root => 1 );
28              
29 65         561     while(1) {
30 794 100       8581         if($i < @$current_parents) {
31 387         4298             my $new_root = $current_parents->[$i++];
32              
33 387 100       5667             if($seen{$new_root}) {
34 27         504                 my @isastack = (
35 8         77                     (map { $_->[0] } @STACK),
36                                 $current_root,
37                                 $new_root
38                             );
39 8         105                 shift @isastack while $isastack[0] ne $new_root;
40 8         89                 my $isastack = join(q{ -> }, @isastack);
41 8         155                 die "Infinite loop detected in parents of '$root': $isastack";
42                         }
43 379         4600             $seen{$new_root} = 1;
44              
45 379 100 100     4680             unless ($pfetcher_is_coderef or $new_root->can($parent_fetcher)) {
46 1         16                 confess "Could not find method $parent_fetcher in $new_root";
47                         }
48              
49 378         4997             push(@STACK, [
50                             $current_root,
51                             $current_parents,
52                             $recurse_mergeout,
53                             $i,
54                         ]);
55              
56 378         4562             $current_root = $new_root;
57 378   100     4953             $current_parents = $cache->{pfetch}->{$current_root} ||= [ $current_root->$parent_fetcher ];
58 378         7779             $recurse_mergeout = [];
59 378         3544             $i = 0;
60 378         3741             next;
61                     }
62              
63 407         3653         $seen{$current_root} = 0;
64              
65 407   100     4930         my $mergeout = $cache->{merge}->{$current_root} ||= do {
66              
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 :)
70              
71             # Initial set (make sure everything is copied - it will be modded)
72 221         2161             my @seqs = map { [@$_] } (@$recurse_mergeout, $current_parents);
  431         5888  
73              
74             # Construct the tail-checking hash
75 221         2041             my %tails;
76 221         1995             foreach my $seq (@seqs) {
77 431         3673                 $tails{$_}++ for (@$seq[1..$#$seq]);
  431         6768  
78                         }
79              
80 221         2583             my @res = ( $current_root );
81 221         1822             while (1) {
82 750         7185                 my $cand;
83 750         6164                 my $winner;
84 750         6792                 foreach (@seqs) {
85 1971 100       30908                     next if !@$_;
86 1129 100       11839                     if(!$winner) { # looking for a winner
87 601         8843                         $cand = $_->[0]; # seq head is candidate
88 601 100       7445                         next if $tails{$cand}; # he loses if in %tails
89 529         7549                         push @res => $winner = $cand;
90                                 }
91 1057 100       11742                     if($_->[0] eq $winner) {
92 825         7727                         shift @$_; # strip off our winner
93 825 100       14039                         $tails{$_->[0]}-- if @$_; # keep %tails sane
94                                 }
95                             }
96 750 100       7741                 last if !$cand;
97 530 100       14298                 die q{Inconsistent hierarchy found while merging '}
98                                 . $current_root . qq{':\n\t}
99                                 . qq{current merge results [\n\t\t}
100                                 . (join ",\n\t\t" => @res)
101                                 . qq{\n\t]\n\t} . qq{merging failed on '$cand'\n}
102                               if !$winner;
103                         }
104 220         3521             \@res;
105                     };
106              
107 406 100       5451         return @$mergeout if !@STACK;
108              
109 351         3899         ($current_root, $current_parents, $recurse_mergeout, $i)
110 351         3051             = @{pop @STACK};
111              
112 351         3940         push(@$recurse_mergeout, $mergeout);
113                 }
114             }
115              
116             1;
117              
118             __END__
119            
120             =pod
121            
122             =head1 NAME
123            
124             Algorithm::C3 - A module for merging hierarchies using the C3 algorithm
125            
126             =head1 SYNOPSIS
127            
128             use Algorithm::C3;
129            
130             # merging a classic diamond
131             # inheritence graph like this:
132             #
133             # <A>
134             # / \
135             # <B> <C>
136             # \ /
137             # <D>
138            
139             my @merged = Algorithm::C3::merge(
140             'D',
141             sub {
142             # extract the ISA array
143             # from the package
144             no strict 'refs';
145             @{$_[0] . '::ISA'};
146             }
147             );
148            
149             print join ", " => @merged; # prints D, B, C, A
150            
151             =head1 DESCRIPTION
152            
153             This module implements the C3 algorithm. I have broken this out
154             into it's own module because I found myself copying and pasting
155             it way too often for various needs. Most of the uses I have for
156             C3 revolve around class building and metamodels, but it could
157             also be used for things like dependency resolution as well since
158             it tends to do such a nice job of preserving local precendence
159             orderings.
160            
161             Below is a brief explanation of C3 taken from the L<Class::C3>
162             module. For more detailed information, see the L<SEE ALSO> section
163             and the links there.
164            
165             =head2 What is C3?
166            
167             C3 is the name of an algorithm which aims to provide a sane method
168             resolution order under multiple inheritence. It was first introduced
169             in the langauge Dylan (see links in the L<SEE ALSO> section), and
170             then later adopted as the prefered MRO (Method Resolution Order)
171             for the new-style classes in Python 2.3. Most recently it has been
172             adopted as the 'canonical' MRO for Perl 6 classes, and the default
173             MRO for Parrot objects as well.
174            
175             =head2 How does C3 work.
176            
177             C3 works by always preserving local precendence ordering. This
178             essentially means that no class will appear before any of it's
179             subclasses. Take the classic diamond inheritence pattern for
180             instance:
181            
182             <A>
183             / \
184             <B> <C>
185             \ /
186             <D>
187            
188             The standard Perl 5 MRO would be (D, B, A, C). The result being that
189             B<A> appears before B<C>, even though B<C> is the subclass of B<A>.
190             The C3 MRO algorithm however, produces the following MRO (D, B, C, A),
191             which does not have this same issue.
192            
193             This example is fairly trival, for more complex examples and a deeper
194             explaination, see the links in the L<SEE ALSO> section.
195            
196             =head1 FUNCTION
197            
198             =over 4
199            
200             =item B<merge ($root, $func_to_fetch_parent, $cache)>
201            
202             This takes a C<$root> node, which can be anything really it
203             is up to you. Then it takes a C<$func_to_fetch_parent> which
204             can be either a CODE reference (see L<SYNOPSIS> above for an
205             example), or a string containing a method name to be called
206             on all the items being linearized. An example of how this
207             might look is below:
208            
209             {
210             package A;
211            
212             sub supers {
213             no strict 'refs';
214             @{$_[0] . '::ISA'};
215             }
216            
217             package C;
218             our @ISA = ('A');
219             package B;
220             our @ISA = ('A');
221             package D;
222             our @ISA = ('B', 'C');
223             }
224            
225             print join ", " => Algorithm::C3::merge('D', 'supers');
226            
227             The purpose of C<$func_to_fetch_parent> is to provide a way
228             for C<merge> to extract the parents of C<$root>. This is
229             needed for C3 to be able to do it's work.
230            
231             The C<$cache> parameter is an entirely optional performance
232             measure, and should not change behavior.
233            
234             If supplied, it should be a hashref that merge can use as a
235             private cache between runs to speed things up. Generally
236             speaking, if you will be calling merge many times on related
237             things, and the parent fetching function will return constant
238             results given the same arguments during all of these calls,
239             you can and should reuse the same shared cache hash for all
240             of the calls. Example:
241            
242             sub do_some_merging {
243             my %merge_cache;
244             my @foo_mro = Algorithm::C3::Merge('Foo', \&get_supers, \%merge_cache);
245             my @bar_mro = Algorithm::C3::Merge('Bar', \&get_supers, \%merge_cache);
246             my @baz_mro = Algorithm::C3::Merge('Baz', \&get_supers, \%merge_cache);
247             my @quux_mro = Algorithm::C3::Merge('Quux', \&get_supers, \%merge_cache);
248             # ...
249             }
250            
251             =back
252            
253             =head1 CODE COVERAGE
254            
255             I use B<Devel::Cover> to test the code coverage of my tests, below
256             is the B<Devel::Cover> report on this module's test suite.
257            
258             ------------------------ ------ ------ ------ ------ ------ ------ ------
259             File stmt bran cond sub pod time total
260             ------------------------ ------ ------ ------ ------ ------ ------ ------
261             Algorithm/C3.pm 100.0 100.0 100.0 100.0 100.0 100.0 100.0
262             ------------------------ ------ ------ ------ ------ ------ ------ ------
263             Total 100.0 100.0 100.0 100.0 100.0 100.0 100.0
264             ------------------------ ------ ------ ------ ------ ------ ------ ------
265            
266             =head1 SEE ALSO
267            
268             =head2 The original Dylan paper
269            
270             =over 4
271            
272             =item L<http://www.webcom.com/haahr/dylan/linearization-oopsla96.html>
273            
274             =back
275            
276             =head2 The prototype Perl 6 Object Model uses C3
277            
278             =over 4
279            
280             =item L<http://svn.openfoundry.org/pugs/perl5/Perl6-MetaModel/>
281            
282             =back
283            
284             =head2 Parrot now uses C3
285            
286             =over 4
287            
288             =item L<http://aspn.activestate.com/ASPN/Mail/Message/perl6-internals/2746631>
289            
290             =item L<http://use.perl.org/~autrijus/journal/25768>
291            
292             =back
293            
294             =head2 Python 2.3 MRO related links
295            
296             =over 4
297            
298             =item L<http://www.python.org/2.3/mro.html>
299            
300             =item L<http://www.python.org/2.2.2/descrintro.html#mro>
301            
302             =back
303            
304             =head2 C3 for TinyCLOS
305            
306             =over 4
307            
308             =item L<http://www.call-with-current-continuation.org/eggs/c3.html>
309            
310             =back
311            
312             =head1 AUTHORS
313            
314             Stevan Little, E<lt>stevan@iinteractive.comE<gt>
315            
316             Brandon L. Black, E<lt>blblack@gmail.comE<gt>
317            
318             =head1 COPYRIGHT AND LICENSE
319            
320             Copyright 2006 by Infinity Interactive, Inc.
321            
322             L<http://www.iinteractive.com>
323            
324             This library is free software; you can redistribute it and/or modify
325             it under the same terms as Perl itself.
326            
327             =cut
328