1#!../perl 2 3BEGIN { 4 if ($ENV{'PERL_CORE'}){ 5 chdir 't'; 6 unshift @INC, '../lib'; 7 } 8 require Config; Config->import(); 9 if ($Config{'extensions'} !~ /\bEncode\b/) { 10 print "1..0 # Skip: Encode was not built\n"; 11 exit 0; 12 } 13} 14 15use strict; 16use Encode; 17use Encode::Alias; 18my %a2c; 19my @override_tests; 20my $ON_EBCDIC; 21 22sub init_a2c{ 23 %a2c = ( 24 'US-ascii' => 'ascii', 25 'ISO-646-US' => 'ascii', 26 'UTF-8' => 'utf-8-strict', 27 'en_US.UTF-8' => 'utf-8-strict', 28 'UCS-2' => 'UCS-2BE', 29 'UCS2' => 'UCS-2BE', 30 'iso-10646-1' => 'UCS-2BE', 31 'ucs2-le' => 'UCS-2LE', 32 'ucs2-be' => 'UCS-2BE', 33 'utf16' => 'UTF-16', 34 'utf32' => 'UTF-32', 35 'utf16-be' => 'UTF-16BE', 36 'utf32-be' => 'UTF-32BE', 37 'utf16-le' => 'UTF-16LE', 38 'utf32-le' => 'UTF-32LE', 39 'UCS4-BE' => 'UTF-32BE', 40 'UCS-4-LE' => 'UTF-32LE', 41 'cyrillic' => 'iso-8859-5', 42 'arabic' => 'iso-8859-6', 43 'greek' => 'iso-8859-7', 44 'hebrew' => 'iso-8859-8', 45 'iso-8859-8-I' => 'iso-8859-8', 46 'thai' => 'iso-8859-11', 47 'tis620' => 'iso-8859-11', 48 'tis-620' => 'iso-8859-11', 49 'WinLatin1' => 'cp1252', 50 'WinLatin2' => 'cp1250', 51 'WinCyrillic' => 'cp1251', 52 'WinGreek' => 'cp1253', 53 'WinTurkish' => 'cp1254', 54 'WinHebrew' => 'cp1255', 55 'WinArabic' => 'cp1256', 56 'WinBaltic' => 'cp1257', 57 'WinVietnamese' => 'cp1258', 58 'Macintosh' => 'MacRoman', 59 'koi8r' => 'koi8-r', 60 'koi8u' => 'koi8-u', 61 'ja_JP.euc' => $ON_EBCDIC ? '' : 'euc-jp', 62 'x-euc-jp' => $ON_EBCDIC ? '' : 'euc-jp', 63 'zh_CN.euc' => $ON_EBCDIC ? '' : 'euc-cn', 64 'x-euc-cn' => $ON_EBCDIC ? '' : 'euc-cn', 65 'ko_KR.euc' => $ON_EBCDIC ? '' : 'euc-kr', 66 'x-euc-kr' => $ON_EBCDIC ? '' : 'euc-kr', 67 'ujis' => $ON_EBCDIC ? '' : 'euc-jp', 68 'Shift_JIS' => $ON_EBCDIC ? '' : 'shiftjis', 69 'x-sjis' => $ON_EBCDIC ? '' : 'shiftjis', 70 'jis' => $ON_EBCDIC ? '' : '7bit-jis', 71 'big-5' => $ON_EBCDIC ? '' : 'big5-eten', 72 'zh_TW.Big5' => $ON_EBCDIC ? '' : 'big5-eten', 73 'tca-big5' => $ON_EBCDIC ? '' : 'big5-eten', 74 'big5-hk' => $ON_EBCDIC ? '' : 'big5-hkscs', 75 'hkscs-big5' => $ON_EBCDIC ? '' : 'big5-hkscs', 76 'GB_2312-80' => $ON_EBCDIC ? '' : 'euc-cn', 77 'KS_C_5601-1987' => $ON_EBCDIC ? '' : 'cp949', 78 # 79 'gb12345-raw' => $ON_EBCDIC ? '' : 'gb12345-raw', 80 'gb2312-raw' => $ON_EBCDIC ? '' : 'gb2312-raw', 81 'jis0201-raw' => $ON_EBCDIC ? '' : 'jis0201-raw', 82 'jis0208-raw' => $ON_EBCDIC ? '' : 'jis0208-raw', 83 'jis0212-raw' => $ON_EBCDIC ? '' : 'jis0212-raw', 84 'ksc5601-raw' => $ON_EBCDIC ? '' : 'ksc5601-raw', 85 'cp65000' => 'UTF-7', 86 'cp65001' => 'utf-8-strict', 87 ); 88 89 for my $i (1..11,13..16){ 90 $a2c{"ISO 8859 $i"} = "iso-8859-$i"; 91 } 92 for my $i (1..10){ 93 $a2c{"ISO Latin $i"} = "iso-8859-$Encode::Alias::Latin2iso[$i]"; 94 } 95 for my $k (keys %Encode::Alias::Winlatin2cp){ 96 my $v = $Encode::Alias::Winlatin2cp{$k}; 97 $a2c{"Win" . ucfirst($k)} = "cp" . $v; 98 $a2c{"IBM-$v"} = $a2c{"MS-$v"} = "cp" . $v; 99 $a2c{"cp-" . $v} = "cp" . $v; 100 } 101 my @a2c = keys %a2c; 102 for my $k (@a2c){ 103 $a2c{uc($k)} = $a2c{$k}; 104 $a2c{lc($k)} = $a2c{$k}; 105 $a2c{lcfirst($k)} = $a2c{$k}; 106 $a2c{ucfirst($k)} = $a2c{$k}; 107 } 108} 109 110BEGIN{ 111 $ON_EBCDIC = ord("A") == 193; 112 @ARGV and $ON_EBCDIC = $ARGV[0] eq 'EBCDIC'; 113 $Encode::ON_EBCDIC = $ON_EBCDIC; 114 init_a2c(); 115 @override_tests = qw( 116 myascii:cp1252 117 mygreek:cp1253 118 myhebrew:iso-8859-2 119 myarabic:cp1256 120 ueightsomething:utf-8-strict 121 unknown: 122 ); 123} 124 125if ($ON_EBCDIC){ 126 delete @Encode::ExtModule{ 127 qw(euc-cn gb2312 gb12345 gbk cp936 iso-ir-165 MacChineseSimp 128 euc-jp iso-2022-jp 7bit-jis shiftjis MacJapanese cp932 129 euc-kr ksc5601 cp949 MacKorean 130 big5 big5-hkscs cp950 MacChineseTrad 131 gb18030 big5plus euc-tw) 132 }; 133} 134 135use Test::More tests => (scalar keys %a2c) * 3 + @override_tests; 136 137print "# alias test; \$ON_EBCDIC == $ON_EBCDIC\n"; 138 139foreach my $a (keys %a2c){ 140 print "# $a => $a2c{$a}\n"; 141 my $e = Encode::find_encoding($a); 142 is((defined($e) and $e->name), $a2c{$a},$a) 143 or warn "alias was $a";; 144} 145 146# now we override some of the aliases and see if it works fine 147 148define_alias( 149 qr/ascii/i => '"WinLatin1"', 150 qr/cyrillic/i => '"WinCyrillic"', 151 qr/arabic/i => '"WinArabic"', 152 qr/greek/i => '"WinGreek"', 153 qr/hebrew/i => '"WinHebrew"' 154 ); 155 156Encode::find_encoding("myhebrew"); # polute alias cache 157 158define_alias( sub { 159 my $enc = shift; 160 return "iso-8859-2" if $enc =~ /hebrew/i; 161 return "does-not-exist" if $enc =~ /arabic/i; # should then use other override alias 162 return "utf-8" if $enc =~ /eight/i; 163 return "unknown"; 164}); 165 166print "# alias test with alias overrides\n"; 167 168for my $test (@override_tests) { 169 my($a, $c) = split /:/, $test; 170 my $e = Encode::find_encoding($a); 171 is((defined($e) and $e->name), $c, $a); 172} 173 174print "# alias undef test\n"; 175 176Encode::Alias->undef_aliases; 177foreach my $a (keys %a2c){ 178 my $e = Encode::find_encoding($a); 179 ok(!defined($e) || $e->name =~ /-raw$/o,"Undef $a") 180 or warn "alias was $a"; 181} 182 183print "# alias reinit test\n"; 184 185Encode::Alias->init_aliases; 186init_a2c(); 187foreach my $a (keys %a2c){ 188 my $e = Encode::find_encoding($a); 189 is((defined($e) and $e->name), $a2c{$a}, "Reinit $a") 190 or warn "alias was $a"; 191} 192__END__ 193for my $k (keys %a2c){ 194 $k =~ /[A-Z]/ and next; 195 print "$k => $a2c{$k}\n"; 196} 197 198 199 200