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 tests => 1;
  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 sub rangify {
  43     my $ary= shift;
  44     my $fmt= shift || '%d';
  45     my $sep= shift || ' ';
  46     my $rng= shift || '..';
  47
  48
  49     my $first= $ary->[0];
  50     my $last= $ary->[0];
  51     my $ret= sprintf $fmt, $first;
  52     for my $idx (1..$#$ary) {
  53         if ( $ary->[$idx] != $last + 1) {
  54             if ($last!=$first) {
  55                 $ret.=sprintf "%s$fmt",$rng, $last;
  56             }
  57             $first= $last= $ary->[$idx];
  58             $ret.=sprintf "%s$fmt",$sep,$first;
  59          } else {
  60             $last= $ary->[$idx];
  61          }
  62     }
  63     if ( $last != $first) {
  64         $ret.=sprintf "%s$fmt",$rng, $last;
  65     }
  66     return $ret;
  67 }
  68
  69 my $description = "";
  70 while (@pats) {
  71     my ($yes,$no)= splice @pats,0,2;
  72
  73     my %err_by_type;
  74     my %singles;
  75     foreach my $b (0..255) {
  76         my %got;
  77         for my $type ('unicode','not-unicode') {
  78             my $str=chr($b).chr($b);
  79             if ($type eq 'unicode') {
  80                 $str.=chr(256);
  81                 chop $str;
  82             }
  83             if ($str=~/[$yes][$no]/) {
  84                 push @{$err_by_type{$type}},$b;
  85             }
  86             $got{"[$yes]"}{$type} = $str=~/[$yes]/ ? 1 : 0;
  87             $got{"[$no]"}{$type} = $str=~/[$no]/ ? 1 : 0;
  88             $got{"[^$yes]"}{$type} = $str=~/[^$yes]/ ? 1 : 0;
  89             $got{"[^$no]"}{$type} = $str=~/[^$no]/ ? 1 : 0;
  90         }
  91         foreach my $which ("[$yes]","[$no]","[^$yes]","[^$no]") {
  92             if ($got{$which}{'unicode'} != $got{$which}{'not-unicode'}) {
  93                 push @{$singles{$which}},$b;
  94             }
  95         }
  96     }
  97
  98
  99     if (%err_by_type || %singles) {
 100         $description||=" Error:\n";
 101         $description .= "/[$yes][$no]/\n";
 102         if (%err_by_type) {
 103             foreach my $type (keys %err_by_type) {
 104                 $description .= "\tmatches $type codepoints:\t";
 105                 $description .= rangify($err_by_type{$type});
 106                 $description .= "\n";
 107             }
 108             $description .= "\n";
 109         }
 110         if (%singles) {
 111             $description .= "Unicode/Nonunicode mismatches:\n";
 112             foreach my $type (keys %singles) {
 113                 $description .= "\t$type:\t";
 114                 $description .= rangify($singles{$type});
 115                 $description .= "\n";
 116             }
 117             $description .= "\n";
 118         }
 119
 120     }
 121
 122 }
 123 TODO: {
 124     local $TODO = "Only works under PERL_LEGACY_UNICODE_CHARCLASS_MAPPINGS = 0";
 125     is( $description, "", "POSIX and perl charclasses should not depend on string type");
 126 };
 127 __DATA__