use 5.003_11;
use strict;
-our $VERSION = "2.07";
+$Safe::VERSION = "2.12";
+
+# *** Don't declare any lexicals above this point ***
+#
+# This function should return a closure which contains an eval that can't
+# see any lexicals in scope (apart from __ExPr__ which is unavoidable)
+
+sub lexless_anon_sub {
+ # $_[0] is package;
+ # $_[1] is strict flag;
+ my $__ExPr__ = $_[2]; # must be a lexical to create the closure that
+ # can be used to pass the value into the safe
+ # world
+
+ # 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)
+ eval sprintf
+ 'package %s; %s strict; sub { @_=(); eval q[my $__ExPr__;] . $__ExPr__; }',
+ $_[0], $_[1] ? 'use' : 'no';
+}
use Carp;
+use Carp::Heavy;
use Opcode 1.01, qw(
opset opset_to_ops opmask_add
my $default_root = 0;
-my $default_share = ['*_']; #, '*main::'];
+# share *_ and functions defined in universal.c
+# Don't share stuff like *UNIVERSAL:: otherwise code from the
+# compartment can 0wn functions in UNIVERSAL
+my $default_share = [qw[
+ *_
+ &PerlIO::get_layers
+ &Regexp::DESTROY
+ &re::is_regexp
+ &re::regname
+ &re::regnames
+ &re::regnames_count
+ &Tie::Hash::NamedCapture::FETCH
+ &Tie::Hash::NamedCapture::STORE
+ &Tie::Hash::NamedCapture::DELETE
+ &Tie::Hash::NamedCapture::CLEAR
+ &Tie::Hash::NamedCapture::EXISTS
+ &Tie::Hash::NamedCapture::FIRSTKEY
+ &Tie::Hash::NamedCapture::NEXTKEY
+ &Tie::Hash::NamedCapture::SCALAR
+ &Tie::Hash::NamedCapture::flags
+ &UNIVERSAL::isa
+ &UNIVERSAL::can
+ &UNIVERSAL::DOES
+ &UNIVERSAL::VERSION
+ &utf8::is_utf8
+ &utf8::valid
+ &utf8::encode
+ &utf8::decode
+ &utf8::upgrade
+ &utf8::downgrade
+ &utf8::native_to_unicode
+ &utf8::unicode_to_native
+ &version::()
+ &version::new
+ &version::(""
+ &version::stringify
+ &version::(0+
+ &version::numify
+ &version::normal
+ &version::(cmp
+ &version::(<=>
+ &version::vcmp
+ &version::(bool
+ &version::boolean
+ &version::(nomethod
+ &version::noop
+ &version::is_alpha
+ &version::qv
+]];
sub new {
my($class, $root, $mask) = @_;
# 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});
+ Opcode::_safe_pkg_prep($obj->{Root}) if($Opcode::VERSION > 1.04);
return $obj;
}
my $no_record = shift || 0;
my $root = $obj->root();
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$/;
my ($var, $type);
$type = $1 if ($var = $arg) =~ s/^(\W)//;
# warn "share_from $pkg $type $var";
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);
my ($obj, $expr, $strict) = @_;
my $root = $obj->{Root};
- # 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 $evalsub;
-
- if ($strict) { use strict; $evalsub = eval $evalcode; }
- else { no strict; $evalsub = eval $evalcode; }
-
+ my $evalsub = lexless_anon_sub($root,$strict, $expr);
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);
}
The default operator mask for a newly created compartment is
the ':default' optag.
-It is important that you read the Opcode(3) module documentation
+It is important that you read the L<Opcode> module documentation
for more information, especially for detailed definitions of opnames,
optags and opsets.
Permit the listed operators to be used when compiling code in the
compartment (in I<addition> to any operators already permitted).
+You can list opcodes by names, or use a tag name; see
+L<Opcode/"Predefined Opcode Tags">.
+
=item permit_only (OP, ...)
Permit I<only> the listed operators to be used when compiling code in
=head2 AUTHOR
-Originally designed and implemented by Malcolm Beattie,
-mbeattie@sable.ox.ac.uk.
+Originally designed and implemented by Malcolm Beattie.
+
+Reworked to use the Opcode module and other changes added by Tim Bunce.
-Reworked to use the Opcode module and other changes added by Tim Bunce
-E<lt>F<Tim.Bunce@ig.co.uk>E<gt>.
+Currently maintained by the Perl 5 Porters, <perl5-porters@perl.org>.
=cut