dVAR;
dSP;
I32 cxix;
+ const PERL_CONTEXT *cx;
EXTEND(SP, 1);
- cxix = dopoptosub(cxstack_ix);
- if (cxix < 0)
+ if (PL_op->op_private & OPpOFFBYONE) {
+ if (!(cx = caller_cx(1,NULL))) RETPUSHUNDEF;
+ }
+ else {
+ cxix = dopoptosub(cxstack_ix);
+ if (cxix < 0)
RETPUSHUNDEF;
+ cx = &cxstack[cxix];
+ }
- switch (cxstack[cxix].blk_gimme) {
+ switch (cx->blk_gimme) {
case G_ARRAY:
RETPUSHYES;
case G_SCALAR:
return 0;
}
+/* only used by PUSHSUB */
+I32
+Perl_was_lvalue_sub(pTHX)
+{
+ dVAR;
+ const I32 cxix = dopoptosub(cxstack_ix-1);
+ assert(cxix >= 0); /* We should only be called from inside subs */
+
+ if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
+ return CxLVAL(cxstack + cxix);
+ else
+ return 0;
+}
+
STATIC I32
S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
{
AV * const ary = cx->blk_sub.argarray;
const int off = AvARRAY(ary) - AvALLOC(ary);
- if (!PL_dbargs)
+ if (!PL_dbargs || AvREAL(PL_dbargs))
Perl_init_dbargs(aTHX);
if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
return newsp;
}
+PP(pp_enter)
+{
+ dVAR; dSP;
+ register PERL_CONTEXT *cx;
+ I32 gimme = GIMME_V;
+
+ ENTER_with_name("block");
+
+ SAVETMPS;
+ PUSHBLOCK(cx, CXt_BLOCK, SP);
+
+ RETURN;
+}
+
+PP(pp_leave)
+{
+ dVAR; dSP;
+ register PERL_CONTEXT *cx;
+ SV **newsp;
+ PMOP *newpm;
+ I32 gimme;
+
+ if (PL_op->op_flags & OPf_SPECIAL) {
+ cx = &cxstack[cxstack_ix];
+ cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
+ }
+
+ POPBLOCK(cx,newpm);
+
+ gimme = OP_GIMME(PL_op, (cxstack_ix >= 0) ? gimme : G_SCALAR);
+
+ TAINT_NOT;
+ SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
+ PL_curpm = newpm; /* Don't pop $1 et al till now */
+
+ LEAVE_with_name("block");
+
+ RETURN;
+}
+
PP(pp_enteriter)
{
dVAR; dSP; dMARK;
if (gimme == G_SCALAR) {
if (CxLVAL(cx) && !ref) { /* Leave it as it is if we can. */
SV *sv;
+ const char *what = NULL;
if (MARK < SP) {
assert(MARK+1 == SP);
if ((SvPADTMP(TOPs) ||
== SVf_READONLY
) &&
!SvSMAGICAL(TOPs)) {
- LEAVE;
- cxstack_ix--;
- POPSUB(cx,sv);
- PL_curpm = newpm;
- LEAVESUB(sv);
- Perl_croak(aTHX_
- "Can't return %s from lvalue subroutine",
+ what =
SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
- : "a readonly value" : "a temporary");
- }
- else { /* Can be a localized value
- EXTEND_MORTAL(1); * subject to deletion. */
- PL_tmps_stack[++PL_tmps_ix] = *SP;
- SvREFCNT_inc_void(*SP);
- *++newsp = *SP;
+ : "a readonly value" : "a temporary";
}
+ else goto copy_sv;
}
else {
/* sub:lvalue{} will take us here. */
- LEAVE;
- cxstack_ix--;
- POPSUB(cx,sv);
- PL_curpm = newpm;
- LEAVESUB(sv);
- Perl_croak(aTHX_
- /* diag_listed_as: Can't return %s from lvalue subroutine*/
- "Can't return undef from lvalue subroutine"
- );
+ what = "undef";
}
+ LEAVE;
+ cxstack_ix--;
+ POPSUB(cx,sv);
+ PL_curpm = newpm;
+ LEAVESUB(sv);
+ Perl_croak(aTHX_
+ "Can't return %s from lvalue subroutine", what
+ );
}
- else if (MARK < SP) {
+ if (MARK < SP) {
+ copy_sv:
if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
*++newsp = SvREFCNT_inc(*SP);
FREETMPS;
assert(cx->blk_sub.retop->op_type == OP_RV2HV);
deref_type = OPpDEREF_HV;
}
- vivify_ref(TOPs, deref_type);
+ TOPs = vivify_ref(TOPs, deref_type);
}
}
}
bool popsub2 = FALSE;
bool clear_errsv = FALSE;
bool lval = FALSE;
- bool gmagic = FALSE;
I32 gimme;
SV **newsp;
PMOP *newpm;
popsub2 = TRUE;
lval = !!CvLVALUE(cx->blk_sub.cv);
retop = cx->blk_sub.retop;
- gmagic = CxLVAL(cx) & OPpENTERSUB_DEREF;
cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
break;
case CXt_EVAL:
FREETMPS;
*++newsp = sv_mortalcopy(sv);
SvREFCNT_dec(sv);
- if (gmagic) SvGETMAGIC(sv);
}
}
else if (SvTEMP(*SP) && SvREFCNT(*SP) == 1) {
*++newsp = *SP;
- if (gmagic) SvGETMAGIC(*SP);
}
else
*++newsp = sv_mortalcopy(*SP);
CvEVAL_on(PL_compcv);
assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
+ cxstack[cxstack_ix].blk_gimme = gimme;
CvOUTSIDE_SEQ(PL_compcv) = seq;
CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
if (yystatus || PL_parser->error_count || !PL_eval_root) {
SV **newsp; /* Used by POPBLOCK. */
- PERL_CONTEXT *cx = NULL;
+ PERL_CONTEXT *cx;
I32 optype; /* Used by POPEVAL. */
- SV *namesv = NULL;
+ SV *namesv;
const char *msg;
+ cx = NULL;
+ namesv = NULL;
PERL_UNUSED_VAR(newsp);
PERL_UNUSED_VAR(optype);
} else
SAVEFREEOP(PL_eval_root);
- /* Set the context for this new optree.
- * Propagate the context from the eval(). */
- if ((gimme & G_WANT) == G_VOID)
- scalarvoid(PL_eval_root);
- else if ((gimme & G_WANT) == G_ARRAY)
- list(PL_eval_root);
- else
- scalar(PL_eval_root);
-
DEBUG_x(dump_eval());
/* Register with debugger: */
SAVECOMPILEWARNINGS();
PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
cophh_free(CopHINTHASH_get(&PL_compiling));
- if (Perl_fetch_cop_label(aTHX_ PL_curcop, NULL, NULL)) {
+ if (Perl_cop_fetch_label(aTHX_ PL_curcop, 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
= cophh_copy(PL_curcop->cop_hints_hash->refcounted_he_next);
/* Check the assumption that this removed the label. */
- assert(Perl_fetch_cop_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
+ assert(Perl_cop_fetch_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
}
else
PL_compiling.cop_hints_hash = cophh_copy(PL_curcop->cop_hints_hash);
if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
RETURNOP(cLOGOP->op_other->op_next);
- ENTER_with_name("eval");
+ ENTER_with_name("when");
SAVETMPS;
PUSHBLOCK(cx, CXt_WHEN, SP);
PP(pp_leavewhen)
{
dVAR; dSP;
+ I32 cxix;
register PERL_CONTEXT *cx;
- I32 gimme __attribute__unused__;
+ I32 gimme;
SV **newsp;
PMOP *newpm;
+ cxix = dopoptogiven(cxstack_ix);
+ if (cxix < 0)
+ DIE(aTHX_ "Can't use when() outside a topicalizer");
+
POPBLOCK(cx,newpm);
assert(CxTYPE(cx) == CXt_WHEN);
- SP = newsp;
- PUTBACK;
-
+ TAINT_NOT;
+ SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
PL_curpm = newpm; /* pop $1 et al */
- LEAVE_with_name("eval");
- return NORMAL;
+ LEAVE_with_name("when");
+
+ if (cxix < cxstack_ix)
+ dounwind(cxix);
+
+ cx = &cxstack[cxix];
+
+ if (CxFOREACH(cx)) {
+ /* clear off anything above the scope we're re-entering */
+ I32 inner = PL_scopestack_ix;
+
+ TOPBLOCK(cx);
+ if (PL_scopestack_ix < inner)
+ leave_scope(PL_scopestack[PL_scopestack_ix]);
+ PL_curcop = cx->blk_oldcop;
+
+ return cx->blk_loop.my_op->op_nextop;
+ }
+ else
+ RETURNOP(cx->blk_givwhen.leave_op);
}
PP(pp_continue)
{
- dVAR;
+ dVAR; dSP;
I32 cxix;
register PERL_CONTEXT *cx;
- I32 inner;
+ I32 gimme;
+ SV **newsp;
+ PMOP *newpm;
+
+ PERL_UNUSED_VAR(gimme);
cxix = dopoptowhen(cxstack_ix);
if (cxix < 0)
DIE(aTHX_ "Can't \"continue\" outside a when block");
+
if (cxix < cxstack_ix)
dounwind(cxix);
- /* clear off anything above the scope we're re-entering */
- inner = PL_scopestack_ix;
- TOPBLOCK(cx);
- if (PL_scopestack_ix < inner)
- leave_scope(PL_scopestack[PL_scopestack_ix]);
- PL_curcop = cx->blk_oldcop;
- return cx->blk_givwhen.leave_op;
+ POPBLOCK(cx,newpm);
+ assert(CxTYPE(cx) == CXt_WHEN);
+
+ SP = newsp;
+ PL_curpm = newpm; /* pop $1 et al */
+
+ LEAVE_with_name("when");
+ RETURNOP(cx->blk_givwhen.leave_op->op_next);
}
PP(pp_break)
dVAR;
I32 cxix;
register PERL_CONTEXT *cx;
- I32 inner;
- dSP;
cxix = dopoptogiven(cxstack_ix);
- if (cxix < 0) {
- if (PL_op->op_flags & OPf_SPECIAL)
- DIE(aTHX_ "Can't use when() outside a topicalizer");
- else
- DIE(aTHX_ "Can't \"break\" outside a given block");
- }
- if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
+ if (cxix < 0)
+ DIE(aTHX_ "Can't \"break\" outside a given block");
+
+ cx = &cxstack[cxix];
+ if (CxFOREACH(cx))
DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
if (cxix < cxstack_ix)
dounwind(cxix);
-
- /* clear off anything above the scope we're re-entering */
- inner = PL_scopestack_ix;
+
+ /* Restore the sp at the time we entered the given block */
TOPBLOCK(cx);
- if (PL_scopestack_ix < inner)
- leave_scope(PL_scopestack[PL_scopestack_ix]);
- PL_curcop = cx->blk_oldcop;
- if (CxFOREACH(cx))
- return (cx)->blk_loop.my_op->op_nextop;
- else
- /* RETURNOP calls PUTBACK which restores the old old sp */
- RETURNOP(cx->blk_givwhen.leave_op);
+ return cx->blk_givwhen.leave_op;
}
static MAGIC *
https://perl5.git.perl.org / perl5.git / blobdiff