Stop parsing on first syntax error.

embed.fnc

@@ -2727,7 +2727,7 @@ p	|void	|write_to_stderr|NN SV* msv
 : Used in op.c
 p	|int	|yyerror	|NN const char *const s
 p	|void	|yyquit
-pr	|void	|abort_execution|NN const char * const msg|NN const char * const name
+pr	|void	|abort_execution|NULLOK SV *msg_sv|NN const char * const name
 p	|int	|yyerror_pv	|NN const char *const s|U32 flags
 p	|int	|yyerror_pvn	|NULLOK const char *const s|STRLEN len|U32 flags
 : Used in perly.y, and by Data::Alias

op.c

@@ -10231,6 +10231,7 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
     bool has_name;
     bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
     bool evanescent = FALSE;
+    bool isBEGIN = FALSE;
     OP *start = NULL;
 #ifdef PERL_DEBUG_READONLY_OPS
     OPSLAB *slab = NULL;
@@ -10283,6 +10284,36 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
         }
     }
 
+    if (o)
+        SAVEFREEOP(o);
+    if (proto)
+        SAVEFREEOP(proto);
+    if (attrs)
+        SAVEFREEOP(attrs);
+
+    /* we need this in two places later on, so set it up here */
+    if (name && block) {
+        const char *s = (char *) my_memrchr(name, ':', namlen);
+        s = s ? s+1 : name;
+        isBEGIN = strEQ(s,"BEGIN");
+    }
+
+    if (isBEGIN) {
+        /* Make sure that we do not have any prototypes or
+         * attributes associated with this BEGIN block, as the block
+         * is already done and dusted, and we will assert or worse
+         * if we try to attach the prototype to the now essentially
+         * nonexistent sub. */
+        if (proto)
+            /* diag_listed_as: %s on BEGIN block ignored */
+            Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Prototype on BEGIN block ignored");
+        if (attrs)
+            /* diag_listed_as: %s on BEGIN block ignored */
+            Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Attribute on BEGIN block ignored");
+        proto = NULL;
+        attrs = NULL;
+    }
+
     if (proto) {
         assert(proto->op_type == OP_CONST);
         ps = SvPV_const(cSVOPx(proto)->op_sv, ps_len);
@@ -10291,13 +10322,6 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
     else
         ps = NULL;
 
-    if (o)
-        SAVEFREEOP(o);
-    if (proto)
-        SAVEFREEOP(proto);
-    if (attrs)
-        SAVEFREEOP(attrs);
-
     if (ec) {
         op_free(block);
 
@@ -10307,18 +10331,14 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
             cv = PL_compcv;
 
         PL_compcv = 0;
-        if (name && block) {
-            const char *s = (char *) my_memrchr(name, ':', namlen);
-            s = s ? s+1 : name;
-            if (strEQ(s, "BEGIN")) {
-                if (PL_in_eval & EVAL_KEEPERR)
-                    Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
-                else {
-                    SV * const errsv = ERRSV;
-                    /* force display of errors found but not reported */
-                    sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
-                    Perl_croak_nocontext("%" SVf, SVfARG(errsv));
-                }
+        if (isBEGIN) {
+            if (PL_in_eval & EVAL_KEEPERR)
+                Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
+            else {
+                SV * const errsv = ERRSV;
+                /* force display of errors found but not reported */
+                sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
+                Perl_croak_nocontext("%" SVf, SVfARG(errsv));
             }
         }
         goto done;

perl.c

@@ -2596,7 +2596,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
 
     SETERRNO(0,SS_NORMAL);
     if (yyparse(GRAMPROG) || PL_parser->error_count) {
-        abort_execution("", PL_origfilename);
+        abort_execution(NULL, PL_origfilename);
     }
     CopLINE_set(PL_curcop, 0);
     SET_CURSTASH(PL_defstash);

perl.h

@@ -8936,6 +8936,12 @@ END_EXTERN_C
 #define PERL_DIAG_WARN_SYNTAX(x)    PERL_DIAG_STR_(x)
 #define PERL_DIAG_DIE_SYNTAX(x)     PERL_DIAG_STR_(x)
 
+#define PERL_STOP_PARSING_AFTER_N_ERRORS 10
+
+#define PERL_PARSE_IS_SYNTAX_ERROR_FLAG 128
+#define PERL_PARSE_IS_SYNTAX_ERROR(f) ((f) & PERL_PARSE_IS_SYNTAX_ERROR_FLAG)
+#define PERL_PARSE_ERROR_COUNT(f)     ((f) & (PERL_PARSE_IS_SYNTAX_ERROR_FLAG-1))
+
 /*
 
    (KEEP THIS LAST IN perl.h!)

pod/perldelta.pod

@@ -246,6 +246,24 @@ L<Locale '%s' is unsupported, and may crash the interpreter.message|perldiag/"Lo
 
 =item *
 
+The compiler will now stop parsing on the first syntax error it
+encounters. Historically the compiler would attempt to "skip past" the
+error and continue parsing so that it could list multiple errors. For
+things like undeclared variables under strict this makes sense. For
+syntax errors however it has been found that continuing tends to result
+in a storm of unrelated or bizarre errors that mostly just obscure the
+true error. In extreme cases it can even lead to segfaults and other
+malbehavior.
+
+Therefore we have reformed the continuation logic so that the parse will
+stop after the first seen syntax error. Semantic errors like undeclared
+variables will not stop the parse, so you may still see multiple errors
+when compiling code. However if there is a syntax error it will be the
+last error message reported by perl and all of the errors that you see
+will be something that actually needs to be fixed.
+
+=item *
+
 Error messages that output class or package names have been modified to
 output double quoted strings with various characters escaped so as to
 make the exact value clear to a reader. The exact rules on which

pod/perldiag.pod

@@ -2235,6 +2235,10 @@ Catamount. See L<perlport>.
 
 (F) The final summary message when a Perl compilation fails.
 
+=item Execution of %s aborted due to compilation errors.
+
+(F) The final summary message when a Perl compilation fails.
+
 =item exists argument is not a HASH or ARRAY element or a subroutine
 
 (F) The argument to C<exists> must be a hash or array element or a
@@ -5245,6 +5249,13 @@ the sub name and via the prototype attribute.  The prototype in
 parentheses is useless, since it will be replaced by the prototype
 from the attribute before it's ever used.
 
+=item %s on BEGIN block ignored
+
+(W syntax) C<BEGIN> blocks are executed immediately after they are parsed
+and then thrown away. Any prototypes or attributes are therefore
+meaningless and are ignored. You should remove them from the C<BEGIN> block.
+Note this also means you cannot create a constant called C<BEGIN>.
+
 =item Quantifier follows nothing in regex; marked by S<<-- HERE> in m/%s/
 
 (F) You started a regular expression with a quantifier.  Backslash it if

pp_ctl.c

@@ -1669,8 +1669,16 @@ Perl_qerror(pTHX_ SV *err)
         sv_catsv(PL_errors, err);
     else
         Perl_warn(aTHX_ "%" SVf, SVfARG(err));
-    if (PL_parser)
+
+    if (PL_parser) {
+        STRLEN len;
+        char *err_pv = SvPV(err,len);
         ++PL_parser->error_count;
+        if (memBEGINs(err_pv,len,"syntax error"))
+        {
+            PL_parser->error_count |= PERL_PARSE_IS_SYNTAX_ERROR_FLAG;
+        }
+    }
 }
 
 

proto.h

@@ -231,11 +231,11 @@ PERL_CALLCONV UV	Perl__utf8n_to_uvchr_msgs_helper(const U8 *s, STRLEN curlen, ST
 	assert(s)
 PERL_CALLCONV void	Perl__warn_problematic_locale(void);
 #define PERL_ARGS_ASSERT__WARN_PROBLEMATIC_LOCALE
-PERL_CALLCONV_NO_RET void	Perl_abort_execution(pTHX_ const char * const msg, const char * const name)
+PERL_CALLCONV_NO_RET void	Perl_abort_execution(pTHX_ SV *msg_sv, const char * const name)
 			__attribute__noreturn__
 			__attribute__visibility__("hidden");
 #define PERL_ARGS_ASSERT_ABORT_EXECUTION	\
-	assert(msg); assert(name)
+	assert(name)
 
 PERL_CALLCONV LOGOP*	Perl_alloc_LOGOP(pTHX_ I32 type, OP *first, OP *other)
 			__attribute__visibility__("hidden");

t/lib/croak/toke

@@ -25,7 +25,6 @@ EXPECT
 Scalar found where operator expected at - line 1, near "0${"
 	(Missing operator before ${?)
 syntax error at - line 1, near "0$"
-Missing right curly or square bracket at - line 1, at end of line
 Execution of - aborted due to compilation errors.
 ########
 # NAME (Missing operator before $#{?) [perl #123737]
@@ -34,7 +33,6 @@ EXPECT
 Array length found where operator expected at - line 1, near "0$#{"
 	(Missing operator before $#{?)
 syntax error at - line 1, near "0$#"
-Missing right curly or square bracket at - line 1, at end of line
 Execution of - aborted due to compilation errors.
 ########
 # NAME (Missing operator before @foo) [perl #123737]
@@ -52,7 +50,6 @@ EXPECT
 Array found where operator expected at - line 1, near "0@{"
 	(Missing operator before @{?)
 syntax error at - line 1, near "0@"
-Missing right curly or square bracket at - line 1, at end of line
 Execution of - aborted due to compilation errors.
 ########
 # NAME Unterminated here-doc in string eval
@@ -483,8 +480,6 @@ Use of bare << to mean <<"" is forbidden at - line 1.
 EXPECT
 Bareword found where operator expected at - line 1, near "1e"
 	(Missing operator before e?)
-Number found where operator expected at - line 1, near "--5"
-	(Missing operator before 5?)
 syntax error at - line 1, near "1e"
 Execution of - aborted due to compilation errors.
 ########
@@ -573,9 +568,6 @@ Execution of - aborted due to compilation errors.
 EXPECT
 Number found where operator expected at - line 1, near "0 0x"
 	(Missing operator before  0x?)
-Array found where operator expected at - line 1, near "0x@
-;"
-	(Missing operator before ;?)
 No digits found for hexadecimal literal at - line 1, near "0 0x@"
 syntax error at - line 1, near "0 0x"
 Execution of - aborted due to compilation errors.

t/lib/subs/subs

@@ -18,7 +18,7 @@ EXPECT
 Number found where operator expected at - line 3, near "Fred 1"
 	(Do you need to predeclare Fred?)
 syntax error at - line 3, near "Fred 1"
-BEGIN not safe after errors--compilation aborted at - line 4.
+Execution of - aborted due to compilation errors.
 ########
 
 # AOK
@@ -104,4 +104,4 @@ EXPECT
 Number found where operator expected at - line 5, near "ふれど 1"
 	(Do you need to predeclare ふれど?)
 syntax error at - line 5, near "ふれど 1"
-BEGIN not safe after errors--compilation aborted at - line 6.
+Execution of - aborted due to compilation errors.

t/lib/warnings/7fatal

@@ -545,8 +545,6 @@ if (1 {
 }
 EXPECT
 syntax error at - line 4, near "1 {"
-"my" variable $x masks earlier declaration in same statement at - line 6.
-syntax error at - line 7, near "}"
 Execution of - aborted due to compilation errors.
 ########
 

t/lib/warnings/toke

@@ -261,13 +261,8 @@ Reversed *= operator at - line 5.
 Reversed %= operator at - line 6.
 Reversed &= operator at - line 7.
 Reversed .= operator at - line 8.
-Reversed ^= operator at - line 9.
-Reversed |= operator at - line 10.
-Reversed <= operator at - line 11.
 syntax error at - line 8, near "=."
-syntax error at - line 9, near "=^"
-syntax error at - line 10, near "=|"
-Unterminated <> operator at - line 11.
+Execution of - aborted due to compilation errors.
 ########
 # toke.c
 no warnings 'syntax' ;
@@ -283,9 +278,7 @@ $a =< 2 ;
 $a =/ 2 ;
 EXPECT
 syntax error at - line 8, near "=."
-syntax error at - line 9, near "=^"
-syntax error at - line 10, near "=|"
-Unterminated <> operator at - line 11.
+Execution of - aborted due to compilation errors.
 ########
 # toke.c
 use warnings 'syntax' ;

t/op/blocks.t

@@ -6,7 +6,7 @@ BEGIN {
     set_up_inc('../lib');
 }
 
-plan tests => 23;
+plan tests => 26;
 
 my @expect = qw(
 b1
@@ -253,6 +253,33 @@ fresh_perl_like(
     "INIT{die} should exit"
 );
 
+fresh_perl_is(
+    "BEGIN{} BEGIN(){1} print 'done'",
+    "Prototype on BEGIN block ignored at - line 1.\ndone",
+    {},
+    "Prototypes on BEGIN blocks should warn"
+);
+
+SKIP: {
+    skip "Test requires full perl, this is miniperl", 1
+        if is_miniperl;
+
+    fresh_perl_is(
+        "use attributes; BEGIN{} sub BEGIN :blerg {1} print 'done'",
+        "Attribute on BEGIN block ignored at - line 1.\ndone",
+        {},
+        "Attributes on BEGIN blocks should warn"
+    );
+}
+
+fresh_perl_is(
+    'BEGIN() {10} foreach my $p (sort {lc($a) cmp lc($b)} keys %v)',
+    "Prototype on BEGIN block ignored at - line 1.\n"
+    . "syntax error at - line 1, at EOF\n"
+    . "Execution of - aborted due to compilation errors.",
+    {},
+    "Prototype on BEGIN blocks should warn"
+);
 
 TODO: {
     local $TODO = 'RT #2917: INIT{} in eval is wrongly considered too late';

t/op/heredoc.t

@@ -7,7 +7,7 @@ BEGIN {
 }
 
 use strict;
-plan(tests => 137);
+plan(tests => 138);
 
 # heredoc without newline (#65838)
 {
@@ -233,3 +233,13 @@ HEREDOC
         );
     }
 }
+fresh_perl_like(
+q#<<E1;
+${sub{b{]]]{} @{[ <<E2 ]}
+E2
+E1
+#,
+    qr/^syntax error/,
+    {},
+    "GH Issue #17397 - Syntax error inside of here doc causes segfault"
+);

t/op/lex.t

@@ -134,7 +134,7 @@ SKIP: {
 Bareword found where operator expected at - line 1, near ""ab}"ax"
 	(Missing operator before ax?)
 syntax error at - line 1, near ""ab}"ax"
-Unrecognized character \\x8A; marked by <-- HERE after ab}"ax;&\0z<-- HERE near column 12 at - line 1.
+Execution of - aborted due to compilation errors.
 gibberish
        { stderr => 1 },
       'gibberish containing &\0z - used to crash [perl #123753]'
@@ -144,7 +144,7 @@ gibberish
 Bareword found where operator expected at - line 1, near ""ab}"ax"
 	(Missing operator before ax?)
 syntax error at - line 1, near ""ab}"ax"
-Unrecognized character \\x8A; marked by <-- HERE after }"ax;&{+z}<-- HERE near column 14 at - line 1.
+Execution of - aborted due to compilation errors.
 gibberish
        { stderr => 1 },
       'gibberish containing &{+z} - used to crash [perl #123753]'

t/op/sub.t

@@ -6,7 +6,7 @@ BEGIN {
     set_up_inc('../lib');
 }
 
-plan(tests => 62);
+plan(tests => 63);
 
 sub empty_sub {}
 
@@ -426,3 +426,10 @@ eval '
    CORE::state sub b; sub d { sub b {} sub d }
  ';
 eval '()=%e; sub e { sub e; eval q|$x| } e;';
+
+fresh_perl_like(
+    q#<s,,$0[sub{m]]]],}>0,shift#,
+    qr/^syntax error/,
+    {},
+    "GH Issue #16944 - Syntax error with sub and shift causes segfault"
+);