This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Use new case changing macros
[perl5.git] / ext / XS-APItest / t / handy.t
CommitLineData
bdd8600f
KW
1#!perl -w
2
3use strict;
4use Test::More;
569f7fc5 5use Config;
bdd8600f
KW
6
7use XS::APItest;
8
e2efe419 9use Unicode::UCD qw(prop_invlist);
c9c05358 10
5073ffbd 11sub truth($) { # Converts values so is() works
e2efe419 12 return (shift) ? 1 : 0;
c9c05358
KW
13}
14
569f7fc5
JR
15my $locale;
16if($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 }
981746b9
KW
33 }
34 }
35}
36
e2efe419
KW
37my %properties = (
38 # name => Lookup-property name
39 alnum => 'Word',
981746b9 40 wordchar => 'Word',
15861f94 41 alphanumeric => 'Alnum',
e2efe419
KW
42 alpha => 'Alpha',
43 ascii => 'ASCII',
44 blank => 'Blank',
45 cntrl => 'Control',
46 digit => 'Digit',
47 graph => 'Graph',
48 idfirst => '_Perl_IDStart',
eba68aa0 49 idcont => '_Perl_IDCont',
e2efe419
KW
50 lower => 'Lower',
51 print => 'Print',
52 psxspc => 'XPosixSpace',
53 punct => 'XPosixPunct',
54 quotemeta => '_Perl_Quotemeta',
55 space => 'XPerlSpace',
840f8e92 56 vertws => 'VertSpace',
e2efe419
KW
57 upper => 'Upper',
58 xdigit => 'XDigit',
59 );
60
5073ffbd
KW
61my @warnings;
62local $SIG{__WARN__} = sub { push @warnings, @_ };
63
c9c05358 64use charnames ();
e2efe419
KW
65foreach 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
eba68aa0
KW
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)/;
2f4622f0
KW
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 }
f91dcd13 92
e2efe419
KW
93 # And finally one non-Unicode code point.
94 push @code_points, 0x110000; # Above Unicode, no prop should match
4f6ef7cc 95 no warnings 'non_unicode';
e2efe419
KW
96
97 for my $i (@code_points) {
c9c05358 98 my $function = uc($name);
c9c05358 99
e2efe419
KW
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 }
5073ffbd 107
e2efe419
KW
108 my $ret;
109 my $char_name = charnames::viacode($i) // "No name";
5073ffbd 110 my $display_name = sprintf "\\N{U+%02X, %s}", $i, $char_name;
e2efe419
KW
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 }
c9c05358
KW
122 next;
123 }
981746b9
KW
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
840f8e92 128 if ($name ne 'vertws') {
981746b9 129 if ($name ne 'alnum') {
195d0f3b
KW
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 }
981746b9
KW
146 }
147
8ff203a1 148 if (defined $locale) {
569f7fc5 149 require locale; import locale;
981746b9 150
31a09021
KW
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 }
8ff203a1 159 }
840f8e92 160 }
c9c05358 161
e2efe419
KW
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 }
c9c05358 169
981746b9 170 if (defined $locale && $name ne 'vertws') {
569f7fc5 171 require locale; import locale;
981746b9
KW
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
c9c05358
KW
183 my $char = chr($i);
184 utf8::upgrade($char);
185 $char = quotemeta $char if $char eq '\\' || $char eq "'";
e2efe419
KW
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 }
981746b9 193
8ff203a1 194 if ($name ne 'vertws' && defined $locale) {
569f7fc5 195 require locale; import locale;
981746b9 196
31a09021
KW
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 }
8ff203a1 205 }
c9c05358
KW
206 }
207}
208
5073ffbd
KW
209# This is primarily to make sure that no non-Unicode warnings get generated
210is(scalar @warnings, 0, "No warnings were generated " . join ", ", @warnings);
211
bdd8600f 212done_testing;