← Index
NYTProf Performance Profile   « line view »
For t/optimization.t
  Run on Thu Jan 8 22:47:42 2015
Reported on Thu Jan 8 22:48:06 2015

Filename/home/ss5/perl5/perlbrew/perls/tapper-perl/lib/5.16.3/Safe.pm
StatementsExecuted 590 statements in 5.04ms
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
1112.38ms3.06msSafe::::BEGIN@34Safe::BEGIN@34
1621876µs938µsSafe::::_clean_stashSafe::_clean_stash (recurses: max depth 2, inclusive time 764µs)
111815µs4.47msSafe::::BEGIN@46Safe::BEGIN@46
221648µs746µsSafe::::share_fromSafe::share_from
211175µs175µsSafe::::lexless_anon_subSafe::lexless_anon_sub
111128µs4.79msSafe::::CORE:regcompSafe::CORE:regcomp (opcode)
21193µs1.44msSafe::::revalSafe::reval
2573166µs66µsSafe::::CORE:matchSafe::CORE:match (opcode)
591154µs54µsSafe::::CORE:substSafe::CORE:subst (opcode)
11140µs159µsSafe::::BEGIN@30Safe::BEGIN@30
21139µs39µsSafe::::share_recordSafe::share_record
11128µs697µsSafe::::newSafe::new
21121µs45µsSafe::::wrap_code_refs_withinSafe::wrap_code_refs_within
21121µs24µsSafe::::_find_code_refsSafe::_find_code_refs
11120µs20µsSafe::::BEGIN@3Safe::BEGIN@3
11117µs37µsSafe::::BEGIN@36Safe::BEGIN@36
11113µs30µsSafe::::BEGIN@188Safe::BEGIN@188
11112µs15µsSafe::::permit_onlySafe::permit_only
11112µs26µsSafe::::BEGIN@334Safe::BEGIN@334
11111µs46µsSafe::::BEGIN@4Safe::BEGIN@4
11111µs11µsSafe::::CORE:packSafe::CORE:pack (opcode)
11110µs24µsSafe::::BEGIN@282Safe::BEGIN@282
11110µs47µsSafe::::BEGIN@29Safe::BEGIN@29
11110µs10µsSafe::::BEGIN@35Safe::BEGIN@35
11110µs24µsSafe::::BEGIN@28Safe::BEGIN@28
1119µs20µsSafe::::BEGIN@341Safe::BEGIN@341
1119µs106µsSafe::::shareSafe::share
1118µs11µsSafe::::permitSafe::permit
2114µs4µsSafe::::rootSafe::root
0000s0sSafe::::DESTROYSafe::DESTROY
0000s0sSafe::::__ANON__[:414]Safe::__ANON__[:414]
0000s0sSafe::::__ANON__[:42]Safe::__ANON__[:42]
0000s0sSafe::::__ANON__[:432]Safe::__ANON__[:432]
0000s0sSafe::::denySafe::deny
0000s0sSafe::::deny_onlySafe::deny_only
0000s0sSafe::::dump_maskSafe::dump_mask
0000s0sSafe::::eraseSafe::erase
0000s0sSafe::::maskSafe::mask
0000s0sSafe::::rdoSafe::rdo
0000s0sSafe::::reinitSafe::reinit
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
3262µs120µs
# spent 20µs within Safe::BEGIN@3 which was called: # once (20µs+0s) by Data::DPath::Context::BEGIN@17 at line 3
use 5.003_11;
# spent 20µs making 1 call to Safe::BEGIN@3
4283µs282µs
# spent 46µs (11+36) within Safe::BEGIN@4 which was called: # once (11µs+36µs) by Data::DPath::Context::BEGIN@17 at line 4
use Scalar::Util qw(reftype refaddr);
# spent 46µs making 1 call to Safe::BEGIN@4 # spent 36µs making 1 call to Exporter::import
5
611µs$Safe::VERSION = "2.31_01";
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 175µs within Safe::lexless_anon_sub which was called 2 times, avg 88µs/call: # 2 times (175µs+0s) by Safe::reval at line 357, avg 88µs/call
sub lexless_anon_sub {
14 # $_[0] is package;
15 # $_[1] is strict flag;
1622µ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)
232168µs eval sprintf
# spent 73µs executing statements in string eval, 48µs here plus 25µs in 1 nested evals
# includes 66µs spent executing 1 call to 1 sub defined therein. # spent 55µs executing statements in string eval, 46µs here plus 9µs in 1 nested evals
# includes 52µs spent executing 1 call to 1 sub defined therein.
24 'package %s; %s sub { @_=(); eval q[my $__ExPr__;] . $__ExPr__; }',
25 $_[0], $_[1] ? 'use strict;' : '';
26}
27
28226µs239µs
# spent 24µs (10+15) within Safe::BEGIN@28 which was called: # once (10µs+15µs) by Data::DPath::Context::BEGIN@17 at line 28
use strict;
# spent 24µs making 1 call to Safe::BEGIN@28 # spent 15µs making 1 call to strict::import
29229µs285µs
# spent 47µs (10+38) within Safe::BEGIN@29 which was called: # once (10µs+38µs) by Data::DPath::Context::BEGIN@17 at line 29
use Carp;
# spent 47µs making 1 call to Safe::BEGIN@29 # spent 38µs making 1 call to Exporter::import
30134µs
# spent 159µs (40+119) within Safe::BEGIN@30 which was called: # once (40µs+119µs) by Data::DPath::Context::BEGIN@17 at line 32
BEGIN { eval q{
# spent 88µs executing statements in string eval
# includes 111µs spent executing 1 call to 1 sub defined therein.
31 use Carp::Heavy;
32119µs1159µs} }
# spent 159µs making 1 call to Safe::BEGIN@30
33
342136µs13.06ms
# spent 3.06ms (2.38+675µs) within Safe::BEGIN@34 which was called: # once (2.38ms+675µs) by Data::DPath::Context::BEGIN@17 at line 34
use B ();
# spent 3.06ms making 1 call to Safe::BEGIN@34
35
# spent 10µs within Safe::BEGIN@35 which was called: # once (10µs+0s) by Data::DPath::Context::BEGIN@17 at line 44
BEGIN {
362111µs258µs
# spent 37µs (17+20) within Safe::BEGIN@36 which was called: # once (17µs+20µs) by Data::DPath::Context::BEGIN@17 at line 36
no strict 'refs';
# spent 37µs making 1 call to Safe::BEGIN@36 # spent 20µs making 1 call to strict::unimport
37111µs 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 }
44142µs110µs}
# spent 10µs making 1 call to Safe::BEGIN@35
45
46114µs1272µs
# spent 4.47ms (815µs+3.66) within Safe::BEGIN@46 which was called: # once (815µs+3.66ms) by Data::DPath::Context::BEGIN@17 at line 50
use Opcode 1.01, qw(
# spent 272µs making 1 call to Exporter::import
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
501532µs14.47ms);
# spent 4.47ms making 1 call to Safe::BEGIN@46
51
5212µs*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.
6211µsrequire 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)
705168µs59.48msdo { my $a = pack('U',0x100); my $b = chr 0x101; utf8::upgrade $b; $a =~ /$b/i };
# spent 4.79ms making 1 call to Safe::CORE:regcomp # spent 4.67ms making 1 call to utf8::SWASHNEW # spent 11µs making 1 call to Safe::CORE:pack # spent 4µs making 1 call to Safe::CORE:match # spent 2µs making 1 call to utf8::upgrade
71# now we can safely include utf8::SWASHNEW in $default_share defined below.
72
731400nsmy $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
77110µsmy $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])];
143
144
# spent 697µs (28+670) within Safe::new which was called: # once (28µs+670µs) by Data::DPath::Context::BEGIN@23 at line 27 of lib/Data/DPath/Context.pm
sub new {
14511µs my($class, $root, $mask) = @_;
1461700ns my $obj = {};
14713µs bless $obj, $class;
148
1491700ns if (defined($root)) {
150 croak "Can't use \"$root\" as root name"
151 if $root =~ /^main\b/ or $root !~ /^\w[:\w]*$/;
152 $obj->{Root} = $root;
153 $obj->{Erase} = 0;
154 }
155 else {
15613µs $obj->{Root} = "Safe::Root".$default_root++;
1571500ns $obj->{Erase} = 1;
158 }
159
160 # use permit/deny methods instead till interface issues resolved
161 # XXX perhaps new Safe 'Root', mask => $mask, foo => bar, ...;
1621200ns croak "Mask parameter to new no longer supported" if defined $mask;
16312µs115µs $obj->permit_only(':default');
# spent 15µs making 1 call to Safe::permit_only
164
165 # We must share $_ and @_ with the compartment or else ops such
166 # as split, length and so on won't default to $_ properly, nor
167 # will passing argument to subroutines work (via @_). In fact,
168 # for reasons I don't completely understand, we need to share
169 # the whole glob *_ rather than $_ and @_ separately, otherwise
170 # @_ in non default packages within the compartment don't work.
17113µs1649µs $obj->share_from('main', $default_share);
# spent 649µs making 1 call to Safe::share_from
172
173114µs16µs Opcode::_safe_pkg_prep($obj->{Root}) if($Opcode::VERSION > 1.04);
# spent 6µs making 1 call to Opcode::_safe_pkg_prep
174
17514µs return $obj;
176}
177
178sub DESTROY {
179 my $obj = shift;
180 $obj->erase('DESTROY') if $obj->{Erase};
181}
182
183sub erase {
184 my ($obj, $action) = @_;
185 my $pkg = $obj->root();
186 my ($stem, $leaf);
187
1882465µs248µs
# spent 30µs (13+18) within Safe::BEGIN@188 which was called: # once (13µs+18µs) by Data::DPath::Context::BEGIN@17 at line 188
no strict 'refs';
# spent 30µs making 1 call to Safe::BEGIN@188 # spent 18µs making 1 call to strict::unimport
189 $pkg = "main::$pkg\::"; # expand to full symbol table name
190 ($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
191
192 # The 'my $foo' is needed! Without it you get an
193 # 'Attempt to free unreferenced scalar' warning!
194 my $stem_symtab = *{$stem}{HASH};
195
196 #warn "erase($pkg) stem=$stem, leaf=$leaf";
197 #warn " stem_symtab hash ".scalar(%$stem_symtab)."\n";
198 # ", join(', ', %$stem_symtab),"\n";
199
200# delete $stem_symtab->{$leaf};
201
202 my $leaf_glob = $stem_symtab->{$leaf};
203 my $leaf_symtab = *{$leaf_glob}{HASH};
204# warn " leaf_symtab ", join(', ', %$leaf_symtab),"\n";
205 %$leaf_symtab = ();
206 #delete $leaf_symtab->{'__ANON__'};
207 #delete $leaf_symtab->{'foo'};
208 #delete $leaf_symtab->{'main::'};
209# my $foo = undef ${"$stem\::"}{"$leaf\::"};
210
211 if ($action and $action eq 'DESTROY') {
212 delete $stem_symtab->{$leaf};
213 } else {
214 $obj->share_from('main', $default_share);
215 }
216 1;
217}
218
219
220sub reinit {
221 my $obj= shift;
222 $obj->erase;
223 $obj->share_redo;
224}
225
226
# spent 4µs within Safe::root which was called 2 times, avg 2µs/call: # 2 times (4µs+0s) by Safe::share_from at line 280, avg 2µs/call
sub root {
2272400ns my $obj = shift;
2282700ns croak("Safe root method now read-only") if @_;
22927µs return $obj->{Root};
230}
231
232
233sub mask {
234 my $obj = shift;
235 return $obj->{Mask} unless @_;
236 $obj->deny_only(@_);
237}
238
239# v1 compatibility methods
240sub trap { shift->deny(@_) }
241sub untrap { shift->permit(@_) }
242
243sub deny {
244 my $obj = shift;
245 $obj->{Mask} |= opset(@_);
246}
247sub deny_only {
248 my $obj = shift;
249 $obj->{Mask} = opset(@_);
250}
251
252
# spent 11µs (8+2) within Safe::permit which was called: # once (8µs+2µs) by Data::DPath::Context::BEGIN@23 at line 28 of lib/Data/DPath/Context.pm
sub permit {
2531300ns my $obj = shift;
254 # XXX needs testing
255112µs22µs $obj->{Mask} &= invert_opset opset(@_);
# spent 1µs making 1 call to Opcode::opset # spent 1µs making 1 call to Opcode::invert_opset
256}
257
# spent 15µs (12+3) within Safe::permit_only which was called: # once (12µs+3µs) by Safe::new at line 163
sub permit_only {
2581400ns my $obj = shift;
259117µs23µs $obj->{Mask} = invert_opset opset(@_);
# spent 2µs making 1 call to Opcode::opset # spent 1µs making 1 call to Opcode::invert_opset
260}
261
262
263sub dump_mask {
264 my $obj = shift;
265 print opset_to_hex($obj->{Mask}),"\n";
266}
267
268
269
# spent 106µs (9+97) within Safe::share which was called: # once (9µs+97µs) by Data::DPath::Context::BEGIN@23 at line 30 of lib/Data/DPath/Context.pm
sub share {
27012µs my($obj, @vars) = @_;
27115µs197µs $obj->share_from(scalar(caller), \@vars);
# spent 97µs making 1 call to Safe::share_from
272}
273
274
275
# spent 746µs (648+97) within Safe::share_from which was called 2 times, avg 373µs/call: # once (565µs+84µs) by Safe::new at line 171 # once (83µs+14µs) by Safe::share at line 271
sub share_from {
2762500ns my $obj = shift;
2772700ns my $pkg = shift;
2782400ns my $vars = shift;
2792700ns my $no_record = shift || 0;
28023µs24µs my $root = $obj->root();
# spent 4µs making 2 calls to Safe::root, avg 2µs/call
28122µs croak("vars not an array ref") unless ref $vars eq 'ARRAY';
2822403µs237µs
# spent 24µs (10+13) within Safe::BEGIN@282 which was called: # once (10µs+13µs) by Data::DPath::Context::BEGIN@17 at line 282
no strict 'refs';
# spent 24µs making 1 call to Safe::BEGIN@282 # spent 13µs making 1 call to strict::unimport
283 # Check that 'from' package actually exists
284 croak("Package \"$pkg\" does not exist")
28524µs unless keys %{"$pkg\::"};
2862300ns my $arg;
28722µs foreach $arg (@$vars) {
288 # catch some $safe->share($var) errors:
2895911µs my ($var, $type);
29059206µs5954µs $type = $1 if ($var = $arg) =~ s/^(\W)//;
# spent 54µs making 59 calls to Safe::CORE:subst, avg 915ns/call
291 # warn "share_from $pkg $type $var";
2925958µs for (1..2) { # assign twice to avoid any 'used once' warnings
293 *{$root."::$var"} = (!$type) ? \&{$pkg."::$var"}
294 : ($type eq '&') ? \&{$pkg."::$var"}
295 : ($type eq '$') ? \${$pkg."::$var"}
296 : ($type eq '@') ? \@{$pkg."::$var"}
297 : ($type eq '%') ? \%{$pkg."::$var"}
298118400µs : ($type eq '*') ? *{$pkg."::$var"}
299 : croak(qq(Can't share "$type$var" of unknown type));
300 }
301 }
302213µs239µs $obj->share_record($pkg, $vars) unless $no_record or !$vars;
# spent 39µs making 2 calls to Safe::share_record, avg 20µs/call
303}
304
305
306
# spent 39µs within Safe::share_record which was called 2 times, avg 20µs/call: # 2 times (39µs+0s) by Safe::share_from at line 302, avg 20µs/call
sub share_record {
3072600ns my $obj = shift;
3082500ns my $pkg = shift;
3092300ns my $vars = shift;
31022µs my $shares = \%{$obj->{Shares} ||= {}};
311 # Record shares using keys of $obj->{Shares}. See reinit.
312239µs @{$shares}{@$vars} = ($pkg) x @$vars if @$vars;
313}
314
315
316sub share_redo {
317 my $obj = shift;
318 my $shares = \%{$obj->{Shares} ||= {}};
319 my($var, $pkg);
320 while(($var, $pkg) = each %$shares) {
321 # warn "share_redo $pkg\:: $var";
322 $obj->share_from($pkg, [ $var ], 1);
323 }
324}
325
326
327sub share_forget {
328 delete shift->{Shares};
329}
330
331
332sub varglob {
333 my ($obj, $var) = @_;
334274µs240µs
# spent 26µs (12+14) within Safe::BEGIN@334 which was called: # once (12µs+14µs) by Data::DPath::Context::BEGIN@17 at line 334
no strict 'refs';
# spent 26µs making 1 call to Safe::BEGIN@334 # spent 14µs making 1 call to strict::unimport
335 return *{$obj->root()."::$var"};
336}
337
338
# spent 938µs (876+61) within Safe::_clean_stash which was called 16 times, avg 59µs/call: # 14 times (618µs+-618µs) by Safe::_clean_stash at line 349, avg 0s/call # 2 times (258µs+679µs) by Safe::reval at line 363, avg 469µs/call
sub _clean_stash {
3391613µs my ($root, $saved_refs) = @_;
340165µs $saved_refs ||= [];
3412680µs232µs
# spent 20µs (9+11) within Safe::BEGIN@341 which was called: # once (9µs+11µs) by Data::DPath::Context::BEGIN@17 at line 341
no strict 'refs';
# spent 20µs making 1 call to Safe::BEGIN@341 # spent 11µs making 1 call to strict::unimport
34216310µs13229µs foreach my $hook (qw(DESTROY AUTOLOAD), grep /^\(/, keys %$root) {
# spent 29µs making 132 calls to Safe::CORE:match, avg 220ns/call
34339108µs push @$saved_refs, \*{$root.$hook};
3443963µs delete ${$root}{$hook};
345 }
346
34716343µs12432µs for (grep /::$/, keys %$root) {
# spent 32µs making 124 calls to Safe::CORE:match, avg 259ns/call
3481654µs next if \%{$root.$_} eq \%$root;
3491445µs140s _clean_stash($root.$_, $saved_refs);
# spent 764µs making 14 calls to Safe::_clean_stash, avg 55µs/call, recursion: max depth 2, sum of overlapping time 764µs
350 }
351}
352
353
# spent 1.44ms (93µs+1.35) within Safe::reval which was called 2 times, avg 720µs/call: # 2 times (93µs+1.35ms) by Data::DPath::Context::_filter_points_eval at line 191 of lib/Data/DPath/Context.pm, avg 720µs/call
sub reval {
35422µs my ($obj, $expr, $strict) = @_;
35522µs my $root = $obj->{Root};
356
35726µs2175µs my $evalsub = lexless_anon_sub($root, $strict, $expr);
# spent 175µs making 2 calls to Safe::lexless_anon_sub, avg 88µs/call
358 # propagate context
359225µs213µs my $sg = sub_generation();
# spent 13µs making 2 calls to B::sub_generation, avg 6µs/call
360260µs4298µs my @subret = (wantarray)
# spent 173µs making 2 calls to Opcode::_safe_call_sv, avg 87µs/call # spent 70µs making 1 call to main::__ANON__[(eval 67)[Safe.pm:23]:1] # spent 55µs making 1 call to main::__ANON__[(eval 55)[Safe.pm:23]:1]
361 ? Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub)
362 : scalar Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub);
363217µs4940µs _clean_stash($root.'::') if $sg != sub_generation();
# spent 938µs making 2 calls to Safe::_clean_stash, avg 469µs/call # spent 2µs making 2 calls to B::sub_generation, avg 1µs/call
36427µs245µs $obj->wrap_code_refs_within(@subret);
# spent 45µs making 2 calls to Safe::wrap_code_refs_within, avg 23µs/call
365226µs return (wantarray) ? @subret : $subret[0];
366}
367
3681200nsmy %OID;
369
370
# spent 45µs (21+24) within Safe::wrap_code_refs_within which was called 2 times, avg 23µs/call: # 2 times (21µs+24µs) by Safe::reval at line 364, avg 23µs/call
sub wrap_code_refs_within {
37122µs my $obj = shift;
372
37323µs %OID = ();
374211µs224µs $obj->_find_code_refs('wrap_code_ref', @_);
# spent 24µs making 2 calls to Safe::_find_code_refs, avg 12µs/call
375}
376
377
378
# spent 24µs (21+3) within Safe::_find_code_refs which was called 2 times, avg 12µs/call: # 2 times (21µs+3µs) by Safe::wrap_code_refs_within at line 374, avg 12µs/call
sub _find_code_refs {
37921µs my $obj = shift;
38021µs my $visitor = shift;
381
382216µs for my $item (@_) {
383214µs23µs my $reftype = $item && reftype $item
# spent 3µs making 2 calls to Scalar::Util::reftype, avg 1µs/call
384 or next;
385
386 # skip references already seen
387 next if ++$OID{refaddr $item} > 1;
388
389 if ($reftype eq 'ARRAY') {
390 $obj->_find_code_refs($visitor, @$item);
391 }
392 elsif ($reftype eq 'HASH') {
393 $obj->_find_code_refs($visitor, values %$item);
394 }
395 # XXX GLOBs?
396 elsif ($reftype eq 'CODE') {
397 $item = $obj->$visitor($item);
398 }
399 }
400}
401
402
403sub wrap_code_ref {
404 my ($obj, $sub) = @_;
405
406 # wrap code ref $sub with _safe_call_sv so that, when called, the
407 # execution will happen with the compartment fully 'in effect'.
408
409 croak "Not a CODE reference"
410 if reftype $sub ne 'CODE';
411
412 my $ret = sub {
413 my @args = @_; # lexical to close over
414 my $sub_with_args = sub { $sub->(@args) };
415
416 my @subret;
417 my $error;
418 do {
419 local $@; # needed due to perl_call_sv(sv, G_EVAL|G_KEEPERR)
420 my $sg = sub_generation();
421 @subret = (wantarray)
422 ? Opcode::_safe_call_sv($obj->{Root}, $obj->{Mask}, $sub_with_args)
423 : scalar Opcode::_safe_call_sv($obj->{Root}, $obj->{Mask}, $sub_with_args);
424 $error = $@;
425 _clean_stash($obj->{Root}.'::') if $sg != sub_generation();
426 };
427 if ($error) { # rethrow exception
428 $error =~ s/\t\(in cleanup\) //; # prefix added by G_KEEPERR
429 die $error;
430 }
431 return (wantarray) ? @subret : $subret[0];
432 };
433
434 return $ret;
435}
436
437
438sub rdo {
439 my ($obj, $file) = @_;
440 my $root = $obj->{Root};
441
442 my $sg = sub_generation();
443 my $evalsub = eval
444 sprintf('package %s; sub { @_ = (); do $file }', $root);
445 my @subret = (wantarray)
446 ? Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub)
447 : scalar Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub);
448 _clean_stash($root.'::') if $sg != sub_generation();
449 $obj->wrap_code_refs_within(@subret);
450 return (wantarray) ? @subret : $subret[0];
451}
452
453
454116µs1;
455
456__END__
 
# spent 66µs within Safe::CORE:match which was called 257 times, avg 255ns/call: # 132 times (29µs+0s) by Safe::_clean_stash at line 342, avg 220ns/call # 124 times (32µs+0s) by Safe::_clean_stash at line 347, avg 259ns/call # once (4µs+0s) by Data::DPath::Context::BEGIN@17 at line 70
sub Safe::CORE:match; # opcode
# spent 11µs within Safe::CORE:pack which was called: # once (11µs+0s) by Data::DPath::Context::BEGIN@17 at line 70
sub Safe::CORE:pack; # opcode
# spent 4.79ms (128µs+4.67) within Safe::CORE:regcomp which was called: # once (128µs+4.67ms) by Data::DPath::Context::BEGIN@17 at line 70
sub Safe::CORE:regcomp; # opcode
# spent 54µs within Safe::CORE:subst which was called 59 times, avg 915ns/call: # 59 times (54µs+0s) by Safe::share_from at line 290, avg 915ns/call
sub Safe::CORE:subst; # opcode