File | /usr/local/share/perl/5.10.0/MRO/Compat.pm |
Statements Executed | 32 |
Total Time | 0.001787 seconds |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
0 | 0 | 0 | 0s | 0s | BEGIN | 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 | Stmts. | Exclusive Time | Avg. | Code |
---|---|---|---|---|
1 | package MRO::Compat; | |||
2 | 3 | 26µs | 9µs | use strict; # spent 7µs making 1 call to strict::import |
3 | 3 | 232µs | 77µs | use warnings; # spent 20µs making 1 call to warnings::import |
4 | 1 | 20µs | 20µ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 | 600ns | 600ns | our $VERSION = '0.11'; |
9 | ||||
10 | BEGIN { | |||
11 | # Alias our private functions over to | |||
12 | # the mro:: namespace and load | |||
13 | # Class::C3 if Perl < 5.9.5 | |||
14 | 5 | 102µs | 20µ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 | require mro; | |||
39 | 3 | 117µs | 39µs | no warnings 'redefine'; # spent 19µs making 1 call to warnings::unimport |
40 | *Class::C3::initialize = sub { 1 }; | |||
41 | *Class::C3::reinitialize = sub { 1 }; | |||
42 | *Class::C3::uninitialize = sub { 1 }; | |||
43 | } | |||
44 | 1 | 38µs | 38µs | } |
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 | 460µs | 153µs | no strict 'refs'; # spent 21µ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 | 28µs | 9µs | no strict 'refs'; # spent 21µs making 1 call to strict::unimport |
226 | 3 | 206µs | 69µs | no warnings 'recursion'; # spent 23µ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 | 550µs | 183µs | no strict 'refs'; # spent 23µ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 | 1µs | 650ns | 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 | 6µs | 6µs | 1; |