This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
APItest/t/utf8.t: Fix test name
[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 10use XS::APItest;
f9380377 11use Data::Dumper;
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
d84e92aa
KW
24sub output_warnings(@) {
25 diag "The warnings were:\n" . join("", @_);
26}
27
7dfd8446
KW
28# This test file can't use byte_utf8a_to_utf8n() from t/charset_tools.pl
29# because that uses the same functions we are testing here. So UTF-EBCDIC
30# strings are hard-coded as I8 strings in this file instead, and we use array
31# lookup to translate into the appropriate code page.
32
33my @i8_to_native = ( # Only code page 1047 so far.
34# _0 _1 _2 _3 _4 _5 _6 _7 _8 _9 _A _B _C _D _E _F
350x00,0x01,0x02,0x03,0x37,0x2D,0x2E,0x2F,0x16,0x05,0x15,0x0B,0x0C,0x0D,0x0E,0x0F,
360x10,0x11,0x12,0x13,0x3C,0x3D,0x32,0x26,0x18,0x19,0x3F,0x27,0x1C,0x1D,0x1E,0x1F,
370x40,0x5A,0x7F,0x7B,0x5B,0x6C,0x50,0x7D,0x4D,0x5D,0x5C,0x4E,0x6B,0x60,0x4B,0x61,
380xF0,0xF1,0xF2,0xF3,0xF4,0xF5,0xF6,0xF7,0xF8,0xF9,0x7A,0x5E,0x4C,0x7E,0x6E,0x6F,
390x7C,0xC1,0xC2,0xC3,0xC4,0xC5,0xC6,0xC7,0xC8,0xC9,0xD1,0xD2,0xD3,0xD4,0xD5,0xD6,
400xD7,0xD8,0xD9,0xE2,0xE3,0xE4,0xE5,0xE6,0xE7,0xE8,0xE9,0xAD,0xE0,0xBD,0x5F,0x6D,
410x79,0x81,0x82,0x83,0x84,0x85,0x86,0x87,0x88,0x89,0x91,0x92,0x93,0x94,0x95,0x96,
420x97,0x98,0x99,0xA2,0xA3,0xA4,0xA5,0xA6,0xA7,0xA8,0xA9,0xC0,0x4F,0xD0,0xA1,0x07,
430x20,0x21,0x22,0x23,0x24,0x25,0x06,0x17,0x28,0x29,0x2A,0x2B,0x2C,0x09,0x0A,0x1B,
440x30,0x31,0x1A,0x33,0x34,0x35,0x36,0x08,0x38,0x39,0x3A,0x3B,0x04,0x14,0x3E,0xFF,
450x41,0x42,0x43,0x44,0x45,0x46,0x47,0x48,0x49,0x4A,0x51,0x52,0x53,0x54,0x55,0x56,
460x57,0x58,0x59,0x62,0x63,0x64,0x65,0x66,0x67,0x68,0x69,0x6A,0x70,0x71,0x72,0x73,
470x74,0x75,0x76,0x77,0x78,0x80,0x8A,0x8B,0x8C,0x8D,0x8E,0x8F,0x90,0x9A,0x9B,0x9C,
480x9D,0x9E,0x9F,0xA0,0xAA,0xAB,0xAC,0xAE,0xAF,0xB0,0xB1,0xB2,0xB3,0xB4,0xB5,0xB6,
490xB7,0xB8,0xB9,0xBA,0xBB,0xBC,0xBE,0xBF,0xCA,0xCB,0xCC,0xCD,0xCE,0xCF,0xDA,0xDB,
500xDC,0xDD,0xDE,0xDF,0xE1,0xEA,0xEB,0xEC,0xED,0xEE,0xEF,0xFA,0xFB,0xFC,0xFD,0xFE,
51);
52
418080dc
KW
53my @native_to_i8;
54for (my $i = 0; $i < 256; $i++) {
55 $native_to_i8[$i8_to_native[$i]] = $i;
56}
57
7dfd8446 58*I8_to_native = (isASCII)
2956ebbf
KW
59 ? sub { return shift }
60 : sub { return join "", map { chr $i8_to_native[ord $_] }
7dfd8446 61 split "", shift };
418080dc 62*native_to_I8 = (isASCII)
2956ebbf
KW
63 ? sub { return shift }
64 : sub { return join "", map { chr $native_to_i8[ord $_] }
418080dc 65 split "", shift };
2b5e7bc2
KW
66sub start_byte_to_cont($) {
67
68 # Extract the code point information from the input UTF-8 start byte, and
69 # return a continuation byte containing the same information. This is
70 # used in constructing an overlong malformation from valid input.
71
72 my $byte = shift;
73 my $len = test_UTF8_SKIP($byte);
74 if ($len < 2) {
921139af 75 die "start_byte_to_cont() is expecting a UTF-8 variant";
2b5e7bc2
KW
76 }
77
78 $byte = ord native_to_I8($byte);
79
80 # Copied from utf8.h. This gets rid of the leading 1 bits.
81 $byte &= ((($len) >= 7) ? 0x00 : (0x1F >> (($len)-2)));
82
8182a17b
KW
83 $byte |= (isASCII) ? 0x80 : 0xA0;
84 return I8_to_native(chr $byte);
2b5e7bc2 85}
7dfd8446
KW
86
87my $is64bit = length sprintf("%x", ~0) > 8;
88
89
f9380377
KW
90# Test utf8n_to_uvchr_error(). These provide essentially complete code
91# coverage. Copied from utf8.h
7dfd8446 92my $UTF8_ALLOW_EMPTY = 0x0001;
f9380377 93my $UTF8_GOT_EMPTY = $UTF8_ALLOW_EMPTY;
7dfd8446 94my $UTF8_ALLOW_CONTINUATION = 0x0002;
f9380377 95my $UTF8_GOT_CONTINUATION = $UTF8_ALLOW_CONTINUATION;
7dfd8446 96my $UTF8_ALLOW_NON_CONTINUATION = 0x0004;
f9380377 97my $UTF8_GOT_NON_CONTINUATION = $UTF8_ALLOW_NON_CONTINUATION;
7dfd8446 98my $UTF8_ALLOW_SHORT = 0x0008;
f9380377 99my $UTF8_GOT_SHORT = $UTF8_ALLOW_SHORT;
7dfd8446 100my $UTF8_ALLOW_LONG = 0x0010;
f9380377
KW
101my $UTF8_GOT_LONG = $UTF8_ALLOW_LONG;
102my $UTF8_GOT_OVERFLOW = 0x0020;
6f89c5a0 103my $UTF8_DISALLOW_SURROGATE = 0x0040;
f9380377 104my $UTF8_GOT_SURROGATE = $UTF8_DISALLOW_SURROGATE;
6f89c5a0
KW
105my $UTF8_WARN_SURROGATE = 0x0080;
106my $UTF8_DISALLOW_NONCHAR = 0x0100;
f9380377 107my $UTF8_GOT_NONCHAR = $UTF8_DISALLOW_NONCHAR;
6f89c5a0
KW
108my $UTF8_WARN_NONCHAR = 0x0200;
109my $UTF8_DISALLOW_SUPER = 0x0400;
f9380377 110my $UTF8_GOT_SUPER = $UTF8_DISALLOW_SUPER;
6f89c5a0
KW
111my $UTF8_WARN_SUPER = 0x0800;
112my $UTF8_DISALLOW_ABOVE_31_BIT = 0x1000;
f9380377 113my $UTF8_GOT_ABOVE_31_BIT = $UTF8_DISALLOW_ABOVE_31_BIT;
6f89c5a0
KW
114my $UTF8_WARN_ABOVE_31_BIT = 0x2000;
115my $UTF8_CHECK_ONLY = 0x4000;
25e3a4e0
KW
116my $UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE
117 = $UTF8_DISALLOW_SUPER|$UTF8_DISALLOW_SURROGATE;
118my $UTF8_DISALLOW_ILLEGAL_INTERCHANGE
119 = $UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE|$UTF8_DISALLOW_NONCHAR;
867a901b
KW
120my $UTF8_WARN_ILLEGAL_C9_INTERCHANGE
121 = $UTF8_WARN_SUPER|$UTF8_WARN_SURROGATE;
122my $UTF8_WARN_ILLEGAL_INTERCHANGE
123 = $UTF8_WARN_ILLEGAL_C9_INTERCHANGE|$UTF8_WARN_NONCHAR;
7dfd8446 124
046d01eb
KW
125# Test uvchr_to_utf8().
126my $UNICODE_WARN_SURROGATE = 0x0001;
127my $UNICODE_WARN_NONCHAR = 0x0002;
128my $UNICODE_WARN_SUPER = 0x0004;
129my $UNICODE_WARN_ABOVE_31_BIT = 0x0008;
130my $UNICODE_DISALLOW_SURROGATE = 0x0010;
131my $UNICODE_DISALLOW_NONCHAR = 0x0020;
132my $UNICODE_DISALLOW_SUPER = 0x0040;
133my $UNICODE_DISALLOW_ABOVE_31_BIT = 0x0080;
134
135my $look_for_everything_utf8n_to
136 = $UTF8_DISALLOW_SURROGATE
7dfd8446
KW
137 | $UTF8_WARN_SURROGATE
138 | $UTF8_DISALLOW_NONCHAR
139 | $UTF8_WARN_NONCHAR
140 | $UTF8_DISALLOW_SUPER
141 | $UTF8_WARN_SUPER
1d1c12d9
KW
142 | $UTF8_DISALLOW_ABOVE_31_BIT
143 | $UTF8_WARN_ABOVE_31_BIT;
046d01eb
KW
144my $look_for_everything_uvchr_to
145 = $UNICODE_DISALLOW_SURROGATE
146 | $UNICODE_WARN_SURROGATE
147 | $UNICODE_DISALLOW_NONCHAR
148 | $UNICODE_WARN_NONCHAR
149 | $UNICODE_DISALLOW_SUPER
150 | $UNICODE_WARN_SUPER
151 | $UNICODE_DISALLOW_ABOVE_31_BIT
152 | $UNICODE_WARN_ABOVE_31_BIT;
7dfd8446 153
fed3ba5d
NC
154foreach ([0, '', '', 'empty'],
155 [0, 'N', 'N', '1 char'],
156 [1, 'NN', 'N', '1 char substring'],
157 [-2, 'Perl', 'Rules', 'different'],
4deba822 158 [0, $pound_sign, $pound_sign, 'pound sign'],
2956ebbf
KW
159 [1, $pound_sign . 10, $pound_sign . 1,
160 '10 pounds is more than 1 pound'],
161 [1, $pound_sign . $pound_sign, $pound_sign,
162 '2 pound signs are more than 1'],
fed3ba5d
NC
163 [-2, ' $!', " \x{1F42B}!", 'Camels are worth more than 1 dollar'],
164 [-1, '!', "!\x{1F42A}", 'Initial substrings match'],
165 ) {
166 my ($expect, $left, $right, $desc) = @$_;
167 my $copy = $right;
168 utf8::encode($copy);
169 is(bytes_cmp_utf8($left, $copy), $expect, $desc);
170 next if $right =~ tr/\0-\377//c;
171 utf8::encode($left);
172 is(bytes_cmp_utf8($right, $left), -$expect, "$desc reversed");
173}
174
7dfd8446
KW
175# The keys to this hash are Unicode code points, their values are the native
176# UTF-8 representations of them. The code points are chosen because they are
177# "interesting" on either or both ASCII and EBCDIC platforms. First we add
178# boundaries where the number of bytes required to represent them increase, or
179# are adjacent to problematic code points, so we want to make sure they aren't
180# considered problematic.
181my %code_points = (
182 0x0100 => (isASCII) ? "\xc4\x80" : I8_to_native("\xc8\xa0"),
183 0x0400 - 1 => (isASCII) ? "\xcf\xbf" : I8_to_native("\xdf\xbf"),
184 0x0400 => (isASCII) ? "\xd0\x80" : I8_to_native("\xe1\xa0\xa0"),
185 0x0800 - 1 => (isASCII) ? "\xdf\xbf" : I8_to_native("\xe1\xbf\xbf"),
186 0x0800 => (isASCII) ? "\xe0\xa0\x80" : I8_to_native("\xe2\xa0\xa0"),
187 0x4000 - 1 => (isASCII) ? "\xe3\xbf\xbf" : I8_to_native("\xef\xbf\xbf"),
188 0x4000 => (isASCII) ? "\xe4\x80\x80" : I8_to_native("\xf0\xb0\xa0\xa0"),
189 0x8000 - 1 => (isASCII) ? "\xe7\xbf\xbf" : I8_to_native("\xf0\xbf\xbf\xbf"),
190
191 # First code point that the implementation of isUTF8_POSSIBLY_PROBLEMATIC,
192 # as of this writing, considers potentially problematic on EBCDIC
193 0x8000 => (isASCII) ? "\xe8\x80\x80" : I8_to_native("\xf1\xa0\xa0\xa0"),
194
195 0xD000 - 1 => (isASCII) ? "\xec\xbf\xbf" : I8_to_native("\xf1\xb3\xbf\xbf"),
196
197 # First code point that the implementation of isUTF8_POSSIBLY_PROBLEMATIC,
198 # as of this writing, considers potentially problematic on ASCII
199 0xD000 => (isASCII) ? "\xed\x80\x80" : I8_to_native("\xf1\xb4\xa0\xa0"),
200
5f8a3d1d 201 # Bracket the surrogates, and include several surrogates
2956ebbf
KW
202 0xD7FF => (isASCII) ? "\xed\x9f\xbf" : I8_to_native("\xf1\xb5\xbf\xbf"),
203 0xD800 => (isASCII) ? "\xed\xa0\x80" : I8_to_native("\xf1\xb6\xa0\xa0"),
204 0xDC00 => (isASCII) ? "\xed\xb0\x80" : I8_to_native("\xf1\xb7\xa0\xa0"),
205 0xDFFF => (isASCII) ? "\xee\x80\x80" : I8_to_native("\xf1\xb8\xa0\xa0"),
206 0xDFFF => (isASCII) ? "\xed\xbf\xbf" : I8_to_native("\xf1\xb7\xbf\xbf"),
207 0xE000 => (isASCII) ? "\xee\x80\x80" : I8_to_native("\xf1\xb8\xa0\xa0"),
7dfd8446 208
5f8a3d1d 209 # Include the 32 contiguous non characters, and surrounding code points
2956ebbf
KW
210 0xFDCF => (isASCII) ? "\xef\xb7\x8f" : I8_to_native("\xf1\xbf\xae\xaf"),
211 0xFDD0 => (isASCII) ? "\xef\xb7\x90" : I8_to_native("\xf1\xbf\xae\xb0"),
212 0xFDD1 => (isASCII) ? "\xef\xb7\x91" : I8_to_native("\xf1\xbf\xae\xb1"),
213 0xFDD2 => (isASCII) ? "\xef\xb7\x92" : I8_to_native("\xf1\xbf\xae\xb2"),
214 0xFDD3 => (isASCII) ? "\xef\xb7\x93" : I8_to_native("\xf1\xbf\xae\xb3"),
215 0xFDD4 => (isASCII) ? "\xef\xb7\x94" : I8_to_native("\xf1\xbf\xae\xb4"),
216 0xFDD5 => (isASCII) ? "\xef\xb7\x95" : I8_to_native("\xf1\xbf\xae\xb5"),
217 0xFDD6 => (isASCII) ? "\xef\xb7\x96" : I8_to_native("\xf1\xbf\xae\xb6"),
218 0xFDD7 => (isASCII) ? "\xef\xb7\x97" : I8_to_native("\xf1\xbf\xae\xb7"),
219 0xFDD8 => (isASCII) ? "\xef\xb7\x98" : I8_to_native("\xf1\xbf\xae\xb8"),
220 0xFDD9 => (isASCII) ? "\xef\xb7\x99" : I8_to_native("\xf1\xbf\xae\xb9"),
221 0xFDDA => (isASCII) ? "\xef\xb7\x9a" : I8_to_native("\xf1\xbf\xae\xba"),
222 0xFDDB => (isASCII) ? "\xef\xb7\x9b" : I8_to_native("\xf1\xbf\xae\xbb"),
223 0xFDDC => (isASCII) ? "\xef\xb7\x9c" : I8_to_native("\xf1\xbf\xae\xbc"),
224 0xFDDD => (isASCII) ? "\xef\xb7\x9d" : I8_to_native("\xf1\xbf\xae\xbd"),
225 0xFDDE => (isASCII) ? "\xef\xb7\x9e" : I8_to_native("\xf1\xbf\xae\xbe"),
226 0xFDDF => (isASCII) ? "\xef\xb7\x9f" : I8_to_native("\xf1\xbf\xae\xbf"),
227 0xFDE0 => (isASCII) ? "\xef\xb7\xa0" : I8_to_native("\xf1\xbf\xaf\xa0"),
228 0xFDE1 => (isASCII) ? "\xef\xb7\xa1" : I8_to_native("\xf1\xbf\xaf\xa1"),
229 0xFDE2 => (isASCII) ? "\xef\xb7\xa2" : I8_to_native("\xf1\xbf\xaf\xa2"),
230 0xFDE3 => (isASCII) ? "\xef\xb7\xa3" : I8_to_native("\xf1\xbf\xaf\xa3"),
231 0xFDE4 => (isASCII) ? "\xef\xb7\xa4" : I8_to_native("\xf1\xbf\xaf\xa4"),
232 0xFDE5 => (isASCII) ? "\xef\xb7\xa5" : I8_to_native("\xf1\xbf\xaf\xa5"),
233 0xFDE6 => (isASCII) ? "\xef\xb7\xa6" : I8_to_native("\xf1\xbf\xaf\xa6"),
234 0xFDE7 => (isASCII) ? "\xef\xb7\xa7" : I8_to_native("\xf1\xbf\xaf\xa7"),
235 0xFDE8 => (isASCII) ? "\xef\xb7\xa8" : I8_to_native("\xf1\xbf\xaf\xa8"),
236 0xFDEa => (isASCII) ? "\xef\xb7\x99" : I8_to_native("\xf1\xbf\xaf\xa9"),
237 0xFDEA => (isASCII) ? "\xef\xb7\xaa" : I8_to_native("\xf1\xbf\xaf\xaa"),
238 0xFDEB => (isASCII) ? "\xef\xb7\xab" : I8_to_native("\xf1\xbf\xaf\xab"),
239 0xFDEC => (isASCII) ? "\xef\xb7\xac" : I8_to_native("\xf1\xbf\xaf\xac"),
240 0xFDED => (isASCII) ? "\xef\xb7\xad" : I8_to_native("\xf1\xbf\xaf\xad"),
241 0xFDEE => (isASCII) ? "\xef\xb7\xae" : I8_to_native("\xf1\xbf\xaf\xae"),
242 0xFDEF => (isASCII) ? "\xef\xb7\xaf" : I8_to_native("\xf1\xbf\xaf\xaf"),
243 0xFDF0 => (isASCII) ? "\xef\xb7\xb0" : I8_to_native("\xf1\xbf\xaf\xb0"),
7dfd8446 244
5f8a3d1d 245 # Mostly around non-characters, but some are transitions to longer strings
2956ebbf
KW
246 0xFFFD => (isASCII) ? "\xef\xbf\xbd" : I8_to_native("\xf1\xbf\xbf\xbd"),
247 0x10000 - 1 => (isASCII)
248 ? "\xef\xbf\xbf"
249 : I8_to_native("\xf1\xbf\xbf\xbf"),
250 0x10000 => (isASCII)
251 ? "\xf0\x90\x80\x80"
252 : I8_to_native("\xf2\xa0\xa0\xa0"),
253 0x1FFFD => (isASCII)
254 ? "\xf0\x9f\xbf\xbd"
255 : I8_to_native("\xf3\xbf\xbf\xbd"),
256 0x1FFFE => (isASCII)
257 ? "\xf0\x9f\xbf\xbe"
258 : I8_to_native("\xf3\xbf\xbf\xbe"),
259 0x1FFFF => (isASCII)
260 ? "\xf0\x9f\xbf\xbf"
261 : I8_to_native("\xf3\xbf\xbf\xbf"),
262 0x20000 => (isASCII)
263 ? "\xf0\xa0\x80\x80"
264 : I8_to_native("\xf4\xa0\xa0\xa0"),
265 0x2FFFD => (isASCII)
266 ? "\xf0\xaf\xbf\xbd"
267 : I8_to_native("\xf5\xbf\xbf\xbd"),
268 0x2FFFE => (isASCII)
269 ? "\xf0\xaf\xbf\xbe"
270 : I8_to_native("\xf5\xbf\xbf\xbe"),
271 0x2FFFF => (isASCII)
272 ? "\xf0\xaf\xbf\xbf"
273 : I8_to_native("\xf5\xbf\xbf\xbf"),
274 0x30000 => (isASCII)
275 ? "\xf0\xb0\x80\x80"
276 : I8_to_native("\xf6\xa0\xa0\xa0"),
277 0x3FFFD => (isASCII)
278 ? "\xf0\xbf\xbf\xbd"
279 : I8_to_native("\xf7\xbf\xbf\xbd"),
280 0x3FFFE => (isASCII)
281 ? "\xf0\xbf\xbf\xbe"
282 : I8_to_native("\xf7\xbf\xbf\xbe"),
283 0x40000 - 1 => (isASCII)
284 ? "\xf0\xbf\xbf\xbf"
285 : I8_to_native("\xf7\xbf\xbf\xbf"),
286 0x40000 => (isASCII)
287 ? "\xf1\x80\x80\x80"
288 : I8_to_native("\xf8\xa8\xa0\xa0\xa0"),
289 0x4FFFD => (isASCII)
290 ? "\xf1\x8f\xbf\xbd"
291 : I8_to_native("\xf8\xa9\xbf\xbf\xbd"),
292 0x4FFFE => (isASCII)
293 ? "\xf1\x8f\xbf\xbe"
294 : I8_to_native("\xf8\xa9\xbf\xbf\xbe"),
295 0x4FFFF => (isASCII)
296 ? "\xf1\x8f\xbf\xbf"
297 : I8_to_native("\xf8\xa9\xbf\xbf\xbf"),
298 0x50000 => (isASCII)
299 ? "\xf1\x90\x80\x80"
300 : I8_to_native("\xf8\xaa\xa0\xa0\xa0"),
301 0x5FFFD => (isASCII)
302 ? "\xf1\x9f\xbf\xbd"
303 : I8_to_native("\xf8\xab\xbf\xbf\xbd"),
304 0x5FFFE => (isASCII)
305 ? "\xf1\x9f\xbf\xbe"
306 : I8_to_native("\xf8\xab\xbf\xbf\xbe"),
307 0x5FFFF => (isASCII)
308 ? "\xf1\x9f\xbf\xbf"
309 : I8_to_native("\xf8\xab\xbf\xbf\xbf"),
310 0x60000 => (isASCII)
311 ? "\xf1\xa0\x80\x80"
312 : I8_to_native("\xf8\xac\xa0\xa0\xa0"),
313 0x6FFFD => (isASCII)
314 ? "\xf1\xaf\xbf\xbd"
315 : I8_to_native("\xf8\xad\xbf\xbf\xbd"),
316 0x6FFFE => (isASCII)
317 ? "\xf1\xaf\xbf\xbe"
318 : I8_to_native("\xf8\xad\xbf\xbf\xbe"),
319 0x6FFFF => (isASCII)
320 ? "\xf1\xaf\xbf\xbf"
321 : I8_to_native("\xf8\xad\xbf\xbf\xbf"),
322 0x70000 => (isASCII)
323 ? "\xf1\xb0\x80\x80"
324 : I8_to_native("\xf8\xae\xa0\xa0\xa0"),
325 0x7FFFD => (isASCII)
326 ? "\xf1\xbf\xbf\xbd"
327 : I8_to_native("\xf8\xaf\xbf\xbf\xbd"),
328 0x7FFFE => (isASCII)
329 ? "\xf1\xbf\xbf\xbe"
330 : I8_to_native("\xf8\xaf\xbf\xbf\xbe"),
331 0x7FFFF => (isASCII)
332 ? "\xf1\xbf\xbf\xbf"
333 : I8_to_native("\xf8\xaf\xbf\xbf\xbf"),
334 0x80000 => (isASCII)
335 ? "\xf2\x80\x80\x80"
336 : I8_to_native("\xf8\xb0\xa0\xa0\xa0"),
337 0x8FFFD => (isASCII)
338 ? "\xf2\x8f\xbf\xbd"
339 : I8_to_native("\xf8\xb1\xbf\xbf\xbd"),
340 0x8FFFE => (isASCII)
341 ? "\xf2\x8f\xbf\xbe"
342 : I8_to_native("\xf8\xb1\xbf\xbf\xbe"),
343 0x8FFFF => (isASCII)
344 ? "\xf2\x8f\xbf\xbf"
345 : I8_to_native("\xf8\xb1\xbf\xbf\xbf"),
346 0x90000 => (isASCII)
347 ? "\xf2\x90\x80\x80"
348 : I8_to_native("\xf8\xb2\xa0\xa0\xa0"),
349 0x9FFFD => (isASCII)
350 ? "\xf2\x9f\xbf\xbd"
351 : I8_to_native("\xf8\xb3\xbf\xbf\xbd"),
352 0x9FFFE => (isASCII)
353 ? "\xf2\x9f\xbf\xbe"
354 : I8_to_native("\xf8\xb3\xbf\xbf\xbe"),
355 0x9FFFF => (isASCII)
356 ? "\xf2\x9f\xbf\xbf"
357 : I8_to_native("\xf8\xb3\xbf\xbf\xbf"),
358 0xA0000 => (isASCII)
359 ? "\xf2\xa0\x80\x80"
360 : I8_to_native("\xf8\xb4\xa0\xa0\xa0"),
361 0xAFFFD => (isASCII)
362 ? "\xf2\xaf\xbf\xbd"
363 : I8_to_native("\xf8\xb5\xbf\xbf\xbd"),
364 0xAFFFE => (isASCII)
365 ? "\xf2\xaf\xbf\xbe"
366 : I8_to_native("\xf8\xb5\xbf\xbf\xbe"),
367 0xAFFFF => (isASCII)
368 ? "\xf2\xaf\xbf\xbf"
369 : I8_to_native("\xf8\xb5\xbf\xbf\xbf"),
370 0xB0000 => (isASCII)
371 ? "\xf2\xb0\x80\x80"
372 : I8_to_native("\xf8\xb6\xa0\xa0\xa0"),
373 0xBFFFD => (isASCII)
374 ? "\xf2\xbf\xbf\xbd"
375 : I8_to_native("\xf8\xb7\xbf\xbf\xbd"),
376 0xBFFFE => (isASCII)
377 ? "\xf2\xbf\xbf\xbe"
378 : I8_to_native("\xf8\xb7\xbf\xbf\xbe"),
379 0xBFFFF => (isASCII)
380 ? "\xf2\xbf\xbf\xbf"
381 : I8_to_native("\xf8\xb7\xbf\xbf\xbf"),
382 0xC0000 => (isASCII)
383 ? "\xf3\x80\x80\x80"
384 : I8_to_native("\xf8\xb8\xa0\xa0\xa0"),
385 0xCFFFD => (isASCII)
386 ? "\xf3\x8f\xbf\xbd"
387 : I8_to_native("\xf8\xb9\xbf\xbf\xbd"),
388 0xCFFFE => (isASCII)
389 ? "\xf3\x8f\xbf\xbe"
390 : I8_to_native("\xf8\xb9\xbf\xbf\xbe"),
391 0xCFFFF => (isASCII)
392 ? "\xf3\x8f\xbf\xbf"
393 : I8_to_native("\xf8\xb9\xbf\xbf\xbf"),
394 0xD0000 => (isASCII)
395 ? "\xf3\x90\x80\x80"
396 : I8_to_native("\xf8\xba\xa0\xa0\xa0"),
397 0xDFFFD => (isASCII)
398 ? "\xf3\x9f\xbf\xbd"
399 : I8_to_native("\xf8\xbb\xbf\xbf\xbd"),
400 0xDFFFE => (isASCII)
401 ? "\xf3\x9f\xbf\xbe"
402 : I8_to_native("\xf8\xbb\xbf\xbf\xbe"),
403 0xDFFFF => (isASCII)
404 ? "\xf3\x9f\xbf\xbf"
405 : I8_to_native("\xf8\xbb\xbf\xbf\xbf"),
406 0xE0000 => (isASCII)
407 ? "\xf3\xa0\x80\x80"
408 : I8_to_native("\xf8\xbc\xa0\xa0\xa0"),
409 0xEFFFD => (isASCII)
410 ? "\xf3\xaf\xbf\xbd"
411 : I8_to_native("\xf8\xbd\xbf\xbf\xbd"),
412 0xEFFFE => (isASCII)
413 ? "\xf3\xaf\xbf\xbe"
414 : I8_to_native("\xf8\xbd\xbf\xbf\xbe"),
415 0xEFFFF => (isASCII)
416 ? "\xf3\xaf\xbf\xbf"
417 : I8_to_native("\xf8\xbd\xbf\xbf\xbf"),
418 0xF0000 => (isASCII)
419 ? "\xf3\xb0\x80\x80"
420 : I8_to_native("\xf8\xbe\xa0\xa0\xa0"),
421 0xFFFFD => (isASCII)
422 ? "\xf3\xbf\xbf\xbd"
423 : I8_to_native("\xf8\xbf\xbf\xbf\xbd"),
424 0xFFFFE => (isASCII)
425 ? "\xf3\xbf\xbf\xbe"
426 : I8_to_native("\xf8\xbf\xbf\xbf\xbe"),
427 0xFFFFF => (isASCII)
428 ? "\xf3\xbf\xbf\xbf"
429 : I8_to_native("\xf8\xbf\xbf\xbf\xbf"),
430 0x100000 => (isASCII)
431 ? "\xf4\x80\x80\x80"
432 : I8_to_native("\xf9\xa0\xa0\xa0\xa0"),
433 0x10FFFD => (isASCII)
434 ? "\xf4\x8f\xbf\xbd"
435 : I8_to_native("\xf9\xa1\xbf\xbf\xbd"),
436 0x10FFFE => (isASCII)
437 ? "\xf4\x8f\xbf\xbe"
438 : I8_to_native("\xf9\xa1\xbf\xbf\xbe"),
439 0x10FFFF => (isASCII)
440 ? "\xf4\x8f\xbf\xbf"
441 : I8_to_native("\xf9\xa1\xbf\xbf\xbf"),
442 0x110000 => (isASCII)
443 ? "\xf4\x90\x80\x80"
444 : I8_to_native("\xf9\xa2\xa0\xa0\xa0"),
7dfd8446
KW
445
446 # Things that would be noncharacters if they were in Unicode, and might be
447 # mistaken, if the C code is bad, to be nonchars
2956ebbf
KW
448 0x11FFFE => (isASCII)
449 ? "\xf4\x9f\xbf\xbe"
450 : I8_to_native("\xf9\xa3\xbf\xbf\xbe"),
451 0x11FFFF => (isASCII)
452 ? "\xf4\x9f\xbf\xbf"
453 : I8_to_native("\xf9\xa3\xbf\xbf\xbf"),
454 0x20FFFE => (isASCII)
455 ? "\xf8\x88\x8f\xbf\xbe"
456 : I8_to_native("\xfa\xa1\xbf\xbf\xbe"),
457 0x20FFFF => (isASCII)
458 ? "\xf8\x88\x8f\xbf\xbf"
459 : I8_to_native("\xfa\xa1\xbf\xbf\xbf"),
460
461 0x200000 - 1 => (isASCII)
462 ? "\xf7\xbf\xbf\xbf"
463 : I8_to_native("\xf9\xbf\xbf\xbf\xbf"),
464 0x200000 => (isASCII)
465 ? "\xf8\x88\x80\x80\x80"
466 : I8_to_native("\xfa\xa0\xa0\xa0\xa0"),
467 0x400000 - 1 => (isASCII)
468 ? "\xf8\x8f\xbf\xbf\xbf"
469 : I8_to_native("\xfb\xbf\xbf\xbf\xbf"),
470 0x400000 => (isASCII)
471 ? "\xf8\x90\x80\x80\x80"
472 : I8_to_native("\xfc\xa4\xa0\xa0\xa0\xa0"),
473 0x4000000 - 1 => (isASCII)
474 ? "\xfb\xbf\xbf\xbf\xbf"
475 : I8_to_native("\xfd\xbf\xbf\xbf\xbf\xbf"),
476 0x4000000 => (isASCII)
477 ? "\xfc\x84\x80\x80\x80\x80"
478 : I8_to_native("\xfe\xa2\xa0\xa0\xa0\xa0\xa0"),
479 0x4000000 - 1 => (isASCII)
480 ? "\xfb\xbf\xbf\xbf\xbf"
481 : I8_to_native("\xfd\xbf\xbf\xbf\xbf\xbf"),
482 0x4000000 => (isASCII)
483 ? "\xfc\x84\x80\x80\x80\x80"
484 : I8_to_native("\xfe\xa2\xa0\xa0\xa0\xa0\xa0"),
485 0x40000000 - 1 => (isASCII)
486 ? "\xfc\xbf\xbf\xbf\xbf\xbf"
487 : I8_to_native("\xfe\xbf\xbf\xbf\xbf\xbf\xbf"),
488 0x40000000 =>
489 (isASCII) ? "\xfd\x80\x80\x80\x80\x80"
490 : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa1\xa0\xa0\xa0\xa0\xa0\xa0"),
491 0x80000000 - 1 =>
492 (isASCII) ? "\xfd\xbf\xbf\xbf\xbf\xbf"
493 : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa1\xbf\xbf\xbf\xbf\xbf\xbf"),
494 0x80000000 =>
495 (isASCII) ? "\xfe\x82\x80\x80\x80\x80\x80"
496 : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa2\xa0\xa0\xa0\xa0\xa0\xa0"),
497 0xFFFFFFFF =>
498 (isASCII) ? "\xfe\x83\xbf\xbf\xbf\xbf\xbf"
499 : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa3\xbf\xbf\xbf\xbf\xbf\xbf"),
7dfd8446 500);
4deba822 501
7dfd8446
KW
502if ($is64bit) {
503 no warnings qw(overflow portable);
2956ebbf
KW
504 $code_points{0x100000000}
505 = (isASCII)
506 ? "\xfe\x84\x80\x80\x80\x80\x80"
507 : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa4\xa0\xa0\xa0\xa0\xa0\xa0");
508 $code_points{0x1000000000 - 1}
509 = (isASCII)
510 ? "\xfe\xbf\xbf\xbf\xbf\xbf\xbf"
511 : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa1\xbf\xbf\xbf\xbf\xbf\xbf\xbf");
512 $code_points{0x1000000000}
513 = (isASCII)
514 ? "\xff\x80\x80\x80\x80\x80\x81\x80\x80\x80\x80\x80\x80"
515 : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa2\xa0\xa0\xa0\xa0\xa0\xa0\xa0");
516 $code_points{0xFFFFFFFFFFFFFFFF}
517 = (isASCII)
518 ? "\xff\x80\x8f\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf"
519 : I8_to_native("\xff\xaf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf");
520 if (isASCII) { # These could falsely show as overlongs in a naive
521 # implementation
522 $code_points{0x40000000000}
523 = "\xff\x80\x80\x80\x80\x81\x80\x80\x80\x80\x80\x80\x80";
524 $code_points{0x1000000000000}
525 = "\xff\x80\x80\x80\x81\x80\x80\x80\x80\x80\x80\x80\x80";
526 $code_points{0x40000000000000}
527 = "\xff\x80\x80\x81\x80\x80\x80\x80\x80\x80\x80\x80\x80";
528 $code_points{0x1000000000000000}
529 = "\xff\x80\x81\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80";
d566bd20 530 # overflows
2956ebbf
KW
531 #$code_points{0xfoo}
532 # = "\xff\x81\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80";
d566bd20
KW
533 }
534}
2956ebbf
KW
535elsif (! isASCII) { # 32-bit EBCDIC. 64-bit is clearer to handle, so doesn't
536 # need this test case
d566bd20 537 no warnings qw(overflow portable);
2956ebbf
KW
538 $code_points{0x40000000} = I8_to_native(
539 "\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa1\xa0\xa0\xa0\xa0\xa0\xa0");
7dfd8446 540}
eb83ed87 541
7dfd8446
KW
542# Now add in entries for each of code points 0-255, which require special
543# handling on EBCDIC. Remember the keys are Unicode values, and the values
544# are the native UTF-8. For invariants, the bytes are just the native chr.
545
546my $cp = 0;
547while ($cp < ((isASCII) ? 128 : 160)) { # This is from the definition of
548 # invariant
549 $code_points{$cp} = chr utf8::unicode_to_native($cp);
550 $cp++;
551}
552
553# Done with the invariants. Now do the variants. All in this range are 2
554# byte. Again, we can't use the internal functions to generate UTF-8, as
555# those are what we are trying to test. In the loop, we know what range the
556# continuation bytes can be in, and what the lowest start byte can be. So we
557# cycle through them.
558
559my $first_continuation = (isASCII) ? 0x80 : 0xA0;
560my $final_continuation = 0xBF;
561my $start = (isASCII) ? 0xC2 : 0xC5;
562
78a3c0f8
KW
563my $max_bytes = (isASCII) ? 13 : 14; # Max number of bytes in a UTF-8 sequence
564 # representing a single code point
565
7dfd8446
KW
566my $continuation = $first_continuation - 1;
567
568while ($cp < 255) {
569 if (++$continuation > $final_continuation) {
570
571 # Wrap to the next start byte when we reach the final continuation
572 # byte possible
573 $continuation = $first_continuation;
574 $start++;
575 }
576 $code_points{$cp} = I8_to_native(chr($start) . chr($continuation));
577
578 $cp++;
579}
eb83ed87
KW
580
581my @warnings;
582
583use warnings 'utf8';
584local $SIG{__WARN__} = sub { push @warnings, @_ };
585
9f2abfde
KW
586my %restriction_types;
587
588$restriction_types{""}{'valid_strings'} = "";
589$restriction_types{"c9strict"}{'valid_strings'} = "";
590$restriction_types{"strict"}{'valid_strings'} = "";
591$restriction_types{"fits_in_31_bits"}{'valid_strings'} = "";
592
593# This set of tests looks for basic sanity, and lastly tests various routines
594# for the given code point. If the earlier tests for that code point fail,
595# the later ones probably will too. Malformations are tested in later
7dfd8446
KW
596# segments of code.
597for my $u (sort { utf8::unicode_to_native($a) <=> utf8::unicode_to_native($b) }
598 keys %code_points)
599{
600 my $hex_u = sprintf("0x%02X", $u);
601 my $n = utf8::unicode_to_native($u);
602 my $hex_n = sprintf("0x%02X", $n);
603 my $bytes = $code_points{$u};
604
605 my $offskip_should_be;
606 {
607 no warnings qw(overflow portable);
608 $offskip_should_be = (isASCII)
609 ? ( $u < 0x80 ? 1 :
610 $u < 0x800 ? 2 :
611 $u < 0x10000 ? 3 :
612 $u < 0x200000 ? 4 :
613 $u < 0x4000000 ? 5 :
614 $u < 0x80000000 ? 6 : (($is64bit)
78a3c0f8 615 ? ($u < 0x1000000000 ? 7 : $max_bytes)
7dfd8446
KW
616 : 7)
617 )
618 : ($u < 0xA0 ? 1 :
619 $u < 0x400 ? 2 :
620 $u < 0x4000 ? 3 :
621 $u < 0x40000 ? 4 :
622 $u < 0x400000 ? 5 :
c0236afe 623 $u < 0x4000000 ? 6 :
78a3c0f8 624 $u < 0x40000000 ? 7 : $max_bytes );
7dfd8446
KW
625 }
626
627 # If this test fails, subsequent ones are meaningless.
628 next unless is(test_OFFUNISKIP($u), $offskip_should_be,
629 "Verify OFFUNISKIP($hex_u) is $offskip_should_be");
630 my $invariant = $offskip_should_be == 1;
631 my $display_invariant = $invariant || 0;
632 is(test_OFFUNI_IS_INVARIANT($u), $invariant,
633 "Verify OFFUNI_IS_INVARIANT($hex_u) is $display_invariant");
634
635 my $uvchr_skip_should_be = $offskip_should_be;
636 next unless is(test_UVCHR_SKIP($n), $uvchr_skip_should_be,
637 "Verify UVCHR_SKIP($hex_n) is $uvchr_skip_should_be");
638 is(test_UVCHR_IS_INVARIANT($n), $offskip_should_be == 1,
639 "Verify UVCHR_IS_INVARIANT($hex_n) is $display_invariant");
640
641 my $n_chr = chr $n;
642 utf8::upgrade $n_chr;
643
644 is(test_UTF8_SKIP($n_chr), $uvchr_skip_should_be,
645 "Verify UTF8_SKIP(chr $hex_n) is $uvchr_skip_should_be");
646
647 use bytes;
3d56ecbe
KW
648 my $byte_length = length $n_chr;
649 for (my $j = 0; $j < $byte_length; $j++) {
650 undef @warnings;
651
652 if ($j == $byte_length - 1) {
2956ebbf
KW
653 my $ret
654 = test_is_utf8_valid_partial_char_flags($n_chr, $byte_length, 0);
655 is($ret, 0, " Verify is_utf8_valid_partial_char_flags("
656 . display_bytes($n_chr)
657 . ") returns 0 for full character");
3d56ecbe
KW
658 }
659 else {
660 my $bytes_so_far = substr($n_chr, 0, $j + 1);
2956ebbf
KW
661 my $ret
662 = test_is_utf8_valid_partial_char_flags($bytes_so_far, $j + 1, 0);
663 is($ret, 1, " Verify is_utf8_valid_partial_char_flags("
664 . display_bytes($bytes_so_far)
665 . ") returns 1");
3d56ecbe
KW
666 }
667
6a0eaf3d
KW
668 is(scalar @warnings, 0, " Verify is_utf8_valid_partial_char_flags"
669 . " generated no warnings")
670 or output_warnings(@warnings);
3d56ecbe 671
7dfd8446
KW
672 my $b = substr($n_chr, $j, 1);
673 my $hex_b = sprintf("\"\\x%02x\"", ord $b);
674
675 my $byte_invariant = $j == 0 && $uvchr_skip_should_be == 1;
676 my $display_byte_invariant = $byte_invariant || 0;
677 next unless is(test_UTF8_IS_INVARIANT($b), $byte_invariant,
678 " Verify UTF8_IS_INVARIANT($hex_b) for byte $j "
679 . "is $display_byte_invariant");
680
681 my $is_start = $j == 0 && $uvchr_skip_should_be > 1;
682 my $display_is_start = $is_start || 0;
683 next unless is(test_UTF8_IS_START($b), $is_start,
684 " Verify UTF8_IS_START($hex_b) is $display_is_start");
685
686 my $is_continuation = $j != 0 && $uvchr_skip_should_be > 1;
687 my $display_is_continuation = $is_continuation || 0;
688 next unless is(test_UTF8_IS_CONTINUATION($b), $is_continuation,
689 " Verify UTF8_IS_CONTINUATION($hex_b) is "
690 . "$display_is_continuation");
691
692 my $is_continued = $uvchr_skip_should_be > 1;
693 my $display_is_continued = $is_continued || 0;
694 next unless is(test_UTF8_IS_CONTINUED($b), $is_continued,
695 " Verify UTF8_IS_CONTINUED($hex_b) is "
696 . "$display_is_continued");
697
698 my $is_downgradeable_start = $n < 256
699 && $uvchr_skip_should_be > 1
700 && $j == 0;
701 my $display_is_downgradeable_start = $is_downgradeable_start || 0;
702 next unless is(test_UTF8_IS_DOWNGRADEABLE_START($b),
703 $is_downgradeable_start,
704 " Verify UTF8_IS_DOWNGRADEABLE_START($hex_b) is "
705 . "$display_is_downgradeable_start");
706
707 my $is_above_latin1 = $n > 255 && $j == 0;
708 my $display_is_above_latin1 = $is_above_latin1 || 0;
709 next unless is(test_UTF8_IS_ABOVE_LATIN1($b),
710 $is_above_latin1,
711 " Verify UTF8_IS_ABOVE_LATIN1($hex_b) is "
712 . "$display_is_above_latin1");
713
714 my $is_possibly_problematic = $j == 0
715 && $n >= ((isASCII)
716 ? 0xD000
717 : 0x8000);
718 my $display_is_possibly_problematic = $is_possibly_problematic || 0;
719 next unless is(test_isUTF8_POSSIBLY_PROBLEMATIC($b),
720 $is_possibly_problematic,
721 " Verify isUTF8_POSSIBLY_PROBLEMATIC($hex_b) is "
722 . "$display_is_above_latin1");
723 }
724
725 # We are not trying to look for warnings, etc, so if they should occur, it
726 # is an error. But some of the code points here do cause warnings, so we
727 # check here and turn off the ones that apply to such code points. A
728 # later section of the code tests for these kinds of things.
046d01eb 729 my $this_utf8_flags = $look_for_everything_utf8n_to;
7dfd8446 730 my $len = length $bytes;
e23e8bc1
KW
731
732 my $valid_under_strict = 1;
a82be82b 733 my $valid_under_c9strict = 1;
9f2abfde 734 my $valid_for_fits_in_31_bits = 1;
7dfd8446
KW
735 if ($n > 0x10FFFF) {
736 $this_utf8_flags &= ~($UTF8_DISALLOW_SUPER|$UTF8_WARN_SUPER);
e23e8bc1 737 $valid_under_strict = 0;
a82be82b 738 $valid_under_c9strict = 0;
5f8a3d1d
KW
739 if ($n > 2 ** 31 - 1) {
740 $this_utf8_flags &=
2956ebbf 741 ~($UTF8_DISALLOW_ABOVE_31_BIT|$UTF8_WARN_ABOVE_31_BIT);
9f2abfde 742 $valid_for_fits_in_31_bits = 0;
5f8a3d1d 743 }
7dfd8446 744 }
5f8a3d1d 745 elsif (($n >= 0xFDD0 && $n <= 0xFDEF) || ($n & 0xFFFE) == 0xFFFE) {
7dfd8446 746 $this_utf8_flags &= ~($UTF8_DISALLOW_NONCHAR|$UTF8_WARN_NONCHAR);
e23e8bc1 747 $valid_under_strict = 0;
7dfd8446 748 }
5f8a3d1d
KW
749 elsif ($n >= 0xD800 && $n <= 0xDFFF) {
750 $this_utf8_flags &= ~($UTF8_DISALLOW_SURROGATE|$UTF8_WARN_SURROGATE);
751 $valid_under_c9strict = 0;
752 $valid_under_strict = 0;
753 }
7dfd8446
KW
754
755 undef @warnings;
756
757 my $display_flags = sprintf "0x%x", $this_utf8_flags;
7dfd8446 758 my $display_bytes = display_bytes($bytes);
f9380377 759 my $ret_ref = test_utf8n_to_uvchr_error($bytes, $len, $this_utf8_flags);
c0d8738e
KW
760
761 # Rest of tests likely meaningless if it gets the wrong code point.
762 next unless is($ret_ref->[0], $n,
f9380377
KW
763 "Verify utf8n_to_uvchr_error($display_bytes, $display_flags)"
764 . "returns $hex_n");
c0d8738e 765 is($ret_ref->[1], $len,
f9380377
KW
766 "Verify utf8n_to_uvchr_error() for $hex_n returns expected length:"
767 . " $len");
7dfd8446
KW
768
769 unless (is(scalar @warnings, 0,
f9380377 770 "Verify utf8n_to_uvchr_error() for $hex_n generated no warnings"))
7dfd8446 771 {
d84e92aa 772 output_warnings(@warnings);
7dfd8446 773 }
f9380377
KW
774 is($ret_ref->[2], 0,
775 "Verify utf8n_to_uvchr_error() returned no error bits");
046d01eb 776
75ffa578
KW
777 undef @warnings;
778
d7874298 779 my $ret = test_isUTF8_CHAR($bytes, $len);
2956ebbf
KW
780 is($ret, $len,
781 "Verify isUTF8_CHAR($display_bytes) returns expected length: $len");
d7874298
KW
782
783 unless (is(scalar @warnings, 0,
784 "Verify isUTF8_CHAR() for $hex_n generated no warnings"))
785 {
d84e92aa 786 output_warnings(@warnings);
d7874298
KW
787 }
788
789 undef @warnings;
790
791 $ret = test_isUTF8_CHAR($bytes, $len - 1);
2956ebbf
KW
792 is($ret, 0,
793 "Verify isUTF8_CHAR() with too short length parameter returns 0");
d7874298 794
6a0eaf3d
KW
795 is(scalar @warnings, 0, "Verify isUTF8_CHAR() generated no warnings")
796 or output_warnings(@warnings);
d7874298
KW
797
798 undef @warnings;
799
25e3a4e0 800 $ret = test_isUTF8_CHAR_flags($bytes, $len, 0);
2956ebbf
KW
801 is($ret, $len, "Verify isUTF8_CHAR_flags($display_bytes, 0)"
802 . " returns expected length: $len");
25e3a4e0 803
6a0eaf3d
KW
804 is(scalar @warnings, 0,
805 "Verify isUTF8_CHAR_flags() for $hex_n generated no warnings")
806 or output_warnings(@warnings);
25e3a4e0
KW
807
808 undef @warnings;
809
810 $ret = test_isUTF8_CHAR_flags($bytes, $len - 1, 0);
2956ebbf
KW
811 is($ret, 0,
812 "Verify isUTF8_CHAR_flags() with too short length parameter returns 0");
25e3a4e0 813
6a0eaf3d
KW
814 is(scalar @warnings, 0, "Verify isUTF8_CHAR_flags() generated no warnings")
815 or output_warnings(@warnings);
25e3a4e0
KW
816
817 undef @warnings;
818
e23e8bc1
KW
819 $ret = test_isSTRICT_UTF8_CHAR($bytes, $len);
820 my $expected_len = ($valid_under_strict) ? $len : 0;
2956ebbf
KW
821 is($ret, $expected_len, "Verify isSTRICT_UTF8_CHAR($display_bytes)"
822 . " returns expected length: $expected_len");
e23e8bc1 823
6a0eaf3d
KW
824 is(scalar @warnings, 0,
825 "Verify isSTRICT_UTF8_CHAR() for $hex_n generated no warnings")
826 or output_warnings(@warnings);
e23e8bc1
KW
827
828 undef @warnings;
829
830 $ret = test_isSTRICT_UTF8_CHAR($bytes, $len - 1);
2956ebbf
KW
831 is($ret, 0,
832 "Verify isSTRICT_UTF8_CHAR() with too short length parameter returns 0");
e23e8bc1 833
6a0eaf3d
KW
834 is(scalar @warnings, 0, "Verify isSTRICT_UTF8_CHAR() generated no warnings")
835 or output_warnings(@warnings);
e23e8bc1 836
25e3a4e0
KW
837 undef @warnings;
838
2956ebbf
KW
839 $ret = test_isUTF8_CHAR_flags($bytes, $len,
840 $UTF8_DISALLOW_ILLEGAL_INTERCHANGE);
841 is($ret, $expected_len,
842 "Verify isUTF8_CHAR_flags('DISALLOW_ILLEGAL_INTERCHANGE')"
843 . " acts like isSTRICT_UTF8_CHAR");
25e3a4e0 844
6a0eaf3d
KW
845 is(scalar @warnings, 0,
846 "Verify isUTF8_CHAR() for $hex_n generated no warnings")
847 or output_warnings(@warnings);
25e3a4e0
KW
848
849 undef @warnings;
850
a82be82b
KW
851 $ret = test_isC9_STRICT_UTF8_CHAR($bytes, $len);
852 $expected_len = ($valid_under_c9strict) ? $len : 0;
2956ebbf
KW
853 is($ret, $expected_len, "Verify isC9_STRICT_UTF8_CHAR($display_bytes)"
854 . " returns expected length: $len");
a82be82b 855
6a0eaf3d
KW
856 is(scalar @warnings, 0,
857 "Verify isC9_STRICT_UTF8_CHAR() for $hex_n generated no warnings")
858 or output_warnings(@warnings);
a82be82b
KW
859
860 undef @warnings;
861
862 $ret = test_isC9_STRICT_UTF8_CHAR($bytes, $len - 1);
2956ebbf
KW
863 is($ret, 0,
864 "Verify isC9_STRICT_UTF8_CHAR() with too short length parameter returns 0");
a82be82b 865
6a0eaf3d
KW
866 is(scalar @warnings, 0,
867 "Verify isC9_STRICT_UTF8_CHAR() generated no warnings")
868 or output_warnings(@warnings);
a82be82b 869
e23e8bc1
KW
870 undef @warnings;
871
2956ebbf
KW
872 $ret = test_isUTF8_CHAR_flags($bytes, $len,
873 $UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE);
874 is($ret, $expected_len,
875 "Verify isUTF8_CHAR_flags('DISALLOW_ILLEGAL_C9_INTERCHANGE')"
876 ." acts like isC9_STRICT_UTF8_CHAR");
25e3a4e0 877
6a0eaf3d
KW
878 is(scalar @warnings, 0,
879 "Verify isUTF8_CHAR() for $hex_n generated no warnings")
880 or output_warnings(@warnings);
25e3a4e0
KW
881
882 undef @warnings;
883
75ffa578 884 $ret_ref = test_valid_utf8_to_uvchr($bytes);
2956ebbf
KW
885 is($ret_ref->[0], $n,
886 "Verify valid_utf8_to_uvchr($display_bytes) returns $hex_n");
887 is($ret_ref->[1], $len,
888 "Verify valid_utf8_to_uvchr() for $hex_n returns expected length: $len");
75ffa578 889
6a0eaf3d
KW
890 is(scalar @warnings, 0,
891 "Verify valid_utf8_to_uvchr() for $hex_n generated no warnings")
892 or output_warnings(@warnings);
75ffa578 893
046d01eb
KW
894 # Similarly for uvchr_to_utf8
895 my $this_uvchr_flags = $look_for_everything_uvchr_to;
896 if ($n > 2 ** 31 - 1) {
897 $this_uvchr_flags &=
898 ~($UNICODE_DISALLOW_ABOVE_31_BIT|$UNICODE_WARN_ABOVE_31_BIT);
899 }
900 if ($n > 0x10FFFF) {
901 $this_uvchr_flags &= ~($UNICODE_DISALLOW_SUPER|$UNICODE_WARN_SUPER);
902 }
5f8a3d1d 903 elsif (($n >= 0xFDD0 && $n <= 0xFDEF) || ($n & 0xFFFE) == 0xFFFE) {
046d01eb
KW
904 $this_uvchr_flags &= ~($UNICODE_DISALLOW_NONCHAR|$UNICODE_WARN_NONCHAR);
905 }
5f8a3d1d 906 elsif ($n >= 0xD800 && $n <= 0xDFFF) {
2956ebbf
KW
907 $this_uvchr_flags
908 &= ~($UNICODE_DISALLOW_SURROGATE|$UNICODE_WARN_SURROGATE);
5f8a3d1d 909 }
046d01eb
KW
910 $display_flags = sprintf "0x%x", $this_uvchr_flags;
911
912 undef @warnings;
913
d7874298 914 $ret = test_uvchr_to_utf8_flags($n, $this_uvchr_flags);
2956ebbf
KW
915 ok(defined $ret,
916 "Verify uvchr_to_utf8_flags($hex_n, $display_flags) returned success");
917 is($ret, $bytes,
918 "Verify uvchr_to_utf8_flags($hex_n, $display_flags) returns correct bytes");
046d01eb 919
6a0eaf3d
KW
920 is(scalar @warnings, 0,
921 "Verify uvchr_to_utf8_flags($hex_n, $display_flags) for $hex_n"
922 . " generated no warnings")
923 or output_warnings(@warnings);
9f2abfde
KW
924
925 # Now append this code point to a string that we will test various
926 # versions of is_foo_utf8_string_bar on, and keep a count of how many code
927 # points are in it. All the code points in this loop are valid in Perl's
928 # extended UTF-8, but some are not valid under various restrictions. A
929 # string and count is kept separately that is entirely valid for each
930 # restriction. And, for each restriction, we note the first occurrence in
931 # the unrestricted string where we find something not in the restricted
932 # string.
933 $restriction_types{""}{'valid_strings'} .= $bytes;
934 $restriction_types{""}{'valid_counts'}++;
935
936 if ($valid_under_c9strict) {
937 $restriction_types{"c9strict"}{'valid_strings'} .= $bytes;
938 $restriction_types{"c9strict"}{'valid_counts'}++;
939 }
940 elsif (! exists $restriction_types{"c9strict"}{'first_invalid_offset'}) {
941 $restriction_types{"c9strict"}{'first_invalid_offset'}
942 = length $restriction_types{"c9strict"}{'valid_strings'};
943 $restriction_types{"c9strict"}{'first_invalid_count'}
944 = $restriction_types{"c9strict"}{'valid_counts'};
945 }
946
947 if ($valid_under_strict) {
948 $restriction_types{"strict"}{'valid_strings'} .= $bytes;
949 $restriction_types{"strict"}{'valid_counts'}++;
950 }
951 elsif (! exists $restriction_types{"strict"}{'first_invalid_offset'}) {
952 $restriction_types{"strict"}{'first_invalid_offset'}
953 = length $restriction_types{"strict"}{'valid_strings'};
954 $restriction_types{"strict"}{'first_invalid_count'}
955 = $restriction_types{"strict"}{'valid_counts'};
956 }
957
958 if ($valid_for_fits_in_31_bits) {
959 $restriction_types{"fits_in_31_bits"}{'valid_strings'} .= $bytes;
960 $restriction_types{"fits_in_31_bits"}{'valid_counts'}++;
961 }
962 elsif (! exists
963 $restriction_types{"fits_in_31_bits"}{'first_invalid_offset'})
964 {
965 $restriction_types{"fits_in_31_bits"}{'first_invalid_offset'}
966 = length $restriction_types{"fits_in_31_bits"}{'valid_strings'};
967 $restriction_types{"fits_in_31_bits"}{'first_invalid_count'}
968 = $restriction_types{"fits_in_31_bits"}{'valid_counts'};
969 }
970}
971
972my $I8c = (isASCII) ? "\x80" : "\xa0"; # A continuation byte
973my $cont_byte = I8_to_native($I8c);
974my $p = (isASCII) ? "\xe1\x80" : I8_to_native("\xE4\xA0"); # partial
975
976# The loop above tested the single or partial character functions/macros,
977# while building up strings to test the string functions, which we do now.
978
979for my $restriction (sort keys %restriction_types) {
980 use bytes;
981
982 for my $use_flags ("", "_flags") {
983
984 # For each restriction, we test it in both the is_foo_flags functions
985 # and the specially named foo function. But not if there isn't such a
986 # specially named function. Currently, this is the only tested
987 # restriction that doesn't have a specially named function
988 next if $use_flags eq "" && $restriction eq "fits_in_31_bits";
989
990 # Start building up the name of the function we will test.
8bc127bf 991 my $base_name = "is_";
9f2abfde
KW
992
993 if (! $use_flags && $restriction ne "") {
8bc127bf 994 $base_name .= $restriction . "_";
9f2abfde 995 }
8bc127bf
KW
996
997 # We test both "is_utf8_string_foo" and "is_fixed_width_buf" functions
998 foreach my $operand ('string', 'fixed_width_buf') {
999
1000 # Currently, the only fixed_width_buf functions have the '_flags'
1001 # suffix.
1002 next if $operand eq 'fixed_width_buf' && $use_flags eq "";
1003
1004 my $name = "${base_name}utf8_$operand";
9f2abfde
KW
1005
1006 # We test each version of the function
1007 for my $function ("_loclen", "_loc", "") {
1008
1009 # We test each function against
1010 # a) valid input
1011 # b) invalid input created by appending an out-of-place
1012 # continuation character to the valid string
8bc127bf
KW
1013 # c) input created by appending a partial character. This
1014 # is valid in the 'fixed_width' functions, but invalid in
1015 # the 'string' ones
9f2abfde
KW
1016 # d) invalid input created by calling a function that is
1017 # expecting a restricted form of the input using the string
1018 # that's valid when unrestricted
1019 for my $error_type (0, $cont_byte, $p, $restriction) {
1020 #diag "restriction=$restriction, use_flags=$use_flags, function=$function, error_type=" . display_bytes($error_type);
1021
1022 # If there is no restriction, the error type will be "",
1023 # which is redundant with 0.
1024 next if $error_type eq "";
1025
1026 my $this_name = "$name$function$use_flags";
1027 my $bytes
1028 = $restriction_types{$restriction}{'valid_strings'};
1029 my $expected_offset = length $bytes;
1030 my $expected_count
1031 = $restriction_types{$restriction}{'valid_counts'};
1032 my $test_name_suffix = "";
1033
1034 my $this_error_type = $error_type;
1035 if ($this_error_type) {
1036
1037 # Appending a bare continuation byte or a partial
8bc127bf
KW
1038 # character doesn't change the character count or
1039 # offset. But in the other cases, we have saved where
1040 # the failures should occur, so use those. Appending
1041 # a continuation byte makes it invalid; appending a
1042 # partial character makes the 'string' form invalid,
1043 # but not the 'fixed_width_buf' form.
2956ebbf
KW
1044 if ( $this_error_type eq $cont_byte
1045 || $this_error_type eq $p)
1046 {
9f2abfde
KW
1047 $bytes .= $this_error_type;
1048 if ($this_error_type eq $cont_byte) {
1049 $test_name_suffix
1050 = " for an unexpected continuation";
1051 }
1052 else {
1053 $test_name_suffix
1054 = " if ends with a partial character";
8bc127bf
KW
1055 $this_error_type
1056 = 0 if $operand eq "fixed_width_buf";
9f2abfde
KW
1057 }
1058 }
1059 else {
1060 $test_name_suffix
1061 = " if contains forbidden code points";
1062 if ($this_error_type eq "c9strict") {
1063 $bytes = $restriction_types{""}{'valid_strings'};
1064 $expected_offset
1065 = $restriction_types{"c9strict"}
1066 {'first_invalid_offset'};
1067 $expected_count
1068 = $restriction_types{"c9strict"}
1069 {'first_invalid_count'};
1070 }
1071 elsif ($this_error_type eq "strict") {
1072 $bytes = $restriction_types{""}{'valid_strings'};
1073 $expected_offset
1074 = $restriction_types{"strict"}
1075 {'first_invalid_offset'};
1076 $expected_count
1077 = $restriction_types{"strict"}
1078 {'first_invalid_count'};
1079
1080 }
1081 elsif ($this_error_type eq "fits_in_31_bits") {
1082 $bytes = $restriction_types{""}{'valid_strings'};
1083 $expected_offset
1084 = $restriction_types{"fits_in_31_bits"}
1085 {'first_invalid_offset'};
1086 $expected_count
1087 = $restriction_types{"fits_in_31_bits"}
1088 {'first_invalid_count'};
1089 }
1090 else {
1091 fail("Internal test error: Unknown error type "
1092 . "'$this_error_type'");
1093 next;
1094 }
1095 }
1096 }
1097
1098 my $length = length $bytes;
1099 my $ret_ref;
1100
1101 my $test = "\$ret_ref = test_$this_name(\$bytes, $length";
1102
1103 # If using the _flags functions, we have to figure out what
1104 # flags to pass. This is done to match the restriction.
1105 if ($use_flags eq "_flags") {
1106 if (! $restriction) {
1107 $test .= ", 0"; # The flag
1108
1109 # Indicate the kind of flag in the test name.
1110 $this_name .= "(0)";
1111 }
1112 else {
1113 $this_name .= "($restriction)";
1114 if ($restriction eq "c9strict") {
1115 $test
1116 .= ", $UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE";
1117 }
1118 elsif ($restriction eq "strict") {
1119 $test .= ", $UTF8_DISALLOW_ILLEGAL_INTERCHANGE";
1120 }
1121 elsif ($restriction eq "fits_in_31_bits") {
1122 $test .= ", $UTF8_DISALLOW_ABOVE_31_BIT";
1123 }
1124 else {
1125 fail("Internal test error: Unknown restriction "
1126 . "'$restriction'");
1127 next;
1128 }
1129 }
1130 }
1131 $test .= ")";
1132
1133 # Actually run the test
1134 eval $test;
1135 if ($@) {
1136 fail($test);
1137 diag $@;
1138 next;
1139 }
1140
1141 my $ret;
1142 my $error_offset;
1143 my $cp_count;
1144
1145 if ($function eq "") {
1146 $ret = $ret_ref; # For plain function, there's only a
1147 # single return value
1148 }
1149 else { # Otherwise, the multiple values come in an array.
1150 $ret = shift @$ret_ref ;
1151 $error_offset = shift @$ret_ref;
1152 $cp_count = shift@$ret_ref if $function eq "_loclen";
1153 }
1154
1155 if ($this_error_type) {
1156 is($ret, 0,
1157 "Verify $this_name is FALSE$test_name_suffix");
1158 }
1159 else {
1160 unless(is($ret, 1,
1161 "Verify $this_name is TRUE for valid input"
1162 . "$test_name_suffix"))
1163 {
5d03eac4 1164 diag(" The bytes starting at offset"
9f2abfde
KW
1165 . " $error_offset are"
1166 . display_bytes(substr(
1167 $restriction_types{$restriction}
1168 {'valid_strings'},
1169 $error_offset)));
1170 next;
1171 }
1172 }
1173
1174 if ($function ne "") {
1175 unless (is($error_offset, $expected_offset,
1176 "\tAnd returns the correct offset"))
1177 {
1178 my $min = ($error_offset < $expected_offset)
1179 ? $error_offset
1180 : $expected_offset;
5d03eac4
KW
1181 diag(" The bytes starting at offset" . $min
1182 . " are " . display_bytes(substr($bytes, $min)));
9f2abfde
KW
1183 }
1184
1185 if ($function eq '_loclen') {
1186 is($cp_count, $expected_count,
1187 "\tAnd returns the correct character count");
1188 }
1189 }
1190 }
1191 }
8bc127bf 1192 }
9f2abfde 1193 }
7dfd8446
KW
1194}
1195
1196my $REPLACEMENT = 0xFFFD;
1197
1198# Now test the malformations. All these raise category utf8 warnings.
7dfd8446 1199my @malformations = (
4b986740 1200 # ($testname, $bytes, $length, $allow_flags, $expected_error_flags,
2d0a2801 1201 # $allowed_uv, $expected_len, $needed_to_discern_len, $message )
eb83ed87 1202 [ "zero length string malformation", "", 0,
2d0a2801 1203 $UTF8_ALLOW_EMPTY, $UTF8_GOT_EMPTY, 0, 0, 0,
eb83ed87
KW
1204 qr/empty string/
1205 ],
2d0a2801
KW
1206 [ "orphan continuation byte malformation", I8_to_native("${I8c}a"), 2,
1207 $UTF8_ALLOW_CONTINUATION, $UTF8_GOT_CONTINUATION, $REPLACEMENT,
1208 1, 1,
eb83ed87
KW
1209 qr/unexpected continuation byte/
1210 ],
7dfd8446 1211 [ "premature next character malformation (immediate)",
9d2d0ecd
KW
1212 (isASCII) ? "\xc2\xc2\x80" : I8_to_native("\xc5\xc5\xa0"),
1213 3,
2d0a2801
KW
1214 $UTF8_ALLOW_NON_CONTINUATION, $UTF8_GOT_NON_CONTINUATION, $REPLACEMENT,
1215 1, 2,
eb83ed87
KW
1216 qr/unexpected non-continuation byte.*immediately after start byte/
1217 ],
7dfd8446 1218 [ "premature next character malformation (non-immediate)",
2d0a2801
KW
1219 I8_to_native("\xef${I8c}a"), 3,
1220 $UTF8_ALLOW_NON_CONTINUATION, $UTF8_GOT_NON_CONTINUATION, $REPLACEMENT,
1221 2, 3,
eb83ed87
KW
1222 qr/unexpected non-continuation byte .* 2 bytes after start byte/
1223 ],
1b514755 1224 [ "too short malformation", I8_to_native("\xf1${I8c}a"), 2,
eb83ed87
KW
1225 # Having the 'a' after this, but saying there are only 2 bytes also
1226 # tests that we pay attention to the passed in length
2d0a2801
KW
1227 $UTF8_ALLOW_SHORT, $UTF8_GOT_SHORT, $REPLACEMENT,
1228 2, 2,
9a6c9c81 1229 qr/2 bytes available, need 4/
eb83ed87 1230 ],
d566bd20
KW
1231 [ "overlong malformation, lowest 2-byte",
1232 (isASCII) ? "\xc0\x80" : I8_to_native("\xc0\xa0"),
1233 2,
f9380377 1234 $UTF8_ALLOW_LONG, $UTF8_GOT_LONG,
7dfd8446 1235 0, # NUL
2d0a2801 1236 2, 1,
7cf8d05d 1237 qr/overlong/
c0236afe 1238 ],
d566bd20
KW
1239 [ "overlong malformation, highest 2-byte",
1240 (isASCII) ? "\xc1\xbf" : I8_to_native("\xc4\xbf"),
1241 2,
f9380377 1242 $UTF8_ALLOW_LONG, $UTF8_GOT_LONG,
f9913875 1243 (isASCII) ? 0x7F : utf8::unicode_to_native(0x9F),
2d0a2801 1244 2, 1,
7cf8d05d 1245 qr/overlong/
d566bd20
KW
1246 ],
1247 [ "overlong malformation, lowest 3-byte",
1248 (isASCII) ? "\xe0\x80\x80" : I8_to_native("\xe0\xa0\xa0"),
1249 3,
f9380377 1250 $UTF8_ALLOW_LONG, $UTF8_GOT_LONG,
d566bd20 1251 0, # NUL
2d0a2801 1252 3, (isASCII) ? 2 : 1,
7cf8d05d 1253 qr/overlong/
d566bd20
KW
1254 ],
1255 [ "overlong malformation, highest 3-byte",
1256 (isASCII) ? "\xe0\x9f\xbf" : I8_to_native("\xe0\xbf\xbf"),
1257 3,
f9380377 1258 $UTF8_ALLOW_LONG, $UTF8_GOT_LONG,
d566bd20 1259 (isASCII) ? 0x7FF : 0x3FF,
2d0a2801 1260 3, (isASCII) ? 2 : 1,
7cf8d05d 1261 qr/overlong/
d566bd20
KW
1262 ],
1263 [ "overlong malformation, lowest 4-byte",
1264 (isASCII) ? "\xf0\x80\x80\x80" : I8_to_native("\xf0\xa0\xa0\xa0"),
1265 4,
f9380377 1266 $UTF8_ALLOW_LONG, $UTF8_GOT_LONG,
d566bd20 1267 0, # NUL
2d0a2801 1268 4, 2,
7cf8d05d 1269 qr/overlong/
d566bd20
KW
1270 ],
1271 [ "overlong malformation, highest 4-byte",
1272 (isASCII) ? "\xf0\x8F\xbf\xbf" : I8_to_native("\xf0\xaf\xbf\xbf"),
1273 4,
f9380377 1274 $UTF8_ALLOW_LONG, $UTF8_GOT_LONG,
d566bd20 1275 (isASCII) ? 0xFFFF : 0x3FFF,
2d0a2801 1276 4, 2,
7cf8d05d 1277 qr/overlong/
d566bd20
KW
1278 ],
1279 [ "overlong malformation, lowest 5-byte",
1280 (isASCII)
1281 ? "\xf8\x80\x80\x80\x80"
1282 : I8_to_native("\xf8\xa0\xa0\xa0\xa0"),
1283 5,
f9380377 1284 $UTF8_ALLOW_LONG, $UTF8_GOT_LONG,
d566bd20 1285 0, # NUL
2d0a2801 1286 5, 2,
7cf8d05d 1287 qr/overlong/
d566bd20
KW
1288 ],
1289 [ "overlong malformation, highest 5-byte",
1290 (isASCII)
1291 ? "\xf8\x87\xbf\xbf\xbf"
1292 : I8_to_native("\xf8\xa7\xbf\xbf\xbf"),
1293 5,
f9380377 1294 $UTF8_ALLOW_LONG, $UTF8_GOT_LONG,
d566bd20 1295 (isASCII) ? 0x1FFFFF : 0x3FFFF,
2d0a2801 1296 5, 2,
7cf8d05d 1297 qr/overlong/
d566bd20
KW
1298 ],
1299 [ "overlong malformation, lowest 6-byte",
1300 (isASCII)
1301 ? "\xfc\x80\x80\x80\x80\x80"
1302 : I8_to_native("\xfc\xa0\xa0\xa0\xa0\xa0"),
1303 6,
f9380377 1304 $UTF8_ALLOW_LONG, $UTF8_GOT_LONG,
d566bd20 1305 0, # NUL
2d0a2801 1306 6, 2,
7cf8d05d 1307 qr/overlong/
d566bd20
KW
1308 ],
1309 [ "overlong malformation, highest 6-byte",
1310 (isASCII)
1311 ? "\xfc\x83\xbf\xbf\xbf\xbf"
1312 : I8_to_native("\xfc\xa3\xbf\xbf\xbf\xbf"),
1313 6,
f9380377 1314 $UTF8_ALLOW_LONG, $UTF8_GOT_LONG,
d566bd20 1315 (isASCII) ? 0x3FFFFFF : 0x3FFFFF,
2d0a2801 1316 6, 2,
7cf8d05d 1317 qr/overlong/
d566bd20
KW
1318 ],
1319 [ "overlong malformation, lowest 7-byte",
1320 (isASCII)
1321 ? "\xfe\x80\x80\x80\x80\x80\x80"
1322 : I8_to_native("\xfe\xa0\xa0\xa0\xa0\xa0\xa0"),
1323 7,
f9380377 1324 $UTF8_ALLOW_LONG, $UTF8_GOT_LONG,
d566bd20 1325 0, # NUL
2d0a2801 1326 7, 2,
7cf8d05d 1327 qr/overlong/
d566bd20
KW
1328 ],
1329 [ "overlong malformation, highest 7-byte",
1330 (isASCII)
1331 ? "\xfe\x81\xbf\xbf\xbf\xbf\xbf"
1332 : I8_to_native("\xfe\xa1\xbf\xbf\xbf\xbf\xbf"),
1333 7,
f9380377 1334 $UTF8_ALLOW_LONG, $UTF8_GOT_LONG,
d566bd20 1335 (isASCII) ? 0x7FFFFFFF : 0x3FFFFFF,
2d0a2801 1336 7, 2,
7cf8d05d 1337 qr/overlong/
c0236afe
KW
1338 ],
1339);
7dfd8446 1340
d566bd20
KW
1341if (isASCII && ! $is64bit) { # 32-bit ASCII platform
1342 no warnings 'portable';
1343 push @malformations,
1344 [ "overflow malformation",
1345 "\xfe\x84\x80\x80\x80\x80\x80", # Represents 2**32
1346 7,
1347 0, # There is no way to allow this malformation
f9380377 1348 $UTF8_GOT_OVERFLOW,
d566bd20 1349 $REPLACEMENT,
2d0a2801 1350 7, 2,
7cf8d05d 1351 qr/overflows/
d566bd20 1352 ],
2d0a2801 1353 [ "overflow malformation",
d566bd20 1354 "\xff\x80\x80\x80\x80\x80\x81\x80\x80\x80\x80\x80\x80",
78a3c0f8 1355 $max_bytes,
d566bd20 1356 0, # There is no way to allow this malformation
f9380377 1357 $UTF8_GOT_OVERFLOW,
d566bd20 1358 $REPLACEMENT,
2d0a2801 1359 $max_bytes, 1,
7cf8d05d 1360 qr/overflows/
d566bd20
KW
1361 ];
1362}
4b986740 1363else { # 64-bit ASCII, or EBCDIC of any size.
d566bd20
KW
1364 # On EBCDIC platforms, another overlong test is needed even on 32-bit
1365 # systems, whereas it doesn't happen on ASCII except on 64-bit ones.
1366
1367 no warnings 'portable';
1368 no warnings 'overflow'; # Doesn't run on 32-bit systems, but compiles
1369 push @malformations,
1370 [ "overlong malformation, lowest max-byte",
1371 (isASCII)
2956ebbf
KW
1372 ? "\xff\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80"
1373 : I8_to_native(
1374 "\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
78a3c0f8 1375 $max_bytes,
f9380377 1376 $UTF8_ALLOW_LONG, $UTF8_GOT_LONG,
d566bd20 1377 0, # NUL
2d0a2801 1378 $max_bytes, (isASCII) ? 7 : 8,
7cf8d05d 1379 qr/overlong/,
d566bd20
KW
1380 ],
1381 [ "overlong malformation, highest max-byte",
1382 (isASCII) # 2**36-1 on ASCII; 2**30-1 on EBCDIC
2956ebbf
KW
1383 ? "\xff\x80\x80\x80\x80\x80\x80\xbf\xbf\xbf\xbf\xbf\xbf"
1384 : I8_to_native(
1385 "\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xbf\xbf\xbf\xbf\xbf\xbf"),
78a3c0f8 1386 $max_bytes,
f9380377 1387 $UTF8_ALLOW_LONG, $UTF8_GOT_LONG,
d566bd20 1388 (isASCII) ? 0xFFFFFFFFF : 0x3FFFFFFF,
2d0a2801 1389 $max_bytes, (isASCII) ? 7 : 8,
7cf8d05d 1390 qr/overlong/,
d566bd20
KW
1391 ];
1392
1393 if (! $is64bit) { # 32-bit EBCDIC
1394 push @malformations,
1395 [ "overflow malformation",
2956ebbf
KW
1396 I8_to_native(
1397 "\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa4\xa0\xa0\xa0\xa0\xa0\xa0"),
78a3c0f8 1398 $max_bytes,
d566bd20 1399 0, # There is no way to allow this malformation
f9380377 1400 $UTF8_GOT_OVERFLOW,
d566bd20 1401 $REPLACEMENT,
2d0a2801 1402 $max_bytes, 8,
7cf8d05d 1403 qr/overflows/
d566bd20
KW
1404 ];
1405 }
4b986740 1406 else { # 64-bit, either ASCII or EBCDIC
d566bd20
KW
1407 push @malformations,
1408 [ "overflow malformation",
1409 (isASCII)
2956ebbf
KW
1410 ? "\xff\x80\x90\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"
1411 : I8_to_native(
1412 "\xff\xb0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
78a3c0f8 1413 $max_bytes,
d566bd20 1414 0, # There is no way to allow this malformation
f9380377 1415 $UTF8_GOT_OVERFLOW,
d566bd20 1416 $REPLACEMENT,
2d0a2801 1417 $max_bytes, (isASCII) ? 3 : 2,
7cf8d05d 1418 qr/overflows/
d566bd20
KW
1419 ];
1420 }
1421}
1422
7dfd8446 1423foreach my $test (@malformations) {
f9380377 1424 my ($testname, $bytes, $length, $allow_flags, $expected_error_flags,
2d0a2801 1425 $allowed_uv, $expected_len, $needed_to_discern_len, $message ) = @$test;
eb83ed87 1426
96f5e3aa
KW
1427 if (length($bytes) < $length) {
1428 fail("Internal test error: actual buffer length (" . length($bytes)
1429 . ") must be at least as high as how far we are allowed to read"
1430 . " into it ($length)");
1431 diag($testname);
1432 next;
1433 }
eb83ed87 1434
d7874298
KW
1435 undef @warnings;
1436
1437 my $ret = test_isUTF8_CHAR($bytes, $length);
1438 is($ret, 0, "$testname: isUTF8_CHAR returns 0");
6a0eaf3d
KW
1439 is(scalar @warnings, 0, "$testname: isUTF8_CHAR() generated no warnings")
1440 or output_warnings(@warnings);
d7874298 1441
25e3a4e0
KW
1442 undef @warnings;
1443
1444 $ret = test_isUTF8_CHAR_flags($bytes, $length, 0);
1445 is($ret, 0, "$testname: isUTF8_CHAR_flags returns 0");
4ad939dc
KW
1446 is(scalar @warnings, 0, "$testname: isUTF8_CHAR_flags() generated no"
1447 . " warnings")
6a0eaf3d 1448 or output_warnings(@warnings);
25e3a4e0 1449
e23e8bc1
KW
1450 $ret = test_isSTRICT_UTF8_CHAR($bytes, $length);
1451 is($ret, 0, "$testname: isSTRICT_UTF8_CHAR returns 0");
6a0eaf3d
KW
1452 is(scalar @warnings, 0,
1453 "$testname: isSTRICT_UTF8_CHAR() generated no warnings")
1454 or output_warnings(@warnings);
e23e8bc1 1455
a82be82b
KW
1456 $ret = test_isC9_STRICT_UTF8_CHAR($bytes, $length);
1457 is($ret, 0, "$testname: isC9_STRICT_UTF8_CHAR returns 0");
6a0eaf3d
KW
1458 is(scalar @warnings, 0,
1459 "$testname: isC9_STRICT_UTF8_CHAR() generated no warnings")
1460 or output_warnings(@warnings);
a82be82b 1461
3d56ecbe
KW
1462 for my $j (1 .. $length - 1) {
1463 my $partial = substr($bytes, 0, $j);
1464
1465 undef @warnings;
1466
1467 $ret = test_is_utf8_valid_partial_char_flags($bytes, $j, 0);
2d0a2801 1468
3d56ecbe
KW
1469 my $ret_should_be = 0;
1470 my $comment = "";
2d0a2801
KW
1471 if ($j < $needed_to_discern_len) {
1472 $ret_should_be = 1;
1473 $comment = ", but need $needed_to_discern_len bytes to discern:";
3d56ecbe 1474 }
2d0a2801 1475
3d56ecbe
KW
1476 is($ret, $ret_should_be, "$testname: is_utf8_valid_partial_char_flags("
1477 . display_bytes($partial)
1478 . ")$comment returns $ret_should_be");
6a0eaf3d
KW
1479 is(scalar @warnings, 0,
1480 "$testname: is_utf8_valid_partial_char_flags() generated"
1481 . " no warnings")
1482 or output_warnings(@warnings);
3d56ecbe
KW
1483 }
1484
d7874298 1485
eb83ed87
KW
1486 # Test what happens when this malformation is not allowed
1487 undef @warnings;
f9380377 1488 my $ret_ref = test_utf8n_to_uvchr_error($bytes, $length, 0);
eb83ed87 1489 is($ret_ref->[0], 0, "$testname: disallowed: Returns 0");
f9380377
KW
1490 is($ret_ref->[1], $expected_len,
1491 "$testname: utf8n_to_uvchr_error(), disallowed: Returns expected"
1492 . " length: $expected_len");
1493 if (is(scalar @warnings, 1,
1494 "$testname: disallowed: Got a single warning "))
1495 {
1496 like($warnings[0], $message,
1497 "$testname: disallowed: Got expected warning");
eb83ed87
KW
1498 }
1499 else {
1500 if (scalar @warnings) {
d84e92aa 1501 output_warnings(@warnings);
eb83ed87
KW
1502 }
1503 }
f9380377
KW
1504 is($ret_ref->[2], $expected_error_flags,
1505 "$testname: utf8n_to_uvchr_error(), disallowed:"
1506 . " Returns expected error");
eb83ed87
KW
1507
1508 { # Next test when disallowed, and warnings are off.
1509 undef @warnings;
1510 no warnings 'utf8';
f9380377
KW
1511 my $ret_ref = test_utf8n_to_uvchr_error($bytes, $length, 0);
1512 is($ret_ref->[0], 0,
1513 "$testname: utf8n_to_uvchr_error(), disallowed: no warnings 'utf8':"
1514 . " Returns 0");
1515 is($ret_ref->[1], $expected_len,
1516 "$testname: utf8n_to_uvchr_error(), disallowed: no warnings 'utf8':"
1517 . " Returns expected length: $expected_len");
1518 if (!is(scalar @warnings, 0,
1519 "$testname: utf8n_to_uvchr_error(), disallowed: no warnings 'utf8':"
1520 . " no warnings generated"))
1521 {
d84e92aa 1522 output_warnings(@warnings);
eb83ed87 1523 }
f9380377
KW
1524 is($ret_ref->[2], $expected_error_flags,
1525 "$testname: utf8n_to_uvchr_error(), disallowed: Returns"
1526 . " expected error");
eb83ed87
KW
1527 }
1528
1529 # Test with CHECK_ONLY
1530 undef @warnings;
f9380377 1531 $ret_ref = test_utf8n_to_uvchr_error($bytes, $length, $UTF8_CHECK_ONLY);
eb83ed87 1532 is($ret_ref->[0], 0, "$testname: CHECK_ONLY: Returns 0");
9d2d0ecd 1533 is($ret_ref->[1], -1, "$testname: CHECK_ONLY: returns -1 for length");
2956ebbf
KW
1534 if (! is(scalar @warnings, 0,
1535 "$testname: CHECK_ONLY: no warnings generated"))
1536 {
d84e92aa 1537 output_warnings(@warnings);
eb83ed87 1538 }
f9380377
KW
1539 is($ret_ref->[2], $expected_error_flags,
1540 "$testname: utf8n_to_uvchr_error(), disallowed: Returns expected"
1541 . " error");
eb83ed87
KW
1542
1543 next if $allow_flags == 0; # Skip if can't allow this malformation
1544
1545 # Test when the malformation is allowed
1546 undef @warnings;
f9380377
KW
1547 $ret_ref = test_utf8n_to_uvchr_error($bytes, $length, $allow_flags);
1548 is($ret_ref->[0], $allowed_uv,
1549 "$testname: utf8n_to_uvchr_error(), allowed: Returns expected uv: "
1550 . sprintf("0x%04X", $allowed_uv));
1551 is($ret_ref->[1], $expected_len,
1552 "$testname: utf8n_to_uvchr_error(), allowed: Returns expected length:"
1553 . " $expected_len");
1554 if (!is(scalar @warnings, 0,
1555 "$testname: utf8n_to_uvchr_error(), allowed: no warnings"
1556 . " generated"))
eb83ed87 1557 {
d84e92aa 1558 output_warnings(@warnings);
eb83ed87 1559 }
f9380377
KW
1560 is($ret_ref->[2], $expected_error_flags,
1561 "$testname: utf8n_to_uvchr_error(), disallowed: Returns"
1562 . " expected error");
eb83ed87
KW
1563}
1564
2b5e7bc2
KW
1565sub nonportable_regex ($) {
1566
1567 # Returns a pattern that matches the non-portable message raised either
1568 # for the specific input code point, or the one generated when there
1569 # is some malformation that precludes the message containing the specific
1570 # code point
1571
1572 my $code_point = shift;
1573
22123136 1574 my $string = sprintf '(Code point 0x%X is not Unicode, and'
2b5e7bc2
KW
1575 . '|Any UTF-8 sequence that starts with'
1576 . ' "(\\\x[[:xdigit:]]{2})+" is for a'
1577 . ' non-Unicode code point, and is) not portable',
1578 $code_point;
1579 return qr/$string/;
1580}
1581
eb83ed87
KW
1582# Now test the cases where a legal code point is generated, but may or may not
1583# be allowed/warned on.
2f8f112e 1584my @tests = (
4b986740 1585 # ($testname, $bytes, $warn_flags, $disallow_flags, $expected_error_flags,
2d0a2801 1586 # $category, $allowed_uv, $expected_len, $needed_to_discern_len, $message )
7dfd8446
KW
1587 [ "lowest surrogate",
1588 (isASCII) ? "\xed\xa0\x80" : I8_to_native("\xf1\xb6\xa0\xa0"),
f9380377 1589 $UTF8_WARN_SURROGATE, $UTF8_DISALLOW_SURROGATE, $UTF8_GOT_SURROGATE,
7dfd8446
KW
1590 'surrogate', 0xD800,
1591 (isASCII) ? 3 : 4,
2d0a2801 1592 2,
7dfd8446
KW
1593 qr/surrogate/
1594 ],
1595 [ "a middle surrogate",
1596 (isASCII) ? "\xed\xa4\x8d" : I8_to_native("\xf1\xb6\xa8\xad"),
f9380377 1597 $UTF8_WARN_SURROGATE, $UTF8_DISALLOW_SURROGATE, $UTF8_GOT_SURROGATE,
7dfd8446
KW
1598 'surrogate', 0xD90D,
1599 (isASCII) ? 3 : 4,
2d0a2801 1600 2,
eb83ed87
KW
1601 qr/surrogate/
1602 ],
7dfd8446
KW
1603 [ "highest surrogate",
1604 (isASCII) ? "\xed\xbf\xbf" : I8_to_native("\xf1\xb7\xbf\xbf"),
f9380377 1605 $UTF8_WARN_SURROGATE, $UTF8_DISALLOW_SURROGATE, $UTF8_GOT_SURROGATE,
7dfd8446
KW
1606 'surrogate', 0xDFFF,
1607 (isASCII) ? 3 : 4,
2d0a2801 1608 2,
7dfd8446
KW
1609 qr/surrogate/
1610 ],
1611 [ "first non_unicode",
1612 (isASCII) ? "\xf4\x90\x80\x80" : I8_to_native("\xf9\xa2\xa0\xa0\xa0"),
f9380377 1613 $UTF8_WARN_SUPER, $UTF8_DISALLOW_SUPER, $UTF8_GOT_SUPER,
7dfd8446
KW
1614 'non_unicode', 0x110000,
1615 (isASCII) ? 4 : 5,
2d0a2801 1616 2,
2b5e7bc2 1617 qr/(not Unicode|for a non-Unicode code point).* may not be portable/
7dfd8446 1618 ],
d566bd20
KW
1619 [ "non_unicode whose first byte tells that",
1620 (isASCII) ? "\xf5\x80\x80\x80" : I8_to_native("\xfa\xa0\xa0\xa0\xa0"),
f9380377 1621 $UTF8_WARN_SUPER, $UTF8_DISALLOW_SUPER, $UTF8_GOT_SUPER,
d566bd20
KW
1622 'non_unicode',
1623 (isASCII) ? 0x140000 : 0x200000,
1624 (isASCII) ? 4 : 5,
2d0a2801 1625 1,
2b5e7bc2 1626 qr/(not Unicode|for a non-Unicode code point).* may not be portable/
d566bd20 1627 ],
7dfd8446
KW
1628 [ "first of 32 consecutive non-character code points",
1629 (isASCII) ? "\xef\xb7\x90" : I8_to_native("\xf1\xbf\xae\xb0"),
f9380377 1630 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
7dfd8446
KW
1631 'nonchar', 0xFDD0,
1632 (isASCII) ? 3 : 4,
2d0a2801 1633 (isASCII) ? 3 : 4,
7dfd8446
KW
1634 qr/Unicode non-character.*is not recommended for open interchange/
1635 ],
1636 [ "a mid non-character code point of the 32 consecutive ones",
1637 (isASCII) ? "\xef\xb7\xa0" : I8_to_native("\xf1\xbf\xaf\xa0"),
f9380377 1638 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
7dfd8446
KW
1639 'nonchar', 0xFDE0,
1640 (isASCII) ? 3 : 4,
2d0a2801 1641 (isASCII) ? 3 : 4,
7dfd8446
KW
1642 qr/Unicode non-character.*is not recommended for open interchange/
1643 ],
1644 [ "final of 32 consecutive non-character code points",
1645 (isASCII) ? "\xef\xb7\xaf" : I8_to_native("\xf1\xbf\xaf\xaf"),
f9380377 1646 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
7dfd8446
KW
1647 'nonchar', 0xFDEF,
1648 (isASCII) ? 3 : 4,
2d0a2801 1649 (isASCII) ? 3 : 4,
7dfd8446
KW
1650 qr/Unicode non-character.*is not recommended for open interchange/
1651 ],
1652 [ "non-character code point U+FFFE",
1653 (isASCII) ? "\xef\xbf\xbe" : I8_to_native("\xf1\xbf\xbf\xbe"),
f9380377 1654 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
7dfd8446
KW
1655 'nonchar', 0xFFFE,
1656 (isASCII) ? 3 : 4,
2d0a2801 1657 (isASCII) ? 3 : 4,
7dfd8446
KW
1658 qr/Unicode non-character.*is not recommended for open interchange/
1659 ],
1660 [ "non-character code point U+FFFF",
1661 (isASCII) ? "\xef\xbf\xbf" : I8_to_native("\xf1\xbf\xbf\xbf"),
f9380377 1662 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
7dfd8446
KW
1663 'nonchar', 0xFFFF,
1664 (isASCII) ? 3 : 4,
2d0a2801 1665 (isASCII) ? 3 : 4,
7dfd8446
KW
1666 qr/Unicode non-character.*is not recommended for open interchange/
1667 ],
1668 [ "non-character code point U+1FFFE",
1669 (isASCII) ? "\xf0\x9f\xbf\xbe" : I8_to_native("\xf3\xbf\xbf\xbe"),
f9380377 1670 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
2d0a2801
KW
1671 'nonchar', 0x1FFFE,
1672 4, 4,
7dfd8446
KW
1673 qr/Unicode non-character.*is not recommended for open interchange/
1674 ],
1675 [ "non-character code point U+1FFFF",
1676 (isASCII) ? "\xf0\x9f\xbf\xbf" : I8_to_native("\xf3\xbf\xbf\xbf"),
f9380377 1677 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
2d0a2801
KW
1678 'nonchar', 0x1FFFF,
1679 4, 4,
7dfd8446
KW
1680 qr/Unicode non-character.*is not recommended for open interchange/
1681 ],
1682 [ "non-character code point U+2FFFE",
1683 (isASCII) ? "\xf0\xaf\xbf\xbe" : I8_to_native("\xf5\xbf\xbf\xbe"),
f9380377 1684 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
2d0a2801
KW
1685 'nonchar', 0x2FFFE,
1686 4, 4,
7dfd8446
KW
1687 qr/Unicode non-character.*is not recommended for open interchange/
1688 ],
1689 [ "non-character code point U+2FFFF",
1690 (isASCII) ? "\xf0\xaf\xbf\xbf" : I8_to_native("\xf5\xbf\xbf\xbf"),
f9380377 1691 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
2d0a2801
KW
1692 'nonchar', 0x2FFFF,
1693 4, 4,
7dfd8446
KW
1694 qr/Unicode non-character.*is not recommended for open interchange/
1695 ],
1696 [ "non-character code point U+3FFFE",
1697 (isASCII) ? "\xf0\xbf\xbf\xbe" : I8_to_native("\xf7\xbf\xbf\xbe"),
f9380377 1698 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
2d0a2801
KW
1699 'nonchar', 0x3FFFE,
1700 4, 4,
7dfd8446
KW
1701 qr/Unicode non-character.*is not recommended for open interchange/
1702 ],
1703 [ "non-character code point U+3FFFF",
1704 (isASCII) ? "\xf0\xbf\xbf\xbf" : I8_to_native("\xf7\xbf\xbf\xbf"),
f9380377 1705 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
2d0a2801
KW
1706 'nonchar', 0x3FFFF,
1707 4, 4,
7dfd8446
KW
1708 qr/Unicode non-character.*is not recommended for open interchange/
1709 ],
1710 [ "non-character code point U+4FFFE",
1711 (isASCII) ? "\xf1\x8f\xbf\xbe" : I8_to_native("\xf8\xa9\xbf\xbf\xbe"),
f9380377 1712 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
7dfd8446
KW
1713 'nonchar', 0x4FFFE,
1714 (isASCII) ? 4 : 5,
2d0a2801 1715 (isASCII) ? 4 : 5,
7dfd8446
KW
1716 qr/Unicode non-character.*is not recommended for open interchange/
1717 ],
1718 [ "non-character code point U+4FFFF",
1719 (isASCII) ? "\xf1\x8f\xbf\xbf" : I8_to_native("\xf8\xa9\xbf\xbf\xbf"),
f9380377 1720 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
7dfd8446
KW
1721 'nonchar', 0x4FFFF,
1722 (isASCII) ? 4 : 5,
2d0a2801 1723 (isASCII) ? 4 : 5,
7dfd8446
KW
1724 qr/Unicode non-character.*is not recommended for open interchange/
1725 ],
1726 [ "non-character code point U+5FFFE",
1727 (isASCII) ? "\xf1\x9f\xbf\xbe" : I8_to_native("\xf8\xab\xbf\xbf\xbe"),
f9380377 1728 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
7dfd8446
KW
1729 'nonchar', 0x5FFFE,
1730 (isASCII) ? 4 : 5,
2d0a2801 1731 (isASCII) ? 4 : 5,
7dfd8446
KW
1732 qr/Unicode non-character.*is not recommended for open interchange/
1733 ],
1734 [ "non-character code point U+5FFFF",
1735 (isASCII) ? "\xf1\x9f\xbf\xbf" : I8_to_native("\xf8\xab\xbf\xbf\xbf"),
f9380377 1736 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
7dfd8446
KW
1737 'nonchar', 0x5FFFF,
1738 (isASCII) ? 4 : 5,
2d0a2801 1739 (isASCII) ? 4 : 5,
7dfd8446
KW
1740 qr/Unicode non-character.*is not recommended for open interchange/
1741 ],
1742 [ "non-character code point U+6FFFE",
1743 (isASCII) ? "\xf1\xaf\xbf\xbe" : I8_to_native("\xf8\xad\xbf\xbf\xbe"),
f9380377 1744 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
7dfd8446
KW
1745 'nonchar', 0x6FFFE,
1746 (isASCII) ? 4 : 5,
2d0a2801 1747 (isASCII) ? 4 : 5,
7dfd8446
KW
1748 qr/Unicode non-character.*is not recommended for open interchange/
1749 ],
1750 [ "non-character code point U+6FFFF",
1751 (isASCII) ? "\xf1\xaf\xbf\xbf" : I8_to_native("\xf8\xad\xbf\xbf\xbf"),
f9380377 1752 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
7dfd8446
KW
1753 'nonchar', 0x6FFFF,
1754 (isASCII) ? 4 : 5,
2d0a2801 1755 (isASCII) ? 4 : 5,
7dfd8446
KW
1756 qr/Unicode non-character.*is not recommended for open interchange/
1757 ],
1758 [ "non-character code point U+7FFFE",
1759 (isASCII) ? "\xf1\xbf\xbf\xbe" : I8_to_native("\xf8\xaf\xbf\xbf\xbe"),
f9380377 1760 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
7dfd8446
KW
1761 'nonchar', 0x7FFFE,
1762 (isASCII) ? 4 : 5,
2d0a2801 1763 (isASCII) ? 4 : 5,
7dfd8446
KW
1764 qr/Unicode non-character.*is not recommended for open interchange/
1765 ],
1766 [ "non-character code point U+7FFFF",
1767 (isASCII) ? "\xf1\xbf\xbf\xbf" : I8_to_native("\xf8\xaf\xbf\xbf\xbf"),
f9380377 1768 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
7dfd8446
KW
1769 'nonchar', 0x7FFFF,
1770 (isASCII) ? 4 : 5,
2d0a2801 1771 (isASCII) ? 4 : 5,
7dfd8446
KW
1772 qr/Unicode non-character.*is not recommended for open interchange/
1773 ],
1774 [ "non-character code point U+8FFFE",
1775 (isASCII) ? "\xf2\x8f\xbf\xbe" : I8_to_native("\xf8\xb1\xbf\xbf\xbe"),
f9380377 1776 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
7dfd8446
KW
1777 'nonchar', 0x8FFFE,
1778 (isASCII) ? 4 : 5,
2d0a2801 1779 (isASCII) ? 4 : 5,
7dfd8446
KW
1780 qr/Unicode non-character.*is not recommended for open interchange/
1781 ],
1782 [ "non-character code point U+8FFFF",
1783 (isASCII) ? "\xf2\x8f\xbf\xbf" : I8_to_native("\xf8\xb1\xbf\xbf\xbf"),
f9380377 1784 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
7dfd8446
KW
1785 'nonchar', 0x8FFFF,
1786 (isASCII) ? 4 : 5,
2d0a2801 1787 (isASCII) ? 4 : 5,
7dfd8446
KW
1788 qr/Unicode non-character.*is not recommended for open interchange/
1789 ],
1790 [ "non-character code point U+9FFFE",
1791 (isASCII) ? "\xf2\x9f\xbf\xbe" : I8_to_native("\xf8\xb3\xbf\xbf\xbe"),
f9380377 1792 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
7dfd8446
KW
1793 'nonchar', 0x9FFFE,
1794 (isASCII) ? 4 : 5,
2d0a2801 1795 (isASCII) ? 4 : 5,
7dfd8446
KW
1796 qr/Unicode non-character.*is not recommended for open interchange/
1797 ],
1798 [ "non-character code point U+9FFFF",
1799 (isASCII) ? "\xf2\x9f\xbf\xbf" : I8_to_native("\xf8\xb3\xbf\xbf\xbf"),
f9380377 1800 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
7dfd8446
KW
1801 'nonchar', 0x9FFFF,
1802 (isASCII) ? 4 : 5,
2d0a2801 1803 (isASCII) ? 4 : 5,
7dfd8446
KW
1804 qr/Unicode non-character.*is not recommended for open interchange/
1805 ],
1806 [ "non-character code point U+AFFFE",
1807 (isASCII) ? "\xf2\xaf\xbf\xbe" : I8_to_native("\xf8\xb5\xbf\xbf\xbe"),
f9380377 1808 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
7dfd8446
KW
1809 'nonchar', 0xAFFFE,
1810 (isASCII) ? 4 : 5,
2d0a2801 1811 (isASCII) ? 4 : 5,
7dfd8446
KW
1812 qr/Unicode non-character.*is not recommended for open interchange/
1813 ],
1814 [ "non-character code point U+AFFFF",
1815 (isASCII) ? "\xf2\xaf\xbf\xbf" : I8_to_native("\xf8\xb5\xbf\xbf\xbf"),
f9380377 1816 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
7dfd8446
KW
1817 'nonchar', 0xAFFFF,
1818 (isASCII) ? 4 : 5,
2d0a2801 1819 (isASCII) ? 4 : 5,
7dfd8446
KW
1820 qr/Unicode non-character.*is not recommended for open interchange/
1821 ],
1822 [ "non-character code point U+BFFFE",
1823 (isASCII) ? "\xf2\xbf\xbf\xbe" : I8_to_native("\xf8\xb7\xbf\xbf\xbe"),
f9380377 1824 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
7dfd8446
KW
1825 'nonchar', 0xBFFFE,
1826 (isASCII) ? 4 : 5,
2d0a2801 1827 (isASCII) ? 4 : 5,
7dfd8446
KW
1828 qr/Unicode non-character.*is not recommended for open interchange/
1829 ],
1830 [ "non-character code point U+BFFFF",
1831 (isASCII) ? "\xf2\xbf\xbf\xbf" : I8_to_native("\xf8\xb7\xbf\xbf\xbf"),
f9380377 1832 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
7dfd8446
KW
1833 'nonchar', 0xBFFFF,
1834 (isASCII) ? 4 : 5,
2d0a2801 1835 (isASCII) ? 4 : 5,
7dfd8446
KW
1836 qr/Unicode non-character.*is not recommended for open interchange/
1837 ],
1838 [ "non-character code point U+CFFFE",
1839 (isASCII) ? "\xf3\x8f\xbf\xbe" : I8_to_native("\xf8\xb9\xbf\xbf\xbe"),
f9380377 1840 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
7dfd8446
KW
1841 'nonchar', 0xCFFFE,
1842 (isASCII) ? 4 : 5,
2d0a2801 1843 (isASCII) ? 4 : 5,
7dfd8446
KW
1844 qr/Unicode non-character.*is not recommended for open interchange/
1845 ],
1846 [ "non-character code point U+CFFFF",
1847 (isASCII) ? "\xf3\x8f\xbf\xbf" : I8_to_native("\xf8\xb9\xbf\xbf\xbf"),
f9380377 1848 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
7dfd8446
KW
1849 'nonchar', 0xCFFFF,
1850 (isASCII) ? 4 : 5,
2d0a2801 1851 (isASCII) ? 4 : 5,
7dfd8446
KW
1852 qr/Unicode non-character.*is not recommended for open interchange/
1853 ],
1854 [ "non-character code point U+DFFFE",
1855 (isASCII) ? "\xf3\x9f\xbf\xbe" : I8_to_native("\xf8\xbb\xbf\xbf\xbe"),
f9380377 1856 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
7dfd8446
KW
1857 'nonchar', 0xDFFFE,
1858 (isASCII) ? 4 : 5,
2d0a2801 1859 (isASCII) ? 4 : 5,
7dfd8446
KW
1860 qr/Unicode non-character.*is not recommended for open interchange/
1861 ],
1862 [ "non-character code point U+DFFFF",
1863 (isASCII) ? "\xf3\x9f\xbf\xbf" : I8_to_native("\xf8\xbb\xbf\xbf\xbf"),
f9380377 1864 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
7dfd8446
KW
1865 'nonchar', 0xDFFFF,
1866 (isASCII) ? 4 : 5,
2d0a2801 1867 (isASCII) ? 4 : 5,
7dfd8446
KW
1868 qr/Unicode non-character.*is not recommended for open interchange/
1869 ],
1870 [ "non-character code point U+EFFFE",
1871 (isASCII) ? "\xf3\xaf\xbf\xbe" : I8_to_native("\xf8\xbd\xbf\xbf\xbe"),
f9380377 1872 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
7dfd8446
KW
1873 'nonchar', 0xEFFFE,
1874 (isASCII) ? 4 : 5,
2d0a2801 1875 (isASCII) ? 4 : 5,
7dfd8446
KW
1876 qr/Unicode non-character.*is not recommended for open interchange/
1877 ],
1878 [ "non-character code point U+EFFFF",
1879 (isASCII) ? "\xf3\xaf\xbf\xbf" : I8_to_native("\xf8\xbd\xbf\xbf\xbf"),
f9380377 1880 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
7dfd8446
KW
1881 'nonchar', 0xEFFFF,
1882 (isASCII) ? 4 : 5,
2d0a2801 1883 (isASCII) ? 4 : 5,
7dfd8446
KW
1884 qr/Unicode non-character.*is not recommended for open interchange/
1885 ],
1886 [ "non-character code point U+FFFFE",
1887 (isASCII) ? "\xf3\xbf\xbf\xbe" : I8_to_native("\xf8\xbf\xbf\xbf\xbe"),
f9380377 1888 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
7dfd8446
KW
1889 'nonchar', 0xFFFFE,
1890 (isASCII) ? 4 : 5,
2d0a2801 1891 (isASCII) ? 4 : 5,
7dfd8446
KW
1892 qr/Unicode non-character.*is not recommended for open interchange/
1893 ],
1894 [ "non-character code point U+FFFFF",
1895 (isASCII) ? "\xf3\xbf\xbf\xbf" : I8_to_native("\xf8\xbf\xbf\xbf\xbf"),
f9380377 1896 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
7dfd8446
KW
1897 'nonchar', 0xFFFFF,
1898 (isASCII) ? 4 : 5,
2d0a2801 1899 (isASCII) ? 4 : 5,
7dfd8446
KW
1900 qr/Unicode non-character.*is not recommended for open interchange/
1901 ],
1902 [ "non-character code point U+10FFFE",
1903 (isASCII) ? "\xf4\x8f\xbf\xbe" : I8_to_native("\xf9\xa1\xbf\xbf\xbe"),
f9380377 1904 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
7dfd8446
KW
1905 'nonchar', 0x10FFFE,
1906 (isASCII) ? 4 : 5,
2d0a2801 1907 (isASCII) ? 4 : 5,
7dfd8446 1908 qr/Unicode non-character.*is not recommended for open interchange/
eb83ed87 1909 ],
7dfd8446
KW
1910 [ "non-character code point U+10FFFF",
1911 (isASCII) ? "\xf4\x8f\xbf\xbf" : I8_to_native("\xf9\xa1\xbf\xbf\xbf"),
f9380377 1912 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
7dfd8446
KW
1913 'nonchar', 0x10FFFF,
1914 (isASCII) ? 4 : 5,
2d0a2801 1915 (isASCII) ? 4 : 5,
ba707cdc 1916 qr/Unicode non-character.*is not recommended for open interchange/
eb83ed87 1917 ],
1d1c12d9 1918 [ "requires at least 32 bits",
c0236afe 1919 (isASCII)
2956ebbf
KW
1920 ? "\xfe\x82\x80\x80\x80\x80\x80"
1921 : I8_to_native(
1922 "\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa2\xa0\xa0\xa0\xa0\xa0\xa0"),
eb83ed87 1923 # This code point is chosen so that it is representable in a UV on
2f8f112e 1924 # 32-bit machines
1d1c12d9 1925 $UTF8_WARN_ABOVE_31_BIT, $UTF8_DISALLOW_ABOVE_31_BIT,
f9380377 1926 $UTF8_GOT_ABOVE_31_BIT,
2d0a2801
KW
1927 'utf8', 0x80000000,
1928 (isASCII) ? 7 : $max_bytes,
1929 (isASCII) ? 1 : 8,
2b5e7bc2 1930 nonportable_regex(0x80000000)
7dfd8446 1931 ],
b0b342d4
KW
1932 [ "highest 32 bit code point",
1933 (isASCII)
2956ebbf
KW
1934 ? "\xfe\x83\xbf\xbf\xbf\xbf\xbf"
1935 : I8_to_native(
1936 "\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa3\xbf\xbf\xbf\xbf\xbf\xbf"),
b0b342d4
KW
1937 $UTF8_WARN_ABOVE_31_BIT, $UTF8_DISALLOW_ABOVE_31_BIT,
1938 $UTF8_GOT_ABOVE_31_BIT,
2d0a2801
KW
1939 'utf8', 0xFFFFFFFF,
1940 (isASCII) ? 7 : $max_bytes,
1941 (isASCII) ? 1 : 8,
b0b342d4
KW
1942 nonportable_regex(0xffffffff)
1943 ],
2956ebbf
KW
1944 [ "requires at least 32 bits, and use SUPER-type flags, instead of"
1945 . " ABOVE_31_BIT",
c0236afe
KW
1946 (isASCII)
1947 ? "\xfe\x82\x80\x80\x80\x80\x80"
2956ebbf
KW
1948 : I8_to_native(
1949 "\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa2\xa0\xa0\xa0\xa0\xa0\xa0"),
f9380377 1950 $UTF8_WARN_SUPER, $UTF8_DISALLOW_SUPER, $UTF8_GOT_SUPER,
2d0a2801
KW
1951 'utf8', 0x80000000,
1952 (isASCII) ? 7 : $max_bytes,
b9a3b632 1953 1,
2b5e7bc2 1954 nonportable_regex(0x80000000)
eb83ed87 1955 ],
1d1c12d9
KW
1956 [ "overflow with warnings/disallow for more than 31 bits",
1957 # This tests the interaction of WARN_ABOVE_31_BIT/DISALLOW_ABOVE_31_BIT
1958 # with overflow. The overflow malformation is never allowed, so
1959 # preventing it takes precedence if the ABOVE_31_BIT options would
c0236afe 1960 # otherwise allow in an overflowing value. The ASCII code points (1
1d1c12d9
KW
1961 # for 32-bits; 1 for 64) were chosen because the old overflow
1962 # detection algorithm did not catch them; this means this test also
c0236afe
KW
1963 # checks for that fix. The EBCDIC are arbitrary overflowing ones
1964 # since we have no reports of failures with it.
1965 (($is64bit)
1966 ? ((isASCII)
2956ebbf
KW
1967 ? "\xff\x80\x90\x90\x90\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf"
1968 : I8_to_native(
1969 "\xff\xB0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"))
c0236afe 1970 : ((isASCII)
2956ebbf
KW
1971 ? "\xfe\x86\x80\x80\x80\x80\x80"
1972 : I8_to_native(
1973 "\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa4\xa0\xa0\xa0\xa0\xa0\xa0"))),
f9380377
KW
1974 $UTF8_WARN_ABOVE_31_BIT,
1975 $UTF8_DISALLOW_ABOVE_31_BIT,
1976 $UTF8_GOT_ABOVE_31_BIT,
7dfd8446 1977 'utf8', 0,
4b986740 1978 (! isASCII || $is64bit) ? $max_bytes : 7,
2d0a2801 1979 (isASCII || $is64bit) ? 2 : 8,
7cf8d05d 1980 qr/overflows/
eb83ed87 1981 ],
c0236afe 1982);
2f8f112e 1983
b0b342d4
KW
1984if (! $is64bit) {
1985 if (isASCII) {
1986 no warnings qw{portable overflow};
1987 push @tests,
1988 [ "Lowest 33 bit code point: overflow",
1989 "\xFE\x84\x80\x80\x80\x80\x80",
1990 $UTF8_WARN_ABOVE_31_BIT, $UTF8_DISALLOW_ABOVE_31_BIT,
1991 $UTF8_GOT_ABOVE_31_BIT,
2d0a2801
KW
1992 'utf8', 0x100000000,
1993 7, 1,
b0b342d4
KW
1994 qr/and( is)? not portable/
1995 ];
1996 }
1997}
1998else {
c0236afe 1999 no warnings qw{portable overflow};
2f8f112e 2000 push @tests,
c0236afe
KW
2001 [ "More than 32 bits",
2002 (isASCII)
2956ebbf
KW
2003 ? "\xff\x80\x80\x80\x80\x80\x81\x80\x80\x80\x80\x80\x80"
2004 : I8_to_native(
2005 "\xff\xa0\xa0\xa0\xa0\xa0\xa2\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
1d1c12d9 2006 $UTF8_WARN_ABOVE_31_BIT, $UTF8_DISALLOW_ABOVE_31_BIT,
f9380377 2007 $UTF8_GOT_ABOVE_31_BIT,
2d0a2801
KW
2008 'utf8', 0x1000000000,
2009 $max_bytes, (isASCII) ? 1 : 7,
2b5e7bc2 2010 qr/and( is)? not portable/
2f8f112e 2011 ];
83dc0f42 2012 if (! isASCII) {
2956ebbf
KW
2013 push @tests, # These could falsely show wrongly in a naive
2014 # implementation
83dc0f42 2015 [ "requires at least 32 bits",
2956ebbf
KW
2016 I8_to_native(
2017 "\xff\xa0\xa0\xa0\xa0\xa0\xa1\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
83dc0f42 2018 $UTF8_WARN_ABOVE_31_BIT,$UTF8_DISALLOW_ABOVE_31_BIT,
f9380377 2019 $UTF8_GOT_ABOVE_31_BIT,
2d0a2801
KW
2020 'utf8', 0x800000000,
2021 $max_bytes, 7,
2b5e7bc2 2022 nonportable_regex(0x80000000)
83dc0f42
KW
2023 ],
2024 [ "requires at least 32 bits",
2956ebbf
KW
2025 I8_to_native(
2026 "\xff\xa0\xa0\xa0\xa0\xa1\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
83dc0f42 2027 $UTF8_WARN_ABOVE_31_BIT,$UTF8_DISALLOW_ABOVE_31_BIT,
f9380377 2028 $UTF8_GOT_ABOVE_31_BIT,
2d0a2801
KW
2029 'utf8', 0x10000000000,
2030 $max_bytes, 6,
2b5e7bc2 2031 nonportable_regex(0x10000000000)
83dc0f42
KW
2032 ],
2033 [ "requires at least 32 bits",
2956ebbf
KW
2034 I8_to_native(
2035 "\xff\xa0\xa0\xa0\xa1\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
83dc0f42 2036 $UTF8_WARN_ABOVE_31_BIT,$UTF8_DISALLOW_ABOVE_31_BIT,
f9380377 2037 $UTF8_GOT_ABOVE_31_BIT,
2d0a2801
KW
2038 'utf8', 0x200000000000,
2039 $max_bytes, 5,
2b5e7bc2 2040 nonportable_regex(0x20000000000)
83dc0f42
KW
2041 ],
2042 [ "requires at least 32 bits",
2956ebbf
KW
2043 I8_to_native(
2044 "\xff\xa0\xa0\xa1\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
83dc0f42 2045 $UTF8_WARN_ABOVE_31_BIT,$UTF8_DISALLOW_ABOVE_31_BIT,
f9380377 2046 $UTF8_GOT_ABOVE_31_BIT,
2d0a2801
KW
2047 'utf8', 0x4000000000000,
2048 $max_bytes, 4,
2b5e7bc2 2049 nonportable_regex(0x4000000000000)
83dc0f42
KW
2050 ],
2051 [ "requires at least 32 bits",
2956ebbf
KW
2052 I8_to_native(
2053 "\xff\xa0\xa1\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
83dc0f42 2054 $UTF8_WARN_ABOVE_31_BIT,$UTF8_DISALLOW_ABOVE_31_BIT,
f9380377 2055 $UTF8_GOT_ABOVE_31_BIT,
2d0a2801
KW
2056 'utf8', 0x80000000000000,
2057 $max_bytes, 3,
2b5e7bc2 2058 nonportable_regex(0x80000000000000)
83dc0f42
KW
2059 ],
2060 [ "requires at least 32 bits",
2956ebbf
KW
2061 I8_to_native(
2062 "\xff\xa1\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
83dc0f42 2063 $UTF8_WARN_ABOVE_31_BIT,$UTF8_DISALLOW_ABOVE_31_BIT,
f9380377 2064 $UTF8_GOT_ABOVE_31_BIT,
2d0a2801
KW
2065 'utf8', 0x1000000000000000,
2066 $max_bytes, 2,
2b5e7bc2 2067 nonportable_regex(0x1000000000000000)
83dc0f42
KW
2068 ];
2069 }
2f8f112e
KW
2070}
2071
2072foreach my $test (@tests) {
f9380377 2073 my ($testname, $bytes, $warn_flags, $disallow_flags, $expected_error_flags,
2956ebbf
KW
2074 $category, $allowed_uv, $expected_len, $needed_to_discern_len, $message
2075 ) = @$test;
eb83ed87
KW
2076
2077 my $length = length $bytes;
2b5e7bc2 2078 my $will_overflow = $testname =~ /overflow/ ? 'overflow' : "";
eb83ed87 2079
d7874298
KW
2080 {
2081 use warnings;
2082 undef @warnings;
2083 my $ret = test_isUTF8_CHAR($bytes, $length);
25e3a4e0 2084 my $ret_flags = test_isUTF8_CHAR_flags($bytes, $length, 0);
d7874298
KW
2085 if ($will_overflow) {
2086 is($ret, 0, "isUTF8_CHAR() $testname: returns 0");
25e3a4e0 2087 is($ret_flags, 0, "isUTF8_CHAR_flags() $testname: returns 0");
d7874298
KW
2088 }
2089 else {
2090 is($ret, $length,
2091 "isUTF8_CHAR() $testname: returns expected length: $length");
2956ebbf
KW
2092 is($ret_flags, $length, "isUTF8_CHAR_flags(...,0) $testname:"
2093 . " returns expected length: $length");
d7874298 2094 }
6a0eaf3d
KW
2095 is(scalar @warnings, 0,
2096 "isUTF8_CHAR() and isUTF8_CHAR()_flags $testname: generated"
2097 . " no warnings")
2098 or output_warnings(@warnings);
3d56ecbe 2099
e23e8bc1
KW
2100 undef @warnings;
2101 $ret = test_isSTRICT_UTF8_CHAR($bytes, $length);
2102 if ($will_overflow) {
2103 is($ret, 0, "isSTRICT_UTF8_CHAR() $testname: returns 0");
2104 }
2105 else {
2106 my $expected_ret = ( $testname =~ /surrogate|non-character/
2107 || $allowed_uv > 0x10FFFF)
2108 ? 0
2109 : $length;
2956ebbf
KW
2110 is($ret, $expected_ret, "isSTRICT_UTF8_CHAR() $testname: returns"
2111 . " expected length: $expected_ret");
25e3a4e0
KW
2112 $ret = test_isUTF8_CHAR_flags($bytes, $length,
2113 $UTF8_DISALLOW_ILLEGAL_INTERCHANGE);
2114 is($ret, $expected_ret,
2956ebbf
KW
2115 "isUTF8_CHAR_flags('DISALLOW_ILLEGAL_INTERCHANGE')"
2116 . " acts like isSTRICT_UTF8_CHAR");
e23e8bc1 2117 }
6a0eaf3d
KW
2118 is(scalar @warnings, 0,
2119 "isSTRICT_UTF8_CHAR() and isUTF8_CHAR_flags $testname:"
2120 . " generated no warnings")
2121 or output_warnings(@warnings);
e23e8bc1 2122
a82be82b
KW
2123 undef @warnings;
2124 $ret = test_isC9_STRICT_UTF8_CHAR($bytes, $length);
2125 if ($will_overflow) {
2126 is($ret, 0, "isC9_STRICT_UTF8_CHAR() $testname: returns 0");
2127 }
2128 else {
2129 my $expected_ret = ( $testname =~ /surrogate/
2130 || $allowed_uv > 0x10FFFF)
2131 ? 0
2132 : $length;
2956ebbf
KW
2133 is($ret, $expected_ret, "isC9_STRICT_UTF8_CHAR() $testname:"
2134 ." returns expected length: $expected_ret");
25e3a4e0
KW
2135 $ret = test_isUTF8_CHAR_flags($bytes, $length,
2136 $UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE);
2137 is($ret, $expected_ret,
2956ebbf
KW
2138 "isUTF8_CHAR_flags('DISALLOW_ILLEGAL_C9_INTERCHANGE')"
2139 . " acts like isC9_STRICT_UTF8_CHAR");
a82be82b 2140 }
6a0eaf3d
KW
2141 is(scalar @warnings, 0,
2142 "isC9_STRICT_UTF8_CHAR() and isUTF8_CHAR_flags $testname:"
2143 . " generated no warnings")
2144 or output_warnings(@warnings);
a82be82b 2145
3d56ecbe
KW
2146 # Test partial character handling, for each byte not a full character
2147 for my $j (1.. $length - 1) {
2148
2149 # Skip the test for the interaction between overflow and above-31
2150 # bit. It is really testing other things than the partial
2151 # character tests, for which other tests in this file are
2152 # sufficient
2153 last if $testname =~ /overflow/;
2154
2155 foreach my $disallow_flag (0, $disallow_flags) {
2156 my $partial = substr($bytes, 0, $j);
2157 my $ret_should_be;
2158 my $comment;
2159 if ($disallow_flag) {
2160 $ret_should_be = 0;
2161 $comment = "disallowed";
2d0a2801
KW
2162 if ($j < $needed_to_discern_len) {
2163 $ret_should_be = 1;
2956ebbf
KW
2164 $comment .= ", but need $needed_to_discern_len bytes"
2165 . " to discern:";
2d0a2801 2166 }
3d56ecbe
KW
2167 }
2168 else {
2169 $ret_should_be = 1;
2170 $comment = "allowed";
2171 }
2172
3d56ecbe
KW
2173 undef @warnings;
2174
2956ebbf
KW
2175 $ret = test_is_utf8_valid_partial_char_flags($partial, $j,
2176 $disallow_flag);
2177 is($ret, $ret_should_be,
2178 "$testname: is_utf8_valid_partial_char_flags("
3d56ecbe
KW
2179 . display_bytes($partial)
2180 . "), $comment: returns $ret_should_be");
6a0eaf3d
KW
2181 is(scalar @warnings, 0,
2182 "$testname: is_utf8_valid_partial_char_flags()"
2183 . " generated no warnings")
2184 or output_warnings(@warnings);
3d56ecbe
KW
2185 }
2186 }
d7874298
KW
2187 }
2188
eb83ed87
KW
2189 # This is more complicated than the malformations tested earlier, as there
2190 # are several orthogonal variables involved. We test all the subclasses
2191 # of utf8 warnings to verify they work with and without the utf8 class,
2192 # and don't have effects on other sublass warnings
54f4afef 2193 foreach my $warning ('utf8', 'surrogate', 'nonchar', 'non_unicode') {
b33122be
KW
2194 foreach my $warn_flag (0, $warn_flags) {
2195 foreach my $disallow_flag (0, $disallow_flags) {
2196 foreach my $do_warning (0, 1) {
2197
2198 # We try each of the above with various combinations of
2199 # malformations that can occur on the same input sequence.
2200 foreach my $short ("", "short") {
2201 foreach my $unexpected_noncont ("",
2202 "unexpected non-continuation")
2203 {
2204 foreach my $overlong ("", "overlong") {
2205
2206 # If we're already at the longest possible, we
2207 # can't create an overlong (which would be longer)
2208 # can't handle anything larger.
2209 next if $overlong && $expected_len >= $max_bytes;
2210
2211 my @malformations;
2212 my @expected_errors;
2213 push @malformations, $short if $short;
2214 push @malformations, $unexpected_noncont
2215 if $unexpected_noncont;
2216 push @malformations, $overlong if $overlong;
2217
2218 # The overflow malformation test in the input
2219 # array is coerced into being treated like one of
2220 # the others.
2221 if ($will_overflow) {
2222 push @malformations, 'overflow';
2223 push @expected_errors, $UTF8_GOT_OVERFLOW;
2224 }
2b5e7bc2 2225
b33122be
KW
2226 my $malformations_name = join "/", @malformations;
2227 $malformations_name .= " malformation"
2228 if $malformations_name;
2229 $malformations_name .= "s" if @malformations > 1;
2230 my $this_bytes = $bytes;
2231 my $this_length = $length;
2232 my $expected_uv = $allowed_uv;
2233 my $this_expected_len = $expected_len;
2234 my $this_needed_to_discern_len = $needed_to_discern_len;
2235 if ($malformations_name) {
2236 $expected_uv = 0;
2237
2238 # Coerce the input into the desired
2239 # malformation
2240 if ($malformations_name =~ /overlong/) {
2241
2242 # For an overlong, we convert the original
2243 # start byte into a continuation byte with
2244 # the same data bits as originally. ...
2245 substr($this_bytes, 0, 1)
2246 = start_byte_to_cont(substr($this_bytes,
2247 0, 1));
2248
2249 # ... Then we prepend it with a known
2250 # overlong sequence. This should evaluate
2251 # to the exact same code point as the
2252 # original.
2253 $this_bytes
2254 = I8_to_native("\xff")
2255 . (I8_to_native(chr $first_continuation)
2256 x ( $max_bytes - 1 - length($this_bytes)))
2257 . $this_bytes;
2258 $this_length = length($this_bytes);
2259 $this_needed_to_discern_len
2260 = $max_bytes - ($this_expected_len
2261 - $this_needed_to_discern_len);
2262 $this_expected_len = $max_bytes;
2263 push @expected_errors, $UTF8_GOT_LONG;
2264 }
2265 if ($malformations_name =~ /short/) {
2b5e7bc2 2266
b33122be
KW
2267 # Just tell the test to not look far
2268 # enough into the input.
2269 $this_length--;
2270 $this_expected_len--;
2271 push @expected_errors, $UTF8_GOT_SHORT;
2272 }
2273 if ($malformations_name
2274 =~ /non-continuation/)
2275 {
2276 # Change the final continuation byte into
2277 # a non one.
2278 my $pos = ($short) ? -2 : -1;
2279 substr($this_bytes, $pos, 1) = '?';
2280 $this_expected_len--;
2281 push @expected_errors,
2282 $UTF8_GOT_NON_CONTINUATION;
2283 }
2284 }
1980a0f4 2285
b33122be
KW
2286 my $eval_warn = $do_warning
2287 ? "use warnings '$warning'"
2288 : $warning eq "utf8"
2289 ? "no warnings 'utf8'"
2290 : ( "use warnings 'utf8';"
2291 . " no warnings '$warning'");
2292
2293 # Is effectively disallowed if we've set up a
2294 # malformation, even if the flag indicates it is
2295 # allowed. Fix up test name to indicate this as
2296 # well
2297 my $disallowed = $disallow_flag
2298 || $malformations_name;
2299 my $this_name = "utf8n_to_uvchr_error() $testname: "
2300 . (($disallow_flag)
2301 ? 'disallowed'
2302 : $disallowed
2303 ? $disallowed
2304 : 'allowed');
2305 $this_name .= ", $eval_warn";
2306 $this_name .= ", " . (($warn_flag)
2307 ? 'with warning flag'
2308 : 'no warning flag');
2309
2310 undef @warnings;
2311 my $ret_ref;
2312 my $display_bytes = display_bytes($this_bytes);
2313 my $call = " Call was: $eval_warn; \$ret_ref"
2314 . " = test_utf8n_to_uvchr_error("
2315 . "'$display_bytes', $this_length,"
2316 . "$warn_flag"
2317 . "|$disallow_flag)";
2318 my $eval_text = "$eval_warn; \$ret_ref"
2319 . " = test_utf8n_to_uvchr_error("
2320 . "'$this_bytes',"
2321 . " $this_length, $warn_flag"
2322 . "|$disallow_flag)";
2323 eval "$eval_text";
2324 if (! ok ("$@ eq ''",
2325 "$this_name: eval succeeded"))
2326 {
2327 diag "\$!='$!'; eval'd=\"$call\"";
2328 next;
2329 }
2330 if ($disallowed) {
6a0eaf3d
KW
2331 is($ret_ref->[0], 0, "$this_name: Returns 0")
2332 or diag $call;
b33122be
KW
2333 }
2334 else {
6a0eaf3d 2335 is($ret_ref->[0], $expected_uv,
b33122be 2336 "$this_name: Returns expected uv: "
6a0eaf3d
KW
2337 . sprintf("0x%04X", $expected_uv))
2338 or diag $call;
b33122be 2339 }
6a0eaf3d
KW
2340 is($ret_ref->[1], $this_expected_len,
2341 "$this_name: Returns expected length:"
2342 . " $this_expected_len")
2343 or diag $call;
f9380377 2344
b33122be 2345 my $errors = $ret_ref->[2];
f9380377 2346
b33122be
KW
2347 for (my $i = @expected_errors - 1; $i >= 0; $i--) {
2348 if (ok($expected_errors[$i] & $errors,
2349 "Expected and got error bit return"
2350 . " for $malformations[$i] malformation"))
2351 {
2352 $errors &= ~$expected_errors[$i];
2353 }
2354 splice @expected_errors, $i, 1;
2355 }
6a0eaf3d
KW
2356 is(scalar @expected_errors, 0,
2357 "Got all the expected malformation errors")
2358 or diag Dumper \@expected_errors;
f9380377 2359
b33122be
KW
2360 if ( $this_expected_len >= $this_needed_to_discern_len
2361 && ($warn_flag || $disallow_flag))
2362 {
6a0eaf3d
KW
2363 is($errors, $expected_error_flags,
2364 "Got the correct error flag")
2365 or diag $call;
b33122be
KW
2366 }
2367 else {
2368 is($errors, 0, "Got no other error flag");
2369 }
1980a0f4 2370
b33122be
KW
2371 if (@malformations) {
2372 if (! $do_warning && $warning eq 'utf8') {
2373 goto no_warnings_expected;
2374 }
2b5e7bc2 2375
b33122be
KW
2376 # Check that each malformation generates a
2377 # warning, removing that warning if found
2378 MALFORMATION:
2379 foreach my $malformation (@malformations) {
2380 foreach (my $i = 0; $i < @warnings; $i++) {
2381 if ($warnings[$i] =~ /$malformation/) {
2382 pass("Expected and got"
2383 . "'$malformation' warning");
2384 splice @warnings, $i, 1;
2385 next MALFORMATION;
1980a0f4
KW
2386 }
2387 }
b33122be
KW
2388 fail("Expected '$malformation' warning"
2389 . " but didn't get it");
2b5e7bc2 2390
b33122be
KW
2391 }
2392 }
2b5e7bc2 2393
b33122be
KW
2394 # Any overflow will override any super or above-31
2395 # warnings.
2396 goto no_warnings_expected
2397 if $will_overflow || $this_expected_len
2398 < $this_needed_to_discern_len;
2399
2400 if ( ! $do_warning
2401 && ( $warning eq 'utf8'
2402 || $warning eq $category))
2403 {
2404 goto no_warnings_expected;
2405 }
2406 elsif ($warn_flag) {
2407 if (is(scalar @warnings, 1,
2408 "$this_name: Got a single warning "))
2409 {
6a0eaf3d
KW
2410 like($warnings[0], $message,
2411 "$this_name: Got expected warning")
2412 or diag $call;
b33122be
KW
2413 }
2414 else {
2415 diag $call;
2416 if (scalar @warnings) {
2417 output_warnings(@warnings);
13d7a909 2418 }
b33122be
KW
2419 }
2420 }
2421 else {
2422 no_warnings_expected:
2423 unless (is(scalar @warnings, 0,
2424 "$this_name: Got no warnings"))
2425 {
2426 diag $call;
2427 output_warnings(@warnings);
2428 }
2429 }
eb83ed87 2430
b33122be
KW
2431 # Check CHECK_ONLY results when the input is
2432 # disallowed. Do this when actually disallowed,
2433 # not just when the $disallow_flag is set
2434 if ($disallowed) {
2435 undef @warnings;
2436 $ret_ref = test_utf8n_to_uvchr_error(
2437 $this_bytes, $this_length,
2438 $disallow_flag|$UTF8_CHECK_ONLY);
6a0eaf3d
KW
2439 is($ret_ref->[0], 0,
2440 "$this_name, CHECK_ONLY: Returns 0")
2441 or diag $call;
2442 is($ret_ref->[1], -1,
2443 "$this_name: CHECK_ONLY: returns -1 for length")
2444 or diag $call;
b33122be
KW
2445 if (! is(scalar @warnings, 0,
2446 "$this_name, CHECK_ONLY: no warnings"
2447 . " generated"))
2448 {
2449 diag $call;
2450 output_warnings(@warnings);
2451 }
2452 }
046d01eb 2453
b33122be
KW
2454 # Now repeat some of the above, but for
2455 # uvchr_to_utf8_flags(). Since this comes from an
2456 # existing code point, it hasn't overflowed, and
2457 # isn't malformed.
2458 next if @malformations;
2459
2460 # The warning and disallow flags passed in are for
2461 # utf8n_to_uvchr_error(). Convert them for
2462 # uvchr_to_utf8_flags().
2463 my $uvchr_warn_flag = 0;
2464 my $uvchr_disallow_flag = 0;
2465 if ($warn_flag) {
2466 if ($warn_flag == $UTF8_WARN_SURROGATE) {
2467 $uvchr_warn_flag = $UNICODE_WARN_SURROGATE
2468 }
2469 elsif ($warn_flag == $UTF8_WARN_NONCHAR) {
2470 $uvchr_warn_flag = $UNICODE_WARN_NONCHAR
2471 }
2472 elsif ($warn_flag == $UTF8_WARN_SUPER) {
2473 $uvchr_warn_flag = $UNICODE_WARN_SUPER
2474 }
2475 elsif ($warn_flag == $UTF8_WARN_ABOVE_31_BIT) {
2476 $uvchr_warn_flag
2477 = $UNICODE_WARN_ABOVE_31_BIT;
2478 }
2479 else {
2480 fail(sprintf "Unexpected warn flag: %x",
2481 $warn_flag);
2482 next;
2483 }
2484 }
2485 if ($disallow_flag) {
2486 if ($disallow_flag == $UTF8_DISALLOW_SURROGATE)
2487 {
2488 $uvchr_disallow_flag
2489 = $UNICODE_DISALLOW_SURROGATE;
2490 }
2491 elsif ($disallow_flag == $UTF8_DISALLOW_NONCHAR)
2492 {
2493 $uvchr_disallow_flag
2494 = $UNICODE_DISALLOW_NONCHAR;
2495 }
2496 elsif ($disallow_flag == $UTF8_DISALLOW_SUPER) {
2497 $uvchr_disallow_flag
2498 = $UNICODE_DISALLOW_SUPER;
2499 }
2500 elsif ($disallow_flag
2501 == $UTF8_DISALLOW_ABOVE_31_BIT)
2502 {
2503 $uvchr_disallow_flag =
2504 $UNICODE_DISALLOW_ABOVE_31_BIT;
2505 }
2506 else {
2507 fail(sprintf "Unexpected disallow flag: %x",
2508 $disallow_flag);
2509 next;
2510 }
2511 }
046d01eb 2512
b33122be
KW
2513 $disallowed = $uvchr_disallow_flag;
2514
2515 $this_name = "uvchr_to_utf8_flags() $testname: "
2516 . (($uvchr_disallow_flag)
2517 ? 'disallowed'
2518 : ($disallowed)
2519 ? 'ABOVE_31_BIT allowed'
2520 : 'allowed');
2521 $this_name .= ", $eval_warn";
2522 $this_name .= ", " . (($uvchr_warn_flag)
2523 ? 'with warning flag'
2524 : 'no warning flag');
2525
2526 undef @warnings;
2527 my $ret;
2528 my $warn_flag = sprintf "0x%x", $uvchr_warn_flag;
2529 my $disallow_flag = sprintf "0x%x",
2530 $uvchr_disallow_flag;
2531 $call = sprintf(" Call was: $eval_warn; \$ret"
2532 . " = test_uvchr_to_utf8_flags("
2533 . " 0x%x, $warn_flag|$disallow_flag)",
2534 $allowed_uv);
2535 $eval_text = "$eval_warn; \$ret ="
2536 . " test_uvchr_to_utf8_flags("
2537 . "$allowed_uv, $warn_flag|"
2538 . "$disallow_flag)";
2539 eval "$eval_text";
2540 if (! ok ("$@ eq ''", "$this_name: eval succeeded"))
2541 {
2542 diag "\$!='$!'; eval'd=\"$eval_text\"";
2543 next;
2544 }
2545 if ($disallowed) {
6a0eaf3d
KW
2546 is($ret, undef, "$this_name: Returns undef")
2547 or diag $call;
b33122be
KW
2548 }
2549 else {
6a0eaf3d
KW
2550 is($ret, $bytes, "$this_name: Returns expected string")
2551 or diag $call;
b33122be
KW
2552 }
2553 if (! $do_warning
2554 && ($warning eq 'utf8' || $warning eq $category))
2555 {
2556 if (!is(scalar @warnings, 0,
2557 "$this_name: No warnings generated"))
2558 {
2559 diag $call;
2560 output_warnings(@warnings);
2561 }
2562 }
2563 elsif ( $uvchr_warn_flag
2564 && ( $warning eq 'utf8'
2565 || $warning eq $category))
2566 {
2567 if (is(scalar @warnings, 1,
2568 "$this_name: Got a single warning "))
2569 {
6a0eaf3d
KW
2570 like($warnings[0], $message,
2571 "$this_name: Got expected warning")
2572 or diag $call;
2b5e7bc2 2573 }
b33122be
KW
2574 else {
2575 diag $call;
2576 output_warnings(@warnings)
2577 if scalar @warnings;
2578 }
e308b348 2579 }
eb83ed87 2580 }
b33122be 2581 }
eb83ed87 2582 }
b33122be 2583 }
eb83ed87 2584 }
b33122be 2585 }
eb83ed87
KW
2586 }
2587}
6e3d6c02 2588
65df57a8
TC
2589SKIP:
2590{
2591 isASCII
2592 or skip "These tests probably break on non-ASCII", 1;
2593 my $simple = join "", "A" .. "J";
2594 my $utf_ch = "\x{7fffffff}";
2595 utf8::encode($utf_ch);
2596 my $utf_ch_len = length $utf_ch;
2597 note "utf_ch_len $utf_ch_len";
2598 my $utf = $utf_ch x 10;
2599 my $bad_start = substr($utf, 1);
2600 # $bad_end ends with a start byte and a single continuation
2601 my $bad_end = substr($utf, 0, length($utf)-$utf_ch_len+2);
2602
2603 # WARNING: all offsets are *byte* offsets
2604 my @hop_tests =
2605 (
2606 # string s off expected name
2607 [ $simple, 0, 5, 5, "simple in range, forward" ],
2608 [ $simple, 10, -5, 5, "simple in range, backward" ],
2609 [ $simple, 5, 10, 10, "simple out of range, forward" ],
2610 [ $simple, 5, -10, 0, "simple out of range, backward" ],
2611 [ $utf, $utf_ch_len * 5, 5, length($utf), "utf in range, forward" ],
2612 [ $utf, $utf_ch_len * 5, -5, 0, "utf in range, backward" ],
2613 [ $utf, $utf_ch_len * 5, 4, $utf_ch_len * 9, "utf in range b, forward" ],
2614 [ $utf, $utf_ch_len * 5, -4, $utf_ch_len, "utf in range b, backward" ],
2615 [ $utf, $utf_ch_len * 5, 6, length($utf), "utf out of range, forward" ],
2616 [ $utf, $utf_ch_len * 5, -6, 0, "utf out of range, backward" ],
2617 [ $bad_start, 0, 1, 1, "bad start, forward 1 from 0" ],
2618 [ $bad_start, 0, $utf_ch_len-1, $utf_ch_len-1, "bad start, forward ch_len-1 from 0" ],
2619 [ $bad_start, 0, $utf_ch_len, $utf_ch_len*2-1, "bad start, forward ch_len from 0" ],
2620 [ $bad_start, $utf_ch_len-1, -1, 0, "bad start, back 1 from first start byte" ],
2621 [ $bad_start, $utf_ch_len-2, -1, 0, "bad start, back 1 from before first start byte" ],
2622 [ $bad_start, 0, -1, 0, "bad start, back 1 from 0" ],
2623 [ $bad_start, length $bad_start, -10, 0, "bad start, back 10 from end" ],
2624 [ $bad_end, 0, 10, length $bad_end, "bad end, forward 10 from 0" ],
2625 [ $bad_end, length($bad_end)-1, 10, length $bad_end, "bad end, forward 1 from end-1" ],
2626 );
2627
2628 for my $test (@hop_tests) {
2629 my ($str, $s_off, $off, $want, $name) = @$test;
2630 my $result = test_utf8_hop_safe($str, $s_off, $off);
2631 is($result, $want, "utf8_hop_safe: $name");
2632 }
2633}
2634
fed3ba5d 2635done_testing;