Commit | Line | Data |
26b787bb |
1 | # |
c731e18e |
2 | # $Id: Unicode.t,v 1.4 2002/04/08 02:35:48 dankogai Exp dankogai $ |
26b787bb |
3 | # |
85d9270e |
4 | # This script is written entirely in ASCII, even though quoted literals |
5 | # do include non-BMP unicode characters -- Are you happy, jhi? |
26b787bb |
6 | # |
7 | |
26b787bb |
8 | BEGIN { |
c731e18e |
9 | require Config; import Config; |
10 | if ($Config{'extensions'} !~ /\bEncode\b/) { |
11 | print "1..0 # Skip: Encode was not built\n"; |
12 | exit 0; |
13 | } |
26b787bb |
14 | # should work without perlio |
15 | # unless (find PerlIO::Layer 'perlio') { |
c731e18e |
16 | # print "1..0 # Skip: PerlIO was not built\n"; |
17 | # exit 0; |
26b787bb |
18 | # } |
19 | # should work on EBCDIC |
20 | # if (ord("A") == 193) { |
c731e18e |
21 | # print "1..0 # Skip: EBCDIC\n"; |
22 | # exit 0; |
26b787bb |
23 | # } |
c731e18e |
24 | $| = 1; |
26b787bb |
25 | } |
26 | |
27 | use strict; |
28 | #use Test::More 'no_plan'; |
29 | use Test::More tests => 22; |
30 | use Encode qw(encode decode); |
c731e18e |
31 | use Encode::Unicode; # to load BOM defs |
26b787bb |
32 | |
33 | # |
34 | # see |
35 | # http://www.unicode.org/unicode/reports/tr19/ |
36 | # |
37 | |
38 | my $nasty = "\x{004D}\x{0061}\x{1abcd}"; |
39 | my $fallback = "\x{004D}\x{0061}\x{fffd}"; |
40 | |
41 | #hi: (0x1abcd - 0x10000) / 0x400 + 0xD800 = 0xd82a |
42 | #lo: (0x1abcd - 0x10000) % 0x400 + 0xDC00 = 0xdfcd |
43 | |
c731e18e |
44 | my $n_16be = |
45 | pack("C*", map {hex($_)} qw<00 4D 00 61 d8 2a df cd>); |
26b787bb |
46 | my $n_16le = |
c731e18e |
47 | pack("C*", map {hex($_)} qw<4D 00 61 00 2a d8 cd df>); |
48 | my $f_16be = |
49 | pack("C*", map {hex($_)} qw<00 4D 00 61 ff fd>); |
26b787bb |
50 | my $f_16le = |
c731e18e |
51 | pack("C*", map {hex($_)} qw<4D 00 61 00 fd ff>); |
52 | my $n_32be = |
53 | pack("C*", map {hex($_)} qw<00 00 00 4D 00 00 00 61 00 01 ab cd>); |
54 | my $n_32le = |
55 | pack("C*", map {hex($_)} qw<4D 00 00 00 61 00 00 00 cd ab 01 00>); |
26b787bb |
56 | |
85d9270e |
57 | my $n_16bb = pack('n', Encode::Unicode::BOM_BE) . $n_16be; |
58 | my $n_16lb = pack('n', Encode::Unicode::BOM16LE) . $n_16le; |
59 | my $n_32bb = pack('N', Encode::Unicode::BOM_BE ) . $n_32be; |
60 | my $n_32lb = pack('N', Encode::Unicode::BOM32LE) . $n_32le; |
26b787bb |
61 | |
62 | is($n_16be, encode('UTF-16BE', $nasty), qq{encode UTF-16BE}); |
63 | is($n_16le, encode('UTF-16LE', $nasty), qq{encode UTF-16LE}); |
64 | is($n_32be, encode('UTF-32BE', $nasty), qq{encode UTF-32BE}); |
65 | is($n_32le, encode('UTF-32LE', $nasty), qq{encode UTF-16LE}); |
66 | |
67 | is($nasty, decode('UTF-16BE', $n_16be), qq{decode UTF-16BE}); |
68 | is($nasty, decode('UTF-16LE', $n_16le), qq{decode UTF-16LE}); |
69 | is($nasty, decode('UTF-32BE', $n_32be), qq{decode UTF-32BE}); |
70 | is($nasty, decode('UTF-32LE', $n_32le), qq{decode UTF-32LE}); |
71 | |
72 | is($n_16bb, encode('UTF-16', $nasty), qq{encode UTF-16}); |
73 | is($n_32bb, encode('UTF-32', $nasty), qq{encode UTF-32}); |
74 | is($nasty, decode('UTF-16', $n_16bb), qq{decode UTF-16, bom=be}); |
75 | is($nasty, decode('UTF-16', $n_16lb), qq{decode UTF-16, bom=le}); |
76 | is($nasty, decode('UTF-32', $n_32bb), qq{decode UTF-32, bom=be}); |
77 | is($nasty, decode('UTF-32', $n_32lb), qq{decode UTF-32, bom=le}); |
78 | |
79 | is(decode('UCS-2BE', $n_16be), $fallback, "decode UCS-2BE: fallback"); |
80 | is(decode('UCS-2LE', $n_16le), $fallback, "decode UCS-2LE: fallback"); |
c731e18e |
81 | eval { decode('UCS-2BE', $n_16be, 1) }; |
26b787bb |
82 | ok($@=~/^UCS-2BE:/, "decode UCS-2BE: exception"); |
c731e18e |
83 | eval { decode('UCS-2LE', $n_16le, 1) }; |
26b787bb |
84 | ok($@=~/^UCS-2LE:/, "decode UCS-2LE: exception"); |
85 | is(encode('UCS-2BE', $nasty), $f_16be, "encode UCS-2BE: fallback"); |
86 | is(encode('UCS-2LE', $nasty), $f_16le, "encode UCS-2LE: fallback"); |
c731e18e |
87 | eval { encode('UCS-2BE', $nasty, 1) }; |
26b787bb |
88 | ok($@=~/^UCS-2BE:/, "encode UCS-2BE: exception"); |
c731e18e |
89 | eval { encode('UCS-2LE', $nasty, 1) }; |
26b787bb |
90 | ok($@=~/^UCS-2LE:/, "encode UCS-2LE: exception"); |
91 | |
92 | 1; |
93 | __END__ |
c731e18e |
94 | |
95 | use Devel::Peek; |
96 | my $foo = decode('UTF-16BE', $n_16be); |
97 | Dump $n_16be; Dump $foo; |