PP(pp_substcont)
{
dSP;
- PERL_CONTEXT *cx = &cxstack[cxstack_ix];
+ PERL_CONTEXT *cx = CX_CUR();
PMOP * const pm = (PMOP*) cLOGOP->op_other;
SV * const dstr = cx->sb_dstr;
char *s = cx->sb_s;
TAINT_NOT;
CX_LEAVE_SCOPE(cx);
- POPSUBST(cx);
- cxstack_ix--;
+ CX_POPSUBST(cx);
+ CX_POP(cx);
PERL_ASYNC_CHECK();
RETURNOP(pm->op_next);
PP(pp_mapwhile)
{
dSP;
- const I32 gimme = GIMME_V;
+ const U8 gimme = GIMME_V;
I32 items = (SP - PL_stack_base) - TOPMARK; /* how many new items */
I32 count;
I32 shift;
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;
-I32
+U8
Perl_dowantarray(pTHX)
{
- const I32 gimme = block_gimme();
+ const U8 gimme = block_gimme();
return (gimme == G_VOID) ? G_SCALAR : gimme;
}
-I32
+U8
Perl_block_gimme(pTHX)
{
const I32 cxix = dopoptosub(cxstack_ix);
return 0;
}
-/* only used by PUSHSUB */
+/* only used by cx_pushsub() */
I32
Perl_was_lvalue_sub(pTHX)
{
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;
}
return i;
}
-/* find the next GIVEN or FOR loop context block */
+/* find the next GIVEN or FOR (with implicit $_) loop context block */
STATIC I32
S_dopoptogivenfor(pTHX_ I32 startingblock)
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;
}
return i;
}
+/* dounwind(): pop all contexts above (but not including) cxix.
+ * Note that it clears the savestack frame associated with each popped
+ * context entry, but doesn't free any temps.
+ * It does a cx_popblock() of the last frame that it pops, and leaves
+ * cxstack_ix equal to cxix.
+ */
+
void
Perl_dounwind(pTHX_ I32 cxix)
{
- I32 optype;
-
if (!PL_curstackinfo) /* can happen if die during thread cloning */
return;
while (cxstack_ix > cxix) {
- PERL_CONTEXT *cx = &cxstack[cxstack_ix];
- DEBUG_CX("UNWIND"); \
+ PERL_CONTEXT *cx = CX_CUR();
+
+ CX_DEBUG(cx, "UNWIND");
/* Note: we don't need to restore the base context info till the end. */
CX_LEAVE_SCOPE(cx);
switch (CxTYPE(cx)) {
case CXt_SUBST:
- POPSUBST(cx);
+ CX_POPSUBST(cx);
break;
case CXt_SUB:
- POPSUB(cx);
+ cx_popsub(cx);
break;
case CXt_EVAL:
- POPEVAL(cx);
- break;
- case CXt_BLOCK:
- POPBASICBLK(cx);
+ cx_popeval(cx);
break;
+ case CXt_LOOP_PLAIN:
case CXt_LOOP_LAZYIV:
case CXt_LOOP_LAZYSV:
- case CXt_LOOP_FOR:
- case CXt_LOOP_PLAIN:
- POPLOOP(cx);
+ case CXt_LOOP_LIST:
+ case CXt_LOOP_ARY:
+ cx_poploop(cx);
break;
case CXt_WHEN:
- POPWHEN(cx);
+ cx_popwhen(cx);
break;
case CXt_GIVEN:
- POPGIVEN(cx);
+ cx_popgiven(cx);
break;
+ case CXt_BLOCK:
case CXt_NULL:
- /* there isn't a POPNULL ! */
+ /* these two don't have a POPFOO() */
break;
case CXt_FORMAT:
- POPFORMAT(cx);
+ cx_popformat(cx);
break;
}
+ if (cxstack_ix == cxix + 1) {
+ cx_popblock(cx);
+ }
cxstack_ix--;
}
- PERL_UNUSED_VAR(optype);
+
}
void
++PL_parser->error_count;
}
+
+
+/* pop a CXt_EVAL context and in addition, if it was a require then
+ * based on action:
+ * 0: do nothing extra;
+ * 1: undef $INC{$name}; croak "$name did not return a true value";
+ * 2: delete $INC{$name}; croak "$errsv: Compilation failed in require"
+ */
+
+static void
+S_pop_eval_context_maybe_croak(pTHX_ PERL_CONTEXT *cx, SV *errsv, int action)
+{
+ SV *namesv;
+ bool do_croak;
+
+ CX_LEAVE_SCOPE(cx);
+ do_croak = action && (CxOLD_OP_TYPE(cx) == OP_REQUIRE);
+ namesv = cx->blk_eval.old_namesv;
+ cx_popeval(cx);
+ cx_popblock(cx);
+ CX_POP(cx);
+
+ if (do_croak) {
+ 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 (action == 1) {
+ (void)hv_delete(inc_hv, key, klen, G_DISCARD);
+ fmt = "%"SVf" did not return a true value";
+ errsv = namesv;
+ }
+ else {
+ (void)hv_store(inc_hv, key, klen, &PL_sv_undef, 0);
+ fmt = "%"SVf"Compilation failed in require";
+ if (!errsv)
+ errsv = newSVpvs_flags("Unknown error\n", SVs_TEMP);
+ }
+
+ Perl_croak(aTHX_ fmt, SVfARG(errsv));
+ }
+}
+
+
+
void
Perl_die_unwind(pTHX_ SV *msv)
{
}
if (cxix >= 0) {
- I32 optype;
- SV *namesv;
PERL_CONTEXT *cx;
- SV **newsp;
- I32 gimme;
-#ifdef DEBUGGING
- COP *oldcop;
-#endif
+ SV **oldsp;
+ U8 gimme;
JMPENV *restartjmpenv;
OP *restartop;
if (cxix < cxstack_ix)
dounwind(cxix);
- cx = &cxstack[cxstack_ix];
+ cx = CX_CUR();
assert(CxTYPE(cx) == CXt_EVAL);
- newsp = PL_stack_base + cx->blk_oldsp;
- gimme = cx->blk_gimme;
+ /* return false to the caller of eval */
+ oldsp = PL_stack_base + cx->blk_oldsp;
+ gimme = cx->blk_gimme;
if (gimme == G_SCALAR)
- *++newsp = &PL_sv_undef;
- PL_stack_sp = newsp;
+ *++oldsp = &PL_sv_undef;
+ PL_stack_sp = oldsp;
-
- 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 (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)));
- }
+ restartop = cx->blk_eval.retop;
+ /* 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
+ * croak(exceptsv). This is all handled by the call below when
+ * action == 2.
+ */
+ S_pop_eval_context_maybe_croak(aTHX_ cx, exceptsv, 2);
+
if (!(in_eval & EVAL_KEEPERR))
sv_setsv(ERRSV, exceptsv);
PL_restartjmpenv = restartjmpenv;
dSP;
const PERL_CONTEXT *cx;
const PERL_CONTEXT *dbcx;
- I32 gimme = GIMME_V;
+ U8 gimme = GIMME_V;
const HEK *stash_hek;
I32 count = 0;
bool has_arg = MAXARG && TOPs;
RETURN;
}
- DEBUG_CX("CALLER");
+ CX_DEBUG(cx, "CALLER");
assert(CopSTASH(cx->blk_oldcop));
stash_hek = SvTYPE(CopSTASH(cx->blk_oldcop)) == SVt_PVHV
? HvNAME_HEK((HV*)CopSTASH(cx->blk_oldcop))
PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
mPUSHi(0);
}
- gimme = (I32)cx->blk_gimme;
+ gimme = cx->blk_gimme;
if (gimme == G_VOID)
PUSHs(&PL_sv_undef);
else
{
PL_curcop = (COP*)PL_op;
TAINT_NOT; /* Each statement is presumed innocent */
- PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
+ PL_stack_sp = PL_stack_base + CX_CUR()->blk_oldsp;
FREETMPS;
PERL_ASYNC_CHECK();
{
dSP;
PERL_CONTEXT *cx;
- const I32 gimme = G_ARRAY;
+ const U8 gimme = G_ARRAY;
GV * const gv = PL_DBgv;
CV * cv = NULL;
return NORMAL;
}
else {
- U8 hasargs = 0;
- PUSHBLOCK(cx, CXt_SUB, SP);
- PUSHSUB_DB(cx);
- cx->blk_sub.retop = PL_op->op_next;
- cx->cx_old_savestack_ix = PL_savestack_ix;
+ cx = cx_pushblock(CXt_SUB, gimme, SP, PL_savestack_ix);
+ cx_pushsub(cx, cv, PL_op->op_next, 0);
+ /* OP_DBSTATE's op_private holds hint bits rather than
+ * the lvalue-ish flags seen in OP_ENTERSUB. So cancel
+ * any CxLVAL() flags that have now been mis-calculated */
+ cx->blk_u16 = 0;
SAVEI32(PL_debug);
PL_debug = 0;
SAVESTACK_POS();
CvDEPTH(cv)++;
- if (CvDEPTH(cv) >= 2) {
- PERL_STACK_OVERFLOW_CHECK();
+ if (CvDEPTH(cv) >= 2)
pad_push(CvPADLIST(cv), CvDEPTH(cv));
- }
PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv));
RETURNOP(CvSTART(cv));
}
return NORMAL;
}
-/* S_leave_common: Common code that many functions in this file use on
- scope exit.
-
- Process the return args on the stack in the range (mark+1..PL_stack_sp)
- based on context, with any final args starting at newsp+1.
- Args are mortal copied (or mortalied if lvalue) unless its safe to use
- as-is, based on whether it has the specified flags. Note that most
- callers specify flags as (SVs_PADTMP|SVs_TEMP), while leaveeval skips
- SVs_PADTMP since its optree gets immediately freed, freeing its padtmps
- at the same time.
-
- Also, taintedness is cleared.
-*/
-
-STATIC void
-S_leave_common(pTHX_ SV **newsp, SV **mark, I32 gimme,
- U32 flags, bool lvalue)
-{
- dSP;
- PERL_ARGS_ASSERT_LEAVE_COMMON;
-
- TAINT_NOT;
- if (gimme == G_SCALAR) {
- if (MARK < SP)
- *++newsp = (SvFLAGS(*SP) & flags)
- ? *SP
- : lvalue
- ? sv_2mortal(SvREFCNT_inc_simple_NN(*SP))
- : sv_mortalcopy(*SP);
- else {
- EXTEND(newsp, 1);
- *++newsp = &PL_sv_undef;
- }
- }
- else if (gimme == G_ARRAY) {
- /* in case LEAVE wipes old return values */
- while (++MARK <= SP) {
- if (SvFLAGS(*MARK) & flags)
- *++newsp = *MARK;
- else {
- *++newsp = lvalue
- ? sv_2mortal(SvREFCNT_inc_simple_NN(*MARK))
- : sv_mortalcopy(*MARK);
- TAINT_NOT; /* Each item is independent */
- }
- }
- /* When this function was called with MARK == newsp, we reach this
- * point with SP == newsp. */
- }
-
- PL_stack_sp = newsp;
-}
-
PP(pp_enter)
{
- dSP;
- PERL_CONTEXT *cx;
- I32 gimme = GIMME_V;
-
- PUSHBLOCK(cx, CXt_BLOCK, SP);
- PUSHBASICBLK(cx);
+ U8 gimme = GIMME_V;
- RETURN;
+ (void)cx_pushblock(CXt_BLOCK, gimme, PL_stack_sp, PL_savestack_ix);
+ return NORMAL;
}
+
PP(pp_leave)
{
PERL_CONTEXT *cx;
- SV **newsp;
- I32 gimme;
+ SV **oldsp;
+ U8 gimme;
- cx = &cxstack[cxstack_ix];
+ cx = CX_CUR();
assert(CxTYPE(cx) == CXt_BLOCK);
if (PL_op->op_flags & OPf_SPECIAL)
- cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
+ /* fake block should preserve $1 et al; e.g. /(...)/ while ...; */
+ cx->blk_oldpm = PL_curpm;
- newsp = PL_stack_base + cx->blk_oldsp;
+ oldsp = PL_stack_base + cx->blk_oldsp;
gimme = cx->blk_gimme;
if (gimme == G_VOID)
- PL_stack_sp = newsp;
+ PL_stack_sp = oldsp;
else
- leave_common(newsp, newsp, gimme, SVs_PADTMP|SVs_TEMP,
- PL_op->op_private & OPpLVALUE);
+ leave_adjust_stacks(oldsp, oldsp, gimme,
+ PL_op->op_private & OPpLVALUE ? 3 : 1);
CX_LEAVE_SCOPE(cx);
- POPBASICBLK(cx);
- POPBLOCK(cx);
- cxstack_ix--;
+ cx_popblock(cx);
+ CX_POP(cx);
return NORMAL;
}
{
dSP; dMARK;
PERL_CONTEXT *cx;
- const I32 gimme = GIMME_V;
+ const U8 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;
itervarp = (void *)sv;
if (LIKELY(isGV(sv))) { /* symbol table variable */
- SV** svp = &GvSV(sv);
- itersave = *svp;
- if (LIKELY(itersave))
- SvREFCNT_inc_simple_void_NN(itersave);
- else
- *svp = newSV(0);
- cxtype |= CXp_FOR_GV;
+ itersave = GvSV(sv);
+ SvREFCNT_inc_simple_void(itersave);
+ cxflags = CXp_FOR_GV;
+ if (PL_op->op_private & OPpITER_DEF)
+ cxflags |= CXp_FOR_DEF;
}
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;
}
}
+ /* OPpITER_DEF (implicit $_) should only occur with a GV iter var */
+ assert((cxflags & CXp_FOR_GV) || !(PL_op->op_private & OPpITER_DEF));
- if (PL_op->op_private & OPpITER_DEF)
- cxtype |= CXp_FOR_DEF;
+ /* Note that this context is initially set as CXt_NULL. Further on
+ * down it's changed to one of the CXt_LOOP_*. Before it's changed,
+ * there mustn't be anything in the blk_loop substruct that requires
+ * freeing or undoing, in case we die in the meantime. And vice-versa.
+ */
+ cx = cx_pushblock(cxflags, gimme, MARK, PL_savestack_ix);
+ cx_pushloop_for(cx, itervarp, itersave);
- PUSHBLOCK(cx, cxtype, SP);
- PUSHLOOP_FOR(cx, itervarp, itersave, MARK);
if (PL_op->op_flags & OPf_STACKED) {
+ /* OPf_STACKED implies either a single array: for(@), with a
+ * single AV on the stack, or a range: for (1..5), with 1 and 5 on
+ * the stack */
SV *maybe_ary = POPs;
if (SvTYPE(maybe_ary) != SVt_PVAV) {
+ /* range */
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");
cx->blk_loop.state_u.lazyiv.cur = SvIV_nomg(sv);
cx->blk_loop.state_u.lazyiv.end = SvIV_nomg(right);
-#ifdef DEBUGGING
- /* for correct -Dstv display */
- cx->blk_oldsp = sp - PL_stack_base;
-#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);
+ SvREFCNT_inc_simple_void_NN(right);
(void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
/* This will do the upgrade to SVt_PV, and warn if the value
is uninitialised. */
}
}
else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
+ /* for (@array) {} */
+ cx->cx_type |= CXt_LOOP_ARY;
cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
- SvREFCNT_inc(maybe_ary);
+ SvREFCNT_inc_simple_void_NN(maybe_ary);
cx->blk_loop.state_u.ary.ix =
(PL_op->op_private & OPpITER_REVERSED) ?
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_oldsp = SP - PL_stack_base;
+ 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;
PP(pp_enterloop)
{
- dSP;
PERL_CONTEXT *cx;
- const I32 gimme = GIMME_V;
+ const U8 gimme = GIMME_V;
- PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);
- PUSHLOOP_PLAIN(cx, SP);
-
- RETURN;
+ cx = cx_pushblock(CXt_LOOP_PLAIN, gimme, PL_stack_sp, PL_savestack_ix);
+ cx_pushloop_plain(cx);
+ return NORMAL;
}
+
PP(pp_leaveloop)
{
PERL_CONTEXT *cx;
- I32 gimme;
- SV **newsp;
+ U8 gimme;
+ SV **oldsp;
SV **mark;
- cx = &cxstack[cxstack_ix];
+ cx = CX_CUR();
assert(CxTYPE_is_LOOP(cx));
mark = PL_stack_base + cx->blk_oldsp;
- newsp = PL_stack_base + cx->blk_loop.resetsp;
+ oldsp = CxTYPE(cx) == CXt_LOOP_LIST
+ ? PL_stack_base + cx->blk_loop.state_u.stack.basesp
+ : mark;
gimme = cx->blk_gimme;
if (gimme == G_VOID)
- PL_stack_sp = newsp;
+ PL_stack_sp = oldsp;
else
- leave_common(newsp, MARK, gimme, SVs_PADTMP|SVs_TEMP,
- PL_op->op_private & OPpLVALUE);
+ leave_adjust_stacks(MARK, oldsp, gimme,
+ PL_op->op_private & OPpLVALUE ? 3 : 1);
CX_LEAVE_SCOPE(cx);
- POPLOOP(cx); /* Stack values are safe: release loop vars ... */
- POPBLOCK(cx);
- cxstack_ix--;
+ cx_poploop(cx); /* Stack values are safe: release loop vars ... */
+ cx_popblock(cx);
+ CX_POP(cx);
return NORMAL;
}
*
* Any changes made to this function may need to be copied to pp_leavesub
* and vice-versa.
+ *
+ * also tail-called by pp_return
*/
PP(pp_leavesublv)
{
- dSP;
- SV **newsp;
- SV **mark;
- I32 gimme;
+ U8 gimme;
PERL_CONTEXT *cx;
- bool ref;
- const char *what = NULL;
+ SV **oldsp;
+ OP *retop;
- cx = &cxstack[cxstack_ix];
+ cx = CX_CUR();
assert(CxTYPE(cx) == CXt_SUB);
if (CxMULTICALL(cx)) {
return 0;
}
- newsp = PL_stack_base + cx->blk_oldsp;
gimme = cx->blk_gimme;
- TAINT_NOT;
+ oldsp = PL_stack_base + cx->blk_oldsp; /* last arg of previous frame */
- mark = newsp + 1;
-
- ref = !!(CxLVAL(cx) & OPpENTERSUB_INARGS);
- if (gimme == G_SCALAR) {
- if (CxLVAL(cx) && !ref) { /* Leave it as it is if we can. */
- if (MARK <= SP) {
- if ((SvPADTMP(TOPs) || SvREADONLY(TOPs)) &&
- !SvSMAGICAL(TOPs)) {
- what =
- SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
- : "a readonly value" : "a temporary";
- }
- else goto copy_sv;
- }
- else {
- /* sub:lvalue{} will take us here. */
- what = "undef";
- }
- croak:
- Perl_croak(aTHX_
- "Can't return %s from lvalue subroutine", what
- );
- }
- if (MARK <= SP) {
- copy_sv:
- if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
- if (!SvPADTMP(*SP)) {
- *MARK = SvREFCNT_inc(*SP);
- FREETMPS;
- sv_2mortal(*MARK);
- }
- else {
- /* FREETMPS could clobber it */
- SV *sv = SvREFCNT_inc(*SP);
- FREETMPS;
- *MARK = sv_mortalcopy(sv);
- SvREFCNT_dec(sv);
- }
- }
- else
- *MARK =
- SvPADTMP(*SP)
- ? sv_mortalcopy(*SP)
- : !SvTEMP(*SP)
- ? sv_2mortal(SvREFCNT_inc_simple_NN(*SP))
- : *SP;
- }
- else {
- MEXTEND(MARK, 0);
- *MARK = &PL_sv_undef;
- }
- SP = MARK;
+ if (gimme == G_VOID)
+ PL_stack_sp = oldsp;
+ else {
+ U8 lval = CxLVAL(cx);
+ bool is_lval = (lval && !(lval & OPpENTERSUB_INARGS));
+ const char *what = NULL;
+
+ if (gimme == G_SCALAR) {
+ if (is_lval) {
+ /* check for bad return arg */
+ if (oldsp < PL_stack_sp) {
+ SV *sv = *PL_stack_sp;
+ if ((SvPADTMP(sv) || SvREADONLY(sv))) {
+ what =
+ SvREADONLY(sv) ? (sv == &PL_sv_undef) ? "undef"
+ : "a readonly value" : "a temporary";
+ }
+ else goto ok;
+ }
+ else {
+ /* sub:lvalue{} will take us here. */
+ what = "undef";
+ }
+ croak:
+ Perl_croak(aTHX_
+ "Can't return %s from lvalue subroutine", what);
+ }
- if (CxLVAL(cx) & OPpDEREF) {
- SvGETMAGIC(TOPs);
- if (!SvOK(TOPs)) {
- TOPs = vivify_ref(TOPs, CxLVAL(cx) & OPpDEREF);
- }
- }
- }
- else if (gimme == G_ARRAY) {
- assert (!(CxLVAL(cx) & OPpDEREF));
- if (ref || !CxLVAL(cx))
- for (; MARK <= SP; MARK++)
- *MARK =
- SvFLAGS(*MARK) & SVs_PADTMP
- ? sv_mortalcopy(*MARK)
- : SvTEMP(*MARK)
- ? *MARK
- : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
- else for (; MARK <= SP; MARK++) {
- if (*MARK != &PL_sv_undef
- && (SvPADTMP(*MARK) || SvREADONLY(*MARK))
- ) {
- /* Might be flattened array after $#array = */
- what = SvREADONLY(*MARK)
- ? "a readonly value" : "a temporary";
- goto croak;
- }
- else if (!SvTEMP(*MARK))
- *MARK = sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
- }
+ ok:
+ leave_adjust_stacks(oldsp, oldsp, gimme, is_lval ? 3 : 2);
+
+ if (lval & OPpDEREF) {
+ /* lval_sub()->{...} and similar */
+ dSP;
+ SvGETMAGIC(TOPs);
+ if (!SvOK(TOPs)) {
+ TOPs = vivify_ref(TOPs, CxLVAL(cx) & OPpDEREF);
+ }
+ PUTBACK;
+ }
+ }
+ else {
+ assert(gimme == G_ARRAY);
+ assert (!(lval & OPpDEREF));
+
+ if (is_lval) {
+ /* scan for bad return args */
+ SV **p;
+ for (p = PL_stack_sp; p > oldsp; p--) {
+ SV *sv = *p;
+ /* the PL_sv_undef exception is to allow things like
+ * this to work, where PL_sv_undef acts as 'skip'
+ * placeholder on the LHS of list assigns:
+ * sub foo :lvalue { undef }
+ * ($a, undef, foo(), $b) = 1..4;
+ */
+ if (sv != &PL_sv_undef && (SvPADTMP(sv) || SvREADONLY(sv)))
+ {
+ /* Might be flattened array after $#array = */
+ what = SvREADONLY(sv)
+ ? "a readonly value" : "a temporary";
+ goto croak;
+ }
+ }
+ }
+
+ leave_adjust_stacks(oldsp, oldsp, gimme, is_lval ? 3 : 2);
+ }
}
- PUTBACK;
CX_LEAVE_SCOPE(cx);
- POPSUB(cx); /* Stack values are safe: release CV and @_ ... */
- POPBLOCK(cx);
- cxstack_ix--;
+ cx_popsub(cx); /* Stack values are safe: release CV and @_ ... */
+ cx_popblock(cx);
+ retop = cx->blk_sub.retop;
+ CX_POP(cx);
- return cx->blk_sub.retop;
+ return retop;
}
}
/* There are contexts that need popping. Doing this may free the
- * return value(s), so preserve them first, e.g. popping the plain
+ * return value(s), so preserve them first: e.g. popping the plain
* loop here would free $x:
* sub f { { my $x = 1; return $x } }
* We may also need to shift the args down; for example,
* for (1,2) { return 3,4 }
- * leaves 1,2,3,4 on the stack. Both these actions can be done by
- * leave_common(). By calling it with lvalue=TRUE, we just bump
- * the ref count and mortalise the args that need it. The "scan
- * the args and maybe copy them" process will be repeated by
- * whoever we tail-call (e.g. pp_leaveeval), where any copying etc
- * will be done. That is to say, in this code path two scans of
- * the args will be done; the first just shifts and preserves; the
- * second is the "real" arg processing, based on the type of
- * return.
+ * leaves 1,2,3,4 on the stack. Both these actions will be done by
+ * leave_adjust_stacks(), along with freeing any temps. Note that
+ * whoever we tail-call (e.g. pp_leaveeval) will also call
+ * leave_adjust_stacks(); however, the second call is likely to
+ * just see a bunch of SvTEMPs with a ref count of 1, and so just
+ * pass them through, rather than copying them again. So this
+ * isn't as inefficient as it sounds.
*/
cx = &cxstack[cxix];
PUTBACK;
- leave_common(PL_stack_base + cx->blk_oldsp, MARK,
- cx->blk_gimme, SVs_TEMP|SVs_PADTMP, TRUE);
+ if (cx->blk_gimme != G_VOID)
+ leave_adjust_stacks(MARK, PL_stack_base + cx->blk_oldsp,
+ cx->blk_gimme,
+ CxTYPE(cx) == CXt_SUB && CvLVALUE(cx->blk_sub.cv)
+ ? 3 : 0);
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
}
}
+/* find the enclosing loop or labelled loop and dounwind() back to it. */
-static I32
-S_unwind_loop(pTHX_ const char * const opname)
+static PERL_CONTEXT *
+S_unwind_loop(pTHX)
{
I32 cxix;
if (PL_op->op_flags & OPf_SPECIAL) {
cxix = dopoptoloop(cxstack_ix);
if (cxix < 0)
/* diag_listed_as: Can't "last" outside a loop block */
- Perl_croak(aTHX_ "Can't \"%s\" outside a loop block", opname);
+ Perl_croak(aTHX_ "Can't \"%s\" outside a loop block",
+ OP_NAME(PL_op));
}
else {
dSP;
if (cxix < 0)
/* diag_listed_as: Label not found for "last %s" */
Perl_croak(aTHX_ "Label not found for \"%s %"SVf"\"",
- opname,
+ OP_NAME(PL_op),
SVfARG(PL_op->op_flags & OPf_STACKED
&& !SvGMAGICAL(TOPp1s)
? TOPp1s
}
if (cxix < cxstack_ix)
dounwind(cxix);
- return cxix;
+ return &cxstack[cxix];
}
+
PP(pp_last)
{
PERL_CONTEXT *cx;
+ OP* nextop;
- S_unwind_loop(aTHX_ "last");
-
- cx = &cxstack[cxstack_ix];
+ cx = S_unwind_loop(aTHX);
- assert(
- CxTYPE(cx) == CXt_LOOP_LAZYIV
- || CxTYPE(cx) == CXt_LOOP_LAZYSV
- || CxTYPE(cx) == CXt_LOOP_FOR
- || CxTYPE(cx) == CXt_LOOP_PLAIN
- );
- PL_stack_sp = PL_stack_base + cx->blk_loop.resetsp;
+ assert(CxTYPE_is_LOOP(cx));
+ PL_stack_sp = PL_stack_base
+ + (CxTYPE(cx) == CXt_LOOP_LIST
+ ? cx->blk_loop.state_u.stack.basesp
+ : cx->blk_oldsp
+ );
TAINT_NOT;
/* Stack values are safe: */
CX_LEAVE_SCOPE(cx);
- POPLOOP(cx); /* release loop vars ... */
- POPBLOCK(cx);
- cxstack_ix--;
+ cx_poploop(cx); /* release loop vars ... */
+ cx_popblock(cx);
+ 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)
{
PERL_CONTEXT *cx;
- S_unwind_loop(aTHX_ "next");
+ /* if not a bare 'next' in the main scope, search for it */
+ cx = CX_CUR();
+ if (!((PL_op->op_flags & OPf_SPECIAL) && CxTYPE_is_LOOP(cx)))
+ cx = S_unwind_loop(aTHX);
- TOPBLOCK(cx);
+ cx_topblock(cx);
PL_curcop = cx->blk_oldcop;
PERL_ASYNC_CHECK();
return (cx)->blk_loop.my_op->op_nextop;
PP(pp_redo)
{
- const I32 cxix = S_unwind_loop(aTHX_ "redo");
- PERL_CONTEXT *cx;
- OP* redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
+ PERL_CONTEXT *cx = S_unwind_loop(aTHX);
+ OP* redo_op = cx->blk_loop.my_op->op_redoop;
if (redo_op->op_type == OP_ENTER) {
/* pop one less context to avoid $x being freed in while (my $x..) */
cxstack_ix++;
- assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
+ cx = CX_CUR();
+ assert(CxTYPE(cx) == CXt_BLOCK);
redo_op = redo_op->op_next;
}
- TOPBLOCK(cx);
- CX_LEAVE_SCOPE(cx);
FREETMPS;
+ CX_LEAVE_SCOPE(cx);
+ cx_topblock(cx);
PL_curcop = cx->blk_oldcop;
PERL_ASYNC_CHECK();
return redo_op;
if (cxix < cxstack_ix) {
dounwind(cxix);
}
- TOPBLOCK(cx);
+ cx = CX_CUR();
+ cx_topblock(cx);
SPAGAIN;
/* protect @_ during save stack unwind. */
CX_LEAVE_SCOPE(cx);
if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
- /* this is POPSUB_ARGS() with minor variations */
+ /* this is part of cx_popsub_args() */
AV* av = MUTABLE_AV(PAD_SVl(0));
assert(AvARRAY(MUTABLE_AV(
PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[
SP += items;
if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
/* Restore old @_ */
- POP_SAVEARRAY();
+ CX_POP_SAVEARRAY(cx);
}
retop = cx->blk_sub.retop;
PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
/* XS subs don't have a CXt_SUB, so pop it;
- * this is a POPBLOCK(), less all the stuff we already did
- * for TOPBLOCK() earlier */
+ * this is a cx_popblock(), less all the stuff we already did
+ * for cx_topblock() earlier */
PL_curcop = cx->blk_oldcop;
- cxstack_ix--;
+ CX_POP(cx);
/* Push a mark for the start of arglist */
PUSHMARK(mark);
SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
- /* partial unrolled PUSHSUB(): */
+ /* partial unrolled cx_pushsub(): */
cx->blk_sub.cv = cv;
cx->blk_sub.olddepth = CvDEPTH(cv);
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);
if (ix < 0)
DIE(aTHX_ "panic: docatch: illegal ix=%ld", (long)ix);
dounwind(ix);
- TOPBLOCK(cx);
+ cx = CX_CUR();
+ cx_topblock(cx);
}
/* push wanted frames */
switch (ret) {
case 0:
assert(cxstack_ix >= 0);
- assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
- cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
+ assert(CxTYPE(CX_CUR()) == CXt_EVAL);
+ CX_CUR()->blk_eval.cur_top_env = PL_top_env;
redo_body:
CALLRUNOPS(aTHX);
break;
int ret;
dJMPENV;
- assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
+ assert(CxTYPE(CX_CUR()) == CXt_EVAL);
JMPENV_PUSH(ret);
switch (ret) {
case 0:
*/
STATIC bool
-S_doeval(pTHX_ int gimme, CV* outside, U32 seq, HV *hh)
+S_doeval_compile(pTHX_ U8 gimme, CV* outside, U32 seq, HV *hh)
{
dSP;
OP * const saveop = PL_op;
evalcv = MUTABLE_CV(newSV_type(SVt_PVCV));
CvEVAL_on(evalcv);
- assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
- cxstack[cxstack_ix].blk_eval.cv = evalcv;
- cxstack[cxstack_ix].blk_gimme = gimme;
+ assert(CxTYPE(CX_CUR()) == CXt_EVAL);
+ CX_CUR()->blk_eval.cv = evalcv;
+ CX_CUR()->blk_gimme = gimme;
CvOUTSIDE_SEQ(evalcv) = seq;
CvOUTSIDE(evalcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
/* 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) {
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);
PL_eval_root = NULL;
}
SP = PL_stack_base + POPMARK; /* pop original mark */
- cx = &cxstack[cxstack_ix];
- CX_LEAVE_SCOPE(cx);
- POPEVAL(cx);
- POPBLOCK(cx);
- cxstack_ix--;
- namesv = cx->blk_eval.old_namesv;
+ cx = CX_CUR();
+ assert(CxTYPE(cx) == CXt_EVAL);
+ /* pop the CXt_EVAL, and if was a require, croak */
+ S_pop_eval_context_maybe_croak(aTHX_ cx, ERRSV, 2);
}
+ /* die_unwind() re-croaks when in require, having popped the
+ * require EVAL context. So we should never catch a require
+ * exception here */
+ assert(!in_require);
+
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 (!*(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)
{
}
-/* also used for: pp_dofile() */
+/* implement 'require 5.010001' */
-PP(pp_require)
+static OP *
+S_require_version(pTHX_ SV *sv)
{
- dSP;
+ dVAR; dSP;
+
+ sv = sv_2mortal(new_version(sv));
+ if (!Perl_sv_derived_from_pvn(aTHX_ PL_patchlevel, STR_WITH_LEN("version"), 0))
+ upg_version(PL_patchlevel, TRUE);
+ if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
+ if ( vcmp(sv,PL_patchlevel) <= 0 )
+ DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
+ SVfARG(sv_2mortal(vnormal(sv))),
+ SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
+ );
+ }
+ else {
+ if ( vcmp(sv,PL_patchlevel) > 0 ) {
+ I32 first = 0;
+ AV *lav;
+ SV * const req = SvRV(sv);
+ SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
+
+ /* get the left hand term */
+ lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
+
+ first = SvIV(*av_fetch(lav,0,0));
+ if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
+ || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
+ || av_tindex(lav) > 1 /* FP with > 3 digits */
+ || strstr(SvPVX(pv),".0") /* FP with leading 0 */
+ ) {
+ DIE(aTHX_ "Perl %"SVf" required--this is only "
+ "%"SVf", stopped",
+ SVfARG(sv_2mortal(vnormal(req))),
+ SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
+ );
+ }
+ else { /* probably 'use 5.10' or 'use 5.8' */
+ SV *hintsv;
+ I32 second = 0;
+
+ if (av_tindex(lav)>=1)
+ second = SvIV(*av_fetch(lav,1,0));
+
+ second /= second >= 600 ? 100 : 10;
+ hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
+ (int)first, (int)second);
+ upg_version(hintsv, TRUE);
+
+ DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
+ "--this is only %"SVf", stopped",
+ SVfARG(sv_2mortal(vnormal(req))),
+ SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))),
+ SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
+ );
+ }
+ }
+ }
+
+ RETPUSHYES;
+}
+
+/* Handle C<require Foo::Bar>, C<require "Foo/Bar.pm"> and C<do "Foo.pm">.
+ * The first form will have already been converted at compile time to
+ * the second form */
+
+static OP *
+S_require_file(pTHX_ SV *const sv)
+{
+ dVAR; dSP;
+
PERL_CONTEXT *cx;
- SV *sv;
const char *name;
STRLEN len;
char * unixname;
#endif
const char *tryname = NULL;
SV *namesv = NULL;
- const I32 gimme = GIMME_V;
+ const U8 gimme = GIMME_V;
int filter_has_file = 0;
PerlIO *tryrsfp = NULL;
SV *filter_cache = NULL;
bool path_searchable;
I32 old_savestack_ix;
- sv = POPs;
- SvGETMAGIC(sv);
- if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
- sv = sv_2mortal(new_version(sv));
- if (!Perl_sv_derived_from_pvn(aTHX_ PL_patchlevel, STR_WITH_LEN("version"), 0))
- upg_version(PL_patchlevel, TRUE);
- if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
- if ( vcmp(sv,PL_patchlevel) <= 0 )
- DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
- SVfARG(sv_2mortal(vnormal(sv))),
- SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
- );
- }
- else {
- if ( vcmp(sv,PL_patchlevel) > 0 ) {
- I32 first = 0;
- AV *lav;
- SV * const req = SvRV(sv);
- SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
-
- /* get the left hand term */
- lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
-
- first = SvIV(*av_fetch(lav,0,0));
- if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
- || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
- || av_tindex(lav) > 1 /* FP with > 3 digits */
- || strstr(SvPVX(pv),".0") /* FP with leading 0 */
- ) {
- DIE(aTHX_ "Perl %"SVf" required--this is only "
- "%"SVf", stopped",
- SVfARG(sv_2mortal(vnormal(req))),
- SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
- );
- }
- else { /* probably 'use 5.10' or 'use 5.8' */
- SV *hintsv;
- I32 second = 0;
-
- if (av_tindex(lav)>=1)
- second = SvIV(*av_fetch(lav,1,0));
-
- second /= second >= 600 ? 100 : 10;
- hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
- (int)first, (int)second);
- upg_version(hintsv, TRUE);
-
- DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
- "--this is only %"SVf", stopped",
- SVfARG(sv_2mortal(vnormal(req))),
- SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))),
- SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
- );
- }
- }
- }
-
- RETPUSHYES;
- }
if (!SvOK(sv))
DIE(aTHX_ "Missing or undefined argument to require");
name = SvPV_nomg_const(sv, len);
if (!IS_SAFE_PATHNAME(name, len, "require")) {
DIE(aTHX_ "Can't locate %s: %s",
- pv_escape(newSVpvs_flags("",SVs_TEMP),SvPVX(sv),SvCUR(sv),
- SvCUR(sv)*2,NULL, SvUTF8(sv)?PERL_PV_ESCAPE_UNI:0),
+ pv_escape(newSVpvs_flags("",SVs_TEMP),name,len,len*2,
+ NULL, SvUTF8(sv)?PERL_PV_ESCAPE_UNI:0),
Strerror(ENOENT));
}
TAINT_PROPER("require");
DIE(aTHX_ "Attempt to reload %s aborted.\n"
"Compilation failed in require", unixname);
}
+
+ if (PL_op->op_flags & OPf_KIDS) {
+ SVOP * const kid = (SVOP*)cUNOP->op_first;
+
+ if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
+ /* require foo (or use foo) with a bareword.
+ Perl_load_module fakes up the identical optree, but its
+ arguments aren't restricted by the parser to real barewords.
+ */
+ const STRLEN package_len = len - 3;
+ const char slashdot[2] = {'/', '.'};
+#ifdef DOSISH
+ const char backslashdot[2] = {'\\', '.'};
+#endif
+
+ /* Disallow *purported* barewords that map to absolute
+ filenames, filenames relative to the current or parent
+ directory, or (*nix) hidden filenames. Also sanity check
+ that the generated filename ends .pm */
+ if (!path_searchable || len < 3 || name[0] == '.'
+ || !memEQ(name + package_len, ".pm", 3))
+ DIE(aTHX_ "Bareword in require maps to disallowed filename \"%"SVf"\"", sv);
+ if (memchr(name, 0, package_len)) {
+ /* diag_listed_as: Bareword in require contains "%s" */
+ DIE(aTHX_ "Bareword in require contains \"\\0\"");
+ }
+ if (ninstr(name, name + package_len, slashdot,
+ slashdot + sizeof(slashdot))) {
+ /* diag_listed_as: Bareword in require contains "%s" */
+ DIE(aTHX_ "Bareword in require contains \"/.\"");
+ }
+#ifdef DOSISH
+ if (ninstr(name, name + package_len, backslashdot,
+ backslashdot + sizeof(backslashdot))) {
+ /* diag_listed_as: Bareword in require contains "%s" */
+ DIE(aTHX_ "Bareword in require contains \"\\.\"");
+ }
+#endif
+ }
+ }
}
- LOADING_FILE_PROBE(unixname);
+ PERL_DTRACE_PROBE_FILE_LOADING(unixname);
/* prepare to compile file */
}
/* switch to eval mode */
- PUSHBLOCK(cx, CXt_EVAL, SP);
- PUSHEVAL(cx, name);
- cx->cx_old_savestack_ix = old_savestack_ix;
- cx->blk_eval.retop = PL_op->op_next;
+ cx = cx_pushblock(CXt_EVAL, gimme, SP, old_savestack_ix);
+ cx_pusheval(cx, PL_op->op_next, newSVpv(name, 0));
SAVECOPLINE(&PL_compiling);
CopLINE_set(&PL_compiling, 0);
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;
- LOADED_FILE_PROBE(unixname);
+ PERL_DTRACE_PROBE_FILE_LOADED(unixname);
return op;
}
+
+/* also used for: pp_dofile() */
+
+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);
+}
+
+
/* This is a op added to hold the hints hash for
pp_entereval. The hash can be modified by the code
being eval'ed, so we return a copy instead. */
dSP;
PERL_CONTEXT *cx;
SV *sv;
- const I32 gimme = GIMME_V;
+ const U8 gimme = GIMME_V;
const U32 was = PL_breakable_sub_gen;
char tbuf[TYPE_DIGITS(long) + 12];
bool saved_delete = FALSE;
* to do the dirty work for us */
runcv = find_runcv(&seq);
- PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
- PUSHEVAL(cx, 0);
- cx->cx_old_savestack_ix = old_savestack_ix;
- cx->blk_eval.retop = PL_op->op_next;
+ cx = cx_pushblock((CXt_EVAL|CXp_REAL), gimme, SP, old_savestack_ix);
+ cx_pusheval(cx, PL_op->op_next, NULL);
/* prepare to compile string */
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) {
}
}
+
+/* also tail-called by pp_return */
+
PP(pp_leaveeval)
{
- dSP;
- SV **newsp;
- I32 gimme;
+ SV **oldsp;
+ U8 gimme;
PERL_CONTEXT *cx;
OP *retop;
- I32 optype;
- SV *namesv;
+ int failed;
CV *evalcv;
- /* grab this value before POPEVAL restores old PL_in_eval */
- bool keep = cBOOL(PL_in_eval & EVAL_KEEPERR);
+ bool keep;
PERL_ASYNC_CHECK();
- cx = &cxstack[cxstack_ix];
+ cx = CX_CUR();
assert(CxTYPE(cx) == CXt_EVAL);
- newsp = PL_stack_base + cx->blk_oldsp;
+
+ oldsp = PL_stack_base + cx->blk_oldsp;
gimme = cx->blk_gimme;
- if (gimme != G_VOID) {
- PUTBACK;
- leave_common(newsp, newsp, gimme, SVs_TEMP, FALSE);
- SPAGAIN;
- }
- /* the POPEVAL does a leavescope, which frees the optree associated
+ /* did require return a false value? */
+ failed = CxOLD_OP_TYPE(cx) == OP_REQUIRE
+ && !(gimme == G_SCALAR
+ ? SvTRUE(*PL_stack_sp)
+ : PL_stack_sp > oldsp);
+
+ if (gimme == G_VOID)
+ PL_stack_sp = oldsp;
+ else
+ leave_adjust_stacks(oldsp, oldsp, gimme, 0);
+
+ /* the cx_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
* regex when running under 'use re Debug' because it needs PL_curcop
* 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;
+
+ /* grab this value before cx_popeval restores the old PL_in_eval */
+ keep = cBOOL(PL_in_eval & EVAL_KEEPERR);
retop = cx->blk_eval.retop;
evalcv = cx->blk_eval.cv;
-
-
#ifdef DEBUGGING
assert(CvDEPTH(evalcv) == 1);
#endif
CvDEPTH(evalcv) = 0;
- if (optype == OP_REQUIRE &&
- !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
- {
- /* 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));
- NOT_REACHED; /* NOTREACHED */
- /* die_unwind() did LEAVE, or we won't be here */
- }
- else {
- if (!keep)
- CLEAR_ERRSV();
- }
+ /* pop the CXt_EVAL, and if a require failed, croak */
+ S_pop_eval_context_maybe_croak(aTHX_ cx, NULL, failed);
- 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 = CX_CUR();
CX_LEAVE_SCOPE(cx);
- POPEVAL(cx);
- POPBLOCK(cx);
- cxstack_ix--;
- PERL_UNUSED_VAR(optype);
+ cx_popeval(cx);
+ cx_popblock(cx);
+ CX_POP(cx);
}
/* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
also needed by Perl_fold_constants. */
-PERL_CONTEXT *
-Perl_create_eval_scope(pTHX_ U32 flags)
+void
+Perl_create_eval_scope(pTHX_ OP *retop, U32 flags)
{
PERL_CONTEXT *cx;
- const I32 gimme = GIMME_V;
+ const U8 gimme = GIMME_V;
- PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
- PUSHEVAL(cx, 0);
- cx->cx_old_savestack_ix = PL_savestack_ix;
+ cx = cx_pushblock((CXt_EVAL|CXp_TRYBLOCK), gimme,
+ PL_stack_sp, PL_savestack_ix);
+ cx_pusheval(cx, retop, NULL);
PL_in_eval = EVAL_INEVAL;
if (flags & G_KEEPERR)
if (flags & G_FAKINGEVAL) {
PL_eval_root = PL_op; /* Only needed so that goto works right. */
}
- return cx;
}
PP(pp_entertry)
{
- PERL_CONTEXT * const cx = create_eval_scope(0);
- cx->blk_eval.retop = cLOGOP->op_other->op_next;
+ create_eval_scope(cLOGOP->op_other->op_next, 0);
return DOCATCH(PL_op->op_next);
}
+
+/* also tail-called by pp_return */
+
PP(pp_leavetry)
{
- SV **newsp;
- I32 gimme;
+ SV **oldsp;
+ U8 gimme;
PERL_CONTEXT *cx;
- I32 optype;
OP *retop;
PERL_ASYNC_CHECK();
- cx = &cxstack[cxstack_ix];
+ cx = CX_CUR();
assert(CxTYPE(cx) == CXt_EVAL);
- newsp = PL_stack_base + cx->blk_oldsp;
+ oldsp = PL_stack_base + cx->blk_oldsp;
gimme = cx->blk_gimme;
if (gimme == G_VOID)
- PL_stack_sp = newsp;
+ PL_stack_sp = oldsp;
else
- leave_common(newsp, newsp, gimme, SVs_PADTMP|SVs_TEMP, FALSE);
+ leave_adjust_stacks(oldsp, oldsp, gimme, 1);
CX_LEAVE_SCOPE(cx);
- POPEVAL(cx);
- POPBLOCK(cx);
- cxstack_ix--;
+ cx_popeval(cx);
+ cx_popblock(cx);
retop = cx->blk_eval.retop;
- PERL_UNUSED_VAR(optype);
+ CX_POP(cx);
CLEAR_ERRSV();
return retop;
{
dSP;
PERL_CONTEXT *cx;
- const I32 gimme = GIMME_V;
+ const U8 gimme = GIMME_V;
SV *origsv = DEFSV;
SV *newsv = POPs;
assert(!PL_op->op_targ); /* used to be set for lexical $_ */
GvSV(PL_defgv) = SvREFCNT_inc(newsv);
- PUSHBLOCK(cx, CXt_GIVEN, SP);
- PUSHGIVEN(cx, origsv);
+ cx = cx_pushblock(CXt_GIVEN, gimme, SP, PL_savestack_ix);
+ cx_pushgiven(cx, origsv);
RETURN;
}
PP(pp_leavegiven)
{
PERL_CONTEXT *cx;
- I32 gimme;
- SV **newsp;
+ U8 gimme;
+ SV **oldsp;
PERL_UNUSED_CONTEXT;
- cx = &cxstack[cxstack_ix];
+ cx = CX_CUR();
assert(CxTYPE(cx) == CXt_GIVEN);
- newsp = PL_stack_base + cx->blk_oldsp;
+ oldsp = PL_stack_base + cx->blk_oldsp;
gimme = cx->blk_gimme;
if (gimme == G_VOID)
- PL_stack_sp = newsp;
+ PL_stack_sp = oldsp;
else
- leave_common(newsp, newsp, gimme, SVs_PADTMP|SVs_TEMP, FALSE);
+ leave_adjust_stacks(oldsp, oldsp, gimme, 1);
CX_LEAVE_SCOPE(cx);
- POPGIVEN(cx);
- POPBLOCK(cx);
- cxstack_ix--;
+ cx_popgiven(cx);
+ cx_popblock(cx);
+ CX_POP(cx);
return NORMAL;
}
{
dSP;
PERL_CONTEXT *cx;
- const I32 gimme = GIMME_V;
+ const U8 gimme = GIMME_V;
/* This is essentially an optimization: if the match
fails, we don't want to push a context and then
to the op that follows the leavewhen.
RETURNOP calls PUTBACK which restores the stack pointer after the POPs.
*/
- if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
+ if (!(PL_op->op_flags & OPf_SPECIAL) && !SvTRUEx(POPs))
RETURNOP(cLOGOP->op_other->op_next);
- PUSHBLOCK(cx, CXt_WHEN, SP);
- PUSHWHEN(cx);
+ cx = cx_pushblock(CXt_WHEN, gimme, SP, PL_savestack_ix);
+ cx_pushwhen(cx);
RETURN;
}
{
I32 cxix;
PERL_CONTEXT *cx;
- I32 gimme;
- SV **newsp;
+ U8 gimme;
+ SV **oldsp;
- cx = &cxstack[cxstack_ix];
+ cx = CX_CUR();
assert(CxTYPE(cx) == CXt_WHEN);
gimme = cx->blk_gimme;
DIE(aTHX_ "Can't \"%s\" outside a topicalizer",
PL_op->op_flags & OPf_SPECIAL ? "default" : "when");
- newsp = PL_stack_base + cx->blk_oldsp;
+ oldsp = PL_stack_base + cx->blk_oldsp;
if (gimme == G_VOID)
- PL_stack_sp = newsp;
+ PL_stack_sp = oldsp;
else
- leave_common(newsp, newsp, gimme, SVs_PADTMP|SVs_TEMP, FALSE);
+ leave_adjust_stacks(oldsp, oldsp, gimme, 1);
+
/* pop the WHEN, BLOCK and anything else before the GIVEN/FOR */
assert(cxix < cxstack_ix);
dounwind(cxix);
if (CxFOREACH(cx)) {
/* emulate pp_next. Note that any stack(s) cleanup will be
* done by the pp_unstack which op_nextop should point to */
- TOPBLOCK(cx);
+ cx = CX_CUR();
+ cx_topblock(cx);
PL_curcop = cx->blk_oldcop;
return cx->blk_loop.my_op->op_nextop;
}
{
I32 cxix;
PERL_CONTEXT *cx;
+ OP *nextop;
cxix = dopoptowhen(cxstack_ix);
if (cxix < 0)
if (cxix < cxstack_ix)
dounwind(cxix);
- cx = &cxstack[cxstack_ix];
+ cx = CX_CUR();
assert(CxTYPE(cx) == CXt_WHEN);
PL_stack_sp = PL_stack_base + cx->blk_oldsp;
CX_LEAVE_SCOPE(cx);
- POPWHEN(cx);
- POPBLOCK(cx);
- cxstack_ix--;
+ cx_popwhen(cx);
+ cx_popblock(cx);
+ nextop = cx->blk_givwhen.leave_op->op_next;
+ CX_POP(cx);
- return cx->blk_givwhen.leave_op->op_next;
+ return nextop;
}
PP(pp_break)
dounwind(cxix);
/* Restore the sp at the time we entered the given block */
- TOPBLOCK(cx);
+ cx = CX_CUR();
+ PL_stack_sp = PL_stack_base + cx->blk_oldsp;
return cx->blk_givwhen.leave_op;
}
https://perl5.git.perl.org / perl5.git / blobdiff