File Coverage

blib/lib/Class/C3.pm
Criterion Covered Total %
statement 132 134 98.5
branch 33 38 86.8
condition 14 18 77.8
subroutine 29 30 96.7
pod 4 4 100.0
total 212 224 94.6


line stmt bran cond sub pod time code
1              
2             package Class::C3;
3              
4 19     19   465 use strict;
  19         634  
  19         483  
5 19     19   332 use warnings;
  19         171  
  19         475  
6              
7 19     19   300 use Scalar::Util 'blessed';
  19         168  
  19         522  
8 19     19   1063 use Algorithm::C3;
  19         197  
  19         452  
9              
10             our $VERSION = '0.14';
11              
12             # this is our global stash of both
13             # MRO's and method dispatch tables
14             # the structure basically looks like
15             # this:
16             #
17             # $MRO{$class} = {
18             # MRO => [ <class precendence list> ],
19             # methods => {
20             # orig => <original location of method>,
21             # code => \&<ref to original method>
22             # },
23             # has_overload_fallback => (1 | 0)
24             # }
25             #
26             our %MRO;
27              
28             # use these for debugging ...
29 0     0   0 sub _dump_MRO_table { %MRO }
30             our $TURN_OFF_C3 = 0;
31              
32             # state tracking for initialize()/uninitialize()
33             our $_initialized = 0;
34              
35             sub import {
36 96     96   1601     my $class = caller();
37             # skip if the caller is main::
38             # since that is clearly not relevant
39 96 100       1131     return if $class eq 'main';
40 79 50       783     return if $TURN_OFF_C3;
41             # make a note to calculate $class
42             # during INIT phase
43 79 50       1266     $MRO{$class} = undef unless exists $MRO{$class};
44             }
45              
46             ## initializers
47              
48             sub initialize {
49             # why bother if we don't have anything ...
50 20 50   20 1 522     return unless keys %MRO;
51 20 100       280     if($_initialized) {
52 2         2709         uninitialize();
53 2         16         $MRO{$_} = undef foreach keys %MRO;
  2         56  
54                 }
55 20         338     _calculate_method_dispatch_tables();
56 20         288     _apply_method_dispatch_tables();
57 20         358     %next::METHOD_CACHE = ();
58 20         237     $_initialized = 1;
59             }
60              
61             sub uninitialize {
62             # why bother if we don't have anything ...
63 6 50   6 1 91     return unless keys %MRO;
64 6         115     _remove_method_dispatch_tables();
65 6         66     %next::METHOD_CACHE = ();
66 6         65     $_initialized = 0;
67             }
68              
69 1     1 1 13 sub reinitialize { goto &initialize }
70              
71             ## functions for applying C3 to classes
72              
73             sub _calculate_method_dispatch_tables {
74 20     20   182     my %merge_cache;
75 20         265     foreach my $class (keys %MRO) {
76 91         992         _calculate_method_dispatch_table($class, \%merge_cache);
77                 }
78             }
79              
80             sub _calculate_method_dispatch_table {
81 91     91   897     my ($class, $merge_cache) = @_;
82 19     19   376     no strict 'refs';
  19         198  
  19         341  
83 91         1199     my @MRO = calculateMRO($class, $merge_cache);
84 91         19920     $MRO{$class} = { MRO => \@MRO };
85 91         936     my $has_overload_fallback = 0;
86 91         1006     my %methods;
87             # NOTE:
88             # we do @MRO[1 .. $#MRO] here because it
89             # makes no sense to interogate the class
90             # which you are calculating for.
91 91         1491     foreach my $local (@MRO[1 .. $#MRO]) {
92             # if overload has tagged this module to
93             # have use "fallback", then we want to
94             # grab that value
95 1         12         $has_overload_fallback = ${"${local}::()"}
  120         1515  
96 120 100       1526             if defined ${"${local}::()"};
97 120         1230         foreach my $method (grep { defined &{"${local}::$_"} } keys %{"${local}::"}) {
  697         6129  
  697         12025  
  120         2200  
98             # skip if already overriden in local class
99 109 100       928             next unless !defined *{"${class}::$method"}{CODE};
  109         1962  
100 59         1090             $methods{$method} = {
101                             orig => "${local}::$method",
102 77 100       1657                 code => \&{"${local}::$method"}
103                         } unless exists $methods{$method};
104                     }
105                 }
106             # now stash them in our %MRO table
107 91         4678     $MRO{$class}->{methods} = \%methods;
108 91         3049     $MRO{$class}->{has_overload_fallback} = $has_overload_fallback;
109             }
110              
111             sub _apply_method_dispatch_tables {
112 20     20   240     foreach my $class (keys %MRO) {
113 91         908         _apply_method_dispatch_table($class);
114                 }
115             }
116              
117             sub _apply_method_dispatch_table {
118 91     91   1038     my $class = shift;
119 19     19   342     no strict 'refs';
  19         211  
  19         293  
120 91 100       1066     ${"${class}::()"} = $MRO{$class}->{has_overload_fallback}
  1         13  
121                     if $MRO{$class}->{has_overload_fallback};
122 91         793     foreach my $method (keys %{$MRO{$class}->{methods}}) {
  91         1663  
123 59         598         *{"${class}::$method"} = $MRO{$class}->{methods}->{$method}->{code};
  59         972  
124                 }
125             }
126              
127             sub _remove_method_dispatch_tables {
128 6     6   89     foreach my $class (keys %MRO) {
129 31         285         _remove_method_dispatch_table($class);
130                 }
131             }
132              
133             sub _remove_method_dispatch_table {
134 31     31   266     my $class = shift;
135 19     19   518     no strict 'refs';
  19         225  
  19         279  
136 31 50       393     delete ${"${class}::"}{"()"} if $MRO{$class}->{has_overload_fallback};
  0         0  
137 31         335     foreach my $method (keys %{$MRO{$class}->{methods}}) {
  31         378  
138 23         325         delete ${"${class}::"}{$method}
  24         407  
139 24         543             if defined *{"${class}::${method}"}{CODE} &&
140 24 100 66     1204                (*{"${class}::${method}"}{CODE} eq $MRO{$class}->{methods}->{$method}->{code});
141                 }
142             }
143              
144             ## functions for calculating C3 MRO
145              
146             sub calculateMRO {
147 129     129 1 1364     my ($class, $merge_cache) = @_;
148                 return Algorithm::C3::merge($class, sub {
149 19     19   475         no strict 'refs';
  19         269  
  19         1075  
150 304     304   26497         @{$_[0] . '::ISA'};
  304         5713  
151 129         2271     }, $merge_cache);
152             }
153              
154             package  # hide me from PAUSE
155                 next;
156              
157 19     19   675 use strict;
  19         175  
  19         253  
158 19     19   950 use warnings;
  19         193  
  19         308  
159              
160 19     19   381 use Scalar::Util 'blessed';
  19         171  
  19         520  
161              
162             our $VERSION = '0.05';
163              
164             our %METHOD_CACHE;
165              
166             sub method {
167 25     25   832     my $indirect = caller() =~ /^(?:next|maybe::next)$/;
168 25 100       331     my $level = $indirect ? 2 : 1;
169                  
170 25         259     my ($method_caller, $label, @label);
171 25         598     while ($method_caller = (caller($level++))[3]) {
172 26         424       @label = (split '::', $method_caller);
173 26         294       $label = pop @label;
174                   last unless
175 26 100 66     534         $label eq '(eval)' ||
176                     $label eq '__ANON__';
177                 }
178 25         315     my $caller = join '::' => @label;
179 25         223     my $self = $_[0];
180 25   66     799     my $class = blessed($self) || $self;
181                 
182 25   100     496     my $method = $METHOD_CACHE{"$class|$caller|$label"} ||= do {
183                     
184 22         252         my @MRO = Class::C3::calculateMRO($class);
185                     
186 22         11708         my $current;
187 22         267         while ($current = shift @MRO) {
188 36 100       415             last if $caller eq $current;
189                     }
190                     
191 19     19   347         no strict 'refs';
  19         212  
  19         751  
192 22         182         my $found;
193 22         223         foreach my $class (@MRO) {
194 36 100 100     839             next if (defined $Class::C3::MRO{$class} &&
195                                  defined $Class::C3::MRO{$class}{methods}{$label});
196 32 100       272             last if (defined ($found = *{$class . '::' . $label}{CODE}));
  32         496  
197                     }
198                     
199 22         292         $found;
200                 };
201              
202 25 100       330     return $method if $indirect;
203              
204 21 100       329     die "No next::method '$label' found for $self" if !$method;
205              
206 18         149     goto &{$method};
  18         308  
207             }
208              
209 2     2   82 sub can { method($_[0]) }
210              
211             package  # hide me from PAUSE
212                 maybe::next;
213              
214 19     19   407 use strict;
  19         205  
  19         248  
215 19     19   310 use warnings;
  19         176  
  19         285  
216              
217             our $VERSION = '0.01';
218              
219 2   66 2   23 sub method { (next::method($_[0]) || return)->(@_) }
220              
221             1;
222              
223             __END__
224            
225             =pod
226            
227             =head1 NAME
228            
229             Class::C3 - A pragma to use the C3 method resolution order algortihm
230            
231             =head1 SYNOPSIS
232            
233             package A;
234             use Class::C3;
235             sub hello { 'A::hello' }
236            
237             package B;
238             use base 'A';
239             use Class::C3;
240            
241             package C;
242             use base 'A';
243             use Class::C3;
244            
245             sub hello { 'C::hello' }
246            
247             package D;
248             use base ('B', 'C');
249             use Class::C3;
250            
251             # Classic Diamond MI pattern
252             # <A>
253             # / \
254             # <B> <C>
255             # \ /
256             # <D>
257            
258             package main;
259            
260             # initializez the C3 module
261             # (formerly called in INIT)
262             Class::C3::initialize();
263            
264             print join ', ' => Class::C3::calculateMRO('Diamond_D') # prints D, B, C, A
265            
266             print D->hello() # prints 'C::hello' instead of the standard p5 'A::hello'
267            
268             D->can('hello')->(); # can() also works correctly
269             UNIVERSAL::can('D', 'hello'); # as does UNIVERSAL::can()
270            
271             =head1 DESCRIPTION
272            
273             This is pragma to change Perl 5's standard method resolution order from depth-first left-to-right
274             (a.k.a - pre-order) to the more sophisticated C3 method resolution order.
275            
276             =head2 What is C3?
277            
278             C3 is the name of an algorithm which aims to provide a sane method resolution order under multiple
279             inheritence. It was first introduced in the langauge Dylan (see links in the L<SEE ALSO> section),
280             and then later adopted as the prefered MRO (Method Resolution Order) for the new-style classes in
281             Python 2.3. Most recently it has been adopted as the 'canonical' MRO for Perl 6 classes, and the
282             default MRO for Parrot objects as well.
283            
284             =head2 How does C3 work.
285            
286             C3 works by always preserving local precendence ordering. This essentially means that no class will
287             appear before any of it's subclasses. Take the classic diamond inheritence pattern for instance:
288            
289             <A>
290             / \
291             <B> <C>
292             \ /
293             <D>
294            
295             The standard Perl 5 MRO would be (D, B, A, C). The result being that B<A> appears before B<C>, even
296             though B<C> is the subclass of B<A>. The C3 MRO algorithm however, produces the following MRO
297             (D, B, C, A), which does not have this same issue.
298            
299             This example is fairly trival, for more complex examples and a deeper explaination, see the links in
300             the L<SEE ALSO> section.
301            
302             =head2 How does this module work?
303            
304             This module uses a technique similar to Perl 5's method caching. When C<Class::C3::initialize> is
305             called, this module calculates the MRO of all the classes which called C<use Class::C3>. It then
306             gathers information from the symbol tables of each of those classes, and builds a set of method
307             aliases for the correct dispatch ordering. Once all these C3-based method tables are created, it
308             then adds the method aliases into the local classes symbol table.
309            
310             The end result is actually classes with pre-cached method dispatch. However, this caching does not
311             do well if you start changing your C<@ISA> or messing with class symbol tables, so you should consider
312             your classes to be effectively closed. See the L<CAVEATS> section for more details.
313            
314             =head1 OPTIONAL LOWERCASE PRAGMA
315            
316             This release also includes an optional module B<c3> in the F<opt/> folder. I did not include this in
317             the regular install since lowercase module names are considered I<"bad"> by some people. However I
318             think that code looks much nicer like this:
319            
320             package MyClass;
321             use c3;
322            
323             The the more clunky:
324            
325             package MyClass;
326             use Class::C3;
327            
328             But hey, it's your choice, thats why it is optional.
329            
330             =head1 FUNCTIONS
331            
332             =over 4
333            
334             =item B<calculateMRO ($class)>
335            
336             Given a C<$class> this will return an array of class names in the proper C3 method resolution order.
337            
338             =item B<initialize>
339            
340             This B<must be called> to initalize the C3 method dispatch tables, this module B<will not work> if
341             you do not do this. It is advised to do this as soon as possible B<after> loading any classes which
342             use C3. Here is a quick code example:
343            
344             package Foo;
345             use Class::C3;
346             # ... Foo methods here
347            
348             package Bar;
349             use Class::C3;
350             use base 'Foo';
351