t/op/reg_posixcc.t

   1 #!perl
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     @INC = '../lib';
   6 }
   7
   8 use strict;
   9 use warnings;
  10 use Test::More 'no_plan'; # otherwise it would 38401 tests, which is, uh, a lot. :-)
  11 my @pats=(
  12             "\\w",
  13             "\\W",
  14             "\\s",
  15             "\\S",
  16             "\\d",
  17             "\\D",
  18             "[:alnum:]",
  19             "[:^alnum:]",
  20             "[:alpha:]",
  21             "[:^alpha:]",
  22             "[:ascii:]",
  23             "[:^ascii:]",
  24             "[:cntrl:]",
  25             "[:^cntrl:]",
  26             "[:graph:]",
  27             "[:^graph:]",
  28             "[:lower:]",
  29             "[:^lower:]",
  30             "[:print:]",
  31             "[:^print:]",
  32             "[:punct:]",
  33             "[:^punct:]",
  34             "[:upper:]",
  35             "[:^upper:]",
  36             "[:xdigit:]",
  37             "[:^xdigit:]",
  38             "[:space:]",
  39             "[:^space:]",
  40             "[:blank:]",
  41             "[:^blank:]" );
  42 if (not $ENV{REAL_POSIX_CC}) {
  43     $TODO = "Only works under PERL_LEGACY_UNICODE_CHARCLASS_MAPPINGS = 0";
  44 }
  45
  46 sub rangify {
  47     my $ary= shift;
  48     my $fmt= shift || '%d';
  49     my $sep= shift || ' ';
  50     my $rng= shift || '..';
  51
  52
  53     my $first= $ary->[0];
  54     my $last= $ary->[0];
  55     my $ret= sprintf $fmt, $first;
  56     for my $idx (1..$#$ary) {
  57         if ( $ary->[$idx] != $last + 1) {
  58             if ($last!=$first) {
  59                 $ret.=sprintf "%s$fmt",$rng, $last;
  60             }
  61             $first= $last= $ary->[$idx];
  62             $ret.=sprintf "%s$fmt",$sep,$first;
  63          } else {
  64             $last= $ary->[$idx];
  65          }
  66     }
  67     if ( $last != $first) {
  68         $ret.=sprintf "%s$fmt",$rng, $last;
  69     }
  70     return $ret;
  71 }
  72
  73 my $description = "";
  74 while (@pats) {
  75     my ($yes,$no)= splice @pats,0,2;
  76
  77     my %err_by_type;
  78     my %singles;
  79     my %complements;
  80     foreach my $b (0..255) {
  81         my %got;
  82         for my $type ('unicode','not-unicode') {
  83             my $str=chr($b).chr($b);
  84             if ($type eq 'unicode') {
  85                 $str.=chr(256);
  86                 chop $str;
  87             }
  88             if ($str=~/[$yes][$no]/){
  89                 TODO: {
  90                     unlike($str,qr/[$yes][$no]/,
  91                         "chr($b)=~/[$yes][$no]/ should not match under $type");
  92                 }
  93                 push @{$err_by_type{$type}},$b;
  94             }
  95             $got{"[$yes]"}{$type} = $str=~/[$yes]/ ? 1 : 0;
  96             $got{"[$no]"}{$type} = $str=~/[$no]/ ? 1 : 0;
  97             $got{"[^$yes]"}{$type} = $str=~/[^$yes]/ ? 1 : 0;
  98             $got{"[^$no]"}{$type} = $str=~/[^$no]/ ? 1 : 0;
  99         }
 100         foreach my $which ("[$yes]","[$no]","[^$yes]","[^$no]") {
 101             if ($got{$which}{'unicode'} != $got{$which}{'not-unicode'}){
 102                 TODO: {
 103                     is($got{$which}{'unicode'},$got{$which}{'not-unicode'},
 104                         "chr($b)=~/$which/ should have the same results regardless of internal string encoding");
 105                 }
 106                 push @{$singles{$which}},$b;
 107             }
 108         }
 109         foreach my $which ($yes,$no) {
 110             foreach my $strtype ('unicode','not-unicode') {
 111                 if ($got{"[$which]"}{$strtype} == $got{"[^$which]"}{$strtype}) {
 112                     TODO: {
 113                         isnt($got{"[$which]"}{$strtype},$got{"[^$which]"}{$strtype},
 114                             "chr($b)=~/[$which]/ should not have the same result as chr($b)=~/[^$which]/");
 115                     }
 116                     push @{$complements{$which}{$strtype}},$b;
 117                 }
 118             }
 119         }
 120     }
 121
 122
 123     if (%err_by_type || %singles || %complements) {
 124         $description||=" Error:\n";
 125         $description .= "/[$yes][$no]/\n";
 126         if (%err_by_type) {
 127             foreach my $type (sort keys %err_by_type) {
 128                 $description .= "\tmatches $type codepoints:\t";
 129                 $description .= rangify($err_by_type{$type});
 130                 $description .= "\n";
 131             }
 132             $description .= "\n";
 133         }
 134         if (%singles) {
 135             $description .= "Unicode/Nonunicode mismatches:\n";
 136             foreach my $type (sort keys %singles) {
 137                 $description .= "\t$type:\t";
 138                 $description .= rangify($singles{$type});
 139                 $description .= "\n";
 140             }
 141             $description .= "\n";
 142         }
 143         if (%complements) {
 144             foreach my $class (sort keys %complements) {
 145                 foreach my $strtype (sort keys %{$complements{$class}}) {
 146                     $description .= "\t$class has complement failures under $strtype for:\t";
 147                     $description .= rangify($complements{$class}{$strtype});
 148                     $description .= "\n";
 149                 }
 150             }
 151         }
 152     }
 153 }
 154 TODO: {
 155     is( $description, "", "POSIX and perl charclasses should not depend on string type");
 156 }
 157
 158 __DATA__