2 # $Id: Unicode.t,v 1.12 2003/05/21 08:41:11 dankogai Exp $
4 # This script is written entirely in ASCII, even though quoted literals
5 # do include non-BMP unicode characters -- Are you happy, jhi?
10 require Config; import Config;
11 if ($Config{'extensions'} !~ /\bEncode\b/) {
12 print "1..0 # Skip: Encode was not built\n";
15 $ON_EBCDIC = (ord("A") == 193) || $ARGV[0];
20 #use Test::More 'no_plan';
21 use Test::More tests => 37;
22 use Encode qw(encode decode);
26 # http://www.unicode.org/unicode/reports/tr19/
29 my $dankogai = "\x{5c0f}\x{98fc}\x{3000}\x{5f3e}";
30 my $nasty = "$dankogai\x{1abcd}";
31 my $fallback = "$dankogai\x{fffd}";
33 #hi: (0x1abcd - 0x10000) / 0x400 + 0xD800 = 0xd82a
34 #lo: (0x1abcd - 0x10000) % 0x400 + 0xDC00 = 0xdfcd
37 pack("C*", map {hex($_)} qw<5c 0f 98 fc 30 00 5f 3e d8 2a df cd>);
39 pack("C*", map {hex($_)} qw<0f 5c fc 98 00 30 3e 5f 2a d8 cd df>);
41 pack("C*", map {hex($_)} qw<5c 0f 98 fc 30 00 5f 3e ff fd>);
43 pack("C*", map {hex($_)} qw<0f 5c fc 98 00 30 3e 5f fd ff>);
45 pack("C*", map {hex($_)}
46 qw<00 00 5c 0f 00 00 98 fc 00 00 30 00 00 00 5f 3e 00 01 ab cd>);
48 pack("C*", map {hex($_)}
49 qw<0f 5c 00 00 fc 98 00 00 00 30 00 00 3e 5f 00 00 cd ab 01 00>);
51 my $n_16bb = pack('n', 0xFeFF) . $n_16be;
52 my $n_16lb = pack('v', 0xFeFF) . $n_16le;
53 my $n_32bb = pack('N', 0xFeFF) . $n_32be;
54 my $n_32lb = pack('V', 0xFeFF) . $n_32le;
56 is($n_16be, encode('UTF-16BE', $nasty), qq{encode UTF-16BE});
57 is($n_16le, encode('UTF-16LE', $nasty), qq{encode UTF-16LE});
58 is($n_32be, encode('UTF-32BE', $nasty), qq{encode UTF-32BE});
59 is($n_32le, encode('UTF-32LE', $nasty), qq{encode UTF-16LE});
61 is($nasty, decode('UTF-16BE', $n_16be), qq{decode UTF-16BE});
62 is($nasty, decode('UTF-16LE', $n_16le), qq{decode UTF-16LE});
63 is($nasty, decode('UTF-32BE', $n_32be), qq{decode UTF-32BE});
64 is($nasty, decode('UTF-32LE', $n_32le), qq{decode UTF-32LE});
66 is($n_16bb, encode('UTF-16', $nasty), qq{encode UTF-16});
67 is($n_32bb, encode('UTF-32', $nasty), qq{encode UTF-32});
68 is($nasty, decode('UTF-16', $n_16bb), qq{decode UTF-16, bom=be});
69 is($nasty, decode('UTF-16', $n_16lb), qq{decode UTF-16, bom=le});
70 is($nasty, decode('UTF-32', $n_32bb), qq{decode UTF-32, bom=be});
71 is($nasty, decode('UTF-32', $n_32lb), qq{decode UTF-32, bom=le});
73 is(decode('UCS-2BE', $n_16be), $fallback, "decode UCS-2BE: fallback");
74 is(decode('UCS-2LE', $n_16le), $fallback, "decode UCS-2LE: fallback");
75 eval { decode('UCS-2BE', $n_16be, 1) };
76 is (index($@,'UCS-2BE:'), 0, "decode UCS-2BE: exception");
77 eval { decode('UCS-2LE', $n_16le, 1) };
78 is (index($@,'UCS-2LE:'), 0, "decode UCS-2LE: exception");
79 is(encode('UCS-2BE', $nasty), $f_16be, "encode UCS-2BE: fallback");
80 is(encode('UCS-2LE', $nasty), $f_16le, "encode UCS-2LE: fallback");
81 eval { encode('UCS-2BE', $nasty, 1) };
82 is(index($@, 'UCS-2BE'), 0, "encode UCS-2BE: exception");
83 eval { encode('UCS-2LE', $nasty, 1) };
84 is(index($@, 'UCS-2LE'), 0, "encode UCS-2LE: exception");
87 # SvGROW test for (en|de)code_xs
90 skip "Not on EBCDIC", 8 if $ON_EBCDIC;
93 for my $i (0..0xffff){
94 $j == 0 and (0xD800 <= $i && $i <= 0xDFFF) and next;
97 for my $major ('UTF-16', 'UTF-32'){
98 for my $minor ('BE', 'LE'){
99 my $enc = $major.$minor;
100 is(decode($enc, encode($enc, $utf8)), $utf8, "$enc RT");
113 my $dir = dirname(__FILE__);
114 opendir my $dh, $dir or die "$dir:$!";
115 my @file = sort grep {/\.utf$/o} readdir $dh;
117 for my $file (@file){
118 my $path = File::Spec->catfile($dir, $file);
119 open my $fh, '<', $path or die "$path:$!";
121 if (PerlIO::Layer->find('perlio')){
122 binmode $fh => ':utf8';
123 $content = join('' => <$fh>);
126 $content = join('' => <$fh>);
127 Encode::_utf8_on($content)
130 is(decode("UTF-7", encode("UTF-7", $content)), $content,