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 | } |
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 | |
67 | $cpt->reval(q{ |
68 | package other; |
69 | sub other_sayok { print "ok @_\n" } |
70 | package main; |
71 | print $foo ? $foo : "not ok 8\n"; |
72 | print $bar{key} ? $bar{key} : "not ok 9\n"; |
73 | (@baz) ? print "@baz\n" : print "not ok 10\n"; |
74 | print $glob; |
75 | other::other_sayok(12); |
76 | $foo =~ s/8/14/; |
77 | $bar{new} = "ok 15\n"; |
78 | @glob = qw(ok 16); |
79 | }); |
80 | print $@ ? "not ok 13\n#$@" : "ok 13\n"; |
81 | $" = ' '; |
82 | print $foo, $bar{new}, "@glob\n"; |
83 | |
84 | $Root::foo = "not ok 17"; |
85 | @{$cpt->varglob('bar')} = qw(not ok 18); |
86 | ${$cpt->varglob('foo')} = "ok 17"; |
87 | @Root::bar = "ok"; |
88 | push(@Root::bar, "18"); # Two steps to prevent "Identifier used only once..." |
89 | |
90 | print "$Root::foo\n"; |
91 | print "@{$cpt->varglob('bar')}\n"; |
92 | |
93 | use strict; |
94 | |
95 | print 1 ? "ok 19\n" : "not ok 19\n"; |
96 | print 1 ? "ok 20\n" : "not ok 20\n"; |
97 | |
98 | my $m1 = $cpt->mask; |
99 | $cpt->trap("negate"); |
100 | my $m2 = $cpt->mask; |
101 | my @masked = opset_to_ops($m1); |
102 | print $m2 eq opset("negate", @masked) ? "ok 21\n" : "not ok 21\n"; |
103 | |
104 | print eval { $cpt->mask("a bad mask") } ? "not ok 22\n" : "ok 22\n"; |
105 | |
106 | print $cpt->reval("2 + 2") == 4 ? "ok 23\n" : "not ok 23\n"; |
107 | |
108 | $cpt->mask(empty_opset); |
109 | my $t_scalar = $cpt->reval('print wantarray ? "not ok 24\n" : "ok 24\n"'); |
110 | print $cpt->reval('@ary=(6,7,8);@ary') == 3 ? "ok 25\n" : "not ok 25\n"; |
111 | my @t_array = $cpt->reval('print wantarray ? "ok 26\n" : "not ok 26\n"; (2,3,4)'); |
112 | print $t_array[2] == 4 ? "ok 27\n" : "not ok 27\n"; |
113 | |
114 | my $t_scalar2 = $cpt->reval('die "foo bar"; 1'); |
115 | print defined $t_scalar2 ? "not ok 28\n" : "ok 28\n"; |
116 | print $@ =~ /foo bar/ ? "ok 29\n" : "not ok 29\n"; |
117 | |
118 | # --- rdo |
119 | |
120 | my $t = 30; |
121 | $cpt->rdo('/non/existant/file.name'); |
36477c24 |
122 | print +(($! =~ /No such file/ || $! =~ /file specification syntax error/) || |
f86702cc |
123 | $! =~ /A file or directory in the path name does not exist/ || |
124 | $! =~ /Device not configured/ ? |
76d62587 |
125 | "ok $t\n" : "not ok $t # $!\n"); $t++; |
126 | print 1 ? "ok $t\n" : "not ok $t\n#$@/$!\n"; $t++; |
127 | |
128 | #my $rdo_file = "tmp_rdo.tpl"; |
129 | #if (open X,">$rdo_file") { |
130 | # print X "999\n"; |
131 | # close X; |
132 | # $cpt->permit_only('const', 'leaveeval'); |
133 | # print $cpt->rdo($rdo_file) == 999 ? "ok $t\n" : "not ok $t\n"; $t++; |
134 | # unlink $rdo_file; |
135 | #} |
136 | #else { |
137 | # print "# test $t skipped, can't open file: $!\nok $t\n"; $t++; |
138 | #} |
139 | |
140 | |
141 | print "ok $last_test\n"; |
142 | BEGIN { $last_test = 32 } |