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                    vertws => 'VertSpace',
  32                    upper => 'Upper',
  33                    xdigit => 'XDigit',
  34                 );
  35
  36 my @warnings;
  37 local $SIG{__WARN__} = sub { push @warnings, @_ };
  38
  39 use charnames ();
  40 foreach my $name (sort keys %properties) {
  41     my $property = $properties{$name};
  42     my @invlist = prop_invlist($property, '_perl_core_internal_ok');
  43     if (! @invlist) {
  44         fail("No inversion list found for $property");
  45         next;
  46     }
  47
  48     # Include all the Latin1 code points, plus 0x100.
  49     my @code_points = (0 .. 256);
  50
  51     # Then include the next few boundaries above those from this property
  52     my $above_latins = 0;
  53     foreach my $range_start (@invlist) {
  54         next if $range_start < 257;
  55         push @code_points, $range_start - 1, $range_start;
  56         $above_latins++;
  57         last if $above_latins > 5;
  58     }
  59
  60     # And finally one non-Unicode code point.
  61     push @code_points, 0x110000;    # Above Unicode, no prop should match
  62     no warnings 'non_unicode';
  63
  64     for my $i (@code_points) {
  65         my $function = uc($name);
  66
  67         my $matches = Unicode::UCD::_search_invlist(\@invlist, $i);
  68         if (! defined $matches) {
  69             $matches = 0;
  70         }
  71         else {
  72             $matches = truth(! ($matches % 2));
  73         }
  74
  75         my $ret;
  76         my $char_name = charnames::viacode($i) // "No name";
  77         my $display_name = sprintf "\\N{U+%02X, %s}", $i, $char_name;
  78
  79         if ($name eq 'quotemeta') { # There is only one macro for this, and is
  80                                     # defined only for Latin1 range
  81             $ret = truth eval "test_is${function}($i)";
  82             if ($@) {
  83                 fail $@;
  84             }
  85             else {
  86                 my $truth = truth($matches && $i < 256);
  87                 is ($ret, $truth, "is${function}( $display_name ) == $truth");
  88             }
  89             next;
  90         }
  91         if ($name ne 'vertws') {
  92             $ret = truth eval "test_is${function}_A($i)";
  93             if ($@) {
  94                 fail($@);
  95             }
  96             else {
  97                 my $truth = truth($matches && $i < 128);
  98                 is ($ret, $truth, "is${function}_A( $display_name ) == $truth");
  99             }
 100             $ret = truth eval "test_is${function}_L1($i)";
 101             if ($@) {
 102                 fail($@);
 103             }
 104             else {
 105                 my $truth = truth($matches && $i < 256);
 106                 is ($ret, $truth, "is${function}_L1( $display_name ) == $truth");
 107             }
 108         }
 109         next if $name eq 'alnumc';
 110
 111         $ret = truth eval "test_is${function}_uni($i)";
 112         if ($@) {
 113             fail($@);
 114         }
 115         else {
 116             is ($ret, $matches, "is${function}_uni( $display_name ) == $matches");
 117         }
 118
 119         my $char = chr($i);
 120         utf8::upgrade($char);
 121         $char = quotemeta $char if $char eq '\\' || $char eq "'";
 122         $ret = truth eval "test_is${function}_utf8('$char')";
 123         if ($@) {
 124             fail($@);
 125         }
 126         else {
 127             is ($ret, $matches, "is${function}_utf8( $display_name ) == $matches");
 128         }
 129     }
 130 }
 131
 132 # This is primarily to make sure that no non-Unicode warnings get generated
 133 is(scalar @warnings, 0, "No warnings were generated " . join ", ", @warnings);
 134
 135 done_testing;