xref: /openbsd/gnu/usr.bin/perl/cpan/Encode/t/Unicode.t (revision 3d61058a) 
1#
2# $Id: Unicode.t,v 2.5 2023/11/10 01:10:50 dankogai Exp $
3#
4# This script is written entirely in ASCII, even though quoted literals
5# do include non-BMP unicode characters -- Are you happy, jhi?
6#
7
8BEGIN {
9    require Config; Config->import();
10    if ($Config{'extensions'} !~ /\bEncode\b/) {
11      print "1..0 # Skip: Encode was not built\n";
12      exit 0;
13    }
14    if (ord("A") == 193) {
15        print "1..0 # Skip: EBCDIC\n";
16    exit 0;
17    }
18    $| = 1;
19}
20
21use strict;
22#use Test::More 'no_plan';
23use Test::More tests => 56;
24use Encode qw(encode decode find_encoding);
25
26#
27# see
28# http://www.unicode.org/reports/tr19/
29#
30
31my $dankogai   = "\x{5c0f}\x{98fc}\x{3000}\x{5f3e}";
32my $nasty      = "$dankogai\x{1abcd}";
33my $fallback   = "$dankogai\x{fffd}\x{fffd}";
34
35#hi: (0x1abcd - 0x10000) / 0x400 + 0xD800 = 0xd82a
36#lo: (0x1abcd - 0x10000) % 0x400 + 0xDC00 = 0xdfcd
37
38my $n_16be =
39    pack("C*", map {hex($_)} qw<5c 0f 98 fc 30 00 5f 3e  d8 2a df cd>);
40my $n_16le =
41    pack("C*", map {hex($_)} qw<0f 5c fc 98 00 30 3e 5f  2a d8 cd df>);
42my $f_16be =
43    pack("C*", map {hex($_)} qw<5c 0f 98 fc 30 00 5f 3e  ff fd>);
44my $f_16le =
45    pack("C*", map {hex($_)} qw<0f 5c fc 98 00 30 3e 5f  fd ff>);
46my $n_32be =
47    pack("C*", map {hex($_)}
48     qw<00 00 5c 0f 00 00 98 fc 00 00 30 00 00 00 5f 3e  00 01 ab cd>);
49my $n_32le =
50    pack("C*", map {hex($_)}
51     qw<0f 5c 00 00 fc 98 00 00 00 30 00 00 3e 5f 00 00  cd ab 01 00>);
52
53my $n_16bb = pack('n', 0xFeFF) . $n_16be;
54my $n_16lb = pack('v', 0xFeFF) . $n_16le;
55my $n_32bb = pack('N', 0xFeFF) . $n_32be;
56my $n_32lb = pack('V', 0xFeFF) . $n_32le;
57
58is($n_16be, encode('UTF-16BE', $nasty),  qq{encode UTF-16BE});
59is($n_16le, encode('UTF-16LE', $nasty),  qq{encode UTF-16LE});
60is($n_32be, encode('UTF-32BE', $nasty),  qq{encode UTF-32BE});
61is($n_32le, encode('UTF-32LE', $nasty),  qq{encode UTF-16LE});
62
63is($nasty,  decode('UTF-16BE', $n_16be), qq{decode UTF-16BE});
64is($nasty,  decode('UTF-16LE', $n_16le), qq{decode UTF-16LE});
65is($nasty,  decode('UTF-32BE', $n_32be), qq{decode UTF-32BE});
66is($nasty,  decode('UTF-32LE', $n_32le), qq{decode UTF-32LE});
67
68is($n_16bb, encode('UTF-16',   $nasty),  qq{encode UTF-16});
69is($n_32bb, encode('UTF-32',   $nasty),  qq{encode UTF-32});
70is($nasty,  decode('UTF-16',   $n_16bb), qq{decode UTF-16, bom=be});
71is($nasty,  decode('UTF-16',   $n_16lb), qq{decode UTF-16, bom=le});
72is($nasty,  decode('UTF-32',   $n_32bb), qq{decode UTF-32, bom=be});
73is($nasty,  decode('UTF-32',   $n_32lb), qq{decode UTF-32, bom=le});
74
75is(decode('UCS-2BE', $n_16be), $fallback, "decode UCS-2BE: fallback");
76is(decode('UCS-2LE', $n_16le), $fallback, "decode UCS-2LE: fallback");
77eval { decode('UCS-2BE', $n_16be, 1) };
78is (index($@,'UCS-2BE:'), 0, "decode UCS-2BE: exception");
79eval { decode('UCS-2LE', $n_16le, 1) };
80is (index($@,'UCS-2LE:'), 0, "decode UCS-2LE: exception");
81is(encode('UCS-2BE', $nasty), $f_16be, "encode UCS-2BE: fallback");
82is(encode('UCS-2LE', $nasty), $f_16le, "encode UCS-2LE: fallback");
83eval { encode('UCS-2BE', $nasty, 1) };
84is(index($@, 'UCS-2BE'), 0, "encode UCS-2BE: exception");
85eval { encode('UCS-2LE', $nasty, 1) };
86is(index($@, 'UCS-2LE'), 0, "encode UCS-2LE: exception");
87
88{
89    my %tests = (
90        'UCS-2BE'  => 'n*',
91        'UCS-2LE'  => 'v*',
92        'UTF-16BE' => 'n*',
93        'UTF-16LE' => 'v*',
94        'UTF-32BE' => 'N*',
95        'UTF-32LE' => 'V*',
96    );
97
98    while (my ($enc, $pack) = each(%tests)) {
99        is(decode($enc, pack($pack, 0xD800, 0x263A)), "\x{FFFD}\x{263A}",
100          "decode $enc (HI surrogate followed by WHITE SMILING FACE)");
101        is(decode($enc, pack($pack, 0xDC00, 0x263A)), "\x{FFFD}\x{263A}",
102          "decode $enc (LO surrogate followed by WHITE SMILING FACE)");
103    }
104}
105
106{
107    my %tests = (
108        'UTF-16BE' => 'n*',
109        'UTF-16LE' => 'v*',
110    );
111
112    while (my ($enc, $pack) = each(%tests)) {
113        is(decode($enc, pack($pack, 0xD800)), "\x{FFFD}",
114          "decode $enc (HI surrogate)");
115        is(decode($enc, pack($pack, 0x263A, 0xD800)), "\x{263A}\x{FFFD}",
116          "decode $enc (WHITE SMILING FACE followed by HI surrogate)");
117    }
118}
119
120{
121    my %tests = (
122        'UTF-16BE' => 'n*',
123        'UTF-16LE' => 'v*',
124    );
125
126    while (my ($enc, $pack) = each(%tests)) {
127        is(encode($enc, "\x{110000}"), pack($pack, 0xFFFD),
128          "ordinals greater than U+10FFFF is replaced with U+FFFD");
129    }
130}
131
132#
133# SvGROW test for (en|de)code_xs
134#
135SKIP: {
136    my $utf8 = '';
137    for my $j (0,0x10){
138    for my $i (0..0xffff){
139        $j == 0 and (0xD800 <= $i && $i <= 0xDFFF) and next;
140        $utf8 .= ord($j+$i);
141    }
142    for my $major ('UTF-16', 'UTF-32'){
143        for my $minor ('BE', 'LE'){
144        my $enc = $major.$minor;
145        is(decode($enc, encode($enc, $utf8)), $utf8, "$enc RT");
146        }
147    }
148    }
149};
150
151#
152# CJKT vs. UTF-7
153#
154
155use File::Spec;
156use File::Basename;
157
158my $dir =  dirname(__FILE__);
159opendir my $dh, $dir or die "$dir:$!";
160my @file = sort grep {/\.utf$/o} readdir $dh;
161closedir $dh;
162for my $file (@file){
163    my $path = File::Spec->catfile($dir, $file);
164    open my $fh, '<', $path or die "$path:$!";
165    my $content;
166    if (PerlIO::Layer->find('perlio')){
167    binmode $fh => ':utf8';
168    $content = join('' => <$fh>);
169    }else{ # ugh!
170    binmode $fh;
171    $content = join('' => <$fh>);
172    Encode::_utf8_on($content)
173    }
174    close $fh;
175    is(decode("UTF-7", encode("UTF-7", $content)), $content,
176       "UTF-7 RT:$file");
177}
178
179# Magic
180{
181    # see http://rt.perl.org/rt3//Ticket/Display.html?id=60472
182    my $work = chr(0x100);
183    my $encoding = find_encoding("UTF16-BE");
184    my $tied;
185    tie $tied, SomeScalar => \$work;
186    my $result = $encoding->encode($tied, 1);
187    is($work, "", "check set magic was applied");
188}
189
190package SomeScalar;
191use Tie::Scalar;
192use vars qw(@ISA);
193BEGIN { @ISA = 'Tie::Scalar' }
194
195sub TIESCALAR {
196    my ($class, $ref) = @_;
197    return bless $ref, $class;
198}
199
200sub FETCH {
201    ${$_[0]}
202}
203
204sub STORE {
205    ${$_[0]} = $_[1];
206}
207
2081;
209__END__
210