In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/e5c5b1c9e1022d343db093f5d2af6fb39e6d1e30?hp=c4a535af41823cc84534bf8dbecfdcc3eb7daa86>
- Log ----------------------------------------------------------------- commit e5c5b1c9e1022d343db093f5d2af6fb39e6d1e30 Merge: c4a535a 214949f Author: David Mitchell <[email protected]> Date: Fri Jul 1 11:13:52 2016 +0100 [MERGE] make eval scope exit free temps plus a bunch of cleanup of the eval scope exit code commit 214949f5cdc4164f25e32c1a6ce989286456c205 Author: David Mitchell <[email protected]> Date: Thu Jun 30 10:56:28 2016 +0100 FREETMPS when leaving eval, even when void/dying When a scope is exited normally (e.g. pp_leavetry, pp_leavesub), we do a FREETMPS only in scalar or list context; in void context we don't bother for efficiency reasons. Similarly, when there's an exception and we unwind to (and then pop) an EVAL context, we haven't been bothering to FREETMPS. The problem with this in try/eval (exiting normally or via an exception) is that it can delay some SVs getting freed until *after* $@ has been set. If that freeing calls a destructor which happens to set $@, then that overwrites the "real" value of $@. For example sub DESTROY { eval { die "died in DESTROY"; } } eval { bless []; }; is ($@, ""); Before this commit, that test would fail because $@ is "died in DESTROY". This commit ensures that leaving an eval/try by whatever means always clears the tmps stack before setting $@. See http://nntp.perl.org/group/perl.perl5.porters/237380. For now, I haven't added a FREETMPS to the other pp_leavefoo() void context cases, since I can't think of a case where it would matter. M pp_ctl.c M t/op/eval.t commit 8c86f0238ecb5f32c2e7fba36e3edfdb54069068 Author: David Mitchell <[email protected]> Date: Thu Jun 30 10:12:06 2016 +0100 die_unwind(): mortalise, not mortalcopy the err SV The error string needs to be preserved while unwinding the stacks, but doing a simple sv_2mortal() and bumping the reference count seems sufficient, rather than making a complete copy. Also, avoid the mortalised SV's buffer from being stolen by using the SV_NOSTEAL flag rather than unsetting SvTEMP. Finally, add some basic comments above Perl_die_unwind() explaining what it's for. M pp_ctl.c commit 2a1e0dfedad09204e5328c32f1fcf915153a191c Author: David Mitchell <[email protected]> Date: Wed Jun 29 09:16:51 2016 +0100 cx_popeval(): don't mortalise blk_eval.old_namesv Currently whenever we pop an eval context used for a require, rather than freeing the SV holding the name of the require, we just mortalise it, since some callers of cx_popeval() need the SV to remain long enough to use it to "undo" %INC and to croak with a message such as ""$name did not return a true value". Now that all those usages have been gathered into one place (S_pop_eval_context_maybe_croak), make that function responsible for mortalising when there's a require error, and make the general-case case of cx_popeval() just decrement the reference count. M inline.h M pp_ctl.c commit 06a7bc17ca999c04cd2c36ca6162417b9bc32959 Author: David Mitchell <[email protected]> Date: Tue Jun 28 21:22:39 2016 +0100 expand and rename S_undo_inc_then_croak() This function is called from 3 places in pp_ctl.c to do things on require failure like: delete $INC{$name}; croak "$errsv: Compilation failed in require" After some previous commits, all 3 callers are now very similar around the time they call this function: for example they all do CX_LEAVE_SCOPE(cx); cx_popeval(cx); cx_popblock(cx); So incorporate all that into the function too, and rename it to S_pop_eval_context_maybe_croak() to reflect its expanded role. M pp_ctl.c commit 7d140242f905c25687570b43289e06f0643d55f3 Author: David Mitchell <[email protected]> Date: Tue Jun 28 17:14:41 2016 +0100 harmonise die_unwind, doeval_compile, leaveeval There is some similar code in each of these functions. Reorganise each of those blocks to make them more similar. In particular, move some of the EVAL context field preserving to earlier; i.e. change CX_LEAVE_SCOPE(cx); cx_popeval(cx); cx_popblock(cx); saved_foo = cx->blk_eval.foo; to saved_foo = cx->blk_eval.foo; CX_LEAVE_SCOPE(cx); cx_popeval(cx); cx_popblock(cx); and always examine the context entry to determine whether the EVAL is a require, rather than using any other method (but assert they're the same); and for leaveeval, move the CvDEPTH(evalcv)=0 setting earlier. M pp_ctl.c commit 03e81cd36058f8d91a1a7b9dbe588f71ee37b274 Author: David Mitchell <[email protected]> Date: Tue Jun 28 16:31:45 2016 +0100 tidy doeval_compile() After the previous commit removed some dead code, the rest of the code can be re-arranged to be slightly tidier. In particular, this structure: if (foo) { ...; } if (in_require) { assert(foo); croak(...); } becomes the logically equivalent if (foo) { ...; if (in_require) { croak(...); } } assert(!in_require); M pp_ctl.c commit 70b02e389c9f2b0bf1f1d601f841f25c606cebda Author: David Mitchell <[email protected]> Date: Tue Jun 28 16:22:03 2016 +0100 doeval_compile(): remove dead code The combination of in_require and yystatus ==3 (i.e. we caught a JUMPENV(3)) should never happen, so remove the code that handles this combo and replace with an assertion. I think the dead code was wrong anyway - it re-croaked without having first popped he current EVAL context. M pp_ctl.c ----------------------------------------------------------------------- Summary of changes: inline.h | 6 +- pp_ctl.c | 186 +++++++++++++++++++++++++++++++++++------------------------- t/op/eval.t | 34 ++++++++++- 3 files changed, 147 insertions(+), 79 deletions(-) diff --git a/inline.h b/inline.h index 46f8d9d..14e9dbe 100644 --- a/inline.h +++ b/inline.h @@ -624,8 +624,10 @@ S_cx_popeval(pTHX_ PERL_CONTEXT *cx) } sv = cx->blk_eval.old_namesv; - if (sv && !SvTEMP(sv))/* TEMP implies cx_popeval() re-entrantly called */ - sv_2mortal(sv); + if (sv) { + cx->blk_eval.old_namesv = NULL; + SvREFCNT_dec_NN(sv); + } } diff --git a/pp_ctl.c b/pp_ctl.c index 1e5b684..3c20f88 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -1588,42 +1588,80 @@ Perl_qerror(pTHX_ SV *err) -/* undef or delete the $INC{namesv} entry, then croak. - * require0 indicates that the require didn't return a true value */ +/* pop a CXt_EVAL context and in addition, if it was a require then + * based on action: + * 0: do nothing extra; + * 1: undef $INC{$name}; croak "$name did not return a true value"; + * 2: delete $INC{$name}; croak "$errsv: Compilation failed in require" + */ static void -S_undo_inc_then_croak(pTHX_ SV *namesv, SV *err, bool require0) +S_pop_eval_context_maybe_croak(pTHX_ PERL_CONTEXT *cx, SV *errsv, int action) { - const char *fmt; - HV *inc_hv = GvHVn(PL_incgv); - I32 klen = SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv); - const char *key = SvPVX_const(namesv); + SV *namesv = NULL; /* just to silence compiler warnings */ + bool do_croak; - if (require0) { - (void)hv_delete(inc_hv, key, klen, G_DISCARD); - fmt = "%"SVf" did not return a true value"; - err = namesv; - } - else { - (void)hv_store(inc_hv, key, klen, &PL_sv_undef, 0); - fmt = "%"SVf"Compilation failed in require"; - err = err ? err : newSVpvs_flags("Unknown error\n", SVs_TEMP); + CX_LEAVE_SCOPE(cx); + do_croak = action && (CxOLD_OP_TYPE(cx) == OP_REQUIRE); + if (do_croak) { + /* keep namesv alive after cx_popeval() */ + namesv = cx->blk_eval.old_namesv; + cx->blk_eval.old_namesv = NULL; + sv_2mortal(namesv); } + cx_popeval(cx); + cx_popblock(cx); + CX_POP(cx); - Perl_croak(aTHX_ fmt, SVfARG(err)); + if (do_croak) { + const char *fmt; + HV *inc_hv = GvHVn(PL_incgv); + I32 klen = SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv); + const char *key = SvPVX_const(namesv); + + if (action == 1) { + (void)hv_delete(inc_hv, key, klen, G_DISCARD); + fmt = "%"SVf" did not return a true value"; + errsv = namesv; + } + else { + (void)hv_store(inc_hv, key, klen, &PL_sv_undef, 0); + fmt = "%"SVf"Compilation failed in require"; + if (!errsv) + errsv = newSVpvs_flags("Unknown error\n", SVs_TEMP); + } + + Perl_croak(aTHX_ fmt, SVfARG(errsv)); + } } +/* die_unwind(): this is the final destination for the various croak() + * functions. If we're in an eval, unwind the context and other stacks + * back to the top-most CXt_EVAL and set $@ to msv; otherwise print msv + * to STDERR and initiate an exit. Note that if the CXt_EVAL popped back + * to is a require the exception will be rethrown, as requires don't + * actually trap exceptions. + */ + void Perl_die_unwind(pTHX_ SV *msv) { - SV *exceptsv = sv_mortalcopy(msv); + SV *exceptsv = msv; U8 in_eval = PL_in_eval; PERL_ARGS_ASSERT_DIE_UNWIND; if (in_eval) { I32 cxix; + /* We need to keep this SV alive through all the stack unwinding + * and FREETMPSing below, while ensuing that it doesn't leak + * if we call out to something which then dies (e.g. sub STORE{die} + * when unlocalising a tied var). So we do a dance with + * mortalising and SAVEFREEing. + */ + sv_2mortal(SvREFCNT_inc_simple_NN(exceptsv)); + /* * Historically, perl used to set ERRSV ($@) early in the die * process and rely on it not getting clobbered during unwinding. @@ -1653,10 +1691,9 @@ Perl_die_unwind(pTHX_ SV *msv) * perls 5.13.{1..7} which had late setting of $@ without this * early-setting hack. */ - if (!(in_eval & EVAL_KEEPERR)) { - SvTEMP_off(exceptsv); - sv_setsv(ERRSV, exceptsv); - } + if (!(in_eval & EVAL_KEEPERR)) + sv_setsv_flags(ERRSV, exceptsv, + (SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL)); if (in_eval & EVAL_KEEPERR) { Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf, @@ -1671,7 +1708,6 @@ Perl_die_unwind(pTHX_ SV *msv) } if (cxix >= 0) { - SV *namesv = NULL; PERL_CONTEXT *cx; SV **oldsp; U8 gimme; @@ -1691,23 +1727,33 @@ Perl_die_unwind(pTHX_ SV *msv) *++oldsp = &PL_sv_undef; PL_stack_sp = oldsp; - CX_LEAVE_SCOPE(cx); - cx_popeval(cx); - cx_popblock(cx); restartjmpenv = cx->blk_eval.cur_top_env; - restartop = cx->blk_eval.retop; - if (CxOLD_OP_TYPE(cx) == OP_REQUIRE) - namesv = cx->blk_eval.old_namesv; - CX_POP(cx); - - if (namesv) { - /* note that unlike pp_entereval, pp_require isn't - * supposed to trap errors. So now that we've popped the - * EVAL that pp_require pushed, process the error message - * and rethrow the error */ - S_undo_inc_then_croak(aTHX_ namesv, exceptsv, FALSE); - NOT_REACHED; /* NOTREACHED */ - } + restartop = cx->blk_eval.retop; + + /* We need a FREETMPS here to avoid late-called destructors + * clobbering $@ *after* we set it below, e.g. + * sub DESTROY { eval { die "X" } } + * eval { my $x = bless []; die $x = 0, "Y" }; + * is($@, "Y") + * Here the clearing of the $x ref mortalises the anon array, + * which needs to be freed *before* $& is set to "Y", + * otherwise it gets overwritten with "X". + * + * However, the FREETMPS will clobber exceptsv, so preserve it + * on the savestack for now. + */ + SAVEFREESV(SvREFCNT_inc_simple_NN(exceptsv)); + FREETMPS; + /* now we're about to pop the savestack, so re-mortalise it */ + sv_2mortal(SvREFCNT_inc_simple_NN(exceptsv)); + + /* Note that unlike pp_entereval, pp_require isn't supposed to + * trap errors. So if we're a require, after we pop the + * CXt_EVAL that pp_require pushed, rethrow the error with + * croak(exceptsv). This is all handled by the call below when + * action == 2. + */ + S_pop_eval_context_maybe_croak(aTHX_ cx, exceptsv, 2); if (!(in_eval & EVAL_KEEPERR)) sv_setsv(ERRSV, exceptsv); @@ -3383,7 +3429,6 @@ S_doeval_compile(pTHX_ U8 gimme, CV* outside, U32 seq, HV *hh) yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG); if (yystatus || PL_parser->error_count || !PL_eval_root) { - SV *namesv = NULL; /* initialise to avoid compiler warning */ PERL_CONTEXT *cx; SV *errsv; @@ -3398,25 +3443,17 @@ S_doeval_compile(pTHX_ U8 gimme, CV* outside, U32 seq, HV *hh) } SP = PL_stack_base + POPMARK; /* pop original mark */ cx = CX_CUR(); - CX_LEAVE_SCOPE(cx); - cx_popeval(cx); - cx_popblock(cx); - if (in_require) - namesv = cx->blk_eval.old_namesv; - CX_POP(cx); + assert(CxTYPE(cx) == CXt_EVAL); + /* pop the CXt_EVAL, and if was a require, croak */ + S_pop_eval_context_maybe_croak(aTHX_ cx, ERRSV, 2); } - errsv = ERRSV; - if (in_require) { - if (yystatus == 3) { - cx = CX_CUR(); - assert(CxTYPE(cx) == CXt_EVAL); - namesv = cx->blk_eval.old_namesv; - } - S_undo_inc_then_croak(aTHX_ namesv, errsv, FALSE); - NOT_REACHED; /* NOTREACHED */ - } + /* die_unwind() re-croaks when in require, having popped the + * require EVAL context. So we should never catch a require + * exception here */ + assert(!in_require); + errsv = ERRSV; if (!*(SvPV_nolen_const(errsv))) sv_setpvs(errsv, "Compilation error"); @@ -4274,10 +4311,9 @@ PP(pp_leaveeval) U8 gimme; PERL_CONTEXT *cx; OP *retop; - SV *namesv = NULL; + int failed; CV *evalcv; - /* grab this value before cx_popeval restores old PL_in_eval */ - bool keep = cBOOL(PL_in_eval & EVAL_KEEPERR); + bool keep; PERL_ASYNC_CHECK(); @@ -4288,15 +4324,16 @@ PP(pp_leaveeval) gimme = cx->blk_gimme; /* did require return a false value? */ - if ( CxOLD_OP_TYPE(cx) == OP_REQUIRE - && !(gimme == G_SCALAR + failed = CxOLD_OP_TYPE(cx) == OP_REQUIRE + && !(gimme == G_SCALAR ? SvTRUE(*PL_stack_sp) - : PL_stack_sp > oldsp) - ) - namesv = cx->blk_eval.old_namesv; + : PL_stack_sp > oldsp); - if (gimme == G_VOID) + if (gimme == G_VOID) { PL_stack_sp = oldsp; + /* free now to avoid late-called destructors clobbering $@ */ + FREETMPS; + } else leave_adjust_stacks(oldsp, oldsp, gimme, 0); @@ -4308,23 +4345,17 @@ PP(pp_leaveeval) */ PL_curcop = cx->blk_oldcop; - CX_LEAVE_SCOPE(cx); - cx_popeval(cx); - cx_popblock(cx); + /* grab this value before cx_popeval restores the old PL_in_eval */ + keep = cBOOL(PL_in_eval & EVAL_KEEPERR); retop = cx->blk_eval.retop; evalcv = cx->blk_eval.cv; - CX_POP(cx); - #ifdef DEBUGGING assert(CvDEPTH(evalcv) == 1); #endif CvDEPTH(evalcv) = 0; - if (namesv) { /* require returned false */ - /* Unassume the success we assumed earlier. */ - S_undo_inc_then_croak(aTHX_ namesv, NULL, TRUE); - NOT_REACHED; /* NOTREACHED */ - } + /* pop the CXt_EVAL, and if a require failed, croak */ + S_pop_eval_context_maybe_croak(aTHX_ cx, NULL, failed); if (!keep) CLEAR_ERRSV(); @@ -4391,8 +4422,11 @@ PP(pp_leavetry) oldsp = PL_stack_base + cx->blk_oldsp; gimme = cx->blk_gimme; - if (gimme == G_VOID) + if (gimme == G_VOID) { PL_stack_sp = oldsp; + /* free now to avoid late-called destructors clobbering $@ */ + FREETMPS; + } else leave_adjust_stacks(oldsp, oldsp, gimme, 1); CX_LEAVE_SCOPE(cx); diff --git a/t/op/eval.t b/t/op/eval.t index 7b9fb17..bb31f83 100644 --- a/t/op/eval.t +++ b/t/op/eval.t @@ -6,7 +6,7 @@ BEGIN { set_up_inc('../lib'); } -plan(tests => 134); +plan(tests => 140); eval 'pass();'; @@ -665,3 +665,35 @@ pass("eval in freed package does not crash"); sub { $s; DB::f127786}->(); pass("RT #127786"); } + +# Late calling of destructors overwriting $@. +# When leaving an eval scope (either by falling off the end or dying), +# we must ensure that any temps are freed before the end of the eval +# leave: in particular before $@ is set (to either "" or the error), +# because otherwise the tmps freeing may call a destructor which +# will change $@ (e.g. due to a successful eval) *after* its been set. +# Some extra nested scopes are included in the tests to ensure they don't +# affect the tmps freeing. + +{ + package TMPS; + sub DESTROY { eval { die "died in DESTROY"; } } # alters $@ + + eval { { 1; { 1; bless []; } } }; + ::is ($@, "", "FREETMPS: normal try exit"); + + eval q{ { 1; { 1; bless []; } } }; + ::is ($@, "", "FREETMPS: normal string eval exit"); + + eval { { 1; { 1; return bless []; } } }; + ::is ($@, "", "FREETMPS: return try exit"); + + eval q{ { 1; { 1; return bless []; } } }; + ::is ($@, "", "FREETMPS: return string eval exit"); + + eval { { 1; { 1; my $x = bless []; die $x = 0, "die in eval"; } } }; + ::like ($@, qr/die in eval/, "FREETMPS: die try exit"); + + eval q{ { 1; { 1; my $x = bless []; die $x = 0, "die in eval"; } } }; + ::like ($@, qr/die in eval/, "FREETMPS: die eval string exit"); +} -- Perl5 Master Repository
