This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Convert Safe's remaining hold out tests to Test::More
[perl5.git] / dist / Safe / t / safe2.t
CommitLineData
76d62587
PP
1#!./perl -w
2$|=1;
3BEGIN {
76d62587
PP
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
14use vars qw($bar);
15
16use Opcode 1.00, qw(opdesc opset opset_to_ops opset_to_hex
17 opmask_add full_opset empty_opset opcodes opmask define_optag);
18
19use Safe 1.00;
20
64535195
NC
21use Test::More;
22my $TB = Test::Builder->new();
76d62587
PP
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
31my $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
e866b74b
RGS
38$cpt->permit(qw(:base_io));
39
76d62587 40$cpt->reval(q{ system("echo not ok 1"); });
64535195 41like($@, qr/^'?system'? trapped by operation mask/);
76d62587
PP
42
43$cpt->reval(q{
44 print $foo eq 'visible' ? "ok 2\n" : "not ok 2\n";
45 print $main::foo eq 'visible' ? "ok 3\n" : "not ok 3\n";
46 print defined($bar) ? "not ok 4\n" : "ok 4\n";
47 print defined($::bar) ? "not ok 5\n" : "ok 5\n";
48 print defined($main::bar) ? "not ok 6\n" : "ok 6\n";
49});
64535195
NC
50$TB->current_test(6);
51is($@, '');
76d62587
PP
52
53$foo = "ok 8\n";
54%bar = (key => "ok 9\n");
64535195 55@baz = (); push(@baz, "o", "10");
76d62587
PP
56$glob = "ok 11\n";
57@glob = qw(not ok 16);
58
59sub sayok { print "ok @_\n" }
60
2faa37cc 61$cpt->share(qw($foo %bar @baz *glob sayok));
d1189716 62$cpt->share('$"') unless $Config{use5005threads};
76d62587 63
64535195
NC
64{
65 $" = 'k ';
66 $cpt->reval(q{
76d62587
PP
67 package other;
68 sub other_sayok { print "ok @_\n" }
69 package main;
70 print $foo ? $foo : "not ok 8\n";
71 print $bar{key} ? $bar{key} : "not ok 9\n";
72 (@baz) ? print "@baz\n" : print "not ok 10\n";
73 print $glob;
74 other::other_sayok(12);
75 $foo =~ s/8/14/;
76 $bar{new} = "ok 15\n";
77 @glob = qw(ok 16);
64535195 78 $" = ' ';
76d62587 79});
64535195
NC
80}
81$TB->current_test(12);
82is($@, '');
83is($foo, "ok 14\n");
84is($bar{new}, "ok 15\n");
85is("@glob", "ok 16");
76d62587
PP
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
64535195
NC
93is($Root::foo, 'ok 17');
94is("@{$cpt->varglob('bar')}", 'ok 18');
76d62587
PP
95
96use strict;
97
76d62587
PP
98my $m1 = $cpt->mask;
99$cpt->trap("negate");
100my $m2 = $cpt->mask;
101my @masked = opset_to_ops($m1);
64535195 102is(opset("negate", @masked), $m2);
76d62587 103
64535195
NC
104is(eval { $cpt->mask("a bad mask") }, undef);
105isnt($@, '');
76d62587 106
64535195 107is($cpt->reval("2 + 2"), 4);
76d62587 108
64535195
NC
109my $test = $TB->current_test() + 1;
110my $t_scalar = $cpt->reval("print wantarray ? 'not ok $test\n' : 'ok $test\n'");
111++$test;
112my @t_array = $cpt->reval("print wantarray ? 'ok $test\n' : 'not ok $test\n'; (2,3,4)");
113$TB->current_test($test);
114
115is($t_array[2], 4);
116
117is($cpt->reval('@ary=(6,7,8);@ary'), 3);
76d62587
PP
118
119my $t_scalar2 = $cpt->reval('die "foo bar"; 1');
64535195
NC
120is($t_scalar2, undef);
121like($@, qr/foo bar/);
76d62587
PP
122
123# --- rdo
124
a79a9020 125$! = 0;
c4a6f826 126my $nosuch = '/non/existent/file.name';
fd0dd314 127open(NOSUCH, $nosuch);
f74a0ddc 128if ($@) {
64535195 129 my $errno = $!;
a79a9020
NC
130 die "Eek! Attempting to open $nosuch failed, but \$! is still 0" unless $!;
131 $! = 0;
f74a0ddc 132 $cpt->rdo($nosuch);
64535195 133 is($!, $errno);
f74a0ddc
JH
134} else {
135 die "Eek! Didn't expect $nosuch to be there.";
136}
fd0dd314
NC
137close(NOSUCH);
138
76d62587
PP
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');
64535195 144# $cpt->rdo($rdo_file) == 999 ? "ok $t\n" : "not ok $t\n"; $t++;
76d62587
PP
145# unlink $rdo_file;
146#}
147#else {
148# print "# test $t skipped, can't open file: $!\nok $t\n"; $t++;
149#}
150
64535195 151done_testing();