← Index
Performance Profile   « block view • line view • sub view »
For /wise/base/deliv/dev/bin/getfix
  Run on Thu May 20 15:30:03 2010
Reported on Thu May 20 16:25:44 2010

File/wise/base/static/lib/perl5/site_perl/5.10.0/MRO/Compat.pm
Statements Executed33
Total Time0.001511 seconds

Subroutines — ordered by exclusive time
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
1119.0e-69.0e-6MRO::Compat::__ANON__[:41]
00000MRO::Compat::BEGIN
00000MRO::Compat::__ANON__[:40]
00000MRO::Compat::__ANON__[:42]
00000MRO::Compat::__get_all_pkgs_with_isas
00000MRO::Compat::__get_isarev
00000MRO::Compat::__get_isarev_recurse
00000MRO::Compat::__get_linear_isa
00000MRO::Compat::__get_linear_isa_dfs
00000MRO::Compat::__get_mro
00000MRO::Compat::__get_pkg_gen_c3xs
00000MRO::Compat::__get_pkg_gen_pp
00000MRO::Compat::__import
00000MRO::Compat::__invalidate_all_method_caches
00000MRO::Compat::__is_universal
00000MRO::Compat::__method_changed_in
00000MRO::Compat::__set_mro

LineStmts.Exclusive
Time		Avg.Code
1package MRO::Compat;
233.1e-51.0e-5use strict;
# spent 10µs making 1 call to strict::import
330.000237.7e-5use warnings;
# spent 24µs making 1 call to warnings::import
413.2e-53.2e-5require 5.006_000;
5
6# Keep this < 1.00, so people can tell the fake
7# mro.pm from the real one
811.0e-61.0e-6our $VERSION = '0.05';
9
10BEGIN {
11 # Alias our private functions over to
12 # the mro:: namespace and load
13 # Class::C3 if Perl < 5.9.5
1413.0e-63.0e-6 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 {
3811.0e-61.0e-6 require mro;
3939.7e-53.2e-5 no warnings 'redefine';
# spent 26µs making 1 call to warnings::unimport
4012.4e-52.4e-5 *Class::C3::initialize = sub { 1 };
4126.0e-63.0e-6
# spent 9µs within MRO::Compat::__ANON__[/wise/base/static/lib/perl5/site_perl/5.10.0/MRO/Compat.pm:41] which was called # once (9µs+0) by DBIx::Class::Schema::load_classes at line 307 of /wise/base/static/lib/perl5/site_perl/5.10.0/DBIx/Class/Schema.pm
*Class::C3::reinitialize = sub { 1 };
4211.0e-51.0e-5 *Class::C3::uninitialize = sub { 1 };
43 }
4413.5e-53.5e-5}
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 MRO 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 MRO 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 {
11630.000420.00014 no strict 'refs';
# spent 18µ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 if(!defined $classname || !$type) {
174 die q{Usage: mro::set_mro($classname, $type)};
175 }
176 if($type eq 'c3') {
177 eval "package $classname; use Class::C3";
178 die $@ if $@;
179 }
180 if($type ne 'dfs') {
181 die q{Invalid mro type "$type"};
182 }
183
184 # In the dfs case, check whether we need to undo C3
185 if(defined $Class::C3::MRO{$classname}) {
186 Class::C3::_remove_method_dispatch_table($classname);
187 }
188 delete $Class::C3::MRO{$classname};
189
190 return;
191}
192
193=head2 mro::get_mro($classname)
194
195Returns the MRO of the given class (either C<c3> or C<dfs>).
196
197It considers any Class::C3-using class to have C3 MRO
198even before L<Class::C3::initialize()> is called.
199
200=cut
201
202sub __get_mro {
203 my $classname = shift;
204 die "mro::get_mro requires a classname" if !defined $classname;
205 return 'c3' if exists $Class::C3::MRO{$classname};
206 return 'dfs';
207}
208
209=head2 mro::get_isarev($classname)
210
211Returns an arrayref of classes who are subclasses of the
212given classname. In other words, classes who we exist,
213however indirectly, in the @ISA inheritancy hierarchy of.
214
215This is much slower on pre-5.9.5 Perls with MRO::Compat
216than it is on 5.9.5+, as it has to search the entire
217package namespace.
218
219=cut
220
221sub __get_all_pkgs_with_isas {
22232.9e-59.7e-6 no strict 'refs';
# spent 22µs making 1 call to strict::unimport
22330.000196.3e-5 no warnings 'recursion';
# spent 27µs making 1 call to warnings::unimport
224
225 my @retval;
226
227 my $search = shift;
228 my $pfx;
229 my $isa;
230 if($search) {
231 $isa = \@{"$search\::ISA"};
232 $pfx = "$search\::";
233 }
234 else {
235 $search = 'main';
236 $isa = \@main::ISA;
237 $pfx = '';
238 }
239
240 push(@retval, $search) if scalar(@$isa);
241
242 foreach my $cand (keys %{"$search\::"}) {
243 if($cand =~ s/::$//) {
244 next if $cand eq $search; # skip self-reference (main?)
245 push(@retval, @{__get_all_pkgs_with_isas($pfx . $cand)});
246 }
247 }
248
249 return \@retval;
250}
251
252sub __get_isarev_recurse {
25330.000390.00013 no strict 'refs';
# spent 19µs making 1 call to strict::unimport
254
255 my ($class, $all_isas, $level) = @_;
256
257 die "Recursive inheritance detected" if $level > 100;
258
259 my %retval;
260
261 foreach my $cand (@$all_isas) {
262 my $found_me;
263 foreach (@{"$cand\::ISA"}) {
264 if($_ eq $class) {
265 $found_me = 1;
266 last;
267 }
268 }
269 if($found_me) {
270 $retval{$cand} = 1;
271 map { $retval{$_} = 1 }
272 @{__get_isarev_recurse($cand, $all_isas, $level+1)};
273 }
274 }
275 return [keys %retval];
276}
277
278sub __get_isarev {
279 my $classname = shift;
280 die "mro::get_isarev requires a classname" if !defined $classname;
281
282 __get_isarev_recurse($classname, __get_all_pkgs_with_isas(), 0);
283}
284
285=head2 mro::is_universal($classname)
286
287Returns a boolean status indicating whether or not
288the given classname is either C<UNIVERSAL> itself,
289or one of C<UNIVERSAL>'s parents by C<@ISA> inheritance.
290
291Any class for which this function returns true is
292"universal" in the sense that all classes potentially
293inherit methods from it.
294
295=cut
296
297sub __is_universal {
298 my $classname = shift;
299 die "mro::is_universal requires a classname" if !defined $classname;
300
301 my $lin = __get_linear_isa('UNIVERSAL');
302 foreach (@$lin) {
303 return 1 if $classname eq $_;
304 }
305
306 return 0;
307}
308
309=head2 mro::invalidate_all_method_caches
310
311Increments C<PL_sub_generation>, which invalidates method
312caching in all packages.
313
314Please note that this is rarely necessary, unless you are
315dealing with a situation which is known to confuse Perl's
316method caching.
317
318=cut
319
320sub __invalidate_all_method_caches {
321 # Super secret mystery code :)
322 @f845a9c1ac41be33::ISA = @f845a9c1ac41be33::ISA;
323 return;
324}
325
326=head2 mro::method_changed_in($classname)
327
328Invalidates the method cache of any classes dependent on the
329given class. In L<MRO::Compat> on pre-5.9.5 Perls, this is
330an alias for C<mro::invalidate_all_method_caches> above, as
331pre-5.9.5 Perls have no other way to do this. It will still
332enforce the requirement that you pass it a classname, for
333compatibility.
334
335Please note that this is rarely necessary, unless you are
336dealing with a situation which is known to confuse Perl's
337method caching.
338
339=cut
340
341sub __method_changed_in {
342 my $classname = shift;
343 die "mro::method_changed_in requires a classname" if !defined $classname;
344
345 __invalidate_all_method_caches();
346}
347
348=head2 mro::get_pkg_gen($classname)
349
350Returns an integer which is incremented every time a local
351method of or the C<@ISA> of the given package changes on
352Perl 5.9.5+. On earlier Perls with this L<MRO::Compat> module,
353it will probably increment a lot more often than necessary.
354
355=cut
356
357{
35823.0e-61.5e-6 my $__pkg_gen = 2;
359 sub __get_pkg_gen_pp {
360 my $classname = shift;
361 die "mro::get_pkg_gen requires a classname" if !defined $classname;
362 return $__pkg_gen++;
363 }
364}
365
366sub __get_pkg_gen_c3xs {
367 my $classname = shift;
368 die "mro::get_pkg_gen requires a classname" if !defined $classname;
369
370 return Class::C3::XS::_plsubgen();
371}
372
373=head1 USING C3
374
375While this module makes the 5.9.5+ syntaxes
376C<use mro 'c3'> and C<mro::set_mro("Foo", 'c3')> available
377on older Perls, it does so merely by passing off the work
378to L<Class::C3>.
379
380It does not remove the need for you to call
381C<Class::C3::initialize()>, C<Class::C3::reinitialize()>, and/or
382C<Class::C3::uninitialize()> at the appropriate times
383as documented in the L<Class::C3> docs. These three functions
384are always provided by L<MRO::Compat>, either via L<Class::C3>
385itself on older Perls, or directly as no-ops on 5.9.5+.
386
387=head1 SEE ALSO
388
389L<Class::C3>
390
391L<mro>
392
393=head1 AUTHOR
394
395Brandon L. Black, E<lt>blblack@gmail.comE<gt>
396
397=head1 COPYRIGHT AND LICENSE
398
399Copyright 2007 Brandon L. Black E<lt>blblack@gmail.comE<gt>
400
401This library is free software; you can redistribute it and/or modify
402it under the same terms as Perl itself.
403
404=cut
405
40617.0e-67.0e-61;

Report produced by the NYTProf 2.07 Perl profiler, developed by Tim Bunce and Adam Kaplan.