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 my $trigger = q{ my $a = pack('U',0xC4); my $b = chr utf8::unicode_to_native(0xE4); utf8::upgrade $b; $a =~ /$b/i };
  25
  26 ok $safe->reval( $trigger ), 'trigger expression should return true';
  27 is $@, '', 'trigger expression should not die';
  28
  29 # return a closure
  30 my $sub = $safe->reval(q{sub { warn pack('U',0xC4) }});
  31
  32 # define code outside Safe that'll be triggered from inside
  33 my @warns;
  34 $SIG{__WARN__} = sub {
  35     my $msg = shift;
  36     # this regex requires a different SWASH digit data for \d)
  37     # than the one used above and by the trigger code in Safe.pm
  38     $msg =~ s/\(eval \d+\)/XXX/i; # uses IsDigit SWASH
  39     push @warns, $msg;
  40 };
  41
  42 is eval { $sub->() }, 1, 'warn should return 1';
  43 is $@, '', '__WARN__ hook should not die';
  44 is @warns, 1, 'should only be 1 warning';
  45 like $warns[0], qr/at XXX line/, 'warning should have been edited';
  46