This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
t/re/pat_advanced.t: Fix test to work on EBCDIC
[perl5.git] / ext / XS-APItest / t / utf8_warn_base.pl
CommitLineData
6aa905cf
KW
1#!perl -w
2
3# This is a base file to be used by various .t's in its directory
4
5use strict;
6use Test::More;
7
8BEGIN {
9 use_ok('XS::APItest');
10 require 'charset_tools.pl';
11 require './t/utf8_setup.pl';
12};
13
14$|=1;
15
16no warnings 'deprecated'; # Some of the below are above IV_MAX on 32 bit
17 # machines, and that is tested elsewhere
18
19use XS::APItest;
20use Data::Dumper;
21
22my @warnings;
23
24use warnings 'utf8';
25local $SIG{__WARN__} = sub { push @warnings, @_ };
26
27sub nonportable_regex ($) {
28
29 # Returns a pattern that matches the non-portable message raised either
30 # for the specific input code point, or the one generated when there
31 # is some malformation that precludes the message containing the specific
32 # code point
33
34 my $code_point = shift;
35
36 my $string = sprintf '(Code point 0x%X is not Unicode, and'
37 . '|Any UTF-8 sequence that starts with'
38 . ' "(\\\x[[:xdigit:]]{2})+" is for a'
39 . ' non-Unicode code point, and is) not portable',
40 $code_point;
41 return qr/$string/;
42}
43
44# Now test the cases where a legal code point is generated, but may or may not
45# be allowed/warned on.
46my @tests = (
47 # ($testname, $bytes, $warn_flags, $disallow_flags, $expected_error_flags,
48 # $category, $allowed_uv, $expected_len, $needed_to_discern_len, $message )
49 [ "lowest surrogate",
50 (isASCII) ? "\xed\xa0\x80" : I8_to_native("\xf1\xb6\xa0\xa0"),
51 $::UTF8_WARN_SURROGATE, $::UTF8_DISALLOW_SURROGATE, $::UTF8_GOT_SURROGATE,
52 'surrogate', 0xD800,
53 (isASCII) ? 3 : 4,
54 2,
55 qr/surrogate/
56 ],
57 [ "a middle surrogate",
58 (isASCII) ? "\xed\xa4\x8d" : I8_to_native("\xf1\xb6\xa8\xad"),
59 $::UTF8_WARN_SURROGATE, $::UTF8_DISALLOW_SURROGATE, $::UTF8_GOT_SURROGATE,
60 'surrogate', 0xD90D,
61 (isASCII) ? 3 : 4,
62 2,
63 qr/surrogate/
64 ],
65 [ "highest surrogate",
66 (isASCII) ? "\xed\xbf\xbf" : I8_to_native("\xf1\xb7\xbf\xbf"),
67 $::UTF8_WARN_SURROGATE, $::UTF8_DISALLOW_SURROGATE, $::UTF8_GOT_SURROGATE,
68 'surrogate', 0xDFFF,
69 (isASCII) ? 3 : 4,
70 2,
71 qr/surrogate/
72 ],
73 [ "first non_unicode",
74 (isASCII) ? "\xf4\x90\x80\x80" : I8_to_native("\xf9\xa2\xa0\xa0\xa0"),
75 $::UTF8_WARN_SUPER, $::UTF8_DISALLOW_SUPER, $::UTF8_GOT_SUPER,
76 'non_unicode', 0x110000,
77 (isASCII) ? 4 : 5,
78 2,
79 qr/(not Unicode|for a non-Unicode code point).* may not be portable/
80 ],
81 [ "non_unicode whose first byte tells that",
82 (isASCII) ? "\xf5\x80\x80\x80" : I8_to_native("\xfa\xa0\xa0\xa0\xa0"),
83 $::UTF8_WARN_SUPER, $::UTF8_DISALLOW_SUPER, $::UTF8_GOT_SUPER,
84 'non_unicode',
85 (isASCII) ? 0x140000 : 0x200000,
86 (isASCII) ? 4 : 5,
87 1,
88 qr/(not Unicode|for a non-Unicode code point).* may not be portable/
89 ],
90 [ "first of 32 consecutive non-character code points",
91 (isASCII) ? "\xef\xb7\x90" : I8_to_native("\xf1\xbf\xae\xb0"),
92 $::UTF8_WARN_NONCHAR, $::UTF8_DISALLOW_NONCHAR, $::UTF8_GOT_NONCHAR,
93 'nonchar', 0xFDD0,
94 (isASCII) ? 3 : 4,
95 (isASCII) ? 3 : 4,
96 qr/Unicode non-character.*is not recommended for open interchange/
97 ],
98 [ "a mid non-character code point of the 32 consecutive ones",
99 (isASCII) ? "\xef\xb7\xa0" : I8_to_native("\xf1\xbf\xaf\xa0"),
100 $::UTF8_WARN_NONCHAR, $::UTF8_DISALLOW_NONCHAR, $::UTF8_GOT_NONCHAR,
101 'nonchar', 0xFDE0,
102 (isASCII) ? 3 : 4,
103 (isASCII) ? 3 : 4,
104 qr/Unicode non-character.*is not recommended for open interchange/
105 ],
106 [ "final of 32 consecutive non-character code points",
107 (isASCII) ? "\xef\xb7\xaf" : I8_to_native("\xf1\xbf\xaf\xaf"),
108 $::UTF8_WARN_NONCHAR, $::UTF8_DISALLOW_NONCHAR, $::UTF8_GOT_NONCHAR,
109 'nonchar', 0xFDEF,
110 (isASCII) ? 3 : 4,
111 (isASCII) ? 3 : 4,
112 qr/Unicode non-character.*is not recommended for open interchange/
113 ],
114 [ "non-character code point U+FFFE",
115 (isASCII) ? "\xef\xbf\xbe" : I8_to_native("\xf1\xbf\xbf\xbe"),
116 $::UTF8_WARN_NONCHAR, $::UTF8_DISALLOW_NONCHAR, $::UTF8_GOT_NONCHAR,
117 'nonchar', 0xFFFE,
118 (isASCII) ? 3 : 4,
119 (isASCII) ? 3 : 4,
120 qr/Unicode non-character.*is not recommended for open interchange/
121 ],
122 [ "non-character code point U+FFFF",
123 (isASCII) ? "\xef\xbf\xbf" : I8_to_native("\xf1\xbf\xbf\xbf"),
124 $::UTF8_WARN_NONCHAR, $::UTF8_DISALLOW_NONCHAR, $::UTF8_GOT_NONCHAR,
125 'nonchar', 0xFFFF,
126 (isASCII) ? 3 : 4,
127 (isASCII) ? 3 : 4,
128 qr/Unicode non-character.*is not recommended for open interchange/
129 ],
130 [ "non-character code point U+1FFFE",
131 (isASCII) ? "\xf0\x9f\xbf\xbe" : I8_to_native("\xf3\xbf\xbf\xbe"),
132 $::UTF8_WARN_NONCHAR, $::UTF8_DISALLOW_NONCHAR, $::UTF8_GOT_NONCHAR,
133 'nonchar', 0x1FFFE,
134 4, 4,
135 qr/Unicode non-character.*is not recommended for open interchange/
136 ],
137 [ "non-character code point U+1FFFF",
138 (isASCII) ? "\xf0\x9f\xbf\xbf" : I8_to_native("\xf3\xbf\xbf\xbf"),
139 $::UTF8_WARN_NONCHAR, $::UTF8_DISALLOW_NONCHAR, $::UTF8_GOT_NONCHAR,
140 'nonchar', 0x1FFFF,
141 4, 4,
142 qr/Unicode non-character.*is not recommended for open interchange/
143 ],
144 [ "non-character code point U+2FFFE",
145 (isASCII) ? "\xf0\xaf\xbf\xbe" : I8_to_native("\xf5\xbf\xbf\xbe"),
146 $::UTF8_WARN_NONCHAR, $::UTF8_DISALLOW_NONCHAR, $::UTF8_GOT_NONCHAR,
147 'nonchar', 0x2FFFE,
148 4, 4,
149 qr/Unicode non-character.*is not recommended for open interchange/
150 ],
151 [ "non-character code point U+2FFFF",
152 (isASCII) ? "\xf0\xaf\xbf\xbf" : I8_to_native("\xf5\xbf\xbf\xbf"),
153 $::UTF8_WARN_NONCHAR, $::UTF8_DISALLOW_NONCHAR, $::UTF8_GOT_NONCHAR,
154 'nonchar', 0x2FFFF,
155 4, 4,
156 qr/Unicode non-character.*is not recommended for open interchange/
157 ],
158 [ "non-character code point U+3FFFE",
159 (isASCII) ? "\xf0\xbf\xbf\xbe" : I8_to_native("\xf7\xbf\xbf\xbe"),
160 $::UTF8_WARN_NONCHAR, $::UTF8_DISALLOW_NONCHAR, $::UTF8_GOT_NONCHAR,
161 'nonchar', 0x3FFFE,
162 4, 4,
163 qr/Unicode non-character.*is not recommended for open interchange/
164 ],
165 [ "non-character code point U+3FFFF",
166 (isASCII) ? "\xf0\xbf\xbf\xbf" : I8_to_native("\xf7\xbf\xbf\xbf"),
167 $::UTF8_WARN_NONCHAR, $::UTF8_DISALLOW_NONCHAR, $::UTF8_GOT_NONCHAR,
168 'nonchar', 0x3FFFF,
169 4, 4,
170 qr/Unicode non-character.*is not recommended for open interchange/
171 ],
172 [ "non-character code point U+4FFFE",
173 (isASCII) ? "\xf1\x8f\xbf\xbe" : I8_to_native("\xf8\xa9\xbf\xbf\xbe"),
174 $::UTF8_WARN_NONCHAR, $::UTF8_DISALLOW_NONCHAR, $::UTF8_GOT_NONCHAR,
175 'nonchar', 0x4FFFE,
176 (isASCII) ? 4 : 5,
177 (isASCII) ? 4 : 5,
178 qr/Unicode non-character.*is not recommended for open interchange/
179 ],
180 [ "non-character code point U+4FFFF",
181 (isASCII) ? "\xf1\x8f\xbf\xbf" : I8_to_native("\xf8\xa9\xbf\xbf\xbf"),
182 $::UTF8_WARN_NONCHAR, $::UTF8_DISALLOW_NONCHAR, $::UTF8_GOT_NONCHAR,
183 'nonchar', 0x4FFFF,
184 (isASCII) ? 4 : 5,
185 (isASCII) ? 4 : 5,
186 qr/Unicode non-character.*is not recommended for open interchange/
187 ],
188 [ "non-character code point U+5FFFE",
189 (isASCII) ? "\xf1\x9f\xbf\xbe" : I8_to_native("\xf8\xab\xbf\xbf\xbe"),
190 $::UTF8_WARN_NONCHAR, $::UTF8_DISALLOW_NONCHAR, $::UTF8_GOT_NONCHAR,
191 'nonchar', 0x5FFFE,
192 (isASCII) ? 4 : 5,
193 (isASCII) ? 4 : 5,
194 qr/Unicode non-character.*is not recommended for open interchange/
195 ],
196 [ "non-character code point U+5FFFF",
197 (isASCII) ? "\xf1\x9f\xbf\xbf" : I8_to_native("\xf8\xab\xbf\xbf\xbf"),
198 $::UTF8_WARN_NONCHAR, $::UTF8_DISALLOW_NONCHAR, $::UTF8_GOT_NONCHAR,
199 'nonchar', 0x5FFFF,
200 (isASCII) ? 4 : 5,
201 (isASCII) ? 4 : 5,
202 qr/Unicode non-character.*is not recommended for open interchange/
203 ],
204 [ "non-character code point U+6FFFE",
205 (isASCII) ? "\xf1\xaf\xbf\xbe" : I8_to_native("\xf8\xad\xbf\xbf\xbe"),
206 $::UTF8_WARN_NONCHAR, $::UTF8_DISALLOW_NONCHAR, $::UTF8_GOT_NONCHAR,
207 'nonchar', 0x6FFFE,
208 (isASCII) ? 4 : 5,
209 (isASCII) ? 4 : 5,
210 qr/Unicode non-character.*is not recommended for open interchange/
211 ],
212 [ "non-character code point U+6FFFF",
213 (isASCII) ? "\xf1\xaf\xbf\xbf" : I8_to_native("\xf8\xad\xbf\xbf\xbf"),
214 $::UTF8_WARN_NONCHAR, $::UTF8_DISALLOW_NONCHAR, $::UTF8_GOT_NONCHAR,
215 'nonchar', 0x6FFFF,
216 (isASCII) ? 4 : 5,
217 (isASCII) ? 4 : 5,
218 qr/Unicode non-character.*is not recommended for open interchange/
219 ],
220 [ "non-character code point U+7FFFE",
221 (isASCII) ? "\xf1\xbf\xbf\xbe" : I8_to_native("\xf8\xaf\xbf\xbf\xbe"),
222 $::UTF8_WARN_NONCHAR, $::UTF8_DISALLOW_NONCHAR, $::UTF8_GOT_NONCHAR,
223 'nonchar', 0x7FFFE,
224 (isASCII) ? 4 : 5,
225 (isASCII) ? 4 : 5,
226 qr/Unicode non-character.*is not recommended for open interchange/
227 ],
228 [ "non-character code point U+7FFFF",
229 (isASCII) ? "\xf1\xbf\xbf\xbf" : I8_to_native("\xf8\xaf\xbf\xbf\xbf"),
230 $::UTF8_WARN_NONCHAR, $::UTF8_DISALLOW_NONCHAR, $::UTF8_GOT_NONCHAR,
231 'nonchar', 0x7FFFF,
232 (isASCII) ? 4 : 5,
233 (isASCII) ? 4 : 5,
234 qr/Unicode non-character.*is not recommended for open interchange/
235 ],
236 [ "non-character code point U+8FFFE",
237 (isASCII) ? "\xf2\x8f\xbf\xbe" : I8_to_native("\xf8\xb1\xbf\xbf\xbe"),
238 $::UTF8_WARN_NONCHAR, $::UTF8_DISALLOW_NONCHAR, $::UTF8_GOT_NONCHAR,
239 'nonchar', 0x8FFFE,
240 (isASCII) ? 4 : 5,
241 (isASCII) ? 4 : 5,
242 qr/Unicode non-character.*is not recommended for open interchange/
243 ],
244 [ "non-character code point U+8FFFF",
245 (isASCII) ? "\xf2\x8f\xbf\xbf" : I8_to_native("\xf8\xb1\xbf\xbf\xbf"),
246 $::UTF8_WARN_NONCHAR, $::UTF8_DISALLOW_NONCHAR, $::UTF8_GOT_NONCHAR,
247 'nonchar', 0x8FFFF,
248 (isASCII) ? 4 : 5,
249 (isASCII) ? 4 : 5,
250 qr/Unicode non-character.*is not recommended for open interchange/
251 ],
252 [ "non-character code point U+9FFFE",
253 (isASCII) ? "\xf2\x9f\xbf\xbe" : I8_to_native("\xf8\xb3\xbf\xbf\xbe"),
254 $::UTF8_WARN_NONCHAR, $::UTF8_DISALLOW_NONCHAR, $::UTF8_GOT_NONCHAR,
255 'nonchar', 0x9FFFE,
256 (isASCII) ? 4 : 5,
257 (isASCII) ? 4 : 5,
258 qr/Unicode non-character.*is not recommended for open interchange/
259 ],
260 [ "non-character code point U+9FFFF",
261 (isASCII) ? "\xf2\x9f\xbf\xbf" : I8_to_native("\xf8\xb3\xbf\xbf\xbf"),
262 $::UTF8_WARN_NONCHAR, $::UTF8_DISALLOW_NONCHAR, $::UTF8_GOT_NONCHAR,
263 'nonchar', 0x9FFFF,
264 (isASCII) ? 4 : 5,
265 (isASCII) ? 4 : 5,
266 qr/Unicode non-character.*is not recommended for open interchange/
267 ],
268 [ "non-character code point U+AFFFE",
269 (isASCII) ? "\xf2\xaf\xbf\xbe" : I8_to_native("\xf8\xb5\xbf\xbf\xbe"),
270 $::UTF8_WARN_NONCHAR, $::UTF8_DISALLOW_NONCHAR, $::UTF8_GOT_NONCHAR,
271 'nonchar', 0xAFFFE,
272 (isASCII) ? 4 : 5,
273 (isASCII) ? 4 : 5,
274 qr/Unicode non-character.*is not recommended for open interchange/
275 ],
276 [ "non-character code point U+AFFFF",
277 (isASCII) ? "\xf2\xaf\xbf\xbf" : I8_to_native("\xf8\xb5\xbf\xbf\xbf"),
278 $::UTF8_WARN_NONCHAR, $::UTF8_DISALLOW_NONCHAR, $::UTF8_GOT_NONCHAR,
279 'nonchar', 0xAFFFF,
280 (isASCII) ? 4 : 5,
281 (isASCII) ? 4 : 5,
282 qr/Unicode non-character.*is not recommended for open interchange/
283 ],
284 [ "non-character code point U+BFFFE",
285 (isASCII) ? "\xf2\xbf\xbf\xbe" : I8_to_native("\xf8\xb7\xbf\xbf\xbe"),
286 $::UTF8_WARN_NONCHAR, $::UTF8_DISALLOW_NONCHAR, $::UTF8_GOT_NONCHAR,
287 'nonchar', 0xBFFFE,
288 (isASCII) ? 4 : 5,
289 (isASCII) ? 4 : 5,
290 qr/Unicode non-character.*is not recommended for open interchange/
291 ],
292 [ "non-character code point U+BFFFF",
293 (isASCII) ? "\xf2\xbf\xbf\xbf" : I8_to_native("\xf8\xb7\xbf\xbf\xbf"),
294 $::UTF8_WARN_NONCHAR, $::UTF8_DISALLOW_NONCHAR, $::UTF8_GOT_NONCHAR,
295 'nonchar', 0xBFFFF,
296 (isASCII) ? 4 : 5,
297 (isASCII) ? 4 : 5,
298 qr/Unicode non-character.*is not recommended for open interchange/
299 ],
300 [ "non-character code point U+CFFFE",
301 (isASCII) ? "\xf3\x8f\xbf\xbe" : I8_to_native("\xf8\xb9\xbf\xbf\xbe"),
302 $::UTF8_WARN_NONCHAR, $::UTF8_DISALLOW_NONCHAR, $::UTF8_GOT_NONCHAR,
303 'nonchar', 0xCFFFE,
304 (isASCII) ? 4 : 5,
305 (isASCII) ? 4 : 5,
306 qr/Unicode non-character.*is not recommended for open interchange/
307 ],
308 [ "non-character code point U+CFFFF",
309 (isASCII) ? "\xf3\x8f\xbf\xbf" : I8_to_native("\xf8\xb9\xbf\xbf\xbf"),
310 $::UTF8_WARN_NONCHAR, $::UTF8_DISALLOW_NONCHAR, $::UTF8_GOT_NONCHAR,
311 'nonchar', 0xCFFFF,
312 (isASCII) ? 4 : 5,
313 (isASCII) ? 4 : 5,
314 qr/Unicode non-character.*is not recommended for open interchange/
315 ],
316 [ "non-character code point U+DFFFE",
317 (isASCII) ? "\xf3\x9f\xbf\xbe" : I8_to_native("\xf8\xbb\xbf\xbf\xbe"),
318 $::UTF8_WARN_NONCHAR, $::UTF8_DISALLOW_NONCHAR, $::UTF8_GOT_NONCHAR,
319 'nonchar', 0xDFFFE,
320 (isASCII) ? 4 : 5,
321 (isASCII) ? 4 : 5,
322 qr/Unicode non-character.*is not recommended for open interchange/
323 ],
324 [ "non-character code point U+DFFFF",
325 (isASCII) ? "\xf3\x9f\xbf\xbf" : I8_to_native("\xf8\xbb\xbf\xbf\xbf"),
326 $::UTF8_WARN_NONCHAR, $::UTF8_DISALLOW_NONCHAR, $::UTF8_GOT_NONCHAR,
327 'nonchar', 0xDFFFF,
328 (isASCII) ? 4 : 5,
329 (isASCII) ? 4 : 5,
330 qr/Unicode non-character.*is not recommended for open interchange/
331 ],
332 [ "non-character code point U+EFFFE",
333 (isASCII) ? "\xf3\xaf\xbf\xbe" : I8_to_native("\xf8\xbd\xbf\xbf\xbe"),
334 $::UTF8_WARN_NONCHAR, $::UTF8_DISALLOW_NONCHAR, $::UTF8_GOT_NONCHAR,
335 'nonchar', 0xEFFFE,
336 (isASCII) ? 4 : 5,
337 (isASCII) ? 4 : 5,
338 qr/Unicode non-character.*is not recommended for open interchange/
339 ],
340 [ "non-character code point U+EFFFF",
341 (isASCII) ? "\xf3\xaf\xbf\xbf" : I8_to_native("\xf8\xbd\xbf\xbf\xbf"),
342 $::UTF8_WARN_NONCHAR, $::UTF8_DISALLOW_NONCHAR, $::UTF8_GOT_NONCHAR,
343 'nonchar', 0xEFFFF,
344 (isASCII) ? 4 : 5,
345 (isASCII) ? 4 : 5,
346 qr/Unicode non-character.*is not recommended for open interchange/
347 ],
348 [ "non-character code point U+FFFFE",
349 (isASCII) ? "\xf3\xbf\xbf\xbe" : I8_to_native("\xf8\xbf\xbf\xbf\xbe"),
350 $::UTF8_WARN_NONCHAR, $::UTF8_DISALLOW_NONCHAR, $::UTF8_GOT_NONCHAR,
351 'nonchar', 0xFFFFE,
352 (isASCII) ? 4 : 5,
353 (isASCII) ? 4 : 5,
354 qr/Unicode non-character.*is not recommended for open interchange/
355 ],
356 [ "non-character code point U+FFFFF",
357 (isASCII) ? "\xf3\xbf\xbf\xbf" : I8_to_native("\xf8\xbf\xbf\xbf\xbf"),
358 $::UTF8_WARN_NONCHAR, $::UTF8_DISALLOW_NONCHAR, $::UTF8_GOT_NONCHAR,
359 'nonchar', 0xFFFFF,
360 (isASCII) ? 4 : 5,
361 (isASCII) ? 4 : 5,
362 qr/Unicode non-character.*is not recommended for open interchange/
363 ],
364 [ "non-character code point U+10FFFE",
365 (isASCII) ? "\xf4\x8f\xbf\xbe" : I8_to_native("\xf9\xa1\xbf\xbf\xbe"),
366 $::UTF8_WARN_NONCHAR, $::UTF8_DISALLOW_NONCHAR, $::UTF8_GOT_NONCHAR,
367 'nonchar', 0x10FFFE,
368 (isASCII) ? 4 : 5,
369 (isASCII) ? 4 : 5,
370 qr/Unicode non-character.*is not recommended for open interchange/
371 ],
372 [ "non-character code point U+10FFFF",
373 (isASCII) ? "\xf4\x8f\xbf\xbf" : I8_to_native("\xf9\xa1\xbf\xbf\xbf"),
374 $::UTF8_WARN_NONCHAR, $::UTF8_DISALLOW_NONCHAR, $::UTF8_GOT_NONCHAR,
375 'nonchar', 0x10FFFF,
376 (isASCII) ? 4 : 5,
377 (isASCII) ? 4 : 5,
378 qr/Unicode non-character.*is not recommended for open interchange/
379 ],
6aa905cf
KW
380);
381
382if (! $::is64bit) {
383 if (isASCII) {
384 no warnings qw{portable overflow};
385 push @tests,
386 [ "Lowest 33 bit code point: overflow",
387 "\xFE\x84\x80\x80\x80\x80\x80",
388 $::UTF8_WARN_ABOVE_31_BIT, $::UTF8_DISALLOW_ABOVE_31_BIT,
389 $::UTF8_GOT_ABOVE_31_BIT,
390 'utf8', 0x100000000,
391 7, 1,
392 qr/and( is)? not portable/
393 ];
394 }
395}
396else {
397 no warnings qw{portable overflow};
398 push @tests,
399 [ "More than 32 bits",
400 (isASCII)
401 ? "\xff\x80\x80\x80\x80\x80\x81\x80\x80\x80\x80\x80\x80"
402 : I8_to_native(
403 "\xff\xa0\xa0\xa0\xa0\xa0\xa2\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
404 $::UTF8_WARN_ABOVE_31_BIT, $::UTF8_DISALLOW_ABOVE_31_BIT,
405 $::UTF8_GOT_ABOVE_31_BIT,
406 'utf8', 0x1000000000,
407 $::max_bytes, (isASCII) ? 1 : 7,
408 qr/and( is)? not portable/
409 ];
51099b64
DM
410 [ "requires at least 32 bits",
411 (isASCII)
412 ? "\xfe\x82\x80\x80\x80\x80\x80"
413 : I8_to_native(
414 "\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa2\xa0\xa0\xa0\xa0\xa0\xa0"),
415 # This code point is chosen so that it is representable in a UV on
416 # 32-bit machines
417 $::UTF8_WARN_ABOVE_31_BIT, $::UTF8_DISALLOW_ABOVE_31_BIT,
418 $::UTF8_GOT_ABOVE_31_BIT,
419 'utf8', 0x80000000,
420 (isASCII) ? 7 : $::max_bytes,
421 (isASCII) ? 1 : 8,
422 nonportable_regex(0x80000000)
423 ],
424 [ "highest 32 bit code point",
425 (isASCII)
426 ? "\xfe\x83\xbf\xbf\xbf\xbf\xbf"
427 : I8_to_native(
428 "\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa3\xbf\xbf\xbf\xbf\xbf\xbf"),
429 $::UTF8_WARN_ABOVE_31_BIT, $::UTF8_DISALLOW_ABOVE_31_BIT,
430 $::UTF8_GOT_ABOVE_31_BIT,
431 'utf8', 0xFFFFFFFF,
432 (isASCII) ? 7 : $::max_bytes,
433 (isASCII) ? 1 : 8,
434 nonportable_regex(0xffffffff)
435 ],
436 [ "requires at least 32 bits, and use SUPER-type flags, instead of"
437 . " ABOVE_31_BIT",
438 (isASCII)
439 ? "\xfe\x82\x80\x80\x80\x80\x80"
440 : I8_to_native(
441 "\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa2\xa0\xa0\xa0\xa0\xa0\xa0"),
442 $::UTF8_WARN_SUPER, $::UTF8_DISALLOW_SUPER, $::UTF8_GOT_SUPER,
443 'utf8', 0x80000000,
444 (isASCII) ? 7 : $::max_bytes,
445 1,
446 nonportable_regex(0x80000000)
447 ],
448 [ "overflow with warnings/disallow for more than 31 bits",
449 # This tests the interaction of WARN_ABOVE_31_BIT/DISALLOW_ABOVE_31_BIT
450 # with overflow. The overflow malformation is never allowed, so
451 # preventing it takes precedence if the ABOVE_31_BIT options would
452 # otherwise allow in an overflowing value. The ASCII code points (1
453 # for 32-bits; 1 for 64) were chosen because the old overflow
454 # detection algorithm did not catch them; this means this test also
455 # checks for that fix. The EBCDIC are arbitrary overflowing ones
456 # since we have no reports of failures with it.
457 ((isASCII)
458 ? "\xff\x80\x90\x90\x90\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf"
459 : I8_to_native(
460 "\xff\xB0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0")),
461 $::UTF8_WARN_ABOVE_31_BIT,
462 $::UTF8_DISALLOW_ABOVE_31_BIT,
463 $::UTF8_GOT_ABOVE_31_BIT,
464 'utf8', 0,
465 (! isASCII || $::is64bit) ? $::max_bytes : 7,
466 (isASCII || $::is64bit) ? 2 : 8,
467 qr/overflows/
468 ];
469
6aa905cf
KW
470 if (! isASCII) {
471 push @tests, # These could falsely show wrongly in a naive
472 # implementation
473 [ "requires at least 32 bits",
474 I8_to_native(
475 "\xff\xa0\xa0\xa0\xa0\xa0\xa1\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
476 $::UTF8_WARN_ABOVE_31_BIT,$::UTF8_DISALLOW_ABOVE_31_BIT,
477 $::UTF8_GOT_ABOVE_31_BIT,
478 'utf8', 0x800000000,
479 $::max_bytes, 7,
480 nonportable_regex(0x80000000)
481 ],
482 [ "requires at least 32 bits",
483 I8_to_native(
484 "\xff\xa0\xa0\xa0\xa0\xa1\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
485 $::UTF8_WARN_ABOVE_31_BIT,$::UTF8_DISALLOW_ABOVE_31_BIT,
486 $::UTF8_GOT_ABOVE_31_BIT,
487 'utf8', 0x10000000000,
488 $::max_bytes, 6,
489 nonportable_regex(0x10000000000)
490 ],
491 [ "requires at least 32 bits",
492 I8_to_native(
493 "\xff\xa0\xa0\xa0\xa1\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
494 $::UTF8_WARN_ABOVE_31_BIT,$::UTF8_DISALLOW_ABOVE_31_BIT,
495 $::UTF8_GOT_ABOVE_31_BIT,
496 'utf8', 0x200000000000,
497 $::max_bytes, 5,
498 nonportable_regex(0x20000000000)
499 ],
500 [ "requires at least 32 bits",
501 I8_to_native(
502 "\xff\xa0\xa0\xa1\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
503 $::UTF8_WARN_ABOVE_31_BIT,$::UTF8_DISALLOW_ABOVE_31_BIT,
504 $::UTF8_GOT_ABOVE_31_BIT,
505 'utf8', 0x4000000000000,
506 $::max_bytes, 4,
507 nonportable_regex(0x4000000000000)
508 ],
509 [ "requires at least 32 bits",
510 I8_to_native(
511 "\xff\xa0\xa1\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
512 $::UTF8_WARN_ABOVE_31_BIT,$::UTF8_DISALLOW_ABOVE_31_BIT,
513 $::UTF8_GOT_ABOVE_31_BIT,
514 'utf8', 0x80000000000000,
515 $::max_bytes, 3,
516 nonportable_regex(0x80000000000000)
517 ],
518 [ "requires at least 32 bits",
519 I8_to_native(
520 "\xff\xa1\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
521 $::UTF8_WARN_ABOVE_31_BIT,$::UTF8_DISALLOW_ABOVE_31_BIT,
522 $::UTF8_GOT_ABOVE_31_BIT,
523 'utf8', 0x1000000000000000,
524 $::max_bytes, 2,
525 nonportable_regex(0x1000000000000000)
526 ];
527 }
528}
529
530# This test is split into this number of files.
531my $num_test_files = $ENV{TEST_JOBS} || 1;
532$num_test_files = 10 if $num_test_files > 10;
533
534my $test_count = -1;
535foreach my $test (@tests) {
536 $test_count++;
537 next if $test_count % $num_test_files != $::TEST_CHUNK;
538
539 my ($testname, $bytes, $warn_flags, $disallow_flags, $expected_error_flags,
540 $category, $allowed_uv, $expected_len, $needed_to_discern_len, $message
541 ) = @$test;
542
543 my $length = length $bytes;
544 my $will_overflow = $testname =~ /overflow/ ? 'overflow' : "";
545
546 {
547 use warnings;
548 undef @warnings;
549 my $ret = test_isUTF8_CHAR($bytes, $length);
550 my $ret_flags = test_isUTF8_CHAR_flags($bytes, $length, 0);
551 if ($will_overflow) {
552 is($ret, 0, "isUTF8_CHAR() $testname: returns 0");
553 is($ret_flags, 0, "isUTF8_CHAR_flags() $testname: returns 0");
554 }
555 else {
556 is($ret, $length,
557 "isUTF8_CHAR() $testname: returns expected length: $length");
558 is($ret_flags, $length, "isUTF8_CHAR_flags(...,0) $testname:"
559 . " returns expected length: $length");
560 }
561 is(scalar @warnings, 0,
562 "isUTF8_CHAR() and isUTF8_CHAR()_flags $testname: generated"
563 . " no warnings")
564 or output_warnings(@warnings);
565
566 undef @warnings;
567 $ret = test_isSTRICT_UTF8_CHAR($bytes, $length);
568 if ($will_overflow) {
569 is($ret, 0, "isSTRICT_UTF8_CHAR() $testname: returns 0");
570 }
571 else {
572 my $expected_ret = ( $testname =~ /surrogate|non-character/
573 || $allowed_uv > 0x10FFFF)
574 ? 0
575 : $length;
576 is($ret, $expected_ret, "isSTRICT_UTF8_CHAR() $testname: returns"
577 . " expected length: $expected_ret");
578 $ret = test_isUTF8_CHAR_flags($bytes, $length,
579 $::UTF8_DISALLOW_ILLEGAL_INTERCHANGE);
580 is($ret, $expected_ret,
581 "isUTF8_CHAR_flags('DISALLOW_ILLEGAL_INTERCHANGE')"
582 . " acts like isSTRICT_UTF8_CHAR");
583 }
584 is(scalar @warnings, 0,
585 "isSTRICT_UTF8_CHAR() and isUTF8_CHAR_flags $testname:"
586 . " generated no warnings")
587 or output_warnings(@warnings);
588
589 undef @warnings;
590 $ret = test_isC9_STRICT_UTF8_CHAR($bytes, $length);
591 if ($will_overflow) {
592 is($ret, 0, "isC9_STRICT_UTF8_CHAR() $testname: returns 0");
593 }
594 else {
595 my $expected_ret = ( $testname =~ /surrogate/
596 || $allowed_uv > 0x10FFFF)
597 ? 0
598 : $length;
599 is($ret, $expected_ret, "isC9_STRICT_UTF8_CHAR() $testname:"
600 ." returns expected length: $expected_ret");
601 $ret = test_isUTF8_CHAR_flags($bytes, $length,
602 $::UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE);
603 is($ret, $expected_ret,
604 "isUTF8_CHAR_flags('DISALLOW_ILLEGAL_C9_INTERCHANGE')"
605 . " acts like isC9_STRICT_UTF8_CHAR");
606 }
607 is(scalar @warnings, 0,
608 "isC9_STRICT_UTF8_CHAR() and isUTF8_CHAR_flags $testname:"
609 . " generated no warnings")
610 or output_warnings(@warnings);
611
612 # Test partial character handling, for each byte not a full character
613 for my $j (1.. $length - 1) {
614
615 # Skip the test for the interaction between overflow and above-31
616 # bit. It is really testing other things than the partial
617 # character tests, for which other tests in this file are
618 # sufficient
619 last if $testname =~ /overflow/;
620
621 foreach my $disallow_flag (0, $disallow_flags) {
622 my $partial = substr($bytes, 0, $j);
623 my $ret_should_be;
624 my $comment;
625 if ($disallow_flag) {
626 $ret_should_be = 0;
627 $comment = "disallowed";
628 if ($j < $needed_to_discern_len) {
629 $ret_should_be = 1;
630 $comment .= ", but need $needed_to_discern_len bytes"
631 . " to discern:";
632 }
633 }
634 else {
635 $ret_should_be = 1;
636 $comment = "allowed";
637 }
638
639 undef @warnings;
640
641 $ret = test_is_utf8_valid_partial_char_flags($partial, $j,
642 $disallow_flag);
643 is($ret, $ret_should_be,
644 "$testname: is_utf8_valid_partial_char_flags("
645 . display_bytes($partial)
646 . "), $comment: returns $ret_should_be");
647 is(scalar @warnings, 0,
648 "$testname: is_utf8_valid_partial_char_flags()"
649 . " generated no warnings")
650 or output_warnings(@warnings);
651 }
652 }
653 }
654
655 # This is more complicated than the malformations tested earlier, as there
656 # are several orthogonal variables involved. We test all the subclasses
657 # of utf8 warnings to verify they work with and without the utf8 class,
658 # and don't have effects on other sublass warnings
659 foreach my $warning ('utf8', 'surrogate', 'nonchar', 'non_unicode') {
660 foreach my $warn_flag (0, $warn_flags) {
661 foreach my $disallow_flag (0, $disallow_flags) {
662 foreach my $do_warning (0, 1) {
663
664 # We try each of the above with various combinations of
665 # malformations that can occur on the same input sequence.
666 foreach my $short ("", "short") {
667 foreach my $unexpected_noncont ("",
668 "unexpected non-continuation")
669 {
670 foreach my $overlong ("", "overlong") {
671
672 # If we're already at the longest possible, we
673 # can't create an overlong (which would be longer)
674 # can't handle anything larger.
675 next if $overlong && $expected_len >= $::max_bytes;
676
677 my @malformations;
678 my @expected_errors;
679 push @malformations, $short if $short;
680 push @malformations, $unexpected_noncont
681 if $unexpected_noncont;
682 push @malformations, $overlong if $overlong;
683
684 # The overflow malformation test in the input
685 # array is coerced into being treated like one of
686 # the others.
687 if ($will_overflow) {
688 push @malformations, 'overflow';
689 push @expected_errors, $::UTF8_GOT_OVERFLOW;
690 }
691
692 my $malformations_name = join "/", @malformations;
693 $malformations_name .= " malformation"
694 if $malformations_name;
695 $malformations_name .= "s" if @malformations > 1;
696 my $this_bytes = $bytes;
697 my $this_length = $length;
698 my $expected_uv = $allowed_uv;
699 my $this_expected_len = $expected_len;
700 my $this_needed_to_discern_len = $needed_to_discern_len;
701 if ($malformations_name) {
702 $expected_uv = 0;
703
704 # Coerce the input into the desired
705 # malformation
706 if ($malformations_name =~ /overlong/) {
707
708 # For an overlong, we convert the original
709 # start byte into a continuation byte with
710 # the same data bits as originally. ...
711 substr($this_bytes, 0, 1)
712 = start_byte_to_cont(substr($this_bytes,
713 0, 1));
714
715 # ... Then we prepend it with a known
716 # overlong sequence. This should evaluate
717 # to the exact same code point as the
718 # original.
719 $this_bytes
720 = I8_to_native("\xff")
721 . (I8_to_native(chr $::first_continuation)
722 x ( $::max_bytes - 1 - length($this_bytes)))
723 . $this_bytes;
724 $this_length = length($this_bytes);
725 $this_needed_to_discern_len
726 = $::max_bytes - ($this_expected_len
727 - $this_needed_to_discern_len);
728 $this_expected_len = $::max_bytes;
729 push @expected_errors, $::UTF8_GOT_LONG;
730 }
731 if ($malformations_name =~ /short/) {
732
733 # Just tell the test to not look far
734 # enough into the input.
735 $this_length--;
736 $this_expected_len--;
737 push @expected_errors, $::UTF8_GOT_SHORT;
738 }
739 if ($malformations_name
740 =~ /non-continuation/)
741 {
742 # Change the final continuation byte into
743 # a non one.
744 my $pos = ($short) ? -2 : -1;
745 substr($this_bytes, $pos, 1) = '?';
746 $this_expected_len--;
747 push @expected_errors,
748 $::UTF8_GOT_NON_CONTINUATION;
749 }
750 }
751
752 my $eval_warn = $do_warning
753 ? "use warnings '$warning'"
754 : $warning eq "utf8"
755 ? "no warnings 'utf8'"
756 : ( "use warnings 'utf8';"
757 . " no warnings '$warning'");
758
759 # Is effectively disallowed if we've set up a
760 # malformation, even if the flag indicates it is
761 # allowed. Fix up test name to indicate this as
762 # well
763 my $disallowed = $disallow_flag
764 || $malformations_name;
765 my $this_name = "utf8n_to_uvchr_error() $testname: "
766 . (($disallow_flag)
767 ? 'disallowed'
768 : $disallowed
769 ? $disallowed
770 : 'allowed');
771 $this_name .= ", $eval_warn";
772 $this_name .= ", " . (($warn_flag)
773 ? 'with warning flag'
774 : 'no warning flag');
775
776 undef @warnings;
777 my $ret_ref;
778 my $display_bytes = display_bytes($this_bytes);
779 my $call = " Call was: $eval_warn; \$ret_ref"
780 . " = test_utf8n_to_uvchr_error("
781 . "'$display_bytes', $this_length,"
782 . "$warn_flag"
783 . "|$disallow_flag)";
784 my $eval_text = "$eval_warn; \$ret_ref"
785 . " = test_utf8n_to_uvchr_error("
786 . "'$this_bytes',"
787 . " $this_length, $warn_flag"
788 . "|$disallow_flag)";
789 eval "$eval_text";
790 if (! ok ("$@ eq ''",
791 "$this_name: eval succeeded"))
792 {
793 diag "\$!='$!'; eval'd=\"$call\"";
794 next;
795 }
796 if ($disallowed) {
797 is($ret_ref->[0], 0, "$this_name: Returns 0")
798 or diag $call;
799 }
800 else {
801 is($ret_ref->[0], $expected_uv,
802 "$this_name: Returns expected uv: "
803 . sprintf("0x%04X", $expected_uv))
804 or diag $call;
805 }
806 is($ret_ref->[1], $this_expected_len,
807 "$this_name: Returns expected length:"
808 . " $this_expected_len")
809 or diag $call;
810
811 my $errors = $ret_ref->[2];
812
813 for (my $i = @expected_errors - 1; $i >= 0; $i--) {
814 if (ok($expected_errors[$i] & $errors,
815 "Expected and got error bit return"
816 . " for $malformations[$i] malformation"))
817 {
818 $errors &= ~$expected_errors[$i];
819 }
820 splice @expected_errors, $i, 1;
821 }
822 is(scalar @expected_errors, 0,
823 "Got all the expected malformation errors")
824 or diag Dumper \@expected_errors;
825
826 if ( $this_expected_len >= $this_needed_to_discern_len
827 && ($warn_flag || $disallow_flag))
828 {
829 is($errors, $expected_error_flags,
830 "Got the correct error flag")
831 or diag $call;
832 }
833 else {
834 is($errors, 0, "Got no other error flag");
835 }
836
837 if (@malformations) {
838 if (! $do_warning && $warning eq 'utf8') {
839 goto no_warnings_expected;
840 }
841
842 # Check that each malformation generates a
843 # warning, removing that warning if found
844 MALFORMATION:
845 foreach my $malformation (@malformations) {
846 foreach (my $i = 0; $i < @warnings; $i++) {
847 if ($warnings[$i] =~ /$malformation/) {
848 pass("Expected and got"
849 . "'$malformation' warning");
850 splice @warnings, $i, 1;
851 next MALFORMATION;
852 }
853 }
854 fail("Expected '$malformation' warning"
855 . " but didn't get it");
856
857 }
858 }
859
860 # Any overflow will override any super or above-31
861 # warnings.
862 goto no_warnings_expected
863 if $will_overflow || $this_expected_len
864 < $this_needed_to_discern_len;
865
866 if ( ! $do_warning
867 && ( $warning eq 'utf8'
868 || $warning eq $category))
869 {
870 goto no_warnings_expected;
871 }
872 elsif ($warn_flag) {
873 if (is(scalar @warnings, 1,
874 "$this_name: Got a single warning "))
875 {
876 like($warnings[0], $message,
877 "$this_name: Got expected warning")
878 or diag $call;
879 }
880 else {
881 diag $call;
882 if (scalar @warnings) {
883 output_warnings(@warnings);
884 }
885 }
886 }
887 else {
888 no_warnings_expected:
889 unless (is(scalar @warnings, 0,
890 "$this_name: Got no warnings"))
891 {
892 diag $call;
893 output_warnings(@warnings);
894 }
895 }
896
897 # Check CHECK_ONLY results when the input is
898 # disallowed. Do this when actually disallowed,
899 # not just when the $disallow_flag is set
900 if ($disallowed) {
901 undef @warnings;
902 $ret_ref = test_utf8n_to_uvchr_error(
903 $this_bytes, $this_length,
904 $disallow_flag|$::UTF8_CHECK_ONLY);
905 is($ret_ref->[0], 0,
906 "$this_name, CHECK_ONLY: Returns 0")
907 or diag $call;
908 is($ret_ref->[1], -1,
909 "$this_name: CHECK_ONLY: returns -1 for length")
910 or diag $call;
911 if (! is(scalar @warnings, 0,
912 "$this_name, CHECK_ONLY: no warnings"
913 . " generated"))
914 {
915 diag $call;
916 output_warnings(@warnings);
917 }
918 }
919
920 # Now repeat some of the above, but for
921 # uvchr_to_utf8_flags(). Since this comes from an
922 # existing code point, it hasn't overflowed, and
923 # isn't malformed.
924 next if @malformations;
925
926 # The warning and disallow flags passed in are for
927 # utf8n_to_uvchr_error(). Convert them for
928 # uvchr_to_utf8_flags().
929 my $uvchr_warn_flag = 0;
930 my $uvchr_disallow_flag = 0;
931 if ($warn_flag) {
932 if ($warn_flag == $::UTF8_WARN_SURROGATE) {
933 $uvchr_warn_flag = $::UNICODE_WARN_SURROGATE
934 }
935 elsif ($warn_flag == $::UTF8_WARN_NONCHAR) {
936 $uvchr_warn_flag = $::UNICODE_WARN_NONCHAR
937 }
938 elsif ($warn_flag == $::UTF8_WARN_SUPER) {
939 $uvchr_warn_flag = $::UNICODE_WARN_SUPER
940 }
941 elsif ($warn_flag == $::UTF8_WARN_ABOVE_31_BIT) {
942 $uvchr_warn_flag
943 = $::UNICODE_WARN_ABOVE_31_BIT;
944 }
945 else {
946 fail(sprintf "Unexpected warn flag: %x",
947 $warn_flag);
948 next;
949 }
950 }
951 if ($disallow_flag) {
952 if ($disallow_flag == $::UTF8_DISALLOW_SURROGATE)
953 {
954 $uvchr_disallow_flag
955 = $::UNICODE_DISALLOW_SURROGATE;
956 }
957 elsif ($disallow_flag == $::UTF8_DISALLOW_NONCHAR)
958 {
959 $uvchr_disallow_flag
960 = $::UNICODE_DISALLOW_NONCHAR;
961 }
962 elsif ($disallow_flag == $::UTF8_DISALLOW_SUPER) {
963 $uvchr_disallow_flag
964 = $::UNICODE_DISALLOW_SUPER;
965 }
966 elsif ($disallow_flag
967 == $::UTF8_DISALLOW_ABOVE_31_BIT)
968 {
969 $uvchr_disallow_flag =
970 $::UNICODE_DISALLOW_ABOVE_31_BIT;
971 }
972 else {
973 fail(sprintf "Unexpected disallow flag: %x",
974 $disallow_flag);
975 next;
976 }
977 }
978
979 $disallowed = $uvchr_disallow_flag;
980
981 $this_name = "uvchr_to_utf8_flags() $testname: "
982 . (($uvchr_disallow_flag)
983 ? 'disallowed'
984 : ($disallowed)
985 ? 'ABOVE_31_BIT allowed'
986 : 'allowed');
987 $this_name .= ", $eval_warn";
988 $this_name .= ", " . (($uvchr_warn_flag)
989 ? 'with warning flag'
990 : 'no warning flag');
991
992 undef @warnings;
993 my $ret;
994 my $warn_flag = sprintf "0x%x", $uvchr_warn_flag;
995 my $disallow_flag = sprintf "0x%x",
996 $uvchr_disallow_flag;
997 $call = sprintf(" Call was: $eval_warn; \$ret"
998 . " = test_uvchr_to_utf8_flags("
999 . " 0x%x, $warn_flag|$disallow_flag)",
1000 $allowed_uv);
1001 $eval_text = "$eval_warn; \$ret ="
1002 . " test_uvchr_to_utf8_flags("
1003 . "$allowed_uv, $warn_flag|"
1004 . "$disallow_flag)";
1005 eval "$eval_text";
1006 if (! ok ("$@ eq ''", "$this_name: eval succeeded"))
1007 {
1008 diag "\$!='$!'; eval'd=\"$eval_text\"";
1009 next;
1010 }
1011 if ($disallowed) {
1012 is($ret, undef, "$this_name: Returns undef")
1013 or diag $call;
1014 }
1015 else {
1016 is($ret, $bytes, "$this_name: Returns expected string")
1017 or diag $call;
1018 }
1019 if (! $do_warning
1020 && ($warning eq 'utf8' || $warning eq $category))
1021 {
1022 if (!is(scalar @warnings, 0,
1023 "$this_name: No warnings generated"))
1024 {
1025 diag $call;
1026 output_warnings(@warnings);
1027 }
1028 }
1029 elsif ( $uvchr_warn_flag
1030 && ( $warning eq 'utf8'
1031 || $warning eq $category))
1032 {
1033 if (is(scalar @warnings, 1,
1034 "$this_name: Got a single warning "))
1035 {
1036 like($warnings[0], $message,
1037 "$this_name: Got expected warning")
1038 or diag $call;
1039 }
1040 else {
1041 diag $call;
1042 output_warnings(@warnings)
1043 if scalar @warnings;
1044 }
1045 }
1046 }
1047 }
1048 }
1049 }
1050 }
1051 }
1052 }
1053}
1054
1055done_testing;