Move Pod::Plainer from ext/ to dist/
[perl.git] / ext / Safe / t / safe2.t
1 #!./perl -w
2 $|=1;
3 BEGIN {
4     require Config; import Config;
5     if ($Config{'extensions'} !~ /\bOpcode\b/ && $Config{'osname'} ne 'VMS') {
6         print "1..0\n";
7         exit 0;
8     }
9 }
10
11 # Tests Todo:
12 #       'main' as root
13
14 use vars qw($bar);
15
16 use Opcode 1.00, qw(opdesc opset opset_to_ops opset_to_hex
17         opmask_add full_opset empty_opset opcodes opmask define_optag);
18
19 use Safe 1.00;
20
21 my $last_test; # initalised at end
22 print "1..$last_test\n";
23
24 # Set up a package namespace of things to be visible to the unsafe code
25 $Root::foo = "visible";
26 $bar = "invisible";
27
28 # Stop perl from moaning about identifies which are apparently only used once
29 $Root::foo .= "";
30
31 my $cpt;
32 # create and destroy a couple of automatic Safe compartments first
33 $cpt = new Safe or die;
34 $cpt = new Safe or die;
35
36 $cpt = new Safe "Root";
37
38 $cpt->permit(qw(:base_io));
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 $cpt->share('$"') unless $Config{use5005threads};
67
68 $cpt->reval(q{
69     package other;
70     sub other_sayok { print "ok @_\n" }
71     package main;
72     print $foo ? $foo : "not ok 8\n";
73     print $bar{key} ? $bar{key} : "not ok 9\n";
74     (@baz) ? print "@baz\n" : print "not ok 10\n";
75     print $glob;
76     other::other_sayok(12);
77     $foo =~ s/8/14/;
78     $bar{new} = "ok 15\n";
79     @glob = qw(ok 16);
80 });
81 print $@ ? "not ok 13\n#$@" : "ok 13\n";
82 $" = ' ';
83 print $foo, $bar{new}, "@glob\n";
84
85 $Root::foo = "not ok 17";
86 @{$cpt->varglob('bar')} = qw(not ok 18);
87 ${$cpt->varglob('foo')} = "ok 17";
88 @Root::bar = "ok";
89 push(@Root::bar, "18"); # Two steps to prevent "Identifier used only once..."
90
91 print "$Root::foo\n";
92 print "@{$cpt->varglob('bar')}\n";
93
94 use strict;
95
96 print 1 ? "ok 19\n" : "not ok 19\n";
97 print 1 ? "ok 20\n" : "not ok 20\n";
98
99 my $m1 = $cpt->mask;
100 $cpt->trap("negate");
101 my $m2 = $cpt->mask;
102 my @masked = opset_to_ops($m1);
103 print $m2 eq opset("negate", @masked) ? "ok 21\n" : "not ok 21\n";
104
105 print eval { $cpt->mask("a bad mask") } ? "not ok 22\n" : "ok 22\n";
106
107 print $cpt->reval("2 + 2") == 4 ? "ok 23\n" : "not ok 23\n";
108
109 $cpt->mask(empty_opset);
110 my $t_scalar = $cpt->reval('print wantarray ? "not ok 24\n" : "ok 24\n"');
111 print $cpt->reval('@ary=(6,7,8);@ary') == 3 ? "ok 25\n" : "not ok 25\n";
112 my @t_array  = $cpt->reval('print wantarray ? "ok 26\n" : "not ok 26\n"; (2,3,4)');
113 print $t_array[2] == 4 ? "ok 27\n" : "not ok 27\n";
114
115 my $t_scalar2 = $cpt->reval('die "foo bar"; 1');
116 print defined $t_scalar2 ? "not ok 28\n" : "ok 28\n";
117 print $@ =~ /foo bar/ ? "ok 29\n" : "not ok 29\n";
118
119 # --- rdo
120   
121 my $t = 30;
122 $! = 0;
123 my $nosuch = '/non/existant/file.name';
124 open(NOSUCH, $nosuch);
125 if ($@) {
126     my $errno  = $!;
127     die "Eek! Attempting to open $nosuch failed, but \$! is still 0" unless $!;
128     $! = 0;
129     $cpt->rdo($nosuch);
130     print $! == $errno ? "ok $t\n" : sprintf "not ok $t # \"$!\" is %d (expected %d)\n", $!, $errno; $t++;
131 } else {
132     die "Eek! Didn't expect $nosuch to be there.";
133 }
134 close(NOSUCH);
135
136 # test #31 is gone.
137 print "ok $t\n"; $t++;
138   
139 #my $rdo_file = "tmp_rdo.tpl";
140 #if (open X,">$rdo_file") {
141 #    print X "999\n";
142 #    close X;
143 #    $cpt->permit_only('const', 'leaveeval');
144 #    print  $cpt->rdo($rdo_file) == 999 ? "ok $t\n" : "not ok $t\n"; $t++;
145 #    unlink $rdo_file;
146 #}
147 #else {
148 #    print "# test $t skipped, can't open file: $!\nok $t\n"; $t++;
149 #}
150
151
152 print "ok $last_test\n";
153 BEGIN { $last_test = 32 }