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