t/re/reg_fold.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 my $count=1;
  12 my @tests;
  13
  14 my %todo_pass = map { $_ => 1 }
  15             qw(00DF 1E9E FB00 FB01 FB02 FB03 FB04 FB05 FB06);
  16
  17 my $file="../lib/unicore/CaseFolding.txt";
  18 open my $fh,"<",$file or die "Failed to read '$file': $!";
  19 while (<$fh>) {
  20     chomp;
  21     my ($line,$comment)= split/\s+#\s+/, $_;
  22     my ($cp,$type,@folded)=split/[\s;]+/,$line||'';
  23     next unless $type and ($type eq 'F' or $type eq 'C');
  24     my $fold_above_latin1 = grep { hex("0x$_") > 255 } @folded;
  25     $_="\\x{$_}" for @folded;
  26     my $cpv=hex("0x$cp");
  27     my $chr="\\x{$cp}";
  28     my @str;
  29     foreach my $swap (0, 1) {   # swap lhs and rhs, or not.
  30         foreach my $charclass (0, 1) {   # Put rhs in [...], or not
  31             my $lhs;
  32             my $rhs;
  33             if ($swap) {
  34                 $lhs = join "", @folded;
  35                 $rhs = $chr;
  36                 $rhs = "[$rhs]" if $charclass;
  37             } else {
  38                 $lhs = $chr;
  39                 $rhs = "";
  40                 foreach my $rhs_char (@folded) {
  41                     $rhs .= '[' if $charclass;
  42                     $rhs .=  $rhs_char;
  43                     $rhs .= ']' if $charclass;
  44                 }
  45             }
  46             $lhs = "\"$lhs\"";
  47             $rhs = "/^$rhs\$/i";
  48
  49             # Try both Latin1 and Unicode for code points below 256
  50             foreach my $upgrade ("", 'utf8::upgrade($c); ') {
  51                 if ($upgrade) {
  52                     next if $swap && $fold_above_latin1;
  53                     next if !$swap && $cpv > 255;
  54                 }
  55                 my $eval = "my \$c = $lhs; $upgrade\$c =~ $rhs";
  56                 #print __LINE__, ": $eval\n";
  57                 push @tests, qq[ok(eval '$eval', '$eval - $comment')];
  58                 if (! $swap && ($cp eq '0390' || $cp eq '03B0')) {
  59                     $tests[-1]="TODO: { local \$::TODO='[13:41] <BinGOs> cue *It is all Greek to me* joke.';\n$tests[-1] }"
  60                 } elsif ($charclass && @folded > 1 && $swap && ! $upgrade && ! $fold_above_latin1) {
  61                     $tests[-1]="TODO: { local \$::TODO='Multi-char, non-utf8 folded inside character class [ ] doesnt work';\n$tests[-1] }"
  62                 } elsif (! $upgrade && $cpv >= 128 && $cpv <= 255 && $cpv != 0xb5) {
  63                     $tests[-1]="TODO: { local \$::TODO='Most non-utf8 latin1 doesnt work';\n$tests[-1] }"
  64                 } elsif (! $swap && $charclass && @folded > 1
  65                     && ! $todo_pass{$cp})
  66                 {
  67                     # There are a few of these that pass; most fail.
  68                     $tests[-1]="TODO: { local \$::TODO='Some multi-char, f8 folded inside character class [ ] doesnt work';\n$tests[-1] }"
  69                 }
  70                 $count++;
  71             }
  72         }
  73     }
  74 }
  75 eval join ";\n","plan tests=>".($count-1),@tests,"1"
  76     or die $@;
  77 __DATA__