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