This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
dist/Safe/t/safeutf8.t: Fix to work on early Perls
[perl5.git] / dist / Safe / t / safeutf8.t
1 #!perl -w
2 $|=1;
3 BEGIN {
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 use Test::More tests => 7;
12
13 use Safe 1.00;
14 use Opcode qw(full_opset);
15
16 pass;
17
18 my $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
25 my $trigger = q{ my $a = pack('U',0xC4); my $b = chr }
26             . (($] lt 5.007_003) ? "" : 'utf8::unicode_to_native(')
27             . '0xE4'
28             . (($] lt 5.007_003) ? "" : ')')
29             . q{; utf8::upgrade $b; $a =~ /$b/i };
30
31 ok $safe->reval( $trigger ), 'trigger expression should return true';
32 is $@, '', 'trigger expression should not die';
33
34 # return a closure
35 my $sub = $safe->reval(q{sub { warn pack('U',0xC4) }});
36
37 # define code outside Safe that'll be triggered from inside
38 my @warns;
39 $SIG{__WARN__} = sub {
40     my $msg = shift;
41     # this regex requires a different SWASH digit data for \d)
42     # than the one used above and by the trigger code in Safe.pm
43     $msg =~ s/\(eval \d+\)/XXX/i; # uses IsDigit SWASH
44     push @warns, $msg;
45 };
46
47 is eval { $sub->() }, 1, 'warn should return 1';
48 is $@, '', '__WARN__ hook should not die';
49 is @warns, 1, 'should only be 1 warning';
50 like $warns[0], qr/at XXX line/, 'warning should have been edited';
51