Upgrade to Safe 2.10 from bleadperl.

Don't get the safeops.t from blead as it needs a core patch.

p4raw-id: //depot/maint-5.6/perl-5.6.2@21462

8 files changed, 226 insertions, 32 deletions

diff --git a/MANIFEST b/MANIFEST
index 65faf35a10..1d37fc61ee 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -289,6 +289,11 @@ ext/Opcode/Opcode.pm		Opcode extension Perl module
 ext/Opcode/Opcode.xs		Opcode extension external subroutines
 ext/Opcode/ops.pm		"Pragma" form of Opcode extension Perl module
 ext/Opcode/Safe.pm		Safe extension Perl module
+ext/Opcode/t/Opcode.t		See if Opcode works
+ext/Opcode/t/ops.t		See if Opcode works
+ext/Safe/t/safe1.t		See if Safe works
+ext/Safe/t/safe2.t		See if Safe works
+ext/Safe/t/safe3.t		See if Safe works
 ext/POSIX/hints/bsdos.pl	Hint for POSIX for named architecture
 ext/POSIX/hints/dynixptx.pl	Hint for POSIX for named architecture
 ext/POSIX/hints/freebsd.pl	Hint for POSIX for named architecture
@@ -1521,13 +1526,10 @@ t/lib/odbm.t		See if ODBM_File works
 t/lib/opcode.t		See if Opcode works
 t/lib/open2.t		See if IPC::Open2 works
 t/lib/open3.t		See if IPC::Open3 works
-t/lib/ops.t		See if Opcode works
 t/lib/parsewords.t	See if Text::ParseWords works
 t/lib/peek.t		See if Devel::Peek works
 t/lib/ph.t		See if h2ph works
 t/lib/posix.t		See if POSIX works
-t/lib/safe1.t		See if Safe works
-t/lib/safe2.t		See if Safe works
 t/lib/sample-tests/bailout		Test data for Test::Harness
 t/lib/sample-tests/bignum		Test data for Test::Harness
 t/lib/sample-tests/combined		Test data for Test::Harness
diff --git a/ext/Opcode/Safe.pm b/ext/Opcode/Safe.pm
index 7e1d6a34a7..5036943cd7 100644
--- a/ext/Opcode/Safe.pm
+++ b/ext/Opcode/Safe.pm
@@ -3,7 +3,27 @@ package Safe;
 use 5.003_11;
 use strict;
 
-our $VERSION = "2.06";
+$Safe::VERSION = "2.10";
+
+# *** 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;
 
@@ -47,6 +67,7 @@ sub new {
     # 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;
 }
 
@@ -154,7 +175,7 @@ sub share_from {
     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\::"};
@@ -189,7 +210,7 @@ sub share_record {
 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);
@@ -210,15 +231,7 @@ sub reval {
     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);
 }
 
@@ -227,7 +240,7 @@ sub rdo {
     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);
 }
 
@@ -379,11 +392,12 @@ respectfully.
 =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'
@@ -425,7 +439,7 @@ C<main::> package to the code inside the compartment.
 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
diff --git a/ext/Opcode/ops.pm b/ext/Opcode/ops.pm
index 9b553b7634..8a7a200665 100644
--- a/ext/Opcode/ops.pm
+++ b/ext/Opcode/ops.pm
@@ -1,5 +1,7 @@
 package ops;
 
