From: Zefram Date: Tue, 20 Apr 2010 20:32:53 +0000 (+0100) Subject: make die reliably hand error to post-eval code X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=96d9b9cd40f1d98fda790eb12b5cdbeef8b48a81;p=p5sagit%2Fp5-mst-13.2.git make die reliably hand error to post-eval code Put the exception into $@ last thing before longjmping to the op following the eval block, where previously it went into $@ before unwinding the stack. This change means that the exception is not liable to be lost by $@ being clobbered by destructors, cleanup code, or restoration after "local $@". The code running immediately after eval can now rely on $@ accurately indicating the exception status of the eval. --- diff --git a/MANIFEST b/MANIFEST index 5ca4f13..6ae1626 100644 --- a/MANIFEST +++ b/MANIFEST @@ -4386,6 +4386,7 @@ t/op/crypt.t See if crypt works t/op/dbm.t See if dbmopen/dbmclose work t/op/defins.t See if auto-insert of defined() works t/op/delete.t See if delete works +t/op/die_except.t See if die/eval avoids $@ clobberage t/op/die_exit.t See if die and exit status interaction works t/op/die.t See if die works t/op/dor.t See if defined-or (//) works diff --git a/pp_ctl.c b/pp_ctl.c index d62d58a..921688d 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -1575,45 +1575,13 @@ void Perl_die_where(pTHX_ SV *msv) { dVAR; + SV *exceptsv = sv_mortalcopy(msv ? msv : ERRSV); + U8 in_eval = PL_in_eval; - if (PL_in_eval) { + if (in_eval) { I32 cxix; I32 gimme; - if (msv) { - if (PL_in_eval & EVAL_KEEPERR) { - static const char prefix[] = "\t(in cleanup) "; - SV * const err = ERRSV; - const char *e = NULL; - if (!SvPOK(err)) - sv_setpvs(err,""); - else if (SvCUR(err) >= sizeof(prefix)+SvCUR(msv)-1) { - STRLEN len; - STRLEN msglen; - const char* message = SvPV_const(msv, msglen); - e = SvPV_const(err, len); - e += len - msglen; - if (*e != *message || strNE(e,message)) - e = NULL; - } - if (!e) { - STRLEN start; - SvGROW(err, SvCUR(err)+sizeof(prefix)+SvCUR(msv)); - sv_catpvn(err, prefix, sizeof(prefix)-1); - sv_catsv(err, msv); - start = SvCUR(err)-SvCUR(msv)-sizeof(prefix)+1; - Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "%s", - SvPVX_const(err)+start); - } - } - else { - STRLEN msglen; - const char* message = SvPV_const(msv, msglen); - sv_setpvn(ERRSV, message, msglen); - SvFLAGS(ERRSV) |= SvFLAGS(msv) & SVf_UTF8; - } - } - while ((cxix = dopoptoeval(cxstack_ix)) < 0 && PL_curstackinfo->si_prev) { @@ -1632,7 +1600,7 @@ Perl_die_where(pTHX_ SV *msv) POPBLOCK(cx,PL_curpm); if (CxTYPE(cx) != CXt_EVAL) { STRLEN msglen; - const char* message = SvPVx_const( msv ? msv : ERRSV, msglen); + const char* message = SvPVx_const(exceptsv, msglen); PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11); PerlIO_write(Perl_error_log, message, msglen); my_exit(1); @@ -1652,7 +1620,7 @@ Perl_die_where(pTHX_ SV *msv) PL_curcop = cx->blk_oldcop; if (optype == OP_REQUIRE) { - const char* const msg = SvPVx_nolen_const(ERRSV); + const char* const msg = SvPVx_nolen_const(exceptsv); SV * const nsv = cx->blk_eval.old_namesv; (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), &PL_sv_undef, 0); @@ -1663,6 +1631,34 @@ Perl_die_where(pTHX_ SV *msv) DIE(aTHX_ "%sCompilation failed in require", *msg ? msg : "Unknown error\n"); } + if ((in_eval & EVAL_KEEPERR) && msv) { + static const char prefix[] = "\t(in cleanup) "; + SV * const err = ERRSV; + const char *e = NULL; + if (!SvPOK(err)) + sv_setpvs(err,""); + else if (SvCUR(err) >= sizeof(prefix)+SvCUR(exceptsv)-1) { + STRLEN len; + STRLEN msglen; + const char* message = SvPV_const(exceptsv, msglen); + e = SvPV_const(err, len); + e += len - msglen; + if (*e != *message || strNE(e,message)) + e = NULL; + } + if (!e) { + STRLEN start; + SvGROW(err, SvCUR(err)+sizeof(prefix)+SvCUR(exceptsv)); + sv_catpvn(err, prefix, sizeof(prefix)-1); + sv_catsv(err, exceptsv); + start = SvCUR(err)-SvCUR(exceptsv)-sizeof(prefix)+1; + Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "%s", + SvPVX_const(err)+start); + } + } + else { + sv_setsv(ERRSV, exceptsv); + } assert(CxTYPE(cx) == CXt_EVAL); PL_restartop = cx->blk_eval.retop; JMPENV_JUMP(3); @@ -1670,7 +1666,7 @@ Perl_die_where(pTHX_ SV *msv) } } - write_to_stderr( msv ? msv : ERRSV ); + write_to_stderr(exceptsv); my_failure_exit(); /* NOTREACHED */ } diff --git a/t/op/die_except.t b/t/op/die_except.t new file mode 100644 index 0000000..b0fcadb --- /dev/null +++ b/t/op/die_except.t @@ -0,0 +1,81 @@ +#!./perl + +print "1..12\n"; +my $test_num = 0; +sub ok { + print $_[0] ? "" : "not ", "ok ", ++$test_num, "\n"; +} + +{ + package End; + sub DESTROY { $_[0]->() } + sub main::end(&) { + my($cleanup) = @_; + return bless(sub { $cleanup->() }, "End"); + } +} + +my($val, $err); + +$@ = "t0\n"; +$val = eval { + $@ = "t1\n"; + 1; +}; $err = $@; +ok $val == 1; +ok $err eq ""; + +$@ = "t0\n"; +$val = eval { + $@ = "t1\n"; + do { + die "t3\n"; + }; + 1; +}; $err = $@; +ok !defined($val); +ok $err eq "t3\n"; + +$@ = "t0\n"; +$val = eval { + $@ = "t1\n"; + local $@ = "t2\n"; + 1; +}; $err = $@; +ok $val == 1; +ok $err eq ""; + +$@ = "t0\n"; +$val = eval { + $@ = "t1\n"; + local $@ = "t2\n"; + do { + die "t3\n"; + }; + 1; +}; $err = $@; +ok !defined($val); +ok $err eq "t3\n"; + +$@ = "t0\n"; +$val = eval { + $@ = "t1\n"; + my $c = end { $@ = "t2\n"; }; + 1; +}; $err = $@; +ok $val == 1; +ok $err eq ""; + +$@ = "t0\n"; +$val = eval { + $@ = "t1\n"; + my $c = end { $@ = "t2\n"; }; + do { + die "t3\n"; + }; + 1; +}; $err = $@; +ok !defined($val); +ok $err eq "t3\n"; + +1; diff --git a/t/op/eval.t b/t/op/eval.t index 98fbc1e..ff5004e 100644 --- a/t/op/eval.t +++ b/t/op/eval.t @@ -526,6 +526,8 @@ if (eval "use Devel::Peek; 1;") { my $in = ; my ($first, $second) = split (/\*\*\*\*\*\*\n/, $in, 2); $first =~ s/,pNOK//; + s/ PV = 0x[0-9a-f]+/ PV = 0x/ foreach $first, $second; + s/ LEN = [0-9]+/ LEN = / foreach $first, $second; $ok = 1 if ($first eq $second); } }