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
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 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.
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
29# things that match EXACTFAA.  It does check for and croak if there ever were
30# to be an upper Latin1 range multi-character fold.
31#
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    if (ref $fold_ref->[$i]) {
46    foreach my $j (0 .. @{$fold_ref->[$i]} - 1) {
47
48        # Append its representation to what we have currently
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];
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    }
60    }
61
62    return @ret;
63}
64
65sub 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]/;
70
71    return () if pack("C*", split /\./, Unicode::UCD::UnicodeVersion()) lt v3.0.1;
72
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';
77
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
91    my @folds;
92    my %output_folds;
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.
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]};
104
105        @folds = @{$folds_ref->[$i]};
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        }
116
117        # Create a line that looks like "\x{foo}\x{bar}\x{baz}" of the code
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}", $_
123                                } @folds;
124        $fold = "\"$fold\"";
125
126        # Skip if something else already has this fold
127        next if grep { $_ eq $fold } keys %output_folds;
128
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
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}} );
139            }
140            else {  # Otherwise, just itself. (gen_combinations() needs a ref)
141                @{$this_fold_ref->[$j]} = ( $this_ord );
142            }
143        }
144
145        # Then generate all combinations of upper/lower case of the fold.
146        $output_folds{$_} = $cp_ref->[$i] for gen_combinations($this_fold_ref);
147    }
148
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
168    # containing 's' are prohibited under /iaa.
169    $output_folds{"\"\x{17F}\x{17F}\""} = 0xDF if $type eq 'u' && $range eq 'a';
170
171    return %output_folds;
172}
173
1741
175