Commit | Line | Data |
26b787bb |
1 | # |
fdd579e2 |
2 | # $Id: Unicode.t,v 1.5 2002/04/08 14:17:19 dankogai Exp $ |
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 | # } |
b3365ecb |
19 | if (ord("A") == 193) { |
20 | print "1..0 # Skip: EBCDIC\n"; |
21 | exit 0; |
22 | } |
c731e18e |
23 | $| = 1; |
26b787bb |
24 | } |
25 | |
26 | use strict; |
27 | #use Test::More 'no_plan'; |
28 | use Test::More tests => 22; |
29 | use Encode qw(encode decode); |
26b787bb |
30 | |
31 | # |
32 | # see |
33 | # http://www.unicode.org/unicode/reports/tr19/ |
34 | # |
35 | |
36 | my $nasty = "\x{004D}\x{0061}\x{1abcd}"; |
37 | my $fallback = "\x{004D}\x{0061}\x{fffd}"; |
38 | |
39 | #hi: (0x1abcd - 0x10000) / 0x400 + 0xD800 = 0xd82a |
40 | #lo: (0x1abcd - 0x10000) % 0x400 + 0xDC00 = 0xdfcd |
41 | |
c731e18e |
42 | my $n_16be = |
43 | pack("C*", map {hex($_)} qw<00 4D 00 61 d8 2a df cd>); |
26b787bb |
44 | my $n_16le = |
c731e18e |
45 | pack("C*", map {hex($_)} qw<4D 00 61 00 2a d8 cd df>); |
46 | my $f_16be = |
47 | pack("C*", map {hex($_)} qw<00 4D 00 61 ff fd>); |
26b787bb |
48 | my $f_16le = |
c731e18e |
49 | pack("C*", map {hex($_)} qw<4D 00 61 00 fd ff>); |
50 | my $n_32be = |
51 | pack("C*", map {hex($_)} qw<00 00 00 4D 00 00 00 61 00 01 ab cd>); |
52 | my $n_32le = |
53 | pack("C*", map {hex($_)} qw<4D 00 00 00 61 00 00 00 cd ab 01 00>); |
26b787bb |
54 | |
fdd579e2 |
55 | my $n_16bb = pack('n', 0xFeFF) . $n_16be; |
56 | my $n_16lb = pack('v', 0xFeFF) . $n_16le; |
57 | my $n_32bb = pack('N', 0xFeFF) . $n_32be; |
58 | my $n_32lb = pack('V', 0xFeFF) . $n_32le; |
26b787bb |
59 | |
60 | is($n_16be, encode('UTF-16BE', $nasty), qq{encode UTF-16BE}); |
61 | is($n_16le, encode('UTF-16LE', $nasty), qq{encode UTF-16LE}); |
62 | is($n_32be, encode('UTF-32BE', $nasty), qq{encode UTF-32BE}); |
63 | is($n_32le, encode('UTF-32LE', $nasty), qq{encode UTF-16LE}); |
64 | |
65 | is($nasty, decode('UTF-16BE', $n_16be), qq{decode UTF-16BE}); |
66 | is($nasty, decode('UTF-16LE', $n_16le), qq{decode UTF-16LE}); |
67 | is($nasty, decode('UTF-32BE', $n_32be), qq{decode UTF-32BE}); |
68 | is($nasty, decode('UTF-32LE', $n_32le), qq{decode UTF-32LE}); |
69 | |
70 | is($n_16bb, encode('UTF-16', $nasty), qq{encode UTF-16}); |
71 | is($n_32bb, encode('UTF-32', $nasty), qq{encode UTF-32}); |
72 | is($nasty, decode('UTF-16', $n_16bb), qq{decode UTF-16, bom=be}); |
73 | is($nasty, decode('UTF-16', $n_16lb), qq{decode UTF-16, bom=le}); |
74 | is($nasty, decode('UTF-32', $n_32bb), qq{decode UTF-32, bom=be}); |
75 | is($nasty, decode('UTF-32', $n_32lb), qq{decode UTF-32, bom=le}); |
76 | |
77 | is(decode('UCS-2BE', $n_16be), $fallback, "decode UCS-2BE: fallback"); |
78 | is(decode('UCS-2LE', $n_16le), $fallback, "decode UCS-2LE: fallback"); |
c731e18e |
79 | eval { decode('UCS-2BE', $n_16be, 1) }; |
26b787bb |
80 | ok($@=~/^UCS-2BE:/, "decode UCS-2BE: exception"); |
c731e18e |
81 | eval { decode('UCS-2LE', $n_16le, 1) }; |
26b787bb |
82 | ok($@=~/^UCS-2LE:/, "decode UCS-2LE: exception"); |
83 | is(encode('UCS-2BE', $nasty), $f_16be, "encode UCS-2BE: fallback"); |
84 | is(encode('UCS-2LE', $nasty), $f_16le, "encode UCS-2LE: fallback"); |
c731e18e |
85 | eval { encode('UCS-2BE', $nasty, 1) }; |
26b787bb |
86 | ok($@=~/^UCS-2BE:/, "encode UCS-2BE: exception"); |
c731e18e |
87 | eval { encode('UCS-2LE', $nasty, 1) }; |
26b787bb |
88 | ok($@=~/^UCS-2LE:/, "encode UCS-2LE: exception"); |
89 | |
90 | 1; |
91 | __END__ |