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