+our $VERSION = '1.00';
+
 use Opcode qw(opmask_add opset invert_opset);
 
 sub import {
diff --git a/ext/Opcode/t/Opcode.t b/ext/Opcode/t/Opcode.t
new file mode 100755
index 0000000000..a785fce48b
--- /dev/null
+++ b/ext/Opcode/t/Opcode.t
@@ -0,0 +1,115 @@
+#!./perl -w
+
+$|=1;
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+    require Config; import Config;
+    if ($Config{'extensions'} !~ /\bOpcode\b/ && $Config{'osname'} ne 'VMS') {
+        print "1..0\n";
+        exit 0;
+    }
+}
+
+use Opcode qw(
+	opcodes opdesc opmask verify_opset
+	opset opset_to_ops opset_to_hex invert_opset
+	opmask_add full_opset empty_opset define_optag
+);
+
+use strict;
+
+my $t = 1;
+my $last_test; # initalised at end
+print "1..$last_test\n";
+
+my($s1, $s2, $s3);
+my(@o1, @o2, @o3);
+
+# --- opset_to_ops and opset
+
+my @empty_l = opset_to_ops(empty_opset);
+print @empty_l == 0 ?   "ok $t\n" : "not ok $t\n"; $t++;
+
+my @full_l1  = opset_to_ops(full_opset);
+print @full_l1 == opcodes() ? "ok $t\n" : "not ok $t\n"; $t++;
+my @full_l2 = @full_l1;	# = opcodes();	# XXX to be fixed
+print "@full_l1" eq "@full_l2" ? "ok $t\n" : "not ok $t\n"; $t++;
+
+@empty_l = opset_to_ops(opset(':none'));
+print @empty_l == 0 ?   "ok $t\n" : "not ok $t\n"; $t++;
+
+my @full_l3 = opset_to_ops(opset(':all'));
+print  @full_l1  ==  @full_l3  ? "ok $t\n" : "not ok $t\n"; $t++;
+print "@full_l1" eq "@full_l3" ? "ok $t\n" : "not ok $t\n"; $t++;
+
+die $t unless $t == 7;
+$s1 = opset(      'padsv');
+$s2 = opset($s1,  'padav');
+$s3 = opset($s2, '!padav');
+print $s1 eq $s2 ? "not ok $t\n" : "ok $t\n"; ++$t;
+print $s1 eq $s3 ? "ok $t\n" : "not ok $t\n"; ++$t;
+
+# --- define_optag
+
+print eval { opset(':_tst_') } ? "not ok $t\n" : "ok $t\n"; ++$t;
+define_optag(":_tst_", opset(qw(padsv padav padhv)));
+print eval { opset(':_tst_') } ? "ok $t\n" : "not ok $t\n"; ++$t;
+
+# --- opdesc and opcodes
+
+die $t unless $t == 11;
+print opdesc("gv") eq "glob value" ? "ok $t\n" : "not ok $t\n"; $t++;
+my @desc = opdesc(':_tst_','stub');
+print "@desc" eq "private variable private array private hash stub"
+				    ? "ok $t\n" : "not ok $t\n#@desc\n"; $t++;
+print opcodes() ? "ok $t\n" : "not ok $t\n"; $t++;
+print "ok $t\n"; ++$t;
+
+# --- invert_opset
+
+$s1 = opset(qw(fileno padsv padav));
+@o2 = opset_to_ops(invert_opset($s1));
+print @o2 == opcodes-3 ? "ok $t\n" : "not ok $t\n"; $t++;
+
+# --- opmask
+
+die $t unless $t == 16;
+print opmask() eq empty_opset() ? "ok $t\n" : "not ok $t\n"; $t++;	# work
+print length opmask() == int((opcodes()+7)/8) ? "ok $t\n" : "not ok $t\n"; $t++;
+
+# --- verify_opset
+
+print verify_opset($s1) && !verify_opset(42) ? "ok $t\n":"not ok $t\n"; $t++;
+
+# --- opmask_add
+
+opmask_add(opset(qw(fileno)));	# add to global op_mask
+print eval 'fileno STDOUT' ? "not ok $t\n" : "ok $t\n";	$t++; # fail
+print $@ =~ /fileno trapped/ ? "ok $t\n" : "not ok $t\n# $@\n"; $t++;
+
+# --- check use of bit vector ops on opsets
+
+$s1 = opset('padsv');
+$s2 = opset('padav');
+$s3 = opset('padsv', 'padav', 'padhv');
+
+# Non-negated
+print (($s1 | $s2) eq opset($s1,$s2) ? "ok $t\n":"not ok $t\n"); $t++;
+print (($s2 & $s3) eq opset($s2)     ? "ok $t\n":"not ok $t\n"); $t++;
+print (($s2 ^ $s3) eq opset('padsv','padhv') ? "ok $t\n":"not ok $t\n"); $t++;
+
+# Negated, e.g., with possible extra bits in last byte beyond last op bit.
+# The extra bits mean we can't just say ~mask eq invert_opset(mask).
+
+@o1 = opset_to_ops(           ~ $s3);
+@o2 = opset_to_ops(invert_opset $s3);
+print "@o1" eq "@o2" ? "ok $t\n":"not ok $t\n"; $t++;
+
+# --- finally, check some opname assertions
+
+foreach(@full_l1) { die "bad opname: $_" if /\W/ or /^\d/ }
+
+print "ok $last_test\n";
+BEGIN { $last_test = 25 }
diff --git a/t/lib/ops.t b/ext/Opcode/t/ops.t
index 56b1bacabb..56b1bacabb 100755
--- a/t/lib/ops.t
+++ b/ext/Opcode/t/ops.t
diff --git a/t/lib/safe1.t b/ext/Safe/t/safe1.t
index 27993d95c9..6a3b9082e3 100755
--- a/t/lib/safe1.t
+++ b/ext/Safe/t/safe1.t
@@ -1,13 +1,16 @@
 #!./perl -w
 $|=1;
 BEGIN {
-    chdir 't' if -d 't';
-    @INC = '../lib';
+    if($ENV{PERL_CORE}) {
+	chdir 't' if -d 't';
+	@INC = '../lib';
+    }
     require Config; import Config;
     if ($Config{'extensions'} !~ /\bOpcode\b/ && $Config{'osname'} ne 'VMS') {
         print "1..0\n";
         exit 0;
     }
+
 }
 
 # Tests Todo:
