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