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