Danger exists in our world today. Danger that can harm our innocent subroutines. Stray in-scope lexicals may be modified, wandering globals might be changed, and fiendish threads may cause deadlock. These are all real threats that can cause erratic behaivor within our subs and perhaps cause irreversible harm!
"What is a Perl Coder to do?!", you might say. Well, I'm glad you asked. With our product, Sub::Sealed, you can achieve full protection for your subs. Any in scope lexicals' or globals' values will be copied on first invocation and put into a hidden compartment; these hidden values will then be aliased to the values that your sub uses. In addition, these new aliased variables will be thread-safe. The best part is that it is available for the low-low price of $1879.99!
package Sub::Sealed; # Probably should be Acme::Sealed, eh? use strict; use warnings; no warnings qw(uninitialized redefine); use Attribute::Handlers; use B qw(svref_2object); use Devel::LexAlias qw(lexalias); use PadWalker qw(peek_my peek_sub); use Storable qw(dclone); our $Thread = scalar eval "use Thread::Tie; 1 "; my $count = 0; sub UNIVERSAL::Sealed : ATTR(CODE) { my ($package, $symbol, $referent, $attr, $data, $phase) = @_; ++ $count; my $invoked = 0; my $pkg = "$package\::ANON$count\::"; # ironically, does not work with closures, where this might # actually be useful. After many hours of experimentation, # it appears impossible to modify a closure with an attribute. *$symbol = sub { if (not $invoked) { my $used = peek_sub($referent); my $in_scope = peek_my(1); my ($names,@values) = svref_2object( $referent )->PADLIST->ARRAY; $names = $names->object_2svref; my %to_save; my %is_global; foreach my $var (keys %$in_scope) { if (exists $used->{$var}) { my $global = 1 if ref $used->{$var} eq 'GLOB'; foreach (1..$#$names) { if ($var eq $names->[$_]) { my $value; if ($global) { no strict 'refs'; my $type = substr($var, 0, 1) ne '$' ? substr($var, 0, 1) eq '@' ? 'ARRAY' : 'HASH' : 'SCALA +R'; my $name = substr($var, 1); $value = *{"$package\::$name"}{$type}; } else { $value = ($values[0]->ARRAY)[$_]->obje +ct_2svref; } $value = dclone($value) if UNIVERSAL::isa($value,'ARRAY') or UNIVERSAL::isa($value,'HASH'); $to_save{$var} = $value; $is_global{$var} = $global; } next; } } } no strict 'refs'; while ( my($var,$value) = each %to_save) { my $sigil = substr($var,0,1,""); my $newvar = *{"$pkg$var"}{SCALAR}; if ($is_global{"$sigil$var"}) { my $type = $sigil ne '$' ? $sigil eq '@' ? 'ARRAY' : 'HASH' : 'SCALAR'; my $variable = *{"$package\::$var"}{$type}; my @args = (\$value, $package, *$symbol, $type); tie ${*{"main::z"}{$type}}, 'Sub::Sealed::Global', + @args if $sigil eq '$'; tie @{*{"main::z"}{$type}}, 'Sub::Sealed::Global', + @args if $sigil eq '@'; tie %{*{"main::z"}{$type}}, 'Sub::Sealed::Global', + @args if $sigil eq '%'; } else { if ( $Thread ) { tie $$newvar, 'Thread::Tie', {}, $value; } else { # for non-thread-wary results $$newvar = $value; } # the next line is necessary, for some reason $newvar = ${*{"$pkg$var"}{SCALAR}}; lexalias($referent, "$sigil$var", $newvar); } } ++ $invoked; } return $referent->(@_); }; } package Sub::Sealed::Global; use Storable qw(dclone); use strict; use warnings; sub TIE { my ($class,$data,$pkg,$sub,$type) = @_; $sub = substr("$sub", rindex("$sub",':')+1); my $copy = dclone($$data); if ( $Thread ) { tie $data, 'Thread::Tie', {}, $$data; } my $obj = { type => $type, normal => $copy, sealed => $data, caller => "$pkg\::$sub" }; bless $obj, $class; } sub pick { my ($self,@caller) = @_; if ($caller[3] && $caller[3] eq $self->{caller}) { return $self->{sealed} } else { return $self->{normal} } } # Cntr sub TIESCALAR { goto \&TIE } sub TIEARRAY { goto \&TIE } sub TIEHASH { goto \&TIE } # Array sub FETCHSIZE { scalar @{pick($_[0], caller(1))} } sub STORESIZE { $#{pick($_[0], caller(1))} = $_[1]-1 } sub POP { pop(@{pick($_[0], caller(1))}) } sub PUSH { my $o = pick(shift, caller(1)); push(@$o,@_) } sub SHIFT { shift(@{pick($_[0], caller(1))}) } sub UNSHIFT { my $o = pick(shift, caller(1)); unshift(@$o,@_) } sub EXTEND { } sub SPLICE { my $ob = pick(shift, caller(1)); my $sz = $ob->FETCHSIZE; my $off = @_ ? shift : 0; $off += $sz if $off < 0; my $len = @_ ? shift : $sz-$off; return splice(@$ob,$off,$len,@_); } # Hash sub FIRSTKEY { my $a = scalar keys %{pick($_[0], caller(1))}; each %{pick($_[0], caller(1))} } sub NEXTKEY { each %{pick($_[0], caller(1))} } # General sub STORE { my $x = pick($_[0], caller(1)); if ($_[0]->{type} eq 'SCALAR') { $$x = $_[1]; } if ($_[0]->{type} eq 'ARRAY') { return $x->[$_[1]] = $_[2] } elsif ($_[0]->{type} eq 'HASH') { return $x->{$_[1]} = $_[2] } } sub FETCH { my $x = pick($_[0], caller(1)); if ($_[0]->{type} eq 'SCALAR') { return $$x } elsif ($_[0]->{type} eq 'ARRAY') { return $x->[$_[1]] } elsif ($_[0]->{type} eq 'HASH') { return $x->{$_[1]} } } sub EXISTS { my $x = pick($_[0], caller(1)); if ($_[0]->{type} eq 'ARRAY') { exists $x->[$_[1]] } elsif ($_[0]->{type} eq 'HASH') { exists $x->{$_[1]} } } sub DELETE { my $x = pick($_[0], caller(1)); if ($_[0]->{type} eq 'ARRAY') { delete $x->[$_[1]] } elsif ($_[0]->{type} eq 'HASH') { delete $x->{$_[1]} } } sub CLEAR { my $x = pick($_[0], caller(1)); if ($_[0]->{type} eq 'ARRAY') { @{$x} = () } elsif ($_[0]->{type} eq 'HASH') { %{$x} = () } } 1;
An example:
use Sub::Sealed; use strict; use warnings; my $q = 9; our @z = (4,6); sub something : Sealed { my $x = 1; print "@z * $q \n"; }; something(); $q = 3; @z = (5,7); something(); print "@z * $q\n";
Prints:
4 6 9 4 6 9 5 7 3
Act now! Order today!
Update: Sub::Sealed will now handle true globals correctly! Upgrade today for only $879.99!
In reply to Protect your subs... from *EVIL*. by jryan
| For: | Use: | ||
| & | & | ||
| < | < | ||
| > | > | ||
| [ | [ | ||
| ] | ] |