ext/Encode/t/fallback.t

   1 BEGIN {
   2     if ($ENV{'PERL_CORE'}){
   3         chdir 't';
   4         unshift @INC, '../lib';
   5     }
   6     require Config; import Config;
   7     if ($Config{'extensions'} !~ /\bEncode\b/) {
   8       print "1..0 # Skip: Encode was not built\n";
   9       exit 0;
  10     }
  11     $| = 1;
  12 }
  13
  14 use strict;
  15 #use Test::More qw(no_plan);
  16 use Test::More tests => 15;
  17 use Encode q(:all);
  18
  19
  20 my $original = '';
  21 my $nofallback  = '';
  22 my ($fallenback, $quiet, $perlqq);
  23 for my $i (0x20..0x7e){
  24     $original .= chr($i);
  25 }
  26 $fallenback = $quiet = $perlqq = $nofallback = $original;
  27
  28 my $residue = '';
  29 for my $i (0x80..0xff){
  30     $original   .= chr($i);
  31     $residue    .= chr($i);
  32     $fallenback .= '?';
  33     $perlqq     .= sprintf("\\x{%04x}", $i);
  34 }
  35 utf8::upgrade($original);
  36 my $meth   = find_encoding('ascii');
  37
  38 my $src = $original;
  39 my $dst = $meth->encode($src, FB_DEFAULT);
  40 is($dst, $fallenback, "FB_DEFAULT");
  41 is($src, $original,   "FB_DEFAULT residue");
  42
  43 $src = $original;
  44 eval{ $dst = $meth->encode($src, FB_CROAK) };
  45 like($@, qr/does not map to ascii/o, "FB_CROAK");
  46 is($src, $original, "FB_CROAK residue");
  47
  48 $src = $original;
  49 eval{ $dst = $meth->encode($src, FB_CROAK) };
  50 like($@, qr/does not map to ascii/o, "FB_CROAK");
  51 is($src, $original, "FB_CROAK residue");
  52
  53
  54 $src = $nofallback;
  55 eval{ $dst = $meth->encode($src, FB_CROAK) };
  56 is($@, '', "FB_CROAK on success");
  57 is($src, '', "FB_CROAK on success residue");
  58
  59 $src = $original;
  60 $dst = $meth->encode($src, FB_QUIET);
  61 is($dst, $quiet,   "FB_QUIET");
  62 is($src, $residue, "FB_QUIET residue");
  63
  64 {
  65     my $message;
  66     local $SIG{__WARN__} = sub { $message = $_[0] };
  67     $src = $original;
  68     $dst = $meth->encode($src, FB_WARN);
  69     is($dst, $quiet,   "FB_WARN");
  70     is($src, $residue, "FB_WARN residue");
  71     like($message, qr/does not map to ascii/o, "FB_WARN message");
  72 }
  73
  74 $src = $original;
  75 $dst = $meth->encode($src, FB_PERLQQ);
  76 is($dst, $perlqq,   "FB_PERLQQ");
  77 is($src, '', "FB_PERLQQ residue");