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 $cpt->reval("
 111     my \$todo = \$] < 5.021007 ? ' # TODO' : '';
 112     print defined wantarray
 113         ? qq'not ok $test\$todo\n'
 114         : qq'ok $test\$todo\n'
 115 ");
 116 ++$test;
 117 my $t_scalar = $cpt->reval("print wantarray ? 'not ok $test\n' : 'ok $test\n'");
 118 ++$test;
 119 my @t_array  = $cpt->reval("print wantarray ? 'ok $test\n' : 'not ok $test\n'; (2,3,4)");
 120 $TB->current_test($test);
 121
 122 is($t_array[2], 4);
 123
 124 is($cpt->reval('@ary=(6,7,8);@ary'), 3);
 125
 126 my $t_scalar2 = $cpt->reval('die "foo bar"; 1');
 127 is($t_scalar2, undef);
 128 like($@, qr/foo bar/);
 129
 130 # --- rdo
 131
 132 $! = 0;
 133 my $nosuch = '/non/existent/file.name';
 134 open(NOSUCH, $nosuch);
 135 if ($@) {
 136     my $errno = $!;
 137     die "Eek! Attempting to open $nosuch failed, but \$! is still 0" unless $!;
 138     $! = 0;
 139     $cpt->rdo($nosuch);
 140     is($!, $errno);
 141 } else {
 142     die "Eek! Didn't expect $nosuch to be there.";
 143 }
 144 close(NOSUCH);
 145
 146 done_testing();