In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/b66d79a6843486dbfe3a6f0a5fb78ffb86dd82e2?hp=655f5b268af8bf50c44ba4ae4803a33c9b792b8b>
- Log ----------------------------------------------------------------- commit b66d79a6843486dbfe3a6f0a5fb78ffb86dd82e2 Author: David Mitchell <[email protected]> Date: Mon Aug 22 09:50:43 2016 +0100 FREETMPS when leaving eval, even when void/dying [ This commit was originally added as v5.25.2-77-g214949f then reverted by v5.25.2-89-gcc040a9, since it broke Variable::Magic. That distribution has since been fixed, so this fix can be re-applied to blead ] 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. ----------------------------------------------------------------------- Summary of changes: pp_ctl.c | 36 +++++++++++++++++++++++++++++++++--- t/op/eval.t | 34 +++++++++++++++++++++++++++++++++- 2 files changed, 66 insertions(+), 4 deletions(-) diff --git a/pp_ctl.c b/pp_ctl.c index e24d7b6019..d465a9edce 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -1685,7 +1685,13 @@ Perl_die_unwind(pTHX_ SV *msv) if (in_eval) { I32 cxix; - exceptsv = sv_2mortal(SvREFCNT_inc_simple_NN(exceptsv)); + /* 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 @@ -1754,6 +1760,24 @@ Perl_die_unwind(pTHX_ SV *msv) restartjmpenv = cx->blk_eval.cur_top_env; 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 @@ -4439,8 +4463,11 @@ PP(pp_leaveeval) ? SvTRUE(*PL_stack_sp) : 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); @@ -4532,8 +4559,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 722cd35c37..a9b8c9ed7a 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
