← Index
NYTProf Performance Profile   « line view »
For /usr/local/bin/sa-learn
  Run on Sun Nov 5 03:09:29 2017
Reported on Mon Nov 6 13:20:46 2017

Filename/usr/local/lib/perl5/5.24/base.pm
StatementsExecuted 987 statements in 10.6ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
25251351.7ms213msbase::::import base::import (recurses: max depth 2, inclusive time 168ms)
2411570µs831µsbase::::__ANON__[:77] base::__ANON__[:77]
2411391µs391µsbase::::has_fields base::has_fields
2411282µs282µsbase::::has_attr base::has_attr
2411168µs168µsbase::::CORE:subst base::CORE:subst (opcode)
211103µs103µsbase::::CORE:regcomp base::CORE:regcomp (opcode)
261190µs90µsbase::::CORE:match base::CORE:match (opcode)
11141µs41µsSocket6::::BEGIN@1 Socket6::BEGIN@1
11127µs70µsbase::::BEGIN@4 base::BEGIN@4
11125µs79µsbase::::BEGIN@5 base::BEGIN@5
0000s0sbase::::__ANON__[:134] base::__ANON__[:134]
0000s0sbase::::__ANON__[:135] base::__ANON__[:135]
0000s0sbase::::__ANON__[:54] base::__ANON__[:54]
0000s0sbase::::__ANON__[:61] base::__ANON__[:61]
0000s0sbase::::__ANON__[:69] base::__ANON__[:69]
0000s0sbase::__inc::scope_guard::::DESTROYbase::__inc::scope_guard::DESTROY
0000s0sbase::__inc::::unhook base::__inc::unhook
0000s0sbase::::get_attr base::get_attr
0000s0sbase::::inherit_fields base::inherit_fields
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments		 Time
on line		 Calls Time
in subs		 Code
12108µs141µs
# spent 41µs within Socket6::BEGIN@1 which was called: # once (41µs+0s) by Socket6::BEGIN@215 at line 1
use 5.008;
# spent 41µs making 1 call to Socket6::BEGIN@1
2package base;
3
4287µs2113µs
# spent 70µs (27+43) within base::BEGIN@4 which was called: # once (27µs+43µs) by Socket6::BEGIN@215 at line 4
use strict 'vars';
# spent 70µs making 1 call to base::BEGIN@4 # spent 43µs making 1 call to strict::import
522.39ms2132µs
# spent 79µs (25+54) within base::BEGIN@5 which was called: # once (25µs+54µs) by Socket6::BEGIN@215 at line 5
use vars qw($VERSION);
# spent 79µs making 1 call to base::BEGIN@5 # spent 54µs making 1 call to vars::import
613µs$VERSION = '2.23_01';
714µs$VERSION =~ tr/_//d;
8
9# simplest way to avoid indexing of the package: no package statement
10sub base::__inc::unhook { @INC = grep !(ref eq 'CODE' && $_ == $_[0]), @INC }
11# instance is blessed array of coderefs to be removed from @INC at scope exit
12sub base::__inc::scope_guard::DESTROY { base::__inc::unhook $_ for @{$_[0]} }
13
14# constant.pm is slow
15sub SUCCESS () { 1 }
16
17sub PUBLIC () { 2**0 }
18sub PRIVATE () { 2**1 }
19sub INHERITED () { 2**2 }
20sub PROTECTED () { 2**3 }
21
22
2312µsmy $Fattr = \%fields::attr;
24
25
# spent 391µs within base::has_fields which was called 24 times, avg 16µs/call: # 24 times (391µs+0s) by base::import at line 178, avg 16µs/call
sub has_fields {
262471µs my($base) = shift;
2748176µs my $fglob = ${"$base\::"}{FIELDS};
2824165µs return( ($fglob && 'GLOB' eq ref($fglob) && *$fglob{HASH}) ? 1 : 0 );
29}
30
31
# spent 282µs within base::has_attr which was called 24 times, avg 12µs/call: # 24 times (282µs+0s) by base::import at line 178, avg 12µs/call
sub has_attr {
322460µs my($proto) = shift;
332461µs my($class) = ref $proto || $proto;
3424188µs return exists $Fattr->{$class};
35}
36
37sub get_attr {
38 $Fattr->{$_[0]} = [1] unless $Fattr->{$_[0]};
39 return $Fattr->{$_[0]};
40}
41
4215µsif ($] < 5.009) {
43 *get_fields = sub {
44 # Shut up a possible typo warning.
45 () = \%{$_[0].'::FIELDS'};
46 my $f = \%{$_[0].'::FIELDS'};
47
48 # should be centralized in fields? perhaps
49 # fields::mk_FIELDS_be_OK. Peh. As long as %{ $package . '::FIELDS' }
50 # is used here anyway, it doesn't matter.
51 bless $f, 'pseudohash' if (ref($f) ne 'pseudohash');
52
53 return $f;
54 }
55}
56else {
57 *get_fields = sub {
58 # Shut up a possible typo warning.
59 () = \%{$_[0].'::FIELDS'};
60 return \%{$_[0].'::FIELDS'};
61 }
6217µs}
63
6414µsif ($] < 5.008) {
65 *_module_to_filename = sub {
66 (my $fn = $_[0]) =~ s!::!/!g;
67 $fn .= '.pm';
68 return $fn;
69 }
70}
71else {
72
# spent 831µs (570+261) within base::__ANON__[/usr/local/lib/perl5/5.24/base.pm:77] which was called 24 times, avg 35µs/call: # 24 times (570µs+261µs) by base::import at line 104, avg 35µs/call
*_module_to_filename = sub {
7324354µs24168µs (my $fn = $_[0]) =~ s!::!/!g;
# spent 168µs making 24 calls to base::CORE:subst, avg 7µs/call
742458µs $fn .= '.pm';
7524265µs2493µs utf8::encode($fn);
# spent 93µs making 24 calls to utf8::encode, avg 4µs/call
7624170µs return $fn;
77 }
7815µs}
79
80
81
# spent 213ms (51.7+161) within base::import which was called 25 times, avg 8.51ms/call: # once (1.18ms+117ms) by Net::DNS::Resolver::BEGIN@22 at line 22 of Net/DNS/Resolver.pm # once (23.5ms+56.6ms) by Razor2::Client::Agent::BEGIN@20 at line 20 of Razor2/Client/Agent.pm # once (6.88ms+4.90ms) by Razor2::Client::Agent::BEGIN@21 at line 21 of Razor2/Client/Agent.pm # once (361µs+199µs) by Net::DNS::RR::OPT::DHU::BEGIN@233 at line 233 of Net/DNS/RR/OPT.pm # once (246µs+130µs) by Socket6::BEGIN@215 at line 215 of Socket6.pm # once (222µs+69µs) by Net::DNS::RR::OPT::N3U::BEGIN@236 at line 236 of Net/DNS/RR/OPT.pm # once (161µs+82µs) by Net::DNS::RR::OPT::BEGIN@11 at line 11 of Net/DNS/RR/OPT.pm # once (164µs+74µs) by Net::DNS::BEGIN@38 at line 38 of Net/DNS.pm # once (132µs+73µs) by Net::DNS::Update::BEGIN@37 at line 37 of Net/DNS/Update.pm # once (140µs+62µs) by Net::DNS::RR::AAAA::BEGIN@11 at line 11 of Net/DNS/RR/AAAA.pm # once (133µs+58µs) by Net::DNS::RR::A::BEGIN@11 at line 11 of Net/DNS/RR/A.pm # once (64µs+5µs) by Razor2::Client::Agent::BEGIN@22 at line 22 of Razor2/Client/Agent.pm # once (33µs+3µs) by Razor2::Client::Agent::BEGIN@23 at line 23 of Razor2/Client/Agent.pm # once (138µs+-138µs) by Razor2::Client::Core::BEGIN@21 at line 21 of Razor2/Client/Core.pm # once (1.33ms+-1.33ms) by Razor2::Client::Core::BEGIN@23 at line 23 of Razor2/Client/Core.pm # once (2.13ms+-2.13ms) by Razor2::Client::Core::BEGIN@22 at line 22 of Razor2/Client/Core.pm # once (1.03ms+-1.03ms) by Razor2::Client::Core::BEGIN@24 at line 24 of Razor2/Client/Core.pm # once (12.9ms+-12.9ms) by Net::DNS::Resolver::UNIX::BEGIN@18 at line 18 of Net/DNS/Resolver/UNIX.pm # once (149µs+-149µs) by Net::DNS::Parameters::BEGIN@22 at line 22 of Net/DNS/Parameters.pm # once (161µs+-161µs) by Net::DNS::DomainName::BEGIN@43 at line 43 of Net/DNS/DomainName.pm # once (124µs+-124µs) by Net::DNS::DomainName1035::BEGIN@158 at line 158 of Net/DNS/DomainName.pm # once (113µs+-113µs) by Net::DNS::DomainName2535::BEGIN@220 at line 220 of Net/DNS/DomainName.pm # once (120µs+-120µs) by IO::Socket::IP::_ForINET6::BEGIN@1172 at line 1172 of IO/Socket/IP.pm # once (140µs+-140µs) by IO::Socket::IP::BEGIN@15 at line 15 of IO/Socket/IP.pm # once (156µs+-156µs) by IO::Socket::IP::_ForINET::BEGIN@1158 at line 1158 of IO/Socket/IP.pm
sub import {
822560µs my $class = shift;
83
842554µs return SUCCESS unless @_;
85
86 # List of base classes from which we will inherit %FIELDS.
872543µs my $fields_base;
88
892571µs my $inheritor = caller(0);
90
912544µs my @bases;
9225103µs foreach my $base (@_) {
932653µs if ( $inheritor eq $base ) {
94 warn "Class '$inheritor' tried to inherit from itself\n";
95 }
96
9726620µs27142µs next if grep $_->isa($base), ($inheritor, @bases);
# spent 142µs making 27 calls to UNIVERSAL::isa, avg 5µs/call
98
99 # Following blocks help isolate $SIG{__DIE__} and @INC changes
100 {
10148116µs my $sigdie;
102 {
10348210µs local $SIG{__DIE__};
10424196µs24831µs my $fn = _module_to_filename($base);
# spent 831µs making 24 calls to base::__ANON__[base.pm:77], avg 35µs/call
1052439µs my $dot_hidden;
1062493µs eval {
1072440µs my $guard;
1082450µs if ($INC[-1] eq '.' && %{"$base\::"}) {
109 # So: the package already exists => this an optional load
110 # And: there is a dot at the end of @INC => we want to hide it
111 # However: we only want to hide it during our *own* require()
112 # (i.e. without affecting nested require()s).
113 # So we add a hook to @INC whose job is to hide the dot, but which
114 # first checks checks the callstack depth, because within nested
115 # require()s the callstack is deeper.
116 # Since CORE::GLOBAL::require makes it unknowable in advance what
117 # the exact relevant callstack depth will be, we have to record it
118 # inside a hook. So we put another hook just for that at the front
119 # of @INC, where it's guaranteed to run -- immediately.
120 # The dot-hiding hook does its job by sitting directly in front of
121 # the dot and removing itself from @INC when reached. This causes
122 # the dot to move up one index in @INC, causing the loop inside
123 # pp_require() to skip it.
124 # Loaded coded may disturb this precise arrangement, but that's OK
125 # because the hook is inert by that time. It is only active during
126 # the top-level require(), when @INC is in our control. The only
127 # possible gotcha is if other hooks already in @INC modify @INC in
128 # some way during that initial require().
129 # Note that this jiggery hookery works just fine recursively: if
130 # a module loaded via base.pm uses base.pm itself, there will be
131 # one pair of hooks in @INC per base::import call frame, but the
132 # pairs from different nestings do not interfere with each other.
133 my $lvl;
134 unshift @INC, sub { return if defined $lvl; 1 while defined caller ++$lvl; () };
135 splice @INC, -1, 0, sub { return if defined caller $lvl; ++$dot_hidden, &base::__inc::unhook; () };
136 $guard = bless [ @INC[0,-2] ], 'base::__inc::scope_guard';
137 }
138242.34ms require $fn
139 };
1402450µs if ($dot_hidden && (my @fn = grep -e && !( -d _ || -b _ ), $fn.'c', $fn)) {
141 require Carp;
142 Carp::croak(<<ERROR);
143Base class package "$base" is not empty but "$fn[0]" exists in the current directory.
144 To help avoid security issues, base.pm now refuses to load optional modules
145 from the current working directory when it is the last entry in \@INC.
146 If your software worked on previous versions of Perl, the best solution
147 is to use FindBin to detect the path properly and to add that path to
148 \@INC. As a last resort, you can re-enable looking in the current working
149 directory by adding "use lib '.'" to your code.
150ERROR
151 }
152 # Only ignore "Can't locate" errors from our eval require.
153 # Other fatal errors (syntax etc) must be reported.
154 #
155 # changing the check here is fragile - if the check
156 # here isn't catching every error you want, you should
157 # probably be using parent.pm, which doesn't try to
158 # guess whether require is needed or failed,
159 # see [perl #118561]
16024412µs28193µs die if $@ && $@ !~ /^Can't locate \Q$fn\E .*? at .* line [0-9]+(?:, <[^>]*> (?:line|chunk) [0-9]+)?\.\n\z/s
# spent 103µs making 2 calls to base::CORE:regcomp, avg 52µs/call # spent 90µs making 26 calls to base::CORE:match, avg 3µs/call
161 || $@ =~ /Compilation failed in require at .* line [0-9]+(?:, <[^>]*> (?:line|chunk) [0-9]+)?\.\n\z/;
16248195µs unless (%{"$base\::"}) {
163 require Carp;
164 local $" = " ";
165 Carp::croak(<<ERROR);
166Base class package "$base" is empty.
167 (Perhaps you need to 'use' the module which defines that package first,
168 or make that module available in \@INC (\@INC contains: @INC).
169ERROR
170 }
17124207µs $sigdie = $SIG{__DIE__} || undef;
172 }
173 # Make sure a global $SIG{__DIE__} makes it out of the localization.
1742449µs $SIG{__DIE__} = $sigdie if defined $sigdie;
175 }
1762465µs push @bases, $base;
177
17824364µs48673µs if ( has_fields($base) || has_attr($base) ) {
# spent 391µs making 24 calls to base::has_fields, avg 16µs/call # spent 282µs making 24 calls to base::has_attr, avg 12µs/call
179 # No multiple fields inheritance *suck*
180 if ($fields_base) {
181 require Carp;
182 Carp::croak("Can't multiply inherit fields");
183 } else {
184 $fields_base = $base;
185 }
186 }
187 }
188 # Save this until the end so it's all or nothing if the above loop croaks.
18950622µs push @{"$inheritor\::ISA"}, @bases;
190
19125277µs if( defined $fields_base ) {
192 inherit_fields($inheritor, $fields_base);
193 }
194}
195
196
197sub inherit_fields {
198 my($derived, $base) = @_;
199
200 return SUCCESS unless $base;
201
202 my $battr = get_attr($base);
203 my $dattr = get_attr($derived);
204 my $dfields = get_fields($derived);
205 my $bfields = get_fields($base);
206
207 $dattr->[0] = @$battr;
208
209 if( keys %$dfields ) {
210 warn <<"END";
211$derived is inheriting from $base but already has its own fields!
212This will cause problems. Be sure you use base BEFORE declaring fields.
213END
214
215 }
216
217 # Iterate through the base's fields adding all the non-private
218 # ones to the derived class. Hang on to the original attribute
219 # (Public, Private, etc...) and add Inherited.
220 # This is all too complicated to do efficiently with add_fields().
221 while (my($k,$v) = each %$bfields) {
222 my $fno;
223 if ($fno = $dfields->{$k} and $fno != $v) {
224 require Carp;
225 Carp::croak ("Inherited fields can't override existing fields");
226 }
227
228 if( $battr->[$v] & PRIVATE ) {
229 $dattr->[$v] = PRIVATE | INHERITED;
230 }
231 else {
232 $dattr->[$v] = INHERITED | $battr->[$v];
233 $dfields->{$k} = $v;
234 }
235 }
236
237 foreach my $idx (1..$#{$battr}) {
238 next if defined $dattr->[$idx];
239 $dattr->[$idx] = $battr->[$idx] & INHERITED;
240 }
241}
242
243
244113µs1;
245
246__END__
 
# spent 90µs within base::CORE:match which was called 26 times, avg 3µs/call: # 26 times (90µs+0s) by base::import at line 160, avg 3µs/call
sub base::CORE:match; # opcode
# spent 103µs within base::CORE:regcomp which was called 2 times, avg 52µs/call: # 2 times (103µs+0s) by base::import at line 160, avg 52µs/call
sub base::CORE:regcomp; # opcode
# spent 168µs within base::CORE:subst which was called 24 times, avg 7µs/call: # 24 times (168µs+0s) by base::__ANON__[/usr/local/lib/perl5/5.24/base.pm:77] at line 73, avg 7µs/call
sub base::CORE:subst; # opcode
Report produced by the NYTProf 6.04 Perl profiler, developed by Tim Bunce based on work by Adam Kaplan and Salvador Fandiño García.