1N/A#!perl -w
1N/A$|=1;
1N/ABEGIN {
1N/A require Config; import Config;
1N/A if ($Config{'extensions'} !~ /\bOpcode\b/ && $Config{'osname'} ne 'VMS') {
1N/A print "1..0\n";
1N/A exit 0;
1N/A }
1N/A}
1N/A
1N/Ause Test::More tests => 7;
1N/A
1N/Ause Safe 1.00;
1N/Ause Opcode qw(full_opset);
1N/A
1N/Apass;
1N/A
1N/Amy $safe = Safe->new('PLPerl');
1N/A$safe->deny_only();
1N/A
1N/A# Expression that triggers require utf8 and call to SWASHNEW.
1N/A# Fails with "Undefined subroutine PLPerl::utf8::SWASHNEW called"
1N/A# if SWASHNEW is not shared, else returns true if unicode logic is working.
1N/Amy $trigger = q{ my $a = pack('U',0xC4); my $b = chr 0xE4; utf8::upgrade $b; $a =~ /$b/i };
1N/A
1N/Aok $safe->reval( $trigger ), 'trigger expression should return true';
1N/Ais $@, '', 'trigger expression should not die';
1N/A
1N/A# return a closure
1N/Amy $sub = $safe->reval(q{sub { warn pack('U',0xC4) }});
1N/A
1N/A# define code outside Safe that'll be triggered from inside
1N/Amy @warns;
1N/A$SIG{__WARN__} = sub {
1N/A my $msg = shift;
1N/A # this regex requires a different SWASH digit data for \d)
1N/A # than the one used above and by the trigger code in Safe.pm
1N/A $msg =~ s/\(eval \d+\)/XXX/i; # uses IsDigit SWASH
1N/A push @warns, $msg;
1N/A};
1N/A
1N/Ais eval { $sub->() }, 1, 'warn should return 1';
1N/Ais $@, '', '__WARN__ hook should not die';
1N/Ais @warns, 1, 'should only be 1 warning';
1N/Alike $warns[0], qr/at XXX line/, 'warning should have been edited';
1N/A