From: Perl 5 Porters <perl5-porters@africa.nicoh.com>
Date: Thu, 18 Jul 1996 01:32:29 +0000 (+0000)
Subject: Add tests for new Opcode extension
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=76d62587dc1ae0868b7cd78c4917985db6c65a72;p=p5sagit%2Fp5-mst-13.2.git

Add tests for new Opcode extension
---

diff --git a/t/lib/opcode.t b/t/lib/opcode.t
new file mode 100644
index 0000000..e171aca
--- /dev/null
+++ b/t/lib/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()/8)+1 ? "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/t/lib/ops.t
new file mode 100644
index 0000000..56b1bac
--- /dev/null
+++ b/t/lib/ops.t
@@ -0,0 +1,29 @@
+#!./perl
+
+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;
+    }
+}
+
+print "1..2\n";
+
+eval <<'EOP';
+	no ops 'fileno';	# equiv to "perl -M-ops=fileno"
+	$a = fileno STDIN;
+EOP
+
+print $@ =~ /trapped/ ? "ok 1\n" : "not ok 1\n# $@\n";
+
+eval <<'EOP';
+	use ops ':default';	# equiv to "perl -M(as above) -Mops=:default"
+	eval 1;
+EOP
+
+print $@ =~ /trapped/ ? "ok 2\n" : "not ok 2\n# $@\n";
+
+1;
diff --git a/t/lib/safe1.t b/t/lib/safe1.t
new file mode 100644
index 0000000..27993d9
--- /dev/null
+++ b/t/lib/safe1.t
@@ -0,0 +1,68 @@
+#!./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;
+    }
+}
+
+# Tests Todo:
+#	'main' as root
+
+package test;	# test from somewhere other than main
+
+use vars qw($bar);
+
+use Opcode 1.00, qw(opdesc opset opset_to_ops opset_to_hex
+	opmask_add full_opset empty_opset opcodes opmask define_optag);
+
+use Safe 1.00;
+
+my $last_test; # initalised at end
+print "1..$last_test\n";
+
+my $t = 1;
+my $cpt;
+# create and destroy some automatic Safe compartments first
+$cpt = new Safe or die;
+$cpt = new Safe or die;
+$cpt = new Safe or die;
+
+$cpt = new Safe "Root" or die;
+
+foreach(1..3) {
+	$foo = 42;
+
+	$cpt->share(qw($foo));
+
+	print ${$cpt->varglob('foo')}       == 42 ? "ok $t\n" : "not ok $t\n"; $t++;
+
+	${$cpt->varglob('foo')} = 9;
+
+	print $foo == 9	? "ok $t\n" : "not ok $t\n"; $t++;
+
+	print $cpt->reval('$foo')       == 9	? "ok $t\n" : "not ok $t\n"; $t++;
+	# check 'main' has been changed:
+	print $cpt->reval('$::foo')     == 9	? "ok $t\n" : "not ok $t\n"; $t++;
+	print $cpt->reval('$main::foo') == 9	? "ok $t\n" : "not ok $t\n"; $t++;
+	# check we can't see our test package:
+	print $cpt->reval('$test::foo')     	? "not ok $t\n" : "ok $t\n"; $t++;
+	print $cpt->reval('${"test::foo"}')		? "not ok $t\n" : "ok $t\n"; $t++;
+
+	$cpt->erase;	# erase the compartment, e.g., delete all variables
+
+	print $cpt->reval('$foo') ? "not ok $t\n" : "ok $t\n"; $t++;
+
+	# Note that we *must* use $cpt->varglob here because if we used
+	# $Root::foo etc we would still see the original values!
+	# This seems to be because the compiler has created an extra ref.
+
+	print ${$cpt->varglob('foo')} ? "not ok $t\n" : "ok $t\n"; $t++;
+}
+
+print "ok $last_test\n";
+BEGIN { $last_test = 28 }
diff --git a/t/lib/safe2.t b/t/lib/safe2.t
new file mode 100644
index 0000000..61c6c8f
--- /dev/null
+++ b/t/lib/safe2.t
@@ -0,0 +1,140 @@
+#!./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;
+    }
+}
+
+# Tests Todo:
+#	'main' as root
+
+use vars qw($bar);
+
+use Opcode 1.00, qw(opdesc opset opset_to_ops opset_to_hex
+	opmask_add full_opset empty_opset opcodes opmask define_optag);
+
+use Safe 1.00;
+
+my $last_test; # initalised at end
+print "1..$last_test\n";
+
+# Set up a package namespace of things to be visible to the unsafe code
+$Root::foo = "visible";
+$bar = "invisible";
+
+# Stop perl from moaning about identifies which are apparently only used once
+$Root::foo .= "";
+
+my $cpt;
+# create and destroy a couple of automatic Safe compartments first
+$cpt = new Safe or die;
+$cpt = new Safe or die;
+
+$cpt = new Safe "Root";
+
+$cpt->reval(q{ system("echo not ok 1"); });
+if ($@ =~ /^system trapped by operation mask/) {
+    print "ok 1\n";
+} else {
+    print "#$@" if $@;
+    print "not ok 1\n";
+}
+
+$cpt->reval(q{
+    print $foo eq 'visible'		? "ok 2\n" : "not ok 2\n";
+    print $main::foo  eq 'visible'	? "ok 3\n" : "not ok 3\n";
+    print defined($bar)			? "not ok 4\n" : "ok 4\n";
+    print defined($::bar)		? "not ok 5\n" : "ok 5\n";
+    print defined($main::bar)		? "not ok 6\n" : "ok 6\n";
+});
+print $@ ? "not ok 7\n#$@" : "ok 7\n";
+
+$foo = "ok 8\n";
+%bar = (key => "ok 9\n");
+@baz = (); push(@baz, "o", "10"); $" = 'k ';
+$glob = "ok 11\n";
+@glob = qw(not ok 16);
+
+sub sayok { print "ok @_\n" }
+
+$cpt->share(qw($foo %bar @baz *glob sayok $"));
+
+$cpt->reval(q{
+    package other;
+    sub other_sayok { print "ok @_\n" }
+    package main;
+    print $foo ? $foo : "not ok 8\n";
+    print $bar{key} ? $bar{key} : "not ok 9\n";
+    (@baz) ? print "@baz\n" : print "not ok 10\n";
+    print $glob;
+    other::other_sayok(12);
+    $foo =~ s/8/14/;
+    $bar{new} = "ok 15\n";
+    @glob = qw(ok 16);
+});
+print $@ ? "not ok 13\n#$@" : "ok 13\n";
+$" = ' ';
+print $foo, $bar{new}, "@glob\n";
+
+$Root::foo = "not ok 17";
+@{$cpt->varglob('bar')} = qw(not ok 18);
+${$cpt->varglob('foo')} = "ok 17";
+@Root::bar = "ok";
+push(@Root::bar, "18"); # Two steps to prevent "Identifier used only once..."
+
+print "$Root::foo\n";
+print "@{$cpt->varglob('bar')}\n";
+
+use strict;
+
+print 1 ? "ok 19\n" : "not ok 19\n";
+print 1 ? "ok 20\n" : "not ok 20\n";
+
+my $m1 = $cpt->mask;
+$cpt->trap("negate");
+my $m2 = $cpt->mask;
+my @masked = opset_to_ops($m1);
+print $m2 eq opset("negate", @masked) ? "ok 21\n" : "not ok 21\n";
+
+print eval { $cpt->mask("a bad mask") } ? "not ok 22\n" : "ok 22\n";
+
+print $cpt->reval("2 + 2") == 4 ? "ok 23\n" : "not ok 23\n";
+
+$cpt->mask(empty_opset);
+my $t_scalar = $cpt->reval('print wantarray ? "not ok 24\n" : "ok 24\n"');
+print $cpt->reval('@ary=(6,7,8);@ary') == 3 ? "ok 25\n" : "not ok 25\n";
+my @t_array  = $cpt->reval('print wantarray ? "ok 26\n" : "not ok 26\n"; (2,3,4)');
+print $t_array[2] == 4 ? "ok 27\n" : "not ok 27\n";
+
+my $t_scalar2 = $cpt->reval('die "foo bar"; 1');
+print defined $t_scalar2 ? "not ok 28\n" : "ok 28\n";
+print $@ =~ /foo bar/ ? "ok 29\n" : "not ok 29\n";
+
+# --- rdo
+  
+my $t = 30;
+$cpt->rdo('/non/existant/file.name');
+print +(($! =~ /No such file/ || $! =~ /file specification syntax error/) ?
+      "ok $t\n" : "not ok $t # $!\n"); $t++;
+print 1 ? "ok $t\n" : "not ok $t\n#$@/$!\n"; $t++;
+  
+#my $rdo_file = "tmp_rdo.tpl";
+#if (open X,">$rdo_file") {
+#    print X "999\n";
+#    close X;
+#    $cpt->permit_only('const', 'leaveeval');
+#    print  $cpt->rdo($rdo_file) == 999 ? "ok $t\n" : "not ok $t\n"; $t++;
+#    unlink $rdo_file;
+#}
+#else {
+#    print "# test $t skipped, can't open file: $!\nok $t\n"; $t++;
+#}
+
+
+print "ok $last_test\n";
+BEGIN { $last_test = 32 }