← Index
NYTProf Performance Profile   « block view • line view • sub view »
For /usr/local/src/github.com/foswiki/core/bin/view
  Run on Sun Dec 4 17:17:59 2011
Reported on Sun Dec 4 17:26:34 2011

Filename/usr/share/perl/5.14/Safe.pm
StatementsExecuted 872 statements in 9.34ms
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
1113.46ms4.47msSafe::::BEGIN@34Safe::BEGIN@34
1112.29ms2.54msSafe::::share_fromSafe::share_from
11211.08ms1.27msSafe::::_clean_stashSafe::_clean_stash (recurses: max depth 3, inclusive time 1.39ms)
1111.06ms9.79msSafe::::BEGIN@46Safe::BEGIN@46
421230µs284µsSafe::::_find_code_refsSafe::_find_code_refs (recurses: max depth 2, inclusive time 338µs)
14241205µs205µsSafe::::CORE:matchSafe::CORE:match (opcode)
5911171µs171µsSafe::::CORE:substSafe::CORE:subst (opcode)
111146µs72.3msSafe::::CORE:regcompSafe::CORE:regcomp (opcode)
111122µs135µsSafe::::eraseSafe::erase
111122µs153µsSafe::::lexless_anon_subSafe::lexless_anon_sub
11171µs1.97msSafe::::revalSafe::reval
11171µs71µsSafe::::share_recordSafe::share_record
11169µs89µsSafe::::BEGIN@30Safe::BEGIN@30
11157µs2.64msSafe::::newSafe::new
11136µs36µsSafe::::BEGIN@3Safe::BEGIN@3
11124µs31µsSafe::::BEGIN@4Safe::BEGIN@4
11123µs61µsSafe::::BEGIN@186Safe::BEGIN@186
11120µs107µsSafe::::BEGIN@5Safe::BEGIN@5
11120µs28µsSafe::::permit_onlySafe::permit_only
11120µs20µsSafe::::CORE:packSafe::CORE:pack (opcode)
11119µs114µsSafe::::BEGIN@29Safe::BEGIN@29
11116µs47µsSafe::::BEGIN@280Safe::BEGIN@280
11116µs47µsSafe::::BEGIN@332Safe::BEGIN@332
11115µs45µsSafe::::BEGIN@36Safe::BEGIN@36
11115µs44µsSafe::::BEGIN@339Safe::BEGIN@339
11115µs150µsSafe::::DESTROYSafe::DESTROY
11115µs299µsSafe::::wrap_code_refs_withinSafe::wrap_code_refs_within
22115µs15µsSafe::::rootSafe::root
11114µs14µsSafe::::BEGIN@35Safe::BEGIN@35
11110µs10µsSafe::::BEGIN@69Safe::BEGIN@69
0000s0sSafe::::__ANON__[:412]Safe::__ANON__[:412]
0000s0sSafe::::__ANON__[:42]Safe::__ANON__[:42]
0000s0sSafe::::__ANON__[:430]Safe::__ANON__[:430]
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
0110µsProfile data that couldn't be associated with a specific line:
# spent 10µs making 1 call to Safe::BEGIN@69
1117µspackage Safe;
2
3277µs136µs
# spent 36µs within Safe::BEGIN@3 which was called: # once (36µs+0s) by CGI::Session::Serialize::default::BEGIN@6 at line 3
use 5.003_11;
# spent 36µs making 1 call to Safe::BEGIN@3
4247µs238µs
# spent 31µs (24+7) within Safe::BEGIN@4 which was called: # once (24µs+7µs) by CGI::Session::Serialize::default::BEGIN@6 at line 4
use strict;
# spent 31µs making 1 call to Safe::BEGIN@4 # spent 7µs making 1 call to strict::import
52142µs2194µs
# spent 107µs (20+87) within Safe::BEGIN@5 which was called: # once (20µs+87µs) by CGI::Session::Serialize::default::BEGIN@6 at line 5
use Scalar::Util qw(reftype refaddr);
# spent 107µs making 1 call to Safe::BEGIN@5 # spent 87µs making 1 call to Exporter::import
6
712µs$Safe::VERSION = "2.29";
8
9# *** Don't declare any lexicals above this point ***
10#
11# This function should return a closure which contains an eval that can't
12# see any lexicals in scope (apart from __ExPr__ which is unavoidable)
13
14
# spent 153µs (122+31) within Safe::lexless_anon_sub which was called: # once (122µs+31µs) by Safe::reval at line 355
sub lexless_anon_sub {
15 # $_[0] is package;
16 # $_[1] is strict flag;
17266µs my $__ExPr__ = $_[2]; # must be a lexical to create the closure that
18 # can be used to pass the value into the safe
19 # world
20
21 # Create anon sub ref in root of compartment.
22 # Uses a closure (on $__ExPr__) to pass in the code to be executed.
23 # (eval on one line to keep line numbers as expected by caller)
24 eval sprintf
# spent 220µs executing statements in string eval, 191µs here plus 28µs in 1 nested evals
# includes 161µs spent executing 2 calls to 2 subs defined therein.
25 'package %s; %s strict; sub { @_=(); eval q[my $__ExPr__;] . $__ExPr__; }',
26 $_[0], $_[1] ? 'use' : 'no';
27}
28
29248µs2209µs
# spent 114µs (19+95) within Safe::BEGIN@29 which was called: # once (19µs+95µs) by CGI::Session::Serialize::default::BEGIN@6 at line 29
use Carp;
# spent 114µs making 1 call to Safe::BEGIN@29 # spent 95µs making 1 call to Exporter::import
30160µs
# spent 89µs (69+20) within Safe::BEGIN@30 which was called: # once (69µs+20µs) by CGI::Session::Serialize::default::BEGIN@6 at line 32
BEGIN { eval q{
# spent 29µs executing statements in string eval
# includes 20µs spent executing 1 call to 1 sub defined therein.
31 use Carp::Heavy;
32128µs189µs} }
# spent 89µs making 1 call to Safe::BEGIN@30
33
342170µs14.47ms
# spent 4.47ms (3.46+1.01) within Safe::BEGIN@34 which was called: # once (3.46ms+1.01ms) by CGI::Session::Serialize::default::BEGIN@6 at line 34
use B ();
# spent 4.47ms making 1 call to Safe::BEGIN@34
35
# spent 14µs within Safe::BEGIN@35 which was called: # once (14µs+0s) by CGI::Session::Serialize::default::BEGIN@6 at line 44
BEGIN {
36296µs275µs
# spent 45µs (15+30) within Safe::BEGIN@36 which was called: # once (15µs+30µs) by CGI::Session::Serialize::default::BEGIN@6 at line 36
no strict 'refs';
# spent 45µs making 1 call to Safe::BEGIN@36 # spent 30µs making 1 call to strict::unimport
37214µ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 }
44152µs114µs}
# spent 14µs making 1 call to Safe::BEGIN@35
45
461674µs
# spent 9.79ms (1.06+8.73) within Safe::BEGIN@46 which was called: # once (1.06ms+8.73ms) by CGI::Session::Serialize::default::BEGIN@6 at line 50
use Opcode 1.01, qw(
# spent 674µ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
502987µs19.79ms);
# spent 9.79ms making 1 call to Safe::BEGIN@46
51
5213µ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.
621333µsrequire utf8;
63# we must ensure that utf8_heavy.pl, where SWASHNEW is defined, is loaded
64# but without depending on knowledge of that implementation detail.
65# This code (//i on a unicode string) ensures utf8 is fully loaded
66# and also loads the ToFold SWASH.
67# (Swashes are cached internally by perl in PL_utf8_* variables
68# independent of being inside/outside of Safe. So once loaded they can be)
697202µs576.9ms
# spent 10µs within Safe::BEGIN@69 which was called: # once (10µs+0s) by Safe::CORE:regcomp at line 0
do { my $a = pack('U',0xC4); my $b = chr 0xE4; utf8::upgrade $b; $a =~ /$b/i };
# spent 72.3ms making 1 call to Safe::CORE:regcomp # spent 4.63ms making 1 call to utf8::AUTOLOAD # spent 20µs making 1 call to Safe::CORE:pack # spent 9µs making 1 call to Safe::CORE:match # spent 4µs making 1 call to utf8::upgrade
70# now we can safely include utf8::SWASHNEW in $default_share defined below.
71
7212µsmy $default_root = 0;
73# share *_ and functions defined in universal.c
74# Don't share stuff like *UNIVERSAL:: otherwise code from the
75# compartment can 0wn functions in UNIVERSAL
76126µsmy $default_share = [qw[
77 *_
78 &PerlIO::get_layers
79 &UNIVERSAL::isa
80 &UNIVERSAL::can
81 &UNIVERSAL::VERSION
82 &utf8::is_utf8
83 &utf8::valid
84 &utf8::encode
85 &utf8::decode
86 &utf8::upgrade
87 &utf8::downgrade
88 &utf8::native_to_unicode
89 &utf8::unicode_to_native
90 &utf8::SWASHNEW
91 $version::VERSION
92 $version::CLASS
93 $version::STRICT
94 $version::LAX
95 @version::ISA
96], ($] < 5.010 && qw[
97 &utf8::SWASHGET
98]), ($] >= 5.008001 && qw[
99 &Regexp::DESTROY
100]), ($] >= 5.010 && qw[
101 &re::is_regexp
102 &re::regname
103 &re::regnames
104 &re::regnames_count
105 &Tie::Hash::NamedCapture::FETCH
106 &Tie::Hash::NamedCapture::STORE
107 &Tie::Hash::NamedCapture::DELETE
108 &Tie::Hash::NamedCapture::CLEAR
109 &Tie::Hash::NamedCapture::EXISTS
110 &Tie::Hash::NamedCapture::FIRSTKEY
111 &Tie::Hash::NamedCapture::NEXTKEY
112 &Tie::Hash::NamedCapture::SCALAR
113 &Tie::Hash::NamedCapture::flags
114 &UNIVERSAL::DOES
115 &version::()
116 &version::new
117 &version::(""
118 &version::stringify
119 &version::(0+
120 &version::numify
121 &version::normal
122 &version::(cmp
123 &version::(<=>
124 &version::vcmp
125 &version::(bool
126 &version::boolean
127 &version::(nomethod
128 &version::noop
129 &version::is_alpha
130 &version::qv
131 &version::vxs::declare
132 &version::vxs::qv
133 &version::vxs::_VERSION
134 &version::vxs::stringify
135 &version::vxs::new
136 &version::vxs::parse
137 &version::vxs::VCMP
138]), ($] >= 5.011 && qw[
139 &re::regexp_pattern
140])];
141
142
# spent 2.64ms (57µs+2.58) within Safe::new which was called: # once (57µs+2.58ms) by CGI::Session::Serialize::default::thaw at line 39 of /usr/local/src/github.com/foswiki/core/lib/CPAN/lib/CGI/Session/Serialize/default.pm
sub new {
1431164µs my($class, $root, $mask) = @_;
144 my $obj = {};
145 bless $obj, $class;
146
147 if (defined($root)) {
148 croak "Can't use \"$root\" as root name"
149 if $root =~ /^main\b/ or $root !~ /^\w[:\w]*$/;
150 $obj->{Root} = $root;
151 $obj->{Erase} = 0;
152 }
153 else {
154 $obj->{Root} = "Safe::Root".$default_root++;
155 $obj->{Erase} = 1;
156 }
157
158 # use permit/deny methods instead till interface issues resolved
159 # XXX perhaps new Safe 'Root', mask => $mask, foo => bar, ...;
160 croak "Mask parameter to new no longer supported" if defined $mask;
161128µs $obj->permit_only(':default');
# spent 28µs making 1 call to Safe::permit_only
162
163 # We must share $_ and @_ with the compartment or else ops such
164 # as split, length and so on won't default to $_ properly, nor
165 # will passing argument to subroutines work (via @_). In fact,
166 # for reasons I don't completely understand, we need to share
167 # the whole glob *_ rather than $_ and @_ separately, otherwise
168 # @_ in non default packages within the compartment don't work.
16912.54ms $obj->share_from('main', $default_share);
# spent 2.54ms making 1 call to Safe::share_from
170
17119µs Opcode::_safe_pkg_prep($obj->{Root}) if($Opcode::VERSION > 1.04);
# spent 9µs making 1 call to Opcode::_safe_pkg_prep
172
173 return $obj;
174}
175
176
# spent 150µs (15+135) within Safe::DESTROY which was called: # once (15µs+135µs) by CGI::Session::Serialize::default::thaw at line 40 of /usr/local/src/github.com/foswiki/core/lib/CPAN/lib/CGI/Session/Serialize/default.pm
sub DESTROY {
177213µs my $obj = shift;
1781135µs $obj->erase('DESTROY') if $obj->{Erase};
# spent 135µs making 1 call to Safe::erase
179}
180
181
# spent 135µs (122+13) within Safe::erase which was called: # once (122µs+13µs) by Safe::DESTROY at line 178
sub erase {
18214127µs my ($obj, $action) = @_;
18317µs my $pkg = $obj->root();
# spent 7µs making 1 call to Safe::root
184 my ($stem, $leaf);
185
1862730µs2100µs
# spent 61µs (23+39) within Safe::BEGIN@186 which was called: # once (23µs+39µs) by CGI::Session::Serialize::default::BEGIN@6 at line 186
no strict 'refs';
# spent 61µs making 1 call to Safe::BEGIN@186 # spent 39µs making 1 call to strict::unimport
187 $pkg = "main::$pkg\::"; # expand to full symbol table name
18816µs ($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
# spent 6µs making 1 call to Safe::CORE:match
189
190 # The 'my $foo' is needed! Without it you get an
191 # 'Attempt to free unreferenced scalar' warning!
192 my $stem_symtab = *{$stem}{HASH};
193
194 #warn "erase($pkg) stem=$stem, leaf=$leaf";
195 #warn " stem_symtab hash ".scalar(%$stem_symtab)."\n";
196 # ", join(', ', %$stem_symtab),"\n";
197
198# delete $stem_symtab->{$leaf};
199
200 my $leaf_glob = $stem_symtab->{$leaf};
201 my $leaf_symtab = *{$leaf_glob}{HASH};
202# warn " leaf_symtab ", join(', ', %$leaf_symtab),"\n";
203 %$leaf_symtab = ();
204 #delete $leaf_symtab->{'__ANON__'};
205 #delete $leaf_symtab->{'foo'};
206 #delete $leaf_symtab->{'main::'};
207# my $foo = undef ${"$stem\::"}{"$leaf\::"};
208
209 if ($action and $action eq 'DESTROY') {
210 delete $stem_symtab->{$leaf};
211 } else {
212 $obj->share_from('main', $default_share);
213 }
214 1;
215}
216
217
218sub reinit {
219 my $obj= shift;
220 $obj->erase;
221 $obj->share_redo;
222}
223
224
# spent 15µs within Safe::root which was called 2 times, avg 7µs/call: # once (8µs+0s) by Safe::share_from at line 278 # once (7µs+0s) by Safe::erase at line 183
sub root {
225621µs my $obj = shift;
226 croak("Safe root method now read-only") if @_;
227 return $obj->{Root};
228}
229
230
231sub mask {
232 my $obj = shift;
233 return $obj->{Mask} unless @_;
234 $obj->deny_only(@_);
235}
236
237# v1 compatibility methods
238sub trap { shift->deny(@_) }
239sub untrap { shift->permit(@_) }
240
241sub deny {
242 my $obj = shift;
243 $obj->{Mask} |= opset(@_);
244}
245sub deny_only {
246 my $obj = shift;
247 $obj->{Mask} = opset(@_);
248}
249
250sub permit {
251 my $obj = shift;
252 # XXX needs testing
253 $obj->{Mask} &= invert_opset opset(@_);
254}
255
# spent 28µs (20+8) within Safe::permit_only which was called: # once (20µs+8µs) by Safe::new at line 161
sub permit_only {
256229µs my $obj = shift;
25728µs $obj->{Mask} = invert_opset opset(@_);
# spent 5µs making 1 call to Opcode::opset # spent 3µs making 1 call to Opcode::invert_opset
258}
259
260
261sub dump_mask {
262 my $obj = shift;
263 print opset_to_hex($obj->{Mask}),"\n";
264}
265
266
267sub share {
268 my($obj, @vars) = @_;
269 $obj->share_from(scalar(caller), \@vars);
270}
271
272
273
# spent 2.54ms (2.29+250µs) within Safe::share_from which was called: # once (2.29ms+250µs) by Safe::new at line 169
sub share_from {
2745422.46ms my $obj = shift;
275 my $pkg = shift;
276 my $vars = shift;
277 my $no_record = shift || 0;
27818µs my $root = $obj->root();
# spent 8µs making 1 call to Safe::root
279 croak("vars not an array ref") unless ref $vars eq 'ARRAY';
2802590µs278µs
# spent 47µs (16+31) within Safe::BEGIN@280 which was called: # once (16µs+31µs) by CGI::Session::Serialize::default::BEGIN@6 at line 280
no strict 'refs';
# spent 47µs making 1 call to Safe::BEGIN@280 # spent 31µs making 1 call to strict::unimport
281 # Check that 'from' package actually exists
282 croak("Package \"$pkg\" does not exist")
283 unless keys %{"$pkg\::"};
284 my $arg;
285 foreach $arg (@$vars) {
286 # catch some $safe->share($var) errors:
287 my ($var, $type);
28859171µs $type = $1 if ($var = $arg) =~ s/^(\W)//;
# spent 171µs making 59 calls to Safe::CORE:subst, avg 3µs/call
289 # warn "share_from $pkg $type $var";
290 for (1..2) { # assign twice to avoid any 'used once' warnings
291 *{$root."::$var"} = (!$type) ? \&{$pkg."::$var"}
292 : ($type eq '&') ? \&{$pkg."::$var"}
293 : ($type eq '$') ? \${$pkg."::$var"}
294 : ($type eq '@') ? \@{$pkg."::$var"}
295 : ($type eq '%') ? \%{$pkg."::$var"}
296 : ($type eq '*') ? *{$pkg."::$var"}
297 : croak(qq(Can't share "$type$var" of unknown type));
298 }
299 }
300171µs $obj->share_record($pkg, $vars) unless $no_record or !$vars;
# spent 71µs making 1 call to Safe::share_record
301}
302
303
304
# spent 71µs within Safe::share_record which was called: # once (71µs+0s) by Safe::share_from at line 300
sub share_record {
305774µs my $obj = shift;
306 my $pkg = shift;
307 my $vars = shift;
308 my $shares = \%{$obj->{Shares} ||= {}};
309 # Record shares using keys of $obj->{Shares}. See reinit.
310 @{$shares}{@$vars} = ($pkg) x @$vars if @$vars;
311}
312
313
314sub share_redo {
315 my $obj = shift;
316 my $shares = \%{$obj->{Shares} ||= {}};
317 my($var, $pkg);
318 while(($var, $pkg) = each %$shares) {
319 # warn "share_redo $pkg\:: $var";
320 $obj->share_from($pkg, [ $var ], 1);
321 }
322}
323
324
325sub share_forget {
326 delete shift->{Shares};
327}
328
329
330sub varglob {
331 my ($obj, $var) = @_;
3322115µs277µs
# spent 47µs (16+30) within Safe::BEGIN@332 which was called: # once (16µs+30µs) by CGI::Session::Serialize::default::BEGIN@6 at line 332
no strict 'refs';
# spent 47µs making 1 call to Safe::BEGIN@332 # spent 30µs making 1 call to strict::unimport
333 return *{$obj->root()."::$var"};
334}
335
336
# spent 1.27ms (1.08+190µs) within Safe::_clean_stash which was called 11 times, avg 115µs/call: # 10 times (837µs+-837µs) by Safe::_clean_stash at line 347, avg 0s/call # once (238µs+1.03ms) by Safe::reval at line 361
sub _clean_stash {
3371921.27ms my ($root, $saved_refs) = @_;
338 $saved_refs ||= [];
33921.03ms273µs
# spent 44µs (15+29) within Safe::BEGIN@339 which was called: # once (15µs+29µs) by CGI::Session::Serialize::default::BEGIN@6 at line 339
no strict 'refs';
# spent 44µs making 1 call to Safe::BEGIN@339 # spent 29µs making 1 call to strict::unimport
3407499µs foreach my $hook (qw(DESTROY AUTOLOAD), grep /^\(/, keys %$root) {
# spent 99µs making 74 calls to Safe::CORE:match, avg 1µs/call
341 push @$saved_refs, \*{$root.$hook};
342 delete ${$root}{$hook};
343 }
344
3456691µs for (grep /::$/, keys %$root) {
# spent 91µs making 66 calls to Safe::CORE:match, avg 1µs/call
346 next if \%{$root.$_} eq \%$root;
347100s _clean_stash($root.$_, $saved_refs);
# spent 1.39ms making 10 calls to Safe::_clean_stash, avg 139µs/call, recursion: max depth 3, sum of overlapping time 1.39ms
348 }
349}
350
351
# spent 1.97ms (71µs+1.90) within Safe::reval which was called: # once (71µs+1.90ms) by CGI::Session::Serialize::default::thaw at line 39 of /usr/local/src/github.com/foswiki/core/lib/CPAN/lib/CGI/Session/Serialize/default.pm
sub reval {
352899µs my ($obj, $expr, $strict) = @_;
353 my $root = $obj->{Root};
354
3551153µs my $evalsub = lexless_anon_sub($root, $strict, $expr);
# spent 153µs making 1 call to Safe::lexless_anon_sub
356 # propagate context
357110µs my $sg = sub_generation();
# spent 10µs making 1 call to B::sub_generation
358113µs2312µs my @subret = (wantarray)
# spent 173µs making 1 call to Opcode::_safe_call_sv # spent 138µs making 1 call to main::__ANON__[(eval 53)[Safe.pm:24]:1]
359 ? Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub)
360 : scalar Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub);
36121.27ms _clean_stash($root.'::') if $sg != sub_generation();
# spent 1.27ms making 1 call to Safe::_clean_stash # spent 3µs making 1 call to B::sub_generation
3621299µs $obj->wrap_code_refs_within(@subret);
# spent 299µs making 1 call to Safe::wrap_code_refs_within
363 return (wantarray) ? @subret : $subret[0];
364}
365
36611µsmy %OID;
367
368
# spent 299µs (15+284) within Safe::wrap_code_refs_within which was called: # once (15µs+284µs) by Safe::reval at line 362
sub wrap_code_refs_within {
369316µs my $obj = shift;
370
371 %OID = ();
3721284µs $obj->_find_code_refs('wrap_code_ref', @_);
# spent 284µs making 1 call to Safe::_find_code_refs
373}
374
375
376
# spent 284µs (230+54) within Safe::_find_code_refs which was called 4 times, avg 71µs/call: # 3 times (187µs+-187µs) by Safe::_find_code_refs at line 391, avg 0s/call # once (43µs+241µs) by Safe::wrap_code_refs_within at line 372
sub _find_code_refs {
37744285µs my $obj = shift;
378 my $visitor = shift;
379
380 for my $item (@_) {
3812247µs my $reftype = $item && reftype $item
# spent 47µs making 22 calls to Scalar::Util::reftype, avg 2µs/call
382 or next;
383
384 # skip references already seen
38537µs next if ++$OID{refaddr $item} > 1;
# spent 7µs making 3 calls to Scalar::Util::refaddr, avg 2µs/call
386
387 if ($reftype eq 'ARRAY') {
388 $obj->_find_code_refs($visitor, @$item);
389 }
390 elsif ($reftype eq 'HASH') {
39130s $obj->_find_code_refs($visitor, values %$item);
# spent 338µs making 3 calls to Safe::_find_code_refs, avg 113µs/call, recursion: max depth 2, sum of overlapping time 338µs
392 }
393 # XXX GLOBs?
394 elsif ($reftype eq 'CODE') {
395 $item = $obj->$visitor($item);
396 }
397 }
398}
399
400
401sub wrap_code_ref {
402 my ($obj, $sub) = @_;
403
404 # wrap code ref $sub with _safe_call_sv so that, when called, the
405 # execution will happen with the compartment fully 'in effect'.
406
407 croak "Not a CODE reference"
408 if reftype $sub ne 'CODE';
409
410 my $ret = sub {
411 my @args = @_; # lexical to close over
412 my $sub_with_args = sub { $sub->(@args) };
413
414 my @subret;
415 my $error;
416 do {
417 local $@; # needed due to perl_call_sv(sv, G_EVAL|G_KEEPERR)
418 my $sg = sub_generation();
419 @subret = (wantarray)
420 ? Opcode::_safe_call_sv($obj->{Root}, $obj->{Mask}, $sub_with_args)
421 : scalar Opcode::_safe_call_sv($obj->{Root}, $obj->{Mask}, $sub_with_args);
422 $error = $@;
423 _clean_stash($obj->{Root}.'::') if $sg != sub_generation();
424 };
425 if ($error) { # rethrow exception
426 $error =~ s/\t\(in cleanup\) //; # prefix added by G_KEEPERR
427 die $error;
428 }
429 return (wantarray) ? @subret : $subret[0];
430 };
431
432 return $ret;
433}
434
435
436sub rdo {
437 my ($obj, $file) = @_;
438 my $root = $obj->{Root};
439
440 my $sg = sub_generation();
441 my $evalsub = eval
442 sprintf('package %s; sub { @_ = (); do $file }', $root);
443 my @subret = (wantarray)
444 ? Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub)
445 : scalar Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub);
446 _clean_stash($root.'::') if $sg != sub_generation();
447 $obj->wrap_code_refs_within(@subret);
448 return (wantarray) ? @subret : $subret[0];
449}
450
451
452134µs1;
453
454__END__
 
# spent 205µs within Safe::CORE:match which was called 142 times, avg 1µs/call: # 74 times (99µs+0s) by Safe::_clean_stash at line 340, avg 1µs/call # 66 times (91µs+0s) by Safe::_clean_stash at line 345, avg 1µs/call # once (9µs+0s) by CGI::Session::Serialize::default::BEGIN@6 at line 69 # once (6µs+0s) by Safe::erase at line 188
sub Safe::CORE:match; # opcode
# spent 20µs within Safe::CORE:pack which was called: # once (20µs+0s) by CGI::Session::Serialize::default::BEGIN@6 at line 69
sub Safe::CORE:pack; # opcode
# spent 72.3ms (146µs+72.1) within Safe::CORE:regcomp which was called: # once (146µs+72.1ms) by CGI::Session::Serialize::default::BEGIN@6 at line 69
sub Safe::CORE:regcomp; # opcode
# spent 171µs within Safe::CORE:subst which was called 59 times, avg 3µs/call: # 59 times (171µs+0s) by Safe::share_from at line 288, avg 3µs/call
sub Safe::CORE:subst; # opcode