← Index
NYTProf Performance Profile   « block view • line view • sub view »
For xt/tapper-mcp-scheduler-with-db-longrun.t
  Run on Tue May 22 17:18:39 2012
Reported on Tue May 22 17:22:58 2012

Filename/2home/ss5/perl5/perlbrew/perls/perl-5.12.3/lib/site_perl/5.12.3/Safe.pm
StatementsExecuted 48 statements in 2.21ms
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
111614µs3.55msSafe::::BEGIN@46Safe::BEGIN@46
11189µs27.6msSafe::::CORE:matchSafe::CORE:match (opcode)
11156µs24.6msSafe::::CORE:regcompSafe::CORE:regcomp (opcode)
11137µs37µsSafe::::BEGIN@3Safe::BEGIN@3
11130µs46µsSafe::::BEGIN@191Safe::BEGIN@191
11129µs40µsSafe::::BEGIN@30Safe::BEGIN@30
11110µs36µsSafe::::BEGIN@4Safe::BEGIN@4
1119µs13µsSafe::::BEGIN@28Safe::BEGIN@28
1118µs39µsSafe::::BEGIN@29Safe::BEGIN@29
1116µs14µsSafe::::BEGIN@285Safe::BEGIN@285
1116µs13µsSafe::::BEGIN@344Safe::BEGIN@344
1116µs14µsSafe::::BEGIN@337Safe::BEGIN@337
1116µs20µsSafe::::BEGIN@36Safe::BEGIN@36
1115µs5µsSafe::::BEGIN@35Safe::BEGIN@35
1114µs4µsSafe::::CORE:packSafe::CORE:pack (opcode)
1114µs4µsSafe::::BEGIN@34Safe::BEGIN@34
0000s0sSafe::::DESTROYSafe::DESTROY
0000s0sSafe::::__ANON__[:417]Safe::__ANON__[:417]
0000s0sSafe::::__ANON__[:42]Safe::__ANON__[:42]
0000s0sSafe::::__ANON__[:435]Safe::__ANON__[:435]
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
3349µs137µ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
use 5.003_11;
# spent 37µs making 1 call to Safe::BEGIN@3
4369µs263µ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
use Scalar::Util qw(reftype refaddr);
# spent 36µs making 1 call to Safe::BEGIN@4 # spent 27µs making 1 call to Exporter::import
5
61700ns$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
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
28318µs218µ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
use strict;
# spent 13µs making 1 call to Safe::BEGIN@28 # spent 5µs making 1 call to strict::import
29324µs270µ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
use Carp;
# spent 39µs making 1 call to Safe::BEGIN@29 # spent 31µs making 1 call to Exporter::import
30125µ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
BEGIN { eval q{
# spent 16µs executing statements in string eval
# includes 11µs spent executing 1 call to 1 sub defined therein.
31 use Carp::Heavy;
32112µs140µs} }
# spent 40µs making 1 call to Safe::BEGIN@30
33
34319µs14µ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
use B ();
# 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
BEGIN {
36353µs233µ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
no strict 'refs';
# spent 20µs making 1 call to Safe::BEGIN@36 # spent 14µs making 1 call to strict::unimport
3716µ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 }
44125µs15µs}
# spent 5µs making 1 call to Safe::BEGIN@35
45
461235µ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
use Opcode 1.01, qw(
# 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
503464µs13.55ms);
# spent 3.55ms making 1 call to Safe::BEGIN@46
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.
621700nsrequire 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)
705173µs7104msdo { 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
731700nsmy $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
77120µ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])];
1431400nsif (defined $Devel::Cover::VERSION) {
144 push @$default_share, '&Devel::Cover::use_file';
145}
146
147sub 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
181sub DESTROY {
182 my $obj = shift;
183 $obj->erase('DESTROY') if $obj->{Erase};
184}
185
186sub erase {
187 my ($obj, $action) = @_;
188 my $pkg = $obj->root();
189 my ($stem, $leaf);
190
1913374µs262µ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
no strict 'refs';
# 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
223sub reinit {
224 my $obj= shift;
225 $obj->erase;
226 $obj->share_redo;
227}
228
229sub root {
230 my $obj = shift;
231 croak("Safe root method now read-only") if @_;
232 return $obj->{Root};
233}
234
235
236sub mask {
237 my $obj = shift;
238 return $obj->{Mask} unless @_;
239 $obj->deny_only(@_);
240}
241
242# v1 compatibility methods
243sub trap { shift->deny(@_) }
244sub untrap { shift->permit(@_) }
245
246sub deny {
247 my $obj = shift;
248 $obj->{Mask} |= opset(@_);
249}
250sub deny_only {
251 my $obj = shift;
252 $obj->{Mask} = opset(@_);
253}
254
255sub permit {
256 my $obj = shift;
257 # XXX needs testing
258 $obj->{Mask} &= invert_opset opset(@_);
259}
260sub permit_only {
261 my $obj = shift;
262 $obj->{Mask} = invert_opset opset(@_);
263}
264
265
266sub dump_mask {
267 my $obj = shift;
268 print opset_to_hex($obj->{Mask}),"\n";
269}
270
271
272sub share {
273 my($obj, @vars) = @_;
274 $obj->share_from(scalar(caller), \@vars);
275}
276
277
278sub 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';
2853286µs222µ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
no strict 'refs';
# 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
309sub 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
319sub 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
330sub share_forget {
331 delete shift->{Shares};
332}
333
334
335sub varglob {
336 my ($obj, $var) = @_;
337347µs222µ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
no strict 'refs';
# 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
341sub _clean_stash {
342 my ($root, $saved_refs) = @_;
343 $saved_refs ||= [];
3443516µs220µ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
no strict 'refs';
# 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
356sub 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
3711200nsmy %OID;
372
373sub wrap_code_refs_within {
374 my $obj = shift;
375
376 %OID = ();
377 $obj->_find_code_refs('wrap_code_ref', @_);
378}
379
380
381sub _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
406sub 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
441sub 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
457124µs1;
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
sub Safe::CORE:match; # opcode
# 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
sub Safe::CORE:pack; # opcode
# 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
sub Safe::CORE:regcomp; # opcode