← Index
NYTProf Performance Profile   « block view • line view • sub view »
For 01.HTTP.t
  Run on Tue May 4 15:25:55 2010
Reported on Tue May 4 15:26:24 2010

File /usr/local/lib/perl5/site_perl/5.10.1/MRO/Compat.pm
Statements Executed 32
Statement Execution Time 11.3ms
Subroutines — ordered by exclusive time
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
111242µs433µsMRO::Compat::::BEGIN@10MRO::Compat::BEGIN@10
11112µs15µsMRO::Compat::::BEGIN@2MRO::Compat::BEGIN@2
11111µs21µsMRO::Compat::::BEGIN@225MRO::Compat::BEGIN@225
1118µs21µsMRO::Compat::::BEGIN@39MRO::Compat::BEGIN@39
1117µs16µsMRO::Compat::::BEGIN@226MRO::Compat::BEGIN@226
1117µs18µsMRO::Compat::::BEGIN@116MRO::Compat::BEGIN@116
1117µs17µsMRO::Compat::::BEGIN@256MRO::Compat::BEGIN@256
1116µs14µsMRO::Compat::::BEGIN@3MRO::Compat::BEGIN@3
0000s0sMRO::Compat::::__ANON__[:40]MRO::Compat::__ANON__[:40]
0000s0sMRO::Compat::::__ANON__[:41]MRO::Compat::__ANON__[:41]
0000s0sMRO::Compat::::__ANON__[:42]MRO::Compat::__ANON__[:42]
0000s0sMRO::Compat::::__get_all_pkgs_with_isasMRO::Compat::__get_all_pkgs_with_isas
0000s0sMRO::Compat::::__get_isarevMRO::Compat::__get_isarev
0000s0sMRO::Compat::::__get_isarev_recurseMRO::Compat::__get_isarev_recurse
0000s0sMRO::Compat::::__get_linear_isaMRO::Compat::__get_linear_isa
0000s0sMRO::Compat::::__get_linear_isa_dfsMRO::Compat::__get_linear_isa_dfs
0000s0sMRO::Compat::::__get_mroMRO::Compat::__get_mro
0000s0sMRO::Compat::::__get_pkg_gen_c3xsMRO::Compat::__get_pkg_gen_c3xs
0000s0sMRO::Compat::::__get_pkg_gen_ppMRO::Compat::__get_pkg_gen_pp
0000s0sMRO::Compat::::__importMRO::Compat::__import
0000s0sMRO::Compat::::__invalidate_all_method_cachesMRO::Compat::__invalidate_all_method_caches
0000s0sMRO::Compat::::__is_universalMRO::Compat::__is_universal
0000s0sMRO::Compat::::__method_changed_inMRO::Compat::__method_changed_in
0000s0sMRO::Compat::::__set_mroMRO::Compat::__set_mro
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments
Time
on line
Calls Time
in subs
Code
1package MRO::Compat;
2318µs218µ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
use strict;
# spent 15µs making 1 call to MRO::Compat::BEGIN@2 # spent 3µs making 1 call to strict::import
33142µs223µs
# spent 14µs (6+8) within MRO::Compat::BEGIN@3 which was called # once (6µs+8µs) by Class::MOP::BEGIN@9 at line 3
use warnings;
# spent 14µs making 1 call to MRO::Compat::BEGIN@3 # spent 8µs making 1 call to warnings::import
4132µsrequire 5.006_000;
5
6# Keep this < 1.00, so people can tell the fake
7# mro.pm from the real one
81800nsour $VERSION = '0.11';
9
10
# spent 433µs (242+192) within MRO::Compat::BEGIN@10 which was called # once (242µs+192µs) by Class::MOP::BEGIN@9 at line 44
BEGIN {
11 # Alias our private functions over to
12 # the mro:: namespace and load
13 # Class::C3 if Perl < 5.9.5
1415µ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 {
38178µs require mro;
39382µs234µs
# spent 21µs (8+13) within MRO::Compat::BEGIN@39 which was called # once (8µs+13µs) by Class::MOP::BEGIN@9 at line 39
no warnings 'redefine';
# spent 21µs making 1 call to MRO::Compat::BEGIN@39 # spent 13µs making 1 call to warnings::unimport
4013µs *Class::C3::initialize = sub { 1 };
4111µs *Class::C3::reinitialize = sub { 1 };
4213µs *Class::C3::uninitialize = sub { 1 };
43 }
44132µs1433µs}
# spent 433µs making 1 call to MRO::Compat::BEGIN@10
45
46=head1 NAME
47
48MRO::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
66The "mro" namespace provides several utilities for dealing
67with method resolution order and method caching in general
68in Perl 5.9.5 and higher.
69
70This module provides those interfaces for
71earlier versions of Perl (back to 5.6.0 anyways).
72
73It is a harmless no-op to use this module on 5.9.5+. That
74is to say, code which properly uses L<MRO::Compat> will work
75unmodified on both older Perls and 5.9.5+.
76
77If you're writing a piece of software that would like to use
78the parts of 5.9.5+'s mro:: interfaces that are supported
79here, and you want compatibility with older Perls, this
80is the module for you.
81
82Some parts of this code will work better and/or faster with
83L<Class::C3::XS> installed (which is an optional prereq
84of L<Class::C3>, which is in turn a prereq of this
85package), but it's not a requirement.
86
87This module never exports any functions. All calls must
88be fully qualified with the C<mro::> prefix.
89
90The interface documentation here serves only as a quick
91reference of what the function basically does, and what
92differences between L<MRO::Compat> and 5.9.5+ one should
93look out for. The main docs in 5.9.5's L<mro> are the real
94interface docs, and contain a lot of other useful information.
95
96=head1 Functions
97
98=head2 mro::get_linear_isa($classname[, $type])
99
100Returns an arrayref which is the linearized "ISA" of the given class.
101Uses whichever MRO is currently in effect for that class by default,
102or the given MRO (either C<c3> or C<dfs> if specified as C<$type>).
103
104The linearized ISA of a class is a single ordered list of all of the
105classes that would be visited in the process of resolving a method
106on the given class, starting with itself. It does not include any
107duplicate entries.
108
109Note that C<UNIVERSAL> (and any members of C<UNIVERSAL>'s MRO) are not
110part of the MRO of a class, even though all classes implicitly inherit
111methods from C<UNIVERSAL> and its parents.
112
113=cut
114
115sub __get_linear_isa_dfs {
1163289µs228µ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
no strict 'refs';
# 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
133sub __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
149This allows the C<use mro 'dfs'> and
150C<use mro 'c3'> syntaxes, providing you
151L<use MRO::Compat> first. Please see the
152L</USING C3> section for additional details.
153
154=cut
155
156sub __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
165Sets the mro of C<$classname> to one of the types
166C<dfs> or C<c3>. Please see the L</USING C3>
167section for additional details.
168
169=cut
170
171sub __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
198Returns the MRO of the given class (either C<c3> or C<dfs>).
199
200It considers any Class::C3-using class to have C3 MRO
201even before L<Class::C3::initialize()> is called.
202
203=cut
204
205sub __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
214Returns an arrayref of classes who are subclasses of the
215given classname. In other words, classes in whose @ISA
216hierarchy we appear, no matter how indirectly.
217
218This is much slower on pre-5.9.5 Perls with MRO::Compat
219than it is on 5.9.5+, as it has to search the entire
220package namespace.
221
222=cut
223
224sub __get_all_pkgs_with_isas {
225326µs232µs
# spent 21µs (11+10) within MRO::Compat::BEGIN@225 which was called # once (11µs+10µs) by Class::MOP::BEGIN@9 at line 225
no strict 'refs';
# spent 21µs making 1 call to MRO::Compat::BEGIN@225 # spent 10µs making 1 call to strict::unimport
2263139µs225µs
# spent 16µs (7+9) within MRO::Compat::BEGIN@226 which was called # once (7µs+9µs) by Class::MOP::BEGIN@9 at line 226
no warnings 'recursion';
# spent 16µs making 1 call to MRO::Compat::BEGIN@226 # spent 9µ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
255sub __get_isarev_recurse {
256310.5ms227µs
# spent 17µs (7+10) within MRO::Compat::BEGIN@256 which was called # once (7µs+10µs) by Class::MOP::BEGIN@9 at line 256
no strict 'refs';
# spent 17µs making 1 call to MRO::Compat::BEGIN@256 # spent 10µ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
281sub __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
290Returns a boolean status indicating whether or not
291the given classname is either C<UNIVERSAL> itself,
292or one of C<UNIVERSAL>'s parents by C<@ISA> inheritance.
293
294Any class for which this function returns true is
295"universal" in the sense that all classes potentially
296inherit methods from it.
297
298=cut
299
300sub __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
314Increments C<PL_sub_generation>, which invalidates method
315caching in all packages.
316
317Please note that this is rarely necessary, unless you are
318dealing with a situation which is known to confuse Perl's
319method caching.
320
321=cut
322
323sub __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
331Invalidates the method cache of any classes dependent on the
332given class. In L<MRO::Compat> on pre-5.9.5 Perls, this is
333an alias for C<mro::invalidate_all_method_caches> above, as
334pre-5.9.5 Perls have no other way to do this. It will still
335enforce the requirement that you pass it a classname, for
336compatibility.
337
338Please note that this is rarely necessary, unless you are
339dealing with a situation which is known to confuse Perl's
340method caching.
341
342=cut
343
344sub __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
353Returns an integer which is incremented every time a local
354method of or the C<@ISA> of the given package changes on
355Perl 5.9.5+. On earlier Perls with this L<MRO::Compat> module,
356it will probably increment a lot more often than necessary.
357
358=cut
359
360{
36122µ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
369sub __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
378While this module makes the 5.9.5+ syntaxes
379C<use mro 'c3'> and C<mro::set_mro("Foo", 'c3')> available
380on older Perls, it does so merely by passing off the work
381to L<Class::C3>.
382
383It does not remove the need for you to call
384C<Class::C3::initialize()>, C<Class::C3::reinitialize()>, and/or
385C<Class::C3::uninitialize()> at the appropriate times
386as documented in the L<Class::C3> docs. These three functions
387are always provided by L<MRO::Compat>, either via L<Class::C3>
388itself on older Perls, or directly as no-ops on 5.9.5+.
389
390=head1 SEE ALSO
391
392L<Class::C3>
393
394L<mro>
395
396=head1 AUTHOR
397
398Brandon L. Black, E<lt>blblack@gmail.comE<gt>
399
400=head1 COPYRIGHT AND LICENSE
401
402Copyright 2007-2008 Brandon L. Black E<lt>blblack@gmail.comE<gt>
403
404This library is free software; you can redistribute it and/or modify
405it under the same terms as Perl itself.
406
407=cut
408
40918µs1;