PATCH: [perl #133860] 5.30 regression

These bugs stem from trying to compile a user-defined \p{IsProperty}
before the data for the property is available.  In the past, a bug used
the wrong package for IsProperty, and it wasn't found, so its expansion
was delayed until runtime.  But that bug got fixed, and now it finds the
property and thinks its deliberately empty, at compile time.

This is a change in behavior, even if it is fixing a bug, where the real
problem is unobvious.  The solution adopted in this commit is to defer
all empty properties at pattern compilation time.  If they are still
empty at runtime, that's what the expansion will be.

2 files changed, 49 insertions, 7 deletions

diff --git a/regcomp.c b/regcomp.c
index fbd5c1809a..9bd6dd3739 100644
--- a/regcomp.c
+++ b/regcomp.c
@@ -23054,6 +23054,14 @@ Perl_parse_uniprop_string(pTHX_
     if (could_be_user_defined) {
         CV* user_sub;
 
+        /* If the user defined property returns the empty string, it could
+         * easily be because the pattern is being compiled before the data it
+         * actually needs to compile is available.  This could be argued to be
+         * a bug in the perl code, but this is a change of behavior for Perl,
+         * so we handle it.  This means that intentionally returning nothing
+         * will not be resolved until runtime */
+        bool empty_return = FALSE;
+
         /* Here, the name could be for a user defined property, which are
          * implemented as subs. */
         user_sub = get_cvn_flags(name, name_len, 0);
@@ -23285,16 +23293,28 @@ Perl_parse_uniprop_string(pTHX_
                 prop_definition = NULL;
             }
             else {  /* G_SCALAR guarantees a single return value */
+                SV * contents = POPs;
 
                 /* The contents is supposed to be the expansion of the property
-                 * definition.  Call a function to check for valid syntax and
-                 * handle it */
-                prop_definition = handle_user_defined_property(name, name_len,
+                 * definition.  If the definition is deferrable, and we got an
+                 * empty string back, set a flag to later defer it (after clean
+                 * up below). */
+                if (      deferrable
+                    && (! SvPOK(contents) || SvCUR(contents) == 0))
+                {
+                        empty_return = TRUE;
+                }
+                else { /* Otherwise, call a function to check for valid syntax,
+                          and handle it */
+
+                    prop_definition = handle_user_defined_property(
+                                                    name, name_len,
                                                     is_utf8, to_fold, runtime,
                                                     deferrable,
-                                                    POPs, user_defined_ptr,
+                                                    contents, user_defined_ptr,
                                                     msg,
                                                     level);
+                }
             }
 
             /* Here, we have the results of the expansion.  Delete the
@@ -23306,8 +23326,9 @@ Perl_parse_uniprop_string(pTHX_
 
             S_delete_recursion_entry(aTHX_ SvPVX(key));
 
-            if (! prop_definition || is_invlist(prop_definition)) {
-
+            if (    ! empty_return
+                && (! prop_definition || is_invlist(prop_definition)))
+            {
                 /* If we got success we use the inversion list defining the
                  * property; otherwise use the error message */
                 SWITCH_TO_GLOBAL_CONTEXT;
@@ -23328,6 +23349,10 @@ Perl_parse_uniprop_string(pTHX_
             LEAVE;
             POPSTACK;
 
+            if (empty_return) {
+                goto definition_deferred;
+            }
+
             if (prop_definition) {
 
                 /* If the definition is for something not known at this time,
diff --git a/t/uni/class.t b/t/uni/class.t
index 37392aabed..572a538004 100644
--- a/t/uni/class.t
+++ b/t/uni/class.t
@@ -5,7 +5,7 @@ BEGIN {
     skip_all_without_unicode_tables();
 }
 
-plan tests => 11;
+plan tests => 12;
 
 my $str = join "", map { chr utf8::unicode_to_native($_) } 0x20 .. 0x6F;
 
@@ -88,5 +88,22 @@ $str = "[\x{038B}\x{038C}\x{038D}]";
 
 is(($str =~ /(\p{InGreek}+)/)[0], "\x{038B}\x{038C}\x{038D}");
 
+{   # [perl #133860], compilation before data for it is available
+    package Foo;
+
+    sub make {
+        my @lines;
+        while( my($c) = splice(@_,0,1) ) {
+            push @lines, sprintf("%04X", $c);
+        }
+        return join "\n", @lines;
+    }
+
+    my @characters = ( ord("a") );
+    sub IsProperty { make(@characters); };
+
+    main::like('a', qr/\p{IsProperty}/, "foo");
+}
+
 # The other tests that are based on looking at the generated files are now
 # in t/re/uniprops.t