1#!./perl -w 2$|=1; 3BEGIN { 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 14use Opcode 1.00, qw(opdesc opset opset_to_ops opset_to_hex 15 opmask_add full_opset empty_opset opcodes opmask define_optag); 16 17use Safe 1.00; 18 19use Test::More; 20my $TB = Test::Builder->new(); 21 22# Set up a package namespace of things to be visible to the unsafe code 23$Root::foo = "visible"; 24our $bar = "invisible"; 25 26# Stop perl from moaning about identifies which are apparently only used once 27$Root::foo .= ""; 28 29my $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"); }); 39like($@, 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); 49is($@, ''); 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 57sub 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); 80is($@, ''); 81is($foo, "ok 14\n"); 82is($bar{new}, "ok 15\n"); 83is("@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"; 89push(@Root::bar, "18"); # Two steps to prevent "Identifier used only once..." 90 91is($Root::foo, 'ok 17'); 92is("@{$cpt->varglob('bar')}", 'ok 18'); 93 94use strict; 95 96my $m1 = $cpt->mask; 97$cpt->trap("negate"); 98my $m2 = $cpt->mask; 99my @masked = opset_to_ops($m1); 100is(opset("negate", @masked), $m2); 101 102is(eval { $cpt->mask("a bad mask") }, undef); 103isnt($@, ''); 104 105is($cpt->reval("2 + 2"), 4); 106 107my $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; 115my $t_scalar = $cpt->reval("print wantarray ? 'not ok $test\n' : 'ok $test\n'"); 116++$test; 117my @t_array = $cpt->reval("print wantarray ? 'ok $test\n' : 'not ok $test\n'; (2,3,4)"); 118$TB->current_test($test); 119 120is($t_array[2], 4); 121 122is($cpt->reval('@ary=(6,7,8);@ary'), 3); 123 124my $t_scalar2 = $cpt->reval('die "foo bar"; 1'); 125is($t_scalar2, undef); 126like($@, qr/foo bar/); 127 128# --- rdo 129 130$! = 0; 131my $nosuch = '/non/existent/file.name'; 132open(NOSUCH, '<', $nosuch); 133if ($@) { 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} 142close(NOSUCH); 143 144done_testing(); 145