In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/84875a28d7b7f4db402f82dd5f607497b00db5e6?hp=8236531137ae107f8a187261b0f8fdb9bff11811>
- Log ----------------------------------------------------------------- commit 84875a28d7b7f4db402f82dd5f607497b00db5e6 Author: Father Chrysostomos <[email protected]> Date: Wed Feb 4 22:03:03 2015 -0800 toke.c: Remove redundant PL_lex_stuff null checks In these three code paths, PL_lex_stuff is never null, so there is no need to check that. M toke.c commit eabab8bccf871f8e85dfa4a3825827825fb86cd9 Author: Father Chrysostomos <[email protected]> Date: Wed Feb 4 21:30:36 2015 -0800 Localise PL_lex_stuff (crash fix) This fixes crashes and assertion failures related to ticket #123617. When the lexer encounters a quote-like operator, it scans for the final delimiter, putting the string in PL_lex_stuff and the replace- ment, if any, in PL_sublex_info.repl. Those are just temporary spots for those values. As soon as the next token is emitted (FUNC or PMFUNC), the values are copied to PL_linestr and PL_lex_repl, respec- tively, after these latter have been localised. When scan_str (which scans a quote-like op) sees that PL_lex_stuff is already set, it assumes that it is now parsing a replacement, so it puts the result in PL_sublex_info.repl. The FUNC or PMFUNC token for a quote-like operator may trigger a syn- tax error while PL_lex_stuff and PL_sublex_info.repl are still set. A syntax error can cause scopes to be popped, discarding the inner lex- ing scope (for the quote op) that we were about to enter, but leaving a PL_lex_stuff value behind. If another quote-like op is parsed after that, scan_str will assume it is parsing a replacement since PL_lex_stuff is set. So you can end up with a replacement for an op of type OP_MATCH, which is not supposed to happen. S_sublex_done fails an assertion in that case. Some exam- ples of this bug crash later on non-debugging builds. Localising PL_lex_stuff fixes the problem. M t/base/lex.t M toke.c commit 67c71cbbd62a75ff2b913421806f6ea0f0b33558 Author: Father Chrysostomos <[email protected]> Date: Wed Feb 4 22:11:06 2015 -0800 Fix double free with const overload after errors The PL_lex_stuff variable in the parser struct is reference-counted. Yet, in toke.c:S_sublex_start we pass the value to S_tokeq, which may pass it to S_new_constant, which takes ownership of the reference count (possibly freeing or mortalising the SV), and then relinquishes its ownership of the returned SV (incrementing the reference count if it is the same SV passed to it). If S_new_constant croaks, then it will have mortalised the SV passed to it while PL_lex_stuff still points to it. This example makes S_new_constant croak indirectly, by causing its yyerror call to croak because of the number of errors: $ perl5.20.1 -e 'BEGIN { $^H|=0x8000} undef(1,2); undef(1,2); undef(1,2); undef(1,2); undef(1,2); undef(1,2); undef(1,2); undef(1,2); undef(1,2); "a"' Too many arguments for undef operator at -e line 1, near "2)" Too many arguments for undef operator at -e line 1, near "2)" Too many arguments for undef operator at -e line 1, near "2)" Too many arguments for undef operator at -e line 1, near "2)" Too many arguments for undef operator at -e line 1, near "2)" Too many arguments for undef operator at -e line 1, near "2)" Too many arguments for undef operator at -e line 1, near "2)" Too many arguments for undef operator at -e line 1, near "2)" Too many arguments for undef operator at -e line 1, near "2)" Constant(q) unknown at -e line 1, near ";"a"" -e has too many errors. Attempt to free unreferenced scalar: SV 0x7fb49882fae8 at -e line 1. M t/lib/croak/toke M toke.c commit d9a13252ba5aad7b3eaaff069b56472cfb651a40 Author: Father Chrysostomos <[email protected]> Date: Wed Feb 4 21:31:29 2015 -0800 toke.c: Use SvREFCNT_dec_NN in one spot M toke.c ----------------------------------------------------------------------- Summary of changes: t/base/lex.t | 3 +++ t/lib/croak/toke | 26 ++++++++++++++++++++++++++ toke.c | 31 ++++++++++++++++--------------- 3 files changed, 45 insertions(+), 15 deletions(-) diff --git a/t/base/lex.t b/t/base/lex.t index f938168..66db28b 100644 --- a/t/base/lex.t +++ b/t/base/lex.t @@ -485,3 +485,6 @@ print "ok $test - map{sub :lvalue...}\n"; $test++; # Used to crash [perl #123711] 0-5x-l{0}; + +# Used to fail an assertion [perl #123617] +eval '"$a{ 1 m// }"; //'; diff --git a/t/lib/croak/toke b/t/lib/croak/toke index 26fc8c7..57f3790 100644 --- a/t/lib/croak/toke +++ b/t/lib/croak/toke @@ -186,6 +186,32 @@ Constant(qq): Call to &{$^H{qr}} did not return a defined value at - line 3, wit Constant(q): Call to &{$^H{qr}} did not return a defined value at - line 3, within pattern Execution of - aborted due to compilation errors. ######## +# NAME Failed constant overloading should not cause a double free +use overload; +BEGIN { overload::constant q => sub {}; undef *^H } +undef(1,2); +undef(1,2); +undef(1,2); +undef(1,2); +undef(1,2); +undef(1,2); +undef(1,2); +undef(1,2); +undef(1,2); +"a" +EXPECT +Too many arguments for undef operator at - line 3, near "2)" +Too many arguments for undef operator at - line 4, near "2)" +Too many arguments for undef operator at - line 5, near "2)" +Too many arguments for undef operator at - line 6, near "2)" +Too many arguments for undef operator at - line 7, near "2)" +Too many arguments for undef operator at - line 8, near "2)" +Too many arguments for undef operator at - line 9, near "2)" +Too many arguments for undef operator at - line 10, near "2)" +Too many arguments for undef operator at - line 11, near "2)" +Constant(q) unknown at - line 12, near ""a"" +- has too many errors. +######## # NAME Unterminated delimiter for here document <<"foo EXPECT diff --git a/toke.c b/toke.c index 559c74c..5373510 100644 --- a/toke.c +++ b/toke.c @@ -2276,7 +2276,9 @@ S_sublex_start(pTHX) return THING; } if (op_type == OP_CONST) { - SV *sv = tokeq(PL_lex_stuff); + SV *sv = PL_lex_stuff; + PL_lex_stuff = NULL; + sv = tokeq(sv); if (SvTYPE(sv) == SVt_PVIV) { /* Overloaded constants, nothing fancy: Convert to SVt_PV: */ @@ -2287,7 +2289,6 @@ S_sublex_start(pTHX) sv = nsv; } pl_yylval.opval = (OP*)newSVOP(op_type, 0, sv); - PL_lex_stuff = NULL; return THING; } @@ -2367,6 +2368,12 @@ S_sublex_push(pTHX) PL_lex_stuff = NULL; PL_sublex_info.repl = NULL; + /* Arrange for PL_lex_stuff to be freed on scope exit, in case it gets + set for an inner quote-like operator and then an error causes scope- + popping. We must not have a PL_lex_stuff value left dangling, as + that breaks assumptions elsewhere. See bug #123617. */ + SAVEGENERICSV(PL_lex_stuff); + PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr); PL_bufend += SvCUR(PL_linestr); @@ -5323,7 +5330,7 @@ Perl_yylex(pTHX) sv_catsv(sv, PL_lex_stuff); attrs = op_append_elem(OP_LIST, attrs, newSVOP(OP_CONST, 0, sv)); - SvREFCNT_dec(PL_lex_stuff); + SvREFCNT_dec_NN(PL_lex_stuff); PL_lex_stuff = NULL; } else { @@ -7670,10 +7677,8 @@ Perl_yylex(pTHX) } if (!words) words = newNULLLIST(); - if (PL_lex_stuff) { - SvREFCNT_dec(PL_lex_stuff); - PL_lex_stuff = NULL; - } + SvREFCNT_dec_NN(PL_lex_stuff); + PL_lex_stuff = NULL; PL_expect = XOPERATOR; pl_yylval.opval = sawparens(words); TOKEN(QWLIST); @@ -8988,10 +8993,8 @@ S_scan_subst(pTHX_ char *start) first_line = CopLINE(PL_curcop); s = scan_str(s,FALSE,FALSE,FALSE,NULL); if (!s) { - if (PL_lex_stuff) { - SvREFCNT_dec(PL_lex_stuff); - PL_lex_stuff = NULL; - } + SvREFCNT_dec_NN(PL_lex_stuff); + PL_lex_stuff = NULL; Perl_croak(aTHX_ "Substitution replacement not terminated"); } PL_multi_start = first_start; /* so whole substitution is taken together */ @@ -9070,10 +9073,8 @@ S_scan_trans(pTHX_ char *start) s = scan_str(s,FALSE,FALSE,FALSE,NULL); if (!s) { - if (PL_lex_stuff) { - SvREFCNT_dec(PL_lex_stuff); - PL_lex_stuff = NULL; - } + SvREFCNT_dec_NN(PL_lex_stuff); + PL_lex_stuff = NULL; Perl_croak(aTHX_ "Transliteration replacement not terminated"); } -- Perl5 Master Repository
