safeutf8.t revision 1.3
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