This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Re: Réf. : Re: PATCH proposal for ext/Safe/safe2.t
[perl5.git] / ext / Safe / safe2.t
CommitLineData
76d62587
PP
1#!./perl -w
2$|=1;
3BEGIN {
4 chdir 't' if -d 't';
20822f61 5 @INC = '../lib';
76d62587
PP
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
16use vars qw($bar);
17
18use Opcode 1.00, qw(opdesc opset opset_to_ops opset_to_hex
19 opmask_add full_opset empty_opset opcodes opmask define_optag);
20
21use Safe 1.00;
22
23my $last_test; # initalised at end
24print "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
33my $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"); });
41if ($@ =~ /^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});
55print $@ ? "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
63sub sayok { print "ok @_\n" }
64
2faa37cc 65$cpt->share(qw($foo %bar @baz *glob sayok));
d1189716 66$cpt->share('$"') unless $Config{use5005threads};
76d62587
PP
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});
81print $@ ? "not ok 13\n#$@" : "ok 13\n";
82$" = ' ';
83print $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";
89push(@Root::bar, "18"); # Two steps to prevent "Identifier used only once..."
90
91print "$Root::foo\n";
92print "@{$cpt->varglob('bar')}\n";
93
94use strict;
95
96print 1 ? "ok 19\n" : "not ok 19\n";
97print 1 ? "ok 20\n" : "not ok 20\n";
98
99my $m1 = $cpt->mask;
100$cpt->trap("negate");
101my $m2 = $cpt->mask;
102my @masked = opset_to_ops($m1);
103print $m2 eq opset("negate", @masked) ? "ok 21\n" : "not ok 21\n";
104
105print eval { $cpt->mask("a bad mask") } ? "not ok 22\n" : "ok 22\n";
106
107print $cpt->reval("2 + 2") == 4 ? "ok 23\n" : "not ok 23\n";
108
109$cpt->mask(empty_opset);
110my $t_scalar = $cpt->reval('print wantarray ? "not ok 24\n" : "ok 24\n"');
111print $cpt->reval('@ary=(6,7,8);@ary') == 3 ? "ok 25\n" : "not ok 25\n";
112my @t_array = $cpt->reval('print wantarray ? "ok 26\n" : "not ok 26\n"; (2,3,4)');
113print $t_array[2] == 4 ? "ok 27\n" : "not ok 27\n";
114
115my $t_scalar2 = $cpt->reval('die "foo bar"; 1');
116print defined $t_scalar2 ? "not ok 28\n" : "ok 28\n";
117print $@ =~ /foo bar/ ? "ok 29\n" : "not ok 29\n";
118
119# --- rdo
120
f74a0ddc 121my $t = 30;
a79a9020 122$! = 0;
fd0dd314
NC
123my $nosuch = '/non/existant/file.name';
124open(NOSUCH, $nosuch);
f74a0ddc
JH
125if ($@) {
126 my $errno = $!;
a79a9020
NC
127 die "Eek! Attempting to open $nosuch failed, but \$! is still 0" unless $!;
128 $! = 0;
f74a0ddc
JH
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}
fd0dd314
NC
134close(NOSUCH);
135
61ae2fbf 136# test #31 is gone.
fd0dd314 137print "ok $t\n"; $t++;
76d62587
PP
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
152print "ok $last_test\n";
153BEGIN { $last_test = 32 }