smartmatch: handle stack realloc

When smartmatch is matching a pattern against something, it was
failing to do appropriate PUTBACK and SPAGAIN's  before calling
matcher_matches_sv() (which pushes an arg an calls pp_match()).
If the stack was almost full, the extra push in matcher_matches_sv()
could cause a stack realloc, which would then be ignored when
pp_smartmatch() returned, setting PL_stack_sp to point to the old (freed)
stack.

Adding SPAGAIN ensures that PL_stack_sp points to the new stack, while
PUTBACK causes PL_stack_sp to no longer see the two args to pp_smartmatch,
so the PUSH in matcher_matches_sv() pushes the SV us9ng ones of two two
reclaimed slots, so the stack won't re-alloc anyway.

Thus by doing the "right thing" with both PUTBACK and SPAGAIN, we
doubly ensure that PL_stack_sp will always be right.

2 files changed, 44 insertions, 5 deletions

diff --git a/pp_ctl.c b/pp_ctl.c
index 23094e805d..ac0f1bcd3d 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -4581,7 +4581,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied)
     }
 
     SP -= 2;	/* Pop the values */
-
+    PUTBACK;
 
     /* ~~ undef */
     if (!SvOK(e)) {
@@ -4778,11 +4778,14 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied)
 		(void) hv_iterinit(hv);
 		while ( (he = hv_iternext(hv)) ) {
 		    DEBUG_M(Perl_deb(aTHX_ "        testing key against pattern...\n"));
+                    PUTBACK;
 		    if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
+                        SPAGAIN;
 			(void) hv_iterinit(hv);
 			destroy_matcher(matcher);
 			RETPUSHYES;
 		    }
+                    SPAGAIN;
 		}
 		destroy_matcher(matcher);
 		RETPUSHNO;
@@ -4887,10 +4890,13 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied)
 		for(i = 0; i <= this_len; ++i) {
 		    SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
 		    DEBUG_M(Perl_deb(aTHX_ "        testing element against pattern...\n"));
+                    PUTBACK;
 		    if (svp && matcher_matches_sv(matcher, *svp)) {
+                        SPAGAIN;
 			destroy_matcher(matcher);
 			RETPUSHYES;
 		    }
+                    SPAGAIN;
 		}
 		destroy_matcher(matcher);
 		RETPUSHNO;
@@ -4951,12 +4957,13 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied)
 	}
 	else {
 	    PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
+            bool result;
 
 	    DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Regex\n"));
 	    PUTBACK;
-	    PUSHs(matcher_matches_sv(matcher, d)
-		    ? &PL_sv_yes
-		    : &PL_sv_no);
+	    result = matcher_matches_sv(matcher, d);
+            SPAGAIN;
+	    PUSHs(result ? &PL_sv_yes : &PL_sv_no);
 	    destroy_matcher(matcher);
 	    RETURN;
 	}
diff --git a/t/op/smartmatch.t b/t/op/smartmatch.t
index 9db20693b6..ca019fdbbb 100644
--- a/t/op/smartmatch.t
+++ b/t/op/smartmatch.t
@@ -76,7 +76,7 @@ my %keyandmore = map { $_ => 0 } @keyandmore;
 my %fooormore = map { $_ => 0 } @fooormore;
 
 # Load and run the tests
-plan tests => 349+1;
+plan tests => 349+2;
 
 while (<DATA>) {
   SKIP: {
@@ -150,6 +150,38 @@ sub NOT_DEF() { undef }
 		 "don't fill the stack with rubbish");
 }
 
+{
+    # [perl #123860] continued;
+    # smartmatch was failing to SPAGAIN after pushing an SV and calling
+    # pp_match, which may have resulted in the stack being realloced
+    # in the meantime. Test this by filling the stack with pregressively
+    # larger amounts of data. At some point the stack will get realloced.
+    my @a = qw(x);
+    my %h = qw(x 1);
+    my @args;
+    my $x = 1;
+    my $bad = -1;
+    for (1..1000)  {
+        push @args, $_;
+        my $exp_n  = join '-',  (@args, $x == 0);
+        my $exp_y  = join '-',  (@args, $x == 1);
+
+        my $got_an = join '-',  (@args, (/X/ ~~ @a));
+        my $got_ay = join '-',  (@args, (/x/ ~~ @a));
+        my $got_hn = join '-',  (@args, (/X/ ~~ %h));
+        my $got_hy = join '-',  (@args, (/x/ ~~ %h));
+
+        if (   $exp_n ne $got_an || $exp_n ne $got_hn
+            || $exp_y ne $got_ay || $exp_y ne $got_hy
+        ) {
+            $bad = $_;
+            last;
+        }
+    }
+    is($bad, -1, "RT 123860: stack realloc");
+}
+
+
 # Prefix character :
 #   - expected to match
 # ! - expected to not match