diff --git a/t/lib/safe2.t b/ext/Safe/t/safe2.t
index 4d6c84a692..3ea19eda4e 100755
--- a/t/lib/safe2.t
+++ b/ext/Safe/t/safe2.t
@@ -1,16 +1,15 @@
 #!./perl -w
 $|=1;
 BEGIN {
-    chdir 't' if -d 't';
-    @INC = '../lib';
+    if($ENV{PERL_CORE}) {
+	chdir 't' if -d 't';
+	@INC = '../lib';
+    } 
     require Config; import Config;
     if ($Config{'extensions'} !~ /\bOpcode\b/ && $Config{'osname'} ne 'VMS') {
         print "1..0\n";
         exit 0;
     }
-    # test 30 rather naughtily expects English error messages
-    $ENV{'LC_ALL'} = 'C';
-    $ENV{LANGUAGE} = 'C'; # GNU locale extension
 }
 
 # Tests Todo:
@@ -41,7 +40,7 @@ $cpt = new Safe or die;
 $cpt = new Safe "Root";
 
 $cpt->reval(q{ system("echo not ok 1"); });
-if ($@ =~ /^system trapped by operation mask/) {
+if ($@ =~ /^'?system'? trapped by operation mask/) {
     print "ok 1\n";
 } else {
     print "#$@" if $@;
@@ -122,11 +121,22 @@ print $@ =~ /foo bar/ ? "ok 29\n" : "not ok 29\n";
 # --- rdo
   
 my $t = 30;
-$cpt->rdo('/non/existant/file.name');
-# The regexp is getting rather baroque.
-print $! =~ /cannot find|No such file|file specification syntax error|A file or directory in the path name does not exist|Invalid argument|Device not configured|file not found|File or directory doesn't exist/i ? "ok $t\n" : "not ok $t # $!\n"; $t++;
+$! = 0;
+my $nosuch = '/non/existant/file.name';
+open(NOSUCH, $nosuch);
+if ($@) {
+    my $errno  = $!;
+    die "Eek! Attempting to open $nosuch failed, but \$! is still 0" unless $!;
+    $! = 0;
+    $cpt->rdo($nosuch);
+    print $! == $errno ? "ok $t\n" : sprintf "not ok $t # \"$!\" is %d (expected %d)\n", $!, $errno; $t++;
+} else {
+    die "Eek! Didn't expect $nosuch to be there.";
+}
+close(NOSUCH);
+
 # test #31 is gone.
-print 1 ? "ok $t\n" : "not ok $t\n#$@/$!\n"; $t++;
+print "ok $t\n"; $t++;
   
 #my $rdo_file = "tmp_rdo.tpl";
 #if (open X,">$rdo_file") {
diff --git a/ext/Safe/t/safe3.t b/ext/Safe/t/safe3.t
new file mode 100644
index 0000000000..2d5f275970
--- /dev/null
+++ b/ext/Safe/t/safe3.t
@@ -0,0 +1,48 @@
+#!perl
+
+BEGIN {
+    if ($ENV{PERL_CORE}) {
+	chdir 't' if -d 't';
+	@INC = '../lib';
+    }
+    require Config; import Config;
+    if ($Config{'extensions'} !~ /\bOpcode\b/
+	&& $Config{'extensions'} !~ /\bPOSIX\b/
+	&& $Config{'osname'} ne 'VMS')
+    {
+	print "1..0\n";
+	exit 0;
+    }
+}
+
+use strict;
+use warnings;
+use POSIX qw(ceil);
+use Test::More tests => 2;
+use Safe;
+
+my $safe = new Safe;
+$safe->deny('add');
+
+my $masksize = ceil( Opcode::opcodes / 8 );
+# Attempt to change the opmask from within the safe compartment
+$safe->reval( qq{\$_[1] = qq/\0/ x } . $masksize );
+
+# Check that it didn't work
+$safe->reval( q{$x + $y} );
+like( $@, qr/^'?addition \(\+\)'? trapped by operation mask/,
+	    'opmask still in place with reval' );
+
+my $safe2 = new Safe;
+$safe2->deny('add');
+
+open my $fh, '>nasty.pl' or die "Can't write nasty.pl: $!\n";
+print $fh <<EOF;
+\$_[1] = "\0" x $masksize;
+EOF
+close $fh;
+$safe2->rdo('nasty.pl');
+$safe2->reval( q{$x + $y} );
+like( $@, qr/^'?addition \(\+\)'? trapped by operation mask/,
+	    'opmask still in place with rdo' );
+END { unlink 'nasty.pl' }