t/re/reg_posixcc.t

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