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 | |
16 | # non-UTF-8 patterns, the strings are not folded, so we need to check for the | |
17 | # upper and lower case versions. For UTF-8 patterns, the strings are folded, | |
18 | # so we only need to worry about the fold version. There are no non-ASCII | |
19 | # Latin1 multi-char folds currently, and none likely to be ever added. Thus | |
20 | # the output is the same as if it were just asking for ASCII characters, not | |
21 | # full Latin1. Hence, it is suitable for generating things that match | |
22 | # EXACTFA. It does check for and croak if there ever were to be an upper | |
23 | # Latin1 range multi-character fold. | |
24 | # | |
4b9dbf47 KW |
25 | # This is designed for input to regen/regcharlass.pl. |
26 | ||
27 | sub gen_combinations ($;) { | |
28 | # Generate all combinations for the first parameter which is an array of | |
29 | # arrays. | |
30 | ||
31 | my ($fold_ref, $string, $i) = @_; | |
32 | $string = "" unless $string; | |
33 | $i = 0 unless $i; | |
34 | ||
35 | my @ret; | |
36 | ||
37 | # Look at each element in this level's array. | |
38 | foreach my $j (0 .. @{$fold_ref->[$i]} - 1) { | |
39 | ||
40 | # Append its representation to what we have currently | |
41 | my $new_string = sprintf "$string\\x{%X}", $fold_ref->[$i][$j]; | |
42 | ||
43 | if ($i >= @$fold_ref - 1) { # Final level: just return it | |
44 | push @ret, "\"$new_string\""; | |
45 | } | |
46 | else { # Generate the combinations for the next level with this one's | |
47 | push @ret, &gen_combinations($fold_ref, $new_string, $i + 1); | |
48 | } | |
49 | } | |
50 | ||
51 | return @ret; | |
52 | } | |
53 | ||
54 | sub multi_char_folds ($) { | |
55 | my $all_folds = shift; # The single parameter is true if wants all | |
56 | # multi-char folds; false if just the ones that | |
57 | # are all ascii | |
58 | ||
59 | my ($cp_ref, $folds_ref, $format) = prop_invmap("Case_Folding"); | |
60 | die "Could not find inversion map for Case_Folding" unless defined $format; | |
61 | die "Incorrect format '$format' for Case_Folding inversion map" | |
62 | unless $format eq 'al'; | |
63 | my @folds; | |
64 | ||
65 | for my $i (0 .. @$folds_ref - 1) { | |
66 | next unless ref $folds_ref->[$i]; # Skip single-char folds | |
67 | ||
68 | # The code in regcomp.c currently assumes that no multi-char fold | |
69 | # folds to the upper Latin1 range. It's not a big deal to add; we | |
70 | # just have to forbid such a fold in EXACTFL nodes, like we do already | |
71 | # for ascii chars in EXACTFA (and EXACTFL) nodes. But I (khw) doubt | |
72 | # that there will ever be such a fold created by Unicode, so the code | |
73 | # isn't there to occupy space and time; instead there is this check. | |
74 | die sprintf("regcomp.c can't cope with a latin1 multi-char fold (found in the fold of U+%X", $cp_ref->[$i]) if grep { $_ < 256 && chr($_) !~ /[[:ascii:]]/ } @{$folds_ref->[$i]}; | |
75 | ||
76 | # Create a line that looks like "\x{foo}\x{bar}\x{baz}" of the code | |
77 | # points that make up the fold. | |
78 | my $fold = join "", map { sprintf "\\x{%X}", $_ } @{$folds_ref->[$i]}; | |
79 | $fold = "\"$fold\""; | |
80 | ||
81 | # Skip if something else already has this fold | |
82 | next if grep { $_ eq $fold } @folds; | |
83 | ||
84 | if ($all_folds) { | |
85 | push @folds, $fold | |
86 | } # Skip if wants only all-ascii folds, and there is a non-ascii | |
87 | elsif (! grep { chr($_) =~ /[^[:ascii:]]/ } @{$folds_ref->[$i]}) { | |
88 | ||
89 | # If the fold is to a cased letter, replace the entry with an | |
90 | # array which also includes its upper case. | |
91 | my $this_fold_ref = $folds_ref->[$i]; | |
92 | for my $j (0 .. @$this_fold_ref - 1) { | |
93 | my $this_ord = $this_fold_ref->[$j]; | |
94 | if (chr($this_ord) =~ /\p{Cased}/) { | |
95 | my $uc = ord(uc(chr($this_ord))); | |
96 | undef $this_fold_ref->[$j]; | |
97 | @{$this_fold_ref->[$j]} = ( $this_ord, $uc); | |
98 | } | |
99 | } | |
100 | ||
101 | # Then generate all combinations of upper/lower case of the fold. | |
102 | push @folds, gen_combinations($this_fold_ref); | |
103 | ||
104 | } | |
105 | } | |
106 | ||
107 | return @folds; | |
108 | } | |
109 | ||
110 | 1 |