File | /usr/local/lib/perl5/site_perl/5.10.1/MRO/Compat.pm |
Statements Executed | 32 |
Statement Execution Time | 1.61ms |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
1 | 1 | 1 | 243µs | 440µs | BEGIN@10 | MRO::Compat::
1 | 1 | 1 | 13µs | 37µs | BEGIN@226 | MRO::Compat::
1 | 1 | 1 | 13µs | 31µs | BEGIN@256 | MRO::Compat::
1 | 1 | 1 | 13µs | 33µs | BEGIN@225 | MRO::Compat::
1 | 1 | 1 | 12µs | 15µs | BEGIN@2 | MRO::Compat::
1 | 1 | 1 | 9µs | 25µs | BEGIN@39 | MRO::Compat::
1 | 1 | 1 | 7µs | 18µs | BEGIN@116 | MRO::Compat::
1 | 1 | 1 | 7µs | 15µs | BEGIN@3 | MRO::Compat::
0 | 0 | 0 | 0s | 0s | __ANON__[:40] | MRO::Compat::
0 | 0 | 0 | 0s | 0s | __ANON__[:41] | MRO::Compat::
0 | 0 | 0 | 0s | 0s | __ANON__[:42] | MRO::Compat::
0 | 0 | 0 | 0s | 0s | __get_all_pkgs_with_isas | MRO::Compat::
0 | 0 | 0 | 0s | 0s | __get_isarev | MRO::Compat::
0 | 0 | 0 | 0s | 0s | __get_isarev_recurse | MRO::Compat::
0 | 0 | 0 | 0s | 0s | __get_linear_isa | MRO::Compat::
0 | 0 | 0 | 0s | 0s | __get_linear_isa_dfs | MRO::Compat::
0 | 0 | 0 | 0s | 0s | __get_mro | MRO::Compat::
0 | 0 | 0 | 0s | 0s | __get_pkg_gen_c3xs | MRO::Compat::
0 | 0 | 0 | 0s | 0s | __get_pkg_gen_pp | MRO::Compat::
0 | 0 | 0 | 0s | 0s | __import | MRO::Compat::
0 | 0 | 0 | 0s | 0s | __invalidate_all_method_caches | MRO::Compat::
0 | 0 | 0 | 0s | 0s | __is_universal | MRO::Compat::
0 | 0 | 0 | 0s | 0s | __method_changed_in | MRO::Compat::
0 | 0 | 0 | 0s | 0s | __set_mro | MRO::Compat::
Line | State ments |
Time on line |
Calls | Time in subs |
Code |
---|---|---|---|---|---|
1 | package MRO::Compat; | ||||
2 | 3 | 27µs | 2 | 18µs | # spent 15µs (12+3) within MRO::Compat::BEGIN@2 which was called
# once (12µs+3µs) by Class::MOP::BEGIN@9 at line 2 # spent 15µs making 1 call to MRO::Compat::BEGIN@2
# spent 3µs making 1 call to strict::import |
3 | 3 | 143µs | 2 | 24µs | # spent 15µs (7+8) within MRO::Compat::BEGIN@3 which was called
# once (7µs+8µs) by Class::MOP::BEGIN@9 at line 3 # spent 15µs making 1 call to MRO::Compat::BEGIN@3
# spent 8µs making 1 call to warnings::import |
4 | 1 | 36µs | require 5.006_000; | ||
5 | |||||
6 | # Keep this < 1.00, so people can tell the fake | ||||
7 | # mro.pm from the real one | ||||
8 | 1 | 400ns | our $VERSION = '0.11'; | ||
9 | |||||
10 | # spent 440µs (243+196) within MRO::Compat::BEGIN@10 which was called
# once (243µs+196µs) by Class::MOP::BEGIN@9 at line 44 | ||||
11 | # Alias our private functions over to | ||||
12 | # the mro:: namespace and load | ||||
13 | # Class::C3 if Perl < 5.9.5 | ||||
14 | 1 | 3µs | if($] < 5.009_005) { | ||
15 | $mro::VERSION # to fool Module::Install when generating META.yml | ||||
16 | = $VERSION; | ||||
17 | $INC{'mro.pm'} = __FILE__; | ||||
18 | *mro::import = \&__import; | ||||
19 | *mro::get_linear_isa = \&__get_linear_isa; | ||||
20 | *mro::set_mro = \&__set_mro; | ||||
21 | *mro::get_mro = \&__get_mro; | ||||
22 | *mro::get_isarev = \&__get_isarev; | ||||
23 | *mro::is_universal = \&__is_universal; | ||||
24 | *mro::method_changed_in = \&__method_changed_in; | ||||
25 | *mro::invalidate_all_method_caches | ||||
26 | = \&__invalidate_all_method_caches; | ||||
27 | require Class::C3; | ||||
28 | if($Class::C3::XS::VERSION && $Class::C3::XS::VERSION > 0.03) { | ||||
29 | *mro::get_pkg_gen = \&__get_pkg_gen_c3xs; | ||||
30 | } | ||||
31 | else { | ||||
32 | *mro::get_pkg_gen = \&__get_pkg_gen_pp; | ||||
33 | } | ||||
34 | } | ||||
35 | |||||
36 | # Load mro.pm and provide no-op Class::C3::.*initialize() funcs for 5.9.5+ | ||||
37 | else { | ||||
38 | 1 | 82µs | require mro; | ||
39 | 3 | 87µs | 2 | 41µs | # spent 25µs (9+16) within MRO::Compat::BEGIN@39 which was called
# once (9µs+16µs) by Class::MOP::BEGIN@9 at line 39 # spent 25µs making 1 call to MRO::Compat::BEGIN@39
# spent 16µs making 1 call to warnings::unimport |
40 | 1 | 2µs | *Class::C3::initialize = sub { 1 }; | ||
41 | 1 | 1µs | *Class::C3::reinitialize = sub { 1 }; | ||
42 | 1 | 2µs | *Class::C3::uninitialize = sub { 1 }; | ||
43 | } | ||||
44 | 1 | 35µs | 1 | 440µs | } # spent 440µs making 1 call to MRO::Compat::BEGIN@10 |
45 | |||||
46 | =head1 NAME | ||||
47 | |||||
48 | MRO::Compat - mro::* interface compatibility for Perls < 5.9.5 | ||||
49 | |||||
50 | =head1 SYNOPSIS | ||||
51 | |||||
52 | package FooClass; use base qw/X Y Z/; | ||||
53 | package X; use base qw/ZZZ/; | ||||
54 | package Y; use base qw/ZZZ/; | ||||
55 | package Z; use base qw/ZZZ/; | ||||
56 | |||||
57 | package main; | ||||
58 | use MRO::Compat; | ||||
59 | my $linear = mro::get_linear_isa('FooClass'); | ||||
60 | print join(q{, }, @$linear); | ||||
61 | |||||
62 | # Prints: "FooClass, X, ZZZ, Y, Z" | ||||
63 | |||||
64 | =head1 DESCRIPTION | ||||
65 | |||||
66 | The "mro" namespace provides several utilities for dealing | ||||
67 | with method resolution order and method caching in general | ||||
68 | in Perl 5.9.5 and higher. | ||||
69 | |||||
70 | This module provides those interfaces for | ||||
71 | earlier versions of Perl (back to 5.6.0 anyways). | ||||
72 | |||||
73 | It is a harmless no-op to use this module on 5.9.5+. That | ||||
74 | is to say, code which properly uses L<MRO::Compat> will work | ||||
75 | unmodified on both older Perls and 5.9.5+. | ||||
76 | |||||
77 | If you're writing a piece of software that would like to use | ||||
78 | the parts of 5.9.5+'s mro:: interfaces that are supported | ||||
79 | here, and you want compatibility with older Perls, this | ||||
80 | is the module for you. | ||||
81 | |||||
82 | Some parts of this code will work better and/or faster with | ||||
83 | L<Class::C3::XS> installed (which is an optional prereq | ||||
84 | of L<Class::C3>, which is in turn a prereq of this | ||||
85 | package), but it's not a requirement. | ||||
86 | |||||
87 | This module never exports any functions. All calls must | ||||
88 | be fully qualified with the C<mro::> prefix. | ||||
89 | |||||
90 | The interface documentation here serves only as a quick | ||||
91 | reference of what the function basically does, and what | ||||
92 | differences between L<MRO::Compat> and 5.9.5+ one should | ||||
93 | look out for. The main docs in 5.9.5's L<mro> are the real | ||||
94 | interface docs, and contain a lot of other useful information. | ||||
95 | |||||
96 | =head1 Functions | ||||
97 | |||||
98 | =head2 mro::get_linear_isa($classname[, $type]) | ||||
99 | |||||
100 | Returns an arrayref which is the linearized "ISA" of the given class. | ||||
101 | Uses whichever MRO is currently in effect for that class by default, | ||||
102 | or the given MRO (either C<c3> or C<dfs> if specified as C<$type>). | ||||
103 | |||||
104 | The linearized ISA of a class is a single ordered list of all of the | ||||
105 | classes that would be visited in the process of resolving a method | ||||
106 | on the given class, starting with itself. It does not include any | ||||
107 | duplicate entries. | ||||
108 | |||||
109 | Note that C<UNIVERSAL> (and any members of C<UNIVERSAL>'s MRO) are not | ||||
110 | part of the MRO of a class, even though all classes implicitly inherit | ||||
111 | methods from C<UNIVERSAL> and its parents. | ||||
112 | |||||
113 | =cut | ||||
114 | |||||
115 | sub __get_linear_isa_dfs { | ||||
116 | 3 | 341µs | 2 | 29µs | # spent 18µs (7+11) within MRO::Compat::BEGIN@116 which was called
# once (7µs+11µs) by Class::MOP::BEGIN@9 at line 116 # spent 18µs making 1 call to MRO::Compat::BEGIN@116
# spent 11µs making 1 call to strict::unimport |
117 | |||||
118 | my $classname = shift; | ||||
119 | |||||
120 | my @lin = ($classname); | ||||
121 | my %stored; | ||||
122 | foreach my $parent (@{"$classname\::ISA"}) { | ||||
123 | my $plin = __get_linear_isa_dfs($parent); | ||||
124 | foreach (@$plin) { | ||||
125 | next if exists $stored{$_}; | ||||
126 | push(@lin, $_); | ||||
127 | $stored{$_} = 1; | ||||
128 | } | ||||
129 | } | ||||
130 | return \@lin; | ||||
131 | } | ||||
132 | |||||
133 | sub __get_linear_isa { | ||||
134 | my ($classname, $type) = @_; | ||||
135 | die "mro::get_mro requires a classname" if !defined $classname; | ||||
136 | |||||
137 | $type ||= __get_mro($classname); | ||||
138 | if($type eq 'dfs') { | ||||
139 | return __get_linear_isa_dfs($classname); | ||||
140 | } | ||||
141 | elsif($type eq 'c3') { | ||||
142 | return [Class::C3::calculateMRO($classname)]; | ||||
143 | } | ||||
144 | die "type argument must be 'dfs' or 'c3'"; | ||||
145 | } | ||||
146 | |||||
147 | =head2 mro::import | ||||
148 | |||||
149 | This allows the C<use mro 'dfs'> and | ||||
150 | C<use mro 'c3'> syntaxes, providing you | ||||
151 | L<use MRO::Compat> first. Please see the | ||||
152 | L</USING C3> section for additional details. | ||||
153 | |||||
154 | =cut | ||||
155 | |||||
156 | sub __import { | ||||
157 | if($_[1]) { | ||||
158 | goto &Class::C3::import if $_[1] eq 'c3'; | ||||
159 | __set_mro(scalar(caller), $_[1]); | ||||
160 | } | ||||
161 | } | ||||
162 | |||||
163 | =head2 mro::set_mro($classname, $type) | ||||
164 | |||||
165 | Sets the mro of C<$classname> to one of the types | ||||
166 | C<dfs> or C<c3>. Please see the L</USING C3> | ||||
167 | section for additional details. | ||||
168 | |||||
169 | =cut | ||||
170 | |||||
171 | sub __set_mro { | ||||
172 | my ($classname, $type) = @_; | ||||
173 | |||||
174 | if(!defined $classname || !$type) { | ||||
175 | die q{Usage: mro::set_mro($classname, $type)}; | ||||
176 | } | ||||
177 | |||||
178 | if($type eq 'c3') { | ||||
179 | eval "package $classname; use Class::C3"; | ||||
180 | die $@ if $@; | ||||
181 | } | ||||
182 | elsif($type eq 'dfs') { | ||||
183 | # In the dfs case, check whether we need to undo C3 | ||||
184 | if(defined $Class::C3::MRO{$classname}) { | ||||
185 | Class::C3::_remove_method_dispatch_table($classname); | ||||
186 | } | ||||
187 | delete $Class::C3::MRO{$classname}; | ||||
188 | } | ||||
189 | else { | ||||
190 | die qq{Invalid mro type "$type"}; | ||||
191 | } | ||||
192 | |||||
193 | return; | ||||
194 | } | ||||
195 | |||||
196 | =head2 mro::get_mro($classname) | ||||
197 | |||||
198 | Returns the MRO of the given class (either C<c3> or C<dfs>). | ||||
199 | |||||
200 | It considers any Class::C3-using class to have C3 MRO | ||||
201 | even before L<Class::C3::initialize()> is called. | ||||
202 | |||||
203 | =cut | ||||
204 | |||||
205 | sub __get_mro { | ||||
206 | my $classname = shift; | ||||
207 | die "mro::get_mro requires a classname" if !defined $classname; | ||||
208 | return 'c3' if exists $Class::C3::MRO{$classname}; | ||||
209 | return 'dfs'; | ||||
210 | } | ||||
211 | |||||
212 | =head2 mro::get_isarev($classname) | ||||
213 | |||||
214 | Returns an arrayref of classes who are subclasses of the | ||||
215 | given classname. In other words, classes in whose @ISA | ||||
216 | hierarchy we appear, no matter how indirectly. | ||||
217 | |||||
218 | This is much slower on pre-5.9.5 Perls with MRO::Compat | ||||
219 | than it is on 5.9.5+, as it has to search the entire | ||||
220 | package namespace. | ||||
221 | |||||
222 | =cut | ||||
223 | |||||
224 | sub __get_all_pkgs_with_isas { | ||||
225 | 3 | 42µs | 2 | 54µs | # spent 33µs (13+21) within MRO::Compat::BEGIN@225 which was called
# once (13µs+21µs) by Class::MOP::BEGIN@9 at line 225 # spent 33µs making 1 call to MRO::Compat::BEGIN@225
# spent 21µs making 1 call to strict::unimport |
226 | 3 | 268µs | 2 | 60µs | # spent 37µs (13+24) within MRO::Compat::BEGIN@226 which was called
# once (13µs+24µs) by Class::MOP::BEGIN@9 at line 226 # spent 37µs making 1 call to MRO::Compat::BEGIN@226
# spent 24µs making 1 call to warnings::unimport |
227 | |||||
228 | my @retval; | ||||
229 | |||||
230 | my $search = shift; | ||||
231 | my $pfx; | ||||
232 | my $isa; | ||||
233 | if(defined $search) { | ||||
234 | $isa = \@{"$search\::ISA"}; | ||||
235 | $pfx = "$search\::"; | ||||
236 | } | ||||
237 | else { | ||||
238 | $search = 'main'; | ||||
239 | $isa = \@main::ISA; | ||||
240 | $pfx = ''; | ||||
241 | } | ||||
242 | |||||
243 | push(@retval, $search) if scalar(@$isa); | ||||
244 | |||||
245 | foreach my $cand (keys %{"$search\::"}) { | ||||
246 | if($cand =~ s/::$//) { | ||||
247 | next if $cand eq $search; # skip self-reference (main?) | ||||
248 | push(@retval, @{__get_all_pkgs_with_isas($pfx . $cand)}); | ||||
249 | } | ||||
250 | } | ||||
251 | |||||
252 | return \@retval; | ||||
253 | } | ||||
254 | |||||
255 | sub __get_isarev_recurse { | ||||
256 | 3 | 528µs | 2 | 49µs | # spent 31µs (13+18) within MRO::Compat::BEGIN@256 which was called
# once (13µs+18µs) by Class::MOP::BEGIN@9 at line 256 # spent 31µs making 1 call to MRO::Compat::BEGIN@256
# spent 18µs making 1 call to strict::unimport |
257 | |||||
258 | my ($class, $all_isas, $level) = @_; | ||||
259 | |||||
260 | die "Recursive inheritance detected" if $level > 100; | ||||
261 | |||||
262 | my %retval; | ||||
263 | |||||
264 | foreach my $cand (@$all_isas) { | ||||
265 | my $found_me; | ||||
266 | foreach (@{"$cand\::ISA"}) { | ||||
267 | if($_ eq $class) { | ||||
268 | $found_me = 1; | ||||
269 | last; | ||||
270 | } | ||||
271 | } | ||||
272 | if($found_me) { | ||||
273 | $retval{$cand} = 1; | ||||
274 | map { $retval{$_} = 1 } | ||||
275 | @{__get_isarev_recurse($cand, $all_isas, $level+1)}; | ||||
276 | } | ||||
277 | } | ||||
278 | return [keys %retval]; | ||||
279 | } | ||||
280 | |||||
281 | sub __get_isarev { | ||||
282 | my $classname = shift; | ||||
283 | die "mro::get_isarev requires a classname" if !defined $classname; | ||||
284 | |||||
285 | __get_isarev_recurse($classname, __get_all_pkgs_with_isas(), 0); | ||||
286 | } | ||||
287 | |||||
288 | =head2 mro::is_universal($classname) | ||||
289 | |||||
290 | Returns a boolean status indicating whether or not | ||||
291 | the given classname is either C<UNIVERSAL> itself, | ||||
292 | or one of C<UNIVERSAL>'s parents by C<@ISA> inheritance. | ||||
293 | |||||
294 | Any class for which this function returns true is | ||||
295 | "universal" in the sense that all classes potentially | ||||
296 | inherit methods from it. | ||||
297 | |||||
298 | =cut | ||||
299 | |||||
300 | sub __is_universal { | ||||
301 | my $classname = shift; | ||||
302 | die "mro::is_universal requires a classname" if !defined $classname; | ||||
303 | |||||
304 | my $lin = __get_linear_isa('UNIVERSAL'); | ||||
305 | foreach (@$lin) { | ||||
306 | return 1 if $classname eq $_; | ||||
307 | } | ||||
308 | |||||
309 | return 0; | ||||
310 | } | ||||
311 | |||||
312 | =head2 mro::invalidate_all_method_caches | ||||
313 | |||||
314 | Increments C<PL_sub_generation>, which invalidates method | ||||
315 | caching in all packages. | ||||
316 | |||||
317 | Please note that this is rarely necessary, unless you are | ||||
318 | dealing with a situation which is known to confuse Perl's | ||||
319 | method caching. | ||||
320 | |||||
321 | =cut | ||||
322 | |||||
323 | sub __invalidate_all_method_caches { | ||||
324 | # Super secret mystery code :) | ||||
325 | @f845a9c1ac41be33::ISA = @f845a9c1ac41be33::ISA; | ||||
326 | return; | ||||
327 | } | ||||
328 | |||||
329 | =head2 mro::method_changed_in($classname) | ||||
330 | |||||
331 | Invalidates the method cache of any classes dependent on the | ||||
332 | given class. In L<MRO::Compat> on pre-5.9.5 Perls, this is | ||||
333 | an alias for C<mro::invalidate_all_method_caches> above, as | ||||
334 | pre-5.9.5 Perls have no other way to do this. It will still | ||||
335 | enforce the requirement that you pass it a classname, for | ||||
336 | compatibility. | ||||
337 | |||||
338 | Please note that this is rarely necessary, unless you are | ||||
339 | dealing with a situation which is known to confuse Perl's | ||||
340 | method caching. | ||||
341 | |||||
342 | =cut | ||||
343 | |||||
344 | sub __method_changed_in { | ||||
345 | my $classname = shift; | ||||
346 | die "mro::method_changed_in requires a classname" if !defined $classname; | ||||
347 | |||||
348 | __invalidate_all_method_caches(); | ||||
349 | } | ||||
350 | |||||
351 | =head2 mro::get_pkg_gen($classname) | ||||
352 | |||||
353 | Returns an integer which is incremented every time a local | ||||
354 | method of or the C<@ISA> of the given package changes on | ||||
355 | Perl 5.9.5+. On earlier Perls with this L<MRO::Compat> module, | ||||
356 | it will probably increment a lot more often than necessary. | ||||
357 | |||||
358 | =cut | ||||
359 | |||||
360 | { | ||||
361 | 2 | 2µs | my $__pkg_gen = 2; | ||
362 | sub __get_pkg_gen_pp { | ||||
363 | my $classname = shift; | ||||
364 | die "mro::get_pkg_gen requires a classname" if !defined $classname; | ||||
365 | return $__pkg_gen++; | ||||
366 | } | ||||
367 | } | ||||
368 | |||||
369 | sub __get_pkg_gen_c3xs { | ||||
370 | my $classname = shift; | ||||
371 | die "mro::get_pkg_gen requires a classname" if !defined $classname; | ||||
372 | |||||
373 | return Class::C3::XS::_plsubgen(); | ||||
374 | } | ||||
375 | |||||
376 | =head1 USING C3 | ||||
377 | |||||
378 | While this module makes the 5.9.5+ syntaxes | ||||
379 | C<use mro 'c3'> and C<mro::set_mro("Foo", 'c3')> available | ||||
380 | on older Perls, it does so merely by passing off the work | ||||
381 | to L<Class::C3>. | ||||
382 | |||||
383 | It does not remove the need for you to call | ||||
384 | C<Class::C3::initialize()>, C<Class::C3::reinitialize()>, and/or | ||||
385 | C<Class::C3::uninitialize()> at the appropriate times | ||||
386 | as documented in the L<Class::C3> docs. These three functions | ||||
387 | are always provided by L<MRO::Compat>, either via L<Class::C3> | ||||
388 | itself on older Perls, or directly as no-ops on 5.9.5+. | ||||
389 | |||||
390 | =head1 SEE ALSO | ||||
391 | |||||
392 | L<Class::C3> | ||||
393 | |||||
394 | L<mro> | ||||
395 | |||||
396 | =head1 AUTHOR | ||||
397 | |||||
398 | Brandon L. Black, E<lt>blblack@gmail.comE<gt> | ||||
399 | |||||
400 | =head1 COPYRIGHT AND LICENSE | ||||
401 | |||||
402 | Copyright 2007-2008 Brandon L. Black E<lt>blblack@gmail.comE<gt> | ||||
403 | |||||
404 | This library is free software; you can redistribute it and/or modify | ||||
405 | it under the same terms as Perl itself. | ||||
406 | |||||
407 | =cut | ||||
408 | |||||
409 | 1 | 7µs | 1; |