This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
APItest/t: Change some variable names
[perl5.git] / ext / XS-APItest / t / utf8.t
CommitLineData
fed3ba5d
NC
1#!perl -w
2
3use strict;
4use Test::More;
5d4414ef 5
6aa905cf
KW
6# This file tests various functions and macros in the API related to UTF-8.
7
5d4414ef
KW
8BEGIN {
9 use_ok('XS::APItest');
10 require 'charset_tools.pl';
6aa905cf 11 require './t/utf8_setup.pl';
5d4414ef
KW
12};
13
7dfd8446 14$|=1;
fed3ba5d 15
760c7c2f
KW
16no warnings 'deprecated'; # Some of the below are above IV_MAX on 32 bit
17 # machines, and that is tested elsewhere
18
fed3ba5d 19use XS::APItest;
4deba822 20
6aa905cf 21my $pound_sign = chr utf8::unicode_to_native(163);
d84e92aa 22
7dfd8446
KW
23# This test file can't use byte_utf8a_to_utf8n() from t/charset_tools.pl
24# because that uses the same functions we are testing here. So UTF-EBCDIC
5d4414ef
KW
25# strings are hard-coded as I8 strings in this file instead, and we use the
26# translation functions to/from I8 from that file instead.
418080dc 27
046d01eb 28my $look_for_everything_utf8n_to
6aa905cf
KW
29 = $::UTF8_DISALLOW_SURROGATE
30 | $::UTF8_WARN_SURROGATE
31 | $::UTF8_DISALLOW_NONCHAR
32 | $::UTF8_WARN_NONCHAR
33 | $::UTF8_DISALLOW_SUPER
34 | $::UTF8_WARN_SUPER
35 | $::UTF8_DISALLOW_ABOVE_31_BIT
36 | $::UTF8_WARN_ABOVE_31_BIT;
046d01eb 37my $look_for_everything_uvchr_to
6aa905cf
KW
38 = $::UNICODE_DISALLOW_SURROGATE
39 | $::UNICODE_WARN_SURROGATE
40 | $::UNICODE_DISALLOW_NONCHAR
41 | $::UNICODE_WARN_NONCHAR
42 | $::UNICODE_DISALLOW_SUPER
43 | $::UNICODE_WARN_SUPER
44 | $::UNICODE_DISALLOW_ABOVE_31_BIT
45 | $::UNICODE_WARN_ABOVE_31_BIT;
7dfd8446 46
fed3ba5d
NC
47foreach ([0, '', '', 'empty'],
48 [0, 'N', 'N', '1 char'],
49 [1, 'NN', 'N', '1 char substring'],
50 [-2, 'Perl', 'Rules', 'different'],
4deba822 51 [0, $pound_sign, $pound_sign, 'pound sign'],
2956ebbf
KW
52 [1, $pound_sign . 10, $pound_sign . 1,
53 '10 pounds is more than 1 pound'],
54 [1, $pound_sign . $pound_sign, $pound_sign,
55 '2 pound signs are more than 1'],
fed3ba5d
NC
56 [-2, ' $!', " \x{1F42B}!", 'Camels are worth more than 1 dollar'],
57 [-1, '!', "!\x{1F42A}", 'Initial substrings match'],
58 ) {
59 my ($expect, $left, $right, $desc) = @$_;
60 my $copy = $right;
61 utf8::encode($copy);
62 is(bytes_cmp_utf8($left, $copy), $expect, $desc);
63 next if $right =~ tr/\0-\377//c;
64 utf8::encode($left);
65 is(bytes_cmp_utf8($right, $left), -$expect, "$desc reversed");
66}
67
7dfd8446
KW
68# The keys to this hash are Unicode code points, their values are the native
69# UTF-8 representations of them. The code points are chosen because they are
70# "interesting" on either or both ASCII and EBCDIC platforms. First we add
71# boundaries where the number of bytes required to represent them increase, or
72# are adjacent to problematic code points, so we want to make sure they aren't
73# considered problematic.
74my %code_points = (
75 0x0100 => (isASCII) ? "\xc4\x80" : I8_to_native("\xc8\xa0"),
76 0x0400 - 1 => (isASCII) ? "\xcf\xbf" : I8_to_native("\xdf\xbf"),
77 0x0400 => (isASCII) ? "\xd0\x80" : I8_to_native("\xe1\xa0\xa0"),
78 0x0800 - 1 => (isASCII) ? "\xdf\xbf" : I8_to_native("\xe1\xbf\xbf"),
79 0x0800 => (isASCII) ? "\xe0\xa0\x80" : I8_to_native("\xe2\xa0\xa0"),
80 0x4000 - 1 => (isASCII) ? "\xe3\xbf\xbf" : I8_to_native("\xef\xbf\xbf"),
81 0x4000 => (isASCII) ? "\xe4\x80\x80" : I8_to_native("\xf0\xb0\xa0\xa0"),
82 0x8000 - 1 => (isASCII) ? "\xe7\xbf\xbf" : I8_to_native("\xf0\xbf\xbf\xbf"),
83
84 # First code point that the implementation of isUTF8_POSSIBLY_PROBLEMATIC,
85 # as of this writing, considers potentially problematic on EBCDIC
86 0x8000 => (isASCII) ? "\xe8\x80\x80" : I8_to_native("\xf1\xa0\xa0\xa0"),
87
88 0xD000 - 1 => (isASCII) ? "\xec\xbf\xbf" : I8_to_native("\xf1\xb3\xbf\xbf"),
89
90 # First code point that the implementation of isUTF8_POSSIBLY_PROBLEMATIC,
91 # as of this writing, considers potentially problematic on ASCII
92 0xD000 => (isASCII) ? "\xed\x80\x80" : I8_to_native("\xf1\xb4\xa0\xa0"),
93
5f8a3d1d 94 # Bracket the surrogates, and include several surrogates
2956ebbf
KW
95 0xD7FF => (isASCII) ? "\xed\x9f\xbf" : I8_to_native("\xf1\xb5\xbf\xbf"),
96 0xD800 => (isASCII) ? "\xed\xa0\x80" : I8_to_native("\xf1\xb6\xa0\xa0"),
97 0xDC00 => (isASCII) ? "\xed\xb0\x80" : I8_to_native("\xf1\xb7\xa0\xa0"),
98 0xDFFF => (isASCII) ? "\xee\x80\x80" : I8_to_native("\xf1\xb8\xa0\xa0"),
99 0xDFFF => (isASCII) ? "\xed\xbf\xbf" : I8_to_native("\xf1\xb7\xbf\xbf"),
100 0xE000 => (isASCII) ? "\xee\x80\x80" : I8_to_native("\xf1\xb8\xa0\xa0"),
7dfd8446 101
5f8a3d1d 102 # Include the 32 contiguous non characters, and surrounding code points
2956ebbf
KW
103 0xFDCF => (isASCII) ? "\xef\xb7\x8f" : I8_to_native("\xf1\xbf\xae\xaf"),
104 0xFDD0 => (isASCII) ? "\xef\xb7\x90" : I8_to_native("\xf1\xbf\xae\xb0"),
105 0xFDD1 => (isASCII) ? "\xef\xb7\x91" : I8_to_native("\xf1\xbf\xae\xb1"),
106 0xFDD2 => (isASCII) ? "\xef\xb7\x92" : I8_to_native("\xf1\xbf\xae\xb2"),
107 0xFDD3 => (isASCII) ? "\xef\xb7\x93" : I8_to_native("\xf1\xbf\xae\xb3"),
108 0xFDD4 => (isASCII) ? "\xef\xb7\x94" : I8_to_native("\xf1\xbf\xae\xb4"),
109 0xFDD5 => (isASCII) ? "\xef\xb7\x95" : I8_to_native("\xf1\xbf\xae\xb5"),
110 0xFDD6 => (isASCII) ? "\xef\xb7\x96" : I8_to_native("\xf1\xbf\xae\xb6"),
111 0xFDD7 => (isASCII) ? "\xef\xb7\x97" : I8_to_native("\xf1\xbf\xae\xb7"),
112 0xFDD8 => (isASCII) ? "\xef\xb7\x98" : I8_to_native("\xf1\xbf\xae\xb8"),
113 0xFDD9 => (isASCII) ? "\xef\xb7\x99" : I8_to_native("\xf1\xbf\xae\xb9"),
114 0xFDDA => (isASCII) ? "\xef\xb7\x9a" : I8_to_native("\xf1\xbf\xae\xba"),
115 0xFDDB => (isASCII) ? "\xef\xb7\x9b" : I8_to_native("\xf1\xbf\xae\xbb"),
116 0xFDDC => (isASCII) ? "\xef\xb7\x9c" : I8_to_native("\xf1\xbf\xae\xbc"),
117 0xFDDD => (isASCII) ? "\xef\xb7\x9d" : I8_to_native("\xf1\xbf\xae\xbd"),
118 0xFDDE => (isASCII) ? "\xef\xb7\x9e" : I8_to_native("\xf1\xbf\xae\xbe"),
119 0xFDDF => (isASCII) ? "\xef\xb7\x9f" : I8_to_native("\xf1\xbf\xae\xbf"),
120 0xFDE0 => (isASCII) ? "\xef\xb7\xa0" : I8_to_native("\xf1\xbf\xaf\xa0"),
121 0xFDE1 => (isASCII) ? "\xef\xb7\xa1" : I8_to_native("\xf1\xbf\xaf\xa1"),
122 0xFDE2 => (isASCII) ? "\xef\xb7\xa2" : I8_to_native("\xf1\xbf\xaf\xa2"),
123 0xFDE3 => (isASCII) ? "\xef\xb7\xa3" : I8_to_native("\xf1\xbf\xaf\xa3"),
124 0xFDE4 => (isASCII) ? "\xef\xb7\xa4" : I8_to_native("\xf1\xbf\xaf\xa4"),
125 0xFDE5 => (isASCII) ? "\xef\xb7\xa5" : I8_to_native("\xf1\xbf\xaf\xa5"),
126 0xFDE6 => (isASCII) ? "\xef\xb7\xa6" : I8_to_native("\xf1\xbf\xaf\xa6"),
127 0xFDE7 => (isASCII) ? "\xef\xb7\xa7" : I8_to_native("\xf1\xbf\xaf\xa7"),
128 0xFDE8 => (isASCII) ? "\xef\xb7\xa8" : I8_to_native("\xf1\xbf\xaf\xa8"),
129 0xFDEa => (isASCII) ? "\xef\xb7\x99" : I8_to_native("\xf1\xbf\xaf\xa9"),
130 0xFDEA => (isASCII) ? "\xef\xb7\xaa" : I8_to_native("\xf1\xbf\xaf\xaa"),
131 0xFDEB => (isASCII) ? "\xef\xb7\xab" : I8_to_native("\xf1\xbf\xaf\xab"),
132 0xFDEC => (isASCII) ? "\xef\xb7\xac" : I8_to_native("\xf1\xbf\xaf\xac"),
133 0xFDED => (isASCII) ? "\xef\xb7\xad" : I8_to_native("\xf1\xbf\xaf\xad"),
134 0xFDEE => (isASCII) ? "\xef\xb7\xae" : I8_to_native("\xf1\xbf\xaf\xae"),
135 0xFDEF => (isASCII) ? "\xef\xb7\xaf" : I8_to_native("\xf1\xbf\xaf\xaf"),
136 0xFDF0 => (isASCII) ? "\xef\xb7\xb0" : I8_to_native("\xf1\xbf\xaf\xb0"),
7dfd8446 137
5f8a3d1d 138 # Mostly around non-characters, but some are transitions to longer strings
2956ebbf
KW
139 0xFFFD => (isASCII) ? "\xef\xbf\xbd" : I8_to_native("\xf1\xbf\xbf\xbd"),
140 0x10000 - 1 => (isASCII)
141 ? "\xef\xbf\xbf"
142 : I8_to_native("\xf1\xbf\xbf\xbf"),
143 0x10000 => (isASCII)
144 ? "\xf0\x90\x80\x80"
145 : I8_to_native("\xf2\xa0\xa0\xa0"),
146 0x1FFFD => (isASCII)
147 ? "\xf0\x9f\xbf\xbd"
148 : I8_to_native("\xf3\xbf\xbf\xbd"),
149 0x1FFFE => (isASCII)
150 ? "\xf0\x9f\xbf\xbe"
151 : I8_to_native("\xf3\xbf\xbf\xbe"),
152 0x1FFFF => (isASCII)
153 ? "\xf0\x9f\xbf\xbf"
154 : I8_to_native("\xf3\xbf\xbf\xbf"),
155 0x20000 => (isASCII)
156 ? "\xf0\xa0\x80\x80"
157 : I8_to_native("\xf4\xa0\xa0\xa0"),
158 0x2FFFD => (isASCII)
159 ? "\xf0\xaf\xbf\xbd"
160 : I8_to_native("\xf5\xbf\xbf\xbd"),
161 0x2FFFE => (isASCII)
162 ? "\xf0\xaf\xbf\xbe"
163 : I8_to_native("\xf5\xbf\xbf\xbe"),
164 0x2FFFF => (isASCII)
165 ? "\xf0\xaf\xbf\xbf"
166 : I8_to_native("\xf5\xbf\xbf\xbf"),
167 0x30000 => (isASCII)
168 ? "\xf0\xb0\x80\x80"
169 : I8_to_native("\xf6\xa0\xa0\xa0"),
170 0x3FFFD => (isASCII)
171 ? "\xf0\xbf\xbf\xbd"
172 : I8_to_native("\xf7\xbf\xbf\xbd"),
173 0x3FFFE => (isASCII)
174 ? "\xf0\xbf\xbf\xbe"
175 : I8_to_native("\xf7\xbf\xbf\xbe"),
176 0x40000 - 1 => (isASCII)
177 ? "\xf0\xbf\xbf\xbf"
178 : I8_to_native("\xf7\xbf\xbf\xbf"),
179 0x40000 => (isASCII)
180 ? "\xf1\x80\x80\x80"
181 : I8_to_native("\xf8\xa8\xa0\xa0\xa0"),
182 0x4FFFD => (isASCII)
183 ? "\xf1\x8f\xbf\xbd"
184 : I8_to_native("\xf8\xa9\xbf\xbf\xbd"),
185 0x4FFFE => (isASCII)
186 ? "\xf1\x8f\xbf\xbe"
187 : I8_to_native("\xf8\xa9\xbf\xbf\xbe"),
188 0x4FFFF => (isASCII)
189 ? "\xf1\x8f\xbf\xbf"
190 : I8_to_native("\xf8\xa9\xbf\xbf\xbf"),
191 0x50000 => (isASCII)
192 ? "\xf1\x90\x80\x80"
193 : I8_to_native("\xf8\xaa\xa0\xa0\xa0"),
194 0x5FFFD => (isASCII)
195 ? "\xf1\x9f\xbf\xbd"
196 : I8_to_native("\xf8\xab\xbf\xbf\xbd"),
197 0x5FFFE => (isASCII)
198 ? "\xf1\x9f\xbf\xbe"
199 : I8_to_native("\xf8\xab\xbf\xbf\xbe"),
200 0x5FFFF => (isASCII)
201 ? "\xf1\x9f\xbf\xbf"
202 : I8_to_native("\xf8\xab\xbf\xbf\xbf"),
203 0x60000 => (isASCII)
204 ? "\xf1\xa0\x80\x80"
205 : I8_to_native("\xf8\xac\xa0\xa0\xa0"),
206 0x6FFFD => (isASCII)
207 ? "\xf1\xaf\xbf\xbd"
208 : I8_to_native("\xf8\xad\xbf\xbf\xbd"),
209 0x6FFFE => (isASCII)
210 ? "\xf1\xaf\xbf\xbe"
211 : I8_to_native("\xf8\xad\xbf\xbf\xbe"),
212 0x6FFFF => (isASCII)
213 ? "\xf1\xaf\xbf\xbf"
214 : I8_to_native("\xf8\xad\xbf\xbf\xbf"),
215 0x70000 => (isASCII)
216 ? "\xf1\xb0\x80\x80"
217 : I8_to_native("\xf8\xae\xa0\xa0\xa0"),
218 0x7FFFD => (isASCII)
219 ? "\xf1\xbf\xbf\xbd"
220 : I8_to_native("\xf8\xaf\xbf\xbf\xbd"),
221 0x7FFFE => (isASCII)
222 ? "\xf1\xbf\xbf\xbe"
223 : I8_to_native("\xf8\xaf\xbf\xbf\xbe"),
224 0x7FFFF => (isASCII)
225 ? "\xf1\xbf\xbf\xbf"
226 : I8_to_native("\xf8\xaf\xbf\xbf\xbf"),
227 0x80000 => (isASCII)
228 ? "\xf2\x80\x80\x80"
229 : I8_to_native("\xf8\xb0\xa0\xa0\xa0"),
230 0x8FFFD => (isASCII)
231 ? "\xf2\x8f\xbf\xbd"
232 : I8_to_native("\xf8\xb1\xbf\xbf\xbd"),
233 0x8FFFE => (isASCII)
234 ? "\xf2\x8f\xbf\xbe"
235 : I8_to_native("\xf8\xb1\xbf\xbf\xbe"),
236 0x8FFFF => (isASCII)
237 ? "\xf2\x8f\xbf\xbf"
238 : I8_to_native("\xf8\xb1\xbf\xbf\xbf"),
239 0x90000 => (isASCII)
240 ? "\xf2\x90\x80\x80"
241 : I8_to_native("\xf8\xb2\xa0\xa0\xa0"),
242 0x9FFFD => (isASCII)
243 ? "\xf2\x9f\xbf\xbd"
244 : I8_to_native("\xf8\xb3\xbf\xbf\xbd"),
245 0x9FFFE => (isASCII)
246 ? "\xf2\x9f\xbf\xbe"
247 : I8_to_native("\xf8\xb3\xbf\xbf\xbe"),
248 0x9FFFF => (isASCII)
249 ? "\xf2\x9f\xbf\xbf"
250 : I8_to_native("\xf8\xb3\xbf\xbf\xbf"),
251 0xA0000 => (isASCII)
252 ? "\xf2\xa0\x80\x80"
253 : I8_to_native("\xf8\xb4\xa0\xa0\xa0"),
254 0xAFFFD => (isASCII)
255 ? "\xf2\xaf\xbf\xbd"
256 : I8_to_native("\xf8\xb5\xbf\xbf\xbd"),
257 0xAFFFE => (isASCII)
258 ? "\xf2\xaf\xbf\xbe"
259 : I8_to_native("\xf8\xb5\xbf\xbf\xbe"),
260 0xAFFFF => (isASCII)
261 ? "\xf2\xaf\xbf\xbf"
262 : I8_to_native("\xf8\xb5\xbf\xbf\xbf"),
263 0xB0000 => (isASCII)
264 ? "\xf2\xb0\x80\x80"
265 : I8_to_native("\xf8\xb6\xa0\xa0\xa0"),
266 0xBFFFD => (isASCII)
267 ? "\xf2\xbf\xbf\xbd"
268 : I8_to_native("\xf8\xb7\xbf\xbf\xbd"),
269 0xBFFFE => (isASCII)
270 ? "\xf2\xbf\xbf\xbe"
271 : I8_to_native("\xf8\xb7\xbf\xbf\xbe"),
272 0xBFFFF => (isASCII)
273 ? "\xf2\xbf\xbf\xbf"
274 : I8_to_native("\xf8\xb7\xbf\xbf\xbf"),
275 0xC0000 => (isASCII)
276 ? "\xf3\x80\x80\x80"
277 : I8_to_native("\xf8\xb8\xa0\xa0\xa0"),
278 0xCFFFD => (isASCII)
279 ? "\xf3\x8f\xbf\xbd"
280 : I8_to_native("\xf8\xb9\xbf\xbf\xbd"),
281 0xCFFFE => (isASCII)
282 ? "\xf3\x8f\xbf\xbe"
283 : I8_to_native("\xf8\xb9\xbf\xbf\xbe"),
284 0xCFFFF => (isASCII)
285 ? "\xf3\x8f\xbf\xbf"
286 : I8_to_native("\xf8\xb9\xbf\xbf\xbf"),
287 0xD0000 => (isASCII)
288 ? "\xf3\x90\x80\x80"
289 : I8_to_native("\xf8\xba\xa0\xa0\xa0"),
290 0xDFFFD => (isASCII)
291 ? "\xf3\x9f\xbf\xbd"
292 : I8_to_native("\xf8\xbb\xbf\xbf\xbd"),
293 0xDFFFE => (isASCII)
294 ? "\xf3\x9f\xbf\xbe"
295 : I8_to_native("\xf8\xbb\xbf\xbf\xbe"),
296 0xDFFFF => (isASCII)
297 ? "\xf3\x9f\xbf\xbf"
298 : I8_to_native("\xf8\xbb\xbf\xbf\xbf"),
299 0xE0000 => (isASCII)
300 ? "\xf3\xa0\x80\x80"
301 : I8_to_native("\xf8\xbc\xa0\xa0\xa0"),
302 0xEFFFD => (isASCII)
303 ? "\xf3\xaf\xbf\xbd"
304 : I8_to_native("\xf8\xbd\xbf\xbf\xbd"),
305 0xEFFFE => (isASCII)
306 ? "\xf3\xaf\xbf\xbe"
307 : I8_to_native("\xf8\xbd\xbf\xbf\xbe"),
308 0xEFFFF => (isASCII)
309 ? "\xf3\xaf\xbf\xbf"
310 : I8_to_native("\xf8\xbd\xbf\xbf\xbf"),
311 0xF0000 => (isASCII)
312 ? "\xf3\xb0\x80\x80"
313 : I8_to_native("\xf8\xbe\xa0\xa0\xa0"),
314 0xFFFFD => (isASCII)
315 ? "\xf3\xbf\xbf\xbd"
316 : I8_to_native("\xf8\xbf\xbf\xbf\xbd"),
317 0xFFFFE => (isASCII)
318 ? "\xf3\xbf\xbf\xbe"
319 : I8_to_native("\xf8\xbf\xbf\xbf\xbe"),
320 0xFFFFF => (isASCII)
321 ? "\xf3\xbf\xbf\xbf"
322 : I8_to_native("\xf8\xbf\xbf\xbf\xbf"),
323 0x100000 => (isASCII)
324 ? "\xf4\x80\x80\x80"
325 : I8_to_native("\xf9\xa0\xa0\xa0\xa0"),
326 0x10FFFD => (isASCII)
327 ? "\xf4\x8f\xbf\xbd"
328 : I8_to_native("\xf9\xa1\xbf\xbf\xbd"),
329 0x10FFFE => (isASCII)
330 ? "\xf4\x8f\xbf\xbe"
331 : I8_to_native("\xf9\xa1\xbf\xbf\xbe"),
332 0x10FFFF => (isASCII)
333 ? "\xf4\x8f\xbf\xbf"
334 : I8_to_native("\xf9\xa1\xbf\xbf\xbf"),
335 0x110000 => (isASCII)
336 ? "\xf4\x90\x80\x80"
337 : I8_to_native("\xf9\xa2\xa0\xa0\xa0"),
7dfd8446
KW
338
339 # Things that would be noncharacters if they were in Unicode, and might be
340 # mistaken, if the C code is bad, to be nonchars
2956ebbf
KW
341 0x11FFFE => (isASCII)
342 ? "\xf4\x9f\xbf\xbe"
343 : I8_to_native("\xf9\xa3\xbf\xbf\xbe"),
344 0x11FFFF => (isASCII)
345 ? "\xf4\x9f\xbf\xbf"
346 : I8_to_native("\xf9\xa3\xbf\xbf\xbf"),
347 0x20FFFE => (isASCII)
348 ? "\xf8\x88\x8f\xbf\xbe"
349 : I8_to_native("\xfa\xa1\xbf\xbf\xbe"),
350 0x20FFFF => (isASCII)
351 ? "\xf8\x88\x8f\xbf\xbf"
352 : I8_to_native("\xfa\xa1\xbf\xbf\xbf"),
353
354 0x200000 - 1 => (isASCII)
355 ? "\xf7\xbf\xbf\xbf"
356 : I8_to_native("\xf9\xbf\xbf\xbf\xbf"),
357 0x200000 => (isASCII)
358 ? "\xf8\x88\x80\x80\x80"
359 : I8_to_native("\xfa\xa0\xa0\xa0\xa0"),
360 0x400000 - 1 => (isASCII)
361 ? "\xf8\x8f\xbf\xbf\xbf"
362 : I8_to_native("\xfb\xbf\xbf\xbf\xbf"),
363 0x400000 => (isASCII)
364 ? "\xf8\x90\x80\x80\x80"
365 : I8_to_native("\xfc\xa4\xa0\xa0\xa0\xa0"),
366 0x4000000 - 1 => (isASCII)
367 ? "\xfb\xbf\xbf\xbf\xbf"
368 : I8_to_native("\xfd\xbf\xbf\xbf\xbf\xbf"),
369 0x4000000 => (isASCII)
370 ? "\xfc\x84\x80\x80\x80\x80"
371 : I8_to_native("\xfe\xa2\xa0\xa0\xa0\xa0\xa0"),
372 0x4000000 - 1 => (isASCII)
373 ? "\xfb\xbf\xbf\xbf\xbf"
374 : I8_to_native("\xfd\xbf\xbf\xbf\xbf\xbf"),
375 0x4000000 => (isASCII)
376 ? "\xfc\x84\x80\x80\x80\x80"
377 : I8_to_native("\xfe\xa2\xa0\xa0\xa0\xa0\xa0"),
378 0x40000000 - 1 => (isASCII)
379 ? "\xfc\xbf\xbf\xbf\xbf\xbf"
380 : I8_to_native("\xfe\xbf\xbf\xbf\xbf\xbf\xbf"),
381 0x40000000 =>
382 (isASCII) ? "\xfd\x80\x80\x80\x80\x80"
383 : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa1\xa0\xa0\xa0\xa0\xa0\xa0"),
76513bdc
KW
384 0x80000000 - 1 =>
385 (isASCII) ? "\xfd\xbf\xbf\xbf\xbf\xbf"
386 : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa1\xbf\xbf\xbf\xbf\xbf\xbf"),
387 0x80000000 =>
388 (isASCII) ? "\xfe\x82\x80\x80\x80\x80\x80"
389 : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa2\xa0\xa0\xa0\xa0\xa0\xa0"),
390 0xFFFFFFFF =>
391 (isASCII) ? "\xfe\x83\xbf\xbf\xbf\xbf\xbf"
392 : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa3\xbf\xbf\xbf\xbf\xbf\xbf"),
7dfd8446 393);
4deba822 394
6aa905cf 395if ($::is64bit) {
7dfd8446 396 no warnings qw(overflow portable);
2956ebbf
KW
397 $code_points{0x100000000}
398 = (isASCII)
399 ? "\xfe\x84\x80\x80\x80\x80\x80"
400 : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa4\xa0\xa0\xa0\xa0\xa0\xa0");
401 $code_points{0x1000000000 - 1}
402 = (isASCII)
403 ? "\xfe\xbf\xbf\xbf\xbf\xbf\xbf"
404 : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa1\xbf\xbf\xbf\xbf\xbf\xbf\xbf");
405 $code_points{0x1000000000}
406 = (isASCII)
407 ? "\xff\x80\x80\x80\x80\x80\x81\x80\x80\x80\x80\x80\x80"
408 : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa2\xa0\xa0\xa0\xa0\xa0\xa0\xa0");
76513bdc
KW
409 $code_points{0xFFFFFFFFFFFFFFFF}
410 = (isASCII)
411 ? "\xff\x80\x8f\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf"
412 : I8_to_native("\xff\xaf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf");
2956ebbf
KW
413 if (isASCII) { # These could falsely show as overlongs in a naive
414 # implementation
415 $code_points{0x40000000000}
416 = "\xff\x80\x80\x80\x80\x81\x80\x80\x80\x80\x80\x80\x80";
417 $code_points{0x1000000000000}
418 = "\xff\x80\x80\x80\x81\x80\x80\x80\x80\x80\x80\x80\x80";
419 $code_points{0x40000000000000}
420 = "\xff\x80\x80\x81\x80\x80\x80\x80\x80\x80\x80\x80\x80";
421 $code_points{0x1000000000000000}
422 = "\xff\x80\x81\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80";
d566bd20 423 # overflows
2956ebbf
KW
424 #$code_points{0xfoo}
425 # = "\xff\x81\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80";
d566bd20
KW
426 }
427}
2956ebbf
KW
428elsif (! isASCII) { # 32-bit EBCDIC. 64-bit is clearer to handle, so doesn't
429 # need this test case
d566bd20 430 no warnings qw(overflow portable);
2956ebbf
KW
431 $code_points{0x40000000} = I8_to_native(
432 "\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa1\xa0\xa0\xa0\xa0\xa0\xa0");
7dfd8446 433}
eb83ed87 434
7dfd8446
KW
435# Now add in entries for each of code points 0-255, which require special
436# handling on EBCDIC. Remember the keys are Unicode values, and the values
437# are the native UTF-8. For invariants, the bytes are just the native chr.
438
439my $cp = 0;
440while ($cp < ((isASCII) ? 128 : 160)) { # This is from the definition of
441 # invariant
442 $code_points{$cp} = chr utf8::unicode_to_native($cp);
443 $cp++;
444}
445
446# Done with the invariants. Now do the variants. All in this range are 2
447# byte. Again, we can't use the internal functions to generate UTF-8, as
448# those are what we are trying to test. In the loop, we know what range the
449# continuation bytes can be in, and what the lowest start byte can be. So we
450# cycle through them.
451
dbb8d798 452my $highest_continuation = 0xBF;
7dfd8446
KW
453my $start = (isASCII) ? 0xC2 : 0xC5;
454
dbb8d798 455my $continuation = $::lowest_continuation - 1;
7dfd8446
KW
456
457while ($cp < 255) {
dbb8d798 458 if (++$continuation > $highest_continuation) {
7dfd8446
KW
459
460 # Wrap to the next start byte when we reach the final continuation
461 # byte possible
dbb8d798 462 $continuation = $::lowest_continuation;
7dfd8446
KW
463 $start++;
464 }
465 $code_points{$cp} = I8_to_native(chr($start) . chr($continuation));
466
467 $cp++;
468}
eb83ed87
KW
469
470my @warnings;
471
472use warnings 'utf8';
473local $SIG{__WARN__} = sub { push @warnings, @_ };
474
9f2abfde
KW
475my %restriction_types;
476
477$restriction_types{""}{'valid_strings'} = "";
478$restriction_types{"c9strict"}{'valid_strings'} = "";
479$restriction_types{"strict"}{'valid_strings'} = "";
480$restriction_types{"fits_in_31_bits"}{'valid_strings'} = "";
481
482# This set of tests looks for basic sanity, and lastly tests various routines
483# for the given code point. If the earlier tests for that code point fail,
484# the later ones probably will too. Malformations are tested in later
7dfd8446
KW
485# segments of code.
486for my $u (sort { utf8::unicode_to_native($a) <=> utf8::unicode_to_native($b) }
487 keys %code_points)
488{
489 my $hex_u = sprintf("0x%02X", $u);
490 my $n = utf8::unicode_to_native($u);
491 my $hex_n = sprintf("0x%02X", $n);
492 my $bytes = $code_points{$u};
493
494 my $offskip_should_be;
495 {
496 no warnings qw(overflow portable);
497 $offskip_should_be = (isASCII)
498 ? ( $u < 0x80 ? 1 :
499 $u < 0x800 ? 2 :
500 $u < 0x10000 ? 3 :
501 $u < 0x200000 ? 4 :
502 $u < 0x4000000 ? 5 :
6aa905cf
KW
503 $u < 0x80000000 ? 6 : (($::is64bit)
504 ? ($u < 0x1000000000 ? 7 : $::max_bytes)
7dfd8446
KW
505 : 7)
506 )
507 : ($u < 0xA0 ? 1 :
508 $u < 0x400 ? 2 :
509 $u < 0x4000 ? 3 :
510 $u < 0x40000 ? 4 :
511 $u < 0x400000 ? 5 :
c0236afe 512 $u < 0x4000000 ? 6 :
6aa905cf 513 $u < 0x40000000 ? 7 : $::max_bytes );
7dfd8446
KW
514 }
515
516 # If this test fails, subsequent ones are meaningless.
517 next unless is(test_OFFUNISKIP($u), $offskip_should_be,
518 "Verify OFFUNISKIP($hex_u) is $offskip_should_be");
519 my $invariant = $offskip_should_be == 1;
520 my $display_invariant = $invariant || 0;
521 is(test_OFFUNI_IS_INVARIANT($u), $invariant,
522 "Verify OFFUNI_IS_INVARIANT($hex_u) is $display_invariant");
523
524 my $uvchr_skip_should_be = $offskip_should_be;
525 next unless is(test_UVCHR_SKIP($n), $uvchr_skip_should_be,
526 "Verify UVCHR_SKIP($hex_n) is $uvchr_skip_should_be");
527 is(test_UVCHR_IS_INVARIANT($n), $offskip_should_be == 1,
528 "Verify UVCHR_IS_INVARIANT($hex_n) is $display_invariant");
529
530 my $n_chr = chr $n;
531 utf8::upgrade $n_chr;
532
533 is(test_UTF8_SKIP($n_chr), $uvchr_skip_should_be,
534 "Verify UTF8_SKIP(chr $hex_n) is $uvchr_skip_should_be");
535
536 use bytes;
3d56ecbe
KW
537 my $byte_length = length $n_chr;
538 for (my $j = 0; $j < $byte_length; $j++) {
539 undef @warnings;
540
541 if ($j == $byte_length - 1) {
2956ebbf
KW
542 my $ret
543 = test_is_utf8_valid_partial_char_flags($n_chr, $byte_length, 0);
544 is($ret, 0, " Verify is_utf8_valid_partial_char_flags("
545 . display_bytes($n_chr)
546 . ") returns 0 for full character");
3d56ecbe
KW
547 }
548 else {
549 my $bytes_so_far = substr($n_chr, 0, $j + 1);
2956ebbf
KW
550 my $ret
551 = test_is_utf8_valid_partial_char_flags($bytes_so_far, $j + 1, 0);
552 is($ret, 1, " Verify is_utf8_valid_partial_char_flags("
553 . display_bytes($bytes_so_far)
554 . ") returns 1");
3d56ecbe
KW
555 }
556
6a0eaf3d
KW
557 is(scalar @warnings, 0, " Verify is_utf8_valid_partial_char_flags"
558 . " generated no warnings")
559 or output_warnings(@warnings);
3d56ecbe 560
7dfd8446
KW
561 my $b = substr($n_chr, $j, 1);
562 my $hex_b = sprintf("\"\\x%02x\"", ord $b);
563
564 my $byte_invariant = $j == 0 && $uvchr_skip_should_be == 1;
565 my $display_byte_invariant = $byte_invariant || 0;
566 next unless is(test_UTF8_IS_INVARIANT($b), $byte_invariant,
567 " Verify UTF8_IS_INVARIANT($hex_b) for byte $j "
568 . "is $display_byte_invariant");
569
570 my $is_start = $j == 0 && $uvchr_skip_should_be > 1;
571 my $display_is_start = $is_start || 0;
572 next unless is(test_UTF8_IS_START($b), $is_start,
573 " Verify UTF8_IS_START($hex_b) is $display_is_start");
574
575 my $is_continuation = $j != 0 && $uvchr_skip_should_be > 1;
576 my $display_is_continuation = $is_continuation || 0;
577 next unless is(test_UTF8_IS_CONTINUATION($b), $is_continuation,
578 " Verify UTF8_IS_CONTINUATION($hex_b) is "
579 . "$display_is_continuation");
580
581 my $is_continued = $uvchr_skip_should_be > 1;
582 my $display_is_continued = $is_continued || 0;
583 next unless is(test_UTF8_IS_CONTINUED($b), $is_continued,
584 " Verify UTF8_IS_CONTINUED($hex_b) is "
585 . "$display_is_continued");
586
587 my $is_downgradeable_start = $n < 256
588 && $uvchr_skip_should_be > 1
589 && $j == 0;
590 my $display_is_downgradeable_start = $is_downgradeable_start || 0;
591 next unless is(test_UTF8_IS_DOWNGRADEABLE_START($b),
592 $is_downgradeable_start,
593 " Verify UTF8_IS_DOWNGRADEABLE_START($hex_b) is "
594 . "$display_is_downgradeable_start");
595
596 my $is_above_latin1 = $n > 255 && $j == 0;
597 my $display_is_above_latin1 = $is_above_latin1 || 0;
598 next unless is(test_UTF8_IS_ABOVE_LATIN1($b),
599 $is_above_latin1,
600 " Verify UTF8_IS_ABOVE_LATIN1($hex_b) is "
601 . "$display_is_above_latin1");
602
603 my $is_possibly_problematic = $j == 0
604 && $n >= ((isASCII)
605 ? 0xD000
606 : 0x8000);
607 my $display_is_possibly_problematic = $is_possibly_problematic || 0;
608 next unless is(test_isUTF8_POSSIBLY_PROBLEMATIC($b),
609 $is_possibly_problematic,
610 " Verify isUTF8_POSSIBLY_PROBLEMATIC($hex_b) is "
611 . "$display_is_above_latin1");
612 }
613
614 # We are not trying to look for warnings, etc, so if they should occur, it
615 # is an error. But some of the code points here do cause warnings, so we
616 # check here and turn off the ones that apply to such code points. A
617 # later section of the code tests for these kinds of things.
046d01eb 618 my $this_utf8_flags = $look_for_everything_utf8n_to;
7dfd8446 619 my $len = length $bytes;
e23e8bc1
KW
620
621 my $valid_under_strict = 1;
a82be82b 622 my $valid_under_c9strict = 1;
9f2abfde 623 my $valid_for_fits_in_31_bits = 1;
7dfd8446 624 if ($n > 0x10FFFF) {
6aa905cf 625 $this_utf8_flags &= ~($::UTF8_DISALLOW_SUPER|$::UTF8_WARN_SUPER);
e23e8bc1 626 $valid_under_strict = 0;
a82be82b 627 $valid_under_c9strict = 0;
5f8a3d1d
KW
628 if ($n > 2 ** 31 - 1) {
629 $this_utf8_flags &=
6aa905cf 630 ~($::UTF8_DISALLOW_ABOVE_31_BIT|$::UTF8_WARN_ABOVE_31_BIT);
9f2abfde 631 $valid_for_fits_in_31_bits = 0;
5f8a3d1d 632 }
7dfd8446 633 }
5f8a3d1d 634 elsif (($n >= 0xFDD0 && $n <= 0xFDEF) || ($n & 0xFFFE) == 0xFFFE) {
6aa905cf 635 $this_utf8_flags &= ~($::UTF8_DISALLOW_NONCHAR|$::UTF8_WARN_NONCHAR);
e23e8bc1 636 $valid_under_strict = 0;
7dfd8446 637 }
5f8a3d1d 638 elsif ($n >= 0xD800 && $n <= 0xDFFF) {
6aa905cf 639 $this_utf8_flags &= ~($::UTF8_DISALLOW_SURROGATE|$::UTF8_WARN_SURROGATE);
5f8a3d1d
KW
640 $valid_under_c9strict = 0;
641 $valid_under_strict = 0;
642 }
7dfd8446
KW
643
644 undef @warnings;
645
646 my $display_flags = sprintf "0x%x", $this_utf8_flags;
7dfd8446 647 my $display_bytes = display_bytes($bytes);
f9380377 648 my $ret_ref = test_utf8n_to_uvchr_error($bytes, $len, $this_utf8_flags);
c0d8738e
KW
649
650 # Rest of tests likely meaningless if it gets the wrong code point.
651 next unless is($ret_ref->[0], $n,
f9380377
KW
652 "Verify utf8n_to_uvchr_error($display_bytes, $display_flags)"
653 . "returns $hex_n");
c0d8738e 654 is($ret_ref->[1], $len,
f9380377
KW
655 "Verify utf8n_to_uvchr_error() for $hex_n returns expected length:"
656 . " $len");
7dfd8446
KW
657
658 unless (is(scalar @warnings, 0,
f9380377 659 "Verify utf8n_to_uvchr_error() for $hex_n generated no warnings"))
7dfd8446 660 {
d84e92aa 661 output_warnings(@warnings);
7dfd8446 662 }
f9380377
KW
663 is($ret_ref->[2], 0,
664 "Verify utf8n_to_uvchr_error() returned no error bits");
046d01eb 665
75ffa578
KW
666 undef @warnings;
667
d7874298 668 my $ret = test_isUTF8_CHAR($bytes, $len);
2956ebbf
KW
669 is($ret, $len,
670 "Verify isUTF8_CHAR($display_bytes) returns expected length: $len");
d7874298
KW
671
672 unless (is(scalar @warnings, 0,
673 "Verify isUTF8_CHAR() for $hex_n generated no warnings"))
674 {
d84e92aa 675 output_warnings(@warnings);
d7874298
KW
676 }
677
678 undef @warnings;
679
680 $ret = test_isUTF8_CHAR($bytes, $len - 1);
2956ebbf
KW
681 is($ret, 0,
682 "Verify isUTF8_CHAR() with too short length parameter returns 0");
d7874298 683
6a0eaf3d
KW
684 is(scalar @warnings, 0, "Verify isUTF8_CHAR() generated no warnings")
685 or output_warnings(@warnings);
d7874298
KW
686
687 undef @warnings;
688
25e3a4e0 689 $ret = test_isUTF8_CHAR_flags($bytes, $len, 0);
2956ebbf
KW
690 is($ret, $len, "Verify isUTF8_CHAR_flags($display_bytes, 0)"
691 . " returns expected length: $len");
25e3a4e0 692
6a0eaf3d
KW
693 is(scalar @warnings, 0,
694 "Verify isUTF8_CHAR_flags() for $hex_n generated no warnings")
695 or output_warnings(@warnings);
25e3a4e0
KW
696
697 undef @warnings;
698
699 $ret = test_isUTF8_CHAR_flags($bytes, $len - 1, 0);
2956ebbf
KW
700 is($ret, 0,
701 "Verify isUTF8_CHAR_flags() with too short length parameter returns 0");
25e3a4e0 702
6a0eaf3d
KW
703 is(scalar @warnings, 0, "Verify isUTF8_CHAR_flags() generated no warnings")
704 or output_warnings(@warnings);
25e3a4e0
KW
705
706 undef @warnings;
707
e23e8bc1
KW
708 $ret = test_isSTRICT_UTF8_CHAR($bytes, $len);
709 my $expected_len = ($valid_under_strict) ? $len : 0;
2956ebbf
KW
710 is($ret, $expected_len, "Verify isSTRICT_UTF8_CHAR($display_bytes)"
711 . " returns expected length: $expected_len");
e23e8bc1 712
6a0eaf3d
KW
713 is(scalar @warnings, 0,
714 "Verify isSTRICT_UTF8_CHAR() for $hex_n generated no warnings")
715 or output_warnings(@warnings);
e23e8bc1
KW
716
717 undef @warnings;
718
719 $ret = test_isSTRICT_UTF8_CHAR($bytes, $len - 1);
2956ebbf
KW
720 is($ret, 0,
721 "Verify isSTRICT_UTF8_CHAR() with too short length parameter returns 0");
e23e8bc1 722
6a0eaf3d
KW
723 is(scalar @warnings, 0, "Verify isSTRICT_UTF8_CHAR() generated no warnings")
724 or output_warnings(@warnings);
e23e8bc1 725
25e3a4e0
KW
726 undef @warnings;
727
2956ebbf 728 $ret = test_isUTF8_CHAR_flags($bytes, $len,
6aa905cf 729 $::UTF8_DISALLOW_ILLEGAL_INTERCHANGE);
2956ebbf
KW
730 is($ret, $expected_len,
731 "Verify isUTF8_CHAR_flags('DISALLOW_ILLEGAL_INTERCHANGE')"
732 . " acts like isSTRICT_UTF8_CHAR");
25e3a4e0 733
6a0eaf3d
KW
734 is(scalar @warnings, 0,
735 "Verify isUTF8_CHAR() for $hex_n generated no warnings")
736 or output_warnings(@warnings);
25e3a4e0
KW
737
738 undef @warnings;
739
a82be82b
KW
740 $ret = test_isC9_STRICT_UTF8_CHAR($bytes, $len);
741 $expected_len = ($valid_under_c9strict) ? $len : 0;
2956ebbf
KW
742 is($ret, $expected_len, "Verify isC9_STRICT_UTF8_CHAR($display_bytes)"
743 . " returns expected length: $len");
a82be82b 744
6a0eaf3d
KW
745 is(scalar @warnings, 0,
746 "Verify isC9_STRICT_UTF8_CHAR() for $hex_n generated no warnings")
747 or output_warnings(@warnings);
a82be82b
KW
748
749 undef @warnings;
750
751 $ret = test_isC9_STRICT_UTF8_CHAR($bytes, $len - 1);
2956ebbf
KW
752 is($ret, 0,
753 "Verify isC9_STRICT_UTF8_CHAR() with too short length parameter returns 0");
a82be82b 754
6a0eaf3d
KW
755 is(scalar @warnings, 0,
756 "Verify isC9_STRICT_UTF8_CHAR() generated no warnings")
757 or output_warnings(@warnings);
a82be82b 758
e23e8bc1
KW
759 undef @warnings;
760
2956ebbf 761 $ret = test_isUTF8_CHAR_flags($bytes, $len,
6aa905cf 762 $::UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE);
2956ebbf
KW
763 is($ret, $expected_len,
764 "Verify isUTF8_CHAR_flags('DISALLOW_ILLEGAL_C9_INTERCHANGE')"
765 ." acts like isC9_STRICT_UTF8_CHAR");
25e3a4e0 766
6a0eaf3d
KW
767 is(scalar @warnings, 0,
768 "Verify isUTF8_CHAR() for $hex_n generated no warnings")
769 or output_warnings(@warnings);
25e3a4e0
KW
770
771 undef @warnings;
772
75ffa578 773 $ret_ref = test_valid_utf8_to_uvchr($bytes);
2956ebbf
KW
774 is($ret_ref->[0], $n,
775 "Verify valid_utf8_to_uvchr($display_bytes) returns $hex_n");
776 is($ret_ref->[1], $len,
777 "Verify valid_utf8_to_uvchr() for $hex_n returns expected length: $len");
75ffa578 778
6a0eaf3d
KW
779 is(scalar @warnings, 0,
780 "Verify valid_utf8_to_uvchr() for $hex_n generated no warnings")
781 or output_warnings(@warnings);
75ffa578 782
046d01eb
KW
783 # Similarly for uvchr_to_utf8
784 my $this_uvchr_flags = $look_for_everything_uvchr_to;
785 if ($n > 2 ** 31 - 1) {
786 $this_uvchr_flags &=
6aa905cf 787 ~($::UNICODE_DISALLOW_ABOVE_31_BIT|$::UNICODE_WARN_ABOVE_31_BIT);
046d01eb
KW
788 }
789 if ($n > 0x10FFFF) {
6aa905cf 790 $this_uvchr_flags &= ~($::UNICODE_DISALLOW_SUPER|$::UNICODE_WARN_SUPER);
046d01eb 791 }
5f8a3d1d 792 elsif (($n >= 0xFDD0 && $n <= 0xFDEF) || ($n & 0xFFFE) == 0xFFFE) {
6aa905cf 793 $this_uvchr_flags &= ~($::UNICODE_DISALLOW_NONCHAR|$::UNICODE_WARN_NONCHAR);
046d01eb 794 }
5f8a3d1d 795 elsif ($n >= 0xD800 && $n <= 0xDFFF) {
2956ebbf 796 $this_uvchr_flags
6aa905cf 797 &= ~($::UNICODE_DISALLOW_SURROGATE|$::UNICODE_WARN_SURROGATE);
5f8a3d1d 798 }
046d01eb
KW
799 $display_flags = sprintf "0x%x", $this_uvchr_flags;
800
801 undef @warnings;
802
d7874298 803 $ret = test_uvchr_to_utf8_flags($n, $this_uvchr_flags);
2956ebbf
KW
804 ok(defined $ret,
805 "Verify uvchr_to_utf8_flags($hex_n, $display_flags) returned success");
806 is($ret, $bytes,
807 "Verify uvchr_to_utf8_flags($hex_n, $display_flags) returns correct bytes");
046d01eb 808
6a0eaf3d
KW
809 is(scalar @warnings, 0,
810 "Verify uvchr_to_utf8_flags($hex_n, $display_flags) for $hex_n"
811 . " generated no warnings")
812 or output_warnings(@warnings);
9f2abfde
KW
813
814 # Now append this code point to a string that we will test various
815 # versions of is_foo_utf8_string_bar on, and keep a count of how many code
816 # points are in it. All the code points in this loop are valid in Perl's
817 # extended UTF-8, but some are not valid under various restrictions. A
818 # string and count is kept separately that is entirely valid for each
819 # restriction. And, for each restriction, we note the first occurrence in
820 # the unrestricted string where we find something not in the restricted
821 # string.
822 $restriction_types{""}{'valid_strings'} .= $bytes;
823 $restriction_types{""}{'valid_counts'}++;
824
825 if ($valid_under_c9strict) {
826 $restriction_types{"c9strict"}{'valid_strings'} .= $bytes;
827 $restriction_types{"c9strict"}{'valid_counts'}++;
828 }
829 elsif (! exists $restriction_types{"c9strict"}{'first_invalid_offset'}) {
830 $restriction_types{"c9strict"}{'first_invalid_offset'}
831 = length $restriction_types{"c9strict"}{'valid_strings'};
832 $restriction_types{"c9strict"}{'first_invalid_count'}
833 = $restriction_types{"c9strict"}{'valid_counts'};
834 }
835
836 if ($valid_under_strict) {
837 $restriction_types{"strict"}{'valid_strings'} .= $bytes;
838 $restriction_types{"strict"}{'valid_counts'}++;
839 }
840 elsif (! exists $restriction_types{"strict"}{'first_invalid_offset'}) {
841 $restriction_types{"strict"}{'first_invalid_offset'}
842 = length $restriction_types{"strict"}{'valid_strings'};
843 $restriction_types{"strict"}{'first_invalid_count'}
844 = $restriction_types{"strict"}{'valid_counts'};
845 }
846
847 if ($valid_for_fits_in_31_bits) {
848 $restriction_types{"fits_in_31_bits"}{'valid_strings'} .= $bytes;
849 $restriction_types{"fits_in_31_bits"}{'valid_counts'}++;
850 }
851 elsif (! exists
852 $restriction_types{"fits_in_31_bits"}{'first_invalid_offset'})
853 {
854 $restriction_types{"fits_in_31_bits"}{'first_invalid_offset'}
855 = length $restriction_types{"fits_in_31_bits"}{'valid_strings'};
856 $restriction_types{"fits_in_31_bits"}{'first_invalid_count'}
857 = $restriction_types{"fits_in_31_bits"}{'valid_counts'};
858 }
859}
860
861my $I8c = (isASCII) ? "\x80" : "\xa0"; # A continuation byte
862my $cont_byte = I8_to_native($I8c);
863my $p = (isASCII) ? "\xe1\x80" : I8_to_native("\xE4\xA0"); # partial
864
865# The loop above tested the single or partial character functions/macros,
866# while building up strings to test the string functions, which we do now.
867
868for my $restriction (sort keys %restriction_types) {
869 use bytes;
870
871 for my $use_flags ("", "_flags") {
872
873 # For each restriction, we test it in both the is_foo_flags functions
874 # and the specially named foo function. But not if there isn't such a
875 # specially named function. Currently, this is the only tested
876 # restriction that doesn't have a specially named function
877 next if $use_flags eq "" && $restriction eq "fits_in_31_bits";
878
879 # Start building up the name of the function we will test.
8bc127bf 880 my $base_name = "is_";
9f2abfde
KW
881
882 if (! $use_flags && $restriction ne "") {
8bc127bf 883 $base_name .= $restriction . "_";
9f2abfde 884 }
8bc127bf
KW
885
886 # We test both "is_utf8_string_foo" and "is_fixed_width_buf" functions
887 foreach my $operand ('string', 'fixed_width_buf') {
888
889 # Currently, the only fixed_width_buf functions have the '_flags'
890 # suffix.
891 next if $operand eq 'fixed_width_buf' && $use_flags eq "";
892
893 my $name = "${base_name}utf8_$operand";
9f2abfde
KW
894
895 # We test each version of the function
896 for my $function ("_loclen", "_loc", "") {
897
898 # We test each function against
899 # a) valid input
900 # b) invalid input created by appending an out-of-place
901 # continuation character to the valid string
8bc127bf
KW
902 # c) input created by appending a partial character. This
903 # is valid in the 'fixed_width' functions, but invalid in
904 # the 'string' ones
9f2abfde
KW
905 # d) invalid input created by calling a function that is
906 # expecting a restricted form of the input using the string
907 # that's valid when unrestricted
908 for my $error_type (0, $cont_byte, $p, $restriction) {
909 #diag "restriction=$restriction, use_flags=$use_flags, function=$function, error_type=" . display_bytes($error_type);
910
911 # If there is no restriction, the error type will be "",
912 # which is redundant with 0.
913 next if $error_type eq "";
914
915 my $this_name = "$name$function$use_flags";
916 my $bytes
917 = $restriction_types{$restriction}{'valid_strings'};
918 my $expected_offset = length $bytes;
919 my $expected_count
920 = $restriction_types{$restriction}{'valid_counts'};
921 my $test_name_suffix = "";
922
923 my $this_error_type = $error_type;
924 if ($this_error_type) {
925
926 # Appending a bare continuation byte or a partial
8bc127bf
KW
927 # character doesn't change the character count or
928 # offset. But in the other cases, we have saved where
929 # the failures should occur, so use those. Appending
930 # a continuation byte makes it invalid; appending a
931 # partial character makes the 'string' form invalid,
932 # but not the 'fixed_width_buf' form.
2956ebbf
KW
933 if ( $this_error_type eq $cont_byte
934 || $this_error_type eq $p)
935 {
9f2abfde
KW
936 $bytes .= $this_error_type;
937 if ($this_error_type eq $cont_byte) {
938 $test_name_suffix
939 = " for an unexpected continuation";
940 }
941 else {
942 $test_name_suffix
943 = " if ends with a partial character";
8bc127bf
KW
944 $this_error_type
945 = 0 if $operand eq "fixed_width_buf";
9f2abfde
KW
946 }
947 }
948 else {
949 $test_name_suffix
950 = " if contains forbidden code points";
951 if ($this_error_type eq "c9strict") {
952 $bytes = $restriction_types{""}{'valid_strings'};
953 $expected_offset
954 = $restriction_types{"c9strict"}
955 {'first_invalid_offset'};
956 $expected_count
957 = $restriction_types{"c9strict"}
958 {'first_invalid_count'};
959 }
960 elsif ($this_error_type eq "strict") {
961 $bytes = $restriction_types{""}{'valid_strings'};
962 $expected_offset
963 = $restriction_types{"strict"}
964 {'first_invalid_offset'};
965 $expected_count
966 = $restriction_types{"strict"}
967 {'first_invalid_count'};
968
969 }
970 elsif ($this_error_type eq "fits_in_31_bits") {
971 $bytes = $restriction_types{""}{'valid_strings'};
972 $expected_offset
973 = $restriction_types{"fits_in_31_bits"}
974 {'first_invalid_offset'};
975 $expected_count
976 = $restriction_types{"fits_in_31_bits"}
977 {'first_invalid_count'};
978 }
979 else {
980 fail("Internal test error: Unknown error type "
981 . "'$this_error_type'");
982 next;
983 }
984 }
985 }
986
987 my $length = length $bytes;
988 my $ret_ref;
989
990 my $test = "\$ret_ref = test_$this_name(\$bytes, $length";
991
992 # If using the _flags functions, we have to figure out what
993 # flags to pass. This is done to match the restriction.
994 if ($use_flags eq "_flags") {
995 if (! $restriction) {
996 $test .= ", 0"; # The flag
997
998 # Indicate the kind of flag in the test name.
999 $this_name .= "(0)";
1000 }
1001 else {
1002 $this_name .= "($restriction)";
1003 if ($restriction eq "c9strict") {
1004 $test
6aa905cf 1005 .= ", $::UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE";
9f2abfde
KW
1006 }
1007 elsif ($restriction eq "strict") {
6aa905cf 1008 $test .= ", $::UTF8_DISALLOW_ILLEGAL_INTERCHANGE";
9f2abfde
KW
1009 }
1010 elsif ($restriction eq "fits_in_31_bits") {
6aa905cf 1011 $test .= ", $::UTF8_DISALLOW_ABOVE_31_BIT";
9f2abfde
KW
1012 }
1013 else {
1014 fail("Internal test error: Unknown restriction "
1015 . "'$restriction'");
1016 next;
1017 }
1018 }
1019 }
1020 $test .= ")";
1021
1022 # Actually run the test
1023 eval $test;
1024 if ($@) {
1025 fail($test);
1026 diag $@;
1027 next;
1028 }
1029
1030 my $ret;
1031 my $error_offset;
1032 my $cp_count;
1033
1034 if ($function eq "") {
1035 $ret = $ret_ref; # For plain function, there's only a
1036 # single return value
1037 }
1038 else { # Otherwise, the multiple values come in an array.
1039 $ret = shift @$ret_ref ;
1040 $error_offset = shift @$ret_ref;
1041 $cp_count = shift@$ret_ref if $function eq "_loclen";
1042 }
1043
1044 if ($this_error_type) {
1045 is($ret, 0,
1046 "Verify $this_name is FALSE$test_name_suffix");
1047 }
1048 else {
1049 unless(is($ret, 1,
1050 "Verify $this_name is TRUE for valid input"
1051 . "$test_name_suffix"))
1052 {
5d03eac4 1053 diag(" The bytes starting at offset"
9f2abfde
KW
1054 . " $error_offset are"
1055 . display_bytes(substr(
1056 $restriction_types{$restriction}
1057 {'valid_strings'},
1058 $error_offset)));
1059 next;
1060 }
1061 }
1062
1063 if ($function ne "") {
1064 unless (is($error_offset, $expected_offset,
1065 "\tAnd returns the correct offset"))
1066 {
1067 my $min = ($error_offset < $expected_offset)
1068 ? $error_offset
1069 : $expected_offset;
5d03eac4
KW
1070 diag(" The bytes starting at offset" . $min
1071 . " are " . display_bytes(substr($bytes, $min)));
9f2abfde
KW
1072 }
1073
1074 if ($function eq '_loclen') {
1075 is($cp_count, $expected_count,
1076 "\tAnd returns the correct character count");
1077 }
1078 }
1079 }
1080 }
8bc127bf 1081 }
9f2abfde 1082 }
7dfd8446
KW
1083}
1084
65df57a8
TC
1085SKIP:
1086{
1087 isASCII
1088 or skip "These tests probably break on non-ASCII", 1;
1089 my $simple = join "", "A" .. "J";
1090 my $utf_ch = "\x{7fffffff}";
1091 utf8::encode($utf_ch);
1092 my $utf_ch_len = length $utf_ch;
1093 note "utf_ch_len $utf_ch_len";
1094 my $utf = $utf_ch x 10;
1095 my $bad_start = substr($utf, 1);
1096 # $bad_end ends with a start byte and a single continuation
1097 my $bad_end = substr($utf, 0, length($utf)-$utf_ch_len+2);
1098
1099 # WARNING: all offsets are *byte* offsets
1100 my @hop_tests =
1101 (
1102 # string s off expected name
1103 [ $simple, 0, 5, 5, "simple in range, forward" ],
1104 [ $simple, 10, -5, 5, "simple in range, backward" ],
1105 [ $simple, 5, 10, 10, "simple out of range, forward" ],
1106 [ $simple, 5, -10, 0, "simple out of range, backward" ],
1107 [ $utf, $utf_ch_len * 5, 5, length($utf), "utf in range, forward" ],
1108 [ $utf, $utf_ch_len * 5, -5, 0, "utf in range, backward" ],
1109 [ $utf, $utf_ch_len * 5, 4, $utf_ch_len * 9, "utf in range b, forward" ],
1110 [ $utf, $utf_ch_len * 5, -4, $utf_ch_len, "utf in range b, backward" ],
1111 [ $utf, $utf_ch_len * 5, 6, length($utf), "utf out of range, forward" ],
1112 [ $utf, $utf_ch_len * 5, -6, 0, "utf out of range, backward" ],
1113 [ $bad_start, 0, 1, 1, "bad start, forward 1 from 0" ],
1114 [ $bad_start, 0, $utf_ch_len-1, $utf_ch_len-1, "bad start, forward ch_len-1 from 0" ],
1115 [ $bad_start, 0, $utf_ch_len, $utf_ch_len*2-1, "bad start, forward ch_len from 0" ],
1116 [ $bad_start, $utf_ch_len-1, -1, 0, "bad start, back 1 from first start byte" ],
1117 [ $bad_start, $utf_ch_len-2, -1, 0, "bad start, back 1 from before first start byte" ],
1118 [ $bad_start, 0, -1, 0, "bad start, back 1 from 0" ],
1119 [ $bad_start, length $bad_start, -10, 0, "bad start, back 10 from end" ],
1120 [ $bad_end, 0, 10, length $bad_end, "bad end, forward 10 from 0" ],
1121 [ $bad_end, length($bad_end)-1, 10, length $bad_end, "bad end, forward 1 from end-1" ],
1122 );
1123
1124 for my $test (@hop_tests) {
1125 my ($str, $s_off, $off, $want, $name) = @$test;
1126 my $result = test_utf8_hop_safe($str, $s_off, $off);
1127 is($result, $want, "utf8_hop_safe: $name");
1128 }
1129}
1130
fed3ba5d 1131done_testing;