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 => 40;
  21 use Encode q(:all);
  22
  23 my $uo = '';
  24 my $nf  = '';
  25 my ($af, $aq, $ap, $ah, $ax, $uf, $uq, $up, $uh, $ux);
  26 for my $i (0x20..0x7e){
  27     $uo .= chr($i);
  28 }
  29 $af = $aq = $ap = $ah = $ax =
  30 $uf = $uq = $up = $uh = $ux =
  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("&#%d;", $i);
  43     $ax .= sprintf("&#x%x;", $i);
  44     $ux .= sprintf("&#x%x;", $i);
  45 }
  46
  47 my $ao = $uo;
  48 utf8::upgrade($uo);
  49
  50 my $ascii  = find_encoding('ascii');
  51 my $utf8   = find_encoding('utf8');
  52
  53 my $src = $uo;
  54 my $dst = $ascii->encode($src, FB_DEFAULT);
  55 is($dst, $af, "FB_DEFAULT ascii");
  56 is($src, $uo, "FB_DEFAULT residue ascii");
  57
  58 $src = $ao;
  59 $dst = $utf8->decode($src, FB_DEFAULT);
  60 is($dst, $uf, "FB_DEFAULT utf8");
  61 is($src, $ao, "FB_DEFAULT residue utf8");
  62
  63 $src = $uo;
  64 eval{ $dst = $ascii->encode($src, FB_CROAK) };
  65 like($@, qr/does not map to ascii/o, "FB_CROAK ascii");
  66 is($src, $uo, "FB_CROAK residue ascii");
  67
  68 $src = $ao;
  69 eval{ $dst = $utf8->decode($src, FB_CROAK) };
  70 like($@, qr/does not map to Unicode/o, "FB_CROAK utf8");
  71 is($src, $ao, "FB_CROAK residue utf8");
  72
  73 $src = $nf;
  74 eval{ $dst = $ascii->encode($src, FB_CROAK) };
  75 is($@, '', "FB_CROAK on success ascii");
  76 is($src, '', "FB_CROAK on success residue ascii");
  77
  78 $src = $nf;
  79 eval{ $dst = $utf8->decode($src, FB_CROAK) };
  80 is($@, '', "FB_CROAK on success utf8");
  81 is($src, '', "FB_CROAK on success residue utf8");
  82
  83 $src = $uo;
  84 $dst = $ascii->encode($src, FB_QUIET);
  85 is($dst, $aq,   "FB_QUIET ascii");
  86 is($src, $residue, "FB_QUIET residue ascii");
  87
  88 $src = $ao;
  89 $dst = $utf8->decode($src, FB_QUIET);
  90 is($dst, $uq,   "FB_QUIET utf8");
  91 is($src, $residue, "FB_QUIET residue utf8");
  92
  93 {
  94     my $message = '';
  95     local $SIG{__WARN__} = sub { $message = $_[0] };
  96
  97     $src = $uo;
  98     $dst = $ascii->encode($src, FB_WARN);
  99     is($dst, $aq,   "FB_WARN ascii");
 100     is($src, $residue, "FB_WARN residue ascii");
 101     like($message, qr/does not map to ascii/o, "FB_WARN message ascii");
 102
 103     $message = '';
 104     $src = $ao;
 105     $dst = $utf8->decode($src, FB_WARN);
 106     is($dst, $uq,   "FB_WARN utf8");
 107     is($src, $residue, "FB_WARN residue utf8");
 108     like($message, qr/does not map to Unicode/o, "FB_WARN message utf8");
 109
 110     $message = '';
 111     $src = $uo;
 112     $dst = $ascii->encode($src, WARN_ON_ERR);
 113     is($dst, $af, "WARN_ON_ERR ascii");
 114     is($src, '',  "WARN_ON_ERR residue ascii");
 115     like($message, qr/does not map to ascii/o, "WARN_ON_ERR message ascii");
 116
 117     $message = '';
 118     $src = $ao;
 119     $dst = $utf8->decode($src, WARN_ON_ERR);
 120     is($dst, $uf, "WARN_ON_ERR utf8");
 121     is($src, '',  "WARN_ON_ERR residue utf8");
 122     like($message, qr/does not map to Unicode/o, "WARN_ON_ERR message ascii");
 123 }
 124
 125 $src = $uo;
 126 $dst = $ascii->encode($src, FB_PERLQQ);
 127 is($dst, $ap,   "FB_PERLQQ ascii");
 128 is($src, $uo, "FB_PERLQQ residue ascii");
 129
 130 $src = $ao;
 131 $dst = $utf8->decode($src, FB_PERLQQ);
 132 is($dst, $up,   "FB_PERLQQ utf8");
 133 is($src, $ao, "FB_PERLQQ residue utf8");
 134
 135 $src = $uo;
 136 $dst = $ascii->encode($src, FB_HTMLCREF);
 137 is($dst, $ah,   "FB_HTMLCREF ascii");
 138 is($src, $uo, "FB_HTMLCREF residue ascii");
 139
 140 $src = $ao;
 141 $dst = $utf8->decode($src, FB_HTMLCREF);
 142 is($dst, $uh,   "FB_HTMLCREF utf8");
 143 is($src, $ao, "FB_HTMLCREF residue utf8");
 144
 145 $src = $uo;
 146 $dst = $ascii->encode($src, FB_XMLCREF);
 147 is($dst, $ax,   "FB_XMLCREF ascii");
 148 is($src, $uo, "FB_XMLCREF residue ascii");
 149
 150 $src = $ao;
 151 $dst = $utf8->decode($src, FB_XMLCREF);
 152 is($dst, $ax,   "FB_XMLCREF utf8");
 153 is($src, $ao, "FB_XMLCREF residue utf8");