use 5.003_11;
use strict;
-our $VERSION = "2.08";
+$Safe::VERSION = "2.16_01";
+
+# *** 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;
+BEGIN { eval q{
+ 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
+ &UNIVERSAL::isa
+ &UNIVERSAL::can
+ &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
+ $version::CLASS
+ @version::ISA
+], ($] >= 5.008001 && qw[
+ &Regexp::DESTROY
+]), ($] >= 5.010 && qw[
+ &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::DOES
+ &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
+]), ($] >= 5.011 && qw[
+ &re::regexp_pattern
+])];
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 $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";
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);
}
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
${$cpt->varglob('foo')} = "Hello world";
-=item reval (STRING)
+=item reval (STRING, STRICT)
This evaluates STRING as perl code inside the compartment.
where earlier versions of perl made it hard to mimic the return
behaviour of the eval() command and the context was always scalar.
+The formerly undocumented STRICT argument sets strictness: if true
+'use strict;' is used, otherwise it uses 'no strict;'. B<Note>: if
+STRICT is omitted 'no strict;' is the default.
+
Some points to note:
If the entereval op is permitted then the code can use eval "..." to
=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
projects / p5sagit/p5-mst-13.2.git / blobdiff