| 1 | #!./perl -w |
| 2 | $|=1; |
| 3 | BEGIN { |
| 4 | chdir 't' if -d 't'; |
| 5 | @INC = '../lib'; |
| 6 | require Config; import Config; |
| 7 | if ($Config{'extensions'} !~ /\bOpcode\b/ && $Config{'osname'} ne 'VMS') { |
| 8 | print "1..0\n"; |
| 9 | exit 0; |
| 10 | } |
| 11 | } |
| 12 | |
| 13 | # Tests Todo: |
| 14 | # 'main' as root |
| 15 | |
| 16 | use vars qw($bar); |
| 17 | |
| 18 | use Opcode 1.00, qw(opdesc opset opset_to_ops opset_to_hex |
| 19 | opmask_add full_opset empty_opset opcodes opmask define_optag); |
| 20 | |
| 21 | use Safe 1.00; |
| 22 | |
| 23 | my $last_test; # initalised at end |
| 24 | print "1..$last_test\n"; |
| 25 | |
| 26 | # Set up a package namespace of things to be visible to the unsafe code |
| 27 | $Root::foo = "visible"; |
| 28 | $bar = "invisible"; |
| 29 | |
| 30 | # Stop perl from moaning about identifies which are apparently only used once |
| 31 | $Root::foo .= ""; |
| 32 | |
| 33 | my $cpt; |
| 34 | # create and destroy a couple of automatic Safe compartments first |
| 35 | $cpt = new Safe or die; |
| 36 | $cpt = new Safe or die; |
| 37 | |
| 38 | $cpt = new Safe "Root"; |
| 39 | |
| 40 | $cpt->reval(q{ system("echo not ok 1"); }); |
| 41 | if ($@ =~ /^system trapped by operation mask/) { |
| 42 | print "ok 1\n"; |
| 43 | } else { |
| 44 | print "#$@" if $@; |
| 45 | print "not ok 1\n"; |
| 46 | } |
| 47 | |
| 48 | $cpt->reval(q{ |
| 49 | print $foo eq 'visible' ? "ok 2\n" : "not ok 2\n"; |
| 50 | print $main::foo eq 'visible' ? "ok 3\n" : "not ok 3\n"; |
| 51 | print defined($bar) ? "not ok 4\n" : "ok 4\n"; |
| 52 | print defined($::bar) ? "not ok 5\n" : "ok 5\n"; |
| 53 | print defined($main::bar) ? "not ok 6\n" : "ok 6\n"; |
| 54 | }); |
| 55 | print $@ ? "not ok 7\n#$@" : "ok 7\n"; |
| 56 | |
| 57 | $foo = "ok 8\n"; |
| 58 | %bar = (key => "ok 9\n"); |
| 59 | @baz = (); push(@baz, "o", "10"); $" = 'k '; |
| 60 | $glob = "ok 11\n"; |
| 61 | @glob = qw(not ok 16); |
| 62 | |
| 63 | sub sayok { print "ok @_\n" } |
| 64 | |
| 65 | $cpt->share(qw($foo %bar @baz *glob sayok)); |
| 66 | $cpt->share('$"') unless $Config{use5005threads}; |
| 67 | |
| 68 | $cpt->reval(q{ |
| 69 | package other; |
| 70 | sub other_sayok { print "ok @_\n" } |
| 71 | package main; |
| 72 | print $foo ? $foo : "not ok 8\n"; |
| 73 | print $bar{key} ? $bar{key} : "not ok 9\n"; |
| 74 | (@baz) ? print "@baz\n" : print "not ok 10\n"; |
| 75 | print $glob; |
| 76 | other::other_sayok(12); |
| 77 | $foo =~ s/8/14/; |
| 78 | $bar{new} = "ok 15\n"; |
| 79 | @glob = qw(ok 16); |
| 80 | }); |
| 81 | print $@ ? "not ok 13\n#$@" : "ok 13\n"; |
| 82 | $" = ' '; |
| 83 | print $foo, $bar{new}, "@glob\n"; |
| 84 | |
| 85 | $Root::foo = "not ok 17"; |
| 86 | @{$cpt->varglob('bar')} = qw(not ok 18); |
| 87 | ${$cpt->varglob('foo')} = "ok 17"; |
| 88 | @Root::bar = "ok"; |
| 89 | push(@Root::bar, "18"); # Two steps to prevent "Identifier used only once..." |
| 90 | |
| 91 | print "$Root::foo\n"; |
| 92 | print "@{$cpt->varglob('bar')}\n"; |
| 93 | |
| 94 | use strict; |
| 95 | |
| 96 | print 1 ? "ok 19\n" : "not ok 19\n"; |
| 97 | print 1 ? "ok 20\n" : "not ok 20\n"; |
| 98 | |
| 99 | my $m1 = $cpt->mask; |
| 100 | $cpt->trap("negate"); |
| 101 | my $m2 = $cpt->mask; |
| 102 | my @masked = opset_to_ops($m1); |
| 103 | print $m2 eq opset("negate", @masked) ? "ok 21\n" : "not ok 21\n"; |
| 104 | |
| 105 | print eval { $cpt->mask("a bad mask") } ? "not ok 22\n" : "ok 22\n"; |
| 106 | |
| 107 | print $cpt->reval("2 + 2") == 4 ? "ok 23\n" : "not ok 23\n"; |
| 108 | |
| 109 | $cpt->mask(empty_opset); |
| 110 | my $t_scalar = $cpt->reval('print wantarray ? "not ok 24\n" : "ok 24\n"'); |
| 111 | print $cpt->reval('@ary=(6,7,8);@ary') == 3 ? "ok 25\n" : "not ok 25\n"; |
| 112 | my @t_array = $cpt->reval('print wantarray ? "ok 26\n" : "not ok 26\n"; (2,3,4)'); |
| 113 | print $t_array[2] == 4 ? "ok 27\n" : "not ok 27\n"; |
| 114 | |
| 115 | my $t_scalar2 = $cpt->reval('die "foo bar"; 1'); |
| 116 | print defined $t_scalar2 ? "not ok 28\n" : "ok 28\n"; |
| 117 | print $@ =~ /foo bar/ ? "ok 29\n" : "not ok 29\n"; |
| 118 | |
| 119 | # --- rdo |
| 120 | |
| 121 | my $t = 30; |
| 122 | my $nosuch = '/non/existant/file.name'; |
| 123 | open(NOSUCH, $nosuch); |
| 124 | if ($@) { |
| 125 | my $errno = $!; |
| 126 | $cpt->rdo($nosuch); |
| 127 | print $! == $errno ? "ok $t\n" : sprintf "not ok $t # \"$!\" is %d (expected %d)\n", $!, $errno; $t++; |
| 128 | } else { |
| 129 | die "Eek! Didn't expect $nosuch to be there."; |
| 130 | } |
| 131 | close(NOSUCH); |
| 132 | |
| 133 | # test #31 is gone. |
| 134 | print "ok $t\n"; $t++; |
| 135 | |
| 136 | #my $rdo_file = "tmp_rdo.tpl"; |
| 137 | #if (open X,">$rdo_file") { |
| 138 | # print X "999\n"; |
| 139 | # close X; |
| 140 | # $cpt->permit_only('const', 'leaveeval'); |
| 141 | # print $cpt->rdo($rdo_file) == 999 ? "ok $t\n" : "not ok $t\n"; $t++; |
| 142 | # unlink $rdo_file; |
| 143 | #} |
| 144 | #else { |
| 145 | # print "# test $t skipped, can't open file: $!\nok $t\n"; $t++; |
| 146 | #} |
| 147 | |
| 148 | |
| 149 | print "ok $last_test\n"; |
| 150 | BEGIN { $last_test = 32 } |