In perl.git, the branch blead has been updated
<https://perl5.git.perl.org/perl.git/commitdiff/bb4e4c3869d9fb6ee5bddd820c2a373601ecc310?hp=4bfb5532d393d56b18d13bc19f70f6f7a64ae781>
- Log -----------------------------------------------------------------
commit bb4e4c3869d9fb6ee5bddd820c2a373601ecc310
Author: Tony Cook <t...@develop-help.com>
Date: Tue Jan 30 16:40:53 2018 +1100
(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...)
-----------------------------------------------------------------------
Summary of changes:
parser.h | 2 ++
t/base/lex.t | 11 ++++++++++-
toke.c | 18 ++++++++++++++++++
3 files changed, 30 insertions(+), 1 deletion(-)
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
--
Perl5 Master Repository
