Profile of Safe.pm

← Index
NYTProf Performance Profile «line view»
For t/optimization.t
Run on Thu Jan 8 22:47:42 2015
Reported on Thu Jan 8 22:48:06 2015

Filename | /home/ss5/perl5/perlbrew/perls/tapper-perl/lib/5.16.3/Safe.pm
Statements | Executed 590 statements in 5.04ms

Subroutines
Calls | P | F | Exclusive Time | Inclusive Time | Subroutine
--- | --- | --- | --- | --- | ---
1 | 1 | 1 | 2.38ms | 3.06ms | Safe::::BEGIN@34Safe::BEGIN@34
16 | 2 | 1 | 876µs | 938µs | Safe::::_clean_stashSafe::_clean_stash (recurses: max depth 2, inclusive time 764µs)
1 | 1 | 1 | 815µs | 4.47ms | Safe::::BEGIN@46Safe::BEGIN@46
2 | 2 | 1 | 648µs | 746µs | Safe::::share_fromSafe::share_from
2 | 1 | 1 | 175µs | 175µs | Safe::::lexless_anon_subSafe::lexless_anon_sub
1 | 1 | 1 | 128µs | 4.79ms | Safe::::CORE:regcompSafe::CORE:regcomp (opcode)
2 | 1 | 1 | 93µs | 1.44ms | Safe::::revalSafe::reval
257 | 3 | 1 | 66µs | 66µs | Safe::::CORE:matchSafe::CORE:match (opcode)
59 | 1 | 1 | 54µs | 54µs | Safe::::CORE:substSafe::CORE:subst (opcode)
1 | 1 | 1 | 40µs | 159µs | Safe::::BEGIN@30Safe::BEGIN@30
2 | 1 | 1 | 39µs | 39µs | Safe::::share_recordSafe::share_record
1 | 1 | 1 | 28µs | 697µs | Safe::::newSafe::new
2 | 1 | 1 | 21µs | 45µs | Safe::::wrap_code_refs_withinSafe::wrap_code_refs_within
2 | 1 | 1 | 21µs | 24µs | Safe::::_find_code_refsSafe::_find_code_refs
1 | 1 | 1 | 20µs | 20µs | Safe::::BEGIN@3Safe::BEGIN@3
1 | 1 | 1 | 17µs | 37µs | Safe::::BEGIN@36Safe::BEGIN@36
1 | 1 | 1 | 13µs | 30µs | Safe::::BEGIN@188Safe::BEGIN@188
1 | 1 | 1 | 12µs | 15µs | Safe::::permit_onlySafe::permit_only
1 | 1 | 1 | 12µs | 26µs | Safe::::BEGIN@334Safe::BEGIN@334
1 | 1 | 1 | 11µs | 46µs | Safe::::BEGIN@4Safe::BEGIN@4
1 | 1 | 1 | 11µs | 11µs | Safe::::CORE:packSafe::CORE:pack (opcode)
1 | 1 | 1 | 10µs | 24µs | Safe::::BEGIN@282Safe::BEGIN@282
1 | 1 | 1 | 10µs | 47µs | Safe::::BEGIN@29Safe::BEGIN@29
1 | 1 | 1 | 10µs | 10µs | Safe::::BEGIN@35Safe::BEGIN@35
1 | 1 | 1 | 10µs | 24µs | Safe::::BEGIN@28Safe::BEGIN@28
1 | 1 | 1 | 9µs | 20µs | Safe::::BEGIN@341Safe::BEGIN@341
1 | 1 | 1 | 9µs | 106µs | Safe::::shareSafe::share
1 | 1 | 1 | 8µs | 11µs | Safe::::permitSafe::permit
2 | 1 | 1 | 4µs | 4µs | Safe::::rootSafe::root
0 | 0 | 0 | 0s | 0s | Safe::::DESTROYSafe::DESTROY
0 | 0 | 0 | 0s | 0s | Safe::::__ANON__[:414]Safe::__ANON__[:414]
0 | 0 | 0 | 0s | 0s | Safe::::__ANON__[:42]Safe::__ANON__[:42]
0 | 0 | 0 | 0s | 0s | Safe::::__ANON__[:432]Safe::__ANON__[:432]
0 | 0 | 0 | 0s | 0s | Safe::::denySafe::deny
0 | 0 | 0 | 0s | 0s | Safe::::deny_onlySafe::deny_only
0 | 0 | 0 | 0s | 0s | Safe::::dump_maskSafe::dump_mask
0 | 0 | 0 | 0s | 0s | Safe::::eraseSafe::erase
0 | 0 | 0 | 0s | 0s | Safe::::maskSafe::mask
0 | 0 | 0 | 0s | 0s | Safe::::rdoSafe::rdo
0 | 0 | 0 | 0s | 0s | Safe::::reinitSafe::reinit
0 | 0 | 0 | 0s | 0s | Safe::::share_forgetSafe::share_forget
0 | 0 | 0 | 0s | 0s | Safe::::share_redoSafe::share_redo
0 | 0 | 0 | 0s | 0s | Safe::::trapSafe::trap
0 | 0 | 0 | 0s | 0s | Safe::::untrapSafe::untrap
0 | 0 | 0 | 0s | 0s | Safe::::varglobSafe::varglob
0 | 0 | 0 | 0s | 0s | Safe::::wrap_code_refSafe::wrap_code_ref

