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