Filename | /2home/ss5/perl5/perlbrew/perls/perl-5.12.3/lib/site_perl/5.12.3/Safe.pm |
Statements | Executed 48 statements in 2.21ms |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
1 | 1 | 1 | 614µs | 3.55ms | BEGIN@46 | Safe::
1 | 1 | 1 | 89µs | 27.6ms | CORE:match (opcode) | Safe::
1 | 1 | 1 | 56µs | 24.6ms | CORE:regcomp (opcode) | Safe::
1 | 1 | 1 | 37µs | 37µs | BEGIN@3 | Safe::
1 | 1 | 1 | 30µs | 46µs | BEGIN@191 | Safe::
1 | 1 | 1 | 29µs | 40µs | BEGIN@30 | Safe::
1 | 1 | 1 | 10µs | 36µs | BEGIN@4 | Safe::
1 | 1 | 1 | 9µs | 13µs | BEGIN@28 | Safe::
1 | 1 | 1 | 8µs | 39µs | BEGIN@29 | Safe::
1 | 1 | 1 | 6µs | 14µs | BEGIN@285 | Safe::
1 | 1 | 1 | 6µs | 13µs | BEGIN@344 | Safe::
1 | 1 | 1 | 6µs | 14µs | BEGIN@337 | Safe::
1 | 1 | 1 | 6µs | 20µs | BEGIN@36 | Safe::
1 | 1 | 1 | 5µs | 5µs | BEGIN@35 | Safe::
1 | 1 | 1 | 4µs | 4µs | CORE:pack (opcode) | Safe::
1 | 1 | 1 | 4µs | 4µs | BEGIN@34 | Safe::
0 | 0 | 0 | 0s | 0s | DESTROY | Safe::
0 | 0 | 0 | 0s | 0s | __ANON__[:417] | Safe::
0 | 0 | 0 | 0s | 0s | __ANON__[:42] | Safe::
0 | 0 | 0 | 0s | 0s | __ANON__[:435] | 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 | 3 | 49µs | 1 | 37µs | # spent 37µs within Safe::BEGIN@3 which was called:
# once (37µs+0s) by Tapper::Schema::TestrunDB::Result::TestrunScheduling::BEGIN@12 at line 3 # spent 37µs making 1 call to Safe::BEGIN@3 |
4 | 3 | 69µs | 2 | 63µs | # spent 36µs (10+27) within Safe::BEGIN@4 which was called:
# once (10µs+27µs) by Tapper::Schema::TestrunDB::Result::TestrunScheduling::BEGIN@12 at line 4 # spent 36µs making 1 call to Safe::BEGIN@4
# spent 27µs making 1 call to Exporter::import |
5 | |||||
6 | 1 | 700ns | $Safe::VERSION = "2.33"; | ||
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 | 3 | 18µs | 2 | 18µs | # spent 13µs (9+5) within Safe::BEGIN@28 which was called:
# once (9µs+5µs) by Tapper::Schema::TestrunDB::Result::TestrunScheduling::BEGIN@12 at line 28 # spent 13µs making 1 call to Safe::BEGIN@28
# spent 5µs making 1 call to strict::import |
29 | 3 | 24µs | 2 | 70µs | # spent 39µs (8+31) within Safe::BEGIN@29 which was called:
# once (8µs+31µs) by Tapper::Schema::TestrunDB::Result::TestrunScheduling::BEGIN@12 at line 29 # spent 39µs making 1 call to Safe::BEGIN@29
# spent 31µs making 1 call to Exporter::import |
30 | 1 | 25µs | # spent 40µs (29+11) within Safe::BEGIN@30 which was called:
# once (29µs+11µs) by Tapper::Schema::TestrunDB::Result::TestrunScheduling::BEGIN@12 at line 32 # spent 16µs executing statements in string eval # includes 11µs spent executing 1 call to 1 sub defined therein. | ||
31 | use Carp::Heavy; | ||||
32 | 1 | 12µs | 1 | 40µs | } } # spent 40µs making 1 call to Safe::BEGIN@30 |
33 | |||||
34 | 3 | 19µs | 1 | 4µs | # spent 4µs within Safe::BEGIN@34 which was called:
# once (4µs+0s) by Tapper::Schema::TestrunDB::Result::TestrunScheduling::BEGIN@12 at line 34 # spent 4µs making 1 call to Safe::BEGIN@34 |
35 | # spent 5µs within Safe::BEGIN@35 which was called:
# once (5µs+0s) by Tapper::Schema::TestrunDB::Result::TestrunScheduling::BEGIN@12 at line 44 | ||||
36 | 3 | 53µs | 2 | 33µs | # spent 20µs (6+14) within Safe::BEGIN@36 which was called:
# once (6µs+14µs) by Tapper::Schema::TestrunDB::Result::TestrunScheduling::BEGIN@12 at line 36 # spent 20µs making 1 call to Safe::BEGIN@36
# spent 14µs making 1 call to strict::unimport |
37 | 1 | 6µ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 | 25µs | 1 | 5µs | } # spent 5µs making 1 call to Safe::BEGIN@35 |
45 | |||||
46 | 1 | 14µs | 1 | 235µs | # spent 3.55ms (614µs+2.94) within Safe::BEGIN@46 which was called:
# once (614µs+2.94ms) by Tapper::Schema::TestrunDB::Result::TestrunScheduling::BEGIN@12 at line 50 # spent 235µ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 | ||||
50 | 2 | 451µs | 1 | 3.55ms | ); # spent 3.55ms making 1 call to Safe::BEGIN@46 |
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 | 700ns | 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 | 173µs | 7 | 104ms | do { my $a = pack('U',0x100); my $b = chr 0x101; utf8::upgrade $b; $a =~ /$b/i }; # spent 52.1ms making 3 calls to utf8::SWASHNEW, avg 17.4ms/call
# spent 27.6ms making 1 call to Safe::CORE:match
# spent 24.6ms making 1 call to Safe::CORE:regcomp
# spent 4µs making 1 call to Safe::CORE:pack
# 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 | 700ns | 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 | 20µ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 | 1 | 400ns | if (defined $Devel::Cover::VERSION) { | ||
144 | push @$default_share, '&Devel::Cover::use_file'; | ||||
145 | } | ||||
146 | |||||
147 | sub new { | ||||
148 | my($class, $root, $mask) = @_; | ||||
149 | my $obj = {}; | ||||
150 | bless $obj, $class; | ||||
151 | |||||
152 | 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 { | ||||
159 | $obj->{Root} = "Safe::Root".$default_root++; | ||||
160 | $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, ...; | ||||
165 | croak "Mask parameter to new no longer supported" if defined $mask; | ||||
166 | $obj->permit_only(':default'); | ||||
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. | ||||
174 | $obj->share_from('main', $default_share); | ||||
175 | |||||
176 | Opcode::_safe_pkg_prep($obj->{Root}) if($Opcode::VERSION > 1.04); | ||||
177 | |||||
178 | return $obj; | ||||
179 | } | ||||
180 | |||||
181 | sub DESTROY { | ||||
182 | my $obj = shift; | ||||
183 | $obj->erase('DESTROY') if $obj->{Erase}; | ||||
184 | } | ||||
185 | |||||
186 | sub erase { | ||||
187 | my ($obj, $action) = @_; | ||||
188 | my $pkg = $obj->root(); | ||||
189 | my ($stem, $leaf); | ||||
190 | |||||
191 | 3 | 374µs | 2 | 62µs | # spent 46µs (30+16) within Safe::BEGIN@191 which was called:
# once (30µs+16µs) by Tapper::Schema::TestrunDB::Result::TestrunScheduling::BEGIN@12 at line 191 # spent 46µs making 1 call to Safe::BEGIN@191
# spent 16µs making 1 call to strict::unimport |
192 | $pkg = "main::$pkg\::"; # expand to full symbol table name | ||||
193 | ($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/; | ||||
194 | |||||
195 | # The 'my $foo' is needed! Without it you get an | ||||
196 | # 'Attempt to free unreferenced scalar' warning! | ||||
197 | 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 | |||||
205 | my $leaf_glob = $stem_symtab->{$leaf}; | ||||
206 | my $leaf_symtab = *{$leaf_glob}{HASH}; | ||||
207 | # warn " leaf_symtab ", join(', ', %$leaf_symtab),"\n"; | ||||
208 | %$leaf_symtab = (); | ||||
209 | #delete $leaf_symtab->{'__ANON__'}; | ||||
210 | #delete $leaf_symtab->{'foo'}; | ||||
211 | #delete $leaf_symtab->{'main::'}; | ||||
212 | # my $foo = undef ${"$stem\::"}{"$leaf\::"}; | ||||
213 | |||||
214 | if ($action and $action eq 'DESTROY') { | ||||
215 | delete $stem_symtab->{$leaf}; | ||||
216 | } else { | ||||
217 | $obj->share_from('main', $default_share); | ||||
218 | } | ||||
219 | 1; | ||||
220 | } | ||||
221 | |||||
222 | |||||
223 | sub reinit { | ||||
224 | my $obj= shift; | ||||
225 | $obj->erase; | ||||
226 | $obj->share_redo; | ||||
227 | } | ||||
228 | |||||
229 | sub root { | ||||
230 | my $obj = shift; | ||||
231 | croak("Safe root method now read-only") if @_; | ||||
232 | return $obj->{Root}; | ||||
233 | } | ||||
234 | |||||
235 | |||||
236 | sub mask { | ||||
237 | my $obj = shift; | ||||
238 | return $obj->{Mask} unless @_; | ||||
239 | $obj->deny_only(@_); | ||||
240 | } | ||||
241 | |||||
242 | # v1 compatibility methods | ||||
243 | sub trap { shift->deny(@_) } | ||||
244 | sub untrap { shift->permit(@_) } | ||||
245 | |||||
246 | sub deny { | ||||
247 | my $obj = shift; | ||||
248 | $obj->{Mask} |= opset(@_); | ||||
249 | } | ||||
250 | sub deny_only { | ||||
251 | my $obj = shift; | ||||
252 | $obj->{Mask} = opset(@_); | ||||
253 | } | ||||
254 | |||||
255 | sub permit { | ||||
256 | my $obj = shift; | ||||
257 | # XXX needs testing | ||||
258 | $obj->{Mask} &= invert_opset opset(@_); | ||||
259 | } | ||||
260 | sub permit_only { | ||||
261 | my $obj = shift; | ||||
262 | $obj->{Mask} = invert_opset opset(@_); | ||||
263 | } | ||||
264 | |||||
265 | |||||
266 | sub dump_mask { | ||||
267 | my $obj = shift; | ||||
268 | print opset_to_hex($obj->{Mask}),"\n"; | ||||
269 | } | ||||
270 | |||||
271 | |||||
272 | sub share { | ||||
273 | my($obj, @vars) = @_; | ||||
274 | $obj->share_from(scalar(caller), \@vars); | ||||
275 | } | ||||
276 | |||||
277 | |||||
278 | sub share_from { | ||||
279 | my $obj = shift; | ||||
280 | my $pkg = shift; | ||||
281 | my $vars = shift; | ||||
282 | my $no_record = shift || 0; | ||||
283 | my $root = $obj->root(); | ||||
284 | croak("vars not an array ref") unless ref $vars eq 'ARRAY'; | ||||
285 | 3 | 286µs | 2 | 22µs | # spent 14µs (6+8) within Safe::BEGIN@285 which was called:
# once (6µs+8µs) by Tapper::Schema::TestrunDB::Result::TestrunScheduling::BEGIN@12 at line 285 # spent 14µs making 1 call to Safe::BEGIN@285
# spent 8µs making 1 call to strict::unimport |
286 | # Check that 'from' package actually exists | ||||
287 | croak("Package \"$pkg\" does not exist") | ||||
288 | unless keys %{"$pkg\::"}; | ||||
289 | my $arg; | ||||
290 | foreach $arg (@$vars) { | ||||
291 | # catch some $safe->share($var) errors: | ||||
292 | my ($var, $type); | ||||
293 | $type = $1 if ($var = $arg) =~ s/^(\W)//; | ||||
294 | # warn "share_from $pkg $type $var"; | ||||
295 | 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"} | ||||
301 | : ($type eq '*') ? *{$pkg."::$var"} | ||||
302 | : croak(qq(Can't share "$type$var" of unknown type)); | ||||
303 | } | ||||
304 | } | ||||
305 | $obj->share_record($pkg, $vars) unless $no_record or !$vars; | ||||
306 | } | ||||
307 | |||||
308 | |||||
309 | sub share_record { | ||||
310 | my $obj = shift; | ||||
311 | my $pkg = shift; | ||||
312 | my $vars = shift; | ||||
313 | my $shares = \%{$obj->{Shares} ||= {}}; | ||||
314 | # Record shares using keys of $obj->{Shares}. See reinit. | ||||
315 | @{$shares}{@$vars} = ($pkg) x @$vars if @$vars; | ||||
316 | } | ||||
317 | |||||
318 | |||||
319 | sub 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 | |||||
330 | sub share_forget { | ||||
331 | delete shift->{Shares}; | ||||
332 | } | ||||
333 | |||||
334 | |||||
335 | sub varglob { | ||||
336 | my ($obj, $var) = @_; | ||||
337 | 3 | 47µs | 2 | 22µs | # spent 14µs (6+8) within Safe::BEGIN@337 which was called:
# once (6µs+8µs) by Tapper::Schema::TestrunDB::Result::TestrunScheduling::BEGIN@12 at line 337 # spent 14µs making 1 call to Safe::BEGIN@337
# spent 8µs making 1 call to strict::unimport |
338 | return *{$obj->root()."::$var"}; | ||||
339 | } | ||||
340 | |||||
341 | sub _clean_stash { | ||||
342 | my ($root, $saved_refs) = @_; | ||||
343 | $saved_refs ||= []; | ||||
344 | 3 | 516µs | 2 | 20µs | # spent 13µs (6+7) within Safe::BEGIN@344 which was called:
# once (6µs+7µs) by Tapper::Schema::TestrunDB::Result::TestrunScheduling::BEGIN@12 at line 344 # spent 13µs making 1 call to Safe::BEGIN@344
# spent 7µs making 1 call to strict::unimport |
345 | foreach my $hook (qw(DESTROY AUTOLOAD), grep /^\(/, keys %$root) { | ||||
346 | push @$saved_refs, \*{$root.$hook}; | ||||
347 | delete ${$root}{$hook}; | ||||
348 | } | ||||
349 | |||||
350 | for (grep /::$/, keys %$root) { | ||||
351 | next if \%{$root.$_} eq \%$root; | ||||
352 | _clean_stash($root.$_, $saved_refs); | ||||
353 | } | ||||
354 | } | ||||
355 | |||||
356 | sub reval { | ||||
357 | my ($obj, $expr, $strict) = @_; | ||||
358 | my $root = $obj->{Root}; | ||||
359 | |||||
360 | my $evalsub = lexless_anon_sub($root, $strict, $expr); | ||||
361 | # propagate context | ||||
362 | my $sg = sub_generation(); | ||||
363 | my @subret = (wantarray) | ||||
364 | ? Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub) | ||||
365 | : scalar Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub); | ||||
366 | _clean_stash($root.'::') if $sg != sub_generation(); | ||||
367 | $obj->wrap_code_refs_within(@subret); | ||||
368 | return (wantarray) ? @subret : $subret[0]; | ||||
369 | } | ||||
370 | |||||
371 | 1 | 200ns | my %OID; | ||
372 | |||||
373 | sub wrap_code_refs_within { | ||||
374 | my $obj = shift; | ||||
375 | |||||
376 | %OID = (); | ||||
377 | $obj->_find_code_refs('wrap_code_ref', @_); | ||||
378 | } | ||||
379 | |||||
380 | |||||
381 | sub _find_code_refs { | ||||
382 | my $obj = shift; | ||||
383 | my $visitor = shift; | ||||
384 | |||||
385 | for my $item (@_) { | ||||
386 | my $reftype = $item && reftype $item | ||||
387 | or next; | ||||
388 | |||||
389 | # skip references already seen | ||||
390 | next if ++$OID{refaddr $item} > 1; | ||||
391 | |||||
392 | if ($reftype eq 'ARRAY') { | ||||
393 | $obj->_find_code_refs($visitor, @$item); | ||||
394 | } | ||||
395 | elsif ($reftype eq 'HASH') { | ||||
396 | $obj->_find_code_refs($visitor, values %$item); | ||||
397 | } | ||||
398 | # XXX GLOBs? | ||||
399 | elsif ($reftype eq 'CODE') { | ||||
400 | $item = $obj->$visitor($item); | ||||
401 | } | ||||
402 | } | ||||
403 | } | ||||
404 | |||||
405 | |||||
406 | sub wrap_code_ref { | ||||
407 | my ($obj, $sub) = @_; | ||||
408 | |||||
409 | # wrap code ref $sub with _safe_call_sv so that, when called, the | ||||
410 | # execution will happen with the compartment fully 'in effect'. | ||||
411 | |||||
412 | croak "Not a CODE reference" | ||||
413 | if reftype $sub ne 'CODE'; | ||||
414 | |||||
415 | my $ret = sub { | ||||
416 | my @args = @_; # lexical to close over | ||||
417 | my $sub_with_args = sub { $sub->(@args) }; | ||||
418 | |||||
419 | my @subret; | ||||
420 | my $error; | ||||
421 | do { | ||||
422 | local $@; # needed due to perl_call_sv(sv, G_EVAL|G_KEEPERR) | ||||
423 | my $sg = sub_generation(); | ||||
424 | @subret = (wantarray) | ||||
425 | ? Opcode::_safe_call_sv($obj->{Root}, $obj->{Mask}, $sub_with_args) | ||||
426 | : scalar Opcode::_safe_call_sv($obj->{Root}, $obj->{Mask}, $sub_with_args); | ||||
427 | $error = $@; | ||||
428 | _clean_stash($obj->{Root}.'::') if $sg != sub_generation(); | ||||
429 | }; | ||||
430 | if ($error) { # rethrow exception | ||||
431 | $error =~ s/\t\(in cleanup\) //; # prefix added by G_KEEPERR | ||||
432 | die $error; | ||||
433 | } | ||||
434 | return (wantarray) ? @subret : $subret[0]; | ||||
435 | }; | ||||
436 | |||||
437 | return $ret; | ||||
438 | } | ||||
439 | |||||
440 | |||||
441 | sub rdo { | ||||
442 | my ($obj, $file) = @_; | ||||
443 | my $root = $obj->{Root}; | ||||
444 | |||||
445 | my $sg = sub_generation(); | ||||
446 | my $evalsub = eval | ||||
447 | sprintf('package %s; sub { @_ = (); do $file }', $root); | ||||
448 | my @subret = (wantarray) | ||||
449 | ? Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub) | ||||
450 | : scalar Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub); | ||||
451 | _clean_stash($root.'::') if $sg != sub_generation(); | ||||
452 | $obj->wrap_code_refs_within(@subret); | ||||
453 | return (wantarray) ? @subret : $subret[0]; | ||||
454 | } | ||||
455 | |||||
456 | |||||
457 | 1 | 24µs | 1; | ||
458 | |||||
459 | __END__ | ||||
# spent 27.6ms (89µs+27.5) within Safe::CORE:match which was called:
# once (89µs+27.5ms) by Tapper::Schema::TestrunDB::Result::TestrunScheduling::BEGIN@12 at line 70 | |||||
# spent 4µs within Safe::CORE:pack which was called:
# once (4µs+0s) by Tapper::Schema::TestrunDB::Result::TestrunScheduling::BEGIN@12 at line 70 | |||||
# spent 24.6ms (56µs+24.6) within Safe::CORE:regcomp which was called:
# once (56µs+24.6ms) by Tapper::Schema::TestrunDB::Result::TestrunScheduling::BEGIN@12 at line 70 |