Profile of base.pm

Filename	/Users/ether/perl5/perlbrew/perls/36.0/lib/5.36.0/base.pm
Statements	Executed 493 statements in 2.24ms

Subroutines
Calls	P	F	Exclusive Time	Inclusive Time	Subroutine
13	13	11	665µs	984µs	base::::import base::import
13	1	1	100µs	138µs	base::::__ANON__[:76] base::__ANON__[:76]
2	1	1	72µs	72µs	base::::CORE:regcomp base::CORE:regcomp (opcode)
13	1	1	45µs	45µs	base::::has_fields base::has_fields
13	1	1	25µs	25µs	base::::has_attr base::has_attr
13	1	1	23µs	23µs	base::::CORE:subst base::CORE:subst (opcode)
1	1	1	21µs	21µs	JSON::MaybeXS::::BEGIN@1 JSON::MaybeXS::BEGIN@1
15	1	1	18µs	18µs	base::::CORE:match base::CORE:match (opcode)
1	1	1	4µs	9µ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::::DESTROYbase::__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	21µs	# spent 21µs within JSON::MaybeXS::BEGIN@1 which was called: # once (21µs+0s) by JSON::MaybeXS::BEGIN@5 at line 1 use 5.008; # spent 21µs making 1 call to JSON::MaybeXS::BEGIN@1
2					package base;
3
4	2	1.18ms	2	14µs	# spent 9µs (4+5) within base::BEGIN@4 which was called: # once (4µs+5µs) by JSON::MaybeXS::BEGIN@5 at line 4 use strict 'vars'; # spent 9µs making 1 call to base::BEGIN@4 # spent 5µs making 1 call to strict::import
5	1	1µs			our $VERSION = '2.27';
6	1	2µs			$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	1µs			my $Fattr = \%fields::attr;
23
24					# spent 45µs within base::has_fields which was called 13 times, avg 3µs/call: # 13 times (45µs+0s) by base::import at line 177, avg 3µs/call sub has_fields {
25	13	7µs			my($base) = shift;
26	13	12µs			my $fglob = ${"$base\::"}{FIELDS};
27	13	25µs			return( ($fglob && 'GLOB' eq ref($fglob) && *$fglob{HASH}) ? 1 : 0 );
28					}
29
30					# spent 25µs within base::has_attr which was called 13 times, avg 2µs/call: # 13 times (25µs+0s) by base::import at line 177, avg 2µs/call sub has_attr {
31	13	3µs			my($proto) = shift;
32	13	6µs			my($class) = ref $proto \|\| $proto;
33	13	22µ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	2µs			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	4µs			}
62
63	1	1µs			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 138µs (100+38) within base::__ANON__[/Users/ether/perl5/perlbrew/perls/36.0/lib/5.36.0/base.pm:76] which was called 13 times, avg 11µs/call: # 13 times (100µs+38µs) by base::import at line 103, avg 11µs/call *_module_to_filename = sub {
72	13	57µs	13	23µs	(my $fn = $_[0]) =~ s!::!/!g; # spent 23µs making 13 calls to base::CORE:subst, avg 2µs/call
73	13	6µs			$fn .= '.pm';
74	13	52µs	13	15µs	utf8::encode($fn); # spent 15µs making 13 calls to utf8::encode, avg 1µs/call
75	13	35µs			return $fn;
76					}
77	1	1µs			}
78
79
80					# spent 984µs (665+319) within base::import which was called 13 times, avg 76µs/call: # once (135µs+60µs) by YAML::PP::Preserve::Hash::BEGIN@227 at line 227 of YAML/PP.pm # once (128µs+61µs) by YAML::PP::Preserve::Array::BEGIN@301 at line 301 of YAML/PP.pm # once (48µs+24µs) by JSON::MaybeXS::BEGIN@5 at line 5 of JSON/MaybeXS.pm # once (38µs+26µs) by YAML::PP::Schema::JSON::BEGIN@7 at line 7 of YAML/PP/Schema/JSON.pm # once (47µs+14µs) by YAML::PP::Common::BEGIN@7 at line 7 of YAML/PP/Common.pm # once (39µs+17µs) by List::MoreUtils::XS::BEGIN@6 at line 6 of List/MoreUtils/XS.pm # once (35µs+19µs) by YAML::PP::Grammar::BEGIN@7 at line 7 of YAML/PP/Grammar.pm # once (35µs+17µs) by Variable::Magic::BEGIN@688 at line 688 of Variable/Magic.pm # once (34µs+17µs) by YAML::PP::Writer::File::BEGIN@9 at line 9 of YAML/PP/Writer/File.pm # once (34µs+16µs) by YAML::PP::BEGIN@15 at line 15 of YAML/PP.pm # once (30µs+17µs) by namespace::clean::_Util::BEGIN@15 at line 15 of namespace/clean/_Util.pm # once (31µs+16µs) by Class::Method::Modifiers::BEGIN@10 at line 10 of Class/Method/Modifiers.pm # once (31µs+15µs) by File::ShareDir::BEGIN@124 at line 124 of File/ShareDir.pm sub import {
81	13	6µs			my $class = shift;
82
83	13	7µs			return SUCCESS unless @_;
84
85					# List of base classes from which we will inherit %FIELDS.
86	13	2µs			my $fields_base;
87
88	13	9µs			my $inheritor = caller(0);
89
90	13	1µs			my @bases;
91	13	12µs			foreach my $base (@_) {
92	13	7µs			if ( $inheritor eq $base ) {
93					warn "Class '$inheritor' tried to inherit from itself\n";
94					}
95
96	13	108µs	13	21µs	next if grep $_->isa($base), ($inheritor, @bases); # spent 21µs making 13 calls to UNIVERSAL::isa, avg 2µs/call
97
98					# Following blocks help isolate $SIG{__DIE__} and @INC changes
99					{
100	26	6µs			my $sigdie;
101					{
102	26	32µs			local $SIG{__DIE__};
103	13	22µs	13	138µs	my $fn = _module_to_filename($base); # spent 138µs making 13 calls to base::__ANON__[base.pm:76], avg 11µs/call
104	13	1µs			my $dot_hidden;
105	13	4µs			eval {
106	13	3µs			my $guard;
107	13	2µ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	13	175µs			require $fn
138					};
139	13	6µs			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	13	127µs	17	90µs	die if $@ && $@ !~ /^Can't locate \Q$fn\E .? at . line [0-9]+(?:, <[^>]*> (?:line\|chunk) [0-9]+)?\.\n\z/s # spent 72µs making 2 calls to base::CORE:regcomp, avg 36µs/call # spent 18µs making 15 calls to base::CORE:match, avg 1µs/call
160					\|\| $@ =~ /Compilation failed in require at .* line [0-9]+(?:, <[^>]*> (?:line\|chunk) [0-9]+)?\.\n\z/;
161	13	15µ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	13	33µs			$sigdie = $SIG{__DIE__} \|\| undef;
171					}
172					# Make sure a global $SIG{__DIE__} makes it out of the localization.
173	13	5µs			$SIG{__DIE__} = $sigdie if defined $sigdie;
174					}
175	13	3µs			push @bases, $base;
176
177	13	43µs	26	70µs	if ( has_fields($base) \|\| has_attr($base) ) { # spent 45µs making 13 calls to base::has_fields, avg 3µs/call # spent 25µs making 13 calls to base::has_attr, avg 2µ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	13	110µs			push @{"$inheritor\::ISA"}, @bases;
189
190	13	39µ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	5µs			1;
244
245					__END__

					# spent 18µs within base::CORE:match which was called 15 times, avg 1µs/call: # 15 times (18µs+0s) by base::import at line 159, avg 1µs/call sub base::CORE:match; # opcode
					# spent 72µs within base::CORE:regcomp which was called 2 times, avg 36µs/call: # 2 times (72µs+0s) by base::import at line 159, avg 36µs/call sub base::CORE:regcomp; # opcode
					# spent 23µs within base::CORE:subst which was called 13 times, avg 2µs/call: # 13 times (23µs+0s) by base::__ANON__[/Users/ether/perl5/perlbrew/perls/36.0/lib/5.36.0/base.pm:76] at line 72, avg 2µs/call sub base::CORE:subst; # opcode