Fix crash on recursive /(?{...})/ call

In something like

    my $pat = /... (?{ foo() if ...; }) .../;
    sub foo { $string =~ $pat; }
    foo();

perl would SEGV or produce the wrong values for $1 et al. This commit
fixes that.

Background:

For a compile-time pattern like $foo =~ /..../, the pattern is compiled
at compile time, and the resulting REGEXP SV is stored as a pointer in
the OP_MATCH op (or on threaded builds, stored in PL_regex_pad[],
indexed by the op_pmoffset field in the match op).

For a runtime pattern like

    $foo =~ /abc$bar/;
or
    $pat = qr/..../;
    $foo =~ $pat;

the pattern is compiled by a regcomp op (or for a qr// object,
duplicated), and the resulting REGEX SV is stored by the regcomp op into
its related match (or subst or split etc) op.

This regex will likely have a refcount of 1: i.e. it is only being kept
alive by the link from the match op. Normally this is fine: the regex
lives for as long as the op (and hence the sub it lives in) exist. In
particular, the regex continues to live on after the match is complete,
so that $1 etc will work.

$1 etc work by perl setting PL_curpm to point to the match op which most
recently did a successful match. This is dynamically scoped: on scope
exit, the old value of PL_curpm is restored.

When $1 is accessed, its get-magic is called, which looks up PL_curpm,
gets the regex pointed to by that match op, and that regex contains the
char ranges and match string associated with the most recent match.

The Problem:

