| Filename | /home/ss5/perl5/perlbrew/perls/tapper-perl/lib/5.16.3/Safe.pm |
| Statements | Executed 590 statements in 5.04ms |
| Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
|---|---|---|---|---|---|
| 1 | 1 | 1 | 2.38ms | 3.06ms | Safe::BEGIN@34 |
| 16 | 2 | 1 | 876µs | 938µs | Safe::_clean_stash (recurses: max depth 2, inclusive time 764µs) |
| 1 | 1 | 1 | 815µs | 4.47ms | Safe::BEGIN@46 |
| 2 | 2 | 1 | 648µs | 746µs | Safe::share_from |
| 2 | 1 | 1 | 175µs | 175µs | Safe::lexless_anon_sub |
| 1 | 1 | 1 | 128µs | 4.79ms | Safe::CORE:regcomp (opcode) |
| 2 | 1 | 1 | 93µs | 1.44ms | Safe::reval |
| 257 | 3 | 1 | 66µs | 66µs | Safe::CORE:match (opcode) |
| 59 | 1 | 1 | 54µs | 54µs | Safe::CORE:subst (opcode) |
| 1 | 1 | 1 | 40µs | 159µs | Safe::BEGIN@30 |
| 2 | 1 | 1 | 39µs | 39µs | Safe::share_record |
| 1 | 1 | 1 | 28µs | 697µs | Safe::new |
| 2 | 1 | 1 | 21µs | 45µs | Safe::wrap_code_refs_within |
| 2 | 1 | 1 | 21µs | 24µs | Safe::_find_code_refs |
| 1 | 1 | 1 | 20µs | 20µs | Safe::BEGIN@3 |
| 1 | 1 | 1 | 17µs | 37µs | Safe::BEGIN@36 |
| 1 | 1 | 1 | 13µs | 30µs | Safe::BEGIN@188 |
| 1 | 1 | 1 | 12µs | 15µs | Safe::permit_only |
| 1 | 1 | 1 | 12µs | 26µs | Safe::BEGIN@334 |
| 1 | 1 | 1 | 11µs | 46µs | Safe::BEGIN@4 |
| 1 | 1 | 1 | 11µs | 11µs | Safe::CORE:pack (opcode) |
| 1 | 1 | 1 | 10µs | 24µs | Safe::BEGIN@282 |
| 1 | 1 | 1 | 10µs | 47µs | Safe::BEGIN@29 |
| 1 | 1 | 1 | 10µs | 10µs | Safe::BEGIN@35 |
| 1 | 1 | 1 | 10µs | 24µs | Safe::BEGIN@28 |
| 1 | 1 | 1 | 9µs | 20µs | Safe::BEGIN@341 |
| 1 | 1 | 1 | 9µs | 106µs | Safe::share |
| 1 | 1 | 1 | 8µs | 11µs | Safe::permit |
| 2 | 1 | 1 | 4µs | 4µs | Safe::root |
| 0 | 0 | 0 | 0s | 0s | Safe::DESTROY |
| 0 | 0 | 0 | 0s | 0s | Safe::__ANON__[:414] |
| 0 | 0 | 0 | 0s | 0s | Safe::__ANON__[:42] |
| 0 | 0 | 0 | 0s | 0s | Safe::__ANON__[:432] |
| 0 | 0 | 0 | 0s | 0s | Safe::deny |
| 0 | 0 | 0 | 0s | 0s | Safe::deny_only |
| 0 | 0 | 0 | 0s | 0s | Safe::dump_mask |
| 0 | 0 | 0 | 0s | 0s | Safe::erase |
| 0 | 0 | 0 | 0s | 0s | Safe::mask |
| 0 | 0 | 0 | 0s | 0s | Safe::rdo |
| 0 | 0 | 0 | 0s | 0s | Safe::reinit |
| 0 | 0 | 0 | 0s | 0s | Safe::share_forget |
| 0 | 0 | 0 | 0s | 0s | Safe::share_redo |
| 0 | 0 | 0 | 0s | 0s | Safe::trap |
| 0 | 0 | 0 | 0s | 0s | Safe::untrap |
| 0 | 0 | 0 | 0s | 0s | Safe::varglob |
| 0 | 0 | 0 | 0s | 0s | Safe::wrap_code_ref |
| 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 # 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 # 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 | ||||
| 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 # 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 # 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 # 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 # 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 | ||||
| 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 # 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 # 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 | ||||
| 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 # 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 | ||||
| 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 | ||||
| 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 | ||||
| 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 | ||||
| 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 | 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 # 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 | ||||
| 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 # 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 | 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 # 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 | ||||
| 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 | ||||
| 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 | ||||
| 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__ | ||||
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 | |||||
# 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 | |||||
# 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 |