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