This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
ext/XS-APItest/t/handy.t: White space only
[perl5.git] / ext / XS-APItest / t / handy.t
CommitLineData
bdd8600f
KW
1#!perl -w
2
3use strict;
4use Test::More;
5
6use XS::APItest;
7
e2efe419 8use Unicode::UCD qw(prop_invlist);
c9c05358 9
5073ffbd 10sub truth($) { # Converts values so is() works
e2efe419 11 return (shift) ? 1 : 0;
c9c05358
KW
12}
13
981746b9
KW
14require POSIX;
15my $locale = POSIX::setlocale( &POSIX::LC_ALL, "C");
16if (defined $locale && $locale eq 'C') {
17 use locale;
18
19 # Some locale implementations don't have the 128-255 characters all
20 # mean nothing. Skip the locale tests in that situation
21 for my $i (128 .. 255) {
22 if (chr($i) =~ /[[:print:]]/) {
23 undef $locale;
24 last;
25 }
26 }
27}
28
e2efe419
KW
29my %properties = (
30 # name => Lookup-property name
31 alnum => 'Word',
981746b9 32 wordchar => 'Word',
e2efe419
KW
33 alnumc => 'Alnum',
34 alpha => 'Alpha',
35 ascii => 'ASCII',
36 blank => 'Blank',
37 cntrl => 'Control',
38 digit => 'Digit',
39 graph => 'Graph',
40 idfirst => '_Perl_IDStart',
41 lower => 'Lower',
42 print => 'Print',
43 psxspc => 'XPosixSpace',
44 punct => 'XPosixPunct',
45 quotemeta => '_Perl_Quotemeta',
46 space => 'XPerlSpace',
840f8e92 47 vertws => 'VertSpace',
e2efe419
KW
48 upper => 'Upper',
49 xdigit => 'XDigit',
50 );
51
5073ffbd
KW
52my @warnings;
53local $SIG{__WARN__} = sub { push @warnings, @_ };
54
c9c05358 55use charnames ();
e2efe419
KW
56foreach my $name (sort keys %properties) {
57 my $property = $properties{$name};
58 my @invlist = prop_invlist($property, '_perl_core_internal_ok');
59 if (! @invlist) {
60 fail("No inversion list found for $property");
61 next;
62 }
63
64 # Include all the Latin1 code points, plus 0x100.
65 my @code_points = (0 .. 256);
66
67 # Then include the next few boundaries above those from this property
68 my $above_latins = 0;
69 foreach my $range_start (@invlist) {
70 next if $range_start < 257;
71 push @code_points, $range_start - 1, $range_start;
72 $above_latins++;
73 last if $above_latins > 5;
74 }
75
f91dcd13
KW
76 # This makes sure we are using the Perl definition of idfirst, and not the
77 # Unicode. There are a few differences.
78 push @code_points, ord "\N{ESTIMATED SYMBOL}" if $name eq 'idfirst';
79
e2efe419
KW
80 # And finally one non-Unicode code point.
81 push @code_points, 0x110000; # Above Unicode, no prop should match
4f6ef7cc 82 no warnings 'non_unicode';
e2efe419
KW
83
84 for my $i (@code_points) {
c9c05358 85 my $function = uc($name);
c9c05358 86
e2efe419
KW
87 my $matches = Unicode::UCD::_search_invlist(\@invlist, $i);
88 if (! defined $matches) {
89 $matches = 0;
90 }
91 else {
92 $matches = truth(! ($matches % 2));
93 }
5073ffbd 94
e2efe419
KW
95 my $ret;
96 my $char_name = charnames::viacode($i) // "No name";
5073ffbd 97 my $display_name = sprintf "\\N{U+%02X, %s}", $i, $char_name;
e2efe419
KW
98
99 if ($name eq 'quotemeta') { # There is only one macro for this, and is
100 # defined only for Latin1 range
101 $ret = truth eval "test_is${function}($i)";
102 if ($@) {
103 fail $@;
104 }
105 else {
106 my $truth = truth($matches && $i < 256);
107 is ($ret, $truth, "is${function}( $display_name ) == $truth");
108 }
c9c05358
KW
109 next;
110 }
981746b9
KW
111
112 # vertws is always all of Unicode; ALNUM_A and ALNUM_L1 are not
113 # defined as they were added later, after WORDCHAR was created to be a
114 # clearer synonym for ALNUM
840f8e92 115 if ($name ne 'vertws') {
981746b9 116 if ($name ne 'alnum') {
195d0f3b
KW
117 $ret = truth eval "test_is${function}_A($i)";
118 if ($@) {
119 fail($@);
120 }
121 else {
122 my $truth = truth($matches && $i < 128);
123 is ($ret, $truth, "is${function}_A( $display_name ) == $truth");
124 }
125 $ret = truth eval "test_is${function}_L1($i)";
126 if ($@) {
127 fail($@);
128 }
129 else {
130 my $truth = truth($matches && $i < 256);
131 is ($ret, $truth, "is${function}_L1( $display_name ) == $truth");
132 }
981746b9
KW
133 }
134
135 next unless defined $locale;
136 use locale;
137
138 $ret = truth eval "test_is${function}_LC($i)";
139 if ($@) {
140 fail($@);
141 }
142 else {
143 my $truth = truth($matches && $i < 128);
144 is ($ret, $truth, "is${function}_LC( $display_name ) == $truth");
145 }
840f8e92 146 }
c9c05358 147
e2efe419
KW
148 $ret = truth eval "test_is${function}_uni($i)";
149 if ($@) {
150 fail($@);
151 }
152 else {
153 is ($ret, $matches, "is${function}_uni( $display_name ) == $matches");
154 }
c9c05358 155
981746b9
KW
156 if (defined $locale && $name ne 'vertws') {
157 use locale;
158
159 $ret = truth eval "test_is${function}_LC_uvchr('$i')";
160 if ($@) {
161 fail($@);
162 }
163 else {
164 my $truth = truth($matches && ($i < 128 || $i > 255));
165 is ($ret, $truth, "is${function}_LC_uvchr( $display_name ) == $truth");
166 }
167 }
168
c9c05358
KW
169 my $char = chr($i);
170 utf8::upgrade($char);
171 $char = quotemeta $char if $char eq '\\' || $char eq "'";
e2efe419
KW
172 $ret = truth eval "test_is${function}_utf8('$char')";
173 if ($@) {
174 fail($@);
175 }
176 else {
177 is ($ret, $matches, "is${function}_utf8( $display_name ) == $matches");
178 }
981746b9
KW
179
180 next if $name eq 'vertws' || ! defined $locale;
181 use locale;
182
183 $ret = truth eval "test_is${function}_LC_utf8('$char')";
184 if ($@) {
185 fail($@);
186 }
187 else {
188 my $truth = truth($matches && ($i < 128 || $i > 255));
189 is ($ret, $truth, "is${function}_LC_utf8( $display_name ) == $truth");
190 }
c9c05358
KW
191 }
192}
193
5073ffbd
KW
194# This is primarily to make sure that no non-Unicode warnings get generated
195is(scalar @warnings, 0, "No warnings were generated " . join ", ", @warnings);
196
bdd8600f 197done_testing;