In perl.git, the branch blead has been updated
<http://perl5.git.perl.org/perl.git/commitdiff/d7e3f70f30811328d2f6ae57e5892deccf64d0b2?hp=4e1ed312da261450ba45a56e7b6756a873678f52>
- Log -----------------------------------------------------------------
commit d7e3f70f30811328d2f6ae57e5892deccf64d0b2
Author: Zefram <zef...@fysh.org>
Date: Sun Mar 26 21:53:29 2017 +0100
set up catchable runloops early enough
The jmpenv frame to catch Perl exceptions is set up lazily, and this used
to be a bit too lazy. The flow of control through pp_entereval had a gap
where the eval frame was on the context stack but the catcher hadn't been
set up, and it was possible for an exception to occur in that gap and be
signalled through unwinding, which would thus break. Specifically this
occurred if the code being evaluated died in a UNITCHECK block, because
doeval_compile() invokes those blocks with no special arrangements for
exceptions, whereas it handles compilation/BEGIN exceptions by means
that don't unwind.
This patch sets up the catcher earlier, before putting the eval frame
on the context stack. This change is made to entereval, entertry,
and require, the three ops that set up real eval frames. In each case,
whereas previously the catcher was interposed last thing before handing
off to the following op, the catcher is now set up first thing in the
pp function, with docatch() now recursively invoking the pp function.
Fixes [perl #105930].
-----------------------------------------------------------------------
Summary of changes:
MANIFEST | 1 +
embed.fnc | 2 +-
pp_ctl.c | 65 +++++++++++++++++++++++++++++++++++++-----------------------
proto.h | 2 +-
t/op/catch.t | 50 ++++++++++++++++++++++++++++++++++++++++++++++
5 files changed, 93 insertions(+), 27 deletions(-)
create mode 100644 t/op/catch.t
diff --git a/MANIFEST b/MANIFEST
index a54b1d88d8..295875012e 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -5522,6 +5522,7 @@ t/op/blocks.t See if BEGIN and
friends work
t/op/bop.t See if bitops work
t/op/caller.pl Tests shared between caller.t and XS op.t
t/op/caller.t See if caller() works
+t/op/catch.t See if catching exception works
t/op/chars.t See if character escapes work
t/op/chdir.t See if chdir works
t/op/chop.t See if chop works
diff --git a/embed.fnc b/embed.fnc
index d3aec2666a..1314504502 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -2203,7 +2203,7 @@ snR |char * |my_bytes_to_utf8|NN const U8
*start|STRLEN len|NN char *dest \
#endif
#if defined(PERL_IN_PP_CTL_C)
-sR |OP* |docatch |NULLOK OP *o
+sR |OP* |docatch |Perl_ppaddr_t firstpp
sR |OP* |dofindlabel |NN OP *o|NN const char *label|STRLEN len \
|U32 flags|NN OP **opstack|NN OP **oplimit
s |MAGIC *|doparseform |NN SV *sv
diff --git a/pp_ctl.c b/pp_ctl.c
index e75e151f81..e24d7b6019 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -34,7 +34,8 @@
#define PERL_IN_PP_CTL_C
#include "perl.h"
-#define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
+#define RUN_PP_CATCHABLY(thispp) \
+ STMT_START { if (CATCH_GET) return docatch(thispp); } STMT_END
#define dopoptosub(plop) dopoptosub_at(cxstack, (plop))
@@ -3159,23 +3160,18 @@ establish a local jmpenv to handle exception traps.
=cut
*/
STATIC OP *
-S_docatch(pTHX_ OP *o)
+S_docatch(pTHX_ Perl_ppaddr_t firstpp)
{
int ret;
OP * const oldop = PL_op;
dJMPENV;
-#ifdef DEBUGGING
assert(CATCH_GET == TRUE);
-#endif
- PL_op = o;
JMPENV_PUSH(ret);
switch (ret) {
case 0:
- assert(cxstack_ix >= 0);
- assert(CxTYPE(CX_CUR()) == CXt_EVAL);
- CX_CUR()->blk_eval.cur_top_env = PL_top_env;
+ PL_op = firstpp(aTHX);
redo_body:
CALLRUNOPS(aTHX);
break;
@@ -4227,6 +4223,7 @@ S_require_file(pTHX_ SV *sv)
}
/* switch to eval mode */
+ assert(!CATCH_GET);
cx = cx_pushblock(CXt_EVAL, gimme, SP, old_savestack_ix);
cx_pusheval(cx, PL_op->op_next, newSVpv(name, 0));
@@ -4236,7 +4233,7 @@ S_require_file(pTHX_ SV *sv)
PUTBACK;
if (doeval_compile(gimme, NULL, PL_curcop->cop_seq, NULL))
- op = DOCATCH(PL_eval_start);
+ op = PL_eval_start;
else
op = PL_op->op_next;
@@ -4250,13 +4247,17 @@ S_require_file(pTHX_ SV *sv)
PP(pp_require)
{
- dSP;
- SV *sv = POPs;
- SvGETMAGIC(sv);
- PUTBACK;
- return ((SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE)
- ? S_require_version(aTHX_ sv)
- : S_require_file(aTHX_ sv);
+ RUN_PP_CATCHABLY(Perl_pp_require);
+
+ {
+ dSP;
+ SV *sv = POPs;
+ SvGETMAGIC(sv);
+ PUTBACK;
+ return ((SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE)
+ ? S_require_version(aTHX_ sv)
+ : S_require_file(aTHX_ sv);
+ }
}
@@ -4277,18 +4278,28 @@ PP(pp_entereval)
dSP;
PERL_CONTEXT *cx;
SV *sv;
- const U8 gimme = GIMME_V;
- const U32 was = PL_breakable_sub_gen;
+ U8 gimme;
+ U32 was;
char tbuf[TYPE_DIGITS(long) + 12];
- bool saved_delete = FALSE;
- char *tmpbuf = tbuf;
+ bool saved_delete;
+ char *tmpbuf;
STRLEN len;
CV* runcv;
- U32 seq, lex_flags = 0;
- HV *saved_hh = NULL;
- const bool bytes = PL_op->op_private & OPpEVAL_BYTES;
+ U32 seq, lex_flags;
+ HV *saved_hh;
+ bool bytes;
I32 old_savestack_ix;
+ RUN_PP_CATCHABLY(Perl_pp_entereval);
+
+ gimme = GIMME_V;
+ was = PL_breakable_sub_gen;
+ saved_delete = FALSE;
+ tmpbuf = tbuf;
+ lex_flags = 0;
+ saved_hh = NULL;
+ bytes = PL_op->op_private & OPpEVAL_BYTES;
+
if (PL_op->op_private & OPpEVAL_HAS_HH) {
saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
}
@@ -4356,6 +4367,7 @@ PP(pp_entereval)
* to do the dirty work for us */
runcv = find_runcv(&seq);
+ assert(!CATCH_GET);
cx = cx_pushblock((CXt_EVAL|CXp_REAL), gimme, SP, old_savestack_ix);
cx_pusheval(cx, PL_op->op_next, NULL);
@@ -4385,7 +4397,7 @@ PP(pp_entereval)
char *const safestr = savepvn(tmpbuf, len);
SAVEDELETE(PL_defstash, safestr, len);
}
- return DOCATCH(PL_eval_start);
+ return PL_eval_start;
} else {
/* We have already left the scope set up earlier thanks to the LEAVE
in doeval_compile(). */
@@ -4496,8 +4508,11 @@ Perl_create_eval_scope(pTHX_ OP *retop, U32 flags)
PP(pp_entertry)
{
+ RUN_PP_CATCHABLY(Perl_pp_entertry);
+
+ assert(!CATCH_GET);
create_eval_scope(cLOGOP->op_other->op_next, 0);
- return DOCATCH(PL_op->op_next);
+ return PL_op->op_next;
}
diff --git a/proto.h b/proto.h
index e129449a4a..7b5b4bc3d0 100644
--- a/proto.h
+++ b/proto.h
@@ -4843,7 +4843,7 @@ STATIC void S_destroy_matcher(pTHX_ PMOP* matcher);
#define PERL_ARGS_ASSERT_DESTROY_MATCHER \
assert(matcher)
STATIC OP* S_do_smartmatch(pTHX_ HV* seen_this, HV* seen_other, const bool
copied);
-STATIC OP* S_docatch(pTHX_ OP *o)
+STATIC OP* S_docatch(pTHX_ Perl_ppaddr_t firstpp)
__attribute__warn_unused_result__;
STATIC bool S_doeval_compile(pTHX_ U8 gimme, CV* outside, U32 seq, HV* hh);
diff --git a/t/op/catch.t b/t/op/catch.t
new file mode 100644
index 0000000000..2ed6a16d9b
--- /dev/null
+++ b/t/op/catch.t
@@ -0,0 +1,50 @@
+#!perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ require './test.pl';
+ set_up_inc('../lib');
+}
+
+use warnings;
+use strict;
+
+plan 12;
+
+{
+ package EvalOnFetch;
+ sub TIESCALAR { bless \(my $z = $_[1]), $_[0] }
+ sub FETCH { eval ${$_[0]} // "died" }
+}
+
+tie my $begindie, "EvalOnFetch", "BEGIN { die } 123";
+is "$begindie", "died";
+tie my $unitcheckdie, "EvalOnFetch", "UNITCHECK { die } 123";
+is "$unitcheckdie", "died";
+tie my $rundie, "EvalOnFetch", "die; 123";
+is "$rundie", "died";
+tie my $runok, "EvalOnFetch", "123";
+is "$runok", 123;
+
+eval { undef };
+is eval "BEGIN { die } 123", undef;
+is eval "UNITCHECK { die } 123", undef;
+is eval "die; 123", undef;
+is eval "123", 123;
+
+{
+ package TryOnFetch;
+ sub TIESCALAR { bless \(my $z = $_[1]), $_[0] }
+ sub FETCH { eval { ${$_[0]} ? die : undef; 123 } // "died" }
+}
+
+tie my $trydie, "TryOnFetch", 1;
+is "$trydie", "died";
+tie my $tryok, "TryOnFetch", 0;
+is "$tryok", 123;
+
+eval { undef };
+is do { eval { die; 123 } }, undef;
+is do { eval { undef; 123 } }, 123;
+
+1;
--
Perl5 Master Repository
