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