1#!./perl -w
2$|=1;
3BEGIN {
4    if($ENV{PERL_CORE}) {
5	chdir 't' if -d 't';
6	@INC = '../lib';
7    }
8    require Config; import Config;
9    if ($Config{'extensions'} !~ /\bOpcode\b/ && $Config{'osname'} ne 'VMS') {
10        print "1..0\n";
11        exit 0;
12    }
13}
14
15# Tests Todo:
16#	'main' as root
17
18use vars qw($bar);
19
20use Opcode 1.00, qw(opdesc opset opset_to_ops opset_to_hex
21	opmask_add full_opset empty_opset opcodes opmask define_optag);
22
23use Safe 1.00;
24
25my $last_test; # initalised at end
26print "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
35my $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"); });
43if ($@ =~ /^'?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});
57print $@ ? "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
65sub sayok { print "ok @_\n" }
66
67$cpt->share(qw($foo %bar @baz *glob sayok));
68$cpt->share('$"') unless $Config{use5005threads};
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});
83print $@ ? "not ok 13\n#$@" : "ok 13\n";
84$" = ' ';
85print $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";
91push(@Root::bar, "18"); # Two steps to prevent "Identifier used only once..."
92
93print "$Root::foo\n";
94print "@{$cpt->varglob('bar')}\n";
95
96use strict;
97
98print 1 ? "ok 19\n" : "not ok 19\n";
99print 1 ? "ok 20\n" : "not ok 20\n";
100
101my $m1 = $cpt->mask;
102$cpt->trap("negate");
103my $m2 = $cpt->mask;
104my @masked = opset_to_ops($m1);
105print $m2 eq opset("negate", @masked) ? "ok 21\n" : "not ok 21\n";
106
107print eval { $cpt->mask("a bad mask") } ? "not ok 22\n" : "ok 22\n";
108
109print $cpt->reval("2 + 2") == 4 ? "ok 23\n" : "not ok 23\n";
110
111$cpt->mask(empty_opset);
112my $t_scalar = $cpt->reval('print wantarray ? "not ok 24\n" : "ok 24\n"');
113print $cpt->reval('@ary=(6,7,8);@ary') == 3 ? "ok 25\n" : "not ok 25\n";
114my @t_array  = $cpt->reval('print wantarray ? "ok 26\n" : "not ok 26\n"; (2,3,4)');
115print $t_array[2] == 4 ? "ok 27\n" : "not ok 27\n";
116
117my $t_scalar2 = $cpt->reval('die "foo bar"; 1');
118print defined $t_scalar2 ? "not ok 28\n" : "ok 28\n";
119print $@ =~ /foo bar/ ? "ok 29\n" : "not ok 29\n";
120
121# --- rdo
122
123my $t = 30;
124$! = 0;
125my $nosuch = '/non/existant/file.name';
126open(NOSUCH, $nosuch);
127if ($@) {
128    my $errno  = $!;
129    die "Eek! Attempting to open $nosuch failed, but \$! is still 0" unless $!;
130    $! = 0;
131    $cpt->rdo($nosuch);
132    print $! == $errno ? "ok $t\n" : sprintf "not ok $t # \"$!\" is %d (expected %d)\n", $!, $errno; $t++;
133} else {
134    die "Eek! Didn't expect $nosuch to be there.";
135}
136close(NOSUCH);
137
138# test #31 is gone.
139print "ok $t\n"; $t++;
140
141#my $rdo_file = "tmp_rdo.tpl";
142#if (open X,">$rdo_file") {
143#    print X "999\n";
144#    close X;
145#    $cpt->permit_only('const', 'leaveeval');
146#    print  $cpt->rdo($rdo_file) == 999 ? "ok $t\n" : "not ok $t\n"; $t++;
147#    unlink $rdo_file;
148#}
149#else {
150#    print "# test $t skipped, can't open file: $!\nok $t\n"; $t++;
151#}
152
153
154print "ok $last_test\n";
155BEGIN { $last_test = 32 }
156