(perl #125351) abort parsing if parse errors happen in a sub lex
authorTony Cook <tony@develop-help.com>
Tue, 30 Jan 2018 05:40:53 +0000 (16:40 +1100)
committerTony Cook <tony@develop-help.com>
Mon, 5 Feb 2018 22:13:31 +0000 (09:13 +1100)
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...)

parser.h
t/base/lex.t
toke.c

index 4187e0a..216e9de 100644 (file)
--- 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 */
index de33e7a..414aa1f 100644 (file)
@@ -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 4e0c3c3..9f37f53 100644 (file)
--- 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