1BEGIN { 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 18use strict; 19#use Test::More qw(no_plan); 20use Test::More tests => 50; 21use Encode q(:all); 22 23my $uo = ''; 24my $nf = ''; 25my ($af, $aq, $ap, $ah, $ax, $uf, $uq, $up, $uh, $ux, $ac, $uc); 26for 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 33my $residue = ''; 34for 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 49my $ao = $uo; 50utf8::upgrade($uo); 51 52my $ascii = find_encoding('ascii'); 53my $utf8 = find_encoding('utf8'); 54 55my $src = $uo; 56my $dst = $ascii->encode($src, FB_DEFAULT); 57is($dst, $af, "FB_DEFAULT ascii"); 58is($src, $uo, "FB_DEFAULT residue ascii"); 59 60$src = $ao; 61$dst = $utf8->decode($src, FB_DEFAULT); 62is($dst, $uf, "FB_DEFAULT utf8"); 63is($src, $ao, "FB_DEFAULT residue utf8"); 64 65$src = $uo; 66eval{ $dst = $ascii->encode($src, FB_CROAK) }; 67like($@, qr/does not map to ascii/o, "FB_CROAK ascii"); 68is($src, $uo, "FB_CROAK residue ascii"); 69 70$src = $ao; 71eval{ $dst = $utf8->decode($src, FB_CROAK) }; 72like($@, qr/does not map to Unicode/o, "FB_CROAK utf8"); 73is($src, $ao, "FB_CROAK residue utf8"); 74 75$src = $nf; 76eval{ $dst = $ascii->encode($src, FB_CROAK) }; 77is($@, '', "FB_CROAK on success ascii"); 78is($src, '', "FB_CROAK on success residue ascii"); 79 80$src = $nf; 81eval{ $dst = $utf8->decode($src, FB_CROAK) }; 82is($@, '', "FB_CROAK on success utf8"); 83is($src, '', "FB_CROAK on success residue utf8"); 84 85$src = $uo; 86$dst = $ascii->encode($src, FB_QUIET); 87is($dst, $aq, "FB_QUIET ascii"); 88is($src, $residue, "FB_QUIET residue ascii"); 89 90$src = $ao; 91$dst = $utf8->decode($src, FB_QUIET); 92is($dst, $uq, "FB_QUIET utf8"); 93is($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); 129is($dst, $ap, "FB_PERLQQ encode"); 130is($src, $uo, "FB_PERLQQ residue encode"); 131 132$src = $ao; 133$dst = $ascii->decode($src, FB_PERLQQ); 134is($dst, $up, "FB_PERLQQ decode"); 135is($src, $ao, "FB_PERLQQ residue decode"); 136 137$src = $uo; 138$dst = $ascii->encode($src, FB_HTMLCREF); 139is($dst, $ah, "FB_HTMLCREF encode"); 140is($src, $uo, "FB_HTMLCREF residue encode"); 141 142$src = $ao; 143$dst = $ascii->decode($src, FB_HTMLCREF); 144is($dst, $uh, "FB_HTMLCREF decode"); 145is($src, $ao, "FB_HTMLCREF residue decode"); 146 147$src = $uo; 148$dst = $ascii->encode($src, FB_XMLCREF); 149is($dst, $ax, "FB_XMLCREF encode"); 150is($src, $uo, "FB_XMLCREF residue encode"); 151 152$src = $ao; 153$dst = $ascii->decode($src, FB_XMLCREF); 154is($dst, $ux, "FB_XMLCREF decode"); 155is($src, $ao, "FB_XMLCREF residue decode"); 156 157$src = $uo; 158$dst = $ascii->encode($src, sub{ sprintf "<U+%04X>", shift }); 159is($dst, $ac, "coderef encode"); 160is($src, $uo, "coderef residue encode"); 161 162$src = $ao; 163$dst = $ascii->decode($src, sub{ sprintf "[%02X]", shift }); 164is($dst, $uc, "coderef decode"); 165is($src, $ao, "coderef residue decode"); 166 167$src = "\x{3000}"; 168$dst = $ascii->encode($src, sub{ $_[0] }); 169is $dst, 0x3000."", qq{$ascii->encode(\$src, sub{ \$_[0] } )}; 170$dst = encode("ascii", "\x{3000}", sub{ $_[0] }); 171is $dst, 0x3000."", qq{encode("ascii", "\\x{3000}", sub{ \$_[0] })}; 172 173$src = pack "C*", 0xFF; 174$dst = $ascii->decode($src, sub{ $_[0] }); 175is $dst, 0xFF."", qq{$ascii->encode(\$src, sub{ \$_[0] } )}; 176$dst = decode("ascii", (pack "C*", 0xFF), sub{ $_[0] }); 177is $dst, 0xFF."", qq{decode("ascii", (pack "C*", 0xFF), sub{ \$_[0] })}; 178 179 180$src = pack "C*", 0x80; 181$dst = $utf8->decode($src, sub{ $_[0] }); 182is $dst, 0x80."", qq{$utf8->encode(\$src, sub{ \$_[0] } )}; 183$dst = decode("utf8", $src, sub{ $_[0] }); 184is $dst, 0x80."", qq{decode("utf8", (pack "C*", 0x80), sub{ \$_[0] })}; 185