regexec.c - fix memory leak in EVAL.

EVAL was calling regcppush twice per invocation, once before executing the
callback, and once after. But not regcppop'ing twice. So each time we
would accumulate an extra "frame" of data. This is/was hidden somewhat by
the way we eventually "blow" the stack, so the extra data was just thrown
away at the end.

This removes the second set of pushes so that the save stack stays a stable
size as it unwinds from each failed eval.

We also weren't cleaning up after a (?{...}) when we failed to match to its
right. This unwinds the stack and restores the parens properly.

This adds tests to check how the save stack grows during patterns using
(?{ ... }) and (??{ ... }) and ensure that when we backtrack and re-execute
the EVAL again it cleans up the stack as it goes.

4 files changed, 52 insertions, 2 deletions

diff --git a/MANIFEST b/MANIFEST
index 40174a28b4..a153ce7a06 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -4677,6 +4677,7 @@ ext/XS-APItest/t/refs.t		Test typemap ref handling
 ext/XS-APItest/t/rmagical.t	XS::APItest extension
 ext/XS-APItest/t/rv2cv_op_cv.t	test rv2cv_op_cv() API
 ext/XS-APItest/t/savehints.t	test SAVEHINTS() API
+ext/XS-APItest/t/savestack.t	test savestack behavior, currently only in the regex engine
 ext/XS-APItest/t/scopelessblock.t	test recursive descent statement-sequence parsing
 ext/XS-APItest/t/sort.t		Test sort(xs_cmp ...)
 ext/XS-APItest/t/stmtasexpr.t	test recursive descent statement parsing
diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs
index ff7667b24a..a7f1d5f011 100644
--- a/ext/XS-APItest/APItest.xs
+++ b/ext/XS-APItest/APItest.xs
@@ -7931,3 +7931,12 @@ newSvNV(const char * string)
         RETVAL = SvNV(newSVpv(string, 0));
     OUTPUT:
         RETVAL
+
+MODULE = XS::APItest            PACKAGE = XS::APItest::savestack
+
+IV
+get_savestack_ix()
+    CODE:
+        RETVAL = PL_savestack_ix;
+    OUTPUT:
+        RETVAL
diff --git a/ext/XS-APItest/t/savestack.t b/ext/XS-APItest/t/savestack.t
new file mode 100644
index 0000000000..0e7d628e37
--- /dev/null
+++ b/ext/XS-APItest/t/savestack.t
@@ -0,0 +1,37 @@
+#!perl -w
+
+use strict;
+use warnings;
+use Test::More;
+
+use XS::APItest;
+
+my %ix;
+sub showix {
+    diag join ", ", map { $ix{$_} > 1 ? "$_ x $ix{$_}" : $_ } sort { $a <=> $b } keys %ix;
+}
+my $len = 100;
+my $str= "a" x $len;
+my $pat= join "|", map { "a" x $_ } 1 .. $len;
+
+$str=~/^($pat)(??{ $ix{get_savestack_ix()}++; "(?!)" })/;
+my $keys= 0+keys %ix;
+cmp_ok($keys,">",0, "We expect at least one key in %ix for (??{ ... }) test");
+cmp_ok($keys,"<=", 2, "We expect no more than two keys in %ix if (??{ ... }) does not leak")
+    or showix();
+
+%ix= ();
+$str=~/^($pat)(?{ $ix{my $x=get_savestack_ix()}++; })(?!)/;
+$keys= 0+keys %ix;
+cmp_ok($keys,">",0, "We expect at least one key in %ix for (?{ ...  }) test");
+cmp_ok($keys, "<=", 2, "We expect no more than two keys in %ix if (?{ ... }) does not leak")
+    or showix();
+
+%ix= ();
+$str=~/^($pat)(?(?{ $ix{my $x=get_savestack_ix()}++; })x|y)(?!)/;
+$keys= 0+keys %ix;
+cmp_ok($keys,">",0, "We expect at least one key in %ix for (?(?{ ... })yes|no) test");
+cmp_ok($keys, "<=", 2, "We expect no more than two keys in %ix if (?(?{ ... })yes|no) does not leak")
+    or showix();
+
+done_testing();
diff --git a/regexec.c b/regexec.c
index 3e5e5892b7..d2c020feb2 100644
--- a/regexec.c
+++ b/regexec.c
@@ -8072,7 +8072,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog)
                 CV *newcv;
 
                 /* save *all* paren positions */
-                regcppush(rex, 0, maxopenparen);
+                ST.cp = regcppush(rex, 0, maxopenparen);
                 REGCP_SET(ST.lastcp);
 
                 if (!caller_cv)
@@ -8349,9 +8349,11 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog)
                 EVAL_CLOSE_PAREN_CLEAR(st); /* ST.close_paren = 0;
                                              * close_paren only for GOSUB */
                 ST.prev_recurse_locinput= NULL; /* only used for GOSUB */
-                /* Save all the seen positions so far. */
+
+                /* note we saved the paren state earlier:
                 ST.cp = regcppush(rex, 0, maxopenparen);
                 REGCP_SET(ST.lastcp);
+                */
                 /* and set maxopenparen to 0, since we are starting a "fresh" match */
                 maxopenparen = 0;
                 /* run the pattern returned from (??{...}) */
@@ -8441,6 +8443,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog)
 
         case EVAL_B_fail: /* unsuccessful B in (?{...})B */
             REGCP_UNWIND(ST.lastcp);
+            regcppop(rex, &maxopenparen);
             sayNO;
 
         case EVAL_postponed_AB_fail: /* unsuccessfully ran A or B in (??{A})B */