package Safe;
use 5.003_11;
use strict;
use vars qw($VERSION);
$VERSION = "2.06";
use Carp;
use Opcode 1.01,qw(
  opset opset_to_ops opmask_add
  empty_opset full_opset invert_opset verify_opset
  opdesc opcodes opmask define_optag opset_to_hex
);
*ops_to_opset=\&opset;
my$default_root=0;
my$default_share=['*_'];
sub new{my($class,$root,$mask)=@_;
my$obj={};
bless$obj,$class;
if(defined($root)){croak"Can't use \"$root\" as root name" if$root=~/^main\b/ or$root!~/^\w[:\w]*$/;
$obj->{Root}=$root;
$obj->{Erase}=0;}else{$obj->{Root}="Safe::Root".$default_root++;
$obj->{Erase}=1;}croak"Mask parameter to new no longer supported" if defined$mask;
$obj->permit_only(':default');
$obj->share_from('main',$default_share);
return$obj;}sub DESTROY{my$obj=shift;
$obj->erase('DESTROY')if$obj->{Erase};}sub erase{my($obj,$action)=@_;
my$pkg=$obj->root();
my($stem,$leaf);
no strict 'refs';
$pkg="main::$pkg\::";
($stem,$leaf)=$pkg=~m/(.*::)(\w+::)$/;
my$stem_symtab=*{$stem}{HASH};
my$leaf_glob=$stem_symtab->{$leaf};
my$leaf_symtab=*{$leaf_glob}{HASH};
%$leaf_symtab=();
if($action and$action eq 'DESTROY'){delete$stem_symtab->{$leaf};}else{$obj->share_from('main',$default_share);}1;}sub reinit{my$obj=shift;
$obj->erase;
$obj->share_redo;}sub root{my$obj=shift;
croak("Safe root method now read-only")if@_;
return$obj->{Root};}sub mask{my$obj=shift;
return$obj->{Mask}unless@_;
$obj->deny_only(@_);}sub trap{shift->deny(@_)}sub untrap{shift->permit(@_)}sub deny{my$obj=shift;
$obj->{Mask}|=opset(@_);}sub deny_only{my$obj=shift;
$obj->{Mask}=opset(@_);}sub permit{my$obj=shift;
$obj->{Mask}&=invert_opset opset(@_);}sub permit_only{my$obj=shift;
$obj->{Mask}=invert_opset opset(@_);}sub dump_mask{my$obj=shift;
print opset_to_hex($obj->{Mask}),"\n";}sub share{my($obj,@vars)=@_;
$obj->share_from(scalar(caller),\@vars);}sub share_from{my$obj=shift;
my$pkg=shift;
my$vars=shift;
my$no_record=shift||0;
my$root=$obj->root();
croak("vars not an array ref")unless ref$vars eq 'ARRAY';
no strict 'refs';
croak("Package \"$pkg\" does not exist")unless keys%{"$pkg\::"};
my$arg;
foreach$arg(@$vars){croak("'$arg' not a valid symbol table name")unless$arg=~/^[\$\@%*&]?\w[\w:]*$/ or$arg=~/^\$\W$/;
my($var,$type);
$type=$1 if($var=$arg)=~s/^(\W)//;
*{$root."::$var"}=(!$type)?\&{$pkg."::$var"}:($type eq '&')?\&{$pkg."::$var"}:($type eq '$')?\${$pkg."::$var"}:($type eq '@')?\@{$pkg."::$var"}:($type eq '%')?\%{$pkg."::$var"}:($type eq '*')?*{$pkg."::$var"}:croak(qq(Can't share "$type$var" of unknown type));}$obj->share_record($pkg,$vars)unless$no_record or!$vars;}sub share_record{my$obj=shift;
my$pkg=shift;
my$vars=shift;
my$shares=\%{$obj->{Shares}||={}};
@{$shares}{@$vars}=($pkg)x@$vars if@$vars;}sub share_redo{my$obj=shift;
my$shares=\%{$obj->{Shares}||={}};
my($var,$pkg);
while(($var,$pkg)=each%$shares){$obj->share_from($pkg,[$var],1);}}sub share_forget{delete shift->{Shares};}sub varglob{my($obj,$var)=@_;
no strict 'refs';
return*{$obj->root()."::$var"};}sub reval{my($obj,$expr,$strict)=@_;
my$root=$obj->{Root};
my$evalcode=sprintf('package %s; sub { eval $expr; }',$root);
my$evalsub;
if($strict){use strict;$evalsub=eval$evalcode;}else{no strict;$evalsub=eval$evalcode;}return Opcode::_safe_call_sv($root,$obj->{Mask},$evalsub);}sub rdo{my($obj,$file)=@_;
my$root=$obj->{Root};
my$evalsub=eval sprintf('package %s; sub { do $file }',$root);
return Opcode::_safe_call_sv($root,$obj->{Mask},$evalsub);}1;
__DATA__


