This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
XS-APItest/t/handy.t: Refactor
[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
e2efe419
KW
14my %properties = (
15 # name => Lookup-property name
16 alnum => 'Word',
17 alnumc => 'Alnum',
18 alpha => 'Alpha',
19 ascii => 'ASCII',
20 blank => 'Blank',
21 cntrl => 'Control',
22 digit => 'Digit',
23 graph => 'Graph',
24 idfirst => '_Perl_IDStart',
25 lower => 'Lower',
26 print => 'Print',
27 psxspc => 'XPosixSpace',
28 punct => 'XPosixPunct',
29 quotemeta => '_Perl_Quotemeta',
30 space => 'XPerlSpace',
31 upper => 'Upper',
32 xdigit => 'XDigit',
33 );
34
5073ffbd
KW
35my @warnings;
36local $SIG{__WARN__} = sub { push @warnings, @_ };
37
c9c05358 38use charnames ();
e2efe419
KW
39foreach my $name (sort keys %properties) {
40 my $property = $properties{$name};
41 my @invlist = prop_invlist($property, '_perl_core_internal_ok');
42 if (! @invlist) {
43 fail("No inversion list found for $property");
44 next;
45 }
46
47 # Include all the Latin1 code points, plus 0x100.
48 my @code_points = (0 .. 256);
49
50 # Then include the next few boundaries above those from this property
51 my $above_latins = 0;
52 foreach my $range_start (@invlist) {
53 next if $range_start < 257;
54 push @code_points, $range_start - 1, $range_start;
55 $above_latins++;
56 last if $above_latins > 5;
57 }
58
59 # And finally one non-Unicode code point.
60 push @code_points, 0x110000; # Above Unicode, no prop should match
61
62 for my $i (@code_points) {
c9c05358 63 my $function = uc($name);
c9c05358 64
e2efe419
KW
65 my $matches = Unicode::UCD::_search_invlist(\@invlist, $i);
66 if (! defined $matches) {
67 $matches = 0;
68 }
69 else {
70 $matches = truth(! ($matches % 2));
71 }
5073ffbd 72
e2efe419
KW
73 my $ret;
74 my $char_name = charnames::viacode($i) // "No name";
5073ffbd 75 my $display_name = sprintf "\\N{U+%02X, %s}", $i, $char_name;
e2efe419
KW
76
77 if ($name eq 'quotemeta') { # There is only one macro for this, and is
78 # defined only for Latin1 range
79 $ret = truth eval "test_is${function}($i)";
80 if ($@) {
81 fail $@;
82 }
83 else {
84 my $truth = truth($matches && $i < 256);
85 is ($ret, $truth, "is${function}( $display_name ) == $truth");
86 }
c9c05358
KW
87 next;
88 }
e2efe419
KW
89 $ret = truth eval "test_is${function}_A($i)";
90 if ($@) {
91 fail($@);
92 }
93 else {
94 my $truth = truth($matches && $i < 128);
95 is ($ret, $truth, "is${function}_A( $display_name ) == $truth");
96 }
97 $ret = truth eval "test_is${function}_L1($i)";
98 if ($@) {
99 fail($@);
100 }
101 else {
102 my $truth = truth($matches && $i < 256);
103 is ($ret, $truth, "is${function}_L1( $display_name ) == $truth");
104 }
c9c05358
KW
105 next if $name eq 'alnumc';
106
e2efe419
KW
107 $ret = truth eval "test_is${function}_uni($i)";
108 if ($@) {
109 fail($@);
110 }
111 else {
112 is ($ret, $matches, "is${function}_uni( $display_name ) == $matches");
113 }
c9c05358
KW
114
115 my $char = chr($i);
116 utf8::upgrade($char);
117 $char = quotemeta $char if $char eq '\\' || $char eq "'";
e2efe419
KW
118 $ret = truth eval "test_is${function}_utf8('$char')";
119 if ($@) {
120 fail($@);
121 }
122 else {
123 is ($ret, $matches, "is${function}_utf8( $display_name ) == $matches");
124 }
c9c05358
KW
125 }
126}
127
5073ffbd
KW
128# This is primarily to make sure that no non-Unicode warnings get generated
129is(scalar @warnings, 0, "No warnings were generated " . join ", ", @warnings);
130
bdd8600f 131done_testing;