CVE-2023-47100: Improper Handling of Exceptional Conditions (CWE-755)
value: In Perl before 5.38.2, S_parse_uniprop_string in regcomp.c can write to unallocated space because a property name associated with a \p{...} regular expression construct is mishandled. The earliest affected version is 5.30.0.
CWE description: The product does not handle or incorrectly handles an exceptional condition.
CVSS v3 base score: 9.8
Published: 2023-12-02T23:15Z
Repository: https://github.com/Perl/perl5
Language: Other
Files changed: regcomp.c, t/re/pat_advanced.t
Commit date: 2023-11-26 13:33:44 +0000
Commit message: Fix read/write past buffer end: perl-security#140

A package name may be specified in a \p{...} regular expression
construct.  If unspecified, "utf8::" is assumed, which is the package
all official Unicode properties are in.  By specifying a different
package, one can create a user-defined property with the same
unqualified name as a Unicode one.  Such a property is defined by a sub
whose name begins with "Is" or "In", and if the sub wishes to refer to
an official Unicode property, it must explicitly specify the "utf8::".
S_parse_uniprop_string() is used to parse the interior of both \p{} and
the user-defined sub lines.

In S_parse_uniprop_string(), it parses the input "name" parameter,
creating a modified copy, "lookup_name", malloc'ed with the same size as
"name".  The modifications are essentially to create a canonicalized
version of the input, with such things as extraneous white-space
stripped off.  I found it convenient to strip off the package specifier
"utf8::".  To to so, the code simply pretends "lookup_name" begins just
after the "utf8::", and adjusts various other values to compensate.
However, it missed the adjustment of one required one.

This is only a problem when the property name begins with "perl" and
isn't "perlspace" nor "perlword".  All such ones are undocumented
internal properties.

What happens in this case is that the input is reparsed with slightly
different rules in effect as to what is legal versus illegal.  The
problem is that "lookup_name" no longer is pointing to its initial
value, but "name" is.  Thus the space allocated for filling "lookup_name"
is now shorter than "name", and as this shortened "lookup_name" is
filled by copying suitable portions of "name", the write can be to
unallocated space.

The solution is to skip the "utf8::" when reparsing "name".  Then both
"lookup_name" and "name" are effectively shortened by the same amount,
and there is no going off the end.

This commit also does white-space adjustment so that things align
vertically for readability.

This can be easily backported to earlier Perl releases.

Diff: diff --git a/regcomp.c b/regcomp.c
index 6e35d95d2ac..34c0516d6cd 100644
--- a/regcomp.c
+++ b/regcomp.c
@@ -14459,11 +14459,11 @@ S_parse_uniprop_string(pTHX_
     /* nv= or numeric_value=, or possibly one of the cjk numeric properties
      * (though it requires extra effort to download them from Unicode and
      * compile perl to know about them) */
     bool is_nv_type = FALSE;
 
-    unsigned int i, j = 0;
+    unsigned int i = 0, i_zero = 0, j = 0;
     int equals_pos = -1;    /* Where the '=' is found, or negative if none */
     int slash_pos  = -1;    /* Where the '/' is found, or negative if none */
     int table_index = 0;    /* The entry number for this property in the table
                                of all Unicode property names */
     bool starts_with_Is = FALSE;  /* ? Does the name start with 'Is' */
@@ -14591,13 +14591,17 @@ S_parse_uniprop_string(pTHX_
     /* If there is a single package name 'utf8::', it is ambiguous.  It could
      * be for a user-defined property, or it could be a Unicode property, as
      * all of them are considered to be for that package.  For the purposes of
      * parsing the rest of the property, strip it off */
     if (non_pkg_begin == STRLENs("utf8::") && memBEGINPs(name, name_len, "utf8::")) {
-        lookup_name +=  STRLENs("utf8::");
-        j -=  STRLENs("utf8::");
-        equals_pos -=  STRLENs("utf8::");
+        lookup_name += STRLENs("utf8::");
+        j           -= STRLENs("utf8::");
+        equals_pos  -= STRLENs("utf8::");
+        i_zero       = STRLENs("utf8::");   /* When resetting 'i' to reparse
+                                               from the beginning, it has to be
+                                               set past what we're stripping
+                                               off */
         stripped_utf8_pkg = TRUE;
     }
 
     /* Here, we are either done with the whole property name, if it was simple;
      * or are positioned just after the '=' if it is compound. */
@@ -15007,11 +15011,12 @@ S_parse_uniprop_string(pTHX_
         {
             stricter = Strict;
 
             /* We set the inputs back to 0 and the code below will reparse,
              * using strict */
-            i = j = 0;
+            i = i_zero;
+            j = 0;
         }
     }
 
     /* Here, we have either finished the property, or are positioned to parse
      * the remainder, and we know if stricter rules apply.  Finish out, if not
@@ -15028,11 +15033,11 @@ S_parse_uniprop_string(pTHX_
 
         /* An underscore is skipped, but not under strict rules unless it
          * separates two digits */
         if (cur == '_') {
             if (    stricter
-                && (     i == 0 || (int) i == equals_pos || i == name_len- 1
+                && (   i == i_zero || (int) i == equals_pos || i == name_len- 1
                     || ! isDIGIT_A(name[i-1]) || ! isDIGIT_A(name[i+1])))
             {
                 lookup_name[j++] = '_';
             }
             continue;
diff --git a/t/re/pat_advanced.t b/t/re/pat_advanced.t
index c237c5879d1..4d62f62c901 100644
--- a/t/re/pat_advanced.t
+++ b/t/re/pat_advanced.t
@@ -2697,10 +2697,18 @@ Freeing REx: "(?<b>\g{c})(?<c>x)(?&b)"
 EOF_DEBUG_OUT
                       {rtrim_result=>1},
                       "Related to Github Issue #19350, forward \\g{x} pattern segv under use re Debug => 'PARSE'");
     }
 
+    {   # perl-security#140, read/write past buffer end
+        fresh_perl_like('qr/\p{utf8::perl x}/',
+                        qr/Illegal user-defined property name "utf8::perl x" in regex/,
+                        {}, "perl-security#140");
+        fresh_perl_is('qr/\p{utf8::_perl_surrogate}/', "",
+                        {}, "perl-security#140");
+    }
+
     {   # GH 20009
         my $x = "awesome quotes";
         utf8::upgrade($x);
         $x =~ s/^[\x{0301}\x{030C}]+//;
     }

Vulnerable code:     unsigned int i, j = 0;
        lookup_name +=  STRLENs("utf8::");
        j -=  STRLENs("utf8::");
        equals_pos -=  STRLENs("utf8::");
            i = j = 0;
                && (     i == 0 || (int) i == equals_pos || i == name_len- 1
Fixed code:     unsigned int i = 0, i_zero = 0, j = 0;
        lookup_name += STRLENs("utf8::");
        j           -= STRLENs("utf8::");
        equals_pos  -= STRLENs("utf8::");
        i_zero       = STRLENs("utf8::");   /* When resetting 'i' to reparse
                                               from the beginning, it has to be
                                               set past what we're stripping
                                               off */
            i = i_zero;
            j = 0;
                && (   i == i_zero || (int) i == equals_pos || i == name_len- 1
    {   # perl-security#140, read/write past buffer end
        fresh_perl_like('qr/\p{utf8::perl x}/',
                        qr/Illegal user-defined property name "utf8::perl x" in regex/,
                        {}, "perl-security#140");
        fresh_perl_is('qr/\p{utf8::_perl_surrogate}/', "",
                        {}, "perl-security#140");
    }