Beefy Boxes and Bandwidth Generously Provided by pair Networks
more useful options
 
PerlMonks  

Protect your subs... from *EVIL*.

by jryan (Vicar)
on Dec 22, 2003 at 09:16 UTC ( [id://316345]=CUFP: print w/replies, xml ) Need Help??

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!

Replies are listed 'Best First'.
Re: Protect your subs... from *EVIL*.
by diotalevi (Canon) on Dec 22, 2003 at 18:31 UTC

    For those of us who don't have an ithread perl handy:

    --- Sub/Sealed.pm~ 2003-12-22 12:20:41.000000000 -0600 +++ Sub/Sealed.pm 2003-12-22 12:28:42.000000000 -0600 @@ -10,7 +10,7 @@ use Devel::LexAlias qw(lexalias); use PadWalker qw(peek_my peek_sub); use Storable qw(dclone); -use Thread::Tie; +our $Thread = scalar eval "use Thread::Tie; 1 "; my $count = 0; @@ -50,9 +50,11 @@ while ( my($var,$value) = each %to_save) { my $sigil = substr($var,0,1,""); my $newvar = *{"$pkg$var"}{SCALAR}; - # $$newvar = $value; # for non-thread-wary results - tie $$newvar, 'Thread::Tie', {}, $value; - + if ( $Thread ) { + tie $$newvar, 'Thread::Tie', {}, $value; + } else { + $$newvar = $value; # for non-thread-wary results + } # the next line is necessary, for some reason $newvar = ${*{"$pkg$var"}{SCALAR}}; lexalias($referent, "$sigil$var", $newvar);
Re: Protect your subs... from *EVIL*.
by cLive ;-) (Prior) on Dec 22, 2003 at 13:23 UTC
    You mean you use global vars! Shame on you jryan, shame, shame... ;-)

    cLive ;-)

      Well, use Sub::Sealed on all of your subroutines and there won't be anything wrong with using globals. ;)

        That's not quite right, globals are still globals even after Sub::Sealed because you only fixup the function's lexicals. In fact, even your lexicals are now globals after being sealed. So this effectively removes lexicals from your function and sneakily replaces them with globals.

        I dunno jryan,

        As a matter of readability and sanity, I'd pass the variable as an argument and taint-check as neccessary. Or use constants. Do you have an example where constants or untainting globals as arguments are not the best way to go?

        Just curious as to practical use. Nice bit of code though :)

        .02

        cLive ;-)

Re: Protect your subs... from *EVIL*.
by gmpassos (Priest) on Dec 28, 2003 at 05:37 UTC
    Have you tried to make some code attack to your resource?

    Without test it you are just losing your time! Take a look in this code: Rebinding closures

    Graciliano M. P.
    "Creativity is the expression of the liberty".

      Of course I tested it. Study what my code does, and then see why Rebinding closures won't be effective. (Also look at the 2nd line of my code; I think you missed the joke!)

Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Node Status?
node history
Node Type: CUFP [id://316345]
Approved by ysth
Front-paged by diotalevi
help
Chatterbox?
and the web crawler heard nothing...

How do I use this?Last hourOther CB clients
Other Users?
Others romping around the Monastery: (4)
As of 2024-03-29 05:19 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found