This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
3a8abc99351dbc75a7efe51cb4e25caecec0c7d9
[perl5.git] / ext / XS-APItest / t / handy.t
1 #!perl -w
2
3 use strict;
4 use Test::More;
5 use Config;
6
7 use XS::APItest;
8
9 use Unicode::UCD qw(prop_invlist prop_invmap);
10
11 sub truth($) {  # Converts values so is() works
12     return (shift) ? 1 : 0;
13 }
14
15 my $locale;
16 if($Config{d_setlocale}) {
17     require POSIX;
18     $locale = POSIX::setlocale( &POSIX::LC_ALL, "C");
19     if (defined $locale && $locale eq 'C') {
20         BEGIN {
21             if($Config{d_setlocale}) {
22                 require locale; import locale; # make \w work right in non-ASCII lands
23             }
24         }
25
26         # Some locale implementations don't have the 128-255 characters all
27         # mean nothing.  Skip the locale tests in that situation
28         for my $i (128 .. 255) {
29             if (chr($i) =~ /[[:print:]]/) {
30                 undef $locale;
31                 last;
32             }
33         }
34     }
35 }
36
37 my %properties = (
38                    # name => Lookup-property name
39                    alnum => 'Word',
40                    wordchar => 'Word',
41                    alphanumeric => 'Alnum',
42                    alpha => 'Alpha',
43                    ascii => 'ASCII',
44                    blank => 'Blank',
45                    cntrl => 'Control',
46                    digit => 'Digit',
47                    graph => 'Graph',
48                    idfirst => '_Perl_IDStart',
49                    idcont => '_Perl_IDCont',
50                    lower => 'Lower',
51                    print => 'Print',
52                    psxspc => 'XPosixSpace',
53                    punct => 'XPosixPunct',
54                    quotemeta => '_Perl_Quotemeta',
55                    space => 'XPerlSpace',
56                    vertws => 'VertSpace',
57                    upper => 'Upper',
58                    xdigit => 'XDigit',
59                 );
60
61 my @warnings;
62 local $SIG{__WARN__} = sub { push @warnings, @_ };
63
64 use charnames ();
65 foreach my $name (sort keys %properties) {
66     my $property = $properties{$name};
67     my @invlist = prop_invlist($property, '_perl_core_internal_ok');
68     if (! @invlist) {
69         fail("No inversion list found for $property");
70         next;
71     }
72
73     # Include all the Latin1 code points, plus 0x100.
74     my @code_points = (0 .. 256);
75
76     # Then include the next few boundaries above those from this property
77     my $above_latins = 0;
78     foreach my $range_start (@invlist) {
79         next if $range_start < 257;
80         push @code_points, $range_start - 1, $range_start;
81         $above_latins++;
82         last if $above_latins > 5;
83     }
84
85     # This makes sure we are using the Perl definition of idfirst and idcont,
86     # and not the Unicode.  There are a few differences.
87     push @code_points, ord "\N{ESTIMATED SYMBOL}" if $name =~ /^id(first|cont)/;
88     if ($name eq "idcont") {    # And some that are continuation but not start
89         push @code_points, ord("\N{GREEK ANO TELEIA}"),
90                            ord("\N{COMBINING GRAVE ACCENT}");
91     }
92
93     # And finally one non-Unicode code point.
94     push @code_points, 0x110000;    # Above Unicode, no prop should match
95     no warnings 'non_unicode';
96
97     for my $j (@code_points) {
98         my $i = utf8::native_to_unicode($j);
99         my $function = uc($name);
100
101         my $matches = Unicode::UCD::search_invlist(\@invlist, $i);
102         if (! defined $matches) {
103             $matches = 0;
104         }
105         else {
106             $matches = truth(! ($matches % 2));
107         }
108
109         my $ret;
110         my $char_name = charnames::viacode($i) // "No name";
111         my $display_name = sprintf "\\N{U+%02X, %s}", $i, $char_name;
112
113         if ($name eq 'quotemeta') { # There is only one macro for this, and is
114                                     # defined only for Latin1 range
115             $ret = truth eval "test_is${function}($i)";
116             if ($@) {
117                 fail $@;
118             }
119             else {
120                 my $truth = truth($matches && $i < 256);
121                 is ($ret, $truth, "is${function}( $display_name ) == $truth");
122             }
123             next;
124         }
125
126         # vertws is always all of Unicode; ALNUM_A and ALNUM_L1 are not
127         # defined as they were added later, after WORDCHAR was created to be a
128         # clearer synonym for ALNUM
129         if ($name ne 'vertws') {
130             if ($name ne 'alnum') {
131                 $ret = truth eval "test_is${function}_A($i)";
132                 if ($@) {
133                     fail($@);
134                 }
135                 else {
136                     my $truth = truth($matches && $i < 128);
137                     is ($ret, $truth, "is${function}_A( $display_name ) == $truth");
138                 }
139                 $ret = truth eval "test_is${function}_L1($i)";
140                 if ($@) {
141                     fail($@);
142                 }
143                 else {
144                     my $truth = truth($matches && $i < 256);
145                     is ($ret, $truth, "is${function}_L1( $display_name ) == $truth");
146                 }
147             }
148
149             if (defined $locale) {
150                 require locale; import locale;
151
152                 $ret = truth eval "test_is${function}_LC($i)";
153                 if ($@) {
154                     fail($@);
155                 }
156                 else {
157                     my $truth = truth($matches && $i < 128);
158                     is ($ret, $truth, "is${function}_LC( $display_name ) == $truth");
159                 }
160             }
161         }
162
163         $ret = truth eval "test_is${function}_uni($i)";
164         if ($@) {
165             fail($@);
166         }
167         else {
168             is ($ret, $matches, "is${function}_uni( $display_name ) == $matches");
169         }
170
171         if (defined $locale && $name ne 'vertws') {
172             require locale; import locale;
173
174             $ret = truth eval "test_is${function}_LC_uvchr('$i')";
175             if ($@) {
176                 fail($@);
177             }
178             else {
179                 my $truth = truth($matches && ($i < 128 || $i > 255));
180                 is ($ret, $truth, "is${function}_LC_uvchr( $display_name ) == $truth");
181             }
182         }
183
184         my $char = chr($i);
185         utf8::upgrade($char);
186         $char = quotemeta $char if $char eq '\\' || $char eq "'";
187         $ret = truth eval "test_is${function}_utf8('$char')";
188         if ($@) {
189             fail($@);
190         }
191         else {
192             is ($ret, $matches, "is${function}_utf8( $display_name ) == $matches");
193         }
194
195         if ($name ne 'vertws' && defined $locale) {
196             require locale; import locale;
197
198             $ret = truth eval "test_is${function}_LC_utf8('$char')";
199             if ($@) {
200                 fail($@);
201             }
202             else {
203                 my $truth = truth($matches && ($i < 128 || $i > 255));
204                 is ($ret, $truth, "is${function}_LC_utf8( $display_name ) == $truth");
205             }
206         }
207     }
208 }
209
210 my %to_properties = (
211                 FOLD => 'Case_Folding',
212                 LOWER => 'Lowercase_Mapping',
213                 TITLE => 'Titlecase_Mapping',
214                 UPPER => 'Uppercase_Mapping',
215             );
216
217
218 foreach my $name (sort keys %to_properties) {
219     my $property = $to_properties{$name};
220     my ($list_ref, $map_ref, $format, $missing)
221                                       = prop_invmap($property, );
222     if (! $list_ref || ! $map_ref) {
223         fail("No inversion map found for $property");
224         next;
225     }
226     if ($format ne "al") {
227         fail("Unexpected inversion map format ('$format') found for $property");
228         next;
229     }
230
231     # Include all the Latin1 code points, plus 0x100.
232     my @code_points = (0 .. 256);
233
234     # Then include the next few multi-char folds above those from this
235     # property, and include the next few single folds as well
236     my $above_latins = 0;
237     my $multi_char = 0;
238     for my $i (0 .. @{$list_ref} - 1) {
239         my $range_start = $list_ref->[$i];
240         next if $range_start < 257;
241         if (ref $map_ref->[$i] && $multi_char < 5)  {
242             push @code_points, $range_start - 1 if $code_points[-1] != $range_start - 1;
243             push @code_points, $range_start;
244             $multi_char++;
245         }
246         elsif ($above_latins < 5) {
247             push @code_points, $range_start - 1 if $code_points[-1] != $range_start - 1;
248             push @code_points, $range_start;
249             $above_latins++;
250         }
251         last if $above_latins >= 5 && $multi_char >= 5;
252     }
253
254     # And finally one non-Unicode code point.
255     push @code_points, 0x110000;    # Above Unicode, no prop should match
256     no warnings 'non_unicode';
257
258     # $j is native; $i unicode.
259     for my $j (@code_points) {
260         my $i = utf8::native_to_unicode($j);
261         my $function = $name;
262
263         my $index = Unicode::UCD::search_invlist(\@{$list_ref}, $j);
264
265         my $ret;
266         my $char_name = charnames::viacode($j) // "No name";
267         my $display_name = sprintf "\\N{U+%02X, %s}", $i, $char_name;
268
269         # Test the base function
270         $ret = eval "test_to${function}($j)";
271         if ($@) {
272             fail($@);
273         }
274         else {
275             my $should_be = ($i < 128 && $map_ref->[$index] != $missing)
276                              ? $map_ref->[$index] + $j - $list_ref->[$index]
277                              : $j;
278             is ($ret, $should_be, sprintf("to${function}( $display_name ) == 0x%02X", $should_be));
279         }
280
281         # Test _L1
282         if ($name eq 'LOWER') {
283             $ret = eval "test_to${function}_L1($j)";
284             if ($@) {
285                 fail($@);
286             }
287             else {
288                 my $should_be = ($i < 256 && $map_ref->[$index] != $missing)
289                                 ? $map_ref->[$index] + $j - $list_ref->[$index]
290                                 : $j;
291                 is ($ret, $should_be, sprintf("to${function}_L1( $display_name ) == 0x%02X", $should_be));
292             }
293         }
294
295         if ($name ne 'TITLE' && defined $locale) {
296             require locale; import locale;
297
298             # Test _LC;  titlecase is not defined in locales.
299             $ret = eval "test_to${function}_LC($j)";
300             if ($@) {
301                 fail($@);
302             }
303             else {
304                 my $should_be = ($i < 128 && $map_ref->[$index] != $missing)
305                                 ? $map_ref->[$index] + $j - $list_ref->[$index]
306                                 : $j;
307                 is ($ret, $should_be, sprintf("to${function}_LC( $display_name ) == 0x%02X", $should_be));
308             }
309         }
310
311         # The _uni and _utf8 functions return both the ordinal of the first
312         # code point of the result, and the result in utf8.  The .xs tests
313         # return these in an array, in [0] and [1] respectively, with [2] the
314         # length of the utf8 in bytes.
315         my $utf8_should_be = "";
316         my $first_ord_should_be;
317         if (ref $map_ref->[$index]) {   # A multi-char result
318             for my $j (0 .. @{$map_ref->[$index]} - 1) {
319                 $utf8_should_be .= chr $map_ref->[$index][$j];
320             }
321
322             $first_ord_should_be = $map_ref->[$index][0];
323         }
324         else {  # A single-char result
325             $first_ord_should_be = ($map_ref->[$index] != $missing)
326                                     ? $map_ref->[$index] + $j - $list_ref->[$index]
327                                     : $j;
328             $utf8_should_be = chr $first_ord_should_be;
329         }
330         utf8::upgrade($utf8_should_be);
331
332         # Test _uni
333         my $s;
334         my $len;
335         $ret = eval "test_to${function}_uni($j)";
336         if ($@) {
337             fail($@);
338         }
339         else {
340             is ($ret->[0], $first_ord_should_be, sprintf("to${function}_uni( $display_name ) == 0x%02X", $first_ord_should_be));
341             is ($ret->[1], $utf8_should_be, sprintf("utf8 of to${function}_uni( $display_name )"));
342             use bytes;
343             is ($ret->[2], length $utf8_should_be, sprintf("number of bytes in utf8 of to${function}_uni( $display_name )"));
344         }
345
346         # Test _utf8
347         my $char = chr($j);
348         utf8::upgrade($char);
349         $char = quotemeta $char if $char eq '\\' || $char eq "'";
350         $ret = eval "test_to${function}_utf8('$char')";
351         if ($@) {
352             fail($@);
353         }
354         else {
355             is ($ret->[0], $first_ord_should_be, sprintf("to${function}_utf8( $display_name ) == 0x%02X", $first_ord_should_be));
356             is ($ret->[1], $utf8_should_be, sprintf("utf8 of to${function}_utf8( $display_name )"));
357             use bytes;
358             is ($ret->[2], length $utf8_should_be, sprintf("number of bytes in utf8 of to${function}_uni( $display_name )"));
359         }
360
361     }
362 }
363
364 # This is primarily to make sure that no non-Unicode warnings get generated
365 is(scalar @warnings, 0, "No warnings were generated " . join ", ", @warnings);
366
367 done_testing;