The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.

use strict;
my $loaded;

BEGIN { $| = 1; print "1..25\n"; }
END {print "not ok 1\n" unless $loaded;}
use Safe::Hole;
use Safe;
use Opcode qw( opmask_add opset );
$loaded = 1;
print "ok 1\n";

# Test construction
my $safe = Safe->new;
my $hole = Safe::Hole->new({});
print "ok 2\n";

# Test visibility of root namespace
our $v;

print (( \$v == $safe->reval('\$v') && !$@ ) ? "not ok 3\n" : "ok 3\n");

sub v { eval '\$v' };

print (( \$v != $hole->call(\&v)) ? "not ok 4\n" : "ok 4\n");

$hole->wrap(sub{ eval '\$v' },$safe,'&v_wrapped');
$safe->share('&v');

print (( \$v == $safe->reval('v()') || $@ ) ? "not ok 5\n" : "ok 5\n");

print (( \$v != $safe->reval('v_wrapped()') || $@ ) ? "not ok 6\n" : "ok 6\n");

# First check Safe works as we expect

my $op = '"Somthing innocuous"';
sub do_op { eval $op; $@ }
$safe->share('&do_op');
print ( $safe->reval('do_op()') ? "not ok 7\n" : "ok 7\n");
$op = 'eval "#Something forbidden"';
print ( !$safe->reval('do_op()') ? "not ok 8\n" : "ok 8\n");

# Check Safe::Hole clears the opmask

$hole->wrap(\&do_op,$safe,'&do_op_wrapped');
print ( $safe->reval('do_op_wrapped()') ? "not ok 9\n" : "ok 9\n");

# Reality: check eof allowed
$op = 'eof';
print ( $safe->reval('do_op()') ? "not ok 10\n" : "ok 10\n");

# Disable one opcode
opmask_add(opset('eof'));
# Make sure that opmask is restored
$hole->call(sub{});

# Disabled opcode propagates into Safe compartment
print ( !$safe->reval('do_op()') ? "not ok 11\n" : "ok 11\n");

# Disabled opcode is not disabled via $hole
print ( $hole->call(\&do_op) ? "not ok 12\n" : "ok 12\n");

# Now create a Safe::Hole with a saved opmask
my $hole2 = Safe::Hole->new({});
print "ok 13\n";

# Sanity check it works at all
print (( 666 != $hole2->call(sub{ 666 })) ? "not ok 14\n" : "ok 14\n");

$op = 'length';
print ( $hole2->call(\&do_op) ? "not ok 15\n" : "ok 15\n");

$op = 'eof';
print ( !$hole2->call(\&do_op) ? "not ok 16\n" : "ok 16\n");

$hole2->wrap(\&do_op,$safe,'&do_op_wrapped2');

# We can still get at forbidden op via $hole...
print ( $safe->reval('do_op_wrapped()') ? "not ok 17\n" : "ok 17\n");
# ...but not via $hole2
print ( !$safe->reval('do_op_wrapped2()') ? "not ok 18\n" : "ok 18\n");

# Check argument and return passing

print (( 5 != $hole2->call(sub{ @{$_[2]} },undef,undef,[ 11 .. 15])) ? "not ok 19\n" : "ok 19\n");
print (( ($hole->call(sub{ map { $_ + shift } 10..15 },20..25))[2] != 34 ) ? "not ok 20\n" : "ok 20\n");

# Check exception handling of die
my $did_not_die;
eval { $hole2->call(sub{die "XXX\n"}); $did_not_die++ };
print (( $did_not_die || $@ ne "XXX\n" ) ? "not ok 21\n" : "ok 21\n");

##############################
# Backward compatible mode
###############################

my $old_hole = new Safe::Hole;
$::v = 'v in main';

print "not " unless $old_hole->call( sub { eval '$v' }) eq 'v in main';
print "ok 22\n";

# Alternate root
my $old_hole2 = new Safe::Hole 'foo';
$foo::v = 'v in foo';
print "not " unless $old_hole2->call( sub { eval '$v' }) eq 'v in foo';
print "ok 23\n";

# Check opcode mask not restored in backward compatible mode
$op='eval "#Something forbidden"'; 
$old_hole->wrap(\&do_op,$safe,'&do_op_wrapped_old');
print "not " unless $safe->reval('do_op_wrapped_old()');
print "ok 24\n";

###################################
# Test that require works
##################################
$hole->wrap(sub { require File::Find; 1 },$safe,'&do_require');
print "not " if $INC{'File/Find.pm'} || !$safe->reval('do_require') || !$INC{'File/Find.pm'};
print "ok 25\n";

###################################
# Test wrapping of objects
##################################

# To do