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:
if (PL_op->op_flags & OPf_SPECIAL)
PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
- if (DO_UTF8(tmpstr)) {
- assert (SvUTF8(tmpstr));
- } else if (SvUTF8(tmpstr)) {
+ if (!DO_UTF8(tmpstr) && SvUTF8(tmpstr)) {
/* Not doing UTF-8, despite what the SV says. Is this only if
we're trapped in use 'bytes'? */
/* Make a copy of the octet sequence, but without the flag on,
s -= RX_GOFS(rx);
/* Are we done */
+ /* I believe that we can't set REXEC_SCREAM here if
+ SvSCREAM(cx->sb_targ) is true because SvPVX(cx->sb_targ) isn't always
+ equal to s. [See the comment before Perl_re_intuit_start(), which is
+ called from Perl_regexec_flags(), which says that it should be when
+ SvSCREAM() is true.] s, cx->sb_strend and orig will be consistent
+ with SvPVX(cx->sb_targ), as substconst doesn't modify cx->sb_targ
+ during the match. */
if (CxONCE(cx) || s < orig ||
!CALLREGEXEC(rx, s, cx->sb_strend, orig,
(s == m) + RX_GOFS(rx), cx->sb_targ, NULL,
? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
: (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
{
- SV * const targ = cx->sb_targ;
+ SV *targ = cx->sb_targ;
assert(cx->sb_strend >= s);
if(cx->sb_strend > s) {
if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
cx->sb_rxtainted |= SUBST_TAINT_PAT;
+ if (pm->op_pmflags & PMf_NONDESTRUCT) {
+ PUSHs(dstr);
+ /* From here on down we're using the copy, and leaving the
+ original untouched. */
+ targ = dstr;
+ }
+ else {
#ifdef PERL_OLD_COPY_ON_WRITE
- if (SvIsCOW(targ)) {
- sv_force_normal_flags(targ, SV_COW_DROP_PV);
- } else
+ if (SvIsCOW(targ)) {
+ sv_force_normal_flags(targ, SV_COW_DROP_PV);
+ } else
#endif
- {
- SvPV_free(targ);
- }
- SvPV_set(targ, SvPVX(dstr));
- SvCUR_set(targ, SvCUR(dstr));
- SvLEN_set(targ, SvLEN(dstr));
- if (DO_UTF8(dstr))
- SvUTF8_on(targ);
- SvPV_set(dstr, NULL);
-
- if (pm->op_pmflags & PMf_NONDESTRUCT)
- PUSHs(targ);
- else
+ {
+ SvPV_free(targ);
+ }
+ SvPV_set(targ, SvPVX(dstr));
+ SvCUR_set(targ, SvCUR(dstr));
+ SvLEN_set(targ, SvLEN(dstr));
+ if (DO_UTF8(dstr))
+ SvUTF8_on(targ);
+ SvPV_set(dstr, NULL);
+
mPUSHi(saviters - 1);
- (void)SvPOK_only_UTF8(targ);
+ (void)SvPOK_only_UTF8(targ);
+ }
/* update the taint state of various various variables in
* preparation for final exit.
}
cx->sb_s = RX_OFFS(rx)[0].end + orig;
{ /* Update the pos() information. */
- SV * const sv = cx->sb_targ;
+ SV * const sv
+ = (pm->op_pmflags & PMf_NONDESTRUCT) ? cx->sb_dstr : cx->sb_targ;
MAGIC *mg;
SvUPGRADE(sv, SVt_PVMG);
if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
if (cx->sb_iters > 1 && (cx->sb_rxtainted &
(SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL)))
- SvTAINTED_on(cx->sb_targ);
+ SvTAINTED_on((pm->op_pmflags & PMf_NONDESTRUCT)
+ ? cx->sb_dstr : cx->sb_targ);
TAINT_NOT;
}
rxres_save(&cx->sb_rxres, rx);
if (RANGE_IS_NUMERIC(left,right)) {
register IV i, j;
IV max;
- if ((SvOK(left) && SvNV(left) < IV_MIN) ||
- (SvOK(right) && SvNV(right) > IV_MAX))
+ if ((SvOK(left) && SvNV_nomg(left) < IV_MIN) ||
+ (SvOK(right) && SvNV_nomg(right) > IV_MAX))
DIE(aTHX_ "Range iterator outside integer range");
- i = SvIV(left);
- max = SvIV(right);
+ i = SvIV_nomg(left);
+ max = SvIV_nomg(right);
if (max >= i) {
j = max - i + 1;
EXTEND_MORTAL(j);
}
}
else {
- SV * const final = sv_mortalcopy(right);
- STRLEN len;
- const char * const tmps = SvPV_const(final, len);
+ STRLEN len, llen;
+ const char * const lpv = SvPV_nomg_const(left, llen);
+ const char * const tmps = SvPV_nomg_const(right, len);
- SV *sv = sv_mortalcopy(left);
- SvPV_force_nolen(sv);
+ SV *sv = newSVpvn_flags(lpv, llen, SvUTF8(left)|SVs_TEMP);
while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
XPUSHs(sv);
if (strEQ(SvPVX_const(sv),tmps))
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)
{
dVAR;
I32 optype;
+ if (!PL_curstackinfo) /* can happen if die during thread cloning */
+ return;
+
while (cxstack_ix > cxix) {
SV *sv;
register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
if (PL_in_eval) {
if (PL_in_eval & EVAL_KEEPERR) {
- Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %s",
- SvPV_nolen_const(err));
+ Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf,
+ SVfARG(err));
}
else
sv_catsv(ERRSV, err);
PL_curcop = oldcop;
if (optype == OP_REQUIRE) {
- const char* const msg = SvPVx_nolen_const(exceptsv);
(void)hv_store(GvHVn(PL_incgv),
- SvPVX_const(namesv), SvCUR(namesv),
+ 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_ "%sCompilation failed in require",
- *msg ? msg : "Unknown error\n");
+ Perl_croak(aTHX_ "%"SVf"Compilation failed in require",
+ SVfARG(exceptsv ? exceptsv : newSVpvs_flags("Unknown error\n",
+ SVs_TEMP)));
}
if (in_eval & EVAL_KEEPERR) {
- Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %s",
- SvPV_nolen_const(exceptsv));
+ Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf,
+ SVfARG(exceptsv));
}
else {
sv_setsv(ERRSV, exceptsv);
register const PERL_CONTEXT *cx;
const PERL_CONTEXT *dbcx;
I32 gimme;
- const char *stashname;
+ const HEK *stash_hek;
I32 count = 0;
+ bool has_arg = MAXARG && TOPs;
- if (MAXARG)
+ if (MAXARG) {
+ if (has_arg)
count = POPi;
+ else (void)POPs;
+ }
- cx = caller_cx(count, &dbcx);
+ cx = caller_cx(count + !!(PL_op->op_private & OPpOFFBYONE), &dbcx);
if (!cx) {
if (GIMME != G_ARRAY) {
EXTEND(SP, 1);
RETURN;
}
- stashname = CopSTASHPV(cx->blk_oldcop);
+ stash_hek = HvNAME_HEK((HV*)CopSTASH(cx->blk_oldcop));
if (GIMME != G_ARRAY) {
EXTEND(SP, 1);
- if (!stashname)
+ if (!stash_hek)
PUSHs(&PL_sv_undef);
else {
dTARGET;
- sv_setpv(TARG, stashname);
+ sv_sethek(TARG, stash_hek);
PUSHs(TARG);
}
RETURN;
EXTEND(SP, 11);
- if (!stashname)
+ if (!stash_hek)
PUSHs(&PL_sv_undef);
- else
- mPUSHs(newSVpv(stashname, 0));
+ else {
+ dTARGET;
+ sv_sethek(TARG, stash_hek);
+ PUSHTARG;
+ }
mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
mPUSHi((I32)CopLINE(cx->blk_oldcop));
- if (!MAXARG)
+ if (!has_arg)
RETURN;
if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
GV * const cvgv = CvGV(dbcx->blk_sub.cv);
AV * const ary = cx->blk_sub.argarray;
const int off = AvARRAY(ary) - AvALLOC(ary);
- if (!PL_dbargs)
- Perl_init_dbargs(aTHX);
+ Perl_init_dbargs(aTHX);
if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
av_extend(PL_dbargs, AvFILLp(ary) + off);
{
dVAR;
dSP;
- const char * const tmps = (MAXARG < 1) ? (const char *)"" : POPpconstx;
+ const char * const tmps =
+ (MAXARG < 1 || (!TOPs && !POPs)) ? (const char *)"" : POPpconstx;
sv_reset(tmps, CopSTASH(PL_curcop));
PUSHs(&PL_sv_yes);
RETURN;
return NORMAL;
}
+STATIC SV **
+S_adjust_stack_on_leave(pTHX_ SV **newsp, SV **sp, SV **mark, I32 gimme, U32 flags)
+{
+ bool padtmp = 0;
+ PERL_ARGS_ASSERT_ADJUST_STACK_ON_LEAVE;
+
+ if (flags & SVs_PADTMP) {
+ flags &= ~SVs_PADTMP;
+ padtmp = 1;
+ }
+ if (gimme == G_SCALAR) {
+ if (MARK < SP)
+ *++newsp = ((SvFLAGS(*SP) & flags) || (padtmp && SvPADTMP(*SP)))
+ ? *SP : sv_mortalcopy(*SP);
+ else {
+ /* MEXTEND() only updates MARK, so reuse it instead of newsp. */
+ MARK = newsp;
+ MEXTEND(MARK, 1);
+ *++MARK = &PL_sv_undef;
+ return MARK;
+ }
+ }
+ else if (gimme == G_ARRAY) {
+ /* in case LEAVE wipes old return values */
+ while (++MARK <= SP) {
+ if ((SvFLAGS(*MARK) & flags) || (padtmp && SvPADTMP(*MARK)))
+ *++newsp = *MARK;
+ else {
+ *++newsp = sv_mortalcopy(*MARK);
+ TAINT_NOT; /* Each item is independent */
+ }
+ }
+ /* When this function was called with MARK == newsp, we reach this
+ * point with SP == newsp. */
+ }
+
+ 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;
assumptions */
assert(CxTYPE(cx) == CXt_LOOP_LAZYIV);
#ifdef NV_PRESERVES_UV
- if ((SvOK(sv) && ((SvNV(sv) < (NV)IV_MIN) ||
- (SvNV(sv) > (NV)IV_MAX)))
+ if ((SvOK(sv) && ((SvNV_nomg(sv) < (NV)IV_MIN) ||
+ (SvNV_nomg(sv) > (NV)IV_MAX)))
||
- (SvOK(right) && ((SvNV(right) > (NV)IV_MAX) ||
- (SvNV(right) < (NV)IV_MIN))))
+ (SvOK(right) && ((SvNV_nomg(right) > (NV)IV_MAX) ||
+ (SvNV_nomg(right) < (NV)IV_MIN))))
#else
- if ((SvOK(sv) && ((SvNV(sv) <= (NV)IV_MIN)
+ if ((SvOK(sv) && ((SvNV_nomg(sv) <= (NV)IV_MIN)
||
- ((SvNV(sv) > 0) &&
- ((SvUV(sv) > (UV)IV_MAX) ||
- (SvNV(sv) > (NV)UV_MAX)))))
+ ((SvNV_nomg(sv) > 0) &&
+ ((SvUV_nomg(sv) > (UV)IV_MAX) ||
+ (SvNV_nomg(sv) > (NV)UV_MAX)))))
||
- (SvOK(right) && ((SvNV(right) <= (NV)IV_MIN)
+ (SvOK(right) && ((SvNV_nomg(right) <= (NV)IV_MIN)
||
- ((SvNV(right) > 0) &&
- ((SvUV(right) > (UV)IV_MAX) ||
- (SvNV(right) > (NV)UV_MAX))))))
+ ((SvNV_nomg(right) > 0) &&
+ ((SvUV_nomg(right) > (UV)IV_MAX) ||
+ (SvNV_nomg(right) > (NV)UV_MAX))
+ ))))
#endif
DIE(aTHX_ "Range iterator outside integer range");
- cx->blk_loop.state_u.lazyiv.cur = SvIV(sv);
- cx->blk_loop.state_u.lazyiv.end = SvIV(right);
+ 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;
newsp = PL_stack_base + cx->blk_loop.resetsp;
TAINT_NOT;
- if (gimme == G_VOID)
- NOOP;
- else if (gimme == G_SCALAR) {
- if (mark < SP)
- *++newsp = sv_mortalcopy(*SP);
- else
- *++newsp = &PL_sv_undef;
- }
- else {
- while (mark < SP) {
- *++newsp = sv_mortalcopy(*++mark);
- TAINT_NOT; /* Each item is independent */
- }
- }
- SP = newsp;
+ SP = adjust_stack_on_leave(newsp, SP, MARK, gimme, 0);
PUTBACK;
POPLOOP(cx); /* Stack values are safe: release loop vars ... */
return NORMAL;
}
+STATIC void
+S_return_lvalues(pTHX_ SV **mark, SV **sp, SV **newsp, I32 gimme,
+ PERL_CONTEXT *cx, PMOP *newpm)
+{
+ const bool ref = !!(CxLVAL(cx) & OPpENTERSUB_INARGS);
+ 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) ||
+ (SvFLAGS(TOPs) & (SVf_READONLY | SVf_FAKE))
+ == SVf_READONLY
+ ) &&
+ !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";
+ }
+ LEAVE;
+ cxstack_ix--;
+ POPSUB(cx,sv);
+ PL_curpm = newpm;
+ LEAVESUB(sv);
+ 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) {
+ *++newsp = SvREFCNT_inc(*SP);
+ FREETMPS;
+ sv_2mortal(*newsp);
+ }
+ else
+ *++newsp =
+ !SvTEMP(*SP)
+ ? sv_2mortal(SvREFCNT_inc_simple_NN(*SP))
+ : *SP;
+ }
+ else {
+ EXTEND(newsp,1);
+ *++newsp = &PL_sv_undef;
+ }
+ 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))
+ while (++MARK <= SP)
+ *++newsp =
+ SvTEMP(*MARK)
+ ? *MARK
+ : ref && SvFLAGS(*MARK) & SVs_PADTMP
+ ? sv_mortalcopy(*MARK)
+ : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
+ else while (++MARK <= SP) {
+ if (*MARK != &PL_sv_undef
+ && (SvPADTMP(*MARK)
+ || (SvFLAGS(*MARK) & (SVf_READONLY|SVf_FAKE))
+ == SVf_READONLY
+ )
+ ) {
+ SV *sv;
+ /* Might be flattened array after $#array = */
+ PUTBACK;
+ LEAVE;
+ cxstack_ix--;
+ POPSUB(cx,sv);
+ PL_curpm = newpm;
+ LEAVESUB(sv);
+ Perl_croak(aTHX_
+ "Can't return a %s from lvalue subroutine",
+ SvREADONLY(TOPs) ? "readonly value" : "temporary");
+ }
+ else
+ *++newsp =
+ SvTEMP(*MARK)
+ ? *MARK
+ : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
+ }
+ }
+ PL_stack_sp = newsp;
+}
+
PP(pp_return)
{
dVAR; dSP; dMARK;
{
/* Unassume the success we assumed earlier. */
(void)hv_delete(GvHVn(PL_incgv),
- SvPVX_const(namesv), SvCUR(namesv),
+ SvPVX_const(namesv),
+ SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
G_DISCARD);
DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv));
}
}
TAINT_NOT;
- if (gimme == G_SCALAR) {
+ if (lval) S_return_lvalues(aTHX_ MARK, SP, newsp, gimme, cx, newpm);
+ else {
+ if (gimme == G_SCALAR) {
if (MARK < SP) {
if (popsub2) {
if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
- if (SvTEMP(TOPs)) {
+ if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1) {
*++newsp = SvREFCNT_inc(*SP);
FREETMPS;
sv_2mortal(*newsp);
SvREFCNT_dec(sv);
}
}
+ else if (SvTEMP(*SP) && SvREFCNT(*SP) == 1) {
+ *++newsp = *SP;
+ }
else
- *++newsp =
- (lval || SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
+ *++newsp = sv_mortalcopy(*SP);
}
else
*++newsp = sv_mortalcopy(*SP);
}
else
*++newsp = &PL_sv_undef;
- }
- else if (gimme == G_ARRAY) {
+ }
+ else if (gimme == G_ARRAY) {
while (++MARK <= SP) {
- *++newsp = popsub2 && (lval || SvTEMP(*MARK))
+ *++newsp = popsub2 && SvTEMP(*MARK) && SvREFCNT(*MARK) == 1
? *MARK : sv_mortalcopy(*MARK);
TAINT_NOT; /* Each item is independent */
}
+ }
+ PL_stack_sp = newsp;
}
- PL_stack_sp = newsp;
LEAVE;
/* Stack values are safe: */
return retop;
}
+/* This duplicates parts of pp_leavesub, so that it can share code with
+ * pp_return */
+PP(pp_leavesublv)
+{
+ dVAR; dSP;
+ SV **newsp;
+ PMOP *newpm;
+ I32 gimme;
+ register PERL_CONTEXT *cx;
+ SV *sv;
+
+ if (CxMULTICALL(&cxstack[cxstack_ix]))
+ return 0;
+
+ POPBLOCK(cx,newpm);
+ cxstack_ix++; /* temporarily protect top context */
+
+ TAINT_NOT;
+
+ S_return_lvalues(aTHX_ newsp, SP, newsp, gimme, cx, newpm);
+
+ LEAVE;
+ cxstack_ix--;
+ POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
+ PL_curpm = newpm; /* ... and pop $1 et al */
+
+ LEAVESUB(sv);
+ return cx->blk_sub.retop;
+}
+
PP(pp_last)
{
dVAR; dSP;
}
TAINT_NOT;
- if (gimme == G_SCALAR) {
- if (MARK < SP)
- *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
- ? *SP : sv_mortalcopy(*SP);
- else
- *++newsp = &PL_sv_undef;
- }
- else if (gimme == G_ARRAY) {
- while (++MARK <= SP) {
- *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
- ? *MARK : sv_mortalcopy(*MARK);
- TAINT_NOT; /* Each item is independent */
- }
- }
- SP = newsp;
+ SP = adjust_stack_on_leave(newsp, SP, MARK, gimme,
+ pop2 == CXt_SUB ? SVs_TEMP : 0);
PUTBACK;
LEAVE;
/* autoloaded stub? */
if (cv != GvCV(gv) && (cv = GvCV(gv)))
goto retry;
- autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
- GvNAMELEN(gv), FALSE);
+ autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv),
+ GvNAMELEN(gv),
+ GvNAMEUTF8(gv) ? SVf_UTF8 : 0);
if (autogv && (cv = GvCV(autogv)))
goto retry;
tmpstr = sv_newmortal();
sub_crush_depth(cv);
pad_push(padlist, CvDEPTH(cv));
}
+ PL_curcop = cx->blk_oldcop;
SAVECOMPPAD();
PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
if (CxHASARGS(cx))
if (MAXARG < 1)
anum = 0;
+ else if (!TOPs) {
+ anum = 0; (void)POPs;
+ }
else {
anum = SvIVx(POPs);
#ifdef VMS
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));
/* make sure we compile in the right package */
if (CopSTASH_ne(PL_curcop, PL_curstash)) {
- SAVESPTR(PL_curstash);
- PL_curstash = CopSTASH(PL_curcop);
+ SAVEGENERICSV(PL_curstash);
+ PL_curstash = (HV *)SvREFCNT_inc_simple(CopSTASH(PL_curcop));
}
/* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
SAVESPTR(PL_beginav);
PL_eval_root = NULL;
PL_curcop = &PL_compiling;
- CopARYBASE_set(PL_curcop, 0);
if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
PL_in_eval |= EVAL_KEEPERR;
else
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;
- const char *msg;
+ SV *namesv;
+ cx = NULL;
+ namesv = NULL;
PERL_UNUSED_VAR(newsp);
PERL_UNUSED_VAR(optype);
if (yystatus != 3)
LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE. */
- msg = SvPVx_nolen_const(ERRSV);
if (in_require) {
if (!cx) {
/* If cx is still NULL, it means that we didn't go in the
namesv = cx->blk_eval.old_namesv;
}
(void)hv_store(GvHVn(PL_incgv),
- SvPVX_const(namesv), SvCUR(namesv),
+ SvPVX_const(namesv),
+ SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
&PL_sv_undef, 0);
- Perl_croak(aTHX_ "%sCompilation failed in require",
- *msg ? msg : "Unknown error\n");
+ Perl_croak(aTHX_ "%"SVf"Compilation failed in require",
+ SVfARG(ERRSV
+ ? ERRSV
+ : newSVpvs_flags("Unknown error\n", SVs_TEMP)));
}
else if (startop) {
if (yystatus != 3) {
POPBLOCK(cx,PL_curpm);
POPEVAL(cx);
}
- Perl_croak(aTHX_ "%sCompilation failed in regexp",
- (*msg ? msg : "Unknown error\n"));
+ Perl_croak(aTHX_ "%"SVf"Compilation failed in regexp",
+ SVfARG(ERRSV
+ ? ERRSV
+ : newSVpvs_flags("Unknown error\n", SVs_TEMP)));
}
else {
- if (!*msg) {
+ if (!*(SvPVx_nolen_const(ERRSV))) {
sv_setpvs(ERRSV, "Compilation error");
}
}
} 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: */
}
#if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
- return PerlIO_openn(aTHX_ NULL, PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name);
+ return PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name);
#else
return PerlIO_open(p, PERL_SCRIPT_MODE);
#endif
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);
PP(pp_leaveeval)
{
dVAR; dSP;
- register SV **mark;
SV **newsp;
PMOP *newpm;
I32 gimme;
retop = cx->blk_eval.retop;
TAINT_NOT;
- if (gimme == G_VOID)
- MARK = newsp;
- else if (gimme == G_SCALAR) {
- MARK = newsp + 1;
- if (MARK <= SP) {
- if (SvFLAGS(TOPs) & SVs_TEMP)
- *MARK = TOPs;
- else
- *MARK = sv_mortalcopy(TOPs);
- }
- else {
- MEXTEND(mark,0);
- *MARK = &PL_sv_undef;
- }
- SP = MARK;
- }
- else {
- /* in case LEAVE wipes old return values */
- for (mark = newsp + 1; mark <= SP; mark++) {
- if (!(SvFLAGS(*mark) & SVs_TEMP)) {
- *mark = sv_mortalcopy(*mark);
- TAINT_NOT; /* Each item is independent */
- }
- }
- }
+ SP = adjust_stack_on_leave((gimme == G_VOID) ? SP : newsp, SP, newsp,
+ gimme, SVs_TEMP);
PL_curpm = newpm; /* Don't pop $1 et al till now */
#ifdef DEBUGGING
{
/* Unassume the success we assumed earlier. */
(void)hv_delete(GvHVn(PL_incgv),
- SvPVX_const(namesv), SvCUR(namesv),
+ SvPVX_const(namesv),
+ SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
G_DISCARD);
retop = Perl_die(aTHX_ "%"SVf" did not return a true value",
SVfARG(namesv));
PERL_UNUSED_VAR(optype);
TAINT_NOT;
- if (gimme == G_VOID)
- SP = newsp;
- else if (gimme == G_SCALAR) {
- register SV **mark;
- MARK = newsp + 1;
- if (MARK <= SP) {
- if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
- *MARK = TOPs;
- else
- *MARK = sv_mortalcopy(TOPs);
- }
- else {
- MEXTEND(mark,0);
- *MARK = &PL_sv_undef;
- }
- SP = MARK;
- }
- else {
- /* in case LEAVE wipes old return values */
- register SV **mark;
- for (mark = newsp + 1; mark <= SP; mark++) {
- if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
- *mark = sv_mortalcopy(*mark);
- TAINT_NOT; /* Each item is independent */
- }
- }
- }
+ 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("eval_scope");
ENTER_with_name("given");
SAVETMPS;
+ SAVECLEARSV(PAD_SVl(PL_op->op_targ));
sv_setsv_mg(PAD_SV(PL_op->op_targ), POPs);
PUSHBLOCK(cx, CXt_GIVEN, SP);
assert(CxTYPE(cx) == CXt_GIVEN);
TAINT_NOT;
- if (gimme == G_VOID)
- SP = newsp;
- else if (gimme == G_SCALAR) {
- register SV **mark;
- MARK = newsp + 1;
- if (MARK <= SP) {
- if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
- *MARK = TOPs;
- else
- *MARK = sv_mortalcopy(TOPs);
- }
- else {
- MEXTEND(mark,0);
- *MARK = &PL_sv_undef;
- }
- SP = MARK;
- }
- else {
- /* in case LEAVE wipes old return values */
- register SV **mark;
- for (mark = newsp + 1; mark <= SP; mark++) {
- if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
- *mark = sv_mortalcopy(*mark);
- TAINT_NOT; /* Each item is independent */
- }
- }
- }
+ 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("given");
PP(pp_smartmatch)
{
DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
- return do_smartmatch(NULL, NULL);
+ return do_smartmatch(NULL, NULL, 0);
}
/* This version of do_smartmatch() implements the
* table of smart matches that is found in perlsyn.
*/
STATIC OP *
-S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
+S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied)
{
dVAR;
dSP;
/* Take care only to invoke mg_get() once for each argument.
* Currently we do this by copying the SV if it's magical. */
if (d) {
- if (SvGMAGICAL(d))
+ if (!copied && SvGMAGICAL(d))
d = sv_mortalcopy(d);
}
else
PUTBACK;
DEBUG_M(Perl_deb(aTHX_ " recursively comparing array element...\n"));
- (void) do_smartmatch(seen_this, seen_other);
+ (void) do_smartmatch(seen_this, seen_other, 0);
SPAGAIN;
DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
PUTBACK;
/* infinite recursion isn't supposed to happen here */
DEBUG_M(Perl_deb(aTHX_ " recursively testing array element...\n"));
- (void) do_smartmatch(NULL, NULL);
+ (void) do_smartmatch(NULL, NULL, 1);
SPAGAIN;
DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
if (SvTRUEx(POPs))
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 *
I'm going to use a mortal in case the upstream filter croaks. */
upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
? sv_newmortal() : buf_sv;
- SvTEMP_off(upstream);
SvUPGRADE(upstream, SVt_PV);
if (filter_has_file) {
int count;
ENTER_with_name("call_filter_sub");
+ save_gp(PL_defgv, 0);
+ GvINTRO_off(PL_defgv);
SAVEGENERICSV(GvSV(PL_defgv));
SAVETMPS;
EXTEND(SP, 2);
https://perl5.git.perl.org / perl5.git / blobdiff