CX_LEAVE_SCOPE(cx);
POPSUBST(cx);
- cxstack_ix--;
+ CX_POP(cx);
PERL_ASYNC_CHECK();
RETURNOP(pm->op_next);
NULL, /* CXt_WHEN never actually needs "block" */
NULL, /* CXt_BLOCK never actually needs "block" */
NULL, /* CXt_GIVEN never actually needs "block" */
- NULL, /* CXt_LOOP_FOR never actually needs "loop" */
NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */
- NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */
NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */
+ NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */
+ NULL, /* CXt_LOOP_LIST never actually needs "loop" */
+ NULL, /* CXt_LOOP_ARY never actually needs "loop" */
"subroutine",
"format",
"eval",
if (CxTYPE(cx) == CXt_NULL) /* sort BLOCK */
return -1;
break;
+ case CXt_LOOP_PLAIN:
case CXt_LOOP_LAZYIV:
case CXt_LOOP_LAZYSV:
- case CXt_LOOP_FOR:
- case CXt_LOOP_PLAIN:
+ case CXt_LOOP_LIST:
+ case CXt_LOOP_ARY:
{
STRLEN cx_label_len = 0;
U32 cx_label_flags = 0;
if ((CxTYPE(cx)) == CXt_NULL) /* sort BLOCK */
return -1;
break;
+ case CXt_LOOP_PLAIN:
case CXt_LOOP_LAZYIV:
case CXt_LOOP_LAZYSV:
- case CXt_LOOP_FOR:
- case CXt_LOOP_PLAIN:
+ case CXt_LOOP_LIST:
+ case CXt_LOOP_ARY:
DEBUG_l( Perl_deb(aTHX_ "(dopoptoloop(): found loop at cx=%ld)\n", (long)i));
return i;
}
DEBUG_l( Perl_deb(aTHX_ "(dopoptogivenfor(): found given at cx=%ld)\n", (long)i));
return i;
case CXt_LOOP_PLAIN:
- assert(!CxFOREACHDEF(cx));
+ assert(!(cx->cx_type & CXp_FOR_DEF));
break;
case CXt_LOOP_LAZYIV:
case CXt_LOOP_LAZYSV:
- case CXt_LOOP_FOR:
- if (CxFOREACHDEF(cx)) {
+ case CXt_LOOP_LIST:
+ case CXt_LOOP_ARY:
+ if (cx->cx_type & CXp_FOR_DEF) {
DEBUG_l( Perl_deb(aTHX_ "(dopoptogivenfor(): found foreach at cx=%ld)\n", (long)i));
return i;
}
void
Perl_dounwind(pTHX_ I32 cxix)
{
- I32 optype;
-
if (!PL_curstackinfo) /* can happen if die during thread cloning */
return;
case CXt_BLOCK:
POPBASICBLK(cx);
break;
+ case CXt_LOOP_PLAIN:
case CXt_LOOP_LAZYIV:
case CXt_LOOP_LAZYSV:
- case CXt_LOOP_FOR:
- case CXt_LOOP_PLAIN:
+ case CXt_LOOP_LIST:
+ case CXt_LOOP_ARY:
POPLOOP(cx);
break;
case CXt_WHEN:
}
cxstack_ix--;
}
- PERL_UNUSED_VAR(optype);
}
void
++PL_parser->error_count;
}
+
+
+/* undef or delete the $INC{namesv} entry, then croak.
+ * require0 indicates that the require didn't return a true value */
+
+static void
+S_undo_inc_then_croak(pTHX_ SV *namesv, SV *err, bool require0)
+{
+ const char *fmt;
+ HV *inc_hv = GvHVn(PL_incgv);
+ I32 klen = SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv);
+ const char *key = SvPVX_const(namesv);
+
+ if (require0) {
+ (void)hv_delete(inc_hv, key, klen, G_DISCARD);
+ fmt = "%"SVf" did not return a true value";
+ err = namesv;
+ }
+ else {
+ (void)hv_store(inc_hv, key, klen, &PL_sv_undef, 0);
+ fmt = "%"SVf"Compilation failed in require";
+ err = err ? err : newSVpvs_flags("Unknown error\n", SVs_TEMP);
+ }
+
+ Perl_croak(aTHX_ fmt, SVfARG(err));
+}
+
+
void
Perl_die_unwind(pTHX_ SV *msv)
{
}
if (cxix >= 0) {
- I32 optype;
- SV *namesv;
+ SV *namesv = NULL;
PERL_CONTEXT *cx;
SV **newsp;
I32 gimme;
-#ifdef DEBUGGING
- COP *oldcop;
-#endif
JMPENV *restartjmpenv;
OP *restartop;
cx = &cxstack[cxstack_ix];
assert(CxTYPE(cx) == CXt_EVAL);
+
+ /* return false to the caller of eval */
newsp = PL_stack_base + cx->blk_oldsp;
gimme = cx->blk_gimme;
-
if (gimme == G_SCALAR)
*++newsp = &PL_sv_undef;
PL_stack_sp = newsp;
-
- if (CxTYPE(cx) != CXt_EVAL) {
- STRLEN 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);
- }
-
CX_LEAVE_SCOPE(cx);
POPEVAL(cx);
POPBLOCK(cx);
- cxstack_ix--;
- namesv = cx->blk_eval.old_namesv;
-#ifdef DEBUGGING
- oldcop = cx->blk_oldcop;
-#endif
restartjmpenv = cx->blk_eval.cur_top_env;
restartop = cx->blk_eval.retop;
+ if (CxOLD_OP_TYPE(cx) == OP_REQUIRE)
+ namesv = cx->blk_eval.old_namesv;
+ CX_POP(cx);
+
+ if (namesv) {
+ /* 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, process the error message
+ * and rethrow the error */
+ S_undo_inc_then_croak(aTHX_ namesv, exceptsv, FALSE);
+ NOT_REACHED; /* NOTREACHED */
+ }
- if (optype == OP_REQUIRE) {
- assert (PL_curcop == oldcop);
- (void)hv_store(GvHVn(PL_incgv),
- SvPVX_const(namesv),
- SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
- &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 */
- Perl_croak(aTHX_ "%"SVf"Compilation failed in require",
- SVfARG(exceptsv ? exceptsv : newSVpvs_flags("Unknown error\n",
- SVs_TEMP)));
- }
if (!(in_eval & EVAL_KEEPERR))
sv_setsv(ERRSV, exceptsv);
PL_restartjmpenv = restartjmpenv;
CX_LEAVE_SCOPE(cx);
POPBASICBLK(cx);
POPBLOCK(cx);
- cxstack_ix--;
+ CX_POP(cx);
return NORMAL;
}
const I32 gimme = GIMME_V;
void *itervarp; /* GV or pad slot of the iteration variable */
SV *itersave; /* the old var in the iterator var slot */
- U8 cxtype = CXt_LOOP_FOR;
+ U8 cxflags = 0;
if (PL_op->op_targ) { /* "my" variable */
itervarp = &PAD_SVl(PL_op->op_targ);
SvPADSTALE_on(itersave);
}
SvREFCNT_inc_simple_void_NN(itersave);
- cxtype |= CXp_FOR_PAD;
+ cxflags = CXp_FOR_PAD;
}
else {
SV * const sv = POPs;
SvREFCNT_inc_simple_void_NN(itersave);
else
*svp = newSV(0);
- cxtype |= CXp_FOR_GV;
+ cxflags = CXp_FOR_GV;
}
else { /* LV ref: for \$foo (...) */
assert(SvTYPE(sv) == SVt_PVMG);
assert(SvMAGIC(sv));
assert(SvMAGIC(sv)->mg_type == PERL_MAGIC_lvref);
itersave = NULL;
- cxtype |= CXp_FOR_LVREF;
+ cxflags = CXp_FOR_LVREF;
}
}
if (PL_op->op_private & OPpITER_DEF)
- cxtype |= CXp_FOR_DEF;
+ cxflags |= CXp_FOR_DEF;
- PUSHBLOCK(cx, cxtype, SP);
+ PUSHBLOCK(cx, cxflags, SP);
PUSHLOOP_FOR(cx, itervarp, itersave, MARK);
if (PL_op->op_flags & OPf_STACKED) {
SV *maybe_ary = POPs;
if (SvTYPE(maybe_ary) != SVt_PVAV) {
dPOPss;
SV * const right = maybe_ary;
- if (UNLIKELY(cxtype & CXp_FOR_LVREF))
+ if (UNLIKELY(cxflags & CXp_FOR_LVREF))
DIE(aTHX_ "Assigned value is not a reference");
SvGETMAGIC(sv);
SvGETMAGIC(right);
if (RANGE_IS_NUMERIC(sv,right)) {
- cx->cx_type &= ~CXTYPEMASK;
cx->cx_type |= CXt_LOOP_LAZYIV;
- /* Make sure that no-one re-orders cop.h and breaks our
- assumptions */
- assert(CxTYPE(cx) == CXt_LOOP_LAZYIV);
if (S_outside_integer(aTHX_ sv) ||
S_outside_integer(aTHX_ right))
DIE(aTHX_ "Range iterator outside integer range");
#endif
}
else {
- cx->cx_type &= ~CXTYPEMASK;
cx->cx_type |= CXt_LOOP_LAZYSV;
- /* Make sure that no-one re-orders cop.h and breaks our
- assumptions */
- assert(CxTYPE(cx) == CXt_LOOP_LAZYSV);
cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
cx->blk_loop.state_u.lazysv.end = right;
SvREFCNT_inc(right);
}
}
else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
+ cx->cx_type |= CXt_LOOP_ARY;
cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
SvREFCNT_inc(maybe_ary);
cx->blk_loop.state_u.ary.ix =
AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
-1;
}
+ /* EXTEND(SP, 1) not needed in this branch because we just did POPs */
}
else { /* iterating over items on the stack */
- cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */
- if (PL_op->op_private & OPpITER_REVERSED) {
- cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1;
- }
- else {
- cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base;
- }
+ cx->cx_type |= CXt_LOOP_LIST;
+ cx->blk_loop.state_u.stack.basesp = MARK - PL_stack_base;
+ cx->blk_loop.state_u.stack.ix =
+ (PL_op->op_private & OPpITER_REVERSED)
+ ? cx->blk_oldsp + 1
+ : cx->blk_loop.state_u.stack.basesp;
+ /* pre-extend stack so pp_iter doesn't have to check every time
+ * it pushes yes/no */
+ EXTEND(SP, 1);
}
RETURN;
CX_LEAVE_SCOPE(cx);
POPLOOP(cx); /* Stack values are safe: release loop vars ... */
POPBLOCK(cx);
- cxstack_ix--;
+ CX_POP(cx);
return NORMAL;
}
PERL_CONTEXT *cx;
bool ref;
const char *what = NULL;
+ OP *retop;
cx = &cxstack[cxstack_ix];
assert(CxTYPE(cx) == CXt_SUB);
what = "undef";
}
croak:
- CX_LEAVE_SCOPE(cx);
- POPSUB(cx);
- cxstack_ix--;
- PL_curpm = cx->blk_oldpm;
Perl_croak(aTHX_
"Can't return %s from lvalue subroutine", what
);
CX_LEAVE_SCOPE(cx);
POPSUB(cx); /* Stack values are safe: release CV and @_ ... */
POPBLOCK(cx);
- cxstack_ix--;
+ retop = cx->blk_sub.retop;
+ CX_POP(cx);
- return cx->blk_sub.retop;
+ return retop;
}
cx->blk_gimme, SVs_TEMP|SVs_PADTMP, TRUE);
SPAGAIN;
dounwind(cxix);
+ cx = &cxstack[cxix]; /* CX stack may have been realloced */
}
else {
/* Like in the branch above, we need to handle any extra junk on
PP(pp_last)
{
PERL_CONTEXT *cx;
+ OP* nextop;
S_unwind_loop(aTHX_ "last");
cx = &cxstack[cxstack_ix];
- assert(
- CxTYPE(cx) == CXt_LOOP_LAZYIV
- || CxTYPE(cx) == CXt_LOOP_LAZYSV
- || CxTYPE(cx) == CXt_LOOP_FOR
- || CxTYPE(cx) == CXt_LOOP_PLAIN
- );
+ assert(CxTYPE_is_LOOP(cx));
PL_stack_sp = PL_stack_base + cx->blk_loop.resetsp;
TAINT_NOT;
CX_LEAVE_SCOPE(cx);
POPLOOP(cx); /* release loop vars ... */
POPBLOCK(cx);
- cxstack_ix--;
+ nextop = cx->blk_loop.my_op->op_lastop->op_next;
+ CX_POP(cx);
- return cx->blk_loop.my_op->op_lastop->op_next;
+ return nextop;
}
PP(pp_next)
assert(PL_scopestack_ix == cx->blk_oldscopesp);
CX_LEAVE_SCOPE(cx);
- /* partial unrolled POPSUB(): */
-
if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
+ /* this is POPSUB_ARGS() with minor variations */
AV* av = MUTABLE_AV(PAD_SVl(0));
assert(AvARRAY(MUTABLE_AV(
PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[
* this is a POPBLOCK(), less all the stuff we already did
* for TOPBLOCK() earlier */
PL_curcop = cx->blk_oldcop;
- cxstack_ix--;
+ CX_POP(cx);
/* Push a mark for the start of arglist */
PUSHMARK(mark);
break;
}
/* else fall through */
- case CXt_LOOP_LAZYIV:
- case CXt_LOOP_LAZYSV:
- case CXt_LOOP_FOR:
- case CXt_LOOP_PLAIN:
+ case CXt_LOOP_PLAIN:
+ case CXt_LOOP_LAZYIV:
+ case CXt_LOOP_LAZYSV:
+ case CXt_LOOP_LIST:
+ case CXt_LOOP_ARY:
case CXt_GIVEN:
case CXt_WHEN:
gotoprobe = OpSIBLING(cx->blk_oldcop);
*/
STATIC bool
-S_doeval(pTHX_ int gimme, CV* outside, U32 seq, HV *hh)
+S_doeval_compile(pTHX_ int gimme, CV* outside, U32 seq, HV *hh)
{
dSP;
OP * const saveop = PL_op;
/* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
* so honour CATCH_GET and trap it here if necessary */
+
+ /* compile the code */
yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG);
if (yystatus || PL_parser->error_count || !PL_eval_root) {
+ SV *namesv = NULL; /* initialise to avoid compiler warning */
PERL_CONTEXT *cx;
- I32 optype; /* Used by POPEVAL. */
- SV *namesv;
- SV *errsv = NULL;
-
- cx = NULL;
- namesv = NULL;
- PERL_UNUSED_VAR(optype);
+ SV *errsv;
- /* note that if yystatus == 3, then the EVAL CX block has already
- * been popped, and various vars restored */
PL_op = saveop;
+ /* note that if yystatus == 3, then the require/eval died during
+ * compilation, so the EVAL CX block has already been popped, and
+ * various vars restored */
if (yystatus != 3) {
if (PL_eval_root) {
op_free(PL_eval_root);
CX_LEAVE_SCOPE(cx);
POPEVAL(cx);
POPBLOCK(cx);
- cxstack_ix--;
- namesv = cx->blk_eval.old_namesv;
+ if (in_require)
+ namesv = cx->blk_eval.old_namesv;
+ CX_POP(cx);
}
errsv = ERRSV;
if (in_require) {
- if (!cx) {
- /* If cx is still NULL, it means that we didn't go in the
- * POPEVAL branch. */
- cx = &cxstack[cxstack_ix];
- assert(CxTYPE(cx) == CXt_EVAL);
- namesv = cx->blk_eval.old_namesv;
- }
- (void)hv_store(GvHVn(PL_incgv),
- SvPVX_const(namesv),
- SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
- &PL_sv_undef, 0);
- Perl_croak(aTHX_ "%"SVf"Compilation failed in require",
- SVfARG(errsv
- ? errsv
- : newSVpvs_flags("Unknown error\n", SVs_TEMP)));
- }
- else {
- if (!*(SvPV_nolen_const(errsv))) {
- sv_setpvs(errsv, "Compilation error");
- }
+ if (yystatus == 3) {
+ cx = &cxstack[cxstack_ix];
+ assert(CxTYPE(cx) == CXt_EVAL);
+ namesv = cx->blk_eval.old_namesv;
+ }
+ S_undo_inc_then_croak(aTHX_ namesv, errsv, FALSE);
+ NOT_REACHED; /* NOTREACHED */
}
+
+ if (!*(SvPV_nolen_const(errsv)))
+ sv_setpvs(errsv, "Compilation error");
+
if (gimme != G_ARRAY) PUSHs(&PL_sv_undef);
PUTBACK;
return FALSE;
}
- else
- LEAVE_with_name("evalcomp");
+
+ /* Compilation successful. Now clean up */
+
+ LEAVE_with_name("evalcomp");
CopLINE_set(&PL_compiling, 0);
SAVEFREEOP(PL_eval_root);
PL_eval_start = es;
}
- /* compiled okay, so do it */
-
CvDEPTH(evalcv) = 1;
SP = PL_stack_base + POPMARK; /* pop original mark */
PL_op = saveop; /* The caller may need it. */
return TRUE;
}
+
STATIC PerlIO *
S_check_type_and_open(pTHX_ SV *name)
{
PUTBACK;
- if (doeval(gimme, NULL, PL_curcop->cop_seq, NULL))
+ if (doeval_compile(gimme, NULL, PL_curcop->cop_seq, NULL))
op = DOCATCH(PL_eval_start);
else
op = PL_op->op_next;
PUTBACK;
- if (doeval(gimme, runcv, seq, saved_hh)) {
+ if (doeval_compile(gimme, runcv, seq, saved_hh)) {
if (was != PL_breakable_sub_gen /* Some subs defined here. */
? PERLDB_LINE_OR_SAVESRC
: PERLDB_SAVESRC_NOSUBS) {
return DOCATCH(PL_eval_start);
} else {
/* We have already left the scope set up earlier thanks to the LEAVE
- in doeval(). */
+ in doeval_compile(). */
if (was != PL_breakable_sub_gen /* Some subs defined here. */
? PERLDB_LINE_OR_SAVESRC
: PERLDB_SAVESRC_INVALID) {
PP(pp_leaveeval)
{
- dSP;
SV **newsp;
I32 gimme;
PERL_CONTEXT *cx;
OP *retop;
- I32 optype;
- SV *namesv;
+ SV *namesv = NULL;
CV *evalcv;
/* grab this value before POPEVAL restores old PL_in_eval */
bool keep = cBOOL(PL_in_eval & EVAL_KEEPERR);
cx = &cxstack[cxstack_ix];
assert(CxTYPE(cx) == CXt_EVAL);
+
newsp = PL_stack_base + cx->blk_oldsp;
gimme = cx->blk_gimme;
- if (gimme != G_VOID) {
- PUTBACK;
+ /* did require return a false value? */
+ if ( CxOLD_OP_TYPE(cx) == OP_REQUIRE
+ && !(gimme == G_SCALAR
+ ? SvTRUE(*PL_stack_sp)
+ : PL_stack_sp > newsp)
+ )
+ namesv = cx->blk_eval.old_namesv;
+
+ if (gimme == G_VOID)
+ PL_stack_sp = newsp;
+ else
leave_common(newsp, newsp, gimme, SVs_TEMP, FALSE);
- SPAGAIN;
- }
+
/* the POPEVAL does a leavescope, which frees the optree associated
* with eval, which if it frees the nextstate associated with
* PL_curcop, sets PL_curcop to NULL. Which can mess up freeing a
* to get the current hints. So restore it early.
*/
PL_curcop = cx->blk_oldcop;
+
CX_LEAVE_SCOPE(cx);
POPEVAL(cx);
POPBLOCK(cx);
- cxstack_ix--;
- namesv = cx->blk_eval.old_namesv;
retop = cx->blk_eval.retop;
evalcv = cx->blk_eval.cv;
-
+ CX_POP(cx);
#ifdef DEBUGGING
assert(CvDEPTH(evalcv) == 1);
#endif
CvDEPTH(evalcv) = 0;
- if (optype == OP_REQUIRE &&
- !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
- {
+ if (namesv) { /* require returned false */
/* Unassume the success we assumed earlier. */
- (void)hv_delete(GvHVn(PL_incgv),
- SvPVX_const(namesv),
- SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
- G_DISCARD);
- Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv));
+ S_undo_inc_then_croak(aTHX_ namesv, NULL, TRUE);
NOT_REACHED; /* NOTREACHED */
- /* die_unwind() did LEAVE, or we won't be here */
- }
- else {
- if (!keep)
- CLEAR_ERRSV();
}
- RETURNOP(retop);
+ if (!keep)
+ CLEAR_ERRSV();
+
+ return retop;
}
/* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
Perl_delete_eval_scope(pTHX)
{
PERL_CONTEXT *cx;
- I32 optype;
cx = &cxstack[cxstack_ix];
CX_LEAVE_SCOPE(cx);
POPEVAL(cx);
POPBLOCK(cx);
- cxstack_ix--;
- PERL_UNUSED_VAR(optype);
+ CX_POP(cx);
}
/* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
SV **newsp;
I32 gimme;
PERL_CONTEXT *cx;
- I32 optype;
OP *retop;
PERL_ASYNC_CHECK();
CX_LEAVE_SCOPE(cx);
POPEVAL(cx);
POPBLOCK(cx);
- cxstack_ix--;
retop = cx->blk_eval.retop;
- PERL_UNUSED_VAR(optype);
+ CX_POP(cx);
CLEAR_ERRSV();
return retop;
CX_LEAVE_SCOPE(cx);
POPGIVEN(cx);
POPBLOCK(cx);
- cxstack_ix--;
+ CX_POP(cx);
return NORMAL;
}
{
I32 cxix;
PERL_CONTEXT *cx;
+ OP *nextop;
cxix = dopoptowhen(cxstack_ix);
if (cxix < 0)
CX_LEAVE_SCOPE(cx);
POPWHEN(cx);
POPBLOCK(cx);
- cxstack_ix--;
+ nextop = cx->blk_givwhen.leave_op->op_next;
+ CX_POP(cx);
- return cx->blk_givwhen.leave_op->op_next;
+ return nextop;
}
PP(pp_break)
https://perl5.git.perl.org / perl5.git / blobdiff