PATCH: [perl #89774] multi-char fold + its fold in char class

The design for handling characters that fold to multiple characters when
the former are encountered in a bracketed character class is defective.
The ticket reads, "If a bracketed character class includes a character
that has a multi-char fold, and it also includes the first character of
that fold, the multi-char fold will never be matched; just the first
character of the fold.".   Thus, in the class /[\0-\xff]/i, \xDF will
never be matched, because its fold is 'ss', the first character of
which, 's', is also in the class.

The reason the design is defective is that it doesn't allow for
backtracking and trying the other options.

This commit solves this by effectively rewriting the above to be
/ (?: \xdf | [\0-\xde\xe0-\xff] ) /xi.  And so the backtracking gets
handled automatcially by the regex engine.

8 files changed, 247 insertions, 35 deletions

diff --git a/embedvar.h b/embedvar.h
index 92bd2ae5d3..dc2583dd85 100644
--- a/embedvar.h
+++ b/embedvar.h
@@ -53,6 +53,7 @@
 #define PL_DBtrace		(vTHX->IDBtrace)
 #define PL_Dir			(vTHX->IDir)
 #define PL_Env			(vTHX->IEnv)
+#define PL_HasMultiCharFold	(vTHX->IHasMultiCharFold)
 #define PL_L1Cased		(vTHX->IL1Cased)
 #define PL_L1PosixAlnum		(vTHX->IL1PosixAlnum)
 #define PL_L1PosixAlpha		(vTHX->IL1PosixAlpha)
diff --git a/intrpvar.h b/intrpvar.h
index 41d9dbbbd5..3978dc1c5d 100644
--- a/intrpvar.h
+++ b/intrpvar.h
@@ -609,6 +609,7 @@ PERLVAR(I, XPosixXDigit, SV *)
 PERLVAR(I, VertSpace,   SV *)
 
 PERLVAR(I, NonL1NonFinalFold,   SV *)
+PERLVAR(I, HasMultiCharFold,   SV *)
 
 /* utf8 character class swashes */
 PERLVAR(I, utf8_alnum,	SV *)
diff --git a/pod/perldelta.pod b/pod/perldelta.pod
index e06faab6a7..a96d4ee3c0 100644
--- a/pod/perldelta.pod
+++ b/pod/perldelta.pod
@@ -53,6 +53,30 @@ XXX For a release on a stable branch, this section aspires to be:
 
 [ List each incompatible change as a =head2 entry ]
 
+=head2 New Restrictions in Multi-Character Case-Insensitive Matching in Regular Expression Bracketed Character Classes
+
+Unicode has now withdrawn their previous recommendation for regular
+expressions to automatically handle cases where a single character can
+match multiple characters case-insensitively; for example, the letter
+LATIN SMALL LETTER SHARP S and the sequence C<ss>.  This is because
+it turns out to be impracticable to do this correctly in all
+circumstances.  Because Perl has tried to do this as best it can, it
+will continue to do so.  (We are considering an option to turn it off.)
+However, a new restriction is being added on such matches when they
+occur in [bracketed] character classes.  People were specifying
+things such as C</[\0-\xff]/i>, and being surprised that it matches the
+two character sequence C<ss> (since LATIN SMALL LETTER SHARP S occurs in
+this range).  This behavior is also inconsistent with the using a
+property instead of a range:  C<\p{Block=Latin1}> also includes LATIN
+SMALL LETTER SHARP S, but C</[\p{Block=Latin1}]/i> does not match C<ss>.
+The new rule is that for there to be a multi-character case-insensitive
+match within a bracketed character class, the character must be
+explicitly listed, and not as an end point of a range.  This more
+closely obeys the Principle of Least Astonishment.  See
+L<perlrecharclass/Bracketed Character Classes>.  Note that a bug [perl
+#89774], now fixed as part of this change, prevented the previous
+behavior from working fully.
+
 =head1 Deprecations
 
 XXX Any deprecated features, syntax, modules etc. should be listed here.  In
@@ -315,7 +339,9 @@ well.
 
 =item *
 
-XXX
+Case-insensitive matching inside a [bracketed] character class with a
+multi-character fold, no longer excludes one of the possibilities in the
+circumstances that it used to. [perl #89774].
 
 =back
 
diff --git a/pod/perlre.pod b/pod/perlre.pod
index b6d6677b2a..09cb581bc7 100644
--- a/pod/perlre.pod
+++ b/pod/perlre.pod
@@ -72,27 +72,13 @@ are split between groupings, or when one or more are quantified.  Thus
  # be even if it did!!
  "\N{LATIN SMALL LIGATURE FI}" =~ /(f)(i)/i;      # Doesn't match!
 
-Perl doesn't match multiple characters in an inverted bracketed
-character class, which otherwise could be highly confusing.  See
+Perl doesn't match multiple characters in a bracketed
+character class unless the character that maps to them is explicitly
+mentioned, and it doesn't match them at all if the character class is
+inverted, which otherwise could be highly confusing.  See
+L<perlrecharclass/Bracketed Character Classes>, and
 L<perlrecharclass/Negation>.
 
-Another bug involves character classes that match both a sequence of
-multiple characters, and an initial sub-string of that sequence.  For
-example,
-
- /[s\xDF]/i
-
-should match both a single and a double "s", since C<\xDF> (on ASCII
-platforms) matches "ss".  However, this bug
-(L<[perl #89774]|https://rt.perl.org/rt3/Ticket/Display.html?id=89774>)
-causes it to only match a single "s", even if the final larger match
-fails, and matching the double "ss" would have succeeded.
-
-Also, Perl matching doesn't fully conform to the current Unicode C</i>
-recommendations, which ask that the matching be made upon the NFD
-(Normalization Form Decomposed) of the text.  However, Unicode is
-in the process of reconsidering and revising their recommendations.
-
 =item x
 X</x>
 
diff --git a/pod/perlrecharclass.pod b/pod/perlrecharclass.pod
index a273a77e0b..7dafc54f9c 100644
--- a/pod/perlrecharclass.pod
+++ b/pod/perlrecharclass.pod
@@ -441,7 +441,8 @@ Examples:
 
 * There is an exception to a bracketed character class matching a
 single character only.  When the class is to match caselessly under C</i>
-matching rules, and a character inside the class matches a
+matching rules, and a character that is explicitly mentioned inside the
+class matches a
 multiple-character sequence caselessly under Unicode rules, the class
 (when not L<inverted|/Negation>) will also match that sequence.  For
 example, Unicode says that the letter C<LATIN SMALL LETTER SHARP S>
@@ -450,6 +451,18 @@ should match the sequence C<ss> under C</i> rules.  Thus,
  'ss' =~ /\A\N{LATIN SMALL LETTER SHARP S}\z/i             # Matches
  'ss' =~ /\A[aeioust\N{LATIN SMALL LETTER SHARP S}]\z/i    # Matches
 
+For this to happen, the character must be explicitly specified, and not
+be part of a multi-character range (not even as one of its endpoints).
+(L</Character Ranges> will be explained shortly.)  Therefore,
+
+ 'ss' =~ /\A[\0-\x{ff}]\z/i        # Doesn't match
+ 'ss' =~ /\A[\0-\N{LATIN SMALL LETTER SHARP S}]\z/i    # No match
+ 'ss' =~ /\A[\xDF-\xDF]\z/i    # Matches on ASCII platforms, since \XDF
+                               # is LATIN SMALL LETTER SHARP S, and the
+                               # range is just a single element
+
+Note that it isn't a good idea to specify these types of ranges anyway.
+
 =head3 Special Characters Inside a Bracketed Character Class
 
 Most characters that are meta characters in regular expressions (that
diff --git a/regcomp.c b/regcomp.c
index 965b461bca..e1b8b79fcd 100644
--- a/regcomp.c
+++ b/regcomp.c
@@ -159,6 +159,7 @@ typedef struct RExC_state_t {
     I32		in_lookbehind;
     I32		contains_locale;
     I32		override_recoding;
+    I32		in_multi_char_class;
     struct reg_code_block *code_blocks;	/* positions of literal (?{})
 					    within pattern */
     int		num_code_blocks;	/* size of code_blocks[] */
@@ -213,7 +214,8 @@ typedef struct RExC_state_t {
 #define RExC_recurse_count	(pRExC_state->recurse_count)
 #define RExC_in_lookbehind	(pRExC_state->in_lookbehind)
 #define RExC_contains_locale	(pRExC_state->contains_locale)
-#define RExC_override_recoding	(pRExC_state->override_recoding)
+#define RExC_override_recoding (pRExC_state->override_recoding)
+#define RExC_in_multi_char_class (pRExC_state->in_multi_char_class)
 
 
 #define	ISMULT1(c)	((c) == '*' || (c) == '+' || (c) == '?')
@@ -5361,6 +5363,8 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count,
 
 	PL_PosixXDigit = _new_invlist_C_array(PosixXDigit_invlist);
 	PL_XPosixXDigit = _new_invlist_C_array(XPosixXDigit_invlist);
+
+        PL_HasMultiCharFold = _new_invlist_C_array(_Perl_Multi_Char_Folds_invlist);
     }
 #endif
 
@@ -5768,6 +5772,7 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count,
     RExC_seen_zerolen = *exp == '^' ? -1 : 0;
     RExC_extralen = 0;
     RExC_override_recoding = 0;
+    RExC_in_multi_char_class = 0;
 
     /* First pass: determine size, legality. */
     RExC_parse = exp;
@@ -11427,21 +11432,35 @@ S_add_alternate(pTHX_ AV** alternate_ptr, U8* string, STRLEN len)
  * number defined in handy.h. */
 #define namedclass_to_classnum(class)  ((class) / 2)
 
-/*
-   parse a class specification and produce either an ANYOF node that
-   matches the pattern or perhaps will be optimized into an EXACTish node
-   instead. The node contains a bit map for the first 256 characters, with the
-   corresponding bit set if that character is in the list.  For characters
-   above 255, a range list is used */
-
 STATIC regnode *
 S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
 {
+    /* parse a bracketed class specification.  Most of these will produce an ANYOF node;
+     * but something like [a] will produce an EXACT node; [aA], an EXACTFish
+     * node; [[:ascii:]], a POSIXA node; etc.  It is more complex under /i with
+     * multi-character folds: it will be rewritten following the paradigm of
+     * this example, where the <multi-fold>s are characters which fold to
+     * multiple character sequences:
+     *      /[abc\x{multi-fold1}def\x{multi-fold2}ghi]/i
+     * gets effectively rewritten as:
+     *      /(?:\x{multi-fold1}|\x{multi-fold2}|[abcdefghi]/i
+     * reg() gets called (recursively) on the rewritten version, and this
+     * function will return what it constructs.  (Actually the <multi-fold>s
+     * aren't physically removed from the [abcdefghi], it's just that they are
+     * ignored in the recursion by means of a a flag:
+     * <RExC_in_multi_char_class>.)
+     *
+     * ANYOF nodes contain a bit map for the first 256 characters, with the
+     * corresponding bit set if that character is in the list.  For characters
+     * above 255, a range list or swash is used.  There are extra bits for \w,
+     * etc. in locale ANYOFs, as what these match is not determinable at
+     * compile time */
+
     dVAR;
     UV nextvalue;
-    UV prevvalue = OOB_UNICODE;
+    UV prevvalue, save_prevvalue = OOB_UNICODE;
     IV range = 0;
-    UV value = 0;
+    UV value, save_value = 0;
     regnode *ret;
     STRLEN numlen;
     IV namedclass = OOB_NAMEDCLASS;
@@ -11456,6 +11475,8 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
                                extended beyond the Latin1 range */
     UV element_count = 0;   /* Number of distinct elements in the class.
 			       Optimizations may be possible if this is tiny */
+    AV * multi_char_matches = NULL; /* Code points that fold to more than one
+                                       character; used under /i */
     UV n;
 
     /* Unicode properties are stored in a swash; this holds the current one
@@ -11514,9 +11535,10 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
     }
 
     if (UCHARAT(RExC_parse) == '^') {	/* Complement of range. */
-	RExC_naughty++;
 	RExC_parse++;
+        if (! RExC_in_multi_char_class) {
         invert = TRUE;
+        RExC_naughty++;
 
         /* We have decided to not allow multi-char folds in inverted character
 	 * classes, due to the confusion that can happen, especially with
@@ -11527,6 +11549,7 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
          *
          * See [perl #89750] */
         allow_full_fold = FALSE;
+        }
     }
 
     if (SIZE_ONLY) {
@@ -11557,6 +11580,8 @@ parseit:
     charclassloop:
 
 	namedclass = OOB_NAMEDCLASS; /* initialize as illegal */
+        save_value = value;
+        save_prevvalue = prevvalue;
 
 	if (!range) {
 	    rangebegin = RExC_parse;
@@ -12180,8 +12205,92 @@ parseit:
 	    RExC_uni_semantics = 1;
 	}
 
-        /* Ready to process either the single value, or the completed range */
-	if (!SIZE_ONLY) {
+        /* Ready to process either the single value, or the completed range.
+         * For single-valued non-inverted ranges, we consider the possibility
+         * of multi-char folds.  (We made a conscious decision to not do this
+         * for the other cases because it can often lead to non-intuitive
+         * results) */
+        if (FOLD && ! invert && value == prevvalue) {
+            if (value == LATIN_SMALL_LETTER_SHARP_S
+                || (value > 255 && _invlist_contains_cp(PL_HasMultiCharFold,
+                                                        value)))
+            {
+                /* Here <value> is indeed a multi-char fold.  Get what it is */
+
+                U8 foldbuf[UTF8_MAXBYTES_CASE];
+                STRLEN foldlen;
+
+                UV folded = _to_uni_fold_flags(
+                                value,
+                                foldbuf,
+                                &foldlen,
+                                FOLD_FLAGS_FULL
+                                | ((LOC) ?  FOLD_FLAGS_LOCALE
+                                            : (ASCII_FOLD_RESTRICTED)
+                                              ? FOLD_FLAGS_NOMIX_ASCII
+                                              : 0)
+                                );
+
+                /* Here, <folded> should be the first character of the
+                 * multi-char fold of <value>, with <foldbuf> containing the
+                 * whole thing.  But, if this fold is not allowed (because of
+                 * the flags), <fold> will be the same as <value>, and should
+                 * be processed like any other character, so skip the special
+                 * handling */
+                if (folded != value) {
+
+                    /* Skip if we are recursed, currently parsing the class
+                     * again.  Otherwise add this character to the list of
+                     * multi-char folds. */
+                    if (! RExC_in_multi_char_class) {
+                        AV** this_array_ptr;
+                        AV* this_array;
+                        STRLEN cp_count = utf8_length(foldbuf, foldbuf + foldlen);
+                        SV* multi_fold = sv_2mortal(newSVpvn("", 0));
+
+                        Perl_sv_catpvf(aTHX_ multi_fold, "\\x{%"UVXf"}", value);
+
+
+                        if (! multi_char_matches) {
+                            multi_char_matches = newAV();
+                        }
+
+                        /* <multi_char_matches> is actually an array of arrays.
+                         * There will be one or two top-level elements: [2],
+                         * and/or [3].  The [2] element is an array, each
+                         * element thereof is a character which folds to two
+                         * characters; likewise for [3].  (Unicode guarantees a
+                         * maximum of 3 characters in any fold.)  When we
+                         * rewrite the character class below, we will do so
+                         * such that the longest folds are written first, so
+                         * that it prefers the longest matching strings first.
+                         * This is done even if it turns out that any
+                         * quantifier is non-greedy, out of programmer
+                         * laziness.  Tom Christiansen has agreed that this is
+                         * ok.  This makes the test for the ligature 'ffi' come
+                         * before the test for 'ff' */
+                        if (av_exists(multi_char_matches, cp_count)) {
+                            this_array_ptr = (AV**) av_fetch(multi_char_matches, cp_count, FALSE);
+                            this_array = *this_array_ptr;
+                        }
+                        else {
+                            this_array = newAV();
+                            av_store(multi_char_matches, cp_count, (SV*) this_array);
+                        }
+                        av_push(this_array, multi_fold);
+                    }
+
+                    /* This element should not be processed further in this class */
+                    element_count--;
+                    value = save_value;
+                    prevvalue = save_prevvalue;
+                    continue;
+                }
+            }
+        }
+
+        /* Deal with this element of the class */
+	if (! SIZE_ONLY) {
 #ifndef EBCDIC
             cp_list = _add_range_to_invlist(cp_list, prevvalue, value);
 #else
@@ -12211,6 +12320,80 @@ parseit:
 	range = 0; /* this range (if it was one) is done now */
     } /* End of loop through all the text within the brackets */
 
+    /* If anything in the class expands to more than one character, we have to
+     * deal with them by building up a substitute parse string, and recursively
+     * calling reg() on it, instead of proceeding */
+    if (multi_char_matches) {
+	SV * substitute_parse = newSVpvn_flags("?:", 2, SVs_TEMP);
+        I32 cp_count;
+	STRLEN len;
+	char *save_end = RExC_end;
+	char *save_parse = RExC_parse;
+        bool first_time = TRUE;     /* First multi-char occurrence doesn't get
+                                       a "|" */
+        I32 reg_flags;
+
+        assert(! invert);
+#if 0   /* Have decided not to deal with multi-char folds in inverted classes,
+           because too confusing */
+        if (invert) {
+            sv_catpv(substitute_parse, "(?:");
+        }
+#endif
+
+        /* Look at the longest folds first */
+        for (cp_count = av_len(multi_char_matches); cp_count > 0; cp_count--) {
+
+            if (av_exists(multi_char_matches, cp_count)) {
+                AV** this_array_ptr;
+                SV* this_sequence;
+
+                this_array_ptr = (AV**) av_fetch(multi_char_matches, cp_count, FALSE);
+                while ((this_sequence = av_pop(*this_array_ptr)) != &PL_sv_undef) {
+                    if (! first_time) {
+                        sv_catpv(substitute_parse, "|");
+                    }
+                    first_time = FALSE;
+
+                    sv_catpv(substitute_parse, SvPVX(this_sequence));
+                }
+            }
+        }
+
+        /* If the character class contains anything else besides these
+         * multi-character folds, have to include it in recursive parsing */
+        if (element_count) {
+            sv_catpv(substitute_parse, "|[");
+            sv_catpvn(substitute_parse, orig_parse, RExC_parse - orig_parse);
+            sv_catpv(substitute_parse, "]");
+        }
+
+        sv_catpv(substitute_parse, ")");
+#if 0
+        if (invert) {
+            /* This is a way to get the parse to skip forward a whole named
+             * sequence instead of matching the 2nd character when it fails the
+             * first */
+            sv_catpv(substitute_parse, "(*THEN)(*SKIP)(*FAIL)|.)");
+        }
+#endif
+
+	RExC_parse = SvPV(substitute_parse, len);
+	RExC_end = RExC_parse + len;
+        RExC_in_multi_char_class = 1;
+        RExC_emit = (regnode *)orig_emit;
+
+	ret = reg(pRExC_state, 1, &reg_flags, depth+1);
+
+	*flagp |= reg_flags&(HASWIDTH|SPSTART|POSTPONED);
+
+	RExC_parse = save_parse;
+	RExC_end = save_end;
+	RExC_in_multi_char_class = 0;
+        SvREFCNT_dec(multi_char_matches);
+        return ret;
+    }
+
     /* If the character class contains only a single element, it may be
      * optimizable into another node type which is smaller and runs faster.
      * Check if this is the case for this class */
diff --git a/sv.c b/sv.c
index a2cc34217d..e7d434ca87 100644
--- a/sv.c
+++ b/sv.c
@@ -13377,6 +13377,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     PL_VertSpace	= sv_dup_inc(proto_perl->IVertSpace, param);
 
     PL_NonL1NonFinalFold = sv_dup_inc(proto_perl->INonL1NonFinalFold, param);
+    PL_HasMultiCharFold= sv_dup_inc(proto_perl->IHasMultiCharFold, param);
 
     /* utf8 character class swashes */
     PL_utf8_alnum	= sv_dup_inc(proto_perl->Iutf8_alnum, param);
diff --git a/t/re/re_tests b/t/re/re_tests
index bf1dc52bc2..a59a6ab522 100644
--- a/t/re/re_tests
+++ b/t/re/re_tests
@@ -1543,7 +1543,8 @@ a\97	a97	y	$&	a97
 /^\p{L}/	\x{3400}	y	$&	\x{3400}
 
 # RT #89774
-/[s\xDF]a/ui	ssa	ybT	$&	ssa
+/[s\xDF]a/ui	ssa	y	$&	ssa
+/[s\xDF]a/ui	sa	y	$&	sa
 
 # RT #99928
 /^\R\x0A$/	\x0D\x0A	n	-	-