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