Filename | /home/ss5/perl5/perlbrew/perls/perl-5.14.1/lib/site_perl/5.14.1/Safe.pm |
Statements | Executed 387 statements in 15.4ms |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
1 | 1 | 1 | 9.51ms | 12.4ms | BEGIN@34 | Safe::
1 | 1 | 1 | 3.21ms | 19.7ms | BEGIN@46 | Safe::
2 | 2 | 1 | 2.61ms | 3.06ms | share_from | Safe::
1 | 1 | 1 | 362µs | 136ms | CORE:regcomp (opcode) | Safe::
59 | 1 | 1 | 269µs | 269µs | CORE:subst (opcode) | Safe::
2 | 1 | 1 | 156µs | 156µs | share_record | Safe::
1 | 1 | 1 | 153µs | 630µs | BEGIN@30 | Safe::
1 | 1 | 1 | 112µs | 2.87ms | new | Safe::
1 | 1 | 1 | 93µs | 93µs | BEGIN@3 | Safe::
1 | 1 | 1 | 50µs | 119µs | BEGIN@191 | Safe::
1 | 1 | 1 | 41µs | 57µs | permit_only | Safe::
1 | 1 | 1 | 39µs | 93µs | BEGIN@36 | Safe::
1 | 1 | 1 | 35µs | 51µs | BEGIN@28 | Safe::
1 | 1 | 1 | 34µs | 85µs | BEGIN@337 | Safe::
1 | 1 | 1 | 32µs | 204µs | BEGIN@4 | Safe::
1 | 1 | 1 | 32µs | 81µs | BEGIN@285 | Safe::
1 | 1 | 1 | 32µs | 32µs | CORE:pack (opcode) | Safe::
1 | 1 | 1 | 31µs | 44µs | permit | Safe::
1 | 1 | 1 | 31µs | 418µs | share | Safe::
1 | 1 | 1 | 29µs | 178µs | BEGIN@29 | Safe::
1 | 1 | 1 | 26µs | 26µs | CORE:match (opcode) | Safe::
1 | 1 | 1 | 25µs | 60µs | BEGIN@344 | Safe::
1 | 1 | 1 | 24µs | 24µs | BEGIN@35 | Safe::
2 | 1 | 1 | 23µs | 23µs | root | Safe::
1 | 1 | 1 | 22µs | 22µs | BEGIN@70 | 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 | rdo | Safe::
0 | 0 | 0 | 0s | 0s | reinit | Safe::
0 | 0 | 0 | 0s | 0s | reval | Safe::
0 | 0 | 0 | 0s | 0s | share_forget | 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 |
---|---|---|---|---|---|
0 | 1 | 22µs | Profile data that couldn't be associated with a specific line: # spent 22µs making 1 call to Safe::BEGIN@70 | ||
1 | 1 | 45µs | package Safe; | ||
2 | |||||
3 | 2 | 206µs | 1 | 93µs | # spent 93µs within Safe::BEGIN@3 which was called:
# once (93µs+0s) by Data::DPath::Context::BEGIN@23 at line 3 # spent 93µs making 1 call to Safe::BEGIN@3 |
4 | 2 | 416µs | 2 | 376µs | # spent 204µs (32+172) within Safe::BEGIN@4 which was called:
# once (32µs+172µs) by Data::DPath::Context::BEGIN@23 at line 4 # spent 204µs making 1 call to Safe::BEGIN@4
# spent 172µs making 1 call to Exporter::import |
5 | |||||
6 | 1 | 3µs | $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 | 2 | 92µs | 2 | 66µs | # spent 51µs (35+16) within Safe::BEGIN@28 which was called:
# once (35µs+16µs) by Data::DPath::Context::BEGIN@23 at line 28 # spent 51µs making 1 call to Safe::BEGIN@28
# spent 16µs making 1 call to strict::import |
29 | 2 | 100µs | 2 | 326µs | # spent 178µs (29+148) within Safe::BEGIN@29 which was called:
# once (29µs+148µs) by Data::DPath::Context::BEGIN@23 at line 29 # spent 178µs making 1 call to Safe::BEGIN@29
# spent 148µs making 1 call to Exporter::import |
30 | 1 | 146µs | # spent 630µs (153+476) within Safe::BEGIN@30 which was called:
# once (153µs+476µs) by Data::DPath::Context::BEGIN@23 at line 32 # spent 341µs executing statements in string eval # includes 445µs spent executing 1 call to 1 sub defined therein. | ||
31 | use Carp::Heavy; | ||||
32 | 1 | 71µs | 1 | 630µs | } } # spent 630µs making 1 call to Safe::BEGIN@30 |
33 | |||||
34 | 2 | 434µs | 1 | 12.4ms | # spent 12.4ms (9.51+2.88) within Safe::BEGIN@34 which was called:
# once (9.51ms+2.88ms) by Data::DPath::Context::BEGIN@23 at line 34 # spent 12.4ms making 1 call to Safe::BEGIN@34 |
35 | # spent 24µs within Safe::BEGIN@35 which was called:
# once (24µs+0s) by Data::DPath::Context::BEGIN@23 at line 44 | ||||
36 | 2 | 275µs | 2 | 147µs | # spent 93µs (39+54) within Safe::BEGIN@36 which was called:
# once (39µs+54µs) by Data::DPath::Context::BEGIN@23 at line 36 # spent 93µs making 1 call to Safe::BEGIN@36
# spent 54µs making 1 call to strict::unimport |
37 | 1 | 24µ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 | 128µs | 1 | 24µs | } # spent 24µs making 1 call to Safe::BEGIN@35 |
45 | |||||
46 | 1 | 54µs | 1 | 1.06ms | # spent 19.7ms (3.21+16.4) within Safe::BEGIN@46 which was called:
# once (3.21ms+16.4ms) by Data::DPath::Context::BEGIN@23 at line 50 # spent 1.06ms 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 | 1 | 2.23ms | 1 | 19.7ms | ); # spent 19.7ms making 1 call to Safe::BEGIN@46 |
51 | |||||
52 | 1 | 8µ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 | 848µs | 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 | 7 | 449µs | 5 | 148ms | # spent 22µs within Safe::BEGIN@70 which was called:
# once (22µs+0s) by Safe::CORE:regcomp at line 0 # spent 136ms making 1 call to Safe::CORE:regcomp
# spent 12.0ms making 1 call to utf8::AUTOLOAD
# spent 32µs making 1 call to Safe::CORE:pack
# spent 26µs making 1 call to Safe::CORE:match
# spent 8µs making 1 call to utf8::upgrade |
71 | # now we can safely include utf8::SWASHNEW in $default_share defined below. | ||||
72 | |||||
73 | 1 | 3µs | 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 | 52µ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 | 1µs | if (defined $Devel::Cover::VERSION) { | ||
144 | push @$default_share, '&Devel::Cover::use_file'; | ||||
145 | } | ||||
146 | |||||
147 | # spent 2.87ms (112µs+2.76) within Safe::new which was called:
# once (112µs+2.76ms) by Data::DPath::Context::BEGIN@29 at line 39 of Data/DPath/Context.pm | ||||
148 | 1 | 6µs | my($class, $root, $mask) = @_; | ||
149 | 1 | 3µs | my $obj = {}; | ||
150 | 1 | 14µs | bless $obj, $class; | ||
151 | |||||
152 | 1 | 3µ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 { | ||||
159 | 1 | 12µs | $obj->{Root} = "Safe::Root".$default_root++; | ||
160 | 1 | 3µ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, ...; | ||||
165 | 1 | 1µs | croak "Mask parameter to new no longer supported" if defined $mask; | ||
166 | 1 | 9µs | 1 | 57µs | $obj->permit_only(':default'); # spent 57µ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. | ||||
174 | 1 | 12µs | 1 | 2.67ms | $obj->share_from('main', $default_share); # spent 2.67ms making 1 call to Safe::share_from |
175 | |||||
176 | 1 | 56µs | 1 | 27µs | Opcode::_safe_pkg_prep($obj->{Root}) if($Opcode::VERSION > 1.04); # spent 27µs making 1 call to Opcode::_safe_pkg_prep |
177 | |||||
178 | 1 | 17µs | 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 | 2 | 1.95ms | 2 | 188µs | # spent 119µs (50+69) within Safe::BEGIN@191 which was called:
# once (50µs+69µs) by Data::DPath::Context::BEGIN@23 at line 191 # spent 119µs making 1 call to Safe::BEGIN@191
# spent 69µ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 | # spent 23µs within Safe::root which was called 2 times, avg 11µs/call:
# 2 times (23µs+0s) by Safe::share_from at line 283, avg 11µs/call | ||||
230 | 2 | 3µs | my $obj = shift; | ||
231 | 2 | 3µs | croak("Safe root method now read-only") if @_; | ||
232 | 2 | 30µs | 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 | # spent 44µs (31+12) within Safe::permit which was called:
# once (31µs+12µs) by Data::DPath::Context::BEGIN@29 at line 40 of Data/DPath/Context.pm | ||||
256 | 1 | 2µs | my $obj = shift; | ||
257 | # XXX needs testing | ||||
258 | 1 | 48µs | 2 | 12µs | $obj->{Mask} &= invert_opset opset(@_); # spent 8µs making 1 call to Opcode::opset
# spent 5µs making 1 call to Opcode::invert_opset |
259 | } | ||||
260 | # spent 57µs (41+16) within Safe::permit_only which was called:
# once (41µs+16µs) by Safe::new at line 166 | ||||
261 | 1 | 2µs | my $obj = shift; | ||
262 | 1 | 60µs | 2 | 16µs | $obj->{Mask} = invert_opset opset(@_); # spent 10µs making 1 call to Opcode::opset
# spent 6µs making 1 call to Opcode::invert_opset |
263 | } | ||||
264 | |||||
265 | |||||
266 | sub dump_mask { | ||||
267 | my $obj = shift; | ||||
268 | print opset_to_hex($obj->{Mask}),"\n"; | ||||
269 | } | ||||
270 | |||||
271 | |||||
272 | # spent 418µs (31+387) within Safe::share which was called:
# once (31µs+387µs) by Data::DPath::Context::BEGIN@29 at line 42 of Data/DPath/Context.pm | ||||
273 | 1 | 12µs | my($obj, @vars) = @_; | ||
274 | 1 | 21µs | 1 | 386µs | $obj->share_from(scalar(caller), \@vars); # spent 386µs making 1 call to Safe::share_from |
275 | } | ||||
276 | |||||
277 | |||||
278 | sub share_from { | ||||
279 | 2 | 3µs | my $obj = shift; | ||
280 | 2 | 3µs | my $pkg = shift; | ||
281 | 2 | 2µs | my $vars = shift; | ||
282 | 2 | 4µs | my $no_record = shift || 0; | ||
283 | 2 | 16µs | 2 | 23µs | my $root = $obj->root(); # spent 23µs making 2 calls to Safe::root, avg 11µs/call |
284 | 2 | 7µs | croak("vars not an array ref") unless ref $vars eq 'ARRAY'; | ||
285 | 2 | 1.56ms | 2 | 129µs | # spent 81µs (32+48) within Safe::BEGIN@285 which was called:
# once (32µs+48µs) by Data::DPath::Context::BEGIN@23 at line 285 # spent 81µs making 1 call to Safe::BEGIN@285
# spent 48µs making 1 call to strict::unimport |
286 | # Check that 'from' package actually exists | ||||
287 | croak("Package \"$pkg\" does not exist") | ||||
288 | 2 | 16µs | unless keys %{"$pkg\::"}; | ||
289 | 2 | 2µs | my $arg; | ||
290 | 2 | 7µs | foreach $arg (@$vars) { | ||
291 | # catch some $safe->share($var) errors: | ||||
292 | 59 | 43µs | my ($var, $type); | ||
293 | 59 | 806µs | 59 | 269µs | $type = $1 if ($var = $arg) =~ s/^(\W)//; # spent 269µs making 59 calls to Safe::CORE:subst, avg 5µs/call |
294 | # warn "share_from $pkg $type $var"; | ||||
295 | 59 | 251µ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"} | ||||
301 | 118 | 1.67ms | : ($type eq '*') ? *{$pkg."::$var"} | ||
302 | : croak(qq(Can't share "$type$var" of unknown type)); | ||||
303 | } | ||||
304 | } | ||||
305 | 2 | 40µs | 2 | 156µs | $obj->share_record($pkg, $vars) unless $no_record or !$vars; # spent 156µs making 2 calls to Safe::share_record, avg 78µs/call |
306 | } | ||||
307 | |||||
308 | |||||
309 | # spent 156µs within Safe::share_record which was called 2 times, avg 78µs/call:
# 2 times (156µs+0s) by Safe::share_from at line 305, avg 78µs/call | ||||
310 | 2 | 3µs | my $obj = shift; | ||
311 | 2 | 4µs | my $pkg = shift; | ||
312 | 2 | 2µs | my $vars = shift; | ||
313 | 2 | 10µs | my $shares = \%{$obj->{Shares} ||= {}}; | ||
314 | # Record shares using keys of $obj->{Shares}. See reinit. | ||||
315 | 2 | 151µs | @{$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 | 2 | 256µs | 2 | 135µs | # spent 85µs (34+50) within Safe::BEGIN@337 which was called:
# once (34µs+50µs) by Data::DPath::Context::BEGIN@23 at line 337 # spent 85µs making 1 call to Safe::BEGIN@337
# spent 50µ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 | 2 | 2.67ms | 2 | 94µs | # spent 60µs (25+34) within Safe::BEGIN@344 which was called:
# once (25µs+34µs) by Data::DPath::Context::BEGIN@23 at line 344 # spent 60µs making 1 call to Safe::BEGIN@344
# spent 34µ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 | 1µs | 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 | 83µs | 1; | ||
458 | |||||
459 | __END__ | ||||
# spent 26µs within Safe::CORE:match which was called:
# once (26µs+0s) by Data::DPath::Context::BEGIN@23 at line 70 | |||||
# spent 32µs within Safe::CORE:pack which was called:
# once (32µs+0s) by Data::DPath::Context::BEGIN@23 at line 70 | |||||
# spent 136ms (362µs+136) within Safe::CORE:regcomp which was called:
# once (362µs+136ms) by Data::DPath::Context::BEGIN@23 at line 70 | |||||
# spent 269µs within Safe::CORE:subst which was called 59 times, avg 5µs/call:
# 59 times (269µs+0s) by Safe::share_from at line 293, avg 5µs/call |