Filename | /usr/share/perl/5.14/Safe.pm |
Statements | Executed 872 statements in 9.34ms |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
1 | 1 | 1 | 3.46ms | 4.47ms | BEGIN@34 | Safe::
1 | 1 | 1 | 2.29ms | 2.54ms | share_from | Safe::
11 | 2 | 1 | 1.08ms | 1.27ms | _clean_stash (recurses: max depth 3, inclusive time 1.39ms) | Safe::
1 | 1 | 1 | 1.06ms | 9.79ms | BEGIN@46 | Safe::
4 | 2 | 1 | 230µs | 284µs | _find_code_refs (recurses: max depth 2, inclusive time 338µs) | Safe::
142 | 4 | 1 | 205µs | 205µs | CORE:match (opcode) | Safe::
59 | 1 | 1 | 171µs | 171µs | CORE:subst (opcode) | Safe::
1 | 1 | 1 | 146µs | 72.3ms | CORE:regcomp (opcode) | Safe::
1 | 1 | 1 | 122µs | 135µs | erase | Safe::
1 | 1 | 1 | 122µs | 153µs | lexless_anon_sub | Safe::
1 | 1 | 1 | 71µs | 1.97ms | reval | Safe::
1 | 1 | 1 | 71µs | 71µs | share_record | Safe::
1 | 1 | 1 | 69µs | 89µs | BEGIN@30 | Safe::
1 | 1 | 1 | 57µs | 2.64ms | new | Safe::
1 | 1 | 1 | 36µs | 36µs | BEGIN@3 | Safe::
1 | 1 | 1 | 24µs | 31µs | BEGIN@4 | Safe::
1 | 1 | 1 | 23µs | 61µs | BEGIN@186 | Safe::
1 | 1 | 1 | 20µs | 107µs | BEGIN@5 | Safe::
1 | 1 | 1 | 20µs | 28µs | permit_only | Safe::
1 | 1 | 1 | 20µs | 20µs | CORE:pack (opcode) | Safe::
1 | 1 | 1 | 19µs | 114µs | BEGIN@29 | Safe::
1 | 1 | 1 | 16µs | 47µs | BEGIN@280 | Safe::
1 | 1 | 1 | 16µs | 47µs | BEGIN@332 | Safe::
1 | 1 | 1 | 15µs | 45µs | BEGIN@36 | Safe::
1 | 1 | 1 | 15µs | 44µs | BEGIN@339 | Safe::
1 | 1 | 1 | 15µs | 150µs | DESTROY | Safe::
1 | 1 | 1 | 15µs | 299µs | wrap_code_refs_within | Safe::
2 | 2 | 1 | 15µs | 15µs | root | Safe::
1 | 1 | 1 | 14µs | 14µs | BEGIN@35 | Safe::
1 | 1 | 1 | 10µs | 10µs | BEGIN@69 | Safe::
0 | 0 | 0 | 0s | 0s | __ANON__[:412] | Safe::
0 | 0 | 0 | 0s | 0s | __ANON__[:42] | Safe::
0 | 0 | 0 | 0s | 0s | __ANON__[:430] | 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 | mask | Safe::
0 | 0 | 0 | 0s | 0s | permit | Safe::
0 | 0 | 0 | 0s | 0s | rdo | Safe::
0 | 0 | 0 | 0s | 0s | reinit | Safe::
0 | 0 | 0 | 0s | 0s | share | 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::
Line | State ments |
Time on line |
Calls | Time in subs |
Code |
---|---|---|---|---|---|
0 | 1 | 10µs | Profile data that couldn't be associated with a specific line: # spent 10µs making 1 call to Safe::BEGIN@69 | ||
1 | 1 | 17µs | package Safe; | ||
2 | |||||
3 | 2 | 77µs | 1 | 36µ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 # spent 36µs making 1 call to Safe::BEGIN@3 |
4 | 2 | 47µs | 2 | 38µ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 # spent 31µs making 1 call to Safe::BEGIN@4
# spent 7µs making 1 call to strict::import |
5 | 2 | 142µs | 2 | 194µ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 # spent 107µs making 1 call to Safe::BEGIN@5
# spent 87µs making 1 call to Exporter::import |
6 | |||||
7 | 1 | 2µ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 | ||||
15 | # $_[0] is package; | ||||
16 | # $_[1] is strict flag; | ||||
17 | 2 | 66µ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 | |||||
29 | 2 | 48µs | 2 | 209µ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 # spent 114µs making 1 call to Safe::BEGIN@29
# spent 95µs making 1 call to Exporter::import |
30 | 1 | 60µ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 # spent 29µs executing statements in string eval # includes 20µs spent executing 1 call to 1 sub defined therein. | ||
31 | use Carp::Heavy; | ||||
32 | 1 | 28µs | 1 | 89µs | } } # spent 89µs making 1 call to Safe::BEGIN@30 |
33 | |||||
34 | 2 | 170µs | 1 | 4.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 # 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 | ||||
36 | 2 | 96µs | 2 | 75µ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 # spent 45µs making 1 call to Safe::BEGIN@36
# spent 30µs making 1 call to strict::unimport |
37 | 2 | 14µ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 | 52µs | 1 | 14µs | } # spent 14µs making 1 call to Safe::BEGIN@35 |
45 | |||||
46 | 1 | 674µ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 # 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 | ||||
50 | 2 | 987µs | 1 | 9.79ms | ); # spent 9.79ms making 1 call to Safe::BEGIN@46 |
51 | |||||
52 | 1 | 3µ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 | 333µs | require 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) | ||||
69 | 7 | 202µs | 5 | 76.9ms | # spent 10µs within Safe::BEGIN@69 which was called:
# once (10µs+0s) by Safe::CORE:regcomp at line 0 # 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 | |||||
72 | 1 | 2µs | my $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 | ||||
76 | 1 | 26µs | my $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 | ||||
143 | 11 | 64µ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; | ||||
161 | 1 | 28µ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. | ||||
169 | 1 | 2.54ms | $obj->share_from('main', $default_share); # spent 2.54ms making 1 call to Safe::share_from | ||
170 | |||||
171 | 1 | 9µ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 | ||||
177 | 2 | 13µs | my $obj = shift; | ||
178 | 1 | 135µ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 | ||||
182 | 14 | 127µs | my ($obj, $action) = @_; | ||
183 | 1 | 7µs | my $pkg = $obj->root(); # spent 7µs making 1 call to Safe::root | ||
184 | my ($stem, $leaf); | ||||
185 | |||||
186 | 2 | 730µs | 2 | 100µ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 # 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 | ||||
188 | 1 | 6µ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 | |||||
218 | sub reinit { | ||||
219 | my $obj= shift; | ||||
220 | $obj->erase; | ||||
221 | $obj->share_redo; | ||||
222 | } | ||||
223 | |||||
224 | sub root { | ||||
225 | 6 | 21µs | my $obj = shift; | ||
226 | croak("Safe root method now read-only") if @_; | ||||
227 | return $obj->{Root}; | ||||
228 | } | ||||
229 | |||||
230 | |||||
231 | sub mask { | ||||
232 | my $obj = shift; | ||||
233 | return $obj->{Mask} unless @_; | ||||
234 | $obj->deny_only(@_); | ||||
235 | } | ||||
236 | |||||
237 | # v1 compatibility methods | ||||
238 | sub trap { shift->deny(@_) } | ||||
239 | sub untrap { shift->permit(@_) } | ||||
240 | |||||
241 | sub deny { | ||||
242 | my $obj = shift; | ||||
243 | $obj->{Mask} |= opset(@_); | ||||
244 | } | ||||
245 | sub deny_only { | ||||
246 | my $obj = shift; | ||||
247 | $obj->{Mask} = opset(@_); | ||||
248 | } | ||||
249 | |||||
250 | sub 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 | ||||
256 | 2 | 29µs | my $obj = shift; | ||
257 | 2 | 8µ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 | |||||
261 | sub dump_mask { | ||||
262 | my $obj = shift; | ||||
263 | print opset_to_hex($obj->{Mask}),"\n"; | ||||
264 | } | ||||
265 | |||||
266 | |||||
267 | sub 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 | ||||
274 | 542 | 2.46ms | my $obj = shift; | ||
275 | my $pkg = shift; | ||||
276 | my $vars = shift; | ||||
277 | my $no_record = shift || 0; | ||||
278 | 1 | 8µ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'; | ||||
280 | 2 | 590µs | 2 | 78µ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 # 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); | ||||
288 | 59 | 171µ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 | } | ||||
300 | 1 | 71µ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 | ||||
305 | 7 | 74µ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 | |||||
314 | sub 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 | |||||
325 | sub share_forget { | ||||
326 | delete shift->{Shares}; | ||||
327 | } | ||||
328 | |||||
329 | |||||
330 | sub varglob { | ||||
331 | my ($obj, $var) = @_; | ||||
332 | 2 | 115µs | 2 | 77µ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 # 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 | sub _clean_stash { | ||||
337 | 192 | 1.27ms | my ($root, $saved_refs) = @_; | ||
338 | $saved_refs ||= []; | ||||
339 | 2 | 1.03ms | 2 | 73µ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 # spent 44µs making 1 call to Safe::BEGIN@339
# spent 29µs making 1 call to strict::unimport |
340 | 74 | 99µ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 | |||||
345 | 66 | 91µ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; | ||||
347 | 10 | 0s | _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 | ||||
352 | 8 | 99µs | my ($obj, $expr, $strict) = @_; | ||
353 | my $root = $obj->{Root}; | ||||
354 | |||||
355 | 1 | 153µs | my $evalsub = lexless_anon_sub($root, $strict, $expr); # spent 153µs making 1 call to Safe::lexless_anon_sub | ||
356 | # propagate context | ||||
357 | 1 | 10µs | my $sg = sub_generation(); # spent 10µs making 1 call to B::sub_generation | ||
358 | 1 | 13µs | 2 | 312µ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); | ||||
361 | 2 | 1.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 | ||
362 | 1 | 299µ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 | |||||
366 | 1 | 1µs | my %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 | ||||
369 | 3 | 16µs | my $obj = shift; | ||
370 | |||||
371 | %OID = (); | ||||
372 | 1 | 284µs | $obj->_find_code_refs('wrap_code_ref', @_); # spent 284µs making 1 call to Safe::_find_code_refs | ||
373 | } | ||||
374 | |||||
375 | |||||
376 | sub _find_code_refs { | ||||
377 | 44 | 285µs | my $obj = shift; | ||
378 | my $visitor = shift; | ||||
379 | |||||
380 | for my $item (@_) { | ||||
381 | 22 | 47µ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 | ||||
385 | 3 | 7µ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') { | ||||
391 | 3 | 0s | $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 | |||||
401 | sub 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 | |||||
436 | sub 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 | |||||
452 | 1 | 34µs | 1; | ||
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 | |||||
# spent 20µs within Safe::CORE:pack which was called:
# once (20µs+0s) by CGI::Session::Serialize::default::BEGIN@6 at line 69 | |||||
# 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 | |||||
# 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 |