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
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 use Test::More;
22 my $TB = Test::Builder->new();
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 like($@, qr/^'?system'? trapped by operation mask/);
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 });
50 $TB->current_test(6);
51 is($@, '');
52
53 $foo = "ok 8\n";
54 %bar = (key => "ok 9\n");
55 @baz = (); push(@baz, "o", "10");
56 $glob = "ok 11\n";
57 @glob = qw(not ok 16);
58
59 sub sayok { print "ok @_\n" }
60
61 $cpt->share(qw($foo %bar @baz *glob sayok));
62 $cpt->share('$"') unless $Config{use5005threads};
63
64 {
65     $" = 'k ';
66     $cpt->reval(q{
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);
78     $" = ' ';
79 });
80 }
81 $TB->current_test(12);
82 is($@, '');
83 is($foo, "ok 14\n");
84 is($bar{new}, "ok 15\n");
85 is("@glob", "ok 16");
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";
91 push(@Root::bar, "18"); # Two steps to prevent "Identifier used only once..."
92
93 is($Root::foo, 'ok 17');
94 is("@{$cpt->varglob('bar')}", 'ok 18');
95
96 use strict;
97
98 my $m1 = $cpt->mask;
99 $cpt->trap("negate");
100 my $m2 = $cpt->mask;
101 my @masked = opset_to_ops($m1);
102 is(opset("negate", @masked), $m2);
103
104 is(eval { $cpt->mask("a bad mask") }, undef);
105 isnt($@, '');
106
107 is($cpt->reval("2 + 2"), 4);
108
109 my $test = $TB->current_test() + 1;
110 my $t_scalar = $cpt->reval("print wantarray ? 'not ok $test\n' : 'ok $test\n'");
111 ++$test;
112 my @t_array  = $cpt->reval("print wantarray ? 'ok $test\n' : 'not ok $test\n'; (2,3,4)");
113 $TB->current_test($test);
114
115 is($t_array[2], 4);
116
117 is($cpt->reval('@ary=(6,7,8);@ary'), 3);
118
119 my $t_scalar2 = $cpt->reval('die "foo bar"; 1');
120 is($t_scalar2, undef);
121 like($@, qr/foo bar/);
122
123 # --- rdo
124   
125 $! = 0;
126 my $nosuch = '/non/existent/file.name';
127 open(NOSUCH, $nosuch);
128 if ($@) {
129     my $errno = $!;
130     die "Eek! Attempting to open $nosuch failed, but \$! is still 0" unless $!;
131     $! = 0;
132     $cpt->rdo($nosuch);
133     is($!, $errno);
134 } else {
135     die "Eek! Didn't expect $nosuch to be there.";
136 }
137 close(NOSUCH);
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 #    $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 done_testing();