fix runtime /(?{})/ with overload::constant qr

There are two issues fixed here.

First, when a pattern has a run-time code-block included, such as

    $code = '(?{...})'
    /foo$code/

the mechanism used to parse those run-time blocks: of feeding the
resultant pattern into a call to eval_sv() with the string

    qr'foo(?{...})'

and then extracting out any resulting opcode trees from the returned
qr object -- suffered from the re-parsed qr'..' also being subject to
overload:constant qr processing, which could result in Bad Things
happening.

Since we now have the PL_parser->lex_re_reparsing flag in scope throughout
the parsing of the pattern, this is easy to detect and avoid.

The second issue is a mechanism to avoid recursion when getting false
positives in S_has_runtime_code() for code like '[(?{})]'.
For patterns like this, we would suspect that the pattern may have code
(even though it doesn't), so feed it into qr'...' and reparse, and
again it looks like runtime code, so feed it in, rinse and repeat.
The thing to stop recursion was when we saw a qr with a single OP_CONST
string, we assumed it couldn't have any run-time component, and thus no
run-time code blocks.

However, this broke qr/foo/ in the presence of overload::constant qr
overloading, which could convert foo into a string containing code blocks.

The fix for this is to change the recursion-avoidance mechanism (in a way
which also turns out to be simpler too). Basically, when we fake up a
qr'...' and eval it, we turn off any 'use re eval' in scope: its not
needed, since we know the .... will be a constant string without any
overloading. Then we use the lack of 'use re eval' in scope to
skip calling S_has_runtime_code() and just assume that the code has no
run-time patterns (if it has, then eventually the regex parser will
rightly complain about 'Eval-group not allowed at runtime').

This commit also adds some fairly comprehensive tests for this.

1 files changed, 13 insertions, 24 deletions

diff --git a/regcomp.c b/regcomp.c
index 0853815a58..ee843e3d12 100644
--- a/regcomp.c
+++ b/regcomp.c
@@ -4877,19 +4877,12 @@ Perl_re_compile(pTHX_ SV * const pattern, U32 rx_flags)
  * False positives are allowed */
 
 static bool
-S_has_runtime_code(pTHX_ RExC_state_t * const pRExC_state, OP *expr,
-		    U32 pm_flags, char *pat, STRLEN plen)
+S_has_runtime_code(pTHX_ RExC_state_t * const pRExC_state,
+		    char *pat, STRLEN plen)
 {
     int n = 0;
     STRLEN s;
 
-    /* avoid infinitely recursing when we recompile the pattern parcelled up
-     * as qr'...'. A single constant qr// string can't have have any
-     * run-time component in it, and thus, no runtime code. (A non-qr
-     * string, however, can, e.g. $x =~ '(?{})') */
-    if  ((pm_flags & PMf_IS_QR) && expr && expr->op_type == OP_CONST)
-	return 0;
-
     for (s = 0; s < plen; s++) {
 	if (n < pRExC_state->num_code_blocks
 	    && s == pRExC_state->code_blocks[n].start)
@@ -5626,6 +5619,13 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count,
         }
     }
 
+    if ((pm_flags & PMf_USE_RE_EVAL)
+		/* this second condition covers the non-regex literal case,
+		 * i.e.  $foo =~ '(?{})'. */
+		|| (IN_PERL_COMPILETIME && (PL_hints & HINT_RE_EVAL))
+    )
+	runtime_code = S_has_runtime_code(aTHX_ pRExC_state, exp, plen);
+
     /* return old regex if pattern hasn't changed */
     /* XXX: note in the below we have to check the flags as well as the pattern.
      *
@@ -5639,23 +5639,12 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count,
         && ( RX_COMPFLAGS(old_re) == ( orig_rx_flags & RXf_PMf_FLAGCOPYMASK ) )
 	&& RX_PRECOMP(old_re)
 	&& RX_PRELEN(old_re) == plen
-        && memEQ(RX_PRECOMP(old_re), exp, plen))
+        && memEQ(RX_PRECOMP(old_re), exp, plen)
+	&& !runtime_code /* with runtime code, always recompile */ )
     {
-	/* with runtime code, always recompile */
-	runtime_code = S_has_runtime_code(aTHX_ pRExC_state, expr, pm_flags,
-					    exp, plen);
-	if (!runtime_code) {
-	    Safefree(pRExC_state->code_blocks);
-	    return old_re;
-	}
+        Safefree(pRExC_state->code_blocks);
+        return old_re;
     }
-    else if ((pm_flags & PMf_USE_RE_EVAL)
-		/* this second condition covers the non-regex literal case,
-		 * i.e.  $foo =~ '(?{})'. */
-		|| (IN_PERL_COMPILETIME && (PL_hints & HINT_RE_EVAL))
-    )
-	runtime_code = S_has_runtime_code(aTHX_ pRExC_state, expr, pm_flags,
-			    exp, plen);
 
     rx_flags = orig_rx_flags;