Profile of base.pm

← Index
NYTProf Performance Profile «line view»
For t/bug-md-11.t
Run on Fri Mar 8 13:27:24 2024
Reported on Fri Mar 8 13:30:23 2024

Filename | /home/micha/.plenv/versions/5.38.2/lib/perl5/5.38.2/base.pm
Statements | Executed 160 statements in 1.06ms

Subroutines
Calls | P | F | Exclusive Time | Inclusive Time | Subroutine
--- | --- | --- | --- | --- | ---
4 | 4 | 4 | 116µs | 164µs | base::::import base::import
4 | 1 | 1 | 17µs | 26µs | base::::__ANON__[:76] base::__ANON__[:76]
1 | 1 | 1 | 11µs | 11µs | Test2::Util::Facets2Legacy::::BEGIN@1Test2::Util::Facets2Legacy::BEGIN@1
4 | 1 | 1 | 8µs | 8µs | base::::has_fields base::has_fields
4 | 1 | 1 | 6µs | 6µs | base::::has_attr base::has_attr
1 | 1 | 1 | 4µs | 8µs | base::::BEGIN@4 base::BEGIN@4
0 | 0 | 0 | 0s | 0s | base::::__ANON__[:133] base::__ANON__[:133]
0 | 0 | 0 | 0s | 0s | base::::__ANON__[:134] base::__ANON__[:134]
0 | 0 | 0 | 0s | 0s | base::::__ANON__[:53] base::__ANON__[:53]
0 | 0 | 0 | 0s | 0s | base::::__ANON__[:60] base::__ANON__[:60]
0 | 0 | 0 | 0s | 0s | base::::__ANON__[:68] base::__ANON__[:68]
0 | 0 | 0 | 0s | 0s | base::__inc::scope_guard::::DESTROY base::__inc::scope_guard::DESTROY
0 | 0 | 0 | 0s | 0s | base::__inc::::unhook base::__inc::unhook
0 | 0 | 0 | 0s | 0s | base::::get_attr base::get_attr
0 | 0 | 0 | 0s | 0s | base::::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
--- | --- | --- | --- | --- | ---
1 | 2 | 39µs | 1 | 11µs | # spent 11µs within Test2::Util::Facets2Legacy::BEGIN@1 which was called: # once (11µs+0s) by Test2::Util::Facets2Legacy::BEGIN@10 at line 1 use 5.008; # spent 11µs making 1 call to Test2::Util::Facets2Legacy::BEGIN@1
2 |  |  |  |  | package base;
3 |  |  |  |  |
4 | 2 | 847µs | 2 | 12µs | # spent 8µs (4+4) within base::BEGIN@4 which was called: # once (4µs+4µs) by Test2::Util::Facets2Legacy::BEGIN@10 at line 4 use strict 'vars'; # spent 8µs making 1 call to base::BEGIN@4 # spent 4µs making 1 call to strict::import
5 | 1 | 400ns |  |  | our $VERSION = '2.27';
6 | 1 | 700ns |  |  | $VERSION =~ tr/_//d;
7 |  |  |  |  |
8 |  |  |  |  | # simplest way to avoid indexing of the package: no package statement
9 |  |  |  |  | sub base::__inc::unhook { @INC = grep !(ref eq 'CODE' && $_ == $_[0]), @INC }
10 |  |  |  |  | # instance is blessed array of coderefs to be removed from @INC at scope exit
11 |  |  |  |  | sub base::__inc::scope_guard::DESTROY { base::__inc::unhook $_ for @{$_[0]} }
12 |  |  |  |  |
13 |  |  |  |  | # constant.pm is slow
14 |  |  |  |  | sub SUCCESS () { 1 }
15 |  |  |  |  |
16 |  |  |  |  | sub PUBLIC () { 2**0 }
17 |  |  |  |  | sub PRIVATE () { 2**1 }
18 |  |  |  |  | sub INHERITED () { 2**2 }
19 |  |  |  |  | sub PROTECTED () { 2**3 }
20 |  |  |  |  |
21 |  |  |  |  |
22 | 1 | 500ns |  |  | my $Fattr = \%fields::attr;
23 |  |  |  |  |
24 |  |  |  |  | # spent 8µs within base::has_fields which was called 4 times, avg 2µs/call: # 4 times (8µs+0s) by base::import at line 177, avg 2µs/call sub has_fields {
25 | 4 | 2µs |  |  | my($base) = shift;
26 | 4 | 3µs |  |  | my $fglob = ${"$base\::"}{FIELDS};
27 | 4 | 5µs |  |  | return( ($fglob && 'GLOB' eq ref($fglob) && *$fglob{HASH}) ? 1 : 0 );
28 |  |  |  |  | }
29 |  |  |  |  |
30 |  |  |  |  | # spent 6µs within base::has_attr which was called 4 times, avg 1µs/call: # 4 times (6µs+0s) by base::import at line 177, avg 1µs/call sub has_attr {
31 | 4 | 800ns |  |  | my($proto) = shift;
32 | 4 | 2µs |  |  | my($class) = ref $proto || $proto;
33 | 4 | 5µs |  |  | return exists $Fattr->{$class};
34 |  |  |  |  | }
35 |  |  |  |  |
36 |  |  |  |  | sub get_attr {
37 |  |  |  |  | $Fattr->{$_[0]} = [1] unless $Fattr->{$_[0]};
38 |  |  |  |  | return $Fattr->{$_[0]};
39 |  |  |  |  | }
40 |  |  |  |  |
41 | 1 | 400ns |  |  | if ($] < 5.009) {
42 |  |  |  |  | *get_fields = sub {
43 |  |  |  |  | # Shut up a possible typo warning.
44 |  |  |  |  | () = \%{$_[0].'::FIELDS'};
45 |  |  |  |  | my $f = \%{$_[0].'::FIELDS'};
46 |  |  |  |  |
47 |  |  |  |  | # should be centralized in fields? perhaps
48 |  |  |  |  | # fields::mk_FIELDS_be_OK. Peh. As long as %{ $package . '::FIELDS' }
49 |  |  |  |  | # is used here anyway, it doesn't matter.
50 |  |  |  |  | bless $f, 'pseudohash' if (ref($f) ne 'pseudohash');
51 |  |  |  |  |
52 |  |  |  |  | return $f;
53 |  |  |  |  | }
54 |  |  |  |  | }
55 |  |  |  |  | else {
56 |  |  |  |  | *get_fields = sub {
57 |  |  |  |  | # Shut up a possible typo warning.
58 |  |  |  |  | () = \%{$_[0].'::FIELDS'};
59 |  |  |  |  | return \%{$_[0].'::FIELDS'};
60 |  |  |  |  | }
61 | 1 | 2µs |  |  | }
62 |  |  |  |  |
63 | 1 | 200ns |  |  | if ($] < 5.008) {
64 |  |  |  |  | *_module_to_filename = sub {
65 |  |  |  |  | (my $fn = $_[0]) =~ s!::!/!g;
66 |  |  |  |  | $fn .= '.pm';
67 |  |  |  |  | return $fn;
68 |  |  |  |  | }
69 |  |  |  |  | }
70 |  |  |  |  | else {
71 |  |  |  |  | # spent 26µs (17+9) within base::__ANON__[/home/micha/.plenv/versions/5.38.2/lib/perl5/5.38.2/base.pm:76] which was called 4 times, avg 7µs/call: # 4 times (17µs+9µs) by base::import at line 103, avg 7µs/call *_module_to_filename = sub {
72 | 4 | 14µs | 4 | 7µs | (my $fn = $_[0]) =~ s!::!/!g; # spent 7µs making 4 calls to CORE::subst, avg 2µs/call
73 | 4 | 1µs |  |  | $fn .= '.pm';
74 | 4 | 7µs | 4 | 2µs | utf8::encode($fn); # spent 2µs making 4 calls to utf8::encode, avg 550ns/call
75 | 4 | 6µs |  |  | return $fn;
76 |  |  |  |  | }
77 | 1 | 2µs |  |  | }
78 |  |  |  |  |
79 |  |  |  |  |
80 |  |  |  |  | # spent 164µs (116+48) within base::import which was called 4 times, avg 41µs/call: # once (30µs+16µs) by Spreadsheet::ParseXLSX::Decryptor::Standard::BEGIN@10 at line 10 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX/Decryptor/Standard.pm # once (35µs+10µs) by Spreadsheet::ParseXLSX::Decryptor::Agile::BEGIN@10 at line 10 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX/Decryptor/Agile.pm # once (30µs+11µs) by Test2::Util::Facets2Legacy::BEGIN@10 at line 10 of Test2/Util/Facets2Legacy.pm # once (21µs+10µs) by Spreadsheet::ParseXLSX::Cell::BEGIN@11 at line 11 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX/Cell.pm sub import {
81 | 4 | 1µs |  |  | my $class = shift;
82 |  |  |  |  |
83 | 4 | 1µs |  |  | return SUCCESS unless @_;
84 |  |  |  |  |
85 |  |  |  |  | # List of base classes from which we will inherit %FIELDS.
86 | 4 | 700ns |  |  | my $fields_base;
87 |  |  |  |  |
88 | 4 | 2µs |  |  | my $inheritor = caller(0);
89 |  |  |  |  |
90 | 4 | 600ns |  |  | my @bases;
91 | 4 | 2µs |  |  | foreach my $base (@_) {
92 | 4 | 1µs |  |  | if ( $inheritor eq $base ) {
93 |  |  |  |  | warn "Class '$inheritor' tried to inherit from itself\n";
94 |  |  |  |  | }
95 |  |  |  |  |
96 | 4 | 42µs | 4 | 6µs | next if grep $_->isa($base), ($inheritor, @bases); # spent 6µs making 4 calls to UNIVERSAL::isa, avg 2µs/call
97 |  |  |  |  |
98 |  |  |  |  | # Following blocks help isolate $SIG{__DIE__} and @INC changes
99 |  |  |  |  | {
100 | 8 | 1µs |  |  | my $sigdie;
101 |  |  |  |  | {
102 | 8 | 6µs |  |  | local $SIG{__DIE__};
103 | 4 | 5µs | 4 | 26µs | my $fn = _module_to_filename($base); # spent 26µs making 4 calls to base::__ANON__[base.pm:76], avg 7µs/call
104 | 4 | 400ns |  |  | my $dot_hidden;
105 | 4 | 1µs |  |  | eval {
106 | 4 | 200ns |  |  | my $guard;
107 | 4 | 1µs |  |  | if ($INC[-1] eq '.' && %{"$base\::"}) {
108 |  |  |  |  | # So: the package already exists => this an optional load
109 |  |  |  |  | # And: there is a dot at the end of @INC => we want to hide it
110 |  |  |  |  | # However: we only want to hide it during our *own* require()
111 |  |  |  |  | # (i.e. without affecting nested require()s).
112 |  |  |  |  | # So we add a hook to @INC whose job is to hide the dot, but which
113 |  |  |  |  | # first checks checks the callstack depth, because within nested
114 |  |  |  |  | # require()s the callstack is deeper.
115 |  |  |  |  | # Since CORE::GLOBAL::require makes it unknowable in advance what
116 |  |  |  |  | # the exact relevant callstack depth will be, we have to record it
117 |  |  |  |  | # inside a hook. So we put another hook just for that at the front
118 |  |  |  |  | # of @INC, where it's guaranteed to run -- immediately.
119 |  |  |  |  | # The dot-hiding hook does its job by sitting directly in front of
120 |  |  |  |  | # the dot and removing itself from @INC when reached. This causes
121 |  |  |  |  | # the dot to move up one index in @INC, causing the loop inside
122 |  |  |  |  | # pp_require() to skip it.
123 |  |  |  |  | # Loaded coded may disturb this precise arrangement, but that's OK
124 |  |  |  |  | # because the hook is inert by that time. It is only active during
125 |  |  |  |  | # the top-level require(), when @INC is in our control. The only
126 |  |  |  |  | # possible gotcha is if other hooks already in @INC modify @INC in
127 |  |  |  |  | # some way during that initial require().
128 |  |  |  |  | # Note that this jiggery hookery works just fine recursively: if
129 |  |  |  |  | # a module loaded via base.pm uses base.pm itself, there will be
130 |  |  |  |  | # one pair of hooks in @INC per base::import call frame, but the
131 |  |  |  |  | # pairs from different nestings do not interfere with each other.
132 |  |  |  |  | my $lvl;
133 |  |  |  |  | unshift @INC, sub { return if defined $lvl; 1 while defined caller ++$lvl; () };
134 |  |  |  |  | splice @INC, -1, 0, sub { return if defined caller $lvl; ++$dot_hidden, &base::__inc::unhook; () };
135 |  |  |  |  | $guard = bless [ @INC[0,-2] ], 'base::__inc::scope_guard';
136 |  |  |  |  | }
137 | 4 | 2µs |  |  | require $fn
138 |  |  |  |  | };
139 | 4 | 600ns |  |  | if ($dot_hidden && (my @fn = grep -e && !( -d _ || -b _ ), $fn.'c', $fn)) {
140 |  |  |  |  | require Carp;
141 |  |  |  |  | Carp::croak(<<ERROR);
142 |  |  |  |  | Base class package "$base" is not empty but "$fn[0]" exists in the current directory.
143 |  |  |  |  | To help avoid security issues, base.pm now refuses to load optional modules
144 |  |  |  |  | from the current working directory when it is the last entry in \@INC.
145 |  |  |  |  | If your software worked on previous versions of Perl, the best solution
146 |  |  |  |  | is to use FindBin to detect the path properly and to add that path to
147 |  |  |  |  | \@INC. As a last resort, you can re-enable looking in the current working
148 |  |  |  |  | directory by adding "use lib '.'" to your code.
149 |  |  |  |  | ERROR
150 |  |  |  |  | }
151 |  |  |  |  | # Only ignore "Can't locate" errors from our eval require.
152 |  |  |  |  | # Other fatal errors (syntax etc) must be reported.
153 |  |  |  |  | #
154 |  |  |  |  | # changing the check here is fragile - if the check
155 |  |  |  |  | # here isn't catching every error you want, you should
156 |  |  |  |  | # probably be using parent.pm, which doesn't try to
157 |  |  |  |  | # guess whether require is needed or failed,
158 |  |  |  |  | # see [perl #118561]
159 | 4 | 6µs | 4 | 900ns | die if $@ && $@ !~ /^Can't locate \Q$fn\E .*? at .* line [0-9]+(?:, <[^>]*> (?:line|chunk) [0-9]+)?\.\n\z/s # spent 900ns making 4 calls to CORE::match, avg 225ns/call
160 |  |  |  |  | || $@ =~ /Compilation failed in require at .* line [0-9]+(?:, <[^>]*> (?:line|chunk) [0-9]+)?\.\n\z/;
161 | 4 | 4µs |  |  | unless (%{"$base\::"}) {
162 |  |  |  |  | require Carp;
163 |  |  |  |  | local $" = " ";
164 |  |  |  |  | Carp::croak(<<ERROR);
165 |  |  |  |  | Base class package "$base" is empty.
166 |  |  |  |  | (Perhaps you need to 'use' the module which defines that package first,
167 |  |  |  |  | or make that module available in \@INC (\@INC contains: @INC).
168 |  |  |  |  | ERROR
169 |  |  |  |  | }
170 | 4 | 8µs |  |  | $sigdie = $SIG{__DIE__} || undef;
171 |  |  |  |  | }
172 |  |  |  |  | # Make sure a global $SIG{__DIE__} makes it out of the localization.
173 | 4 | 1µs |  |  | $SIG{__DIE__} = $sigdie if defined $sigdie;
174 |  |  |  |  | }
175 | 4 | 1µs |  |  | push @bases, $base;
176 |  |  |  |  |
177 | 4 | 7µs | 8 | 14µs | if ( has_fields($base) || has_attr($base) ) { # spent 8µs making 4 calls to base::has_fields, avg 2µs/call # spent 6µs making 4 calls to base::has_attr, avg 1µs/call
178 |  |  |  |  | # No multiple fields inheritance *suck*
179 |  |  |  |  | if ($fields_base) {
180 |  |  |  |  | require Carp;
181 |  |  |  |  | Carp::croak("Can't multiply inherit fields");
182 |  |  |  |  | } else {
183 |  |  |  |  | $fields_base = $base;
184 |  |  |  |  | }
185 |  |  |  |  | }
186 |  |  |  |  | }
187 |  |  |  |  | # Save this until the end so it's all or nothing if the above loop croaks.
188 | 4 | 19µs |  |  | push @{"$inheritor\::ISA"}, @bases;
189 |  |  |  |  |
190 | 4 | 8µs |  |  | if( defined $fields_base ) {
191 |  |  |  |  | inherit_fields($inheritor, $fields_base);
192 |  |  |  |  | }
193 |  |  |  |  | }
194 |  |  |  |  |
195 |  |  |  |  |
196 |  |  |  |  | sub inherit_fields {
197 |  |  |  |  | my($derived, $base) = @_;
198 |  |  |  |  |
199 |  |  |  |  | return SUCCESS unless $base;
200 |  |  |  |  |
201 |  |  |  |  | my $battr = get_attr($base);
202 |  |  |  |  | my $dattr = get_attr($derived);
203 |  |  |  |  | my $dfields = get_fields($derived);
204 |  |  |  |  | my $bfields = get_fields($base);
205 |  |  |  |  |
206 |  |  |  |  | $dattr->[0] = @$battr;
207 |  |  |  |  |
208 |  |  |  |  | if( keys %$dfields ) {
209 |  |  |  |  | warn <<"END";
210 |  |  |  |  | $derived is inheriting from $base but already has its own fields!
211 |  |  |  |  | This will cause problems. Be sure you use base BEFORE declaring fields.
212 |  |  |  |  | END
213 |  |  |  |  |
214 |  |  |  |  | }
215 |  |  |  |  |
216 |  |  |  |  | # Iterate through the base's fields adding all the non-private
217 |  |  |  |  | # ones to the derived class. Hang on to the original attribute
218 |  |  |  |  | # (Public, Private, etc...) and add Inherited.
219 |  |  |  |  | # This is all too complicated to do efficiently with add_fields().
220 |  |  |  |  | while (my($k,$v) = each %$bfields) {
221 |  |  |  |  | my $fno;
222 |  |  |  |  | if ($fno = $dfields->{$k} and $fno != $v) {
223 |  |  |  |  | require Carp;
224 |  |  |  |  | Carp::croak ("Inherited fields can't override existing fields");
225 |  |  |  |  | }
226 |  |  |  |  |
227 |  |  |  |  | if( $battr->[$v] & PRIVATE ) {
228 |  |  |  |  | $dattr->[$v] = PRIVATE | INHERITED;
229 |  |  |  |  | }
230 |  |  |  |  | else {
231 |  |  |  |  | $dattr->[$v] = INHERITED | $battr->[$v];
232 |  |  |  |  | $dfields->{$k} = $v;
233 |  |  |  |  | }
234 |  |  |  |  | }
235 |  |  |  |  |
236 |  |  |  |  | foreach my $idx (1..$#{$battr}) {
237 |  |  |  |  | next if defined $dattr->[$idx];
238 |  |  |  |  | $dattr->[$idx] = $battr->[$idx] & INHERITED;
239 |  |  |  |  | }
240 |  |  |  |  | }
241 |  |  |  |  |
242 |  |  |  |  |
243 | 1 | 4µs |  |  | 1;
244 |  |  |  |  |
245 |  |  |  |  | __END__