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 vars qw($bar); 15 16use Opcode 1.00, qw(opdesc opset opset_to_ops opset_to_hex 17 opmask_add full_opset empty_opset opcodes opmask define_optag); 18 19use Safe 1.00; 20 21use Test::More; 22my $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 31my $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"); }); 41like($@, 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); 51is($@, ''); 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 59sub 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); 82is($@, ''); 83is($foo, "ok 14\n"); 84is($bar{new}, "ok 15\n"); 85is("@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"; 91push(@Root::bar, "18"); # Two steps to prevent "Identifier used only once..." 92 93is($Root::foo, 'ok 17'); 94is("@{$cpt->varglob('bar')}", 'ok 18'); 95 96use strict; 97 98my $m1 = $cpt->mask; 99$cpt->trap("negate"); 100my $m2 = $cpt->mask; 101my @masked = opset_to_ops($m1); 102is(opset("negate", @masked), $m2); 103 104is(eval { $cpt->mask("a bad mask") }, undef); 105isnt($@, ''); 106 107is($cpt->reval("2 + 2"), 4); 108 109my $test = $TB->current_test() + 1; 110my $t_scalar = $cpt->reval("print wantarray ? 'not ok $test\n' : 'ok $test\n'"); 111++$test; 112my @t_array = $cpt->reval("print wantarray ? 'ok $test\n' : 'not ok $test\n'; (2,3,4)"); 113$TB->current_test($test); 114 115is($t_array[2], 4); 116 117is($cpt->reval('@ary=(6,7,8);@ary'), 3); 118 119my $t_scalar2 = $cpt->reval('die "foo bar"; 1'); 120is($t_scalar2, undef); 121like($@, qr/foo bar/); 122 123# --- rdo 124 125$! = 0; 126my $nosuch = '/non/existent/file.name'; 127open(NOSUCH, $nosuch); 128if ($@) { 129 my $errno = $!; 130 die "Eek! Attempting to open $nosuch failed, but \$! is still 0" unless $!; 131 $! = 0; 132 $cpt->rdo($nosuch); 133 is($!, $errno); 134} else { 135 die "Eek! Didn't expect $nosuch to be there."; 136} 137close(NOSUCH); 138 139#my $rdo_file = "tmp_rdo.tpl"; 140#if (open X,">$rdo_file") { 141# print X "999\n"; 142# close X; 143# $cpt->permit_only('const', 'leaveeval'); 144# $cpt->rdo($rdo_file) == 999 ? "ok $t\n" : "not ok $t\n"; $t++; 145# unlink $rdo_file; 146#} 147#else { 148# print "# test $t skipped, can't open file: $!\nok $t\n"; $t++; 149#} 150 151done_testing(); 152