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
1 #!perl -w
2
3 use strict;
4 use Test::More;
5
6 use XS::APItest;
7
8 use Unicode::UCD qw(prop_invlist);
9
10 sub truth($) {  # Converts values so is() works
11     return (shift) ? 1 : 0;
12 }
13
14 my %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
35 my @warnings;
36 local $SIG{__WARN__} = sub { push @warnings, @_ };
37
38 use charnames ();
39 foreach 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) {
63         my $function = uc($name);
64
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         }
72
73         my $ret;
74         my $char_name = charnames::viacode($i) // "No name";
75         my $display_name = sprintf "\\N{U+%02X, %s}", $i, $char_name;
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             }
87             next;
88         }
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             }
105         next if $name eq 'alnumc';
106
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         }
114
115         my $char = chr($i);
116         utf8::upgrade($char);
117         $char = quotemeta $char if $char eq '\\' || $char eq "'";
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         }
125     }
126 }
127
128 # This is primarily to make sure that no non-Unicode warnings get generated
129 is(scalar @warnings, 0, "No warnings were generated " . join ", ", @warnings);
130
131 done_testing;