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 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#
25# This is designed for input to regen/regcharlass.pl.
26
27sub 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
54sub 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 0x%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    # \x17F is the small LONG S, which folds to 's'.  Both Capital and small
108    # LATIN SHARP S fold to 'ss'.  Therefore, they should also match two 17F's
109    # in a row under regex /i matching.  But under /iaa regex matching, all
110    # three folds to 's' are prohibited, but the sharp S's should still match
111    # two 17F's.  This prohibition causes our regular regex algorithm that
112    # would ordinarily allow this match to fail.  This is the only instance in
113    # all Unicode of this kind of issue.  By adding a special case here, we
114    # can use the regular algorithm (with some other changes elsewhere as
115    # well).
116    #
117    # It would be possible to re-write the above code to automatically detect
118    # and handle this case, and any others that might eventually get added to
119    # the Unicode standard, but I (khw) don't think it's worth it.  I believe
120    # that it's extremely unlikely that more folds to ASCII characters are
121    # going to be added, and if I'm wrong, fold_grind.t has the intelligence
122    # to detect them, and test that they work, at which point another special
123    # case could be added here if necessary.
124    #
125    # No combinations of this with 's' need be added, as any of these
126    # containing 's' are prohibted under /iaa.
127    push @folds, "\"\x{17F}\x{17F}\"";
128
129
130    return @folds;
131}
132
1331
134