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