#include "EXTERN.h"
#define PERL_IN_PP_HOT_C
#include "perl.h"
+#include "regcomp.h"
/* Hot code. */
+
+#ifdef PERL_RC_STACK
+
+/* common code for pp_wrap() and xs_wrap():
+ * free any original arguments, and bump and shift down any return
+ * args
+ */
+
+STATIC void
+S_pp_xs_wrap_return(pTHX_ I32 nargs, I32 old_sp)
+{
+ I32 nret = (I32)(PL_stack_sp - PL_stack_base) - old_sp;
+ assert(nret >= 0);
+
+ /* bump any returned values */
+ if (nret) {
+ SV **svp = PL_stack_sp - nret + 1;
+ while (svp <= PL_stack_sp) {
+ SvREFCNT_inc(*svp);
+ svp++;
+ }
+ }
+
+ PL_curstackinfo->si_stack_nonrc_base = 0;
+
+ /* free the original args and shift the returned valued down */
+ if (nargs) {
+ SV **svp = PL_stack_sp - nret;
+ I32 i = nargs;
+ while (i--) {
+ SvREFCNT_dec(*svp);
+ *svp = NULL;
+ svp--;
+ }
+
+ if (nret) {
+ Move(PL_stack_sp - nret + 1,
+ PL_stack_sp - nret - nargs + 1,
+ nret, SV*);
+ }
+ PL_stack_sp -= nargs;
+ }
+}
+
+/* pp_wrap():
+ * wrapper function for pp() functions to turn them into functions
+ * that can operate on a reference-counted stack, by taking a non-
+ * reference-counted copy of the current stack frame, calling the real
+ * pp() function, then incrementing the reference count of any returned
+ * args.
+ *
+ * nargs or nlists indicate the number of stack arguments or the
+ * number of stack lists (delimited by MARKs) which the function expects.
+ */
+OP*
+Perl_pp_wrap(pTHX_ Perl_ppaddr_t real_pp_fn, I32 nargs, int nlists)
+{
+ PERL_ARGS_ASSERT_PP_WRAP;
+
+ if (!rpp_stack_is_rc())
+ /* stack-already non-RC; nothing needing wrapping */
+ return real_pp_fn(aTHX);
+
+ OP *next_op;
+ I32 old_sp = (I32)(PL_stack_sp - PL_stack_base);
+
+ assert(nargs >= 0);
+ assert(nlists >= 0);
+ assert(AvREAL(PL_curstack));
+
+ PL_curstackinfo->si_stack_nonrc_base = PL_stack_sp - PL_stack_base + 1;
+
+ if (nlists) {
+ assert(nargs == 0);
+ I32 mark = PL_markstack_ptr[-nlists+1];
+ nargs = (PL_stack_sp - PL_stack_base) - mark;
+ assert(nlists <= 2); /* if ever more, make below a loop */
+ PL_markstack_ptr[0] += nargs;
+ if (nlists == 2)
+ PL_markstack_ptr[-1] += nargs;
+ }
+
+ if (nargs) {
+ /* duplicate all the arg pointers further up the stack */
+ rpp_extend(nargs);
+ Copy(PL_stack_sp - nargs + 1, PL_stack_sp + 1, nargs, SV*);
+ PL_stack_sp += nargs;
+ }
+
+ next_op = real_pp_fn(aTHX);
+
+ /* we should still be a split stack */
+ assert(AvREAL(PL_curstack));
+ assert(PL_curstackinfo->si_stack_nonrc_base);
+
+ S_pp_xs_wrap_return(aTHX_ nargs, old_sp);
+
+ return next_op;
+}
+
+
+/* xs_wrap():
+ * similar in concept to pp_wrap: make a non-referenced-counted copy of
+ * a (not refcount aware) XS sub's args, call the XS subs, then bump any
+ * return values and free the original args */
+
+void
+Perl_xs_wrap(pTHX_ XSUBADDR_t xsub, CV *cv)
+{
+ PERL_ARGS_ASSERT_XS_WRAP;
+
+ I32 old_sp = (I32)(PL_stack_sp - PL_stack_base);
+ I32 mark = PL_markstack_ptr[0];
+ I32 nargs = (PL_stack_sp - PL_stack_base) - mark;
+
+ /* we should be a fully refcounted stack */
+ assert(AvREAL(PL_curstack));
+ assert(!PL_curstackinfo->si_stack_nonrc_base);
+
+ PL_curstackinfo->si_stack_nonrc_base = PL_stack_sp - PL_stack_base + 1;
+
+
+ if (nargs) {
+ /* duplicate all the arg pointers further up the stack */
+ rpp_extend(nargs);
+ Copy(PL_stack_sp - nargs + 1, PL_stack_sp + 1, nargs, SV*);
+ PL_stack_sp += nargs;
+ PL_markstack_ptr[0] += nargs;
+ }
+
+ xsub(aTHX_ cv);
+
+ S_pp_xs_wrap_return(aTHX_ nargs, old_sp);
+}
+
+#endif
+
+
+
+/* Private helper function for Perl_rpp_replace_2_1_COMMON()
+ * and rpp_popfree_2_NN().
+ * Free the two passed SVs, whose original ref counts are rc1 and rc2.
+ * Assumes the stack initially looked like
+ * .... sv1 sv2
+ * and is now:
+ * .... X
+ * but where sv2 is still on the slot above the current PL_stack_sp.
+ */
+
+void
+Perl_rpp_free_2_(pTHX_ SV *const sv1, SV *const sv2,
+ const U32 rc1, const U32 rc2)
+{
+
+ PERL_ARGS_ASSERT_RPP_FREE_2_;
+
+#ifdef PERL_RC_STACK
+ if (rc1 > 1)
+ SvREFCNT(sv1) = rc1 - 1;
+ else {
+ /* temporarily reclaim sv2 on stack in case we die while freeing sv1 */
+ assert(PL_stack_sp[1] == sv2);
+ PL_stack_sp++;
+ Perl_sv_free2(aTHX_ sv1, rc1);
+ PL_stack_sp--;
+ }
+ if (rc2 > 1)
+ SvREFCNT(sv2) = rc2 - 1;
+ else
+ Perl_sv_free2(aTHX_ sv2, rc2);
+#else
+ PERL_UNUSED_VAR(sv1);
+ PERL_UNUSED_VAR(sv2);
+ PERL_UNUSED_VAR(rc1);
+ PERL_UNUSED_VAR(rc2);
+#endif
+}
+
+
+
+/* ----------------------------------------------------------- */
+
+
PP(pp_const)
{
- dSP;
- XPUSHs(cSVOP_sv);
- RETURN;
+ rpp_xpush_1(cSVOP_sv);
+ return NORMAL;
}
PP(pp_nextstate)
{
PL_curcop = (COP*)PL_op;
TAINT_NOT; /* Each statement is presumed innocent */
- PL_stack_sp = PL_stack_base + CX_CUR()->blk_oldsp;
+ rpp_popfree_to_NN(PL_stack_base + CX_CUR()->blk_oldsp);
FREETMPS;
PERL_ASYNC_CHECK();
return NORMAL;
PP(pp_gvsv)
{
- dSP;
- EXTEND(SP,1);
- if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO))
- PUSHs(save_scalar(cGVOP_gv));
- else
- PUSHs(GvSVn(cGVOP_gv));
- RETURN;
+ assert(SvTYPE(cGVOP_gv) == SVt_PVGV);
+ rpp_xpush_1(
+ UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)
+ ? save_scalar(cGVOP_gv)
+ : GvSVn(cGVOP_gv));
+ return NORMAL;
}
PP(pp_stringify)
{
- dSP; dTARGET;
- SV * const sv = TOPs;
- SETs(TARG);
- sv_copypv(TARG, sv);
+ dTARGET;
+ sv_copypv(TARG, *PL_stack_sp);
SvSETMAGIC(TARG);
- /* no PUTBACK, SETs doesn't inc/dec SP */
+ rpp_replace_1_1_NN(TARG);
return NORMAL;
}
PP(pp_gv)
{
- dSP;
- XPUSHs(MUTABLE_SV(cGVOP_gv));
- RETURN;
+ /* cGVOP_gv might be a real GV or might be an RV to a CV */
+ assert(SvTYPE(cGVOP_gv) == SVt_PVGV ||
+ (SvTYPE(cGVOP_gv) <= SVt_PVMG && SvROK(cGVOP_gv) && SvTYPE(SvRV(cGVOP_gv)) == SVt_PVCV));
+ rpp_xpush_1(MUTABLE_SV(cGVOP_gv));
+ return NORMAL;
}
{
PERL_ASYNC_CHECK();
{
- /* SP is not used to remove a variable that is saved across the
- sv_2bool_flags call in SvTRUE_NN, if a RISC/CISC or low/high machine
- register or load/store vs direct mem ops macro is introduced, this
- should be a define block between direct PL_stack_sp and dSP operations,
- presently, using PL_stack_sp is bias towards CISC cpus */
- SV * const sv = *PL_stack_sp;
- if (!SvTRUE_NN(sv))
- return NORMAL;
- else {
- if (PL_op->op_type == OP_AND)
- --PL_stack_sp;
- return cLOGOP->op_other;
- }
+ SV * const sv = *PL_stack_sp;
+ if (!SvTRUE_NN(sv))
+ return NORMAL;
+ else {
+ if (PL_op->op_type == OP_AND)
+ rpp_popfree_1_NN();
+ return cLOGOP->op_other;
+ }
}
}
+/*
+ * Mashup of simple padsv + sassign OPs
+ * Doesn't support the following lengthy and unlikely sassign case:
+ * (UNLIKELY(PL_op->op_private & OPpASSIGN_CV_TO_GV))
+ * These cases have a separate optimization, so are not handled here:
+ * (PL_op->op_private & OPpASSIGN_BACKWARDS) {or,and,dor}assign
+*/
+
+PP(pp_padsv_store)
+{
+ OP * const op = PL_op;
+ SV** const padentry = &PAD_SVl(op->op_targ);
+ SV* targ = *padentry; /* lvalue to assign into */
+ SV* const val = *PL_stack_sp; /* RHS value to assign */
+
+ /* !OPf_STACKED is not handled by this OP */
+ assert(op->op_flags & OPf_STACKED);
+
+ /* Inlined, simplified pp_padsv here */
+ if ((op->op_private & (OPpLVAL_INTRO|OPpPAD_STATE)) == OPpLVAL_INTRO) {
+ save_clearsv(padentry);
+ }
+
+ /* Inlined, simplified pp_sassign from here */
+ assert(TAINTING_get || !TAINT_get);
+ if (UNLIKELY(TAINT_get) && !SvTAINTED(val))
+ TAINT_NOT;
+
+ if (
+ UNLIKELY(SvTEMP(targ)) && !SvSMAGICAL(targ) && SvREFCNT(targ) == 1 &&
+ (!isGV_with_GP(targ) || SvFAKE(targ)) && ckWARN(WARN_MISC)
+ )
+ Perl_warner(aTHX_
+ packWARN(WARN_MISC), "Useless assignment to a temporary"
+ );
+ SvSetMagicSV(targ, val);
+
+ assert(GIMME_V == G_VOID);
+ rpp_popfree_1_NN();
+ return NORMAL;
+}
+
+
+/* A mashup of simplified AELEMFAST_LEX + SASSIGN OPs */
+
+PP(pp_aelemfastlex_store)
+{
+ OP * const op = PL_op;
+ SV* const val = *PL_stack_sp; /* RHS value to assign */
+ AV * const av = MUTABLE_AV(PAD_SV(op->op_targ));
+ const I8 key = (I8)PL_op->op_private;
+ SV * targ = NULL;
+
+ /* !OPf_STACKED is not handled by this OP */
+ assert(op->op_flags & OPf_STACKED);
+
+ /* Inlined, simplified pp_aelemfast here */
+ assert(SvTYPE(av) == SVt_PVAV);
+
+ /* inlined av_fetch() for simple cases ... */
+ if (!SvRMAGICAL(av) && key >=0 && key <= AvFILLp(av)) {
+ targ = AvARRAY(av)[key];
+ }
+ /* ... else do it the hard way */
+ if (!targ) {
+ SV **svp = av_fetch(av, key, 1);
+
+ if (svp)
+ targ = *svp;
+ else
+ DIE(aTHX_ PL_no_aelem, (int)key);
+ }
+
+ /* Inlined, simplified pp_sassign from here */
+ assert(TAINTING_get || !TAINT_get);
+ if (UNLIKELY(TAINT_get) && !SvTAINTED(val))
+ TAINT_NOT;
+
+ /* This assertion is a deviation from pp_sassign, which uses an if()
+ * condition to check for "Useless assignment to a temporary" and
+ * warns if the condition is true. Here, the condition should NEVER
+ * be true when the LHS is the result of an array fetch. The
+ * assertion is here as a final check that this remains the case.
+ */
+ assert(!(SvTEMP(targ) && SvREFCNT(targ) == 1 && !SvSMAGICAL(targ)));
+
+ SvSetMagicSV(targ, val);
+
+ assert(GIMME_V == G_VOID);
+ rpp_popfree_1_NN();
+ return NORMAL;
+}
+
PP(pp_sassign)
{
- dSP;
/* sassign keeps its args in the optree traditionally backwards.
So we pop them differently.
*/
- SV *left = POPs; SV *right = TOPs;
+ SV *left = PL_stack_sp[0];
+ SV *right = PL_stack_sp[-1];
if (PL_op->op_private & OPpASSIGN_BACKWARDS) { /* {or,and,dor}assign */
- SV * const temp = left;
- left = right; right = temp;
+ SV * const temp = left;
+ left = right; right = temp;
+ PL_stack_sp[0] = left;
+ PL_stack_sp[-1] = right;
}
assert(TAINTING_get || !TAINT_get);
if (UNLIKELY(TAINT_get) && !SvTAINTED(right))
- TAINT_NOT;
+ TAINT_NOT;
+
if (UNLIKELY(PL_op->op_private & OPpASSIGN_CV_TO_GV)) {
/* *foo =\&bar */
- SV * const cv = SvRV(right);
- const U32 cv_type = SvTYPE(cv);
- const bool is_gv = isGV_with_GP(left);
- const bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM;
-
- if (!got_coderef) {
- assert(SvROK(cv));
- }
-
- /* Can do the optimisation if left (LVALUE) is not a typeglob,
- right (RVALUE) is a reference to something, and we're in void
- context. */
- if (!got_coderef && !is_gv && GIMME_V == G_VOID) {
- /* Is the target symbol table currently empty? */
- GV * const gv = gv_fetchsv_nomg(left, GV_NOINIT, SVt_PVGV);
- if (SvTYPE(gv) != SVt_PVGV && !SvOK(gv)) {
- /* Good. Create a new proxy constant subroutine in the target.
- The gv becomes a(nother) reference to the constant. */
- SV *const value = SvRV(cv);
-
- SvUPGRADE(MUTABLE_SV(gv), SVt_IV);
- SvPCS_IMPORTED_on(gv);
- SvRV_set(gv, value);
- SvREFCNT_inc_simple_void(value);
- SETs(left);
- RETURN;
- }
- }
-
- /* Need to fix things up. */
- if (!is_gv) {
- /* Need to fix GV. */
- left = MUTABLE_SV(gv_fetchsv_nomg(left,GV_ADD, SVt_PVGV));
- }
-
- if (!got_coderef) {
- /* We've been returned a constant rather than a full subroutine,
- but they expect a subroutine reference to apply. */
- if (SvROK(cv)) {
- ENTER_with_name("sassign_coderef");
- SvREFCNT_inc_void(SvRV(cv));
- /* newCONSTSUB takes a reference count on the passed in SV
- from us. We set the name to NULL, otherwise we get into
- all sorts of fun as the reference to our new sub is
- donated to the GV that we're about to assign to.
- */
- SvRV_set(right, MUTABLE_SV(newCONSTSUB(GvSTASH(left), NULL,
- SvRV(cv))));
- SvREFCNT_dec_NN(cv);
- LEAVE_with_name("sassign_coderef");
- } else {
- /* What can happen for the corner case *{"BONK"} = \&{"BONK"};
- is that
- First: ops for \&{"BONK"}; return us the constant in the
- symbol table
- Second: ops for *{"BONK"} cause that symbol table entry
- (and our reference to it) to be upgraded from RV
- to typeblob)
- Thirdly: We get here. cv is actually PVGV now, and its
- GvCV() is actually the subroutine we're looking for
-
- So change the reference so that it points to the subroutine
- of that typeglob, as that's what they were after all along.
- */
- GV *const upgraded = MUTABLE_GV(cv);
- CV *const source = GvCV(upgraded);
-
- assert(source);
- assert(CvFLAGS(source) & CVf_CONST);
-
- SvREFCNT_inc_simple_void_NN(source);
- SvREFCNT_dec_NN(upgraded);
- SvRV_set(right, MUTABLE_SV(source));
- }
- }
+ SV * const cv = SvRV(right);
+ const U32 cv_type = SvTYPE(cv);
+ const bool is_gv = isGV_with_GP(left);
+ const bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM;
+
+ if (!got_coderef) {
+ assert(SvROK(cv));
+ }
+
+ /* Can do the optimisation if left (LVALUE) is not a typeglob,
+ right (RVALUE) is a reference to something, and we're in void
+ context. */
+ if (!got_coderef && !is_gv && GIMME_V == G_VOID) {
+ /* Is the target symbol table currently empty? */
+ GV * const gv = gv_fetchsv_nomg(left, GV_NOINIT, SVt_PVGV);
+ if (SvTYPE(gv) != SVt_PVGV && !SvOK(gv)) {
+ /* Good. Create a new proxy constant subroutine in the target.
+ The gv becomes a(nother) reference to the constant. */
+ SV *const value = SvRV(cv);
+
+ SvUPGRADE(MUTABLE_SV(gv), SVt_IV);
+ SvPCS_IMPORTED_on(gv);
+ SvRV_set(gv, value);
+ SvREFCNT_inc_simple_void(value);
+ rpp_replace_2_1_NN(left);
+ return NORMAL;
+ }
+ }
+
+ /* Need to fix things up. */
+ if (!is_gv) {
+ /* Need to fix GV. */
+ SV *sv = MUTABLE_SV(gv_fetchsv_nomg(left,GV_ADD, SVt_PVGV));
+ rpp_replace_1_1_NN(sv);
+ left = sv;
+ }
+
+ if (!got_coderef) {
+ /* We've been returned a constant rather than a full subroutine,
+ but they expect a subroutine reference to apply. */
+ if (SvROK(cv)) {
+ ENTER_with_name("sassign_coderef");
+ SvREFCNT_inc_void(SvRV(cv));
+ /* newCONSTSUB takes a reference count on the passed in SV
+ from us. We set the name to NULL, otherwise we get into
+ all sorts of fun as the reference to our new sub is
+ donated to the GV that we're about to assign to.
+ */
+ SvRV_set(right, MUTABLE_SV(newCONSTSUB(GvSTASH(left), NULL,
+ SvRV(cv))));
+ SvREFCNT_dec_NN(cv);
+ LEAVE_with_name("sassign_coderef");
+ } else {
+ /* What can happen for the corner case *{"BONK"} = \&{"BONK"};
+ is that
+ First: ops for \&{"BONK"}; return us the constant in the
+ symbol table
+ Second: ops for *{"BONK"} cause that symbol table entry
+ (and our reference to it) to be upgraded from RV
+ to typeblob)
+ Thirdly: We get here. cv is actually PVGV now, and its
+ GvCV() is actually the subroutine we're looking for
+
+ So change the reference so that it points to the subroutine
+ of that typeglob, as that's what they were after all along.
+ */
+ GV *const upgraded = MUTABLE_GV(cv);
+ CV *const source = GvCV(upgraded);
+
+ assert(source);
+ assert(CvFLAGS(source) & CVf_CONST);
+
+ SvREFCNT_inc_simple_void_NN(source);
+ SvREFCNT_dec_NN(upgraded);
+ SvRV_set(right, MUTABLE_SV(source));
+ }
+ }
}
if (
- UNLIKELY(SvTEMP(left)) && !SvSMAGICAL(left) && SvREFCNT(left) == 1 &&
+ rpp_is_lone(left) && !SvSMAGICAL(left) &&
(!isGV_with_GP(left) || SvFAKE(left)) && ckWARN(WARN_MISC)
)
- Perl_warner(aTHX_
- packWARN(WARN_MISC), "Useless assignment to a temporary"
- );
+ Perl_warner(aTHX_
+ packWARN(WARN_MISC), "Useless assignment to a temporary"
+ );
SvSetMagicSV(left, right);
- SETs(left);
- RETURN;
+ if (LIKELY(GIMME_V == G_VOID))
+ rpp_popfree_2_NN(); /* pop left and right */
+ else {
+ /* pop right, leave left on the stack */
+ assert(PL_stack_sp[-1] == right);
+ assert(PL_stack_sp[0] == left);
+ *--PL_stack_sp = left;
+#ifdef PERL_RC_STACK
+ SvREFCNT_dec_NN(right);
+#endif
+ }
+
+ return NORMAL;
}
PP(pp_cond_expr)
{
- dSP;
- SV *sv;
-
PERL_ASYNC_CHECK();
- sv = POPs;
- RETURNOP(SvTRUE_NN(sv) ? cLOGOP->op_other : cLOGOP->op_next);
+ bool ok = SvTRUE_NN(*PL_stack_sp);
+ rpp_popfree_1_NN();
+ return (ok ? cLOGOP->op_other : cLOGOP->op_next);
}
PP(pp_unstack)
PERL_ASYNC_CHECK();
TAINT_NOT; /* Each statement is presumed innocent */
cx = CX_CUR();
- PL_stack_sp = PL_stack_base + cx->blk_oldsp;
+ rpp_popfree_to_NN(PL_stack_base + CX_CUR()->blk_oldsp);
FREETMPS;
if (!(PL_op->op_flags & OPf_SPECIAL)) {
assert(CxTYPE(cx) == CXt_BLOCK || CxTYPE_is_LOOP(cx));
- CX_LEAVE_SCOPE(cx);
+ CX_LEAVE_SCOPE(cx);
}
return NORMAL;
}
-PP(pp_concat)
+
+/* The main body of pp_concat, not including the magic/overload and
+ * stack handling.
+ * It does targ = left . right.
+ * Moved into a separate function so that pp_multiconcat() can use it
+ * too.
+ */
+
+PERL_STATIC_INLINE void
+S_do_concat(pTHX_ SV *left, SV *right, SV *targ, U8 targmy)
{
- dSP; dATARGET; tryAMAGICbin_MG(concat_amg, AMGf_assign);
- {
- dPOPTOPssrl;
bool lbyte;
STRLEN rlen;
const char *rpv = NULL;
bool rcopied = FALSE;
if (TARG == right && right != left) { /* $r = $l.$r */
- rpv = SvPV_nomg_const(right, rlen);
- rbyte = !DO_UTF8(right);
- right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
- rpv = SvPV_const(right, rlen); /* no point setting UTF-8 here */
- rcopied = TRUE;
+ rpv = SvPV_nomg_const(right, rlen);
+ rbyte = !DO_UTF8(right);
+ right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
+ rpv = SvPV_const(right, rlen); /* no point setting UTF-8 here */
+ rcopied = TRUE;
}
if (TARG != left) { /* not $l .= $r */
STRLEN llen;
const char* const lpv = SvPV_nomg_const(left, llen);
- lbyte = !DO_UTF8(left);
- sv_setpvn(TARG, lpv, llen);
- if (!lbyte)
- SvUTF8_on(TARG);
- else
- SvUTF8_off(TARG);
+ lbyte = !DO_UTF8(left);
+ sv_setpvn(TARG, lpv, llen);
+ if (!lbyte)
+ SvUTF8_on(TARG);
+ else
+ SvUTF8_off(TARG);
}
else { /* $l .= $r and left == TARG */
- if (!SvOK(left)) {
+ if (!SvOK(left)) {
if ((left == right /* $l .= $l */
- || (PL_op->op_private & OPpTARGET_MY)) /* $l = $l . $r */
+ || targmy) /* $l = $l . $r */
&& ckWARN(WARN_UNINITIALIZED)
)
report_uninit(left);
SvPVCLEAR(left);
- }
+ }
else {
SvPV_force_nomg_nolen(left);
}
- lbyte = !DO_UTF8(left);
- if (IN_BYTES)
- SvUTF8_off(left);
+ lbyte = !DO_UTF8(left);
+ if (IN_BYTES)
+ SvUTF8_off(left);
}
if (!rcopied) {
- rpv = SvPV_nomg_const(right, rlen);
- rbyte = !DO_UTF8(right);
+ rpv = SvPV_nomg_const(right, rlen);
+ rbyte = !DO_UTF8(right);
}
if (lbyte != rbyte) {
- if (lbyte)
- sv_utf8_upgrade_nomg(TARG);
- else {
- if (!rcopied)
- right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
- sv_utf8_upgrade_nomg(right);
- rpv = SvPV_nomg_const(right, rlen);
- }
+ if (lbyte)
+ sv_utf8_upgrade_nomg(TARG);
+ else {
+ if (!rcopied)
+ right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
+ sv_utf8_upgrade_nomg(right);
+ rpv = SvPV_nomg_const(right, rlen);
+ }
}
sv_catpvn_nomg(TARG, rpv, rlen);
+ SvSETMAGIC(TARG);
+}
- SETTARG;
- RETURN;
- }
+
+PP(pp_concat)
+{
+ SV *targ = (PL_op->op_flags & OPf_STACKED)
+ ? PL_stack_sp[-1]
+ : PAD_SV(PL_op->op_targ);
+
+ if (rpp_try_AMAGIC_2(concat_amg, AMGf_assign))
+ return NORMAL;
+
+ SV *right = PL_stack_sp[0];
+ SV *left = PL_stack_sp[-1];
+ S_do_concat(aTHX_ left, right, targ, PL_op->op_private & OPpTARGET_MY);
+ rpp_replace_2_1_NN(targ);
+ return NORMAL;
}
sprintf "...%s...". Don't call '.'
overloading: only use '""' overloading.
- OPpMULTICONCAT_STRINGIFY: (for Deparse's benefit) the RHS was of the
- form "...$a...$b..." rather than
+ OPpMULTICONCAT_STRINGIFY: the RHS was of the form
+ "...$a...$b..." rather than
"..." . $a . "..." . $b . "..."
An OP_MULTICONCAT is of type UNOP_AUX. The fixed slots of the aux array are
PP(pp_multiconcat)
{
- dSP;
SV *targ; /* The SV to be assigned or appended to */
- SV *dsv; /* the SV to concat args to (often == targ) */
- char *dsv_pv; /* where within SvPVX(dsv) we're writing to */
+ char *targ_pv; /* where within SvPVX(targ) we're writing to */
STRLEN targ_len; /* SvCUR(targ) */
SV **toparg; /* the highest arg position on the stack */
UNOP_AUX_item *aux; /* PL_op->op_aux buffer */
UNOP_AUX_item *const_lens; /* the segment length array part of aux */
const char *const_pv; /* the current segment of the const string buf */
SSize_t nargs; /* how many args were expected */
- SSize_t stack_adj; /* how much to adjust SP on return */
- STRLEN grow; /* final size of destination string (dsv) */
+ SSize_t stack_adj; /* how much to adjust PL_stack_sp on return */
+ STRLEN grow; /* final size of destination string (targ) */
UV targ_count; /* how many times targ has appeared on the RHS */
bool is_append; /* OPpMULTICONCAT_APPEND flag is set */
bool slow_concat; /* args too complex for quick concat */
for ease of testing and setting) */
/* for each arg, holds the result of an SvPV() call */
struct multiconcat_svpv {
- char *pv;
+ const char *pv;
SSize_t len;
}
*targ_chain, /* chain of slots where targ has appeared on RHS */
/* get targ from the stack or pad */
+ toparg = PL_stack_sp;
if (PL_op->op_flags & OPf_STACKED) {
+ stack_adj++;
if (is_append) {
/* for 'expr .= ...', expr is the bottom item on the stack */
- targ = SP[-nargs];
- stack_adj++;
+ targ = PL_stack_sp[-nargs];
}
- else
+ else {
/* for 'expr = ...', expr is the top item on the stack */
- targ = POPs;
+ targ = *PL_stack_sp;
+ toparg--;
+ }
}
else {
SV **svp = &(PAD_SVl(PL_op->op_targ));
}
if (!nargs)
/* $lex .= "const" doesn't cause anything to be pushed */
- EXTEND(SP,1);
+ rpp_extend(1);
}
- toparg = SP;
- SP -= (nargs - 1);
- dsv = targ; /* Set the destination for all concats. This is
- initially targ; later on, dsv may be switched
- to point to a TEMP SV if overloading is
- encountered. */
grow = 1; /* allow for '\0' at minimum */
targ_count = 0;
targ_chain = NULL;
* Where an arg is actually targ, the stringification is deferred:
* the length is set to 0, and the slot is added to targ_chain.
*
- * If an overloaded arg is found, the loop is abandoned at that point,
- * and dsv is set to an SvTEMP SV where the results-so-far will be
- * accumulated.
+ * If a magic, overloaded, or otherwise weird arg is found, which
+ * might have side effects when stringified, the loop is abandoned and
+ * we goto a code block where a more basic 'emulate calling
+ * pp_cpncat() on each arg in turn' is done.
*/
- for (; SP <= toparg; SP++, svpv_end++) {
- bool simple_flags;
+ for (SV **svp = toparg - (nargs - 1); svp <= toparg; svp++, svpv_end++) {
U32 utf8;
STRLEN len;
SV *sv;
assert(svpv_end - svpv_buf < PERL_MULTICONCAT_MAXARG);
- sv = *SP;
- simple_flags = (SvFLAGS(sv) & (SVs_GMG|SVf_ROK|SVf_POK)) == SVf_POK;
+ sv = *svp;
/* this if/else chain is arranged so that common/simple cases
* take few conditionals */
- if (LIKELY(simple_flags && (sv != targ))) {
- /* common case: sv is a simple PV and not the targ */
- svpv_end->pv = SvPVX(sv);
+ if (LIKELY((SvFLAGS(sv) & (SVs_GMG|SVf_ROK|SVf_POK)) == SVf_POK)) {
+ /* common case: sv is a simple non-magical PV */
+ if (targ == sv) {
+ /* targ appears on RHS.
+ * Delay storing PV pointer; instead, add slot to targ_chain
+ * so it can be populated later, after targ has been grown and
+ * we know its final SvPVX() address.
+ */
+ targ_on_rhs:
+ svpv_end->len = 0; /* zerojng here means we can skip
+ updating later if targ_len == 0 */
+ svpv_end->pv = (char*)targ_chain;
+ targ_chain = svpv_end;
+ targ_count++;
+ continue;
+ }
+
len = SvCUR(sv);
+ svpv_end->pv = SvPVX(sv);
}
- else if (simple_flags) {
- /* sv is targ (but can't be magic or overloaded).
- * Delay storing PV pointer; instead, add slot to targ_chain
- * so it can be populated later, after targ has been grown and
- * we know its final SvPVX() address.
+ else if (UNLIKELY(SvFLAGS(sv) & (SVs_GMG|SVf_ROK)))
+ /* may have side effects: tie, overload etc.
+ * Abandon 'stringify everything first' and handle
+ * args in strict order. Note that already-stringified args
+ * will be reprocessed, which is safe because the each first
+ * stringification would have been idempotent.
*/
- targ_on_rhs:
- svpv_end->len = 0; /* zerojng here means we can skip
- updating later if targ_len == 0 */
- svpv_end->pv = (char*)targ_chain;
- targ_chain = svpv_end;
- targ_count++;
- continue;
- }
- else {
- if (UNLIKELY(SvFLAGS(sv) & (SVs_GMG|SVf_ROK))) {
- /* its got magic, is tied, and/or is overloaded */
- SvGETMAGIC(sv);
-
- if (UNLIKELY(SvAMAGIC(sv))
- && !(PL_op->op_private & OPpMULTICONCAT_FAKE))
- {
- /* One of the RHS args is overloaded. Abandon stringifying
- * the args at this point, then in the concat loop later
- * on, concat the plain args stringified so far into a
- * TEMP SV. At the end of this function the remaining
- * args (including the current one) will be handled
- * specially, using overload calls.
- * FAKE implies an optimised sprintf which doesn't use
- * concat overloading, only "" overloading.
- */
-
- if ( svpv_end == svpv_buf + 1
- /* no const string segments */
- && aux[PERL_MULTICONCAT_IX_LENGTHS].ssize == -1
- && aux[PERL_MULTICONCAT_IX_LENGTHS + 1].ssize == -1
- ) {
- /* special case: if the overloaded sv is the
- * second arg in the concat chain, stop at the
- * first arg rather than this, so that
- *
- * $arg1 . $arg2
- *
- * invokes overloading as
- *
- * concat($arg2, $arg1, 1)
- *
- * rather than
- *
- * concat($arg2, "$arg1", 1)
- *
- * This means that if for example arg1 is a ref,
- * it gets passed as-is to the concat method
- * rather than a stringified copy. If it's not the
- * first arg, it doesn't matter, as in $arg0 .
- * $arg1 . $arg2, where the result of ($arg0 .
- * $arg1) will already be a string.
- * THis isn't perfect: we'll have already
- * done SvPV($arg1) on the previous iteration;
- * and are now throwing away that result and
- * hoping arg1 hasn;t been affected.
- */
- svpv_end--;
- SP--;
- }
-
- setup_overload:
- dsv = newSVpvn_flags("", 0, SVs_TEMP);
-
- if (targ_chain) {
- /* Get the string value of targ and populate any
- * RHS slots which use it */
- char *pv = SvPV_nomg(targ, len);
- dst_utf8 |= (SvFLAGS(targ) & SVf_UTF8);
- grow += len * targ_count;
- do {
- struct multiconcat_svpv *p = targ_chain;
- targ_chain = (struct multiconcat_svpv *)(p->pv);
- p->pv = pv;
- p->len = len;
- } while (targ_chain);
- }
- else if (is_append)
- SvGETMAGIC(targ);
-
- goto phase3;
- }
-
- if (SvFLAGS(sv) & SVs_RMG) {
- /* probably tied; copy it to guarantee separate values
- * each time it's used, e.g. "-$tied-$tied-$tied-",
- * since FETCH() isn't necessarily idempotent */
- SV *nsv = newSV(0);
- sv_setsv_flags(nsv, sv, SV_NOSTEAL);
- sv_2mortal(nsv);
- if ( sv == targ
- && is_append
- && nargs == 1
- /* no const string segments */
- && aux[PERL_MULTICONCAT_IX_LENGTHS].ssize == -1
- && aux[PERL_MULTICONCAT_IX_LENGTHS+1].ssize == -1)
- {
- /* special-case $tied .= $tied.
- *
- * For something like
- * sub FETCH { $i++ }
- * then
- * $tied .= $tied . $tied . $tied;
- * will STORE "4123"
- * while
- * $tied .= $tied
- * will STORE "12"
- *
- * i.e. for a single mutator concat, the LHS is
- * retrieved first; in all other cases it is
- * retrieved last. Whether this is sane behaviour
- * is open to debate; but for now, multiconcat (as
- * it is an optimisation) tries to reproduce
- * existing behaviour.
- */
- sv_catsv(nsv, sv);
- sv_setsv(sv,nsv);
- SP++;
- goto phase7; /* just return targ as-is */
- }
-
- sv = nsv;
- }
- }
-
- if (sv == targ) {
- /* must warn for each RH usage of targ, except that
- * we will later get one warning when doing
- * SvPV_force(targ), *except* on '.=' */
- if ( !SvOK(sv)
- && (targ_chain || is_append)
- && ckWARN(WARN_UNINITIALIZED)
- )
- report_uninit(sv);
- goto targ_on_rhs;
- }
-
- /* stringify general SV */
+ goto do_magical;
+ else if (SvNIOK(sv)) {
+ if (targ == sv)
+ goto targ_on_rhs;
+ /* stringify general valid scalar */
svpv_end->pv = sv_2pv_flags(sv, &len, 0);
}
+ else if (!SvOK(sv)) {
+ if (ckWARN(WARN_UNINITIALIZED))
+ /* an undef value in the presence of warnings may trigger
+ * side affects */
+ goto do_magical;
+ svpv_end->pv = "";
+ len = 0;
+ }
+ else
+ goto do_magical; /* something weird */
utf8 = (SvFLAGS(sv) & SVf_UTF8);
dst_utf8 |= utf8;
*/
if (is_append) {
- if (UNLIKELY(SvFLAGS(targ) & (SVs_GMG|SVf_ROK))) {
- SvGETMAGIC(targ); /* must do before SvAMAGIC() check */
- if (UNLIKELY(SvAMAGIC(targ))) {
- /* $overloaded .= ....;
- * accumulate RHS in a temp SV rather than targ,
- * then append tmp to targ at the end using overload
- */
- assert(!targ_chain);
- dsv = newSVpvn_flags("", 0, SVs_TEMP);
-
- if ( svpv_end == svpv_buf + 1
- /* no const string segments */
- && aux[PERL_MULTICONCAT_IX_LENGTHS].ssize == -1
- ) {
- /* special case $overloaded .= $arg1:
- * avoid stringifying $arg1.
- * Similar to the $arg1 . $arg2 case in phase1
- */
- svpv_end--;
- SP--;
- }
-
- goto phase3;
- }
- }
+ /* abandon quick route if using targ might have side effects */
+ if (UNLIKELY(SvFLAGS(targ) & (SVs_GMG|SVf_ROK)))
+ goto do_magical;
if (SvOK(targ)) {
U32 targ_utf8;
grow += targ_len * (targ_count + is_append);
goto phase3;
}
+ else if (ckWARN(WARN_UNINITIALIZED))
+ /* warning might have side effects */
+ goto do_magical;
+ /* the undef targ will be silently SvPVCLEAR()ed below */
}
else if (UNLIKELY(SvTYPE(targ) >= SVt_REGEXP)) {
/* Assigning to some weird LHS type. Don't force the LHS to be an
* (which makes the 'F' typeglob an alias to the
* '*main::F*main::F' typeglob).
*/
- goto setup_overload;
+ goto do_magical;
}
- else if (targ_chain) {
+ else if (targ_chain)
/* targ was found on RHS.
- * We don't need the SvGETMAGIC() call and SvAMAGIC() test as
- * both were already done earlier in the SvPV() loop; other
- * than that we can share the same code with the append
- * branch below.
- * Note that this goto jumps directly into the SvOK() branch
- * even if targ isn't SvOK(), to force an 'uninitialised'
- * warning; e.g.
- * $undef .= .... targ only on LHS: don't warn
- * $undef .= $undef .... targ on RHS too: warn
+ * Force stringify it, using the same code as the append branch
+ * above, except that we don't need the magic/overload/undef
+ * checks as these will already have been done in the phase 1
+ * loop.
*/
- assert(!SvAMAGIC(targ));
goto stringify_targ;
- }
-
/* unrolled SvPVCLEAR() - mostly: no need to grow or set SvCUR() to 0;
* those will be done later. */
- assert(targ == dsv);
SV_CHECK_THINKFIRST_COW_DROP(targ);
SvUPGRADE(targ, SVt_PV);
SvFLAGS(targ) &= ~(SVf_OK|SVf_IVisUV|SVf_UTF8);
/* --------------------------------------------------------------
* Phase 3:
*
- * UTF-8 tweaks and grow dsv:
+ * UTF-8 tweaks and grow targ:
*
* Now that we know the length and utf8-ness of both the targ and
- * args, grow dsv to the size needed to accumulate all the args, based
+ * args, grow targ to the size needed to accumulate all the args, based
* on whether targ appears on the RHS, whether we're appending, and
* whether any non-utf8 args expand in size if converted to utf8.
*
* one set of segment lengths.
*
* * If the string has different plain and utf8 representations
- * (e.g. "\x80"), then then aux[PERL_MULTICONCAT_IX_PLAIN_PV/LEN]]
+ * (e.g. "\x80"), then aux[PERL_MULTICONCAT_IX_PLAIN_PV/LEN]]
* holds the plain rep, while aux[PERL_MULTICONCAT_IX_UTF8_PV/LEN]
* holds the utf8 rep, and there are 2 sets of segment lengths,
* with the utf8 set following after the plain set.
/* turn off utf8 handling if 'use bytes' is in scope */
if (UNLIKELY(dst_utf8 && IN_BYTES)) {
dst_utf8 = 0;
- SvUTF8_off(dsv);
+ SvUTF8_off(targ);
/* undo all the negative lengths which flag utf8-ness */
for (svpv_p = svpv_buf; svpv_p < svpv_end; svpv_p++) {
SSize_t len = svpv_p->len;
* calculate how much extra growth is needed for all the chars
* which will expand to two utf8 bytes.
* Also, if the growth is non-zero, negate the length to indicate
- * that this this is a variant string. Conversely, un-negate the
+ * that this is a variant string. Conversely, un-negate the
* length on utf8 args (which was only needed to flag non-utf8
* args in this loop */
for (svpv_p = svpv_buf; svpv_p < svpv_end; svpv_p++) {
/* unrolled SvGROW(), except don't check for SVf_IsCOW, which should
* already have been dropped */
- assert(!SvIsCOW(dsv));
- dsv_pv = (SvLEN(dsv) < (grow) ? sv_grow(dsv,grow) : SvPVX(dsv));
+ assert(!SvIsCOW(targ));
+ targ_pv = (SvLEN(targ) < (grow) ? sv_grow(targ,grow) : SvPVX(targ));
/* --------------------------------------------------------------
* Phase 4:
*
- * Now that dsv (which is probably targ) has been grown, we know the
- * final address of the targ PVX, if needed. Preserve / move targ
- * contents if appending or if targ appears on RHS.
+ * Now that targ has been grown, we know the final address of the targ
+ * PVX, if needed. Preserve / move targ contents if appending or if
+ * targ appears on RHS.
*
* Also update svpv_buf slots in targ_chain.
*
* On exit, the targ contents will have been moved to the
* earliest place they are needed (e.g. $x = "abc$x" will shift them
* 3 bytes, while $x .= ... will leave them at the beginning);
- * and dst_pv will point to the location within SvPVX(dsv) where the
+ * and dst_pv will point to the location within SvPVX(targ) where the
* next arg should be copied.
*/
if (targ_len) {
struct multiconcat_svpv *tc_stop;
- char *targ_pv = dsv_pv;
+ char *targ_buf = targ_pv; /* ptr to original targ string */
- assert(targ == dsv);
assert(is_append || targ_count);
if (is_append) {
- dsv_pv += targ_len;
+ targ_pv += targ_len;
tc_stop = NULL;
}
else {
}
if (offset) {
- targ_pv += offset;
- Move(dsv_pv, targ_pv, targ_len, char);
+ targ_buf += offset;
+ Move(targ_pv, targ_buf, targ_len, char);
/* a negative length implies don't Copy(), but do increment */
svpv_p->len = -((SSize_t)targ_len);
slow_concat = TRUE;
/* skip the first targ copy */
svpv_base++;
const_lens++;
- dsv_pv += targ_len;
+ targ_pv += targ_len;
}
/* Don't populate the first targ slot in the loop below; it's
while (targ_chain != tc_stop) {
struct multiconcat_svpv *p = targ_chain;
targ_chain = (struct multiconcat_svpv *)(p->pv);
- p->pv = targ_pv;
+ p->pv = targ_buf;
p->len = (SSize_t)targ_len;
}
}
/* --------------------------------------------------------------
* Phase 5:
*
- * Append all the args in svpv_buf, plus the const strings, to dsv.
+ * Append all the args in svpv_buf, plus the const strings, to targ.
*
* On entry to this section the (pv,len) pairs in svpv_buf have the
* following meanings:
* (pv, -(len+extra)) a plain string which will expand by 'extra'
* bytes when converted to utf8
* (0, -len) left-most targ, whose content has already
- * been copied. Just advance dsv_pv by len.
+ * been copied. Just advance targ_pv by len.
*/
/* If there are no constant strings and no special case args
SSize_t len = svpv_p->len;
if (!len)
continue;
- Copy(svpv_p->pv, dsv_pv, len, char);
- dsv_pv += len;
+ Copy(svpv_p->pv, targ_pv, len, char);
+ targ_pv += len;
}
const_lens += (svpv_end - svpv_base + 1);
}
/* Note that we iterate the loop nargs+1 times: to append nargs
* arguments and nargs+1 constant strings. For example, "-$a-$b-"
*/
- svpv_p = svpv_base - 1;
+ svpv_p = svpv_base;
for (;;) {
SSize_t len = (const_lens++)->ssize;
/* append next const string segment */
if (len > 0) {
- Copy(const_pv, dsv_pv, len, char);
- dsv_pv += len;
+ Copy(const_pv, targ_pv, len, char);
+ targ_pv += len;
const_pv += len;
}
- if (++svpv_p == svpv_end)
+ if (svpv_p == svpv_end)
break;
/* append next arg */
len = svpv_p->len;
if (LIKELY(len > 0)) {
- Copy(svpv_p->pv, dsv_pv, len, char);
- dsv_pv += len;
+ Copy(svpv_p->pv, targ_pv, len, char);
+ targ_pv += len;
}
else if (UNLIKELY(len < 0)) {
/* negative length indicates two special cases */
len = -len;
if (UNLIKELY(p)) {
/* copy plain-but-variant pv to a utf8 targ */
- char * end_pv = dsv_pv + len;
+ char * end_pv = targ_pv + len;
assert(dst_utf8);
- while (dsv_pv < end_pv) {
+ while (targ_pv < end_pv) {
U8 c = (U8) *p++;
- append_utf8_from_native_byte(c, (U8**)&dsv_pv);
+ append_utf8_from_native_byte(c, (U8**)&targ_pv);
}
}
else
/* arg is already-copied targ */
- dsv_pv += len;
+ targ_pv += len;
}
+ ++svpv_p;
}
}
- *dsv_pv = '\0';
- SvCUR_set(dsv, dsv_pv - SvPVX(dsv));
- assert(grow >= SvCUR(dsv) + 1);
- assert(SvLEN(dsv) >= SvCUR(dsv) + 1);
+ *targ_pv = '\0';
+ SvCUR_set(targ, targ_pv - SvPVX(targ));
+ assert(grow >= SvCUR(targ) + 1);
+ assert(SvLEN(targ) >= SvCUR(targ) + 1);
/* --------------------------------------------------------------
* Phase 6:
*
- * Handle overloading. If an overloaded arg or targ was detected
- * earlier, dsv will have been set to a new mortal, and any args and
- * consts to the left of the first overloaded arg will have been
- * accumulated to it. This section completes any further concatenation
- * steps with overloading handled.
+ * return result
*/
- if (UNLIKELY(dsv != targ)) {
- SV *res;
+ rpp_popfree_to_NN(PL_stack_sp - stack_adj);
+ SvTAINT(targ);
+ SvSETMAGIC(targ);
+ rpp_push_1(targ);
+ return NORMAL;
- SvFLAGS(dsv) |= dst_utf8;
+ /* --------------------------------------------------------------
+ * Phase 7:
+ *
+ * We only get here if any of the args (or targ too in the case of
+ * append) have something which might cause side effects, such
+ * as magic, overload, or an undef value in the presence of warnings.
+ * In that case, any earlier attempt to stringify the args will have
+ * been abandoned, and we come here instead.
+ *
+ * Here, we concat each arg in turn the old-fashioned way: essentially
+ * emulating pp_concat() in a loop. This means that all the weird edge
+ * cases will be handled correctly, if not necessarily speedily.
+ *
+ * Note that some args may already have been stringified - those are
+ * processed again, which is safe, since only args without side-effects
+ * were stringified earlier.
+ */
- if (SP <= toparg) {
- /* Stringifying the RHS was abandoned because *SP
- * is overloaded. dsv contains all the concatted strings
- * before *SP. Apply the rest of the args using overloading.
+ do_magical:
+ {
+ SSize_t i, n;
+ SV *left = NULL;
+ SV *right;
+ SV* nexttarg;
+ bool nextappend;
+ U32 utf8 = 0;
+ SV **svp;
+ const char *cpv = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv;
+ SV *csv = NULL; /* SV which will hold cpv */
+ UNOP_AUX_item *lens = aux + PERL_MULTICONCAT_IX_LENGTHS;
+ Size_t arg_count = 0; /* how many args have been processed */
+
+ if (!cpv) {
+ cpv = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv;
+ utf8 = SVf_UTF8;
+ }
+
+ svp = toparg - nargs + 1;
+
+ /* iterate for:
+ * nargs arguments,
+ * plus possible nargs+1 consts,
+ * plus, if appending, a final targ in an extra last iteration
+ */
+
+ n = nargs *2 + 1;
+ for (i = 0; i <= n; i++) {
+ SSize_t len;
+
+ /* if necessary, stringify the final RHS result in
+ * something like $targ .= "$a$b$c" - simulating
+ * pp_stringify
*/
- SV *left, *right, *res;
- int i;
- bool getmg = FALSE;
- /* number of args already concatted */
- SSize_t n = (nargs - 1) - (toparg - SP);
- /* current arg is either the first
- * or second value to be concatted
- * (including constant strings), so would
- * form part of the first concat */
- bool first_concat = ( n == 0
- || (n == 1 && const_lens[-2].ssize < 0
- && const_lens[-1].ssize < 0));
- int f_assign = first_concat ? 0 : AMGf_assign;
-
- left = dsv;
-
- for (; n < nargs; n++) {
- /* loop twice, first applying the arg, then the const segment */
- for (i = 0; i < 2; i++) {
- if (i) {
- /* append next const string segment */
- STRLEN len = (STRLEN)((const_lens++)->ssize);
- /* a length of -1 implies no constant string
- * rather than a zero-length one, e.g.
- * ($a . $b) versus ($a . "" . $b)
- */
- if ((SSize_t)len < 0)
- continue;
+ if ( i == n
+ && (PL_op->op_private &OPpMULTICONCAT_STRINGIFY)
+ && !(SvPOK(left))
+ /* extra conditions for backwards compatibility:
+ * probably incorrect, but keep the existing behaviour
+ * for now. The rules are:
+ * $x = "$ov" single arg: stringify;
+ * $x = "$ov$y" multiple args: don't stringify,
+ * $lex = "$ov$y$z" except TARGMY with at least 2 concats
+ */
+ && ( arg_count == 1
+ || ( arg_count >= 3
+ && !is_append
+ && (PL_op->op_private & OPpTARGET_MY)
+ && !(PL_op->op_private & OPpLVAL_INTRO)
+ )
+ )
+ )
+ {
+ assert(aux[PERL_MULTICONCAT_IX_PADTMP2].pad_offset);
+ SV *tmp = PAD_SV(aux[PERL_MULTICONCAT_IX_PADTMP2].pad_offset);
+ sv_copypv(tmp, left);
+ SvSETMAGIC(tmp);
+ left = tmp;
+ }
- /* set right to the next constant string segment */
- right = newSVpvn_flags(const_pv, len,
- (dst_utf8 | SVs_TEMP));
- const_pv += len;
- }
+ /* do one extra iteration to handle $targ in $targ .= ... */
+ if (i == n && !is_append)
+ break;
+
+ /* get the next arg SV or regen the next const SV */
+ len = lens[i >> 1].ssize;
+ if (i == n) {
+ /* handle the final targ .= (....) */
+ right = left;
+ left = targ;
+ }
+ else if (i & 1)
+ right = svp[(i >> 1)];
+ else if (len < 0)
+ continue; /* no const in this position */
+ else {
+ /* Use one of our PADTMPs to fake up the SV which would
+ * have been returned by an OP_CONST. Try to reuse it if
+ * possible. If the refcount has gone up, something like
+ * overload code has taken a reference to it, so abandon
+ * it */
+ if (!csv || SvREFCNT(csv) > 1 || SvLEN(csv) != 0) {
+ if (csv)
+ csv = newSV_type_mortal(SVt_PV);
else {
- /* append next arg */
- right = *SP++;
- if (getmg)
- SvGETMAGIC(right);
- else
- /* SvGETMAGIC already called on this SV just
- * before we broke from the loop earlier */
- getmg = TRUE;
-
- if (first_concat && n == 0 && const_lens[-1].ssize < 0) {
- /* nothing before the current arg; repeat the
- * loop to get a second arg */
- left = right;
- first_concat = FALSE;
- continue;
- }
+ assert(aux[PERL_MULTICONCAT_IX_PADTMP1].pad_offset);
+ csv = PAD_SV(
+ aux[PERL_MULTICONCAT_IX_PADTMP1].pad_offset);
+ SvUPGRADE(csv, SVt_PV);
}
- if ((SvAMAGIC(left) || SvAMAGIC(right))
- && (res = amagic_call(left, right, concat_amg, f_assign))
+ if (utf8)
+ SvUTF8_on(csv);
+ SvREADONLY_on(csv);
+ SvPOK_on(csv);
+ }
+ /* use the const string buffer directly with the
+ * SvLEN==0 trick */
+
+ /* cast away constness because we think we know it's safe
+ * (SvREADONLY) */
+ SvPV_set(csv, (char *)cpv);
+ SvLEN_set(csv, 0);
+ SvCUR_set(csv, len);
+
+ right = csv;
+ cpv += len;
+ }
+
+ arg_count++;
+
+ if (arg_count <= 1) {
+ left = right;
+ continue; /* need at least two SVs to concat together */
+ }
+
+ if (arg_count == 2 && i < n) {
+ /* for the first concat, use one of the PADTMPs to emulate
+ * the PADTMP from OP_CONST. In later iterations this will
+ * be appended to */
+ nexttarg = PAD_SV(aux[PERL_MULTICONCAT_IX_PADTMP0].pad_offset);
+ nextappend = FALSE;
+ }
+ else {
+ nexttarg = left;
+ nextappend = TRUE;
+ }
+
+ /* Handle possible overloading.
+ * This is basically an unrolled
+ * tryAMAGICbin_MG(concat_amg, AMGf_assign);
+ * and
+ * Perl_try_amagic_bin()
+ * call, but using left and right rather than
+ * PL_stack_sp[-1], PL_stack_sp[0],
+ * and not relying on OPf_STACKED implying .=
+ */
+
+ if ((SvFLAGS(left)|SvFLAGS(right)) & (SVf_ROK|SVs_GMG)) {
+ SvGETMAGIC(left);
+ if (left != right)
+ SvGETMAGIC(right);
+
+ if ((SvAMAGIC(left) || SvAMAGIC(right))
+ /* sprintf doesn't do concat overloading,
+ * but allow for $x .= sprintf(...)
+ */
+ && ( !(PL_op->op_private & OPpMULTICONCAT_FAKE)
+ || i == n)
)
- left = res;
- else {
- if (left != dsv) {
- sv_setsv(dsv, left);
- left = dsv;
+ {
+ SV * const tmpsv = amagic_call(left, right, concat_amg,
+ (nextappend ? AMGf_assign: 0));
+ if (tmpsv) {
+ /* NB: tryAMAGICbin_MG() includes an OPpTARGET_MY test
+ * here, which isn't needed as any implicit
+ * assign done under OPpTARGET_MY is done after
+ * this loop */
+ if (nextappend) {
+ sv_setsv(left, tmpsv);
+ SvSETMAGIC(left);
}
- sv_catsv_nomg(left, right);
+ else
+ left = tmpsv;
+ continue;
}
- f_assign = AMGf_assign;
+ }
+
+ /* if both args are the same magical value, make one a copy */
+ if (left == right && SvGMAGICAL(left)) {
+ SV * targetsv = right;
+ /* Print the uninitialized warning now, so it includes the
+ * variable name. */
+ if (!SvOK(right)) {
+ if (ckWARN(WARN_UNINITIALIZED))
+ report_uninit(right);
+ targetsv = &PL_sv_no;
+ }
+ left = sv_mortalcopy_flags(targetsv, 0);
+ SvGETMAGIC(right);
}
}
- dsv = left;
+
+ /* nexttarg = left . right */
+ S_do_concat(aTHX_ left, right, nexttarg, 0);
+ left = nexttarg;
}
- /* assign/append RHS (dsv) to LHS (targ) */
- if (is_append) {
- if ((SvAMAGIC(targ) || SvAMAGIC(dsv))
- && (res = amagic_call(targ, dsv, concat_amg, AMGf_assign))
- )
- sv_setsv(targ, res);
- else
- sv_catsv_nomg(targ, dsv);
+ /* Return the result of all RHS concats, unless this op includes
+ * an assign ($lex = x.y.z or expr = x.y.z), in which case copy
+ * to target (which will be $lex or expr).
+ * If we are appending, targ will already have been appended to in
+ * the loop */
+ if ( !is_append
+ && ( (PL_op->op_flags & OPf_STACKED)
+ || (PL_op->op_private & OPpTARGET_MY))
+ ) {
+ sv_setsv(targ, left);
+ SvSETMAGIC(targ);
}
else
- sv_setsv(targ, dsv);
- }
-
- /* --------------------------------------------------------------
- * Phase 7:
- *
- * return result
- */
+ targ = left;
- phase7:
-
- SP -= stack_adj;
- SvTAINT(targ);
- SETTARG;
- RETURN;
+ rpp_popfree_to_NN(PL_stack_sp - stack_adj);
+ rpp_push_1(targ);
+ return NORMAL;
+ }
}
STATIC OP*
S_pushav(pTHX_ AV* const av)
{
- dSP;
const SSize_t maxarg = AvFILL(av) + 1;
- EXTEND(SP, maxarg);
+ rpp_extend(maxarg);
if (UNLIKELY(SvRMAGICAL(av))) {
PADOFFSET i;
for (i=0; i < (PADOFFSET)maxarg; i++) {
SV ** const svp = av_fetch(av, i, FALSE);
- SP[i+1] = svp ? *svp : &PL_sv_undef;
+ rpp_push_1(LIKELY(svp)
+ ? *svp
+ : UNLIKELY(PL_op->op_flags & OPf_MOD)
+ ? av_nonelem(av,i)
+ : &PL_sv_undef
+ );
}
}
else {
PADOFFSET i;
for (i=0; i < (PADOFFSET)maxarg; i++) {
- SV * const sv = AvARRAY(av)[i];
- SP[i+1] = LIKELY(sv) ? sv : &PL_sv_undef;
+ SV *sv = AvARRAY(av)[i];
+ rpp_push_1(LIKELY(sv)
+ ? sv
+ : UNLIKELY(PL_op->op_flags & OPf_MOD)
+ ? av_nonelem(av,i)
+ : &PL_sv_undef
+ );
}
}
- SP += maxarg;
- PUTBACK;
return NORMAL;
}
PP(pp_padrange)
{
- dSP;
PADOFFSET base = PL_op->op_targ;
int count = (int)(PL_op->op_private) & OPpPADRANGE_COUNTMASK;
if (PL_op->op_flags & OPf_SPECIAL) {
/* fake the RHS of my ($x,$y,..) = @_ */
- PUSHMARK(SP);
+ PUSHMARK(PL_stack_sp);
(void)S_pushav(aTHX_ GvAVn(PL_defgv));
- SPAGAIN;
}
/* note, this is only skipped for compile-time-known void cxt */
if ((PL_op->op_flags & OPf_WANT) != OPf_WANT_VOID) {
int i;
- EXTEND(SP, count);
- PUSHMARK(SP);
+ rpp_extend(count);
+ PUSHMARK(PL_stack_sp);
for (i = 0; i <count; i++)
- *++SP = PAD_SV(base+i);
+ rpp_push_1(PAD_SV(base+i));
}
+
if (PL_op->op_private & OPpLVAL_INTRO) {
SV **svp = &(PAD_SVl(base));
const UV payload = (UV)(
for (i = 0; i <count; i++)
SvPADSTALE_off(*svp++); /* mark lexical as active */
}
- RETURN;
+ return NORMAL;
}
PP(pp_padsv)
{
- dSP;
- EXTEND(SP, 1);
{
- OP * const op = PL_op;
- /* access PL_curpad once */
- SV ** const padentry = &(PAD_SVl(op->op_targ));
- {
- dTARG;
- TARG = *padentry;
- PUSHs(TARG);
- PUTBACK; /* no pop/push after this, TOPs ok */
- }
- if (op->op_flags & OPf_MOD) {
- if (op->op_private & OPpLVAL_INTRO)
- if (!(op->op_private & OPpPAD_STATE))
- save_clearsv(padentry);
- if (op->op_private & OPpDEREF) {
- /* TOPs is equivalent to TARG here. Using TOPs (SP) rather
- than TARG reduces the scope of TARG, so it does not
- span the call to save_clearsv, resulting in smaller
- machine code. */
- TOPs = vivify_ref(TOPs, op->op_private & OPpDEREF);
- }
- }
- return op->op_next;
+ OP * const op = PL_op;
+ /* access PL_curpad once */
+ SV ** const padentry = &(PAD_SVl(op->op_targ));
+ {
+ dTARG;
+ TARG = *padentry;
+ rpp_xpush_1(TARG);
+ }
+ if (op->op_flags & OPf_MOD) {
+ if (op->op_private & OPpLVAL_INTRO)
+ if (!(op->op_private & OPpPAD_STATE))
+ save_clearsv(padentry);
+ if (op->op_private & OPpDEREF) {
+ /* *sp is equivalent to TARG here. Using *sp rather
+ than TARG reduces the scope of TARG, so it does not
+ span the call to save_clearsv, resulting in smaller
+ machine code. */
+ rpp_replace_1_1_NN(
+ vivify_ref(*PL_stack_sp, op->op_private & OPpDEREF));
+ }
+ }
+ return op->op_next;
}
}
+
+/* Implement readline(), and also <X> and <<X>> in the cases where X is
+ * seen by the parser as file-handle-ish rather than glob-ish.
+ *
+ * It expects at least one arg: the typeglob or scalar filehandle to read
+ * from. An empty <> isn't handled specially by this op; instead the parser
+ * will have planted a preceding gv(*ARGV) op.
+ *
+ * Scalar assignment is optimised away by making the assignment target be
+ * passed as a second argument, with OPf_STACKED set. For example,
+ *
+ * $x[$i] = readline($fh);
+ *
+ * is implemented as if written as
+ *
+ * readline($x[$i], $fh);
+ *
+ * (that is, if the perl-level readline function took two args, which it
+ * doesn't). The 'while (<>) {...}' construct is handled specially by the
+ * parser, but not specially by this op. The parser treats the condition
+ * as
+ *
+ * defined($_ = <>)
+ *
+ * which is then optimised into the equivalent of
+ *
+ * defined(readline($_, *ARGV))
+ *
+ * When called as a real function, e.g. (\&CORE::readline)->(*STDIN),
+ * pp_coreargs() will have pushed a NULL if no argument was supplied.
+ *
+ * The parser decides whether '<something>' in the perl src code causes an
+ * OP_GLOB or an OPREADLINE op to be planted.
+ */
+
PP(pp_readline)
{
- dSP;
+ SV *arg = *PL_stack_sp;
+
/* pp_coreargs pushes a NULL to indicate no args passed to
* CORE::readline() */
- if (TOPs) {
- SvGETMAGIC(TOPs);
- tryAMAGICunTARGETlist(iter_amg, 0);
- PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
+ if (arg) {
+ SvGETMAGIC(arg);
+
+ /* unrolled tryAMAGICunTARGETlist(iter_amg, 0) */
+ SV *tmpsv;
+ U8 gimme = GIMME_V;
+ if (UNLIKELY(SvAMAGIC(arg) &&
+ (tmpsv = amagic_call(arg, &PL_sv_undef, iter_amg,
+ AMGf_want_list | AMGf_noright
+ |AMGf_unary))))
+ {
+ if (gimme == G_VOID) {
+ NOOP;
+ }
+ else if (gimme == G_LIST) {
+ SSize_t i;
+ SSize_t len;
+ assert(SvTYPE(tmpsv) == SVt_PVAV);
+ len = av_count((AV *)tmpsv);
+ assert(*PL_stack_sp == arg);
+ rpp_popfree_1_NN(); /* pop the original filehhandle arg */
+ /* no assignment target to pop */
+ assert(!(PL_op->op_flags & OPf_STACKED));
+ rpp_extend(len);
+ for (i = 0; i < len; ++i)
+ /* amagic_call() naughtily doesn't increment the ref counts
+ * of the items it pushes onto the temporary array. So we
+ * don't need to decrement them when shifting off. */
+ rpp_push_1(av_shift((AV *)tmpsv));
+ }
+ else { /* AMGf_want_scalar */
+ /* OPf_STACKED: assignment optimised away and target
+ * on stack */
+ SV *targ = (PL_op->op_flags & OPf_STACKED)
+ ? PL_stack_sp[-1]
+ : PAD_SV(PL_op->op_targ);
+ sv_setsv(targ, tmpsv);
+ SvSETMAGIC(targ);
+ if (PL_op->op_flags & OPf_STACKED) {
+ rpp_popfree_1_NN();
+ assert(*PL_stack_sp == targ);
+ }
+ else
+ rpp_replace_1_1_NN(targ);
+ }
+ return NORMAL;
+ }
+ /* end of unrolled tryAMAGICunTARGETlist */
+
+ PL_last_in_gv = MUTABLE_GV(*PL_stack_sp);
+#ifdef PERL_RC_STACK
+ /* PL_last_in_gv appears to be non-refcounted, so won't keep
+ * GV alive */
+ if (SvREFCNT(PL_last_in_gv) < 2)
+ sv_2mortal((SV*)PL_last_in_gv);
+#endif
+ rpp_popfree_1_NN();
}
- else PL_last_in_gv = PL_argvgv, PL_stack_sp--;
+ else {
+ PL_last_in_gv = PL_argvgv;
+ PL_stack_sp--;
+ }
+
+
+ /* is it *FOO, $fh, or 'FOO' ? */
if (!isGV_with_GP(PL_last_in_gv)) {
- if (SvROK(PL_last_in_gv) && isGV_with_GP(SvRV(PL_last_in_gv)))
- PL_last_in_gv = MUTABLE_GV(SvRV(PL_last_in_gv));
- else {
- dSP;
- XPUSHs(MUTABLE_SV(PL_last_in_gv));
- PUTBACK;
- Perl_pp_rv2gv(aTHX);
- PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
- assert((SV*)PL_last_in_gv == &PL_sv_undef || isGV_with_GP(PL_last_in_gv));
- }
+ if (SvROK(PL_last_in_gv) && isGV_with_GP(SvRV(PL_last_in_gv)))
+ PL_last_in_gv = MUTABLE_GV(SvRV(PL_last_in_gv));
+ else {
+ rpp_xpush_1(MUTABLE_SV(PL_last_in_gv));
+ Perl_pp_rv2gv(aTHX);
+ PL_last_in_gv = MUTABLE_GV(*PL_stack_sp);
+ rpp_popfree_1_NN();
+ assert( (SV*)PL_last_in_gv == &PL_sv_undef
+ || isGV_with_GP(PL_last_in_gv));
+ }
}
+
return do_readline();
}
+
PP(pp_eq)
{
- dSP;
- SV *left, *right;
-
- tryAMAGICbin_MG(eq_amg, AMGf_set|AMGf_numeric);
- right = POPs;
- left = TOPs;
- SETs(boolSV(
- (SvIOK_notUV(left) && SvIOK_notUV(right))
- ? (SvIVX(left) == SvIVX(right))
- : ( do_ncmp(left, right) == 0)
+ if (rpp_try_AMAGIC_2(eq_amg, AMGf_numeric))
+ return NORMAL;
+
+ SV *right = PL_stack_sp[0];
+ SV *left = PL_stack_sp[-1];
+
+ U32 flags_and = SvFLAGS(left) & SvFLAGS(right);
+ U32 flags_or = SvFLAGS(left) | SvFLAGS(right);
+
+ rpp_replace_2_IMM_NN(boolSV(
+ ( (flags_and & SVf_IOK) && ((flags_or & SVf_IVisUV) ==0 ) )
+ ? (SvIVX(left) == SvIVX(right))
+ : (flags_and & SVf_NOK)
+ ? (SvNVX(left) == SvNVX(right))
+ : ( do_ncmp(left, right) == 0)
));
- RETURN;
+ return NORMAL;
}
== SVf_IOK))
&& SvIVX(sv) != IV_MAX)
{
- SvIV_set(sv, SvIVX(sv) + 1);
+ SvIV_set(sv, SvIVX(sv) + 1);
}
else /* Do all the PERL_PRESERVE_IVUV and hard cases in sv_inc */
- sv_inc(sv);
+ sv_inc(sv);
SvSETMAGIC(sv);
return NORMAL;
}
== SVf_IOK))
&& SvIVX(sv) != IV_MIN)
{
- SvIV_set(sv, SvIVX(sv) - 1);
+ SvIV_set(sv, SvIVX(sv) - 1);
}
else /* Do all the PERL_PRESERVE_IVUV and hard cases in sv_dec */
- sv_dec(sv);
+ sv_dec(sv);
SvSETMAGIC(sv);
return NORMAL;
}
PP(pp_or)
{
- dSP;
SV *sv;
PERL_ASYNC_CHECK();
- sv = TOPs;
+ sv = *PL_stack_sp;
if (SvTRUE_NN(sv))
- RETURN;
+ return NORMAL;
else {
- if (PL_op->op_type == OP_OR)
- --SP;
- RETURNOP(cLOGOP->op_other);
+ if (PL_op->op_type == OP_OR)
+ rpp_popfree_1_NN();
+ return cLOGOP->op_other;
}
}
PP(pp_defined)
{
- dSP;
- SV* sv;
- bool defined;
+ SV* sv = *PL_stack_sp;
+ bool defined = FALSE;
const int op_type = PL_op->op_type;
const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
if (is_dor) {
- PERL_ASYNC_CHECK();
- sv = TOPs;
+ PERL_ASYNC_CHECK();
+ if (UNLIKELY(!sv || !SvANY(sv))) {
+ if (op_type == OP_DOR)
+ rpp_popfree_1();
+ return cLOGOP->op_other;
+ }
+ }
+ else {
+ /* OP_DEFINED */
if (UNLIKELY(!sv || !SvANY(sv))) {
- if (op_type == OP_DOR)
- --SP;
- RETURNOP(cLOGOP->op_other);
+ rpp_replace_1_1(&PL_sv_no);
+ return NORMAL;
}
}
+
+ /* Historically what followed was a switch on SvTYPE(sv), handling SVt_PVAV,
+ * SVt_PVCV, SVt_PVHV and "default". `defined &sub` is still valid syntax,
+ * hence we still need the special case PVCV code. But AVs and HVs now
+ * should never arrive here... */
+#ifdef DEBUGGING
+ assert(SvTYPE(sv) != SVt_PVAV);
+ assert(SvTYPE(sv) != SVt_PVHV);
+#endif
+
+ if (UNLIKELY(SvTYPE(sv) == SVt_PVCV)) {
+ if (CvROOT(sv) || CvXSUB(sv))
+ defined = TRUE;
+ }
else {
- /* OP_DEFINED */
- sv = POPs;
- if (UNLIKELY(!sv || !SvANY(sv)))
- RETPUSHNO;
- }
-
- defined = FALSE;
- switch (SvTYPE(sv)) {
- case SVt_PVAV:
- if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
- defined = TRUE;
- break;
- case SVt_PVHV:
- if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
- defined = TRUE;
- break;
- case SVt_PVCV:
- if (CvROOT(sv) || CvXSUB(sv))
- defined = TRUE;
- break;
- default:
- SvGETMAGIC(sv);
- if (SvOK(sv))
- defined = TRUE;
- break;
+ SvGETMAGIC(sv);
+ if (SvOK(sv))
+ defined = TRUE;
}
if (is_dor) {
if(defined)
- RETURN;
+ return NORMAL;
if(op_type == OP_DOR)
- --SP;
- RETURNOP(cLOGOP->op_other);
+ rpp_popfree_1_NN();
+ return cLOGOP->op_other;
}
/* assuming OP_DEFINED */
- if(defined)
- RETPUSHYES;
- RETPUSHNO;
+ rpp_replace_1_IMM_NN(defined ? &PL_sv_yes : &PL_sv_no);
+ return NORMAL;
}
PP(pp_add)
{
- dSP; dATARGET; bool useleft; SV *svl, *svr;
+ bool useleft; SV *svl, *svr;
+ SV *targ = (PL_op->op_flags & OPf_STACKED)
+ ? PL_stack_sp[-1]
+ : PAD_SV(PL_op->op_targ);
+
+ if (rpp_try_AMAGIC_2(add_amg, AMGf_assign|AMGf_numeric))
+ return NORMAL;
- tryAMAGICbin_MG(add_amg, AMGf_assign|AMGf_numeric);
- svr = TOPs;
- svl = TOPm1s;
+ svr = PL_stack_sp[0];
+ svl = PL_stack_sp[-1];
#ifdef PERL_PRESERVE_IVUV
* simple integer add: if the top of both numbers
* are 00 or 11, then it's safe */
if (!( ((topl+1) | (topr+1)) & 2)) {
- SP--;
TARGi(il + ir, 0); /* args not GMG, so can't be tainted */
- SETs(TARG);
- RETURN;
+ goto ret;
}
goto generic;
}
NV nl = SvNVX(svl);
NV nr = SvNVX(svr);
- if (
-#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
- !Perl_isnan(nl) && nl == (NV)(il = (IV)nl)
- && !Perl_isnan(nr) && nr == (NV)(ir = (IV)nr)
-#else
- nl == (NV)(il = (IV)nl) && nr == (NV)(ir = (IV)nr)
-#endif
- )
+ if (lossless_NV_to_IV(nl, &il) && lossless_NV_to_IV(nr, &ir)) {
/* nothing was lost by converting to IVs */
goto do_iv;
- SP--;
+ }
TARGn(nl + nr, 0); /* args not GMG, so can't be tainted */
- SETs(TARG);
- RETURN;
+ goto ret;
}
}
*/
if (SvIV_please_nomg(svr)) {
- /* Unless the left argument is integer in range we are going to have to
- use NV maths. Hence only attempt to coerce the right argument if
- we know the left is integer. */
- UV auv = 0;
- bool auvok = FALSE;
- bool a_valid = 0;
-
- if (!useleft) {
- auv = 0;
- a_valid = auvok = 1;
- /* left operand is undef, treat as zero. + 0 is identity,
- Could SETi or SETu right now, but space optimise by not adding
- lots of code to speed up what is probably a rarish case. */
- } else {
- /* Left operand is defined, so is it IV? */
- if (SvIV_please_nomg(svl)) {
- if ((auvok = SvUOK(svl)))
- auv = SvUVX(svl);
- else {
- const IV aiv = SvIVX(svl);
- if (aiv >= 0) {
- auv = aiv;
- auvok = 1; /* Now acting as a sign flag. */
- } else {
- auv = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv);
- }
- }
- a_valid = 1;
- }
- }
- if (a_valid) {
- bool result_good = 0;
- UV result;
- UV buv;
- bool buvok = SvUOK(svr);
-
- if (buvok)
- buv = SvUVX(svr);
- else {
- const IV biv = SvIVX(svr);
- if (biv >= 0) {
- buv = biv;
- buvok = 1;
- } else
- buv = (biv == IV_MIN) ? (UV)biv : (UV)(-biv);
- }
- /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
- else "IV" now, independent of how it came in.
- if a, b represents positive, A, B negative, a maps to -A etc
- a + b => (a + b)
- A + b => -(a - b)
- a + B => (a - b)
- A + B => -(a + b)
- all UV maths. negate result if A negative.
- add if signs same, subtract if signs differ. */
-
- if (auvok ^ buvok) {
- /* Signs differ. */
- if (auv >= buv) {
- result = auv - buv;
- /* Must get smaller */
- if (result <= auv)
- result_good = 1;
- } else {
- result = buv - auv;
- if (result <= buv) {
- /* result really should be -(auv-buv). as its negation
- of true value, need to swap our result flag */
- auvok = !auvok;
- result_good = 1;
- }
- }
- } else {
- /* Signs same */
- result = auv + buv;
- if (result >= auv)
- result_good = 1;
- }
- if (result_good) {
- SP--;
- if (auvok)
- SETu( result );
- else {
- /* Negate result */
- if (result <= (UV)IV_MIN)
- SETi(result == (UV)IV_MIN
- ? IV_MIN : -(IV)result);
- else {
- /* result valid, but out of range for IV. */
- SETn( -(NV)result );
- }
- }
- RETURN;
- } /* Overflow, drop through to NVs. */
- }
+ /* Unless the left argument is integer in range we are going to have to
+ use NV maths. Hence only attempt to coerce the right argument if
+ we know the left is integer. */
+ UV auv = 0;
+ bool auvok = FALSE;
+ bool a_valid = 0;
+
+ if (!useleft) {
+ auv = 0;
+ a_valid = auvok = 1;
+ /* left operand is undef, treat as zero. + 0 is identity,
+ Could TARGi or TARGu right now, but space optimise by not
+ adding lots of code to speed up what is probably a rare-ish
+ case. */
+ } else {
+ /* Left operand is defined, so is it IV? */
+ if (SvIV_please_nomg(svl)) {
+ if ((auvok = SvUOK(svl)))
+ auv = SvUVX(svl);
+ else {
+ const IV aiv = SvIVX(svl);
+ if (aiv >= 0) {
+ auv = aiv;
+ auvok = 1; /* Now acting as a sign flag. */
+ } else {
+ /* Using 0- here and later to silence bogus warning
+ * from MS VC */
+ auv = (UV) (0 - (UV) aiv);
+ }
+ }
+ a_valid = 1;
+ }
+ }
+ if (a_valid) {
+ bool result_good = 0;
+ UV result;
+ UV buv;
+ bool buvok = SvUOK(svr);
+
+ if (buvok)
+ buv = SvUVX(svr);
+ else {
+ const IV biv = SvIVX(svr);
+ if (biv >= 0) {
+ buv = biv;
+ buvok = 1;
+ } else
+ buv = (UV) (0 - (UV) biv);
+ }
+ /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
+ else "IV" now, independent of how it came in.
+ if a, b represents positive, A, B negative, a maps to -A etc
+ a + b => (a + b)
+ A + b => -(a - b)
+ a + B => (a - b)
+ A + B => -(a + b)
+ all UV maths. negate result if A negative.
+ add if signs same, subtract if signs differ. */
+
+ if (auvok ^ buvok) {
+ /* Signs differ. */
+ if (auv >= buv) {
+ result = auv - buv;
+ /* Must get smaller */
+ if (result <= auv)
+ result_good = 1;
+ } else {
+ result = buv - auv;
+ if (result <= buv) {
+ /* result really should be -(auv-buv). as its negation
+ of true value, need to swap our result flag */
+ auvok = !auvok;
+ result_good = 1;
+ }
+ }
+ } else {
+ /* Signs same */
+ result = auv + buv;
+ if (result >= auv)
+ result_good = 1;
+ }
+ if (result_good) {
+ if (auvok)
+ TARGu(result,1);
+ else {
+ /* Negate result */
+ if (result <= (UV)IV_MIN)
+ TARGi(result == (UV)IV_MIN
+ ? IV_MIN : -(IV)result, 1);
+ else {
+ /* result valid, but out of range for IV. */
+ TARGn(-(NV)result, 1);
+ }
+ }
+ goto ret;
+ } /* Overflow, drop through to NVs. */
+ }
}
#else
#endif
{
- NV value = SvNV_nomg(svr);
- (void)POPs;
- if (!useleft) {
- /* left operand is undef, treat as zero. + 0.0 is identity. */
- SETn(value);
- RETURN;
- }
- SETn( value + SvNV_nomg(svl) );
- RETURN;
+ NV value = SvNV_nomg(svr);
+ if (!useleft) {
+ /* left operand is undef, treat as zero. + 0.0 is identity. */
+ TARGn(value, 1);
+ }
+ else {
+ TARGn(value + SvNV_nomg(svl), 1);
+ }
}
+
+ ret:
+ rpp_replace_2_1_NN(targ);
+ return NORMAL;
}
PP(pp_aelemfast)
{
- dSP;
AV * const av = PL_op->op_type == OP_AELEMFAST_LEX
- ? MUTABLE_AV(PAD_SV(PL_op->op_targ)) : GvAVn(cGVOP_gv);
+ ? MUTABLE_AV(PAD_SV(PL_op->op_targ)) : GvAVn(cGVOP_gv);
const U32 lval = PL_op->op_flags & OPf_MOD;
const I8 key = (I8)PL_op->op_private;
SV** svp;
assert(SvTYPE(av) == SVt_PVAV);
- EXTEND(SP, 1);
-
/* inlined av_fetch() for simple cases ... */
if (!SvRMAGICAL(av) && key >= 0 && key <= AvFILLp(av)) {
sv = AvARRAY(av)[key];
- if (sv) {
- PUSHs(sv);
- RETURN;
+ if (sv)
+ goto ret;
+ if (!lval) {
+ sv = &PL_sv_undef;
+ goto ret;
}
}
DIE(aTHX_ PL_no_aelem, (int)key);
if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
- mg_get(sv);
- PUSHs(sv);
- RETURN;
+ mg_get(sv);
+
+ ret:
+ rpp_xpush_1(sv);
+ return NORMAL;
}
PP(pp_join)
{
- dSP; dMARK; dTARGET;
+ dMARK; dTARGET;
MARK++;
- do_join(TARG, *MARK, MARK, SP);
- SP = MARK;
- SETs(TARG);
- RETURN;
+ do_join(TARG, *MARK, MARK, PL_stack_sp);
+ rpp_popfree_to_NN(MARK - 1);
+ rpp_push_1(TARG);
+ return NORMAL;
}
+
/* Oversized hot code. */
/* also used for: pp_say() */
PP(pp_print)
{
- dSP; dMARK; dORIGMARK;
+ dMARK; dORIGMARK;
PerlIO *fp;
MAGIC *mg;
GV * const gv
- = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
+ = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
IO *io = GvIO(gv);
+ SV *retval = &PL_sv_undef;
if (io
- && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
+ && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
{
had_magic:
- if (MARK == ORIGMARK) {
- /* If using default handle then we need to make space to
- * pass object as 1st arg, so move other args up ...
- */
- MEXTEND(SP, 1);
- ++MARK;
- Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
- ++SP;
- }
- return Perl_tied_method(aTHX_ SV_CONST(PRINT), mark - 1, MUTABLE_SV(io),
- mg,
- (G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK
- | (PL_op->op_type == OP_SAY
- ? TIED_METHOD_SAY : 0)), sp - mark);
+ if (MARK == ORIGMARK) {
+ /* If using default handle then we need to make space to
+ * pass object as 1st arg, so move other args up ...
+ */
+ rpp_extend(1);
+ MARK = ORIGMARK; /* stack may have been realloced */
+ ++MARK;
+ Move(MARK, MARK + 1, (PL_stack_sp - MARK) + 1, SV*);
+ *MARK = NULL;
+ ++PL_stack_sp;
+ }
+ return Perl_tied_method(aTHX_ SV_CONST(PRINT), mark - 1, MUTABLE_SV(io),
+ mg,
+ (G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK
+ | (PL_op->op_type == OP_SAY
+ ? TIED_METHOD_SAY : 0)),
+ PL_stack_sp - mark);
}
+
if (!io) {
if ( gv && GvEGVx(gv) && (io = GvIO(GvEGV(gv)))
- && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
+ && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
goto had_magic;
- report_evil_fh(gv);
- SETERRNO(EBADF,RMS_IFI);
- goto just_say_no;
+ report_evil_fh(gv);
+ SETERRNO(EBADF,RMS_IFI);
+ goto just_say_no;
}
else if (!(fp = IoOFP(io))) {
- if (IoIFP(io))
- report_wrongway_fh(gv, '<');
- else
- report_evil_fh(gv);
- SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
- goto just_say_no;
+ if (IoIFP(io))
+ report_wrongway_fh(gv, '<');
+ else
+ report_evil_fh(gv);
+ SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
+ goto just_say_no;
}
else {
- SV * const ofs = GvSV(PL_ofsgv); /* $, */
- MARK++;
- if (ofs && (SvGMAGICAL(ofs) || SvOK(ofs))) {
- while (MARK <= SP) {
- if (!do_print(*MARK, fp))
- break;
- MARK++;
- if (MARK <= SP) {
- /* don't use 'ofs' here - it may be invalidated by magic callbacks */
- if (!do_print(GvSV(PL_ofsgv), fp)) {
- MARK--;
- break;
- }
- }
- }
- }
- else {
- while (MARK <= SP) {
- if (!do_print(*MARK, fp))
- break;
- MARK++;
- }
- }
- if (MARK <= SP)
- goto just_say_no;
- else {
- if (PL_op->op_type == OP_SAY) {
- if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp))
- goto just_say_no;
- }
+ SV * const ofs = GvSV(PL_ofsgv); /* $, */
+ MARK++;
+ if (ofs && (SvGMAGICAL(ofs) || SvOK(ofs))) {
+ while (MARK <= PL_stack_sp) {
+ if (!do_print(*MARK, fp))
+ break;
+ MARK++;
+ if (MARK <= PL_stack_sp) {
+ /* don't use 'ofs' here - it may be invalidated by magic callbacks */
+ if (!do_print(GvSV(PL_ofsgv), fp)) {
+ MARK--;
+ break;
+ }
+ }
+ }
+ }
+ else {
+ while (MARK <= PL_stack_sp) {
+ if (!do_print(*MARK, fp))
+ break;
+ MARK++;
+ }
+ }
+ if (MARK <= PL_stack_sp)
+ goto just_say_no;
+ else {
+ if (PL_op->op_type == OP_SAY) {
+ if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp))
+ goto just_say_no;
+ }
else if (PL_ors_sv && SvOK(PL_ors_sv))
- if (!do_print(PL_ors_sv, fp)) /* $\ */
- goto just_say_no;
+ if (!do_print(PL_ors_sv, fp)) /* $\ */
+ goto just_say_no;
- if (IoFLAGS(io) & IOf_FLUSH)
- if (PerlIO_flush(fp) == EOF)
- goto just_say_no;
- }
+ if (IoFLAGS(io) & IOf_FLUSH)
+ if (PerlIO_flush(fp) == EOF)
+ goto just_say_no;
+ }
}
- SP = ORIGMARK;
- XPUSHs(&PL_sv_yes);
- RETURN;
+ retval = &PL_sv_yes;
just_say_no:
- SP = ORIGMARK;
- XPUSHs(&PL_sv_undef);
- RETURN;
+ rpp_popfree_to_NN(ORIGMARK);
+ if ((PL_op->op_flags & OPf_WANT) != OPf_WANT_VOID)
+ rpp_xpush_IMM(retval);
+ return NORMAL;
}
/* do the common parts of pp_padhv() and pp_rv2hv()
- * It assumes the caller has done EXTEND(SP, 1) or equivalent.
+ * It assumes the caller has done rpp_extend(1) or equivalent.
* 'is_keys' indicates the OPpPADHV_ISKEYS/OPpRV2HV_ISKEYS flag is set.
* 'has_targ' indicates that the op has a target - this should
* be a compile-time constant so that the code can constant-folded as
- * appropriate
+ * appropriate. has_targ also implies that the caller has left an
+ * arg on the stack which needs freeing.
* */
PERL_STATIC_INLINE OP*
S_padhv_rv2hv_common(pTHX_ HV *hv, U8 gimme, bool is_keys, bool has_targ)
{
- bool is_tied;
- bool is_bool;
- MAGIC *mg;
- dSP;
- IV i;
- SV *sv;
-
assert(PL_op->op_type == OP_PADHV || PL_op->op_type == OP_RV2HV);
- if (gimme == G_ARRAY) {
- hv_pushkv(hv, 3);
+ if (gimme == G_LIST) {
+ /* push all (key,value) pairs onto stack */
+ if (has_targ) { /* i.e. if has arg still on stack */
+#ifdef PERL_RC_STACK
+ SSize_t sp_base = PL_stack_sp - PL_stack_base;
+ hv_pushkv(hv, 3);
+ /* Now safe to free the original arg on the stack and shuffle
+ * down one place anything pushed on top of it */
+ SSize_t nitems = PL_stack_sp - (PL_stack_base + sp_base);
+ SV *old_sv = PL_stack_sp[-nitems];
+ if (nitems)
+ Move(PL_stack_sp - nitems + 1,
+ PL_stack_sp - nitems, nitems, SV*);
+ PL_stack_sp--;
+ SvREFCNT_dec_NN(old_sv);
+#else
+ rpp_popfree_1_NN();
+ hv_pushkv(hv, 3);
+#endif
+ }
+ else
+ hv_pushkv(hv, 3);
return NORMAL;
}
/* 'keys %h' masquerading as '%h': reset iterator */
(void)hv_iterinit(hv);
- if (gimme == G_VOID)
+ if (gimme == G_VOID) {
+ if (has_targ)
+ rpp_popfree_1_NN();
return NORMAL;
+ }
- is_bool = ( PL_op->op_private & OPpTRUEBOOL
- || ( PL_op->op_private & OPpMAYBE_TRUEBOOL
- && block_gimme() == G_VOID));
- is_tied = SvRMAGICAL(hv) && (mg = mg_find(MUTABLE_SV(hv), PERL_MAGIC_tied));
+ bool is_bool = ( PL_op->op_private & OPpTRUEBOOL
+ || ( PL_op->op_private & OPpMAYBE_TRUEBOOL
+ && block_gimme() == G_VOID));
- if (UNLIKELY(is_tied)) {
+ MAGIC *is_tied_mg = SvRMAGICAL(hv)
+ ? mg_find(MUTABLE_SV(hv), PERL_MAGIC_tied)
+ : NULL;
+
+ IV i = 0;
+ SV *sv = NULL;
+ if (UNLIKELY(is_tied_mg)) {
if (is_keys && !is_bool) {
i = 0;
while (hv_iternext(hv))
i++;
+ /* hv finished with. Safe to free arg now */
+ if (has_targ)
+ rpp_popfree_1_NN();
goto push_i;
}
else {
- sv = magic_scalarpack(hv, mg);
- goto push_sv;
+ sv = magic_scalarpack(hv, is_tied_mg);
+ /* hv finished with. Safe to free arg now */
+ if (has_targ)
+ rpp_popfree_1_NN();
+ rpp_push_1(sv);
}
}
else {
+#if defined(DYNAMIC_ENV_FETCH) && defined(VMS)
+ /* maybe nothing set up %ENV for iteration yet...
+ do this always (not just if HvUSEDKEYS(hv) is currently 0) because
+ we ought to give a *consistent* answer to "how many keys?"
+ whether we ask this op in scalar context, or get the list of all
+ keys then check its length, and whether we do either with or without
+ an %ENV lookup first. prime_env_iter() returns quickly if nothing
+ needs doing. */
+ if (SvRMAGICAL((const SV *)hv)
+ && mg_find((const SV *)hv, PERL_MAGIC_env)) {
+ prime_env_iter();
+ }
+#endif
i = HvUSEDKEYS(hv);
+
+ /* hv finished with. Safe to free arg now */
+ if (has_targ)
+ rpp_popfree_1_NN();
+
if (is_bool) {
- sv = i ? &PL_sv_yes : &PL_sv_zero;
- push_sv:
- PUSHs(sv);
+ rpp_push_IMM(i ? &PL_sv_yes : &PL_sv_zero);
}
else {
push_i:
if (has_targ) {
dTARGET;
- PUSHi(i);
+ TARGi(i,1);
+ rpp_push_1(targ);
}
else
-#ifdef PERL_OP_PARENT
if (is_keys) {
/* parent op should be an unused OP_KEYS whose targ we can
* use */
k = PL_op->op_sibparent;
assert(k->op_type == OP_KEYS);
TARG = PAD_SV(k->op_targ);
- PUSHi(i);
+ TARGi(i,1);
+ rpp_push_1(targ);
}
else
-#endif
- mPUSHi(i);
+ rpp_push_1_norc(newSViv(i));
}
}
- PUTBACK;
return NORMAL;
}
/* This is also called directly by pp_lvavref. */
PP(pp_padav)
{
- dSP; dTARGET;
+ dTARGET;
U8 gimme;
+
assert(SvTYPE(TARG) == SVt_PVAV);
if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO ))
- if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) ))
- SAVECLEARSV(PAD_SVl(PL_op->op_targ));
- EXTEND(SP, 1);
+ if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) ))
+ SAVECLEARSV(PAD_SVl(PL_op->op_targ));
- if (PL_op->op_flags & OPf_REF) {
- PUSHs(TARG);
- RETURN;
- }
- else if (PL_op->op_private & OPpMAYBE_LVSUB) {
+
+ if (PL_op->op_flags & OPf_REF)
+ goto ret;
+
+ if (PL_op->op_private & OPpMAYBE_LVSUB) {
const I32 flags = is_lvalue_sub();
if (flags && !(flags & OPpENTERSUB_INARGS)) {
- if (GIMME_V == G_SCALAR)
+ if (GIMME_V == G_SCALAR)
/* diag_listed_as: Can't return %s to lvalue scalar context */
Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
- PUSHs(TARG);
- RETURN;
+ goto ret;
}
}
gimme = GIMME_V;
- if (gimme == G_ARRAY)
+ if (gimme == G_LIST)
return S_pushav(aTHX_ (AV*)TARG);
- if (gimme == G_SCALAR) {
- const SSize_t maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
+ if (gimme == G_VOID)
+ return NORMAL;
+
+ {
+ const SSize_t maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
+ rpp_extend(1);
if (!maxarg)
- PUSHs(&PL_sv_zero);
+ targ = &PL_sv_zero;
else if (PL_op->op_private & OPpTRUEBOOL)
- PUSHs(&PL_sv_yes);
- else
- mPUSHi(maxarg);
+ targ = &PL_sv_yes;
+ else {
+ rpp_push_1_norc(newSViv(maxarg));
+ return NORMAL;
+ }
+ rpp_push_IMM(targ);
+ return NORMAL;
}
- RETURN;
+
+ ret:
+ rpp_xpush_1(targ);
+ return NORMAL;
}
PP(pp_padhv)
{
- dSP; dTARGET;
+ dTARGET;
U8 gimme;
assert(SvTYPE(TARG) == SVt_PVHV);
if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO ))
- if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) ))
- SAVECLEARSV(PAD_SVl(PL_op->op_targ));
+ if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) ))
+ SAVECLEARSV(PAD_SVl(PL_op->op_targ));
- EXTEND(SP, 1);
+ rpp_extend(1);
if (PL_op->op_flags & OPf_REF) {
- PUSHs(TARG);
- RETURN;
+ rpp_push_1(TARG);
+ return NORMAL;
}
else if (PL_op->op_private & OPpMAYBE_LVSUB) {
const I32 flags = is_lvalue_sub();
if (GIMME_V == G_SCALAR)
/* diag_listed_as: Can't return %s to lvalue scalar context */
Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
- PUSHs(TARG);
- RETURN;
+ rpp_push_1(TARG);
+ return NORMAL;
}
}
PP(pp_rv2av)
{
- dSP; dTOPss;
+ SV *sv = *PL_stack_sp;
const U8 gimme = GIMME_V;
static const char an_array[] = "an ARRAY";
static const char a_hash[] = "a HASH";
const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV
- || PL_op->op_type == OP_LVAVREF;
+ || PL_op->op_type == OP_LVAVREF;
const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
SvGETMAGIC(sv);
if (SvROK(sv)) {
- if (UNLIKELY(SvAMAGIC(sv))) {
- sv = amagic_deref_call(sv, is_pp_rv2av ? to_av_amg : to_hv_amg);
- }
- sv = SvRV(sv);
- if (UNLIKELY(SvTYPE(sv) != type))
- /* diag_listed_as: Not an ARRAY reference */
- DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
- else if (UNLIKELY(PL_op->op_flags & OPf_MOD
- && PL_op->op_private & OPpLVAL_INTRO))
- Perl_croak(aTHX_ "%s", PL_no_localize_ref);
+ if (UNLIKELY(SvAMAGIC(sv))) {
+ sv = amagic_deref_call(sv, is_pp_rv2av ? to_av_amg : to_hv_amg);
+ }
+ sv = SvRV(sv);
+ if (UNLIKELY(SvTYPE(sv) != type))
+ /* diag_listed_as: Not an ARRAY reference */
+ DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
+ else if (UNLIKELY(PL_op->op_flags & OPf_MOD
+ && PL_op->op_private & OPpLVAL_INTRO))
+ Perl_croak(aTHX_ "%s", PL_no_localize_ref);
}
else if (UNLIKELY(SvTYPE(sv) != type)) {
- GV *gv;
-
- if (!isGV_with_GP(sv)) {
- gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
- type, &sp);
- if (!gv)
- RETURN;
- }
- else {
- gv = MUTABLE_GV(sv);
- }
- sv = is_pp_rv2av ? MUTABLE_SV(GvAVn(gv)) : MUTABLE_SV(GvHVn(gv));
- if (PL_op->op_private & OPpLVAL_INTRO)
- sv = is_pp_rv2av ? MUTABLE_SV(save_ary(gv)) : MUTABLE_SV(save_hash(gv));
+ GV *gv;
+
+ if (!isGV_with_GP(sv)) {
+ gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
+ type);
+ if (!gv)
+ return NORMAL;
+ }
+ else {
+ gv = MUTABLE_GV(sv);
+ }
+ sv = is_pp_rv2av ? MUTABLE_SV(GvAVn(gv)) : MUTABLE_SV(GvHVn(gv));
+ if (PL_op->op_private & OPpLVAL_INTRO)
+ sv = is_pp_rv2av ? MUTABLE_SV(save_ary(gv)) : MUTABLE_SV(save_hash(gv));
}
if (PL_op->op_flags & OPf_REF) {
- SETs(sv);
- RETURN;
+ rpp_replace_1_1_NN(sv);
+ return NORMAL;
}
else if (UNLIKELY(PL_op->op_private & OPpMAYBE_LVSUB)) {
- const I32 flags = is_lvalue_sub();
- if (flags && !(flags & OPpENTERSUB_INARGS)) {
- if (gimme != G_ARRAY)
- goto croak_cant_return;
- SETs(sv);
- RETURN;
- }
+ const I32 flags = is_lvalue_sub();
+ if (flags && !(flags & OPpENTERSUB_INARGS)) {
+ if (gimme != G_LIST)
+ goto croak_cant_return;
+ rpp_replace_1_1_NN(sv);
+ return NORMAL;
+ }
}
if (is_pp_rv2av) {
- AV *const av = MUTABLE_AV(sv);
-
- if (gimme == G_ARRAY) {
- SP--;
- PUTBACK;
+ AV *const av = MUTABLE_AV(sv);
+
+ if (gimme == G_LIST) {
+#ifdef PERL_RC_STACK
+ SSize_t sp_base = PL_stack_sp - PL_stack_base;
+ (void)S_pushav(aTHX_ av);
+ /* Now safe to free the original arg on the stack and shuffle
+ * down one place anything pushed on top of it */
+ SSize_t nitems = PL_stack_sp - (PL_stack_base + sp_base);
+ SV *old_sv = PL_stack_sp[-nitems];
+ if (nitems)
+ Move(PL_stack_sp - nitems + 1,
+ PL_stack_sp - nitems, nitems, SV*);
+ PL_stack_sp--;
+ SvREFCNT_dec_NN(old_sv);
+ return NORMAL;
+#else
+ rpp_popfree_1_NN();
return S_pushav(aTHX_ av);
- }
+#endif
+ }
- if (gimme == G_SCALAR) {
- const SSize_t maxarg = AvFILL(av) + 1;
+ if (gimme == G_SCALAR) {
+ const SSize_t maxarg = AvFILL(av) + 1;
if (PL_op->op_private & OPpTRUEBOOL)
- SETs(maxarg ? &PL_sv_yes : &PL_sv_zero);
+ rpp_replace_1_IMM_NN(maxarg ? &PL_sv_yes : &PL_sv_zero);
else {
dTARGET;
- SETi(maxarg);
+ TARGi(maxarg, 1);
+ rpp_replace_1_1_NN(targ);
}
- }
+ }
}
else {
- SP--; PUTBACK;
+ /* this static function is responsible for popping sv off stack */
return S_padhv_rv2hv_common(aTHX_ (HV*)sv, gimme,
cBOOL(PL_op->op_private & OPpRV2HV_ISKEYS),
1 /* has_targ*/);
}
- RETURN;
+ return NORMAL;
croak_cant_return:
Perl_croak(aTHX_ "Can't return %s to lvalue scalar context",
- is_pp_rv2av ? "array" : "hash");
- RETURN;
+ is_pp_rv2av ? "array" : "hash");
}
+
STATIC void
S_do_oddball(pTHX_ SV **oddkey, SV **firstkey)
{
if (*oddkey) {
if (ckWARN(WARN_MISC)) {
- const char *err;
- if (oddkey == firstkey &&
- SvROK(*oddkey) &&
- (SvTYPE(SvRV(*oddkey)) == SVt_PVAV ||
- SvTYPE(SvRV(*oddkey)) == SVt_PVHV))
- {
- err = "Reference found where even-sized list expected";
- }
- else
- err = "Odd number of elements in hash assignment";
- Perl_warner(aTHX_ packWARN(WARN_MISC), "%s", err);
- }
+ const char *err;
+ if (oddkey == firstkey &&
+ SvROK(*oddkey) &&
+ (SvTYPE(SvRV(*oddkey)) == SVt_PVAV ||
+ SvTYPE(SvRV(*oddkey)) == SVt_PVHV))
+ {
+ err = "Reference found where even-sized list expected";
+ }
+ else
+ err = "Odd number of elements in hash assignment";
+ Perl_warner(aTHX_ packWARN(WARN_MISC), "%s", err);
+ }
}
}
* For example in ($a,$b) = ($b,$a), assigning the value of the first RHS
* element ($b) to the first LH element ($a), modifies $a; when the
* second assignment is done, the second RH element now has the wrong
- * value. So we initially replace the RHS with ($b, mortalcopy($a)).
- * Note that we don't need to make a mortal copy of $b.
+ * value. So we initially replace the RHS with ($b, copy($a)).
+ * Note that we don't need to make a copy of $b.
*
* The algorithm below works by, for every RHS element, mark the
* corresponding LHS target element with SVf_BREAK. Then if the RHS
#endif
)
{
- dVAR;
SV **relem;
SV **lelem;
SSize_t lcount = lastlelem - firstlelem + 1;
lcount = -1;
lelem--; /* no need to unmark this element */
}
- else if (!(do_rc1 && SvREFCNT(svl) == 1) && !SvIMMORTAL(svl)) {
+ else if (!(do_rc1 &&
+#ifdef PERL_RC_STACK
+ SvREFCNT(svl) <= 2
+#else
+ SvREFCNT(svl) == 1
+#endif
+ ) && !SvIMMORTAL(svl))
+ {
SvFLAGS(svl) |= SVf_BREAK;
marked = TRUE;
}
TAINT_NOT; /* Each item is independent */
+#ifndef PERL_RC_STACK
+ /* The TODO test was eventually commented out. It's now been
+ * revived, but only on PERL_RC_STACK builds. Continue
+ * this hacky workaround otherwise - DAPM Sept 2023 */
+
/* Dear TODO test in t/op/sort.t, I love you.
(It's relying on a panic, not a "semi-panic" from newSVsv()
and then an assertion failure below.) */
Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p",
(void*)svr);
}
+#endif
+
/* avoid break flag while copying; otherwise COW etc
* disabled... */
SvFLAGS(svr) &= ~SVf_BREAK;
count bump. (Although I suspect that the SV won't be
stealable here anyway - DAPM).
*/
+#ifdef PERL_RC_STACK
+ *relem = newSVsv_flags(svr,
+ SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
+ SvREFCNT_dec_NN(svr);
+#else
*relem = sv_mortalcopy_flags(svr,
SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
+#endif
/* ... but restore afterwards in case it's needed again,
* e.g. ($a,$b,$c) = (1,$a,$a)
*/
}
+/* Helper function for pp_aassign(): after performing something like
+ *
+ * ($<,$>) = ($>,$<); # swap real and effective uids
+ *
+ * the assignment to the magic variables just sets various flags in
+ * PL_delaymagic; now we tell the OS to update the uids/gids atomically.
+ */
+
+STATIC void
+S_aassign_uid(pTHX)
+{
+ /* Will be used to set PL_tainting below */
+ Uid_t tmp_uid = PerlProc_getuid();
+ Uid_t tmp_euid = PerlProc_geteuid();
+ Gid_t tmp_gid = PerlProc_getgid();
+ Gid_t tmp_egid = PerlProc_getegid();
+
+ /* XXX $> et al currently silently ignore failures */
+ if (PL_delaymagic & DM_UID) {
+#ifdef HAS_SETRESUID
+ PERL_UNUSED_RESULT(
+ setresuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
+ (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1,
+ (Uid_t)-1));
+#elif defined(HAS_SETREUID)
+ PERL_UNUSED_RESULT(
+ setreuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
+ (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1));
+#else
+# ifdef HAS_SETRUID
+ if ((PL_delaymagic & DM_UID) == DM_RUID) {
+ PERL_UNUSED_RESULT(setruid(PL_delaymagic_uid));
+ PL_delaymagic &= ~DM_RUID;
+ }
+# endif /* HAS_SETRUID */
+# ifdef HAS_SETEUID
+ if ((PL_delaymagic & DM_UID) == DM_EUID) {
+ PERL_UNUSED_RESULT(seteuid(PL_delaymagic_euid));
+ PL_delaymagic &= ~DM_EUID;
+ }
+# endif /* HAS_SETEUID */
+ if (PL_delaymagic & DM_UID) {
+ if (PL_delaymagic_uid != PL_delaymagic_euid)
+ Perl_die(aTHX_ "No setreuid available");
+ PERL_UNUSED_RESULT(PerlProc_setuid(PL_delaymagic_uid));
+ }
+#endif /* HAS_SETRESUID */
+
+ tmp_uid = PerlProc_getuid();
+ tmp_euid = PerlProc_geteuid();
+ }
+
+ /* XXX $> et al currently silently ignore failures */
+ if (PL_delaymagic & DM_GID) {
+#ifdef HAS_SETRESGID
+ PERL_UNUSED_RESULT(
+ setresgid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
+ (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1,
+ (Gid_t)-1));
+#elif defined(HAS_SETREGID)
+ PERL_UNUSED_RESULT(
+ setregid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
+ (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1));
+#else
+# ifdef HAS_SETRGID
+ if ((PL_delaymagic & DM_GID) == DM_RGID) {
+ PERL_UNUSED_RESULT(setrgid(PL_delaymagic_gid));
+ PL_delaymagic &= ~DM_RGID;
+ }
+# endif /* HAS_SETRGID */
+# ifdef HAS_SETEGID
+ if ((PL_delaymagic & DM_GID) == DM_EGID) {
+ PERL_UNUSED_RESULT(setegid(PL_delaymagic_egid));
+ PL_delaymagic &= ~DM_EGID;
+ }
+# endif /* HAS_SETEGID */
+ if (PL_delaymagic & DM_GID) {
+ if (PL_delaymagic_gid != PL_delaymagic_egid)
+ Perl_die(aTHX_ "No setregid available");
+ PERL_UNUSED_RESULT(PerlProc_setgid(PL_delaymagic_gid));
+ }
+#endif /* HAS_SETRESGID */
+
+ tmp_gid = PerlProc_getgid();
+ tmp_egid = PerlProc_getegid();
+ }
+ TAINTING_set( TAINTING_get | (tmp_uid && (tmp_euid != tmp_uid || tmp_egid != tmp_gid)) );
+#ifdef NO_TAINT_SUPPORT
+ PERL_UNUSED_VAR(tmp_uid);
+ PERL_UNUSED_VAR(tmp_euid);
+ PERL_UNUSED_VAR(tmp_gid);
+ PERL_UNUSED_VAR(tmp_egid);
+#endif
+}
+
PP(pp_aassign)
{
- dVAR; dSP;
SV **lastlelem = PL_stack_sp;
SV **lastrelem = PL_stack_base + POPMARK;
SV **firstrelem = PL_stack_base + POPMARK + 1;
SV **relem;
SV **lelem;
U8 gimme;
- /* PL_delaymagic is restored by JUMPENV_POP on dieing, so we
+ /* PL_delaymagic is restored by JMPENV_POP on dieing, so we
* only need to save locally, not on the save stack */
U16 old_delaymagic = PL_delaymagic;
#ifdef DEBUGGING
/* skip the scan if all scalars have a ref count of 1 */
for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
SV *sv = *lelem;
- if (!sv || SvREFCNT(sv) == 1)
+ if (!sv ||
+#ifdef PERL_RC_STACK
+ SvREFCNT(sv) <= 2
+#else
+ SvREFCNT(sv) == 1
+#endif
+ )
continue;
if (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVAV)
goto do_scan;
#endif
gimme = GIMME_V;
+ bool is_list = (gimme == G_LIST);
relem = firstrelem;
lelem = firstlelem;
+#ifdef PERL_RC_STACK
+ /* Where we can reset stack to at the end, without needing to free
+ * each element. This is normally all the lelem's, but it can vary for
+ * things like odd number of hash elements, which pushes a
+ * &PL_sv_undef into the 'lvalue' part of the stack.
+ */
+ SV ** first_discard = firstlelem;
+#endif
if (relem > lastrelem)
goto no_relems;
/* first lelem loop while there are still relems */
while (LIKELY(lelem <= lastlelem)) {
- bool alias = FALSE;
- SV *lsv = *lelem++;
+ bool alias = FALSE;
+ SV *lsv = *lelem;
TAINT_NOT; /* Each item stands on its own, taintwise. */
assert(relem <= lastrelem);
- if (UNLIKELY(!lsv)) {
- alias = TRUE;
- lsv = *lelem++;
- ASSUME(SvTYPE(lsv) == SVt_PVAV);
- }
-
- switch (SvTYPE(lsv)) {
- case SVt_PVAV: {
+ if (UNLIKELY(!lsv)) {
+ alias = TRUE;
+ lsv = *++lelem;
+ ASSUME(SvTYPE(lsv) == SVt_PVAV);
+ }
+
+ switch (SvTYPE(lsv)) {
+ case SVt_PVAV: {
SV **svp;
SSize_t i;
- SSize_t tmps_base;
SSize_t nelems = lastrelem - relem + 1;
AV *ary = MUTABLE_AV(lsv);
* @a = ($a[0]) case, but the current implementation uses the
* same algorithm regardless, so ignores that flag. (It *is*
* used in the hash branch below, however).
- */
+ *
+ *
+ * The net effect of this next block of code (apart from
+ * optimisations and aliasing) is to make a copy of each
+ * *relem and store the new SV both in the array and back on
+ * the *relem slot of the stack, overwriting the original.
+ * This new list of SVs will later be either returned
+ * (G_LIST), or popped.
+ *
+ * Note that under PERL_RC_STACK builds most of this
+ * complexity can be thrown away: things can be kept alive on
+ * the argument stack without involving the temps stack. In
+ * particular, the args are kept on the argument stack and
+ * processed from there, rather than their pointers being
+ * copied to the temps stack and then processed from there.
+ */
+#ifndef PERL_RC_STACK
/* Reserve slots for ary, plus the elems we're about to copy,
* then protect ary and temporarily void the remaining slots
* with &PL_sv_undef */
EXTEND_MORTAL(nelems + 1);
PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(ary);
- tmps_base = PL_tmps_ix + 1;
+ SSize_t tmps_base = PL_tmps_ix + 1;
for (i = 0; i < nelems; i++)
PL_tmps_stack[tmps_base + i] = &PL_sv_undef;
PL_tmps_ix += nelems;
+#endif
/* Make a copy of each RHS elem and save on the tmps_stack
* (or pass through where we can optimise away the copy) */
if (UNLIKELY(alias)) {
- U32 lval = (gimme == G_ARRAY)
+ U32 lval = (is_list)
? (PL_op->op_flags & OPf_MOD || LVRET) : 0;
for (svp = relem; svp <= lastrelem; svp++) {
SV *rsv = *svp;
/* diag_listed_as: Assigned value is not %s reference */
DIE(aTHX_
"Assigned value is not a SCALAR reference");
- if (lval)
- *svp = rsv = sv_mortalcopy(rsv);
+ if (lval) {
+ /* XXX the 'mortal' part here is probably
+ * unnecessary under PERL_RC_STACK.
+ */
+ rsv = sv_mortalcopy(rsv);
+ rpp_replace_at_NN(svp, rsv);
+ }
/* XXX else check for weak refs? */
+#ifndef PERL_RC_STACK
rsv = SvREFCNT_inc_NN(SvRV(rsv));
assert(tmps_base <= PL_tmps_max);
PL_tmps_stack[tmps_base++] = rsv;
+#endif
}
}
else {
for (svp = relem; svp <= lastrelem; svp++) {
SV *rsv = *svp;
- if (SvTEMP(rsv) && !SvGMAGICAL(rsv) && SvREFCNT(rsv) == 1) {
+ if (rpp_is_lone(rsv) && !SvGMAGICAL(rsv)) {
/* can skip the copy */
+#ifndef PERL_RC_STACK
SvREFCNT_inc_simple_void_NN(rsv);
+#endif
SvTEMP_off(rsv);
}
else {
SV *nsv;
- /* do get before newSV, in case it dies and leaks */
- SvGETMAGIC(rsv);
- nsv = newSV(0);
/* see comment in S_aassign_copy_common about
* SV_NOSTEAL */
- sv_setsv_flags(nsv, rsv,
- (SV_DO_COW_SVSETSV|SV_NOSTEAL));
- rsv = *svp = nsv;
+ nsv = newSVsv_flags(rsv,
+ (SV_DO_COW_SVSETSV|SV_NOSTEAL|SV_GMAGIC));
+#ifdef PERL_RC_STACK
+ rpp_replace_at_norc_NN(svp, nsv);
+#else
+ /* using rpp_replace_at_norc() would mortalise,
+ * but we're manually adding nsv to the tmps stack
+ * below already */
+ rpp_replace_at_NN(svp, nsv);
+#endif
+
+ rsv = nsv;
}
+#ifndef PERL_RC_STACK
assert(tmps_base <= PL_tmps_max);
PL_tmps_stack[tmps_base++] = rsv;
+#endif
}
}
if (SvRMAGICAL(ary) || AvFILLp(ary) >= 0) /* may be non-empty */
av_clear(ary);
- /* store in the array, the SVs that are in the tmps stack */
+ /* Store in the array, the argument copies that are in the
+ * tmps stack (or for PERL_RC_STACK, on the args stack) */
+#ifndef PERL_RC_STACK
tmps_base -= nelems;
-
- if (SvMAGICAL(ary) || SvREADONLY(ary) || !AvREAL(ary)) {
+#endif
+ if (alias || SvMAGICAL(ary) || SvREADONLY(ary) || !AvREAL(ary)) {
/* for arrays we can't cheat with, use the official API */
av_extend(ary, nelems - 1);
for (i = 0; i < nelems; i++) {
- SV **svp = &(PL_tmps_stack[tmps_base + i]);
+ SV **svp =
+#ifdef PERL_RC_STACK
+ &relem[i];
+#else
+ &(PL_tmps_stack[tmps_base + i]);
+#endif
+
SV *rsv = *svp;
+#ifdef PERL_RC_STACK
+ if (alias) {
+ assert(SvROK(rsv));
+ rsv = SvRV(rsv);
+ }
+#endif
+
/* A tied store won't take ownership of rsv, so keep
* the 1 refcnt on the tmps stack; otherwise disarm
* the tmps stack entry */
if (av_store(ary, i, rsv))
+#ifdef PERL_RC_STACK
+ SvREFCNT_inc_simple_NN(rsv);
+#else
*svp = &PL_sv_undef;
+#endif
/* av_store() may have added set magic to rsv */;
SvSETMAGIC(rsv);
}
+#ifndef PERL_RC_STACK
/* disarm ary refcount: see comments below about leak */
PL_tmps_stack[tmps_base - 1] = &PL_sv_undef;
+#endif
}
else {
- /* directly access/set the guts of the AV */
+ /* Simple array: directly access/set the guts of the AV */
SSize_t fill = nelems - 1;
if (fill > AvMAX(ary))
av_extend_guts(ary, fill, &AvMAX(ary), &AvALLOC(ary),
&AvARRAY(ary));
AvFILLp(ary) = fill;
+#ifdef PERL_RC_STACK
+ Copy(relem, AvARRAY(ary), nelems, SV*);
+ /* ownership of one ref count of each elem passed to
+ * array. Quietly remove old SVs from stack, or if need
+ * to keep the list on the stack too, bump the count */
+ if (UNLIKELY(is_list))
+ for (i = 0; i < nelems; i++)
+ SvREFCNT_inc_void_NN(relem[i]);
+ else {
+ assert(first_discard == relem + nelems);
+ Zero(relem, nelems, SV*);
+ first_discard = relem;
+ }
+#else
Copy(&(PL_tmps_stack[tmps_base]), AvARRAY(ary), nelems, SV*);
/* Quietly remove all the SVs from the tmps stack slots,
* since ary has now taken ownership of the refcnt.
PL_tmps_ix - (tmps_base + nelems) + 1,
SV*);
PL_tmps_ix -= (nelems + 1);
+#endif
}
- if (UNLIKELY(PL_delaymagic & DM_ARRAY_ISA))
+ if (UNLIKELY(PL_delaymagic & DM_ARRAY_ISA))
/* its assumed @ISA set magic can't die and leak ary */
- SvSETMAGIC(MUTABLE_SV(ary));
- SvREFCNT_dec_NN(ary);
+ SvSETMAGIC(MUTABLE_SV(ary));
+#ifdef PERL_RC_STACK
+ assert(*lelem == (SV*)ary);
+ *lelem = NULL;
+#endif
+ lelem++;
+ SvREFCNT_dec_NN(ary);
relem = lastrelem + 1;
- goto no_relems;
+ goto no_relems;
}
- case SVt_PVHV: { /* normal hash */
+ case SVt_PVHV: { /* normal hash */
SV **svp;
- bool dirty_tmps;
SSize_t i;
- SSize_t tmps_base;
SSize_t nelems = lastrelem - relem + 1;
HV *hash = MUTABLE_HV(lsv);
if (UNLIKELY(nelems & 1)) {
do_oddball(lastrelem, relem);
/* we have firstlelem to reuse, it's not needed any more */
+#ifdef PERL_RC_STACK
+ if (lelem == lastrelem + 1) {
+ /* the lelem slot we want to use is the
+ * one keeping hash alive. Mortalise the hash
+ * so it doesn't leak */
+ assert(lastrelem[1] == (SV*)hash);
+ sv_2mortal((SV*)hash);
+ }
+ else {
+ /* safe to repurpose old lelem slot */
+ assert(!lastrelem[1] || SvIMMORTAL(lastrelem[1]));
+ }
+ first_discard++;
+ assert(first_discard = lastrelem + 2);
+#endif
*++lastrelem = &PL_sv_undef;
nelems++;
}
* copied (except for the SvTEMP optimisation), since they
* need to be stored in the hash; while keys are only
* processed where they might get prematurely freed or
- * whatever. */
+ * whatever. The same comments about simplifying under
+ * PERL_RC_STACK apply here too */
/* tmps stack slots:
* * reserve a slot for the hash keepalive;
* later;
* then protect hash and temporarily void the remaining
* value slots with &PL_sv_undef */
+#ifndef PERL_RC_STACK
EXTEND_MORTAL(nelems + 1);
-
+#endif
/* convert to number of key/value pairs */
nelems >>= 1;
+#ifndef PERL_RC_STACK
PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(hash);
- tmps_base = PL_tmps_ix + 1;
+ SSize_t tmps_base = PL_tmps_ix + 1;
for (i = 0; i < nelems; i++)
PL_tmps_stack[tmps_base + i] = &PL_sv_undef;
PL_tmps_ix += nelems;
+#endif
/* Make a copy of each RHS hash value and save on the tmps_stack
* (or pass through where we can optimise away the copy) */
for (svp = relem + 1; svp <= lastrelem; svp += 2) {
SV *rsv = *svp;
- if (SvTEMP(rsv) && !SvGMAGICAL(rsv) && SvREFCNT(rsv) == 1) {
+ if (rpp_is_lone(rsv) && !SvGMAGICAL(rsv)) {
/* can skip the copy */
+#ifndef PERL_RC_STACK
SvREFCNT_inc_simple_void_NN(rsv);
+#endif
SvTEMP_off(rsv);
}
else {
SV *nsv;
- /* do get before newSV, in case it dies and leaks */
- SvGETMAGIC(rsv);
- nsv = newSV(0);
/* see comment in S_aassign_copy_common about
* SV_NOSTEAL */
- sv_setsv_flags(nsv, rsv,
- (SV_DO_COW_SVSETSV|SV_NOSTEAL));
- rsv = *svp = nsv;
+ nsv = newSVsv_flags(rsv,
+ (SV_DO_COW_SVSETSV|SV_NOSTEAL|SV_GMAGIC));
+#ifdef PERL_RC_STACK
+ rpp_replace_at_norc_NN(svp, nsv);
+#else
+ /* using rpp_replace_at_norc() would mortalise,
+ * but we're manually adding nsv to the tmps stack
+ * below already */
+ rpp_replace_at_NN(svp, nsv);
+#endif
+ rsv = nsv;
}
+#ifndef PERL_RC_STACK
assert(tmps_base <= PL_tmps_max);
PL_tmps_stack[tmps_base++] = rsv;
+#endif
}
+
+#ifndef PERL_RC_STACK
tmps_base -= nelems;
+#endif
/* possibly protect keys */
- if (UNLIKELY(gimme == G_ARRAY)) {
+ if (UNLIKELY(is_list)) {
/* handle e.g.
* @a = ((%h = ($$r, 1)), $r = "x");
* $_++ for %h = (1,2,3,4);
*/
+#ifndef PERL_RC_STACK
EXTEND_MORTAL(nelems);
- for (svp = relem; svp <= lastrelem; svp += 2)
- *svp = sv_mortalcopy_flags(*svp,
- SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
+#endif
+ for (svp = relem; svp <= lastrelem; svp += 2) {
+ rpp_replace_at_norc_NN(svp,
+ newSVsv_flags(*svp,
+ SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL));
+ }
}
else if (PL_op->op_private & OPpASSIGN_COMMON_AGG) {
/* for possible commonality, e.g.
* cases, not just under OPpASSIGN_COMMON_AGG, but in
* practice, !OPpASSIGN_COMMON_AGG implies only
* constants or padtmps on the RHS.
+ *
+ * For PERL_RC_STACK, no danger of premature frees, so
+ * just handle the magic.
*/
+#ifdef PERL_RC_STACK
+ for (svp = relem; svp <= lastrelem; svp += 2) {
+ SV *rsv = *svp;
+ if (UNLIKELY(SvGMAGICAL(rsv)))
+ /* XXX does this actually need to be copied, or
+ * could we just call the get magic??? */
+ rpp_replace_at_norc_NN(svp,
+ newSVsv_flags(rsv,
+ SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL));
+ }
+#else
EXTEND_MORTAL(nelems);
for (svp = relem; svp <= lastrelem; svp += 2) {
SV *rsv = *svp;
if (UNLIKELY(SvGMAGICAL(rsv))) {
SSize_t n;
- *svp = sv_mortalcopy_flags(*svp,
- SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
+ rpp_replace_at_norc_NN(svp,
+ newSVsv_flags(rsv,
+ SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL));
/* allow other branch to continue pushing
* onto tmps stack without checking each time */
n = (lastrelem - relem) >> 1;
PL_tmps_stack[++PL_tmps_ix] =
SvREFCNT_inc_simple_NN(rsv);
}
+#endif
}
if (SvRMAGICAL(hash) || HvUSEDKEYS(hash))
hv_clear(hash);
- /* now assign the keys and values to the hash */
+ /* "nelems" was converted to the number of pairs earlier. */
+ if (nelems > PERL_HASH_DEFAULT_HvMAX) {
+ hv_ksplit(hash, nelems);
+ }
- dirty_tmps = FALSE;
+ /* now assign the keys and values to the hash */
- if (UNLIKELY(gimme == G_ARRAY)) {
+#ifndef PERL_RC_STACK
+ bool dirty_tmps = FALSE;
+#endif
+ if (UNLIKELY(is_list)) {
/* @a = (%h = (...)) etc */
SV **svp;
SV **topelem = relem;
* stack location if we encountered dups earlier,
* The values will be updated later
*/
- *topelem = key;
+ rpp_replace_at_NN(topelem, key);
topelem += 2;
}
/* A tied store won't take ownership of val, so keep
* the 1 refcnt on the tmps stack; otherwise disarm
* the tmps stack entry */
if (hv_store_ent(hash, key, val, 0))
+#ifdef PERL_RC_STACK
+ SvREFCNT_inc_simple_NN(val);
+#else
PL_tmps_stack[tmps_base + i] = &PL_sv_undef;
else
dirty_tmps = TRUE;
+#endif
/* hv_store_ent() may have added set magic to val */;
SvSETMAGIC(val);
}
+
if (topelem < svp) {
/* at this point we have removed the duplicate key/value
* pairs from the stack, but the remaining values may be
while (relem < lastrelem) {
HE *he;
he = hv_fetch_ent(hash, *relem++, 0, 0);
- *relem++ = (he ? HeVAL(he) : &PL_sv_undef);
+ rpp_replace_at_NN(relem++,
+ (he ? HeVAL(he) : &PL_sv_undef));
}
}
}
for (i = 0, svp = relem; svp <= lastrelem; i++, svp++) {
SV *key = *svp++;
SV *val = *svp;
+#ifdef PERL_RC_STACK
+ {
+ HE *stored = hv_store_ent(hash, key, val, 0);
+ /* hv_store_ent() may have added set magic to val */;
+ SvSETMAGIC(val);
+ /* remove key and val from stack */
+ *svp = NULL;
+ if (!stored)
+ SvREFCNT_dec_NN(val);
+ svp[-1] = NULL;
+ SvREFCNT_dec_NN(key);
+ }
+#else
if (hv_store_ent(hash, key, val, 0))
PL_tmps_stack[tmps_base + i] = &PL_sv_undef;
else
dirty_tmps = TRUE;
/* hv_store_ent() may have added set magic to val */;
SvSETMAGIC(val);
+#endif
}
+#ifdef PERL_RC_STACK
+ /* now that all the key and val slots on the stack have
+ * been discarded, we can skip freeing them on return */
+ assert(first_discard == lastrelem + 1);
+ first_discard = relem;
+#endif
}
+#ifdef PERL_RC_STACK
+ /* Disarm the ref-counted pointer on the stack. This will
+ * usually point to the hash, except for the case of an odd
+ * number of elems where the hash was mortalised and its slot
+ * on the stack was made part of the relems with the slot's
+ * value overwritten with &PL_sv_undef. */
+ if (*lelem == (SV*)hash) {
+ *lelem = NULL;
+ SvREFCNT_dec_NN(hash);
+ }
+#else
if (dirty_tmps) {
/* there are still some 'live' recounts on the tmps stack
* - usually caused by storing into a tied hash. So let
}
SvREFCNT_dec_NN(hash);
-
+#endif
+ lelem++;
relem = lastrelem + 1;
- goto no_relems;
- }
-
- default:
- if (!SvIMMORTAL(lsv)) {
- SV *ref;
+ goto no_relems;
+ }
+ default:
+ if (!SvIMMORTAL(lsv)) {
if (UNLIKELY(
- SvTEMP(lsv) && !SvSMAGICAL(lsv) && SvREFCNT(lsv) == 1 &&
+ rpp_is_lone(lsv) && !SvSMAGICAL(lsv) &&
(!isGV_with_GP(lsv) || SvFAKE(lsv)) && ckWARN(WARN_MISC)
))
Perl_warner(aTHX_
"Useless assignment to a temporary"
);
+#ifndef PERL_RC_STACK
/* avoid freeing $$lsv if it might be needed for further
* elements, e.g. ($ref, $foo) = (1, $$ref) */
+ SV *ref;
if ( SvROK(lsv)
&& ( ((ref = SvRV(lsv)), SvREFCNT(ref)) == 1)
- && lelem <= lastlelem
+ && lelem < lastlelem
) {
SSize_t ix;
SvREFCNT_inc_simple_void_NN(ref);
if (UNLIKELY(ix >= PL_tmps_max))
/* speculatively grow enough to cover other
* possible refs */
- (void)tmps_grow_p(ix + (lastlelem - lelem));
+ (void)tmps_grow_p(ix + (lastlelem - lelem + 1));
PL_tmps_stack[ix] = ref;
}
+#endif
sv_setsv(lsv, *relem);
- *relem = lsv;
SvSETMAGIC(lsv);
+ if (UNLIKELY(is_list))
+ rpp_replace_at_NN(relem, lsv);
+#ifdef PERL_RC_STACK
+ *lelem = NULL;
+ SvREFCNT_dec_NN(lsv);
+#endif
}
+ lelem++;
if (++relem > lastrelem)
goto no_relems;
- break;
+ break;
} /* switch */
} /* while */
/* simplified lelem loop for when there are no relems left */
while (LIKELY(lelem <= lastlelem)) {
- SV *lsv = *lelem++;
+ SV *lsv = *lelem;
TAINT_NOT; /* Each item stands on its own, taintwise. */
- if (UNLIKELY(!lsv)) {
- lsv = *lelem++;
- ASSUME(SvTYPE(lsv) == SVt_PVAV);
- }
+ if (UNLIKELY(!lsv)) {
+ lsv = *++lelem;
+ ASSUME(SvTYPE(lsv) == SVt_PVAV);
+ }
- switch (SvTYPE(lsv)) {
- case SVt_PVAV:
+ switch (SvTYPE(lsv)) {
+ case SVt_PVAV:
if (SvRMAGICAL(lsv) || AvFILLp((SV*)lsv) >= 0) {
av_clear((AV*)lsv);
if (UNLIKELY(PL_delaymagic & DM_ARRAY_ISA))
}
break;
- case SVt_PVHV:
+ case SVt_PVHV:
if (SvRMAGICAL(lsv) || HvUSEDKEYS((HV*)lsv))
hv_clear((HV*)lsv);
break;
- default:
- if (!SvIMMORTAL(lsv)) {
+ default:
+ if (!SvIMMORTAL(lsv)) {
sv_set_undef(lsv);
SvSETMAGIC(lsv);
- *relem++ = lsv;
}
- break;
+ if (UNLIKELY(is_list)) {
+ /* this usually grows the list of relems to be returned
+ * into the stack space holding lelems (unless
+ * there was previously a hash with dup elements) */
+#ifdef PERL_RC_STACK
+ assert(relem <= first_discard);
+ assert(relem <= lelem);
+ if (relem == first_discard)
+ first_discard++;
+#endif
+ rpp_replace_at(relem++, lsv);
+#ifdef PERL_RC_STACK
+ if (relem == lelem + 1) {
+ lelem++;
+ /* skip the NULLing of the slot */
+ continue;
+ }
+#endif
+ }
+ break;
} /* switch */
+#ifdef PERL_RC_STACK
+ *lelem = NULL;
+ SvREFCNT_dec_NN(lsv);
+#endif
+ lelem++;
} /* while */
TAINT_NOT; /* result of list assign isn't tainted */
- if (UNLIKELY(PL_delaymagic & ~DM_DELAY)) {
- /* Will be used to set PL_tainting below */
- Uid_t tmp_uid = PerlProc_getuid();
- Uid_t tmp_euid = PerlProc_geteuid();
- Gid_t tmp_gid = PerlProc_getgid();
- Gid_t tmp_egid = PerlProc_getegid();
+ if (UNLIKELY(PL_delaymagic & ~DM_DELAY))
+ /* update system UIDs and/or GIDs */
+ S_aassign_uid(aTHX);
+ PL_delaymagic = old_delaymagic;
- /* XXX $> et al currently silently ignore failures */
- if (PL_delaymagic & DM_UID) {
-#ifdef HAS_SETRESUID
- PERL_UNUSED_RESULT(
- setresuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
- (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1,
- (Uid_t)-1));
-#elif defined(HAS_SETREUID)
- PERL_UNUSED_RESULT(
- setreuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
- (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1));
-#else
-# ifdef HAS_SETRUID
- if ((PL_delaymagic & DM_UID) == DM_RUID) {
- PERL_UNUSED_RESULT(setruid(PL_delaymagic_uid));
- PL_delaymagic &= ~DM_RUID;
- }
-# endif /* HAS_SETRUID */
-# ifdef HAS_SETEUID
- if ((PL_delaymagic & DM_UID) == DM_EUID) {
- PERL_UNUSED_RESULT(seteuid(PL_delaymagic_euid));
- PL_delaymagic &= ~DM_EUID;
- }
-# endif /* HAS_SETEUID */
- if (PL_delaymagic & DM_UID) {
- if (PL_delaymagic_uid != PL_delaymagic_euid)
- DIE(aTHX_ "No setreuid available");
- PERL_UNUSED_RESULT(PerlProc_setuid(PL_delaymagic_uid));
- }
-#endif /* HAS_SETRESUID */
+#ifdef PERL_RC_STACK
+ /* On ref-counted builds, the code above should have stored
+ * NULL in each lelem field and already freed each lelem. Thus
+ * the popfree_to() can start at a lower point.
+ * Under some circumstances, &PL_sv_undef might be stored rather than
+ * NULL, but this also doesn't need its refcount decrementing.
+ * Assert that this is true.
+ * Note that duplicate hash keys in list context can cause
+ * lastrelem and relem to be lower than at the start;
+ * while an odd number of hash elements can cause lastrelem to
+ * have a value one higher than at the start */
+# ifdef DEBUGGING
+ for (SV **svp = first_discard; svp <= PL_stack_sp; svp++)
+ assert(!*svp || SvIMMORTAL(*svp));
+# endif
+ PL_stack_sp = first_discard - 1;
+
+ /* now pop all the R elements too */
+ rpp_popfree_to_NN((is_list ? relem : firstrelem) - 1);
- tmp_uid = PerlProc_getuid();
- tmp_euid = PerlProc_geteuid();
- }
- /* XXX $> et al currently silently ignore failures */
- if (PL_delaymagic & DM_GID) {
-#ifdef HAS_SETRESGID
- PERL_UNUSED_RESULT(
- setresgid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
- (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1,
- (Gid_t)-1));
-#elif defined(HAS_SETREGID)
- PERL_UNUSED_RESULT(
- setregid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
- (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1));
#else
-# ifdef HAS_SETRGID
- if ((PL_delaymagic & DM_GID) == DM_RGID) {
- PERL_UNUSED_RESULT(setrgid(PL_delaymagic_gid));
- PL_delaymagic &= ~DM_RGID;
- }
-# endif /* HAS_SETRGID */
-# ifdef HAS_SETEGID
- if ((PL_delaymagic & DM_GID) == DM_EGID) {
- PERL_UNUSED_RESULT(setegid(PL_delaymagic_egid));
- PL_delaymagic &= ~DM_EGID;
- }
-# endif /* HAS_SETEGID */
- if (PL_delaymagic & DM_GID) {
- if (PL_delaymagic_gid != PL_delaymagic_egid)
- DIE(aTHX_ "No setregid available");
- PERL_UNUSED_RESULT(PerlProc_setgid(PL_delaymagic_gid));
- }
-#endif /* HAS_SETRESGID */
-
- tmp_gid = PerlProc_getgid();
- tmp_egid = PerlProc_getegid();
- }
- TAINTING_set( TAINTING_get | (tmp_uid && (tmp_euid != tmp_uid || tmp_egid != tmp_gid)) );
-#ifdef NO_TAINT_SUPPORT
- PERL_UNUSED_VAR(tmp_uid);
- PERL_UNUSED_VAR(tmp_euid);
- PERL_UNUSED_VAR(tmp_gid);
- PERL_UNUSED_VAR(tmp_egid);
+ /* pop all L and R elements apart from any being returned */
+ rpp_popfree_to_NN((is_list ? relem : firstrelem) - 1);
#endif
- }
- PL_delaymagic = old_delaymagic;
- if (gimme == G_VOID)
- SP = firstrelem - 1;
- else if (gimme == G_SCALAR) {
- SP = firstrelem;
- EXTEND(SP,1);
+ if (gimme == G_SCALAR) {
+ rpp_extend(1);
+ SV *sv;
if (PL_op->op_private & OPpASSIGN_TRUEBOOL)
- SETs((firstlelem - firstrelem) ? &PL_sv_yes : &PL_sv_zero);
+ rpp_push_IMM((firstlelem - firstrelem) ? &PL_sv_yes : &PL_sv_zero);
else {
dTARGET;
- SETi(firstlelem - firstrelem);
+ TARGi(firstlelem - firstrelem, 1);
+ sv = targ;
+ rpp_push_1(sv);
}
}
- else
- SP = relem - 1;
- RETURN;
+ return NORMAL;
}
+
PP(pp_qr)
{
- dSP;
PMOP * const pm = cPMOP;
REGEXP * rx = PM_GETRE(pm);
regexp *prog = ReANY(rx);
SV * const pkg = RXp_ENGINE(prog)->qr_package(aTHX_ (rx));
- SV * const rv = sv_newmortal();
+ SV * const rv = newSV_type_mortal(SVt_IV);
CV **cvp;
CV *cv;
cvp = &( ReANY((REGEXP *)SvRV(rv))->qr_anoncv);
if (UNLIKELY((cv = *cvp) && CvCLONE(*cvp))) {
- *cvp = cv_clone(cv);
- SvREFCNT_dec_NN(cv);
+ *cvp = cv_clone(cv);
+ SvREFCNT_dec_NN(cv);
}
if (pkg) {
- HV *const stash = gv_stashsv(pkg, GV_ADD);
- SvREFCNT_dec_NN(pkg);
- (void)sv_bless(rv, stash);
+ HV *const stash = gv_stashsv(pkg, GV_ADD);
+ SvREFCNT_dec_NN(pkg);
+ (void)sv_bless(rv, stash);
}
if (UNLIKELY(RXp_ISTAINTED(prog))) {
SvTAINTED_on(rv);
SvTAINTED_on(SvRV(rv));
}
- XPUSHs(rv);
- RETURN;
+ rpp_xpush_1(rv);
+ return NORMAL;
+}
+
+STATIC bool
+S_are_we_in_Debug_EXECUTE_r(pTHX)
+{
+ /* Given a 'use re' is in effect, does it ask for outputting execution
+ * debug info?
+ *
+ * This is separated from the sole place it's called, an inline function,
+ * because it is the large-ish slow portion of the function */
+
+ DECLARE_AND_GET_RE_DEBUG_FLAGS_NON_REGEX;
+
+ return cBOOL(RE_DEBUG_FLAG(RE_DEBUG_EXECUTE_MASK));
+}
+
+PERL_STATIC_INLINE bool
+S_should_we_output_Debug_r(pTHX_ regexp *prog)
+{
+ PERL_ARGS_ASSERT_SHOULD_WE_OUTPUT_DEBUG_R;
+
+ /* pp_match can output regex debugging info. This function returns a
+ * boolean as to whether or not it should.
+ *
+ * Under -Dr, it should. Any reasonable compiler will optimize this bit of
+ * code away on non-debugging builds. */
+ if (UNLIKELY(DEBUG_r_TEST)) {
+ return TRUE;
+ }
+
+ /* If the regex engine is using the non-debugging execution routine, then
+ * no debugging should be output. Same if the field is NULL that pluggable
+ * engines are not supposed to fill. */
+ if ( LIKELY(prog->engine->exec == &Perl_regexec_flags)
+ || UNLIKELY(prog->engine->op_comp == NULL))
+ {
+ return FALSE;
+ }
+
+ /* Otherwise have to check */
+ return S_are_we_in_Debug_EXECUTE_r(aTHX);
}
+
PP(pp_match)
{
- dSP; dTARG;
+ SV *targ;
PMOP *pm = cPMOP;
PMOP *dynpm = pm;
const char *s;
const I32 oldsave = PL_savestack_ix;
I32 had_zerolen = 0;
MAGIC *mg = NULL;
+ SSize_t sp_base;
- if (PL_op->op_flags & OPf_STACKED)
- TARG = POPs;
+ if (PL_op->op_flags & OPf_STACKED) {
+ targ = PL_stack_sp[0];
+ /* We have to keep targ alive on the stack. At the end we have to
+ * free it and shuffle down all the return values by one.
+ * Remember the position.
+ */
+ sp_base = PL_stack_sp - PL_stack_base;
+ assert(sp_base > 0);
+ }
else {
- if (ARGTARG)
- GETTARGET;
+ sp_base = 0;
+ if (PL_op->op_targ)
+ targ = PAD_SV(PL_op->op_targ);
else {
- TARG = DEFSV;
+ targ = DEFSV;
}
- EXTEND(SP,1);
+ rpp_extend(1);
}
- PUTBACK; /* EVAL blocks need stack_sp. */
/* Skip get-magic if this is a qr// clone, because regcomp has
already done it. */
truebase = prog->mother_re
- ? SvPV_nomg_const(TARG, len)
- : SvPV_const(TARG, len);
+ ? SvPV_nomg_const(TARG, len)
+ : SvPV_const(TARG, len);
if (!truebase)
- DIE(aTHX_ "panic: pp_match");
+ DIE(aTHX_ "panic: pp_match");
strend = truebase + len;
rxtainted = (RXp_ISTAINTED(prog) ||
- (TAINT_get && (pm->op_pmflags & PMf_RETAINT)));
+ (TAINT_get && (pm->op_pmflags & PMf_RETAINT)));
TAINT_NOT;
/* We need to know this in case we fail out early - pos() must be reset */
pm->op_pmflags & PMf_USED
#endif
) {
- DEBUG_r(PerlIO_printf(Perl_debug_log, "?? already matched once"));
- goto nope;
+ if (UNLIKELY(should_we_output_Debug_r(prog))) {
+ PerlIO_printf(Perl_debug_log, "?? already matched once");
+ }
+ goto nope;
}
/* handle the empty pattern */
}
if (RXp_MINLEN(prog) >= 0 && (STRLEN)RXp_MINLEN(prog) > len) {
- DEBUG_r(PerlIO_printf(Perl_debug_log, "String shorter than min possible regex match (%"
- UVuf " < %" IVdf ")\n",
- (UV)len, (IV)RXp_MINLEN(prog)));
- goto nope;
+ if (UNLIKELY(should_we_output_Debug_r(prog))) {
+ PerlIO_printf(Perl_debug_log,
+ "String shorter than min possible regex match (%zd < %zd)\n",
+ len, RXp_MINLEN(prog));
+ }
+ goto nope;
}
/* get pos() if //g */
)
#endif
{
- r_flags |= (REXEC_COPY_STR|REXEC_COPY_SKIP_PRE);
- /* in @a =~ /(.)/g, we iterate multiple times, but copy the buffer
+ r_flags |= (REXEC_COPY_STR|REXEC_COPY_SKIP_PRE);
+ /* In @a = /(.)/g, we iterate multiple times, but copy the buffer
* only on the first iteration. Therefore we need to copy $' as well
* as $&, to make the rest of the string available for captures in
* subsequent iterations */
- if (! (global && gimme == G_ARRAY))
+ if (! (global && gimme == G_LIST))
r_flags |= REXEC_COPY_SKIP_POST;
};
#ifdef PERL_SAWAMPERSAND
play_it_again:
if (global)
- s = truebase + curpos;
+ s = truebase + curpos;
if (!CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
- had_zerolen, TARG, NULL, r_flags))
- goto nope;
+ had_zerolen, TARG, NULL, r_flags))
+ goto nope;
PL_curpm = pm;
if (dynpm->op_pmflags & PMf_ONCE)
#ifdef USE_ITHREADS
- SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
+ SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
#else
- dynpm->op_pmflags |= PMf_USED;
+ dynpm->op_pmflags |= PMf_USED;
#endif
if (rxtainted)
- RXp_MATCH_TAINTED_on(prog);
+ RXp_MATCH_TAINTED_on(prog);
TAINT_IF(RXp_MATCH_TAINTED(prog));
/* update pos */
- if (global && (gimme != G_ARRAY || (dynpm->op_pmflags & PMf_CONTINUE))) {
+ if (global && (gimme != G_LIST || (dynpm->op_pmflags & PMf_CONTINUE))) {
if (!mg)
mg = sv_magicext_mglob(TARG);
- MgBYTEPOS_set(mg, TARG, truebase, RXp_OFFS(prog)[0].end);
+ MgBYTEPOS_set(mg, TARG, truebase, RXp_OFFS_END(prog,0));
if (RXp_ZERO_LEN(prog))
mg->mg_flags |= MGf_MINMATCH;
else
mg->mg_flags &= ~MGf_MINMATCH;
}
- if ((!RXp_NPARENS(prog) && !global) || gimme != G_ARRAY) {
- LEAVE_SCOPE(oldsave);
- RETPUSHYES;
+ if ((!RXp_NPARENS(prog) && !global) || gimme != G_LIST) {
+ LEAVE_SCOPE(oldsave);
+ if (sp_base)
+ rpp_popfree_1(); /* free arg */
+ rpp_push_IMM(&PL_sv_yes);
+ return NORMAL;
}
/* push captures on stack */
{
- const I32 nparens = RXp_NPARENS(prog);
- I32 i = (global && !nparens) ? 1 : 0;
-
- SPAGAIN; /* EVAL blocks could move the stack. */
- EXTEND(SP, nparens + i);
- EXTEND_MORTAL(nparens + i);
- for (i = !i; i <= nparens; i++) {
- PUSHs(sv_newmortal());
- if (LIKELY((RXp_OFFS(prog)[i].start != -1)
- && RXp_OFFS(prog)[i].end != -1 ))
- {
- const I32 len = RXp_OFFS(prog)[i].end - RXp_OFFS(prog)[i].start;
- const char * const s = RXp_OFFS(prog)[i].start + truebase;
- if (UNLIKELY( RXp_OFFS(prog)[i].end < 0
- || RXp_OFFS(prog)[i].start < 0
- || len < 0
- || len > strend - s)
- )
- DIE(aTHX_ "panic: pp_match start/end pointers, i=%ld, "
- "start=%ld, end=%ld, s=%p, strend=%p, len=%" UVuf,
- (long) i, (long) RXp_OFFS(prog)[i].start,
- (long)RXp_OFFS(prog)[i].end, s, strend, (UV) len);
- sv_setpvn(*SP, s, len);
- if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
- SvUTF8_on(*SP);
- }
- }
- if (global) {
- curpos = (UV)RXp_OFFS(prog)[0].end;
- had_zerolen = RXp_ZERO_LEN(prog);
- PUTBACK; /* EVAL blocks may use stack */
- r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
- goto play_it_again;
- }
- LEAVE_SCOPE(oldsave);
- RETURN;
+ const I32 logical_nparens = RXp_LOGICAL_NPARENS(prog);
+ /* This following statement is *devious* code. If we are in a global
+ match and the pattern has no parens in it, we should return $&
+ (offset pair 0). So we set logical_paren to 1 when we should return
+ $&, otherwise we set it to 0.
+
+ This allows us to simply add logical_nparens to logical_paren to
+ compute the number of elements we are going to return.
+
+ In the loop init we "not" it with: logical_paren = !logical_paren
+ which results in it being 0 inside the loop when we want to return
+ $&, and results in it being 1 when we want to return the parens.
+ Thus we either loop over 1..logical_nparens, or just over 0.
+
+ This is an elegant way to do this code-wise, but is super devious
+ and potentially confusing. When I first saw this logic I thought
+ "WTF?". But it makes sense after you poke it a while.
+
+ Frankly I probably would have done it differently, but it works so
+ I am leaving it. - Yves */
+ I32 logical_paren = (global && !logical_nparens) ? 1 : 0;
+ I32 *l2p = RXp_LOGICAL_TO_PARNO(prog);
+ /* This is used to step through the physical parens associated
+ with a given logical paren. */
+ I32 *p2l_next = RXp_PARNO_TO_LOGICAL_NEXT(prog);
+
+ rpp_extend(logical_nparens + logical_paren); /* devious code ... */
+ EXTEND_MORTAL(logical_nparens + logical_paren); /* ... see above */
+
+ /* Loop over the logical parens in the pattern. This may not
+ correspond to the actual paren checked, as branch reset may
+ mean that there is more than one paren "behind" the logical
+ parens. Eg, in /(?|(a)|(b))/ there are two parens, but one
+ logical paren. */
+ for (logical_paren = !logical_paren;
+ logical_paren <= logical_nparens;
+ logical_paren++)
+ {
+ /* Now convert the logical_paren to the physical parens which
+ are "behind" it. If branch reset was not used, then
+ physical_paren and logical_paren are the same as each other
+ and we will only perform one iteration of the loop. */
+ I32 phys_paren = l2p ? l2p[logical_paren] : logical_paren;
+ SSize_t offs_start, offs_end;
+ /* We check the loop invariants below and break out of the loop
+ explicitly if our checks fail, so we use while (1) here to
+ avoid double testing a conditional. */
+ while (1) {
+ /* Check end offset first, as the start might be >=0 even
+ though the end is -1, so testing the end first helps
+ us avoid the start check. Really we should be able to
+ get away with ONLY testing the end, but testing both
+ doesn't hurt much and preserves sanity. */
+ if (((offs_end = RXp_OFFS_END(prog, phys_paren)) != -1) &&
+ ((offs_start = RXp_OFFS_START(prog, phys_paren)) != -1))
+ {
+ const SSize_t len = offs_end - offs_start;
+ const char * const s = offs_start + truebase;
+ if ( UNLIKELY( len < 0 || len > strend - s) ) {
+ DIE(aTHX_ "panic: pp_match start/end pointers, paren=%" I32df ", "
+ "start=%zd, end=%zd, s=%p, strend=%p, len=%zd",
+ phys_paren, offs_start, offs_end, s, strend, len);
+ }
+ rpp_push_1(newSVpvn_flags(s, len,
+ (DO_UTF8(TARG))
+ ? SVf_UTF8|SVs_TEMP
+ : SVs_TEMP)
+ );
+ break;
+ } else if (!p2l_next || !(phys_paren = p2l_next[phys_paren])) {
+ /* Either logical_paren and phys_paren are the same and
+ we won't have a p2l_next, or they aren't the same (and
+ we do have a p2l_next) but we have exhausted the list
+ of physical parens associated with this logical paren.
+ Either way we are done, and we can push undef and break
+ out of the loop. */
+ rpp_push_1(sv_newmortal());
+ break;
+ }
+ }
+ }
+ if (global) {
+ curpos = (UV)RXp_OFFS_END(prog,0);
+ had_zerolen = RXp_ZERO_LEN(prog);
+ r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
+ goto play_it_again;
+ }
+ LEAVE_SCOPE(oldsave);
+ goto ret_list;
}
NOT_REACHED; /* NOTREACHED */
mg->mg_len = -1;
}
LEAVE_SCOPE(oldsave);
- if (gimme == G_ARRAY)
- RETURN;
- RETPUSHNO;
+ if (gimme != G_LIST) {
+ if (sp_base)
+ rpp_popfree_1(); /* free arg */
+ rpp_push_IMM(&PL_sv_no);
+ return NORMAL;
+ }
+
+ ret_list:
+ /* return when in list context (i.e. don't push YES/NO, but do return
+ * a (possibly empty) list of matches */
+ if (sp_base) {
+ /* need to free the original argument and shift any results down
+ * by one */
+ SSize_t nitems = PL_stack_sp - (PL_stack_base + sp_base);
+#ifdef PERL_RC_STACK
+ SV *old_sv = PL_stack_sp[-nitems];
+#endif
+ if (nitems)
+ Move(PL_stack_sp - nitems + 1,
+ PL_stack_sp - nitems, nitems, SV*);
+ PL_stack_sp--;
+#ifdef PERL_RC_STACK
+ SvREFCNT_dec_NN(old_sv);
+#endif
+ }
+
+ return NORMAL;
}
+
+/* Perl_do_readline(): implement <$fh>, readline($fh) and glob('*.h')
+ *
+ * This function is tail-called by pp_readline(), pp_rcatline() and
+ * pp_glob(), and it may check PL_op's op_type and op_flags as
+ * appropriate.
+ *
+ * For file reading:
+ * It reads the line(s) from PL_last_in_gv.
+ * It returns a list of lines, or in scalar context, reads one line into
+ * targ (or if OPf_STACKED, into the top SV on the stack), and
+ * returns that. (If OP_RCATLINE, concats rather than sets).
+ *
+ * So it normally expects zero args, or one arg when the OPf_STACKED
+ * optimisation is present.
+ *
+ * For file globbing:
+ * Note that we don't normally reach here: we only get here if perl is
+ * built with PERL_EXTERNAL_GLOB, which is normally only when
+ * building miniperl.
+ *
+ * Expects one arg, which is the pattern string (e.g. '*.h').
+ * The caller sets PL_last_in_gv to a plain GV that just has a new
+ * IO::File PVIO attached.
+ *
+ * Handles tied IO magic, but not overloading - that's the caller's
+ * responsibility.
+ *
+ * Handles the *ARGV filehandle specially, to do all the <> wizardry.
+ *
+ * In summary: on entry, the stack has zero or one items pushed, and
+ * looks like:
+ *
+ * - when OP_READLINE without OPf_STACKED
+ * target when OP_READLINE with OPf_STACKED, or when OP_RCATLINE
+ * '*.h' when OP_GLOB
+ */
+
OP *
Perl_do_readline(pTHX)
{
- dSP; dTARGETSTACKED;
+
+ const I32 type = PL_op->op_type;
+
+ /* only readline/rcatline can have the STACKED optimisation,
+ * and rcatline *always* has it */
+ if (PL_op->op_flags & OPf_STACKED) {
+ assert(type != OP_GLOB);
+ assert(GIMME_V == G_SCALAR);
+ }
+ if (type == OP_RCATLINE)
+ assert(PL_op->op_flags & OPf_STACKED);
+
+ const U8 gimme = GIMME_V;
+ SV *targ = (gimme == G_SCALAR)
+ ? (PL_op->op_flags & OPf_STACKED)
+ ? *PL_stack_sp
+ : PAD_SV(PL_op->op_targ)
+ : NULL;
SV *sv;
STRLEN tmplen = 0;
STRLEN offset;
PerlIO *fp;
IO * const io = GvIO(PL_last_in_gv);
- const I32 type = PL_op->op_type;
- const U8 gimme = GIMME_V;
+
+ /* process tied file handle if present */
if (io) {
- const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
- if (mg) {
- Perl_tied_method(aTHX_ SV_CONST(READLINE), SP, MUTABLE_SV(io), mg, gimme, 0);
- if (gimme == G_SCALAR) {
- SPAGAIN;
- SvSetSV_nosteal(TARG, TOPs);
- SETTARG;
- }
- return NORMAL;
- }
+ const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
+ if (mg) {
+ /* not possible for the faked-up IO passed by an OP_GLOB to be
+ * tied */
+ assert(type != OP_GLOB);
+ /* OPf_STACKED only applies when in scalar context */
+ assert(!(gimme != G_SCALAR && (PL_op->op_flags & OPf_STACKED)));
+
+ /* tied_method() frees everything currently above the passed
+ * mark, and returns any values at mark[1] onwards */
+ Perl_tied_method(aTHX_ SV_CONST(READLINE),
+ /* mark => */ PL_stack_sp,
+ MUTABLE_SV(io), mg, gimme, 0);
+
+ if (gimme == G_SCALAR) {
+ SvSetSV_nosteal(targ, *PL_stack_sp);
+ SvSETMAGIC(targ);
+ if (PL_op->op_flags & OPf_STACKED) {
+ /* free the tied method call's return value */
+ rpp_popfree_1();
+ assert(*PL_stack_sp == targ);
+ }
+ else
+ rpp_replace_1_1(targ);
+ }
+ else
+ /* no targ to pop off the stack - any returned values
+ * are in the right place in the stack */
+ assert(!(PL_op->op_flags & OPf_STACKED));
+
+ return NORMAL;
+ }
}
+
fp = NULL;
+
+ /* handle possible *ARGV, and check for read on write-only FH */
+
if (io) {
- fp = IoIFP(io);
- if (!fp) {
- if (IoFLAGS(io) & IOf_ARGV) {
- if (IoFLAGS(io) & IOf_START) {
- IoLINES(io) = 0;
- if (av_tindex(GvAVn(PL_last_in_gv)) < 0) {
- IoFLAGS(io) &= ~IOf_START;
- do_open6(PL_last_in_gv, "-", 1, NULL, NULL, 0);
- SvTAINTED_off(GvSVn(PL_last_in_gv)); /* previous tainting irrelevant */
- sv_setpvs(GvSVn(PL_last_in_gv), "-");
- SvSETMAGIC(GvSV(PL_last_in_gv));
- fp = IoIFP(io);
- goto have_fp;
- }
- }
- fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL);
- if (!fp) { /* Note: fp != IoIFP(io) */
- (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
- }
- }
- else if (type == OP_GLOB)
- fp = Perl_start_glob(aTHX_ POPs, io);
- }
- else if (type == OP_GLOB)
- SP--;
- else if (IoTYPE(io) == IoTYPE_WRONLY) {
- report_wrongway_fh(PL_last_in_gv, '>');
- }
+ fp = IoIFP(io);
+ if (fp) {
+ /* not possible for the faked-up IO passed by an OP_GLOB to
+ * have a file handle */
+ assert(type != OP_GLOB);
+
+ if (IoTYPE(io) == IoTYPE_WRONLY)
+ report_wrongway_fh(PL_last_in_gv, '>');
+ }
+ else {
+ if (IoFLAGS(io) & IOf_ARGV) {
+ if (IoFLAGS(io) & IOf_START) {
+ IoLINES(io) = 0;
+ if (av_count(GvAVn(PL_last_in_gv)) == 0) {
+ IoFLAGS(io) &= ~IOf_START;
+ do_open6(PL_last_in_gv, "-", 1, NULL, NULL, 0);
+ SvTAINTED_off(GvSVn(PL_last_in_gv)); /* previous tainting irrelevant */
+ sv_setpvs(GvSVn(PL_last_in_gv), "-");
+ SvSETMAGIC(GvSV(PL_last_in_gv));
+ fp = IoIFP(io);
+ goto have_fp;
+ }
+ }
+ fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL);
+ if (!fp) { /* Note: fp != IoIFP(io) */
+ (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
+ }
+ }
+ else if (type == OP_GLOB) {
+ fp = Perl_start_glob(aTHX_ *PL_stack_sp, io);
+ rpp_popfree_1_NN();
+ }
+ }
}
+
+ /* handle bad file handle */
+
if (!fp) {
- if ((!io || !(IoFLAGS(io) & IOf_START))
- && ckWARN(WARN_CLOSED)
+ if ((!io || !(IoFLAGS(io) & IOf_START))
+ && ckWARN(WARN_CLOSED)
&& type != OP_GLOB)
- {
- report_evil_fh(PL_last_in_gv);
- }
- if (gimme == G_SCALAR) {
- /* undef TARG, and push that undefined value */
- if (type != OP_RCATLINE) {
- sv_set_undef(TARG);
- }
- PUSHTARG;
- }
- RETURN;
+ {
+ report_evil_fh(PL_last_in_gv);
+ }
+
+ if (gimme == G_SCALAR) {
+ /* undef targ, and return that undefined value */
+ if (type != OP_RCATLINE)
+ sv_set_undef(targ);
+ if (!(PL_op->op_flags & OPf_STACKED))
+ rpp_push_1(targ);
+ }
+ return NORMAL;
}
+
have_fp:
+
+ /* prepare targ to have a string assigned to it */
+
if (gimme == G_SCALAR) {
- sv = TARG;
- if (type == OP_RCATLINE && SvGMAGICAL(sv))
- mg_get(sv);
- if (SvROK(sv)) {
- if (type == OP_RCATLINE)
- SvPV_force_nomg_nolen(sv);
- else
- sv_unref(sv);
- }
- else if (isGV_with_GP(sv)) {
- SvPV_force_nomg_nolen(sv);
- }
- SvUPGRADE(sv, SVt_PV);
- tmplen = SvLEN(sv); /* remember if already alloced */
- if (!tmplen && !SvREADONLY(sv) && !SvIsCOW(sv)) {
+ sv = targ;
+ if (type == OP_RCATLINE && SvGMAGICAL(sv))
+ mg_get(sv);
+
+ if (SvROK(sv)) {
+ if (type == OP_RCATLINE)
+ SvPV_force_nomg_nolen(sv);
+ else
+ sv_unref(sv);
+ }
+ else if (isGV_with_GP(sv)) {
+ SvPV_force_nomg_nolen(sv);
+ }
+
+ SvUPGRADE(sv, SVt_PV);
+ tmplen = SvLEN(sv); /* remember if already alloced */
+ if (!tmplen && !SvREADONLY(sv) && !SvIsCOW(sv)) {
/* try short-buffering it. Please update t/op/readline.t
- * if you change the growth length.
- */
- Sv_Grow(sv, 80);
- }
- offset = 0;
- if (type == OP_RCATLINE && SvOK(sv)) {
- if (!SvPOK(sv)) {
- SvPV_force_nomg_nolen(sv);
- }
- offset = SvCUR(sv);
- }
+ * if you change the growth length.
+ */
+ Sv_Grow(sv, 80);
+ }
+
+ offset = 0;
+ if (type == OP_RCATLINE && SvOK(sv)) {
+ if (!SvPOK(sv)) {
+ SvPV_force_nomg_nolen(sv);
+ }
+ offset = SvCUR(sv);
+ }
}
else {
- sv = sv_2mortal(newSV(80));
- offset = 0;
+ /* XXX on RC builds, push on stack rather than mortalize ? */
+ sv = sv_2mortal(newSV(80));
+ offset = 0;
}
/* This should not be marked tainted if the fp is marked clean */
#define MAYBE_TAINT_LINE(io, sv) \
if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
- TAINT; \
- SvTAINTED_on(sv); \
+ TAINT; \
+ SvTAINTED_on(sv); \
}
/* delay EOF state for a snarfed empty file */
(gimme != G_SCALAR || SvCUR(sv) \
|| (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
+ /* create one or more lines, or (if OP_GLOB), pathnames */
+
for (;;) {
- PUTBACK;
- if (!sv_gets(sv, fp, offset)
- && (type == OP_GLOB
- || SNARF_EOF(gimme, PL_rs, io, sv)
- || PerlIO_error(fp)))
- {
- PerlIO_clearerr(fp);
- if (IoFLAGS(io) & IOf_ARGV) {
- fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL);
- if (fp)
- continue;
- (void)do_close(PL_last_in_gv, FALSE);
- }
- else if (type == OP_GLOB) {
- if (!do_close(PL_last_in_gv, FALSE)) {
- Perl_ck_warner(aTHX_ packWARN(WARN_GLOB),
- "glob failed (child exited with status %d%s)",
- (int)(STATUS_CURRENT >> 8),
- (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
- }
- }
- if (gimme == G_SCALAR) {
- if (type != OP_RCATLINE) {
- SV_CHECK_THINKFIRST_COW_DROP(TARG);
- SvOK_off(TARG);
- }
- SPAGAIN;
- PUSHTARG;
- }
- MAYBE_TAINT_LINE(io, sv);
- RETURN;
- }
- MAYBE_TAINT_LINE(io, sv);
- IoLINES(io)++;
- IoFLAGS(io) |= IOf_NOLINE;
- SvSETMAGIC(sv);
- SPAGAIN;
- XPUSHs(sv);
- if (type == OP_GLOB) {
- const char *t1;
- Stat_t statbuf;
-
- if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
- char * const tmps = SvEND(sv) - 1;
- if (*tmps == *SvPVX_const(PL_rs)) {
- *tmps = '\0';
- SvCUR_set(sv, SvCUR(sv) - 1);
- }
- }
- for (t1 = SvPVX_const(sv); *t1; t1++)
+ if (!sv_gets(sv, fp, offset)
+ && (type == OP_GLOB
+ || SNARF_EOF(gimme, PL_rs, io, sv)
+ || PerlIO_error(fp)))
+ {
+ if (IoFLAGS(io) & IOf_ARGV) {
+ fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL);
+ if (fp) {
+ continue;
+ }
+ (void)do_close(PL_last_in_gv, FALSE);
+ }
+ else if (type == OP_GLOB) {
+ /* clear any errors here so we only fail on the pclose()
+ failing, which should only happen on the child
+ failing
+ */
+ PerlIO_clearerr(fp);
+ if (!do_close(PL_last_in_gv, FALSE)) {
+ Perl_ck_warner(aTHX_ packWARN(WARN_GLOB),
+ "glob failed (child exited with status %d%s)",
+ (int)(STATUS_CURRENT >> 8),
+ (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
+ }
+ }
+
+ if (gimme == G_SCALAR) {
+ if (type != OP_RCATLINE) {
+ SV_CHECK_THINKFIRST_COW_DROP(targ);
+ SvOK_off(targ);
+ }
+ /* targ not already there? */
+ if (!(PL_op->op_flags & OPf_STACKED))
+ rpp_push_1(targ);
+ }
+ else if (PL_op->op_flags & OPf_STACKED)
+ rpp_popfree_1_NN();
+
+ MAYBE_TAINT_LINE(io, sv);
+ return NORMAL;
+ }
+
+ MAYBE_TAINT_LINE(io, sv);
+ IoLINES(io)++;
+ IoFLAGS(io) |= IOf_NOLINE;
+ SvSETMAGIC(sv);
+ rpp_extend(1);
+ if (PL_op->op_flags & OPf_STACKED) {
+ /* push sv while keeping targ above it, so targ doesn't get
+ * freed */
+ assert(*PL_stack_sp == targ);
+ PL_stack_sp[1] = targ;
+ *PL_stack_sp++ = NULL;
+ rpp_replace_at(PL_stack_sp - 1, sv);
+ }
+ else
+ rpp_push_1(sv);
+
+ if (type == OP_GLOB) {
+ const char *t1;
+ Stat_t statbuf;
+
+ /* chomp(sv) */
+ if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
+ char * const tmps = SvEND(sv) - 1;
+ if (*tmps == *SvPVX_const(PL_rs)) {
+ *tmps = '\0';
+ SvCUR_set(sv, SvCUR(sv) - 1);
+ }
+ }
+
+ /* find longest substring of sv up to first metachar */
+ for (t1 = SvPVX_const(sv); *t1; t1++) {
#ifdef __VMS
- if (strchr("*%?", *t1))
+ if (memCHRs("*%?", *t1))
#else
- if (strchr("$&*(){}[]'\";\\|?<>~`", *t1))
+ if (memCHRs("$&*(){}[]'\";\\|?<>~`", *t1))
#endif
- break;
- if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &statbuf) < 0) {
- (void)POPs; /* Unmatched wildcard? Chuck it... */
- continue;
- }
- } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
- if (ckWARN(WARN_UTF8)) {
- const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
- const STRLEN len = SvCUR(sv) - offset;
- const U8 *f;
-
- if (!is_utf8_string_loc(s, len, &f))
- /* Emulate :encoding(utf8) warning in the same case. */
- Perl_warner(aTHX_ packWARN(WARN_UTF8),
- "utf8 \"\\x%02X\" does not map to Unicode",
- f < (U8*)SvEND(sv) ? *f : 0);
- }
- }
- if (gimme == G_ARRAY) {
- if (SvLEN(sv) - SvCUR(sv) > 20) {
- SvPV_shrink_to_cur(sv);
- }
- sv = sv_2mortal(newSV(80));
- continue;
- }
- else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
- /* try to reclaim a bit of scalar space (only on 1st alloc) */
- const STRLEN new_len
- = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
- SvPV_renew(sv, new_len);
- }
- RETURN;
- }
+ break;
+ }
+
+ if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &statbuf) < 0) {
+ /* Unmatched wildcard? Chuck it... */
+ /* no need to worry about targ still on top of stack */
+ assert(!(PL_op->op_flags & OPf_STACKED));
+ rpp_popfree_1();
+ continue;
+ }
+ } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
+ /* check line if valid Unicode */
+ if (ckWARN(WARN_UTF8)) {
+ const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
+ const STRLEN len = SvCUR(sv) - offset;
+ const U8 *f;
+
+ if (!is_utf8_string_loc(s, len, &f))
+ /* Emulate :encoding(utf8) warning in the same case. */
+ Perl_warner(aTHX_ packWARN(WARN_UTF8),
+ "utf8 \"\\x%02X\" does not map to Unicode",
+ f < (U8*)SvEND(sv) ? *f : 0);
+ }
+ }
+
+ if (gimme == G_LIST) {
+ if (SvLEN(sv) - SvCUR(sv) > 20) {
+ SvPV_shrink_to_cur(sv);
+ }
+ /* XXX on RC builds, push on stack rather than mortalize ? */
+ sv = sv_2mortal(newSV(80));
+ continue;
+ }
+
+ if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
+ /* try to reclaim a bit of scalar space (only on 1st alloc) */
+ const STRLEN new_len
+ = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
+ SvPV_renew(sv, new_len);
+ }
+
+
+ if (PL_op->op_flags & OPf_STACKED)
+ rpp_popfree_1_NN(); /* finally remove targ */
+ /* return sv, which was recently pushed onto the stack */
+ return NORMAL;
+ } /* for (;;) */
}
+
PP(pp_helem)
{
- dSP;
HE* he;
SV **svp;
- SV * const keysv = POPs;
- HV * const hv = MUTABLE_HV(POPs);
+ SV * const keysv = PL_stack_sp[0];
+ HV * const hv = MUTABLE_HV(PL_stack_sp[-1]);
const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
SV *sv;
const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
bool preeminent = TRUE;
+ SV *retsv;
- if (SvTYPE(hv) != SVt_PVHV)
- RETPUSHUNDEF;
+ if (SvTYPE(hv) != SVt_PVHV) {
+ retsv = &PL_sv_undef;
+ goto ret;
+ }
if (localizing) {
- MAGIC *mg;
- HV *stash;
+ MAGIC *mg;
+ HV *stash;
- /* If we can determine whether the element exist,
- * Try to preserve the existenceness of a tied hash
- * element by using EXISTS and DELETE if possible.
- * Fallback to FETCH and STORE otherwise. */
- if (SvCANEXISTDELETE(hv))
- preeminent = hv_exists_ent(hv, keysv, 0);
+ /* Try to preserve the existence of a tied hash
+ * element by using EXISTS and DELETE if possible.
+ * Fall back to FETCH and STORE otherwise. */
+ if (SvCANEXISTDELETE(hv))
+ preeminent = hv_exists_ent(hv, keysv, 0);
}
he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
svp = he ? &HeVAL(he) : NULL;
if (lval) {
- if (!svp || !*svp || *svp == &PL_sv_undef) {
- SV* lv;
- SV* key2;
- if (!defer) {
- DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
- }
- lv = sv_newmortal();
- sv_upgrade(lv, SVt_PVLV);
- LvTYPE(lv) = 'y';
- sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
- SvREFCNT_dec_NN(key2); /* sv_magic() increments refcount */
- LvTARG(lv) = SvREFCNT_inc_simple_NN(hv);
- LvTARGLEN(lv) = 1;
- PUSHs(lv);
- RETURN;
- }
- if (localizing) {
- if (HvNAME_get(hv) && isGV_or_RVCV(*svp))
- save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
- else if (preeminent)
- save_helem_flags(hv, keysv, svp,
- (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
- else
- SAVEHDELETE(hv, keysv);
- }
- else if (PL_op->op_private & OPpDEREF) {
- PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
- RETURN;
- }
+ if (!svp || !*svp || *svp == &PL_sv_undef) {
+ SV* lv;
+ SV* key2;
+ if (!defer) {
+ DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
+ }
+ lv = newSV_type_mortal(SVt_PVLV);
+ LvTYPE(lv) = 'y';
+ sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
+ SvREFCNT_dec_NN(key2); /* sv_magic() increments refcount */
+ LvTARG(lv) = SvREFCNT_inc_simple_NN(hv);
+ LvTARGLEN(lv) = 1;
+ retsv = lv;
+ goto ret;
+ }
+
+ if (localizing) {
+ if (HvNAME_get(hv) && isGV_or_RVCV(*svp))
+ save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
+ else if (preeminent)
+ save_helem_flags(hv, keysv, svp,
+ (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
+ else
+ SAVEHDELETE(hv, keysv);
+ }
+ else if (PL_op->op_private & OPpDEREF) {
+ retsv = vivify_ref(*svp, PL_op->op_private & OPpDEREF);
+ goto ret;;
+ }
}
sv = (svp && *svp ? *svp : &PL_sv_undef);
/* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
* compromise, do the get magic here. (The MGf_GSKIP flag will stop it
* being called too many times). */
if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv))
- mg_get(sv);
- PUSHs(sv);
- RETURN;
+ mg_get(sv);
+ retsv = sv;
+
+ ret:
+ rpp_replace_2_1_NN(retsv);
+ return NORMAL;
}
STATIC GV *
S_softref2xv_lite(pTHX_ SV *const sv, const char *const what,
- const svtype type)
+ const svtype type)
{
if (PL_op->op_private & HINT_STRICT_REFS) {
- if (SvOK(sv))
- Perl_die(aTHX_ PL_no_symref_sv, sv,
- (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what);
- else
- Perl_die(aTHX_ PL_no_usym, what);
+ if (SvOK(sv))
+ Perl_die(aTHX_ PL_no_symref_sv, sv,
+ (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what);
+ else
+ Perl_die(aTHX_ PL_no_usym, what);
}
if (!SvOK(sv))
Perl_die(aTHX_ PL_no_usym, what);
* op_aux points to an array of unions of UV / IV / SV* / PADOFFSET.
* Each of these either contains a set of actions, or an argument, such as
* an IV to use as an array index, or a lexical var to retrieve.
- * Several actions re stored per UV; we keep shifting new actions off the
+ * Several actions are stored per UV; we keep shifting new actions off the
* one UV, and only reload when it becomes zero.
*/
assert(actions);
/* this tells find_uninit_var() where we're up to */
PL_multideref_pc = items;
+ bool replace = FALSE;
while (1) {
- /* there are three main classes of action; the first retrieve
+ /* there are three main classes of action; the first retrieves
* the initial AV or HV from a variable or the stack; the second
* does the equivalent of an unrolled (/DREFAV, rv2av, aelem),
* the third an unrolled (/DREFHV, rv2hv, helem).
case MDEREF_AV_pop_rv2av_aelem: /* expr->[...] */
{
- dSP;
- sv = POPs;
- PUTBACK;
+ sv = *PL_stack_sp;
+ replace = TRUE;
goto do_AV_rv2av_aelem;
}
MAGIC *mg;
HV *stash;
- /* If we can determine whether the element exist,
- * Try to preserve the existenceness of a tied array
+ /* Try to preserve the existence of a tied array
* element by using EXISTS and DELETE if possible.
- * Fallback to FETCH and STORE otherwise. */
+ * Fall back to FETCH and STORE otherwise. */
if (SvCANEXISTDELETE(av))
preeminent = av_exists(av, elem);
}
IV len;
if (!defer)
DIE(aTHX_ PL_no_aelem, elem);
- len = av_tindex(av);
- sv = sv_2mortal(newSVavdefelem(av,
- /* Resolve a negative index now, unless it points
- * before the beginning of the array, in which
- * case record it for error reporting in
- * magic_setdefelem. */
- elem < 0 && len + elem >= 0
- ? len + elem : elem, 1));
+ len = av_top_index(av);
+ /* Resolve a negative index that falls within
+ * the array. Leave it negative it if falls
+ * outside the array. */
+ if (elem < 0 && len + elem >= 0)
+ elem = len + elem;
+ if (elem >= 0 && elem <= len)
+ /* Falls within the array. */
+ sv = av_nonelem(av,elem);
+ else
+ /* Falls outside the array. If it is neg-
+ ative, magic_setdefelem will use the
+ index for error reporting. */
+ sv = sv_2mortal(newSVavdefelem(av,elem,1));
}
else {
if (UNLIKELY(localizing)) {
}
finish:
{
- dSP;
- XPUSHs(sv);
- RETURN;
+ if (replace)
+ rpp_replace_1_1_NN(sv);
+ else
+ rpp_xpush_1(sv);
+ return NORMAL;
}
/* NOTREACHED */
case MDEREF_HV_pop_rv2hv_helem: /* expr->{...} */
{
- dSP;
- sv = POPs;
- PUTBACK;
+ sv = *PL_stack_sp;
+ replace = TRUE;
goto do_HV_rv2hv_helem;
}
MAGIC *mg;
HV *stash;
- /* If we can determine whether the element exist,
- * Try to preserve the existenceness of a tied hash
+ /* Try to preserve the existence of a tied hash
* element by using EXISTS and DELETE if possible.
- * Fallback to FETCH and STORE otherwise. */
+ * Fall back to FETCH and STORE otherwise. */
if (SvCANEXISTDELETE(hv))
preeminent = hv_exists_ent(hv, keysv, 0);
}
SV* key2;
if (!defer)
DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
- lv = sv_newmortal();
- sv_upgrade(lv, SVt_PVLV);
+ lv = newSV_type_mortal(SVt_PVLV);
LvTYPE(lv) = 'y';
sv_magic(lv, key2 = newSVsv(keysv),
PERL_MAGIC_defelem, NULL, 0);
PP(pp_iter)
{
- PERL_CONTEXT *cx;
- SV *oldsv;
- SV **itersvp;
+ PERL_CONTEXT *cx = CX_CUR();
+ SV **itersvp = CxITERVAR(cx);
+ const U8 type = CxTYPE(cx);
+
+ /* Classic "for" syntax iterates one-at-a-time.
+ Many-at-a-time for loops are only for lexicals declared as part of the
+ for loop, and rely on all the lexicals being in adjacent pad slots.
+
+ Curiously, even if the iterator variable is a lexical, the pad offset is
+ stored in the targ slot of the ENTERITER op, meaning that targ of this OP
+ has always been zero. Hence we can use this op's targ to hold "how many"
+ for many-at-a-time. We actually store C<how_many - 1>, so that for the
+ case of one-at-a-time we have zero (as before), as this makes all the
+ logic of the for loop below much simpler, with all the other
+ one-at-a-time cases just falling out of this "naturally". */
+ PADOFFSET how_many = PL_op->op_targ;
+ PADOFFSET i = 0;
- SV *sv;
- AV *av;
- IV ix;
- IV inc;
-
- cx = CX_CUR();
- itersvp = CxITERVAR(cx);
assert(itersvp);
- switch (CxTYPE(cx)) {
+ for (; i <= how_many; ++i ) {
+ SV *oldsv;
+ SV *sv;
+ AV *av;
+ IV ix;
+ IV inc;
+
+ switch (type) {
- case CXt_LOOP_LAZYSV: /* string increment */
- {
- SV* cur = cx->blk_loop.state_u.lazysv.cur;
- SV *end = cx->blk_loop.state_u.lazysv.end;
- /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
- It has SvPVX of "" and SvCUR of 0, which is what we want. */
- STRLEN maxlen = 0;
- const char *max = SvPV_const(end, maxlen);
- if (DO_UTF8(end) && IN_UNI_8_BIT)
- maxlen = sv_len_utf8_nomg(end);
- if (UNLIKELY(SvNIOK(cur) || SvCUR(cur) > maxlen))
- goto retno;
-
- oldsv = *itersvp;
- /* NB: on the first iteration, oldsv will have a ref count of at
- * least 2 (one extra from blk_loop.itersave), so the GV or pad
- * slot will get localised; on subsequent iterations the RC==1
- * optimisation may kick in and the SV will be reused. */
- if (oldsv && LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) {
- /* safe to reuse old SV */
- sv_setsv(oldsv, cur);
- }
- else
- {
- /* we need a fresh SV every time so that loop body sees a
- * completely new SV for closures/references to work as
- * they used to */
- *itersvp = newSVsv(cur);
- SvREFCNT_dec(oldsv);
- }
- if (strEQ(SvPVX_const(cur), max))
- sv_setiv(cur, 0); /* terminate next time */
- else
- sv_inc(cur);
- break;
- }
+ case CXt_LOOP_LAZYSV: /* string increment */
+ {
+ SV* cur = cx->blk_loop.state_u.lazysv.cur;
+ SV *end = cx->blk_loop.state_u.lazysv.end;
+ /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
+ It has SvPVX of "" and SvCUR of 0, which is what we want. */
+ STRLEN maxlen = 0;
+ const char *max = SvPV_const(end, maxlen);
+ bool pad_it = FALSE;
+ if (DO_UTF8(end) && IN_UNI_8_BIT)
+ maxlen = sv_len_utf8_nomg(end);
+ if (UNLIKELY(SvNIOK(cur) || SvCUR(cur) > maxlen)) {
+ if (LIKELY(!i)) {
+ goto retno;
+ }
+ /* We are looping n-at-a-time and the range isn't a multiple
+ of n, so we fill the rest of the lexicals with undef.
+ This only happens on the last iteration of the loop, and
+ we will have already set up the "terminate next time"
+ condition earlier in this for loop for this call of the
+ ITER op when we set up the lexical corresponding to the
+ last value in the range. Hence we don't goto retno (yet),
+ and just below we don't repeat the setup for "terminate
+ next time". */
+ pad_it = TRUE;
+ }
- case CXt_LOOP_LAZYIV: /* integer increment */
- {
- IV cur = cx->blk_loop.state_u.lazyiv.cur;
- if (UNLIKELY(cur > cx->blk_loop.state_u.lazyiv.end))
- goto retno;
+ oldsv = *itersvp;
+ /* NB: on the first iteration, oldsv will have a ref count of at
+ * least 2 (one extra from blk_loop.itersave), so the GV or pad
+ * slot will get localised; on subsequent iterations the RC==1
+ * optimisation may kick in and the SV will be reused. */
+ if (UNLIKELY(pad_it)) {
+ *itersvp = &PL_sv_undef;
+ SvREFCNT_dec(oldsv);
+ }
+ else if (oldsv && LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) {
+ /* safe to reuse old SV */
+ sv_setsv(oldsv, cur);
+ }
+ else {
+ /* we need a fresh SV every time so that loop body sees a
+ * completely new SV for closures/references to work as
+ * they used to */
+ *itersvp = newSVsv(cur);
+ SvREFCNT_dec(oldsv);
+ }
- oldsv = *itersvp;
- /* see NB comment above */
- if (oldsv && LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) {
- /* safe to reuse old SV */
+ if (UNLIKELY(pad_it)) {
+ /* We're "beyond the end" of the iterator here, filling the
+ extra lexicals with undef, so we mustn't do anything
+ (further) to the iterator itself at this point.
+ (Observe how the other two blocks modify the iterator's
+ value) */
+ }
+ else if (strEQ(SvPVX_const(cur), max))
+ sv_setiv(cur, 0); /* terminate next time */
+ else
+ sv_inc(cur);
+ break;
+ }
- if ( (SvFLAGS(oldsv) & (SVTYPEMASK|SVf_THINKFIRST|SVf_IVisUV))
- == SVt_IV)
+ case CXt_LOOP_LAZYIV: /* integer increment */
{
- /* Cheap SvIOK_only().
- * Assert that flags which SvIOK_only() would test or
- * clear can't be set, because we're SVt_IV */
- assert(!(SvFLAGS(oldsv) &
- (SVf_OOK|SVf_UTF8|(SVf_OK & ~(SVf_IOK|SVp_IOK)))));
- SvFLAGS(oldsv) |= (SVf_IOK|SVp_IOK);
- /* SvIV_set() where sv_any points to head */
- oldsv->sv_u.svu_iv = cur;
+ IV cur = cx->blk_loop.state_u.lazyiv.cur;
+ bool pad_it = FALSE;
+ if (UNLIKELY(cur > cx->blk_loop.state_u.lazyiv.end)) {
+ if (LIKELY(!i)) {
+ goto retno;
+ }
+ pad_it = TRUE;
+ }
+
+ oldsv = *itersvp;
+ /* see NB comment above */
+ if (UNLIKELY(pad_it)) {
+ *itersvp = &PL_sv_undef;
+ SvREFCNT_dec(oldsv);
+ }
+ else if (oldsv && LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) {
+ /* safe to reuse old SV */
+
+ if ( (SvFLAGS(oldsv) & (SVTYPEMASK|SVf_THINKFIRST|SVf_IVisUV))
+ == SVt_IV) {
+ /* Cheap SvIOK_only().
+ * Assert that flags which SvIOK_only() would test or
+ * clear can't be set, because we're SVt_IV */
+ assert(!(SvFLAGS(oldsv) &
+ (SVf_OOK|SVf_UTF8|(SVf_OK & ~(SVf_IOK|SVp_IOK)))));
+ SvFLAGS(oldsv) |= (SVf_IOK|SVp_IOK);
+ /* SvIV_set() where sv_any points to head */
+ oldsv->sv_u.svu_iv = cur;
+
+ }
+ else
+ sv_setiv(oldsv, cur);
+ }
+ else {
+ /* we need a fresh SV every time so that loop body sees a
+ * completely new SV for closures/references to work as they
+ * used to */
+ *itersvp = newSViv(cur);
+ SvREFCNT_dec(oldsv);
+ }
+ if (UNLIKELY(pad_it)) {
+ /* We're good (see "We are looping n-at-a-time" comment
+ above). */
+ }
+ else if (UNLIKELY(cur == IV_MAX)) {
+ /* Handle end of range at IV_MAX */
+ cx->blk_loop.state_u.lazyiv.end = IV_MIN;
+ } else
+ ++cx->blk_loop.state_u.lazyiv.cur;
+ break;
}
- else
- sv_setiv(oldsv, cur);
- }
- else
- {
- /* we need a fresh SV every time so that loop body sees a
- * completely new SV for closures/references to work as they
- * used to */
- *itersvp = newSViv(cur);
- SvREFCNT_dec(oldsv);
- }
-
- if (UNLIKELY(cur == IV_MAX)) {
- /* Handle end of range at IV_MAX */
- cx->blk_loop.state_u.lazyiv.end = IV_MIN;
- } else
- ++cx->blk_loop.state_u.lazyiv.cur;
- break;
- }
-
- case CXt_LOOP_LIST: /* for (1,2,3) */
-
- assert(OPpITER_REVERSED == 2); /* so inc becomes -1 or 1 */
- inc = 1 - (PL_op->op_private & OPpITER_REVERSED);
- ix = (cx->blk_loop.state_u.stack.ix += inc);
- if (UNLIKELY(inc > 0
- ? ix > cx->blk_oldsp
- : ix <= cx->blk_loop.state_u.stack.basesp)
- )
- goto retno;
- sv = PL_stack_base[ix];
- av = NULL;
- goto loop_ary_common;
+ case CXt_LOOP_LIST: /* for (1,2,3) */
- case CXt_LOOP_ARY: /* for (@ary) */
+ assert(OPpITER_REVERSED == 2); /* so inc becomes -1 or 1 */
+ inc = (IV)1 - (IV)(PL_op->op_private & OPpITER_REVERSED);
+ ix = (cx->blk_loop.state_u.stack.ix += inc);
+ if (UNLIKELY(inc > 0
+ ? ix > cx->blk_oldsp
+ : ix <= cx->blk_loop.state_u.stack.basesp)
+ ) {
+ if (LIKELY(!i)) {
+ goto retno;
+ }
- av = cx->blk_loop.state_u.ary.ary;
- inc = 1 - (PL_op->op_private & OPpITER_REVERSED);
- ix = (cx->blk_loop.state_u.ary.ix += inc);
- if (UNLIKELY(inc > 0
- ? ix > AvFILL(av)
- : ix < 0)
- )
- goto retno;
+ sv = &PL_sv_undef;
+ }
+ else {
+ sv = PL_stack_base[ix];
+ }
- if (UNLIKELY(SvRMAGICAL(av))) {
- SV * const * const svp = av_fetch(av, ix, FALSE);
- sv = svp ? *svp : NULL;
- }
- else {
- sv = AvARRAY(av)[ix];
- }
+ av = NULL;
+ goto loop_ary_common;
- loop_ary_common:
+ case CXt_LOOP_ARY: /* for (@ary) */
- if (UNLIKELY(cx->cx_type & CXp_FOR_LVREF)) {
- SvSetMagicSV(*itersvp, sv);
- break;
- }
+ av = cx->blk_loop.state_u.ary.ary;
+ inc = (IV)1 - (IV)(PL_op->op_private & OPpITER_REVERSED);
+ ix = (cx->blk_loop.state_u.ary.ix += inc);
+ if (UNLIKELY(inc > 0
+ ? ix > AvFILL(av)
+ : ix < 0)
+ ) {
+ if (LIKELY(!i)) {
+ goto retno;
+ }
- if (LIKELY(sv)) {
- if (UNLIKELY(SvIS_FREED(sv))) {
- *itersvp = NULL;
- Perl_croak(aTHX_ "Use of freed value in iteration");
- }
- if (SvPADTMP(sv)) {
- sv = newSVsv(sv);
+ sv = &PL_sv_undef;
+ } else if (UNLIKELY(SvRMAGICAL(av))) {
+ SV * const * const svp = av_fetch(av, ix, FALSE);
+ sv = svp ? *svp : NULL;
}
else {
- SvTEMP_off(sv);
- SvREFCNT_inc_simple_void_NN(sv);
+ sv = AvARRAY(av)[ix];
}
- }
- else if (av) {
- sv = newSVavdefelem(av, ix, 0);
- }
- else
- sv = &PL_sv_undef;
- oldsv = *itersvp;
- *itersvp = sv;
- SvREFCNT_dec(oldsv);
- break;
+ loop_ary_common:
+
+ if (UNLIKELY(cx->cx_type & CXp_FOR_LVREF)) {
+ SvSetMagicSV(*itersvp, sv);
+ break;
+ }
+
+ if (LIKELY(sv)) {
+ if (UNLIKELY(SvIS_FREED(sv))) {
+ *itersvp = NULL;
+ Perl_croak(aTHX_ "Use of freed value in iteration");
+ }
+ if (SvPADTMP(sv)) {
+ sv = newSVsv(sv);
+ }
+ else {
+ SvTEMP_off(sv);
+ SvREFCNT_inc_simple_void_NN(sv);
+ }
+ }
+ else if (av) {
+ sv = newSVavdefelem(av, ix, 0);
+ }
+ else
+ sv = &PL_sv_undef;
+
+ oldsv = *itersvp;
+ *itersvp = sv;
+ SvREFCNT_dec(oldsv);
+ break;
+
+ default:
+ DIE(aTHX_ "panic: pp_iter, type=%u", CxTYPE(cx));
+ }
- default:
- DIE(aTHX_ "panic: pp_iter, type=%u", CxTYPE(cx));
+ /* Only relevant for a many-at-a-time loop: */
+ ++itersvp;
}
- /* Bypass pushing &PL_sv_yes and calling pp_and(); instead
+ /* Try to bypass pushing &PL_sv_yes and calling pp_and(); instead
* jump straight to the AND op's op_other */
assert(PL_op->op_next->op_type == OP_AND);
- assert(PL_op->op_next->op_ppaddr == Perl_pp_and);
- return cLOGOPx(PL_op->op_next)->op_other;
+ if (PL_op->op_next->op_ppaddr == Perl_pp_and) {
+ return cLOGOPx(PL_op->op_next)->op_other;
+ }
+ else {
+ /* An XS module has replaced the op_ppaddr, so fall back to the slow,
+ * obvious way. */
+ /* pp_enteriter should have pre-extended the stack */
+ EXTEND_SKIP(PL_stack_sp, 1);
+ rpp_push_IMM(&PL_sv_yes);
+ return PL_op->op_next;
+ }
retno:
- /* Bypass pushing &PL_sv_no and calling pp_and(); instead
+ /* Try to bypass pushing &PL_sv_no and calling pp_and(); instead
* jump straight to the AND op's op_next */
assert(PL_op->op_next->op_type == OP_AND);
- assert(PL_op->op_next->op_ppaddr == Perl_pp_and);
/* pp_enteriter should have pre-extended the stack */
EXTEND_SKIP(PL_stack_sp, 1);
/* we only need this for the rare case where the OP_AND isn't
* in void context, e.g. $x = do { for (..) {...} };
- * but its cheaper to just push it rather than testing first
+ * (or for when an XS module has replaced the op_ppaddr)
+ * but it's cheaper to just push it rather than testing first
*/
- *++PL_stack_sp = &PL_sv_no;
- return PL_op->op_next->op_next;
+ rpp_push_IMM(&PL_sv_no);
+ if (PL_op->op_next->op_ppaddr == Perl_pp_and) {
+ return PL_op->op_next->op_next;
+ }
+ else {
+ /* An XS module has replaced the op_ppaddr, so fall back to the slow,
+ * obvious way. */
+ return PL_op->op_next;
+ }
}
/*
A description of how taint works in pattern matching and substitution.
-This is all conditional on NO_TAINT_SUPPORT not being defined. Under
-NO_TAINT_SUPPORT, taint-related operations should become no-ops.
+This is all conditional on NO_TAINT_SUPPORT remaining undefined (the default).
+Under NO_TAINT_SUPPORT, taint-related operations should become no-ops.
While the pattern is being assembled/concatenated and then compiled,
PL_tainted will get set (via TAINT_set) if any component of the pattern
according to the rules below:
* the return value (not including /r):
- tainted by the source string and pattern, but only for the
- number-of-iterations case; boolean returns aren't tainted;
+ tainted by the source string and pattern, but only for the
+ number-of-iterations case; boolean returns aren't tainted;
* the modified string (or modified copy under /r):
- tainted by the source string, pattern, and replacement strings;
+ tainted by the source string, pattern, and replacement strings;
* $1 et al:
- tainted by the pattern, and under 'use re "taint"', by the source
- string too;
+ tainted by the pattern, and under 'use re "taint"', by the source
+ string too;
* PL_taint - i.e. whether subsequent code (e.g. in a /e block) is tainted:
- should always be unset before executing subsequent code.
+ should always be unset before executing subsequent code.
The overall action of pp_subst is:
* at the start, set bits in rxtainted indicating the taint status of
- the various sources.
+ the various sources.
* After each pattern execution, update the SUBST_TAINT_PAT bit in
- rxtainted if RXf_TAINTED_SEEN has been set, to indicate that the
- pattern has subsequently become tainted via locale ops.
+ rxtainted if RXf_TAINTED_SEEN has been set, to indicate that the
+ pattern has subsequently become tainted via locale ops.
* If control is being passed to pp_substcont to execute a /e block,
- save rxtainted in the CXt_SUBST block, for future use by
- pp_substcont.
+ save rxtainted in the CXt_SUBST block, for future use by
+ pp_substcont.
* Whenever control is being returned to perl code (either by falling
- off the "end" of pp_subst/pp_substcont, or by entering a /e block),
- use the flag bits in rxtainted to make all the appropriate types of
- destination taint visible; e.g. set RXf_TAINTED_SEEN so that $1
- et al will appear tainted.
+ off the "end" of pp_subst/pp_substcont, or by entering a /e block),
+ use the flag bits in rxtainted to make all the appropriate types of
+ destination taint visible; e.g. set RXf_TAINTED_SEEN so that $1
+ et al will appear tainted.
pp_match is just a simpler version of the above.
PP(pp_subst)
{
- dSP; dTARG;
+ dTARG;
PMOP *pm = cPMOP;
PMOP *rpm = pm;
char *s;
SSize_t maxiters;
bool once;
U8 rxtainted = 0; /* holds various SUBST_TAINT_* flag bits.
- See "how taint works" above */
+ See "how taint works" above */
char *orig;
U8 r_flags;
REGEXP *rx = PM_GETRE(pm);
STRLEN len;
int force_on_match = 0;
const I32 oldsave = PL_savestack_ix;
- STRLEN slen;
bool doutf8 = FALSE; /* whether replacement is in utf8 */
#ifdef PERL_ANY_COW
bool was_cow;
#endif
SV *nsv = NULL;
- /* known replacement string? */
- SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
+ SSize_t sp_offset = 0; /* number of items left on stack */
+ SV *dstr;
+ SV *retval;
PERL_ASYNC_CHECK();
- if (PL_op->op_flags & OPf_STACKED)
- TARG = POPs;
+ if (pm->op_pmflags & PMf_CONST) {
+ /* known replacement string */
+ dstr = *PL_stack_sp;
+ sp_offset++;
+ }
+ else
+ dstr = NULL;
+
+ if (PL_op->op_flags & OPf_STACKED) {
+ /* expr =~ s///; */
+ TARG = PL_stack_sp[-sp_offset];
+ sp_offset++;
+ }
else {
if (ARGTARG)
+ /* $lex =~ s///; */
GETTARGET;
else {
+ /* s///; */
TARG = DEFSV;
}
- EXTEND(SP,1);
+ if (!sp_offset)
+ rpp_extend(1);
}
SvGETMAGIC(TARG); /* must come before cow check */
#endif
if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) {
#ifndef PERL_ANY_COW
- if (SvIsCOW(TARG))
- sv_force_normal_flags(TARG,0);
+ if (SvIsCOW(TARG))
+ sv_force_normal_flags(TARG,0);
#endif
- if ((SvREADONLY(TARG)
- || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
- || SvTYPE(TARG) > SVt_PVLV)
- && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
- Perl_croak_no_modify();
+ if ((SvREADONLY(TARG)
+ || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
+ || SvTYPE(TARG) > SVt_PVLV)
+ && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
+ Perl_croak_no_modify();
}
- PUTBACK;
orig = SvPV_nomg(TARG, len);
/* note we don't (yet) force the var into being a string; if we fail
* to match, we leave as-is; on successful match however, we *will*
* coerce into a string, then repeat the match */
if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV || SvVOK(TARG))
- force_on_match = 1;
+ force_on_match = 1;
/* only replace once? */
once = !(rpm->op_pmflags & PMf_GLOBAL);
/* See "how taint works" above */
if (TAINTING_get) {
- rxtainted = (
- (SvTAINTED(TARG) ? SUBST_TAINT_STR : 0)
- | (RXp_ISTAINTED(prog) ? SUBST_TAINT_PAT : 0)
- | ((pm->op_pmflags & PMf_RETAINT) ? SUBST_TAINT_RETAINT : 0)
- | (( (once && !(rpm->op_pmflags & PMf_NONDESTRUCT))
+ rxtainted = (
+ (SvTAINTED(TARG) ? SUBST_TAINT_STR : 0)
+ | (RXp_ISTAINTED(prog) ? SUBST_TAINT_PAT : 0)
+ | ((pm->op_pmflags & PMf_RETAINT) ? SUBST_TAINT_RETAINT : 0)
+ | (( (once && !(rpm->op_pmflags & PMf_NONDESTRUCT))
|| (PL_op->op_private & OPpTRUEBOOL)) ? SUBST_TAINT_BOOLRET : 0));
- TAINT_NOT;
+ TAINT_NOT;
}
force_it:
if (!pm || !orig)
- DIE(aTHX_ "panic: pp_subst, pm=%p, orig=%p", pm, orig);
+ DIE(aTHX_ "panic: pp_subst, pm=%p, orig=%p", pm, orig);
strend = orig + len;
- slen = DO_UTF8(TARG) ? utf8_length((U8*)orig, (U8*)strend) : len;
- maxiters = 2 * slen + 10; /* We can match twice at each
- position, once with zero-length,
- second time with non-zero. */
+ /* We can match twice at each position, once with zero-length,
+ * second time with non-zero.
+ * Don't handle utf8 specially; we can use length-in-bytes as an
+ * upper bound on length-in-characters, and avoid the cpu-cost of
+ * computing a tighter bound. */
+ maxiters = 2 * len + 10;
/* handle the empty pattern */
if (!RX_PRELEN(rx) && PL_curpm && !prog->mother_re) {
if (!CALLREGEXEC(rx, orig, strend, orig, 0, TARG, NULL, r_flags))
{
- SPAGAIN;
- PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_no);
- LEAVE_SCOPE(oldsave);
- RETURN;
+ SV *ret = rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_no;
+ if (dstr)
+ rpp_popfree_1_NN(); /* pop replacement string */
+ if (PL_op->op_flags & OPf_STACKED)
+ rpp_replace_1_1_NN(ret); /* pop LHS of =~ */
+ else
+ rpp_push_1(ret);
+ LEAVE_SCOPE(oldsave);
+ return NORMAL;
}
PL_curpm = pm;
/* known replacement string? */
if (dstr) {
- /* replacement needing upgrading? */
- if (DO_UTF8(TARG) && !doutf8) {
- nsv = sv_newmortal();
- SvSetSV(nsv, dstr);
- sv_utf8_upgrade(nsv);
- c = SvPV_const(nsv, clen);
- doutf8 = TRUE;
- }
- else {
- c = SvPV_const(dstr, clen);
- doutf8 = DO_UTF8(dstr);
- }
-
- if (UNLIKELY(TAINT_get))
- rxtainted |= SUBST_TAINT_REPL;
+ /* replacement needing upgrading? */
+ if (DO_UTF8(TARG) && !doutf8) {
+ nsv = sv_newmortal();
+ SvSetSV(nsv, dstr);
+ sv_utf8_upgrade(nsv);
+ c = SvPV_const(nsv, clen);
+ doutf8 = TRUE;
+ }
+ else {
+ c = SvPV_const(dstr, clen);
+ doutf8 = DO_UTF8(dstr);
+ }
+
+ if (UNLIKELY(TAINT_get))
+ rxtainted |= SUBST_TAINT_REPL;
}
else {
- c = NULL;
- doutf8 = FALSE;
+ c = NULL;
+ doutf8 = FALSE;
}
- /* can do inplace substitution? */
if (c
#ifdef PERL_ANY_COW
- && !was_cow
+ && !was_cow
#endif
- && (I32)clen <= RXp_MINLENRET(prog)
+ && (SSize_t)clen <= RXp_MINLENRET(prog)
&& ( once
|| !(r_flags & REXEC_COPY_STR)
|| (!SvGMAGICAL(dstr) && !(RXp_EXTFLAGS(prog) & RXf_EVAL_SEEN))
)
&& !(RXp_EXTFLAGS(prog) & RXf_NO_INPLACE_SUBST)
- && (!doutf8 || SvUTF8(TARG))
- && !(rpm->op_pmflags & PMf_NONDESTRUCT))
+ && (!doutf8 || SvUTF8(TARG))
+ && !(rpm->op_pmflags & PMf_NONDESTRUCT))
{
+ /* known replacement string and can do in-place substitution */
#ifdef PERL_ANY_COW
/* string might have got converted to COW since we set was_cow */
- if (SvIsCOW(TARG)) {
- if (!force_on_match)
- goto have_a_cow;
- assert(SvVOK(TARG));
- }
+ if (SvIsCOW(TARG)) {
+ if (!force_on_match)
+ goto have_a_cow;
+ assert(SvVOK(TARG));
+ }
#endif
- if (force_on_match) {
+ if (force_on_match) {
/* redo the first match, this time with the orig var
* forced into being a string */
- force_on_match = 0;
- orig = SvPV_force_nomg(TARG, len);
- goto force_it;
- }
+ force_on_match = 0;
+ orig = SvPV_force_nomg(TARG, len);
+ goto force_it;
+ }
- if (once) {
+ if (once) {
char *d, *m;
- if (RXp_MATCH_TAINTED(prog)) /* run time pattern taint, eg locale */
- rxtainted |= SUBST_TAINT_PAT;
- m = orig + RXp_OFFS(prog)[0].start;
- d = orig + RXp_OFFS(prog)[0].end;
- s = orig;
- if (m - s > strend - d) { /* faster to shorten from end */
- I32 i;
- if (clen) {
- Copy(c, m, clen, char);
- m += clen;
- }
- i = strend - d;
- if (i > 0) {
- Move(d, m, i, char);
- m += i;
- }
- *m = '\0';
- SvCUR_set(TARG, m - s);
- }
- else { /* faster from front */
- I32 i = m - s;
- d -= clen;
+ if (RXp_MATCH_TAINTED(prog)) /* run time pattern taint, eg locale */
+ rxtainted |= SUBST_TAINT_PAT;
+ m = orig + RXp_OFFS_START(prog,0);
+ d = orig + RXp_OFFS_END(prog,0);
+ s = orig;
+ if (m - s > strend - d) { /* faster to shorten from end */
+ SSize_t i;
+ if (clen) {
+ Copy(c, m, clen, char);
+ m += clen;
+ }
+ i = strend - d;
+ if (i > 0) {
+ Move(d, m, i, char);
+ m += i;
+ }
+ *m = '\0';
+ SvCUR_set(TARG, m - s);
+ }
+ else { /* faster from front */
+ SSize_t i = m - s;
+ d -= clen;
if (i > 0)
Move(s, d - i, i, char);
- sv_chop(TARG, d-i);
- if (clen)
- Copy(c, d, clen, char);
- }
- SPAGAIN;
- PUSHs(&PL_sv_yes);
- }
- else {
+ sv_chop(TARG, d-i);
+ if (clen)
+ Copy(c, d, clen, char);
+ }
+ retval = &PL_sv_yes;
+ goto ret;
+ }
+ else {
char *d, *m;
- d = s = RXp_OFFS(prog)[0].start + orig;
- do {
- I32 i;
- if (UNLIKELY(iters++ > maxiters))
- DIE(aTHX_ "Substitution loop");
+ d = s = RXp_OFFS_START(prog,0) + orig;
+ do {
+ SSize_t i;
+ if (UNLIKELY(iters++ > maxiters))
+ DIE(aTHX_ "Substitution loop");
/* run time pattern taint, eg locale */
- if (UNLIKELY(RXp_MATCH_TAINTED(prog)))
- rxtainted |= SUBST_TAINT_PAT;
- m = RXp_OFFS(prog)[0].start + orig;
- if ((i = m - s)) {
- if (s != d)
- Move(s, d, i, char);
- d += i;
- }
- if (clen) {
- Copy(c, d, clen, char);
- d += clen;
- }
- s = RXp_OFFS(prog)[0].end + orig;
- } while (CALLREGEXEC(rx, s, strend, orig,
- s == m, /* don't match same null twice */
- TARG, NULL,
+ if (UNLIKELY(RXp_MATCH_TAINTED(prog)))
+ rxtainted |= SUBST_TAINT_PAT;
+ m = RXp_OFFS_START(prog,0) + orig;
+ if ((i = m - s)) {
+ if (s != d)
+ Move(s, d, i, char);
+ d += i;
+ }
+ if (clen) {
+ Copy(c, d, clen, char);
+ d += clen;
+ }
+ s = RXp_OFFS_END(prog,0) + orig;
+ } while (CALLREGEXEC(rx, s, strend, orig,
+ s == m, /* don't match same null twice */
+ TARG, NULL,
REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
- if (s != d) {
- I32 i = strend - s;
- SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
- Move(s, d, i+1, char); /* include the NUL */
- }
- SPAGAIN;
+ if (s != d) {
+ SSize_t i = strend - s;
+ SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
+ Move(s, d, i+1, char); /* include the NUL */
+ }
assert(iters);
- if (PL_op->op_private & OPpTRUEBOOL)
- PUSHs(&PL_sv_yes);
- else
- mPUSHi(iters);
- }
+ goto ret_iters;
+ }
}
else {
- bool first;
+ /* not known replacement string or can't do in-place substitution) */
+ bool first;
char *m;
- SV *repl;
- if (force_on_match) {
+ SV *repl;
+ if (force_on_match) {
/* redo the first match, this time with the orig var
* forced into being a string */
- force_on_match = 0;
- if (rpm->op_pmflags & PMf_NONDESTRUCT) {
- /* I feel that it should be possible to avoid this mortal copy
- given that the code below copies into a new destination.
- However, I suspect it isn't worth the complexity of
- unravelling the C<goto force_it> for the small number of
- cases where it would be viable to drop into the copy code. */
- TARG = sv_2mortal(newSVsv(TARG));
- }
- orig = SvPV_force_nomg(TARG, len);
- goto force_it;
- }
+ force_on_match = 0;
+ if (rpm->op_pmflags & PMf_NONDESTRUCT) {
+ /* I feel that it should be possible to avoid this mortal copy
+ given that the code below copies into a new destination.
+ However, I suspect it isn't worth the complexity of
+ unravelling the C<goto force_it> for the small number of
+ cases where it would be viable to drop into the copy code. */
+ TARG = sv_2mortal(newSVsv(TARG));
+ }
+ orig = SvPV_force_nomg(TARG, len);
+ goto force_it;
+ }
#ifdef PERL_ANY_COW
have_a_cow:
#endif
- if (RXp_MATCH_TAINTED(prog)) /* run time pattern taint, eg locale */
- rxtainted |= SUBST_TAINT_PAT;
- repl = dstr;
- s = RXp_OFFS(prog)[0].start + orig;
- dstr = newSVpvn_flags(orig, s-orig,
+ if (RXp_MATCH_TAINTED(prog)) /* run time pattern taint, eg locale */
+ rxtainted |= SUBST_TAINT_PAT;
+ repl = dstr;
+ s = RXp_OFFS_START(prog,0) + orig;
+ dstr = newSVpvn_flags(orig, s-orig,
SVs_TEMP | (DO_UTF8(TARG) ? SVf_UTF8 : 0));
- if (!c) {
- PERL_CONTEXT *cx;
- SPAGAIN;
+ if (!c) {
+ /* not known replacement string - call out to ops and OP_SUBSTCONT */
+ PERL_CONTEXT *cx;
m = orig;
- /* note that a whole bunch of local vars are saved here for
- * use by pp_substcont: here's a list of them in case you're
- * searching for places in this sub that uses a particular var:
- * iters maxiters r_flags oldsave rxtainted orig dstr targ
- * s m strend rx once */
- CX_PUSHSUBST(cx);
- RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
- }
- first = TRUE;
- do {
- if (UNLIKELY(iters++ > maxiters))
- DIE(aTHX_ "Substitution loop");
- if (UNLIKELY(RXp_MATCH_TAINTED(prog)))
- rxtainted |= SUBST_TAINT_PAT;
- if (RXp_MATCH_COPIED(prog) && RXp_SUBBEG(prog) != orig) {
- char *old_s = s;
- char *old_orig = orig;
+ /* note that a whole bunch of local vars are saved here for
+ * use by pp_substcont: here's a list of them in case you're
+ * searching for places in this sub that uses a particular var:
+ * iters maxiters r_flags oldsave rxtainted orig dstr targ
+ * s m strend rx once */
+ CX_PUSHSUBST(cx);
+ return cPMOP->op_pmreplrootu.op_pmreplroot;
+ }
+
+ /* We get here if it's a known replacement string, but can't
+ * substitute in-place */
+
+ first = TRUE;
+ do {
+ if (UNLIKELY(iters++ > maxiters))
+ DIE(aTHX_ "Substitution loop");
+ if (UNLIKELY(RXp_MATCH_TAINTED(prog)))
+ rxtainted |= SUBST_TAINT_PAT;
+ if (RXp_MATCH_COPIED(prog) && RXp_SUBBEG(prog) != orig) {
+ char *old_s = s;
+ char *old_orig = orig;
assert(RXp_SUBOFFSET(prog) == 0);
- orig = RXp_SUBBEG(prog);
- s = orig + (old_s - old_orig);
- strend = s + (strend - old_s);
- }
- m = RXp_OFFS(prog)[0].start + orig;
- sv_catpvn_nomg_maybeutf8(dstr, s, m - s, DO_UTF8(TARG));
- s = RXp_OFFS(prog)[0].end + orig;
- if (first) {
- /* replacement already stringified */
- if (clen)
- sv_catpvn_nomg_maybeutf8(dstr, c, clen, doutf8);
- first = FALSE;
- }
- else {
- sv_catsv(dstr, repl);
- }
- if (once)
- break;
- } while (CALLREGEXEC(rx, s, strend, orig,
+ orig = RXp_SUBBEG(prog);
+ s = orig + (old_s - old_orig);
+ strend = s + (strend - old_s);
+ }
+ m = RXp_OFFS_START(prog,0) + orig;
+ sv_catpvn_nomg_maybeutf8(dstr, s, m - s, DO_UTF8(TARG));
+ s = RXp_OFFS_END(prog,0) + orig;
+ if (first) {
+ /* replacement already stringified */
+ if (clen)
+ sv_catpvn_nomg_maybeutf8(dstr, c, clen, doutf8);
+ first = FALSE;
+ }
+ else {
+ sv_catsv(dstr, repl);
+ }
+ if (once)
+ break;
+ } while (CALLREGEXEC(rx, s, strend, orig,
s == m, /* Yields minend of 0 or 1 */
- TARG, NULL,
+ TARG, NULL,
REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
assert(strend >= s);
- sv_catpvn_nomg_maybeutf8(dstr, s, strend - s, DO_UTF8(TARG));
-
- if (rpm->op_pmflags & PMf_NONDESTRUCT) {
- /* From here on down we're using the copy, and leaving the original
- untouched. */
- TARG = dstr;
- SPAGAIN;
- PUSHs(dstr);
- } else {
+ sv_catpvn_nomg_maybeutf8(dstr, s, strend - s, DO_UTF8(TARG));
+
+ if (rpm->op_pmflags & PMf_NONDESTRUCT) {
+ /* From here on down we're using the copy, and leaving the original
+ untouched. */
+ TARG = dstr;
+ retval = dstr;
+ goto ret;
+ } else {
#ifdef PERL_ANY_COW
- /* The match may make the string COW. If so, brilliant, because
- that's just saved us one malloc, copy and free - the regexp has
- donated the old buffer, and we malloc an entirely new one, rather
- than the regexp malloc()ing a buffer and copying our original,
- only for us to throw it away here during the substitution. */
- if (SvIsCOW(TARG)) {
- sv_force_normal_flags(TARG, SV_COW_DROP_PV);
- } else
+ /* The match may make the string COW. If so, brilliant, because
+ that's just saved us one malloc, copy and free - the regexp has
+ donated the old buffer, and we malloc an entirely new one, rather
+ than the regexp malloc()ing a buffer and copying our original,
+ only for us to throw it away here during the substitution. */
+ 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));
- SvFLAGS(TARG) |= SvUTF8(dstr);
- SvPV_set(dstr, NULL);
-
- SPAGAIN;
- if (PL_op->op_private & OPpTRUEBOOL)
- PUSHs(&PL_sv_yes);
- else
- mPUSHi(iters);
- }
+ {
+ SvPV_free(TARG);
+ }
+ SvPV_set(TARG, SvPVX(dstr));
+ SvCUR_set(TARG, SvCUR(dstr));
+ SvLEN_set(TARG, SvLEN(dstr));
+ SvFLAGS(TARG) |= SvUTF8(dstr);
+ SvPV_set(dstr, NULL);
+ goto ret_iters;
+ }
+ }
+
+ ret_iters:
+ if (PL_op->op_private & OPpTRUEBOOL)
+ retval = &PL_sv_yes;
+ else {
+ retval = sv_newmortal();
+ sv_setiv(retval, iters);
}
+ ret:
+ if (dstr)
+ rpp_popfree_1_NN(); /* pop replacement string */
+ if (PL_op->op_flags & OPf_STACKED)
+ rpp_replace_1_1_NN(retval); /* pop LHS of =~ */
+ else
+ rpp_push_1(retval);
+
if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) {
- (void)SvPOK_only_UTF8(TARG);
+ (void)SvPOK_only_UTF8(TARG);
}
/* See "how taint works" above */
if (TAINTING_get) {
- if ((rxtainted & SUBST_TAINT_PAT) ||
- ((rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) ==
- (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
- )
- (RXp_MATCH_TAINTED_on(prog)); /* taint $1 et al */
-
- if (!(rxtainted & SUBST_TAINT_BOOLRET)
- && (rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
- )
- SvTAINTED_on(TOPs); /* taint return value */
- else
- SvTAINTED_off(TOPs); /* may have got tainted earlier */
-
- /* needed for mg_set below */
- TAINT_set(
- cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))
+ if ((rxtainted & SUBST_TAINT_PAT) ||
+ ((rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) ==
+ (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
+ )
+ (RXp_MATCH_TAINTED_on(prog)); /* taint $1 et al */
+
+ if (!(rxtainted & SUBST_TAINT_BOOLRET)
+ && (rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
+ )
+ SvTAINTED_on(retval); /* taint return value */
+ else
+ SvTAINTED_off(retval); /* may have got tainted earlier */
+
+ /* needed for mg_set below */
+ TAINT_set(
+ cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))
);
- SvTAINT(TARG);
+ SvTAINT(TARG);
}
SvSETMAGIC(TARG); /* PL_tainted must be correctly set for this mg_set */
TAINT_NOT;
LEAVE_SCOPE(oldsave);
- RETURN;
+ return NORMAL;
}
+
PP(pp_grepwhile)
{
- dSP;
- dPOPss;
+ /* Understanding the stack during a grep.
+ *
+ * 'grep expr, args' is implemented in the form of
+ * grepstart;
+ * do {
+ * expr;
+ * grepwhile;
+ * } while (args);
+ *
+ * The stack examples below are in the form of 'perl -Ds' output,
+ * where any stack element indexed by PL_markstack_ptr[i] has a star
+ * just to the right of it. In addition, the corresponding i value
+ * is displayed under the indexed stack element.
+ *
+ * On entry to grepwhile, the stack looks like this:
+ *
+ * => * M1..Mn X1 * X2..Xn C * R1..Rn BOOL
+ * [-2] [-1] [0]
+ *
+ * where:
+ * M1..Mn Accumulated args which have been matched so far.
+ * X1..Xn Random discardable elements from previous iterations.
+ * C The current (just processed) arg, still aliased to $_.
+ * R1..Rn The args remaining to be processed.
+ * BOOL the result of the just-executed grep expression.
+ *
+ * Note that it is easiest to think of the top two stack marks as both
+ * being one too high, and so it would make more sense to have had the
+ * marks like this:
+ *
+ * => * M1..Mn * X1..Xn * C R1..Rn BOOL
+ * [-2] [-1] [0]
+ *
+ * where the stack is divided neatly into 3 groups:
+ * - matched,
+ * - discarded,
+ * - being, or yet to be, processed.
+ * But off-by-one is the way it is currently, and it works as long as
+ * we keep it consistent and bear it in mind.
+ *
+ * pp_grepwhile() does the following:
+ *
+ * - for a match, replace the X1 pointer with a pointer to C and bump
+ * PL_markstack_ptr[-1]
+ * - if more args to process, bump PL_markstack_ptr[0] and update the
+ * $_ alias, else
+ * - remove top 3 MARKs and return M1..Mn, or a scalar,
+ * or void as appropriate.
+ *
+ */
+
+ bool match = SvTRUE_NN(*PL_stack_sp);
+ rpp_popfree_1_NN();
+
+ if (match) {
+ SV **from_p = PL_stack_base + PL_markstack_ptr[0];
+ SV **to_p = PL_stack_base + PL_markstack_ptr[-1]++;
+ SV *from = *from_p;
+ SV *to = *to_p;
+
+ if (from != to) {
+ *to_p = from;
+#ifdef PERL_RC_STACK
+ SvREFCNT_inc_simple_void_NN(from);
+ SvREFCNT_dec(to);
+#endif
+ }
+ }
- if (SvTRUE_NN(sv))
- PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
++*PL_markstack_ptr;
FREETMPS;
LEAVE_with_name("grep_item"); /* exit inner scope */
/* All done yet? */
- if (UNLIKELY(PL_stack_base + *PL_markstack_ptr > SP)) {
- I32 items;
- const U8 gimme = GIMME_V;
-
- LEAVE_with_name("grep"); /* exit outer scope */
- (void)POPMARK; /* pop src */
- items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
- (void)POPMARK; /* pop dst */
- SP = PL_stack_base + POPMARK; /* pop original mark */
- if (gimme == G_SCALAR) {
- if (PL_op->op_private & OPpTRUEBOOL)
- PUSHs(items ? &PL_sv_yes : &PL_sv_zero);
- else {
- dTARGET;
- PUSHi(items);
+ if (UNLIKELY(PL_stack_base + *PL_markstack_ptr > PL_stack_sp)) {
+ SSize_t items;
+ const U8 gimme = GIMME_V;
+
+ LEAVE_with_name("grep"); /* exit outer scope */
+ (void)POPMARK; /* pop src */
+ items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
+ (void)POPMARK; /* pop dst */
+ SV **base = PL_stack_base + POPMARK; /* pop original mark */
+
+ if (gimme == G_LIST)
+ rpp_popfree_to_NN(base + items);
+ else {
+ rpp_popfree_to_NN(base);
+ if (gimme == G_SCALAR) {
+ if (PL_op->op_private & OPpTRUEBOOL)
+ rpp_push_IMM(items ? &PL_sv_yes : &PL_sv_zero);
+ else {
+ dTARGET;
+ TARGi(items,1);
+ rpp_push_1(TARG);
+ }
}
- }
- else if (gimme == G_ARRAY)
- SP += items;
- RETURN;
+ }
+
+ return NORMAL;
}
else {
- SV *src;
-
- ENTER_with_name("grep_item"); /* enter inner scope */
- SAVEVPTR(PL_curpm);
-
- src = PL_stack_base[TOPMARK];
- if (SvPADTMP(src)) {
- src = PL_stack_base[TOPMARK] = sv_mortalcopy(src);
- PL_tmps_floor++;
- }
- SvTEMP_off(src);
- DEFSV_set(src);
+ SV *src;
+
+ ENTER_with_name("grep_item"); /* enter inner scope */
+ SAVEVPTR(PL_curpm);
+
+ src = PL_stack_base[TOPMARK];
+ if (SvPADTMP(src)) {
+ SV *newsrc = sv_mortalcopy(src);
+ PL_stack_base[TOPMARK] = newsrc;
+#ifdef PERL_RC_STACK
+ SvREFCNT_inc_simple_void_NN(newsrc);
+ SvREFCNT_dec(src);
+#endif
+ src = newsrc;
+ PL_tmps_floor++;
+ }
+ SvTEMP_off(src);
+ DEFSV_set(src);
- RETURNOP(cLOGOP->op_other);
+ return cLOGOP->op_other;
}
}
+
/* leave_adjust_stacks():
*
* Process a scope's return args (in the range from_sp+1 .. PL_stack_sp),
void
Perl_leave_adjust_stacks(pTHX_ SV **from_sp, SV **to_sp, U8 gimme, int pass)
{
- dVAR;
- dSP;
SSize_t tmps_base; /* lowest index into tmps stack that needs freeing now */
SSize_t nargs;
TAINT_NOT;
- if (gimme == G_ARRAY) {
- nargs = SP - from_sp;
+ if (gimme == G_LIST) {
+ nargs = PL_stack_sp - from_sp;
from_sp++;
}
else {
assert(gimme == G_SCALAR);
- if (UNLIKELY(from_sp >= SP)) {
+ if (UNLIKELY(from_sp >= PL_stack_sp)) {
/* no return args */
- assert(from_sp == SP);
- EXTEND(SP, 1);
- *++SP = &PL_sv_undef;
- to_sp = SP;
- nargs = 0;
+ assert(from_sp == PL_stack_sp);
+ rpp_xpush_IMM(&PL_sv_undef);
}
- else {
- from_sp = SP;
- nargs = 1;
+ from_sp = PL_stack_sp;
+ nargs = 1;
+ }
+
+ /* common code for G_SCALAR and G_LIST */
+
+#ifdef PERL_RC_STACK
+ {
+ /* free any items from the stack which are about to get
+ * over-written */
+ SV **p = from_sp - 1;
+ assert(p >= to_sp);
+ while (p > to_sp) {
+ SV *sv = *p;
+ *p-- = NULL;
+ SvREFCNT_dec(sv);
}
}
+#endif
- /* common code for G_SCALAR and G_ARRAY */
tmps_base = PL_tmps_floor + 1;
#endif
if (
- pass == 0 ? (SvTEMP(sv) && !SvMAGICAL(sv) && SvREFCNT(sv) == 1)
+ pass == 0 ? (rpp_is_lone(sv) && !SvMAGICAL(sv))
: pass == 1 ? ((SvTEMP(sv) || SvPADTMP(sv)) && !SvMAGICAL(sv) && SvREFCNT(sv) == 1)
: pass == 2 ? (!SvPADTMP(sv))
: 1)
{
/* pass through: skip copy for logic or optimisation
* reasons; instead mortalise it, except that ... */
+
+#ifdef PERL_RC_STACK
+ from_sp[-1] = NULL;
+#endif
*++to_sp = sv;
if (SvTEMP(sv)) {
* ++PL_tmps_ix, moving the previous occupant there
* instead.
*/
- SV *newsv = newSV(0);
+ SV *newsv = newSV_type(SVt_NULL);
PL_tmps_stack[++PL_tmps_ix] = *tmps_basep;
/* put it on the tmps stack early so it gets freed if we die */
*tmps_basep++ = newsv;
- *++to_sp = newsv;
if (SvTYPE(sv) <= SVt_IV) {
/* arg must be one of undef, IV/UV, or RV: skip
TAINT_NOT; /* Each item is independent */
}
+
+#ifdef PERL_RC_STACK
+ from_sp[-1] = NULL;
+ SvREFCNT_dec_NN(sv);
+ assert(!to_sp[1]);
+ *++to_sp = newsv;
+ SvREFCNT_inc_simple_void_NN(newsv);
+#else
+ *++to_sp = newsv;
+#endif
+
}
} while (--nargs);
/* entry zero of a stack is always PL_sv_undef, which
* simplifies converting a '()' return into undef in scalar context */
assert(PL_stack_sp > PL_stack_base || *PL_stack_base == &PL_sv_undef);
- return 0;
+ return 0;
}
gimme = cx->blk_gimme;
oldsp = PL_stack_base + cx->blk_oldsp; /* last arg of previous frame */
if (gimme == G_VOID)
- PL_stack_sp = oldsp;
+ rpp_popfree_to_NN(oldsp);
else
leave_adjust_stacks(oldsp, oldsp, gimme, 0);
void
Perl_clear_defarray(pTHX_ AV* av, bool abandon)
{
- const SSize_t fill = AvFILLp(av);
-
PERL_ARGS_ASSERT_CLEAR_DEFARRAY;
- if (LIKELY(!abandon && SvREFCNT(av) == 1 && !SvMAGICAL(av))) {
- av_clear(av);
+ if (LIKELY(!abandon && SvREFCNT(av) == 1 && !SvMAGICAL(av))
+#ifndef PERL_RC_STACK
+ && !AvREAL(av)
+#endif
+ ) {
+ clear_defarray_simple(av);
+#ifndef PERL_RC_STACK
AvREIFY_only(av);
+#endif
}
else {
- AV *newav = newAV();
- av_extend(newav, fill);
+ /* abandon */
+ const SSize_t size = AvFILLp(av) + 1;
+ /* The ternary gives consistency with av_extend() */
+ AV *newav = newAV_alloc_xz(size < PERL_ARRAY_NEW_MIN_KEY ?
+ PERL_ARRAY_NEW_MIN_KEY : size);
+#ifndef PERL_RC_STACK
AvREIFY_only(newav);
+#endif
PAD_SVl(0) = MUTABLE_SV(newav);
SvREFCNT_dec_NN(av);
}
PP(pp_entersub)
{
- dSP; dPOPss;
GV *gv;
CV *cv;
PERL_CONTEXT *cx;
I32 old_savestack_ix;
+ SV *sv = *PL_stack_sp;
if (UNLIKELY(!sv))
- goto do_die;
+ goto do_die;
/* Locate the CV to call:
* - most common case: RV->CV: f(), $ref->():
do_ref:
if (UNLIKELY(SvAMAGIC(sv))) {
sv = amagic_deref_call(sv, to_cv_amg);
- /* Don't SPAGAIN here. */
}
}
else {
assert(cv);
assert((void*)&CvROOT(cv) == (void*)&CvXSUB(cv));
while (UNLIKELY(!CvROOT(cv))) {
- GV* autogv;
- SV* sub_name;
-
- /* anonymous or undef'd function leaves us no recourse */
- if (CvLEXICAL(cv) && CvHASGV(cv))
- DIE(aTHX_ "Undefined subroutine &%" SVf " called",
- SVfARG(cv_name(cv, NULL, 0)));
- if (CvANON(cv) || !CvHASGV(cv)) {
- DIE(aTHX_ "Undefined subroutine called");
- }
-
- /* autoloaded stub? */
- if (cv != GvCV(gv = CvGV(cv))) {
- cv = GvCV(gv);
- }
- /* should call AUTOLOAD now? */
- else {
+ GV* autogv;
+ SV* sub_name;
+
+ /* anonymous or undef'd function leaves us no recourse */
+ if (CvLEXICAL(cv) && CvHASGV(cv))
+ DIE(aTHX_ "Undefined subroutine &%" SVf " called",
+ SVfARG(cv_name(cv, NULL, 0)));
+ if (CvANON(cv) || !CvHASGV(cv)) {
+ DIE(aTHX_ "Undefined subroutine called");
+ }
+
+ /* autoloaded stub? */
+ if (cv != GvCV(gv = CvGV(cv))) {
+ cv = GvCV(gv);
+ }
+ /* should call AUTOLOAD now? */
+ else {
try_autoload:
- autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
+ autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
(GvNAMEUTF8(gv) ? SVf_UTF8 : 0)
|(PL_op->op_flags & OPf_REF
? GV_AUTOLOAD_ISMETHOD
: 0));
cv = autogv ? GvCV(autogv) : NULL;
- }
- if (!cv) {
+ }
+ if (!cv) {
sub_name = sv_newmortal();
gv_efullname3(sub_name, gv, NULL);
DIE(aTHX_ "Undefined subroutine &%" SVf " called", SVfARG(sub_name));
/* unrolled "CvCLONE(cv) && ! CvCLONED(cv)" */
if (UNLIKELY((CvFLAGS(cv) & (CVf_CLONE|CVf_CLONED)) == CVf_CLONE))
- DIE(aTHX_ "Closure prototype called");
+ DIE(aTHX_ "Closure prototype called");
if (UNLIKELY((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub)
&& !CvNODEBUG(cv)))
{
- Perl_get_db_sub(aTHX_ &sv, cv);
- if (CvISXSUB(cv))
- PL_curcopdb = PL_curcop;
+ Perl_get_db_sub(aTHX_ &sv, cv);
+ if (CvISXSUB(cv))
+ PL_curcopdb = PL_curcop;
if (CvLVALUE(cv)) {
/* check for lsub that handles lvalue subroutines */
- cv = GvCV(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVCV));
+ cv = GvCV(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVCV));
/* if lsub not found then fall back to DB::sub */
- if (!cv) cv = GvCV(PL_DBsub);
+ if (!cv) cv = GvCV(PL_DBsub);
} else {
cv = GvCV(PL_DBsub);
}
- if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
- DIE(aTHX_ "No DB::sub routine defined");
+ if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
+ DIE(aTHX_ "No DB::sub routine defined");
}
+ rpp_popfree_1_NN(); /* finished with sv now */
+
if (!(CvISXSUB(cv))) {
- /* This path taken at least 75% of the time */
- dMARK;
- PADLIST *padlist;
+ /* This path taken at least 75% of the time */
+ dMARK;
+ PADLIST *padlist;
I32 depth;
bool hasargs;
U8 gimme;
* in the caller's tmps frame, so they won't be freed until after
* we return from the sub.
*/
- {
+ {
SV **svp = MARK;
- while (svp < SP) {
+ while (svp < PL_stack_sp) {
SV *sv = *++svp;
if (!sv)
continue;
- if (SvPADTMP(sv))
- *svp = sv = sv_mortalcopy(sv);
+ if (SvPADTMP(sv)) {
+ SV *newsv = sv_mortalcopy(sv);
+ *svp = newsv;
+#ifdef PERL_RC_STACK
+ /* should just skip the mortalisation instead */
+ SvREFCNT_inc_simple_void_NN(newsv);
+ SvREFCNT_dec_NN(sv);
+#endif
+ sv = newsv;
+ }
SvTEMP_off(sv);
- }
+ }
}
gimme = GIMME_V;
- cx = cx_pushblock(CXt_SUB, gimme, MARK, old_savestack_ix);
+ cx = cx_pushblock(CXt_SUB, gimme, MARK, old_savestack_ix);
hasargs = cBOOL(PL_op->op_flags & OPf_STACKED);
- cx_pushsub(cx, cv, PL_op->op_next, hasargs);
-
- padlist = CvPADLIST(cv);
- if (UNLIKELY((depth = ++CvDEPTH(cv)) >= 2))
- pad_push(padlist, depth);
- PAD_SET_CUR_NOSAVE(padlist, depth);
- if (LIKELY(hasargs)) {
- AV *const av = MUTABLE_AV(PAD_SVl(0));
+ cx_pushsub(cx, cv, PL_op->op_next, hasargs);
+
+ padlist = CvPADLIST(cv);
+ if (UNLIKELY((depth = ++CvDEPTH(cv)) >= 2))
+ pad_push(padlist, depth);
+ PAD_SET_CUR_NOSAVE(padlist, depth);
+ if (LIKELY(hasargs)) {
+ AV *const av = MUTABLE_AV(PAD_SVl(0));
SSize_t items;
AV **defavp;
- defavp = &GvAV(PL_defgv);
- cx->blk_sub.savearray = *defavp;
- *defavp = MUTABLE_AV(SvREFCNT_inc_simple_NN(av));
+ defavp = &GvAV(PL_defgv);
+ cx->blk_sub.savearray = *defavp;
+ *defavp = MUTABLE_AV(SvREFCNT_inc_simple_NN(av));
/* it's the responsibility of whoever leaves a sub to ensure
* that a clean, empty AV is left in pad[0]. This is normally
* done by cx_popsub() */
- assert(!AvREAL(av) && AvFILLp(av) == -1);
- items = SP - MARK;
- if (UNLIKELY(items - 1 > AvMAX(av))) {
+#ifdef PERL_RC_STACK
+ assert(AvREAL(av));
+#else
+ assert(!AvREAL(av));
+#endif
+ assert(AvFILLp(av) == -1);
+
+ items = PL_stack_sp - MARK;
+ if (UNLIKELY(items - 1 > AvMAX(av))) {
SV **ary = AvALLOC(av);
Renew(ary, items, SV*);
AvMAX(av) = items - 1;
if (items)
Copy(MARK+1,AvARRAY(av),items,SV*);
- AvFILLp(av) = items - 1;
- }
- if (UNLIKELY((cx->blk_u16 & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
- !CvLVALUE(cv)))
+ AvFILLp(av) = items - 1;
+#ifdef PERL_RC_STACK
+ /* transfer ownership of the arguments' refcounts to av */
+ PL_stack_sp = MARK;
+#endif
+ }
+ if (UNLIKELY((cx->blk_u16 & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
+ !CvLVALUE(cv)))
DIE(aTHX_ "Can't modify non-lvalue subroutine call of &%" SVf,
SVfARG(cv_name(cv, NULL, 0)));
- /* warning must come *after* we fully set up the context
- * stuff so that __WARN__ handlers can safely dounwind()
- * if they want to
- */
- if (UNLIKELY(depth == PERL_SUB_DEPTH_WARN
+ /* warning must come *after* we fully set up the context
+ * stuff so that __WARN__ handlers can safely dounwind()
+ * if they want to
+ */
+ if (UNLIKELY(depth == PERL_SUB_DEPTH_WARN
&& ckWARN(WARN_RECURSION)
&& !(PERLDB_SUB && cv == GvCV(PL_DBsub))))
- sub_crush_depth(cv);
- RETURNOP(CvSTART(cv));
+ sub_crush_depth(cv);
+ return CvSTART(cv);
}
else {
- SSize_t markix = TOPMARK;
+ SSize_t markix = TOPMARK;
bool is_scalar;
ENTER;
/* pretend we did the ENTER earlier */
- PL_scopestack[PL_scopestack_ix - 1] = old_savestack_ix;
+ PL_scopestack[PL_scopestack_ix - 1] = old_savestack_ix;
- SAVETMPS;
- PUTBACK;
+ SAVETMPS;
- if (UNLIKELY(((PL_op->op_private
- & CX_PUSHSUB_GET_LVALUE_MASK(Perl_is_lvalue_sub)
+ if (UNLIKELY(((PL_op->op_private
+ & CX_PUSHSUB_GET_LVALUE_MASK(Perl_is_lvalue_sub)
) & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
- !CvLVALUE(cv)))
+ !CvLVALUE(cv)))
DIE(aTHX_ "Can't modify non-lvalue subroutine call of &%" SVf,
SVfARG(cv_name(cv, NULL, 0)));
- if (UNLIKELY(!(PL_op->op_flags & OPf_STACKED) && GvAV(PL_defgv))) {
- /* Need to copy @_ to stack. Alternative may be to
- * switch stack to @_, and copy return values
- * back. This would allow popping @_ in XSUB, e.g.. XXXX */
- AV * const av = GvAV(PL_defgv);
- const SSize_t items = AvFILL(av) + 1;
-
- if (items) {
- SSize_t i = 0;
- const bool m = cBOOL(SvRMAGICAL(av));
- /* Mark is at the end of the stack. */
- EXTEND(SP, items);
- for (; i < items; ++i)
- {
- SV *sv;
- if (m) {
- SV ** const svp = av_fetch(av, i, 0);
- sv = svp ? *svp : NULL;
- }
- else sv = AvARRAY(av)[i];
- if (sv) SP[i+1] = sv;
- else {
- SP[i+1] = newSVavdefelem(av, i, 1);
- }
- }
- SP += items;
- PUTBACK ;
- }
- }
- else {
- SV **mark = PL_stack_base + markix;
- SSize_t items = SP - mark;
- while (items--) {
- mark++;
- if (*mark && SvPADTMP(*mark)) {
- *mark = sv_mortalcopy(*mark);
+ if (UNLIKELY(!(PL_op->op_flags & OPf_STACKED) && GvAV(PL_defgv))) {
+ /* Need to copy @_ to stack. Alternative may be to
+ * switch stack to @_, and copy return values
+ * back. This would allow popping @_ in XSUB, e.g.. XXXX */
+ AV * const av = GvAV(PL_defgv);
+ const SSize_t items = AvFILL(av) + 1;
+
+ if (items) {
+ SSize_t i = 0;
+ const bool m = cBOOL(SvRMAGICAL(av));
+ /* Mark is at the end of the stack. */
+ rpp_extend(items);
+ for (; i < items; ++i)
+ {
+ SV *sv;
+ if (m) {
+ SV ** const svp = av_fetch(av, i, 0);
+ sv = svp ? *svp : NULL;
+ }
+ else
+ sv = AvARRAY(av)[i];
+
+ rpp_push_1(sv ? sv : av_nonelem(av, i));
}
- }
- }
- /* We assume first XSUB in &DB::sub is the called one. */
- if (UNLIKELY(PL_curcopdb)) {
- SAVEVPTR(PL_curcop);
- PL_curcop = PL_curcopdb;
- PL_curcopdb = NULL;
- }
- /* Do we need to open block here? XXXX */
+ }
+ }
+ else {
+ SV **mark = PL_stack_base + markix;
+ SSize_t items = PL_stack_sp - mark;
+ while (items--) {
+ mark++;
+ if (*mark && SvPADTMP(*mark)) {
+ SV *oldsv = *mark;
+ SV *newsv = sv_mortalcopy(oldsv);
+ *mark = newsv;
+#ifdef PERL_RC_STACK
+ /* should just skip the mortalisation instead */
+ SvREFCNT_inc_simple_void_NN(newsv);
+ SvREFCNT_dec_NN(oldsv);
+#endif
+ }
+ }
+ }
+
+ /* We assume first XSUB in &DB::sub is the called one. */
+ if (UNLIKELY(PL_curcopdb)) {
+ SAVEVPTR(PL_curcop);
+ PL_curcop = PL_curcopdb;
+ PL_curcopdb = NULL;
+ }
+ /* Do we need to open block here? XXXX */
/* calculate gimme here as PL_op might get changed and then not
* restored until the LEAVE further down */
is_scalar = (GIMME_V == G_SCALAR);
- /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
- assert(CvXSUB(cv));
- CvXSUB(cv)(aTHX_ cv);
+ /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
+ assert(CvXSUB(cv));
+
+ rpp_invoke_xs(cv);
#if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
/* This duplicates the check done in runops_debug(), but provides more
PL_stack_base, PL_stack_sp,
PL_stack_base + PL_curstackinfo->si_stack_hwm);
#endif
- /* Enforce some sanity in scalar context. */
- if (is_scalar) {
+ /* Enforce some sanity in scalar context. */
+ if (is_scalar) {
SV **svp = PL_stack_base + markix + 1;
if (svp != PL_stack_sp) {
+#ifdef PERL_RC_STACK
+ if (svp < PL_stack_sp) {
+ /* move return value to bottom of stack frame
+ * and free everything else */
+ SV* retsv = *PL_stack_sp;
+ *PL_stack_sp = *svp;
+ *svp = retsv;
+ rpp_popfree_to_NN(svp);
+ }
+ else
+ rpp_push_IMM(&PL_sv_undef);
+#else
*svp = svp > PL_stack_sp ? &PL_sv_undef : *PL_stack_sp;
PL_stack_sp = svp;
+#endif
}
- }
- LEAVE;
- return NORMAL;
+ }
+ LEAVE;
+ return NORMAL;
}
}
PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
if (CvANON(cv))
- Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
+ Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
else {
- Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%" SVf "\"",
- SVfARG(cv_name(cv,NULL,0)));
+ Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%" SVf "\"",
+ SVfARG(cv_name(cv,NULL,0)));
}
}
PP(pp_aelem)
{
- dSP;
SV** svp;
- SV* const elemsv = POPs;
+ SV* const elemsv = PL_stack_sp[0];
IV elem = SvIV(elemsv);
- AV *const av = MUTABLE_AV(POPs);
+ AV *const av = MUTABLE_AV(PL_stack_sp[-1]);
const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
bool preeminent = TRUE;
SV *sv;
+ SV *retsv;
if (UNLIKELY(SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC)))
- Perl_warner(aTHX_ packWARN(WARN_MISC),
- "Use of reference \"%" SVf "\" as array index",
- SVfARG(elemsv));
- if (UNLIKELY(SvTYPE(av) != SVt_PVAV))
- RETPUSHUNDEF;
+ Perl_warner(aTHX_ packWARN(WARN_MISC),
+ "Use of reference \"%" SVf "\" as array index",
+ SVfARG(elemsv));
+ if (UNLIKELY(SvTYPE(av) != SVt_PVAV)) {
+ retsv = &PL_sv_undef;
+ goto ret;
+ }
if (UNLIKELY(localizing)) {
- MAGIC *mg;
- HV *stash;
+ MAGIC *mg;
+ HV *stash;
- /* If we can determine whether the element exist,
- * Try to preserve the existenceness of a tied array
- * element by using EXISTS and DELETE if possible.
- * Fallback to FETCH and STORE otherwise. */
- if (SvCANEXISTDELETE(av))
- preeminent = av_exists(av, elem);
+ /* Try to preserve the existence of a tied array
+ * element by using EXISTS and DELETE if possible.
+ * Fall back to FETCH and STORE otherwise. */
+ if (SvCANEXISTDELETE(av))
+ preeminent = av_exists(av, elem);
}
svp = av_fetch(av, elem, lval && !defer);
if (lval) {
#ifdef PERL_MALLOC_WRAP
- if (SvUOK(elemsv)) {
- const UV uv = SvUV(elemsv);
- elem = uv > IV_MAX ? IV_MAX : uv;
- }
- else if (SvNOK(elemsv))
- elem = (IV)SvNV(elemsv);
- if (elem > 0) {
- static const char oom_array_extend[] =
- "Out of memory during array extend"; /* Duplicated in av.c */
- MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
- }
+ if (SvUOK(elemsv)) {
+ const UV uv = SvUV(elemsv);
+ elem = uv > IV_MAX ? IV_MAX : uv;
+ }
+ else if (SvNOK(elemsv))
+ elem = (IV)SvNV(elemsv);
+ if (elem > 0) {
+ MEM_WRAP_CHECK_s(elem,SV*,"Out of memory during array extend");
+ }
#endif
- if (!svp || !*svp) {
- IV len;
- if (!defer)
- DIE(aTHX_ PL_no_aelem, elem);
- len = av_tindex(av);
- mPUSHs(newSVavdefelem(av,
- /* Resolve a negative index now, unless it points before the
- beginning of the array, in which case record it for error
- reporting in magic_setdefelem. */
- elem < 0 && len + elem >= 0 ? len + elem : elem,
- 1));
- RETURN;
- }
- if (UNLIKELY(localizing)) {
- if (preeminent)
- save_aelem(av, elem, svp);
- else
- SAVEADELETE(av, elem);
- }
- else if (PL_op->op_private & OPpDEREF) {
- PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
- RETURN;
- }
+ if (!svp || !*svp) {
+ IV len;
+ if (!defer)
+ DIE(aTHX_ PL_no_aelem, elem);
+ len = av_top_index(av);
+ /* Resolve a negative index that falls within the array. Leave
+ it negative it if falls outside the array. */
+ if (elem < 0 && len + elem >= 0)
+ elem = len + elem;
+ if (elem >= 0 && elem <= len)
+ /* Falls within the array. */
+ retsv = av_nonelem(av, elem);
+ else
+ /* Falls outside the array. If it is negative,
+ magic_setdefelem will use the index for error reporting.
+ */
+ retsv = sv_2mortal(newSVavdefelem(av, elem, 1));
+ goto ret;
+ }
+ if (UNLIKELY(localizing)) {
+ if (preeminent)
+ save_aelem(av, elem, svp);
+ else
+ SAVEADELETE(av, elem);
+ }
+ else if (PL_op->op_private & OPpDEREF) {
+ retsv = vivify_ref(*svp, PL_op->op_private & OPpDEREF);
+ goto ret;
+ }
}
sv = (svp ? *svp : &PL_sv_undef);
if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
- mg_get(sv);
- PUSHs(sv);
- RETURN;
+ mg_get(sv);
+ retsv = sv;
+
+ ret:
+ rpp_replace_2_1_NN(retsv);
+ return NORMAL;
}
SV*
SvGETMAGIC(sv);
if (!SvOK(sv)) {
- if (SvREADONLY(sv))
- Perl_croak_no_modify();
- prepare_SV_for_RV(sv);
- switch (to_what) {
- case OPpDEREF_SV:
- SvRV_set(sv, newSV(0));
- break;
- case OPpDEREF_AV:
- SvRV_set(sv, MUTABLE_SV(newAV()));
- break;
- case OPpDEREF_HV:
- SvRV_set(sv, MUTABLE_SV(newHV()));
- break;
- }
- SvROK_on(sv);
- SvSETMAGIC(sv);
- SvGETMAGIC(sv);
+ if (SvREADONLY(sv))
+ Perl_croak_no_modify();
+ prepare_SV_for_RV(sv);
+ switch (to_what) {
+ case OPpDEREF_SV:
+ SvRV_set(sv, newSV_type(SVt_NULL));
+ break;
+ case OPpDEREF_AV:
+ SvRV_set(sv, MUTABLE_SV(newAV()));
+ break;
+ case OPpDEREF_HV:
+ SvRV_set(sv, MUTABLE_SV(newHV()));
+ break;
+ }
+ SvROK_on(sv);
+ SvSETMAGIC(sv);
+ SvGETMAGIC(sv);
}
if (SvGMAGICAL(sv)) {
- /* copy the sv without magic to prevent magic from being
- executed twice */
- SV* msv = sv_newmortal();
- sv_setsv_nomg(msv, sv);
- return msv;
+ /* copy the sv without magic to prevent magic from being
+ executed twice */
+ SV* msv = sv_newmortal();
+ sv_setsv_nomg(msv, sv);
+ return msv;
}
return sv;
}
HV* stash;
SV* const sv = PL_stack_base + TOPMARK == PL_stack_sp
- ? (Perl_croak(aTHX_ "Can't call method \"%" SVf "\" without a "
- "package or object reference", SVfARG(meth)),
- (SV *)NULL)
- : *(PL_stack_base + TOPMARK + 1);
+ ? (Perl_croak(aTHX_ "Can't call method \"%" SVf "\" without a "
+ "package or object reference", SVfARG(meth)),
+ (SV *)NULL)
+ : *(PL_stack_base + TOPMARK + 1);
PERL_ARGS_ASSERT_OPMETHOD_STASH;
if (UNLIKELY(!sv))
undefined:
- Perl_croak(aTHX_ "Can't call method \"%" SVf "\" on an undefined value",
- SVfARG(meth));
+ Perl_croak(aTHX_ "Can't call method \"%" SVf "\" on an undefined value",
+ SVfARG(meth));
if (UNLIKELY(SvGMAGICAL(sv))) mg_get(sv);
else if (SvIsCOW_shared_hash(sv)) { /* MyClass->meth() */
- stash = gv_stashsv(sv, GV_CACHE_ONLY);
- if (stash) return stash;
+ stash = gv_stashsv(sv, GV_CACHE_ONLY);
+ if (stash) return stash;
}
if (SvROK(sv))
- ob = MUTABLE_SV(SvRV(sv));
+ ob = MUTABLE_SV(SvRV(sv));
else if (!SvOK(sv)) goto undefined;
else if (isGV_with_GP(sv)) {
- if (!GvIO(sv))
- Perl_croak(aTHX_ "Can't call method \"%" SVf "\" "
- "without a package or object reference",
- SVfARG(meth));
- ob = sv;
- if (SvTYPE(ob) == SVt_PVLV && LvTYPE(ob) == 'y') {
- assert(!LvTARGLEN(ob));
- ob = LvTARG(ob);
- assert(ob);
- }
- *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(ob));
+ if (!GvIO(sv))
+ Perl_croak(aTHX_ "Can't call method \"%" SVf "\" "
+ "without a package or object reference",
+ SVfARG(meth));
+ ob = sv;
+ if (SvTYPE(ob) == SVt_PVLV && LvTYPE(ob) == 'y') {
+ assert(!LvTARGLEN(ob));
+ ob = LvTARG(ob);
+ assert(ob);
+ }
+ /* Replace the object at the base of the stack frame.
+ * This is "below" whatever pp_wrap has wrapped, so needs freeing.
+ */
+ SV *newsv = sv_2mortal(newRV(ob));
+ SV **svp = (PL_stack_base + TOPMARK + 1);
+#ifdef PERL_RC_STACK
+ SV *oldsv = *svp;
+#endif
+ *svp = newsv;
+#ifdef PERL_RC_STACK
+ SvREFCNT_inc_simple_void_NN(newsv);
+ SvREFCNT_dec_NN(oldsv);
+#endif
}
else {
- /* this isn't a reference */
- GV* iogv;
+ /* this isn't a reference */
+ GV* iogv;
STRLEN packlen;
const char * const packname = SvPV_nomg_const(sv, packlen);
const U32 packname_utf8 = SvUTF8(sv);
stash = gv_stashpvn(packname, packlen, packname_utf8 | GV_CACHE_ONLY);
if (stash) return stash;
- if (!(iogv = gv_fetchpvn_flags(
- packname, packlen, packname_utf8, SVt_PVIO
- )) ||
- !(ob=MUTABLE_SV(GvIO(iogv))))
- {
- /* this isn't the name of a filehandle either */
- if (!packlen)
- {
- Perl_croak(aTHX_ "Can't call method \"%" SVf "\" "
- "without a package or object reference",
- SVfARG(meth));
- }
- /* assume it's a package name */
- stash = gv_stashpvn(packname, packlen, packname_utf8);
- if (stash) return stash;
- else return MUTABLE_HV(sv);
- }
- /* it _is_ a filehandle name -- replace with a reference */
- *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(MUTABLE_SV(iogv)));
+ if (!(iogv = gv_fetchpvn_flags(
+ packname, packlen, packname_utf8, SVt_PVIO
+ )) ||
+ !(ob=MUTABLE_SV(GvIO(iogv))))
+ {
+ /* this isn't the name of a filehandle either */
+ if (!packlen)
+ {
+ Perl_croak(aTHX_ "Can't call method \"%" SVf "\" "
+ "without a package or object reference",
+ SVfARG(meth));
+ }
+ /* assume it's a package name */
+ stash = gv_stashpvn(packname, packlen, packname_utf8);
+ if (stash) return stash;
+ else return MUTABLE_HV(sv);
+ }
+ /* it _is_ a filehandle name -- replace with a reference.
+ * Replace the object at the base of the stack frame.
+ * This is "below" whatever pp_wrap has wrapped, so needs freeing.
+ */
+ SV *newsv = sv_2mortal(newRV(MUTABLE_SV(iogv)));
+ SV **svp = (PL_stack_base + TOPMARK + 1);
+#ifdef PERL_RC_STACK
+ SV *oldsv = *svp;
+#endif
+ *svp = newsv;
+#ifdef PERL_RC_STACK
+ SvREFCNT_inc_simple_void_NN(newsv);
+ SvREFCNT_dec_NN(oldsv);
+#endif
}
/* if we got here, ob should be an object or a glob */
if (!ob || !(SvOBJECT(ob)
- || (isGV_with_GP(ob)
- && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
- && SvOBJECT(ob))))
+ || (isGV_with_GP(ob)
+ && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
+ && SvOBJECT(ob))))
{
- Perl_croak(aTHX_ "Can't call method \"%" SVf "\" on unblessed reference",
- SVfARG((SvPOK(meth) && SvPVX(meth) == PL_isa_DOES)
+ Perl_croak(aTHX_ "Can't call method \"%" SVf "\" on unblessed reference",
+ SVfARG((SvPOK(meth) && SvPVX(meth) == PL_isa_DOES)
? newSVpvs_flags("DOES", SVs_TEMP)
: meth));
}
PP(pp_method)
{
- dSP;
GV* gv;
HV* stash;
- SV* const meth = TOPs;
+ SV* const meth = *PL_stack_sp;
if (SvROK(meth)) {
SV* const rmeth = SvRV(meth);
if (SvTYPE(rmeth) == SVt_PVCV) {
- SETs(rmeth);
- RETURN;
+ rpp_replace_1_1_NN(rmeth);
+ return NORMAL;
}
}
gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK);
assert(gv);
- SETs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
- RETURN;
+ rpp_replace_1_1_NN(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
+ return NORMAL;
}
#define METHOD_CHECK_CACHE(stash,cache,meth) \
if (isGV(gv) && GvCV(gv) && (!GvCVGEN(gv) || GvCVGEN(gv) \
== (PL_sub_generation + HvMROMETA(stash)->cache_gen))) \
{ \
- XPUSHs(MUTABLE_SV(GvCV(gv))); \
- RETURN; \
+ rpp_xpush_1(MUTABLE_SV(GvCV(gv))); \
+ return NORMAL; \
} \
} \
PP(pp_method_named)
{
- dSP;
GV* gv;
- SV* const meth = cMETHOPx_meth(PL_op);
+ SV* const meth = cMETHOP_meth;
HV* const stash = opmethod_stash(meth);
if (LIKELY(SvTYPE(stash) == SVt_PVHV)) {
gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK);
assert(gv);
- XPUSHs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
- RETURN;
+ rpp_xpush_1(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
+ return NORMAL;
}
PP(pp_method_super)
{
- dSP;
GV* gv;
HV* cache;
- SV* const meth = cMETHOPx_meth(PL_op);
+ SV* const meth = cMETHOP_meth;
HV* const stash = CopSTASH(PL_curcop);
/* Actually, SUPER doesn't need real object's (or class') stash at all,
* as it uses CopSTASH. However, we must ensure that object(class) is
gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK|GV_SUPER);
assert(gv);
- XPUSHs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
- RETURN;
+ rpp_xpush_1(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
+ return NORMAL;
}
PP(pp_method_redir)
{
- dSP;
GV* gv;
- SV* const meth = cMETHOPx_meth(PL_op);
- HV* stash = gv_stashsv(cMETHOPx_rclass(PL_op), 0);
+ SV* const meth = cMETHOP_meth;
+ HV* stash = gv_stashsv(cMETHOP_rclass, 0);
opmethod_stash(meth); /* not used but needed for error checks */
if (stash) { METHOD_CHECK_CACHE(stash, stash, meth); }
- else stash = MUTABLE_HV(cMETHOPx_rclass(PL_op));
+ else stash = MUTABLE_HV(cMETHOP_rclass);
gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK);
assert(gv);
- XPUSHs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
- RETURN;
+ rpp_xpush_1(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
+ return NORMAL;
}
PP(pp_method_redir_super)
{
- dSP;
GV* gv;
HV* cache;
- SV* const meth = cMETHOPx_meth(PL_op);
- HV* stash = gv_stashsv(cMETHOPx_rclass(PL_op), 0);
+ SV* const meth = cMETHOP_meth;
+ HV* stash = gv_stashsv(cMETHOP_rclass, 0);
opmethod_stash(meth); /* not used but needed for error checks */
- if (UNLIKELY(!stash)) stash = MUTABLE_HV(cMETHOPx_rclass(PL_op));
+ if (UNLIKELY(!stash)) stash = MUTABLE_HV(cMETHOP_rclass);
else if ((cache = HvMROMETA(stash)->super)) {
METHOD_CHECK_CACHE(stash, cache, meth);
}
gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK|GV_SUPER);
assert(gv);
- XPUSHs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
- RETURN;
+ rpp_xpush_1(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
+ return NORMAL;
}
/*
https://perl5.git.perl.org / perl5.git / blobdiff