Commit | Line | Data |
656753f8 |
1 | BEGIN { |
037b88d6 |
2 | if ($ENV{'PERL_CORE'}){ |
3 | chdir 't'; |
4 | unshift @INC, '../lib'; |
5 | } |
9c593e56 |
6 | if (ord("A") == 193) { |
7 | print "1..0 # Skip: EBCDIC\n"; |
8 | exit 0; |
9 | } |
5a814814 |
10 | require Config; import Config; |
bb50757b |
11 | if ($Config{'extensions'} !~ /\bEncode\b/) { |
5a814814 |
12 | print "1..0 # Skip: Encode was not built\n"; |
13 | exit 0; |
14 | } |
656753f8 |
15 | } |
0e567a6c |
16 | use strict; |
656753f8 |
17 | use Test; |
2eebba1d |
18 | use Encode qw(from_to encode decode |
19 | encode_utf8 decode_utf8 |
20 | find_encoding is_utf8); |
656753f8 |
21 | use charnames qw(greek); |
51ef4e11 |
22 | my @encodings = grep(/iso-?8859/,Encode::encodings()); |
656753f8 |
23 | my $n = 2; |
f90497d6 |
24 | my @character_set = ('0'..'9', 'A'..'Z', 'a'..'z'); |
25 | my @source = qw(ascii iso8859-1 cp1250); |
26 | my @destiny = qw(cp1047 cp37 posix-bc); |
27 | my @ebcdic_sets = qw(cp1047 cp37 posix-bc); |
2eebba1d |
28 | plan test => 38+$n*@encodings + 2*@source*@destiny*@character_set + 2*@ebcdic_sets*256 + 6; |
656753f8 |
29 | my $str = join('',map(chr($_),0x20..0x7E)); |
30 | my $cpy = $str; |
31 | ok(length($str),from_to($cpy,'iso8859-1','Unicode'),"Length Wrong"); |
32 | ok($cpy,$str,"ASCII mangled by translating from iso8859-1 to Unicode"); |
33 | $cpy = $str; |
34 | ok(from_to($cpy,'Unicode','iso8859-1'),length($str),"Length wrong"); |
35 | ok($cpy,$str,"ASCII mangled by translating from Unicode to iso8859-1"); |
36 | |
37 | $str = join('',map(chr($_),0xa0..0xff)); |
87714904 |
38 | $cpy = $str; |
656753f8 |
39 | ok(length($str),from_to($cpy,'iso8859-1','Unicode'),"Length Wrong"); |
40 | |
41 | my $sym = Encode->getEncoding('symbol'); |
7d85a32c |
42 | my $uni = $sym->decode(encode(ascii => 'a')); |
f90497d6 |
43 | ok("\N{alpha}",substr($uni,0,1),"alpha does not map to symbol 'a'"); |
50d26985 |
44 | $str = $sym->encode("\N{Beta}"); |
7d85a32c |
45 | ok("B",decode(ascii => substr($str,0,1)),"Symbol 'B' does not map to Beta"); |
656753f8 |
46 | |
47 | foreach my $enc (qw(symbol dingbats ascii),@encodings) |
48 | { |
49 | my $tab = Encode->getEncoding($enc); |
50 | ok(1,defined($tab),"Could not load $enc"); |
51 | $str = join('',map(chr($_),0x20..0x7E)); |
50d26985 |
52 | $uni = $tab->decode($str); |
53 | $cpy = $tab->encode($uni); |
656753f8 |
54 | ok($cpy,$str,"$enc mangled translating to Unicode and back"); |
55 | } |
56 | |
f90497d6 |
57 | # On ASCII based machines see if we can map several codepoints from |
58 | # three distinct ASCII sets to three distinct EBCDIC coded character sets. |
a12c0f56 |
59 | # On EBCDIC machines see if we can map from three EBCDIC sets to three |
f90497d6 |
60 | # distinct ASCII sets. |
61 | |
62 | my @expectation = (240..249, 193..201,209..217,226..233, 129..137,145..153,162..169); |
63 | if (ord('A') != 65) { |
64 | my @temp = @destiny; |
65 | @destiny = @source; |
66 | @source = @temp; |
67 | undef(@temp); |
68 | @expectation = (48..57, 65..90, 97..122); |
69 | } |
70 | |
71 | foreach my $to (@destiny) |
72 | { |
73 | foreach my $from (@source) |
74 | { |
75 | my @expected = @expectation; |
76 | foreach my $chr (@character_set) |
77 | { |
78 | my $native_chr = $chr; |
79 | my $cpy = $chr; |
80 | my $rc = from_to($cpy,$from,$to); |
81 | ok(1,$rc,"Could not translate from $from to $to"); |
82 | ok(ord($cpy),shift(@expected),"mangled translating $native_chr from $from to $to"); |
83 | } |
84 | } |
85 | } |
86 | |
87 | # On either ASCII or EBCDIC machines ensure we can take the full one |
88 | # byte repetoire to EBCDIC sets and back. |
89 | |
90 | my $enc_as = 'iso8859-1'; |
91 | foreach my $enc_eb (@ebcdic_sets) |
92 | { |
93 | foreach my $ord (0..255) |
94 | { |
95 | $str = chr($ord); |
96 | my $rc = from_to($str,$enc_as,$enc_eb); |
97 | $rc += from_to($str,$enc_eb,$enc_as); |
98 | ok($rc,2,"return code for $ord $enc_eb -> $enc_as -> $enc_eb was not obtained"); |
99 | ok($ord,ord($str),"$enc_as mangled translating $ord to $enc_eb and back"); |
100 | } |
101 | } |
102 | |
51ef4e11 |
103 | my $mime = find_encoding('iso-8859-2'); |
104 | ok(defined($mime),1,"Cannot find MIME-ish'iso-8859-2'"); |
105 | my $x11 = find_encoding('iso8859-2'); |
106 | ok(defined($x11),1,"Cannot find X11-ish 'iso8859-2'"); |
107 | ok($mime,$x11,"iso8598-2 and iso-8859-2 not same"); |
108 | my $spc = find_encoding('iso 8859-2'); |
109 | ok(defined($spc),1,"Cannot find 'iso 8859-2'"); |
110 | ok($spc,$mime,"iso 8859-2 and iso-8859-2 not same"); |
111 | |
4411f3b6 |
112 | for my $i (256,128,129,256) |
a12c0f56 |
113 | { |
114 | my $c = chr($i); |
115 | my $s = "$c\n".sprintf("%02X",$i); |
1b026014 |
116 | ok(utf8::valid($s),1,"concat of $i botched"); |
117 | utf8::upgrade($s); |
118 | ok(utf8::valid($s),1,"concat of $i botched"); |
a12c0f56 |
119 | } |
120 | |
4411f3b6 |
121 | # Spot check a few points in/out of utf8 |
ed46d110 |
122 | for my $i (ord('A'),128,256,0x20AC) |
4411f3b6 |
123 | { |
124 | my $c = chr($i); |
125 | my $o = encode_utf8($c); |
126 | ok(decode_utf8($o),$c,"decode_utf8 not inverse of encode_utf8 for $i"); |
127 | ok(encode('utf8',$c),$o,"utf8 encode by name broken for $i"); |
128 | ok(decode('utf8',$o),$c,"utf8 decode by name broken for $i"); |
129 | } |
130 | |
131 | |
2eebba1d |
132 | # is_utf8 |
133 | |
134 | ok( is_utf8("\x{100}")); |
135 | ok(! is_utf8("a")); |
136 | ok(! is_utf8("")); |
137 | "\x{100}" =~ /(.)/; |
138 | ok( is_utf8($1)); # ID 20011127.151 |
139 | $a = $1; |
140 | ok( is_utf8($a)); |
141 | $a = "\x{100}"; |
142 | chop $a; |
143 | ok( is_utf8($a)); # weird but true: an empty UTF-8 string |
144 | |