This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
eb620ec942de8df9d9dbede065df93836c8763f4
[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);
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 $i (@code_points) {
98         my $function = uc($name);
99
100         my $matches = Unicode::UCD::_search_invlist(\@invlist, $i);
101         if (! defined $matches) {
102             $matches = 0;
103         }
104         else {
105             $matches = truth(! ($matches % 2));
106         }
107
108         my $ret;
109         my $char_name = charnames::viacode($i) // "No name";
110         my $display_name = sprintf "\\N{U+%02X, %s}", $i, $char_name;
111
112         if ($name eq 'quotemeta') { # There is only one macro for this, and is
113                                     # defined only for Latin1 range
114             $ret = truth eval "test_is${function}($i)";
115             if ($@) {
116                 fail $@;
117             }
118             else {
119                 my $truth = truth($matches && $i < 256);
120                 is ($ret, $truth, "is${function}( $display_name ) == $truth");
121             }
122             next;
123         }
124
125         # vertws is always all of Unicode; ALNUM_A and ALNUM_L1 are not
126         # defined as they were added later, after WORDCHAR was created to be a
127         # clearer synonym for ALNUM
128         if ($name ne 'vertws') {
129             if ($name ne 'alnum') {
130                 $ret = truth eval "test_is${function}_A($i)";
131                 if ($@) {
132                     fail($@);
133                 }
134                 else {
135                     my $truth = truth($matches && $i < 128);
136                     is ($ret, $truth, "is${function}_A( $display_name ) == $truth");
137                 }
138                 $ret = truth eval "test_is${function}_L1($i)";
139                 if ($@) {
140                     fail($@);
141                 }
142                 else {
143                     my $truth = truth($matches && $i < 256);
144                     is ($ret, $truth, "is${function}_L1( $display_name ) == $truth");
145                 }
146             }
147
148             if (defined $locale) {
149                 require locale; import locale;
150
151                 $ret = truth eval "test_is${function}_LC($i)";
152                 if ($@) {
153                     fail($@);
154                 }
155                 else {
156                     my $truth = truth($matches && $i < 128);
157                     is ($ret, $truth, "is${function}_LC( $display_name ) == $truth");
158                 }
159             }
160         }
161
162         $ret = truth eval "test_is${function}_uni($i)";
163         if ($@) {
164             fail($@);
165         }
166         else {
167             is ($ret, $matches, "is${function}_uni( $display_name ) == $matches");
168         }
169
170         if (defined $locale && $name ne 'vertws') {
171             require locale; import locale;
172
173             $ret = truth eval "test_is${function}_LC_uvchr('$i')";
174             if ($@) {
175                 fail($@);
176             }
177             else {
178                 my $truth = truth($matches && ($i < 128 || $i > 255));
179                 is ($ret, $truth, "is${function}_LC_uvchr( $display_name ) == $truth");
180             }
181         }
182
183         my $char = chr($i);
184         utf8::upgrade($char);
185         $char = quotemeta $char if $char eq '\\' || $char eq "'";
186         $ret = truth eval "test_is${function}_utf8('$char')";
187         if ($@) {
188             fail($@);
189         }
190         else {
191             is ($ret, $matches, "is${function}_utf8( $display_name ) == $matches");
192         }
193
194         if ($name ne 'vertws' && defined $locale) {
195             require locale; import locale;
196
197             $ret = truth eval "test_is${function}_LC_utf8('$char')";
198             if ($@) {
199                 fail($@);
200             }
201             else {
202                 my $truth = truth($matches && ($i < 128 || $i > 255));
203                 is ($ret, $truth, "is${function}_LC_utf8( $display_name ) == $truth");
204             }
205         }
206     }
207 }
208
209 # This is primarily to make sure that no non-Unicode warnings get generated
210 is(scalar @warnings, 0, "No warnings were generated " . join ", ", @warnings);
211
212 done_testing;