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     if (ord("A") == 193) {
  12     print "1..0 # Skip: EBCDIC\n";
  13     exit 0;
  14     }
  15     $| = 1;
  16 }
  17
  18 use strict;
  19 #use Test::More qw(no_plan);
  20 use Test::More tests => 44;
  21 use Encode q(:all);
  22
  23 my $uo = '';
  24 my $nf  = '';
  25 my ($af, $aq, $ap, $ah, $ax, $uf, $uq, $up, $uh, $ux, $ac, $uc);
  26 for my $i (0x20..0x7e){
  27     $uo .= chr($i);
  28 }
  29 $af = $aq = $ap = $ah = $ax = $ac =
  30 $uf = $uq = $up = $uh = $ux = $uc =
  31 $nf = $uo;
  32
  33 my $residue = '';
  34 for my $i (0x80..0xff){
  35     $uo   .= chr($i);
  36     $residue    .= chr($i);
  37     $af .= '?';
  38     $uf .= "\x{FFFD}";
  39     $ap .= sprintf("\\x{%04x}", $i);
  40     $up .= sprintf("\\x%02X", $i);
  41     $ah .= sprintf("&#%d;", $i);
  42     $uh .= sprintf("\\x%02X", $i);
  43     $ax .= sprintf("&#x%x;", $i);
  44     $ux .= sprintf("\\x%02X", $i);
  45     $ac .= sprintf("<U+%04X>", $i);
  46     $uc .= sprintf("[%02X]", $i);
  47 }
  48
  49 my $ao = $uo;
  50 utf8::upgrade($uo);
  51
  52 my $ascii  = find_encoding('ascii');
  53 my $utf8   = find_encoding('utf8');
  54
  55 my $src = $uo;
  56 my $dst = $ascii->encode($src, FB_DEFAULT);
  57 is($dst, $af, "FB_DEFAULT ascii");
  58 is($src, $uo, "FB_DEFAULT residue ascii");
  59
  60 $src = $ao;
  61 $dst = $utf8->decode($src, FB_DEFAULT);
  62 is($dst, $uf, "FB_DEFAULT utf8");
  63 is($src, $ao, "FB_DEFAULT residue utf8");
  64
  65 $src = $uo;
  66 eval{ $dst = $ascii->encode($src, FB_CROAK) };
  67 like($@, qr/does not map to ascii/o, "FB_CROAK ascii");
  68 is($src, $uo, "FB_CROAK residue ascii");
  69
  70 $src = $ao;
  71 eval{ $dst = $utf8->decode($src, FB_CROAK) };
  72 like($@, qr/does not map to Unicode/o, "FB_CROAK utf8");
  73 is($src, $ao, "FB_CROAK residue utf8");
  74
  75 $src = $nf;
  76 eval{ $dst = $ascii->encode($src, FB_CROAK) };
  77 is($@, '', "FB_CROAK on success ascii");
  78 is($src, '', "FB_CROAK on success residue ascii");
  79
  80 $src = $nf;
  81 eval{ $dst = $utf8->decode($src, FB_CROAK) };
  82 is($@, '', "FB_CROAK on success utf8");
  83 is($src, '', "FB_CROAK on success residue utf8");
  84
  85 $src = $uo;
  86 $dst = $ascii->encode($src, FB_QUIET);
  87 is($dst, $aq,   "FB_QUIET ascii");
  88 is($src, $residue, "FB_QUIET residue ascii");
  89
  90 $src = $ao;
  91 $dst = $utf8->decode($src, FB_QUIET);
  92 is($dst, $uq,   "FB_QUIET utf8");
  93 is($src, $residue, "FB_QUIET residue utf8");
  94
  95 {
  96     my $message = '';
  97     local $SIG{__WARN__} = sub { $message = $_[0] };
  98
  99     $src = $uo;
 100     $dst = $ascii->encode($src, FB_WARN);
 101     is($dst, $aq,   "FB_WARN ascii");
 102     is($src, $residue, "FB_WARN residue ascii");
 103     like($message, qr/does not map to ascii/o, "FB_WARN message ascii");
 104
 105     $message = '';
 106     $src = $ao;
 107     $dst = $utf8->decode($src, FB_WARN);
 108     is($dst, $uq,   "FB_WARN utf8");
 109     is($src, $residue, "FB_WARN residue utf8");
 110     like($message, qr/does not map to Unicode/o, "FB_WARN message utf8");
 111
 112     $message = '';
 113     $src = $uo;
 114     $dst = $ascii->encode($src, WARN_ON_ERR);
 115     is($dst, $af, "WARN_ON_ERR ascii");
 116     is($src, '',  "WARN_ON_ERR residue ascii");
 117     like($message, qr/does not map to ascii/o, "WARN_ON_ERR message ascii");
 118
 119     $message = '';
 120     $src = $ao;
 121     $dst = $utf8->decode($src, WARN_ON_ERR);
 122     is($dst, $uf, "WARN_ON_ERR utf8");
 123     is($src, '',  "WARN_ON_ERR residue utf8");
 124     like($message, qr/does not map to Unicode/o, "WARN_ON_ERR message ascii");
 125 }
 126
 127 $src = $uo;
 128 $dst = $ascii->encode($src, FB_PERLQQ);
 129 is($dst, $ap, "FB_PERLQQ encode");
 130 is($src, $uo, "FB_PERLQQ residue encode");
 131
 132 $src = $ao;
 133 $dst = $ascii->decode($src, FB_PERLQQ);
 134 is($dst, $up, "FB_PERLQQ decode");
 135 is($src, $ao, "FB_PERLQQ residue decode");
 136
 137 $src = $uo;
 138 $dst = $ascii->encode($src, FB_HTMLCREF);
 139 is($dst, $ah, "FB_HTMLCREF encode");
 140 is($src, $uo, "FB_HTMLCREF residue encode");
 141
 142 $src = $ao;
 143 $dst = $ascii->decode($src, FB_HTMLCREF);
 144 is($dst, $uh, "FB_HTMLCREF decode");
 145 is($src, $ao, "FB_HTMLCREF residue decode");
 146
 147 $src = $uo;
 148 $dst = $ascii->encode($src, FB_XMLCREF);
 149 is($dst, $ax, "FB_XMLCREF encode");
 150 is($src, $uo, "FB_XMLCREF residue encode");
 151
 152 $src = $ao;
 153 $dst = $ascii->decode($src, FB_XMLCREF);
 154 is($dst, $ux, "FB_XMLCREF decode");
 155 is($src, $ao, "FB_XMLCREF residue decode");
 156
 157 $src = $uo;
 158 $dst = $ascii->encode($src, sub{ sprintf "<U+%04X>", shift });
 159 is($dst, $ac, "coderef encode");
 160 is($src, $uo, "coderef residue encode");
 161
 162 $src = $ao;
 163 $dst = $ascii->decode($src, sub{ sprintf "[%02X]", shift });
 164 is($dst, $uc, "coderef decode");
 165 is($src, $ao, "coderef residue decode");