Change 30127 by [EMAIL PROTECTED] on 2007/02/05 11:57:18
Integrate:
[ 24361]
move the SETJMP exception-handing definitions from scope.h to cop.h
so that a JMPENV* entry can be added to struct block_eval
[ 24362]
Revert change #15705 (Core dump in 'leavetry')
This fixes bug #34682, reintroduces bug #8738 (ID 20020301.011),
and reintroduces an eval optimisation for innter runops levels
[ 24363]
Better fix for #8738 (Core dump in 'leavetry')
When in an inner runops loop (eg via a tie or sort), an eval
needs a new JMPENV pushing by S_docatch. If an exception is raised,
control is returned to S_docatch, and it must determine whether
the eval that trapped the exception is an inner eval or an outer
one. In the former case, restart the loop, in the latter case,
rethrow the exception. This is determined by whether we are still
at the same PL_curstackinfo level. This fails in the case of
SPLICE(), which pushes a new SETJMP and runops level, but not a
new stackinfo level. There may be other code which does similar.
The solution is to store the current value of PL_top_env in each
pushed CxEVAL, and see if it's still the same as PL_top_env when
the exception is handled.
[ 24387]
add test for [perl #34682] leaving eval via last in inner runops
Affected files ...
... //depot/maint-5.8/perl/cop.h#33 edit
... //depot/maint-5.8/perl/pp_ctl.c#170 edit
... //depot/maint-5.8/perl/scope.h#27 integrate
... //depot/maint-5.8/perl/t/op/eval.t#8 integrate
Differences ...
==== //depot/maint-5.8/perl/cop.h#33 (text) ====
Index: perl/cop.h
--- perl/cop.h#32~29993~ 2007-01-26 01:15:17.000000000 -0800
+++ perl/cop.h 2007-02-05 03:57:18.000000000 -0800
@@ -13,6 +13,205 @@
* and thus can be used to determine our current state.
*/
+/* A jmpenv packages the state required to perform a proper non-local jump.
+ * Note that there is a start_env initialized when perl starts, and top_env
+ * points to this initially, so top_env should always be non-null.
+ *
+ * Existence of a non-null top_env->je_prev implies it is valid to call
+ * longjmp() at that runlevel (we make sure start_env.je_prev is always
+ * null to ensure this).
+ *
+ * je_mustcatch, when set at any runlevel to TRUE, means eval ops must
+ * establish a local jmpenv to handle exception traps. Care must be taken
+ * to restore the previous value of je_mustcatch before exiting the
+ * stack frame iff JMPENV_PUSH was not called in that stack frame.
+ * GSAR 97-03-27
+ */
+
+struct jmpenv {
+ struct jmpenv * je_prev;
+ Sigjmp_buf je_buf; /* only for use if !je_throw */
+ int je_ret; /* last exception thrown */
+ bool je_mustcatch; /* need to call longjmp()? */
+#ifdef PERL_FLEXIBLE_EXCEPTIONS
+ void (*je_throw)(int v); /* last for bincompat */
+ bool je_noset; /* no need for setjmp() */
+#endif
+};
+
+typedef struct jmpenv JMPENV;
+
+#ifdef OP_IN_REGISTER
+#define OP_REG_TO_MEM PL_opsave = op
+#define OP_MEM_TO_REG op = PL_opsave
+#else
+#define OP_REG_TO_MEM NOOP
+#define OP_MEM_TO_REG NOOP
+#endif
+
+/*
+ * How to build the first jmpenv.
+ *
+ * top_env needs to be non-zero. It points to an area
+ * in which longjmp() stuff is stored, as C callstack
+ * info there at least is thread specific this has to
+ * be per-thread. Otherwise a 'die' in a thread gives
+ * that thread the C stack of last thread to do an eval {}!
+ */
+
+#define JMPENV_BOOTSTRAP \
+ STMT_START { \
+ Zero(&PL_start_env, 1, JMPENV); \
+ PL_start_env.je_ret = -1; \
+ PL_start_env.je_mustcatch = TRUE; \
+ PL_top_env = &PL_start_env; \
+ } STMT_END
+
+#ifdef PERL_FLEXIBLE_EXCEPTIONS
+
+/*
+ * These exception-handling macros are split up to
+ * ease integration with C++ exceptions.
+ *
+ * To use C++ try+catch to catch Perl exceptions, an extension author
+ * needs to first write an extern "C" function to throw an appropriate
+ * exception object; typically it will be or contain an integer,
+ * because Perl's internals use integers to track exception types:
+ * extern "C" { static void thrower(int i) { throw i; } }
+ *
+ * Then (as shown below) the author needs to use, not the simple
+ * JMPENV_PUSH, but several of its constitutent macros, to arrange for
+ * the Perl internals to call thrower() rather than longjmp() to
+ * report exceptions:
+ *
+ * dJMPENV;
+ * JMPENV_PUSH_INIT(thrower);
+ * try {
+ * ... stuff that may throw exceptions ...
+ * }
+ * catch (int why) { // or whatever matches thrower()
+ * JMPENV_POST_CATCH;
+ * EXCEPT_SET(why);
+ * switch (why) {
+ * ... // handle various Perl exception codes
+ * }
+ * }
+ * JMPENV_POP; // don't forget this!
+ */
+
+/*
+ * Function that catches/throws, and its callback for the
+ * body of protected processing.
+ */
+typedef void *(CPERLscope(*protect_body_t)) (pTHX_ va_list);
+typedef void *(CPERLscope(*protect_proc_t)) (pTHX_ volatile JMPENV *pcur_env,
+ int *, protect_body_t, ...);
+
+#define dJMPENV JMPENV cur_env; \
+ volatile JMPENV *pcur_env = ((cur_env.je_noset = 0),&cur_env)
+
+#define JMPENV_PUSH_INIT_ENV(ce,THROWFUNC) \
+ STMT_START { \
+ (ce).je_throw = (THROWFUNC); \
+ (ce).je_ret = -1; \
+ (ce).je_mustcatch = FALSE; \
+ (ce).je_prev = PL_top_env; \
+ PL_top_env = &(ce); \
+ OP_REG_TO_MEM; \
+ } STMT_END
+
+#define JMPENV_PUSH_INIT(THROWFUNC)
JMPENV_PUSH_INIT_ENV(*(JMPENV*)pcur_env,THROWFUNC)
+
+#define JMPENV_POST_CATCH_ENV(ce) \
+ STMT_START { \
+ OP_MEM_TO_REG; \
+ PL_top_env = &(ce); \
+ } STMT_END
+
+#define JMPENV_POST_CATCH JMPENV_POST_CATCH_ENV(*(JMPENV*)pcur_env)
+
+#define JMPENV_PUSH_ENV(ce,v) \
+ STMT_START { \
+ if (!(ce).je_noset) { \
+ DEBUG_l(Perl_deb(aTHX_ "Setting up jumplevel %p, was %p\n", \
+ (void*)ce, (void*)PL_top_env)); \
+ JMPENV_PUSH_INIT_ENV(ce,NULL); \
+ EXCEPT_SET_ENV(ce,PerlProc_setjmp((ce).je_buf,
SCOPE_SAVES_SIGNAL_MASK));\
+ (ce).je_noset = 1; \
+ } \
+ else \
+ EXCEPT_SET_ENV(ce,0); \
+ JMPENV_POST_CATCH_ENV(ce); \
+ (v) = EXCEPT_GET_ENV(ce); \
+ } STMT_END
+
+#define JMPENV_PUSH(v) JMPENV_PUSH_ENV(*(JMPENV*)pcur_env,v)
+
+#define JMPENV_POP_ENV(ce) \
+ STMT_START { \
+ if (PL_top_env == &(ce)) \
+ PL_top_env = (ce).je_prev; \
+ } STMT_END
+
+#define JMPENV_POP JMPENV_POP_ENV(*(JMPENV*)pcur_env)
+
+#define JMPENV_JUMP(v) \
+ STMT_START { \
+ OP_REG_TO_MEM; \
+ if (PL_top_env->je_prev) { \
+ if (PL_top_env->je_throw) \
+ PL_top_env->je_throw(v); \
+ else \
+ PerlProc_longjmp(PL_top_env->je_buf, (v)); \
+ } \
+ if ((v) == 2) \
+ PerlProc_exit(STATUS_EXIT); \
+ PerlIO_printf(Perl_error_log, "panic: top_env\n"); \
+ PerlProc_exit(1); \
+ } STMT_END
+
+#define EXCEPT_GET_ENV(ce) ((ce).je_ret)
+#define EXCEPT_GET EXCEPT_GET_ENV(*(JMPENV*)pcur_env)
+#define EXCEPT_SET_ENV(ce,v) ((ce).je_ret = (v))
+#define EXCEPT_SET(v) EXCEPT_SET_ENV(*(JMPENV*)pcur_env,v)
+
+#else /* !PERL_FLEXIBLE_EXCEPTIONS */
+
+#define dJMPENV JMPENV cur_env
+
+#define JMPENV_PUSH(v) \
+ STMT_START { \
+ DEBUG_l(Perl_deb(aTHX_ "Setting up jumplevel %p, was %p\n", \
+ (void*)&cur_env, (void*)PL_top_env)); \
+ cur_env.je_prev = PL_top_env; \
+ OP_REG_TO_MEM; \
+ cur_env.je_ret = PerlProc_setjmp(cur_env.je_buf,
SCOPE_SAVES_SIGNAL_MASK); \
+ OP_MEM_TO_REG; \
+ PL_top_env = &cur_env; \
+ cur_env.je_mustcatch = FALSE; \
+ (v) = cur_env.je_ret; \
+ } STMT_END
+
+#define JMPENV_POP \
+ STMT_START { PL_top_env = cur_env.je_prev; } STMT_END
+
+#define JMPENV_JUMP(v) \
+ STMT_START { \
+ OP_REG_TO_MEM; \
+ if (PL_top_env->je_prev) \
+ PerlProc_longjmp(PL_top_env->je_buf, (v)); \
+ if ((v) == 2) \
+ PerlProc_exit(STATUS_EXIT); \
+ PerlIO_printf(PerlIO_stderr(), "panic: top_env\n"); \
+ PerlProc_exit(1); \
+ } STMT_END
+
+#endif /* PERL_FLEXIBLE_EXCEPTIONS */
+
+#define CATCH_GET (PL_top_env->je_mustcatch)
+#define CATCH_SET(v) (PL_top_env->je_mustcatch = (v))
+
+
struct cop {
BASEOP
char * cop_label; /* label for this construct */
@@ -220,6 +419,7 @@
OP * old_eval_root;
SV * cur_text;
CV * cv;
+ JMPENV * cur_top_env; /* value of PL_top_env when eval CX created */
};
#define PUSHEVAL(cx,n,fgv) \
@@ -230,6 +430,7 @@
cx->blk_eval.old_eval_root = PL_eval_root; \
cx->blk_eval.cur_text = PL_linestr; \
cx->blk_eval.cv = NULL; /* set by doeval(), as applicable */ \
+ cx->blk_eval.cur_top_env = PL_top_env; \
} STMT_END
#define POPEVAL(cx) \
==== //depot/maint-5.8/perl/pp_ctl.c#170 (text) ====
Index: perl/pp_ctl.c
--- perl/pp_ctl.c#169~30099~ 2007-02-02 13:14:53.000000000 -0800
+++ perl/pp_ctl.c 2007-02-05 03:57:18.000000000 -0800
@@ -2566,8 +2566,6 @@
{
int ret;
OP * const oldop = PL_op;
- OP *retop;
- volatile PERL_SI *cursi = PL_curstackinfo;
dJMPENV;
#ifdef DEBUGGING
@@ -2575,14 +2573,6 @@
#endif
PL_op = o;
- /* Normally, the leavetry at the end of this block of ops will
- * pop an op off the return stack and continue there. By setting
- * the op to Nullop, we force an exit from the inner runops()
- * loop. DAPM.
- */
- retop = pop_return();
- push_return(Nullop);
-
#ifdef PERL_FLEXIBLE_EXCEPTIONS
redo_body:
CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vdocatch_body));
@@ -2591,6 +2581,7 @@
#endif
switch (ret) {
case 0:
+ cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
#ifndef PERL_FLEXIBLE_EXCEPTIONS
redo_body:
docatch_body();
@@ -2598,14 +2589,20 @@
break;
case 3:
/* die caught by an inner eval - continue inner loop */
- if (PL_restartop && cursi == PL_curstackinfo) {
+
+ /* NB XXX we rely on the old popped CxEVAL still being at the top
+ * of the stack; the way die_where() currently works, this
+ * assumption is valid. In theory The cur_top_env value should be
+ * returned in another global, the way retop (aka PL_restartop)
+ * is. */
+
+ if (PL_restartop
+ && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
+ {
PL_op = PL_restartop;
PL_restartop = 0;
goto redo_body;
}
- /* a die in this eval - continue in outer loop */
- if (!PL_restartop)
- break;
/* FALL THROUGH */
default:
JMPENV_POP;
@@ -2615,7 +2612,7 @@
}
JMPENV_POP;
PL_op = oldop;
- return retop;
+ return NULL;
}
OP *
@@ -3616,15 +3613,12 @@
dSP;
SV **newsp;
PMOP *newpm;
- OP* retop;
I32 gimme;
register PERL_CONTEXT *cx;
I32 optype;
POPBLOCK(cx,newpm);
POPEVAL(cx);
- retop = pop_return();
- PERL_UNUSED_VAR(optype);
TAINT_NOT;
if (gimme == G_VOID)
@@ -3658,7 +3652,7 @@
LEAVE;
sv_setpvn(ERRSV,"",0);
- RETURNOP(retop);
+ RETURN;
}
STATIC OP *
==== //depot/maint-5.8/perl/scope.h#27 (text) ====
Index: perl/scope.h
--- perl/scope.h#26~30118~ 2007-02-04 11:27:45.000000000 -0800
+++ perl/scope.h 2007-02-05 03:57:18.000000000 -0800
@@ -233,205 +233,3 @@
#define SSPTR(off,type) ((type) ((char*)PL_savestack + off))
#define SSPTRt(off,type) ((type*) ((char*)PL_savestack + off))
-
-/* A jmpenv packages the state required to perform a proper non-local jump.
- * Note that there is a start_env initialized when perl starts, and top_env
- * points to this initially, so top_env should always be non-null.
- *
- * Existence of a non-null top_env->je_prev implies it is valid to call
- * longjmp() at that runlevel (we make sure start_env.je_prev is always
- * null to ensure this).
- *
- * je_mustcatch, when set at any runlevel to TRUE, means eval ops must
- * establish a local jmpenv to handle exception traps. Care must be taken
- * to restore the previous value of je_mustcatch before exiting the
- * stack frame iff JMPENV_PUSH was not called in that stack frame.
- * GSAR 97-03-27
- */
-
-struct jmpenv {
- struct jmpenv * je_prev;
- Sigjmp_buf je_buf; /* only for use if !je_throw */
- int je_ret; /* last exception thrown */
- bool je_mustcatch; /* need to call longjmp()? */
-#ifdef PERL_FLEXIBLE_EXCEPTIONS
- void (*je_throw)(int v); /* last for bincompat */
- bool je_noset; /* no need for setjmp() */
-#endif
-};
-
-typedef struct jmpenv JMPENV;
-
-#ifdef OP_IN_REGISTER
-#define OP_REG_TO_MEM PL_opsave = op
-#define OP_MEM_TO_REG op = PL_opsave
-#else
-#define OP_REG_TO_MEM NOOP
-#define OP_MEM_TO_REG NOOP
-#endif
-
-/*
- * How to build the first jmpenv.
- *
- * top_env needs to be non-zero. It points to an area
- * in which longjmp() stuff is stored, as C callstack
- * info there at least is thread specific this has to
- * be per-thread. Otherwise a 'die' in a thread gives
- * that thread the C stack of last thread to do an eval {}!
- */
-
-#define JMPENV_BOOTSTRAP \
- STMT_START { \
- Zero(&PL_start_env, 1, JMPENV); \
- PL_start_env.je_ret = -1; \
- PL_start_env.je_mustcatch = TRUE; \
- PL_top_env = &PL_start_env; \
- } STMT_END
-
-#ifdef PERL_FLEXIBLE_EXCEPTIONS
-
-/*
- * These exception-handling macros are split up to
- * ease integration with C++ exceptions.
- *
- * To use C++ try+catch to catch Perl exceptions, an extension author
- * needs to first write an extern "C" function to throw an appropriate
- * exception object; typically it will be or contain an integer,
- * because Perl's internals use integers to track exception types:
- * extern "C" { static void thrower(int i) { throw i; } }
- *
- * Then (as shown below) the author needs to use, not the simple
- * JMPENV_PUSH, but several of its constitutent macros, to arrange for
- * the Perl internals to call thrower() rather than longjmp() to
- * report exceptions:
- *
- * dJMPENV;
- * JMPENV_PUSH_INIT(thrower);
- * try {
- * ... stuff that may throw exceptions ...
- * }
- * catch (int why) { // or whatever matches thrower()
- * JMPENV_POST_CATCH;
- * EXCEPT_SET(why);
- * switch (why) {
- * ... // handle various Perl exception codes
- * }
- * }
- * JMPENV_POP; // don't forget this!
- */
-
-/*
- * Function that catches/throws, and its callback for the
- * body of protected processing.
- */
-typedef void *(CPERLscope(*protect_body_t)) (pTHX_ va_list);
-typedef void *(CPERLscope(*protect_proc_t)) (pTHX_ volatile JMPENV *pcur_env,
- int *, protect_body_t, ...);
-
-#define dJMPENV JMPENV cur_env; \
- volatile JMPENV *pcur_env = ((cur_env.je_noset = 0),&cur_env)
-
-#define JMPENV_PUSH_INIT_ENV(ce,THROWFUNC) \
- STMT_START { \
- (ce).je_throw = (THROWFUNC); \
- (ce).je_ret = -1; \
- (ce).je_mustcatch = FALSE; \
- (ce).je_prev = PL_top_env; \
- PL_top_env = &(ce); \
- OP_REG_TO_MEM; \
- } STMT_END
-
-#define JMPENV_PUSH_INIT(THROWFUNC)
JMPENV_PUSH_INIT_ENV(*(JMPENV*)pcur_env,THROWFUNC)
-
-#define JMPENV_POST_CATCH_ENV(ce) \
- STMT_START { \
- OP_MEM_TO_REG; \
- PL_top_env = &(ce); \
- } STMT_END
-
-#define JMPENV_POST_CATCH JMPENV_POST_CATCH_ENV(*(JMPENV*)pcur_env)
-
-#define JMPENV_PUSH_ENV(ce,v) \
- STMT_START { \
- if (!(ce).je_noset) { \
- DEBUG_l(Perl_deb(aTHX_ "Setting up jumplevel %p, was %p\n", \
- (void*)ce, (void*)PL_top_env)); \
- JMPENV_PUSH_INIT_ENV(ce,NULL); \
- EXCEPT_SET_ENV(ce,PerlProc_setjmp((ce).je_buf,
SCOPE_SAVES_SIGNAL_MASK));\
- (ce).je_noset = 1; \
- } \
- else \
- EXCEPT_SET_ENV(ce,0); \
- JMPENV_POST_CATCH_ENV(ce); \
- (v) = EXCEPT_GET_ENV(ce); \
- } STMT_END
-
-#define JMPENV_PUSH(v) JMPENV_PUSH_ENV(*(JMPENV*)pcur_env,v)
-
-#define JMPENV_POP_ENV(ce) \
- STMT_START { \
- if (PL_top_env == &(ce)) \
- PL_top_env = (ce).je_prev; \
- } STMT_END
-
-#define JMPENV_POP JMPENV_POP_ENV(*(JMPENV*)pcur_env)
-
-#define JMPENV_JUMP(v) \
- STMT_START { \
- OP_REG_TO_MEM; \
- if (PL_top_env->je_prev) { \
- if (PL_top_env->je_throw) \
- PL_top_env->je_throw(v); \
- else \
- PerlProc_longjmp(PL_top_env->je_buf, (v)); \
- } \
- if ((v) == 2) \
- PerlProc_exit(STATUS_EXIT); \
- PerlIO_printf(Perl_error_log, "panic: top_env\n"); \
- PerlProc_exit(1); \
- } STMT_END
-
-#define EXCEPT_GET_ENV(ce) ((ce).je_ret)
-#define EXCEPT_GET EXCEPT_GET_ENV(*(JMPENV*)pcur_env)
-#define EXCEPT_SET_ENV(ce,v) ((ce).je_ret = (v))
-#define EXCEPT_SET(v) EXCEPT_SET_ENV(*(JMPENV*)pcur_env,v)
-
-#else /* !PERL_FLEXIBLE_EXCEPTIONS */
-
-#define dJMPENV JMPENV cur_env
-
-#define JMPENV_PUSH(v) \
- STMT_START { \
- DEBUG_l(Perl_deb(aTHX_ "Setting up jumplevel %p, was %p\n", \
- (void*)&cur_env, (void*)PL_top_env)); \
- cur_env.je_prev = PL_top_env; \
- OP_REG_TO_MEM; \
- cur_env.je_ret = PerlProc_setjmp(cur_env.je_buf,
SCOPE_SAVES_SIGNAL_MASK); \
- OP_MEM_TO_REG; \
- PL_top_env = &cur_env; \
- cur_env.je_mustcatch = FALSE; \
- (v) = cur_env.je_ret; \
- } STMT_END
-
-#define JMPENV_POP \
- STMT_START { \
- DEBUG_l(Perl_deb(aTHX_ "popping jumplevel was %p, now %p\n", \
- PL_top_env, cur_env.je_prev)); \
- PL_top_env = cur_env.je_prev; \
- } STMT_END
-
-#define JMPENV_JUMP(v) \
- STMT_START { \
- OP_REG_TO_MEM; \
- if (PL_top_env->je_prev) \
- PerlProc_longjmp(PL_top_env->je_buf, (v)); \
- if ((v) == 2) \
- PerlProc_exit(STATUS_EXIT); \
- PerlIO_printf(PerlIO_stderr(), "panic: top_env\n"); \
- PerlProc_exit(1); \
- } STMT_END
-
-#endif /* PERL_FLEXIBLE_EXCEPTIONS */
-
-#define CATCH_GET (PL_top_env->je_mustcatch)
-#define CATCH_SET(v) (PL_top_env->je_mustcatch = (v))
==== //depot/maint-5.8/perl/t/op/eval.t#8 (xtext) ====
Index: perl/t/op/eval.t
--- perl/t/op/eval.t#7~30098~ 2007-02-02 12:54:46.000000000 -0800
+++ perl/t/op/eval.t 2007-02-05 03:57:18.000000000 -0800
@@ -5,7 +5,7 @@
@INC = '../lib';
}
-print "1..92\n";
+print "1..93\n";
eval 'print "ok 1\n";';
@@ -438,6 +438,17 @@
eval $code;
print $c eq 'V' ? "ok " : "# '$c' ne 'V'\nnot ok ", $test++, "\n";
}
+
+# [perl #34682] escaping an eval with last could coredump or dup output
+
+$got = runperl (
+ prog =>
+ 'sub A::TIEARRAY { L: { eval { last L } } } tie @a, A; warn qq(ok\n)',
+stderr => 1);
+
+print "not " unless $got eq "ok\n";
+print "ok $test - eval and last\n"; $test++;
+
# eval undef should be the same as eval "" barring any warnings
{
End of Patch.
