This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
The Grand Trek: move the *.t files from t/ to lib/ and ext/.
[perl5.git] / ext / Safe / safe2.t
1 #!./perl -w
2 $|=1;
3 BEGIN {
4     chdir 't' if -d 't';
5     @INC = '../lib';
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     # test 30 rather naughtily expects English error messages
12     $ENV{'LC_ALL'} = 'C';
13     $ENV{LANGUAGE} = 'C'; # GNU locale extension
14 }
15
16 # Tests Todo:
17 #       'main' as root
18
19 use vars qw($bar);
20
21 use Opcode 1.00, qw(opdesc opset opset_to_ops opset_to_hex
22         opmask_add full_opset empty_opset opcodes opmask define_optag);
23
24 use Safe 1.00;
25
26 my $last_test; # initalised at end
27 print "1..$last_test\n";
28
29 # Set up a package namespace of things to be visible to the unsafe code
30 $Root::foo = "visible";
31 $bar = "invisible";
32
33 # Stop perl from moaning about identifies which are apparently only used once
34 $Root::foo .= "";
35
36 my $cpt;
37 # create and destroy a couple of automatic Safe compartments first
38 $cpt = new Safe or die;
39 $cpt = new Safe or die;
40
41 $cpt = new Safe "Root";
42
43 $cpt->reval(q{ system("echo not ok 1"); });
44 if ($@ =~ /^system trapped by operation mask/) {
45     print "ok 1\n";
46 } else {
47     print "#$@" if $@;
48     print "not ok 1\n";
49 }
50
51 $cpt->reval(q{
52     print $foo eq 'visible'             ? "ok 2\n" : "not ok 2\n";
53     print $main::foo  eq 'visible'      ? "ok 3\n" : "not ok 3\n";
54     print defined($bar)                 ? "not ok 4\n" : "ok 4\n";
55     print defined($::bar)               ? "not ok 5\n" : "ok 5\n";
56     print defined($main::bar)           ? "not ok 6\n" : "ok 6\n";
57 });
58 print $@ ? "not ok 7\n#$@" : "ok 7\n";
59
60 $foo = "ok 8\n";
61 %bar = (key => "ok 9\n");
62 @baz = (); push(@baz, "o", "10"); $" = 'k ';
63 $glob = "ok 11\n";
64 @glob = qw(not ok 16);
65
66 sub sayok { print "ok @_\n" }
67
68 $cpt->share(qw($foo %bar @baz *glob sayok));
69 $cpt->share('$"') unless $Config{use5005threads};
70
71 $cpt->reval(q{
72     package other;
73     sub other_sayok { print "ok @_\n" }
74     package main;
75     print $foo ? $foo : "not ok 8\n";
76     print $bar{key} ? $bar{key} : "not ok 9\n";
77     (@baz) ? print "@baz\n" : print "not ok 10\n";
78     print $glob;
79     other::other_sayok(12);
80     $foo =~ s/8/14/;
81     $bar{new} = "ok 15\n";
82     @glob = qw(ok 16);
83 });
84 print $@ ? "not ok 13\n#$@" : "ok 13\n";
85 $" = ' ';
86 print $foo, $bar{new}, "@glob\n";
87
88 $Root::foo = "not ok 17";
89 @{$cpt->varglob('bar')} = qw(not ok 18);
90 ${$cpt->varglob('foo')} = "ok 17";
91 @Root::bar = "ok";
92 push(@Root::bar, "18"); # Two steps to prevent "Identifier used only once..."
93
94 print "$Root::foo\n";
95 print "@{$cpt->varglob('bar')}\n";
96
97 use strict;
98
99 print 1 ? "ok 19\n" : "not ok 19\n";
100 print 1 ? "ok 20\n" : "not ok 20\n";
101
102 my $m1 = $cpt->mask;
103 $cpt->trap("negate");
104 my $m2 = $cpt->mask;
105 my @masked = opset_to_ops($m1);
106 print $m2 eq opset("negate", @masked) ? "ok 21\n" : "not ok 21\n";
107
108 print eval { $cpt->mask("a bad mask") } ? "not ok 22\n" : "ok 22\n";
109
110 print $cpt->reval("2 + 2") == 4 ? "ok 23\n" : "not ok 23\n";
111
112 $cpt->mask(empty_opset);
113 my $t_scalar = $cpt->reval('print wantarray ? "not ok 24\n" : "ok 24\n"');
114 print $cpt->reval('@ary=(6,7,8);@ary') == 3 ? "ok 25\n" : "not ok 25\n";
115 my @t_array  = $cpt->reval('print wantarray ? "ok 26\n" : "not ok 26\n"; (2,3,4)');
116 print $t_array[2] == 4 ? "ok 27\n" : "not ok 27\n";
117
118 my $t_scalar2 = $cpt->reval('die "foo bar"; 1');
119 print defined $t_scalar2 ? "not ok 28\n" : "ok 28\n";
120 print $@ =~ /foo bar/ ? "ok 29\n" : "not ok 29\n";
121
122 # --- rdo
123   
124 my $t = 30;
125 $cpt->rdo('/non/existant/file.name');
126 # The regexp is getting rather baroque.
127 print $! =~ /cannot find|No such file|file specification syntax error|A file or directory in the path name does not exist|Invalid argument|Device not configured|file not found|File or directory doesn't exist/i ? "ok $t\n" : "not ok $t # $!\n"; $t++;
128 # test #31 is gone.
129 print 1 ? "ok $t\n" : "not ok $t\n#$@/$!\n"; $t++;
130   
131 #my $rdo_file = "tmp_rdo.tpl";
132 #if (open X,">$rdo_file") {
133 #    print X "999\n";
134 #    close X;
135 #    $cpt->permit_only('const', 'leaveeval');
136 #    print  $cpt->rdo($rdo_file) == 999 ? "ok $t\n" : "not ok $t\n"; $t++;
137 #    unlink $rdo_file;
138 #}
139 #else {
140 #    print "# test $t skipped, can't open file: $!\nok $t\n"; $t++;
141 #}
142
143
144 print "ok $last_test\n";
145 BEGIN { $last_test = 32 }