Filename | /Users/ap13/perl5/perlbrew/perls/perl-5.16.2/lib/5.16.2/Safe.pm |
Statements | Executed 36 statements in 3.49ms |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
1 | 1 | 1 | 1.13ms | 6.35ms | BEGIN@46 | Safe::
1 | 1 | 1 | 210µs | 5.23ms | CORE:regcomp (opcode) | Safe::
1 | 1 | 1 | 59µs | 82µs | BEGIN@30 | Safe::
1 | 1 | 1 | 32µs | 32µs | BEGIN@3 | Safe::
1 | 1 | 1 | 15µs | 40µs | BEGIN@28 | Safe::
1 | 1 | 1 | 15µs | 15µs | CORE:pack (opcode) | Safe::
1 | 1 | 1 | 14µs | 37µs | BEGIN@188 | Safe::
1 | 1 | 1 | 14µs | 64µs | BEGIN@29 | Safe::
1 | 1 | 1 | 14µs | 40µs | BEGIN@36 | Safe::
1 | 1 | 1 | 13µs | 56µs | BEGIN@4 | Safe::
1 | 1 | 1 | 12µs | 27µs | BEGIN@282 | Safe::
1 | 1 | 1 | 12µs | 27µs | BEGIN@334 | Safe::
1 | 1 | 1 | 9µs | 21µs | BEGIN@341 | Safe::
1 | 1 | 1 | 7µs | 7µs | BEGIN@35 | Safe::
1 | 1 | 1 | 6µs | 6µs | BEGIN@34 | Safe::
1 | 1 | 1 | 4µs | 4µs | CORE:match (opcode) | Safe::
0 | 0 | 0 | 0s | 0s | DESTROY | Safe::
0 | 0 | 0 | 0s | 0s | __ANON__[:414] | Safe::
0 | 0 | 0 | 0s | 0s | __ANON__[:42] | Safe::
0 | 0 | 0 | 0s | 0s | __ANON__[:432] | Safe::
0 | 0 | 0 | 0s | 0s | _clean_stash | Safe::
0 | 0 | 0 | 0s | 0s | _find_code_refs | Safe::
0 | 0 | 0 | 0s | 0s | deny | Safe::
0 | 0 | 0 | 0s | 0s | deny_only | Safe::
0 | 0 | 0 | 0s | 0s | dump_mask | Safe::
0 | 0 | 0 | 0s | 0s | erase | Safe::
0 | 0 | 0 | 0s | 0s | lexless_anon_sub | Safe::
0 | 0 | 0 | 0s | 0s | mask | Safe::
0 | 0 | 0 | 0s | 0s | new | Safe::
0 | 0 | 0 | 0s | 0s | permit | Safe::
0 | 0 | 0 | 0s | 0s | permit_only | Safe::
0 | 0 | 0 | 0s | 0s | rdo | Safe::
0 | 0 | 0 | 0s | 0s | reinit | Safe::
0 | 0 | 0 | 0s | 0s | reval | Safe::
0 | 0 | 0 | 0s | 0s | root | Safe::
0 | 0 | 0 | 0s | 0s | share | Safe::
0 | 0 | 0 | 0s | 0s | share_forget | Safe::
0 | 0 | 0 | 0s | 0s | share_from | Safe::
0 | 0 | 0 | 0s | 0s | share_record | Safe::
0 | 0 | 0 | 0s | 0s | share_redo | Safe::
0 | 0 | 0 | 0s | 0s | trap | Safe::
0 | 0 | 0 | 0s | 0s | untrap | Safe::
0 | 0 | 0 | 0s | 0s | varglob | Safe::
0 | 0 | 0 | 0s | 0s | wrap_code_ref | Safe::
0 | 0 | 0 | 0s | 0s | wrap_code_refs_within | Safe::
Line | State ments |
Time on line |
Calls | Time in subs |
Code |
---|---|---|---|---|---|
1 | package Safe; | ||||
2 | |||||
3 | 2 | 87µs | 1 | 32µs | # spent 32µs within Safe::BEGIN@3 which was called:
# once (32µs+0s) by Graph::BEGIN@42 at line 3 # spent 32µs making 1 call to Safe::BEGIN@3 |
4 | 2 | 123µs | 2 | 99µs | # spent 56µs (13+43) within Safe::BEGIN@4 which was called:
# once (13µs+43µs) by Graph::BEGIN@42 at line 4 # spent 56µs making 1 call to Safe::BEGIN@4
# spent 43µs making 1 call to Exporter::import |
5 | |||||
6 | 1 | 1µ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 | sub lexless_anon_sub { | ||||
14 | # $_[0] is package; | ||||
15 | # $_[1] is strict flag; | ||||
16 | 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) | ||||
23 | eval sprintf | ||||
24 | 'package %s; %s sub { @_=(); eval q[my $__ExPr__;] . $__ExPr__; }', | ||||
25 | $_[0], $_[1] ? 'use strict;' : ''; | ||||
26 | } | ||||
27 | |||||
28 | 2 | 39µs | 2 | 65µs | # spent 40µs (15+25) within Safe::BEGIN@28 which was called:
# once (15µs+25µs) by Graph::BEGIN@42 at line 28 # spent 40µs making 1 call to Safe::BEGIN@28
# spent 25µs making 1 call to strict::import |
29 | 2 | 42µs | 2 | 114µs | # spent 64µs (14+50) within Safe::BEGIN@29 which was called:
# once (14µs+50µs) by Graph::BEGIN@42 at line 29 # spent 64µs making 1 call to Safe::BEGIN@29
# spent 50µs making 1 call to Exporter::import |
30 | 1 | 49µs | # spent 82µs (59+23) within Safe::BEGIN@30 which was called:
# once (59µs+23µs) by Graph::BEGIN@42 at line 32 # spent 33µs executing statements in string eval # includes 23µs spent executing 1 call to 1 sub defined therein. | ||
31 | use Carp::Heavy; | ||||
32 | 1 | 27µs | 1 | 82µs | } } # spent 82µs making 1 call to Safe::BEGIN@30 |
33 | |||||
34 | 2 | 42µs | 1 | 6µs | # spent 6µs within Safe::BEGIN@34 which was called:
# once (6µs+0s) by Graph::BEGIN@42 at line 34 # spent 6µs making 1 call to Safe::BEGIN@34 |
35 | # spent 7µs within Safe::BEGIN@35 which was called:
# once (7µs+0s) by Graph::BEGIN@42 at line 44 | ||||
36 | 2 | 98µs | 2 | 66µs | # spent 40µs (14+26) within Safe::BEGIN@36 which was called:
# once (14µs+26µs) by Graph::BEGIN@42 at line 36 # spent 40µs making 1 call to Safe::BEGIN@36
# spent 26µs making 1 call to strict::unimport |
37 | 1 | 19µ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 | } | ||||
44 | 1 | 59µs | 1 | 7µs | } # spent 7µs making 1 call to Safe::BEGIN@35 |
45 | |||||
46 | 2 | 184µs | # spent 6.35ms (1.13+5.22) within Safe::BEGIN@46 which was called:
# once (1.13ms+5.22ms) by Graph::BEGIN@42 at line 50 | ||
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 | 1 | 555µs | 2 | 6.67ms | ); # spent 6.35ms making 1 call to Safe::BEGIN@46
# spent 316µs making 1 call to Exporter::import |
51 | |||||
52 | 1 | 2µ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. | ||||
62 | 1 | 900ns | require 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) | ||||
70 | 5 | 253µs | 5 | 10.3ms | do { my $a = pack('U',0x100); my $b = chr 0x101; utf8::upgrade $b; $a =~ /$b/i }; # spent 5.23ms making 1 call to Safe::CORE:regcomp
# spent 5.02ms making 1 call to utf8::SWASHNEW
# spent 15µ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 | |||||
73 | 1 | 500ns | my $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 | ||||
77 | 1 | 16µs | my $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 | sub new { | ||||
145 | my($class, $root, $mask) = @_; | ||||
146 | my $obj = {}; | ||||
147 | bless $obj, $class; | ||||
148 | |||||
149 | 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 { | ||||
156 | $obj->{Root} = "Safe::Root".$default_root++; | ||||
157 | $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, ...; | ||||
162 | croak "Mask parameter to new no longer supported" if defined $mask; | ||||
163 | $obj->permit_only(':default'); | ||||
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. | ||||
171 | $obj->share_from('main', $default_share); | ||||
172 | |||||
173 | Opcode::_safe_pkg_prep($obj->{Root}) if($Opcode::VERSION > 1.04); | ||||
174 | |||||
175 | return $obj; | ||||
176 | } | ||||
177 | |||||
178 | sub DESTROY { | ||||
179 | my $obj = shift; | ||||
180 | $obj->erase('DESTROY') if $obj->{Erase}; | ||||
181 | } | ||||
182 | |||||
183 | sub erase { | ||||
184 | my ($obj, $action) = @_; | ||||
185 | my $pkg = $obj->root(); | ||||
186 | my ($stem, $leaf); | ||||
187 | |||||
188 | 2 | 575µs | 2 | 61µs | # spent 37µs (14+23) within Safe::BEGIN@188 which was called:
# once (14µs+23µs) by Graph::BEGIN@42 at line 188 # spent 37µs making 1 call to Safe::BEGIN@188
# spent 23µ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 | |||||
220 | sub reinit { | ||||
221 | my $obj= shift; | ||||
222 | $obj->erase; | ||||
223 | $obj->share_redo; | ||||
224 | } | ||||
225 | |||||
226 | sub root { | ||||
227 | my $obj = shift; | ||||
228 | croak("Safe root method now read-only") if @_; | ||||
229 | return $obj->{Root}; | ||||
230 | } | ||||
231 | |||||
232 | |||||
233 | sub mask { | ||||
234 | my $obj = shift; | ||||
235 | return $obj->{Mask} unless @_; | ||||
236 | $obj->deny_only(@_); | ||||
237 | } | ||||
238 | |||||
239 | # v1 compatibility methods | ||||
240 | sub trap { shift->deny(@_) } | ||||
241 | sub untrap { shift->permit(@_) } | ||||
242 | |||||
243 | sub deny { | ||||
244 | my $obj = shift; | ||||
245 | $obj->{Mask} |= opset(@_); | ||||
246 | } | ||||
247 | sub deny_only { | ||||
248 | my $obj = shift; | ||||
249 | $obj->{Mask} = opset(@_); | ||||
250 | } | ||||
251 | |||||
252 | sub permit { | ||||
253 | my $obj = shift; | ||||
254 | # XXX needs testing | ||||
255 | $obj->{Mask} &= invert_opset opset(@_); | ||||
256 | } | ||||
257 | sub permit_only { | ||||
258 | my $obj = shift; | ||||
259 | $obj->{Mask} = invert_opset opset(@_); | ||||
260 | } | ||||
261 | |||||
262 | |||||
263 | sub dump_mask { | ||||
264 | my $obj = shift; | ||||
265 | print opset_to_hex($obj->{Mask}),"\n"; | ||||
266 | } | ||||
267 | |||||
268 | |||||
269 | sub share { | ||||
270 | my($obj, @vars) = @_; | ||||
271 | $obj->share_from(scalar(caller), \@vars); | ||||
272 | } | ||||
273 | |||||
274 | |||||
275 | sub share_from { | ||||
276 | my $obj = shift; | ||||
277 | my $pkg = shift; | ||||
278 | my $vars = shift; | ||||
279 | my $no_record = shift || 0; | ||||
280 | my $root = $obj->root(); | ||||
281 | croak("vars not an array ref") unless ref $vars eq 'ARRAY'; | ||||
282 | 2 | 449µs | 2 | 42µs | # spent 27µs (12+15) within Safe::BEGIN@282 which was called:
# once (12µs+15µs) by Graph::BEGIN@42 at line 282 # spent 27µs making 1 call to Safe::BEGIN@282
# spent 15µs making 1 call to strict::unimport |
283 | # Check that 'from' package actually exists | ||||
284 | croak("Package \"$pkg\" does not exist") | ||||
285 | unless keys %{"$pkg\::"}; | ||||
286 | my $arg; | ||||
287 | foreach $arg (@$vars) { | ||||
288 | # catch some $safe->share($var) errors: | ||||
289 | my ($var, $type); | ||||
290 | $type = $1 if ($var = $arg) =~ s/^(\W)//; | ||||
291 | # warn "share_from $pkg $type $var"; | ||||
292 | 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"} | ||||
298 | : ($type eq '*') ? *{$pkg."::$var"} | ||||
299 | : croak(qq(Can't share "$type$var" of unknown type)); | ||||
300 | } | ||||
301 | } | ||||
302 | $obj->share_record($pkg, $vars) unless $no_record or !$vars; | ||||
303 | } | ||||
304 | |||||
305 | |||||
306 | sub share_record { | ||||
307 | my $obj = shift; | ||||
308 | my $pkg = shift; | ||||
309 | my $vars = shift; | ||||
310 | my $shares = \%{$obj->{Shares} ||= {}}; | ||||
311 | # Record shares using keys of $obj->{Shares}. See reinit. | ||||
312 | @{$shares}{@$vars} = ($pkg) x @$vars if @$vars; | ||||
313 | } | ||||
314 | |||||
315 | |||||
316 | sub 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 | |||||
327 | sub share_forget { | ||||
328 | delete shift->{Shares}; | ||||
329 | } | ||||
330 | |||||
331 | |||||
332 | sub varglob { | ||||
333 | my ($obj, $var) = @_; | ||||
334 | 2 | 102µs | 2 | 42µs | # spent 27µs (12+15) within Safe::BEGIN@334 which was called:
# once (12µs+15µs) by Graph::BEGIN@42 at line 334 # spent 27µs making 1 call to Safe::BEGIN@334
# spent 15µs making 1 call to strict::unimport |
335 | return *{$obj->root()."::$var"}; | ||||
336 | } | ||||
337 | |||||
338 | sub _clean_stash { | ||||
339 | my ($root, $saved_refs) = @_; | ||||
340 | $saved_refs ||= []; | ||||
341 | 2 | 737µs | 2 | 33µs | # spent 21µs (9+12) within Safe::BEGIN@341 which was called:
# once (9µs+12µs) by Graph::BEGIN@42 at line 341 # spent 21µs making 1 call to Safe::BEGIN@341
# spent 12µs making 1 call to strict::unimport |
342 | foreach my $hook (qw(DESTROY AUTOLOAD), grep /^\(/, keys %$root) { | ||||
343 | push @$saved_refs, \*{$root.$hook}; | ||||
344 | delete ${$root}{$hook}; | ||||
345 | } | ||||
346 | |||||
347 | for (grep /::$/, keys %$root) { | ||||
348 | next if \%{$root.$_} eq \%$root; | ||||
349 | _clean_stash($root.$_, $saved_refs); | ||||
350 | } | ||||
351 | } | ||||
352 | |||||
353 | sub reval { | ||||
354 | my ($obj, $expr, $strict) = @_; | ||||
355 | my $root = $obj->{Root}; | ||||
356 | |||||
357 | my $evalsub = lexless_anon_sub($root, $strict, $expr); | ||||
358 | # propagate context | ||||
359 | my $sg = sub_generation(); | ||||
360 | my @subret = (wantarray) | ||||
361 | ? Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub) | ||||
362 | : scalar Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub); | ||||
363 | _clean_stash($root.'::') if $sg != sub_generation(); | ||||
364 | $obj->wrap_code_refs_within(@subret); | ||||
365 | return (wantarray) ? @subret : $subret[0]; | ||||
366 | } | ||||
367 | |||||
368 | 1 | 200ns | my %OID; | ||
369 | |||||
370 | sub wrap_code_refs_within { | ||||
371 | my $obj = shift; | ||||
372 | |||||
373 | %OID = (); | ||||
374 | $obj->_find_code_refs('wrap_code_ref', @_); | ||||
375 | } | ||||
376 | |||||
377 | |||||
378 | sub _find_code_refs { | ||||
379 | my $obj = shift; | ||||
380 | my $visitor = shift; | ||||
381 | |||||
382 | for my $item (@_) { | ||||
383 | my $reftype = $item && reftype $item | ||||
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 | |||||
403 | sub 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 | |||||
438 | sub 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 | |||||
454 | 1 | 35µs | 1; | ||
455 | |||||
456 | __END__ | ||||
# spent 4µs within Safe::CORE:match which was called:
# once (4µs+0s) by Graph::BEGIN@42 at line 70 | |||||
# spent 15µs within Safe::CORE:pack which was called:
# once (15µs+0s) by Graph::BEGIN@42 at line 70 | |||||
# spent 5.23ms (210µs+5.02) within Safe::CORE:regcomp which was called:
# once (210µs+5.02ms) by Graph::BEGIN@42 at line 70 |