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 JH |
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 MB |
68 | $cpt->share(qw($foo %bar @baz *glob sayok)); |
69 | $cpt->share('$"') unless $Config{archname} =~ /-thread$/; | |
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 JH |
126 | # The regexp is getting rather baroque. |
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/i ? "ok $t\n" : "not ok $t # $!\n"; $t++; | |
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 } |