This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
regen/regcharclass_multi_char_folds.pl: Use case fold
[perl5.git] / regen / regcharclass_multi_char_folds.pl
CommitLineData
4b9dbf47
KW
1package regcharclass_multi_char_folds;
2use 5.015;
3use strict;
4use warnings;
5use Unicode::UCD "prop_invmap";
6
7# This returns an array of strings of the form
8# "\x{foo}\x{bar}\x{baz}"
9# of the sequences of code points that are multi-character folds in the
10# current Unicode version. If the parameter is 1, all such folds are
11# returned. If the parameters is 0, only the ones containing exclusively
40b1ba4f
KW
12# Latin1 characters are returned. In the latter case all combinations of
13# Latin1 characters that can fold to the base one are returned. Thus for
14# 'ss', it would return in addition, 'Ss', 'sS', and 'SS'. This is because
15# this code is designed to help regcomp.c, and EXACTFish regnodes. For
53b298b6
KW
16# non-UTF-8 patterns, the strings are not necessarily folded, so we need to
17# check for the upper and lower case versions. For UTF-8 patterns, the
18# strings are folded, except in EXACTFL nodes) so we only need to worry about
19# the fold version. All folded-to characters in non-UTF-8 (Latin1) are
20# members of fold-pairs, at least within Latin1, 'k', and 'K', for example.
21# So there aren't complications with dealing with unfolded input. That's not
22# true of UTF-8 patterns, where things can get tricky. Thus for EXACTFL nodes
23# where things aren't all folded, code has to be written specially to handle
24# this, instead of the macros here being extended to try to handle it.
b07262fd
KW
25#
26# There are no non-ASCII Latin1 multi-char folds currently, and none likely to
27# be ever added. Thus the output is the same as if it were just asking for
28# ASCII characters, not full Latin1. Hence, it is suitable for generating
53b298b6 29# things that match EXACTFAA. It does check for and croak if there ever were
b07262fd 30# to be an upper Latin1 range multi-character fold.
40b1ba4f 31#
4b9dbf47
KW
32# This is designed for input to regen/regcharlass.pl.
33
34sub gen_combinations ($;) {
35 # Generate all combinations for the first parameter which is an array of
36 # arrays.
37
38 my ($fold_ref, $string, $i) = @_;
39 $string = "" unless $string;
40 $i = 0 unless $i;
41
42 my @ret;
43
44 # Look at each element in this level's array.
45 foreach my $j (0 .. @{$fold_ref->[$i]} - 1) {
46
47 # Append its representation to what we have currently
d960bb7e
KW
48 my $new_string = $fold_ref->[$i][$j] =~ /[[:print:]]/
49 ? ($string . chr $fold_ref->[$i][$j])
50 : sprintf "$string\\x{%X}", $fold_ref->[$i][$j];
4b9dbf47
KW
51
52 if ($i >= @$fold_ref - 1) { # Final level: just return it
53 push @ret, "\"$new_string\"";
54 }
55 else { # Generate the combinations for the next level with this one's
56 push @ret, &gen_combinations($fold_ref, $new_string, $i + 1);
57 }
58 }
59
60 return @ret;
61}
62
42d7c910
KW
63sub multi_char_folds ($$) {
64 my $type = shift; # 'u' for UTF-8; 'l' for latin1
65 my $range = shift; # 'a' for all; 'h' for starting 2 bytes; 'm' for ending 2
66 die "[lu] only valid values for first parameter" if $type !~ /[lu]/;
67 die "[aht3] only valid values for 2nd parameter" if $range !~ /[aht3]/;
4b9dbf47 68
9b63e895
KW
69 return () if pack("C*", split /\./, Unicode::UCD::UnicodeVersion()) lt v3.0.1;
70
4b9dbf47
KW
71 my ($cp_ref, $folds_ref, $format) = prop_invmap("Case_Folding");
72 die "Could not find inversion map for Case_Folding" unless defined $format;
73 die "Incorrect format '$format' for Case_Folding inversion map"
74 unless $format eq 'al';
8cb8e708 75
114fc8b6
KW
76 my %inverse_latin1_folds;
77 for my $i (0 .. @$cp_ref - 1) {
78 next if ref $folds_ref->[$i]; # multi-char fold
79 next if $folds_ref->[$i] == 0; # Not folded
80 my $cp_base = $cp_ref->[$i];
81
82 for my $j ($cp_base .. $cp_ref->[$i+1] - 1) {
83 my $folded_base = $folds_ref->[$i];
84 next if $folded_base > 255; # only interested in Latin1
85 push @{$inverse_latin1_folds{$folded_base + $j - $cp_base}}, $j;
86 }
87 }
88
4b9dbf47 89 my @folds;
8cb8e708 90 my @output_folds;
4b9dbf47
KW
91
92 for my $i (0 .. @$folds_ref - 1) {
93 next unless ref $folds_ref->[$i]; # Skip single-char folds
94
95 # The code in regcomp.c currently assumes that no multi-char fold
96 # folds to the upper Latin1 range. It's not a big deal to add; we
97 # just have to forbid such a fold in EXACTFL nodes, like we do already
98 # for ascii chars in EXACTFA (and EXACTFL) nodes. But I (khw) doubt
99 # that there will ever be such a fold created by Unicode, so the code
100 # isn't there to occupy space and time; instead there is this check.
33daa3a5 101 die sprintf("regcomp.c can't cope with a latin1 multi-char fold (found in the fold of 0x%X", $cp_ref->[$i]) if grep { $_ < 256 && chr($_) !~ /[[:ascii:]]/ } @{$folds_ref->[$i]};
4b9dbf47 102
8cb8e708 103 @folds = @{$folds_ref->[$i]};
42d7c910
KW
104 if ($range eq '3') {
105 next if @folds < 3;
106 }
107 elsif ($range eq 'h') {
108 pop @folds;
109 }
110 elsif ($range eq 't') {
111 next if @folds < 3;
112 shift @folds;
113 }
8cb8e708 114
4b9dbf47 115 # Create a line that looks like "\x{foo}\x{bar}\x{baz}" of the code
d960bb7e
KW
116 # points that make up the fold (use the actual character if
117 # printable).
118 my $fold = join "", map { chr $_ =~ /[[:print:]]/a
119 ? chr $_
120 : sprintf "\\x{%X}", $_
8cb8e708 121 } @folds;
4b9dbf47
KW
122 $fold = "\"$fold\"";
123
124 # Skip if something else already has this fold
8cb8e708 125 next if grep { $_ eq $fold } @output_folds;
4b9dbf47 126
70dc0cf1
KW
127 # If the fold is to a cased letter, replace the entry with an
128 # array which also includes its upper case.
129 my $this_fold_ref = \@folds;
130 for my $j (0 .. @$this_fold_ref - 1) {
131 my $this_ord = $this_fold_ref->[$j];
132 undef $this_fold_ref->[$j];
133
114fc8b6
KW
134 # If the fold is to a Latin1-range cased letter, replace the entry
135 # with an array which also includes everything that folds to it.
136 if (exists $inverse_latin1_folds{$this_ord}) {
137 push @{$this_fold_ref->[$j]},
138 ( $this_ord, @{$inverse_latin1_folds{$this_ord}} );
70dc0cf1
KW
139 }
140 else { # Otherwise, just itself. (gen_combinations() needs a ref)
141 @{$this_fold_ref->[$j]} = ( $this_ord );
4b9dbf47 142 }
70dc0cf1 143 }
4b9dbf47 144
70dc0cf1
KW
145 # Then generate all combinations of upper/lower case of the fold.
146 push @output_folds, gen_combinations($this_fold_ref);
4b9dbf47 147
4b9dbf47
KW
148 }
149
1ca267a5
KW
150 # \x17F is the small LONG S, which folds to 's'. Both Capital and small
151 # LATIN SHARP S fold to 'ss'. Therefore, they should also match two 17F's
152 # in a row under regex /i matching. But under /iaa regex matching, all
153 # three folds to 's' are prohibited, but the sharp S's should still match
154 # two 17F's. This prohibition causes our regular regex algorithm that
155 # would ordinarily allow this match to fail. This is the only instance in
156 # all Unicode of this kind of issue. By adding a special case here, we
157 # can use the regular algorithm (with some other changes elsewhere as
158 # well).
159 #
160 # It would be possible to re-write the above code to automatically detect
161 # and handle this case, and any others that might eventually get added to
162 # the Unicode standard, but I (khw) don't think it's worth it. I believe
163 # that it's extremely unlikely that more folds to ASCII characters are
164 # going to be added, and if I'm wrong, fold_grind.t has the intelligence
165 # to detect them, and test that they work, at which point another special
166 # case could be added here if necessary.
167 #
168 # No combinations of this with 's' need be added, as any of these
ab473f03 169 # containing 's' are prohibited under /iaa.
42d7c910 170 push @output_folds, '"\x{17F}\x{17F}"' if $type eq 'u' && $range eq 'a';
1ca267a5 171
8cb8e708 172 return @output_folds;
4b9dbf47
KW
173}
174
1751