(perl #125351) abort parsing if parse errors happen in a sub lex

We've had a few reports of segmentation faults and other misbehaviour
when sub-parsing, such as within interpolated expressions, fails.

This change aborts compilation if anything complex enough to not be
parsed by the lexer is compiled in a sub-parse *and* an error
occurs within the sub-parse.

An earlier version of this patch failed on simpler expressions,
which caused many test failures, which this version doesn't (which may
just mean we need more tests...)

3 files changed, 30 insertions, 1 deletions

diff --git a/parser.h b/parser.h
index 4187e0a93d..216e9deca8 100644
--- a/parser.h
+++ b/parser.h
@@ -58,6 +58,7 @@ typedef struct yy_parser {
 				   1 = @{...}  2 = ->@ */
     U8		expect;		/* how to interpret ambiguous tokens */
     bool	preambled;
+    bool        sub_no_recover; /* can't recover from a sublex error */
     I32		lex_formbrack;	/* bracket count at outer format level */
     OP		*lex_inpat;	/* in pattern $) and $| are special */
     OP		*lex_op;	/* extra info to pass back on op */
@@ -95,6 +96,7 @@ typedef struct yy_parser {
     U16		in_my;		/* we're compiling a "my"/"our" declaration */
     U8		lex_state;	/* next token is determined */
     U8		error_count;	/* how many compile errors so far, max 10 */
+    U8		sub_error_count; /* the number of errors before sublexing */
     HV		*in_my_stash;	/* declared class of this "my" declaration */
     PerlIO	*rsfp;		/* current source file pointer */
     AV		*rsfp_filters;	/* holds chain of active source filters */
diff --git a/t/base/lex.t b/t/base/lex.t
index de33e7a688..414aa1fceb 100644
--- a/t/base/lex.t
+++ b/t/base/lex.t
@@ -1,6 +1,6 @@
 #!./perl
 
-print "1..117\n";
+print "1..120\n";
 
 $x = 'x';
 
@@ -557,6 +557,15 @@ eval q|s##[}#e|;
  eval ('/@0{0*->@*/*]');
  print "ok $test - 128171\n"; $test++;
 }
+{
+  # various sub-parse recovery issues that crashed perl
+  eval 's//${sub{b{]]]{}#$/ sub{}';
+  print "ok $test - 132640\n"; $test++;
+  eval 'qq{@{sub{]]}}}};shift';
+  print "ok $test - 125351\n"; $test++;
+  eval 'qq{@{sub{]]}}}}-shift';
+  print "ok $test - 126192\n"; $test++;
+}
 
 $foo = "WRONG"; $foo:: = "bar"; $bar = "baz";
 print "not " unless "$foo::$bar" eq "barbaz";
diff --git a/toke.c b/toke.c
index 4e0c3c3189..9f37f53ba4 100644
--- a/toke.c
+++ b/toke.c
@@ -2390,6 +2390,8 @@ S_sublex_start(pTHX)
     PL_parser->lex_super_state = PL_lex_state;
     PL_parser->lex_sub_inwhat = (U16)op_type;
     PL_parser->lex_sub_op = PL_lex_op;
+    PL_parser->sub_no_recover = FALSE;
+    PL_parser->sub_error_count = PL_error_count;
     PL_lex_state = LEX_INTERPPUSH;
 
     PL_expect = XTERM;
@@ -2569,6 +2571,20 @@ S_sublex_done(pTHX)
     else {
 	const line_t l = CopLINE(PL_curcop);
 	LEAVE;
+        if (PL_parser->sub_error_count != PL_error_count) {
+            const char * const name = OutCopFILE(PL_curcop);
+            if (PL_parser->sub_no_recover) {
+                const char * msg = "";
+                if (PL_in_eval) {
+                    SV *errsv = ERRSV;
+                    if (SvCUR(ERRSV)) {
+                        msg = Perl_form(aTHX_ "%" SVf, SVfARG(errsv));
+                    }
+                }
+                abort_execution(msg, name);
+                NOT_REACHED;
+            }
+        }
 	if (PL_multi_close == '<')
 	    PL_parser->herelines += l - PL_multi_end;
 	PL_bufend = SvPVX(PL_linestr);
@@ -4157,6 +4173,7 @@ S_intuit_more(pTHX_ char *s, char *e)
 	return TRUE;
     if (*s != '{' && *s != '[')
 	return FALSE;
+    PL_parser->sub_no_recover = TRUE;
     if (!PL_lex_inpat)
 	return TRUE;
 
@@ -9580,6 +9597,7 @@ S_scan_ident(pTHX_ char *s, char *dest, STRLEN destlen, I32 ck_uni)
             CopLINE_set(PL_curcop, orig_copline);
             PL_parser->herelines = herelines;
 	    *dest = '\0';
+            PL_parser->sub_no_recover = TRUE;
 	}
     }
     else if (   PL_lex_state == LEX_INTERPNORMAL