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