← Index
NYTProf Performance Profile   « block view • line view • sub view »
For bin/pan_genome_post_analysis
  Run on Fri Mar 27 11:43:32 2015
Reported on Fri Mar 27 11:45:29 2015

Filename/Users/ap13/perl5/perlbrew/perls/perl-5.16.2/lib/5.16.2/Safe.pm
StatementsExecuted 36 statements in 3.49ms
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
1111.13ms6.35msSafe::::BEGIN@46Safe::BEGIN@46
111210µs5.23msSafe::::CORE:regcompSafe::CORE:regcomp (opcode)
11159µs82µsSafe::::BEGIN@30Safe::BEGIN@30
11132µs32µsSafe::::BEGIN@3Safe::BEGIN@3
11115µs40µsSafe::::BEGIN@28Safe::BEGIN@28
11115µs15µsSafe::::CORE:packSafe::CORE:pack (opcode)
11114µs37µsSafe::::BEGIN@188Safe::BEGIN@188
11114µs64µsSafe::::BEGIN@29Safe::BEGIN@29
11114µs40µsSafe::::BEGIN@36Safe::BEGIN@36
11113µs56µsSafe::::BEGIN@4Safe::BEGIN@4
11112µs27µsSafe::::BEGIN@282Safe::BEGIN@282
11112µs27µsSafe::::BEGIN@334Safe::BEGIN@334
1119µs21µsSafe::::BEGIN@341Safe::BEGIN@341
1117µs7µsSafe::::BEGIN@35Safe::BEGIN@35
1116µs6µsSafe::::BEGIN@34Safe::BEGIN@34
1114µs4µsSafe::::CORE:matchSafe::CORE:match (opcode)
0000s0sSafe::::DESTROYSafe::DESTROY
0000s0sSafe::::__ANON__[:414]Safe::__ANON__[:414]
0000s0sSafe::::__ANON__[:42]Safe::__ANON__[:42]
0000s0sSafe::::__ANON__[:432]Safe::__ANON__[:432]
0000s0sSafe::::_clean_stashSafe::_clean_stash
0000s0sSafe::::_find_code_refsSafe::_find_code_refs
0000s0sSafe::::denySafe::deny
0000s0sSafe::::deny_onlySafe::deny_only
0000s0sSafe::::dump_maskSafe::dump_mask
0000s0sSafe::::eraseSafe::erase
0000s0sSafe::::lexless_anon_subSafe::lexless_anon_sub
0000s0sSafe::::maskSafe::mask
0000s0sSafe::::newSafe::new
0000s0sSafe::::permitSafe::permit
0000s0sSafe::::permit_onlySafe::permit_only
0000s0sSafe::::rdoSafe::rdo
0000s0sSafe::::reinitSafe::reinit
0000s0sSafe::::revalSafe::reval
0000s0sSafe::::rootSafe::root
0000s0sSafe::::shareSafe::share
0000s0sSafe::::share_forgetSafe::share_forget
0000s0sSafe::::share_fromSafe::share_from
0000s0sSafe::::share_recordSafe::share_record
0000s0sSafe::::share_redoSafe::share_redo
0000s0sSafe::::trapSafe::trap
0000s0sSafe::::untrapSafe::untrap
0000s0sSafe::::varglobSafe::varglob
0000s0sSafe::::wrap_code_refSafe::wrap_code_ref
0000s0sSafe::::wrap_code_refs_withinSafe::wrap_code_refs_within
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments
Time
on line
Calls Time
in subs
Code
1package Safe;
2
3287µs132µs
# spent 32µs within Safe::BEGIN@3 which was called: # once (32µs+0s) by Graph::BEGIN@42 at line 3
use 5.003_11;
# spent 32µs making 1 call to Safe::BEGIN@3
42123µs299µ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
use Scalar::Util qw(reftype refaddr);
# spent 56µs making 1 call to Safe::BEGIN@4 # spent 43µs making 1 call to Exporter::import
5
611µ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
13sub 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
28239µs265µ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
use strict;
# spent 40µs making 1 call to Safe::BEGIN@28 # spent 25µs making 1 call to strict::import
29242µs2114µ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
use Carp;
# spent 64µs making 1 call to Safe::BEGIN@29 # spent 50µs making 1 call to Exporter::import
30149µ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
BEGIN { eval q{
# spent 33µs executing statements in string eval
# includes 23µs spent executing 1 call to 1 sub defined therein.
31 use Carp::Heavy;
32127µs182µs} }
# spent 82µs making 1 call to Safe::BEGIN@30
33
34242µs16µs
# spent 6µs within Safe::BEGIN@34 which was called: # once (6µs+0s) by Graph::BEGIN@42 at line 34
use B ();
# 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
BEGIN {
36298µs266µ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
no strict 'refs';
# spent 40µs making 1 call to Safe::BEGIN@36 # spent 26µs making 1 call to strict::unimport
37119µ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 }
44159µs17µs}
# spent 7µs making 1 call to Safe::BEGIN@35
45
462184µ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
use Opcode 1.01, qw(
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
501555µs26.67ms);
# spent 6.35ms making 1 call to Safe::BEGIN@46 # spent 316µs making 1 call to Exporter::import
51
5212µ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.
621900nsrequire 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)
705253µs510.3msdo { 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
731500nsmy $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
77116µsmy $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
144sub 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
178sub DESTROY {
179 my $obj = shift;
180 $obj->erase('DESTROY') if $obj->{Erase};
181}
182
183sub erase {
184 my ($obj, $action) = @_;
185 my $pkg = $obj->root();
186 my ($stem, $leaf);
187
1882575µs261µ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
no strict 'refs';
# 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
220sub reinit {
221 my $obj= shift;
222 $obj->erase;
223 $obj->share_redo;
224}
225
226sub root {
227 my $obj = shift;
228 croak("Safe root method now read-only") if @_;
229 return $obj->{Root};
230}
231
232
233sub mask {
234 my $obj = shift;
235 return $obj->{Mask} unless @_;
236 $obj->deny_only(@_);
237}
238
239# v1 compatibility methods
240sub trap { shift->deny(@_) }
241sub untrap { shift->permit(@_) }
242
243sub deny {
244 my $obj = shift;
245 $obj->{Mask} |= opset(@_);
246}
247sub deny_only {
248 my $obj = shift;
249 $obj->{Mask} = opset(@_);
250}
251
252sub permit {
253 my $obj = shift;
254 # XXX needs testing
255 $obj->{Mask} &= invert_opset opset(@_);
256}
257sub permit_only {
258 my $obj = shift;
259 $obj->{Mask} = invert_opset opset(@_);
260}
261
262
263sub dump_mask {
264 my $obj = shift;
265 print opset_to_hex($obj->{Mask}),"\n";
266}
267
268
269sub share {
270 my($obj, @vars) = @_;
271 $obj->share_from(scalar(caller), \@vars);
272}
273
274
275sub 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';
2822449µs242µ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
no strict 'refs';
# 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
306sub 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
316sub 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
327sub share_forget {
328 delete shift->{Shares};
329}
330
331
332sub varglob {
333 my ($obj, $var) = @_;
3342102µs242µ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
no strict 'refs';
# 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
338sub _clean_stash {
339 my ($root, $saved_refs) = @_;
340 $saved_refs ||= [];
3412737µs233µ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
no strict 'refs';
# 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
353sub 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
3681200nsmy %OID;
369
370sub wrap_code_refs_within {
371 my $obj = shift;
372
373 %OID = ();
374 $obj->_find_code_refs('wrap_code_ref', @_);
375}
376
377
378sub _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
403sub 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
438sub 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
454135µs1;
455
456__END__
 
# spent 4µs within Safe::CORE:match which was called: # once (4µs+0s) by Graph::BEGIN@42 at line 70
sub Safe::CORE:match; # opcode
# spent 15µs within Safe::CORE:pack which was called: # once (15µs+0s) by Graph::BEGIN@42 at line 70
sub Safe::CORE:pack; # opcode
# 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
sub Safe::CORE:regcomp; # opcode