This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
utf8.c: Fix warning category and subcategory conflicts
[perl5.git] / ext / XS-APItest / t / utf8.t
CommitLineData
fed3ba5d
NC
1#!perl -w
2
3use strict;
4use Test::More;
5
6use XS::APItest;
7
8foreach ([0, '', '', 'empty'],
9 [0, 'N', 'N', '1 char'],
10 [1, 'NN', 'N', '1 char substring'],
11 [-2, 'Perl', 'Rules', 'different'],
12 [0, chr 163, chr 163, 'pound sign'],
13 [1, chr (163) . 10, chr (163) . 1, '10 pounds is more than 1 pound'],
14 [1, chr(163) . chr(163), chr 163, '2 pound signs are more than 1'],
15 [-2, ' $!', " \x{1F42B}!", 'Camels are worth more than 1 dollar'],
16 [-1, '!', "!\x{1F42A}", 'Initial substrings match'],
17 ) {
18 my ($expect, $left, $right, $desc) = @$_;
19 my $copy = $right;
20 utf8::encode($copy);
21 is(bytes_cmp_utf8($left, $copy), $expect, $desc);
22 next if $right =~ tr/\0-\377//c;
23 utf8::encode($left);
24 is(bytes_cmp_utf8($right, $left), -$expect, "$desc reversed");
25}
26
bd70aaaf 27# Test uft8n_to_uvchr(). These provide essentially complete code coverage.
eb83ed87
KW
28
29# Copied from utf8.h
30my $UTF8_ALLOW_EMPTY = 0x0001;
31my $UTF8_ALLOW_CONTINUATION = 0x0002;
32my $UTF8_ALLOW_NON_CONTINUATION = 0x0004;
33my $UTF8_ALLOW_SHORT = 0x0008;
34my $UTF8_ALLOW_LONG = 0x0010;
35my $UTF8_DISALLOW_SURROGATE = 0x0020;
36my $UTF8_WARN_SURROGATE = 0x0040;
37my $UTF8_DISALLOW_NONCHAR = 0x0080;
38my $UTF8_WARN_NONCHAR = 0x0100;
39my $UTF8_DISALLOW_SUPER = 0x0200;
40my $UTF8_WARN_SUPER = 0x0400;
41my $UTF8_DISALLOW_FE_FF = 0x0800;
42my $UTF8_WARN_FE_FF = 0x1000;
43my $UTF8_CHECK_ONLY = 0x2000;
44
45my $REPLACEMENT = 0xFFFD;
46
47my @warnings;
48
49use warnings 'utf8';
50local $SIG{__WARN__} = sub { push @warnings, @_ };
51
52# First test the malformations. All these raise category utf8 warnings.
53foreach my $test (
54 [ "zero length string malformation", "", 0,
55 $UTF8_ALLOW_EMPTY, 0, 0,
56 qr/empty string/
57 ],
58 [ "orphan continuation byte malformation", "\x80a", 2,
59 $UTF8_ALLOW_CONTINUATION, $REPLACEMENT, 1,
60 qr/unexpected continuation byte/
61 ],
62 [ "premature next character malformation (immediate)", "\xc2a", 2,
63 $UTF8_ALLOW_NON_CONTINUATION, $REPLACEMENT, 1,
64 qr/unexpected non-continuation byte.*immediately after start byte/
65 ],
66 [ "premature next character malformation (non-immediate)", "\xf0\x80a", 3,
67 $UTF8_ALLOW_NON_CONTINUATION, $REPLACEMENT, 2,
68 qr/unexpected non-continuation byte .* 2 bytes after start byte/
69 ],
70 [ "too short malformation", "\xf0\x80a", 2,
71 # Having the 'a' after this, but saying there are only 2 bytes also
72 # tests that we pay attention to the passed in length
73 $UTF8_ALLOW_SHORT, $REPLACEMENT, 2,
74 qr/2 bytes, need 4/
75 ],
76 [ "overlong malformation", "\xc1\xaf", 2,
77 $UTF8_ALLOW_LONG, ord('o'), 2,
78 qr/2 bytes, need 1/
79 ],
80 [ "overflow malformation", "\xff\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf", 13,
81 0, # There is no way to allow this malformation
82 $REPLACEMENT, 13,
83 qr/overflow/
84 ],
85) {
86 my ($testname, $bytes, $length, $allow_flags, $allowed_uv, $expected_len, $message ) = @$test;
87
88 next if ! ok(length($bytes) >= $length, "$testname: Make sure won't read beyond buffer: " . length($bytes) . " >= $length");
89
90 # Test what happens when this malformation is not allowed
91 undef @warnings;
bd70aaaf 92 my $ret_ref = test_utf8n_to_uvchr($bytes, $length, 0);
eb83ed87
KW
93 is($ret_ref->[0], 0, "$testname: disallowed: Returns 0");
94 is($ret_ref->[1], $expected_len, "$testname: disallowed: Returns expected length");
95 if (is(scalar @warnings, 1, "$testname: disallowed: Got a single warning ")) {
96 like($warnings[0], $message, "$testname: disallowed: Got expected warning");
97 }
98 else {
99 if (scalar @warnings) {
100 note "The warnings were: " . join(", ", @warnings);
101 }
102 }
103
104 { # Next test when disallowed, and warnings are off.
105 undef @warnings;
106 no warnings 'utf8';
bd70aaaf 107 my $ret_ref = test_utf8n_to_uvchr($bytes, $length, 0);
eb83ed87
KW
108 is($ret_ref->[0], 0, "$testname: disallowed: no warnings 'utf8': Returns 0");
109 is($ret_ref->[1], $expected_len, "$testname: disallowed: no warnings 'utf8': Returns expected length");
110 if (!is(scalar @warnings, 0, "$testname: disallowed: no warnings 'utf8': no warnings generated")) {
111 note "The warnings were: " . join(", ", @warnings);
112 }
113 }
114
115 # Test with CHECK_ONLY
116 undef @warnings;
bd70aaaf 117 $ret_ref = test_utf8n_to_uvchr($bytes, $length, $UTF8_CHECK_ONLY);
eb83ed87
KW
118 is($ret_ref->[0], 0, "$testname: CHECK_ONLY: Returns 0");
119 is($ret_ref->[1], -1, "$testname: CHECK_ONLY: returns expected length");
120 if (! is(scalar @warnings, 0, "$testname: CHECK_ONLY: no warnings generated")) {
121 note "The warnings were: " . join(", ", @warnings);
122 }
123
124 next if $allow_flags == 0; # Skip if can't allow this malformation
125
126 # Test when the malformation is allowed
127 undef @warnings;
bd70aaaf 128 $ret_ref = test_utf8n_to_uvchr($bytes, $length, $allow_flags);
eb83ed87
KW
129 is($ret_ref->[0], $allowed_uv, "$testname: allowed: Returns expected uv");
130 is($ret_ref->[1], $expected_len, "$testname: allowed: Returns expected length");
131 if (!is(scalar @warnings, 0, "$testname: allowed: no warnings generated"))
132 {
133 note "The warnings were: " . join(", ", @warnings);
134 }
135}
136
137my $FF_ret;
138
139use Unicode::UCD;
140my $has_quad = ($Unicode::UCD::MAX_CP > 0xFFFF_FFFF);
141if ($has_quad) {
142 no warnings qw{portable overflow};
143 $FF_ret = 0x1000000000;
144}
145else { # The above overflows unless a quad platform
146 $FF_ret = 0;
147}
148
149# Now test the cases where a legal code point is generated, but may or may not
150# be allowed/warned on.
2f8f112e 151my @tests = (
eb83ed87
KW
152 [ "surrogate", "\xed\xa4\x8d",
153 $UTF8_WARN_SURROGATE, $UTF8_DISALLOW_SURROGATE, 'surrogate', 0xD90D, 3,
154 qr/surrogate/
155 ],
156 [ "non_unicode", "\xf4\x90\x80\x80",
157 $UTF8_WARN_SUPER, $UTF8_DISALLOW_SUPER, 'non_unicode', 0x110000, 4,
158 qr/not Unicode/
159 ],
160 [ "non-character code point", "\xEF\xB7\x90",
161 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, 'nonchar', 0xFDD0, 3,
162 qr/Unicode non-character.*is illegal for open interchange/
163 ],
164 [ "begins with FE", "\xfe\x82\x80\x80\x80\x80\x80",
165
166 # This code point is chosen so that it is representable in a UV on
2f8f112e 167 # 32-bit machines
eb83ed87
KW
168 $UTF8_WARN_FE_FF, $UTF8_DISALLOW_FE_FF, 'utf8', 0x80000000, 7,
169 qr/Code point beginning with byte .* is not Unicode, and not portable/
170 ],
2f8f112e
KW
171 [ "overflow with FE/FF",
172 # This tests the interaction of WARN_FE_FF/DISALLOW_FE_FF with
173 # overflow. The overflow malformation is never allowed, so preventing
174 # it takes precedence if the FE_FF options would otherwise allow in an
175 # overflowing value. These two code points (1 for 32-bits; 1 for 64)
176 # were chosen because the old overflow detection algorithm did not
177 # catch them; this means this test also checks for that fix.
178 ($has_quad)
179 ? "\xff\x80\x90\x90\x90\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf"
180 : "\xfe\x86\x80\x80\x80\x80\x80",
181 $UTF8_WARN_FE_FF, $UTF8_DISALLOW_FE_FF, 'utf8', 0,
182 ($has_quad) ? 13 : 7,
eb83ed87
KW
183 qr/Code point beginning with byte .* is not Unicode, and not portable/
184 ],
2f8f112e
KW
185);
186
187if ($has_quad) { # All FF's will overflow on 32 bit
188 push @tests,
189 [ "begins with FF", "\xff\x80\x80\x80\x80\x80\x81\x80\x80\x80\x80\x80\x80",
190 $UTF8_WARN_FE_FF, $UTF8_DISALLOW_FE_FF, 'utf8', $FF_ret, 13,
191 qr/Code point beginning with byte .* is not Unicode, and not portable/
192 ];
193}
194
195foreach my $test (@tests) {
eb83ed87
KW
196 my ($testname, $bytes, $warn_flags, $disallow_flags, $category, $allowed_uv, $expected_len, $message ) = @$test;
197
198 my $length = length $bytes;
2f8f112e 199 my $will_overflow = $testname =~ /overflow/;
eb83ed87
KW
200
201 # This is more complicated than the malformations tested earlier, as there
202 # are several orthogonal variables involved. We test all the subclasses
203 # of utf8 warnings to verify they work with and without the utf8 class,
204 # and don't have effects on other sublass warnings
54f4afef 205 foreach my $warning ('utf8', 'surrogate', 'nonchar', 'non_unicode') {
eb83ed87
KW
206 foreach my $warn_flag (0, $warn_flags) {
207 foreach my $disallow_flag (0, $disallow_flags) {
54f4afef 208 foreach my $do_warning (0, 1) {
eb83ed87 209
54f4afef
KW
210 my $eval_warn = $do_warning
211 ? "use warnings '$warning'"
212 : $warning eq "utf8"
213 ? "no warnings 'utf8'"
214 : "use warnings 'utf8'; no warnings '$warning'";
2f8f112e
KW
215
216 # is effectively disallowed if will overflow, even if the flag
217 # indicates it is allowed, fix up test name to indicate this
218 # as well
219 my $disallowed = $disallow_flag || $will_overflow;
220
221 my $this_name = "$testname: " . (($disallow_flag)
222 ? 'disallowed'
223 : ($disallowed)
224 ? 'FE_FF allowed'
225 : 'allowed');
eb83ed87
KW
226 $this_name .= ", $eval_warn";
227 $this_name .= ", " . (($warn_flag) ? 'with warning flag' : 'no warning flag');
228
229 undef @warnings;
230 my $ret_ref;
bd70aaaf
KW
231 #note __LINE__ . ": $eval_warn; \$ret_ref = test_utf8n_to_uvchr('$bytes', $length, $warn_flag|$disallow_flag)";
232 my $eval_text = "$eval_warn; \$ret_ref = test_utf8n_to_uvchr('$bytes', $length, $warn_flag|$disallow_flag)";
eb83ed87
KW
233 eval "$eval_text";
234 if (! ok ("$@ eq ''", "$this_name: eval succeeded")) {
235 note "\$!='$!'; eval'd=\"$eval_text\"";
236 next;
237 }
2f8f112e 238 if ($disallowed) {
eb83ed87
KW
239 is($ret_ref->[0], 0, "$this_name: Returns 0");
240 }
241 else {
242 is($ret_ref->[0], $allowed_uv, "$this_name: Returns expected uv");
243 }
244 is($ret_ref->[1], $expected_len, "$this_name: Returns expected length");
245
54f4afef
KW
246 if (! $do_warning && ($warning eq 'utf8' || $warning eq $category)) {
247 if (!is(scalar @warnings, 0, "$this_name: No warnings generated"))
248 {
249 note "The warnings were: " . join(", ", @warnings);
250 }
251 }
252 elsif ($will_overflow && ! $disallow_flag && $warning eq 'utf8') {
2f8f112e
KW
253
254 # Will get the overflow message instead of the expected
255 # message under these circumstances, as they would
256 # otherwise accept an overflowed value, which the code
257 # should not allow, so falls back to overflow.
258 if (is(scalar @warnings, 1, "$this_name: Got a single warning ")) {
259 like($warnings[0], qr/overflow/, "$this_name: Got overflow warning");
260 }
261 else {
262 if (scalar @warnings) {
263 note "The warnings were: " . join(", ", @warnings);
264 }
265 }
266 }
267 elsif ($warn_flag && ($warning eq 'utf8' || $warning eq $category)) {
eb83ed87
KW
268 if (is(scalar @warnings, 1, "$this_name: Got a single warning ")) {
269 like($warnings[0], $message, "$this_name: Got expected warning");
270 }
271 else {
272 if (scalar @warnings) {
273 note "The warnings were: " . join(", ", @warnings);
274 }
275 }
276 }
eb83ed87 277
2f8f112e
KW
278 # Check CHECK_ONLY results when the input is disallowed. Do
279 # this when actually disallowed, not just when the
280 # $disallow_flag is set
281 if ($disallowed) {
eb83ed87 282 undef @warnings;
bd70aaaf 283 $ret_ref = test_utf8n_to_uvchr($bytes, $length, $disallow_flag|$UTF8_CHECK_ONLY);
eb83ed87
KW
284 is($ret_ref->[0], 0, "$this_name, CHECK_ONLY: Returns 0");
285 is($ret_ref->[1], -1, "$this_name: CHECK_ONLY: returns expected length");
286 if (! is(scalar @warnings, 0, "$this_name, CHECK_ONLY: no warnings generated")) {
287 note "The warnings were: " . join(", ", @warnings);
288 }
289 }
290 }
291 }
54f4afef 292 }
eb83ed87
KW
293 }
294}
295
fed3ba5d 296done_testing;