| Filename | /home/ss5/perl5/perlbrew/perls/tapper-perl/lib/5.16.3/Safe.pm |
| Statements | Executed 384 statements in 2.55ms |
| Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
|---|---|---|---|---|---|
| 1 | 1 | 1 | 1.44ms | 1.95ms | Safe::BEGIN@34 |
| 1 | 1 | 1 | 806µs | 2.97ms | Safe::BEGIN@46 |
| 2 | 2 | 1 | 488µs | 561µs | Safe::share_from |
| 1 | 1 | 1 | 86µs | 3.21ms | Safe::CORE:regcomp (opcode) |
| 1 | 1 | 1 | 60µs | 532µs | Safe::new |
| 59 | 1 | 1 | 37µs | 37µs | Safe::CORE:subst (opcode) |
| 2 | 1 | 1 | 32µs | 32µs | Safe::share_record |
| 1 | 1 | 1 | 27µs | 107µs | Safe::BEGIN@30 |
| 1 | 1 | 1 | 17µs | 17µs | Safe::BEGIN@3 |
| 1 | 1 | 1 | 10µs | 24µs | Safe::BEGIN@188 |
| 1 | 1 | 1 | 10µs | 13µs | Safe::permit |
| 1 | 1 | 1 | 10µs | 118µs | Safe::share |
| 1 | 1 | 1 | 9µs | 18µs | Safe::BEGIN@36 |
| 1 | 1 | 1 | 8µs | 11µs | Safe::permit_only |
| 1 | 1 | 1 | 8µs | 20µs | Safe::BEGIN@28 |
| 1 | 1 | 1 | 8µs | 8µs | Safe::CORE:pack (opcode) |
| 1 | 1 | 1 | 8µs | 33µs | Safe::BEGIN@4 |
| 1 | 1 | 1 | 7µs | 16µs | Safe::BEGIN@282 |
| 1 | 1 | 1 | 7µs | 16µs | Safe::BEGIN@334 |
| 1 | 1 | 1 | 7µs | 14µs | Safe::BEGIN@341 |
| 1 | 1 | 1 | 6µs | 33µs | Safe::BEGIN@29 |
| 1 | 1 | 1 | 4µs | 4µs | Safe::BEGIN@35 |
| 2 | 1 | 1 | 4µs | 4µs | Safe::root |
| 1 | 1 | 1 | 3µs | 3µs | Safe::CORE:match (opcode) |
| 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::_clean_stash |
| 0 | 0 | 0 | 0s | 0s | Safe::_find_code_refs |
| 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::lexless_anon_sub |
| 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::reval |
| 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 |
| 0 | 0 | 0 | 0s | 0s | Safe::wrap_code_refs_within |
| Line | State ments |
Time on line |
Calls | Time in subs |
Code |
|---|---|---|---|---|---|
| 1 | package Safe; | ||||
| 2 | |||||
| 3 | 2 | 42µs | 1 | 17µs | # spent 17µs within Safe::BEGIN@3 which was called:
# once (17µs+0s) by Data::DPath::Context::BEGIN@23 at line 3 # spent 17µs making 1 call to Safe::BEGIN@3 |
| 4 | 2 | 60µs | 2 | 59µs | # spent 33µs (8+26) within Safe::BEGIN@4 which was called:
# once (8µs+26µs) by Data::DPath::Context::BEGIN@23 at line 4 # spent 33µs making 1 call to Safe::BEGIN@4
# spent 26µs making 1 call to Exporter::import |
| 5 | |||||
| 6 | 1 | 600ns | $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 | 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 | 18µs | 2 | 32µs | # spent 20µs (8+12) within Safe::BEGIN@28 which was called:
# once (8µs+12µs) by Data::DPath::Context::BEGIN@23 at line 28 # spent 20µs making 1 call to Safe::BEGIN@28
# spent 12µs making 1 call to strict::import |
| 29 | 2 | 20µs | 2 | 59µs | # spent 33µs (6+26) within Safe::BEGIN@29 which was called:
# once (6µs+26µs) by Data::DPath::Context::BEGIN@23 at line 29 # spent 33µs making 1 call to Safe::BEGIN@29
# spent 26µs making 1 call to Exporter::import |
| 30 | 1 | 23µs | # spent 107µs (27+80) within Safe::BEGIN@30 which was called:
# once (27µs+80µs) by Data::DPath::Context::BEGIN@23 at line 32 # spent 59µs executing statements in string eval # includes 75µs spent executing 1 call to 1 sub defined therein. | ||
| 31 | use Carp::Heavy; | ||||
| 32 | 1 | 13µs | 1 | 107µs | } } # spent 107µs making 1 call to Safe::BEGIN@30 |
| 33 | |||||
| 34 | 2 | 69µs | 1 | 1.95ms | # spent 1.95ms (1.44+516µs) within Safe::BEGIN@34 which was called:
# once (1.44ms+516µs) by Data::DPath::Context::BEGIN@23 at line 34 # spent 1.95ms making 1 call to Safe::BEGIN@34 |
| 35 | # spent 4µs within Safe::BEGIN@35 which was called:
# once (4µs+0s) by Data::DPath::Context::BEGIN@23 at line 44 | ||||
| 36 | 2 | 48µs | 2 | 26µs | # spent 18µs (9+9) within Safe::BEGIN@36 which was called:
# once (9µs+9µs) by Data::DPath::Context::BEGIN@23 at line 36 # spent 18µs making 1 call to Safe::BEGIN@36
# spent 8µs making 1 call to strict::unimport |
| 37 | 1 | 4µ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 | 23µs | 1 | 4µs | } # spent 4µs making 1 call to Safe::BEGIN@35 |
| 45 | |||||
| 46 | 1 | 11µs | 1 | 199µs | # spent 2.97ms (806µs+2.17) within Safe::BEGIN@46 which was called:
# once (806µs+2.17ms) by Data::DPath::Context::BEGIN@23 at line 50 # spent 199µ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 | 353µs | 1 | 2.97ms | ); # spent 2.97ms making 1 call to Safe::BEGIN@46 |
| 51 | |||||
| 52 | 1 | 1µ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 | 500ns | 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 | 114µs | 5 | 6.34ms | do { my $a = pack('U',0x100); my $b = chr 0x101; utf8::upgrade $b; $a =~ /$b/i }; # spent 3.21ms making 1 call to Safe::CORE:regcomp
# spent 3.12ms making 1 call to utf8::SWASHNEW
# spent 8µs making 1 call to Safe::CORE:pack
# spent 3µs making 1 call to Safe::CORE:match
# spent 1µs making 1 call to utf8::upgrade |
| 71 | # now we can safely include utf8::SWASHNEW in $default_share defined below. | ||||
| 72 | |||||
| 73 | 1 | 500ns | 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 | 9µ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 532µs (60+472) within Safe::new which was called:
# once (60µs+472µs) by Data::DPath::Context::BEGIN@29 at line 39 of Data/DPath/Context.pm | ||||
| 145 | 1 | 900ns | my($class, $root, $mask) = @_; | ||
| 146 | 1 | 400ns | my $obj = {}; | ||
| 147 | 1 | 2µs | bless $obj, $class; | ||
| 148 | |||||
| 149 | 1 | 400ns | 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 | 2µs | $obj->{Root} = "Safe::Root".$default_root++; | ||
| 157 | 1 | 300ns | $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 | 100ns | croak "Mask parameter to new no longer supported" if defined $mask; | ||
| 163 | 1 | 1µs | 1 | 11µs | $obj->permit_only(':default'); # spent 11µ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 | 2µs | 1 | 453µs | $obj->share_from('main', $default_share); # spent 453µs making 1 call to Safe::share_from |
| 172 | |||||
| 173 | 1 | 21µs | 1 | 8µs | Opcode::_safe_pkg_prep($obj->{Root}) if($Opcode::VERSION > 1.04); # spent 8µs making 1 call to Opcode::_safe_pkg_prep |
| 174 | |||||
| 175 | 1 | 5µ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 | 316µs | 2 | 38µs | # spent 24µs (10+14) within Safe::BEGIN@188 which was called:
# once (10µs+14µs) by Data::DPath::Context::BEGIN@23 at line 188 # spent 24µs making 1 call to Safe::BEGIN@188
# spent 14µ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 | 600ns | croak("Safe root method now read-only") if @_; | ||
| 229 | 2 | 6µ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 13µs (10+3) within Safe::permit which was called:
# once (10µs+3µs) by Data::DPath::Context::BEGIN@29 at line 40 of Data/DPath/Context.pm | ||||
| 253 | 1 | 400ns | my $obj = shift; | ||
| 254 | # XXX needs testing | ||||
| 255 | 1 | 14µ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 |
| 256 | } | ||||
| 257 | # spent 11µs (8+3) within Safe::permit_only which was called:
# once (8µs+3µs) by Safe::new at line 163 | ||||
| 258 | 1 | 400ns | my $obj = shift; | ||
| 259 | 1 | 13µ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 118µs (10+108) within Safe::share which was called:
# once (10µs+108µs) by Data::DPath::Context::BEGIN@29 at line 42 of Data/DPath/Context.pm | ||||
| 270 | 1 | 3µs | my($obj, @vars) = @_; | ||
| 271 | 1 | 6µs | 1 | 108µs | $obj->share_from(scalar(caller), \@vars); # spent 108µs making 1 call to Safe::share_from |
| 272 | } | ||||
| 273 | |||||
| 274 | |||||
| 275 | sub share_from { | ||||
| 276 | 2 | 600ns | my $obj = shift; | ||
| 277 | 2 | 500ns | my $pkg = shift; | ||
| 278 | 2 | 200ns | my $vars = shift; | ||
| 279 | 2 | 1µs | 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 | 1µs | croak("vars not an array ref") unless ref $vars eq 'ARRAY'; | ||
| 282 | 2 | 256µs | 2 | 25µs | # spent 16µs (7+9) within Safe::BEGIN@282 which was called:
# once (7µs+9µs) by Data::DPath::Context::BEGIN@23 at line 282 # spent 16µs making 1 call to Safe::BEGIN@282
# spent 9µ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 | 200ns | my $arg; | ||
| 287 | 2 | 1µs | foreach $arg (@$vars) { | ||
| 288 | # catch some $safe->share($var) errors: | ||||
| 289 | 59 | 8µs | my ($var, $type); | ||
| 290 | 59 | 150µs | 59 | 37µs | $type = $1 if ($var = $arg) =~ s/^(\W)//; # spent 37µs making 59 calls to Safe::CORE:subst, avg 631ns/call |
| 291 | # warn "share_from $pkg $type $var"; | ||||
| 292 | 59 | 43µ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 | 299µs | : ($type eq '*') ? *{$pkg."::$var"} | ||
| 299 | : croak(qq(Can't share "$type$var" of unknown type)); | ||||
| 300 | } | ||||
| 301 | } | ||||
| 302 | 2 | 42µs | 2 | 32µs | $obj->share_record($pkg, $vars) unless $no_record or !$vars; # spent 32µs making 2 calls to Safe::share_record, avg 16µs/call |
| 303 | } | ||||
| 304 | |||||
| 305 | |||||
| 306 | # spent 32µs within Safe::share_record which was called 2 times, avg 16µs/call:
# 2 times (32µs+0s) by Safe::share_from at line 302, avg 16µs/call | ||||
| 307 | 2 | 500ns | my $obj = shift; | ||
| 308 | 2 | 500ns | my $pkg = shift; | ||
| 309 | 2 | 200ns | my $vars = shift; | ||
| 310 | 2 | 2µs | my $shares = \%{$obj->{Shares} ||= {}}; | ||
| 311 | # Record shares using keys of $obj->{Shares}. See reinit. | ||||
| 312 | 2 | 32µ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 | 47µs | 2 | 25µs | # spent 16µs (7+9) within Safe::BEGIN@334 which was called:
# once (7µs+9µs) by Data::DPath::Context::BEGIN@23 at line 334 # spent 16µs making 1 call to Safe::BEGIN@334
# spent 9µs making 1 call to strict::unimport |
| 335 | return *{$obj->root()."::$var"}; | ||||
| 336 | } | ||||
| 337 | |||||
| 338 | sub _clean_stash { | ||||
| 339 | my ($root, $saved_refs) = @_; | ||||
| 340 | $saved_refs ||= []; | ||||
| 341 | 2 | 442µs | 2 | 22µs | # spent 14µs (7+8) within Safe::BEGIN@341 which was called:
# once (7µs+8µs) by Data::DPath::Context::BEGIN@23 at line 341 # spent 14µs making 1 call to Safe::BEGIN@341
# spent 8µs making 1 call to strict::unimport |
| 342 | foreach my $hook (qw(DESTROY AUTOLOAD), grep /^\(/, keys %$root) { | ||||
| 343 | push @$saved_refs, \*{$root.$hook}; | ||||
| 344 | delete ${$root}{$hook}; | ||||
| 345 | } | ||||
| 346 | |||||
| 347 | for (grep /::$/, keys %$root) { | ||||
| 348 | next if \%{$root.$_} eq \%$root; | ||||
| 349 | _clean_stash($root.$_, $saved_refs); | ||||
| 350 | } | ||||
| 351 | } | ||||
| 352 | |||||
| 353 | sub reval { | ||||
| 354 | my ($obj, $expr, $strict) = @_; | ||||
| 355 | my $root = $obj->{Root}; | ||||
| 356 | |||||
| 357 | my $evalsub = lexless_anon_sub($root, $strict, $expr); | ||||
| 358 | # propagate context | ||||
| 359 | my $sg = sub_generation(); | ||||
| 360 | my @subret = (wantarray) | ||||
| 361 | ? Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub) | ||||
| 362 | : scalar Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub); | ||||
| 363 | _clean_stash($root.'::') if $sg != sub_generation(); | ||||
| 364 | $obj->wrap_code_refs_within(@subret); | ||||
| 365 | return (wantarray) ? @subret : $subret[0]; | ||||
| 366 | } | ||||
| 367 | |||||
| 368 | 1 | 100ns | my %OID; | ||
| 369 | |||||
| 370 | sub wrap_code_refs_within { | ||||
| 371 | my $obj = shift; | ||||
| 372 | |||||
| 373 | %OID = (); | ||||
| 374 | $obj->_find_code_refs('wrap_code_ref', @_); | ||||
| 375 | } | ||||
| 376 | |||||
| 377 | |||||
| 378 | sub _find_code_refs { | ||||
| 379 | my $obj = shift; | ||||
| 380 | my $visitor = shift; | ||||
| 381 | |||||
| 382 | for my $item (@_) { | ||||
| 383 | my $reftype = $item && reftype $item | ||||
| 384 | or next; | ||||
| 385 | |||||
| 386 | # skip references already seen | ||||
| 387 | next if ++$OID{refaddr $item} > 1; | ||||
| 388 | |||||
| 389 | if ($reftype eq 'ARRAY') { | ||||
| 390 | $obj->_find_code_refs($visitor, @$item); | ||||
| 391 | } | ||||
| 392 | elsif ($reftype eq 'HASH') { | ||||
| 393 | $obj->_find_code_refs($visitor, values %$item); | ||||
| 394 | } | ||||
| 395 | # XXX GLOBs? | ||||
| 396 | elsif ($reftype eq 'CODE') { | ||||
| 397 | $item = $obj->$visitor($item); | ||||
| 398 | } | ||||
| 399 | } | ||||
| 400 | } | ||||
| 401 | |||||
| 402 | |||||
| 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 | 13µs | 1; | ||
| 455 | |||||
| 456 | __END__ | ||||
# spent 3µs within Safe::CORE:match which was called:
# once (3µs+0s) by Data::DPath::Context::BEGIN@23 at line 70 | |||||
# spent 8µs within Safe::CORE:pack which was called:
# once (8µs+0s) by Data::DPath::Context::BEGIN@23 at line 70 | |||||
# spent 3.21ms (86µs+3.12) within Safe::CORE:regcomp which was called:
# once (86µs+3.12ms) by Data::DPath::Context::BEGIN@23 at line 70 | |||||
# spent 37µs within Safe::CORE:subst which was called 59 times, avg 631ns/call:
# 59 times (37µs+0s) by Safe::share_from at line 290, avg 631ns/call |