Filename | /usr/local/lib/perl5/5.24/base.pm |
Statements | Executed 987 statements in 11.6ms |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
25 | 25 | 13 | 54.9ms | 254ms | import (recurses: max depth 2, inclusive time 204ms) | base::
24 | 1 | 1 | 694µs | 1.00ms | __ANON__[:77] | base::
24 | 1 | 1 | 459µs | 459µs | has_fields | base::
24 | 1 | 1 | 341µs | 341µs | has_attr | base::
24 | 1 | 1 | 184µs | 184µs | CORE:subst (opcode) | base::
2 | 1 | 1 | 88µs | 88µs | CORE:regcomp (opcode) | base::
26 | 1 | 1 | 84µs | 84µs | CORE:match (opcode) | base::
1 | 1 | 1 | 44µs | 44µs | BEGIN@1 | Socket6::
1 | 1 | 1 | 21µs | 116µs | BEGIN@5 | base::
1 | 1 | 1 | 21µs | 85µs | BEGIN@4 | base::
0 | 0 | 0 | 0s | 0s | __ANON__[:134] | base::
0 | 0 | 0 | 0s | 0s | __ANON__[:135] | base::
0 | 0 | 0 | 0s | 0s | __ANON__[:54] | base::
0 | 0 | 0 | 0s | 0s | __ANON__[:61] | base::
0 | 0 | 0 | 0s | 0s | __ANON__[:69] | base::
0 | 0 | 0 | 0s | 0s | DESTROY | base::__inc::scope_guard::
0 | 0 | 0 | 0s | 0s | unhook | base::__inc::
0 | 0 | 0 | 0s | 0s | get_attr | base::
0 | 0 | 0 | 0s | 0s | inherit_fields | base::
Line | State ments |
Time on line |
Calls | Time in subs |
Code |
---|---|---|---|---|---|
1 | 2 | 120µs | 1 | 44µs | # spent 44µs within Socket6::BEGIN@1 which was called:
# once (44µs+0s) by Socket6::BEGIN@215 at line 1 # spent 44µs making 1 call to Socket6::BEGIN@1 |
2 | package base; | ||||
3 | |||||
4 | 2 | 87µs | 2 | 149µs | # spent 85µs (21+64) within base::BEGIN@4 which was called:
# once (21µs+64µs) by Socket6::BEGIN@215 at line 4 # spent 85µs making 1 call to base::BEGIN@4
# spent 64µs making 1 call to strict::import |
5 | 2 | 2.62ms | 2 | 211µs | # spent 116µs (21+95) within base::BEGIN@5 which was called:
# once (21µs+95µs) by Socket6::BEGIN@215 at line 5 # spent 116µs making 1 call to base::BEGIN@5
# spent 95µs making 1 call to vars::import |
6 | 1 | 2µs | $VERSION = '2.23_01'; | ||
7 | 1 | 8µs | $VERSION =~ tr/_//d; | ||
8 | |||||
9 | # simplest way to avoid indexing of the package: no package statement | ||||
10 | sub 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 | ||||
12 | sub base::__inc::scope_guard::DESTROY { base::__inc::unhook $_ for @{$_[0]} } | ||||
13 | |||||
14 | # constant.pm is slow | ||||
15 | sub SUCCESS () { 1 } | ||||
16 | |||||
17 | sub PUBLIC () { 2**0 } | ||||
18 | sub PRIVATE () { 2**1 } | ||||
19 | sub INHERITED () { 2**2 } | ||||
20 | sub PROTECTED () { 2**3 } | ||||
21 | |||||
22 | |||||
23 | 1 | 2µs | my $Fattr = \%fields::attr; | ||
24 | |||||
25 | # spent 459µs within base::has_fields which was called 24 times, avg 19µs/call:
# 24 times (459µs+0s) by base::import at line 178, avg 19µs/call | ||||
26 | 24 | 66µs | my($base) = shift; | ||
27 | 48 | 233µs | my $fglob = ${"$base\::"}{FIELDS}; | ||
28 | 24 | 214µs | return( ($fglob && 'GLOB' eq ref($fglob) && *$fglob{HASH}) ? 1 : 0 ); | ||
29 | } | ||||
30 | |||||
31 | # spent 341µs within base::has_attr which was called 24 times, avg 14µs/call:
# 24 times (341µs+0s) by base::import at line 178, avg 14µs/call | ||||
32 | 24 | 60µs | my($proto) = shift; | ||
33 | 24 | 71µs | my($class) = ref $proto || $proto; | ||
34 | 24 | 236µs | return exists $Fattr->{$class}; | ||
35 | } | ||||
36 | |||||
37 | sub get_attr { | ||||
38 | $Fattr->{$_[0]} = [1] unless $Fattr->{$_[0]}; | ||||
39 | return $Fattr->{$_[0]}; | ||||
40 | } | ||||
41 | |||||
42 | 1 | 11µs | if ($] < 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 | } | ||||
56 | else { | ||||
57 | *get_fields = sub { | ||||
58 | # Shut up a possible typo warning. | ||||
59 | () = \%{$_[0].'::FIELDS'}; | ||||
60 | return \%{$_[0].'::FIELDS'}; | ||||
61 | } | ||||
62 | 1 | 8µs | } | ||
63 | |||||
64 | 1 | 10µs | if ($] < 5.008) { | ||
65 | *_module_to_filename = sub { | ||||
66 | (my $fn = $_[0]) =~ s!::!/!g; | ||||
67 | $fn .= '.pm'; | ||||
68 | return $fn; | ||||
69 | } | ||||
70 | } | ||||
71 | else { | ||||
72 | # spent 1.00ms (694µs+308µs) within base::__ANON__[/usr/local/lib/perl5/5.24/base.pm:77] which was called 24 times, avg 42µs/call:
# 24 times (694µs+308µs) by base::import at line 104, avg 42µs/call | ||||
73 | 24 | 399µs | 24 | 184µs | (my $fn = $_[0]) =~ s!::!/!g; # spent 184µs making 24 calls to base::CORE:subst, avg 8µs/call |
74 | 24 | 54µs | $fn .= '.pm'; | ||
75 | 24 | 326µs | 24 | 124µs | utf8::encode($fn); # spent 124µs making 24 calls to utf8::encode, avg 5µs/call |
76 | 24 | 232µs | return $fn; | ||
77 | } | ||||
78 | 1 | 5µs | } | ||
79 | |||||
80 | |||||
81 | # spent 254ms (54.9+199) within base::import which was called 25 times, avg 10.2ms/call:
# once (1.27ms+144ms) by Net::DNS::Resolver::BEGIN@22 at line 22 of Net/DNS/Resolver.pm
# once (24.2ms+69.8ms) by Razor2::Client::Agent::BEGIN@20 at line 20 of Razor2/Client/Agent.pm
# once (7.30ms+5.11ms) by Razor2::Client::Agent::BEGIN@21 at line 21 of Razor2/Client/Agent.pm
# once (344µs+191µs) by Net::DNS::RR::OPT::DHU::BEGIN@233 at line 233 of Net/DNS/RR/OPT.pm
# once (337µs+165µs) by Socket6::BEGIN@215 at line 215 of Socket6.pm
# once (289µs+83µs) by Net::DNS::RR::OPT::N3U::BEGIN@236 at line 236 of Net/DNS/RR/OPT.pm
# once (181µs+82µs) by Net::DNS::RR::AAAA::BEGIN@11 at line 11 of Net/DNS/RR/AAAA.pm
# once (160µs+97µs) by Net::DNS::Update::BEGIN@37 at line 37 of Net/DNS/Update.pm
# once (174µs+75µs) by Net::DNS::BEGIN@38 at line 38 of Net/DNS.pm
# once (161µs+81µs) by Net::DNS::RR::OPT::BEGIN@11 at line 11 of Net/DNS/RR/OPT.pm
# once (149µs+79µs) by Net::DNS::RR::A::BEGIN@11 at line 11 of Net/DNS/RR/A.pm
# once (54µs+4µ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 (168µs+-168µs) by IO::Socket::IP::_ForINET::BEGIN@1158 at line 1158 of IO/Socket/IP.pm
# once (216µs+-216µs) by IO::Socket::IP::BEGIN@15 at line 15 of IO/Socket/IP.pm
# once (181µs+-181µs) by IO::Socket::IP::_ForINET6::BEGIN@1172 at line 1172 of IO/Socket/IP.pm
# once (154µs+-154µs) by Net::DNS::Parameters::BEGIN@22 at line 22 of Net/DNS/Parameters.pm
# once (167µs+-167µs) by Net::DNS::DomainName1035::BEGIN@158 at line 158 of Net/DNS/DomainName.pm
# once (168µs+-168µs) by Net::DNS::DomainName2535::BEGIN@220 at line 220 of Net/DNS/DomainName.pm
# once (168µs+-168µs) by Net::DNS::DomainName::BEGIN@43 at line 43 of Net/DNS/DomainName.pm
# once (1.30ms+-1.30ms) by Razor2::Client::Core::BEGIN@23 at line 23 of Razor2/Client/Core.pm
# once (2.14ms+-2.14ms) by Razor2::Client::Core::BEGIN@22 at line 22 of Razor2/Client/Core.pm
# once (1.10ms+-1.10ms) by Razor2::Client::Core::BEGIN@24 at line 24 of Razor2/Client/Core.pm
# once (178µs+-178µs) by Razor2::Client::Core::BEGIN@21 at line 21 of Razor2/Client/Core.pm
# once (14.3ms+-14.3ms) by Net::DNS::Resolver::UNIX::BEGIN@18 at line 18 of Net/DNS/Resolver/UNIX.pm | ||||
82 | 25 | 60µs | my $class = shift; | ||
83 | |||||
84 | 25 | 52µs | return SUCCESS unless @_; | ||
85 | |||||
86 | # List of base classes from which we will inherit %FIELDS. | ||||
87 | 25 | 45µs | my $fields_base; | ||
88 | |||||
89 | 25 | 68µs | my $inheritor = caller(0); | ||
90 | |||||
91 | 25 | 44µs | my @bases; | ||
92 | 25 | 106µs | foreach my $base (@_) { | ||
93 | 26 | 55µs | if ( $inheritor eq $base ) { | ||
94 | warn "Class '$inheritor' tried to inherit from itself\n"; | ||||
95 | } | ||||
96 | |||||
97 | 26 | 696µs | 27 | 134µs | next if grep $_->isa($base), ($inheritor, @bases); # spent 134µs making 27 calls to UNIVERSAL::isa, avg 5µs/call |
98 | |||||
99 | # Following blocks help isolate $SIG{__DIE__} and @INC changes | ||||
100 | { | ||||
101 | 48 | 119µs | my $sigdie; | ||
102 | { | ||||
103 | 48 | 261µs | local $SIG{__DIE__}; | ||
104 | 24 | 254µs | 24 | 1.00ms | my $fn = _module_to_filename($base); # spent 1.00ms making 24 calls to base::__ANON__[base.pm:77], avg 42µs/call |
105 | 24 | 55µs | my $dot_hidden; | ||
106 | 24 | 90µs | eval { | ||
107 | 24 | 53µs | my $guard; | ||
108 | 24 | 52µ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 | } | ||||
138 | 24 | 2.29ms | require $fn | ||
139 | }; | ||||
140 | 24 | 46µs | if ($dot_hidden && (my @fn = grep -e && !( -d _ || -b _ ), $fn.'c', $fn)) { | ||
141 | require Carp; | ||||
142 | Carp::croak(<<ERROR); | ||||
143 | Base 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. | ||||
150 | ERROR | ||||
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] | ||||
160 | 24 | 439µs | 28 | 172µs | die if $@ && $@ !~ /^Can't locate \Q$fn\E .*? at .* line [0-9]+(?:, <[^>]*> (?:line|chunk) [0-9]+)?\.\n\z/s # spent 88µs making 2 calls to base::CORE:regcomp, avg 44µs/call
# spent 84µ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/; | ||||
162 | 48 | 207µs | unless (%{"$base\::"}) { | ||
163 | require Carp; | ||||
164 | local $" = " "; | ||||
165 | Carp::croak(<<ERROR); | ||||
166 | Base 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). | ||||
169 | ERROR | ||||
170 | } | ||||
171 | 24 | 258µs | $sigdie = $SIG{__DIE__} || undef; | ||
172 | } | ||||
173 | # Make sure a global $SIG{__DIE__} makes it out of the localization. | ||||
174 | 24 | 83µs | $SIG{__DIE__} = $sigdie if defined $sigdie; | ||
175 | } | ||||
176 | 24 | 67µs | push @bases, $base; | ||
177 | |||||
178 | 24 | 415µs | 48 | 800µs | if ( has_fields($base) || has_attr($base) ) { # spent 459µs making 24 calls to base::has_fields, avg 19µs/call
# spent 341µs making 24 calls to base::has_attr, avg 14µ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. | ||||
189 | 50 | 690µs | push @{"$inheritor\::ISA"}, @bases; | ||
190 | |||||
191 | 25 | 309µs | if( defined $fields_base ) { | ||
192 | inherit_fields($inheritor, $fields_base); | ||||
193 | } | ||||
194 | } | ||||
195 | |||||
196 | |||||
197 | sub 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! | ||||
212 | This will cause problems. Be sure you use base BEFORE declaring fields. | ||||
213 | END | ||||
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 | |||||
244 | 1 | 22µs | 1; | ||
245 | |||||
246 | __END__ | ||||
# spent 84µs within base::CORE:match which was called 26 times, avg 3µs/call:
# 26 times (84µs+0s) by base::import at line 160, avg 3µs/call | |||||
# spent 88µs within base::CORE:regcomp which was called 2 times, avg 44µs/call:
# 2 times (88µs+0s) by base::import at line 160, avg 44µs/call | |||||
# spent 184µs within base::CORE:subst which was called 24 times, avg 8µs/call:
# 24 times (184µs+0s) by base::__ANON__[/usr/local/lib/perl5/5.24/base.pm:77] at line 73, avg 8µs/call |