From 37b5ba32185c0d629cf374ddd26ecc268b642a8a Mon Sep 17 00:00:00 2001 From: Yves Orton Date: Fri, 26 Aug 2022 18:26:14 +0200 Subject: [PATCH 1/2] Stop parsing on first syntax error. We try to keep parsing after many types of errors, up to a (current) maximum of 10 errors. Continuing after a semantic error (like undeclared variables) can be helpful, for instance showing a set of common errors, but continuing after a syntax error isn't helpful most of the time as the internal state of the parser can get confused and is not reliably restored in between attempts. This can produce sometimes completely bizarre errors which just obscure the true error, and has resulted in security tickets being filed in the past. This patch makes the parser stop after the first syntax error, while preserving the current behavior for other errors. An error is considered a syntax error if the error message from our internals is the literal text "syntax error". This may not be a complete list of true syntax errors, we can iterate on that in the future. This fixes the segfaults reported in Issue #17397, and #16944 and likely fixes other "segfault due to compiler continuation after syntax error" bugs that we have on record, which has been a recurring issue over the years. --- embed.fnc | 2 +- perl.c | 2 +- perl.h | 6 +++++ pod/perldelta.pod | 18 ++++++++++++++ pod/perldiag.pod | 4 ++++ pp_ctl.c | 10 +++++++- proto.h | 4 ++-- t/lib/croak/toke | 8 ------- t/lib/subs/subs | 4 ++-- t/lib/warnings/7fatal | 2 -- t/lib/warnings/toke | 11 ++------- t/op/heredoc.t | 12 +++++++++- t/op/lex.t | 4 ++-- t/op/sub.t | 9 ++++++- t/op/tie.t | 8 +++---- t/run/fresh_perl.t | 4 ---- toke.c | 56 +++++++++++++++++++++++++++++++------------ 17 files changed, 111 insertions(+), 53 deletions(-) diff --git a/embed.fnc b/embed.fnc index eba677a2a6cd..8991b51f8b03 100644 --- a/embed.fnc +++ b/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 diff --git a/perl.c b/perl.c index 1cfea3f99796..343c117f44b0 100644 --- a/perl.c +++ b/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); diff --git a/perl.h b/perl.h index 25f422365f17..49c983570752 100644 --- a/perl.h +++ b/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!) diff --git a/pod/perldelta.pod b/pod/perldelta.pod index fe30ce1de0b8..f3a659a0a3a8 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -246,6 +246,24 @@ L. (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 must be a hash or array element or a diff --git a/pp_ctl.c b/pp_ctl.c index c194d7b2f968..680072f0fcf7 100644 --- a/pp_ctl.c +++ b/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; + } + } } diff --git a/proto.h b/proto.h index 4d695a5405d9..727d008d5181 100644 --- a/proto.h +++ b/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"); diff --git a/t/lib/croak/toke b/t/lib/croak/toke index dd27874c9ad0..abcf20e225b6 100644 --- a/t/lib/croak/toke +++ b/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. diff --git a/t/lib/subs/subs b/t/lib/subs/subs index e0bb16eadb9c..d6c416a1c06c 100644 --- a/t/lib/subs/subs +++ b/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. diff --git a/t/lib/warnings/7fatal b/t/lib/warnings/7fatal index 40c649f249a7..ebf6a25fa018 100644 --- a/t/lib/warnings/7fatal +++ b/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. ######## diff --git a/t/lib/warnings/toke b/t/lib/warnings/toke index 39f92b022de1..53cd22645c39 100644 --- a/t/lib/warnings/toke +++ b/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' ; diff --git a/t/op/heredoc.t b/t/op/heredoc.t index 0a7bb06b0ff7..6e7e895def7d 100644 --- a/t/op/heredoc.t +++ b/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#< 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]' diff --git a/t/op/sub.t b/t/op/sub.t index 11d7147e5df7..09f5609b499a 100644 --- a/t/op/sub.t +++ b/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#0,shift#, + qr/^syntax error/, + {}, + "GH Issue #16944 - Syntax error with sub and shift causes segfault" +); diff --git a/t/op/tie.t b/t/op/tie.t index 9cc1599331a6..673ec49dce7b 100644 --- a/t/op/tie.t +++ b/t/op/tie.t @@ -731,10 +731,10 @@ $foo{'exit'}; print "overshot main\n"; # shouldn't reach here EXPECT -eval: s0=EVAL-BD-BS-E1-S1-E2-S2-S2-S2-S2-S2-S2-S2-S2-S2-S2-R -eval: s1=EVAL-BD-BS-E1-S1-E2-S2-S2-S2-S2-S2-S2-S2-S2-S2-S2-R -eval: s2=EVAL-BD-BS-E1-S1-E2-S2-S2-S2-S2-S2-S2-S2-S2-S2-S2-R -eval: s3=EVAL-BD-BS-E1-S1-E2-S2-S2-S2-S2-S2-S2-S2-S2-S2-S2-R +eval: s0=EVAL-BD-BS-E1-S1-E2-S2-R +eval: s1=EVAL-BD-BS-E1-S1-E2-S2-R +eval: s2=EVAL-BD-BS-E1-S1-E2-S2-R +eval: s3=EVAL-BD-BS-E1-S1-E2-S2-R require: s0=REQUIRE-0-ERQ-ENDRQ-1-ERQ-ENDRQ-2-ERQ-ENDRQ-3-ERQ-ENDRQ-R require: s1=REQUIRE-0-RQ require: s2=REQUIRE-0-ERQ-ENDRQ-1-ERQ-ENDRQ-2-ERQ-ENDRQ-3-ERQ-ENDRQ-R diff --git a/t/run/fresh_perl.t b/t/run/fresh_perl.t index 88a64ad58391..df7cebb80c74 100644 --- a/t/run/fresh_perl.t +++ b/t/run/fresh_perl.t @@ -817,8 +817,6 @@ meow { }; EXPECT syntax error at - line 12, near "used" -syntax error at - line 12, near "used}" -Unmatched right curly bracket at - line 14, at end of line Execution of - aborted due to compilation errors. ######## [perl #112312] crash on syntax error - another test # SKIP: !defined &DynaLoader::boot_DynaLoader # miniperl @@ -849,6 +847,4 @@ sub testo { EXPECT syntax error at - line 15, near "used" -syntax error at - line 15, near "used}" -Unmatched right curly bracket at - line 17, at end of line Execution of - aborted due to compilation errors. diff --git a/toke.c b/toke.c index feffec22f891..607ce0372a7a 100644 --- a/toke.c +++ b/toke.c @@ -12521,15 +12521,24 @@ S_yywarn(pTHX_ const char *const s, U32 flags) } void -Perl_abort_execution(pTHX_ const char * const msg, const char * const name) +Perl_abort_execution(pTHX_ SV* msg_sv, const char * const name) { PERL_ARGS_ASSERT_ABORT_EXECUTION; - if (PL_minus_c) - Perl_croak(aTHX_ "%s%s had compilation errors.\n", msg, name); - else { - Perl_croak(aTHX_ - "%sExecution of %s aborted due to compilation errors.\n", msg, name); + if (msg_sv) { + if (PL_minus_c) + Perl_croak(aTHX_ "%" SVf "%s had compilation errors.\n", SVfARG(msg_sv), name); + else { + Perl_croak(aTHX_ + "%" SVf "Execution of %s aborted due to compilation errors.\n", SVfARG(msg_sv), name); + } + } else { + if (PL_minus_c) + Perl_croak(aTHX_ "%s had compilation errors.\n", name); + else { + Perl_croak(aTHX_ + "Execution of %s aborted due to compilation errors.\n", name); + } } NOT_REACHED; /* NOTREACHED */ } @@ -12644,22 +12653,39 @@ Perl_yyerror_pvn(pTHX_ const char *const s, STRLEN len, U32 flags) qerror(msg); } } - if (s == NULL || PL_error_count >= 10) { - const char * msg = ""; + if ( s == NULL || + PL_error_count >= PERL_STOP_PARSING_AFTER_N_ERRORS + ) { const char * const name = OutCopFILE(PL_curcop); + SV * errsv = NULL; + U8 raw_error_count = PERL_PARSE_ERROR_COUNT(PL_error_count); + bool syntax_error = PERL_PARSE_IS_SYNTAX_ERROR(PL_error_count); if (PL_in_eval) { - SV * errsv = ERRSV; - if (SvCUR(errsv)) { - msg = Perl_form(aTHX_ "%" SVf, SVfARG(errsv)); - } + errsv = ERRSV; } if (s == NULL) { - abort_execution(msg, name); + abort_execution(errsv, name); } - else { - Perl_croak(aTHX_ "%s%s has too many errors.\n", msg, name); + else + if (raw_error_count >= PERL_STOP_PARSING_AFTER_N_ERRORS) { + if (errsv) { + Perl_croak(aTHX_ "%" SVf "%s has too many errors.\n", + SVfARG(errsv), name); + } else { + Perl_croak(aTHX_ "%s has too many errors.\n", name); + } + } + else + /* if (syntax_error) - implied */ + { + assert(syntax_error); + if (errsv) { + Perl_croak_sv(aTHX_ errsv); + } else { + abort_execution(errsv, name); + } } } PL_in_my = 0; From 66b139ed41a3366932060029148a2ffcff2cdb46 Mon Sep 17 00:00:00 2001 From: Yves Orton Date: Thu, 8 Sep 2022 10:31:57 +0200 Subject: [PATCH 2/2] op.c - Ignore attributes and prototypes on BEGIN blocks This fixes Issue #16057, prototypes on BEGIN blocks cause segfaults. This patch warns about the use of either. --- op.c | 58 ++++++++++++++++++++++++++++++++---------------- pod/perldiag.pod | 7 ++++++ t/op/blocks.t | 29 +++++++++++++++++++++++- 3 files changed, 74 insertions(+), 20 deletions(-) diff --git a/op.c b/op.c index 9de2326488e2..47c78bfcbd7f 100644 --- a/op.c +++ b/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; diff --git a/pod/perldiag.pod b/pod/perldiag.pod index 60df38264697..e513bb0b8c51 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -5249,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 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 block. +Note this also means you cannot create a constant called C. + =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 diff --git a/t/op/blocks.t b/t/op/blocks.t index 18f0596226b2..33401bdaf6a6 100644 --- a/t/op/blocks.t +++ b/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';