#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))
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
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
=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;
SSize_t i;
SV *const msg = newSVpvs_flags("", SVs_TEMP);
SV *const inc = newSVpvs_flags("", SVs_TEMP);
+ const char *e = name + len - 3; /* possible .pm */
for (i = 0; i <= AvFILL(ar); i++) {
sv_catpvs(inc, " ");
sv_catsv(inc, *av_fetch(ar, i, TRUE));
}
- if (len >= 4 && memEQ(name + len - 3, ".pm", 4)) {
- const char *c, *e = name + len - 3;
- sv_catpv(msg, " (you may need to install the ");
- for (c = name; c < e; c++) {
- if (*c == '/') {
- sv_catpvs(msg, "::");
- }
- else {
- sv_catpvn(msg, c, 1);
- }
- }
- sv_catpv(msg, " module)");
+ if (e > name && _memEQs(e, ".pm")) {
+ const char *c;
+ bool utf8 = cBOOL(SvUTF8(sv));
+
+ /* if the filename, when converted from "Foo/Bar.pm"
+ * form back to Foo::Bar form, makes a valid
+ * package name (i.e. parseable by C<require
+ * Foo::Bar>), then emit a hint.
+ *
+ * this loop is modelled after the one in
+ S_parse_ident */
+ c = name;
+ while (c < e) {
+ if (utf8 && isIDFIRST_utf8_safe(c, e)) {
+ c += UTF8SKIP(c);
+ while (c < e && isIDCONT_utf8_safe(
+ (const U8*) c, (const U8*) e))
+ c += UTF8SKIP(c);
+ }
+ else if (isWORDCHAR_A(*c)) {
+ while (c < e && isWORDCHAR_A(*c))
+ c++;
+ }
+ else if (*c == '/')
+ c++;
+ else
+ break;
+ }
+
+ if (c == e && isIDFIRST_lazy_if_safe(name, e, utf8)) {
+ sv_catpv(msg, " (you may need to install the ");
+ for (c = name; c < e; c++) {
+ if (*c == '/') {
+ sv_catpvs(msg, "::");
+ }
+ else {
+ sv_catpvn(msg, c, 1);
+ }
+ }
+ sv_catpv(msg, " module)");
+ }
}
else if (len >= 2 && memEQ(name + len - 2, ".h", 3)) {
sv_catpv(msg, " (change .h to .ph maybe?) (did you run h2ph?)");
}
/* 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));
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;
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);
+ }
}
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));
}
* 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);
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(). */
? 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);
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;
}
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);
https://perl5.git.perl.org / perl5.git / blobdiff