1N/A#!./perl -w
1N/A$|=1;
1N/ABEGIN {
1N/A require Config; import Config;
1N/A if ($Config{'extensions'} !~ /\bOpcode\b/ && $Config{'osname'} ne 'VMS') {
1N/A print "1..0\n";
1N/A exit 0;
1N/A }
1N/A}
1N/A
1N/A# Tests Todo:
1N/A# 'main' as root
1N/A
1N/Ause vars qw($bar);
1N/A
1N/Ause Opcode 1.00, qw(opdesc opset opset_to_ops opset_to_hex
1N/A opmask_add full_opset empty_opset opcodes opmask define_optag);
1N/A
1N/Ause Safe 1.00;
1N/A
1N/Amy $last_test; # initalised at end
1N/Aprint "1..$last_test\n";
1N/A
1N/A# Set up a package namespace of things to be visible to the unsafe code
1N/A$Root::foo = "visible";
1N/A$bar = "invisible";
1N/A
1N/A# Stop perl from moaning about identifies which are apparently only used once
1N/A$Root::foo .= "";
1N/A
1N/Amy $cpt;
1N/A# create and destroy a couple of automatic Safe compartments first
1N/A$cpt = new Safe or die;
1N/A$cpt = new Safe or die;
1N/A
1N/A$cpt = new Safe "Root";
1N/A
1N/A$cpt->permit(qw(:base_io));
1N/A
1N/A$cpt->reval(q{ system("echo not ok 1"); });
1N/Aif ($@ =~ /^'?system'? trapped by operation mask/) {
1N/A print "ok 1\n";
1N/A} else {
1N/A print "#$@" if $@;
1N/A print "not ok 1\n";
1N/A}
1N/A
1N/A$cpt->reval(q{
1N/A print $foo eq 'visible' ? "ok 2\n" : "not ok 2\n";
1N/A print $main::foo eq 'visible' ? "ok 3\n" : "not ok 3\n";
1N/A print defined($bar) ? "not ok 4\n" : "ok 4\n";
1N/A print defined($::bar) ? "not ok 5\n" : "ok 5\n";
1N/A print defined($main::bar) ? "not ok 6\n" : "ok 6\n";
1N/A});
1N/Aprint $@ ? "not ok 7\n#$@" : "ok 7\n";
1N/A
1N/A$foo = "ok 8\n";
1N/A%bar = (key => "ok 9\n");
1N/A@baz = (); push(@baz, "o", "10"); $" = 'k ';
1N/A$glob = "ok 11\n";
1N/A@glob = qw(not ok 16);
1N/A
1N/Asub sayok { print "ok @_\n" }
1N/A
1N/A$cpt->share(qw($foo %bar @baz *glob sayok));
1N/A$cpt->share('$"') unless $Config{use5005threads};
1N/A
1N/A$cpt->reval(q{
1N/A package other;
1N/A sub other_sayok { print "ok @_\n" }
1N/A package main;
1N/A print $foo ? $foo : "not ok 8\n";
1N/A print $bar{key} ? $bar{key} : "not ok 9\n";
1N/A (@baz) ? print "@baz\n" : print "not ok 10\n";
1N/A print $glob;
1N/A other::other_sayok(12);
1N/A $foo =~ s/8/14/;
1N/A $bar{new} = "ok 15\n";
1N/A @glob = qw(ok 16);
1N/A});
1N/Aprint $@ ? "not ok 13\n#$@" : "ok 13\n";
1N/A$" = ' ';
1N/Aprint $foo, $bar{new}, "@glob\n";
1N/A
1N/A$Root::foo = "not ok 17";
1N/A@{$cpt->varglob('bar')} = qw(not ok 18);
1N/A${$cpt->varglob('foo')} = "ok 17";
1N/A@Root::bar = "ok";
1N/Apush(@Root::bar, "18"); # Two steps to prevent "Identifier used only once..."
1N/A
1N/Aprint "$Root::foo\n";
1N/Aprint "@{$cpt->varglob('bar')}\n";
1N/A
1N/Ause strict;
1N/A
1N/Aprint 1 ? "ok 19\n" : "not ok 19\n";
1N/Aprint 1 ? "ok 20\n" : "not ok 20\n";
1N/A
1N/Amy $m1 = $cpt->mask;
1N/A$cpt->trap("negate");
1N/Amy $m2 = $cpt->mask;
1N/Amy @masked = opset_to_ops($m1);
1N/Aprint $m2 eq opset("negate", @masked) ? "ok 21\n" : "not ok 21\n";
1N/A
1N/Aprint eval { $cpt->mask("a bad mask") } ? "not ok 22\n" : "ok 22\n";
1N/A
1N/Aprint $cpt->reval("2 + 2") == 4 ? "ok 23\n" : "not ok 23\n";
1N/A
1N/A$cpt->mask(empty_opset);
1N/Amy $t_scalar = $cpt->reval('print wantarray ? "not ok 24\n" : "ok 24\n"');
1N/Aprint $cpt->reval('@ary=(6,7,8);@ary') == 3 ? "ok 25\n" : "not ok 25\n";
1N/Amy @t_array = $cpt->reval('print wantarray ? "ok 26\n" : "not ok 26\n"; (2,3,4)');
1N/Aprint $t_array[2] == 4 ? "ok 27\n" : "not ok 27\n";
1N/A
1N/Amy $t_scalar2 = $cpt->reval('die "foo bar"; 1');
1N/Aprint defined $t_scalar2 ? "not ok 28\n" : "ok 28\n";
1N/Aprint $@ =~ /foo bar/ ? "ok 29\n" : "not ok 29\n";
1N/A
1N/A# --- rdo
1N/A
1N/Amy $t = 30;
1N/A$! = 0;
1N/Amy $nosuch = '/non/existant/file.name';
1N/Aopen(NOSUCH, $nosuch);
1N/Aif ($@) {
1N/A my $errno = $!;
1N/A die "Eek! Attempting to open $nosuch failed, but \$! is still 0" unless $!;
1N/A $! = 0;
1N/A $cpt->rdo($nosuch);
1N/A print $! == $errno ? "ok $t\n" : sprintf "not ok $t # \"$!\" is %d (expected %d)\n", $!, $errno; $t++;
1N/A} else {
1N/A die "Eek! Didn't expect $nosuch to be there.";
1N/A}
1N/Aclose(NOSUCH);
1N/A
1N/A# test #31 is gone.
1N/Aprint "ok $t\n"; $t++;
1N/A
1N/A#my $rdo_file = "tmp_rdo.tpl";
1N/A#if (open X,">$rdo_file") {
1N/A# print X "999\n";
1N/A# close X;
1N/A# $cpt->permit_only('const', 'leaveeval');
1N/A# print $cpt->rdo($rdo_file) == 999 ? "ok $t\n" : "not ok $t\n"; $t++;
1N/A# unlink $rdo_file;
1N/A#}
1N/A#else {
1N/A# print "# test $t skipped, can't open file: $!\nok $t\n"; $t++;
1N/A#}
1N/A
1N/A
1N/Aprint "ok $last_test\n";
1N/ABEGIN { $last_test = 32 }