Commit | Line | Data |
---|---|---|
4b9dbf47 KW |
1 | package regcharclass_multi_char_folds; |
2 | use 5.015; | |
3 | use strict; | |
4 | use warnings; | |
5 | use 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 | ||
34 | sub 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. | |
a50454ce | 45 | if (ref $fold_ref->[$i]) { |
4b9dbf47 KW |
46 | foreach my $j (0 .. @{$fold_ref->[$i]} - 1) { |
47 | ||
48 | # Append its representation to what we have currently | |
d960bb7e KW |
49 | my $new_string = $fold_ref->[$i][$j] =~ /[[:print:]]/ |
50 | ? ($string . chr $fold_ref->[$i][$j]) | |
51 | : sprintf "$string\\x{%X}", $fold_ref->[$i][$j]; | |
4b9dbf47 KW |
52 | |
53 | if ($i >= @$fold_ref - 1) { # Final level: just return it | |
54 | push @ret, "\"$new_string\""; | |
55 | } | |
56 | else { # Generate the combinations for the next level with this one's | |
57 | push @ret, &gen_combinations($fold_ref, $new_string, $i + 1); | |
58 | } | |
59 | } | |
a50454ce | 60 | } |
4b9dbf47 KW |
61 | |
62 | return @ret; | |
63 | } | |
64 | ||
42d7c910 KW |
65 | sub multi_char_folds ($$) { |
66 | my $type = shift; # 'u' for UTF-8; 'l' for latin1 | |
67 | my $range = shift; # 'a' for all; 'h' for starting 2 bytes; 'm' for ending 2 | |
68 | die "[lu] only valid values for first parameter" if $type !~ /[lu]/; | |
69 | die "[aht3] only valid values for 2nd parameter" if $range !~ /[aht3]/; | |
4b9dbf47 | 70 | |
9b63e895 KW |
71 | return () if pack("C*", split /\./, Unicode::UCD::UnicodeVersion()) lt v3.0.1; |
72 | ||
4b9dbf47 KW |
73 | my ($cp_ref, $folds_ref, $format) = prop_invmap("Case_Folding"); |
74 | die "Could not find inversion map for Case_Folding" unless defined $format; | |
75 | die "Incorrect format '$format' for Case_Folding inversion map" | |
76 | unless $format eq 'al'; | |
8cb8e708 | 77 | |
114fc8b6 KW |
78 | my %inverse_latin1_folds; |
79 | for my $i (0 .. @$cp_ref - 1) { | |
80 | next if ref $folds_ref->[$i]; # multi-char fold | |
81 | next if $folds_ref->[$i] == 0; # Not folded | |
82 | my $cp_base = $cp_ref->[$i]; | |
83 | ||
84 | for my $j ($cp_base .. $cp_ref->[$i+1] - 1) { | |
85 | my $folded_base = $folds_ref->[$i]; | |
86 | next if $folded_base > 255; # only interested in Latin1 | |
87 | push @{$inverse_latin1_folds{$folded_base + $j - $cp_base}}, $j; | |
88 | } | |
89 | } | |
90 | ||
4b9dbf47 | 91 | my @folds; |
a50454ce | 92 | my %output_folds; |
4b9dbf47 KW |
93 | |
94 | for my $i (0 .. @$folds_ref - 1) { | |
95 | next unless ref $folds_ref->[$i]; # Skip single-char folds | |
96 | ||
97 | # The code in regcomp.c currently assumes that no multi-char fold | |
98 | # folds to the upper Latin1 range. It's not a big deal to add; we | |
99 | # just have to forbid such a fold in EXACTFL nodes, like we do already | |
100 | # for ascii chars in EXACTFA (and EXACTFL) nodes. But I (khw) doubt | |
101 | # that there will ever be such a fold created by Unicode, so the code | |
102 | # isn't there to occupy space and time; instead there is this check. | |
33daa3a5 | 103 | 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 | 104 | |
8cb8e708 | 105 | @folds = @{$folds_ref->[$i]}; |
42d7c910 KW |
106 | if ($range eq '3') { |
107 | next if @folds < 3; | |
108 | } | |
109 | elsif ($range eq 'h') { | |
110 | pop @folds; | |
111 | } | |
112 | elsif ($range eq 't') { | |
113 | next if @folds < 3; | |
114 | shift @folds; | |
115 | } | |
8cb8e708 | 116 | |
4b9dbf47 | 117 | # Create a line that looks like "\x{foo}\x{bar}\x{baz}" of the code |
d960bb7e KW |
118 | # points that make up the fold (use the actual character if |
119 | # printable). | |
120 | my $fold = join "", map { chr $_ =~ /[[:print:]]/a | |
121 | ? chr $_ | |
122 | : sprintf "\\x{%X}", $_ | |
8cb8e708 | 123 | } @folds; |
4b9dbf47 KW |
124 | $fold = "\"$fold\""; |
125 | ||
126 | # Skip if something else already has this fold | |
a50454ce | 127 | next if grep { $_ eq $fold } keys %output_folds; |
4b9dbf47 | 128 | |
70dc0cf1 KW |
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 | 145 | # Then generate all combinations of upper/lower case of the fold. |
a50454ce | 146 | $output_folds{$_} = $cp_ref->[$i] for gen_combinations($this_fold_ref); |
4b9dbf47 KW |
147 | } |
148 | ||
1ca267a5 KW |
149 | # \x17F is the small LONG S, which folds to 's'. Both Capital and small |
150 | # LATIN SHARP S fold to 'ss'. Therefore, they should also match two 17F's | |
151 | # in a row under regex /i matching. But under /iaa regex matching, all | |
152 | # three folds to 's' are prohibited, but the sharp S's should still match | |
153 | # two 17F's. This prohibition causes our regular regex algorithm that | |
154 | # would ordinarily allow this match to fail. This is the only instance in | |
155 | # all Unicode of this kind of issue. By adding a special case here, we | |
156 | # can use the regular algorithm (with some other changes elsewhere as | |
157 | # well). | |
158 | # | |
159 | # It would be possible to re-write the above code to automatically detect | |
160 | # and handle this case, and any others that might eventually get added to | |
161 | # the Unicode standard, but I (khw) don't think it's worth it. I believe | |
162 | # that it's extremely unlikely that more folds to ASCII characters are | |
163 | # going to be added, and if I'm wrong, fold_grind.t has the intelligence | |
164 | # to detect them, and test that they work, at which point another special | |
165 | # case could be added here if necessary. | |
166 | # | |
167 | # No combinations of this with 's' need be added, as any of these | |
ab473f03 | 168 | # containing 's' are prohibited under /iaa. |
a50454ce | 169 | $output_folds{"\"\x{17F}\x{17F}\""} = 0xDF if $type eq 'u' && $range eq 'a'; |
1ca267a5 | 170 | |
a50454ce | 171 | return %output_folds; |
4b9dbf47 KW |
172 | } |
173 | ||
174 | 1 |