1BEGIN { 2 if ($ENV{'PERL_CORE'}){ 3 chdir 't'; 4 unshift @INC, '../lib'; 5 } 6 if (ord("A") == 193) { 7 print "1..0 # Skip: EBCDIC\n"; 8 exit 0; 9 } 10 require Config; import Config; 11 if ($Config{'extensions'} !~ /\bEncode\b/) { 12 print "1..0 # Skip: Encode was not built\n"; 13 exit 0; 14 } 15} 16use strict; 17use Test::More; 18use Encode qw(from_to encode decode 19 encode_utf8 decode_utf8 20 find_encoding is_utf8); 21use charnames qw(greek); 22my @encodings = grep(/iso-?8859/,Encode::encodings()); 23my $n = 2; 24my @character_set = ('0'..'9', 'A'..'Z', 'a'..'z'); 25my @source = qw(ascii iso8859-1 cp1250); 26my @destiny = qw(cp1047 cp37 posix-bc); 27my @ebcdic_sets = qw(cp1047 cp37 posix-bc); 28plan tests => 38+$n*@encodings + 2*@source*@destiny*@character_set + 2*@ebcdic_sets*256 + 6 + 3*8; 29 30my $str = join('',map(chr($_),0x20..0x7E)); 31my $cpy = $str; 32 33my $sym = Encode->getEncoding('symbol'); 34my $uni = $sym->decode(encode(ascii => 'a')); 35is "\N{alpha}",substr($uni,0,1),"alpha does not map to symbol 'a'"; 36$str = $sym->encode("\N{Beta}"); 37is "B",decode(ascii => substr($str,0,1)),"Symbol 'B' does not map to Beta"; 38 39foreach my $enc (qw(symbol dingbats ascii),@encodings) 40 { 41 my $tab = Encode->getEncoding($enc); 42 is 1,defined($tab),"Could not load $enc"; 43 $str = join('',map(chr($_),0x20..0x7E)); 44 $uni = $tab->decode($str); 45 $cpy = $tab->encode($uni); 46 is $cpy,$str,"$enc mangled translating to Unicode and back"; 47 } 48 49# On ASCII based machines see if we can map several codepoints from 50# three distinct ASCII sets to three distinct EBCDIC coded character sets. 51# On EBCDIC machines see if we can map from three EBCDIC sets to three 52# distinct ASCII sets. 53 54my @expectation = (240..249, 193..201,209..217,226..233, 129..137,145..153,162..169); 55if (ord('A') != 65) { 56 my @temp = @destiny; 57 @destiny = @source; 58 @source = @temp; 59 undef(@temp); 60 @expectation = (48..57, 65..90, 97..122); 61} 62 63foreach my $to (@destiny) 64 { 65 foreach my $from (@source) 66 { 67 my @expected = @expectation; 68 foreach my $chr (@character_set) 69 { 70 my $native_chr = $chr; 71 my $cpy = $chr; 72 my $rc = from_to($cpy,$from,$to); 73 is 1,$rc,"Could not translate from $from to $to"; 74 is ord($cpy),shift(@expected),"mangled translating $native_chr from $from to $to"; 75 } 76 } 77 } 78 79# On either ASCII or EBCDIC machines ensure we can take the full one 80# byte repetoire to EBCDIC sets and back. 81 82my $enc_as = 'iso8859-1'; 83foreach my $enc_eb (@ebcdic_sets) 84 { 85 foreach my $ord (0..255) 86 { 87 $str = chr($ord); 88 my $rc = from_to($str,$enc_as,$enc_eb); 89 $rc += from_to($str,$enc_eb,$enc_as); 90 is $rc,2,"return code for $ord $enc_eb -> $enc_as -> $enc_eb was not obtained"; 91 is $ord,ord($str),"$enc_as mangled translating $ord to $enc_eb and back"; 92 } 93 } 94 95my $mime = find_encoding('iso-8859-2'); 96is defined($mime),1,"Cannot find MIME-ish'iso-8859-2'"; 97my $x11 = find_encoding('iso8859-2'); 98is defined($x11),1,"Cannot find X11-ish 'iso8859-2'"; 99is $mime,$x11,"iso8598-2 and iso-8859-2 not same"; 100my $spc = find_encoding('iso 8859-2'); 101is defined($spc),1,"Cannot find 'iso 8859-2'"; 102is $spc,$mime,"iso 8859-2 and iso-8859-2 not same"; 103 104for my $i (256,128,129,256) 105 { 106 my $c = chr($i); 107 my $s = "$c\n".sprintf("%02X",$i); 108 is utf8::valid($s),1,"concat of $i botched"; 109 utf8::upgrade($s); 110 is utf8::valid($s),1,"concat of $i botched"; 111 } 112 113# Spot check a few points in/out of utf8 114for my $i (ord('A'),128,256,0x20AC) 115 { 116 my $c = chr($i); 117 my $o = encode_utf8($c); 118 is decode_utf8($o),$c,"decode_utf8 not inverse of encode_utf8 for $i"; 119 is encode('utf8',$c),$o,"utf8 encode by name broken for $i"; 120 is decode('utf8',$o),$c,"utf8 decode by name broken for $i"; 121 } 122 123 124# is_utf8 125 126ok( is_utf8("\x{100}")); 127ok(! is_utf8("a")); 128ok(! is_utf8("")); 129"\x{100}" =~ /(.)/; 130ok( is_utf8($1)); # ID 20011127.151 131$a = $1; 132ok( is_utf8($a)); 133$a = "\x{100}"; 134chop $a; 135ok( is_utf8($a)); # weird but true: an empty UTF-8 string 136 137# non-string arguments 138package Encode::Dummy; 139use overload q("") => sub { $_[0]->[0] }; 140sub new { my $class = shift; bless [ @_ ] => $class } 141package main; 142ok(decode(latin1 => Encode::Dummy->new("foobar")), "foobar"); 143ok(encode(utf8 => Encode::Dummy->new("foobar")), "foobar"); 144 145# RT#91569 146# decode_utf8 with non-string arguments 147ok(decode_utf8(*1), "*main::1"); 148 149# hash keys 150foreach my $name ("UTF-16LE", "UTF-8", "Latin1") { 151 my $key = (keys %{{ "whatever\x{CA}" => '' }})[0]; 152 my $kopy = $key; 153 encode($name, $kopy, Encode::FB_CROAK); 154 is $key, "whatever\x{CA}", "encode $name with shared hash key scalars"; 155 undef $key; 156 $key = (keys %{{ "whatever\x{CA}" => '' }})[0]; 157 $kopy = $key; 158 encode($name, $kopy, Encode::FB_CROAK | Encode::LEAVE_SRC); 159 is $key, "whatever\x{CA}", "encode $name with LEAVE_SRC and shared hash key scalars"; 160 undef $key; 161 $key = (keys %{{ "whatever" => '' }})[0]; 162 $kopy = $key; 163 decode($name, $kopy, Encode::FB_CROAK); 164 is $key, "whatever", "decode $name with shared hash key scalars"; 165 undef $key; 166 $key = (keys %{{ "whatever" => '' }})[0]; 167 $kopy = $key; 168 decode($name, $kopy, Encode::FB_CROAK | Encode::LEAVE_SRC); 169 is $key, "whatever", "decode $name with LEAVE_SRC and shared hash key scalars"; 170 171 my $enc = find_encoding($name); 172 undef $key; 173 $key = (keys %{{ "whatever\x{CA}" => '' }})[0]; 174 $kopy = $key; 175 $enc->encode($kopy, Encode::FB_CROAK); 176 is $key, "whatever\x{CA}", "encode obj $name with shared hash key scalars"; 177 undef $key; 178 $key = (keys %{{ "whatever\x{CA}" => '' }})[0]; 179 $kopy = $key; 180 $enc->encode($kopy, Encode::FB_CROAK | Encode::LEAVE_SRC); 181 is $key, "whatever\x{CA}", "encode obj $name with LEAVE_SRC and shared hash key scalars"; 182 undef $key; 183 $key = (keys %{{ "whatever" => '' }})[0]; 184 $kopy = $key; 185 $enc->decode($kopy, Encode::FB_CROAK); 186 is $key, "whatever", "decode obj $name with shared hash key scalars"; 187 undef $key; 188 $key = (keys %{{ "whatever" => '' }})[0]; 189 $kopy = $key; 190 $enc->decode($kopy, Encode::FB_CROAK | Encode::LEAVE_SRC); 191 is $key, "whatever", "decode obj $name with LEAVE_SRC and shared hash key scalars"; 192} 193 194my $latin1 = find_encoding('latin1'); 195my $orig = "\316"; 196$orig =~ /(.)/; 197is $latin1->encode($1), $orig, '[cpan #115168] passing magic regex globals to encode'; 198SKIP: { 199 skip "Perl Version ($]) is older than v5.16", 1 if $] < 5.016; 200 *a = $orig; 201 is $latin1->encode(*a), '*main::'.$orig, '[cpan #115168] passing typeglobs to encode'; 202} 203