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