← Index
NYTProf Performance Profile   « line view »
For /Users/brian/bin/perls/cpan5.26.1
  Run on Sat Dec 30 01:41:10 2017
Reported on Sat Dec 30 01:44:15 2017

Filename/usr/local/perls/perl-5.26.1/lib/5.26.1/Safe.pm
StatementsExecuted 4929 statements in 15.8ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
4082112.2ms13.8msSafe::::_find_code_refsSafe::_find_code_refs (recurses: max depth 2, inclusive time 19.0ms)
111616µs783µsSafe::::share_fromSafe::share_from
111432µs446µsSafe::::eraseSafe::erase
821288µs348µsSafe::::_clean_stashSafe::_clean_stash (recurses: max depth 2, inclusive time 244µs)
111117µs117µsSafe::::lexless_anon_subSafe::lexless_anon_sub
5111104µs104µsSafe::::CORE:substSafe::CORE:subst (opcode)
111102µs74.4msSafe::::revalSafe::reval
1173172µs72µsSafe::::CORE:matchSafe::CORE:match (opcode)
11165µs920µsSafe::::newSafe::new
11158µs58µsSafe::::share_recordSafe::share_record
11130µs39µsSafe::::permit_onlySafe::permit_only
11112µs458µsSafe::::DESTROYSafe::DESTROY
1119µs13.8msSafe::::wrap_code_refs_withinSafe::wrap_code_refs_within
2217µs7µsSafe::::rootSafe::root
0000s0sSafe::::BEGINSafe::BEGIN
0000s0sSafe::::__ANON__[:426]Safe::__ANON__[:426]
0000s0sSafe::::__ANON__[:42]Safe::__ANON__[:42]
0000s0sSafe::::__ANON__[:444]Safe::__ANON__[:444]
0000s0sSafe::::denySafe::deny
0000s0sSafe::::deny_onlySafe::deny_only
0000s0sSafe::::dump_maskSafe::dump_mask
0000s0sSafe::::maskSafe::mask
0000s0sSafe::::permitSafe::permit
0000s0sSafe::::rdoSafe::rdo
0000s0sSafe::::reinitSafe::reinit
0000s0sSafe::::shareSafe::share
0000s0sSafe::::share_forgetSafe::share_forget
0000s0sSafe::::share_redoSafe::share_redo
0000s0sSafe::::trapSafe::trap
0000s0sSafe::::untrapSafe::untrap
0000s0sSafe::::varglobSafe::varglob
0000s0sSafe::::wrap_code_refSafe::wrap_code_ref
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments		 Time
on line		 Calls Time
in subs		 Code
1package Safe;
2
3use 5.003_11;
4use Scalar::Util qw(reftype refaddr);
5
6$Safe::VERSION = "2.40";
7
8# *** Don't declare any lexicals above this point ***
9#
10# This function should return a closure which contains an eval that can't
11# see any lexicals in scope (apart from __ExPr__ which is unavoidable)
12
13
# spent 117µs within Safe::lexless_anon_sub which was called: # once (117µs+0s) by Safe::reval at line 362
sub lexless_anon_sub {
14 # $_[0] is package;
15 # $_[1] is strict flag;
1611µs my $__ExPr__ = $_[2]; # must be a lexical to create the closure that
17 # can be used to pass the value into the safe
18 # world
19
20 # Create anon sub ref in root of compartment.
21 # Uses a closure (on $__ExPr__) to pass in the code to be executed.
22 # (eval on one line to keep line numbers as expected by caller)
231114µs eval sprintf
# spent 60.1ms executing statements in string eval, 9.50ms here plus 50.6ms in 1 nested evals
# includes 60.0ms spent executing 1 call to 1 sub defined therein.
24 'package %s; %s sub { @_=(); eval q[local *SIG; my $__ExPr__;] . $__ExPr__; }',
25 $_[0], $_[1] ? 'use strict;' : '';
26}
27
28use strict;
29use Carp;
30BEGIN { eval q{
31 use Carp::Heavy;
32} }
33
34use B ();
35BEGIN {
36 no strict 'refs';
37 if (defined &B::sub_generation) {
38 *sub_generation = \&B::sub_generation;
39 }
40 else {
41 # fake sub generation changing for perls < 5.8.9
42 my $sg; *sub_generation = sub { ++$sg };
43 }
44}
45
46use Opcode 1.01, qw(
47 opset opset_to_ops opmask_add
48 empty_opset full_opset invert_opset verify_opset
49 opdesc opcodes opmask define_optag opset_to_hex
50);
51
52*ops_to_opset = \&opset; # Temporary alias for old Penguins
53
54# Regular expressions and other unicode-aware code may need to call
55# utf8->SWASHNEW (via perl's utf8.c). That will fail unless we share the
56# SWASHNEW method.
57# Sadly we can't just add utf8::SWASHNEW to $default_share because perl's
58# utf8.c code does a fetchmethod on SWASHNEW to check if utf8.pm is loaded,
59# and sharing makes it look like the method exists.
60# The simplest and most robust fix is to ensure the utf8 module is loaded when
61# Safe is loaded. Then we can add utf8::SWASHNEW to $default_share.
62require utf8;
63# we must ensure that utf8_heavy.pl, where SWASHNEW is defined, is loaded
64# but without depending on too much knowledge of that implementation detail.
65# This code (//i on a unicode string) should ensure utf8 is fully loaded
66# and also loads the ToFold SWASH, unless things change so that these
67# particular code points don't cause it to load.
68# (Swashes are cached internally by perl in PL_utf8_* variables
69# independent of being inside/outside of Safe. So once loaded they can be)
70do { my $a = pack('U',0x100); my $b = chr 0x101; utf8::upgrade $b; $a =~ /$b/i };
71# now we can safely include utf8::SWASHNEW in $default_share defined below.
72
73my $default_root = 0;
74# share *_ and functions defined in universal.c
75# Don't share stuff like *UNIVERSAL:: otherwise code from the
76# compartment can 0wn functions in UNIVERSAL
77my $default_share = [qw[
78 *_
79 &PerlIO::get_layers
80 &UNIVERSAL::isa
81 &UNIVERSAL::can
82 &UNIVERSAL::VERSION
83 &utf8::is_utf8
84 &utf8::valid
85 &utf8::encode
86 &utf8::decode
87 &utf8::upgrade
88 &utf8::downgrade
89 &utf8::native_to_unicode
90 &utf8::unicode_to_native
91 &utf8::SWASHNEW
92 $version::VERSION
93 $version::CLASS
94 $version::STRICT
95 $version::LAX
96 @version::ISA
97], ($] < 5.010 && qw[
98 &utf8::SWASHGET
99]), ($] >= 5.008001 && qw[
100 &Regexp::DESTROY
101]), ($] >= 5.010 && qw[
102 &re::is_regexp
103 &re::regname
104 &re::regnames
105 &re::regnames_count
106 &UNIVERSAL::DOES
107 &version::()
108 &version::new
109 &version::(""
110 &version::stringify
111 &version::(0+
112 &version::numify
113 &version::normal
114 &version::(cmp
115 &version::(<=>
116 &version::vcmp
117 &version::(bool
118 &version::boolean
119 &version::(nomethod
120 &version::noop
121 &version::is_alpha
122 &version::qv
123 &version::vxs::declare
124 &version::vxs::qv
125 &version::vxs::_VERSION
126 &version::vxs::stringify
127 &version::vxs::new
128 &version::vxs::parse
129 &version::vxs::VCMP
130]), ($] >= 5.011 && qw[
131 &re::regexp_pattern
132]), ($] >= 5.010 && $] < 5.014 && qw[
133 &Tie::Hash::NamedCapture::FETCH
134 &Tie::Hash::NamedCapture::STORE
135 &Tie::Hash::NamedCapture::DELETE
136 &Tie::Hash::NamedCapture::CLEAR
137 &Tie::Hash::NamedCapture::EXISTS
138 &Tie::Hash::NamedCapture::FIRSTKEY
139 &Tie::Hash::NamedCapture::NEXTKEY
140 &Tie::Hash::NamedCapture::SCALAR
141 &Tie::Hash::NamedCapture::flags
142])];
143if (defined $Devel::Cover::VERSION) {
144 push @$default_share, '&Devel::Cover::use_file';
145}
146
147
# spent 920µs (65+855) within Safe::new which was called: # once (65µs+855µs) by CPAN::Distribution::CHECKSUM_check_file at line 1498 of CPAN/Distribution.pm
sub new {
14815µs my($class, $root, $mask) = @_;
14912µs my $obj = {};
15012µs bless $obj, $class;
151
15211µs if (defined($root)) {
153 croak "Can't use \"$root\" as root name"
154 if $root =~ /^main\b/ or $root !~ /^\w[:\w]*$/;
155 $obj->{Root} = $root;
156 $obj->{Erase} = 0;
157 }
158 else {
159118µs $obj->{Root} = "Safe::Root".$default_root++;
16011µs $obj->{Erase} = 1;
161 }
162
163 # use permit/deny methods instead till interface issues resolved
164 # XXX perhaps new Safe 'Root', mask => $mask, foo => bar, ...;
16510s croak "Mask parameter to new no longer supported" if defined $mask;
16619µs139µs $obj->permit_only(':default');
# spent 39µs making 1 call to Safe::permit_only
167
168 # We must share $_ and @_ with the compartment or else ops such
169 # as split, length and so on won't default to $_ properly, nor
170 # will passing argument to subroutines work (via @_). In fact,
171 # for reasons I don't completely understand, we need to share
172 # the whole glob *_ rather than $_ and @_ separately, otherwise
173 # @_ in non default packages within the compartment don't work.
17415µs1783µs $obj->share_from('main', $default_share);
# spent 783µs making 1 call to Safe::share_from
175
176148µs133µs Opcode::_safe_pkg_prep($obj->{Root}) if($Opcode::VERSION > 1.04);
# spent 33µs making 1 call to Opcode::_safe_pkg_prep
177
17818µs return $obj;
179}
180
181
# spent 458µs (12+446) within Safe::DESTROY which was called: # once (12µs+446µs) by CPAN::Distribution::CHECKSUM_check_file at line 1500 of CPAN/Distribution.pm
sub DESTROY {
18211µs my $obj = shift;
18318µs1446µs $obj->erase('DESTROY') if $obj->{Erase};
# spent 446µs making 1 call to Safe::erase
184}
185
186
# spent 446µs (432+14) within Safe::erase which was called: # once (432µs+14µs) by Safe::DESTROY at line 183
sub erase {
18711µs my ($obj, $action) = @_;
18812µs12µs my $pkg = $obj->root();
# spent 2µs making 1 call to Safe::root
18911µs my ($stem, $leaf);
190
191 no strict 'refs';
19212µs $pkg = "main::$pkg\::"; # expand to full symbol table name
193117µs112µs ($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
# spent 12µs making 1 call to Safe::CORE:match
194
195 # The 'my $foo' is needed! Without it you get an
196 # 'Attempt to free unreferenced scalar' warning!
19713µs my $stem_symtab = *{$stem}{HASH};
198
199 #warn "erase($pkg) stem=$stem, leaf=$leaf";
200 #warn " stem_symtab hash ".scalar(%$stem_symtab)."\n";
201 # ", join(', ', %$stem_symtab),"\n";
202
203# delete $stem_symtab->{$leaf};
204
20514µs my $leaf_glob = $stem_symtab->{$leaf};
20612µs my $leaf_symtab = *{$leaf_glob}{HASH};
207# warn " leaf_symtab ", join(', ', %$leaf_symtab),"\n";
2081395µs %$leaf_symtab = ();
209 #delete $leaf_symtab->{'__ANON__'};
210 #delete $leaf_symtab->{'foo'};
211 #delete $leaf_symtab->{'main::'};
212# my $foo = undef ${"$stem\::"}{"$leaf\::"};
213
21419µs if ($action and $action eq 'DESTROY') {
215 delete $stem_symtab->{$leaf};
216 } else {
217 $obj->share_from('main', $default_share);
218 }
219110µs 1;
220}
221
222
223sub reinit {
224 my $obj= shift;
225 $obj->erase;
226 $obj->share_redo;
227}
228
229
# spent 7µs within Safe::root which was called 2 times, avg 4µs/call: # once (5µs+0s) by Safe::share_from at line 283 # once (2µs+0s) by Safe::erase at line 188
sub root {
23021µs my $obj = shift;
23121µs croak("Safe root method now read-only") if @_;
232211µs return $obj->{Root};
233}
234
235
236sub mask {
237 my $obj = shift;
238 return $obj->{Mask} unless @_;
239 $obj->deny_only(@_);
240}
241
242# v1 compatibility methods
243sub trap { shift->deny(@_) }
244sub untrap { shift->permit(@_) }
245
246sub deny {
247 my $obj = shift;
248 $obj->{Mask} |= opset(@_);
249}
250sub deny_only {
251 my $obj = shift;
252 $obj->{Mask} = opset(@_);
253}
254
255sub permit {
256 my $obj = shift;
257 # XXX needs testing
258 $obj->{Mask} &= invert_opset opset(@_);
259}
260
# spent 39µs (30+9) within Safe::permit_only which was called: # once (30µs+9µs) by Safe::new at line 166
sub permit_only {
26111µs my $obj = shift;
262137µs29µs $obj->{Mask} = invert_opset opset(@_);
# spent 6µs making 1 call to Opcode::opset # spent 3µs making 1 call to Opcode::invert_opset
263}
264
265
266sub dump_mask {
267 my $obj = shift;
268 print opset_to_hex($obj->{Mask}),"\n";
269}
270
271
272sub share {
273 my($obj, @vars) = @_;
274 $obj->share_from(scalar(caller), \@vars);
275}
276
277
278
# spent 783µs (616+167) within Safe::share_from which was called: # once (616µs+167µs) by Safe::new at line 174
sub share_from {
27910s my $obj = shift;
28011µs my $pkg = shift;
28112µs my $vars = shift;
28211µs my $no_record = shift || 0;
28314µs15µs my $root = $obj->root();
# spent 5µs making 1 call to Safe::root
28413µs croak("vars not an array ref") unless ref $vars eq 'ARRAY';
285 no strict 'refs';
286 # Check that 'from' package actually exists
287 croak("Package \"$pkg\" does not exist")
28812µs unless keys %{"$pkg\::"};
28911µs my $arg;
29014µs foreach $arg (@$vars) {
291 # catch some $safe->share($var) errors:
292514µs my ($var, $type);
29351240µs51104µs $type = $1 if ($var = $arg) =~ s/^(\W)//;
# spent 104µs making 51 calls to Safe::CORE:subst, avg 2µs/call
294 # warn "share_from $pkg $type $var";
2955154µs for (1..2) { # assign twice to avoid any 'used once' warnings
296 *{$root."::$var"} = (!$type) ? \&{$pkg."::$var"}
297 : ($type eq '&') ? \&{$pkg."::$var"}
298 : ($type eq '$') ? \${$pkg."::$var"}
299 : ($type eq '@') ? \@{$pkg."::$var"}
300 : ($type eq '%') ? \%{$pkg."::$var"}
301102387µs : ($type eq '*') ? *{$pkg."::$var"}
302 : croak(qq(Can't share "$type$var" of unknown type));
303 }
304 }
305110µs158µs $obj->share_record($pkg, $vars) unless $no_record or !$vars;
# spent 58µs making 1 call to Safe::share_record
306}
307
308
309
# spent 58µs within Safe::share_record which was called: # once (58µs+0s) by Safe::share_from at line 305
sub share_record {
31010s my $obj = shift;
31111µs my $pkg = shift;
31210s my $vars = shift;
31315µs my $shares = \%{$obj->{Shares} ||= {}};
314 # Record shares using keys of $obj->{Shares}. See reinit.
315155µs @{$shares}{@$vars} = ($pkg) x @$vars if @$vars;
316}
317
318
319sub share_redo {
320 my $obj = shift;
321 my $shares = \%{$obj->{Shares} ||= {}};
322 my($var, $pkg);
323 while(($var, $pkg) = each %$shares) {
324 # warn "share_redo $pkg\:: $var";
325 $obj->share_from($pkg, [ $var ], 1);
326 }
327}
328
329
330sub share_forget {
331 delete shift->{Shares};
332}
333
334
335sub varglob {
336 my ($obj, $var) = @_;
337 no strict 'refs';
338 return *{$obj->root()."::$var"};
339}
340
341
# spent 348µs (288+60) within Safe::_clean_stash which was called 8 times, avg 44µs/call: # 7 times (185µs+-185µs) by Safe::_clean_stash at line 352, avg 0s/call # once (103µs+245µs) by Safe::reval at line 374
sub _clean_stash {
34284µs my ($root, $saved_refs) = @_;
34383µs $saved_refs ||= [];
344 no strict 'refs';
3458116µs6224µs foreach my $hook (qw(DESTROY AUTOLOAD), grep /^\(/, keys %$root) {
# spent 24µs making 62 calls to Safe::CORE:match, avg 387ns/call
3462343µs push @$saved_refs, \*{$root.$hook};
3472323µs delete ${$root}{$hook};
348 }
349
3508121µs5436µs for (grep /::$/, keys %$root) {
# spent 36µs making 54 calls to Safe::CORE:match, avg 667ns/call
351819µs next if \%{$root.$_} eq \%$root;
352719µs70s _clean_stash($root.$_, $saved_refs);
# spent 244µs making 7 calls to Safe::_clean_stash, avg 35µs/call, recursion: max depth 2, sum of overlapping time 244µs
353 }
354}
355
356
# spent 74.4ms (102µs+74.3) within Safe::reval which was called: # once (102µs+74.3ms) by CPAN::Distribution::CHECKSUM_check_file at line 1499 of CPAN/Distribution.pm
sub reval {
357115µs my ($obj, $expr, $strict) = @_;
358111µs12µs die "Bad Safe object" unless $obj->isa('Safe');
# spent 2µs making 1 call to UNIVERSAL::isa
359
36011µs my $root = $obj->{Root};
361
36214µs1117µs my $evalsub = lexless_anon_sub($root, $strict, $expr);
# spent 117µs making 1 call to Safe::lexless_anon_sub
363 # propagate context
364119µs112µs my $sg = sub_generation();
# spent 12µs making 1 call to B::sub_generation
36511µs my @subret;
366157µs2120ms if (defined wantarray) {
# spent 60.1ms making 1 call to Opcode::_safe_call_sv # spent 60.0ms making 1 call to main::__ANON__[(eval 43)[Safe.pm:23]:1]
367 @subret = (wantarray)
368 ? Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub)
369 : scalar Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub);
370 }
371 else {
372 Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub);
373 }
374116µs2352µs _clean_stash($root.'::') if $sg != sub_generation();
# spent 348µs making 1 call to Safe::_clean_stash # spent 4µs making 1 call to B::sub_generation
37513µs113.8ms $obj->wrap_code_refs_within(@subret);
# spent 13.8ms making 1 call to Safe::wrap_code_refs_within
376122µs return (wantarray) ? @subret : $subret[0];
377}
378
379my %OID;
380
381
# spent 13.8ms (9µs+13.8) within Safe::wrap_code_refs_within which was called: # once (9µs+13.8ms) by Safe::reval at line 375
sub wrap_code_refs_within {
38211µs my $obj = shift;
383
38411µs %OID = ();
38519µs113.8ms $obj->_find_code_refs('wrap_code_ref', @_);
# spent 13.8ms making 1 call to Safe::_find_code_refs
386}
387
388
389
# spent 13.8ms (12.2+1.52) within Safe::_find_code_refs which was called 408 times, avg 34µs/call: # 407 times (12.2ms+-12.2ms) by Safe::_find_code_refs at line 400, avg 0s/call # once (50µs+13.7ms) by Safe::wrap_code_refs_within at line 385
sub _find_code_refs {
39040875µs my $obj = shift;
39140888µs my $visitor = shift;
392
3934081.12ms for my $item (@_) {
39424815.40ms24811.29ms my $reftype = $item && reftype $item
# spent 1.29ms making 2481 calls to Scalar::Util::reftype, avg 521ns/call
395 or next;
396
397 # skip references already seen
3984076.00ms407228µs next if ++$OID{refaddr $item} > 1;
# spent 228µs making 407 calls to Scalar::Util::refaddr, avg 560ns/call
399
4004071.07ms4070s if ($reftype eq 'ARRAY') {
# spent 19.0ms making 407 calls to Safe::_find_code_refs, avg 47µs/call, recursion: max depth 2, sum of overlapping time 19.0ms
401 $obj->_find_code_refs($visitor, @$item);
402 }
403 elsif ($reftype eq 'HASH') {
404 $obj->_find_code_refs($visitor, values %$item);
405 }
406 # XXX GLOBs?
407 elsif ($reftype eq 'CODE') {
408 $item = $obj->$visitor($item);
409 }
410 }
411}
412
413
414sub wrap_code_ref {
415 my ($obj, $sub) = @_;
416 die "Bad safe object" unless $obj->isa('Safe');
417
418 # wrap code ref $sub with _safe_call_sv so that, when called, the
419 # execution will happen with the compartment fully 'in effect'.
420
421 croak "Not a CODE reference"
422 if reftype $sub ne 'CODE';
423
424 my $ret = sub {
425 my @args = @_; # lexical to close over
426 my $sub_with_args = sub { $sub->(@args) };
427
428 my @subret;
429 my $error;
430 do {
431 local $@; # needed due to perl_call_sv(sv, G_EVAL|G_KEEPERR)
432 my $sg = sub_generation();
433 @subret = (wantarray)
434 ? Opcode::_safe_call_sv($obj->{Root}, $obj->{Mask}, $sub_with_args)
435 : scalar Opcode::_safe_call_sv($obj->{Root}, $obj->{Mask}, $sub_with_args);
436 $error = $@;
437 _clean_stash($obj->{Root}.'::') if $sg != sub_generation();
438 };
439 if ($error) { # rethrow exception
440 $error =~ s/\t\(in cleanup\) //; # prefix added by G_KEEPERR
441 die $error;
442 }
443 return (wantarray) ? @subret : $subret[0];
444 };
445
446 return $ret;
447}
448
449
450sub rdo {
451 my ($obj, $file) = @_;
452 die "Bad Safe object" unless $obj->isa('Safe');
453
454 my $root = $obj->{Root};
455
456 my $sg = sub_generation();
457 my $evalsub = eval
458 sprintf('package %s; sub { @_ = (); do $file }', $root);
459 my @subret = (wantarray)
460 ? Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub)
461 : scalar Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub);
462 _clean_stash($root.'::') if $sg != sub_generation();
463 $obj->wrap_code_refs_within(@subret);
464 return (wantarray) ? @subret : $subret[0];
465}
466
467
4681;
469
470__END__
 
# spent 72µs within Safe::CORE:match which was called 117 times, avg 615ns/call: # 62 times (24µs+0s) by Safe::_clean_stash at line 345, avg 387ns/call # 54 times (36µs+0s) by Safe::_clean_stash at line 350, avg 667ns/call # once (12µs+0s) by Safe::erase at line 193
sub Safe::CORE:match; # opcode
# spent 104µs within Safe::CORE:subst which was called 51 times, avg 2µs/call: # 51 times (104µs+0s) by Safe::share_from at line 293, avg 2µs/call
sub Safe::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.