Commit | Line | Data |
95bebf8c |
1 | |
2 | package Class::C3; |
3 | |
4 | use strict; |
5 | use warnings; |
6 | |
7 | our $VERSION = '0.01'; |
8 | |
9 | use Scalar::Util 'blessed'; |
10 | |
11 | my %MRO; |
12 | |
13 | sub import { |
14 | my $class = caller(); |
15 | return if $class eq 'main'; |
16 | $MRO{$class} = undef; |
17 | } |
18 | |
19 | INIT { |
20 | no strict 'refs'; |
21 | foreach my $class (keys %MRO) { |
22 | my @MRO = calculateMRO($class); |
23 | $MRO{$class} = { MRO => \@MRO }; |
24 | my %methods; |
25 | foreach my $local (@MRO[1 .. $#MRO]) { |
26 | foreach my $method (grep { defined &{"${local}::$_"} } keys %{"${local}::"}) { |
27 | next unless !defined *{"${class}::$method"}{CODE}; |
28 | if (!exists $methods{$method}) { |
29 | $methods{$method} = { |
30 | orig => "${local}::$method", |
31 | code => \&{"${local}::$method"} |
32 | }; |
33 | } |
34 | } |
35 | } |
36 | $MRO{$class}->{methods} = \%methods; |
37 | } |
38 | #use Data::Dumper; warn Dumper \%MRO; |
39 | foreach my $class (keys %MRO) { |
40 | #warn "installing methods (" . (join ", " => keys %{$MRO{$class}->{methods}}) . ") for $class"; |
41 | foreach my $method (keys %{$MRO{$class}->{methods}}) { |
42 | #warn "Installing ${class}::$method using " . $MRO{$class}->{methods}->{$method}->{orig}; |
43 | *{"${class}::$method"} = $MRO{$class}->{methods}->{$method}->{code}; |
44 | } |
45 | } |
46 | } |
47 | |
48 | sub _merge { |
49 | my (@seqs) = @_; |
50 | my @res; |
51 | while (1) { |
52 | # remove all empty seqences |
53 | my @nonemptyseqs = (map { (@{$_} ? $_ : ()) } @seqs); |
54 | # return the list if we have no more no-empty sequences |
55 | return @res if not @nonemptyseqs; |
56 | my $cand; # a canidate .. |
57 | foreach my $seq (@nonemptyseqs) { |
58 | $cand = $seq->[0]; # get the head of the list |
59 | my $nothead; |
60 | foreach my $sub_seq (@nonemptyseqs) { |
61 | # XXX - this is instead of the python "in" |
62 | my %in_tail = (map { $_ => 1 } @{$sub_seq}[ 1 .. $#{$sub_seq} ]); |
63 | # NOTE: |
64 | # jump out as soon as we find one matching |
65 | # there is no reason not too. However, if |
66 | # we find one, then just remove the '&& last' |
67 | $nothead++ && last if exists $in_tail{$cand}; |
68 | } |
69 | last unless $nothead; # leave the loop with our canidate ... |
70 | $cand = undef; # otherwise, reject it ... |
71 | } |
72 | die "Inconsistent hierarchy" if not $cand; |
73 | push @res => $cand; |
74 | # now loop through our non-empties and pop |
75 | # off the head if it matches our canidate |
76 | foreach my $seq (@nonemptyseqs) { |
77 | shift @{$seq} if $seq->[0] eq $cand; |
78 | } |
79 | } |
80 | } |
81 | |
82 | sub calculateMRO { |
83 | my ($class) = @_; |
84 | no strict 'refs'; |
85 | return _merge( |
86 | [ $class ], # the class we are linearizing |
87 | (map { [ calculateMRO($_) ] } @{"${class}::ISA"}), # the MRO of all the superclasses |
88 | [ @{"${class}::ISA"} ] # a list of all the superclasses |
89 | ); |
90 | } |
91 | |
92 | 1; |
93 | |
94 | __END__ |
95 | |
96 | =pod |
97 | |
98 | =head1 NAME |
99 | |
100 | Class::C3 - A pragma to use the C3 method resolution order algortihm |
101 | |
102 | =head1 SYNOPSIS |
103 | |
104 | package A; |
105 | use Class::C3; |
106 | sub hello { 'A::hello' } |
107 | |
108 | package B; |
109 | use base 'A'; |
110 | use Class::C3; |
111 | |
112 | package C; |
113 | use base 'A'; |
114 | use Class::C3; |
115 | |
116 | sub hello { 'C::hello' } |
117 | |
118 | package D; |
119 | use base ('B', 'C'); |
120 | use Class::C3; |
121 | |
122 | # Classic Diamond MI pattern |
123 | # [ A ] |
124 | # / \ |
125 | # [ B ] [ C ] |
126 | # \ / |
127 | # [ D ] |
128 | |
129 | package main; |
130 | |
131 | print join ', ' => Class::C3::calculateMRO('Diamond_D') # prints D, B, C, A |
132 | |
133 | print D->hello() # prints 'C::hello' instead of the standard p5 'A::hello' |
134 | |
135 | D->can('hello')->(); # can() also works correctly |
136 | UNIVERSAL::can('D', 'hello'); # as does UNIVERSAL::can() |
137 | |
138 | =head1 DESCRIPTION |
139 | |
140 | This is currently an experimental pragma to change Perl 5's standard method resolution order |
141 | from depth-first left-to-right (a.k.a - pre-order) to the more sophisticated C3 method resolution |
142 | order. |
143 | |
144 | =head2 What is C3? |
145 | |
146 | C3 is the name of an algorithm which aims to provide a sane method resolution order under multiple |
147 | inheritence. It was first introduced in the langauge Dylan (see links in the L<SEE ALSO> section), |
148 | and then later adopted as the prefered MRO (Method Resolution Order) for the new-style classes in |
149 | Python 2.3. Most recently it has been adopted as the 'canonical' MRO for Perl 6 classes, and the |
150 | default MRO for Parrot objects as well. |
151 | |
152 | =head2 How does C3 work. |
153 | |
154 | C3 works by always preserving local precendence ordering. This essentially means that no class will |
155 | appear before any of it's subclasses. Take the classic diamond inheritence pattern for instance: |
156 | |
157 | [ A ] |
158 | / \ |
159 | [ B ] [ C ] |
160 | \ / |
161 | [ D ] |
162 | |
163 | The standard Perl 5 MRO would be (D, B, A, C). The result being that B<A> appears before B<C>, even |
164 | though B<C> is the subclass of B<A>. The C3 MRO algorithm however, produces the following MRO |
165 | (D, B, C, A), which does not have this same issue. |
166 | |
167 | This example is fairly trival, for more complex examples and a deeper explaination, see the links in |
168 | the L<SEE ALSO> section. |
169 | |
170 | =head2 How does this module work? |
171 | |
172 | This module uses a technique similar to Perl 5's method caching. During the INIT phase, this module |
173 | calculates the MRO of all the classes which called C<use Class::C3>. It then gathers information from |
174 | the symbol tables of each of those classes, and builds a set of method aliases for the correct |
175 | dispatch ordering. Once all these C3-based method tables are created, it then adds the method aliases |
176 | into the local classes symbol table. |
177 | |
178 | The end result is actually classes with pre-cached method dispatch. However, this caching does not |
179 | do well if you start changing your C<@ISA> or messing with class symbol tables, so you should consider |
180 | your classes to be effectively closed. See the L<CAVEATS> section for more details. |
181 | |
182 | =head1 FUNCTIONS |
183 | |
184 | =over 4 |
185 | |
186 | =item B<calculateMRO ($class)> |
187 | |
188 | Given a C<$class> this will return an array of class names in the proper C3 method resolution order. |
189 | |
190 | =back |
191 | |
192 | =head1 CAVEATS |
193 | |
194 | Let me first say, this is an experimental module, and so it should not be used for anything other |
195 | then other experimentation for the time being. |
196 | |
197 | That said, it is the authors intention to make this into a completely usable and production stable |
198 | module if possible. Time will tell. |
199 | |
200 | And now, onto the caveats. |
201 | |
202 | =over 4 |
203 | |
204 | =item Use of C<SUPER::>. |
205 | |
206 | The idea of C<SUPER::> under multiple inheritence is ambigious, and generally not recomended anyway. |
207 | However, it's use in conjuntion with this module is very much not recommended, and in fact very |
208 | discouraged. In the future I plan to support a C<NEXT::> style interface to be used to move to the |
209 | next most appropriate method in the MRO. |
210 | |
211 | =item Changing C<@ISA>. |
212 | |
213 | It is the author's opinion that changing C<@ISA> at runtime is pure insanity anyway. However, people |
214 | do it, so I must caveat. Any changes to the C<@ISA> will not be reflected in the MRO calculated by this |
215 | module, and therefor probably won't even show up. I am considering some kind of C<recalculateMRO> function |
216 | which can be used to recalculate the MRO on demand at runtime, but that is still off in the future. |
217 | |
218 | =item Adding/deleting methods from class symbol tables. |
219 | |
220 | This module calculates the MRO for each requested class during the INIT phase by interogatting the symbol |
221 | tables of said classes. So any symbol table manipulation which takes place after our INIT phase is run will |
222 | not be reflected in the calculated MRO. |
223 | |
224 | =item Not for use with mod_perl |
225 | |
226 | Since this module utilizes the INIT phase, it cannot be easily used with mod_perl. If this module works out |
227 | and proves useful in the I<real world>, I will most likely be supporting mod_perl in some way. |
228 | |
229 | =back |
230 | |
15eeb546 |
231 | =head1 TODO |
232 | |
233 | =over 4 |
234 | |
235 | =item More tests |
236 | |
237 | You can never have enough tests :) |
238 | |
239 | I need to convert the other MRO and class-precendence-list related tests from the Perl6-MetaModel (see link |
240 | in L<SEE ALSO>). In addition, I need to add some method checks to these tests as well. |
241 | |
242 | =item call-next-method / NEXT:: / next METHOD |
243 | |
244 | I am contemplating some kind of psudeo-package which can dispatch to the next most relevant method in the |
245 | MRO. This should not be too hard to implement when the time comes. |
246 | |
247 | =item recalculateMRO |
248 | |
249 | This being Perl, it would be remiss of me to force people to close thier classes at runtime. So I need to |
250 | develop a means for recalculating the MRO for a given class. |
251 | |
252 | =back |
253 | |
95bebf8c |
254 | =head1 SEE ALSO |
255 | |
256 | =head2 The original Dylan paper |
257 | |
258 | =over 4 |
259 | |
260 | =item L<http://www.webcom.com/haahr/dylan/linearization-oopsla96.html> |
261 | |
262 | =back |
263 | |
264 | =head2 The prototype Perl 6 Object Model uses C3 |
265 | |
266 | =over 4 |
267 | |
268 | =item L<http://svn.openfoundry.org/pugs/perl5/Perl6-MetaModel/> |
269 | |
270 | =back |
271 | |
272 | =head2 Parrot now uses C3 |
273 | |
274 | =over 4 |
275 | |
276 | =item L<http://aspn.activestate.com/ASPN/Mail/Message/perl6-internals/2746631> |
277 | |
278 | =item L<http://use.perl.org/~autrijus/journal/25768> |
279 | |
280 | =back |
281 | |
282 | =head2 Python 2.3 MRO related links |
283 | |
284 | =over 4 |
285 | |
286 | =item L<http://www.python.org/2.3/mro.html> |
287 | |
288 | =item L<http://www.python.org/2.2.2/descrintro.html#mro> |
289 | |
290 | =back |
291 | |
292 | =head2 C3 for TinyCLOS |
293 | |
294 | =over 4 |
295 | |
296 | =item L<http://www.call-with-current-continuation.org/eggs/c3.html> |
297 | |
298 | =back |
299 | |
300 | =head1 AUTHOR |
301 | |
302 | stevan little, E<lt>stevan@iinteractive.comE<gt> |
303 | |
304 | =head1 COPYRIGHT AND LICENSE |
305 | |
306 | Copyright 2005 by Infinity Interactive, Inc. |
307 | |
308 | L<http://www.iinteractive.com> |
309 | |
310 | This library is free software; you can redistribute it and/or modify |
311 | it under the same terms as Perl itself. |
312 | |
313 | =cut |