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 Opcode 1.00, qw(opdesc opset opset_to_ops opset_to_hex
  15         opmask_add full_opset empty_opset opcodes opmask define_optag);
  16
  17 use Safe 1.00;
  18
  19 use Test::More;
  20 my $TB = Test::Builder->new();
  21
  22 # Set up a package namespace of things to be visible to the unsafe code
  23 $Root::foo = "visible";
  24 our $bar = "invisible";
  25
  26 # Stop perl from moaning about identifies which are apparently only used once
  27 $Root::foo .= "";
  28
  29 my $cpt;
  30 # create and destroy a couple of automatic Safe compartments first
  31 $cpt = new Safe or die;
  32 $cpt = new Safe or die;
  33
  34 $cpt = new Safe "Root";
  35
  36 $cpt->permit(qw(:base_io));
  37
  38 $cpt->reval(q{ system("echo not ok 1"); });
  39 like($@, qr/^'?system'? trapped by operation mask/);
  40
  41 $cpt->reval(q{
  42     print $foo eq 'visible'             ? "ok 2\n" : "not ok 2\n";
  43     print $main::foo  eq 'visible'      ? "ok 3\n" : "not ok 3\n";
  44     print defined($bar)                 ? "not ok 4\n" : "ok 4\n";
  45     print defined($::bar)               ? "not ok 5\n" : "ok 5\n";
  46     print defined($main::bar)           ? "not ok 6\n" : "ok 6\n";
  47 });
  48 $TB->current_test(6);
  49 is($@, '');
  50
  51 $foo = "ok 8\n";
  52 %bar = (key => "ok 9\n");
  53 @baz = (); push(@baz, "o", "10");
  54 $glob = "ok 11\n";
  55 @glob = qw(not ok 16);
  56
  57 sub sayok { print "ok @_\n" }
  58
  59 $cpt->share(qw($foo %bar @baz *glob sayok));
  60 $cpt->share('$"') unless $Config{use5005threads};
  61
  62 {
  63     $" = 'k ';
  64     $cpt->reval(q{
  65     package other;
  66     sub other_sayok { print "ok @_\n" }
  67     package main;
  68     print $foo ? $foo : "not ok 8\n";
  69     print $bar{key} ? $bar{key} : "not ok 9\n";
  70     (@baz) ? print "@baz\n" : print "not ok 10\n";
  71     print $glob;
  72     other::other_sayok(12);
  73     $foo =~ s/8/14/;
  74     $bar{new} = "ok 15\n";
  75     @glob = qw(ok 16);
  76     $" = ' ';
  77 });
  78 }
  79 $TB->current_test(12);
  80 is($@, '');
  81 is($foo, "ok 14\n");
  82 is($bar{new}, "ok 15\n");
  83 is("@glob", "ok 16");
  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";
  89 push(@Root::bar, "18"); # Two steps to prevent "Identifier used only once..."
  90
  91 is($Root::foo, 'ok 17');
  92 is("@{$cpt->varglob('bar')}", 'ok 18');
  93
  94 use strict;
  95
  96 my $m1 = $cpt->mask;
  97 $cpt->trap("negate");
  98 my $m2 = $cpt->mask;
  99 my @masked = opset_to_ops($m1);
 100 is(opset("negate", @masked), $m2);
 101
 102 is(eval { $cpt->mask("a bad mask") }, undef);
 103 isnt($@, '');
 104
 105 is($cpt->reval("2 + 2"), 4);
 106
 107 my $test = $TB->current_test() + 1;
 108 $cpt->reval("
 109     my \$todo = \$] < 5.021007 ? ' # TODO' : '';
 110     print defined wantarray
 111         ? qq'not ok $test\$todo\n'
 112         : qq'ok $test\$todo\n'
 113 ");
 114 ++$test;
 115 my $t_scalar = $cpt->reval("print wantarray ? 'not ok $test\n' : 'ok $test\n'");
 116 ++$test;
 117 my @t_array  = $cpt->reval("print wantarray ? 'ok $test\n' : 'not ok $test\n'; (2,3,4)");
 118 $TB->current_test($test);
 119
 120 is($t_array[2], 4);
 121
 122 is($cpt->reval('@ary=(6,7,8);@ary'), 3);
 123
 124 my $t_scalar2 = $cpt->reval('die "foo bar"; 1');
 125 is($t_scalar2, undef);
 126 like($@, qr/foo bar/);
 127
 128 # --- rdo
 129
 130 $! = 0;
 131 my $nosuch = '/non/existent/file.name';
 132 open(NOSUCH, '<', $nosuch);
 133 if ($@) {
 134     my $errno = $!;
 135     die "Eek! Attempting to open $nosuch failed, but \$! is still 0" unless $!;
 136     $! = 0;
 137     $cpt->rdo($nosuch);
 138     is($!, $errno);
 139 } else {
 140     die "Eek! Didn't expect $nosuch to be there.";
 141 }
 142 close(NOSUCH);
 143
 144 done_testing();