In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/cc040a9bd824f7d0dd1abf4940dff44fe71500f9?hp=5993d6620f29d22b0a72701f4f0fdacff3d25460>
- Log ----------------------------------------------------------------- commit cc040a9bd824f7d0dd1abf4940dff44fe71500f9 Author: David Mitchell <[email protected]> Date: Sun Jul 3 22:19:26 2016 +0100 Revert "FREETMPS when leaving eval, even when void/dying" This reverts commit 214949f5cdc4164f25e32c1a6ce989286456c205. It breaks Variable::Magic. Temporarily revert while we work out what to do. ----------------------------------------------------------------------- Summary of changes: pp_ctl.c | 38 ++++---------------------------------- t/op/eval.t | 34 +--------------------------------- 2 files changed, 5 insertions(+), 67 deletions(-) diff --git a/pp_ctl.c b/pp_ctl.c index 3c20f88..5a66e26 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -1598,7 +1598,7 @@ Perl_qerror(pTHX_ SV *err) static void S_pop_eval_context_maybe_croak(pTHX_ PERL_CONTEXT *cx, SV *errsv, int action) { - SV *namesv = NULL; /* just to silence compiler warnings */ + SV *namesv; bool do_croak; CX_LEAVE_SCOPE(cx); @@ -1654,13 +1654,7 @@ Perl_die_unwind(pTHX_ SV *msv) 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)); + exceptsv = sv_2mortal(SvREFCNT_inc_simple_NN(exceptsv)); /* * Historically, perl used to set ERRSV ($@) early in the die @@ -1729,24 +1723,6 @@ 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 @@ -4329,11 +4305,8 @@ 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); @@ -4422,11 +4395,8 @@ 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 bb31f83..7b9fb17 100644 --- a/t/op/eval.t +++ b/t/op/eval.t @@ -6,7 +6,7 @@ BEGIN { set_up_inc('../lib'); } -plan(tests => 140); +plan(tests => 134); eval 'pass();'; @@ -665,35 +665,3 @@ 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
