Commit | Line | Data |
95bebf8c |
1 | |
2 | package Class::C3; |
3 | |
4 | use strict; |
5 | use warnings; |
6 | |
95bebf8c |
7 | use Scalar::Util 'blessed'; |
8 | |
bad9dc59 |
9 | our $VERSION = '0.09'; |
d401eda1 |
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> |
680100b1 |
21 | # }, |
22 | # has_overload_fallback => (1 | 0) |
d401eda1 |
23 | # } |
24 | # |
f7facd7b |
25 | our %MRO; |
95bebf8c |
26 | |
d0e2efe5 |
27 | # use these for debugging ... |
d401eda1 |
28 | sub _dump_MRO_table { %MRO } |
d401eda1 |
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 |
f7facd7b |
39 | $MRO{$class} = undef unless exists $MRO{$class}; |
95bebf8c |
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(); |
5d5c86d9 |
59 | %next::METHOD_CACHE = (); |
d401eda1 |
60 | } |
61 | |
d0e2efe5 |
62 | sub uninitialize { |
63 | # why bother if we don't have anything ... |
64 | return unless keys %MRO; |
65 | _remove_method_dispatch_tables(); |
5d5c86d9 |
66 | %next::METHOD_CACHE = (); |
d0e2efe5 |
67 | } |
68 | |
69 | sub reinitialize { |
70 | uninitialize(); |
71 | # clean up the %MRO before we re-initialize |
72 | $MRO{$_} = undef foreach keys %MRO; |
73 | initialize(); |
74 | } |
75 | |
d401eda1 |
76 | ## functions for applying C3 to classes |
77 | |
78 | sub _calculate_method_dispatch_tables { |
95bebf8c |
79 | foreach my $class (keys %MRO) { |
d401eda1 |
80 | _calculate_method_dispatch_table($class); |
95bebf8c |
81 | } |
d401eda1 |
82 | } |
83 | |
84 | sub _calculate_method_dispatch_table { |
85 | my $class = shift; |
86 | no strict 'refs'; |
87 | my @MRO = calculateMRO($class); |
88 | $MRO{$class} = { MRO => \@MRO }; |
680100b1 |
89 | my $has_overload_fallback = 0; |
d401eda1 |
90 | my %methods; |
91 | # NOTE: |
92 | # we do @MRO[1 .. $#MRO] here because it |
93 | # makes no sense to interogate the class |
94 | # which you are calculating for. |
95 | foreach my $local (@MRO[1 .. $#MRO]) { |
680100b1 |
96 | # if overload has tagged this module to |
97 | # have use "fallback", then we want to |
98 | # grab that value |
99 | $has_overload_fallback = ${"${local}::()"} |
100 | if defined ${"${local}::()"}; |
d401eda1 |
101 | foreach my $method (grep { defined &{"${local}::$_"} } keys %{"${local}::"}) { |
102 | # skip if already overriden in local class |
103 | next unless !defined *{"${class}::$method"}{CODE}; |
104 | $methods{$method} = { |
105 | orig => "${local}::$method", |
106 | code => \&{"${local}::$method"} |
107 | } unless exists $methods{$method}; |
95bebf8c |
108 | } |
d401eda1 |
109 | } |
110 | # now stash them in our %MRO table |
680100b1 |
111 | $MRO{$class}->{methods} = \%methods; |
112 | $MRO{$class}->{has_overload_fallback} = $has_overload_fallback; |
d401eda1 |
113 | } |
114 | |
115 | sub _apply_method_dispatch_tables { |
116 | foreach my $class (keys %MRO) { |
117 | _apply_method_dispatch_table($class); |
118 | } |
95bebf8c |
119 | } |
120 | |
d401eda1 |
121 | sub _apply_method_dispatch_table { |
122 | my $class = shift; |
123 | no strict 'refs'; |
680100b1 |
124 | ${"${class}::()"} = $MRO{$class}->{has_overload_fallback} |
125 | if $MRO{$class}->{has_overload_fallback}; |
d401eda1 |
126 | foreach my $method (keys %{$MRO{$class}->{methods}}) { |
127 | *{"${class}::$method"} = $MRO{$class}->{methods}->{$method}->{code}; |
128 | } |
129 | } |
130 | |
d0e2efe5 |
131 | sub _remove_method_dispatch_tables { |
132 | foreach my $class (keys %MRO) { |
133 | _remove_method_dispatch_table($class); |
134 | } |
135 | } |
136 | |
137 | sub _remove_method_dispatch_table { |
138 | my $class = shift; |
139 | no strict 'refs'; |
680100b1 |
140 | delete ${"${class}::"}{"()"} if $MRO{$class}->{has_overload_fallback}; |
d0e2efe5 |
141 | foreach my $method (keys %{$MRO{$class}->{methods}}) { |
5dd9299c |
142 | delete ${"${class}::"}{$method} |
143 | if defined *{"${class}::${method}"}{CODE} && |
144 | (*{"${class}::${method}"}{CODE} eq $MRO{$class}->{methods}->{$method}->{code}); |
d0e2efe5 |
145 | } |
146 | } |
147 | |
d401eda1 |
148 | ## functions for calculating C3 MRO |
149 | |
150 | # this function is a perl-port of the |
151 | # python code on this page: |
152 | # http://www.python.org/2.3/mro.html |
95bebf8c |
153 | sub _merge { |
154 | my (@seqs) = @_; |
4e47d2a4 |
155 | my $class_being_merged = $seqs[0]->[0]; |
95bebf8c |
156 | my @res; |
157 | while (1) { |
158 | # remove all empty seqences |
159 | my @nonemptyseqs = (map { (@{$_} ? $_ : ()) } @seqs); |
160 | # return the list if we have no more no-empty sequences |
161 | return @res if not @nonemptyseqs; |
4e47d2a4 |
162 | my $reject; |
95bebf8c |
163 | my $cand; # a canidate .. |
164 | foreach my $seq (@nonemptyseqs) { |
165 | $cand = $seq->[0]; # get the head of the list |
166 | my $nothead; |
167 | foreach my $sub_seq (@nonemptyseqs) { |
168 | # XXX - this is instead of the python "in" |
169 | my %in_tail = (map { $_ => 1 } @{$sub_seq}[ 1 .. $#{$sub_seq} ]); |
170 | # NOTE: |
171 | # jump out as soon as we find one matching |
172 | # there is no reason not too. However, if |
173 | # we find one, then just remove the '&& last' |
ac6b0914 |
174 | ++$nothead && last if exists $in_tail{$cand}; |
95bebf8c |
175 | } |
176 | last unless $nothead; # leave the loop with our canidate ... |
4e47d2a4 |
177 | $reject = $cand; |
95bebf8c |
178 | $cand = undef; # otherwise, reject it ... |
179 | } |
4e47d2a4 |
180 | die "Inconsistent hierarchy found while merging '$class_being_merged':\n\t" . |
181 | "current merge results [\n\t\t" . (join ",\n\t\t" => @res) . "\n\t]\n\t" . |
182 | "mergeing failed on '$reject'\n" if not $cand; |
95bebf8c |
183 | push @res => $cand; |
184 | # now loop through our non-empties and pop |
185 | # off the head if it matches our canidate |
186 | foreach my $seq (@nonemptyseqs) { |
187 | shift @{$seq} if $seq->[0] eq $cand; |
188 | } |
189 | } |
190 | } |
191 | |
192 | sub calculateMRO { |
193 | my ($class) = @_; |
194 | no strict 'refs'; |
195 | return _merge( |
196 | [ $class ], # the class we are linearizing |
197 | (map { [ calculateMRO($_) ] } @{"${class}::ISA"}), # the MRO of all the superclasses |
198 | [ @{"${class}::ISA"} ] # a list of all the superclasses |
199 | ); |
200 | } |
201 | |
5d5c86d9 |
202 | package # hide me from PAUSE |
203 | next; |
204 | |
205 | use strict; |
206 | use warnings; |
207 | |
208 | use Scalar::Util 'blessed'; |
209 | |
ac6b0914 |
210 | our $VERSION = '0.05'; |
5d5c86d9 |
211 | |
212 | our %METHOD_CACHE; |
213 | |
214 | sub method { |
ac6b0914 |
215 | my $level = 1; |
7bb662d7 |
216 | my ($method_caller, $label, @label); |
ac6b0914 |
217 | while ($method_caller = (caller($level++))[3]) { |
7bb662d7 |
218 | @label = (split '::', $method_caller); |
219 | $label = pop @label; |
220 | last unless |
221 | $label eq '(eval)' || |
222 | $label eq '__ANON__'; |
ac6b0914 |
223 | } |
5d5c86d9 |
224 | my $caller = join '::' => @label; |
225 | my $self = $_[0]; |
226 | my $class = blessed($self) || $self; |
227 | |
228 | goto &{ $METHOD_CACHE{"$class|$caller|$label"} ||= do { |
229 | |
230 | my @MRO = Class::C3::calculateMRO($class); |
231 | |
232 | my $current; |
233 | while ($current = shift @MRO) { |
234 | last if $caller eq $current; |
235 | } |
236 | |
237 | no strict 'refs'; |
238 | my $found; |
239 | foreach my $class (@MRO) { |
f7facd7b |
240 | next if (defined $Class::C3::MRO{$class} && |
241 | defined $Class::C3::MRO{$class}{methods}{$label}); |
5d5c86d9 |
242 | last if (defined ($found = *{$class . '::' . $label}{CODE})); |
243 | } |
244 | |
245 | die "No next::method '$label' found for $self" unless $found; |
246 | |
247 | $found; |
248 | } }; |
249 | } |
250 | |
95bebf8c |
251 | 1; |
252 | |
253 | __END__ |
254 | |
255 | =pod |
256 | |
257 | =head1 NAME |
258 | |
259 | Class::C3 - A pragma to use the C3 method resolution order algortihm |
260 | |
261 | =head1 SYNOPSIS |
262 | |
263 | package A; |
264 | use Class::C3; |
265 | sub hello { 'A::hello' } |
266 | |
267 | package B; |
268 | use base 'A'; |
269 | use Class::C3; |
270 | |
271 | package C; |
272 | use base 'A'; |
273 | use Class::C3; |
274 | |
275 | sub hello { 'C::hello' } |
276 | |
277 | package D; |
278 | use base ('B', 'C'); |
279 | use Class::C3; |
280 | |
281 | # Classic Diamond MI pattern |
d401eda1 |
282 | # <A> |
283 | # / \ |
284 | # <B> <C> |
285 | # \ / |
286 | # <D> |
95bebf8c |
287 | |
288 | package main; |
289 | |
290 | print join ', ' => Class::C3::calculateMRO('Diamond_D') # prints D, B, C, A |
291 | |
292 | print D->hello() # prints 'C::hello' instead of the standard p5 'A::hello' |
293 | |
294 | D->can('hello')->(); # can() also works correctly |
295 | UNIVERSAL::can('D', 'hello'); # as does UNIVERSAL::can() |
296 | |
297 | =head1 DESCRIPTION |
298 | |
299 | This is currently an experimental pragma to change Perl 5's standard method resolution order |
300 | from depth-first left-to-right (a.k.a - pre-order) to the more sophisticated C3 method resolution |
301 | order. |
302 | |
303 | =head2 What is C3? |
304 | |
305 | C3 is the name of an algorithm which aims to provide a sane method resolution order under multiple |
306 | inheritence. It was first introduced in the langauge Dylan (see links in the L<SEE ALSO> section), |
307 | and then later adopted as the prefered MRO (Method Resolution Order) for the new-style classes in |
308 | Python 2.3. Most recently it has been adopted as the 'canonical' MRO for Perl 6 classes, and the |
309 | default MRO for Parrot objects as well. |
310 | |
311 | =head2 How does C3 work. |
312 | |
313 | C3 works by always preserving local precendence ordering. This essentially means that no class will |
314 | appear before any of it's subclasses. Take the classic diamond inheritence pattern for instance: |
315 | |
d401eda1 |
316 | <A> |
317 | / \ |
318 | <B> <C> |
319 | \ / |
320 | <D> |
95bebf8c |
321 | |
322 | The standard Perl 5 MRO would be (D, B, A, C). The result being that B<A> appears before B<C>, even |
323 | though B<C> is the subclass of B<A>. The C3 MRO algorithm however, produces the following MRO |
324 | (D, B, C, A), which does not have this same issue. |
325 | |
326 | This example is fairly trival, for more complex examples and a deeper explaination, see the links in |
327 | the L<SEE ALSO> section. |
328 | |
329 | =head2 How does this module work? |
330 | |
331 | This module uses a technique similar to Perl 5's method caching. During the INIT phase, this module |
332 | calculates the MRO of all the classes which called C<use Class::C3>. It then gathers information from |
333 | the symbol tables of each of those classes, and builds a set of method aliases for the correct |
334 | dispatch ordering. Once all these C3-based method tables are created, it then adds the method aliases |
335 | into the local classes symbol table. |
336 | |
337 | The end result is actually classes with pre-cached method dispatch. However, this caching does not |
338 | do well if you start changing your C<@ISA> or messing with class symbol tables, so you should consider |
339 | your classes to be effectively closed. See the L<CAVEATS> section for more details. |
340 | |
d401eda1 |
341 | =head1 OPTIONAL LOWERCASE PRAGMA |
342 | |
343 | This release also includes an optional module B<c3> in the F<opt/> folder. I did not include this in |
344 | the regular install since lowercase module names are considered I<"bad"> by some people. However I |
345 | think that code looks much nicer like this: |
346 | |
347 | package MyClass; |
348 | use c3; |
349 | |
350 | The the more clunky: |
351 | |
352 | package MyClass; |
353 | use Class::C3; |
354 | |
355 | But hey, it's your choice, thats why it is optional. |
356 | |
95bebf8c |
357 | =head1 FUNCTIONS |
358 | |
359 | =over 4 |
360 | |
361 | =item B<calculateMRO ($class)> |
362 | |
363 | Given a C<$class> this will return an array of class names in the proper C3 method resolution order. |
364 | |
d401eda1 |
365 | =item B<initialize> |
366 | |
367 | This can be used to initalize the C3 method dispatch tables. You need to call this if you are running |
368 | under mod_perl, or in any other environment which does not run the INIT phase of the perl compiler. |
369 | |
370 | NOTE: |
d0e2efe5 |
371 | This can B<not> be used to re-load the dispatch tables for all classes. Use C<reinitialize> for that. |
372 | |
373 | =item B<uninitialize> |
374 | |
375 | Calling this function results in the removal of all cached methods, and the restoration of the old Perl 5 |
376 | style dispatch order (depth-first, left-to-right). |
377 | |
378 | =item B<reinitialize> |
379 | |
380 | This effectively calls C<uninitialize> followed by C<initialize> the result of which is a reloading of |
381 | B<all> the calculated C3 dispatch tables. |
382 | |
383 | It should be noted that if you have a large class library, this could potentially be a rather costly |
384 | operation. |
d401eda1 |
385 | |
95bebf8c |
386 | =back |
387 | |
5d5c86d9 |
388 | =head1 METHOD REDISPATCHING |
389 | |
390 | It is always useful to be able to re-dispatch your method call to the "next most applicable method". This |
391 | module provides a pseudo package along the lines of C<SUPER::> or C<NEXT::> which will re-dispatch the |
392 | method along the C3 linearization. This is best show with an examples. |
393 | |
394 | # a classic diamond MI pattern ... |
395 | <A> |
396 | / \ |
397 | <B> <C> |
398 | \ / |
399 | <D> |
400 | |
401 | package A; |
402 | use c3; |
403 | sub foo { 'A::foo' } |
404 | |
405 | package B; |
406 | use base 'A'; |
407 | use c3; |
408 | sub foo { 'B::foo => ' . (shift)->next::method() } |
409 | |
410 | package B; |
411 | use base 'A'; |
412 | use c3; |
413 | sub foo { 'C::foo => ' . (shift)->next::method() } |
414 | |
415 | package D; |
416 | use base ('B', 'C'); |
417 | use c3; |
418 | sub foo { 'D::foo => ' . (shift)->next::method() } |
419 | |
420 | print D->foo; # prints out "D::foo => B::foo => C::foo => A::foo" |
421 | |
422 | A few things to note. First, we do not require you to add on the method name to the C<next::method> |
423 | call (this is unlike C<NEXT::> and C<SUPER::> which do require that). This helps to enforce the rule |
424 | that you cannot dispatch to a method of a different name (this is how C<NEXT::> behaves as well). |
425 | |
426 | The next thing to keep in mind is that you will need to pass all arguments to C<next::method> it can |
427 | not automatically use the current C<@_>. |
428 | |
95bebf8c |
429 | =head1 CAVEATS |
430 | |
431 | Let me first say, this is an experimental module, and so it should not be used for anything other |
432 | then other experimentation for the time being. |
433 | |
434 | That said, it is the authors intention to make this into a completely usable and production stable |
435 | module if possible. Time will tell. |
436 | |
437 | And now, onto the caveats. |
438 | |
439 | =over 4 |
440 | |
441 | =item Use of C<SUPER::>. |
442 | |
443 | The idea of C<SUPER::> under multiple inheritence is ambigious, and generally not recomended anyway. |
444 | However, it's use in conjuntion with this module is very much not recommended, and in fact very |
5d5c86d9 |
445 | discouraged. The recommended approach is to instead use the supplied C<next::method> feature, see |
446 | more details on it's usage above. |
95bebf8c |
447 | |
448 | =item Changing C<@ISA>. |
449 | |
450 | It is the author's opinion that changing C<@ISA> at runtime is pure insanity anyway. However, people |
451 | do it, so I must caveat. Any changes to the C<@ISA> will not be reflected in the MRO calculated by this |
d0e2efe5 |
452 | module, and therefor probably won't even show up. If you do this, you will need to call C<reinitialize> |
453 | in order to recalulate B<all> method dispatch tables. See the C<reinitialize> documentation and an example |
454 | in F<t/20_reinitialize.t> for more information. |
95bebf8c |
455 | |
456 | =item Adding/deleting methods from class symbol tables. |
457 | |
458 | This module calculates the MRO for each requested class during the INIT phase by interogatting the symbol |
459 | tables of said classes. So any symbol table manipulation which takes place after our INIT phase is run will |
d0e2efe5 |
460 | not be reflected in the calculated MRO. Just as with changing the C<@ISA>, you will need to call |
461 | C<reinitialize> for any changes you make to take effect. |
95bebf8c |
462 | |
95bebf8c |
463 | =back |
464 | |
15eeb546 |
465 | =head1 TODO |
466 | |
467 | =over 4 |
468 | |
469 | =item More tests |
470 | |
471 | You can never have enough tests :) |
472 | |
5d5c86d9 |
473 | =back |
15eeb546 |
474 | |
5d5c86d9 |
475 | =head1 CODE COVERAGE |
15eeb546 |
476 | |
ac6b0914 |
477 | I use B<Devel::Cover> to test the code coverage of my tests, below is the B<Devel::Cover> report on this |
478 | module's test suite. |
5d5c86d9 |
479 | |
480 | ---------------------------- ------ ------ ------ ------ ------ ------ ------ |
481 | File stmt bran cond sub pod time total |
482 | ---------------------------- ------ ------ ------ ------ ------ ------ ------ |
5dd9299c |
483 | Class/C3.pm 98.6 90.9 73.3 96.0 100.0 96.8 95.3 |
5d5c86d9 |
484 | ---------------------------- ------ ------ ------ ------ ------ ------ ------ |
5dd9299c |
485 | Total 98.6 90.9 73.3 96.0 100.0 96.8 95.3 |
5d5c86d9 |
486 | ---------------------------- ------ ------ ------ ------ ------ ------ ------ |
15eeb546 |
487 | |
95bebf8c |
488 | =head1 SEE ALSO |
489 | |
490 | =head2 The original Dylan paper |
491 | |
492 | =over 4 |
493 | |
494 | =item L<http://www.webcom.com/haahr/dylan/linearization-oopsla96.html> |
495 | |
496 | =back |
497 | |
498 | =head2 The prototype Perl 6 Object Model uses C3 |
499 | |
500 | =over 4 |
501 | |
502 | =item L<http://svn.openfoundry.org/pugs/perl5/Perl6-MetaModel/> |
503 | |
504 | =back |
505 | |
506 | =head2 Parrot now uses C3 |
507 | |
508 | =over 4 |
509 | |
510 | =item L<http://aspn.activestate.com/ASPN/Mail/Message/perl6-internals/2746631> |
511 | |
512 | =item L<http://use.perl.org/~autrijus/journal/25768> |
513 | |
514 | =back |
515 | |
516 | =head2 Python 2.3 MRO related links |
517 | |
518 | =over 4 |
519 | |
520 | =item L<http://www.python.org/2.3/mro.html> |
521 | |
522 | =item L<http://www.python.org/2.2.2/descrintro.html#mro> |
523 | |
524 | =back |
525 | |
526 | =head2 C3 for TinyCLOS |
527 | |
528 | =over 4 |
529 | |
530 | =item L<http://www.call-with-current-continuation.org/eggs/c3.html> |
531 | |
532 | =back |
533 | |
bad9dc59 |
534 | =head1 ACKNOWLEGEMENTS |
535 | |
536 | =over 4 |
537 | |
538 | =item Thanks to Matt S. Trout for using this module in his module L<DBIx::Class> |
539 | and finding many bugs and providing fixes. |
540 | |
541 | =item Thanks to Justin Guenther for making C<next::method> more robust by handling |
542 | calls inside C<eval> and anon-subs. |
543 | |
544 | =back |
545 | |
95bebf8c |
546 | =head1 AUTHOR |
547 | |
d401eda1 |
548 | Stevan Little, E<lt>stevan@iinteractive.comE<gt> |
95bebf8c |
549 | |
550 | =head1 COPYRIGHT AND LICENSE |
551 | |
552 | Copyright 2005 by Infinity Interactive, Inc. |
553 | |
554 | L<http://www.iinteractive.com> |
555 | |
556 | This library is free software; you can redistribute it and/or modify |
557 | it under the same terms as Perl itself. |
558 | |
559 | =cut |