That all works well until the`

    sub foo { $string =~ $pat; }

from the example above is called recursively from the /(?{...}/). When
foo() is first called, $pat is compiled and the resulting REGEXP is
stored in the OP_MATCH with a ref count of 1. OP_MATCH is then executed,
which calls the regex engine with that regex and string. Part of the
match is a (?{...}) which recursively calls foo(). foo() does an
OP_REGCOMP again, which overwrites the current regex in the OP_MATCH
with a new regex, freeing the old regex (the one we are in the middle of
executing). Cue SEGVs etc.

There is a further complication: PL_curpm points to the current
successful *match op* rather than the current *regex*. When the regex
engine was made accessible via an API, it was possible for the engine to
be running with no active OP_MATCH present. But the design of (?{...})
is such that any partial matches are accessible *during* the execution,
not just after the end of a successful match. So for example

    "AB" =~ /^(.) (?{ say "$1$2" } (.)$/x;

will print out "A" and undef. The regex engine handles this by having a
fake global match PMOP structure, PL_reg_curpm, and every time code
within (?{...}) is about to be called, the current regex is pointed to
from PL_reg_curpm, and PL_curpm is set to point to PL_reg_curpm.  Since
this is global, it suffers from the same problem as for the recursive
match op, in that the inner call to (?{...}) will overwrite the regex
pointer in PL_reg_curpm, potentially prematurely freeing the regex, and
even if not freed, meaning that on return to the outer pattern, $1 et al
will refer to the inner match, not the current match.

The Solution:

This commit makes use of an existing save/restore mechanism for patterns
involving (?{...}). At the start of the match, S_setup_eval_state() is
called, which saves some state in reginfo->info_aux_eval. On exit from
the match (either normally or via croak), S_cleanup_regmatch_info_aux()
is called to restore stuff.

This commit saves three new things in info_aux_eval.

1) The current REGEXP SV (ref counted). Formerly it stored ReANY(regex);
   now it stores regex directly. This ensures the regex isn't freed
   during matching (including calls out to code in (?{...}) blocks), but
   it doesn't guarantee that it will live on after the end of the match,
   to be accessible to $1 etc al.

2) It saves (ref counted) the current value of the regex pointer in
   PL_reg_curpm and restores it on return. Thus on return from doing the
   inner match, $1 et al will give the current value for any remaining
   code within the code block, e.g. /(?{ foo(); print $1 })/

3) If PL_op happens to be a pattern match op (it might not if for
   example the engine has been called via the API from XS) then its
   regex is saved and restored similar to (2).

The combination of those three extra saves makes it likely that the
regex will not be prematurely freed, and $1 etc will have the right
values at all times.

Note that this commit doesn't fix the general problem of recursively
calling a match op; only the ones involving calls from within a
(?{...}). For example this still prints "BB" rather than "AB":

    sub foo {
        $_[0] =~ /(.)/;
        foo('B') if $_[0] eq 'A';
        print $1;
    }
    foo('A');

Note that the PM_GETRE() and PM_SETRE() macros, which I wanted to use to
save and restore the regex pointer in PL_reg_curpm, do some funny
business: PM_GETRE() returns NULL if the SV isn't a REGEX (e.g. if its
&PL_sv_undef),and PM_SETRE asserts that the regex isn't null. I got
round those side-effects by adding PM_GETRE_raw()/PM_SETRE_raw(), which
do nothing but get/set the regex from the PMOP.

Author: iabyn

op.h

@@ -298,9 +298,16 @@ struct pmop {
     OP *	op_code_list;	/* list of (?{}) code blocks */
 };
 
+/* The PM_GETRE_raw/PM_SETRE_raw variants get/set the slot without any
+ * processing or asserts */
 #ifdef USE_ITHREADS
+#define PM_GETRE_raw(o)	(REGEXP*)(PL_regex_pad[(o)->op_pmoffset])
 #define PM_GETRE(o)	(SvTYPE(PL_regex_pad[(o)->op_pmoffset]) == SVt_REGEXP \
                          ? (REGEXP*)(PL_regex_pad[(o)->op_pmoffset]) : NULL)
+
+#define PM_SETRE_raw(o,r)	STMT_START {					\
+                            PL_regex_pad[(o)->op_pmoffset] = MUTABLE_SV(r); \
+                        } STMT_END
 /* The assignment is just to enforce type safety (or at least get a warning).
  */
 /* With first class regexps not via a reference one needs to assign
@@ -315,7 +322,9 @@ struct pmop {
                             PL_regex_pad[(o)->op_pmoffset] = MUTABLE_SV(_pm_setre); \
                         } STMT_END
 #else
+#define PM_GETRE_raw(o) ((o)->op_pmregexp)
 #define PM_GETRE(o)     ((o)->op_pmregexp)
+#define PM_SETRE_raw(o,r) ((o)->op_pmregexp = (r))
 #define PM_SETRE(o,r)   ((o)->op_pmregexp = (r))
 #endif
 

regexec.c

@@ -11237,8 +11237,9 @@ S_setup_eval_state(pTHX_ regmatch_info *const reginfo)
     regexp *const rex = ReANY(reginfo->prog);
     regmatch_info_aux_eval *eval_state = reginfo->info_aux_eval;
 
-    eval_state->rex = rex;
-    eval_state->sv  = reginfo->sv;
+    eval_state->rx = reginfo->prog;
+    SvREFCNT_inc(eval_state->rx);
+    eval_state->sv = reginfo->sv;
 
     if (reginfo->sv) {
         /* Make $_ available to executed code. */
@@ -11278,6 +11279,26 @@ S_setup_eval_state(pTHX_ regmatch_info *const reginfo)
         }
 #endif
     }
+
+    /* if we're currently executing a MATCHish op, the only ref to the
+     * current regex might be from that op. If recursive code called from
+     * (?{...}) recompiles that regex, the old regex will be lost -
+     * meaning that $1 etc will stuff refer to the value from the inner
+     * match. So if possible restore the PMOPs regex to the outer value at
+     * the end of the outer match */
+    if (   PL_op
+        && (PL_opargs[PL_op->op_type] & OA_CLASS_MASK) == OA_PMOP
+        && PM_GETRE((PMOP*)PL_op))
+    {
+        eval_state->old_op     = (PMOP*)PL_op;
+        eval_state->old_op_val = PM_GETRE((PMOP*)PL_op);
+        SvREFCNT_inc(eval_state->old_op_val);
+    }
+    else
+        eval_state->old_op = NULL;
+
+    eval_state->old_regcurpm_val = PM_GETRE_raw(PL_reg_curpm);
+    SvREFCNT_inc(eval_state->old_regcurpm_val);
     S_set_reg_curpm(aTHX_ reginfo->prog, reginfo);
     eval_state->curpm = PL_curpm;
     PL_curpm_under = PL_curpm;
@@ -11320,7 +11341,7 @@ S_cleanup_regmatch_info_aux(pTHX_ void *arg)
         /* undo the effects of S_setup_eval_state() */
 
         if (eval_state->subbeg) {
-            regexp * const rex = eval_state->rex;
+            regexp * const rex = ReANY(eval_state->rx);
             RXp_SUBBEG(rex) = eval_state->subbeg;
             RXp_SUBLEN(rex)     = eval_state->sublen;
             RXp_SUBOFFSET(rex)  = eval_state->suboffset;
@@ -11340,6 +11361,17 @@ S_cleanup_regmatch_info_aux(pTHX_ void *arg)
 
         PL_curpm = eval_state->curpm;
         SvREFCNT_dec(eval_state->sv);
+        SvREFCNT_dec(eval_state->rx);
+
+        REGEXP *old_rx = PM_GETRE(PL_reg_curpm);
+        PM_SETRE_raw(PL_reg_curpm, eval_state->old_regcurpm_val);
+        SvREFCNT_dec(old_rx);
+
+        if (eval_state->old_op) {
+            old_rx = PM_GETRE(eval_state->old_op);
+            PM_SETRE(eval_state->old_op, eval_state->old_op_val);
+            SvREFCNT_dec(old_rx);
+        }
     }
 
     PL_regmatch_state = aux->old_regmatch_state;

regexp.h

@@ -776,7 +776,10 @@ struct regmatch_slab;
  * regmatch_state stack at the start of execution */
 
 typedef struct {
-    regexp *rex;
+    REGEXP *rx;
+    PMOP   *old_op;           /* saved value of PL_op and ... */
+    REGEXP *old_op_val;       /* ... saved value of PM_GETRE(PL_op) if any */
+    REGEXP *old_regcurpm_val; /* saved value of PM_GETRE(PL_reg_curpm) */
     PMOP    *curpm;     /* saved PL_curpm */
 #ifdef PERL_ANY_COW
     SV      *saved_copy; /* saved saved_copy field from rex */

t/re/pat_re_eval.t

@@ -25,7 +25,7 @@ BEGIN {
 our @global;
 
 
-plan tests => 527;  # Update this when adding/deleting tests.
+plan tests => 528;  # Update this when adding/deleting tests.
 
 run_tests() unless caller;
 
@@ -1409,6 +1409,43 @@ sub run_tests {
 
     ok("" =~ m{^ (?{eval q{$x=}})}x, "GH #19390");
 
+    # GH #22869 "Perl crash with recursive sub and regex with code eval".
+    #
+    # A recursive call to a match op with a run-time pattern and which
+    # contained a code block, led to to the temporary rex stored in the
+    # OP_MATCH and PL_reg_curpm ops getting prematurely freed when updated
+    # within the inner match's OP_MATCH op.
+
+    {
+        my @got;
+
+        my $f = sub {
+            my ($s, $re) = @_;
+            $s =~ $re;
+            push @got, ',', $1, $2, ']';
+        };
+
+        my $pat;
+        $pat = qr{^
+                    (.)
+                    (?{
+                        push @got, '[', $1, $2;
+                        $f->('XY', $pat) if $1 eq 'A';
+                        push @got, ',', $1, $2;
+                    })
+                    (.)
+                    (?{
+                        push @got, ',', $1, $2;
+                    })
+                    $
+                }x;
+
+        $f->('AB',$pat);
+
+        my $got = join '', map defined ? $_ : '-', @got;
+        is($got, "[A-[X-,X-,XY,XY],A-,AB,AB]", "GH22869");
+    }
+
 } # End of sub run_tests
 
 1;