c7a032efde4683bae065184c34770ce6c117fb2e
[perl.git] / ext / XS-APItest / t / utf8.t
1 #!perl -w
2
3 use strict;
4 use Test::More;
5
6 # This file tests various functions and macros in the API related to UTF-8.
7
8 BEGIN {
9     use_ok('XS::APItest');
10     require 'charset_tools.pl';
11     require './t/utf8_setup.pl';
12 };
13
14 $|=1;
15
16 no warnings 'deprecated'; # Some of the below are above IV_MAX on 32 bit
17                           # machines, and that is tested elsewhere
18
19 use XS::APItest;
20
21 my $pound_sign = chr utf8::unicode_to_native(163);
22
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
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.
27
28 my $look_for_everything_utf8n_to
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;
37 my $look_for_everything_uvchr_to
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;
46
47 foreach ([0, '', '', 'empty'],
48          [0, 'N', 'N', '1 char'],
49          [1, 'NN', 'N', '1 char substring'],
50          [-2, 'Perl', 'Rules', 'different'],
51          [0, $pound_sign, $pound_sign, 'pound sign'],
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'],
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
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.
74 my %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
94     # Bracket the surrogates, and include several surrogates
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"),
101
102     # Include the 32 contiguous non characters, and surrounding code points
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"),
137
138     # Mostly around non-characters, but some are transitions to longer strings
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"),
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
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"),
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"),
393 );
394
395 if ($::is64bit) {
396     no warnings qw(overflow portable);
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");
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");
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";
423         # overflows
424         #$code_points{0xfoo}
425         #           = "\xff\x81\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80";
426     }
427 }
428 elsif (! isASCII) { # 32-bit EBCDIC.  64-bit is clearer to handle, so doesn't
429                     # need this test case
430     no warnings qw(overflow portable);
431     $code_points{0x40000000} = I8_to_native(
432                     "\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa1\xa0\xa0\xa0\xa0\xa0\xa0");
433 }
434
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
439 my $cp = 0;
440 while ($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
452 my $final_continuation = 0xBF;
453 my $start = (isASCII) ? 0xC2 : 0xC5;
454
455 my $continuation = $::first_continuation - 1;
456
457 while ($cp < 255) {
458     if (++$continuation > $final_continuation) {
459
460         # Wrap to the next start byte when we reach the final continuation
461         # byte possible
462         $continuation = $::first_continuation;
463         $start++;
464     }
465     $code_points{$cp} = I8_to_native(chr($start) . chr($continuation));
466
467     $cp++;
468 }
469
470 my @warnings;
471
472 use warnings 'utf8';
473 local $SIG{__WARN__} = sub { push @warnings, @_ };
474
475 my %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
485 # segments of code.
486 for 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 :
503                 $u < 0x80000000     ? 6 : (($::is64bit)
504                                         ? ($u < 0x1000000000 ? 7 : $::max_bytes)
505                                         : 7)
506               )
507             : ($u < 0xA0        ? 1 :
508                $u < 0x400       ? 2 :
509                $u < 0x4000      ? 3 :
510                $u < 0x40000     ? 4 :
511                $u < 0x400000    ? 5 :
512                $u < 0x4000000   ? 6 :
513                $u < 0x40000000  ? 7 : $::max_bytes );
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;
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) {
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");
547         }
548         else {
549             my $bytes_so_far = substr($n_chr, 0, $j + 1);
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");
555         }
556
557         is(scalar @warnings, 0, "   Verify is_utf8_valid_partial_char_flags"
558                               . " generated no warnings")
559           or output_warnings(@warnings);
560
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.
618     my $this_utf8_flags = $look_for_everything_utf8n_to;
619     my $len = length $bytes;
620
621     my $valid_under_strict = 1;
622     my $valid_under_c9strict = 1;
623     my $valid_for_fits_in_31_bits = 1;
624     if ($n > 0x10FFFF) {
625         $this_utf8_flags &= ~($::UTF8_DISALLOW_SUPER|$::UTF8_WARN_SUPER);
626         $valid_under_strict = 0;
627         $valid_under_c9strict = 0;
628         if ($n > 2 ** 31 - 1) {
629             $this_utf8_flags &=
630                         ~($::UTF8_DISALLOW_ABOVE_31_BIT|$::UTF8_WARN_ABOVE_31_BIT);
631             $valid_for_fits_in_31_bits = 0;
632         }
633     }
634     elsif (($n >= 0xFDD0 && $n <= 0xFDEF) || ($n & 0xFFFE) == 0xFFFE) {
635         $this_utf8_flags &= ~($::UTF8_DISALLOW_NONCHAR|$::UTF8_WARN_NONCHAR);
636         $valid_under_strict = 0;
637     }
638     elsif ($n >= 0xD800 && $n <= 0xDFFF) {
639         $this_utf8_flags &= ~($::UTF8_DISALLOW_SURROGATE|$::UTF8_WARN_SURROGATE);
640         $valid_under_c9strict = 0;
641         $valid_under_strict = 0;
642     }
643
644     undef @warnings;
645
646     my $display_flags = sprintf "0x%x", $this_utf8_flags;
647     my $display_bytes = display_bytes($bytes);
648     my $ret_ref = test_utf8n_to_uvchr_error($bytes, $len, $this_utf8_flags);
649
650     # Rest of tests likely meaningless if it gets the wrong code point.
651     next unless is($ret_ref->[0], $n,
652                    "Verify utf8n_to_uvchr_error($display_bytes, $display_flags)"
653                  . "returns $hex_n");
654     is($ret_ref->[1], $len,
655        "Verify utf8n_to_uvchr_error() for $hex_n returns expected length:"
656      . " $len");
657
658     unless (is(scalar @warnings, 0,
659              "Verify utf8n_to_uvchr_error() for $hex_n generated no warnings"))
660     {
661         output_warnings(@warnings);
662     }
663     is($ret_ref->[2], 0,
664        "Verify utf8n_to_uvchr_error() returned no error bits");
665
666     undef @warnings;
667
668     my $ret = test_isUTF8_CHAR($bytes, $len);
669     is($ret, $len,
670             "Verify isUTF8_CHAR($display_bytes) returns expected length: $len");
671
672     unless (is(scalar @warnings, 0,
673                "Verify isUTF8_CHAR() for $hex_n generated no warnings"))
674     {
675         output_warnings(@warnings);
676     }
677
678     undef @warnings;
679
680     $ret = test_isUTF8_CHAR($bytes, $len - 1);
681     is($ret, 0,
682             "Verify isUTF8_CHAR() with too short length parameter returns 0");
683
684     is(scalar @warnings, 0, "Verify isUTF8_CHAR() generated no warnings")
685       or output_warnings(@warnings);
686
687     undef @warnings;
688
689     $ret = test_isUTF8_CHAR_flags($bytes, $len, 0);
690     is($ret, $len, "Verify isUTF8_CHAR_flags($display_bytes, 0)"
691                  . " returns expected length: $len");
692
693     is(scalar @warnings, 0,
694                "Verify isUTF8_CHAR_flags() for $hex_n generated no warnings")
695       or output_warnings(@warnings);
696
697     undef @warnings;
698
699     $ret = test_isUTF8_CHAR_flags($bytes, $len - 1, 0);
700     is($ret, 0,
701         "Verify isUTF8_CHAR_flags() with too short length parameter returns 0");
702
703     is(scalar @warnings, 0, "Verify isUTF8_CHAR_flags() generated no warnings")
704       or output_warnings(@warnings);
705
706     undef @warnings;
707
708     $ret = test_isSTRICT_UTF8_CHAR($bytes, $len);
709     my $expected_len = ($valid_under_strict) ? $len : 0;
710     is($ret, $expected_len, "Verify isSTRICT_UTF8_CHAR($display_bytes)"
711                           . " returns expected length: $expected_len");
712
713     is(scalar @warnings, 0,
714                "Verify isSTRICT_UTF8_CHAR() for $hex_n generated no warnings")
715       or output_warnings(@warnings);
716
717     undef @warnings;
718
719     $ret = test_isSTRICT_UTF8_CHAR($bytes, $len - 1);
720     is($ret, 0,
721        "Verify isSTRICT_UTF8_CHAR() with too short length parameter returns 0");
722
723     is(scalar @warnings, 0, "Verify isSTRICT_UTF8_CHAR() generated no warnings")
724       or output_warnings(@warnings);
725
726     undef @warnings;
727
728     $ret = test_isUTF8_CHAR_flags($bytes, $len,
729                                             $::UTF8_DISALLOW_ILLEGAL_INTERCHANGE);
730     is($ret, $expected_len,
731                     "Verify isUTF8_CHAR_flags('DISALLOW_ILLEGAL_INTERCHANGE')"
732                   . " acts like isSTRICT_UTF8_CHAR");
733
734     is(scalar @warnings, 0,
735                "Verify isUTF8_CHAR() for $hex_n generated no warnings")
736       or output_warnings(@warnings);
737
738     undef @warnings;
739
740     $ret = test_isC9_STRICT_UTF8_CHAR($bytes, $len);
741     $expected_len = ($valid_under_c9strict) ? $len : 0;
742     is($ret, $expected_len, "Verify isC9_STRICT_UTF8_CHAR($display_bytes)"
743                           . " returns expected length: $len");
744
745     is(scalar @warnings, 0,
746             "Verify isC9_STRICT_UTF8_CHAR() for $hex_n generated no warnings")
747       or output_warnings(@warnings);
748
749     undef @warnings;
750
751     $ret = test_isC9_STRICT_UTF8_CHAR($bytes, $len - 1);
752     is($ret, 0,
753     "Verify isC9_STRICT_UTF8_CHAR() with too short length parameter returns 0");
754
755     is(scalar @warnings, 0,
756                "Verify isC9_STRICT_UTF8_CHAR() generated no warnings")
757       or output_warnings(@warnings);
758
759     undef @warnings;
760
761     $ret = test_isUTF8_CHAR_flags($bytes, $len,
762                                         $::UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE);
763     is($ret, $expected_len,
764                    "Verify isUTF8_CHAR_flags('DISALLOW_ILLEGAL_C9_INTERCHANGE')"
765                   ." acts like isC9_STRICT_UTF8_CHAR");
766
767     is(scalar @warnings, 0,
768                "Verify isUTF8_CHAR() for $hex_n generated no warnings")
769       or output_warnings(@warnings);
770
771     undef @warnings;
772
773     $ret_ref = test_valid_utf8_to_uvchr($bytes);
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");
778
779     is(scalar @warnings, 0,
780                "Verify valid_utf8_to_uvchr() for $hex_n generated no warnings")
781       or output_warnings(@warnings);
782
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 &=
787                 ~($::UNICODE_DISALLOW_ABOVE_31_BIT|$::UNICODE_WARN_ABOVE_31_BIT);
788     }
789     if ($n > 0x10FFFF) {
790         $this_uvchr_flags &= ~($::UNICODE_DISALLOW_SUPER|$::UNICODE_WARN_SUPER);
791     }
792     elsif (($n >= 0xFDD0 && $n <= 0xFDEF) || ($n & 0xFFFE) == 0xFFFE) {
793         $this_uvchr_flags &= ~($::UNICODE_DISALLOW_NONCHAR|$::UNICODE_WARN_NONCHAR);
794     }
795     elsif ($n >= 0xD800 && $n <= 0xDFFF) {
796         $this_uvchr_flags
797                      &= ~($::UNICODE_DISALLOW_SURROGATE|$::UNICODE_WARN_SURROGATE);
798     }
799     $display_flags = sprintf "0x%x", $this_uvchr_flags;
800
801     undef @warnings;
802
803     $ret = test_uvchr_to_utf8_flags($n, $this_uvchr_flags);
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");
808
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);
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
861 my $I8c = (isASCII) ? "\x80" : "\xa0";    # A continuation byte
862 my $cont_byte = I8_to_native($I8c);
863 my $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
868 for 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.
880         my $base_name = "is_";
881
882         if (! $use_flags  && $restriction ne "") {
883             $base_name .= $restriction . "_";
884         }
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";
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
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
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
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.
933                         if (   $this_error_type eq $cont_byte
934                             || $this_error_type eq $p)
935                         {
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";
944                                 $this_error_type
945                                         = 0 if $operand eq "fixed_width_buf";
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
1005                                   .= ", $::UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE";
1006                             }
1007                             elsif ($restriction eq "strict") {
1008                                 $test .= ", $::UTF8_DISALLOW_ILLEGAL_INTERCHANGE";
1009                             }
1010                             elsif ($restriction eq "fits_in_31_bits") {
1011                                 $test .= ", $::UTF8_DISALLOW_ABOVE_31_BIT";
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                         {
1053                             diag("    The bytes starting at offset"
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;
1070                             diag("    The bytes starting at offset" . $min
1071                               . " are " . display_bytes(substr($bytes, $min)));
1072                         }
1073
1074                         if ($function eq '_loclen') {
1075                             is($cp_count, $expected_count,
1076                                "\tAnd returns the correct character count");
1077                         }
1078                     }
1079                 }
1080             }
1081         }
1082     }
1083 }
1084
1085 SKIP:
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
1131 done_testing;