This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
reg_fold.t: Disable single char fold testing
[perl5.git] / t / re / reg_fold.t
CommitLineData
24df86f6
RGS
1#!perl
2
3BEGIN {
4 chdir 't' if -d 't';
5 @INC = '../lib';
0214bff6 6 require './test.pl';
24df86f6
RGS
7}
8
a0a388a1
YO
9use strict;
10use warnings;
a0a388a1
YO
11my $count=1;
12my @tests;
a0a388a1 13
2f7760b5
DM
14my %todo_pass = map { $_ => 1 }
15 qw(00DF 1E9E FB00 FB01 FB02 FB03 FB04 FB05 FB06);
16
a0a388a1 17my $file="../lib/unicore/CaseFolding.txt";
24df86f6 18open my $fh,"<",$file or die "Failed to read '$file': $!";
a0a388a1
YO
19while (<$fh>) {
20 chomp;
21 my ($line,$comment)= split/\s+#\s+/, $_;
1443f10d 22 my ($cp,$type,@folded)=split/[\s;]+/,$line||'';
a0a388a1 23 next unless $type and ($type eq 'F' or $type eq 'C');
8bfc9fab 24 next if $type eq 'C'; # 'C' tests now done by fold_grind.t
1443f10d
KW
25 my $fold_above_latin1 = grep { hex("0x$_") > 255 } @folded;
26 $_="\\x{$_}" for @folded;
a0a388a1 27 my $cpv=hex("0x$cp");
1443f10d 28 my $chr="\\x{$cp}";
a0a388a1 29 my @str;
1443f10d 30 foreach my $swap (0, 1) { # swap lhs and rhs, or not.
3366dfc6 31 foreach my $charclass (0) { # Put rhs in [...], or not
1443f10d
KW
32 my $lhs;
33 my $rhs;
34 if ($swap) {
35 $lhs = join "", @folded;
36 $rhs = $chr;
37 $rhs = "[$rhs]" if $charclass;
38 } else {
39 $lhs = $chr;
40 $rhs = "";
41 foreach my $rhs_char (@folded) {
42 $rhs .= '[' if $charclass;
43 $rhs .= $rhs_char;
44 $rhs .= ']' if $charclass;
45 }
46 }
47 $lhs = "\"$lhs\"";
48 $rhs = "/^$rhs\$/i";
24df86f6 49
1443f10d
KW
50 # Try both Latin1 and Unicode for code points below 256
51 foreach my $upgrade ("", 'utf8::upgrade($c); ') {
52 if ($upgrade) {
53 next if $swap && $fold_above_latin1;
54 next if !$swap && $cpv > 255;
55 }
56 my $eval = "my \$c = $lhs; $upgrade\$c =~ $rhs";
57 #print __LINE__, ": $eval\n";
58 push @tests, qq[ok(eval '$eval', '$eval - $comment')];
59 if (! $swap && ($cp eq '0390' || $cp eq '03B0')) {
60 $tests[-1]="TODO: { local \$::TODO='[13:41] <BinGOs> cue *It is all Greek to me* joke.';\n$tests[-1] }"
61 } elsif ($charclass && @folded > 1 && $swap && ! $upgrade && ! $fold_above_latin1) {
62 $tests[-1]="TODO: { local \$::TODO='Multi-char, non-utf8 folded inside character class [ ] doesnt work';\n$tests[-1] }"
63 } elsif (! $upgrade && $cpv >= 128 && $cpv <= 255 && $cpv != 0xb5) {
64 $tests[-1]="TODO: { local \$::TODO='Most non-utf8 latin1 doesnt work';\n$tests[-1] }"
2f7760b5
DM
65 } elsif (! $swap && $charclass && @folded > 1
66 && ! $todo_pass{$cp})
67 {
1443f10d
KW
68 # There are a few of these that pass; most fail.
69 $tests[-1]="TODO: { local \$::TODO='Some multi-char, f8 folded inside character class [ ] doesnt work';\n$tests[-1] }"
70 }
71 $count++;
72 }
73 }
a0a388a1 74 }
24df86f6 75}
2726813d
KW
76
77push @tests, qq[like chr(0x0430), qr/[=\x{0410}-\x{0411}]/i, 'Bug #71752 Unicode /i char in a range'];
78$count++;
79push @tests, qq[like 'a', qr/\\p{Upper}/i, "'a' =~ /\\\\p{Upper}/i"];
80$count++;
8951c461
KW
81push @tests, q[my $c = "\x{212A}"; my $p = qr/(?:^[\x{004B}_]+$)/i; utf8::upgrade($p); like $c, $p, 'Bug #78994: my $c = "\x{212A}"; my $p = qr/(?:^[\x{004B}_]+$)/i; utf8::upgrade($p); $c =~ $p'];
82$count++;
2726813d 83
a0a388a1
YO
84eval join ";\n","plan tests=>".($count-1),@tests,"1"
85 or die $@;
86__DATA__