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
11use Test::More tests => 7;
12
13use Safe 1.00;
14use Opcode qw(full_opset);
15
16pass;
17
18my $safe = Safe->new('PLPerl');
19$safe->deny_only();
20
21# Expression that triggers require utf8 and call to SWASHNEW.
22# Fails with "Undefined subroutine PLPerl::utf8::SWASHNEW called"
23# if SWASHNEW is not shared, else returns true if unicode logic is working.
24# (For early Perls we don't take into account EBCDIC, so will fail there
25my $trigger = q{ my $a = pack('U',0xB6); $a =~ tr/\x{1234}//rd };
26
27ok $safe->reval( $trigger ), 'trigger expression should return true';
28is $@, '', 'trigger expression should not die';
29
30# return a closure
31my $sub = $safe->reval(q{sub { warn pack('U',0xB6) }});
32
33# define code outside Safe that'll be triggered from inside
34my @warns;
35$SIG{__WARN__} = sub {
36    my $msg = shift;
37    # this regex requires a different SWASH digit data for \d)
38    # than the one used above and by the trigger code in Safe.pm
39    $msg =~ s/\(eval \d+\)/XXX/i; # uses IsDigit SWASH
40    push @warns, $msg;
41};
42
43is eval { $sub->() }, 1, 'warn should return 1';
44is $@, '', '__WARN__ hook should not die';
45is @warns, 1, 'should only be 1 warning';
46like $warns[0], qr/at XXX line/, 'warning should have been edited';
47
48