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