Profile of Safe.pm

← Index
NYTProf Performance Profile «block view•line view•sub view»
For bin/dpath
Run on Tue Jun 5 15:31:33 2012
Reported on Tue Jun 5 15:31:44 2012

Filename | /home/ss5/perl5/perlbrew/perls/perl-5.14.1/lib/site_perl/5.14.1/Safe.pm
Statements | Executed 387 statements in 15.4ms

Subroutines
Calls | P | F | Exclusive Time | Inclusive Time | Subroutine
--- | --- | --- | --- | --- | ---
1 | 1 | 1 | 9.51ms | 12.4ms | Safe::::BEGIN@34Safe::BEGIN@34
1 | 1 | 1 | 3.21ms | 19.7ms | Safe::::BEGIN@46Safe::BEGIN@46
2 | 2 | 1 | 2.61ms | 3.06ms | Safe::::share_fromSafe::share_from
1 | 1 | 1 | 362µs | 136ms | Safe::::CORE:regcompSafe::CORE:regcomp (opcode)
59 | 1 | 1 | 269µs | 269µs | Safe::::CORE:substSafe::CORE:subst (opcode)
2 | 1 | 1 | 156µs | 156µs | Safe::::share_recordSafe::share_record
1 | 1 | 1 | 153µs | 630µs | Safe::::BEGIN@30Safe::BEGIN@30
1 | 1 | 1 | 112µs | 2.87ms | Safe::::newSafe::new
1 | 1 | 1 | 93µs | 93µs | Safe::::BEGIN@3Safe::BEGIN@3
1 | 1 | 1 | 50µs | 119µs | Safe::::BEGIN@191Safe::BEGIN@191
1 | 1 | 1 | 41µs | 57µs | Safe::::permit_onlySafe::permit_only
1 | 1 | 1 | 39µs | 93µs | Safe::::BEGIN@36Safe::BEGIN@36
1 | 1 | 1 | 35µs | 51µs | Safe::::BEGIN@28Safe::BEGIN@28
1 | 1 | 1 | 34µs | 85µs | Safe::::BEGIN@337Safe::BEGIN@337
1 | 1 | 1 | 32µs | 204µs | Safe::::BEGIN@4Safe::BEGIN@4
1 | 1 | 1 | 32µs | 81µs | Safe::::BEGIN@285Safe::BEGIN@285
1 | 1 | 1 | 32µs | 32µs | Safe::::CORE:packSafe::CORE:pack (opcode)
1 | 1 | 1 | 31µs | 44µs | Safe::::permitSafe::permit
1 | 1 | 1 | 31µs | 418µs | Safe::::shareSafe::share
1 | 1 | 1 | 29µs | 178µs | Safe::::BEGIN@29Safe::BEGIN@29
1 | 1 | 1 | 26µs | 26µs | Safe::::CORE:matchSafe::CORE:match (opcode)
1 | 1 | 1 | 25µs | 60µs | Safe::::BEGIN@344Safe::BEGIN@344
1 | 1 | 1 | 24µs | 24µs | Safe::::BEGIN@35Safe::BEGIN@35
2 | 1 | 1 | 23µs | 23µs | Safe::::rootSafe::root
1 | 1 | 1 | 22µs | 22µs | Safe::::BEGIN@70Safe::BEGIN@70
0 | 0 | 0 | 0s | 0s | Safe::::DESTROYSafe::DESTROY
0 | 0 | 0 | 0s | 0s | Safe::::__ANON__[:417]Safe::__ANON__[:417]
0 | 0 | 0 | 0s | 0s | Safe::::__ANON__[:42]Safe::__ANON__[:42]
0 | 0 | 0 | 0s | 0s | Safe::::__ANON__[:435]Safe::__ANON__[:435]
0 | 0 | 0 | 0s | 0s | Safe::::_clean_stashSafe::_clean_stash
0 | 0 | 0 | 0s | 0s | Safe::::_find_code_refsSafe::_find_code_refs
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::::lexless_anon_subSafe::lexless_anon_sub
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::::revalSafe::reval
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
0 | 0 | 0 | 0s | 0s | Safe::::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
--- | --- | --- | --- | --- | ---
0 |  |  | 1 | 22µs | Profile data that couldn't be associated with a specific line: # spent 22µs making 1 call to Safe::BEGIN@70
1 | 1 | 45µs |  |  | package Safe;
2 |  |  |  |  |
3 | 2 | 206µs | 1 | 93µs | # spent 93µs within Safe::BEGIN@3 which was called: # once (93µs+0s) by Data::DPath::Context::BEGIN@23 at line 3 use 5.003_11; # spent 93µs making 1 call to Safe::BEGIN@3
4 | 2 | 416µs | 2 | 376µs | # spent 204µs (32+172) within Safe::BEGIN@4 which was called: # once (32µs+172µs) by Data::DPath::Context::BEGIN@23 at line 4 use Scalar::Util qw(reftype refaddr); # spent 204µs making 1 call to Safe::BEGIN@4 # spent 172µs making 1 call to Exporter::import
5 |  |  |  |  |
6 | 1 | 3µs |  |  | $Safe::VERSION = "2.33";
7 |  |  |  |  |
8 |  |  |  |  | # *** Don't declare any lexicals above this point ***
9 |  |  |  |  | #
10 |  |  |  |  | # This function should return a closure which contains an eval that can't
11 |  |  |  |  | # see any lexicals in scope (apart from __ExPr__ which is unavoidable)
12 |  |  |  |  |
13 |  |  |  |  | sub lexless_anon_sub {
14 |  |  |  |  | # $_[0] is package;
15 |  |  |  |  | # $_[1] is strict flag;
16 |  |  |  |  | my $__ExPr__ = $_[2]; # must be a lexical to create the closure that
17 |  |  |  |  | # can be used to pass the value into the safe
18 |  |  |  |  | # world
19 |  |  |  |  |
20 |  |  |  |  | # Create anon sub ref in root of compartment.
21 |  |  |  |  | # Uses a closure (on $__ExPr__) to pass in the code to be executed.
22 |  |  |  |  | # (eval on one line to keep line numbers as expected by caller)
23 |  |  |  |  | eval sprintf
24 |  |  |  |  | 'package %s; %s sub { @_=(); eval q[my $__ExPr__;] . $__ExPr__; }',
25 |  |  |  |  | $_[0], $_[1] ? 'use strict;' : '';
26 |  |  |  |  | }
27 |  |  |  |  |
28 | 2 | 92µs | 2 | 66µs | # spent 51µs (35+16) within Safe::BEGIN@28 which was called: # once (35µs+16µs) by Data::DPath::Context::BEGIN@23 at line 28 use strict; # spent 51µs making 1 call to Safe::BEGIN@28 # spent 16µs making 1 call to strict::import
29 | 2 | 100µs | 2 | 326µs | # spent 178µs (29+148) within Safe::BEGIN@29 which was called: # once (29µs+148µs) by Data::DPath::Context::BEGIN@23 at line 29 use Carp; # spent 178µs making 1 call to Safe::BEGIN@29 # spent 148µs making 1 call to Exporter::import
30 | 1 | 146µs |  |  | # spent 630µs (153+476) within Safe::BEGIN@30 which was called: # once (153µs+476µs) by Data::DPath::Context::BEGIN@23 at line 32 BEGIN { eval q{ # spent 341µs executing statements in string eval # includes 445µs spent executing 1 call to 1 sub defined therein.
31 |  |  |  |  | use Carp::Heavy;
32 | 1 | 71µs | 1 | 630µs | } } # spent 630µs making 1 call to Safe::BEGIN@30
33 |  |  |  |  |
34 | 2 | 434µs | 1 | 12.4ms | # spent 12.4ms (9.51+2.88) within Safe::BEGIN@34 which was called: # once (9.51ms+2.88ms) by Data::DPath::Context::BEGIN@23 at line 34 use B (); # spent 12.4ms making 1 call to Safe::BEGIN@34
35 |  |  |  |  | # spent 24µs within Safe::BEGIN@35 which was called: # once (24µs+0s) by Data::DPath::Context::BEGIN@23 at line 44 BEGIN {
36 | 2 | 275µs | 2 | 147µs | # spent 93µs (39+54) within Safe::BEGIN@36 which was called: # once (39µs+54µs) by Data::DPath::Context::BEGIN@23 at line 36 no strict 'refs'; # spent 93µs making 1 call to Safe::BEGIN@36 # spent 54µs making 1 call to strict::unimport
37 | 1 | 24µs |  |  | if (defined &B::sub_generation) {
38 |  |  |  |  | *sub_generation = \&B::sub_generation;
39 |  |  |  |  | }
40 |  |  |  |  | else {
41 |  |  |  |  | # fake sub generation changing for perls < 5.8.9
42 |  |  |  |  | my $sg; *sub_generation = sub { ++$sg };
43 |  |  |  |  | }
44 | 1 | 128µs | 1 | 24µs | } # spent 24µs making 1 call to Safe::BEGIN@35
45 |  |  |  |  |
46 |  |  | 1 | 1.06ms | # spent 19.7ms (3.21+16.4) within Safe::BEGIN@46 which was called: # once (3.21ms+16.4ms) by Data::DPath::Context::BEGIN@23 at line 50 use Opcode 1.01, qw( # spent 1.06ms making 1 call to Exporter::import
47 |  |  |  |  | opset opset_to_ops opmask_add
48 |  |  |  |  | empty_opset full_opset invert_opset verify_opset
49 |  |  |  |  | opdesc opcodes opmask define_optag opset_to_hex
50 | 2 | 2.28ms | 1 | 19.7ms | ); # spent 19.7ms making 1 call to Safe::BEGIN@46
51 |  |  |  |  |
52 | 1 | 8µs |  |  | *ops_to_opset = \&opset; # Temporary alias for old Penguins
53 |  |  |  |  |
54 |  |  |  |  | # Regular expressions and other unicode-aware code may need to call
55 |  |  |  |  | # utf8->SWASHNEW (via perl's utf8.c). That will fail unless we share the
56 |  |  |  |  | # SWASHNEW method.
57 |  |  |  |  | # Sadly we can't just add utf8::SWASHNEW to $default_share because perl's
58 |  |  |  |  | # utf8.c code does a fetchmethod on SWASHNEW to check if utf8.pm is loaded,
59 |  |  |  |  | # and sharing makes it look like the method exists.
60 |  |  |  |  | # The simplest and most robust fix is to ensure the utf8 module is loaded when
61 |  |  |  |  | # Safe is loaded. Then we can add utf8::SWASHNEW to $default_share.
62 | 1 | 848µs |  |  | require utf8;
63 |  |  |  |  | # we must ensure that utf8_heavy.pl, where SWASHNEW is defined, is loaded
64 |  |  |  |  | # but without depending on too much knowledge of that implementation detail.
65 |  |  |  |  | # This code (//i on a unicode string) should ensure utf8 is fully loaded
66 |  |  |  |  | # and also loads the ToFold SWASH, unless things change so that these
67 |  |  |  |  | # particular code points don't cause it to load.
68 |  |  |  |  | # (Swashes are cached internally by perl in PL_utf8_* variables
69 |  |  |  |  | # independent of being inside/outside of Safe. So once loaded they can be)
70 | 7 | 449µs | 5 | 148ms | # spent 22µs within Safe::BEGIN@70 which was called: # once (22µs+0s) by Safe::CORE:regcomp at line 0 do { my $a = pack('U',0x100); my $b = chr 0x101; utf8::upgrade $b; $a =~ /$b/i }; # spent 136ms making 1 call to Safe::CORE:regcomp # spent 12.0ms making 1 call to utf8::AUTOLOAD # spent 32µs making 1 call to Safe::CORE:pack # spent 26µs making 1 call to Safe::CORE:match # spent 8µs making 1 call to utf8::upgrade
71 |  |  |  |  | # now we can safely include utf8::SWASHNEW in $default_share defined below.
72 |  |  |  |  |
73 | 1 | 3µs |  |  | my $default_root = 0;
74 |  |  |  |  | # share *_ and functions defined in universal.c
75 |  |  |  |  | # Don't share stuff like *UNIVERSAL:: otherwise code from the
76 |  |  |  |  | # compartment can 0wn functions in UNIVERSAL
77 | 1 | 52µs |  |  | my $default_share = [qw[
78 |  |  |  |  | *_
79 |  |  |  |  | &PerlIO::get_layers
80 |  |  |  |  | &UNIVERSAL::isa
81 |  |  |  |  | &UNIVERSAL::can
82 |  |  |  |  | &UNIVERSAL::VERSION
83 |  |  |  |  | &utf8::is_utf8
84 |  |  |  |  | &utf8::valid
85 |  |  |  |  | &utf8::encode
86 |  |  |  |  | &utf8::decode
87 |  |  |  |  | &utf8::upgrade
88 |  |  |  |  | &utf8::downgrade
89 |  |  |  |  | &utf8::native_to_unicode
90 |  |  |  |  | &utf8::unicode_to_native
91 |  |  |  |  | &utf8::SWASHNEW
92 |  |  |  |  | $version::VERSION
93 |  |  |  |  | $version::CLASS
94 |  |  |  |  | $version::STRICT
95 |  |  |  |  | $version::LAX
96 |  |  |  |  | @version::ISA
97 |  |  |  |  | ], ($] < 5.010 && qw[
98 |  |  |  |  | &utf8::SWASHGET
99 |  |  |  |  | ]), ($] >= 5.008001 && qw[
100 |  |  |  |  | &Regexp::DESTROY
101 |  |  |  |  | ]), ($] >= 5.010 && qw[
102 |  |  |  |  | &re::is_regexp
103 |  |  |  |  | &re::regname
104 |  |  |  |  | &re::regnames
105 |  |  |  |  | &re::regnames_count
106 |  |  |  |  | &UNIVERSAL::DOES
107 |  |  |  |  | &version::()
108 |  |  |  |  | &version::new
109 |  |  |  |  | &version::(""
110 |  |  |  |  | &version::stringify
111 |  |  |  |  | &version::(0+
112 |  |  |  |  | &version::numify
113 |  |  |  |  | &version::normal
114 |  |  |  |  | &version::(cmp
115 |  |  |  |  | &version::(<=>
116 |  |  |  |  | &version::vcmp
117 |  |  |  |  | &version::(bool
118 |  |  |  |  | &version::boolean
119 |  |  |  |  | &version::(nomethod
120 |  |  |  |  | &version::noop
121 |  |  |  |  | &version::is_alpha
122 |  |  |  |  | &version::qv
123 |  |  |  |  | &version::vxs::declare
124 |  |  |  |  | &version::vxs::qv
125 |  |  |  |  | &version::vxs::_VERSION
126 |  |  |  |  | &version::vxs::stringify
127 |  |  |  |  | &version::vxs::new
128 |  |  |  |  | &version::vxs::parse
129 |  |  |  |  | &version::vxs::VCMP
130 |  |  |  |  | ]), ($] >= 5.011 && qw[
131 |  |  |  |  | &re::regexp_pattern
132 |  |  |  |  | ]), ($] >= 5.010 && $] < 5.014 && qw[
133 |  |  |  |  | &Tie::Hash::NamedCapture::FETCH
134 |  |  |  |  | &Tie::Hash::NamedCapture::STORE
135 |  |  |  |  | &Tie::Hash::NamedCapture::DELETE
136 |  |  |  |  | &Tie::Hash::NamedCapture::CLEAR
137 |  |  |  |  | &Tie::Hash::NamedCapture::EXISTS
138 |  |  |  |  | &Tie::Hash::NamedCapture::FIRSTKEY
139 |  |  |  |  | &Tie::Hash::NamedCapture::NEXTKEY
140 |  |  |  |  | &Tie::Hash::NamedCapture::SCALAR
141 |  |  |  |  | &Tie::Hash::NamedCapture::flags
142 |  |  |  |  | ])];
143 | 1 | 1µs |  |  | if (defined $Devel::Cover::VERSION) {
144 |  |  |  |  | push @$default_share, '&Devel::Cover::use_file';
145 |  |  |  |  | }
146 |  |  |  |  |
147 |  |  |  |  | # spent 2.87ms (112µs+2.76) within Safe::new which was called: # once (112µs+2.76ms) by Data::DPath::Context::BEGIN@29 at line 39 of Data/DPath/Context.pm sub new {
148 | 9 | 120µs |  |  | my($class, $root, $mask) = @_;
149 |  |  |  |  | my $obj = {};
150 |  |  |  |  | bless $obj, $class;
151 |  |  |  |  |
152 | 2 | 15µs |  |  | if (defined($root)) {
153 |  |  |  |  | croak "Can't use \"$root\" as root name"
154 |  |  |  |  | if $root =~ /^main\b/ or $root !~ /^\w[:\w]*$/;
155 |  |  |  |  | $obj->{Root} = $root;
156 |  |  |  |  | $obj->{Erase} = 0;
157 |  |  |  |  | }
158 |  |  |  |  | else {
159 |  |  |  |  | $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 |  |  | 1 | 57µs | $obj->permit_only(':default'); # spent 57µs making 1 call to Safe::permit_only
167 |  |  |  |  |
168 |  |  |  |  | # We must share $_ and @_ with the compartment or else ops such
169 |  |  |  |  | # as split, length and so on won't default to $_ properly, nor
170 |  |  |  |  | # will passing argument to subroutines work (via @_). In fact,
171 |  |  |  |  | # for reasons I don't completely understand, we need to share
172 |  |  |  |  | # the whole glob *_ rather than $_ and @_ separately, otherwise
173 |  |  |  |  | # @_ in non default packages within the compartment don't work.
174 |  |  | 1 | 2.67ms | $obj->share_from('main', $default_share); # spent 2.67ms making 1 call to Safe::share_from
175 |  |  |  |  |
176 |  |  | 1 | 27µs | Opcode::_safe_pkg_prep($obj->{Root}) if($Opcode::VERSION > 1.04); # spent 27µs making 1 call to Opcode::_safe_pkg_prep
177 |  |  |  |  |
178 |  |  |  |  | return $obj;
179 |  |  |  |  | }
180 |  |  |  |  |
181 |  |  |  |  | sub DESTROY {
182 |  |  |  |  | my $obj = shift;
183 |  |  |  |  | $obj->erase('DESTROY') if $obj->{Erase};
184 |  |  |  |  | }
185 |  |  |  |  |
186 |  |  |  |  | sub erase {
187 |  |  |  |  | my ($obj, $action) = @_;
188 |  |  |  |  | my $pkg = $obj->root();
189 |  |  |  |  | my ($stem, $leaf);
190 |  |  |  |  |
191 | 2 | 1.95ms | 2 | 188µs | # spent 119µs (50+69) within Safe::BEGIN@191 which was called: # once (50µs+69µs) by Data::DPath::Context::BEGIN@23 at line 191 no strict 'refs'; # spent 119µs making 1 call to Safe::BEGIN@191 # spent 69µs making 1 call to strict::unimport
192 |  |  |  |  | $pkg = "main::$pkg\::"; # expand to full symbol table name
193 |  |  |  |  | ($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
194 |  |  |  |  |
195 |  |  |  |  | # The 'my $foo' is needed! Without it you get an
196 |  |  |  |  | # 'Attempt to free unreferenced scalar' warning!
197 |  |  |  |  | my $stem_symtab = *{$stem}{HASH};
198 |  |  |  |  |
199 |  |  |  |  | #warn "erase($pkg) stem=$stem, leaf=$leaf";
200 |  |  |  |  | #warn " stem_symtab hash ".scalar(%$stem_symtab)."\n";
201 |  |  |  |  | # ", join(', ', %$stem_symtab),"\n";
202 |  |  |  |  |
203 |  |  |  |  | # delete $stem_symtab->{$leaf};
204 |  |  |  |  |
205 |  |  |  |  | my $leaf_glob = $stem_symtab->{$leaf};
206 |  |  |  |  | my $leaf_symtab = *{$leaf_glob}{HASH};
207 |  |  |  |  | # warn " leaf_symtab ", join(', ', %$leaf_symtab),"\n";
208 |  |  |  |  | %$leaf_symtab = ();
209 |  |  |  |  | #delete $leaf_symtab->{'__ANON__'};
210 |  |  |  |  | #delete $leaf_symtab->{'foo'};
211 |  |  |  |  | #delete $leaf_symtab->{'main::'};
212 |  |  |  |  | # my $foo = undef ${"$stem\::"}{"$leaf\::"};
213 |  |  |  |  |
214 |  |  |  |  | if ($action and $action eq 'DESTROY') {
215 |  |  |  |  | delete $stem_symtab->{$leaf};
216 |  |  |  |  | } else {
217 |  |  |  |  | $obj->share_from('main', $default_share);
218 |  |  |  |  | }
219 |  |  |  |  | 1;
220 |  |  |  |  | }
221 |  |  |  |  |
222 |  |  |  |  |
223 |  |  |  |  | sub reinit {
224 |  |  |  |  | my $obj= shift;
225 |  |  |  |  | $obj->erase;
226 |  |  |  |  | $obj->share_redo;
227 |  |  |  |  | }
228 |  |  |  |  |
229 |  |  |  |  | # spent 23µs within Safe::root which was called 2 times, avg 11µs/call: # 2 times (23µs+0s) by Safe::share_from at line 283, avg 11µs/call sub root {
230 | 6 | 36µs |  |  | my $obj = shift;
231 |  |  |  |  | croak("Safe root method now read-only") if @_;
232 |  |  |  |  | return $obj->{Root};
233 |  |  |  |  | }
234 |  |  |  |  |
235 |  |  |  |  |
236 |  |  |  |  | sub mask {
237 |  |  |  |  | my $obj = shift;
238 |  |  |  |  | return $obj->{Mask} unless @_;
239 |  |  |  |  | $obj->deny_only(@_);
240 |  |  |  |  | }
241 |  |  |  |  |
242 |  |  |  |  | # v1 compatibility methods
243 |  |  |  |  | sub trap { shift->deny(@_) }
244 |  |  |  |  | sub untrap { shift->permit(@_) }
245 |  |  |  |  |
246 |  |  |  |  | sub deny {
247 |  |  |  |  | my $obj = shift;
248 |  |  |  |  | $obj->{Mask} |= opset(@_);
249 |  |  |  |  | }
250 |  |  |  |  | sub deny_only {
251 |  |  |  |  | my $obj = shift;
252 |  |  |  |  | $obj->{Mask} = opset(@_);
253 |  |  |  |  | }
254 |  |  |  |  |
255 |  |  |  |  | # spent 44µs (31+12) within Safe::permit which was called: # once (31µs+12µs) by Data::DPath::Context::BEGIN@29 at line 40 of Data/DPath/Context.pm sub permit {
256 | 2 | 49µs |  |  | my $obj = shift;
257 |  |  |  |  | # XXX needs testing
258 |  |  | 2 | 12µs | $obj->{Mask} &= invert_opset opset(@_); # spent 8µs making 1 call to Opcode::opset # spent 5µs making 1 call to Opcode::invert_opset
259 |  |  |  |  | }
260 |  |  |  |  | # spent 57µs (41+16) within Safe::permit_only which was called: # once (41µs+16µs) by Safe::new at line 166 sub permit_only {
261 | 2 | 62µs |  |  | my $obj = shift;
262 |  |  | 2 | 16µs | $obj->{Mask} = invert_opset opset(@_); # spent 10µs making 1 call to Opcode::opset # spent 6µs making 1 call to Opcode::invert_opset
263 |  |  |  |  | }
264 |  |  |  |  |
265 |  |  |  |  |
266 |  |  |  |  | sub dump_mask {
267 |  |  |  |  | my $obj = shift;
268 |  |  |  |  | print opset_to_hex($obj->{Mask}),"\n";
269 |  |  |  |  | }
270 |  |  |  |  |
271 |  |  |  |  |
272 |  |  |  |  | # spent 418µs (31+387) within Safe::share which was called: # once (31µs+387µs) by Data::DPath::Context::BEGIN@29 at line 42 of Data/DPath/Context.pm sub share {
273 | 2 | 33µs |  |  | my($obj, @vars) = @_;
274 |  |  | 1 | 386µs | $obj->share_from(scalar(caller), \@vars); # spent 386µs making 1 call to Safe::share_from
275 |  |  |  |  | }
276 |  |  |  |  |
277 |  |  |  |  |
278 |  |  |  |  | # spent 3.06ms (2.61+448µs) within Safe::share_from which was called 2 times, avg 1.53ms/call: # once (2.29ms+382µs) by Safe::new at line 174 # once (320µs+66µs) by Safe::share at line 274 sub share_from {
279 | 20 | 99µs |  |  | my $obj = shift;
280 |  |  |  |  | my $pkg = shift;
281 |  |  |  |  | my $vars = shift;
282 |  |  |  |  | my $no_record = shift || 0;
283 |  |  | 2 | 23µs | my $root = $obj->root(); # spent 23µs making 2 calls to Safe::root, avg 11µs/call
284 |  |  |  |  | croak("vars not an array ref") unless ref $vars eq 'ARRAY';
285 | 2 | 1.56ms | 2 | 129µs | # spent 81µs (32+48) within Safe::BEGIN@285 which was called: # once (32µs+48µs) by Data::DPath::Context::BEGIN@23 at line 285 no strict 'refs'; # spent 81µs making 1 call to Safe::BEGIN@285 # spent 48µs making 1 call to strict::unimport
286 |  |  |  |  | # Check that 'from' package actually exists
287 |  |  |  |  | croak("Package \"$pkg\" does not exist")
288 |  |  |  |  | unless keys %{"$pkg\::"};
289 |  |  |  |  | my $arg;
290 |  |  |  |  | foreach $arg (@$vars) {
291 |  |  |  |  | # catch some $safe->share($var) errors:
292 | 177 | 1.10ms |  |  | my ($var, $type);
293 |  |  | 59 | 269µs | $type = $1 if ($var = $arg) =~ s/^(\W)//; # spent 269µs making 59 calls to Safe::CORE:subst, avg 5µs/call
294 |  |  |  |  | # warn "share_from $pkg $type $var";
295 |  |  |  |  | for (1..2) { # assign twice to avoid any 'used once' warnings
296 |  |  |  |  | *{$root."::$var"} = (!$type) ? \&{$pkg."::$var"}
297 |  |  |  |  | : ($type eq '&') ? \&{$pkg."::$var"}
298 |  |  |  |  | : ($type eq '$') ? \${$pkg."::$var"}
299 |  |  |  |  | : ($type eq '@') ? \@{$pkg."::$var"}
300 |  |  |  |  | : ($type eq '%') ? \%{$pkg."::$var"}
301 | 118 | 1.67ms |  |  | : ($type eq '*') ? *{$pkg."::$var"}
302 |  |  |  |  | : croak(qq(Can't share "$type$var" of unknown type));
303 |  |  |  |  | }
304 |  |  |  |  | }
305 |  |  | 2 | 156µs | $obj->share_record($pkg, $vars) unless $no_record or !$vars; # spent 156µs making 2 calls to Safe::share_record, avg 78µs/call
306 |  |  |  |  | }
307 |  |  |  |  |
308 |  |  |  |  |
309 |  |  |  |  | # spent 156µs within Safe::share_record which was called 2 times, avg 78µs/call: # 2 times (156µs+0s) by Safe::share_from at line 305, avg 78µs/call sub share_record {
310 | 10 | 170µs |  |  | 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 |  |  |  |  |
319 |  |  |  |  | sub share_redo {
320 |  |  |  |  | my $obj = shift;
321 |  |  |  |  | my $shares = \%{$obj->{Shares} ||= {}};
322 |  |  |  |  | my($var, $pkg);
323 |  |  |  |  | while(($var, $pkg) = each %$shares) {
324 |  |  |  |  | # warn "share_redo $pkg\:: $var";
325 |  |  |  |  | $obj->share_from($pkg, [ $var ], 1);
326 |  |  |  |  | }
327 |  |  |  |  | }
328 |  |  |  |  |
329 |  |  |  |  |
330 |  |  |  |  | sub share_forget {
331 |  |  |  |  | delete shift->{Shares};
332 |  |  |  |  | }
333 |  |  |  |  |
334 |  |  |  |  |
335 |  |  |  |  | sub varglob {
336 |  |  |  |  | my ($obj, $var) = @_;
337 | 2 | 256µs | 2 | 135µs | # spent 85µs (34+50) within Safe::BEGIN@337 which was called: # once (34µs+50µs) by Data::DPath::Context::BEGIN@23 at line 337 no strict 'refs'; # spent 85µs making 1 call to Safe::BEGIN@337 # spent 50µs making 1 call to strict::unimport
338 |  |  |  |  | return *{$obj->root()."::$var"};
339 |  |  |  |  | }
340 |  |  |  |  |
341 |  |  |  |  | sub _clean_stash {
342 |  |  |  |  | my ($root, $saved_refs) = @_;
343 |  |  |  |  | $saved_refs ||= [];
344 | 2 | 2.67ms | 2 | 94µs | # spent 60µs (25+34) within Safe::BEGIN@344 which was called: # once (25µs+34µs) by Data::DPath::Context::BEGIN@23 at line 344 no strict 'refs'; # spent 60µs making 1 call to Safe::BEGIN@344 # spent 34µs making 1 call to strict::unimport
345 |  |  |  |  | foreach my $hook (qw(DESTROY AUTOLOAD), grep /^\(/, keys %$root) {
346 |  |  |  |  | push @$saved_refs, \*{$root.$hook};
347 |  |  |  |  | delete ${$root}{$hook};
348 |  |  |  |  | }
349 |  |  |  |  |
350 |  |  |  |  | for (grep /::$/, keys %$root) {
351 |  |  |  |  | next if \%{$root.$_} eq \%$root;
352 |  |  |  |  | _clean_stash($root.$_, $saved_refs);
353 |  |  |  |  | }
354 |  |  |  |  | }
355 |  |  |  |  |
356 |  |  |  |  | sub reval {
357 |  |  |  |  | my ($obj, $expr, $strict) = @_;
358 |  |  |  |  | my $root = $obj->{Root};
359 |  |  |  |  |
360 |  |  |  |  | my $evalsub = lexless_anon_sub($root, $strict, $expr);
361 |  |  |  |  | # propagate context
362 |  |  |  |  | my $sg = sub_generation();
363 |  |  |  |  | my @subret = (wantarray)
364 |  |  |  |  | ? Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub)
365 |  |  |  |  | : scalar Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub);
366 |  |  |  |  | _clean_stash($root.'::') if $sg != sub_generation();
367 |  |  |  |  | $obj->wrap_code_refs_within(@subret);
368 |  |  |  |  | return (wantarray) ? @subret : $subret[0];
369 |  |  |  |  | }
370 |  |  |  |  |
371 | 1 | 1µs |  |  | my %OID;
372 |  |  |  |  |
373 |  |  |  |  | sub wrap_code_refs_within {
374 |  |  |  |  | my $obj = shift;
375 |  |  |  |  |
376 |  |  |  |  | %OID = ();
377 |  |  |  |  | $obj->_find_code_refs('wrap_code_ref', @_);
378 |  |  |  |  | }
379 |  |  |  |  |
380 |  |  |  |  |
381 |  |  |  |  | sub _find_code_refs {
382 |  |  |  |  | my $obj = shift;
383 |  |  |  |  | my $visitor = shift;
384 |  |  |  |  |
385 |  |  |  |  | for my $item (@_) {
386 |  |  |  |  | my $reftype = $item && reftype $item
387 |  |  |  |  | or next;
388 |  |  |  |  |
389 |  |  |  |  | # skip references already seen
390 |  |  |  |  | next if ++$OID{refaddr $item} > 1;
391 |  |  |  |  |
392 |  |  |  |  | if ($reftype eq 'ARRAY') {
393 |  |  |  |  | $obj->_find_code_refs($visitor, @$item);
394 |  |  |  |  | }
395 |  |  |  |  | elsif ($reftype eq 'HASH') {
396 |  |  |  |  | $obj->_find_code_refs($visitor, values %$item);
397 |  |  |  |  | }
398 |  |  |  |  | # XXX GLOBs?
399 |  |  |  |  | elsif ($reftype eq 'CODE') {
400 |  |  |  |  | $item = $obj->$visitor($item);
401 |  |  |  |  | }
402 |  |  |  |  | }
403 |  |  |  |  | }
404 |  |  |  |  |
405 |  |  |  |  |
406 |  |  |  |  | sub wrap_code_ref {
407 |  |  |  |  | my ($obj, $sub) = @_;
408 |  |  |  |  |
409 |  |  |  |  | # wrap code ref $sub with _safe_call_sv so that, when called, the
410 |  |  |  |  | # execution will happen with the compartment fully 'in effect'.
411 |  |  |  |  |
412 |  |  |  |  | croak "Not a CODE reference"
413 |  |  |  |  | if reftype $sub ne 'CODE';
414 |  |  |  |  |
415 |  |  |  |  | my $ret = sub {
416 |  |  |  |  | my @args = @_; # lexical to close over
417 |  |  |  |  | my $sub_with_args = sub { $sub->(@args) };
418 |  |  |  |  |
419 |  |  |  |  | my @subret;
420 |  |  |  |  | my $error;
421 |  |  |  |  | do {
422 |  |  |  |  | local $@; # needed due to perl_call_sv(sv, G_EVAL|G_KEEPERR)
423 |  |  |  |  | my $sg = sub_generation();
424 |  |  |  |  | @subret = (wantarray)
425 |  |  |  |  | ? Opcode::_safe_call_sv($obj->{Root}, $obj->{Mask}, $sub_with_args)
426 |  |  |  |  | : scalar Opcode::_safe_call_sv($obj->{Root}, $obj->{Mask}, $sub_with_args);
427 |  |  |  |  | $error = $@;
428 |  |  |  |  | _clean_stash($obj->{Root}.'::') if $sg != sub_generation();
429 |  |  |  |  | };
430 |  |  |  |  | if ($error) { # rethrow exception
431 |  |  |  |  | $error =~ s/\t\(in cleanup\) //; # prefix added by G_KEEPERR
432 |  |  |  |  | die $error;
433 |  |  |  |  | }
434 |  |  |  |  | return (wantarray) ? @subret : $subret[0];
435 |  |  |  |  | };
436 |  |  |  |  |
437 |  |  |  |  | return $ret;
438 |  |  |  |  | }
439 |  |  |  |  |
440 |  |  |  |  |
441 |  |  |  |  | sub rdo {
442 |  |  |  |  | my ($obj, $file) = @_;
443 |  |  |  |  | my $root = $obj->{Root};
444 |  |  |  |  |
445 |  |  |  |  | my $sg = sub_generation();
446 |  |  |  |  | my $evalsub = eval
447 |  |  |  |  | sprintf('package %s; sub { @_ = (); do $file }', $root);
448 |  |  |  |  | my @subret = (wantarray)
449 |  |  |  |  | ? Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub)
450 |  |  |  |  | : scalar Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub);
451 |  |  |  |  | _clean_stash($root.'::') if $sg != sub_generation();
452 |  |  |  |  | $obj->wrap_code_refs_within(@subret);
453 |  |  |  |  | return (wantarray) ? @subret : $subret[0];
454 |  |  |  |  | }
455 |  |  |  |  |
456 |  |  |  |  |
457 | 1 | 83µs |  |  | 1;
458 |  |  |  |  |
459 |  |  |  |  | __END__
|  |  |  |  | # spent 26µs within Safe::CORE:match which was called: # once (26µs+0s) by Data::DPath::Context::BEGIN@23 at line 70 sub Safe::CORE:match; # opcode
|  |  |  |  | # spent 32µs within Safe::CORE:pack which was called: # once (32µs+0s) by Data::DPath::Context::BEGIN@23 at line 70 sub Safe::CORE:pack; # opcode
|  |  |  |  | # spent 136ms (362µs+136) within Safe::CORE:regcomp which was called: # once (362µs+136ms) by Data::DPath::Context::BEGIN@23 at line 70 sub Safe::CORE:regcomp; # opcode
|  |  |  |  | # spent 269µs within Safe::CORE:subst which was called 59 times, avg 5µs/call: # 59 times (269µs+0s) by Safe::share_from at line 293, avg 5µs/call sub Safe::CORE:subst; # opcode