← Index
NYTProf Performance Profile   « line view »
For starman worker -M FindBin --max-requests 50 --workers 2 --user=kohadev-koha --group kohadev-koha --pid /var/run/koha/kohadev/plack.pid --daemonize --access-log /var/log/koha/kohadev/plack.log --error-log /var/log/koha/kohadev/plack-error.log -E deployment --socket /var/run/koha/kohadev/plack.sock /etc/koha/sites/kohadev/plack.psgi
  Run on Fri Jan 8 13:01:18 2016
Reported on Fri Jan 8 13:01:34 2016

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