Call graph for these subroutines as a Graphviz dot language file.

Line | State ments | Time on line | Calls | Time in subs | Code
--- | --- | --- | --- | --- | ---
1 |  |  |  |  | package Safe;
2 |  |  |  |  |
3 | 2 | 62µs | 1 | 20µs | # spent 20µs within Safe::BEGIN@3 which was called: # once (20µs+0s) by Data::DPath::Context::BEGIN@17 at line 3 use 5.003_11; # spent 20µs making 1 call to Safe::BEGIN@3
4 | 2 | 83µs | 2 | 82µs | # spent 46µs (11+36) within Safe::BEGIN@4 which was called: # once (11µs+36µs) by Data::DPath::Context::BEGIN@17 at line 4 use Scalar::Util qw(reftype refaddr); # spent 46µs making 1 call to Safe::BEGIN@4 # spent 36µs making 1 call to Exporter::import
5 |  |  |  |  |
6 | 1 | 1µ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 |  |  |  |  |
13 |  |  |  |  | # spent 175µs within Safe::lexless_anon_sub which was called 2 times, avg 88µs/call: # 2 times (175µs+0s) by Safe::reval at line 357, avg 88µs/call sub lexless_anon_sub {
14 |  |  |  |  | # $_[0] is package;
15 |  |  |  |  | # $_[1] is strict flag;
16 | 2 | 2µs |  |  | 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 | 2 | 168µs |  |  | eval sprintf # spent 73µs executing statements in string eval, 48µs here plus 25µs in 1 nested evals # includes 66µs spent executing 1 call to 1 sub defined therein. # spent 55µs executing statements in string eval, 46µs here plus 9µs in 1 nested evals # includes 52µs spent executing 1 call to 1 sub defined therein.
24 |  |  |  |  | 'package %s; %s sub { @_=(); eval q[my $__ExPr__;] . $__ExPr__; }',
25 |  |  |  |  | $_[0], $_[1] ? 'use strict;' : '';
26 |  |  |  |  | }
27 |  |  |  |  |
28 | 2 | 26µs | 2 | 39µs | # spent 24µs (10+15) within Safe::BEGIN@28 which was called: # once (10µs+15µs) by Data::DPath::Context::BEGIN@17 at line 28 use strict; # spent 24µs making 1 call to Safe::BEGIN@28 # spent 15µs making 1 call to strict::import
29 | 2 | 29µs | 2 | 85µs | # spent 47µs (10+38) within Safe::BEGIN@29 which was called: # once (10µs+38µs) by Data::DPath::Context::BEGIN@17 at line 29 use Carp; # spent 47µs making 1 call to Safe::BEGIN@29 # spent 38µs making 1 call to Exporter::import
30 | 1 | 34µs |  |  | # spent 159µs (40+119) within Safe::BEGIN@30 which was called: # once (40µs+119µs) by Data::DPath::Context::BEGIN@17 at line 32 BEGIN { eval q{ # spent 88µs executing statements in string eval # includes 111µs spent executing 1 call to 1 sub defined therein.
31 |  |  |  |  | use Carp::Heavy;
32 | 1 | 19µs | 1 | 159µs | } } # spent 159µs making 1 call to Safe::BEGIN@30
33 |  |  |  |  |
34 | 2 | 136µs | 1 | 3.06ms | # spent 3.06ms (2.38+675µs) within Safe::BEGIN@34 which was called: # once (2.38ms+675µs) by Data::DPath::Context::BEGIN@17 at line 34 use B (); # spent 3.06ms making 1 call to Safe::BEGIN@34
35 |  |  |  |  | # spent 10µs within Safe::BEGIN@35 which was called: # once (10µs+0s) by Data::DPath::Context::BEGIN@17 at line 44 BEGIN {
36 | 2 | 111µs | 2 | 58µs | # spent 37µs (17+20) within Safe::BEGIN@36 which was called: # once (17µs+20µs) by Data::DPath::Context::BEGIN@17 at line 36 no strict 'refs'; # spent 37µs making 1 call to Safe::BEGIN@36 # spent 20µs making 1 call to strict::unimport
37 | 1 | 11µ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 | 42µs | 1 | 10µs | } # spent 10µs making 1 call to Safe::BEGIN@35
45 |  |  |  |  |
46 | 1 | 14µs | 1 | 272µs | # spent 4.47ms (815µs+3.66) within Safe::BEGIN@46 which was called: # once (815µs+3.66ms) by Data::DPath::Context::BEGIN@17 at line 50 use Opcode 1.01, qw( # spent 272µ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 | 1 | 532µs | 1 | 4.47ms | ); # spent 4.47ms 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 | 1µ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 | 5 | 168µs | 5 | 9.48ms | do { my $a = pack('U',0x100); my $b = chr 0x101; utf8::upgrade $b; $a =~ /$b/i }; # spent 4.79ms making 1 call to Safe::CORE:regcomp # spent 4.67ms making 1 call to utf8::SWASHNEW # spent 11µ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 |  |  |  |  |
73 | 1 | 400ns |  |  | 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 | 10µ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 |  |  |  |  |
144 |  |  |  |  | # spent 697µs (28+670) within Safe::new which was called: # once (28µs+670µs) by Data::DPath::Context::BEGIN@23 at line 27 of lib/Data/DPath/Context.pm sub new {
145 | 1 | 1µs |  |  | my($class, $root, $mask) = @_;
146 | 1 | 700ns |  |  | my $obj = {};
147 | 1 | 3µs |  |  | bless $obj, $class;
148 |  |  |  |  |
149 | 1 | 700ns |  |  | 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 | 1 | 3µs |  |  | $obj->{Root} = "Safe::Root".$default_root++;
157 | 1 | 500ns |  |  | $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 | 1 | 200ns |  |  | croak "Mask parameter to new no longer supported" if defined $mask;
163 | 1 | 2µs | 1 | 15µs | $obj->permit_only(':default'); # spent 15µs making 1 call to Safe::permit_only
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 | 1 | 3µs | 1 | 649µs | $obj->share_from('main', $default_share); # spent 649µs making 1 call to Safe::share_from
172 |  |  |  |  |
173 | 1 | 14µs | 1 | 6µs | Opcode::_safe_pkg_prep($obj->{Root}) if($Opcode::VERSION > 1.04); # spent 6µs making 1 call to Opcode::_safe_pkg_prep
174 |  |  |  |  |
175 | 1 | 4µs |  |  | return $obj;
176 |  |  |  |  | }
177 |  |  |  |  |
178 |  |  |  |  | sub DESTROY {
179 |  |  |  |  | my $obj = shift;
180 |  |  |  |  | $obj->erase('DESTROY') if $obj->{Erase};
181 |  |  |  |  | }
182 |  |  |  |  |
183 |  |  |  |  | sub erase {
184 |  |  |  |  | my ($obj, $action) = @_;
185 |  |  |  |  | my $pkg = $obj->root();
186 |  |  |  |  | my ($stem, $leaf);
187 |  |  |  |  |
188 | 2 | 465µs | 2 | 48µs | # spent 30µs (13+18) within Safe::BEGIN@188 which was called: # once (13µs+18µs) by Data::DPath::Context::BEGIN@17 at line 188 no strict 'refs'; # spent 30µs making 1 call to Safe::BEGIN@188 # spent 18µ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 |  |  |  |  |
220 |  |  |  |  | sub reinit {
221 |  |  |  |  | my $obj= shift;
222 |  |  |  |  | $obj->erase;
223 |  |  |  |  | $obj->share_redo;
224 |  |  |  |  | }
225 |  |  |  |  |
226 |  |  |  |  | # spent 4µs within Safe::root which was called 2 times, avg 2µs/call: # 2 times (4µs+0s) by Safe::share_from at line 280, avg 2µs/call sub root {
227 | 2 | 400ns |  |  | my $obj = shift;
228 | 2 | 700ns |  |  | croak("Safe root method now read-only") if @_;
229 | 2 | 7µs |  |  | return $obj->{Root};
230 |  |  |  |  | }
231 |  |  |  |  |
232 |  |  |  |  |
233 |  |  |  |  | sub mask {
234 |  |  |  |  | my $obj = shift;
235 |  |  |  |  | return $obj->{Mask} unless @_;
236 |  |  |  |  | $obj->deny_only(@_);
237 |  |  |  |  | }
238 |  |  |  |  |
239 |  |  |  |  | # v1 compatibility methods
240 |  |  |  |  | sub trap { shift->deny(@_) }
241 |  |  |  |  | sub untrap { shift->permit(@_) }
242 |  |  |  |  |
243 |  |  |  |  | sub deny {
244 |  |  |  |  | my $obj = shift;
245 |  |  |  |  | $obj->{Mask} |= opset(@_);
246 |  |  |  |  | }
247 |  |  |  |  | sub deny_only {
248 |  |  |  |  | my $obj = shift;
249 |  |  |  |  | $obj->{Mask} = opset(@_);
250 |  |  |  |  | }
251 |  |  |  |  |
252 |  |  |  |  | # spent 11µs (8+2) within Safe::permit which was called: # once (8µs+2µs) by Data::DPath::Context::BEGIN@23 at line 28 of lib/Data/DPath/Context.pm sub permit {
253 | 1 | 300ns |  |  | my $obj = shift;
254 |  |  |  |  | # XXX needs testing
255 | 1 | 12µs | 2 | 2µs | $obj->{Mask} &= invert_opset opset(@_); # spent 1µs making 1 call to Opcode::opset # spent 1µs making 1 call to Opcode::invert_opset
256 |  |  |  |  | }
257 |  |  |  |  | # spent 15µs (12+3) within Safe::permit_only which was called: # once (12µs+3µs) by Safe::new at line 163 sub permit_only {
258 | 1 | 400ns |  |  | my $obj = shift;
259 | 1 | 17µs | 2 | 3µs | $obj->{Mask} = invert_opset opset(@_); # spent 2µs making 1 call to Opcode::opset # spent 1µs making 1 call to Opcode::invert_opset
260 |  |  |  |  | }
261 |  |  |  |  |
262 |  |  |  |  |
263 |  |  |  |  | sub dump_mask {
264 |  |  |  |  | my $obj = shift;
265 |  |  |  |  | print opset_to_hex($obj->{Mask}),"\n";
266 |  |  |  |  | }
267 |  |  |  |  |
268 |  |  |  |  |
269 |  |  |  |  | # spent 106µs (9+97) within Safe::share which was called: # once (9µs+97µs) by Data::DPath::Context::BEGIN@23 at line 30 of lib/Data/DPath/Context.pm sub share {
270 | 1 | 2µs |  |  | my($obj, @vars) = @_;
271 | 1 | 5µs | 1 | 97µs | $obj->share_from(scalar(caller), \@vars); # spent 97µs making 1 call to Safe::share_from
272 |  |  |  |  | }
273 |  |  |  |  |
274 |  |  |  |  |
275 |  |  |  |  | # spent 746µs (648+97) within Safe::share_from which was called 2 times, avg 373µs/call: # once (565µs+84µs) by Safe::new at line 171 # once (83µs+14µs) by Safe::share at line 271 sub share_from {
276 | 2 | 500ns |  |  | my $obj = shift;
277 | 2 | 700ns |  |  | my $pkg = shift;
278 | 2 | 400ns |  |  | my $vars = shift;
279 | 2 | 700ns |  |  | my $no_record = shift || 0;
280 | 2 | 3µs | 2 | 4µs | my $root = $obj->root(); # spent 4µs making 2 calls to Safe::root, avg 2µs/call
281 | 2 | 2µs |  |  | croak("vars not an array ref") unless ref $vars eq 'ARRAY';
282 | 2 | 403µs | 2 | 37µs | # spent 24µs (10+13) within Safe::BEGIN@282 which was called: # once (10µs+13µs) by Data::DPath::Context::BEGIN@17 at line 282 no strict 'refs'; # spent 24µs making 1 call to Safe::BEGIN@282 # spent 13µs making 1 call to strict::unimport
283 |  |  |  |  | # Check that 'from' package actually exists
284 |  |  |  |  | croak("Package \"$pkg\" does not exist")
285 | 2 | 4µs |  |  | unless keys %{"$pkg\::"};
286 | 2 | 300ns |  |  | my $arg;
287 | 2 | 2µs |  |  | foreach $arg (@$vars) {
288 |  |  |  |  | # catch some $safe->share($var) errors:
289 | 59 | 11µs |  |  | my ($var, $type);
290 | 59 | 206µs | 59 | 54µs | $type = $1 if ($var = $arg) =~ s/^(\W)//; # spent 54µs making 59 calls to Safe::CORE:subst, avg 915ns/call
291 |  |  |  |  | # warn "share_from $pkg $type $var";
292 | 59 | 58µs |  |  | 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 | 118 | 400µs |  |  | : ($type eq '*') ? *{$pkg."::$var"}
299 |  |  |  |  | : croak(qq(Can't share "$type$var" of unknown type));
300 |  |  |  |  | }
301 |  |  |  |  | }
302 | 2 | 13µs | 2 | 39µs | $obj->share_record($pkg, $vars) unless $no_record or !$vars; # spent 39µs making 2 calls to Safe::share_record, avg 20µs/call
303 |  |  |  |  | }
304 |  |  |  |  |
305 |  |  |  |  |
306 |  |  |  |  | # spent 39µs within Safe::share_record which was called 2 times, avg 20µs/call: # 2 times (39µs+0s) by Safe::share_from at line 302, avg 20µs/call sub share_record {
307 | 2 | 600ns |  |  | my $obj = shift;
308 | 2 | 500ns |  |  | my $pkg = shift;
309 | 2 | 300ns |  |  | my $vars = shift;
310 | 2 | 2µs |  |  | my $shares = \%{$obj->{Shares} ||= {}};
311 |  |  |  |  | # Record shares using keys of $obj->{Shares}. See reinit.
312 | 2 | 39µs |  |  | @{$shares}{@$vars} = ($pkg) x @$vars if @$vars;
313 |  |  |  |  | }
314 |  |  |  |  |
315 |  |  |  |  |
316 |  |  |  |  | sub 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 |  |  |  |  |
327 |  |  |  |  | sub share_forget {
328 |  |  |  |  | delete shift->{Shares};
329 |  |  |  |  | }
330 |  |  |  |  |
331 |  |  |  |  |
332 |  |  |  |  | sub varglob {
333 |  |  |  |  | my ($obj, $var) = @_;
334 | 2 | 74µs | 2 | 40µs | # spent 26µs (12+14) within Safe::BEGIN@334 which was called: # once (12µs+14µs) by Data::DPath::Context::BEGIN@17 at line 334 no strict 'refs'; # spent 26µs making 1 call to Safe::BEGIN@334 # spent 14µs making 1 call to strict::unimport
335 |  |  |  |  | return *{$obj->root()."::$var"};
336 |  |  |  |  | }
337 |  |  |  |  |
338 |  |  |  |  | # spent 938µs (876+61) within Safe::_clean_stash which was called 16 times, avg 59µs/call: # 14 times (618µs+-618µs) by Safe::_clean_stash at line 349, avg 0s/call # 2 times (258µs+679µs) by Safe::reval at line 363, avg 469µs/call sub _clean_stash {
339 | 16 | 13µs |  |  | my ($root, $saved_refs) = @_;
340 | 16 | 5µs |  |  | $saved_refs ||= [];
341 | 2 | 680µs | 2 | 32µs | # spent 20µs (9+11) within Safe::BEGIN@341 which was called: # once (9µs+11µs) by Data::DPath::Context::BEGIN@17 at line 341 no strict 'refs'; # spent 20µs making 1 call to Safe::BEGIN@341 # spent 11µs making 1 call to strict::unimport
342 | 16 | 310µs | 132 | 29µs | foreach my $hook (qw(DESTROY AUTOLOAD), grep /^\(/, keys %$root) { # spent 29µs making 132 calls to Safe::CORE:match, avg 220ns/call
343 | 39 | 108µs |  |  | push @$saved_refs, \*{$root.$hook};
344 | 39 | 63µs |  |  | delete ${$root}{$hook};
345 |  |  |  |  | }
346 |  |  |  |  |
347 | 16 | 343µs | 124 | 32µs | for (grep /::$/, keys %$root) { # spent 32µs making 124 calls to Safe::CORE:match, avg 259ns/call
348 | 16 | 54µs |  |  | next if \%{$root.$_} eq \%$root;
349 | 14 | 45µs | 14 | 0s | _clean_stash($root.$_, $saved_refs); # spent 764µs making 14 calls to Safe::_clean_stash, avg 55µs/call, recursion: max depth 2, sum of overlapping time 764µs
350 |  |  |  |  | }
351 |  |  |  |  | }
352 |  |  |  |  |
353 |  |  |  |  | # spent 1.44ms (93µs+1.35) within Safe::reval which was called 2 times, avg 720µs/call: # 2 times (93µs+1.35ms) by Data::DPath::Context::_filter_points_eval at line 191 of lib/Data/DPath/Context.pm, avg 720µs/call sub reval {
354 | 2 | 2µs |  |  | my ($obj, $expr, $strict) = @_;
355 | 2 | 2µs |  |  | my $root = $obj->{Root};
356 |  |  |  |  |
357 | 2 | 6µs | 2 | 175µs | my $evalsub = lexless_anon_sub($root, $strict, $expr); # spent 175µs making 2 calls to Safe::lexless_anon_sub, avg 88µs/call
358 |  |  |  |  | # propagate context
359 | 2 | 25µs | 2 | 13µs | my $sg = sub_generation(); # spent 13µs making 2 calls to B::sub_generation, avg 6µs/call
360 | 2 | 60µs | 4 | 298µs | my @subret = (wantarray) # spent 173µs making 2 calls to Opcode::_safe_call_sv, avg 87µs/call # spent 70µs making 1 call to main::__ANON__[(eval 67)[Safe.pm:23]:1] # spent 55µs making 1 call to main::__ANON__[(eval 55)[Safe.pm:23]:1]
361 |  |  |  |  | ? Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub)
362 |  |  |  |  | : scalar Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub);
363 | 2 | 17µs | 4 | 940µs | _clean_stash($root.'::') if $sg != sub_generation(); # spent 938µs making 2 calls to Safe::_clean_stash, avg 469µs/call # spent 2µs making 2 calls to B::sub_generation, avg 1µs/call
364 | 2 | 7µs | 2 | 45µs | $obj->wrap_code_refs_within(@subret); # spent 45µs making 2 calls to Safe::wrap_code_refs_within, avg 23µs/call
365 | 2 | 26µs |  |  | return (wantarray) ? @subret : $subret[0];
366 |  |  |  |  | }
367 |  |  |  |  |
368 | 1 | 200ns |  |  | my %OID;
369 |  |  |  |  |
370 |  |  |  |  | # spent 45µs (21+24) within Safe::wrap_code_refs_within which was called 2 times, avg 23µs/call: # 2 times (21µs+24µs) by Safe::reval at line 364, avg 23µs/call sub wrap_code_refs_within {
371 | 2 | 2µs |  |  | my $obj = shift;
372 |  |  |  |  |
373 | 2 | 3µs |  |  | %OID = ();
374 | 2 | 11µs | 2 | 24µs | $obj->_find_code_refs('wrap_code_ref', @_); # spent 24µs making 2 calls to Safe::_find_code_refs, avg 12µs/call
375 |  |  |  |  | }
376 |  |  |  |  |
377 |  |  |  |  |
378 |  |  |  |  | # spent 24µs (21+3) within Safe::_find_code_refs which was called 2 times, avg 12µs/call: # 2 times (21µs+3µs) by Safe::wrap_code_refs_within at line 374, avg 12µs/call sub _find_code_refs {
379 | 2 | 1µs |  |  | my $obj = shift;
380 | 2 | 1µs |  |  | my $visitor = shift;
381 |  |  |  |  |
382 | 2 | 16µs |  |  | for my $item (@_) {
383 | 2 | 14µs | 2 | 3µs | my $reftype = $item && reftype $item # spent 3µs making 2 calls to Scalar::Util::reftype, avg 1µs/call
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 |  |  |  |  |
403 |  |  |  |  | sub 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 |  |  |  |  |
438 |  |  |  |  | sub 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 |  |  |  |  |
454 | 1 | 16µs |  |  | 1;
455 |  |  |  |  |
456 |  |  |  |  | __END__
|  |  |  |  | # spent 66µs within Safe::CORE:match which was called 257 times, avg 255ns/call: # 132 times (29µs+0s) by Safe::_clean_stash at line 342, avg 220ns/call # 124 times (32µs+0s) by Safe::_clean_stash at line 347, avg 259ns/call # once (4µs+0s) by Data::DPath::Context::BEGIN@17 at line 70 sub Safe::CORE:match; # opcode
|  |  |  |  | # spent 11µs within Safe::CORE:pack which was called: # once (11µs+0s) by Data::DPath::Context::BEGIN@17 at line 70 sub Safe::CORE:pack; # opcode
|  |  |  |  | # spent 4.79ms (128µs+4.67) within Safe::CORE:regcomp which was called: # once (128µs+4.67ms) by Data::DPath::Context::BEGIN@17 at line 70 sub Safe::CORE:regcomp; # opcode
|  |  |  |  | # spent 54µs within Safe::CORE:subst which was called 59 times, avg 915ns/call: # 59 times (54µs+0s) by Safe::share_from at line 290, avg 915ns/call sub Safe::CORE:subst; # opcode