use 5.003_11;
use strict;
-use vars qw($VERSION);
-$VERSION = "2.06";
+$Safe::VERSION = "2.09";
use Carp;
# the whole glob *_ rather than $_ and @_ separately, otherwise
# @_ in non default packages within the compartment don't work.
$obj->share_from('main', $default_share);
+ Opcode::_safe_pkg_prep($obj->{Root}) if($Opcode::VERSION > 1.04);
return $obj;
}
sub DESTROY {
my $obj = shift;
- $obj->erase if $obj->{Erase};
+ $obj->erase('DESTROY') if $obj->{Erase};
}
sub erase {
- my $obj= shift;
+ my ($obj, $action) = @_;
my $pkg = $obj->root();
my ($stem, $leaf);
#warn " stem_symtab hash ".scalar(%$stem_symtab)."\n";
# ", join(', ', %$stem_symtab),"\n";
- delete $stem_symtab->{$leaf};
+# delete $stem_symtab->{$leaf};
-# my $leaf_glob = $stem_symtab->{$leaf};
-# my $leaf_symtab = *{$leaf_glob}{HASH};
+ my $leaf_glob = $stem_symtab->{$leaf};
+ my $leaf_symtab = *{$leaf_glob}{HASH};
# warn " leaf_symtab ", join(', ', %$leaf_symtab),"\n";
-# %$leaf_symtab = ();
+ %$leaf_symtab = ();
#delete $leaf_symtab->{'__ANON__'};
#delete $leaf_symtab->{'foo'};
#delete $leaf_symtab->{'main::'};
# my $foo = undef ${"$stem\::"}{"$leaf\::"};
- $obj->share_from('main', $default_share);
+ if ($action and $action eq 'DESTROY') {
+ delete $stem_symtab->{$leaf};
+ } else {
+ $obj->share_from('main', $default_share);
+ }
1;
}
my $vars = shift;
my $no_record = shift || 0;
my $root = $obj->root();
- my ($var, $arg);
croak("vars not an array ref") unless ref $vars eq 'ARRAY';
- no strict 'refs';
+ no strict 'refs';
# Check that 'from' package actually exists
croak("Package \"$pkg\" does not exist")
unless keys %{"$pkg\::"};
+ my $arg;
foreach $arg (@$vars) {
# catch some $safe->share($var) errors:
croak("'$arg' not a valid symbol table name")
unless $arg =~ /^[\$\@%*&]?\w[\w:]*$/
or $arg =~ /^\$\W$/;
- ($var = $arg) =~ s/^(\W)//; # get type char
- # warn "share_from $pkg $1 $var";
- *{$root."::$var"} = ($1 eq '$') ? \${$pkg."::$var"}
- : ($1 eq '@') ? \@{$pkg."::$var"}
- : ($1 eq '%') ? \%{$pkg."::$var"}
- : ($1 eq '*') ? *{$pkg."::$var"}
- : ($1 eq '&') ? \&{$pkg."::$var"}
- : (!$1) ? \&{$pkg."::$var"}
- : croak(qq(Can't share "$1$var" of unknown type));
+ my ($var, $type);
+ $type = $1 if ($var = $arg) =~ s/^(\W)//;
+ # warn "share_from $pkg $type $var";
+ *{$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_redo {
my $obj = shift;
my $shares = \%{$obj->{Shares} ||= {}};
- my($var, $pkg);
+ my($var, $pkg);
while(($var, $pkg) = each %$shares) {
# warn "share_redo $pkg\:: $var";
$obj->share_from($pkg, [ $var ], 1);
# Create anon sub ref in root of compartment.
# Uses a closure (on $expr) to pass in the code to be executed.
# (eval on one line to keep line numbers as expected by caller)
- my $evalcode = sprintf('package %s; sub { eval $expr; }', $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; }
+ if ($strict) { use strict; $evalsub = eval $evalcode; }
+ else { no strict; $evalsub = eval $evalcode; }
return Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub);
}
my $root = $obj->{Root};
my $evalsub = eval
- sprintf('package %s; sub { do $file }', $root);
+ sprintf('package %s; sub { @_ = (); do $file }', $root);
return Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub);
}
1;
-__DATA__
+__END__
=head1 NAME
Evaluating perl code (e.g. via "eval" or "do 'file'") causes
the code to be compiled into an internal format and then,
provided there was no error in the compilation, executed.
-Code evaulated in a compartment compiles subject to the
-compartment's operator mask. Attempting to evaulate code in a
+Code evaluated in a compartment compiles subject to the
+compartment's operator mask. Attempting to evaluate code in a
compartment which contains a masked operator will cause the
compilation to fail with an error. The code will not be executed.
=item share (NAME, ...)
This shares the variable(s) in the argument list with the compartment.
-This is almost identical to exporting variables using the L<Exporter(3)>
+This is almost identical to exporting variables using the L<Exporter>
module.
-Each NAME must be the B<name> of a variable, typically with the leading
-type identifier included. A bareword is treated as a function name.
+Each NAME must be the B<name> of a non-lexical variable, typically
+with the leading type identifier included. A bareword is treated as a
+function name.
Examples of legal names are '$foo' for a scalar, '@foo' for an
array, '%foo' for a hash, '&foo' or 'foo' for a subroutine and '*foo'
Any attempt by the code in STRING to use an operator which is not permitted
by the compartment will cause an error (at run-time of the main program
but at compile-time for the code in STRING). The error is of the form
-"%s trapped by operation mask operation...".
+"'%s' trapped by operation mask...".
If an operation is trapped in this way, then the code in STRING will
not be executed. If such a trapped operation occurs or any other