register REGEXP * const rx = cx->sb_rx;
SV *nsv = NULL;
REGEXP *old = PM_GETRE(pm);
+
+ PERL_ASYNC_CHECK();
+
if(old != rx) {
if(old)
ReREFCNT_dec(old);
{
const char *cx_label = CxLABEL(cx);
if (!cx_label || strNE(label, cx_label) ) {
- DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
+ DEBUG_l(Perl_deb(aTHX_ "(poptolabel(): skipping label at cx=%ld %s)\n",
(long)i, cx_label));
continue;
}
- DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
+ DEBUG_l( Perl_deb(aTHX_ "(poptolabel(): found label at cx=%ld %s)\n", (long)i, label));
return i;
}
}
case CXt_EVAL:
case CXt_SUB:
case CXt_FORMAT:
- DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
+ DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
return i;
}
}
default:
continue;
case CXt_EVAL:
- DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
+ DEBUG_l( Perl_deb(aTHX_ "(dopoptoeval(): found eval at cx=%ld)\n", (long)i));
return i;
}
}
case CXt_LOOP_LAZYSV:
case CXt_LOOP_FOR:
case CXt_LOOP_PLAIN:
- DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
+ DEBUG_l( Perl_deb(aTHX_ "(dopoptoloop(): found loop at cx=%ld)\n", (long)i));
return i;
}
}
default:
continue;
case CXt_GIVEN:
- DEBUG_l( Perl_deb(aTHX_ "(Found given #%ld)\n", (long)i));
+ DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found given at cx=%ld)\n", (long)i));
return i;
case CXt_LOOP_PLAIN:
assert(!CxFOREACHDEF(cx));
case CXt_LOOP_LAZYSV:
case CXt_LOOP_FOR:
if (CxFOREACHDEF(cx)) {
- DEBUG_l( Perl_deb(aTHX_ "(Found foreach #%ld)\n", (long)i));
+ DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found foreach at cx=%ld)\n", (long)i));
return i;
}
}
default:
continue;
case CXt_WHEN:
- DEBUG_l( Perl_deb(aTHX_ "(Found when #%ld)\n", (long)i));
+ DEBUG_l( Perl_deb(aTHX_ "(dopoptowhen(): found when at cx=%ld)\n", (long)i));
return i;
}
}
while (cxstack_ix > cxix) {
SV *sv;
register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
- DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
- (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
+ DEBUG_CX("UNWIND"); \
/* Note: we don't need to restore the base context info till the end. */
switch (CxTYPE(cx)) {
case CXt_SUBST:
SV * const nsv = cx->blk_eval.old_namesv;
(void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
&PL_sv_undef, 0);
+ /* note that unlike pp_entereval, pp_require isn't
+ * supposed to trap errors. So now that we've popped the
+ * EVAL that pp_require pushed, and processed the error
+ * message, rethrow the error */
DIE(aTHX_ "%sCompilation failed in require",
*msg ? msg : "Unknown error\n");
}
PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
FREETMPS;
+ PERL_ASYNC_CHECK();
+
if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
|| SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
{
else
label = cPVOP->op_pv;
+ PERL_ASYNC_CHECK();
+
if (label && *label) {
OP *gotoprobe = NULL;
bool leaving_eval = FALSE;
}
+/* Run yyparse() in a setjmp wrapper. Returns:
+ * 0: yyparse() successful
+ * 1: yyparse() failed
+ * 3: yyparse() died
+ */
+STATIC int
+S_try_yyparse(pTHX)
+{
+ int ret;
+ dJMPENV;
+
+ assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
+ JMPENV_PUSH(ret);
+ switch (ret) {
+ case 0:
+ ret = yyparse() ? 1 : 0;
+ break;
+ case 3:
+ break;
+ default:
+ JMPENV_POP;
+ JMPENV_JUMP(ret);
+ /* NOTREACHED */
+ }
+ JMPENV_POP;
+ return ret;
+}
+
+
/* Compile a require/do, an eval '', or a /(?{...})/.
* In the last case, startop is non-null, and contains the address of
* a pointer that should be set to the just-compiled code.
{
dVAR; dSP;
OP * const saveop = PL_op;
+ bool in_require = (saveop && saveop->op_type == OP_REQUIRE);
+ int yystatus;
- PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
+ PL_in_eval = (in_require
? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
: EVAL_INEVAL);
PL_in_eval |= EVAL_KEEPERR;
else
CLEAR_ERRSV();
- if (yyparse() || PL_parser->error_count || !PL_eval_root) {
+
+ /* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
+ * so honour CATCH_GET and trap it here if necessary */
+
+ yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX) : yyparse();
+
+ if (yystatus || PL_parser->error_count || !PL_eval_root) {
SV **newsp; /* Used by POPBLOCK. */
PERL_CONTEXT *cx = &cxstack[cxstack_ix];
- I32 optype = 0; /* Might be reset by POPEVAL. */
+ I32 optype; /* Used by POPEVAL. */
const char *msg;
+ PERL_UNUSED_VAR(newsp);
+ PERL_UNUSED_VAR(optype);
+
PL_op = saveop;
if (PL_eval_root) {
op_free(PL_eval_root);
PL_eval_root = NULL;
}
- SP = PL_stack_base + POPMARK; /* pop original mark */
- if (!startop) {
- POPBLOCK(cx,PL_curpm);
- POPEVAL(cx);
+ if (yystatus != 3) {
+ SP = PL_stack_base + POPMARK; /* pop original mark */
+ if (!startop) {
+ POPBLOCK(cx,PL_curpm);
+ POPEVAL(cx);
+ }
}
lex_end();
- LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE. */
+ if (yystatus != 3)
+ LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE. */
msg = SvPVx_nolen_const(ERRSV);
- if (optype == OP_REQUIRE) {
+ if (in_require) {
const SV * const nsv = cx->blk_eval.old_namesv;
(void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
&PL_sv_undef, 0);
*msg ? msg : "Unknown error\n");
}
else if (startop) {
- POPBLOCK(cx,PL_curpm);
- POPEVAL(cx);
+ if (yystatus != 3) {
+ POPBLOCK(cx,PL_curpm);
+ POPEVAL(cx);
+ }
Perl_croak(aTHX_ "%sCompilation failed in regexp",
(*msg ? msg : "Unknown error\n"));
}
sv_setpvs(ERRSV, "Compilation error");
}
}
- PERL_UNUSED_VAR(newsp);
PUSHs(&PL_sv_undef);
PUTBACK;
return FALSE;
if (PL_compiling.cop_hints_hash) {
Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
}
- PL_compiling.cop_hints_hash = PL_curcop->cop_hints_hash;
+ if (Perl_fetch_cop_label(aTHX_ PL_curcop->cop_hints_hash, NULL, NULL)) {
+ /* The label, if present, is the first entry on the chain. So rather
+ than writing a blank label in front of it (which involves an
+ allocation), just use the next entry in the chain. */
+ PL_compiling.cop_hints_hash
+ = PL_curcop->cop_hints_hash->refcounted_he_next;
+ /* Check the assumption that this removed the label. */
+ assert(Perl_fetch_cop_label(aTHX_ PL_compiling.cop_hints_hash, NULL,
+ NULL) == NULL);
+ }
+ else
+ PL_compiling.cop_hints_hash = PL_curcop->cop_hints_hash;
if (PL_compiling.cop_hints_hash) {
HINTS_REFCNT_LOCK;
PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
https://perl5.git.perl.org / perl5.git / blobdiff