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