This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add macro for Unicode Corregindum #9 strict
[perl5.git] / ext / XS-APItest / t / utf8.t
CommitLineData
fed3ba5d
NC
1#!perl -w
2
3use strict;
4use Test::More;
7dfd8446 5$|=1;
fed3ba5d 6
760c7c2f
KW
7no warnings 'deprecated'; # Some of the below are above IV_MAX on 32 bit
8 # machines, and that is tested elsewhere
9
fed3ba5d
NC
10use XS::APItest;
11
4deba822
KW
12my $pound_sign = chr utf8::unicode_to_native(163);
13
7dfd8446
KW
14sub isASCII { ord "A" == 65 }
15
16sub display_bytes {
9d2d0ecd 17 use bytes;
7dfd8446
KW
18 my $string = shift;
19 return '"'
20 . join("", map { sprintf("\\x%02x", ord $_) } split "", $string)
21 . '"';
22}
23
24# This test file can't use byte_utf8a_to_utf8n() from t/charset_tools.pl
25# because that uses the same functions we are testing here. So UTF-EBCDIC
26# strings are hard-coded as I8 strings in this file instead, and we use array
27# lookup to translate into the appropriate code page.
28
29my @i8_to_native = ( # Only code page 1047 so far.
30# _0 _1 _2 _3 _4 _5 _6 _7 _8 _9 _A _B _C _D _E _F
310x00,0x01,0x02,0x03,0x37,0x2D,0x2E,0x2F,0x16,0x05,0x15,0x0B,0x0C,0x0D,0x0E,0x0F,
320x10,0x11,0x12,0x13,0x3C,0x3D,0x32,0x26,0x18,0x19,0x3F,0x27,0x1C,0x1D,0x1E,0x1F,
330x40,0x5A,0x7F,0x7B,0x5B,0x6C,0x50,0x7D,0x4D,0x5D,0x5C,0x4E,0x6B,0x60,0x4B,0x61,
340xF0,0xF1,0xF2,0xF3,0xF4,0xF5,0xF6,0xF7,0xF8,0xF9,0x7A,0x5E,0x4C,0x7E,0x6E,0x6F,
350x7C,0xC1,0xC2,0xC3,0xC4,0xC5,0xC6,0xC7,0xC8,0xC9,0xD1,0xD2,0xD3,0xD4,0xD5,0xD6,
360xD7,0xD8,0xD9,0xE2,0xE3,0xE4,0xE5,0xE6,0xE7,0xE8,0xE9,0xAD,0xE0,0xBD,0x5F,0x6D,
370x79,0x81,0x82,0x83,0x84,0x85,0x86,0x87,0x88,0x89,0x91,0x92,0x93,0x94,0x95,0x96,
380x97,0x98,0x99,0xA2,0xA3,0xA4,0xA5,0xA6,0xA7,0xA8,0xA9,0xC0,0x4F,0xD0,0xA1,0x07,
390x20,0x21,0x22,0x23,0x24,0x25,0x06,0x17,0x28,0x29,0x2A,0x2B,0x2C,0x09,0x0A,0x1B,
400x30,0x31,0x1A,0x33,0x34,0x35,0x36,0x08,0x38,0x39,0x3A,0x3B,0x04,0x14,0x3E,0xFF,
410x41,0x42,0x43,0x44,0x45,0x46,0x47,0x48,0x49,0x4A,0x51,0x52,0x53,0x54,0x55,0x56,
420x57,0x58,0x59,0x62,0x63,0x64,0x65,0x66,0x67,0x68,0x69,0x6A,0x70,0x71,0x72,0x73,
430x74,0x75,0x76,0x77,0x78,0x80,0x8A,0x8B,0x8C,0x8D,0x8E,0x8F,0x90,0x9A,0x9B,0x9C,
440x9D,0x9E,0x9F,0xA0,0xAA,0xAB,0xAC,0xAE,0xAF,0xB0,0xB1,0xB2,0xB3,0xB4,0xB5,0xB6,
450xB7,0xB8,0xB9,0xBA,0xBB,0xBC,0xBE,0xBF,0xCA,0xCB,0xCC,0xCD,0xCE,0xCF,0xDA,0xDB,
460xDC,0xDD,0xDE,0xDF,0xE1,0xEA,0xEB,0xEC,0xED,0xEE,0xEF,0xFA,0xFB,0xFC,0xFD,0xFE,
47);
48
49*I8_to_native = (isASCII)
50 ? sub { return shift }
51 : sub { return join "", map { chr $i8_to_native[ord $_] }
52 split "", shift };
53
54my $is64bit = length sprintf("%x", ~0) > 8;
55
56
57# Test utf8n_to_uvchr(). These provide essentially complete code coverage.
58# Copied from utf8.h
59my $UTF8_ALLOW_EMPTY = 0x0001;
60my $UTF8_ALLOW_CONTINUATION = 0x0002;
61my $UTF8_ALLOW_NON_CONTINUATION = 0x0004;
62my $UTF8_ALLOW_SHORT = 0x0008;
63my $UTF8_ALLOW_LONG = 0x0010;
64my $UTF8_DISALLOW_SURROGATE = 0x0020;
65my $UTF8_WARN_SURROGATE = 0x0040;
66my $UTF8_DISALLOW_NONCHAR = 0x0080;
67my $UTF8_WARN_NONCHAR = 0x0100;
68my $UTF8_DISALLOW_SUPER = 0x0200;
69my $UTF8_WARN_SUPER = 0x0400;
1d1c12d9
KW
70my $UTF8_DISALLOW_ABOVE_31_BIT = 0x0800;
71my $UTF8_WARN_ABOVE_31_BIT = 0x1000;
7dfd8446
KW
72my $UTF8_CHECK_ONLY = 0x2000;
73
046d01eb
KW
74# Test uvchr_to_utf8().
75my $UNICODE_WARN_SURROGATE = 0x0001;
76my $UNICODE_WARN_NONCHAR = 0x0002;
77my $UNICODE_WARN_SUPER = 0x0004;
78my $UNICODE_WARN_ABOVE_31_BIT = 0x0008;
79my $UNICODE_DISALLOW_SURROGATE = 0x0010;
80my $UNICODE_DISALLOW_NONCHAR = 0x0020;
81my $UNICODE_DISALLOW_SUPER = 0x0040;
82my $UNICODE_DISALLOW_ABOVE_31_BIT = 0x0080;
83
84my $look_for_everything_utf8n_to
85 = $UTF8_DISALLOW_SURROGATE
7dfd8446
KW
86 | $UTF8_WARN_SURROGATE
87 | $UTF8_DISALLOW_NONCHAR
88 | $UTF8_WARN_NONCHAR
89 | $UTF8_DISALLOW_SUPER
90 | $UTF8_WARN_SUPER
1d1c12d9
KW
91 | $UTF8_DISALLOW_ABOVE_31_BIT
92 | $UTF8_WARN_ABOVE_31_BIT;
046d01eb
KW
93my $look_for_everything_uvchr_to
94 = $UNICODE_DISALLOW_SURROGATE
95 | $UNICODE_WARN_SURROGATE
96 | $UNICODE_DISALLOW_NONCHAR
97 | $UNICODE_WARN_NONCHAR
98 | $UNICODE_DISALLOW_SUPER
99 | $UNICODE_WARN_SUPER
100 | $UNICODE_DISALLOW_ABOVE_31_BIT
101 | $UNICODE_WARN_ABOVE_31_BIT;
7dfd8446 102
fed3ba5d
NC
103foreach ([0, '', '', 'empty'],
104 [0, 'N', 'N', '1 char'],
105 [1, 'NN', 'N', '1 char substring'],
106 [-2, 'Perl', 'Rules', 'different'],
4deba822
KW
107 [0, $pound_sign, $pound_sign, 'pound sign'],
108 [1, $pound_sign . 10, $pound_sign . 1, '10 pounds is more than 1 pound'],
109 [1, $pound_sign . $pound_sign, $pound_sign, '2 pound signs are more than 1'],
fed3ba5d
NC
110 [-2, ' $!', " \x{1F42B}!", 'Camels are worth more than 1 dollar'],
111 [-1, '!', "!\x{1F42A}", 'Initial substrings match'],
112 ) {
113 my ($expect, $left, $right, $desc) = @$_;
114 my $copy = $right;
115 utf8::encode($copy);
116 is(bytes_cmp_utf8($left, $copy), $expect, $desc);
117 next if $right =~ tr/\0-\377//c;
118 utf8::encode($left);
119 is(bytes_cmp_utf8($right, $left), -$expect, "$desc reversed");
120}
121
7dfd8446
KW
122# The keys to this hash are Unicode code points, their values are the native
123# UTF-8 representations of them. The code points are chosen because they are
124# "interesting" on either or both ASCII and EBCDIC platforms. First we add
125# boundaries where the number of bytes required to represent them increase, or
126# are adjacent to problematic code points, so we want to make sure they aren't
127# considered problematic.
128my %code_points = (
129 0x0100 => (isASCII) ? "\xc4\x80" : I8_to_native("\xc8\xa0"),
130 0x0400 - 1 => (isASCII) ? "\xcf\xbf" : I8_to_native("\xdf\xbf"),
131 0x0400 => (isASCII) ? "\xd0\x80" : I8_to_native("\xe1\xa0\xa0"),
132 0x0800 - 1 => (isASCII) ? "\xdf\xbf" : I8_to_native("\xe1\xbf\xbf"),
133 0x0800 => (isASCII) ? "\xe0\xa0\x80" : I8_to_native("\xe2\xa0\xa0"),
134 0x4000 - 1 => (isASCII) ? "\xe3\xbf\xbf" : I8_to_native("\xef\xbf\xbf"),
135 0x4000 => (isASCII) ? "\xe4\x80\x80" : I8_to_native("\xf0\xb0\xa0\xa0"),
136 0x8000 - 1 => (isASCII) ? "\xe7\xbf\xbf" : I8_to_native("\xf0\xbf\xbf\xbf"),
137
138 # First code point that the implementation of isUTF8_POSSIBLY_PROBLEMATIC,
139 # as of this writing, considers potentially problematic on EBCDIC
140 0x8000 => (isASCII) ? "\xe8\x80\x80" : I8_to_native("\xf1\xa0\xa0\xa0"),
141
142 0xD000 - 1 => (isASCII) ? "\xec\xbf\xbf" : I8_to_native("\xf1\xb3\xbf\xbf"),
143
144 # First code point that the implementation of isUTF8_POSSIBLY_PROBLEMATIC,
145 # as of this writing, considers potentially problematic on ASCII
146 0xD000 => (isASCII) ? "\xed\x80\x80" : I8_to_native("\xf1\xb4\xa0\xa0"),
147
148 # Bracket the surrogates
149 0xD7FF => (isASCII) ? "\xed\x9f\xbf" : I8_to_native("\xf1\xb5\xbf\xbf"),
150 0xE000 => (isASCII) ? "\xee\x80\x80" : I8_to_native("\xf1\xb8\xa0\xa0"),
151
152 # Bracket the 32 contiguous non characters
153 0xFDCF => (isASCII) ? "\xef\xb7\x8f" : I8_to_native("\xf1\xbf\xae\xaf"),
154 0xFDF0 => (isASCII) ? "\xef\xb7\xb0" : I8_to_native("\xf1\xbf\xaf\xb0"),
155
156 # Mostly bracket non-characters, but some are transitions to longer
157 # strings
158 0xFFFD => (isASCII) ? "\xef\xbf\xbd" : I8_to_native("\xf1\xbf\xbf\xbd"),
159 0x10000 - 1 => (isASCII) ? "\xef\xbf\xbf" : I8_to_native("\xf1\xbf\xbf\xbf"),
160 0x10000 => (isASCII) ? "\xf0\x90\x80\x80" : I8_to_native("\xf2\xa0\xa0\xa0"),
161 0x1FFFD => (isASCII) ? "\xf0\x9f\xbf\xbd" : I8_to_native("\xf3\xbf\xbf\xbd"),
162 0x20000 => (isASCII) ? "\xf0\xa0\x80\x80" : I8_to_native("\xf4\xa0\xa0\xa0"),
163 0x2FFFD => (isASCII) ? "\xf0\xaf\xbf\xbd" : I8_to_native("\xf5\xbf\xbf\xbd"),
164 0x30000 => (isASCII) ? "\xf0\xb0\x80\x80" : I8_to_native("\xf6\xa0\xa0\xa0"),
165 0x3FFFD => (isASCII) ? "\xf0\xbf\xbf\xbd" : I8_to_native("\xf7\xbf\xbf\xbd"),
166 0x40000 - 1 => (isASCII) ? "\xf0\xbf\xbf\xbf" : I8_to_native("\xf7\xbf\xbf\xbf"),
167 0x40000 => (isASCII) ? "\xf1\x80\x80\x80" : I8_to_native("\xf8\xa8\xa0\xa0\xa0"),
168 0x4FFFD => (isASCII) ? "\xf1\x8f\xbf\xbd" : I8_to_native("\xf8\xa9\xbf\xbf\xbd"),
169 0x50000 => (isASCII) ? "\xf1\x90\x80\x80" : I8_to_native("\xf8\xaa\xa0\xa0\xa0"),
170 0x5FFFD => (isASCII) ? "\xf1\x9f\xbf\xbd" : I8_to_native("\xf8\xab\xbf\xbf\xbd"),
171 0x60000 => (isASCII) ? "\xf1\xa0\x80\x80" : I8_to_native("\xf8\xac\xa0\xa0\xa0"),
172 0x6FFFD => (isASCII) ? "\xf1\xaf\xbf\xbd" : I8_to_native("\xf8\xad\xbf\xbf\xbd"),
173 0x70000 => (isASCII) ? "\xf1\xb0\x80\x80" : I8_to_native("\xf8\xae\xa0\xa0\xa0"),
174 0x7FFFD => (isASCII) ? "\xf1\xbf\xbf\xbd" : I8_to_native("\xf8\xaf\xbf\xbf\xbd"),
175 0x80000 => (isASCII) ? "\xf2\x80\x80\x80" : I8_to_native("\xf8\xb0\xa0\xa0\xa0"),
176 0x8FFFD => (isASCII) ? "\xf2\x8f\xbf\xbd" : I8_to_native("\xf8\xb1\xbf\xbf\xbd"),
177 0x90000 => (isASCII) ? "\xf2\x90\x80\x80" : I8_to_native("\xf8\xb2\xa0\xa0\xa0"),
178 0x9FFFD => (isASCII) ? "\xf2\x9f\xbf\xbd" : I8_to_native("\xf8\xb3\xbf\xbf\xbd"),
179 0xA0000 => (isASCII) ? "\xf2\xa0\x80\x80" : I8_to_native("\xf8\xb4\xa0\xa0\xa0"),
180 0xAFFFD => (isASCII) ? "\xf2\xaf\xbf\xbd" : I8_to_native("\xf8\xb5\xbf\xbf\xbd"),
181 0xB0000 => (isASCII) ? "\xf2\xb0\x80\x80" : I8_to_native("\xf8\xb6\xa0\xa0\xa0"),
182 0xBFFFD => (isASCII) ? "\xf2\xbf\xbf\xbd" : I8_to_native("\xf8\xb7\xbf\xbf\xbd"),
183 0xC0000 => (isASCII) ? "\xf3\x80\x80\x80" : I8_to_native("\xf8\xb8\xa0\xa0\xa0"),
184 0xCFFFD => (isASCII) ? "\xf3\x8f\xbf\xbd" : I8_to_native("\xf8\xb9\xbf\xbf\xbd"),
185 0xD0000 => (isASCII) ? "\xf3\x90\x80\x80" : I8_to_native("\xf8\xba\xa0\xa0\xa0"),
186 0xDFFFD => (isASCII) ? "\xf3\x9f\xbf\xbd" : I8_to_native("\xf8\xbb\xbf\xbf\xbd"),
187 0xE0000 => (isASCII) ? "\xf3\xa0\x80\x80" : I8_to_native("\xf8\xbc\xa0\xa0\xa0"),
188 0xEFFFD => (isASCII) ? "\xf3\xaf\xbf\xbd" : I8_to_native("\xf8\xbd\xbf\xbf\xbd"),
189 0xF0000 => (isASCII) ? "\xf3\xb0\x80\x80" : I8_to_native("\xf8\xbe\xa0\xa0\xa0"),
190 0xFFFFD => (isASCII) ? "\xf3\xbf\xbf\xbd" : I8_to_native("\xf8\xbf\xbf\xbf\xbd"),
191 0x100000 => (isASCII) ? "\xf4\x80\x80\x80" : I8_to_native("\xf9\xa0\xa0\xa0\xa0"),
192 0x10FFFD => (isASCII) ? "\xf4\x8f\xbf\xbd" : I8_to_native("\xf9\xa1\xbf\xbf\xbd"),
193 0x110000 => (isASCII) ? "\xf4\x90\x80\x80" : I8_to_native("\xf9\xa2\xa0\xa0\xa0"),
194
195 # Things that would be noncharacters if they were in Unicode, and might be
196 # mistaken, if the C code is bad, to be nonchars
197 0x11FFFE => (isASCII) ? "\xf4\x9f\xbf\xbe" : I8_to_native("\xf9\xa3\xbf\xbf\xbe"),
198 0x11FFFF => (isASCII) ? "\xf4\x9f\xbf\xbf" : I8_to_native("\xf9\xa3\xbf\xbf\xbf"),
199 0x20FFFE => (isASCII) ? "\xf8\x88\x8f\xbf\xbe" : I8_to_native("\xfa\xa1\xbf\xbf\xbe"),
200 0x20FFFF => (isASCII) ? "\xf8\x88\x8f\xbf\xbf" : I8_to_native("\xfa\xa1\xbf\xbf\xbf"),
201
202 0x200000 - 1 => (isASCII) ? "\xf7\xbf\xbf\xbf" : I8_to_native("\xf9\xbf\xbf\xbf\xbf"),
203 0x200000 => (isASCII) ? "\xf8\x88\x80\x80\x80" : I8_to_native("\xfa\xa0\xa0\xa0\xa0"),
204 0x400000 - 1 => (isASCII) ? "\xf8\x8f\xbf\xbf\xbf" : I8_to_native("\xfb\xbf\xbf\xbf\xbf"),
205 0x400000 => (isASCII) ? "\xf8\x90\x80\x80\x80" : I8_to_native("\xfc\xa4\xa0\xa0\xa0\xa0"),
206 0x4000000 - 1 => (isASCII) ? "\xfb\xbf\xbf\xbf\xbf" : I8_to_native("\xfd\xbf\xbf\xbf\xbf\xbf"),
207 0x4000000 => (isASCII) ? "\xfc\x84\x80\x80\x80\x80" : I8_to_native("\xfe\xa2\xa0\xa0\xa0\xa0\xa0"),
208 0x4000000 - 1 => (isASCII) ? "\xfb\xbf\xbf\xbf\xbf" : I8_to_native("\xfd\xbf\xbf\xbf\xbf\xbf"),
209 0x4000000 => (isASCII) ? "\xfc\x84\x80\x80\x80\x80" : I8_to_native("\xfe\xa2\xa0\xa0\xa0\xa0\xa0"),
210 0x40000000 - 1 => (isASCII) ? "\xfc\xbf\xbf\xbf\xbf\xbf" : I8_to_native("\xfe\xbf\xbf\xbf\xbf\xbf\xbf"),
211 0x40000000 => (isASCII) ? "\xfd\x80\x80\x80\x80\x80" : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa1\xa0\xa0\xa0\xa0\xa0\xa0"),
212 0x80000000 - 1 => (isASCII) ? "\xfd\xbf\xbf\xbf\xbf\xbf" : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa1\xbf\xbf\xbf\xbf\xbf\xbf"),
c0236afe
KW
213 0x80000000 => (isASCII) ? "\xfe\x82\x80\x80\x80\x80\x80" : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa2\xa0\xa0\xa0\xa0\xa0\xa0"),
214 0xFFFFFFFF => (isASCII) ? "\xfe\x83\xbf\xbf\xbf\xbf\xbf" : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa3\xbf\xbf\xbf\xbf\xbf\xbf"),
7dfd8446 215);
4deba822 216
7dfd8446
KW
217if ($is64bit) {
218 no warnings qw(overflow portable);
9d2d0ecd
KW
219 $code_points{0x100000000} = (isASCII)
220 ? "\xfe\x84\x80\x80\x80\x80\x80"
221 : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa4\xa0\xa0\xa0\xa0\xa0\xa0");
222 $code_points{0x1000000000 - 1} = (isASCII)
223 ? "\xfe\xbf\xbf\xbf\xbf\xbf\xbf"
224 : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa1\xbf\xbf\xbf\xbf\xbf\xbf\xbf");
225 $code_points{0x1000000000} = (isASCII)
226 ? "\xff\x80\x80\x80\x80\x80\x81\x80\x80\x80\x80\x80\x80"
227 : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa2\xa0\xa0\xa0\xa0\xa0\xa0\xa0");
228 $code_points{0xFFFFFFFFFFFFFFFF} = (isASCII)
229 ? "\xff\x80\x8f\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf"
230 : I8_to_native("\xff\xaf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf");
d566bd20
KW
231 if (isASCII) { # These could falsely show as overlongs in a naive implementation
232 $code_points{0x40000000000} = "\xff\x80\x80\x80\x80\x81\x80\x80\x80\x80\x80\x80\x80";
233 $code_points{0x1000000000000} = "\xff\x80\x80\x80\x81\x80\x80\x80\x80\x80\x80\x80\x80";
234 $code_points{0x40000000000000} = "\xff\x80\x80\x81\x80\x80\x80\x80\x80\x80\x80\x80\x80";
235 $code_points{0x1000000000000000} = "\xff\x80\x81\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80";
236 # overflows
237 #$code_points{0xfoo} = "\xff\x81\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80";
238 }
239}
240elsif (! isASCII) { # 32-bit EBCDIC. 64-bit is clearer to handle, so doesn't need this test case
241 no warnings qw(overflow portable);
242 $code_points{0x40000000} = I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa1\xa0\xa0\xa0\xa0\xa0\xa0");
7dfd8446 243}
eb83ed87 244
7dfd8446
KW
245# Now add in entries for each of code points 0-255, which require special
246# handling on EBCDIC. Remember the keys are Unicode values, and the values
247# are the native UTF-8. For invariants, the bytes are just the native chr.
248
249my $cp = 0;
250while ($cp < ((isASCII) ? 128 : 160)) { # This is from the definition of
251 # invariant
252 $code_points{$cp} = chr utf8::unicode_to_native($cp);
253 $cp++;
254}
255
256# Done with the invariants. Now do the variants. All in this range are 2
257# byte. Again, we can't use the internal functions to generate UTF-8, as
258# those are what we are trying to test. In the loop, we know what range the
259# continuation bytes can be in, and what the lowest start byte can be. So we
260# cycle through them.
261
262my $first_continuation = (isASCII) ? 0x80 : 0xA0;
263my $final_continuation = 0xBF;
264my $start = (isASCII) ? 0xC2 : 0xC5;
265
266my $continuation = $first_continuation - 1;
267
268while ($cp < 255) {
269 if (++$continuation > $final_continuation) {
270
271 # Wrap to the next start byte when we reach the final continuation
272 # byte possible
273 $continuation = $first_continuation;
274 $start++;
275 }
276 $code_points{$cp} = I8_to_native(chr($start) . chr($continuation));
277
278 $cp++;
279}
eb83ed87
KW
280
281my @warnings;
282
283use warnings 'utf8';
284local $SIG{__WARN__} = sub { push @warnings, @_ };
285
7dfd8446
KW
286# This set of tests looks for basic sanity, and lastly tests the bottom level
287# decode routine for the given code point. If the earlier tests for that code
288# point fail, that one probably will too. Malformations are tested in later
289# segments of code.
290for my $u (sort { utf8::unicode_to_native($a) <=> utf8::unicode_to_native($b) }
291 keys %code_points)
292{
293 my $hex_u = sprintf("0x%02X", $u);
294 my $n = utf8::unicode_to_native($u);
295 my $hex_n = sprintf("0x%02X", $n);
296 my $bytes = $code_points{$u};
297
298 my $offskip_should_be;
299 {
300 no warnings qw(overflow portable);
301 $offskip_should_be = (isASCII)
302 ? ( $u < 0x80 ? 1 :
303 $u < 0x800 ? 2 :
304 $u < 0x10000 ? 3 :
305 $u < 0x200000 ? 4 :
306 $u < 0x4000000 ? 5 :
307 $u < 0x80000000 ? 6 : (($is64bit)
308 ? ($u < 0x1000000000 ? 7 : 13)
309 : 7)
310 )
311 : ($u < 0xA0 ? 1 :
312 $u < 0x400 ? 2 :
313 $u < 0x4000 ? 3 :
314 $u < 0x40000 ? 4 :
315 $u < 0x400000 ? 5 :
c0236afe
KW
316 $u < 0x4000000 ? 6 :
317 $u < 0x40000000 ? 7 : 14 );
7dfd8446
KW
318 }
319
320 # If this test fails, subsequent ones are meaningless.
321 next unless is(test_OFFUNISKIP($u), $offskip_should_be,
322 "Verify OFFUNISKIP($hex_u) is $offskip_should_be");
323 my $invariant = $offskip_should_be == 1;
324 my $display_invariant = $invariant || 0;
325 is(test_OFFUNI_IS_INVARIANT($u), $invariant,
326 "Verify OFFUNI_IS_INVARIANT($hex_u) is $display_invariant");
327
328 my $uvchr_skip_should_be = $offskip_should_be;
329 next unless is(test_UVCHR_SKIP($n), $uvchr_skip_should_be,
330 "Verify UVCHR_SKIP($hex_n) is $uvchr_skip_should_be");
331 is(test_UVCHR_IS_INVARIANT($n), $offskip_should_be == 1,
332 "Verify UVCHR_IS_INVARIANT($hex_n) is $display_invariant");
333
334 my $n_chr = chr $n;
335 utf8::upgrade $n_chr;
336
337 is(test_UTF8_SKIP($n_chr), $uvchr_skip_should_be,
338 "Verify UTF8_SKIP(chr $hex_n) is $uvchr_skip_should_be");
339
340 use bytes;
3d56ecbe
KW
341 my $byte_length = length $n_chr;
342 for (my $j = 0; $j < $byte_length; $j++) {
343 undef @warnings;
344
345 if ($j == $byte_length - 1) {
346 my $ret = test_is_utf8_valid_partial_char_flags($n_chr, $byte_length, 0);
347 is($ret, 0, " Verify is_utf8_valid_partial_char_flags(" . display_bytes($n_chr) . ") returns 0 for full character");
348 }
349 else {
350 my $bytes_so_far = substr($n_chr, 0, $j + 1);
351 my $ret = test_is_utf8_valid_partial_char_flags($bytes_so_far, $j + 1, 0);
352 is($ret, 1, " Verify is_utf8_valid_partial_char_flags(" . display_bytes($bytes_so_far) . ") returns 1");
353 }
354
355 unless (is(scalar @warnings, 0,
356 " Verify is_utf8_valid_partial_char_flags generated no warnings"))
357 {
358 diag "The warnings were: " . join(", ", @warnings);
359 }
360
7dfd8446
KW
361 my $b = substr($n_chr, $j, 1);
362 my $hex_b = sprintf("\"\\x%02x\"", ord $b);
363
364 my $byte_invariant = $j == 0 && $uvchr_skip_should_be == 1;
365 my $display_byte_invariant = $byte_invariant || 0;
366 next unless is(test_UTF8_IS_INVARIANT($b), $byte_invariant,
367 " Verify UTF8_IS_INVARIANT($hex_b) for byte $j "
368 . "is $display_byte_invariant");
369
370 my $is_start = $j == 0 && $uvchr_skip_should_be > 1;
371 my $display_is_start = $is_start || 0;
372 next unless is(test_UTF8_IS_START($b), $is_start,
373 " Verify UTF8_IS_START($hex_b) is $display_is_start");
374
375 my $is_continuation = $j != 0 && $uvchr_skip_should_be > 1;
376 my $display_is_continuation = $is_continuation || 0;
377 next unless is(test_UTF8_IS_CONTINUATION($b), $is_continuation,
378 " Verify UTF8_IS_CONTINUATION($hex_b) is "
379 . "$display_is_continuation");
380
381 my $is_continued = $uvchr_skip_should_be > 1;
382 my $display_is_continued = $is_continued || 0;
383 next unless is(test_UTF8_IS_CONTINUED($b), $is_continued,
384 " Verify UTF8_IS_CONTINUED($hex_b) is "
385 . "$display_is_continued");
386
387 my $is_downgradeable_start = $n < 256
388 && $uvchr_skip_should_be > 1
389 && $j == 0;
390 my $display_is_downgradeable_start = $is_downgradeable_start || 0;
391 next unless is(test_UTF8_IS_DOWNGRADEABLE_START($b),
392 $is_downgradeable_start,
393 " Verify UTF8_IS_DOWNGRADEABLE_START($hex_b) is "
394 . "$display_is_downgradeable_start");
395
396 my $is_above_latin1 = $n > 255 && $j == 0;
397 my $display_is_above_latin1 = $is_above_latin1 || 0;
398 next unless is(test_UTF8_IS_ABOVE_LATIN1($b),
399 $is_above_latin1,
400 " Verify UTF8_IS_ABOVE_LATIN1($hex_b) is "
401 . "$display_is_above_latin1");
402
403 my $is_possibly_problematic = $j == 0
404 && $n >= ((isASCII)
405 ? 0xD000
406 : 0x8000);
407 my $display_is_possibly_problematic = $is_possibly_problematic || 0;
408 next unless is(test_isUTF8_POSSIBLY_PROBLEMATIC($b),
409 $is_possibly_problematic,
410 " Verify isUTF8_POSSIBLY_PROBLEMATIC($hex_b) is "
411 . "$display_is_above_latin1");
412 }
413
414 # We are not trying to look for warnings, etc, so if they should occur, it
415 # is an error. But some of the code points here do cause warnings, so we
416 # check here and turn off the ones that apply to such code points. A
417 # later section of the code tests for these kinds of things.
046d01eb 418 my $this_utf8_flags = $look_for_everything_utf8n_to;
7dfd8446
KW
419 my $len = length $bytes;
420 if ($n > 2 ** 31 - 1) {
1d1c12d9
KW
421 $this_utf8_flags &=
422 ~($UTF8_DISALLOW_ABOVE_31_BIT|$UTF8_WARN_ABOVE_31_BIT);
7dfd8446 423 }
e23e8bc1
KW
424
425 my $valid_under_strict = 1;
a82be82b 426 my $valid_under_c9strict = 1;
7dfd8446
KW
427 if ($n > 0x10FFFF) {
428 $this_utf8_flags &= ~($UTF8_DISALLOW_SUPER|$UTF8_WARN_SUPER);
e23e8bc1 429 $valid_under_strict = 0;
a82be82b 430 $valid_under_c9strict = 0;
7dfd8446
KW
431 }
432 elsif (($n & 0xFFFE) == 0xFFFE) {
433 $this_utf8_flags &= ~($UTF8_DISALLOW_NONCHAR|$UTF8_WARN_NONCHAR);
e23e8bc1 434 $valid_under_strict = 0;
7dfd8446
KW
435 }
436
437 undef @warnings;
438
439 my $display_flags = sprintf "0x%x", $this_utf8_flags;
7dfd8446 440 my $display_bytes = display_bytes($bytes);
d7874298 441 my $ret_ref = test_utf8n_to_uvchr($bytes, $len, $this_utf8_flags);
7dfd8446 442 is($ret_ref->[0], $n, "Verify utf8n_to_uvchr($display_bytes, $display_flags) returns $hex_n");
9d2d0ecd 443 is($ret_ref->[1], $len, "Verify utf8n_to_uvchr() for $hex_n returns expected length: $len");
7dfd8446
KW
444
445 unless (is(scalar @warnings, 0,
446 "Verify utf8n_to_uvchr() for $hex_n generated no warnings"))
447 {
448 diag "The warnings were: " . join(", ", @warnings);
449 }
046d01eb 450
75ffa578
KW
451 undef @warnings;
452
d7874298 453 my $ret = test_isUTF8_CHAR($bytes, $len);
9d2d0ecd 454 is($ret, $len, "Verify isUTF8_CHAR($display_bytes) returns expected length: $len");
d7874298
KW
455
456 unless (is(scalar @warnings, 0,
457 "Verify isUTF8_CHAR() for $hex_n generated no warnings"))
458 {
459 diag "The warnings were: " . join(", ", @warnings);
460 }
461
462 undef @warnings;
463
464 $ret = test_isUTF8_CHAR($bytes, $len - 1);
465 is($ret, 0, "Verify isUTF8_CHAR() with too short length parameter returns 0");
466
467 unless (is(scalar @warnings, 0,
468 "Verify isUTF8_CHAR() generated no warnings"))
469 {
470 diag "The warnings were: " . join(", ", @warnings);
471 }
472
473 undef @warnings;
474
e23e8bc1
KW
475 $ret = test_isSTRICT_UTF8_CHAR($bytes, $len);
476 my $expected_len = ($valid_under_strict) ? $len : 0;
477 is($ret, $expected_len, "Verify isSTRICT_UTF8_CHAR($display_bytes) returns expected length: $expected_len");
478
479 unless (is(scalar @warnings, 0,
480 "Verify isSTRICT_UTF8_CHAR() for $hex_n generated no warnings"))
481 {
482 diag "The warnings were: " . join(", ", @warnings);
483 }
484
485 undef @warnings;
486
487 $ret = test_isSTRICT_UTF8_CHAR($bytes, $len - 1);
488 is($ret, 0, "Verify isSTRICT_UTF8_CHAR() with too short length parameter returns 0");
489
490 unless (is(scalar @warnings, 0,
491 "Verify isSTRICT_UTF8_CHAR() generated no warnings"))
492 {
493 diag "The warnings were: " . join(", ", @warnings);
494 }
495
a82be82b
KW
496 $ret = test_isC9_STRICT_UTF8_CHAR($bytes, $len);
497 $expected_len = ($valid_under_c9strict) ? $len : 0;
498 is($ret, $expected_len, "Verify isC9_STRICT_UTF8_CHAR($display_bytes) returns expected length: $len");
499
500 unless (is(scalar @warnings, 0,
501 "Verify isC9_STRICT_UTF8_CHAR() for $hex_n generated no warnings"))
502 {
503 diag "The warnings were: " . join(", ", @warnings);
504 }
505
506 undef @warnings;
507
508 $ret = test_isC9_STRICT_UTF8_CHAR($bytes, $len - 1);
509 is($ret, 0, "Verify isC9_STRICT_UTF8_CHAR() with too short length parameter returns 0");
510
511 unless (is(scalar @warnings, 0,
512 "Verify isC9_STRICT_UTF8_CHAR() generated no warnings"))
513 {
514 diag "The warnings were: " . join(", ", @warnings);
515 }
516
e23e8bc1
KW
517 undef @warnings;
518
75ffa578
KW
519 $ret_ref = test_valid_utf8_to_uvchr($bytes);
520 is($ret_ref->[0], $n, "Verify valid_utf8_to_uvchr($display_bytes) returns $hex_n");
9d2d0ecd 521 is($ret_ref->[1], $len, "Verify valid_utf8_to_uvchr() for $hex_n returns expected length: $len");
75ffa578
KW
522
523 unless (is(scalar @warnings, 0,
524 "Verify valid_utf8_to_uvchr() for $hex_n generated no warnings"))
525 {
526 diag "The warnings were: " . join(", ", @warnings);
527 }
528
046d01eb
KW
529 # Similarly for uvchr_to_utf8
530 my $this_uvchr_flags = $look_for_everything_uvchr_to;
531 if ($n > 2 ** 31 - 1) {
532 $this_uvchr_flags &=
533 ~($UNICODE_DISALLOW_ABOVE_31_BIT|$UNICODE_WARN_ABOVE_31_BIT);
534 }
535 if ($n > 0x10FFFF) {
536 $this_uvchr_flags &= ~($UNICODE_DISALLOW_SUPER|$UNICODE_WARN_SUPER);
537 }
538 elsif (($n & 0xFFFE) == 0xFFFE) {
539 $this_uvchr_flags &= ~($UNICODE_DISALLOW_NONCHAR|$UNICODE_WARN_NONCHAR);
540 }
541 $display_flags = sprintf "0x%x", $this_uvchr_flags;
542
543 undef @warnings;
544
d7874298 545 $ret = test_uvchr_to_utf8_flags($n, $this_uvchr_flags);
046d01eb
KW
546 ok(defined $ret, "Verify uvchr_to_utf8_flags($hex_n, $display_flags) returned success");
547 is($ret, $bytes, "Verify uvchr_to_utf8_flags($hex_n, $display_flags) returns correct bytes");
548
549 unless (is(scalar @warnings, 0,
550 "Verify uvchr_to_utf8_flags($hex_n, $display_flags) for $hex_n generated no warnings"))
551 {
552 diag "The warnings were: " . join(", ", @warnings);
553 }
7dfd8446
KW
554}
555
556my $REPLACEMENT = 0xFFFD;
557
558# Now test the malformations. All these raise category utf8 warnings.
559my $c = (isASCII) ? "\x80" : "\xa0"; # A continuation byte
560my @malformations = (
eb83ed87
KW
561 [ "zero length string malformation", "", 0,
562 $UTF8_ALLOW_EMPTY, 0, 0,
563 qr/empty string/
564 ],
7dfd8446
KW
565 [ "orphan continuation byte malformation", I8_to_native("${c}a"),
566 2,
eb83ed87
KW
567 $UTF8_ALLOW_CONTINUATION, $REPLACEMENT, 1,
568 qr/unexpected continuation byte/
569 ],
7dfd8446 570 [ "premature next character malformation (immediate)",
9d2d0ecd
KW
571 (isASCII) ? "\xc2\xc2\x80" : I8_to_native("\xc5\xc5\xa0"),
572 3,
eb83ed87
KW
573 $UTF8_ALLOW_NON_CONTINUATION, $REPLACEMENT, 1,
574 qr/unexpected non-continuation byte.*immediately after start byte/
575 ],
7dfd8446
KW
576 [ "premature next character malformation (non-immediate)",
577 I8_to_native("\xf0${c}a"),
578 3,
eb83ed87
KW
579 $UTF8_ALLOW_NON_CONTINUATION, $REPLACEMENT, 2,
580 qr/unexpected non-continuation byte .* 2 bytes after start byte/
581 ],
7dfd8446 582 [ "too short malformation", I8_to_native("\xf0${c}a"), 2,
eb83ed87
KW
583 # Having the 'a' after this, but saying there are only 2 bytes also
584 # tests that we pay attention to the passed in length
585 $UTF8_ALLOW_SHORT, $REPLACEMENT, 2,
586 qr/2 bytes, need 4/
587 ],
d566bd20
KW
588 [ "overlong malformation, lowest 2-byte",
589 (isASCII) ? "\xc0\x80" : I8_to_native("\xc0\xa0"),
590 2,
7dfd8446
KW
591 $UTF8_ALLOW_LONG,
592 0, # NUL
593 2,
eb83ed87 594 qr/2 bytes, need 1/
c0236afe 595 ],
d566bd20
KW
596 [ "overlong malformation, highest 2-byte",
597 (isASCII) ? "\xc1\xbf" : I8_to_native("\xc4\xbf"),
598 2,
599 $UTF8_ALLOW_LONG,
600 (isASCII) ? 0x7F : utf8::unicode_to_native(0xBF),
601 2,
602 qr/2 bytes, need 1/
603 ],
604 [ "overlong malformation, lowest 3-byte",
605 (isASCII) ? "\xe0\x80\x80" : I8_to_native("\xe0\xa0\xa0"),
606 3,
607 $UTF8_ALLOW_LONG,
608 0, # NUL
609 3,
610 qr/3 bytes, need 1/
611 ],
612 [ "overlong malformation, highest 3-byte",
613 (isASCII) ? "\xe0\x9f\xbf" : I8_to_native("\xe0\xbf\xbf"),
614 3,
615 $UTF8_ALLOW_LONG,
616 (isASCII) ? 0x7FF : 0x3FF,
617 3,
618 qr/3 bytes, need 2/
619 ],
620 [ "overlong malformation, lowest 4-byte",
621 (isASCII) ? "\xf0\x80\x80\x80" : I8_to_native("\xf0\xa0\xa0\xa0"),
622 4,
623 $UTF8_ALLOW_LONG,
624 0, # NUL
625 4,
626 qr/4 bytes, need 1/
627 ],
628 [ "overlong malformation, highest 4-byte",
629 (isASCII) ? "\xf0\x8F\xbf\xbf" : I8_to_native("\xf0\xaf\xbf\xbf"),
630 4,
631 $UTF8_ALLOW_LONG,
632 (isASCII) ? 0xFFFF : 0x3FFF,
633 4,
634 qr/4 bytes, need 3/
635 ],
636 [ "overlong malformation, lowest 5-byte",
637 (isASCII)
638 ? "\xf8\x80\x80\x80\x80"
639 : I8_to_native("\xf8\xa0\xa0\xa0\xa0"),
640 5,
641 $UTF8_ALLOW_LONG,
642 0, # NUL
643 5,
644 qr/5 bytes, need 1/
645 ],
646 [ "overlong malformation, highest 5-byte",
647 (isASCII)
648 ? "\xf8\x87\xbf\xbf\xbf"
649 : I8_to_native("\xf8\xa7\xbf\xbf\xbf"),
650 5,
651 $UTF8_ALLOW_LONG,
652 (isASCII) ? 0x1FFFFF : 0x3FFFF,
653 5,
654 qr/5 bytes, need 4/
655 ],
656 [ "overlong malformation, lowest 6-byte",
657 (isASCII)
658 ? "\xfc\x80\x80\x80\x80\x80"
659 : I8_to_native("\xfc\xa0\xa0\xa0\xa0\xa0"),
660 6,
661 $UTF8_ALLOW_LONG,
662 0, # NUL
663 6,
664 qr/6 bytes, need 1/
665 ],
666 [ "overlong malformation, highest 6-byte",
667 (isASCII)
668 ? "\xfc\x83\xbf\xbf\xbf\xbf"
669 : I8_to_native("\xfc\xa3\xbf\xbf\xbf\xbf"),
670 6,
671 $UTF8_ALLOW_LONG,
672 (isASCII) ? 0x3FFFFFF : 0x3FFFFF,
673 6,
674 qr/6 bytes, need 5/
675 ],
676 [ "overlong malformation, lowest 7-byte",
677 (isASCII)
678 ? "\xfe\x80\x80\x80\x80\x80\x80"
679 : I8_to_native("\xfe\xa0\xa0\xa0\xa0\xa0\xa0"),
680 7,
681 $UTF8_ALLOW_LONG,
682 0, # NUL
683 7,
684 qr/7 bytes, need 1/
685 ],
686 [ "overlong malformation, highest 7-byte",
687 (isASCII)
688 ? "\xfe\x81\xbf\xbf\xbf\xbf\xbf"
689 : I8_to_native("\xfe\xa1\xbf\xbf\xbf\xbf\xbf"),
690 7,
691 $UTF8_ALLOW_LONG,
692 (isASCII) ? 0x7FFFFFFF : 0x3FFFFFF,
693 7,
694 qr/7 bytes, need 6/
c0236afe
KW
695 ],
696);
7dfd8446 697
d566bd20
KW
698if (isASCII && ! $is64bit) { # 32-bit ASCII platform
699 no warnings 'portable';
700 push @malformations,
701 [ "overflow malformation",
702 "\xfe\x84\x80\x80\x80\x80\x80", # Represents 2**32
703 7,
704 0, # There is no way to allow this malformation
705 $REPLACEMENT,
706 7,
707 qr/overflow/
708 ],
709 [ "overflow malformation, can tell on first byte",
710 "\xff\x80\x80\x80\x80\x80\x81\x80\x80\x80\x80\x80\x80",
711 13,
712 0, # There is no way to allow this malformation
713 $REPLACEMENT,
714 13,
715 qr/overflow/
716 ];
717}
718else {
719 # On EBCDIC platforms, another overlong test is needed even on 32-bit
720 # systems, whereas it doesn't happen on ASCII except on 64-bit ones.
721
722 no warnings 'portable';
723 no warnings 'overflow'; # Doesn't run on 32-bit systems, but compiles
724 push @malformations,
725 [ "overlong malformation, lowest max-byte",
726 (isASCII)
727 ? "\xff\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80"
728 : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
729 (isASCII) ? 13 : 14,
730 $UTF8_ALLOW_LONG,
731 0, # NUL
732 (isASCII) ? 13 : 14,
733 qr/1[34] bytes, need 1/, # 1[34] to work on either ASCII or EBCDIC
734 ],
735 [ "overlong malformation, highest max-byte",
736 (isASCII) # 2**36-1 on ASCII; 2**30-1 on EBCDIC
737 ? "\xff\x80\x80\x80\x80\x80\x80\xbf\xbf\xbf\xbf\xbf\xbf"
738 : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xbf\xbf\xbf\xbf\xbf\xbf"),
739 (isASCII) ? 13 : 14,
740 $UTF8_ALLOW_LONG,
741 (isASCII) ? 0xFFFFFFFFF : 0x3FFFFFFF,
742 (isASCII) ? 13 : 14,
743 qr/1[34] bytes, need 7/,
744 ];
745
746 if (! $is64bit) { # 32-bit EBCDIC
747 push @malformations,
748 [ "overflow malformation",
749 I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa4\xa0\xa0\xa0\xa0\xa0\xa0"),
750 14,
751 0, # There is no way to allow this malformation
752 $REPLACEMENT,
753 14,
754 qr/overflow/
755 ];
756 }
757 else { # 64-bit
758 push @malformations,
759 [ "overflow malformation",
760 (isASCII)
761 ? "\xff\x80\x90\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"
762 : I8_to_native("\xff\xb0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
763 (isASCII) ? 13 : 14,
764 0, # There is no way to allow this malformation
765 $REPLACEMENT,
766 (isASCII) ? 13 : 14,
767 qr/overflow/
768 ];
769 }
770}
771
7dfd8446 772foreach my $test (@malformations) {
eb83ed87
KW
773 my ($testname, $bytes, $length, $allow_flags, $allowed_uv, $expected_len, $message ) = @$test;
774
775 next if ! ok(length($bytes) >= $length, "$testname: Make sure won't read beyond buffer: " . length($bytes) . " >= $length");
776
d7874298
KW
777 undef @warnings;
778
779 my $ret = test_isUTF8_CHAR($bytes, $length);
780 is($ret, 0, "$testname: isUTF8_CHAR returns 0");
781 unless (is(scalar @warnings, 0,
782 "$testname: isUTF8_CHAR() generated no warnings"))
783 {
784 diag "The warnings were: " . join(", ", @warnings);
785 }
786
e23e8bc1
KW
787 $ret = test_isSTRICT_UTF8_CHAR($bytes, $length);
788 is($ret, 0, "$testname: isSTRICT_UTF8_CHAR returns 0");
789 unless (is(scalar @warnings, 0,
790 "$testname: isSTRICT_UTF8_CHAR() generated no warnings"))
791 {
792 diag "The warnings were: " . join(", ", @warnings);
793 }
794
a82be82b
KW
795 $ret = test_isC9_STRICT_UTF8_CHAR($bytes, $length);
796 is($ret, 0, "$testname: isC9_STRICT_UTF8_CHAR returns 0");
797 unless (is(scalar @warnings, 0,
798 "$testname: isC9_STRICT_UTF8_CHAR() generated no warnings"))
799 {
800 diag "The warnings were: " . join(", ", @warnings);
801 }
802
3d56ecbe
KW
803 for my $j (1 .. $length - 1) {
804 my $partial = substr($bytes, 0, $j);
805
806 undef @warnings;
807
808 $ret = test_is_utf8_valid_partial_char_flags($bytes, $j, 0);
809 my $ret_should_be = 0;
810 my $comment = "";
811 if ($testname =~ /premature|short/ && $j < 2) {
812 $ret_should_be = 1;
813 $comment = ", but need 2 bytes to discern:";
814 }
815 elsif ($testname =~ /overlong/ && $length > 2) {
816 if ($length <= 7 && $j < 2) {
817 $ret_should_be = 1;
818 $comment = ", but need 2 bytes to discern:";
819 }
820 elsif ($length > 7 && $j < 7) {
821 $ret_should_be = 1;
822 $comment = ", but need 7 bytes to discern:";
823 }
824 }
825 elsif ($testname =~ /overflow/ && $testname !~ /first byte/) {
826 if (isASCII) {
827 if ($j < (($is64bit) ? 3 : 2)) {
828 $comment = ", but need $j bytes to discern:";
829 $ret_should_be = 1;
830 }
831 }
832 else {
833 if ($j < (($is64bit) ? 2 : 8)) {
834 $comment = ", but need $j bytes to discern:";
835 $ret_should_be = 1;
836 }
837 }
838 }
839 is($ret, $ret_should_be, "$testname: is_utf8_valid_partial_char_flags("
840 . display_bytes($partial)
841 . ")$comment returns $ret_should_be");
842 unless (is(scalar @warnings, 0,
843 "$testname: is_utf8_valid_partial_char_flags() generated no warnings"))
844 {
845 diag "The warnings were: " . join(", ", @warnings);
846 }
847 }
848
d7874298 849
eb83ed87
KW
850 # Test what happens when this malformation is not allowed
851 undef @warnings;
bd70aaaf 852 my $ret_ref = test_utf8n_to_uvchr($bytes, $length, 0);
eb83ed87 853 is($ret_ref->[0], 0, "$testname: disallowed: Returns 0");
9d2d0ecd 854 is($ret_ref->[1], $expected_len, "$testname: utf8n_to_uvchr(), disallowed: Returns expected length: $expected_len");
eb83ed87
KW
855 if (is(scalar @warnings, 1, "$testname: disallowed: Got a single warning ")) {
856 like($warnings[0], $message, "$testname: disallowed: Got expected warning");
857 }
858 else {
859 if (scalar @warnings) {
7dfd8446 860 diag "The warnings were: " . join(", ", @warnings);
eb83ed87
KW
861 }
862 }
863
864 { # Next test when disallowed, and warnings are off.
865 undef @warnings;
866 no warnings 'utf8';
bd70aaaf 867 my $ret_ref = test_utf8n_to_uvchr($bytes, $length, 0);
9d2d0ecd
KW
868 is($ret_ref->[0], 0, "$testname: utf8n_to_uvchr(), disallowed: no warnings 'utf8': Returns 0");
869 is($ret_ref->[1], $expected_len, "$testname: utf8n_to_uvchr(), disallowed: no warnings 'utf8': Returns expected length: $expected_len");
870 if (!is(scalar @warnings, 0, "$testname: utf8n_to_uvchr(), disallowed: no warnings 'utf8': no warnings generated")) {
7dfd8446 871 diag "The warnings were: " . join(", ", @warnings);
eb83ed87
KW
872 }
873 }
874
875 # Test with CHECK_ONLY
876 undef @warnings;
bd70aaaf 877 $ret_ref = test_utf8n_to_uvchr($bytes, $length, $UTF8_CHECK_ONLY);
eb83ed87 878 is($ret_ref->[0], 0, "$testname: CHECK_ONLY: Returns 0");
9d2d0ecd 879 is($ret_ref->[1], -1, "$testname: CHECK_ONLY: returns -1 for length");
eb83ed87 880 if (! is(scalar @warnings, 0, "$testname: CHECK_ONLY: no warnings generated")) {
7dfd8446 881 diag "The warnings were: " . join(", ", @warnings);
eb83ed87
KW
882 }
883
884 next if $allow_flags == 0; # Skip if can't allow this malformation
885
886 # Test when the malformation is allowed
887 undef @warnings;
bd70aaaf 888 $ret_ref = test_utf8n_to_uvchr($bytes, $length, $allow_flags);
9d2d0ecd
KW
889 is($ret_ref->[0], $allowed_uv, "$testname: utf8n_to_uvchr(), allowed: Returns expected uv: " . sprintf("0x%04X", $allowed_uv));
890 is($ret_ref->[1], $expected_len, "$testname: utf8n_to_uvchr(), allowed: Returns expected length: $expected_len");
891 if (!is(scalar @warnings, 0, "$testname: utf8n_to_uvchr(), allowed: no warnings generated"))
eb83ed87 892 {
7dfd8446 893 diag "The warnings were: " . join(", ", @warnings);
eb83ed87
KW
894 }
895}
896
eb83ed87
KW
897# Now test the cases where a legal code point is generated, but may or may not
898# be allowed/warned on.
2f8f112e 899my @tests = (
7dfd8446
KW
900 [ "lowest surrogate",
901 (isASCII) ? "\xed\xa0\x80" : I8_to_native("\xf1\xb6\xa0\xa0"),
902 $UTF8_WARN_SURROGATE, $UTF8_DISALLOW_SURROGATE,
903 'surrogate', 0xD800,
904 (isASCII) ? 3 : 4,
905 qr/surrogate/
906 ],
907 [ "a middle surrogate",
908 (isASCII) ? "\xed\xa4\x8d" : I8_to_native("\xf1\xb6\xa8\xad"),
909 $UTF8_WARN_SURROGATE, $UTF8_DISALLOW_SURROGATE,
910 'surrogate', 0xD90D,
911 (isASCII) ? 3 : 4,
eb83ed87
KW
912 qr/surrogate/
913 ],
7dfd8446
KW
914 [ "highest surrogate",
915 (isASCII) ? "\xed\xbf\xbf" : I8_to_native("\xf1\xb7\xbf\xbf"),
916 $UTF8_WARN_SURROGATE, $UTF8_DISALLOW_SURROGATE,
917 'surrogate', 0xDFFF,
918 (isASCII) ? 3 : 4,
919 qr/surrogate/
920 ],
921 [ "first non_unicode",
922 (isASCII) ? "\xf4\x90\x80\x80" : I8_to_native("\xf9\xa2\xa0\xa0\xa0"),
923 $UTF8_WARN_SUPER, $UTF8_DISALLOW_SUPER,
924 'non_unicode', 0x110000,
925 (isASCII) ? 4 : 5,
926 qr/not Unicode.* may not be portable/
927 ],
d566bd20
KW
928 [ "non_unicode whose first byte tells that",
929 (isASCII) ? "\xf5\x80\x80\x80" : I8_to_native("\xfa\xa0\xa0\xa0\xa0"),
930 $UTF8_WARN_SUPER, $UTF8_DISALLOW_SUPER,
931 'non_unicode',
932 (isASCII) ? 0x140000 : 0x200000,
933 (isASCII) ? 4 : 5,
934 qr/not Unicode.* may not be portable/
935 ],
7dfd8446
KW
936 [ "first of 32 consecutive non-character code points",
937 (isASCII) ? "\xef\xb7\x90" : I8_to_native("\xf1\xbf\xae\xb0"),
938 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
939 'nonchar', 0xFDD0,
940 (isASCII) ? 3 : 4,
941 qr/Unicode non-character.*is not recommended for open interchange/
942 ],
943 [ "a mid non-character code point of the 32 consecutive ones",
944 (isASCII) ? "\xef\xb7\xa0" : I8_to_native("\xf1\xbf\xaf\xa0"),
945 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
946 'nonchar', 0xFDE0,
947 (isASCII) ? 3 : 4,
948 qr/Unicode non-character.*is not recommended for open interchange/
949 ],
950 [ "final of 32 consecutive non-character code points",
951 (isASCII) ? "\xef\xb7\xaf" : I8_to_native("\xf1\xbf\xaf\xaf"),
952 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
953 'nonchar', 0xFDEF,
954 (isASCII) ? 3 : 4,
955 qr/Unicode non-character.*is not recommended for open interchange/
956 ],
957 [ "non-character code point U+FFFE",
958 (isASCII) ? "\xef\xbf\xbe" : I8_to_native("\xf1\xbf\xbf\xbe"),
959 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
960 'nonchar', 0xFFFE,
961 (isASCII) ? 3 : 4,
962 qr/Unicode non-character.*is not recommended for open interchange/
963 ],
964 [ "non-character code point U+FFFF",
965 (isASCII) ? "\xef\xbf\xbf" : I8_to_native("\xf1\xbf\xbf\xbf"),
966 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
967 'nonchar', 0xFFFF,
968 (isASCII) ? 3 : 4,
969 qr/Unicode non-character.*is not recommended for open interchange/
970 ],
971 [ "non-character code point U+1FFFE",
972 (isASCII) ? "\xf0\x9f\xbf\xbe" : I8_to_native("\xf3\xbf\xbf\xbe"),
973 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
974 'nonchar', 0x1FFFE, 4,
975 qr/Unicode non-character.*is not recommended for open interchange/
976 ],
977 [ "non-character code point U+1FFFF",
978 (isASCII) ? "\xf0\x9f\xbf\xbf" : I8_to_native("\xf3\xbf\xbf\xbf"),
979 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
980 'nonchar', 0x1FFFF, 4,
981 qr/Unicode non-character.*is not recommended for open interchange/
982 ],
983 [ "non-character code point U+2FFFE",
984 (isASCII) ? "\xf0\xaf\xbf\xbe" : I8_to_native("\xf5\xbf\xbf\xbe"),
985 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
986 'nonchar', 0x2FFFE, 4,
987 qr/Unicode non-character.*is not recommended for open interchange/
988 ],
989 [ "non-character code point U+2FFFF",
990 (isASCII) ? "\xf0\xaf\xbf\xbf" : I8_to_native("\xf5\xbf\xbf\xbf"),
991 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
992 'nonchar', 0x2FFFF, 4,
993 qr/Unicode non-character.*is not recommended for open interchange/
994 ],
995 [ "non-character code point U+3FFFE",
996 (isASCII) ? "\xf0\xbf\xbf\xbe" : I8_to_native("\xf7\xbf\xbf\xbe"),
997 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
998 'nonchar', 0x3FFFE, 4,
999 qr/Unicode non-character.*is not recommended for open interchange/
1000 ],
1001 [ "non-character code point U+3FFFF",
1002 (isASCII) ? "\xf0\xbf\xbf\xbf" : I8_to_native("\xf7\xbf\xbf\xbf"),
1003 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1004 'nonchar', 0x3FFFF, 4,
1005 qr/Unicode non-character.*is not recommended for open interchange/
1006 ],
1007 [ "non-character code point U+4FFFE",
1008 (isASCII) ? "\xf1\x8f\xbf\xbe" : I8_to_native("\xf8\xa9\xbf\xbf\xbe"),
1009 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1010 'nonchar', 0x4FFFE,
1011 (isASCII) ? 4 : 5,
1012 qr/Unicode non-character.*is not recommended for open interchange/
1013 ],
1014 [ "non-character code point U+4FFFF",
1015 (isASCII) ? "\xf1\x8f\xbf\xbf" : I8_to_native("\xf8\xa9\xbf\xbf\xbf"),
1016 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1017 'nonchar', 0x4FFFF,
1018 (isASCII) ? 4 : 5,
1019 qr/Unicode non-character.*is not recommended for open interchange/
1020 ],
1021 [ "non-character code point U+5FFFE",
1022 (isASCII) ? "\xf1\x9f\xbf\xbe" : I8_to_native("\xf8\xab\xbf\xbf\xbe"),
1023 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1024 'nonchar', 0x5FFFE,
1025 (isASCII) ? 4 : 5,
1026 qr/Unicode non-character.*is not recommended for open interchange/
1027 ],
1028 [ "non-character code point U+5FFFF",
1029 (isASCII) ? "\xf1\x9f\xbf\xbf" : I8_to_native("\xf8\xab\xbf\xbf\xbf"),
1030 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1031 'nonchar', 0x5FFFF,
1032 (isASCII) ? 4 : 5,
1033 qr/Unicode non-character.*is not recommended for open interchange/
1034 ],
1035 [ "non-character code point U+6FFFE",
1036 (isASCII) ? "\xf1\xaf\xbf\xbe" : I8_to_native("\xf8\xad\xbf\xbf\xbe"),
1037 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1038 'nonchar', 0x6FFFE,
1039 (isASCII) ? 4 : 5,
1040 qr/Unicode non-character.*is not recommended for open interchange/
1041 ],
1042 [ "non-character code point U+6FFFF",
1043 (isASCII) ? "\xf1\xaf\xbf\xbf" : I8_to_native("\xf8\xad\xbf\xbf\xbf"),
1044 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1045 'nonchar', 0x6FFFF,
1046 (isASCII) ? 4 : 5,
1047 qr/Unicode non-character.*is not recommended for open interchange/
1048 ],
1049 [ "non-character code point U+7FFFE",
1050 (isASCII) ? "\xf1\xbf\xbf\xbe" : I8_to_native("\xf8\xaf\xbf\xbf\xbe"),
1051 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1052 'nonchar', 0x7FFFE,
1053 (isASCII) ? 4 : 5,
1054 qr/Unicode non-character.*is not recommended for open interchange/
1055 ],
1056 [ "non-character code point U+7FFFF",
1057 (isASCII) ? "\xf1\xbf\xbf\xbf" : I8_to_native("\xf8\xaf\xbf\xbf\xbf"),
1058 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1059 'nonchar', 0x7FFFF,
1060 (isASCII) ? 4 : 5,
1061 qr/Unicode non-character.*is not recommended for open interchange/
1062 ],
1063 [ "non-character code point U+8FFFE",
1064 (isASCII) ? "\xf2\x8f\xbf\xbe" : I8_to_native("\xf8\xb1\xbf\xbf\xbe"),
1065 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1066 'nonchar', 0x8FFFE,
1067 (isASCII) ? 4 : 5,
1068 qr/Unicode non-character.*is not recommended for open interchange/
1069 ],
1070 [ "non-character code point U+8FFFF",
1071 (isASCII) ? "\xf2\x8f\xbf\xbf" : I8_to_native("\xf8\xb1\xbf\xbf\xbf"),
1072 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1073 'nonchar', 0x8FFFF,
1074 (isASCII) ? 4 : 5,
1075 qr/Unicode non-character.*is not recommended for open interchange/
1076 ],
1077 [ "non-character code point U+9FFFE",
1078 (isASCII) ? "\xf2\x9f\xbf\xbe" : I8_to_native("\xf8\xb3\xbf\xbf\xbe"),
1079 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1080 'nonchar', 0x9FFFE,
1081 (isASCII) ? 4 : 5,
1082 qr/Unicode non-character.*is not recommended for open interchange/
1083 ],
1084 [ "non-character code point U+9FFFF",
1085 (isASCII) ? "\xf2\x9f\xbf\xbf" : I8_to_native("\xf8\xb3\xbf\xbf\xbf"),
1086 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1087 'nonchar', 0x9FFFF,
1088 (isASCII) ? 4 : 5,
1089 qr/Unicode non-character.*is not recommended for open interchange/
1090 ],
1091 [ "non-character code point U+AFFFE",
1092 (isASCII) ? "\xf2\xaf\xbf\xbe" : I8_to_native("\xf8\xb5\xbf\xbf\xbe"),
1093 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1094 'nonchar', 0xAFFFE,
1095 (isASCII) ? 4 : 5,
1096 qr/Unicode non-character.*is not recommended for open interchange/
1097 ],
1098 [ "non-character code point U+AFFFF",
1099 (isASCII) ? "\xf2\xaf\xbf\xbf" : I8_to_native("\xf8\xb5\xbf\xbf\xbf"),
1100 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1101 'nonchar', 0xAFFFF,
1102 (isASCII) ? 4 : 5,
1103 qr/Unicode non-character.*is not recommended for open interchange/
1104 ],
1105 [ "non-character code point U+BFFFE",
1106 (isASCII) ? "\xf2\xbf\xbf\xbe" : I8_to_native("\xf8\xb7\xbf\xbf\xbe"),
1107 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1108 'nonchar', 0xBFFFE,
1109 (isASCII) ? 4 : 5,
1110 qr/Unicode non-character.*is not recommended for open interchange/
1111 ],
1112 [ "non-character code point U+BFFFF",
1113 (isASCII) ? "\xf2\xbf\xbf\xbf" : I8_to_native("\xf8\xb7\xbf\xbf\xbf"),
1114 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1115 'nonchar', 0xBFFFF,
1116 (isASCII) ? 4 : 5,
1117 qr/Unicode non-character.*is not recommended for open interchange/
1118 ],
1119 [ "non-character code point U+CFFFE",
1120 (isASCII) ? "\xf3\x8f\xbf\xbe" : I8_to_native("\xf8\xb9\xbf\xbf\xbe"),
1121 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1122 'nonchar', 0xCFFFE,
1123 (isASCII) ? 4 : 5,
1124 qr/Unicode non-character.*is not recommended for open interchange/
1125 ],
1126 [ "non-character code point U+CFFFF",
1127 (isASCII) ? "\xf3\x8f\xbf\xbf" : I8_to_native("\xf8\xb9\xbf\xbf\xbf"),
1128 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1129 'nonchar', 0xCFFFF,
1130 (isASCII) ? 4 : 5,
1131 qr/Unicode non-character.*is not recommended for open interchange/
1132 ],
1133 [ "non-character code point U+DFFFE",
1134 (isASCII) ? "\xf3\x9f\xbf\xbe" : I8_to_native("\xf8\xbb\xbf\xbf\xbe"),
1135 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1136 'nonchar', 0xDFFFE,
1137 (isASCII) ? 4 : 5,
1138 qr/Unicode non-character.*is not recommended for open interchange/
1139 ],
1140 [ "non-character code point U+DFFFF",
1141 (isASCII) ? "\xf3\x9f\xbf\xbf" : I8_to_native("\xf8\xbb\xbf\xbf\xbf"),
1142 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1143 'nonchar', 0xDFFFF,
1144 (isASCII) ? 4 : 5,
1145 qr/Unicode non-character.*is not recommended for open interchange/
1146 ],
1147 [ "non-character code point U+EFFFE",
1148 (isASCII) ? "\xf3\xaf\xbf\xbe" : I8_to_native("\xf8\xbd\xbf\xbf\xbe"),
1149 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1150 'nonchar', 0xEFFFE,
1151 (isASCII) ? 4 : 5,
1152 qr/Unicode non-character.*is not recommended for open interchange/
1153 ],
1154 [ "non-character code point U+EFFFF",
1155 (isASCII) ? "\xf3\xaf\xbf\xbf" : I8_to_native("\xf8\xbd\xbf\xbf\xbf"),
1156 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1157 'nonchar', 0xEFFFF,
1158 (isASCII) ? 4 : 5,
1159 qr/Unicode non-character.*is not recommended for open interchange/
1160 ],
1161 [ "non-character code point U+FFFFE",
1162 (isASCII) ? "\xf3\xbf\xbf\xbe" : I8_to_native("\xf8\xbf\xbf\xbf\xbe"),
1163 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1164 'nonchar', 0xFFFFE,
1165 (isASCII) ? 4 : 5,
1166 qr/Unicode non-character.*is not recommended for open interchange/
1167 ],
1168 [ "non-character code point U+FFFFF",
1169 (isASCII) ? "\xf3\xbf\xbf\xbf" : I8_to_native("\xf8\xbf\xbf\xbf\xbf"),
1170 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1171 'nonchar', 0xFFFFF,
1172 (isASCII) ? 4 : 5,
1173 qr/Unicode non-character.*is not recommended for open interchange/
1174 ],
1175 [ "non-character code point U+10FFFE",
1176 (isASCII) ? "\xf4\x8f\xbf\xbe" : I8_to_native("\xf9\xa1\xbf\xbf\xbe"),
1177 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1178 'nonchar', 0x10FFFE,
1179 (isASCII) ? 4 : 5,
1180 qr/Unicode non-character.*is not recommended for open interchange/
eb83ed87 1181 ],
7dfd8446
KW
1182 [ "non-character code point U+10FFFF",
1183 (isASCII) ? "\xf4\x8f\xbf\xbf" : I8_to_native("\xf9\xa1\xbf\xbf\xbf"),
1184 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1185 'nonchar', 0x10FFFF,
1186 (isASCII) ? 4 : 5,
ba707cdc 1187 qr/Unicode non-character.*is not recommended for open interchange/
eb83ed87 1188 ],
1d1c12d9 1189 [ "requires at least 32 bits",
c0236afe
KW
1190 (isASCII)
1191 ? "\xfe\x82\x80\x80\x80\x80\x80"
1192 : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa2\xa0\xa0\xa0\xa0\xa0\xa0"),
eb83ed87 1193 # This code point is chosen so that it is representable in a UV on
2f8f112e 1194 # 32-bit machines
1d1c12d9 1195 $UTF8_WARN_ABOVE_31_BIT, $UTF8_DISALLOW_ABOVE_31_BIT,
c0236afe 1196 'utf8', 0x80000000, (isASCII) ? 7 :14,
7dfd8446
KW
1197 qr/Code point 0x80000000 is not Unicode, and not portable/
1198 ],
1d1c12d9 1199 [ "requires at least 32 bits, and use SUPER-type flags, instead of ABOVE_31_BIT",
c0236afe
KW
1200 (isASCII)
1201 ? "\xfe\x82\x80\x80\x80\x80\x80"
1202 : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa2\xa0\xa0\xa0\xa0\xa0\xa0"),
7dfd8446 1203 $UTF8_WARN_SUPER, $UTF8_DISALLOW_SUPER,
c0236afe 1204 'utf8', 0x80000000, (isASCII) ? 7 :14,
ea5ced44 1205 qr/Code point 0x80000000 is not Unicode, and not portable/
eb83ed87 1206 ],
1d1c12d9
KW
1207 [ "overflow with warnings/disallow for more than 31 bits",
1208 # This tests the interaction of WARN_ABOVE_31_BIT/DISALLOW_ABOVE_31_BIT
1209 # with overflow. The overflow malformation is never allowed, so
1210 # preventing it takes precedence if the ABOVE_31_BIT options would
c0236afe 1211 # otherwise allow in an overflowing value. The ASCII code points (1
1d1c12d9
KW
1212 # for 32-bits; 1 for 64) were chosen because the old overflow
1213 # detection algorithm did not catch them; this means this test also
c0236afe
KW
1214 # checks for that fix. The EBCDIC are arbitrary overflowing ones
1215 # since we have no reports of failures with it.
1216 (($is64bit)
1217 ? ((isASCII)
9d2d0ecd 1218 ? "\xff\x80\x90\x90\x90\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf"
c0236afe
KW
1219 : I8_to_native("\xff\xB0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"))
1220 : ((isASCII)
9d2d0ecd 1221 ? "\xfe\x86\x80\x80\x80\x80\x80"
c0236afe 1222 : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa4\xa0\xa0\xa0\xa0\xa0\xa0"))),
ea5ced44 1223
1d1c12d9
KW
1224 # We include both warning categories to make sure the ABOVE_31_BIT one
1225 # has precedence
1226 "$UTF8_WARN_ABOVE_31_BIT|$UTF8_WARN_SUPER",
1227 "$UTF8_DISALLOW_ABOVE_31_BIT",
7dfd8446 1228 'utf8', 0,
c0236afe 1229 (! isASCII) ? 14 : ($is64bit) ? 13 : 7,
ea5ced44 1230 qr/overflow at byte .*, after start byte 0xf/
eb83ed87 1231 ],
c0236afe 1232);
2f8f112e 1233
c0236afe
KW
1234if ($is64bit) {
1235 no warnings qw{portable overflow};
2f8f112e 1236 push @tests,
c0236afe
KW
1237 [ "More than 32 bits",
1238 (isASCII)
9d2d0ecd 1239 ? "\xff\x80\x80\x80\x80\x80\x81\x80\x80\x80\x80\x80\x80"
c0236afe 1240 : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa2\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
1d1c12d9 1241 $UTF8_WARN_ABOVE_31_BIT, $UTF8_DISALLOW_ABOVE_31_BIT,
c0236afe 1242 'utf8', 0x1000000000, (isASCII) ? 13 : 14,
ea5ced44 1243 qr/Code point 0x.* is not Unicode, and not portable/
2f8f112e 1244 ];
83dc0f42
KW
1245 if (! isASCII) {
1246 push @tests, # These could falsely show wrongly in a naive implementation
1247 [ "requires at least 32 bits",
1248 I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa1\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
1249 $UTF8_WARN_ABOVE_31_BIT,$UTF8_DISALLOW_ABOVE_31_BIT,
1250 'utf8', 0x800000000, 14,
1251 qr/Code point 0x800000000 is not Unicode, and not portable/
1252 ],
1253 [ "requires at least 32 bits",
1254 I8_to_native("\xff\xa0\xa0\xa0\xa0\xa1\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
1255 $UTF8_WARN_ABOVE_31_BIT,$UTF8_DISALLOW_ABOVE_31_BIT,
1256 'utf8', 0x10000000000, 14,
1257 qr/Code point 0x10000000000 is not Unicode, and not portable/
1258 ],
1259 [ "requires at least 32 bits",
1260 I8_to_native("\xff\xa0\xa0\xa0\xa1\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
1261 $UTF8_WARN_ABOVE_31_BIT,$UTF8_DISALLOW_ABOVE_31_BIT,
1262 'utf8', 0x200000000000, 14,
1263 qr/Code point 0x200000000000 is not Unicode, and not portable/
1264 ],
1265 [ "requires at least 32 bits",
1266 I8_to_native("\xff\xa0\xa0\xa1\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
1267 $UTF8_WARN_ABOVE_31_BIT,$UTF8_DISALLOW_ABOVE_31_BIT,
1268 'utf8', 0x4000000000000, 14,
1269 qr/Code point 0x4000000000000 is not Unicode, and not portable/
1270 ],
1271 [ "requires at least 32 bits",
1272 I8_to_native("\xff\xa0\xa1\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
1273 $UTF8_WARN_ABOVE_31_BIT,$UTF8_DISALLOW_ABOVE_31_BIT,
1274 'utf8', 0x80000000000000, 14,
1275 qr/Code point 0x80000000000000 is not Unicode, and not portable/
1276 ],
1277 [ "requires at least 32 bits",
1278 I8_to_native("\xff\xa1\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
1279 $UTF8_WARN_ABOVE_31_BIT,$UTF8_DISALLOW_ABOVE_31_BIT,
1280 'utf8', 0x1000000000000000, 14,
1281 qr/Code point 0x1000000000000000 is not Unicode, and not portable/
1282 ];
1283 }
2f8f112e
KW
1284}
1285
1286foreach my $test (@tests) {
eb83ed87
KW
1287 my ($testname, $bytes, $warn_flags, $disallow_flags, $category, $allowed_uv, $expected_len, $message ) = @$test;
1288
1289 my $length = length $bytes;
2f8f112e 1290 my $will_overflow = $testname =~ /overflow/;
eb83ed87 1291
d7874298
KW
1292 {
1293 use warnings;
1294 undef @warnings;
1295 my $ret = test_isUTF8_CHAR($bytes, $length);
1296 if ($will_overflow) {
1297 is($ret, 0, "isUTF8_CHAR() $testname: returns 0");
1298 }
1299 else {
1300 is($ret, $length,
1301 "isUTF8_CHAR() $testname: returns expected length: $length");
1302 }
1303 unless (is(scalar @warnings, 0,
1304 "isUTF8_CHAR() $testname: generated no warnings"))
1305 {
1306 diag "The warnings were: " . join(", ", @warnings);
1307 }
3d56ecbe 1308
e23e8bc1
KW
1309 undef @warnings;
1310 $ret = test_isSTRICT_UTF8_CHAR($bytes, $length);
1311 if ($will_overflow) {
1312 is($ret, 0, "isSTRICT_UTF8_CHAR() $testname: returns 0");
1313 }
1314 else {
1315 my $expected_ret = ( $testname =~ /surrogate|non-character/
1316 || $allowed_uv > 0x10FFFF)
1317 ? 0
1318 : $length;
1319 is($ret, $expected_ret,
1320 "isSTRICT_UTF8_CHAR() $testname: returns expected length: $expected_ret");
1321 }
1322 unless (is(scalar @warnings, 0,
1323 "isSTRICT_UTF8_CHAR() $testname: generated no warnings"))
1324 {
1325 diag "The warnings were: " . join(", ", @warnings);
1326 }
1327
a82be82b
KW
1328 undef @warnings;
1329 $ret = test_isC9_STRICT_UTF8_CHAR($bytes, $length);
1330 if ($will_overflow) {
1331 is($ret, 0, "isC9_STRICT_UTF8_CHAR() $testname: returns 0");
1332 }
1333 else {
1334 my $expected_ret = ( $testname =~ /surrogate/
1335 || $allowed_uv > 0x10FFFF)
1336 ? 0
1337 : $length;
1338 is($ret, $expected_ret,
1339 "isC9_STRICT_UTF8_CHAR() $testname: returns expected length: $expected_ret");
1340 }
1341 unless (is(scalar @warnings, 0,
1342 "isC9_STRICT_UTF8_CHAR() $testname: generated no warnings"))
1343 {
1344 diag "The warnings were: " . join(", ", @warnings);
1345 }
1346
3d56ecbe
KW
1347 # Test partial character handling, for each byte not a full character
1348 for my $j (1.. $length - 1) {
1349
1350 # Skip the test for the interaction between overflow and above-31
1351 # bit. It is really testing other things than the partial
1352 # character tests, for which other tests in this file are
1353 # sufficient
1354 last if $testname =~ /overflow/;
1355
1356 foreach my $disallow_flag (0, $disallow_flags) {
1357 my $partial = substr($bytes, 0, $j);
1358 my $ret_should_be;
1359 my $comment;
1360 if ($disallow_flag) {
1361 $ret_should_be = 0;
1362 $comment = "disallowed";
1363 }
1364 else {
1365 $ret_should_be = 1;
1366 $comment = "allowed";
1367 }
1368
1369 if ($disallow_flag) {
1370 if ($testname =~ /non-character/) {
1371 $ret_should_be = 1;
1372 $comment .= ", but but need full char to discern";
1373 }
1374 elsif ($testname =~ /surrogate/) {
1375 if ($j < 2) {
1376 $ret_should_be = 1;
1377 $comment .= ", but need 2 bytes to discern";
1378 }
1379 }
1380 elsif ($testname =~ /first non_unicode/ && $j < 2) {
1381 $ret_should_be = 1;
1382 $comment .= ", but need 2 bytes to discern";
1383 }
1384 }
1385
1386 undef @warnings;
1387
1388 $ret = test_is_utf8_valid_partial_char_flags($partial, $j, $disallow_flag);
1389 is($ret, $ret_should_be, "$testname: is_utf8_valid_partial_char_flags("
1390 . display_bytes($partial)
1391 . "), $comment: returns $ret_should_be");
1392 unless (is(scalar @warnings, 0,
1393 "$testname: is_utf8_valid_partial_char_flags() generated no warnings"))
1394 {
1395 diag "The warnings were: " . join(", ", @warnings);
1396 }
1397 }
1398 }
d7874298
KW
1399 }
1400
eb83ed87
KW
1401 # This is more complicated than the malformations tested earlier, as there
1402 # are several orthogonal variables involved. We test all the subclasses
1403 # of utf8 warnings to verify they work with and without the utf8 class,
1404 # and don't have effects on other sublass warnings
54f4afef 1405 foreach my $warning ('utf8', 'surrogate', 'nonchar', 'non_unicode') {
eb83ed87
KW
1406 foreach my $warn_flag (0, $warn_flags) {
1407 foreach my $disallow_flag (0, $disallow_flags) {
54f4afef 1408 foreach my $do_warning (0, 1) {
eb83ed87 1409
13d7a909
KW
1410 my $eval_warn = $do_warning
1411 ? "use warnings '$warning'"
1412 : $warning eq "utf8"
7dfd8446
KW
1413 ? "no warnings 'utf8'"
1414 : "use warnings 'utf8'; no warnings '$warning'";
2f8f112e 1415
13d7a909
KW
1416 # is effectively disallowed if will overflow, even if the
1417 # flag indicates it is allowed, fix up test name to
1418 # indicate this as well
1419 my $disallowed = $disallow_flag || $will_overflow;
2f8f112e 1420
046d01eb 1421 my $this_name = "utf8n_to_uvchr() $testname: " . (($disallow_flag)
13d7a909
KW
1422 ? 'disallowed'
1423 : ($disallowed)
1d1c12d9 1424 ? 'ABOVE_31_BIT allowed'
13d7a909
KW
1425 : 'allowed');
1426 $this_name .= ", $eval_warn";
1427 $this_name .= ", " . (($warn_flag)
1428 ? 'with warning flag'
1429 : 'no warning flag');
eb83ed87 1430
13d7a909
KW
1431 undef @warnings;
1432 my $ret_ref;
7dfd8446
KW
1433 my $display_bytes = display_bytes($bytes);
1434 my $call = "Call was: $eval_warn; \$ret_ref = test_utf8n_to_uvchr('$display_bytes', $length, $warn_flag|$disallow_flag)";
1435 my $eval_text = "$eval_warn; \$ret_ref = test_utf8n_to_uvchr('$bytes', $length, $warn_flag|$disallow_flag)";
13d7a909
KW
1436 eval "$eval_text";
1437 if (! ok ("$@ eq ''", "$this_name: eval succeeded")) {
7dfd8446 1438 diag "\$!='$!'; eval'd=\"$call\"";
13d7a909 1439 next;
54f4afef 1440 }
13d7a909 1441 if ($disallowed) {
7dfd8446
KW
1442 unless (is($ret_ref->[0], 0, "$this_name: Returns 0"))
1443 {
1444 diag $call;
1445 }
2f8f112e
KW
1446 }
1447 else {
7dfd8446 1448 unless (is($ret_ref->[0], $allowed_uv,
9d2d0ecd
KW
1449 "$this_name: Returns expected uv: "
1450 . sprintf("0x%04X", $allowed_uv)))
7dfd8446
KW
1451 {
1452 diag $call;
1453 }
1454 }
1455 unless (is($ret_ref->[1], $expected_len,
9d2d0ecd 1456 "$this_name: Returns expected length: $expected_len"))
7dfd8446
KW
1457 {
1458 diag $call;
13d7a909 1459 }
13d7a909
KW
1460
1461 if (! $do_warning
1462 && ($warning eq 'utf8' || $warning eq $category))
1463 {
1464 if (!is(scalar @warnings, 0,
1465 "$this_name: No warnings generated"))
1466 {
7dfd8446
KW
1467 diag $call;
1468 diag "The warnings were: " . join(", ", @warnings);
2f8f112e
KW
1469 }
1470 }
13d7a909
KW
1471 elsif ($will_overflow
1472 && ! $disallow_flag
1473 && $warning eq 'utf8')
1474 {
1475
1476 # Will get the overflow message instead of the expected
1477 # message under these circumstances, as they would
1478 # otherwise accept an overflowed value, which the code
1479 # should not allow, so falls back to overflow.
1480 if (is(scalar @warnings, 1,
1481 "$this_name: Got a single warning "))
1482 {
7dfd8446
KW
1483 unless (like($warnings[0], qr/overflow/,
1484 "$this_name: Got overflow warning"))
1485 {
1486 diag $call;
1487 }
13d7a909
KW
1488 }
1489 else {
7dfd8446 1490 diag $call;
13d7a909 1491 if (scalar @warnings) {
7dfd8446 1492 diag "The warnings were: "
13d7a909
KW
1493 . join(", ", @warnings);
1494 }
1495 }
eb83ed87 1496 }
13d7a909
KW
1497 elsif ($warn_flag
1498 && ($warning eq 'utf8' || $warning eq $category))
1499 {
1500 if (is(scalar @warnings, 1,
1501 "$this_name: Got a single warning "))
1502 {
7dfd8446
KW
1503 unless (like($warnings[0], $message,
1504 "$this_name: Got expected warning"))
1505 {
1506 diag $call;
1507 }
13d7a909
KW
1508 }
1509 else {
7dfd8446 1510 diag $call;
13d7a909 1511 if (scalar @warnings) {
7dfd8446 1512 diag "The warnings were: "
13d7a909
KW
1513 . join(", ", @warnings);
1514 }
eb83ed87
KW
1515 }
1516 }
eb83ed87 1517
13d7a909
KW
1518 # Check CHECK_ONLY results when the input is disallowed. Do
1519 # this when actually disallowed, not just when the
1520 # $disallow_flag is set
1521 if ($disallowed) {
1522 undef @warnings;
1523 $ret_ref = test_utf8n_to_uvchr($bytes, $length,
1524 $disallow_flag|$UTF8_CHECK_ONLY);
7dfd8446
KW
1525 unless (is($ret_ref->[0], 0, "$this_name, CHECK_ONLY: Returns 0")) {
1526 diag $call;
1527 }
1528 unless (is($ret_ref->[1], -1,
9d2d0ecd 1529 "$this_name: CHECK_ONLY: returns -1 for length"))
7dfd8446
KW
1530 {
1531 diag $call;
1532 }
13d7a909
KW
1533 if (! is(scalar @warnings, 0,
1534 "$this_name, CHECK_ONLY: no warnings generated"))
1535 {
7dfd8446
KW
1536 diag $call;
1537 diag "The warnings were: " . join(", ", @warnings);
13d7a909 1538 }
eb83ed87 1539 }
046d01eb
KW
1540
1541 # Now repeat some of the above, but for
1542 # uvchr_to_utf8_flags(). Since this comes from an
1543 # existing code point, it hasn't overflowed.
1544 next if $will_overflow;
1545
1546 # The warning and disallow flags passed in are for
1547 # utf8n_to_uvchr(). Convert them for
1548 # uvchr_to_utf8_flags().
1549 my $uvchr_warn_flag = 0;
1550 my $uvchr_disallow_flag = 0;
1551 if ($warn_flag) {
1552 if ($warn_flag == $UTF8_WARN_SURROGATE) {
1553 $uvchr_warn_flag = $UNICODE_WARN_SURROGATE
1554 }
1555 elsif ($warn_flag == $UTF8_WARN_NONCHAR) {
1556 $uvchr_warn_flag = $UNICODE_WARN_NONCHAR
1557 }
1558 elsif ($warn_flag == $UTF8_WARN_SUPER) {
1559 $uvchr_warn_flag = $UNICODE_WARN_SUPER
1560 }
1d1c12d9 1561 elsif ($warn_flag == $UTF8_WARN_ABOVE_31_BIT) {
046d01eb
KW
1562 $uvchr_warn_flag = $UNICODE_WARN_ABOVE_31_BIT;
1563 }
1564 else {
1565 fail(sprintf "Unexpected warn flag: %x",
1566 $warn_flag);
1567 next;
1568 }
1569 }
1570 if ($disallow_flag) {
1571 if ($disallow_flag == $UTF8_DISALLOW_SURROGATE) {
1572 $uvchr_disallow_flag = $UNICODE_DISALLOW_SURROGATE
1573 }
1574 elsif ($disallow_flag == $UTF8_DISALLOW_NONCHAR) {
1575 $uvchr_disallow_flag = $UNICODE_DISALLOW_NONCHAR
1576 }
1577 elsif ($disallow_flag == $UTF8_DISALLOW_SUPER) {
1578 $uvchr_disallow_flag = $UNICODE_DISALLOW_SUPER
1579 }
1d1c12d9 1580 elsif ($disallow_flag == $UTF8_DISALLOW_ABOVE_31_BIT) {
046d01eb
KW
1581 $uvchr_disallow_flag =
1582 $UNICODE_DISALLOW_ABOVE_31_BIT;
1583 }
1584 else {
1585 fail(sprintf "Unexpected disallow flag: %x",
1586 $disallow_flag);
1587 next;
1588 }
1589 }
1590
1591 $disallowed = $uvchr_disallow_flag;
1592
1593 $this_name = "uvchr_to_utf8_flags() $testname: "
1594 . (($uvchr_disallow_flag)
1595 ? 'disallowed'
1596 : ($disallowed)
1597 ? 'ABOVE_31_BIT allowed'
1598 : 'allowed');
1599 $this_name .= ", $eval_warn";
1600 $this_name .= ", " . (($uvchr_warn_flag)
1601 ? 'with warning flag'
1602 : 'no warning flag');
1603
1604 undef @warnings;
1605 my $ret;
1606 my $warn_flag = sprintf "0x%x", $uvchr_warn_flag;
1607 my $disallow_flag = sprintf "0x%x", $uvchr_disallow_flag;
1608 $call = sprintf "call was: $eval_warn; \$ret = test_uvchr_to_utf8_flags(0x%x, $warn_flag|$disallow_flag)", $allowed_uv;
1609 $eval_text = "$eval_warn; \$ret = test_uvchr_to_utf8_flags($allowed_uv, $warn_flag|$disallow_flag)";
1610 eval "$eval_text";
1611 if (! ok ("$@ eq ''", "$this_name: eval succeeded")) {
1612 diag "\$!='$!'; eval'd=\"$eval_text\"";
1613 next;
1614 }
1615 if ($disallowed) {
1616 unless (is($ret, undef, "$this_name: Returns undef")) {
1617 diag $call;
1618 }
1619 }
1620 else {
1621 unless (is($ret, $bytes, "$this_name: Returns expected string")) {
1622 diag $call;
1623 }
1624 }
1625 if (! $do_warning
1626 && ($warning eq 'utf8' || $warning eq $category))
1627 {
1628 if (!is(scalar @warnings, 0,
1629 "$this_name: No warnings generated"))
1630 {
1631 diag $call;
1632 diag "The warnings were: " . join(", ", @warnings);
1633 }
1634 }
1635 elsif ($uvchr_warn_flag
1636 && ($warning eq 'utf8' || $warning eq $category))
1637 {
1638 if (is(scalar @warnings, 1,
1639 "$this_name: Got a single warning "))
1640 {
046d01eb
KW
1641 unless (like($warnings[0], $message,
1642 "$this_name: Got expected warning"))
1643 {
1644 diag $call;
1645 }
046d01eb
KW
1646 }
1647 else {
1648 diag $call;
1649 if (scalar @warnings) {
1650 diag "The warnings were: "
1651 . join(", ", @warnings);
1652 }
1653 }
1654 }
eb83ed87
KW
1655 }
1656 }
1657 }
1658 }
1659}
6e3d6c02 1660
fed3ba5d 1661done_testing;