This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
mk_PL_charclass.pl: Allow to work on early Unicodes
[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';
164766b2 7 skip_all_if_miniperl("no dynamic loading on miniperl, no File::Spec");
24df86f6
RGS
8}
9
a0a388a1
YO
10use strict;
11use warnings;
a0a388a1 12my @tests;
a0a388a1
YO
13
14my $file="../lib/unicore/CaseFolding.txt";
24df86f6 15open my $fh,"<",$file or die "Failed to read '$file': $!";
a0a388a1
YO
16while (<$fh>) {
17 chomp;
18 my ($line,$comment)= split/\s+#\s+/, $_;
1443f10d 19 my ($cp,$type,@folded)=split/[\s;]+/,$line||'';
a0a388a1 20 next unless $type and ($type eq 'F' or $type eq 'C');
1443f10d
KW
21 my $fold_above_latin1 = grep { hex("0x$_") > 255 } @folded;
22 $_="\\x{$_}" for @folded;
a0a388a1 23 my $cpv=hex("0x$cp");
1443f10d 24 my $chr="\\x{$cp}";
a0a388a1 25 my @str;
1443f10d 26 foreach my $swap (0, 1) { # swap lhs and rhs, or not.
8edd0c7f 27 foreach my $charclass (0, 1) { # Put rhs in [...], or not
1443f10d
KW
28 my $lhs;
29 my $rhs;
30 if ($swap) {
31 $lhs = join "", @folded;
32 $rhs = $chr;
33 $rhs = "[$rhs]" if $charclass;
34 } else {
8edd0c7f 35 #next if $charclass && @folded > 1;
1443f10d
KW
36 $lhs = $chr;
37 $rhs = "";
38 foreach my $rhs_char (@folded) {
39 $rhs .= '[' if $charclass;
40 $rhs .= $rhs_char;
41 $rhs .= ']' if $charclass;
42 }
43 }
44 $lhs = "\"$lhs\"";
6cdc48f8 45 $rhs = "/^$rhs\$/iu";
24df86f6 46
1443f10d
KW
47 # Try both Latin1 and Unicode for code points below 256
48 foreach my $upgrade ("", 'utf8::upgrade($c); ') {
59aef945
KW
49 if ($upgrade) { # No need to upgrade if already must be in
50 # utf8
1443f10d
KW
51 next if $swap && $fold_above_latin1;
52 next if !$swap && $cpv > 255;
53 }
54 my $eval = "my \$c = $lhs; $upgrade\$c =~ $rhs";
55 #print __LINE__, ": $eval\n";
56 push @tests, qq[ok(eval '$eval', '$eval - $comment')];
67fcf67c 57 if (! $swap && $charclass && @folded > 1)
2f7760b5 58 {
67fcf67c 59 $tests[-1]="TODO: { local \$::TODO='A multi-char fold \"foo\", doesnt work for /[f][o][o]/i';\n$tests[-1] }"
1443f10d 60 }
1443f10d
KW
61 }
62 }
a0a388a1 63 }
24df86f6 64}
2726813d 65
fad448f4
KW
66# Now verify the case folding tables. First compute the mappings without
67# resorting to the functions we're testing.
68
69# Initialize the array so each $i maps to itself.
70my @fold_ascii;
71for my $i (0 .. 255) {
72 $fold_ascii[$i] = $i;
73}
74my @fold_latin1 = @fold_ascii;
75
76# Override the uppercase elements to fold to their lower case equivalents,
77# using the fact that 'A' in ASCII is 0x41, 'a' is 0x41+32, 'B' is 0x42, and
78# so on. The same paradigm applies for most of the Latin1 range cased
79# characters, but in posix anything outside ASCII maps to itself, as we've
80# already set up.
81for my $i (0x41 .. 0x5A, 0xC0 .. 0xD6, 0xD8 .. 0xDE) {
82 my $upper_ord = ord_latin1_to_native($i);
83 my $lower_ord = ord_latin1_to_native($i + 32);
84
85 $fold_latin1[$upper_ord] = $lower_ord;
86
87 next if $i > 127;
88 $fold_ascii[$upper_ord] = $lower_ord;
89}
90
91# Same for folding lower to the upper equivalents
92for my $i (0x61 .. 0x7A, 0xE0 .. 0xF6, 0xF8 .. 0xFE) {
93 my $lower_ord = ord_latin1_to_native($i);
94 my $upper_ord = ord_latin1_to_native($i - 32);
95
96 $fold_latin1[$lower_ord] = $upper_ord;
97
98 next if $i > 127;
99 $fold_ascii[$lower_ord] = $upper_ord;
100}
101
59aef945 102# Test every latin1 character for the correct values in both /u and /d
fad448f4
KW
103for my $i (0 .. 255) {
104 my $chr = sprintf "\\x%02X", $i;
105 my $hex_fold_ascii = sprintf "0x%02X", $fold_ascii[$i];
106 my $hex_fold_latin1 = sprintf "0x%02X", $fold_latin1[$i];
107 push @tests, qq[like chr($hex_fold_ascii), qr/(?d:$chr)/i, 'chr($hex_fold_ascii) =~ qr/(?d:$chr)/i'];
fad448f4 108 push @tests, qq[like chr($hex_fold_latin1), qr/(?u:$chr)/i, 'chr($hex_fold_latin1) =~ qr/(?u:$chr)/i'];
fad448f4
KW
109}
110
111
2726813d 112push @tests, qq[like chr(0x0430), qr/[=\x{0410}-\x{0411}]/i, 'Bug #71752 Unicode /i char in a range'];
2726813d 113push @tests, qq[like 'a', qr/\\p{Upper}/i, "'a' =~ /\\\\p{Upper}/i"];
8951c461 114push @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'];
2726813d 115
7b98bc43
KW
116use charnames ":full";
117push @tests, q[my $re1 = "\N{WHITE SMILING FACE}";like "\xE8", qr/[\w$re1]/, 'my $re = "\N{WHITE SMILING FACE}"; "\xE8" =~ qr/[\w$re]/'];
118push @tests, q[my $re2 = "\N{WHITE SMILING FACE}";like "\xE8", qr/\w|$re2/, 'my $re = "\N{WHITE SMILING FACE}"; "\xE8" =~ qr/\w|$re/'];
119
b2a1b324 120eval join ";\n","plan tests=>". (scalar @tests), @tests, "1"
a0a388a1
YO
121 or die $@;
122__DATA__