This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
6e6fef5f22048a344149b46532f6bffc53fb5067
[perl5.git] / ext / XS-APItest / t / handy.t
1 #!perl -w
2
3 BEGIN {
4     require 'loc_tools.pl';   # Contains locales_enabled() and
5                               # find_utf8_ctype_locale()
6 }
7
8 use strict;
9 use Test::More;
10 use Config;
11
12 use XS::APItest;
13
14 my $tab = " " x 4;  # Indent subsidiary tests this much
15
16 use Unicode::UCD qw(search_invlist prop_invmap prop_invlist);
17 my ($charname_list, $charname_map, $format, $default) = prop_invmap("Name Alias");
18
19 sub get_charname($) {
20     my $cp = shift;
21
22     # If there is a an abbreviation for the code point name, use it
23     my $name_index = search_invlist(\@{$charname_list}, $cp);
24     if (defined $name_index) {
25         my $synonyms = $charname_map->[$name_index];
26         if (ref $synonyms) {
27             my $pat = qr/: abbreviation/;
28             my @abbreviations = grep { $_ =~ $pat } @$synonyms;
29             if (@abbreviations) {
30                 return $abbreviations[0] =~ s/$pat//r;
31             }
32         }
33     }
34
35     # Otherwise, use the full name
36     use charnames ();
37     return charnames::viacode($cp) // "No name";
38 }
39
40 sub truth($) {  # Converts values so is() works
41     return (shift) ? 1 : 0;
42 }
43
44 my $base_locale;
45 my $utf8_locale;
46 if(locales_enabled('LC_ALL')) {
47     require POSIX;
48     $base_locale = POSIX::setlocale( &POSIX::LC_ALL, "C");
49     if (defined $base_locale && $base_locale eq 'C') {
50         use locale; # make \w work right in non-ASCII lands
51
52         # Some locale implementations don't have the 128-255 characters all
53         # mean nothing.  Skip the locale tests in that situation
54         for my $i (128 .. 255) {
55             if (chr(utf8::unicode_to_native($i)) =~ /[[:print:]]/) {
56                 undef $base_locale;
57                 last;
58             }
59         }
60
61         $utf8_locale = find_utf8_ctype_locale() if $base_locale;
62     }
63 }
64
65 sub get_display_locale_or_skip($$) {
66
67     # Helper function intimately tied to its callers.  It knows the loop
68     # iterates with a locale of "", meaning don't use locale; $base_locale
69     # meaning to use a non-UTF-8 locale; and $utf8_locale.
70     #
71     # It checks to see if the current test should be skipped or executed,
72     # returning an empty list for the former, and for the latter:
73     #   ( 'locale display name',
74     #     bool of is this a UTF-8 locale )
75     #
76     # The display name is the empty string if not using locale.  Functions
77     # with _LC in their name are skipped unless in locale, and functions
78     # without _LC are executed only outside locale.  However, if no locales at
79     # all are on the system, the _LC functions are executed outside locale.
80
81     my ($locale, $suffix) = @_;
82
83     # The test should be skipped if the input is for a non-existent locale
84     return unless defined $locale;
85
86     # Here the input is defined, either a locale name or "".  If the test is
87     # for not using locales, we want to do the test for non-LC functions,
88     # and skip it for LC ones (except if there are no locales on the system,
89     # we do it for LC ones as if they weren't LC).
90     if ($locale eq "") {
91         return ("", 0) if $suffix !~ /LC/ || ! defined $base_locale;
92         return;
93     }
94
95     # Here the input is for a real locale.  We don't test the non-LC functions
96     # for locales.
97     return if $suffix !~ /LC/;
98
99     # Here is for a LC function and a real locale.  The base locale is not
100     # UTF-8.
101     return (" ($locale locale)", 0) if $locale eq $base_locale;
102
103     # The only other possibility is that we have a UTF-8 locale
104     return (" ($locale)", 1);
105 }
106
107 my %properties = (
108                    # name => Lookup-property name
109                    alnum => 'Word',
110                    wordchar => 'Word',
111                    alphanumeric => 'Alnum',
112                    alpha => 'XPosixAlpha',
113                    ascii => 'ASCII',
114                    blank => 'Blank',
115                    cntrl => 'Control',
116                    digit => 'Digit',
117                    graph => 'Graph',
118                    idfirst => '_Perl_IDStart',
119                    idcont => '_Perl_IDCont',
120                    lower => 'XPosixLower',
121                    print => 'Print',
122                    psxspc => 'XPosixSpace',
123                    punct => 'XPosixPunct',
124                    quotemeta => '_Perl_Quotemeta',
125                    space => 'XPerlSpace',
126                    vertws => 'VertSpace',
127                    upper => 'XPosixUpper',
128                    xdigit => 'XDigit',
129                 );
130
131 my @warnings;
132 local $SIG{__WARN__} = sub { push @warnings, @_ };
133
134
135 foreach my $name (sort keys %properties, 'octal') {
136     my @invlist;
137     if ($name eq 'octal') {
138         # Hand-roll an inversion list with 0-7 in it and nothing else.
139         push @invlist, ord "0", ord "8";
140     }
141     else {
142         my $property = $properties{$name};
143         @invlist = prop_invlist($property, '_perl_core_internal_ok');
144         if (! @invlist) {
145
146             # An empty return could mean an unknown property, or merely that
147             # it is empty.  Call in scalar context to differentiate
148             if (! prop_invlist($property, '_perl_core_internal_ok')) {
149                 fail("No inversion list found for $property");
150                 next;
151             }
152         }
153     }
154
155     # Include all the Latin1 code points, plus 0x100.
156     my @code_points = (0 .. 256);
157
158     # Then include the next few boundaries above those from this property
159     my $above_latins = 0;
160     foreach my $range_start (@invlist) {
161         next if $range_start < 257;
162         push @code_points, $range_start - 1, $range_start;
163         $above_latins++;
164         last if $above_latins > 5;
165     }
166
167     # This makes sure we are using the Perl definition of idfirst and idcont,
168     # and not the Unicode.  There are a few differences.
169     push @code_points, ord "\N{ESTIMATED SYMBOL}" if $name =~ /^id(first|cont)/;
170     if ($name eq "idcont") {    # And some that are continuation but not start
171         push @code_points, ord("\N{GREEK ANO TELEIA}"),
172                            ord("\N{COMBINING GRAVE ACCENT}");
173     }
174
175     # And finally one non-Unicode code point.
176     push @code_points, 0x110000;    # Above Unicode, no prop should match
177     no warnings 'non_unicode';
178
179     for my $j (@code_points) {
180         my $i = utf8::native_to_unicode($j);
181         my $function = uc($name);
182
183         is (@warnings, 0, "Got no unexpected warnings in previous iteration")
184            or diag("@warnings");
185         undef @warnings;
186
187         my $matches = search_invlist(\@invlist, $i);
188         if (! defined $matches) {
189             $matches = 0;
190         }
191         else {
192             $matches = truth(! ($matches % 2));
193         }
194
195         my $ret;
196         my $char_name = get_charname($j);
197         my $display_name = sprintf "\\x{%02X, %s}", $i, $char_name;
198         my $display_call = "is${function}( $display_name )";
199
200         if ($name eq 'quotemeta') { # There is only one macro for this, and is
201                                     # defined only for Latin1 range
202             $ret = truth eval "test_is${function}($i)";
203             if (is ($@, "", "$display_call didn't give error")) {
204                 my $truth = truth($matches && $i < 256);
205                 is ($ret, $truth, "${tab}And returns $truth");
206             }
207             next;
208         }
209
210         foreach my $suffix ("", "_A", "_L1", "_LC", "_uni", "_LC_uvchr",
211                             "_utf8", "_LC_utf8")
212         {
213
214             # Not all possible macros have been defined
215             if ($name eq 'vertws') {
216
217                 # vertws is always all of Unicode
218                 next if $suffix ne "_uni" && $suffix ne "_utf8";
219             }
220             elsif ($name eq 'alnum') {
221
222                 # ALNUM_A and ALNUM_L1 are not defined as they were added
223                 # later, after WORDCHAR was created to be a clearer synonym
224                 # for ALNUM
225                 next if $suffix eq '_A' || $suffix eq '_L1';
226             }
227             elsif ($name eq 'octal') {
228                 next if $suffix ne ""  && $suffix ne '_A' && $suffix ne '_L1';
229             }
230
231             foreach my $locale ("", $base_locale, $utf8_locale) {
232
233                 my ($display_locale, $locale_is_utf8)
234                                 = get_display_locale_or_skip($locale, $suffix);
235                 next unless defined $display_locale;
236
237                 use if $locale, "locale";
238                 POSIX::setlocale( &POSIX::LC_ALL, $locale) if $locale;
239
240                 if ($suffix !~ /utf8/) {    # _utf8 has to handled specially
241                     my $display_call
242                        = "is${function}$suffix( $display_name )$display_locale";
243                     $ret = truth eval "test_is${function}$suffix($i)";
244                     if (is ($@, "", "$display_call didn't give error")) {
245                         my $truth = $matches;
246                         if ($truth) {
247
248                             # The single byte functions are false for
249                             # above-Latin1
250                             if ($i >= 256) {
251                                 $truth = 0
252                                         if $suffix=~ / ^ ( _A | _L [1C] )? $ /x;
253                             }
254                             elsif (utf8::native_to_unicode($i) >= 128) {
255
256                                 # The no-suffix and _A functions are false
257                                 # for non-ASCII.  So are  _LC  functions on a
258                                 # non-UTF-8 locale
259                                 $truth = 0 if    $suffix eq "_A"
260                                               || $suffix eq ""
261                                               || (     $suffix =~ /LC/
262                                                   && ! $locale_is_utf8);
263                             }
264                         }
265
266                         is ($ret, $truth, "${tab}And correctly returns $truth");
267                     }
268                 }
269                 else {  # _utf8 suffix
270                     my $char = chr($i);
271                     utf8::upgrade($char);
272                     $char = quotemeta $char if $char eq '\\' || $char eq "'";
273                     my $truth;
274                     if (   $suffix =~ /LC/
275                         && ! $locale_is_utf8
276                         && $i < 256
277                         && utf8::native_to_unicode($i) >= 128)
278                     {   # The C-locale _LC function returns FALSE for Latin1
279                         # above ASCII
280                         $truth = 0;
281                     }
282                     else {
283                         $truth = $matches;
284                     }
285
286                         my $display_call = "is${function}$suffix("
287                                          . " $display_name )$display_locale";
288                         $ret = truth eval "test_is${function}$suffix('$char')";
289                         if (is ($@, "", "$display_call didn't give error")) {
290                             is ($ret, $truth,
291                                 "${tab}And correctly returned $truth");
292                         }
293                 }
294             }
295         }
296     }
297 }
298
299 my %to_properties = (
300                 FOLD  => 'Case_Folding',
301                 LOWER => 'Lowercase_Mapping',
302                 TITLE => 'Titlecase_Mapping',
303                 UPPER => 'Uppercase_Mapping',
304             );
305
306
307 foreach my $name (sort keys %to_properties) {
308     my $property = $to_properties{$name};
309     my ($list_ref, $map_ref, $format, $missing)
310                                       = prop_invmap($property, );
311     if (! $list_ref || ! $map_ref) {
312         fail("No inversion map found for $property");
313         next;
314     }
315     if ($format !~ / ^ a l? $ /x) {
316         fail("Unexpected inversion map format ('$format') found for $property");
317         next;
318     }
319
320     # Include all the Latin1 code points, plus 0x100.
321     my @code_points = (0 .. 256);
322
323     # Then include the next few multi-char folds above those from this
324     # property, and include the next few single folds as well
325     my $above_latins = 0;
326     my $multi_char = 0;
327     for my $i (0 .. @{$list_ref} - 1) {
328         my $range_start = $list_ref->[$i];
329         next if $range_start < 257;
330         if (ref $map_ref->[$i] && $multi_char < 5)  {
331             push @code_points, $range_start - 1
332                                         if $code_points[-1] != $range_start - 1;
333             push @code_points, $range_start;
334             $multi_char++;
335         }
336         elsif ($above_latins < 5) {
337             push @code_points, $range_start - 1
338                                         if $code_points[-1] != $range_start - 1;
339             push @code_points, $range_start;
340             $above_latins++;
341         }
342         last if $above_latins >= 5 && $multi_char >= 5;
343     }
344
345     # And finally one non-Unicode code point.
346     push @code_points, 0x110000;    # Above Unicode, no prop should match
347     no warnings 'non_unicode';
348
349     # $j is native; $i unicode.
350     for my $j (@code_points) {
351         my $i = utf8::native_to_unicode($j);
352         my $function = $name;
353
354         my $index = search_invlist(\@{$list_ref}, $j);
355
356         my $ret;
357         my $char_name = get_charname($j);
358         my $display_name = sprintf "\\N{U+%02X, %s}", $i, $char_name;
359
360         foreach my $suffix ("", "_L1", "_LC") {
361
362             # This is the only macro defined for L1
363             next if $suffix eq "_L1" && $function ne "LOWER";
364
365           SKIP:
366             foreach my $locale ("", $base_locale, $utf8_locale) {
367
368                 # titlecase is not defined in locales.
369                 next if $name eq 'TITLE' && $suffix eq "_LC";
370
371                 my ($display_locale, $locale_is_utf8)
372                                 = get_display_locale_or_skip($locale, $suffix);
373                 next unless defined $display_locale;
374
375                 skip("to${name}_LC does not work for LATIN SMALL LETTER SHARP S"
376                   . "$display_locale", 1)
377                             if  $i == 0xDF && $name =~ / FOLD | UPPER /x
378                              && $suffix eq "_LC" && $locale_is_utf8;
379
380                 use if $locale, "locale";
381                 POSIX::setlocale( &POSIX::LC_ALL, $locale) if $locale;
382
383                 my $display_call = "to${function}$suffix("
384                                  . " $display_name )$display_locale";
385                 $ret = eval "test_to${function}$suffix($j)";
386                 if (is ($@, "", "$display_call didn't give error")) {
387                     my $should_be;
388                     if ($i > 255) {
389                         $should_be = $j;
390                     }
391                     elsif (    $i > 127
392                             && (   $suffix eq ""
393                                 || ($suffix eq "_LC" && ! $locale_is_utf8)))
394                     {
395                         $should_be = $j;
396                     }
397                     elsif ($map_ref->[$index] != $missing) {
398                         $should_be = $map_ref->[$index] + $j - $list_ref->[$index]
399                     }
400                     else {
401                         $should_be = $j;
402                     }
403
404                     is ($ret, $should_be,
405                         sprintf("${tab}And correctly returned 0x%02X",
406                                                               $should_be));
407                 }
408             }
409         }
410
411         # The _uni and _utf8 functions return both the ordinal of the first
412         # code point of the result, and the result in utf8.  The .xs tests
413         # return these in an array, in [0] and [1] respectively, with [2] the
414         # length of the utf8 in bytes.
415         my $utf8_should_be = "";
416         my $first_ord_should_be;
417         if (ref $map_ref->[$index]) {   # A multi-char result
418             for my $j (0 .. @{$map_ref->[$index]} - 1) {
419                 $utf8_should_be .= chr $map_ref->[$index][$j];
420             }
421
422             $first_ord_should_be = $map_ref->[$index][0];
423         }
424         else {  # A single-char result
425             $first_ord_should_be = ($map_ref->[$index] != $missing)
426                                     ? $map_ref->[$index] + $j
427                                                          - $list_ref->[$index]
428                                     : $j;
429             $utf8_should_be = chr $first_ord_should_be;
430         }
431         utf8::upgrade($utf8_should_be);
432
433         # Test _uni
434         my $s;
435         my $len;
436         my $display_call = "to${function}_uni( $display_name )";
437         $ret = eval "test_to${function}_uni($j)";
438         if (is ($@, "", "$display_call didn't give error")) {
439             is ($ret->[0], $first_ord_should_be,
440                 sprintf("${tab}And correctly returned 0x%02X",
441                                                   $first_ord_should_be));
442             is ($ret->[1], $utf8_should_be, "${tab}Got correct utf8");
443             use bytes;
444             is ($ret->[2], length $utf8_should_be,
445                 "${tab}Got correct number of bytes for utf8 length");
446         }
447
448         # Test _utf8
449         my $char = chr($j);
450         utf8::upgrade($char);
451         $char = quotemeta $char if $char eq '\\' || $char eq "'";
452         {
453             my $display_call = "to${function}_utf8($display_name )";
454             $ret = eval   "test_to${function}_utf8('$char')";
455             if (is ($@, "", "$display_call didn't give error")) {
456                 is ($ret->[0], $first_ord_should_be,
457                     sprintf("${tab}And correctly returned 0x%02X",
458                                                     $first_ord_should_be));
459                 is ($ret->[1], $utf8_should_be, "${tab}Got correct utf8");
460                 use bytes;
461                 is ($ret->[2], length $utf8_should_be,
462                     "${tab}Got correct number of bytes for utf8 length");
463             }
464         }
465     }
466 }
467
468 # This is primarily to make sure that no non-Unicode warnings get generated
469 is(scalar @warnings, 0, "No unexpected warnings were generated in the tests")
470   or diag @warnings;
471
472 done_testing;