#include "EXTERN.h"
#define PERL_IN_PP_CTL_C
#include "perl.h"
+#include "feature.h"
-#define RUN_PP_CATCHABLY(thispp) \
- STMT_START { if (CATCH_GET) return docatch(thispp); } STMT_END
+#define dopopto_cursub() \
+ (PL_curstackinfo->si_cxsubix >= 0 \
+ ? PL_curstackinfo->si_cxsubix \
+ : dopoptosub_at(cxstack, cxstack_ix))
#define dopoptosub(plop) dopoptosub_at(cxstack, (plop))
PP(pp_wantarray)
{
- dSP;
I32 cxix;
const PERL_CONTEXT *cx;
- EXTEND(SP, 1);
+ SV *sv;
if (PL_op->op_private & OPpOFFBYONE) {
- if (!(cx = caller_cx(1,NULL))) RETPUSHUNDEF;
+ if (!(cx = caller_cx(1,NULL))) {
+ sv = &PL_sv_undef;
+ goto ret;
+ }
}
else {
- cxix = dopoptosub(cxstack_ix);
- if (cxix < 0)
- RETPUSHUNDEF;
+ cxix = dopopto_cursub();
+ if (cxix < 0) {
+ sv = &PL_sv_undef;
+ goto ret;
+ }
cx = &cxstack[cxix];
}
switch (cx->blk_gimme) {
- case G_ARRAY:
- RETPUSHYES;
+ case G_LIST:
+ sv = &PL_sv_yes;
+ break;
case G_SCALAR:
- RETPUSHNO;
+ sv = &PL_sv_no;
+ break;
default:
- RETPUSHUNDEF;
+ sv = &PL_sv_undef;
+ break;
}
+
+ ret:
+ rpp_xpush_IMM(sv);
+ return NORMAL;
}
PP(pp_regcreset)
PP(pp_regcomp)
{
- dSP;
- PMOP *pm = (PMOP*)cLOGOP->op_other;
+ PMOP *pm = cPMOPx(cLOGOP->op_other);
SV **args;
int nargs;
REGEXP *re = NULL;
bool is_bare_re= FALSE;
if (PL_op->op_flags & OPf_STACKED) {
- dMARK;
- nargs = SP - MARK;
- args = ++MARK;
+ dMARK;
+ nargs = PL_stack_sp - MARK;
+ args = ++MARK;
}
else {
- nargs = 1;
- args = SP;
+ nargs = 1;
+ args = PL_stack_sp;
}
/* prevent recompiling under /o and ithreads. */
#if defined(USE_ITHREADS)
- if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) {
- SP = args-1;
- RETURN;
- }
+ if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm))
+ goto finish;
#endif
re = PM_GETRE(pm);
eng = re ? RX_ENGINE(re) : current_re_engine();
new_re = (eng->op_comp
- ? eng->op_comp
- : &Perl_re_op_compile
- )(aTHX_ args, nargs, pm->op_code_list, eng, re,
- &is_bare_re,
+ ? eng->op_comp
+ : &Perl_re_op_compile
+ )(aTHX_ args, nargs, pm->op_code_list, eng, re,
+ &is_bare_re,
(pm->op_pmflags & RXf_PMf_FLAGCOPYMASK),
- pm->op_pmflags |
- (PL_op->op_flags & OPf_SPECIAL ? PMf_USE_RE_EVAL : 0));
+ pm->op_pmflags |
+ (PL_op->op_flags & OPf_SPECIAL ? PMf_USE_RE_EVAL : 0));
if (pm->op_pmflags & PMf_HAS_CV)
- ReANY(new_re)->qr_anoncv
- = (CV*) SvREFCNT_inc(PAD_SV(PL_op->op_targ));
+ ReANY(new_re)->qr_anoncv
+ = (CV*) SvREFCNT_inc(PAD_SV(PL_op->op_targ));
if (is_bare_re) {
- REGEXP *tmp;
- /* The match's LHS's get-magic might need to access this op's regexp
- (e.g. $' =~ /$re/ while foo; see bug 70764). So we must call
- get-magic now before we replace the regexp. Hopefully this hack can
- be replaced with the approach described at
- http://www.nntp.perl.org/group/perl.perl5.porters/2007/03/msg122415.html
- some day. */
- if (pm->op_type == OP_MATCH) {
- SV *lhs;
- const bool was_tainted = TAINT_get;
- if (pm->op_flags & OPf_STACKED)
- lhs = args[-1];
- else if (pm->op_targ)
- lhs = PAD_SV(pm->op_targ);
- else lhs = DEFSV;
- SvGETMAGIC(lhs);
- /* Restore the previous value of PL_tainted (which may have been
- modified by get-magic), to avoid incorrectly setting the
- RXf_TAINTED flag with RX_TAINT_on further down. */
- TAINT_set(was_tainted);
+ REGEXP *tmp;
+ /* The match's LHS's get-magic might need to access this op's regexp
+ (e.g. $' =~ /$re/ while foo; see bug 70764). So we must call
+ get-magic now before we replace the regexp. Hopefully this hack can
+ be replaced with the approach described at
+ https://www.nntp.perl.org/group/perl.perl5.porters/2007/03/msg122415.html
+ some day. */
+ if (pm->op_type == OP_MATCH) {
+ SV *lhs;
+ const bool was_tainted = TAINT_get;
+ if (pm->op_flags & OPf_STACKED)
+ lhs = args[-1];
+ else if (pm->op_targ)
+ lhs = PAD_SV(pm->op_targ);
+ else lhs = DEFSV;
+ SvGETMAGIC(lhs);
+ /* Restore the previous value of PL_tainted (which may have been
+ modified by get-magic), to avoid incorrectly setting the
+ RXf_TAINTED flag with RX_TAINT_on further down. */
+ TAINT_set(was_tainted);
#ifdef NO_TAINT_SUPPORT
PERL_UNUSED_VAR(was_tainted);
#endif
- }
- tmp = reg_temp_copy(NULL, new_re);
- ReREFCNT_dec(new_re);
- new_re = tmp;
+ }
+ tmp = reg_temp_copy(NULL, new_re);
+ ReREFCNT_dec(new_re);
+ new_re = tmp;
}
if (re != new_re) {
- ReREFCNT_dec(re);
- PM_SETRE(pm, new_re);
+ ReREFCNT_dec(re);
+ PM_SETRE(pm, new_re);
}
assert(TAINTING_get || !TAINT_get);
if (TAINT_get) {
- SvTAINTED_on((SV*)new_re);
+ SvTAINTED_on((SV*)new_re);
RX_TAINT_on(new_re);
}
/* can't change the optree at runtime either */
/* PMf_KEEP is handled differently under threads to avoid these problems */
if (pm->op_pmflags & PMf_KEEP) {
- cLOGOP->op_first->op_next = PL_op->op_next;
+ cLOGOP->op_first->op_next = PL_op->op_next;
}
#endif
- SP = args-1;
- RETURN;
+#if defined(USE_ITHREADS)
+ finish:
+#endif
+ rpp_popfree_to_NN(args - 1);
+ return NORMAL;
}
+/* s/.../expr/e is executed in order as if written as
+ *
+ * pp_subst();
+ * while (pp_substcont()) {
+ * expr;
+ * }
+ *
+ * Only on the second and later calls to pp_substcont() is there a scalar
+ * on the stack holding the value of expr.
+ *
+ * Note that pp_subst() leaves its original 0-2 args on the stack to
+ * avoid them being prematurely freed. It is pp_substcont()'s
+ * responsibility to pop them after the last iteration.
+ */
+
PP(pp_substcont)
{
- dSP;
PERL_CONTEXT *cx = CX_CUR();
- PMOP * const pm = (PMOP*) cLOGOP->op_other;
+ PMOP * const pm = cPMOPx(cLOGOP->op_other);
SV * const dstr = cx->sb_dstr;
char *s = cx->sb_s;
char *m = cx->sb_m;
PERL_ASYNC_CHECK();
if(old != rx) {
- if(old)
- ReREFCNT_dec(old);
- PM_SETRE(pm,ReREFCNT_inc(rx));
+ if(old)
+ ReREFCNT_dec(old);
+ PM_SETRE(pm,ReREFCNT_inc(rx));
}
rxres_restore(&cx->sb_rxres, rx);
if (cx->sb_iters++) {
- const SSize_t saviters = cx->sb_iters;
- if (cx->sb_iters > cx->sb_maxiters)
- DIE(aTHX_ "Substitution loop");
-
- SvGETMAGIC(TOPs); /* possibly clear taint on $1 etc: #67962 */
-
- /* See "how taint works" above pp_subst() */
- sv_catsv_nomg(dstr, POPs);
- if (UNLIKELY(TAINT_get))
- cx->sb_rxtainted |= SUBST_TAINT_REPL;
- if (CxONCE(cx) || s < orig ||
+ /* second+ time round. Result is on stack */
+ const SSize_t saviters = cx->sb_iters;
+ if (cx->sb_iters > cx->sb_maxiters)
+ DIE(aTHX_ "Substitution loop");
+
+ SvGETMAGIC(*PL_stack_sp); /* possibly clear taint on $1 etc: #67962 */
+
+ /* See "how taint works": pp_subst() in pp_hot.c */
+ sv_catsv_nomg(dstr, *PL_stack_sp);
+ rpp_popfree_1_NN();
+ if (UNLIKELY(TAINT_get))
+ cx->sb_rxtainted |= SUBST_TAINT_REPL;
+ if (CxONCE(cx) || s < orig ||
!CALLREGEXEC(rx, s, cx->sb_strend, orig,
- (s == m), cx->sb_targ, NULL,
+ (s == m), cx->sb_targ, NULL,
(REXEC_IGNOREPOS|REXEC_NOT_FIRST|REXEC_FAIL_ON_UNDERFLOW)))
- {
- SV *targ = cx->sb_targ;
-
- assert(cx->sb_strend >= s);
- if(cx->sb_strend > s) {
- if (DO_UTF8(dstr) && !SvUTF8(targ))
- sv_catpvn_nomg_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
- else
- sv_catpvn_nomg(dstr, s, cx->sb_strend - s);
- }
- if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
- cx->sb_rxtainted |= SUBST_TAINT_PAT;
-
- if (pm->op_pmflags & PMf_NONDESTRUCT) {
- PUSHs(dstr);
- /* From here on down we're using the copy, and leaving the
- original untouched. */
- targ = dstr;
- }
- else {
- SV_CHECK_THINKFIRST_COW_DROP(targ);
- if (isGV(targ)) Perl_croak_no_modify();
- SvPV_free(targ);
- SvPV_set(targ, SvPVX(dstr));
- SvCUR_set(targ, SvCUR(dstr));
- SvLEN_set(targ, SvLEN(dstr));
- if (DO_UTF8(dstr))
- SvUTF8_on(targ);
- SvPV_set(dstr, NULL);
-
- PL_tainted = 0;
- mPUSHi(saviters - 1);
-
- (void)SvPOK_only_UTF8(targ);
- }
-
- /* update the taint state of various various variables in
- * preparation for final exit.
- * See "how taint works" above pp_subst() */
- if (TAINTING_get) {
- if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
- ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
- == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
- )
- (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
-
- if (!(cx->sb_rxtainted & SUBST_TAINT_BOOLRET)
- && (cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
- )
- SvTAINTED_on(TOPs); /* taint return value */
- /* needed for mg_set below */
- TAINT_set(
+ {
+ /* no more iterations. Push return value etc */
+ SV *targ = cx->sb_targ;
+ SV *retval;
+
+ assert(cx->sb_strend >= s);
+ if(cx->sb_strend > s) {
+ if (DO_UTF8(dstr) && !SvUTF8(targ))
+ sv_catpvn_nomg_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
+ else
+ sv_catpvn_nomg(dstr, s, cx->sb_strend - s);
+ }
+ if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
+ cx->sb_rxtainted |= SUBST_TAINT_PAT;
+
+ if (pm->op_pmflags & PMf_NONDESTRUCT) {
+ retval = dstr;
+ /* From here on down we're using the copy, and leaving the
+ original untouched. */
+ targ = dstr;
+ }
+ else {
+ SV_CHECK_THINKFIRST_COW_DROP(targ);
+ if (isGV(targ)) Perl_croak_no_modify();
+ SvPV_free(targ);
+ SvPV_set(targ, SvPVX(dstr));
+ SvCUR_set(targ, SvCUR(dstr));
+ SvLEN_set(targ, SvLEN(dstr));
+ if (DO_UTF8(dstr))
+ SvUTF8_on(targ);
+ SvPV_set(dstr, NULL);
+
+ PL_tainted = 0;
+ retval = sv_newmortal();
+ sv_setiv(retval, saviters - 1);
+
+ (void)SvPOK_only_UTF8(targ);
+ }
+
+ /* pop the original args (if any) to pp_subst(),
+ * then push the result */
+ if (pm->op_pmflags & PMf_CONST)
+ rpp_popfree_1_NN(); /* pop replacement string */
+ if (pm->op_flags & OPf_STACKED)
+ rpp_replace_1_1_NN(retval); /* pop LHS of =~ */
+ else
+ rpp_push_1(retval);
+
+ /* update the taint state of various variables in
+ * preparation for final exit.
+ * See "how taint works": pp_subst() in pp_hot.c */
+ if (TAINTING_get) {
+ if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
+ ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
+ == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
+ )
+ (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
+
+ if (!(cx->sb_rxtainted & SUBST_TAINT_BOOLRET)
+ && (cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
+ )
+ SvTAINTED_on(retval); /* taint return value */
+ /* needed for mg_set below */
+ TAINT_set(
cBOOL(cx->sb_rxtainted &
- (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))
+ (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))
);
/* sv_magic(), when adding magic (e.g.taint magic), also
}
}
- SvTAINT(TARG);
- }
- /* PL_tainted must be correctly set for this mg_set */
- SvSETMAGIC(TARG);
- TAINT_NOT;
+ SvTAINT(TARG);
+ }
+ /* PL_tainted must be correctly set for this mg_set */
+ SvSETMAGIC(TARG);
+ TAINT_NOT;
- CX_LEAVE_SCOPE(cx);
- CX_POPSUBST(cx);
+ CX_LEAVE_SCOPE(cx);
+ CX_POPSUBST(cx);
CX_POP(cx);
- PERL_ASYNC_CHECK();
- RETURNOP(pm->op_next);
- NOT_REACHED; /* NOTREACHED */
- }
- cx->sb_iters = saviters;
+ PERL_ASYNC_CHECK();
+ return pm->op_next;
+ NOT_REACHED; /* NOTREACHED */
+ }
+ cx->sb_iters = saviters;
}
+
+ /* First iteration. The substitution expression hasn;'t been executed
+ * this time */
+
if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
- m = s;
- s = orig;
+ m = s;
+ s = orig;
assert(!RX_SUBOFFSET(rx));
- cx->sb_orig = orig = RX_SUBBEG(rx);
- s = orig + (m - s);
- cx->sb_strend = s + (cx->sb_strend - m);
+ cx->sb_orig = orig = RX_SUBBEG(rx);
+ s = orig + (m - s);
+ cx->sb_strend = s + (cx->sb_strend - m);
}
- cx->sb_m = m = RX_OFFS(rx)[0].start + orig;
+ cx->sb_m = m = RX_OFFS_START(rx,0) + orig;
if (m > s) {
- if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
- sv_catpvn_nomg_utf8_upgrade(dstr, s, m - s, nsv);
- else
- sv_catpvn_nomg(dstr, s, m-s);
+ if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
+ sv_catpvn_nomg_utf8_upgrade(dstr, s, m - s, nsv);
+ else
+ sv_catpvn_nomg(dstr, s, m-s);
}
- cx->sb_s = RX_OFFS(rx)[0].end + orig;
+ cx->sb_s = RX_OFFS_END(rx,0) + orig;
{ /* Update the pos() information. */
- SV * const sv
- = (pm->op_pmflags & PMf_NONDESTRUCT) ? cx->sb_dstr : cx->sb_targ;
- MAGIC *mg;
+ SV * const sv
+ = (pm->op_pmflags & PMf_NONDESTRUCT) ? cx->sb_dstr : cx->sb_targ;
+ MAGIC *mg;
/* the string being matched against may no longer be a string,
* e.g. $_=0; s/.../$_++/ge */
if (!SvPOK(sv))
SvPV_force_nomg_nolen(sv);
- if (!(mg = mg_find_mglob(sv))) {
- mg = sv_magicext_mglob(sv);
- }
- MgBYTEPOS_set(mg, sv, SvPVX(sv), m - orig);
+ if (!(mg = mg_find_mglob(sv))) {
+ mg = sv_magicext_mglob(sv);
+ }
+ MgBYTEPOS_set(mg, sv, SvPVX(sv), m - orig);
}
if (old != rx)
- (void)ReREFCNT_inc(rx);
- /* update the taint state of various various variables in preparation
+ (void)ReREFCNT_inc(rx);
+ /* update the taint state of various variables in preparation
* for calling the code block.
- * See "how taint works" above pp_subst() */
+ * See "how taint works": pp_subst() in pp_hot.c */
if (TAINTING_get) {
- if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
- cx->sb_rxtainted |= SUBST_TAINT_PAT;
+ if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
+ cx->sb_rxtainted |= SUBST_TAINT_PAT;
- if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
- ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
- == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
- )
- (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
+ if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
+ ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
+ == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
+ )
+ (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
- if (cx->sb_iters > 1 && (cx->sb_rxtainted &
- (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL)))
- SvTAINTED_on((pm->op_pmflags & PMf_NONDESTRUCT)
- ? cx->sb_dstr : cx->sb_targ);
- TAINT_NOT;
+ if (cx->sb_iters > 1 && (cx->sb_rxtainted &
+ (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL)))
+ SvTAINTED_on((pm->op_pmflags & PMf_NONDESTRUCT)
+ ? cx->sb_dstr : cx->sb_targ);
+ TAINT_NOT;
}
rxres_save(&cx->sb_rxres, rx);
PL_curpm = pm;
- RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
+ return pm->op_pmstashstartu.op_pmreplstart;
}
+
void
Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
{
PERL_ARGS_ASSERT_RXRES_SAVE;
PERL_UNUSED_CONTEXT;
+ /* deal with regexp_paren_pair items */
if (!p || p[1] < RX_NPARENS(rx)) {
#ifdef PERL_ANY_COW
- i = 7 + (RX_NPARENS(rx)+1) * 2;
+ i = 7 + (RX_NPARENS(rx)+1) * 2;
#else
- i = 6 + (RX_NPARENS(rx)+1) * 2;
+ i = 6 + (RX_NPARENS(rx)+1) * 2;
#endif
- if (!p)
- Newx(p, i, UV);
- else
- Renew(p, i, UV);
- *rsp = (void*)p;
+ if (!p)
+ Newx(p, i, UV);
+ else
+ Renew(p, i, UV);
+ *rsp = (void*)p;
}
/* what (if anything) to free on croak */
*p++ = (UV)RX_SUBOFFSET(rx);
*p++ = (UV)RX_SUBCOFFSET(rx);
for (i = 0; i <= RX_NPARENS(rx); ++i) {
- *p++ = (UV)RX_OFFS(rx)[i].start;
- *p++ = (UV)RX_OFFS(rx)[i].end;
+ *p++ = (UV)RX_OFFSp(rx)[i].start;
+ *p++ = (UV)RX_OFFSp(rx)[i].end;
}
}
#ifdef PERL_ANY_COW
if (RX_SAVED_COPY(rx))
- SvREFCNT_dec (RX_SAVED_COPY(rx));
+ SvREFCNT_dec (RX_SAVED_COPY(rx));
RX_SAVED_COPY(rx) = INT2PTR(SV*,*p);
*p++ = 0;
#endif
RX_SUBBEG(rx) = INT2PTR(char*,*p++);
- RX_SUBLEN(rx) = (I32)(*p++);
- RX_SUBOFFSET(rx) = (I32)*p++;
- RX_SUBCOFFSET(rx) = (I32)*p++;
+ RX_SUBLEN(rx) = (SSize_t)(*p++);
+ RX_SUBOFFSET(rx) = (Size_t)*p++;
+ RX_SUBCOFFSET(rx) = (SSize_t)*p++;
for (i = 0; i <= RX_NPARENS(rx); ++i) {
- RX_OFFS(rx)[i].start = (I32)(*p++);
- RX_OFFS(rx)[i].end = (I32)(*p++);
+ RX_OFFSp(rx)[i].start = (SSize_t)(*p++);
+ RX_OFFSp(rx)[i].end = (SSize_t)(*p++);
}
}
PERL_UNUSED_CONTEXT;
if (p) {
- void *tmp = INT2PTR(char*,*p);
+ void *tmp = INT2PTR(char*,*p);
#ifdef PERL_POISON
#ifdef PERL_ANY_COW
- U32 i = 9 + p[1] * 2;
+ U32 i = 9 + p[1] * 2;
#else
- U32 i = 8 + p[1] * 2;
+ U32 i = 8 + p[1] * 2;
#endif
#endif
PoisonFree(p, i, sizeof(UV));
#endif
- Safefree(tmp);
- Safefree(p);
- *rsp = NULL;
+ Safefree(tmp);
+ Safefree(p);
+ *rsp = NULL;
}
}
#define FORM_NUM_BLANK (1<<30)
#define FORM_NUM_POINT (1<<29)
-PP(pp_formline)
+PP_wrapped(pp_formline, 0, 1)
{
dSP; dMARK; dORIGMARK;
SV * const tmpForm = *++MARK;
SvPV_force(PL_formtarget, len);
if (SvTAINTED(tmpForm) || SvTAINTED(formsv))
- SvTAINTED_on(PL_formtarget);
+ SvTAINTED_on(PL_formtarget);
if (DO_UTF8(PL_formtarget))
- targ_is_utf8 = TRUE;
+ targ_is_utf8 = TRUE;
/* this is an initial estimate of how much output buffer space
* to allocate. It may be exceeded later */
linemax = (SvCUR(formsv) * (IN_BYTES ? 1 : 3) + 1);
f = SvPV_const(formsv, len);
for (;;) {
- DEBUG_f( {
- const char *name = "???";
- arg = -1;
- switch (*fpc) {
- case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
- case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
- case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
- case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
- case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
-
- case FF_CHECKNL: name = "CHECKNL"; break;
- case FF_CHECKCHOP: name = "CHECKCHOP"; break;
- case FF_SPACE: name = "SPACE"; break;
- case FF_HALFSPACE: name = "HALFSPACE"; break;
- case FF_ITEM: name = "ITEM"; break;
- case FF_CHOP: name = "CHOP"; break;
- case FF_LINEGLOB: name = "LINEGLOB"; break;
- case FF_NEWLINE: name = "NEWLINE"; break;
- case FF_MORE: name = "MORE"; break;
- case FF_LINEMARK: name = "LINEMARK"; break;
- case FF_END: name = "END"; break;
- case FF_0DECIMAL: name = "0DECIMAL"; break;
- case FF_LINESNGL: name = "LINESNGL"; break;
- }
- if (arg >= 0)
- PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
- else
- PerlIO_printf(Perl_debug_log, "%-16s\n", name);
- } );
- switch (*fpc++) {
- case FF_LINEMARK: /* start (or end) of a line */
- linemark = t - SvPVX(PL_formtarget);
- lines++;
- gotsome = FALSE;
- break;
-
- case FF_LITERAL: /* append <arg> literal chars */
- to_copy = *fpc++;
- source = (U8 *)f;
- f += to_copy;
- trans = '~';
- item_is_utf8 = targ_is_utf8 ? !!DO_UTF8(formsv) : !!SvUTF8(formsv);
- goto append;
-
- case FF_SKIP: /* skip <arg> chars in format */
- f += *fpc++;
- break;
-
- case FF_FETCH: /* get next item and set field size to <arg> */
- arg = *fpc++;
- f += arg;
- fieldsize = arg;
-
- if (MARK < SP)
- sv = *++MARK;
- else {
- sv = &PL_sv_no;
- Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
- }
- if (SvTAINTED(sv))
- SvTAINTED_on(PL_formtarget);
- break;
-
- case FF_CHECKNL: /* find max len of item (up to \n) that fits field */
- {
- const char *s = item = SvPV_const(sv, len);
- const char *send = s + len;
+ DEBUG_f( {
+ const char *name = "???";
+ arg = -1;
+ switch (*fpc) {
+ case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
+ case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
+ case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
+ case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
+ case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
+
+ case FF_CHECKNL: name = "CHECKNL"; break;
+ case FF_CHECKCHOP: name = "CHECKCHOP"; break;
+ case FF_SPACE: name = "SPACE"; break;
+ case FF_HALFSPACE: name = "HALFSPACE"; break;
+ case FF_ITEM: name = "ITEM"; break;
+ case FF_CHOP: name = "CHOP"; break;
+ case FF_LINEGLOB: name = "LINEGLOB"; break;
+ case FF_NEWLINE: name = "NEWLINE"; break;
+ case FF_MORE: name = "MORE"; break;
+ case FF_LINEMARK: name = "LINEMARK"; break;
+ case FF_END: name = "END"; break;
+ case FF_0DECIMAL: name = "0DECIMAL"; break;
+ case FF_LINESNGL: name = "LINESNGL"; break;
+ }
+ if (arg >= 0)
+ PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
+ else
+ PerlIO_printf(Perl_debug_log, "%-16s\n", name);
+ } );
+ switch (*fpc++) {
+ case FF_LINEMARK: /* start (or end) of a line */
+ linemark = t - SvPVX(PL_formtarget);
+ lines++;
+ gotsome = FALSE;
+ break;
+
+ case FF_LITERAL: /* append <arg> literal chars */
+ to_copy = *fpc++;
+ source = (U8 *)f;
+ f += to_copy;
+ trans = '~';
+ item_is_utf8 = (targ_is_utf8)
+ ? cBOOL(DO_UTF8(formsv))
+ : cBOOL(SvUTF8(formsv));
+ goto append;
+
+ case FF_SKIP: /* skip <arg> chars in format */
+ f += *fpc++;
+ break;
+
+ case FF_FETCH: /* get next item and set field size to <arg> */
+ arg = *fpc++;
+ f += arg;
+ fieldsize = arg;
+
+ if (MARK < SP)
+ sv = *++MARK;
+ else {
+ sv = &PL_sv_no;
+ Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
+ }
+ if (SvTAINTED(sv))
+ SvTAINTED_on(PL_formtarget);
+ break;
+
+ case FF_CHECKNL: /* find max len of item (up to \n) that fits field */
+ {
+ const char *s = item = SvPV_const(sv, len);
+ const char *send = s + len;
itemsize = 0;
- item_is_utf8 = DO_UTF8(sv);
+ item_is_utf8 = DO_UTF8(sv);
while (s < send) {
if (!isCNTRL(*s))
gotsome = TRUE;
}
itembytes = s - item;
chophere = s;
- break;
- }
+ break;
+ }
- case FF_CHECKCHOP: /* like CHECKNL, but up to highest split point */
- {
- const char *s = item = SvPV_const(sv, len);
- const char *send = s + len;
+ case FF_CHECKCHOP: /* like CHECKNL, but up to highest split point */
+ {
+ const char *s = item = SvPV_const(sv, len);
+ const char *send = s + len;
I32 size = 0;
chophere = NULL;
- item_is_utf8 = DO_UTF8(sv);
+ item_is_utf8 = DO_UTF8(sv);
while (s < send) {
/* look for a legal split position */
if (isSPACE(*s)) {
break;
}
else {
+ if (size == fieldsize)
+ break;
if (strchr(PL_chopset, *s)) {
/* provisional split point */
/* for a non-space split char, we include
* the split char; hence the '+1' */
chophere = s + 1;
- itemsize = size;
+ itemsize = size + 1;
}
- if (size == fieldsize)
- break;
if (!isCNTRL(*s))
gotsome = TRUE;
}
}
itembytes = chophere - item;
- break;
- }
-
- case FF_SPACE: /* append padding space (diff of field, item size) */
- arg = fieldsize - itemsize;
- if (arg) {
- fieldsize -= arg;
- while (arg-- > 0)
- *t++ = ' ';
- }
- break;
-
- case FF_HALFSPACE: /* like FF_SPACE, but only append half as many */
- arg = fieldsize - itemsize;
- if (arg) {
- arg /= 2;
- fieldsize -= arg;
- while (arg-- > 0)
- *t++ = ' ';
- }
- break;
-
- case FF_ITEM: /* append a text item, while blanking ctrl chars */
- to_copy = itembytes;
- source = (U8 *)item;
- trans = 1;
- goto append;
-
- case FF_CHOP: /* (for ^*) chop the current item */
- if (sv != &PL_sv_no) {
- const char *s = chophere;
+ break;
+ }
+
+ case FF_SPACE: /* append padding space (diff of field, item size) */
+ arg = fieldsize - itemsize;
+ if (arg) {
+ fieldsize -= arg;
+ while (arg-- > 0)
+ *t++ = ' ';
+ }
+ break;
+
+ case FF_HALFSPACE: /* like FF_SPACE, but only append half as many */
+ arg = fieldsize - itemsize;
+ if (arg) {
+ arg /= 2;
+ fieldsize -= arg;
+ while (arg-- > 0)
+ *t++ = ' ';
+ }
+ break;
+
+ case FF_ITEM: /* append a text item, while blanking ctrl chars */
+ to_copy = itembytes;
+ source = (U8 *)item;
+ trans = 1;
+ goto append;
+
+ case FF_CHOP: /* (for ^*) chop the current item */
+ if (sv != &PL_sv_no) {
+ const char *s = chophere;
if (!copied_form &&
((sv == tmpForm || SvSMAGICAL(sv))
|| (SvGMAGICAL(tmpForm) && !sv_only_taint_gmagic(tmpForm))) ) {
copied_form = TRUE;
}
- if (chopspace) {
- while (isSPACE(*s))
- s++;
- }
+ if (chopspace) {
+ while (isSPACE(*s))
+ s++;
+ }
if (SvPOKp(sv))
sv_chop(sv,s);
else
/* tied, overloaded or similar strangeness.
* Do it the hard way */
sv_setpvn(sv, s, len - (s-item));
- SvSETMAGIC(sv);
- break;
- }
+ SvSETMAGIC(sv);
+ break;
+ }
/* FALLTHROUGH */
- case FF_LINESNGL: /* process ^* */
- chopspace = 0;
+ case FF_LINESNGL: /* process ^* */
+ chopspace = 0;
/* FALLTHROUGH */
- case FF_LINEGLOB: /* process @* */
- {
- const bool oneline = fpc[-1] == FF_LINESNGL;
- const char *s = item = SvPV_const(sv, len);
- const char *const send = s + len;
-
- item_is_utf8 = DO_UTF8(sv);
- chophere = s + len;
- if (!len)
- break;
- trans = 0;
- gotsome = TRUE;
- source = (U8 *) s;
- to_copy = len;
- while (s < send) {
- if (*s++ == '\n') {
- if (oneline) {
- to_copy = s - item - 1;
- chophere = s;
- break;
- } else {
- if (s == send) {
- to_copy--;
- } else
- lines++;
- }
- }
- }
- }
-
- append:
- /* append to_copy bytes from source to PL_formstring.
- * item_is_utf8 implies source is utf8.
- * if trans, translate certain characters during the copy */
- {
- U8 *tmp = NULL;
- STRLEN grow = 0;
-
- SvCUR_set(PL_formtarget,
- t - SvPVX_const(PL_formtarget));
-
- if (targ_is_utf8 && !item_is_utf8) {
- source = tmp = bytes_to_utf8(source, &to_copy);
+ case FF_LINEGLOB: /* process @* */
+ {
+ const bool oneline = fpc[-1] == FF_LINESNGL;
+ const char *s = item = SvPV_const(sv, len);
+ const char *const send = s + len;
+
+ item_is_utf8 = DO_UTF8(sv);
+ chophere = s + len;
+ if (!len)
+ break;
+ trans = 0;
+ gotsome = TRUE;
+ source = (U8 *) s;
+ to_copy = len;
+ while (s < send) {
+ if (*s++ == '\n') {
+ if (oneline) {
+ to_copy = s - item - 1;
+ chophere = s;
+ break;
+ } else {
+ if (s == send) {
+ to_copy--;
+ } else
+ lines++;
+ }
+ }
+ }
+ }
+
+ append:
+ /* append to_copy bytes from source to PL_formstring.
+ * item_is_utf8 implies source is utf8.
+ * if trans, translate certain characters during the copy */
+ {
+ U8 *tmp = NULL;
+ STRLEN grow = 0;
+
+ SvCUR_set(PL_formtarget,
+ t - SvPVX_const(PL_formtarget));
+
+ if (targ_is_utf8 && !item_is_utf8) {
+ source = tmp = bytes_to_utf8(source, &to_copy);
grow = to_copy;
- } else {
- if (item_is_utf8 && !targ_is_utf8) {
- U8 *s;
- /* Upgrade targ to UTF8, and then we reduce it to
- a problem we have a simple solution for.
- Don't need get magic. */
- sv_utf8_upgrade_nomg(PL_formtarget);
- targ_is_utf8 = TRUE;
- /* re-calculate linemark */
- s = (U8*)SvPVX(PL_formtarget);
- /* the bytes we initially allocated to append the
- * whole line may have been gobbled up during the
- * upgrade, so allocate a whole new line's worth
- * for safety */
- grow = linemax;
- while (linemark--)
- s += UTF8_SAFE_SKIP(s,
+ } else {
+ if (item_is_utf8 && !targ_is_utf8) {
+ U8 *s;
+ /* Upgrade targ to UTF8, and then we reduce it to
+ a problem we have a simple solution for.
+ Don't need get magic. */
+ sv_utf8_upgrade_nomg(PL_formtarget);
+ targ_is_utf8 = TRUE;
+ /* re-calculate linemark */
+ s = (U8*)SvPVX(PL_formtarget);
+ /* the bytes we initially allocated to append the
+ * whole line may have been gobbled up during the
+ * upgrade, so allocate a whole new line's worth
+ * for safety */
+ grow = linemax;
+ while (linemark--)
+ s += UTF8_SAFE_SKIP(s,
(U8 *) SvEND(PL_formtarget));
- linemark = s - (U8*)SvPVX(PL_formtarget);
- }
- /* Easy. They agree. */
- assert (item_is_utf8 == targ_is_utf8);
- }
- if (!trans)
- /* @* and ^* are the only things that can exceed
- * the linemax, so grow by the output size, plus
- * a whole new form's worth in case of any further
- * output */
- grow = linemax + to_copy;
- if (grow)
- SvGROW(PL_formtarget, SvCUR(PL_formtarget) + grow + 1);
- t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
-
- Copy(source, t, to_copy, char);
- if (trans) {
- /* blank out ~ or control chars, depending on trans.
- * works on bytes not chars, so relies on not
- * matching utf8 continuation bytes */
- U8 *s = (U8*)t;
- U8 *send = s + to_copy;
- while (s < send) {
- const int ch = *s;
- if (trans == '~' ? (ch == '~') : isCNTRL(ch))
- *s = ' ';
- s++;
- }
- }
-
- t += to_copy;
- SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) + to_copy);
- if (tmp)
- Safefree(tmp);
- break;
- }
-
- case FF_0DECIMAL: /* like FF_DECIMAL but for 0### */
- arg = *fpc++;
- fmt = (const char *)
- ((arg & FORM_NUM_POINT) ? "%#0*.*" NVff : "%0*.*" NVff);
- goto ff_dec;
-
- case FF_DECIMAL: /* do @##, ^##, where <arg>=(precision|flags) */
- arg = *fpc++;
- fmt = (const char *)
- ((arg & FORM_NUM_POINT) ? "%#*.*" NVff : "%*.*" NVff);
- ff_dec:
- /* If the field is marked with ^ and the value is undefined,
- blank it out. */
- if ((arg & FORM_NUM_BLANK) && !SvOK(sv)) {
- arg = fieldsize;
- while (arg--)
- *t++ = ' ';
- break;
- }
- gotsome = TRUE;
- value = SvNV(sv);
- /* overflow evidence */
- if (num_overflow(value, fieldsize, arg)) {
- arg = fieldsize;
- while (arg--)
- *t++ = '#';
- break;
- }
- /* Formats aren't yet marked for locales, so assume "yes". */
- {
+ linemark = s - (U8*)SvPVX(PL_formtarget);
+ }
+ /* Easy. They agree. */
+ assert (item_is_utf8 == targ_is_utf8);
+ }
+ if (!trans)
+ /* @* and ^* are the only things that can exceed
+ * the linemax, so grow by the output size, plus
+ * a whole new form's worth in case of any further
+ * output */
+ grow = linemax + to_copy;
+ if (grow)
+ SvGROW(PL_formtarget, SvCUR(PL_formtarget) + grow + 1);
+ t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
+
+ Copy(source, t, to_copy, char);
+ if (trans) {
+ /* blank out ~ or control chars, depending on trans.
+ * works on bytes not chars, so relies on not
+ * matching utf8 continuation bytes */
+ U8 *s = (U8*)t;
+ U8 *send = s + to_copy;
+ while (s < send) {
+ const int ch = *s;
+ if (trans == '~' ? (ch == '~') : isCNTRL(ch))
+ *s = ' ';
+ s++;
+ }
+ }
+
+ t += to_copy;
+ SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) + to_copy);
+ if (tmp)
+ Safefree(tmp);
+ break;
+ }
+
+ case FF_0DECIMAL: /* like FF_DECIMAL but for 0### */
+ arg = *fpc++;
+ fmt = (const char *)
+ ((arg & FORM_NUM_POINT) ? "%#0*.*" NVff : "%0*.*" NVff);
+ goto ff_dec;
+
+
case FF_DECIMAL: /* do @##, ^##, where <arg>=(precision|flags) */
+ arg = *fpc++;
+ fmt = (const char *)
+ ((arg & FORM_NUM_POINT) ? "%#*.*" NVff : "%*.*" NVff);
+ ff_dec:
+ /* If the field is marked with ^ and the value is undefined,
+ blank it out. */
+ if ((arg & FORM_NUM_BLANK) && !SvOK(sv)) {
+ arg = fieldsize;
+ while (arg--)
+ *t++ = ' ';
+ break;
+ }
+ gotsome = TRUE;
+ value = SvNV(sv);
+ /* overflow evidence */
+ if (num_overflow(value, fieldsize, arg)) {
+ arg = fieldsize;
+ while (arg--)
+ *t++ = '#';
+ break;
+ }
+ /* Formats aren't yet marked for locales, so assume "yes". */
+ {
Size_t max = SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget));
int len;
- DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
- STORE_LC_NUMERIC_SET_TO_NEEDED();
arg &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
#ifdef USE_QUADMATH
{
- const char* qfmt = quadmath_format_single(fmt);
int len;
- if (!qfmt)
+ if (!quadmath_format_valid(fmt))
Perl_croak_nocontext("panic: quadmath invalid format \"%s\"", fmt);
- len = quadmath_snprintf(t, max, qfmt, (int) fieldsize, (int) arg, value);
+ WITH_LC_NUMERIC_SET_TO_NEEDED(
+ len = quadmath_snprintf(t, max, fmt, (int) fieldsize,
+ (int) arg, value);
+ );
if (len == -1)
- Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", qfmt);
- if (qfmt != fmt)
- Safefree(fmt);
+ Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", fmt);
}
#else
/* we generate fmt ourselves so it is safe */
GCC_DIAG_RESTORE_STMT;
#endif
PERL_MY_SNPRINTF_POST_GUARD(len, max);
- RESTORE_LC_NUMERIC();
- }
- t += fieldsize;
- break;
-
- case FF_NEWLINE: /* delete trailing spaces, then append \n */
- f++;
- while (t-- > (SvPVX(PL_formtarget) + linemark) && *t == ' ') ;
- t++;
- *t++ = '\n';
- break;
-
- case FF_BLANK: /* for arg==0: do '~'; for arg>0 : do '~~' */
- arg = *fpc++;
- if (gotsome) {
- if (arg) { /* repeat until fields exhausted? */
- fpc--;
- goto end;
- }
- }
- else {
- t = SvPVX(PL_formtarget) + linemark;
- lines--;
- }
- break;
-
- case FF_MORE: /* replace long end of string with '...' */
- {
- const char *s = chophere;
- const char *send = item + len;
- if (chopspace) {
- while (isSPACE(*s) && (s < send))
- s++;
- }
- if (s < send) {
- char *s1;
- arg = fieldsize - itemsize;
- if (arg) {
- fieldsize -= arg;
- while (arg-- > 0)
- *t++ = ' ';
- }
- s1 = t - 3;
- if (strBEGINs(s1," ")) {
- while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
- s1--;
- }
- *s1++ = '.';
- *s1++ = '.';
- *s1++ = '.';
- }
- break;
- }
-
- case FF_END: /* tidy up, then return */
- end:
- assert(t < SvPVX_const(PL_formtarget) + SvLEN(PL_formtarget));
- *t = '\0';
- SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
- if (targ_is_utf8)
- SvUTF8_on(PL_formtarget);
- FmLINES(PL_formtarget) += lines;
- SP = ORIGMARK;
- if (fpc[-1] == FF_BLANK)
- RETURNOP(cLISTOP->op_first);
- else
- RETPUSHYES;
- }
+ }
+ t += fieldsize;
+ break;
+
+ case FF_NEWLINE: /* delete trailing spaces, then append \n */
+ f++;
+ while (t-- > (SvPVX(PL_formtarget) + linemark) && *t == ' ') ;
+ t++;
+ *t++ = '\n';
+ break;
+
+ case FF_BLANK: /* for arg==0: do '~'; for arg>0 : do '~~' */
+ arg = *fpc++;
+ if (gotsome) {
+ if (arg) { /* repeat until fields exhausted? */
+ fpc--;
+ goto end;
+ }
+ }
+ else {
+ t = SvPVX(PL_formtarget) + linemark;
+ lines--;
+ }
+ break;
+
+ case FF_MORE: /* replace long end of string with '...' */
+ {
+ const char *s = chophere;
+ const char *send = item + len;
+ if (chopspace) {
+ while (isSPACE(*s) && (s < send))
+ s++;
+ }
+ if (s < send) {
+ char *s1;
+ arg = fieldsize - itemsize;
+ if (arg) {
+ fieldsize -= arg;
+ while (arg-- > 0)
+ *t++ = ' ';
+ }
+ s1 = t - 3;
+ if (strBEGINs(s1," ")) {
+ while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
+ s1--;
+ }
+ *s1++ = '.';
+ *s1++ = '.';
+ *s1++ = '.';
+ }
+ break;
+ }
+
+ case FF_END: /* tidy up, then return */
+ end:
+ assert(t < SvPVX_const(PL_formtarget) + SvLEN(PL_formtarget));
+ *t = '\0';
+ SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
+ if (targ_is_utf8)
+ SvUTF8_on(PL_formtarget);
+ FmLINES(PL_formtarget) += lines;
+ SP = ORIGMARK;
+ if (fpc[-1] == FF_BLANK)
+ RETURNOP(cLISTOP->op_first);
+ else
+ RETPUSHYES;
+ }
}
}
/* also used for: pp_mapstart() */
PP(pp_grepstart)
{
- dSP;
+ /* See the code comments at the start of pp_grepwhile() and
+ * pp_mapwhile() for an explanation of how the stack is used
+ * during a grep or map.
+ */
SV *src;
+ SV **svp;
- if (PL_stack_base + TOPMARK == SP) {
- (void)POPMARK;
- if (GIMME_V == G_SCALAR)
- XPUSHs(&PL_sv_zero);
- RETURNOP(PL_op->op_next->op_next);
+ if (PL_stack_base + TOPMARK == PL_stack_sp) {
+ (void)POPMARK;
+ if (GIMME_V == G_SCALAR) {
+ rpp_extend(1);
+ *++PL_stack_sp = &PL_sv_zero;
+ }
+ return PL_op->op_next->op_next;
}
- PL_stack_sp = PL_stack_base + TOPMARK + 1;
- Perl_pp_pushmark(aTHX); /* push dst */
- Perl_pp_pushmark(aTHX); /* push src */
+ svp = PL_stack_base + TOPMARK + 1;
+ PUSHMARK(svp); /* push dst */
+ PUSHMARK(svp); /* push src */
ENTER_with_name("grep"); /* enter outer scope */
SAVETMPS;
src = PL_stack_base[TOPMARK];
if (SvPADTMP(src)) {
- src = PL_stack_base[TOPMARK] = sv_mortalcopy(src);
- PL_tmps_floor++;
+ SV *newsrc = sv_mortalcopy(src);
+ PL_tmps_floor++;
+ PL_stack_base[TOPMARK] = newsrc;
+#ifdef PERL_RC_STACK
+ SvREFCNT_inc_simple_void_NN(newsrc);
+ SvREFCNT_dec(src);
+#endif
+ src = newsrc;
}
SvTEMP_off(src);
DEFSV_set(src);
- PUTBACK;
if (PL_op->op_type == OP_MAPSTART)
- Perl_pp_pushmark(aTHX); /* push top */
- return ((LOGOP*)PL_op->op_next)->op_other;
+ PUSHMARK(PL_stack_sp); /* push top */
+ return cLOGOPx(PL_op->op_next)->op_other;
}
+/* pp_grepwhile() lives in pp_hot.c */
+
PP(pp_mapwhile)
{
- dSP;
+ /* Understanding the stack during a map.
+ *
+ * 'map expr, args' is implemented in the form of
+ *
+ * grepstart; // which handles map too
+ * do {
+ * expr;
+ * mapwhile;
+ * } 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 mapwhile, the stack looks like this:
+ *
+ * => * A1..An X1 * X2..Xn C * R1..Rn * E1..En
+ * [-3] [-2] [-1] [0]
+ *
+ * where:
+ * A1..An Accumulated results from all previous iterations of expr
+ * X1..Xn Random garbage
+ * C The current (just processed) arg, still aliased to $_.
+ * R1..Rn The args remaining to be processed.
+ * E1..En the (list) result of the just-executed map expression.
+ *
+ * Note that it is easiest to think of stack marks [-1] and [-2] as both
+ * being one too high, and so it would make more sense to have had the
+ * marks like this:
+ *
+ * => * A1..An * X1..Xn * C R1..Rn * E1..En
+ * [-3] [-2] [-1] [0]
+ *
+ * where the stack is divided neatly into 4 groups:
+ * - accumulated results
+ * - discards and/or holes proactively created for later result storage
+ * - being, or yet to be, processed,
+ * - results of last expr
+ * 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_mapwhile() does the following:
+ *
+ * - If there isn't enough space in the X1..Xn zone to insert the
+ * expression results, grow the stack and shift up everything above C.
+ * - move E1..En to just above An
+ * - at the same time, manipulate the tmps stack so that temporaries
+ * from executing expr can be freed without prematurely freeing
+ * E1..En.
+ * - if on last iteration, pop all the marks, reset the stack pointer
+ * and update the return args based on caller context.
+ * - else alias $_ to the next arg.
+ *
+ */
+
const U8 gimme = GIMME_V;
- I32 items = (SP - PL_stack_base) - TOPMARK; /* how many new items */
- I32 count;
- I32 shift;
+ SSize_t items = (PL_stack_sp - PL_stack_base) - TOPMARK; /* how many new items */
+ SSize_t count;
+ SSize_t shift;
SV** src;
SV** dst;
+#ifdef PERL_RC_STACK
+ /* for ref-counted stack, we need to account for the currently-aliased
+ * stack element, as it might (or might not) get over-written when
+ * copying values from the expr to the end of the accumulated results
+ * section of the list. By RC--ing and zeroing out the stack entry, we
+ * ensure consistent handling.
+ */
+ dst = PL_stack_base + PL_markstack_ptr[-1];
+ SvREFCNT_dec_NN(*dst);
+ *dst = NULL;
+#endif
+
/* first, move source pointer to the next item in the source list */
++PL_markstack_ptr[-1];
/* if there are new items, push them into the destination list */
if (items && gimme != G_VOID) {
- /* might need to make room back there first */
- if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
- /* XXX this implementation is very pessimal because the stack
- * is repeatedly extended for every set of items. Is possible
- * to do this without any stack extension or copying at all
- * by maintaining a separate list over which the map iterates
- * (like foreach does). --gsar */
-
- /* everything in the stack after the destination list moves
- * towards the end the stack by the amount of room needed */
- shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
-
- /* items to shift up (accounting for the moved source pointer) */
- count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
-
- /* This optimization is by Ben Tilly and it does
- * things differently from what Sarathy (gsar)
- * is describing. The downside of this optimization is
- * that leaves "holes" (uninitialized and hopefully unused areas)
- * to the Perl stack, but on the other hand this
- * shouldn't be a problem. If Sarathy's idea gets
- * implemented, this optimization should become
- * irrelevant. --jhi */
+ /* might need to make room back there first */
+ if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
+ /* XXX this implementation is very pessimal because the stack
+ * is repeatedly extended for every set of items. Is possible
+ * to do this without any stack extension or copying at all
+ * by maintaining a separate list over which the map iterates
+ * (like foreach does). --gsar */
+
+ /* everything in the stack after the destination list moves
+ * towards the end the stack by the amount of room needed */
+ shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
+
+ /* items to shift up (accounting for the moved source pointer) */
+ count = (PL_stack_sp - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
+
+ /* This optimization is by Ben Tilly and it does
+ * things differently from what Sarathy (gsar)
+ * is describing. The downside of this optimization is
+ * that leaves "holes" (uninitialized and hopefully unused areas)
+ * to the Perl stack, but on the other hand this
+ * shouldn't be a problem. If Sarathy's idea gets
+ * implemented, this optimization should become
+ * irrelevant. --jhi */
if (shift < count)
shift = count; /* Avoid shifting too often --Ben Tilly */
- EXTEND(SP,shift);
- src = SP;
- dst = (SP += shift);
- PL_markstack_ptr[-1] += shift;
- *PL_markstack_ptr += shift;
- while (count--)
- *dst-- = *src--;
- }
- /* copy the new items down to the destination list */
- dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
- if (gimme == G_ARRAY) {
- /* add returned items to the collection (making mortal copies
- * if necessary), then clear the current temps stack frame
- * *except* for those items. We do this splicing the items
- * into the start of the tmps frame (so some items may be on
- * the tmps stack twice), then moving PL_tmps_floor above
- * them, then freeing the frame. That way, the only tmps that
- * accumulate over iterations are the return values for map.
- * We have to do to this way so that everything gets correctly
- * freed if we die during the map.
- */
- I32 tmpsbase;
- I32 i = items;
- /* make space for the slice */
- EXTEND_MORTAL(items);
- tmpsbase = PL_tmps_floor + 1;
- Move(PL_tmps_stack + tmpsbase,
- PL_tmps_stack + tmpsbase + items,
- PL_tmps_ix - PL_tmps_floor,
- SV*);
- PL_tmps_ix += items;
-
- while (i-- > 0) {
- SV *sv = POPs;
- if (!SvTEMP(sv))
- sv = sv_mortalcopy(sv);
- *dst-- = sv;
- PL_tmps_stack[tmpsbase++] = SvREFCNT_inc_simple(sv);
- }
- /* clear the stack frame except for the items */
- PL_tmps_floor += items;
- FREETMPS;
- /* FREETMPS may have cleared the TEMP flag on some of the items */
- i = items;
- while (i-- > 0)
- SvTEMP_on(PL_tmps_stack[--tmpsbase]);
- }
- else {
- /* scalar context: we don't care about which values map returns
- * (we use undef here). And so we certainly don't want to do mortal
- * copies of meaningless values. */
- while (items-- > 0) {
- (void)POPs;
- *dst-- = &PL_sv_undef;
- }
- FREETMPS;
- }
+ rpp_extend(shift);
+ src = PL_stack_sp;
+ PL_stack_sp += shift;
+ dst = PL_stack_sp;
+ PL_markstack_ptr[-1] += shift;
+ *PL_markstack_ptr += shift;
+ while (count--)
+ *dst-- = *src--;
+#ifdef PERL_RC_STACK
+ /* zero out the hole just created, so that on a
+ * reference-counted stack, so that the just-shifted SVs
+ * aren't counted twice.
+ */
+ Zero(src+1, (dst-src), SV*);
+#endif
+ }
+ /* copy the new items down to the destination list */
+ PL_markstack_ptr[-2] += items;
+ dst = PL_stack_base + PL_markstack_ptr[-2] - 1;
+ if (gimme == G_LIST) {
+ /* add returned items to the collection (making mortal copies
+ * if necessary), then clear the current temps stack frame
+ * *except* for those items. We do this splicing the items
+ * into the start of the tmps frame (so some items may be on
+ * the tmps stack twice), then moving PL_tmps_floor above
+ * them, then freeing the frame. That way, the only tmps that
+ * accumulate over iterations are the return values for map.
+ * We have to do to this way so that everything gets correctly
+ * freed if we die during the map.
+ */
+ SSize_t tmpsbase;
+ SSize_t i = items;
+ /* make space for the slice */
+ EXTEND_MORTAL(items);
+ tmpsbase = PL_tmps_floor + 1;
+ Move(PL_tmps_stack + tmpsbase,
+ PL_tmps_stack + tmpsbase + items,
+ PL_tmps_ix - PL_tmps_floor,
+ SV*);
+ PL_tmps_ix += items;
+
+ while (i-- > 0) {
+#ifdef PERL_RC_STACK
+ SV *sv = *PL_stack_sp;
+ assert(!*dst); /* not overwriting ptrs to refcnted SVs */
+ if (!SvTEMP(sv)) {
+ sv = sv_mortalcopy(sv);
+ /* NB - don't really need the mortalising above.
+ * A simple copy would suffice */
+ *dst-- = sv;
+ SvREFCNT_inc_simple_void_NN(sv);
+ rpp_popfree_1_NN();
+ }
+ else {
+ *dst-- = sv;
+ PL_stack_sp--;
+ }
+
+#else
+ SV *sv = *PL_stack_sp--;
+ if (!SvTEMP(sv))
+ sv = sv_mortalcopy(sv);
+ *dst-- = sv;
+#endif
+ PL_tmps_stack[tmpsbase++] = SvREFCNT_inc_simple(sv);
+ }
+ /* clear the stack frame except for the items */
+ PL_tmps_floor += items;
+ FREETMPS;
+ /* FREETMPS may have cleared the TEMP flag on some of the items */
+ i = items;
+ while (i-- > 0)
+ SvTEMP_on(PL_tmps_stack[--tmpsbase]);
+ }
+ else {
+ /* scalar context: we don't care about which values map returns
+ * (we use undef here). And so we certainly don't want to do mortal
+ * copies of meaningless values. */
+ *(dst - items + 1) = &PL_sv_undef;
+ rpp_popfree_to(PL_stack_sp - items);
+ FREETMPS;
+ }
}
else {
- FREETMPS;
+ if (items) {
+ assert(gimme == G_VOID);
+ rpp_popfree_to(PL_stack_sp - items);
+ }
+ FREETMPS;
}
LEAVE_with_name("grep_item"); /* exit inner scope */
/* All done yet? */
if (PL_markstack_ptr[-1] > TOPMARK) {
- (void)POPMARK; /* pop top */
- 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) {
- dTARGET;
- XPUSHi(items);
- }
- else if (gimme == G_ARRAY)
- SP += items;
- RETURN;
+ (void)POPMARK; /* pop top */
+ LEAVE_with_name("grep"); /* exit outer scope */
+ (void)POPMARK; /* pop src */
+ items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
+ (void)POPMARK; /* pop dst */
+ SV **svp = PL_stack_base + POPMARK; /* pop original mark */
+ if (gimme == G_LIST)
+ svp += items;
+ rpp_popfree_to(svp);
+ if (gimme == G_SCALAR) {
+ dTARGET;
+ TARGi(items, 1);
+ /* XXX is the extend necessary? */
+ rpp_xpush_1(targ);
+ }
+ return NORMAL;
}
else {
- SV *src;
-
- ENTER_with_name("grep_item"); /* enter inner scope */
- SAVEVPTR(PL_curpm);
-
- /* set $_ to the new source item */
- src = PL_stack_base[PL_markstack_ptr[-1]];
- if (SvPADTMP(src)) {
+ SV *src;
+
+ ENTER_with_name("grep_item"); /* enter inner scope */
+ SAVEVPTR(PL_curpm);
+
+ /* set $_ to the new source item */
+ src = PL_stack_base[PL_markstack_ptr[-1]];
+ if (SvPADTMP(src)) {
+ SV *newsrc = sv_mortalcopy(src);
+ PL_stack_base[PL_markstack_ptr[-1]] = newsrc;
+#ifdef PERL_RC_STACK
+ SvREFCNT_inc_simple_void_NN(newsrc);
+ SvREFCNT_dec(src);
+#endif
+ src = newsrc;
+ }
+ if (SvPADTMP(src)) {
src = sv_mortalcopy(src);
}
- SvTEMP_off(src);
- DEFSV_set(src);
+ SvTEMP_off(src);
+ DEFSV_set(src);
- RETURNOP(cLOGOP->op_other);
+ return cLOGOP->op_other;
}
}
PP(pp_range)
{
dTARG;
- if (GIMME_V == G_ARRAY)
- return NORMAL;
+ if (GIMME_V == G_LIST)
+ return NORMAL;
GETTARGET;
if (SvTRUE_NN(targ))
- return cLOGOP->op_other;
+ return cLOGOP->op_other;
else
- return NORMAL;
+ return NORMAL;
}
-PP(pp_flip)
+
+PP_wrapped(pp_flip,((GIMME_V == G_LIST) ? 0 : 1), 0)
{
dSP;
- if (GIMME_V == G_ARRAY) {
- RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
+ if (GIMME_V == G_LIST) {
+ RETURNOP(cLOGOPx(cUNOP->op_first)->op_other);
}
else {
- dTOPss;
- SV * const targ = PAD_SV(PL_op->op_targ);
- int flip = 0;
-
- if (PL_op->op_private & OPpFLIP_LINENUM) {
- if (GvIO(PL_last_in_gv)) {
- flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
- }
- else {
- GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
- if (gv && GvSV(gv))
- flip = SvIV(sv) == SvIV(GvSV(gv));
- }
- } else {
- flip = SvTRUE_NN(sv);
- }
- if (flip) {
- sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
- if (PL_op->op_flags & OPf_SPECIAL) {
- sv_setiv(targ, 1);
- SETs(targ);
- RETURN;
- }
- else {
- sv_setiv(targ, 0);
- SP--;
- RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
- }
- }
+ dTOPss;
+ SV * const targ = PAD_SV(PL_op->op_targ);
+ int flip = 0;
+
+ if (PL_op->op_private & OPpFLIP_LINENUM) {
+ if (GvIO(PL_last_in_gv)) {
+ flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
+ }
+ else {
+ GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
+ if (gv && GvSV(gv))
+ flip = SvIV(sv) == SvIV(GvSV(gv));
+ }
+ } else {
+ flip = SvTRUE_NN(sv);
+ }
+ if (flip) {
+ sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
+ if (PL_op->op_flags & OPf_SPECIAL) {
+ sv_setiv(targ, 1);
+ SETs(targ);
+ RETURN;
+ }
+ else {
+ sv_setiv(targ, 0);
+ SP--;
+ RETURNOP(cLOGOPx(cUNOP->op_first)->op_other);
+ }
+ }
SvPVCLEAR(TARG);
- SETs(targ);
- RETURN;
+ SETs(targ);
+ RETURN;
}
}
+
/* This code tries to decide if "$left .. $right" should use the
magical string increment, or if the range is numeric. Initially,
an exception was made for *any* string beginning with "0" (see
perlop [#133695] */
#define RANGE_IS_NUMERIC(left,right) ( \
- SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
- SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
- (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
+ SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
+ SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
+ (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
looks_like_number(left)) && SvPOKp(left) \
&& !(*SvPVX_const(left) == '0' && SvCUR(left)>1 ) )) \
&& (!SvOK(right) || looks_like_number(right))))
-PP(pp_flop)
+
+PP_wrapped(pp_flop, (GIMME_V == G_LIST) ? 2 : 1, 0)
{
dSP;
- if (GIMME_V == G_ARRAY) {
- dPOPPOPssrl;
-
- SvGETMAGIC(left);
- SvGETMAGIC(right);
-
- if (RANGE_IS_NUMERIC(left,right)) {
- IV i, j, n;
- if ((SvOK(left) && !SvIOK(left) && SvNV_nomg(left) < IV_MIN) ||
- (SvOK(right) && (SvIOK(right)
- ? SvIsUV(right) && SvUV(right) > IV_MAX
- : SvNV_nomg(right) > IV_MAX)))
- DIE(aTHX_ "Range iterator outside integer range");
- i = SvIV_nomg(left);
- j = SvIV_nomg(right);
- if (j >= i) {
+ if (GIMME_V == G_LIST) {
+ dPOPPOPssrl;
+
+ SvGETMAGIC(left);
+ SvGETMAGIC(right);
+
+ if (RANGE_IS_NUMERIC(left,right)) {
+ IV i, j, n;
+ if ((SvOK(left) && !SvIOK(left) && SvNV_nomg(left) < IV_MIN) ||
+ (SvOK(right) && (SvIOK(right)
+ ? SvIsUV(right) && SvUV(right) > IV_MAX
+ : SvNV_nomg(right) > (NV) IV_MAX)))
+ DIE(aTHX_ "Range iterator outside integer range");
+ i = SvIV_nomg(left);
+ j = SvIV_nomg(right);
+ if (j >= i) {
/* Dance carefully around signed max. */
bool overflow = (i <= 0 && j > SSize_t_MAX + i - 1);
if (!overflow) {
}
if (overflow)
Perl_croak(aTHX_ "Out of memory during list extend");
- EXTEND_MORTAL(n);
- EXTEND(SP, n);
- }
- else
- n = 0;
- while (n--) {
- SV * const sv = sv_2mortal(newSViv(i));
- PUSHs(sv);
+ EXTEND_MORTAL(n);
+ EXTEND(SP, n);
+ }
+ else
+ n = 0;
+ while (n--) {
+ SV * const sv = sv_2mortal(newSViv(i));
+ PUSHs(sv);
if (n) /* avoid incrementing above IV_MAX */
i++;
- }
- }
- else {
- STRLEN len, llen;
- const char * const lpv = SvPV_nomg_const(left, llen);
- const char * const tmps = SvPV_nomg_const(right, len);
-
- SV *sv = newSVpvn_flags(lpv, llen, SvUTF8(left)|SVs_TEMP);
+ }
+ }
+ else {
+ STRLEN len, llen;
+ const char * const lpv = SvPV_nomg_const(left, llen);
+ const char * const tmps = SvPV_nomg_const(right, len);
+
+ SV *sv = newSVpvn_flags(lpv, llen, SvUTF8(left)|SVs_TEMP);
if (DO_UTF8(right) && IN_UNI_8_BIT)
len = sv_len_utf8_nomg(right);
- while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
- XPUSHs(sv);
- if (strEQ(SvPVX_const(sv),tmps))
- break;
- sv = sv_2mortal(newSVsv(sv));
- sv_inc(sv);
- }
- }
+ while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
+ XPUSHs(sv);
+ if (strEQ(SvPVX_const(sv),tmps))
+ break;
+ sv = sv_2mortal(newSVsv(sv));
+ sv_inc(sv);
+ }
+ }
}
else {
- dTOPss;
- SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
- int flop = 0;
- sv_inc(targ);
-
- if (PL_op->op_private & OPpFLIP_LINENUM) {
- if (GvIO(PL_last_in_gv)) {
- flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
- }
- else {
- GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
- if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
- }
- }
- else {
- flop = SvTRUE_NN(sv);
- }
-
- if (flop) {
- sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
- sv_catpvs(targ, "E0");
- }
- SETs(targ);
+ dTOPss;
+ SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
+ int flop = 0;
+ sv_inc(targ);
+
+ if (PL_op->op_private & OPpFLIP_LINENUM) {
+ if (GvIO(PL_last_in_gv)) {
+ flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
+ }
+ else {
+ GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
+ if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
+ }
+ }
+ else {
+ flop = SvTRUE_NN(sv);
+ }
+
+ if (flop) {
+ sv_setiv(PAD_SV(cUNOPx(cUNOP->op_first)->op_first->op_targ), 0);
+ sv_catpvs(targ, "E0");
+ }
+ SETs(targ);
}
RETURN;
}
+
/* Control. */
static const char * const context_name[] = {
"format",
"eval",
"substitution",
+ "defer block",
};
STATIC I32
PERL_ARGS_ASSERT_DOPOPTOLABEL;
for (i = cxstack_ix; i >= 0; i--) {
- const PERL_CONTEXT * const cx = &cxstack[i];
- switch (CxTYPE(cx)) {
- case CXt_SUBST:
- case CXt_SUB:
- case CXt_FORMAT:
- case CXt_EVAL:
- case CXt_NULL:
- /* diag_listed_as: Exiting subroutine via %s */
- Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
- context_name[CxTYPE(cx)], OP_NAME(PL_op));
- if (CxTYPE(cx) == CXt_NULL) /* sort BLOCK */
- return -1;
- break;
- case CXt_LOOP_PLAIN:
- case CXt_LOOP_LAZYIV:
- case CXt_LOOP_LAZYSV:
- case CXt_LOOP_LIST:
- case CXt_LOOP_ARY:
- {
+ const PERL_CONTEXT * const cx = &cxstack[i];
+ switch (CxTYPE(cx)) {
+ case CXt_EVAL:
+ if(CxTRY(cx))
+ continue;
+ /* FALLTHROUGH */
+ case CXt_SUBST:
+ case CXt_SUB:
+ case CXt_FORMAT:
+ case CXt_NULL:
+ /* diag_listed_as: Exiting subroutine via %s */
+ Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
+ context_name[CxTYPE(cx)], OP_NAME(PL_op));
+ if (CxTYPE(cx) == CXt_NULL) /* sort BLOCK */
+ return -1;
+ break;
+ case CXt_LOOP_PLAIN:
+ case CXt_LOOP_LAZYIV:
+ case CXt_LOOP_LAZYSV:
+ case CXt_LOOP_LIST:
+ case CXt_LOOP_ARY:
+ {
STRLEN cx_label_len = 0;
U32 cx_label_flags = 0;
- const char *cx_label = CxLABEL_len_flags(cx, &cx_label_len, &cx_label_flags);
- if (!cx_label || !(
+ const char *cx_label = CxLABEL_len_flags(cx, &cx_label_len, &cx_label_flags);
+ if (!cx_label || !(
( (cx_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
(flags & SVf_UTF8)
? (bytes_cmp_utf8(
(const U8*)cx_label, cx_label_len) == 0)
: (len == cx_label_len && ((cx_label == label)
|| memEQ(cx_label, label, len))) )) {
- DEBUG_l(Perl_deb(aTHX_ "(poptolabel(): skipping label at cx=%ld %s)\n",
- (long)i, cx_label));
- continue;
- }
- DEBUG_l( Perl_deb(aTHX_ "(poptolabel(): found label at cx=%ld %s)\n", (long)i, label));
- return i;
- }
- }
+ DEBUG_l(Perl_deb(aTHX_ "(poptolabel(): skipping label at cx=%ld %s)\n",
+ (long)i, cx_label));
+ continue;
+ }
+ DEBUG_l( Perl_deb(aTHX_ "(poptolabel(): found label at cx=%ld %s)\n", (long)i, label));
+ return i;
+ }
+ }
}
return i;
}
+/*
+=for apidoc_section $callback
+=for apidoc dowantarray
+
+Implements the deprecated L<perlapi/C<GIMME>>.
+=cut
+*/
U8
Perl_dowantarray(pTHX)
return (gimme == G_VOID) ? G_SCALAR : gimme;
}
+/* note that this function has mostly been superseded by Perl_gimme_V */
+
U8
Perl_block_gimme(pTHX)
{
- const I32 cxix = dopoptosub(cxstack_ix);
+ const I32 cxix = dopopto_cursub();
U8 gimme;
if (cxix < 0)
- return G_VOID;
+ return G_VOID;
gimme = (cxstack[cxix].blk_gimme & G_WANT);
if (!gimme)
- Perl_croak(aTHX_ "panic: bad gimme: %d\n", gimme);
+ Perl_croak(aTHX_ "panic: bad gimme: %d\n", gimme);
return gimme;
}
+/*
+=for apidoc is_lvalue_sub
+
+Returns non-zero if the sub calling this function is being called in an lvalue
+context. Returns 0 otherwise.
+
+=cut
+*/
I32
Perl_is_lvalue_sub(pTHX)
{
- const I32 cxix = dopoptosub(cxstack_ix);
+ const I32 cxix = dopopto_cursub();
assert(cxix >= 0); /* We should only be called from inside subs */
if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
- return CxLVAL(cxstack + cxix);
+ return CxLVAL(cxstack + cxix);
else
- return 0;
+ return 0;
}
/* only used by cx_pushsub() */
assert(cxix >= 0); /* We should only be called from inside subs */
if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
- return CxLVAL(cxstack + cxix);
+ return CxLVAL(cxstack + cxix);
else
- return 0;
+ return 0;
}
STATIC I32
#endif
for (i = startingblock; i >= 0; i--) {
- const PERL_CONTEXT * const cx = &cxstk[i];
- switch (CxTYPE(cx)) {
- default:
- continue;
- case CXt_SUB:
+ const PERL_CONTEXT * const cx = &cxstk[i];
+ switch (CxTYPE(cx)) {
+ default:
+ continue;
+ case CXt_SUB:
/* in sub foo { /(?{...})/ }, foo ends up on the CX stack
* twice; the first for the normal foo() call, and the second
* for a faked up re-entry into the sub to execute the
* code block. Hide this faked entry from the world. */
if (cx->cx_type & CXp_SUB_RE_FAKE)
continue;
- /* FALLTHROUGH */
- case CXt_EVAL:
- case CXt_FORMAT:
- DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
- return i;
- }
+ DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
+ return i;
+
+ case CXt_EVAL:
+ if (CxTRY(cx))
+ continue;
+ DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
+ return i;
+
+ case CXt_FORMAT:
+ DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
+ return i;
+ }
}
return i;
}
{
I32 i;
for (i = startingblock; i >= 0; i--) {
- const PERL_CONTEXT *cx = &cxstack[i];
- switch (CxTYPE(cx)) {
- default:
- continue;
- case CXt_EVAL:
- DEBUG_l( Perl_deb(aTHX_ "(dopoptoeval(): found eval at cx=%ld)\n", (long)i));
- return i;
- }
+ const PERL_CONTEXT *cx = &cxstack[i];
+ switch (CxTYPE(cx)) {
+ default:
+ continue;
+ case CXt_EVAL:
+ DEBUG_l( Perl_deb(aTHX_ "(dopoptoeval(): found eval at cx=%ld)\n", (long)i));
+ return i;
+ }
}
return i;
}
{
I32 i;
for (i = startingblock; i >= 0; i--) {
- const PERL_CONTEXT * const cx = &cxstack[i];
- switch (CxTYPE(cx)) {
- case CXt_SUBST:
- case CXt_SUB:
- case CXt_FORMAT:
- case CXt_EVAL:
- case CXt_NULL:
- /* diag_listed_as: Exiting subroutine via %s */
- Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
- context_name[CxTYPE(cx)], OP_NAME(PL_op));
- if ((CxTYPE(cx)) == CXt_NULL) /* sort BLOCK */
- return -1;
- break;
- case CXt_LOOP_PLAIN:
- case CXt_LOOP_LAZYIV:
- case CXt_LOOP_LAZYSV:
- case CXt_LOOP_LIST:
- case CXt_LOOP_ARY:
- DEBUG_l( Perl_deb(aTHX_ "(dopoptoloop(): found loop at cx=%ld)\n", (long)i));
- return i;
- }
+ const PERL_CONTEXT * const cx = &cxstack[i];
+ switch (CxTYPE(cx)) {
+ case CXt_EVAL:
+ if(CxTRY(cx))
+ continue;
+ /* FALLTHROUGH */
+ case CXt_SUBST:
+ case CXt_SUB:
+ case CXt_FORMAT:
+ case CXt_NULL:
+ /* diag_listed_as: Exiting subroutine via %s */
+ Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
+ context_name[CxTYPE(cx)], OP_NAME(PL_op));
+ if ((CxTYPE(cx)) == CXt_NULL) /* sort BLOCK */
+ return -1;
+ break;
+ case CXt_LOOP_PLAIN:
+ case CXt_LOOP_LAZYIV:
+ case CXt_LOOP_LAZYSV:
+ case CXt_LOOP_LIST:
+ case CXt_LOOP_ARY:
+ DEBUG_l( Perl_deb(aTHX_ "(dopoptoloop(): found loop at cx=%ld)\n", (long)i));
+ return i;
+ }
}
return i;
}
{
I32 i;
for (i = startingblock; i >= 0; i--) {
- const PERL_CONTEXT *cx = &cxstack[i];
- switch (CxTYPE(cx)) {
- default:
- continue;
- case CXt_GIVEN:
- DEBUG_l( Perl_deb(aTHX_ "(dopoptogivenfor(): found given at cx=%ld)\n", (long)i));
- return i;
- case CXt_LOOP_PLAIN:
+ const PERL_CONTEXT *cx = &cxstack[i];
+ switch (CxTYPE(cx)) {
+ default:
+ continue;
+ case CXt_GIVEN:
+ DEBUG_l( Perl_deb(aTHX_ "(dopoptogivenfor(): found given at cx=%ld)\n", (long)i));
+ return i;
+ case CXt_LOOP_PLAIN:
assert(!(cx->cx_type & CXp_FOR_DEF));
- break;
- case CXt_LOOP_LAZYIV:
- case CXt_LOOP_LAZYSV:
- case CXt_LOOP_LIST:
- case CXt_LOOP_ARY:
+ break;
+ case CXt_LOOP_LAZYIV:
+ case CXt_LOOP_LAZYSV:
+ case CXt_LOOP_LIST:
+ case CXt_LOOP_ARY:
if (cx->cx_type & CXp_FOR_DEF) {
- DEBUG_l( Perl_deb(aTHX_ "(dopoptogivenfor(): found foreach at cx=%ld)\n", (long)i));
- return i;
- }
- }
+ DEBUG_l( Perl_deb(aTHX_ "(dopoptogivenfor(): found foreach at cx=%ld)\n", (long)i));
+ return i;
+ }
+ }
}
return i;
}
{
I32 i;
for (i = startingblock; i >= 0; i--) {
- const PERL_CONTEXT *cx = &cxstack[i];
- switch (CxTYPE(cx)) {
- default:
- continue;
- case CXt_WHEN:
- DEBUG_l( Perl_deb(aTHX_ "(dopoptowhen(): found when at cx=%ld)\n", (long)i));
- return i;
- }
+ const PERL_CONTEXT *cx = &cxstack[i];
+ switch (CxTYPE(cx)) {
+ default:
+ continue;
+ case CXt_WHEN:
+ DEBUG_l( Perl_deb(aTHX_ "(dopoptowhen(): found when at cx=%ld)\n", (long)i));
+ return i;
+ }
}
return i;
}
Perl_dounwind(pTHX_ I32 cxix)
{
if (!PL_curstackinfo) /* can happen if die during thread cloning */
- return;
+ return;
while (cxstack_ix > cxix) {
PERL_CONTEXT *cx = CX_CUR();
- CX_DEBUG(cx, "UNWIND");
- /* Note: we don't need to restore the base context info till the end. */
+ CX_DEBUG(cx, "UNWIND");
+ /* Note: we don't need to restore the base context info till the end. */
CX_LEAVE_SCOPE(cx);
- switch (CxTYPE(cx)) {
- case CXt_SUBST:
- CX_POPSUBST(cx);
+ switch (CxTYPE(cx)) {
+ case CXt_SUBST:
+ CX_POPSUBST(cx);
/* CXt_SUBST is not a block context type, so skip the
* cx_popblock(cx) below */
if (cxstack_ix == cxix + 1) {
cxstack_ix--;
return;
}
- break;
- case CXt_SUB:
- cx_popsub(cx);
- break;
- case CXt_EVAL:
- cx_popeval(cx);
- break;
- case CXt_LOOP_PLAIN:
- case CXt_LOOP_LAZYIV:
- case CXt_LOOP_LAZYSV:
- case CXt_LOOP_LIST:
- case CXt_LOOP_ARY:
- cx_poploop(cx);
- break;
- case CXt_WHEN:
- cx_popwhen(cx);
- break;
- case CXt_GIVEN:
- cx_popgiven(cx);
- break;
- case CXt_BLOCK:
- case CXt_NULL:
+ break;
+ case CXt_SUB:
+ cx_popsub(cx);
+ break;
+ case CXt_EVAL:
+ cx_popeval(cx);
+ break;
+ case CXt_LOOP_PLAIN:
+ case CXt_LOOP_LAZYIV:
+ case CXt_LOOP_LAZYSV:
+ case CXt_LOOP_LIST:
+ case CXt_LOOP_ARY:
+ cx_poploop(cx);
+ break;
+ case CXt_WHEN:
+ cx_popwhen(cx);
+ break;
+ case CXt_GIVEN:
+ cx_popgiven(cx);
+ break;
+ case CXt_BLOCK:
+ case CXt_NULL:
+ case CXt_DEFER:
/* these two don't have a POPFOO() */
- break;
- case CXt_FORMAT:
- cx_popformat(cx);
- break;
- }
+ break;
+ case CXt_FORMAT:
+ cx_popformat(cx);
+ break;
+ }
if (cxstack_ix == cxix + 1) {
cx_popblock(cx);
}
- cxstack_ix--;
+ cxstack_ix--;
}
}
+
+/* Like rpp_popfree_to(), but takes an offset rather than a pointer,
+ * and frees everything above ix appropriately, *regardless* of the
+ * refcountedness of the stack. If necessary it removes any split stack.
+ * Intended for use during exit() and die() and similar.
+*/
void
-Perl_qerror(pTHX_ SV *err)
+Perl_rpp_obliterate_stack_to(pTHX_ I32 ix)
{
- PERL_ARGS_ASSERT_QERROR;
+#ifdef PERL_RC_STACK
+ I32 nonrc_base = PL_curstackinfo->si_stack_nonrc_base;
+ assert(ix >= 0);
+ assert(ix <= PL_stack_sp - PL_stack_base);
+ assert(nonrc_base <= PL_stack_sp - PL_stack_base + 1);
- if (PL_in_eval) {
- if (PL_in_eval & EVAL_KEEPERR) {
- Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %" SVf,
- SVfARG(err));
- }
- else
- sv_catsv(ERRSV, err);
+ if (nonrc_base && nonrc_base > ix) {
+ /* abandon any non-refcounted stuff */
+ PL_stack_sp = PL_stack_base + nonrc_base - 1;
+ /* and mark the stack as fully refcounted again */
+ PL_curstackinfo->si_stack_nonrc_base = 0;
}
- else if (PL_errors)
- sv_catsv(PL_errors, err);
+
+ if (rpp_stack_is_rc())
+ rpp_popfree_to(PL_stack_base + ix);
else
- Perl_warn(aTHX_ "%" SVf, SVfARG(err));
- if (PL_parser)
- ++PL_parser->error_count;
+ PL_stack_sp = PL_stack_base + ix;
+#else
+ PL_stack_sp = PL_stack_base + ix;
+#endif
+
}
+void
+Perl_qerror(pTHX_ SV *err)
+{
+ PERL_ARGS_ASSERT_QERROR;
+ if (err!=NULL) {
+ if (PL_in_eval) {
+ if (PL_in_eval & EVAL_KEEPERR) {
+ Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %" SVf,
+ SVfARG(err));
+ }
+ else {
+ sv_catsv(ERRSV, err);
+ }
+ }
+ else if (PL_errors)
+ sv_catsv(PL_errors, err);
+ else
+ Perl_warn(aTHX_ "%" SVf, SVfARG(err));
+
+ if (PL_parser) {
+ ++PL_parser->error_count;
+ }
+ }
+
+ if ( PL_parser && (err == NULL ||
+ PL_parser->error_count >= PERL_STOP_PARSING_AFTER_N_ERRORS)
+ ) {
+ const char * const name = OutCopFILE(PL_curcop);
+ SV * errsv = NULL;
+ U8 raw_error_count = PERL_PARSE_ERROR_COUNT(PL_parser->error_count);
+
+ if (PL_in_eval) {
+ errsv = ERRSV;
+ }
+
+ if (err == NULL) {
+ abort_execution(errsv, name);
+ }
+ else
+ if (raw_error_count >= PERL_STOP_PARSING_AFTER_N_ERRORS) {
+ if (errsv) {
+ Perl_croak(aTHX_ "%" SVf "%s has too many errors.\n",
+ SVfARG(errsv), name);
+ } else {
+ Perl_croak(aTHX_ "%s has too many errors.\n", name);
+ }
+ }
+ }
+}
+
/* pop a CXt_EVAL context and in addition, if it was a require then
* based on action:
if (do_croak) {
const char *fmt;
HV *inc_hv = GvHVn(PL_incgv);
- I32 klen = SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv);
- const char *key = SvPVX_const(namesv);
if (action == 1) {
- (void)hv_delete(inc_hv, key, klen, G_DISCARD);
+ (void)hv_delete_ent(inc_hv, namesv, G_DISCARD, 0);
fmt = "%" SVf " did not return a true value";
errsv = namesv;
}
else {
- (void)hv_store(inc_hv, key, klen, &PL_sv_undef, 0);
+ (void)hv_store_ent(inc_hv, namesv, &PL_sv_undef, 0);
fmt = "%" SVf "Compilation failed in require";
if (!errsv)
errsv = newSVpvs_flags("Unknown error\n", SVs_TEMP);
PERL_ARGS_ASSERT_DIE_UNWIND;
if (in_eval) {
- I32 cxix;
+ I32 cxix;
/* We need to keep this SV alive through all the stack unwinding
* and FREETMPSing below, while ensuing that it doesn't leak
* when unlocalising a tied var). So we do a dance with
* mortalising and SAVEFREEing.
*/
- sv_2mortal(SvREFCNT_inc_simple_NN(exceptsv));
-
- /*
- * Historically, perl used to set ERRSV ($@) early in the die
- * process and rely on it not getting clobbered during unwinding.
- * That sucked, because it was liable to get clobbered, so the
- * setting of ERRSV used to emit the exception from eval{} has
- * been moved to much later, after unwinding (see just before
- * JMPENV_JUMP below). However, some modules were relying on the
- * early setting, by examining $@ during unwinding to use it as
- * a flag indicating whether the current unwinding was caused by
- * an exception. It was never a reliable flag for that purpose,
- * being totally open to false positives even without actual
- * clobberage, but was useful enough for production code to
- * semantically rely on it.
- *
- * We'd like to have a proper introspective interface that
- * explicitly describes the reason for whatever unwinding
- * operations are currently in progress, so that those modules
- * work reliably and $@ isn't further overloaded. But we don't
- * have one yet. In its absence, as a stopgap measure, ERRSV is
- * now *additionally* set here, before unwinding, to serve as the
- * (unreliable) flag that it used to.
- *
- * This behaviour is temporary, and should be removed when a
- * proper way to detect exceptional unwinding has been developed.
- * As of 2010-12, the authors of modules relying on the hack
- * are aware of the issue, because the modules failed on
- * perls 5.13.{1..7} which had late setting of $@ without this
- * early-setting hack.
- */
- if (!(in_eval & EVAL_KEEPERR)) {
+ if (PL_phase == PERL_PHASE_DESTRUCT) {
+ exceptsv = sv_mortalcopy(exceptsv);
+ } else {
+ exceptsv = sv_2mortal(SvREFCNT_inc_simple_NN(exceptsv));
+ }
+
+ /*
+ * Historically, perl used to set ERRSV ($@) early in the die
+ * process and rely on it not getting clobbered during unwinding.
+ * That sucked, because it was liable to get clobbered, so the
+ * setting of ERRSV used to emit the exception from eval{} has
+ * been moved to much later, after unwinding (see just before
+ * JMPENV_JUMP below). However, some modules were relying on the
+ * early setting, by examining $@ during unwinding to use it as
+ * a flag indicating whether the current unwinding was caused by
+ * an exception. It was never a reliable flag for that purpose,
+ * being totally open to false positives even without actual
+ * clobberage, but was useful enough for production code to
+ * semantically rely on it.
+ *
+ * We'd like to have a proper introspective interface that
+ * explicitly describes the reason for whatever unwinding
+ * operations are currently in progress, so that those modules
+ * work reliably and $@ isn't further overloaded. But we don't
+ * have one yet. In its absence, as a stopgap measure, ERRSV is
+ * now *additionally* set here, before unwinding, to serve as the
+ * (unreliable) flag that it used to.
+ *
+ * This behaviour is temporary, and should be removed when a
+ * proper way to detect exceptional unwinding has been developed.
+ * As of 2010-12, the authors of modules relying on the hack
+ * are aware of the issue, because the modules failed on
+ * perls 5.13.{1..7} which had late setting of $@ without this
+ * early-setting hack.
+ */
+ if (!(in_eval & EVAL_KEEPERR)) {
/* remove any read-only/magic from the SV, so we don't
get infinite recursion when setting ERRSV */
SANE_ERRSV();
- sv_setsv_flags(ERRSV, exceptsv,
+ sv_setsv_flags(ERRSV, exceptsv,
(SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL));
}
- if (in_eval & EVAL_KEEPERR) {
- Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %" SVf,
- SVfARG(exceptsv));
- }
+ if (in_eval & EVAL_KEEPERR) {
+ Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %" SVf,
+ SVfARG(exceptsv));
+ }
- while ((cxix = dopoptoeval(cxstack_ix)) < 0
- && PL_curstackinfo->si_prev)
- {
- dounwind(-1);
- POPSTACK;
- }
+ while ((cxix = dopoptoeval(cxstack_ix)) < 0
+ && PL_curstackinfo->si_prev)
+ {
+ dounwind(-1);
+ rpp_obliterate_stack_to(0);
+ POPSTACK;
+ }
- if (cxix >= 0) {
- PERL_CONTEXT *cx;
- SV **oldsp;
+ if (cxix >= 0) {
+ PERL_CONTEXT *cx;
U8 gimme;
- JMPENV *restartjmpenv;
- OP *restartop;
+ JMPENV *restartjmpenv;
+ OP *restartop;
- if (cxix < cxstack_ix)
- dounwind(cxix);
+ if (cxix < cxstack_ix)
+ dounwind(cxix);
cx = CX_CUR();
assert(CxTYPE(cx) == CXt_EVAL);
+ rpp_obliterate_stack_to(cx->blk_oldsp);
+
/* return false to the caller of eval */
- oldsp = PL_stack_base + cx->blk_oldsp;
gimme = cx->blk_gimme;
- if (gimme == G_SCALAR)
- *++oldsp = &PL_sv_undef;
- PL_stack_sp = oldsp;
+ if (gimme == G_SCALAR)
+ rpp_xpush_IMM(&PL_sv_undef);
- restartjmpenv = cx->blk_eval.cur_top_env;
- restartop = cx->blk_eval.retop;
+ restartjmpenv = cx->blk_eval.cur_top_env;
+ restartop = cx->blk_eval.retop;
/* We need a FREETMPS here to avoid late-called destructors
* clobbering $@ *after* we set it below, e.g.
*/
S_pop_eval_context_maybe_croak(aTHX_ cx, exceptsv, 2);
- if (!(in_eval & EVAL_KEEPERR)) {
+ if (!(in_eval & EVAL_KEEPERR)) {
SANE_ERRSV();
- sv_setsv(ERRSV, exceptsv);
+ sv_setsv(ERRSV, exceptsv);
}
- PL_restartjmpenv = restartjmpenv;
- PL_restartop = restartop;
- JMPENV_JUMP(3);
- NOT_REACHED; /* NOTREACHED */
- }
+ PL_restartjmpenv = restartjmpenv;
+ PL_restartop = restartop;
+ JMPENV_JUMP(3);
+ NOT_REACHED; /* NOTREACHED */
+ }
}
write_to_stderr(exceptsv);
NOT_REACHED; /* NOTREACHED */
}
+
PP(pp_xor)
{
- dSP; dPOPTOPssrl;
- if (SvTRUE_NN(left) != SvTRUE_NN(right))
- RETSETYES;
- else
- RETSETNO;
+ SV *left = PL_stack_sp[0];
+ SV *right = PL_stack_sp[-1];
+ rpp_replace_2_IMM_NN(SvTRUE_NN(left) != SvTRUE_NN(right)
+ ? &PL_sv_yes
+ : &PL_sv_no);
+ return NORMAL;
}
+
/*
-=head1 CV Manipulation Functions
+=for apidoc_section $CV
=for apidoc caller_cx
const PERL_CONTEXT *
Perl_caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp)
{
- I32 cxix = dopoptosub(cxstack_ix);
+ I32 cxix = dopopto_cursub();
const PERL_CONTEXT *cx;
const PERL_CONTEXT *ccstack = cxstack;
const PERL_SI *top_si = PL_curstackinfo;
for (;;) {
- /* we may be in a higher stacklevel, so dig down deeper */
- while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
- top_si = top_si->si_prev;
- ccstack = top_si->si_cxstack;
- cxix = dopoptosub_at(ccstack, top_si->si_cxix);
- }
- if (cxix < 0)
- return NULL;
- /* caller() should not report the automatic calls to &DB::sub */
- if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
- ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
- count++;
- if (!count--)
- break;
- cxix = dopoptosub_at(ccstack, cxix - 1);
+ /* we may be in a higher stacklevel, so dig down deeper */
+ while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
+ top_si = top_si->si_prev;
+ ccstack = top_si->si_cxstack;
+ cxix = dopoptosub_at(ccstack, top_si->si_cxix);
+ }
+ if (cxix < 0)
+ return NULL;
+ /* caller() should not report the automatic calls to &DB::sub */
+ if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
+ ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
+ count++;
+ if (!count--)
+ break;
+ cxix = dopoptosub_at(ccstack, cxix - 1);
}
cx = &ccstack[cxix];
if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
- /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
- field below is defined for any cx. */
- /* caller() should not report the automatic calls to &DB::sub */
- if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
- cx = &ccstack[dbcxix];
+ /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
+ field below is defined for any cx. */
+ /* caller() should not report the automatic calls to &DB::sub */
+ if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
+ cx = &ccstack[dbcxix];
}
return cx;
}
-PP(pp_caller)
+PP_wrapped(pp_caller, MAXARG, 0)
{
dSP;
const PERL_CONTEXT *cx;
if (MAXARG) {
if (has_arg)
- count = POPi;
+ count = POPi;
else (void)POPs;
}
- cx = caller_cx(count + !!(PL_op->op_private & OPpOFFBYONE), &dbcx);
+ cx = caller_cx(count + cBOOL(PL_op->op_private & OPpOFFBYONE), &dbcx);
if (!cx) {
- if (gimme != G_ARRAY) {
- EXTEND(SP, 1);
- RETPUSHUNDEF;
- }
- RETURN;
+ if (gimme != G_LIST) {
+ EXTEND(SP, 1);
+ RETPUSHUNDEF;
+ }
+ RETURN;
+ }
+
+ /* populate @DB::args ? */
+ if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
+ && CopSTASH_eq(PL_curcop, PL_debstash))
+ {
+ /* slot 0 of the pad contains the original @_ */
+ AV * const ary = MUTABLE_AV(AvARRAY(MUTABLE_AV(
+ PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[
+ cx->blk_sub.olddepth+1]))[0]);
+ const SSize_t off = AvARRAY(ary) - AvALLOC(ary);
+
+ Perl_init_dbargs(aTHX);
+
+ if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
+ av_extend(PL_dbargs, AvFILLp(ary) + off);
+
+ /* Alias elements of @_ to @DB::args */
+ for (SSize_t i = AvFILLp(ary) + off; i >= 0; i--) {
+ SV* sv = AvALLOC(ary)[i];
+ /* for a shifted @_, the elements between AvALLOC and AvARRAY
+ * point to old SVs which may have been freed or even
+ * reallocated in the meantime. In the interests of
+ * reconstructing the original @_ before any shifting, use
+ * those old values, even at the risk of them being wrong.
+ * But if the ref count is 0, then don't use it because
+ * further assigning that value anywhere will panic.
+ * Of course there's nothing to stop a RC != 0 SV being
+ * subsequently freed, but hopefully people quickly copy the
+ * contents of @DB::args before doing anything else.
+ */
+ if (sv && (SvREFCNT(sv) == 0 || SvIS_FREED(sv)))
+ sv = NULL;
+ AvARRAY(PL_dbargs)[i] = sv;
+ }
+ AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
}
CX_DEBUG(cx, "CALLER");
stash_hek = SvTYPE(CopSTASH(cx->blk_oldcop)) == SVt_PVHV
? HvNAME_HEK((HV*)CopSTASH(cx->blk_oldcop))
: NULL;
- if (gimme != G_ARRAY) {
+ if (gimme != G_LIST) {
EXTEND(SP, 1);
- if (!stash_hek)
- PUSHs(&PL_sv_undef);
- else {
- dTARGET;
- sv_sethek(TARG, stash_hek);
- PUSHs(TARG);
- }
- RETURN;
+ if (!stash_hek)
+ PUSHs(&PL_sv_undef);
+ else {
+ dTARGET;
+ sv_sethek(TARG, stash_hek);
+ PUSHs(TARG);
+ }
+ RETURN;
}
EXTEND(SP, 11);
if (!stash_hek)
- PUSHs(&PL_sv_undef);
+ PUSHs(&PL_sv_undef);
else {
- dTARGET;
- sv_sethek(TARG, stash_hek);
- PUSHTARG;
+ dTARGET;
+ sv_sethek(TARG, stash_hek);
+ PUSHTARG;
}
mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
lcop = closest_cop(cx->blk_oldcop, OpSIBLING(cx->blk_oldcop),
- cx->blk_sub.retop, TRUE);
+ cx->blk_sub.retop, TRUE);
if (!lcop)
- lcop = cx->blk_oldcop;
+ lcop = cx->blk_oldcop;
mPUSHu(CopLINE(lcop));
if (!has_arg)
- RETURN;
+ RETURN;
if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
- /* So is ccstack[dbcxix]. */
- if (CvHASGV(dbcx->blk_sub.cv)) {
- PUSHs(cv_name(dbcx->blk_sub.cv, 0, 0));
- PUSHs(boolSV(CxHASARGS(cx)));
- }
- else {
- PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
- PUSHs(boolSV(CxHASARGS(cx)));
- }
+ /* So is ccstack[dbcxix]. */
+ if (CvHASGV(dbcx->blk_sub.cv)) {
+ PUSHs(cv_name(dbcx->blk_sub.cv, 0, 0));
+ PUSHs(boolSV(CxHASARGS(cx)));
+ }
+ else {
+ PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
+ PUSHs(boolSV(CxHASARGS(cx)));
+ }
}
else {
- PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
- PUSHs(&PL_sv_zero);
+ PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
+ PUSHs(&PL_sv_zero);
}
gimme = cx->blk_gimme;
if (gimme == G_VOID)
- PUSHs(&PL_sv_undef);
+ PUSHs(&PL_sv_undef);
else
- PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
+ PUSHs(boolSV((gimme & G_WANT) == G_LIST));
if (CxTYPE(cx) == CXt_EVAL) {
- /* eval STRING */
- if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
+ /* eval STRING */
+ if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
SV *cur_text = cx->blk_eval.cur_text;
if (SvCUR(cur_text) >= 2) {
PUSHs(newSVpvn_flags(SvPVX(cur_text), SvCUR(cur_text)-2,
PUSHs(sv_2mortal(newSVsv(cur_text)));
}
- PUSHs(&PL_sv_no);
- }
- /* require */
- else if (cx->blk_eval.old_namesv) {
- mPUSHs(newSVsv(cx->blk_eval.old_namesv));
- PUSHs(&PL_sv_yes);
- }
- /* eval BLOCK (try blocks have old_namesv == 0) */
- else {
- PUSHs(&PL_sv_undef);
- PUSHs(&PL_sv_undef);
- }
+ PUSHs(&PL_sv_no);
+ }
+ /* require */
+ else if (cx->blk_eval.old_namesv) {
+ mPUSHs(newSVsv(cx->blk_eval.old_namesv));
+ PUSHs(&PL_sv_yes);
+ }
+ /* eval BLOCK (try blocks have old_namesv == 0) */
+ else {
+ PUSHs(&PL_sv_undef);
+ PUSHs(&PL_sv_undef);
+ }
}
else {
- PUSHs(&PL_sv_undef);
- PUSHs(&PL_sv_undef);
+ PUSHs(&PL_sv_undef);
+ PUSHs(&PL_sv_undef);
}
- if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
- && CopSTASH_eq(PL_curcop, PL_debstash))
- {
- /* slot 0 of the pad contains the original @_ */
- AV * const ary = MUTABLE_AV(AvARRAY(MUTABLE_AV(
- PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[
- cx->blk_sub.olddepth+1]))[0]);
- const SSize_t off = AvARRAY(ary) - AvALLOC(ary);
-
- Perl_init_dbargs(aTHX);
- if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
- av_extend(PL_dbargs, AvFILLp(ary) + off);
- if (AvFILLp(ary) + 1 + off)
- Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
- AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
- }
mPUSHi(CopHINTS_get(cx->blk_oldcop));
{
- SV * mask ;
- STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
+ SV * mask ;
+ char *old_warnings = cx->blk_oldcop->cop_warnings;
- if (old_warnings == pWARN_NONE)
+ if (old_warnings == pWARN_NONE)
mask = newSVpvn(WARN_NONEstring, WARNsize) ;
- else if (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0)
+ else if (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0)
mask = &PL_sv_undef ;
else if (old_warnings == pWARN_ALL ||
- (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
- mask = newSVpvn(WARN_ALLstring, WARNsize) ;
- }
+ (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
+ mask = newSVpvn(WARN_ALLstring, WARNsize) ;
+ }
else
- mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
+ mask = newSVpvn(old_warnings, RCPV_LEN(old_warnings));
mPUSHs(mask);
}
PUSHs(cx->blk_oldcop->cop_hints_hash ?
- sv_2mortal(newRV_noinc(MUTABLE_SV(cop_hints_2hv(cx->blk_oldcop, 0))))
- : &PL_sv_undef);
+ sv_2mortal(newRV_noinc(MUTABLE_SV(cop_hints_2hv(cx->blk_oldcop, 0))))
+ : &PL_sv_undef);
RETURN;
}
-PP(pp_reset)
+
+PP_wrapped(pp_reset, MAXARG, 0)
{
dSP;
const char * tmps;
STRLEN len = 0;
if (MAXARG < 1 || (!TOPs && !POPs)) {
EXTEND(SP, 1);
- tmps = NULL, len = 0;
+ tmps = NULL, len = 0;
}
else
- tmps = SvPVx_const(POPs, len);
+ tmps = SvPVx_const(POPs, len);
sv_resetpvn(tmps, len, CopSTASH(PL_curcop));
PUSHs(&PL_sv_yes);
RETURN;
{
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();
if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
- || PL_DBsingle_iv || PL_DBsignal_iv || PL_DBtrace_iv)
+ || PL_DBsingle_iv || PL_DBsignal_iv || PL_DBtrace_iv)
{
- dSP;
- PERL_CONTEXT *cx;
- const U8 gimme = G_ARRAY;
- GV * const gv = PL_DBgv;
- CV * cv = NULL;
+ PERL_CONTEXT *cx;
+ const U8 gimme = G_LIST;
+ GV * const gv = PL_DBgv;
+ CV * cv = NULL;
if (gv && isGV_with_GP(gv))
cv = GvCV(gv);
- if (!cv || (!CvROOT(cv) && !CvXSUB(cv)))
- DIE(aTHX_ "No DB::DB routine defined");
+ if (!cv || (!CvROOT(cv) && !CvXSUB(cv)))
+ DIE(aTHX_ "No DB::DB routine defined");
- if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
- /* don't do recursive DB::DB call */
- return NORMAL;
+ if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
+ /* don't do recursive DB::DB call */
+ return NORMAL;
- if (CvISXSUB(cv)) {
+ if (CvISXSUB(cv)) {
ENTER;
SAVEI32(PL_debug);
PL_debug = 0;
+ /* I suspect that saving the stack position is no longer
+ * required. It was added in 5.001 by:
+ *
+ * NETaa13155: &DB::DB left trash on the stack.
+ * From: Thomas Koenig
+ * Files patched: lib/perl5db.pl pp_ctl.c
+ * The call by pp_dbstate() to &DB::DB left trash on the
+ * stack. It now calls DB in list context, and DB returns
+ * ().
+ *
+ * but the details of what bug it fixed are long lost to
+ * history. SAVESTACK_POS() doesn't work well with stacks
+ * which may be split into partly reference-counted and partly
+ * not halves, so skip it and hope it doesn't cause any
+ * problems.
+ */
+#ifndef PERL_RC_STACK
SAVESTACK_POS();
+#endif
SAVETMPS;
- PUSHMARK(SP);
- (void)(*CvXSUB(cv))(aTHX_ cv);
- FREETMPS;
- LEAVE;
- return NORMAL;
- }
- else {
- cx = cx_pushblock(CXt_SUB, gimme, SP, PL_savestack_ix);
- cx_pushsub(cx, cv, PL_op->op_next, 0);
+ PUSHMARK(PL_stack_sp);
+ rpp_invoke_xs(cv);
+ FREETMPS;
+ LEAVE;
+ return NORMAL;
+ }
+ else {
+#ifdef PERL_RC_STACK
+ assert(!PL_curstackinfo->si_stack_nonrc_base);
+#endif
+ cx = cx_pushblock(CXt_SUB, gimme, PL_stack_sp, PL_savestack_ix);
+ cx_pushsub(cx, cv, PL_op->op_next, 0);
/* OP_DBSTATE's op_private holds hint bits rather than
* the lvalue-ish flags seen in OP_ENTERSUB. So cancel
* any CxLVAL() flags that have now been mis-calculated */
SAVEI32(PL_debug);
PL_debug = 0;
+ /* see comment above about SAVESTACK_POS */
+#ifndef PERL_RC_STACK
SAVESTACK_POS();
- CvDEPTH(cv)++;
- if (CvDEPTH(cv) >= 2)
- pad_push(CvPADLIST(cv), CvDEPTH(cv));
- PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv));
- RETURNOP(CvSTART(cv));
- }
+#endif
+ CvDEPTH(cv)++;
+ if (CvDEPTH(cv) >= 2)
+ pad_push(CvPADLIST(cv), CvDEPTH(cv));
+ PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv));
+ return CvSTART(cv);
+ }
}
else
- return NORMAL;
+ return NORMAL;
}
if (PL_op->op_flags & OPf_SPECIAL)
/* fake block should preserve $1 et al; e.g. /(...)/ while ...; */
- cx->blk_oldpm = PL_curpm;
+ cx->blk_oldpm = PL_curpm;
oldsp = PL_stack_base + cx->blk_oldsp;
gimme = cx->blk_gimme;
if (gimme == G_VOID)
- PL_stack_sp = oldsp;
+ rpp_popfree_to_NN(oldsp);
else
leave_adjust_stacks(oldsp, oldsp, gimme,
PL_op->op_private & OPpLVALUE ? 3 : 1);
PP(pp_enteriter)
{
- dSP; dMARK;
+ dMARK;
PERL_CONTEXT *cx;
const U8 gimme = GIMME_V;
void *itervarp; /* GV or pad slot of the iteration variable */
U8 cxflags = 0;
if (PL_op->op_targ) { /* "my" variable */
- itervarp = &PAD_SVl(PL_op->op_targ);
+ itervarp = &PAD_SVl(PL_op->op_targ);
itersave = *(SV**)itervarp;
assert(itersave);
- if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
+ if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
/* the SV currently in the pad slot is never live during
* iteration (the slot is always aliased to one of the items)
* so it's always stale */
- SvPADSTALE_on(itersave);
- }
+ SvPADSTALE_on(itersave);
+ }
SvREFCNT_inc_simple_void_NN(itersave);
- cxflags = CXp_FOR_PAD;
+ cxflags = CXp_FOR_PAD;
}
else {
- SV * const sv = POPs;
- itervarp = (void *)sv;
+ SV * const sv = *PL_stack_sp;
+ itervarp = (void *)sv;
if (LIKELY(isGV(sv))) { /* symbol table variable */
itersave = GvSV(sv);
SvREFCNT_inc_simple_void(itersave);
itersave = NULL;
cxflags = CXp_FOR_LVREF;
}
+ /* we transfer ownership of 1 ref count of itervarp from the stack
+ * to the CX entry, so no SvREFCNT_dec() needed */
+ (void)rpp_pop_1_norc();
}
/* OPpITER_DEF (implicit $_) should only occur with a GV iter var */
assert((cxflags & CXp_FOR_GV) || !(PL_op->op_private & OPpITER_DEF));
/* OPf_STACKED implies either a single array: for(@), with a
* single AV on the stack, or a range: for (1..5), with 1 and 5 on
* the stack */
- SV *maybe_ary = POPs;
- if (SvTYPE(maybe_ary) != SVt_PVAV) {
+ SV *maybe_ary = *PL_stack_sp;
+ if (SvTYPE(maybe_ary) != SVt_PVAV) {
/* range */
- dPOPss;
- SV * const right = maybe_ary;
- if (UNLIKELY(cxflags & CXp_FOR_LVREF))
- DIE(aTHX_ "Assigned value is not a reference");
- SvGETMAGIC(sv);
- SvGETMAGIC(right);
- if (RANGE_IS_NUMERIC(sv,right)) {
- cx->cx_type |= CXt_LOOP_LAZYIV;
- if (S_outside_integer(aTHX_ sv) ||
+ SV* sv = PL_stack_sp[-1];
+ SV * const right = maybe_ary;
+ if (UNLIKELY(cxflags & CXp_FOR_LVREF))
+ DIE(aTHX_ "Assigned value is not a reference");
+ SvGETMAGIC(sv);
+ SvGETMAGIC(right);
+ if (RANGE_IS_NUMERIC(sv,right)) {
+ cx->cx_type |= CXt_LOOP_LAZYIV;
+ if (S_outside_integer(aTHX_ sv) ||
S_outside_integer(aTHX_ right))
- DIE(aTHX_ "Range iterator outside integer range");
- cx->blk_loop.state_u.lazyiv.cur = SvIV_nomg(sv);
- cx->blk_loop.state_u.lazyiv.end = SvIV_nomg(right);
- }
- else {
- cx->cx_type |= CXt_LOOP_LAZYSV;
- cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
- cx->blk_loop.state_u.lazysv.end = right;
- SvREFCNT_inc_simple_void_NN(right);
- (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
- /* This will do the upgrade to SVt_PV, and warn if the value
- is uninitialised. */
- (void) SvPV_nolen_const(right);
- /* Doing this avoids a check every time in pp_iter in pp_hot.c
- to replace !SvOK() with a pointer to "". */
- if (!SvOK(right)) {
- SvREFCNT_dec(right);
- cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
- }
- }
- }
- else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
+ DIE(aTHX_ "Range iterator outside integer range");
+ cx->blk_loop.state_u.lazyiv.cur = SvIV_nomg(sv);
+ cx->blk_loop.state_u.lazyiv.end = SvIV_nomg(right);
+ rpp_popfree_2_NN();
+ }
+ else {
+ cx->cx_type |= CXt_LOOP_LAZYSV;
+ cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
+ cx->blk_loop.state_u.lazysv.end = right;
+
+ /* we transfer ownership of 1 ref count of right from the
+ * stack to the CX .end entry, so no SvREFCNT_dec() needed */
+ (void)rpp_pop_1_norc();
+
+ rpp_popfree_1_NN(); /* free the (now copied) start SV */
+ (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
+ /* This will do the upgrade to SVt_PV, and warn if the value
+ is uninitialised. */
+ (void) SvPV_nolen_const(right);
+ /* Doing this avoids a check every time in pp_iter in pp_hot.c
+ to replace !SvOK() with a pointer to "". */
+ if (!SvOK(right)) {
+ SvREFCNT_dec(right);
+ cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
+ }
+ }
+ }
+ else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
/* for (@array) {} */
cx->cx_type |= CXt_LOOP_ARY;
- cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
- SvREFCNT_inc_simple_void_NN(maybe_ary);
- cx->blk_loop.state_u.ary.ix =
- (PL_op->op_private & OPpITER_REVERSED) ?
- AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
- -1;
- }
- /* EXTEND(SP, 1) not needed in this branch because we just did POPs */
+ cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
+ /* we transfer ownership of 1 ref count of the av from the
+ * stack to the CX .ary entry, so no SvREFCNT_dec() needed */
+ (void)rpp_pop_1_norc();
+ cx->blk_loop.state_u.ary.ix =
+ (PL_op->op_private & OPpITER_REVERSED) ?
+ AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
+ -1;
+ }
+ /* rpp_extend(1) not needed in this branch
+ * because we just popped 1 item */
}
else { /* iterating over items on the stack */
cx->cx_type |= CXt_LOOP_LIST;
- cx->blk_oldsp = SP - PL_stack_base;
- cx->blk_loop.state_u.stack.basesp = MARK - PL_stack_base;
+ cx->blk_oldsp = PL_stack_sp - PL_stack_base;
+ cx->blk_loop.state_u.stack.basesp = MARK - PL_stack_base;
cx->blk_loop.state_u.stack.ix =
(PL_op->op_private & OPpITER_REVERSED)
? cx->blk_oldsp + 1
: cx->blk_loop.state_u.stack.basesp;
/* pre-extend stack so pp_iter doesn't have to check every time
* it pushes yes/no */
- EXTEND(SP, 1);
+ rpp_extend(1);
}
- RETURN;
+ return NORMAL;
}
PP(pp_enterloop)
gimme = cx->blk_gimme;
if (gimme == G_VOID)
- PL_stack_sp = base;
+ rpp_popfree_to_NN(base);
else
leave_adjust_stacks(oldsp, base, gimme,
PL_op->op_private & OPpLVALUE ? 3 : 1);
/* 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 {
U8 lval = CxLVAL(cx);
bool is_lval = (lval && !(lval & OPpENTERSUB_INARGS));
if (lval & OPpDEREF) {
/* lval_sub()->{...} and similar */
- dSP;
- SvGETMAGIC(TOPs);
- if (!SvOK(TOPs)) {
- TOPs = vivify_ref(TOPs, CxLVAL(cx) & OPpDEREF);
+ SvGETMAGIC(*PL_stack_sp);
+ if (!SvOK(*PL_stack_sp)) {
+ SV *sv = vivify_ref(*PL_stack_sp, CxLVAL(cx) & OPpDEREF);
+ rpp_replace_1_1_NN(sv);
}
- PUTBACK;
}
}
else {
- assert(gimme == G_ARRAY);
+ assert(gimme == G_LIST);
assert (!(lval & OPpDEREF));
if (is_lval) {
return retop;
}
+static const char *S_defer_blockname(PERL_CONTEXT *cx)
+{
+ return (cx->cx_type & CXp_FINALLY) ? "finally" : "defer";
+}
+
PP(pp_return)
{
- dSP; dMARK;
+ dMARK;
PERL_CONTEXT *cx;
- const I32 cxix = dopoptosub(cxstack_ix);
+ I32 cxix = dopopto_cursub();
assert(cxstack_ix >= 0);
if (cxix < cxstack_ix) {
+ I32 i;
+ /* Check for defer { return; } */
+ for(i = cxstack_ix; i > cxix; i--) {
+ if(CxTYPE(&cxstack[i]) == CXt_DEFER)
+ /* diag_listed_as: Can't "%s" out of a "defer" block */
+ /* diag_listed_as: Can't "%s" out of a "finally" block */
+ Perl_croak(aTHX_ "Can't \"%s\" out of a \"%s\" block",
+ "return", S_defer_blockname(&cxstack[i]));
+ }
if (cxix < 0) {
if (!( PL_curstackinfo->si_type == PERLSI_SORT
|| ( PL_curstackinfo->si_type == PERLSI_MULTICALL
/* See comment below about context popping. Since we know
* we're scalar and not lvalue, we can preserve the return
* value in a simpler fashion than there. */
- SV *sv = *SP;
+ SV *sv = *PL_stack_sp;
assert(cxstack[0].blk_gimme == G_SCALAR);
- if ( (sp != PL_stack_base)
+ if ( (PL_stack_sp != PL_stack_base)
&& !(SvFLAGS(sv) & (SVs_TEMP|SVs_PADTMP))
)
- *SP = sv_mortalcopy(sv);
+#ifdef PERL_RC_STACK
+ rpp_replace_at_norc(PL_stack_sp, newSVsv(sv));
+#else
+ *PL_stack_sp = sv_mortalcopy(sv);
+#endif
dounwind(0);
}
/* caller responsible for popping cxstack[0] */
* isn't as inefficient as it sounds.
*/
cx = &cxstack[cxix];
- PUTBACK;
if (cx->blk_gimme != G_VOID)
leave_adjust_stacks(MARK, PL_stack_base + cx->blk_oldsp,
cx->blk_gimme,
CxTYPE(cx) == CXt_SUB && CvLVALUE(cx->blk_sub.cv)
? 3 : 0);
- SPAGAIN;
- dounwind(cxix);
+ dounwind(cxix);
cx = &cxstack[cxix]; /* CX stack may have been realloced */
}
else {
* context we can leave as-is (pp_leavesub will later return the
* top stack element). But for an empty arg list, e.g.
* for (1,2) { return }
- * we need to set sp = oldsp so that pp_leavesub knows to push
- * &PL_sv_undef onto the stack.
+ * we need to set PL_stack_sp = oldsp so that pp_leavesub knows to
+ * push &PL_sv_undef onto the stack.
*/
SV **oldsp;
cx = &cxstack[cxix];
oldsp = PL_stack_base + cx->blk_oldsp;
if (oldsp != MARK) {
- SSize_t nargs = SP - MARK;
+ SSize_t nargs = PL_stack_sp - MARK;
if (nargs) {
- if (cx->blk_gimme == G_ARRAY) {
+ if (cx->blk_gimme == G_LIST) {
/* shift return args to base of call stack frame */
+#ifdef PERL_RC_STACK
+ /* free the items on the stack that will get
+ * overwritten */
+ SV **p;
+ for (p = MARK; p > oldsp; p--) {
+ SV *sv = *p;
+ *p = NULL;
+ SvREFCNT_dec(sv);
+ }
+#endif
Move(MARK + 1, oldsp + 1, nargs, SV*);
PL_stack_sp = oldsp + nargs;
}
}
else
- PL_stack_sp = oldsp;
+ rpp_popfree_to_NN(oldsp);
}
}
/* fall through to a normal exit */
switch (CxTYPE(cx)) {
case CXt_EVAL:
- return CxTRYBLOCK(cx)
+ return CxEVALBLOCK(cx)
? Perl_pp_leavetry(aTHX)
: Perl_pp_leaveeval(aTHX);
case CXt_SUB:
case CXt_FORMAT:
return Perl_pp_leavewrite(aTHX);
default:
- DIE(aTHX_ "panic: return, type=%u", (unsigned) CxTYPE(cx));
+ DIE(aTHX_ "panic: return, type=%u", (unsigned) CxTYPE(cx));
}
}
{
I32 cxix;
if (PL_op->op_flags & OPf_SPECIAL) {
- cxix = dopoptoloop(cxstack_ix);
- if (cxix < 0)
- /* diag_listed_as: Can't "last" outside a loop block */
- Perl_croak(aTHX_ "Can't \"%s\" outside a loop block",
+ cxix = dopoptoloop(cxstack_ix);
+ if (cxix < 0)
+ /* diag_listed_as: Can't "last" outside a loop block */
+ Perl_croak(aTHX_ "Can't \"%s\" outside a loop block",
OP_NAME(PL_op));
}
else {
- dSP;
- STRLEN label_len;
- const char * const label =
- PL_op->op_flags & OPf_STACKED
- ? SvPV(TOPs,label_len)
- : (label_len = strlen(cPVOP->op_pv), cPVOP->op_pv);
- const U32 label_flags =
- PL_op->op_flags & OPf_STACKED
- ? SvUTF8(POPs)
- : (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
- PUTBACK;
+ STRLEN label_len;
+ const char * label;
+ U32 label_flags;
+ SV *sv;
+
+ if (PL_op->op_flags & OPf_STACKED) {
+ sv = *PL_stack_sp;
+ label = SvPV(sv, label_len);
+ label_flags = SvUTF8(sv);
+ }
+ else {
+ sv = NULL; /* not needed, but shuts up compiler warn */
+ label = cPVOP->op_pv;
+ label_len = strlen(label);
+ label_flags = (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
+ }
+
cxix = dopoptolabel(label, label_len, label_flags);
- if (cxix < 0)
- /* diag_listed_as: Label not found for "last %s" */
- Perl_croak(aTHX_ "Label not found for \"%s %" SVf "\"",
- OP_NAME(PL_op),
+ if (cxix < 0)
+ /* diag_listed_as: Label not found for "last %s" */
+ Perl_croak(aTHX_ "Label not found for \"%s %" SVf "\"",
+ OP_NAME(PL_op),
SVfARG(PL_op->op_flags & OPf_STACKED
- && !SvGMAGICAL(TOPp1s)
- ? TOPp1s
+ && !SvGMAGICAL(sv)
+ ? sv
: newSVpvn_flags(label,
label_len,
label_flags | SVs_TEMP)));
+ if (PL_op->op_flags & OPf_STACKED)
+ rpp_popfree_1_NN();
+ }
+
+ if (cxix < cxstack_ix) {
+ I32 i;
+ /* Check for defer { last ... } etc */
+ for(i = cxstack_ix; i > cxix; i--) {
+ if(CxTYPE(&cxstack[i]) == CXt_DEFER)
+ /* diag_listed_as: Can't "%s" out of a "defer" block */
+ /* diag_listed_as: Can't "%s" out of a "finally" block */
+ Perl_croak(aTHX_ "Can't \"%s\" out of a \"%s\" block",
+ OP_NAME(PL_op), S_defer_blockname(&cxstack[i]));
+ }
+ dounwind(cxix);
}
- if (cxix < cxstack_ix)
- dounwind(cxix);
return &cxstack[cxix];
}
cx = S_unwind_loop(aTHX);
assert(CxTYPE_is_LOOP(cx));
- PL_stack_sp = PL_stack_base
+ rpp_popfree_to_NN(PL_stack_base
+ (CxTYPE(cx) == CXt_LOOP_LIST
? cx->blk_loop.state_u.stack.basesp
: cx->blk_oldsp
- );
+ ));
TAINT_NOT;
OP* redo_op = cx->blk_loop.my_op->op_redoop;
if (redo_op->op_type == OP_ENTER) {
- /* pop one less context to avoid $x being freed in while (my $x..) */
- cxstack_ix++;
+ /* pop one less context to avoid $x being freed in while (my $x..) */
+ cxstack_ix++;
cx = CX_CUR();
- assert(CxTYPE(cx) == CXt_BLOCK);
- redo_op = redo_op->op_next;
+ assert(CxTYPE(cx) == CXt_BLOCK);
+ redo_op = redo_op->op_next;
}
FREETMPS;
PERL_ARGS_ASSERT_DOFINDLABEL;
if (ops >= oplimit)
- Perl_croak(aTHX_ "%s", too_deep);
+ Perl_croak(aTHX_ "%s", too_deep);
if (o->op_type == OP_LEAVE ||
- o->op_type == OP_SCOPE ||
- o->op_type == OP_LEAVELOOP ||
- o->op_type == OP_LEAVESUB ||
- o->op_type == OP_LEAVETRY ||
- o->op_type == OP_LEAVEGIVEN)
+ o->op_type == OP_SCOPE ||
+ o->op_type == OP_LEAVELOOP ||
+ o->op_type == OP_LEAVESUB ||
+ o->op_type == OP_LEAVETRY ||
+ o->op_type == OP_LEAVEGIVEN)
{
- *ops++ = cUNOPo->op_first;
+ *ops++ = cUNOPo->op_first;
}
else if (oplimit - opstack < GOTO_DEPTH) {
if (o->op_flags & OPf_KIDS
- && cUNOPo->op_first->op_type == OP_PUSHMARK) {
- *ops++ = UNENTERABLE;
+ && cUNOPo->op_first->op_type == OP_PUSHMARK) {
+ *ops++ = UNENTERABLE;
}
else if (o->op_flags & OPf_KIDS && PL_opargs[o->op_type]
- && OP_CLASS(o) != OA_LOGOP
- && o->op_type != OP_LINESEQ
- && o->op_type != OP_SREFGEN
- && o->op_type != OP_ENTEREVAL
- && o->op_type != OP_GLOB
- && o->op_type != OP_RV2CV) {
- OP * const kid = cUNOPo->op_first;
- if (OP_GIMME(kid, 0) != G_SCALAR || OpHAS_SIBLING(kid))
- *ops++ = UNENTERABLE;
+ && OP_CLASS(o) != OA_LOGOP
+ && o->op_type != OP_LINESEQ
+ && o->op_type != OP_SREFGEN
+ && o->op_type != OP_ENTEREVAL
+ && o->op_type != OP_GLOB
+ && o->op_type != OP_RV2CV) {
+ OP * const kid = cUNOPo->op_first;
+ if (OP_GIMME(kid, 0) != G_SCALAR || OpHAS_SIBLING(kid))
+ *ops++ = UNENTERABLE;
}
}
if (ops >= oplimit)
- Perl_croak(aTHX_ "%s", too_deep);
+ Perl_croak(aTHX_ "%s", too_deep);
*ops = 0;
if (o->op_flags & OPf_KIDS) {
- OP *kid;
- OP * const kid1 = cUNOPo->op_first;
- /* First try all the kids at this level, since that's likeliest. */
- for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
- if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
+ OP *kid;
+ OP * const kid1 = cUNOPo->op_first;
+ /* First try all the kids at this level, since that's likeliest. */
+ for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
+ if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
STRLEN kid_label_len;
U32 kid_label_flags;
- const char *kid_label = CopLABEL_len_flags(kCOP,
+ const char *kid_label = CopLABEL_len_flags(kCOP,
&kid_label_len, &kid_label_flags);
- if (kid_label && (
+ if (kid_label && (
( (kid_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
(flags & SVf_UTF8)
? (bytes_cmp_utf8(
(const U8*)kid_label, kid_label_len) == 0)
: ( len == kid_label_len && ((kid_label == label)
|| memEQ(kid_label, label, len)))))
- return kid;
- }
- }
- for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
- bool first_kid_of_binary = FALSE;
- if (kid == PL_lastgotoprobe)
- continue;
- if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
- if (ops == opstack)
- *ops++ = kid;
- else if (ops[-1] != UNENTERABLE
- && (ops[-1]->op_type == OP_NEXTSTATE ||
- ops[-1]->op_type == OP_DBSTATE))
- ops[-1] = kid;
- else
- *ops++ = kid;
- }
- if (kid == kid1 && ops != opstack && ops[-1] == UNENTERABLE) {
- first_kid_of_binary = TRUE;
- ops--;
- }
- if ((o = dofindlabel(kid, label, len, flags, ops, oplimit)))
- return o;
- if (first_kid_of_binary)
- *ops++ = UNENTERABLE;
- }
+ return kid;
+ }
+ }
+ for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
+ bool first_kid_of_binary = FALSE;
+ if (kid == PL_lastgotoprobe)
+ continue;
+ if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
+ if (ops == opstack)
+ *ops++ = kid;
+ else if (ops[-1] != UNENTERABLE
+ && (ops[-1]->op_type == OP_NEXTSTATE ||
+ ops[-1]->op_type == OP_DBSTATE))
+ ops[-1] = kid;
+ else
+ *ops++ = kid;
+ }
+ if (kid == kid1 && ops != opstack && ops[-1] == UNENTERABLE) {
+ first_kid_of_binary = TRUE;
+ ops--;
+ }
+ if ((o = dofindlabel(kid, label, len, flags, ops, oplimit))) {
+ if (kid->op_type == OP_PUSHDEFER)
+ Perl_croak(aTHX_ "Can't \"goto\" into a \"defer\" block");
+ return o;
+ }
+ if (first_kid_of_binary)
+ *ops++ = UNENTERABLE;
+ }
}
*ops = 0;
return 0;
* for each op. For now, we punt on the hard ones. */
/* XXX This comment seems to me like wishful thinking. --sprout */
if (o == UNENTERABLE)
- Perl_croak(aTHX_
+ Perl_croak(aTHX_
"Can't \"goto\" into a binary or list expression");
if (o->op_type == OP_ENTERITER)
Perl_croak(aTHX_
PP(pp_goto)
{
- dVAR; dSP;
OP *retop = NULL;
I32 ix;
PERL_CONTEXT *cx;
if (PL_op->op_flags & OPf_STACKED) {
/* goto EXPR or goto &foo */
- SV * const sv = POPs;
- SvGETMAGIC(sv);
+ SV * const sv = *PL_stack_sp;
+ SvGETMAGIC(sv);
- if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
+ if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
/* This egregious kludge implements goto &subroutine */
- I32 cxix;
- PERL_CONTEXT *cx;
- CV *cv = MUTABLE_CV(SvRV(sv));
- AV *arg = GvAV(PL_defgv);
-
- while (!CvROOT(cv) && !CvXSUB(cv)) {
- const GV * const gv = CvGV(cv);
- if (gv) {
- GV *autogv;
- SV *tmpstr;
- /* autoloaded stub? */
- if (cv != GvCV(gv) && (cv = GvCV(gv)))
- continue;
- autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv),
- GvNAMELEN(gv),
+ I32 cxix;
+ PERL_CONTEXT *cx;
+ CV *cv = MUTABLE_CV(SvRV(sv));
+ AV *arg = GvAV(PL_defgv);
+ CV *old_cv = NULL;
+
+ while (!CvROOT(cv) && !CvXSUB(cv)) {
+ const GV * const gv = CvGV(cv);
+ if (gv) {
+ GV *autogv;
+ SV *tmpstr;
+ /* autoloaded stub? */
+ if (cv != GvCV(gv) && (cv = GvCV(gv)))
+ continue;
+ autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv),
+ GvNAMELEN(gv),
GvNAMEUTF8(gv) ? SVf_UTF8 : 0);
- if (autogv && (cv = GvCV(autogv)))
- continue;
- tmpstr = sv_newmortal();
- gv_efullname3(tmpstr, gv, NULL);
- DIE(aTHX_ "Goto undefined subroutine &%" SVf, SVfARG(tmpstr));
- }
- DIE(aTHX_ "Goto undefined subroutine");
- }
-
- cxix = dopoptosub(cxstack_ix);
+ if (autogv && (cv = GvCV(autogv)))
+ continue;
+ tmpstr = sv_newmortal();
+ gv_efullname3(tmpstr, gv, NULL);
+ DIE(aTHX_ "Goto undefined subroutine &%" SVf, SVfARG(tmpstr));
+ }
+ DIE(aTHX_ "Goto undefined subroutine");
+ }
+
+ cxix = dopopto_cursub();
if (cxix < 0) {
DIE(aTHX_ "Can't goto subroutine outside a subroutine");
}
cx = &cxstack[cxix];
- /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
- if (CxTYPE(cx) == CXt_EVAL) {
- if (CxREALEVAL(cx))
- /* diag_listed_as: Can't goto subroutine from an eval-%s */
- DIE(aTHX_ "Can't goto subroutine from an eval-string");
- else
- /* diag_listed_as: Can't goto subroutine from an eval-%s */
- DIE(aTHX_ "Can't goto subroutine from an eval-block");
- }
- else if (CxMULTICALL(cx))
- DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
-
- /* First do some returnish stuff. */
-
- SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
- FREETMPS;
- if (cxix < cxstack_ix) {
- dounwind(cxix);
+ /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
+ if (CxTYPE(cx) == CXt_EVAL) {
+ if (CxREALEVAL(cx))
+ /* diag_listed_as: Can't goto subroutine from an eval-%s */
+ DIE(aTHX_ "Can't goto subroutine from an eval-string");
+ else
+ /* diag_listed_as: Can't goto subroutine from an eval-%s */
+ DIE(aTHX_ "Can't goto subroutine from an eval-block");
+ }
+ else if (CxMULTICALL(cx))
+ DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
+
+ /* Check for defer { goto &...; } */
+ for(ix = cxstack_ix; ix > cxix; ix--) {
+ if(CxTYPE(&cxstack[ix]) == CXt_DEFER)
+ /* diag_listed_as: Can't "%s" out of a "defer" block */
+ Perl_croak(aTHX_ "Can't \"%s\" out of a \"%s\" block",
+ "goto", S_defer_blockname(&cxstack[ix]));
+ }
+
+ /* First do some returnish stuff. */
+
+ SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
+ rpp_popfree_1_NN(); /* safe to free original sv now */
+
+ FREETMPS;
+ if (cxix < cxstack_ix) {
+ dounwind(cxix);
}
cx = CX_CUR();
- cx_topblock(cx);
- SPAGAIN;
+ cx_topblock(cx);
/* protect @_ during save stack unwind. */
if (arg)
SvREFCNT_inc_NN(sv_2mortal(MUTABLE_SV(arg)));
- assert(PL_scopestack_ix == cx->blk_oldscopesp);
+ assert(PL_scopestack_ix == cx->blk_oldscopesp);
CX_LEAVE_SCOPE(cx);
- if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
+ if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
/* this is part of cx_popsub_args() */
- AV* av = MUTABLE_AV(PAD_SVl(0));
+ AV* av = MUTABLE_AV(PAD_SVl(0));
assert(AvARRAY(MUTABLE_AV(
PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[
CvDEPTH(cx->blk_sub.cv)])) == PL_curpad);
* unless pad[0] and @_ differ (e.g. if the old sub did
* local *_ = []); in which case clear the old pad[0]
* array in the usual way */
- if (av == arg || AvREAL(av))
+
+ if (av != arg && !SvMAGICAL(av) && SvREFCNT(av) == 1
+#ifndef PERL_RC_STACK
+ && !AvREAL(av)
+#endif
+ )
+ clear_defarray_simple(av);
+ else
clear_defarray(av, av == arg);
- else CLEAR_ARGARRAY(av);
- }
+ }
/* don't restore PL_comppad here. It won't be needed if the
* sub we're going to is non-XS, but restoring it early then
* means the CX block gets processed again in dounwind,
* but this time with the wrong PL_comppad */
- /* A destructor called during LEAVE_SCOPE could have undefined
- * our precious cv. See bug #99850. */
- if (!CvROOT(cv) && !CvXSUB(cv)) {
- const GV * const gv = CvGV(cv);
- if (gv) {
- SV * const tmpstr = sv_newmortal();
- gv_efullname3(tmpstr, gv, NULL);
- DIE(aTHX_ "Goto undefined subroutine &%" SVf,
- SVfARG(tmpstr));
- }
- DIE(aTHX_ "Goto undefined subroutine");
- }
-
- if (CxTYPE(cx) == CXt_SUB) {
- CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth;
- SvREFCNT_dec_NN(cx->blk_sub.cv);
+ /* A destructor called during LEAVE_SCOPE could have undefined
+ * our precious cv. See bug #99850. */
+ if (!CvROOT(cv) && !CvXSUB(cv)) {
+ const GV * const gv = CvGV(cv);
+ if (gv) {
+ SV * const tmpstr = sv_newmortal();
+ gv_efullname3(tmpstr, gv, NULL);
+ DIE(aTHX_ "Goto undefined subroutine &%" SVf,
+ SVfARG(tmpstr));
+ }
+ DIE(aTHX_ "Goto undefined subroutine");
+ }
+
+ if (CxTYPE(cx) == CXt_SUB) {
+ CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth;
+ /*on XS calls defer freeing the old CV as it could
+ * prematurely set PL_op to NULL, which could cause
+ * e..g XS subs using GIMME_V to SEGV */
+ if (CvISXSUB(cv))
+ old_cv = cx->blk_sub.cv;
+ else
+ SvREFCNT_dec_NN(cx->blk_sub.cv);
}
- /* Now do some callish stuff. */
- if (CvISXSUB(cv)) {
- const SSize_t items = arg ? AvFILL(arg) + 1 : 0;
- const bool m = arg ? cBOOL(SvRMAGICAL(arg)) : 0;
- SV** mark;
+ /* Now do some callish stuff. */
+ if (CvISXSUB(cv)) {
+ const SSize_t items = arg ? AvFILL(arg) + 1 : 0;
+ const bool m = arg ? cBOOL(SvRMAGICAL(arg)) : 0;
+ SV** mark;
+ UNOP fake_goto_op;
ENTER;
SAVETMPS;
SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
+ if (old_cv)
+ SAVEFREESV(old_cv); /* ditto, deferred freeing of old CV */
+
+ /* put GvAV(defgv) back onto stack */
+ if (items)
+ rpp_extend(items + 1); /* @_ could have been extended. */
+ mark = PL_stack_sp;
+ if (items) {
+ SSize_t index;
+#ifdef PERL_RC_STACK
+ assert(AvREAL(arg));
+#else
+ bool r = cBOOL(AvREAL(arg));
+#endif
+ for (index=0; index<items; index++)
+ {
+ SV *sv;
+ if (m) {
+ SV ** const svp = av_fetch(arg, index, 0);
+ sv = svp ? *svp : NULL;
+ }
+ else sv = AvARRAY(arg)[index];
+
+#ifdef PERL_RC_STACK
+ rpp_push_1(
+ sv
+ ? sv
+ : newSVavdefelem(arg, index, 1)
+ );
+#else
+ rpp_push_1(
+ sv
+ ? (r ? SvREFCNT_inc_NN(sv_2mortal(sv)) : sv)
+ : sv_2mortal(newSVavdefelem(arg, index, 1))
+ );
+#endif
+ }
+ }
- /* put GvAV(defgv) back onto stack */
- if (items) {
- EXTEND(SP, items+1); /* @_ could have been extended. */
- }
- mark = SP;
- if (items) {
- SSize_t index;
- bool r = cBOOL(AvREAL(arg));
- for (index=0; index<items; index++)
- {
- SV *sv;
- if (m) {
- SV ** const svp = av_fetch(arg, index, 0);
- sv = svp ? *svp : NULL;
- }
- else sv = AvARRAY(arg)[index];
- SP[index+1] = sv
- ? r ? SvREFCNT_inc_NN(sv_2mortal(sv)) : sv
- : sv_2mortal(newSVavdefelem(arg, index, 1));
- }
- }
- SP += items;
- if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
- /* Restore old @_ */
+ if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
+ /* Restore old @_ */
CX_POP_SAVEARRAY(cx);
- }
+ }
- retop = cx->blk_sub.retop;
+ retop = cx->blk_sub.retop;
PL_comppad = cx->blk_sub.prevcomppad;
PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
- /* XS subs don't have a CXt_SUB, so pop it;
+ /* Make a temporary a copy of the current GOTO op on the C
+ * stack, but with a modified gimme (we can't modify the
+ * real GOTO op as that's not thread-safe). This allows XS
+ * users of GIMME_V to get the correct calling context,
+ * even though there is no longer a CXt_SUB frame to
+ * provide that information.
+ */
+ Copy(PL_op, &fake_goto_op, 1, UNOP);
+ fake_goto_op.op_flags =
+ (fake_goto_op.op_flags & ~OPf_WANT)
+ | (cx->blk_gimme & G_WANT);
+ PL_op = (OP*)&fake_goto_op;
+
+ /* XS subs don't have a CXt_SUB, so pop it;
* this is a cx_popblock(), less all the stuff we already did
* for cx_topblock() earlier */
PL_curcop = cx->blk_oldcop;
+ /* this is cx_popsub, less all the stuff we already did */
+ PL_curstackinfo->si_cxsubix = cx->blk_sub.old_cxsubix;
+
CX_POP(cx);
- /* Push a mark for the start of arglist */
- PUSHMARK(mark);
- PUTBACK;
- (void)(*CvXSUB(cv))(aTHX_ cv);
- LEAVE;
- goto _return;
- }
- else {
- PADLIST * const padlist = CvPADLIST(cv);
+ /* Push a mark for the start of arglist */
+ PUSHMARK(mark);
+ rpp_invoke_xs(cv);
+ LEAVE;
+ goto finish;
+ }
+ else {
+ PADLIST * const padlist = CvPADLIST(cv);
SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
/* partial unrolled cx_pushsub(): */
- cx->blk_sub.cv = cv;
- cx->blk_sub.olddepth = CvDEPTH(cv);
+ cx->blk_sub.cv = cv;
+ cx->blk_sub.olddepth = CvDEPTH(cv);
- CvDEPTH(cv)++;
+ CvDEPTH(cv)++;
SvREFCNT_inc_simple_void_NN(cv);
- if (CvDEPTH(cv) > 1) {
- if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
- sub_crush_depth(cv);
- pad_push(padlist, CvDEPTH(cv));
- }
- PL_curcop = cx->blk_oldcop;
- PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
- if (CxHASARGS(cx))
- {
+ if (CvDEPTH(cv) > 1) {
+ if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
+ sub_crush_depth(cv);
+ pad_push(padlist, CvDEPTH(cv));
+ }
+ PL_curcop = cx->blk_oldcop;
+ PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
+
+ if (CxHASARGS(cx))
+ {
/* second half of donating @_ from the old sub to the
* new sub: abandon the original pad[0] AV in the
* new sub, and replace it with the donated @_.
* pad[0] takes ownership of the extra refcount
* we gave arg earlier */
- if (arg) {
- SvREFCNT_dec(PAD_SVl(0));
- PAD_SVl(0) = (SV *)arg;
+ if (arg) {
+ SvREFCNT_dec(PAD_SVl(0));
+ PAD_SVl(0) = (SV *)arg;
SvREFCNT_inc_simple_void_NN(arg);
- }
-
- /* GvAV(PL_defgv) might have been modified on scope
- exit, so point it at arg again. */
- if (arg != GvAV(PL_defgv)) {
- AV * const av = GvAV(PL_defgv);
- GvAV(PL_defgv) = (AV *)SvREFCNT_inc_simple(arg);
- SvREFCNT_dec(av);
- }
- }
-
- if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
- Perl_get_db_sub(aTHX_ NULL, cv);
- if (PERLDB_GOTO) {
- CV * const gotocv = get_cvs("DB::goto", 0);
- if (gotocv) {
- PUSHMARK( PL_stack_sp );
- call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
- PL_stack_sp--;
- }
- }
- }
- retop = CvSTART(cv);
- goto putback_return;
- }
- }
- else {
+ }
+
+ /* GvAV(PL_defgv) might have been modified on scope
+ exit, so point it at arg again. */
+ if (arg != GvAV(PL_defgv)) {
+ AV * const av = GvAV(PL_defgv);
+ GvAV(PL_defgv) = (AV *)SvREFCNT_inc_simple(arg);
+ SvREFCNT_dec(av);
+ }
+ }
+
+ if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
+ Perl_get_db_sub(aTHX_ NULL, cv);
+ if (PERLDB_GOTO) {
+ CV * const gotocv = get_cvs("DB::goto", 0);
+ if (gotocv) {
+ PUSHMARK( PL_stack_sp );
+ call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
+ PL_stack_sp--;
+ }
+ }
+ }
+ retop = CvSTART(cv);
+ goto finish;
+ }
+ }
+ else {
/* goto EXPR */
- label = SvPV_nomg_const(sv, label_len);
+ /* avoid premature free of label before popping it off stack */
+ SvREFCNT_inc_NN(sv);
+ sv_2mortal(sv);
+ rpp_popfree_1_NN();
+ label = SvPV_nomg_const(sv, label_len);
label_flags = SvUTF8(sv);
- }
+ }
}
else if (!(PL_op->op_flags & OPf_SPECIAL)) {
/* goto LABEL or dump LABEL */
- label = cPVOP->op_pv;
+ label = cPVOP->op_pv;
label_flags = (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
label_len = strlen(label);
}
PERL_ASYNC_CHECK();
if (label_len) {
- OP *gotoprobe = NULL;
- bool leaving_eval = FALSE;
- bool in_block = FALSE;
- bool pseudo_block = FALSE;
- PERL_CONTEXT *last_eval_cx = NULL;
-
- /* find label */
-
- PL_lastgotoprobe = NULL;
- *enterops = 0;
- for (ix = cxstack_ix; ix >= 0; ix--) {
- cx = &cxstack[ix];
- switch (CxTYPE(cx)) {
- case CXt_EVAL:
- leaving_eval = TRUE;
- if (!CxTRYBLOCK(cx)) {
- gotoprobe = (last_eval_cx ?
- last_eval_cx->blk_eval.old_eval_root :
- PL_eval_root);
- last_eval_cx = cx;
- break;
+ OP *gotoprobe = NULL;
+ bool leaving_eval = FALSE;
+ bool in_block = FALSE;
+ bool pseudo_block = FALSE;
+ PERL_CONTEXT *last_eval_cx = NULL;
+
+ /* find label */
+
+ PL_lastgotoprobe = NULL;
+ *enterops = 0;
+ for (ix = cxstack_ix; ix >= 0; ix--) {
+ cx = &cxstack[ix];
+ switch (CxTYPE(cx)) {
+ case CXt_EVAL:
+ leaving_eval = TRUE;
+ if (!CxEVALBLOCK(cx)) {
+ gotoprobe = (last_eval_cx ?
+ last_eval_cx->blk_eval.old_eval_root :
+ PL_eval_root);
+ last_eval_cx = cx;
+ break;
}
/* else fall through */
case CXt_LOOP_PLAIN:
case CXt_LOOP_LAZYSV:
case CXt_LOOP_LIST:
case CXt_LOOP_ARY:
- case CXt_GIVEN:
- case CXt_WHEN:
- gotoprobe = OpSIBLING(cx->blk_oldcop);
- break;
- case CXt_SUBST:
- continue;
- case CXt_BLOCK:
- if (ix) {
- gotoprobe = OpSIBLING(cx->blk_oldcop);
- in_block = TRUE;
- } else
- gotoprobe = PL_main_root;
- break;
- case CXt_SUB:
- gotoprobe = CvROOT(cx->blk_sub.cv);
- pseudo_block = cBOOL(CxMULTICALL(cx));
- break;
- case CXt_FORMAT:
- case CXt_NULL:
- DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
- default:
- if (ix)
- DIE(aTHX_ "panic: goto, type=%u, ix=%ld",
- CxTYPE(cx), (long) ix);
- gotoprobe = PL_main_root;
- break;
- }
- if (gotoprobe) {
+ case CXt_GIVEN:
+ case CXt_WHEN:
+ gotoprobe = OpSIBLING(cx->blk_oldcop);
+ break;
+ case CXt_SUBST:
+ continue;
+ case CXt_BLOCK:
+ if (ix) {
+ gotoprobe = OpSIBLING(cx->blk_oldcop);
+ in_block = TRUE;
+ } else
+ gotoprobe = PL_main_root;
+ break;
+ case CXt_SUB:
+ gotoprobe = CvROOT(cx->blk_sub.cv);
+ pseudo_block = cBOOL(CxMULTICALL(cx));
+ break;
+ case CXt_FORMAT:
+ case CXt_NULL:
+ DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
+ case CXt_DEFER:
+ /* diag_listed_as: Can't "%s" out of a "defer" block */
+ DIE(aTHX_ "Can't \"%s\" out of a \"%s\" block", "goto", S_defer_blockname(cx));
+ default:
+ if (ix)
+ DIE(aTHX_ "panic: goto, type=%u, ix=%ld",
+ CxTYPE(cx), (long) ix);
+ gotoprobe = PL_main_root;
+ break;
+ }
+ if (gotoprobe) {
OP *sibl1, *sibl2;
- retop = dofindlabel(gotoprobe, label, label_len, label_flags,
- enterops, enterops + GOTO_DEPTH);
- if (retop)
- break;
- if ( (sibl1 = OpSIBLING(gotoprobe)) &&
- sibl1->op_type == OP_UNSTACK &&
- (sibl2 = OpSIBLING(sibl1)))
+ retop = dofindlabel(gotoprobe, label, label_len, label_flags,
+ enterops, enterops + GOTO_DEPTH);
+ if (retop)
+ break;
+ if ( (sibl1 = OpSIBLING(gotoprobe)) &&
+ sibl1->op_type == OP_UNSTACK &&
+ (sibl2 = OpSIBLING(sibl1)))
{
- retop = dofindlabel(sibl2,
- label, label_len, label_flags, enterops,
- enterops + GOTO_DEPTH);
- if (retop)
- break;
- }
- }
- if (pseudo_block)
- DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
- PL_lastgotoprobe = gotoprobe;
- }
- if (!retop)
- DIE(aTHX_ "Can't find label %" UTF8f,
- UTF8fARG(label_flags, label_len, label));
-
- /* if we're leaving an eval, check before we pop any frames
+ retop = dofindlabel(sibl2,
+ label, label_len, label_flags, enterops,
+ enterops + GOTO_DEPTH);
+ if (retop)
+ break;
+ }
+ }
+ if (pseudo_block)
+ DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
+ PL_lastgotoprobe = gotoprobe;
+ }
+ if (!retop)
+ DIE(aTHX_ "Can't find label %" UTF8f,
+ UTF8fARG(label_flags, label_len, label));
+
+ /* if we're leaving an eval, check before we pop any frames
that we're not going to punt, otherwise the error
- won't be caught */
+ won't be caught */
- if (leaving_eval && *enterops && enterops[1]) {
- I32 i;
+ if (leaving_eval && *enterops && enterops[1]) {
+ I32 i;
for (i = 1; enterops[i]; i++)
S_check_op_type(aTHX_ enterops[i]);
- }
-
- if (*enterops && enterops[1]) {
- I32 i = enterops[1] != UNENTERABLE
- && enterops[1]->op_type == OP_ENTER && in_block
- ? 2
- : 1;
- if (enterops[i])
- deprecate("\"goto\" to jump into a construct");
- }
-
- /* pop unwanted frames */
-
- if (ix < cxstack_ix) {
- if (ix < 0)
- DIE(aTHX_ "panic: docatch: illegal ix=%ld", (long)ix);
- dounwind(ix);
+ }
+
+ if (*enterops && enterops[1]) {
+ I32 i = enterops[1] != UNENTERABLE
+ && enterops[1]->op_type == OP_ENTER && in_block
+ ? 2
+ : 1;
+ if (enterops[i])
+ deprecate_fatal_in(WARN_DEPRECATED__GOTO_CONSTRUCT,
+ "5.42",
+ "Use of \"goto\" to jump into a construct");
+ }
+
+ /* pop unwanted frames */
+
+ if (ix < cxstack_ix) {
+ if (ix < 0)
+ DIE(aTHX_ "panic: docatch: illegal ix=%ld", (long)ix);
+ dounwind(ix);
cx = CX_CUR();
- cx_topblock(cx);
- }
-
- /* push wanted frames */
-
- if (*enterops && enterops[1]) {
- OP * const oldop = PL_op;
- ix = enterops[1] != UNENTERABLE
- && enterops[1]->op_type == OP_ENTER && in_block
- ? 2
- : 1;
- for (; enterops[ix]; ix++) {
- PL_op = enterops[ix];
- S_check_op_type(aTHX_ PL_op);
- DEBUG_l( Perl_deb(aTHX_ "pp_goto: Entering %s\n",
- OP_NAME(PL_op)));
- PL_op->op_ppaddr(aTHX);
- }
- PL_op = oldop;
- }
+ cx_topblock(cx);
+ }
+
+ /* push wanted frames */
+
+ if (*enterops && enterops[1]) {
+ OP * const oldop = PL_op;
+ ix = enterops[1] != UNENTERABLE
+ && enterops[1]->op_type == OP_ENTER && in_block
+ ? 2
+ : 1;
+ for (; enterops[ix]; ix++) {
+ PL_op = enterops[ix];
+ S_check_op_type(aTHX_ PL_op);
+ DEBUG_l( Perl_deb(aTHX_ "pp_goto: Entering %s\n",
+ OP_NAME(PL_op)));
+ PL_op->op_ppaddr(aTHX);
+ }
+ PL_op = oldop;
+ }
}
if (do_dump) {
#ifdef VMS
- if (!retop) retop = PL_main_start;
+ if (!retop) retop = PL_main_start;
#endif
- PL_restartop = retop;
- PL_do_undump = TRUE;
+ PL_restartop = retop;
+ PL_do_undump = TRUE;
- my_unexec();
+ my_unexec();
- PL_restartop = 0; /* hmm, must be GNU unexec().. */
- PL_do_undump = FALSE;
+ PL_restartop = 0; /* hmm, must be GNU unexec().. */
+ PL_do_undump = FALSE;
}
- putback_return:
- PL_stack_sp = sp;
- _return:
+ finish:
PERL_ASYNC_CHECK();
return retop;
}
-PP(pp_exit)
+PP_wrapped(pp_exit, 1, 0)
{
dSP;
I32 anum;
if (MAXARG < 1)
- anum = 0;
+ anum = 0;
else if (!TOPs) {
- anum = 0; (void)POPs;
+ anum = 0; (void)POPs;
}
else {
- anum = SvIVx(POPs);
+ anum = SvIVx(POPs);
#ifdef VMS
- if (anum == 1
- && SvTRUE(cop_hints_fetch_pvs(PL_curcop, "vmsish_exit", 0)))
- anum = 0;
+ if (anum == 1
+ && SvTRUE(cop_hints_fetch_pvs(PL_curcop, "vmsish_exit", 0)))
+ anum = 0;
VMSISH_HUSHED =
VMSISH_HUSHED || (PL_curcop->op_private & OPpHUSH_VMSISH);
#endif
PERL_ARGS_ASSERT_SAVE_LINES;
while (s && s < send) {
- const char *t;
- SV * const tmpstr = newSV_type(SVt_PVMG);
+ const char *t;
+ SV * const tmpstr = newSV_type(SVt_PVMG);
- t = (const char *)memchr(s, '\n', send - s);
- if (t)
- t++;
- else
- t = send;
+ t = (const char *)memchr(s, '\n', send - s);
+ if (t)
+ t++;
+ else
+ t = send;
- sv_setpvn(tmpstr, s, t - s);
- av_store(array, line++, tmpstr);
- s = t;
+ sv_setpvn_fresh(tmpstr, s, t - s);
+ av_store(array, line++, tmpstr);
+ s = t;
}
}
/*
=for apidoc docatch
-Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context.
+Interpose, for the current op and RUNOPS loop,
-0 is used as continue inside eval,
+ - a new JMPENV stack catch frame, and
+ - an inner RUNOPS loop to run all the remaining ops following the
+ current PL_op.
-3 is used for a die caught by an inner eval - continue inner loop
+Then handle any exceptions raised while in that loop.
+For a caught eval at this level, re-enter the loop with the specified
+restart op (i.e. the op following the OP_LEAVETRY etc); otherwise re-throw
+the exception.
-See F<cop.h>: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
-establish a local jmpenv to handle exception traps.
+docatch() is intended to be used like this:
+
+ PP(pp_entertry)
+ {
+ if (CATCH_GET)
+ return docatch(Perl_pp_entertry);
+
+ ... rest of function ...
+ return PL_op->op_next;
+ }
+
+If a new catch frame isn't needed, the op behaves normally. Otherwise it
+calls docatch(), which recursively calls pp_entertry(), this time with
+CATCH_GET() false, so the rest of the body of the entertry is run. Then
+docatch() calls CALLRUNOPS() which executes all the ops following the
+entertry. When the loop finally finishes, control returns to docatch(),
+which pops the JMPENV and returns to the parent pp_entertry(), which
+itself immediately returns. Note that *all* subsequent ops are run within
+the inner RUNOPS loop, not just the body of the eval. For example, in
+
+ sub TIEARRAY { eval {1}; my $x }
+ tie @a, "main";
+
+at the point the 'my' is executed, the C stack will look something like:
+
+ #10 main()
+ #9 perl_run() # JMPENV_PUSH level 1 here
+ #8 S_run_body()
+ #7 Perl_runops_standard() # main RUNOPS loop
+ #6 Perl_pp_tie()
+ #5 Perl_call_sv()
+ #4 Perl_runops_standard() # unguarded RUNOPS loop: no new JMPENV
+ #3 Perl_pp_entertry()
+ #2 S_docatch() # JMPENV_PUSH level 2 here
+ #1 Perl_runops_standard() # docatch()'s RUNOPs loop
+ #0 Perl_pp_padsv()
+
+Basically, any section of the perl core which starts a RUNOPS loop may
+make a promise that it will catch any exceptions and restart the loop if
+necessary. If it's not prepared to do that (like call_sv() isn't), then
+it sets CATCH_GET() to true, so that any later eval-like code knows to
+set up a new handler and loop (via docatch()).
+
+See L<perlinterp/"Exception handing"> for further details.
=cut
*/
+
STATIC OP *
S_docatch(pTHX_ Perl_ppaddr_t firstpp)
{
OP * const oldop = PL_op;
dJMPENV;
- assert(CATCH_GET == TRUE);
-
+ assert(CATCH_GET);
JMPENV_PUSH(ret);
+ assert(!CATCH_GET);
+
switch (ret) {
- case 0:
- PL_op = firstpp(aTHX);
+ case 0: /* normal flow-of-control return from JMPENV_PUSH */
+
+ /* re-run the current op, this time executing the full body of the
+ * pp function */
+ PL_op = firstpp(aTHX);
redo_body:
- CALLRUNOPS(aTHX);
- break;
- case 3:
- /* die caught by an inner eval - continue inner loop */
- if (PL_restartop && PL_restartjmpenv == PL_top_env) {
- PL_restartjmpenv = NULL;
- PL_op = PL_restartop;
- PL_restartop = 0;
- goto redo_body;
- }
- /* FALLTHROUGH */
+ if (PL_op) {
+ CALLRUNOPS(aTHX);
+ }
+ break;
+
+ case 3: /* an exception raised within an eval */
+ if (PL_restartjmpenv == PL_top_env) {
+ /* die caught by an inner eval - continue inner loop */
+
+ if (!PL_restartop)
+ break;
+ PL_restartjmpenv = NULL;
+ PL_op = PL_restartop;
+ PL_restartop = 0;
+ goto redo_body;
+ }
+ /* FALLTHROUGH */
+
default:
- JMPENV_POP;
- PL_op = oldop;
- JMPENV_JUMP(ret);
- NOT_REACHED; /* NOTREACHED */
+ JMPENV_POP;
+ PL_op = oldop;
+ JMPENV_JUMP(ret); /* re-throw the exception */
+ NOT_REACHED; /* NOTREACHED */
}
JMPENV_POP;
PL_op = oldop;
int level = 0;
if (db_seqp)
- *db_seqp =
+ *db_seqp =
PL_curcop == &PL_compiling
? PL_cop_seqmax
: PL_curcop->cop_seq;
for (si = PL_curstackinfo; si; si = si->si_prev) {
I32 ix;
- for (ix = si->si_cxix; ix >= 0; ix--) {
- const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
- CV *cv = NULL;
- if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
- cv = cx->blk_sub.cv;
- /* skip DB:: code */
- if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
- *db_seqp = cx->blk_oldcop->cop_seq;
- continue;
- }
+ for (ix = si->si_cxix; ix >= 0; ix--) {
+ const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
+ CV *cv = NULL;
+ if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
+ cv = cx->blk_sub.cv;
+ /* skip DB:: code */
+ if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
+ *db_seqp = cx->blk_oldcop->cop_seq;
+ continue;
+ }
if (cx->cx_type & CXp_SUB_RE)
continue;
- }
- else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
- cv = cx->blk_eval.cv;
- if (cv) {
- switch (cond) {
- case FIND_RUNCV_padid_eq:
- if (!CvPADLIST(cv)
- || CvPADLIST(cv)->xpadl_id != (U32)arg)
- continue;
- return cv;
- case FIND_RUNCV_level_eq:
- if (level++ != arg) continue;
+ }
+ else if (CxTYPE(cx) == CXt_EVAL && !CxEVALBLOCK(cx))
+ cv = cx->blk_eval.cv;
+ if (cv) {
+ switch (cond) {
+ case FIND_RUNCV_padid_eq:
+ if (!CvPADLIST(cv)
+ || CvPADLIST(cv)->xpadl_id != (U32)arg)
+ continue;
+ return cv;
+ case FIND_RUNCV_level_eq:
+ if (level++ != arg) continue;
/* FALLTHROUGH */
- default:
- return cv;
- }
- }
- }
+ default:
+ return cv;
+ }
+ }
+ }
}
return cond == FIND_RUNCV_padid_eq ? NULL : PL_main_cv;
}
-/* Run yyparse() in a setjmp wrapper. Returns:
+/* S_try_yyparse():
+ *
+ * Run yyparse() in a setjmp wrapper. Returns:
* 0: yyparse() successful
* 1: yyparse() failed
* 3: yyparse() died
+ *
+ * This is used to trap Perl_croak() calls that are executed
+ * during the compilation process and before the code has been
+ * completely compiled. It is expected to be called from
+ * doeval_compile() only. The parameter 'caller_op' is
+ * only used in DEBUGGING to validate the logic is working
+ * correctly.
+ *
+ * See also try_run_unitcheck().
+ *
*/
STATIC int
-S_try_yyparse(pTHX_ int gramtype)
+S_try_yyparse(pTHX_ int gramtype, OP *caller_op)
{
- int ret;
+ /* if we die during compilation PL_restartop and PL_restartjmpenv
+ * will be set by Perl_die_unwind(). We need to restore their values
+ * if that happens as they are intended for the case where the code
+ * compiles and dies during execution, not where it dies during
+ * compilation. PL_restartop and caller_op->op_next should be the
+ * same anyway, and when compilation fails then caller_op->op_next is
+ * used as the next op after the compile.
+ */
+ JMPENV *restartjmpenv = PL_restartjmpenv;
+ OP *restartop = PL_restartop;
dJMPENV;
+ int ret;
+ PERL_UNUSED_ARG(caller_op); /* only used in debugging builds */
assert(CxTYPE(CX_CUR()) == CXt_EVAL);
JMPENV_PUSH(ret);
switch (ret) {
case 0:
- ret = yyparse(gramtype) ? 1 : 0;
- break;
+ ret = yyparse(gramtype) ? 1 : 0;
+ break;
case 3:
- break;
+ /* yyparse() died and we trapped the error. We need to restore
+ * the old PL_restartjmpenv and PL_restartop values. */
+ assert(PL_restartop == caller_op->op_next); /* we expect these to match */
+ PL_restartjmpenv = restartjmpenv;
+ PL_restartop = restartop;
+ break;
default:
- JMPENV_POP;
- JMPENV_JUMP(ret);
- NOT_REACHED; /* NOTREACHED */
+ JMPENV_POP;
+ JMPENV_JUMP(ret);
+ NOT_REACHED; /* NOTREACHED */
}
JMPENV_POP;
return ret;
}
+/* S_try_run_unitcheck()
+ *
+ * Run PL_unitcheckav in a setjmp wrapper via call_list.
+ * Returns:
+ * 0: unitcheck blocks ran without error
+ * 3: a unitcheck block died
+ *
+ * This is used to trap Perl_croak() calls that are executed
+ * during UNITCHECK blocks executed after the compilation
+ * process has completed but before the code itself has been
+ * executed via the normal run loops. It is expected to be called
+ * from doeval_compile() only. The parameter 'caller_op' is
+ * only used in DEBUGGING to validate the logic is working
+ * correctly.
+ *
+ * See also try_yyparse().
+ */
+STATIC int
+S_try_run_unitcheck(pTHX_ OP* caller_op)
+{
+ /* if we die during compilation PL_restartop and PL_restartjmpenv
+ * will be set by Perl_die_unwind(). We need to restore their values
+ * if that happens as they are intended for the case where the code
+ * compiles and dies during execution, not where it dies during
+ * compilation. UNITCHECK runs after compilation completes, and
+ * if it dies we will execute the PL_restartop anyway via the
+ * failed compilation code path. PL_restartop and caller_op->op_next
+ * should be the same anyway, and when compilation fails then
+ * caller_op->op_next is used as the next op after the compile.
+ */
+ JMPENV *restartjmpenv = PL_restartjmpenv;
+ OP *restartop = PL_restartop;
+ dJMPENV;
+ int ret;
+ PERL_UNUSED_ARG(caller_op); /* only used in debugging builds */
+
+ assert(CxTYPE(CX_CUR()) == CXt_EVAL);
+ JMPENV_PUSH(ret);
+ switch (ret) {
+ case 0:
+ call_list(PL_scopestack_ix, PL_unitcheckav);
+ break;
+ case 3:
+ /* call_list died */
+ /* call_list() died and we trapped the error. We should restore
+ * the old PL_restartjmpenv and PL_restartop values, as they are
+ * used only in the case where the code was actually run.
+ * The assert validates that we will still execute the PL_restartop.
+ */
+ assert(PL_restartop == caller_op->op_next); /* we expect these to match */
+ PL_restartjmpenv = restartjmpenv;
+ PL_restartop = restartop;
+ break;
+ default:
+ JMPENV_POP;
+ JMPENV_JUMP(ret);
+ NOT_REACHED; /* NOTREACHED */
+ }
+ JMPENV_POP;
+ return ret;
+}
/* Compile a require/do or an eval ''.
*
STATIC bool
S_doeval_compile(pTHX_ U8 gimme, CV* outside, U32 seq, HV *hh)
{
- dSP;
OP * const saveop = PL_op;
bool clear_hints = saveop->op_type != OP_ENTEREVAL;
COP * const oldcurcop = PL_curcop;
CV *evalcv;
PL_in_eval = (in_require
- ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
- : (EVAL_INEVAL |
+ ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
+ : (EVAL_INEVAL |
((PL_op->op_private & OPpEVAL_RE_REPARSING)
? EVAL_RE_REPARSING : 0)));
- PUSHMARK(SP);
+ PUSHMARK(PL_stack_sp);
evalcv = MUTABLE_CV(newSV_type(SVt_PVCV));
CvEVAL_on(evalcv);
/* make sure we compile in the right package */
if (CopSTASH_ne(PL_curcop, PL_curstash)) {
- SAVEGENERICSV(PL_curstash);
- PL_curstash = (HV *)CopSTASH(PL_curcop);
- if (SvTYPE(PL_curstash) != SVt_PVHV) PL_curstash = NULL;
- else {
- SvREFCNT_inc_simple_void(PL_curstash);
- save_item(PL_curstname);
- sv_sethek(PL_curstname, HvNAME_HEK(PL_curstash));
- }
+ SAVEGENERICSV(PL_curstash);
+ PL_curstash = (HV *)CopSTASH(PL_curcop);
+ if (SvTYPE(PL_curstash) != SVt_PVHV) PL_curstash = NULL;
+ else {
+ SvREFCNT_inc_simple_void(PL_curstash);
+ save_item(PL_curstname);
+ sv_sethek(PL_curstname, HvNAME_HEK(PL_curstash));
+ }
}
/* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
SAVESPTR(PL_beginav);
PL_eval_root = NULL;
PL_curcop = &PL_compiling;
if ((saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
- PL_in_eval |= EVAL_KEEPERR;
+ PL_in_eval |= EVAL_KEEPERR;
else
- CLEAR_ERRSV();
+ CLEAR_ERRSV();
SAVEHINTS();
if (clear_hints) {
- PL_hints = 0;
- hv_clear(GvHV(PL_hintgv));
+ PL_hints = HINTS_DEFAULT;
+ PL_prevailing_version = 0;
+ hv_clear(GvHV(PL_hintgv));
+ CLEARFEATUREBITS();
}
else {
- PL_hints = saveop->op_private & OPpEVAL_COPHH
- ? oldcurcop->cop_hints : (U32)saveop->op_targ;
+ PL_hints = saveop->op_private & OPpEVAL_COPHH
+ ? oldcurcop->cop_hints : (U32)saveop->op_targ;
/* making 'use re eval' not be in scope when compiling the
* qr/mabye_has_runtime_code_block/ ensures that we don't get
if (PL_in_eval & EVAL_RE_REPARSING)
PL_hints &= ~HINT_RE_EVAL;
- if (hh) {
- /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
- SvREFCNT_dec(GvHV(PL_hintgv));
- GvHV(PL_hintgv) = hh;
- }
+ if (hh) {
+ /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
+ SvREFCNT_dec(GvHV(PL_hintgv));
+ GvHV(PL_hintgv) = hh;
+ FETCHFEATUREBITSHH(hh);
+ }
}
SAVECOMPILEWARNINGS();
if (clear_hints) {
- if (PL_dowarn & G_WARN_ALL_ON)
- PL_compiling.cop_warnings = pWARN_ALL ;
- else if (PL_dowarn & G_WARN_ALL_OFF)
- PL_compiling.cop_warnings = pWARN_NONE ;
- else
- PL_compiling.cop_warnings = pWARN_STD ;
+ if (PL_dowarn & G_WARN_ALL_ON)
+ PL_compiling.cop_warnings = pWARN_ALL ;
+ else if (PL_dowarn & G_WARN_ALL_OFF)
+ PL_compiling.cop_warnings = pWARN_NONE ;
+ else
+ PL_compiling.cop_warnings = pWARN_STD ;
}
else {
- PL_compiling.cop_warnings =
- DUP_WARNINGS(oldcurcop->cop_warnings);
- cophh_free(CopHINTHASH_get(&PL_compiling));
- if (Perl_cop_fetch_label(aTHX_ oldcurcop, NULL, NULL)) {
- /* The label, if present, is the first entry on the chain. So rather
- than writing a blank label in front of it (which involves an
- allocation), just use the next entry in the chain. */
- PL_compiling.cop_hints_hash
- = cophh_copy(oldcurcop->cop_hints_hash->refcounted_he_next);
- /* Check the assumption that this removed the label. */
- assert(Perl_cop_fetch_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
- }
- else
- PL_compiling.cop_hints_hash = cophh_copy(oldcurcop->cop_hints_hash);
+ PL_compiling.cop_warnings =
+ DUP_WARNINGS(oldcurcop->cop_warnings);
+ cophh_free(CopHINTHASH_get(&PL_compiling));
+ if (Perl_cop_fetch_label(aTHX_ oldcurcop, NULL, NULL)) {
+ /* The label, if present, is the first entry on the chain. So rather
+ than writing a blank label in front of it (which involves an
+ allocation), just use the next entry in the chain. */
+ PL_compiling.cop_hints_hash
+ = cophh_copy(oldcurcop->cop_hints_hash->refcounted_he_next);
+ /* Check the assumption that this removed the label. */
+ assert(Perl_cop_fetch_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
+ }
+ else
+ PL_compiling.cop_hints_hash = cophh_copy(oldcurcop->cop_hints_hash);
}
CALL_BLOCK_HOOKS(bhk_eval, saveop);
- /* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
- * so honour CATCH_GET and trap it here if necessary */
+ /* we should never be CATCH_GET true here, as our immediate callers should
+ * always handle that case. */
+ assert(!CATCH_GET);
+ /* compile the code */
- /* compile the code */
- yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG);
+ yystatus = (!in_require)
+ ? S_try_yyparse(aTHX_ GRAMPROG, saveop)
+ : yyparse(GRAMPROG);
if (yystatus || PL_parser->error_count || !PL_eval_root) {
- PERL_CONTEXT *cx;
+ PERL_CONTEXT *cx;
SV *errsv;
- PL_op = saveop;
- /* note that if yystatus == 3, then the require/eval died during
- * compilation, so the EVAL CX block has already been popped, and
- * various vars restored */
- if (yystatus != 3) {
- if (PL_eval_root) {
- op_free(PL_eval_root);
- PL_eval_root = NULL;
- }
- SP = PL_stack_base + POPMARK; /* pop original mark */
+ PL_op = saveop;
+ if (yystatus != 3) {
+ /* note that if yystatus == 3, then the require/eval died during
+ * compilation, so the EVAL CX block has already been popped, and
+ * various vars restored. This block applies similar steps after
+ * the other "failed to compile" cases in yyparse, eg, where
+ * yystatus=1, "failed, but did not die". */
+
+ if (!in_require)
+ invoke_exception_hook(ERRSV,FALSE);
+
+ op_free(PL_eval_root);
+ PL_eval_root = NULL;
+
+ rpp_popfree_to(PL_stack_base + POPMARK); /* pop original mark */
cx = CX_CUR();
assert(CxTYPE(cx) == CXt_EVAL);
+ /* If we are in an eval we need to make sure that $SIG{__DIE__}
+ * handler is invoked so we simulate that part of the
+ * Perl_die_unwind() process. In a require we will croak
+ * so it will happen there. */
/* pop the CXt_EVAL, and if was a require, croak */
S_pop_eval_context_maybe_croak(aTHX_ cx, ERRSV, 2);
- }
+
+ }
/* die_unwind() re-croaks when in require, having popped the
* require EVAL context. So we should never catch a require
* exception here */
- assert(!in_require);
+ assert(!in_require);
- errsv = ERRSV;
+ errsv = ERRSV;
if (!*(SvPV_nolen_const(errsv)))
sv_setpvs(errsv, "Compilation error");
- if (gimme != G_ARRAY) PUSHs(&PL_sv_undef);
- PUTBACK;
- return FALSE;
+ if (gimme == G_SCALAR) {
+ if (yystatus == 3) {
+ /* die_unwind already pushed undef in scalar context */
+ assert(*PL_stack_sp == &PL_sv_undef);
+ }
+ else {
+ rpp_xpush_1(&PL_sv_undef);
+ }
+ }
+ return FALSE;
}
/* Compilation successful. Now clean up */
/* Register with debugger: */
if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
- CV * const cv = get_cvs("DB::postponed", 0);
- if (cv) {
- dSP;
- PUSHMARK(SP);
- XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
- PUTBACK;
- call_sv(MUTABLE_SV(cv), G_DISCARD);
- }
+ CV * const cv = get_cvs("DB::postponed", 0);
+ if (cv) {
+ PUSHMARK(PL_stack_sp);
+ rpp_xpush_1(MUTABLE_SV(CopFILEGV(&PL_compiling)));
+ call_sv(MUTABLE_SV(cv), G_DISCARD);
+ }
}
- if (PL_unitcheckav) {
- OP *es = PL_eval_start;
- call_list(PL_scopestack_ix, PL_unitcheckav);
- PL_eval_start = es;
+ if (PL_unitcheckav && av_count(PL_unitcheckav)>0) {
+ OP *es = PL_eval_start;
+ /* TODO: are we sure we shouldn't do S_try_run_unitcheck()
+ * when `in_require` is true? */
+ if (in_require) {
+ call_list(PL_scopestack_ix, PL_unitcheckav);
+ }
+ else if (S_try_run_unitcheck(aTHX_ saveop)) {
+ /* there was an error! */
+
+ /* Restore PL_OP */
+ PL_op = saveop;
+
+ SV *errsv = ERRSV;
+ if (!*(SvPV_nolen_const(errsv))) {
+ /* This happens when using:
+ * eval qq# UNITCHECK { die "\x00"; } #;
+ */
+ sv_setpvs(errsv, "Unit check error");
+ }
+
+ if (gimme != G_LIST)
+ rpp_xpush_1(&PL_sv_undef);
+ return FALSE;
+ }
+ PL_eval_start = es;
}
CvDEPTH(evalcv) = 1;
- SP = PL_stack_base + POPMARK; /* pop original mark */
+ rpp_popfree_to_NN(PL_stack_base + POPMARK); /* pop original mark */
PL_op = saveop; /* The caller may need it. */
PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
- PUTBACK;
return TRUE;
}
+
/* Return NULL if the file doesn't exist or isn't a file;
* else return PerlIO_openn().
*/
st_rc = PerlLIO_stat(p, &st);
if (st_rc < 0)
- return NULL;
+ return NULL;
else {
- int eno;
- if(S_ISBLK(st.st_mode)) {
- eno = EINVAL;
- goto not_file;
- }
- else if(S_ISDIR(st.st_mode)) {
- eno = EISDIR;
- not_file:
- errno = eno;
- return NULL;
- }
+ int eno;
+ if(S_ISBLK(st.st_mode)) {
+ eno = EINVAL;
+ goto not_file;
+ }
+ else if(S_ISDIR(st.st_mode)) {
+ eno = EISDIR;
+ not_file:
+ errno = eno;
+ return NULL;
+ }
}
#endif
/* EACCES stops the INC search early in pp_require to implement
feature RT #113422 */
if(!retio && errno == EACCES) { /* exists but probably a directory */
- int eno;
- st_rc = PerlLIO_stat(p, &st);
- if (st_rc >= 0) {
- if(S_ISDIR(st.st_mode))
- eno = EISDIR;
- else if(S_ISBLK(st.st_mode))
- eno = EINVAL;
- else
- eno = EACCES;
- errno = eno;
- }
+ int eno;
+ st_rc = PerlLIO_stat(p, &st);
+ if (st_rc >= 0) {
+ if(S_ISDIR(st.st_mode))
+ eno = EISDIR;
+ else if(S_ISBLK(st.st_mode))
+ eno = EINVAL;
+ else
+ eno = EACCES;
+ errno = eno;
+ }
}
#endif
return retio;
return NULL;
if (memENDPs(p, namelen, ".pm")) {
- SV *const pmcsv = sv_newmortal();
- PerlIO * pmcio;
+ SV *const pmcsv = sv_newmortal();
+ PerlIO * pmcio;
- SvSetSV_nosteal(pmcsv,name);
- sv_catpvs(pmcsv, "c");
+ SvSetSV_nosteal(pmcsv,name);
+ sv_catpvs(pmcsv, "c");
- pmcio = check_type_and_open(pmcsv);
- if (pmcio)
- return pmcio;
+ pmcio = check_type_and_open(pmcsv);
+ if (pmcio)
+ return pmcio;
}
return check_type_and_open(name);
}
if (PERL_FILE_IS_ABSOLUTE(name)
#ifdef WIN32
- || (*name == '.' && ((name[1] == '/' ||
- (name[1] == '.' && name[2] == '/'))
- || (name[1] == '\\' ||
- ( name[1] == '.' && name[2] == '\\')))
- )
+ || (*name == '.' && ((name[1] == '/' ||
+ (name[1] == '.' && name[2] == '/'))
+ || (name[1] == '\\' ||
+ ( name[1] == '.' && name[2] == '\\')))
+ )
#else
- || (*name == '.' && (name[1] == '/' ||
- (name[1] == '.' && name[2] == '/')))
+ || (*name == '.' && (name[1] == '/' ||
+ (name[1] == '.' && name[2] == '/')))
#endif
- )
+ )
{
- return FALSE;
+ return FALSE;
}
else
- return TRUE;
+ return TRUE;
}
static OP *
S_require_version(pTHX_ SV *sv)
{
- dVAR; dSP;
-
sv = sv_2mortal(new_version(sv));
+ rpp_popfree_1_NN();
+
if (!Perl_sv_derived_from_pvn(aTHX_ PL_patchlevel, STR_WITH_LEN("version"), 0))
upg_version(PL_patchlevel, TRUE);
if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
first = SvIV(*av_fetch(lav,0,0));
if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
|| hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
- || av_tindex(lav) > 1 /* FP with > 3 digits */
+ || av_count(lav) > 2 /* FP with > 3 digits */
|| strstr(SvPVX(pv),".0") /* FP with leading 0 */
) {
DIE(aTHX_ "Perl %" SVf " required--this is only "
SV *hintsv;
I32 second = 0;
- if (av_tindex(lav)>=1)
+ if (av_count(lav) > 1)
second = SvIV(*av_fetch(lav,1,0));
second /= second >= 600 ? 100 : 10;
}
}
- RETPUSHYES;
+ rpp_push_IMM(&PL_sv_yes);
+ return NORMAL;
}
+
/* Handle C<require Foo::Bar>, C<require "Foo/Bar.pm"> and C<do "Foo.pm">.
* The first form will have already been converted at compile time to
- * the second form */
+ * the second form.
+ * sv is still on the stack at this point. */
static OP *
S_require_file(pTHX_ SV *sv)
{
- dVAR; dSP;
-
PERL_CONTEXT *cx;
const char *name;
STRLEN len;
if (!(name && len > 0 && *name))
DIE(aTHX_ "Missing or undefined argument to %s", op_name);
+ if (
+ PL_hook__require__before
+ && SvROK(PL_hook__require__before)
+ && SvTYPE(SvRV(PL_hook__require__before)) == SVt_PVCV
+ ) {
+ SV* name_sv = sv_mortalcopy(sv);
+ SV *post_hook__require__before_sv = NULL;
+
+ ENTER_with_name("call_PRE_REQUIRE");
+ SAVETMPS;
+ PUSHMARK(PL_stack_sp);
+ rpp_xpush_1(name_sv); /* always use the object for method calls */
+ call_sv(PL_hook__require__before, G_SCALAR);
+ SV *rsv = *PL_stack_sp;
+ if (SvOK(rsv) && SvROK(rsv) && SvTYPE(SvRV(rsv)) == SVt_PVCV) {
+ /* the RC++ preserves it across the popping and/or FREETMPS
+ * below */
+ post_hook__require__before_sv = SvREFCNT_inc_simple_NN(rsv);
+ rpp_popfree_1_NN();
+ }
+ if (!sv_streq(name_sv,sv)) {
+ /* they modified the name argument, so do some sleight of hand */
+ name = SvPV_nomg_const(name_sv, len);
+ if (!(name && len > 0 && *name))
+ DIE(aTHX_ "Missing or undefined argument to %s via %%{^HOOK}{require__before}",
+ op_name);
+ sv = name_sv;
+ }
+ FREETMPS;
+ LEAVE_with_name("call_PRE_REQUIRE");
+ if (post_hook__require__before_sv) {
+ SV *nsv = newSVsv(sv);
+ MORTALDESTRUCTOR_SV(post_hook__require__before_sv, nsv);
+ SvREFCNT_dec_NN(nsv);
+ SvREFCNT_dec_NN(post_hook__require__before_sv);
+ }
+ }
+ if (
+ PL_hook__require__after
+ && SvROK(PL_hook__require__after)
+ && SvTYPE(SvRV(PL_hook__require__after)) == SVt_PVCV
+ ) {
+ SV *nsv = newSVsv(sv);
+ MORTALDESTRUCTOR_SV(PL_hook__require__after, nsv);
+ SvREFCNT_dec_NN(nsv);
+ }
+
#ifndef VMS
- /* try to return earlier (save the SAFE_PATHNAME check) if INC already got the name */
- if (op_is_require) {
- /* can optimize to only perform one single lookup */
- svp_cached = hv_fetch(GvHVn(PL_incgv), (char*) name, len, 0);
- if ( svp_cached && *svp_cached != &PL_sv_undef ) RETPUSHYES;
- }
+ /* try to return earlier (save the SAFE_PATHNAME check) if INC already got the name */
+ if (op_is_require) {
+ /* can optimize to only perform one single lookup */
+ svp_cached = hv_fetch(GvHVn(PL_incgv), (char*) name, len, 0);
+ if (svp_cached &&
+ (SvGETMAGIC(*svp_cached), SvOK(*svp_cached)))
+ {
+ rpp_replace_1_IMM_NN(&PL_sv_yes);
+ return NORMAL;
+ }
+ }
#endif
if (!IS_SAFE_PATHNAME(name, len, op_name)) {
if (!op_is_require) {
CLEAR_ERRSV();
- RETPUSHUNDEF;
+ rpp_replace_1_IMM_NN(&PL_sv_undef);
+ return NORMAL;
}
DIE(aTHX_ "Can't locate %s: %s",
pv_escape(newSVpvs_flags("",SVs_TEMP),name,len,len*2,
*/
if ((unixname =
- tounixspec(name, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
- != NULL) {
- unixlen = strlen(unixname);
- vms_unixname = 1;
+ tounixspec(name, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
+ != NULL) {
+ unixlen = strlen(unixname);
+ vms_unixname = 1;
}
else
#endif
{
/* if not VMS or VMS name can not be translated to UNIX, pass it
- * through.
- */
- unixname = (char *) name;
- unixlen = len;
+ * through.
+ */
+ unixname = (char *) name;
+ unixlen = len;
}
if (op_is_require) {
- /* reuse the previous hv_fetch result if possible */
- SV * const * const svp = svp_cached ? svp_cached : hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
- if ( svp ) {
- if (*svp != &PL_sv_undef)
- RETPUSHYES;
- else
- DIE(aTHX_ "Attempt to reload %s aborted.\n"
- "Compilation failed in require", unixname);
- }
+ /* reuse the previous hv_fetch result if possible */
+ SV * const * const svp = svp_cached ? svp_cached : hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
+ if ( svp ) {
+ /* we already did a get magic if this was cached */
+ if (!svp_cached)
+ SvGETMAGIC(*svp);
+ if (SvOK(*svp)) {
+ rpp_replace_1_IMM_NN(&PL_sv_yes);
+ return NORMAL;
+ }
+ else
+ DIE(aTHX_ "Attempt to reload %s aborted.\n"
+ "Compilation failed in require", unixname);
+ }
/*XXX OPf_KIDS should always be true? -dapm 4/2017 */
if (PL_op->op_flags & OPf_KIDS) {
- SVOP * const kid = (SVOP*)cUNOP->op_first;
+ SVOP * const kid = cSVOPx(cUNOP->op_first);
if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
/* Make sure that a bareword module name (e.g. ::Foo::Bar)
/* with "/foo/bar.pm", "./foo.pm" and "../foo/bar.pm", try to load
* the file directly rather than via @INC ... */
if (!path_searchable) {
- /* At this point, name is SvPVX(sv) */
- tryname = name;
- tryrsfp = doopen_pm(sv);
+ /* At this point, name is SvPVX(sv) */
+ tryname = name;
+ tryrsfp = doopen_pm(sv);
}
/* ... but if we fail, still search @INC for code references;
- * these are applied even on on-searchable paths (except
+ * these are applied even on non-searchable paths (except
* if we got EACESS).
*
* For searchable paths, just search @INC normally
*/
+ AV *inc_checked = (AV*)sv_2mortal((SV*)newAV());
if (!tryrsfp && !(errno == EACCES && !path_searchable)) {
- AV * const ar = GvAVn(PL_incgv);
- SSize_t i;
+ SSize_t inc_idx;
#ifdef VMS
- if (vms_unixname)
+ if (vms_unixname)
#endif
- {
- SV *nsv = sv;
- namesv = newSV_type(SVt_PV);
- for (i = 0; i <= AvFILL(ar); i++) {
- SV * const dirsv = *av_fetch(ar, i, TRUE);
-
- SvGETMAGIC(dirsv);
- if (SvROK(dirsv)) {
- int count;
- SV **svp;
- SV *loader = dirsv;
-
- if (SvTYPE(SvRV(loader)) == SVt_PVAV
- && !SvOBJECT(SvRV(loader)))
- {
- loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
- SvGETMAGIC(loader);
- }
-
- Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%" UVxf "/%s",
- PTR2UV(SvRV(dirsv)), name);
- tryname = SvPVX_const(namesv);
- tryrsfp = NULL;
-
- if (SvPADTMP(nsv)) {
- nsv = sv_newmortal();
- SvSetSV_nosteal(nsv,sv);
- }
-
- ENTER_with_name("call_INC");
- SAVETMPS;
- EXTEND(SP, 2);
-
- PUSHMARK(SP);
- PUSHs(dirsv);
- PUSHs(nsv);
- PUTBACK;
- if (SvGMAGICAL(loader)) {
- SV *l = sv_newmortal();
- sv_setsv_nomg(l, loader);
- loader = l;
- }
- if (sv_isobject(loader))
- count = call_method("INC", G_ARRAY);
- else
- count = call_sv(loader, G_ARRAY);
- SPAGAIN;
-
- if (count > 0) {
- int i = 0;
- SV *arg;
-
- SP -= count - 1;
- arg = SP[i++];
-
- if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
- && !isGV_with_GP(SvRV(arg))) {
- filter_cache = SvRV(arg);
-
- if (i < count) {
- arg = SP[i++];
- }
- }
-
- if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
- arg = SvRV(arg);
- }
-
- if (isGV_with_GP(arg)) {
- IO * const io = GvIO((const GV *)arg);
-
- ++filter_has_file;
-
- if (io) {
- tryrsfp = IoIFP(io);
- if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
- PerlIO_close(IoOFP(io));
- }
- IoIFP(io) = NULL;
- IoOFP(io) = NULL;
- }
-
- if (i < count) {
- arg = SP[i++];
- }
- }
-
- if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
- filter_sub = arg;
- SvREFCNT_inc_simple_void_NN(filter_sub);
-
- if (i < count) {
- filter_state = SP[i];
- SvREFCNT_inc_simple_void(filter_state);
- }
- }
-
- if (!tryrsfp && (filter_cache || filter_sub)) {
- tryrsfp = PerlIO_open(BIT_BUCKET,
- PERL_SCRIPT_MODE);
- }
- SP--;
- }
-
- /* FREETMPS may free our filter_cache */
- SvREFCNT_inc_simple_void(filter_cache);
-
- PUTBACK;
- FREETMPS;
- LEAVE_with_name("call_INC");
-
- /* Now re-mortalize it. */
- sv_2mortal(filter_cache);
-
- /* Adjust file name if the hook has set an %INC entry.
- This needs to happen after the FREETMPS above. */
- svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
- if (svp)
- tryname = SvPV_nolen_const(*svp);
-
- if (tryrsfp) {
- hook_sv = dirsv;
- break;
- }
-
- filter_has_file = 0;
- filter_cache = NULL;
- if (filter_state) {
- SvREFCNT_dec_NN(filter_state);
- filter_state = NULL;
- }
- if (filter_sub) {
- SvREFCNT_dec_NN(filter_sub);
- filter_sub = NULL;
- }
- }
- else if (path_searchable) {
- /* match against a plain @INC element (non-searchable
- * paths are only matched against refs in @INC) */
- const char *dir;
- STRLEN dirlen;
-
- if (SvOK(dirsv)) {
- dir = SvPV_nomg_const(dirsv, dirlen);
- } else {
- dir = "";
- dirlen = 0;
- }
-
- if (!IS_SAFE_SYSCALL(dir, dirlen, "@INC entry", op_name))
- continue;
-#ifdef VMS
- if ((unixdir =
- tounixpath(dir, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
- == NULL)
- continue;
- sv_setpv(namesv, unixdir);
- sv_catpv(namesv, unixname);
-#elif defined(__SYMBIAN32__)
- if (PL_origfilename[0] &&
- PL_origfilename[1] == ':' &&
- !(dir[0] && dir[1] == ':'))
- Perl_sv_setpvf(aTHX_ namesv,
- "%c:%s\\%s",
- PL_origfilename[0],
- dir, name);
- else
- Perl_sv_setpvf(aTHX_ namesv,
- "%s\\%s",
- dir, name);
-#else
- /* The equivalent of
- Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
- but without the need to parse the format string, or
- call strlen on either pointer, and with the correct
- allocation up front. */
- {
- char *tmp = SvGROW(namesv, dirlen + len + 2);
-
- memcpy(tmp, dir, dirlen);
- tmp +=dirlen;
-
- /* Avoid '<dir>//<file>' */
- if (!dirlen || *(tmp-1) != '/') {
- *tmp++ = '/';
- } else {
- /* So SvCUR_set reports the correct length below */
- dirlen--;
- }
-
- /* name came from an SV, so it will have a '\0' at the
- end that we can copy as part of this memcpy(). */
- memcpy(tmp, name, len + 1);
-
- SvCUR_set(namesv, dirlen + len + 1);
- SvPOK_on(namesv);
- }
-#endif
- TAINT_PROPER(op_name);
- tryname = SvPVX_const(namesv);
- tryrsfp = doopen_pm(namesv);
- if (tryrsfp) {
- if (tryname[0] == '.' && tryname[1] == '/') {
- ++tryname;
- while (*++tryname == '/') {}
- }
- break;
- }
- else if (errno == EMFILE || errno == EACCES) {
- /* no point in trying other paths if out of handles;
- * on the other hand, if we couldn't open one of the
- * files, then going on with the search could lead to
- * unexpected results; see perl #113422
- */
- break;
+ {
+ AV *incdir_av = (AV*)sv_2mortal((SV*)newAV());
+ SV *nsv = sv; /* non const copy we can change if necessary */
+ namesv = newSV_type(SVt_PV);
+ AV *inc_ar = GvAVn(PL_incgv);
+ SSize_t incdir_continue_inc_idx = -1;
+
+ for (
+ inc_idx = 0;
+ (AvFILL(incdir_av)>=0 /* we have INCDIR items pending */
+ || inc_idx <= AvFILL(inc_ar)); /* @INC entries remain */
+ inc_idx++
+ ) {
+ SV *dirsv;
+
+ /* do we have any pending INCDIR items? */
+ if (AvFILL(incdir_av)>=0) {
+ /* yep, shift it out */
+ dirsv = av_shift(incdir_av);
+ if (AvFILL(incdir_av)<0) {
+ /* incdir is now empty, continue from where
+ * we left off after we process this entry */
+ inc_idx = incdir_continue_inc_idx;
}
- }
- }
- }
- }
+ } else {
+ dirsv = *av_fetch(inc_ar, inc_idx, TRUE);
+ }
- /* at this point we've ether opened a file (tryrsfp) or set errno */
+ if (SvGMAGICAL(dirsv)) {
+ SvGETMAGIC(dirsv);
+ dirsv = newSVsv_nomg(dirsv);
+ } else {
+ /* on the other hand, since we aren't copying we do need
+ * to increment */
+ SvREFCNT_inc(dirsv);
+ }
+ if (!SvOK(dirsv))
+ continue;
- saved_errno = errno; /* sv_2mortal can realloc things */
- sv_2mortal(namesv);
- if (!tryrsfp) {
- /* we failed; croak if require() or return undef if do() */
- if (op_is_require) {
- if(saved_errno == EMFILE || saved_errno == EACCES) {
- /* diag_listed_as: Can't locate %s */
- DIE(aTHX_ "Can't locate %s: %s: %s",
- name, tryname, Strerror(saved_errno));
- } else {
- if (path_searchable) { /* did we lookup @INC? */
- AV * const ar = GvAVn(PL_incgv);
- SSize_t i;
- SV *const msg = newSVpvs_flags("", SVs_TEMP);
- SV *const inc = newSVpvs_flags("", SVs_TEMP);
- for (i = 0; i <= AvFILL(ar); i++) {
- sv_catpvs(inc, " ");
- sv_catsv(inc, *av_fetch(ar, i, TRUE));
- }
- if (memENDPs(name, len, ".pm")) {
- const char *e = name + len - (sizeof(".pm") - 1);
- const char *c;
- bool utf8 = cBOOL(SvUTF8(sv));
+ av_push(inc_checked, dirsv);
- /* if the filename, when converted from "Foo/Bar.pm"
+ if (SvROK(dirsv)) {
+ int count;
+ SV **svp;
+ SV *loader = dirsv;
+ UV diruv = PTR2UV(SvRV(dirsv));
+
+ if (SvTYPE(SvRV(loader)) == SVt_PVAV
+ && !SvOBJECT(SvRV(loader)))
+ {
+ loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
+ if (SvGMAGICAL(loader)) {
+ SvGETMAGIC(loader);
+ SV *l = sv_newmortal();
+ sv_setsv_nomg(l, loader);
+ loader = l;
+ }
+ }
+
+ if (SvPADTMP(nsv)) {
+ nsv = sv_newmortal();
+ SvSetSV_nosteal(nsv,sv);
+ }
+
+ const char *method = NULL;
+ bool is_incdir = FALSE;
+ SV * inc_idx_sv = save_scalar(PL_incgv);
+ sv_setiv(inc_idx_sv,inc_idx);
+ if (sv_isobject(loader)) {
+ /* if it is an object and it has an INC method, then
+ * call the method.
+ */
+ HV *pkg = SvSTASH(SvRV(loader));
+ GV * gv = gv_fetchmethod_pvn_flags(pkg, "INC", 3, GV_AUTOLOAD);
+ if (gv && isGV(gv)) {
+ method = "INC";
+ } else {
+ /* no point to autoload here, it would have been found above */
+ gv = gv_fetchmethod_pvn_flags(pkg, "INCDIR", 6, 0);
+ if (gv && isGV(gv)) {
+ method = "INCDIR";
+ is_incdir = TRUE;
+ }
+ }
+ /* But if we have no method, check if this is a
+ * coderef, if it is then we treat it as an
+ * unblessed coderef would be treated: we
+ * execute it. If it is some other and it is in
+ * an array ref wrapper, then really we don't
+ * know what to do with it, (why use the
+ * wrapper?) and we throw an exception to help
+ * debug. If it is not in a wrapper assume it
+ * has an overload and treat it as a string.
+ * Maybe in the future we can detect if it does
+ * have overloading and throw an error if not.
+ */
+ if (!method) {
+ if (SvTYPE(SvRV(loader)) != SVt_PVCV) {
+ if (amagic_applies(loader,string_amg,AMGf_unary))
+ goto treat_as_string;
+ else {
+ croak("Can't locate object method \"INC\", nor"
+ " \"INCDIR\" nor string overload via"
+ " package %" HvNAMEf_QUOTEDPREFIX " %s"
+ " in @INC", pkg,
+ dirsv == loader
+ ? "in object hook"
+ : "in object in ARRAY hook"
+ );
+ }
+ }
+ }
+ }
+
+ Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%" UVxf "/%s",
+ diruv, name);
+ tryname = SvPVX_const(namesv);
+ tryrsfp = NULL;
+
+ ENTER_with_name("call_INC_hook");
+ SAVETMPS;
+ PUSHMARK(PL_stack_sp);
+ /* add the args array for method calls */
+ bool add_dirsv = (method && (loader != dirsv));
+ rpp_extend(2 + add_dirsv);
+ rpp_push_2(
+ /* always use the object for method calls */
+ method ? loader : dirsv,
+ nsv
+ );
+ if (add_dirsv)
+ rpp_push_1(dirsv);
+ if (method) {
+ count = call_method(method, G_LIST|G_EVAL);
+ } else {
+ count = call_sv(loader, G_LIST|G_EVAL);
+ }
+
+ if (count > 0) {
+ int i = 0;
+ SV *arg;
+ SV **base = PL_stack_sp - count + 1;
+
+ if (is_incdir) {
+ /* push the stringified returned items into the
+ * incdir_av array for processing immediately
+ * afterwards. we deliberately stringify or copy
+ * "special" arguments, so that overload logic for
+ * instance applies, but so that the end result is
+ * stable. We speficially do *not* support returning
+ * coderefs from an INCDIR call. */
+ while (count-->0) {
+ arg = base[i++];
+ SvGETMAGIC(arg);
+ if (!SvOK(arg))
+ continue;
+ if (SvROK(arg)) {
+ STRLEN l;
+ char *pv = SvPV(arg,l);
+ arg = newSVpvn(pv,l);
+ }
+ else if (SvGMAGICAL(arg)) {
+ arg = newSVsv_nomg(arg);
+ }
+ else {
+ SvREFCNT_inc(arg);
+ }
+ av_push(incdir_av, arg);
+ }
+ /* We copy $INC into incdir_continue_inc_idx
+ * so that when we finish processing the items
+ * we just inserted into incdir_av we can continue
+ * as though we had just finished executing the INCDIR
+ * hook. We honour $INC here just like we would for
+ * an INC hook, the hook might have rewritten @INC
+ * at the same time as returning something to us.
+ */
+ inc_idx_sv = GvSVn(PL_incgv);
+ incdir_continue_inc_idx = SvOK(inc_idx_sv)
+ ? SvIV(inc_idx_sv) : -1;
+
+ goto done_hook;
+ }
+
+ arg = base[i++];
+
+ if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
+ && !isGV_with_GP(SvRV(arg))) {
+ filter_cache = SvRV(arg);
+
+ if (i < count) {
+ arg = base[i++];
+ }
+ }
+
+ if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
+ arg = SvRV(arg);
+ }
+
+ if (isGV_with_GP(arg)) {
+ IO * const io = GvIO((const GV *)arg);
+
+ ++filter_has_file;
+
+ if (io) {
+ tryrsfp = IoIFP(io);
+ if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
+ PerlIO_close(IoOFP(io));
+ }
+ IoIFP(io) = NULL;
+ IoOFP(io) = NULL;
+ }
+
+ if (i < count) {
+ arg = base[i++];
+ }
+ }
+
+ if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
+ filter_sub = arg;
+ SvREFCNT_inc_simple_void_NN(filter_sub);
+
+ if (i < count) {
+ filter_state = base[i];
+ SvREFCNT_inc_simple_void(filter_state);
+ }
+ }
+
+ if (!tryrsfp && (filter_cache || filter_sub)) {
+ tryrsfp = PerlIO_open(BIT_BUCKET,
+ PERL_SCRIPT_MODE);
+ }
+ done_hook:
+ rpp_popfree_to_NN(base - 1);
+ } else {
+ SV *errsv= ERRSV;
+ if (SvTRUE(errsv) && !SvROK(errsv)) {
+ STRLEN l;
+ char *pv= SvPV(errsv,l);
+ /* Heuristic to tell if this error message
+ * includes the standard line number info:
+ * check if the line ends in digit dot newline.
+ * If it does then we add some extra info so
+ * its obvious this is coming from a hook.
+ * If it is a user generated error we try to
+ * leave it alone. l>12 is to ensure the
+ * other checks are in string, but also
+ * accounts for "at ... line 1.\n" to a
+ * certain extent. Really we should check
+ * further, but this is good enough for back
+ * compat I think.
+ */
+ if (l>=12 && pv[l-1] == '\n' && pv[l-2] == '.' && isDIGIT(pv[l-3]))
+ sv_catpvf(errsv, "%s %s hook died--halting @INC search",
+ method ? method : "INC",
+ method ? "method" : "sub");
+ croak_sv(errsv);
+ }
+ }
+
+ /* FREETMPS may free our filter_cache */
+ SvREFCNT_inc_simple_void(filter_cache);
+
+ /*
+ Let the hook override which @INC entry we visit
+ next by setting $INC to a different value than it
+ was before we called the hook. If they have
+ completely rewritten the array they might want us
+ to start traversing from the beginning, which is
+ represented by -1. We use undef as an equivalent of
+ -1. This can't be used as a way to call a hook
+ twice, as we still dedupe.
+ We have to do this before we LEAVE, as we localized
+ $INC before we called the hook.
+ */
+ inc_idx_sv = GvSVn(PL_incgv);
+ inc_idx = SvOK(inc_idx_sv) ? SvIV(inc_idx_sv) : -1;
+
+ FREETMPS;
+ LEAVE_with_name("call_INC_hook");
+
+ /*
+ It is possible that @INC has been replaced and that inc_ar
+ now points at a freed AV. So we have to refresh it from
+ the GV to be sure.
+ */
+ inc_ar = GvAVn(PL_incgv);
+
+ /* Now re-mortalize it. */
+ sv_2mortal(filter_cache);
+
+ /* Adjust file name if the hook has set an %INC entry.
+ This needs to happen after the FREETMPS above. */
+ svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
+ /* we have to make sure that the value is not undef
+ * or the empty string, if it is then we should not
+ * set tryname to it as this will break error messages.
+ *
+ * This might happen if an @INC hook evals the module
+ * which was required in the first place and which
+ * triggered the @INC hook, and that eval dies.
+ * See https://github.com/Perl/perl5/issues/20535
+ */
+ if (svp && SvOK(*svp)) {
+ STRLEN len;
+ const char *tmp_pv = SvPV_const(*svp,len);
+ /* we also guard against the deliberate empty string.
+ * We do not guard against '0', if people want to set their
+ * file name to 0 that is up to them. */
+ if (len)
+ tryname = tmp_pv;
+ }
+
+ if (tryrsfp) {
+ hook_sv = dirsv;
+ break;
+ }
+
+ filter_has_file = 0;
+ filter_cache = NULL;
+ if (filter_state) {
+ SvREFCNT_dec_NN(filter_state);
+ filter_state = NULL;
+ }
+ if (filter_sub) {
+ SvREFCNT_dec_NN(filter_sub);
+ filter_sub = NULL;
+ }
+ }
+ else
+ treat_as_string:
+ if (path_searchable) {
+ /* match against a plain @INC element (non-searchable
+ * paths are only matched against refs in @INC) */
+ const char *dir;
+ STRLEN dirlen;
+ if (SvOK(dirsv)) {
+ dir = SvPV_nomg_const(dirsv, dirlen);
+ } else {
+ dir = "";
+ dirlen = 0;
+ }
+
+ if (!IS_SAFE_SYSCALL(dir, dirlen, "@INC entry", op_name))
+ continue;
+#ifdef VMS
+ if ((unixdir =
+ tounixpath(dir, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
+ == NULL)
+ continue;
+ sv_setpv(namesv, unixdir);
+ sv_catpv(namesv, unixname);
+#else
+ /* The equivalent of
+ Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
+ but without the need to parse the format string, or
+ call strlen on either pointer, and with the correct
+ allocation up front. */
+ {
+ char *tmp = SvGROW(namesv, dirlen + len + 2);
+
+ memcpy(tmp, dir, dirlen);
+ tmp +=dirlen;
+
+ /* Avoid '<dir>//<file>' */
+ if (!dirlen || *(tmp-1) != '/') {
+ *tmp++ = '/';
+ } else {
+ /* So SvCUR_set reports the correct length below */
+ dirlen--;
+ }
+
+ /* name came from an SV, so it will have a '\0' at the
+ end that we can copy as part of this memcpy(). */
+ memcpy(tmp, name, len + 1);
+
+ SvCUR_set(namesv, dirlen + len + 1);
+ SvPOK_on(namesv);
+ }
+#endif
+ TAINT_PROPER(op_name);
+ tryname = SvPVX_const(namesv);
+ tryrsfp = doopen_pm(namesv);
+ if (tryrsfp) {
+ if (tryname[0] == '.' && tryname[1] == '/') {
+ ++tryname;
+ while (*++tryname == '/') {}
+ }
+ break;
+ }
+ else if (errno == EMFILE || errno == EACCES) {
+ /* no point in trying other paths if out of handles;
+ * on the other hand, if we couldn't open one of the
+ * files, then going on with the search could lead to
+ * unexpected results; see perl #113422
+ */
+ break;
+ }
+ }
+ }
+ }
+ }
+
+ /* at this point we've ether opened a file (tryrsfp) or set errno */
+
+ saved_errno = errno; /* sv_2mortal can realloc things */
+ sv_2mortal(namesv);
+ if (!tryrsfp) {
+ /* we failed; croak if require() or return undef if do() */
+ if (op_is_require) {
+ if(saved_errno == EMFILE || saved_errno == EACCES) {
+ /* diag_listed_as: Can't locate %s */
+ DIE(aTHX_ "Can't locate %s: %s: %s",
+ name, tryname, Strerror(saved_errno));
+ } else {
+ if (path_searchable) { /* did we lookup @INC? */
+ SSize_t i;
+ SV *const msg = newSVpvs_flags("", SVs_TEMP);
+ SV *const inc = newSVpvs_flags("", SVs_TEMP);
+ for (i = 0; i <= AvFILL(inc_checked); i++) {
+ SV **svp= av_fetch(inc_checked, i, TRUE);
+ if (!svp || !*svp) continue;
+ sv_catpvs(inc, " ");
+ sv_catsv(inc, *svp);
+ }
+ if (memENDPs(name, len, ".pm")) {
+ const char *e = name + len - (sizeof(".pm") - 1);
+ const char *c;
+ bool utf8 = cBOOL(SvUTF8(sv));
+
+ /* if the filename, when converted from "Foo/Bar.pm"
* form back to Foo::Bar form, makes a valid
* package name (i.e. parseable by C<require
* Foo::Bar>), then emit a hint.
*
* this loop is modelled after the one in
S_parse_ident */
- c = name;
+ c = name;
while (c < e) {
if (utf8 && isIDFIRST_utf8_safe(c, e)) {
c += UTF8SKIP(c);
while (c < e && isWORDCHAR_A(*c))
c++;
}
- else if (*c == '/')
+ else if (*c == '/')
c++;
else
break;
}
sv_catpvs(msg, " module)");
}
- }
- else if (memENDs(name, len, ".h")) {
- sv_catpvs(msg, " (change .h to .ph maybe?) (did you run h2ph?)");
- }
- else if (memENDs(name, len, ".ph")) {
- sv_catpvs(msg, " (did you run h2ph?)");
- }
-
- /* diag_listed_as: Can't locate %s */
- DIE(aTHX_
- "Can't locate %s in @INC%" SVf " (@INC contains:%" SVf ")",
- name, msg, inc);
- }
- }
- DIE(aTHX_ "Can't locate %s", name);
- }
+ }
+ else if (memENDs(name, len, ".h")) {
+ sv_catpvs(msg, " (change .h to .ph maybe?) (did you run h2ph?)");
+ }
+ else if (memENDs(name, len, ".ph")) {
+ sv_catpvs(msg, " (did you run h2ph?)");
+ }
+
+ /* diag_listed_as: Can't locate %s */
+ DIE(aTHX_
+ "Can't locate %s in @INC%" SVf " (@INC entries checked:%" SVf ")",
+ name, msg, inc);
+ }
+ }
+ DIE(aTHX_ "Can't locate %s", name);
+ }
else {
#ifdef DEFAULT_INC_EXCLUDES_DOT
Stat_t st;
/* the complication is to match the logic from doopen_pm() so
* we don't treat do "sda1" as a previously successful "do".
*/
- bool do_warn = namesv && ckWARN_d(WARN_DEPRECATED)
+ bool do_warn = namesv && ckWARN_d(WARN_DEPRECATED__DOT_IN_INC)
&& PerlLIO_stat(name, &st) == 0 && !S_ISDIR(st.st_mode) && !S_ISBLK(st.st_mode)
&& (io = PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &sv)) != NULL;
if (io)
RESTORE_ERRNO;
if (do_warn) {
- Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
+ Perl_warner(aTHX_ packWARN(WARN_DEPRECATED__DOT_IN_INC),
"do \"%s\" failed, '.' is no longer in @INC; "
"did you mean do \"./%s\"?",
name, name);
}
#endif
CLEAR_ERRSV();
- RETPUSHUNDEF;
+ rpp_replace_1_IMM_NN(&PL_sv_undef);
+ return NORMAL;
}
}
else
- SETERRNO(0, SS_NORMAL);
+ SETERRNO(0, SS_NORMAL);
+
+ rpp_popfree_1_NN(); /* finished with sv now */
/* Update %INC. Assume success here to prevent recursive requirement. */
/* name is never assigned to again, so len is still strlen(name) */
/* Check whether a hook in @INC has already filled %INC */
if (!hook_sv) {
- (void)hv_store(GvHVn(PL_incgv),
- unixname, unixlen, newSVpv(tryname,0),0);
+ (void)hv_store(GvHVn(PL_incgv),
+ unixname, unixlen, newSVpv(tryname,0),0);
} else {
- SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
- if (!svp)
- (void)hv_store(GvHVn(PL_incgv),
- unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
+ /* store the hook in the sv, note we have to *copy* hook_sv,
+ * we don't want modifications to it to change @INC - see GH #20577
+ */
+ SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
+ if (!svp)
+ (void)hv_store(GvHVn(PL_incgv),
+ unixname, unixlen, newSVsv(hook_sv), 0 );
}
/* Now parse the file */
lex_start(NULL, tryrsfp, 0);
if (filter_sub || filter_cache) {
- /* We can use the SvPV of the filter PVIO itself as our cache, rather
- than hanging another SV from it. In turn, filter_add() optionally
- takes the SV to use as the filter (or creates a new SV if passed
- NULL), so simply pass in whatever value filter_cache has. */
- SV * const fc = filter_cache ? newSV(0) : NULL;
- SV *datasv;
- if (fc) sv_copypv(fc, filter_cache);
- datasv = filter_add(S_run_user_filter, fc);
- IoLINES(datasv) = filter_has_file;
- IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
- IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
+ /* We can use the SvPV of the filter PVIO itself as our cache, rather
+ than hanging another SV from it. In turn, filter_add() optionally
+ takes the SV to use as the filter (or creates a new SV if passed
+ NULL), so simply pass in whatever value filter_cache has. */
+ SV * const fc = filter_cache ? newSV_type(SVt_NULL) : NULL;
+ SV *datasv;
+ if (fc) sv_copypv(fc, filter_cache);
+ datasv = filter_add(S_run_user_filter, fc);
+ IoLINES(datasv) = filter_has_file;
+ IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
+ IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
}
/* switch to eval mode */
assert(!CATCH_GET);
- cx = cx_pushblock(CXt_EVAL, gimme, SP, old_savestack_ix);
+ cx = cx_pushblock(CXt_EVAL, gimme, PL_stack_sp, old_savestack_ix);
cx_pusheval(cx, PL_op->op_next, newSVpv(name, 0));
SAVECOPLINE(&PL_compiling);
CopLINE_set(&PL_compiling, 0);
- PUTBACK;
-
if (doeval_compile(gimme, NULL, PL_curcop->cop_seq, NULL))
- op = PL_eval_start;
+ op = PL_eval_start;
else
- op = PL_op->op_next;
+ op = PL_op->op_next;
PERL_DTRACE_PROBE_FILE_LOADED(unixname);
PP(pp_require)
{
- RUN_PP_CATCHABLY(Perl_pp_require);
+ /* If a suitable JMPENV catch frame isn't present, call docatch(),
+ * which will:
+ * - add such a frame, and
+ * - start a new RUNOPS loop, which will (as the first op to run),
+ * recursively call this pp function again.
+ * The main body of this function is then executed by the inner call.
+ */
+ if (CATCH_GET)
+ return docatch(Perl_pp_require);
{
- dSP;
- SV *sv = POPs;
- SvGETMAGIC(sv);
- PUTBACK;
- return ((SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE)
- ? S_require_version(aTHX_ sv)
- : S_require_file(aTHX_ sv);
+ SV *sv = *PL_stack_sp;
+ SvGETMAGIC(sv);
+ /* these tail-called subs are responsible for popping sv off the
+ * stack */
+ return ((SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE)
+ ? S_require_version(aTHX_ sv)
+ : S_require_file(aTHX_ sv);
}
}
PP(pp_hintseval)
{
- dSP;
- mXPUSHs(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv))));
- RETURN;
+ rpp_extend(1);
+ rpp_push_1_norc(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv))));
+ return NORMAL;
}
PP(pp_entereval)
{
- dSP;
PERL_CONTEXT *cx;
SV *sv;
U8 gimme;
bool bytes;
I32 old_savestack_ix;
- RUN_PP_CATCHABLY(Perl_pp_entereval);
+ /* If a suitable JMPENV catch frame isn't present, call docatch(),
+ * which will:
+ * - add such a frame, and
+ * - start a new RUNOPS loop, which will (as the first op to run),
+ * recursively call this pp function again.
+ * The main body of this function is then executed by the inner call.
+ */
+ if (CATCH_GET)
+ return docatch(Perl_pp_entereval);
+
+ assert(!CATCH_GET);
gimme = GIMME_V;
was = PL_breakable_sub_gen;
bytes = PL_op->op_private & OPpEVAL_BYTES;
if (PL_op->op_private & OPpEVAL_HAS_HH) {
- saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
+ saved_hh = MUTABLE_HV(rpp_pop_1_norc());
}
else if (PL_hints & HINT_LOCALIZE_HH || (
- PL_op->op_private & OPpEVAL_COPHH
- && PL_curcop->cop_hints & HINT_LOCALIZE_HH
- )) {
- saved_hh = cop_hints_2hv(PL_curcop, 0);
- hv_magic(saved_hh, NULL, PERL_MAGIC_hints);
+ PL_op->op_private & OPpEVAL_COPHH
+ && PL_curcop->cop_hints & HINT_LOCALIZE_HH
+ )) {
+ saved_hh = cop_hints_2hv(PL_curcop, 0);
+ hv_magic(saved_hh, NULL, PERL_MAGIC_hints);
}
- sv = POPs;
+ sv = *PL_stack_sp;
if (!SvPOK(sv)) {
- /* make sure we've got a plain PV (no overload etc) before testing
- * for taint. Making a copy here is probably overkill, but better
- * safe than sorry */
- STRLEN len;
- const char * const p = SvPV_const(sv, len);
+ /* make sure we've got a plain PV (no overload etc) before testing
+ * for taint. Making a copy here is probably overkill, but better
+ * safe than sorry */
+ STRLEN len;
+ const char * const p = SvPV_const(sv, len);
- sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
- lex_flags |= LEX_START_COPIED;
+ sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
+ lex_flags |= LEX_START_COPIED;
- if (bytes && SvUTF8(sv))
- SvPVbyte_force(sv, len);
+ if (bytes && SvUTF8(sv))
+ SvPVbyte_force(sv, len);
}
else if (bytes && SvUTF8(sv)) {
- /* Don't modify someone else's scalar */
- STRLEN len;
- sv = newSVsv(sv);
- (void)sv_2mortal(sv);
- SvPVbyte_force(sv,len);
- lex_flags |= LEX_START_COPIED;
+ /* Don't modify someone else's scalar */
+ STRLEN len;
+ sv = newSVsv(sv);
+ (void)sv_2mortal(sv);
+ SvPVbyte_force(sv,len);
+ lex_flags |= LEX_START_COPIED;
}
TAINT_IF(SvTAINTED(sv));
old_savestack_ix = PL_savestack_ix;
lex_start(sv, NULL, lex_flags | (PL_op->op_private & OPpEVAL_UNICODE
- ? LEX_IGNORE_UTF8_HINTS
- : bytes ? LEX_EVALBYTES : LEX_START_SAME_FILTER
- )
- );
+ ? LEX_IGNORE_UTF8_HINTS
+ : bytes ? LEX_EVALBYTES : LEX_START_SAME_FILTER
+ )
+ );
+
+ rpp_popfree_1_NN(); /* can free sv now */
/* switch to eval mode */
if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
- SV * const temp_sv = sv_newmortal();
- Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%" IVdf "]",
- (unsigned long)++PL_evalseq,
- CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
- tmpbuf = SvPVX(temp_sv);
- len = SvCUR(temp_sv);
+ SV * const temp_sv = sv_newmortal();
+ Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%" LINE_Tf "]",
+ (unsigned long)++PL_evalseq,
+ CopFILE(PL_curcop), CopLINE(PL_curcop));
+ tmpbuf = SvPVX(temp_sv);
+ len = SvCUR(temp_sv);
}
else
- len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
+ len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
SAVECOPFILE_FREE(&PL_compiling);
CopFILE_set(&PL_compiling, tmpbuf+2);
SAVECOPLINE(&PL_compiling);
runcv = find_runcv(&seq);
assert(!CATCH_GET);
- cx = cx_pushblock((CXt_EVAL|CXp_REAL), gimme, SP, old_savestack_ix);
+ cx = cx_pushblock((CXt_EVAL|CXp_REAL),
+ gimme, PL_stack_sp, old_savestack_ix);
cx_pusheval(cx, PL_op->op_next, NULL);
/* prepare to compile string */
if (PERLDB_LINE_OR_SAVESRC && PL_curstash != PL_debstash)
- save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
+ save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
else {
- /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
- deleting the eval's FILEGV from the stash before gv_check() runs
- (i.e. before run-time proper). To work around the coredump that
- ensues, we always turn GvMULTI_on for any globals that were
- introduced within evals. See force_ident(). GSAR 96-10-12 */
- char *const safestr = savepvn(tmpbuf, len);
- SAVEDELETE(PL_defstash, safestr, len);
- saved_delete = TRUE;
+ /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
+ deleting the eval's FILEGV from the stash before gv_check() runs
+ (i.e. before run-time proper). To work around the coredump that
+ ensues, we always turn GvMULTI_on for any globals that were
+ introduced within evals. See force_ident(). GSAR 96-10-12 */
+ char *const safestr = savepvn(tmpbuf, len);
+ SAVEDELETE(PL_defstash, safestr, len);
+ saved_delete = TRUE;
}
- PUTBACK;
-
if (doeval_compile(gimme, runcv, seq, saved_hh)) {
- if (was != PL_breakable_sub_gen /* Some subs defined here. */
- ? PERLDB_LINE_OR_SAVESRC
- : PERLDB_SAVESRC_NOSUBS) {
- /* Retain the filegv we created. */
- } else if (!saved_delete) {
- char *const safestr = savepvn(tmpbuf, len);
- SAVEDELETE(PL_defstash, safestr, len);
- }
- return PL_eval_start;
+ if (was != PL_breakable_sub_gen /* Some subs defined here. */
+ ? PERLDB_LINE_OR_SAVESRC
+ : PERLDB_SAVESRC_NOSUBS) {
+ /* Retain the filegv we created. */
+ } else if (!saved_delete) {
+ char *const safestr = savepvn(tmpbuf, len);
+ SAVEDELETE(PL_defstash, safestr, len);
+ }
+ return PL_eval_start;
} else {
- /* We have already left the scope set up earlier thanks to the LEAVE
- in doeval_compile(). */
- if (was != PL_breakable_sub_gen /* Some subs defined here. */
- ? PERLDB_LINE_OR_SAVESRC
- : PERLDB_SAVESRC_INVALID) {
- /* Retain the filegv we created. */
- } else if (!saved_delete) {
- (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
- }
- return PL_op->op_next;
+ /* We have already left the scope set up earlier thanks to the LEAVE
+ in doeval_compile(). */
+ if (was != PL_breakable_sub_gen /* Some subs defined here. */
+ ? PERLDB_LINE_OR_SAVESRC
+ : PERLDB_SAVESRC_INVALID) {
+ /* Retain the filegv we created. */
+ } else if (!saved_delete) {
+ (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
+ }
+ if (PL_op->op_private & OPpEVAL_EVALSV)
+ /* signal compiletime failure to our eval_sv() caller */
+ *++PL_stack_sp = NULL;
+ return PL_op->op_next;
}
}
PERL_CONTEXT *cx;
OP *retop;
int failed;
+ bool override_return = FALSE; /* is feature 'module_true' in effect? */
CV *evalcv;
bool keep;
oldsp = PL_stack_base + cx->blk_oldsp;
gimme = cx->blk_gimme;
- /* did require return a false value? */
- failed = CxOLD_OP_TYPE(cx) == OP_REQUIRE
+ bool is_require= CxOLD_OP_TYPE(cx) == OP_REQUIRE;
+ if (is_require) {
+ /* We are in an require. Check if use feature 'module_true' is enabled,
+ * and if so later on correct any returns from the require. */
+
+ /* we might be called for an OP_LEAVEEVAL or OP_RETURN opcode
+ * and the parse tree will look different for either case.
+ * so find the right op to check later */
+ if (OP_TYPE_IS_OR_WAS(PL_op, OP_RETURN)) {
+ if (PL_op->op_flags & OPf_SPECIAL)
+ override_return = true;
+ }
+ else if ((PL_op->op_flags & OPf_KIDS) && OP_TYPE_IS_OR_WAS(PL_op, OP_LEAVEEVAL)){
+ COP *old_pl_curcop = PL_curcop;
+ OP *check = cUNOPx(PL_op)->op_first;
+
+ /* ok, we found something to check, we need to scan through
+ * it and find the last OP_NEXTSTATE it contains and then read the
+ * feature state out of the COP data it contains.
+ */
+ if (check) {
+ if (!OP_TYPE_IS(check,OP_STUB)) {
+ const OP *kid = cLISTOPx(check)->op_first;
+ const OP *last_state = NULL;
+
+ for (; kid; kid = OpSIBLING(kid)) {
+ if (
+ OP_TYPE_IS_OR_WAS(kid, OP_NEXTSTATE)
+ || OP_TYPE_IS_OR_WAS(kid, OP_DBSTATE)
+ ){
+ last_state = kid;
+ }
+ }
+ if (last_state) {
+ PL_curcop = cCOPx(last_state);
+ if (FEATURE_MODULE_TRUE_IS_ENABLED) {
+ override_return = TRUE;
+ }
+ } else {
+ NOT_REACHED; /* NOTREACHED */
+ }
+ }
+ } else {
+ NOT_REACHED; /* NOTREACHED */
+ }
+ PL_curcop = old_pl_curcop;
+ }
+ }
+
+ /* we might override this later if 'module_true' is enabled */
+ failed = is_require
&& !(gimme == G_SCALAR
? SvTRUE_NN(*PL_stack_sp)
: PL_stack_sp > oldsp);
if (gimme == G_VOID) {
- PL_stack_sp = oldsp;
+ rpp_popfree_to(oldsp);
/* free now to avoid late-called destructors clobbering $@ */
FREETMPS;
}
#endif
CvDEPTH(evalcv) = 0;
+ if (override_return) {
+ /* make sure that we use a standard return when feature 'module_load'
+ * is enabled. Returns from require are problematic (consider what happens
+ * when it is called twice) */
+ if (gimme == G_SCALAR)
+ rpp_replace_1_IMM_NN(&PL_sv_yes);
+ assert(gimme == G_VOID || gimme == G_SCALAR);
+ failed = 0;
+ }
+
/* pop the CXt_EVAL, and if a require failed, croak */
S_pop_eval_context_maybe_croak(aTHX_ cx, NULL, failed);
return retop;
}
+/* Ops that implement try/catch syntax
+ * Note the asymmetry here:
+ * pp_entertrycatch does two pushblocks
+ * pp_leavetrycatch pops only the outer one; the inner one is popped by
+ * pp_poptry or by stack-unwind of die within the try block
+ */
+
+PP(pp_entertrycatch)
+{
+ PERL_CONTEXT *cx;
+ const U8 gimme = GIMME_V;
+
+ /* If a suitable JMPENV catch frame isn't present, call docatch(),
+ * which will:
+ * - add such a frame, and
+ * - start a new RUNOPS loop, which will (as the first op to run),
+ * recursively call this pp function again.
+ * The main body of this function is then executed by the inner call.
+ */
+ if (CATCH_GET)
+ return docatch(Perl_pp_entertrycatch);
+
+ assert(!CATCH_GET);
+
+ Perl_pp_enter(aTHX); /* performs cx_pushblock(CXt_BLOCK, ...) */
+
+ save_scalar(PL_errgv);
+ CLEAR_ERRSV();
+
+ cx = cx_pushblock((CXt_EVAL|CXp_EVALBLOCK|CXp_TRY), gimme,
+ PL_stack_sp, PL_savestack_ix);
+ cx_pushtry(cx, cLOGOP->op_other);
+
+ PL_in_eval = EVAL_INEVAL;
+
+ return NORMAL;
+}
+
+PP(pp_leavetrycatch)
+{
+ /* leavetrycatch is leave */
+ return Perl_pp_leave(aTHX);
+}
+
+PP(pp_poptry)
+{
+ /* poptry is leavetry */
+ return Perl_pp_leavetry(aTHX);
+}
+
+PP(pp_catch)
+{
+ dTARGET;
+
+ save_clearsv(&(PAD_SVl(PL_op->op_targ)));
+ sv_setsv(TARG, ERRSV);
+ CLEAR_ERRSV();
+
+ return cLOGOP->op_other;
+}
+
/* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
close to the related Perl_create_eval_scope. */
void
Perl_delete_eval_scope(pTHX)
{
PERL_CONTEXT *cx;
-
+
cx = CX_CUR();
CX_LEAVE_SCOPE(cx);
cx_popeval(cx);
/* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
also needed by Perl_fold_constants. */
void
-Perl_create_eval_scope(pTHX_ OP *retop, U32 flags)
+Perl_create_eval_scope(pTHX_ OP *retop, SV **sp, U32 flags)
{
PERL_CONTEXT *cx;
const U8 gimme = GIMME_V;
-
- cx = cx_pushblock((CXt_EVAL|CXp_TRYBLOCK), gimme,
- PL_stack_sp, PL_savestack_ix);
+
+ PERL_ARGS_ASSERT_CREATE_EVAL_SCOPE;
+
+ cx = cx_pushblock((CXt_EVAL|CXp_EVALBLOCK), gimme,
+ sp, PL_savestack_ix);
cx_pusheval(cx, retop, NULL);
PL_in_eval = EVAL_INEVAL;
if (flags & G_KEEPERR)
- PL_in_eval |= EVAL_KEEPERR;
+ PL_in_eval |= EVAL_KEEPERR;
else
- CLEAR_ERRSV();
+ CLEAR_ERRSV();
if (flags & G_FAKINGEVAL) {
- PL_eval_root = PL_op; /* Only needed so that goto works right. */
+ PL_eval_root = PL_op; /* Only needed so that goto works right. */
}
}
PP(pp_entertry)
{
- RUN_PP_CATCHABLY(Perl_pp_entertry);
+ OP *retop = cLOGOP->op_other->op_next;
+
+ /* If a suitable JMPENV catch frame isn't present, call docatch(),
+ * which will:
+ * - add such a frame, and
+ * - start a new RUNOPS loop, which will (as the first op to run),
+ * recursively call this pp function again.
+ * The main body of this function is then executed by the inner call.
+ */
+ if (CATCH_GET)
+ return docatch(Perl_pp_entertry);
assert(!CATCH_GET);
- create_eval_scope(cLOGOP->op_other->op_next, 0);
+
+ create_eval_scope(retop, PL_stack_sp, 0);
+
return PL_op->op_next;
}
gimme = cx->blk_gimme;
if (gimme == G_VOID) {
- PL_stack_sp = oldsp;
+ rpp_popfree_to_NN(oldsp);
/* free now to avoid late-called destructors clobbering $@ */
FREETMPS;
}
CX_LEAVE_SCOPE(cx);
cx_popeval(cx);
cx_popblock(cx);
- retop = cx->blk_eval.retop;
+ retop = CxTRY(cx) ? PL_op->op_next : cx->blk_eval.retop;
CX_POP(cx);
CLEAR_ERRSV();
PP(pp_entergiven)
{
- dSP;
PERL_CONTEXT *cx;
const U8 gimme = GIMME_V;
SV *origsv = DEFSV;
- SV *newsv = POPs;
assert(!PL_op->op_targ); /* used to be set for lexical $_ */
- GvSV(PL_defgv) = SvREFCNT_inc(newsv);
+ GvSV(PL_defgv) = rpp_pop_1_norc();
- cx = cx_pushblock(CXt_GIVEN, gimme, SP, PL_savestack_ix);
+ cx = cx_pushblock(CXt_GIVEN, gimme, PL_stack_sp, PL_savestack_ix);
cx_pushgiven(cx, origsv);
- RETURN;
+ return NORMAL;
}
PP(pp_leavegiven)
gimme = cx->blk_gimme;
if (gimme == G_VOID)
- PL_stack_sp = oldsp;
+ rpp_popfree_to_NN(oldsp);
else
leave_adjust_stacks(oldsp, oldsp, gimme, 1);
STATIC PMOP *
S_make_matcher(pTHX_ REGEXP *re)
{
- PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
+ PMOP *matcher = cPMOPx(newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED));
PERL_ARGS_ASSERT_MAKE_MATCHER;
STATIC bool
S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
{
- dSP;
bool result;
PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
PL_op = (OP *) matcher;
- XPUSHs(sv);
- PUTBACK;
+ rpp_xpush_1(sv);
(void) Perl_pp_match(aTHX);
- SPAGAIN;
- result = SvTRUEx(POPs);
- PUTBACK;
-
+ result = SvTRUEx(*PL_stack_sp);
+ rpp_popfree_1_NN();
return result;
}
LEAVE_with_name("matcher");
}
+
/* Do a smart match */
PP(pp_smartmatch)
{
return do_smartmatch(NULL, NULL, 0);
}
+
/* This version of do_smartmatch() implements the
* table of smart matches that is found in perlsyn.
*/
STATIC OP *
S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied)
{
- dSP;
-
bool object_on_left = FALSE;
- SV *e = TOPs; /* e is for 'expression' */
- SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
+ SV *e = PL_stack_sp[0]; /* e is for 'expression' */
+ SV *d = PL_stack_sp[-1]; /* d is for 'default', as in PL_defgv */
/* Take care only to invoke mg_get() once for each argument.
* Currently we do this by copying the SV if it's magical. */
if (d) {
- if (!copied && SvGMAGICAL(d))
- d = sv_mortalcopy(d);
+ if (!copied && SvGMAGICAL(d))
+ d = sv_mortalcopy(d);
}
else
- d = &PL_sv_undef;
+ d = &PL_sv_undef;
assert(e);
if (SvGMAGICAL(e))
- e = sv_mortalcopy(e);
+ e = sv_mortalcopy(e);
/* First of all, handle overload magic of the rightmost argument */
if (SvAMAGIC(e)) {
- SV * tmpsv;
- DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
- DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
-
- tmpsv = amagic_call(d, e, smart_amg, AMGf_noleft);
- if (tmpsv) {
- SPAGAIN;
- (void)POPs;
- SETs(tmpsv);
- RETURN;
- }
- DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; continuing...\n"));
+ SV * tmpsv;
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
+ DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
+
+ tmpsv = amagic_call(d, e, smart_amg, AMGf_noleft);
+ if (tmpsv) {
+ rpp_replace_2_1_NN(tmpsv);
+ return NORMAL;
+ }
+ DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; continuing...\n"));
}
- SP -= 2; /* Pop the values */
- PUTBACK;
-
/* ~~ undef */
if (!SvOK(e)) {
- DEBUG_M(Perl_deb(aTHX_ " applying rule Any-undef\n"));
- if (SvOK(d))
- RETPUSHNO;
- else
- RETPUSHYES;
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Any-undef\n"));
+ if (SvOK(d))
+ goto ret_no;
+ else
+ goto ret_yes;
}
if (SvROK(e) && SvOBJECT(SvRV(e)) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
- DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
- Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
+ Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
}
if (SvROK(d) && SvOBJECT(SvRV(d)) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
- object_on_left = TRUE;
+ object_on_left = TRUE;
/* ~~ sub */
if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
- I32 c;
- if (object_on_left) {
- goto sm_any_sub; /* Treat objects like scalars */
- }
- else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
- /* Test sub truth for each key */
- HE *he;
- bool andedresults = TRUE;
- HV *hv = (HV*) SvRV(d);
- I32 numkeys = hv_iterinit(hv);
- DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-CodeRef\n"));
- if (numkeys == 0)
- RETPUSHYES;
- while ( (he = hv_iternext(hv)) ) {
- DEBUG_M(Perl_deb(aTHX_ " testing hash key...\n"));
- ENTER_with_name("smartmatch_hash_key_test");
- SAVETMPS;
- PUSHMARK(SP);
- PUSHs(hv_iterkeysv(he));
- PUTBACK;
- c = call_sv(e, G_SCALAR);
- SPAGAIN;
- if (c == 0)
- andedresults = FALSE;
- else
- andedresults = SvTRUEx(POPs) && andedresults;
- FREETMPS;
- LEAVE_with_name("smartmatch_hash_key_test");
- }
- if (andedresults)
- RETPUSHYES;
- else
- RETPUSHNO;
- }
- else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
- /* Test sub truth for each element */
- SSize_t i;
- bool andedresults = TRUE;
- AV *av = (AV*) SvRV(d);
- const I32 len = av_tindex(av);
- DEBUG_M(Perl_deb(aTHX_ " applying rule Array-CodeRef\n"));
- if (len == -1)
- RETPUSHYES;
- for (i = 0; i <= len; ++i) {
- SV * const * const svp = av_fetch(av, i, FALSE);
- DEBUG_M(Perl_deb(aTHX_ " testing array element...\n"));
- ENTER_with_name("smartmatch_array_elem_test");
- SAVETMPS;
- PUSHMARK(SP);
- if (svp)
- PUSHs(*svp);
- PUTBACK;
- c = call_sv(e, G_SCALAR);
- SPAGAIN;
- if (c == 0)
- andedresults = FALSE;
- else
- andedresults = SvTRUEx(POPs) && andedresults;
- FREETMPS;
- LEAVE_with_name("smartmatch_array_elem_test");
- }
- if (andedresults)
- RETPUSHYES;
- else
- RETPUSHNO;
- }
- else {
- sm_any_sub:
- DEBUG_M(Perl_deb(aTHX_ " applying rule Any-CodeRef\n"));
- ENTER_with_name("smartmatch_coderef");
- SAVETMPS;
- PUSHMARK(SP);
- PUSHs(d);
- PUTBACK;
- c = call_sv(e, G_SCALAR);
- SPAGAIN;
- if (c == 0)
- PUSHs(&PL_sv_no);
- else if (SvTEMP(TOPs))
- SvREFCNT_inc_void(TOPs);
- FREETMPS;
- LEAVE_with_name("smartmatch_coderef");
- RETURN;
- }
+ if (object_on_left) {
+ goto sm_any_sub; /* Treat objects like scalars */
+ }
+ else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
+ /* Test sub truth for each key */
+ HE *he;
+ bool andedresults = TRUE;
+ HV *hv = (HV*) SvRV(d);
+ I32 numkeys = hv_iterinit(hv);
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-CodeRef\n"));
+ if (numkeys == 0)
+ goto ret_yes;
+ while ( (he = hv_iternext(hv)) ) {
+ DEBUG_M(Perl_deb(aTHX_ " testing hash key...\n"));
+ ENTER_with_name("smartmatch_hash_key_test");
+ SAVETMPS;
+ PUSHMARK(PL_stack_sp);
+ rpp_xpush_1(hv_iterkeysv(he));
+ (void)call_sv(e, G_SCALAR);
+ andedresults = SvTRUEx(PL_stack_sp[0]) && andedresults;
+ rpp_popfree_1_NN();
+ FREETMPS;
+ LEAVE_with_name("smartmatch_hash_key_test");
+ }
+ if (andedresults)
+ goto ret_yes;
+ else
+ goto ret_no;
+ }
+ else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
+ /* Test sub truth for each element */
+ Size_t i;
+ bool andedresults = TRUE;
+ AV *av = (AV*) SvRV(d);
+ const Size_t len = av_count(av);
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Array-CodeRef\n"));
+ if (len == 0)
+ goto ret_yes;
+ for (i = 0; i < len; ++i) {
+ SV * const * const svp = av_fetch(av, i, FALSE);
+ DEBUG_M(Perl_deb(aTHX_ " testing array element...\n"));
+ ENTER_with_name("smartmatch_array_elem_test");
+ SAVETMPS;
+ PUSHMARK(PL_stack_sp);
+ if (svp)
+ rpp_xpush_1(*svp);
+ (void)call_sv(e, G_SCALAR);
+ andedresults = SvTRUEx(PL_stack_sp[0]) && andedresults;
+ rpp_popfree_1_NN();
+ FREETMPS;
+ LEAVE_with_name("smartmatch_array_elem_test");
+ }
+ if (andedresults)
+ goto ret_yes;
+ else
+ goto ret_no;
+ }
+ else {
+ sm_any_sub:
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Any-CodeRef\n"));
+ ENTER_with_name("smartmatch_coderef");
+ PUSHMARK(PL_stack_sp);
+ rpp_xpush_1(d);
+ (void)call_sv(e, G_SCALAR);
+ LEAVE_with_name("smartmatch_coderef");
+ SV *retsv = *PL_stack_sp--;
+ rpp_replace_2_1(retsv);
+#ifdef PERL_RC_STACK
+ SvREFCNT_dec(retsv);
+#endif
+ return NORMAL;
+ }
}
/* ~~ %hash */
else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
- if (object_on_left) {
- goto sm_any_hash; /* Treat objects like scalars */
- }
- else if (!SvOK(d)) {
- DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash ($a undef)\n"));
- RETPUSHNO;
- }
- else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
- /* Check that the key-sets are identical */
- HE *he;
- HV *other_hv = MUTABLE_HV(SvRV(d));
- bool tied;
- bool other_tied;
- U32 this_key_count = 0,
- other_key_count = 0;
- HV *hv = MUTABLE_HV(SvRV(e));
-
- DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Hash\n"));
- /* Tied hashes don't know how many keys they have. */
- tied = cBOOL(SvTIED_mg((SV*)hv, PERL_MAGIC_tied));
- other_tied = cBOOL(SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied));
- if (!tied ) {
- if(other_tied) {
- /* swap HV sides */
- HV * const temp = other_hv;
- other_hv = hv;
- hv = temp;
- tied = TRUE;
- other_tied = FALSE;
- }
- else if(HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
- RETPUSHNO;
- }
-
- /* The hashes have the same number of keys, so it suffices
- to check that one is a subset of the other. */
- (void) hv_iterinit(hv);
- while ( (he = hv_iternext(hv)) ) {
- SV *key = hv_iterkeysv(he);
-
- DEBUG_M(Perl_deb(aTHX_ " comparing hash key...\n"));
- ++ this_key_count;
-
- if(!hv_exists_ent(other_hv, key, 0)) {
- (void) hv_iterinit(hv); /* reset iterator */
- RETPUSHNO;
- }
- }
-
- if (other_tied) {
- (void) hv_iterinit(other_hv);
- while ( hv_iternext(other_hv) )
- ++other_key_count;
- }
- else
- other_key_count = HvUSEDKEYS(other_hv);
-
- if (this_key_count != other_key_count)
- RETPUSHNO;
- else
- RETPUSHYES;
- }
- else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
- AV * const other_av = MUTABLE_AV(SvRV(d));
- const SSize_t other_len = av_tindex(other_av) + 1;
- SSize_t i;
- HV *hv = MUTABLE_HV(SvRV(e));
-
- DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Hash\n"));
- for (i = 0; i < other_len; ++i) {
- SV ** const svp = av_fetch(other_av, i, FALSE);
- DEBUG_M(Perl_deb(aTHX_ " checking for key existence...\n"));
- if (svp) { /* ??? When can this not happen? */
- if (hv_exists_ent(hv, *svp, 0))
- RETPUSHYES;
- }
- }
- RETPUSHNO;
- }
- else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
- DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Hash\n"));
- sm_regex_hash:
- {
- PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
- HE *he;
- HV *hv = MUTABLE_HV(SvRV(e));
-
- (void) hv_iterinit(hv);
- while ( (he = hv_iternext(hv)) ) {
- DEBUG_M(Perl_deb(aTHX_ " testing key against pattern...\n"));
- PUTBACK;
- if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
- SPAGAIN;
- (void) hv_iterinit(hv);
- destroy_matcher(matcher);
- RETPUSHYES;
- }
- SPAGAIN;
- }
- destroy_matcher(matcher);
- RETPUSHNO;
- }
- }
- else {
- sm_any_hash:
- DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash\n"));
- if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
- RETPUSHYES;
- else
- RETPUSHNO;
- }
+ if (object_on_left) {
+ goto sm_any_hash; /* Treat objects like scalars */
+ }
+ else if (!SvOK(d)) {
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash ($a undef)\n"));
+ goto ret_no;
+ }
+ else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
+ /* Check that the key-sets are identical */
+ HE *he;
+ HV *other_hv = MUTABLE_HV(SvRV(d));
+ bool tied;
+ bool other_tied;
+ U32 this_key_count = 0,
+ other_key_count = 0;
+ HV *hv = MUTABLE_HV(SvRV(e));
+
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Hash\n"));
+ /* Tied hashes don't know how many keys they have. */
+ tied = cBOOL(SvTIED_mg((SV*)hv, PERL_MAGIC_tied));
+ other_tied = cBOOL(SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied));
+ if (!tied ) {
+ if(other_tied) {
+ /* swap HV sides */
+ HV * const temp = other_hv;
+ other_hv = hv;
+ hv = temp;
+ tied = TRUE;
+ other_tied = FALSE;
+ }
+ else if(HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
+ goto ret_no;
+ }
+
+ /* The hashes have the same number of keys, so it suffices
+ to check that one is a subset of the other. */
+ (void) hv_iterinit(hv);
+ while ( (he = hv_iternext(hv)) ) {
+ SV *key = hv_iterkeysv(he);
+
+ DEBUG_M(Perl_deb(aTHX_ " comparing hash key...\n"));
+ ++ this_key_count;
+
+ if(!hv_exists_ent(other_hv, key, 0)) {
+ (void) hv_iterinit(hv); /* reset iterator */
+ goto ret_no;
+ }
+ }
+
+ if (other_tied) {
+ (void) hv_iterinit(other_hv);
+ while ( hv_iternext(other_hv) )
+ ++other_key_count;
+ }
+ else
+ other_key_count = HvUSEDKEYS(other_hv);
+
+ if (this_key_count != other_key_count)
+ goto ret_no;
+ else
+ goto ret_yes;
+ }
+ else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
+ AV * const other_av = MUTABLE_AV(SvRV(d));
+ const Size_t other_len = av_count(other_av);
+ Size_t i;
+ HV *hv = MUTABLE_HV(SvRV(e));
+
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Hash\n"));
+ for (i = 0; i < other_len; ++i) {
+ SV ** const svp = av_fetch(other_av, i, FALSE);
+ DEBUG_M(Perl_deb(aTHX_ " checking for key existence...\n"));
+ if (svp) { /* ??? When can this not happen? */
+ if (hv_exists_ent(hv, *svp, 0))
+ goto ret_yes;
+ }
+ }
+ goto ret_no;
+ }
+ else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Hash\n"));
+ sm_regex_hash:
+ {
+ PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
+ HE *he;
+ HV *hv = MUTABLE_HV(SvRV(e));
+
+ (void) hv_iterinit(hv);
+ while ( (he = hv_iternext(hv)) ) {
+ DEBUG_M(Perl_deb(aTHX_ " testing key against pattern...\n"));
+ if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
+ (void) hv_iterinit(hv);
+ destroy_matcher(matcher);
+ goto ret_yes;
+ }
+ }
+ destroy_matcher(matcher);
+ goto ret_no;
+ }
+ }
+ else {
+ sm_any_hash:
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash\n"));
+ if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
+ goto ret_yes;
+ else
+ goto ret_no;
+ }
}
/* ~~ @array */
else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
- if (object_on_left) {
- goto sm_any_array; /* Treat objects like scalars */
- }
- else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
- AV * const other_av = MUTABLE_AV(SvRV(e));
- const SSize_t other_len = av_tindex(other_av) + 1;
- SSize_t i;
-
- DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Array\n"));
- for (i = 0; i < other_len; ++i) {
- SV ** const svp = av_fetch(other_av, i, FALSE);
-
- DEBUG_M(Perl_deb(aTHX_ " testing for key existence...\n"));
- if (svp) { /* ??? When can this not happen? */
- if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
- RETPUSHYES;
- }
- }
- RETPUSHNO;
- }
- if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
- AV *other_av = MUTABLE_AV(SvRV(d));
- DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Array\n"));
- if (av_tindex(MUTABLE_AV(SvRV(e))) != av_tindex(other_av))
- RETPUSHNO;
- else {
- SSize_t i;
- const SSize_t other_len = av_tindex(other_av);
-
- if (NULL == seen_this) {
- seen_this = newHV();
- (void) sv_2mortal(MUTABLE_SV(seen_this));
- }
- if (NULL == seen_other) {
- seen_other = newHV();
- (void) sv_2mortal(MUTABLE_SV(seen_other));
- }
- for(i = 0; i <= other_len; ++i) {
- SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
- SV * const * const other_elem = av_fetch(other_av, i, FALSE);
-
- if (!this_elem || !other_elem) {
- if ((this_elem && SvOK(*this_elem))
- || (other_elem && SvOK(*other_elem)))
- RETPUSHNO;
- }
- else if (hv_exists_ent(seen_this,
- sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
- hv_exists_ent(seen_other,
- sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
- {
- if (*this_elem != *other_elem)
- RETPUSHNO;
- }
- else {
- (void)hv_store_ent(seen_this,
- sv_2mortal(newSViv(PTR2IV(*this_elem))),
- &PL_sv_undef, 0);
- (void)hv_store_ent(seen_other,
- sv_2mortal(newSViv(PTR2IV(*other_elem))),
- &PL_sv_undef, 0);
- PUSHs(*other_elem);
- PUSHs(*this_elem);
-
- PUTBACK;
- DEBUG_M(Perl_deb(aTHX_ " recursively comparing array element...\n"));
- (void) do_smartmatch(seen_this, seen_other, 0);
- SPAGAIN;
- DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
-
- if (!SvTRUEx(POPs))
- RETPUSHNO;
- }
- }
- RETPUSHYES;
- }
- }
- else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
- DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Array\n"));
- sm_regex_array:
- {
- PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
- const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
- SSize_t i;
-
- for(i = 0; i <= this_len; ++i) {
- SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
- DEBUG_M(Perl_deb(aTHX_ " testing element against pattern...\n"));
- PUTBACK;
- if (svp && matcher_matches_sv(matcher, *svp)) {
- SPAGAIN;
- destroy_matcher(matcher);
- RETPUSHYES;
- }
- SPAGAIN;
- }
- destroy_matcher(matcher);
- RETPUSHNO;
- }
- }
- else if (!SvOK(d)) {
- /* undef ~~ array */
- const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
- SSize_t i;
-
- DEBUG_M(Perl_deb(aTHX_ " applying rule Undef-Array\n"));
- for (i = 0; i <= this_len; ++i) {
- SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
- DEBUG_M(Perl_deb(aTHX_ " testing for undef element...\n"));
- if (!svp || !SvOK(*svp))
- RETPUSHYES;
- }
- RETPUSHNO;
- }
- else {
- sm_any_array:
- {
- SSize_t i;
- const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
-
- DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Array\n"));
- for (i = 0; i <= this_len; ++i) {
- SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
- if (!svp)
- continue;
-
- PUSHs(d);
- PUSHs(*svp);
- PUTBACK;
- /* infinite recursion isn't supposed to happen here */
- DEBUG_M(Perl_deb(aTHX_ " recursively testing array element...\n"));
- (void) do_smartmatch(NULL, NULL, 1);
- SPAGAIN;
- DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
- if (SvTRUEx(POPs))
- RETPUSHYES;
- }
- RETPUSHNO;
- }
- }
+ if (object_on_left) {
+ goto sm_any_array; /* Treat objects like scalars */
+ }
+ else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
+ AV * const other_av = MUTABLE_AV(SvRV(e));
+ const Size_t other_len = av_count(other_av);
+ Size_t i;
+
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Array\n"));
+ for (i = 0; i < other_len; ++i) {
+ SV ** const svp = av_fetch(other_av, i, FALSE);
+
+ DEBUG_M(Perl_deb(aTHX_ " testing for key existence...\n"));
+ if (svp) { /* ??? When can this not happen? */
+ if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
+ goto ret_yes;
+ }
+ }
+ goto ret_no;
+ }
+ if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
+ AV *other_av = MUTABLE_AV(SvRV(d));
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Array\n"));
+ if (av_count(MUTABLE_AV(SvRV(e))) != av_count(other_av))
+ goto ret_no;
+ else {
+ Size_t i;
+ const Size_t other_len = av_count(other_av);
+
+ if (NULL == seen_this) {
+ seen_this = (HV*)newSV_type_mortal(SVt_PVHV);
+ }
+ if (NULL == seen_other) {
+ seen_other = (HV*)newSV_type_mortal(SVt_PVHV);
+ }
+ for(i = 0; i < other_len; ++i) {
+ SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
+ SV * const * const other_elem = av_fetch(other_av, i, FALSE);
+
+ if (!this_elem || !other_elem) {
+ if ((this_elem && SvOK(*this_elem))
+ || (other_elem && SvOK(*other_elem)))
+ goto ret_no;
+ }
+ else if (hv_exists_ent(seen_this,
+ sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
+ hv_exists_ent(seen_other,
+ sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
+ {
+ if (*this_elem != *other_elem)
+ goto ret_no;
+ }
+ else {
+ (void)hv_store_ent(seen_this,
+ sv_2mortal(newSViv(PTR2IV(*this_elem))),
+ &PL_sv_undef, 0);
+ (void)hv_store_ent(seen_other,
+ sv_2mortal(newSViv(PTR2IV(*other_elem))),
+ &PL_sv_undef, 0);
+ rpp_xpush_2(*other_elem, *this_elem);
+ DEBUG_M(Perl_deb(aTHX_ " recursively comparing array element...\n"));
+ (void) do_smartmatch(seen_this, seen_other, 0);
+ DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
+
+ bool ok = SvTRUEx(PL_stack_sp[0]);
+ rpp_popfree_1_NN();
+ if (!ok)
+ goto ret_no;
+ }
+ }
+ goto ret_yes;
+ }
+ }
+ else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Array\n"));
+ sm_regex_array:
+ {
+ PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
+ const Size_t this_len = av_count(MUTABLE_AV(SvRV(e)));
+ Size_t i;
+
+ for(i = 0; i < this_len; ++i) {
+ SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
+ DEBUG_M(Perl_deb(aTHX_ " testing element against pattern...\n"));
+ if (svp && matcher_matches_sv(matcher, *svp)) {
+ destroy_matcher(matcher);
+ goto ret_yes;
+ }
+ }
+ destroy_matcher(matcher);
+ goto ret_no;
+ }
+ }
+ else if (!SvOK(d)) {
+ /* undef ~~ array */
+ const Size_t this_len = av_count(MUTABLE_AV(SvRV(e)));
+ Size_t i;
+
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Undef-Array\n"));
+ for (i = 0; i < this_len; ++i) {
+ SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
+ DEBUG_M(Perl_deb(aTHX_ " testing for undef element...\n"));
+ if (!svp || !SvOK(*svp))
+ goto ret_yes;
+ }
+ goto ret_no;
+ }
+ else {
+ sm_any_array:
+ {
+ Size_t i;
+ const Size_t this_len = av_count(MUTABLE_AV(SvRV(e)));
+
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Array\n"));
+ for (i = 0; i < this_len; ++i) {
+ SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
+ if (!svp)
+ continue;
+
+ rpp_xpush_2(d, *svp);
+ /* infinite recursion isn't supposed to happen here */
+ DEBUG_M(Perl_deb(aTHX_ " recursively testing array element...\n"));
+ (void) do_smartmatch(NULL, NULL, 1);
+ DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
+ bool ok = SvTRUEx(PL_stack_sp[0]);
+ rpp_popfree_1_NN();
+ if (ok)
+ goto ret_yes;
+ }
+ goto ret_no;
+ }
+ }
}
/* ~~ qr// */
else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
- if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
- SV *t = d; d = e; e = t;
- DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Regex\n"));
- goto sm_regex_hash;
- }
- else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
- SV *t = d; d = e; e = t;
- DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Regex\n"));
- goto sm_regex_array;
- }
- else {
- PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
+ if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
+ SV *t = d; d = e; e = t;
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Regex\n"));
+ goto sm_regex_hash;
+ }
+ else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
+ SV *t = d; d = e; e = t;
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Regex\n"));
+ goto sm_regex_array;
+ }
+ else {
+ PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
bool result;
- DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Regex\n"));
- PUTBACK;
- result = matcher_matches_sv(matcher, d);
- SPAGAIN;
- PUSHs(result ? &PL_sv_yes : &PL_sv_no);
- destroy_matcher(matcher);
- RETURN;
- }
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Regex\n"));
+ result = matcher_matches_sv(matcher, d);
+ destroy_matcher(matcher);
+ if (result)
+ goto ret_yes;
+ else
+ goto ret_no;
+ }
}
/* ~~ scalar */
/* See if there is overload magic on left */
else if (object_on_left && SvAMAGIC(d)) {
- SV *tmpsv;
- DEBUG_M(Perl_deb(aTHX_ " applying rule Object-Any\n"));
- DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
- PUSHs(d); PUSHs(e);
- PUTBACK;
- tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
- if (tmpsv) {
- SPAGAIN;
- (void)POPs;
- SETs(tmpsv);
- RETURN;
- }
- SP -= 2;
- DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; falling back...\n"));
- goto sm_any_scalar;
+ SV *tmpsv;
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Object-Any\n"));
+ DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
+ tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
+ if (tmpsv) {
+ rpp_replace_2_1_NN(tmpsv);
+ return NORMAL;
+ }
+
+ DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; falling back...\n"));
+ goto sm_any_scalar;
}
else if (!SvOK(d)) {
- /* undef ~~ scalar ; we already know that the scalar is SvOK */
- DEBUG_M(Perl_deb(aTHX_ " applying rule undef-Any\n"));
- RETPUSHNO;
+ /* undef ~~ scalar ; we already know that the scalar is SvOK */
+ DEBUG_M(Perl_deb(aTHX_ " applying rule undef-Any\n"));
+ goto ret_no;
}
else
sm_any_scalar:
if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
- DEBUG_M(if (SvNIOK(e))
- Perl_deb(aTHX_ " applying rule Any-Num\n");
- else
- Perl_deb(aTHX_ " applying rule Num-numish\n");
- );
- /* numeric comparison */
- PUSHs(d); PUSHs(e);
- PUTBACK;
- if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
- (void) Perl_pp_i_eq(aTHX);
- else
- (void) Perl_pp_eq(aTHX);
- SPAGAIN;
- if (SvTRUEx(POPs))
- RETPUSHYES;
- else
- RETPUSHNO;
+ DEBUG_M(if (SvNIOK(e))
+ Perl_deb(aTHX_ " applying rule Any-Num\n");
+ else
+ Perl_deb(aTHX_ " applying rule Num-numish\n");
+ );
+ /* numeric comparison */
+ rpp_xpush_2(d, e);
+ if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
+ (void) Perl_pp_i_eq(aTHX);
+ else
+ (void) Perl_pp_eq(aTHX);
+ bool ok = SvTRUEx(PL_stack_sp[0]);
+ rpp_popfree_1_NN();
+ if (ok)
+ goto ret_yes;
+ else
+ goto ret_no;
}
/* As a last resort, use string comparison */
DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Any\n"));
- PUSHs(d); PUSHs(e);
- PUTBACK;
- return Perl_pp_seq(aTHX);
+ rpp_xpush_2(d, e);
+ Perl_pp_seq(aTHX);
+ {
+ bool ok = SvTRUEx(PL_stack_sp[0]);
+ rpp_popfree_1_NN();
+ if (ok)
+ goto ret_yes;
+ else
+ goto ret_no;
+ }
+
+ ret_no:
+ rpp_replace_2_IMM_NN(&PL_sv_no);
+ return NORMAL;
+
+ ret_yes:
+ rpp_replace_2_IMM_NN(&PL_sv_yes);
+ return NORMAL;
}
+
PP(pp_enterwhen)
{
- dSP;
PERL_CONTEXT *cx;
const U8 gimme = GIMME_V;
fails, we don't want to push a context and then
pop it again right away, so we skip straight
to the op that follows the leavewhen.
- RETURNOP calls PUTBACK which restores the stack pointer after the POPs.
*/
- if (!(PL_op->op_flags & OPf_SPECIAL) && !SvTRUEx(POPs)) {
- if (gimme == G_SCALAR)
- PUSHs(&PL_sv_undef);
- RETURNOP(cLOGOP->op_other->op_next);
+ if (!(PL_op->op_flags & OPf_SPECIAL)) { /* SPECIAL implies no condition */
+ bool tr = SvTRUEx(*PL_stack_sp);
+ rpp_popfree_1_NN();
+ if (!tr) {
+ if (gimme == G_SCALAR)
+ rpp_push_IMM(&PL_sv_undef);
+ return cLOGOP->op_other->op_next;
+ }
}
- cx = cx_pushblock(CXt_WHEN, gimme, SP, PL_savestack_ix);
+ cx = cx_pushblock(CXt_WHEN, gimme, PL_stack_sp, PL_savestack_ix);
cx_pushwhen(cx);
- RETURN;
+ return NORMAL;
}
PP(pp_leavewhen)
cxix = dopoptogivenfor(cxstack_ix);
if (cxix < 0)
- /* diag_listed_as: Can't "when" outside a topicalizer */
- DIE(aTHX_ "Can't \"%s\" outside a topicalizer",
- PL_op->op_flags & OPf_SPECIAL ? "default" : "when");
+ /* diag_listed_as: Can't "when" outside a topicalizer */
+ DIE(aTHX_ "Can't \"%s\" outside a topicalizer",
+ PL_op->op_flags & OPf_SPECIAL ? "default" : "when");
oldsp = PL_stack_base + cx->blk_oldsp;
if (gimme == G_VOID)
- PL_stack_sp = oldsp;
+ rpp_popfree_to_NN(oldsp);
else
leave_adjust_stacks(oldsp, oldsp, gimme, 1);
/* emulate pp_next. Note that any stack(s) cleanup will be
* done by the pp_unstack which op_nextop should point to */
cx = CX_CUR();
- cx_topblock(cx);
- PL_curcop = cx->blk_oldcop;
- return cx->blk_loop.my_op->op_nextop;
+ cx_topblock(cx);
+ PL_curcop = cx->blk_oldcop;
+ return cx->blk_loop.my_op->op_nextop;
}
else {
- PERL_ASYNC_CHECK();
+ PERL_ASYNC_CHECK();
assert(cx->blk_givwhen.leave_op->op_type == OP_LEAVEGIVEN);
- return cx->blk_givwhen.leave_op;
+ return cx->blk_givwhen.leave_op;
}
}
cxix = dopoptowhen(cxstack_ix);
if (cxix < 0)
- DIE(aTHX_ "Can't \"continue\" outside a when block");
+ DIE(aTHX_ "Can't \"continue\" outside a when block");
if (cxix < cxstack_ix)
dounwind(cxix);
cx = CX_CUR();
assert(CxTYPE(cx) == CXt_WHEN);
- PL_stack_sp = PL_stack_base + cx->blk_oldsp;
+ rpp_popfree_to_NN(PL_stack_base + cx->blk_oldsp);
CX_LEAVE_SCOPE(cx);
cx_popwhen(cx);
cx_popblock(cx);
cxix = dopoptogivenfor(cxstack_ix);
if (cxix < 0)
- DIE(aTHX_ "Can't \"break\" outside a given block");
+ DIE(aTHX_ "Can't \"break\" outside a given block");
cx = &cxstack[cxix];
if (CxFOREACH(cx))
- DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
+ DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
if (cxix < cxstack_ix)
dounwind(cxix);
/* Restore the sp at the time we entered the given block */
cx = CX_CUR();
- PL_stack_sp = PL_stack_base + cx->blk_oldsp;
+ rpp_popfree_to_NN(PL_stack_base + cx->blk_oldsp);
return cx->blk_givwhen.leave_op;
}
+static void
+_invoke_defer_block(pTHX_ U8 type, void *_arg)
+{
+ OP *start = (OP *)_arg;
+#ifdef DEBUGGING
+ I32 was_cxstack_ix = cxstack_ix;
+#endif
+
+ cx_pushblock(type, G_VOID, PL_stack_sp, PL_savestack_ix);
+ ENTER;
+ SAVETMPS;
+
+ SAVEOP();
+ PL_op = start;
+
+ CALLRUNOPS(aTHX);
+
+ FREETMPS;
+ LEAVE;
+
+ {
+ PERL_CONTEXT *cx;
+
+ cx = CX_CUR();
+ assert(CxTYPE(cx) == CXt_DEFER);
+
+ /* since we're called during a scope cleanup (including after
+ * a croak), theere's no guarantee thr stack is currently
+ * ref-counted */
+#ifdef PERL_RC_STACK
+ if (rpp_stack_is_rc())
+ rpp_popfree_to_NN(PL_stack_base + cx->blk_oldsp);
+ else
+#endif
+ PL_stack_sp = PL_stack_base + cx->blk_oldsp;
+
+
+ CX_LEAVE_SCOPE(cx);
+ cx_popblock(cx);
+ CX_POP(cx);
+ }
+
+ assert(cxstack_ix == was_cxstack_ix);
+}
+
+static void
+invoke_defer_block(pTHX_ void *_arg)
+{
+ _invoke_defer_block(aTHX_ CXt_DEFER, _arg);
+}
+
+static void
+invoke_finally_block(pTHX_ void *_arg)
+{
+ _invoke_defer_block(aTHX_ CXt_DEFER|CXp_FINALLY, _arg);
+}
+
+PP(pp_pushdefer)
+{
+ if(PL_op->op_private & OPpDEFER_FINALLY)
+ SAVEDESTRUCTOR_X(invoke_finally_block, cLOGOP->op_other);
+ else
+ SAVEDESTRUCTOR_X(invoke_defer_block, cLOGOP->op_other);
+
+ return NORMAL;
+}
+
static MAGIC *
S_doparseform(pTHX_ SV *sv)
{
PERL_ARGS_ASSERT_DOPARSEFORM;
if (len == 0)
- Perl_croak(aTHX_ "Null picture in formline");
+ Perl_croak(aTHX_ "Null picture in formline");
if (SvTYPE(sv) >= SVt_PVMG) {
- /* This might, of course, still return NULL. */
- mg = mg_find(sv, PERL_MAGIC_fm);
+ /* This might, of course, still return NULL. */
+ mg = mg_find(sv, PERL_MAGIC_fm);
} else {
- sv_upgrade(sv, SVt_PVMG);
+ sv_upgrade(sv, SVt_PVMG);
}
if (mg) {
- /* still the same as previously-compiled string? */
- SV *old = mg->mg_obj;
- if ( !(!!SvUTF8(old) ^ !!SvUTF8(sv))
- && len == SvCUR(old)
- && strnEQ(SvPVX(old), s, len)
- ) {
- DEBUG_f(PerlIO_printf(Perl_debug_log,"Re-using compiled format\n"));
- return mg;
- }
-
- DEBUG_f(PerlIO_printf(Perl_debug_log, "Re-compiling format\n"));
- Safefree(mg->mg_ptr);
- mg->mg_ptr = NULL;
- SvREFCNT_dec(old);
- mg->mg_obj = NULL;
+ /* still the same as previously-compiled string? */
+ SV *old = mg->mg_obj;
+ if ( ! (cBOOL(SvUTF8(old)) ^ cBOOL(SvUTF8(sv)))
+ && len == SvCUR(old)
+ && strnEQ(SvPVX(old), s, len)
+ ) {
+ DEBUG_f(PerlIO_printf(Perl_debug_log,"Re-using compiled format\n"));
+ return mg;
+ }
+
+ DEBUG_f(PerlIO_printf(Perl_debug_log, "Re-compiling format\n"));
+ Safefree(mg->mg_ptr);
+ mg->mg_ptr = NULL;
+ SvREFCNT_dec(old);
+ mg->mg_obj = NULL;
}
else {
- DEBUG_f(PerlIO_printf(Perl_debug_log, "Compiling format\n"));
- mg = sv_magicext(sv, NULL, PERL_MAGIC_fm, &PL_vtbl_fm, NULL, 0);
+ DEBUG_f(PerlIO_printf(Perl_debug_log, "Compiling format\n"));
+ mg = sv_magicext(sv, NULL, PERL_MAGIC_fm, &PL_vtbl_fm, NULL, 0);
}
sv_copy = newSVpvn_utf8(s, len, SvUTF8(sv));
/* estimate the buffer size needed */
for (base = s; s <= send; s++) {
- if (*s == '\n' || *s == '@' || *s == '^')
- maxops += 10;
+ if (*s == '\n' || *s == '@' || *s == '^')
+ maxops += 10;
}
s = base;
base = NULL;
fpc = fops;
if (s < send) {
- linepc = fpc;
- *fpc++ = FF_LINEMARK;
- noblank = repeat = FALSE;
- base = s;
+ linepc = fpc;
+ *fpc++ = FF_LINEMARK;
+ noblank = repeat = FALSE;
+ base = s;
}
while (s <= send) {
- switch (*s++) {
- default:
- skipspaces = 0;
- continue;
-
- case '~':
- if (*s == '~') {
- repeat = TRUE;
- skipspaces++;
- s++;
- }
- noblank = TRUE;
- /* FALLTHROUGH */
- case ' ': case '\t':
- skipspaces++;
- continue;
+ switch (*s++) {
+ default:
+ skipspaces = 0;
+ continue;
+
+ case '~':
+ if (*s == '~') {
+ repeat = TRUE;
+ skipspaces++;
+ s++;
+ }
+ noblank = TRUE;
+ /* FALLTHROUGH */
+ case ' ': case '\t':
+ skipspaces++;
+ continue;
case 0:
- if (s < send) {
- skipspaces = 0;
+ if (s < send) {
+ skipspaces = 0;
continue;
}
/* FALLTHROUGH */
- case '\n':
- arg = s - base;
- skipspaces++;
- arg -= skipspaces;
- if (arg) {
- if (postspace)
- *fpc++ = FF_SPACE;
- *fpc++ = FF_LITERAL;
- *fpc++ = (U32)arg;
- }
- postspace = FALSE;
- if (s <= send)
- skipspaces--;
- if (skipspaces) {
- *fpc++ = FF_SKIP;
- *fpc++ = (U32)skipspaces;
- }
- skipspaces = 0;
- if (s <= send)
- *fpc++ = FF_NEWLINE;
- if (noblank) {
- *fpc++ = FF_BLANK;
- if (repeat)
- arg = fpc - linepc + 1;
- else
- arg = 0;
- *fpc++ = (U32)arg;
- }
- if (s < send) {
- linepc = fpc;
- *fpc++ = FF_LINEMARK;
- noblank = repeat = FALSE;
- base = s;
- }
- else
- s++;
- continue;
-
- case '@':
- case '^':
- ischop = s[-1] == '^';
-
- if (postspace) {
- *fpc++ = FF_SPACE;
- postspace = FALSE;
- }
- arg = (s - base) - 1;
- if (arg) {
- *fpc++ = FF_LITERAL;
- *fpc++ = (U32)arg;
- }
-
- base = s - 1;
- *fpc++ = FF_FETCH;
- if (*s == '*') { /* @* or ^* */
- s++;
- *fpc++ = 2; /* skip the @* or ^* */
- if (ischop) {
- *fpc++ = FF_LINESNGL;
- *fpc++ = FF_CHOP;
- } else
- *fpc++ = FF_LINEGLOB;
- }
- else if (*s == '#' || (*s == '.' && s[1] == '#')) { /* @###, ^### */
- arg = ischop ? FORM_NUM_BLANK : 0;
- base = s - 1;
- while (*s == '#')
- s++;
- if (*s == '.') {
+ case '\n':
+ arg = s - base;
+ skipspaces++;
+ arg -= skipspaces;
+ if (arg) {
+ if (postspace)
+ *fpc++ = FF_SPACE;
+ *fpc++ = FF_LITERAL;
+ *fpc++ = (U32)arg;
+ }
+ postspace = FALSE;
+ if (s <= send)
+ skipspaces--;
+ if (skipspaces) {
+ *fpc++ = FF_SKIP;
+ *fpc++ = (U32)skipspaces;
+ }
+ skipspaces = 0;
+ if (s <= send)
+ *fpc++ = FF_NEWLINE;
+ if (noblank) {
+ *fpc++ = FF_BLANK;
+ if (repeat)
+ arg = fpc - linepc + 1;
+ else
+ arg = 0;
+ *fpc++ = (U32)arg;
+ }
+ if (s < send) {
+ linepc = fpc;
+ *fpc++ = FF_LINEMARK;
+ noblank = repeat = FALSE;
+ base = s;
+ }
+ else
+ s++;
+ continue;
+
+ case '@':
+ case '^':
+ ischop = s[-1] == '^';
+
+ if (postspace) {
+ *fpc++ = FF_SPACE;
+ postspace = FALSE;
+ }
+ arg = (s - base) - 1;
+ if (arg) {
+ *fpc++ = FF_LITERAL;
+ *fpc++ = (U32)arg;
+ }
+
+ base = s - 1;
+ *fpc++ = FF_FETCH;
+ if (*s == '*') { /* @* or ^* */
+ s++;
+ *fpc++ = 2; /* skip the @* or ^* */
+ if (ischop) {
+ *fpc++ = FF_LINESNGL;
+ *fpc++ = FF_CHOP;
+ } else
+ *fpc++ = FF_LINEGLOB;
+ }
+ else if (*s == '#' || (*s == '.' && s[1] == '#')) { /* @###, ^### */
+ arg = ischop ? FORM_NUM_BLANK : 0;
+ base = s - 1;
+ while (*s == '#')
+ s++;
+ if (*s == '.') {
const char * const f = ++s;
- while (*s == '#')
- s++;
- arg |= FORM_NUM_POINT + (s - f);
- }
- *fpc++ = s - base; /* fieldsize for FETCH */
- *fpc++ = FF_DECIMAL;
+ while (*s == '#')
+ s++;
+ arg |= FORM_NUM_POINT + (s - f);
+ }
+ *fpc++ = s - base; /* fieldsize for FETCH */
+ *fpc++ = FF_DECIMAL;
*fpc++ = (U32)arg;
unchopnum |= ! ischop;
}
else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
arg = ischop ? FORM_NUM_BLANK : 0;
- base = s - 1;
+ base = s - 1;
s++; /* skip the '0' first */
while (*s == '#')
s++;
}
*fpc++ = s - base; /* fieldsize for FETCH */
*fpc++ = FF_0DECIMAL;
- *fpc++ = (U32)arg;
+ *fpc++ = (U32)arg;
unchopnum |= ! ischop;
- }
- else { /* text field */
- I32 prespace = 0;
- bool ismore = FALSE;
-
- if (*s == '>') {
- while (*++s == '>') ;
- prespace = FF_SPACE;
- }
- else if (*s == '|') {
- while (*++s == '|') ;
- prespace = FF_HALFSPACE;
- postspace = TRUE;
- }
- else {
- if (*s == '<')
- while (*++s == '<') ;
- postspace = TRUE;
- }
- if (*s == '.' && s[1] == '.' && s[2] == '.') {
- s += 3;
- ismore = TRUE;
- }
- *fpc++ = s - base; /* fieldsize for FETCH */
-
- *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
-
- if (prespace)
- *fpc++ = (U32)prespace; /* add SPACE or HALFSPACE */
- *fpc++ = FF_ITEM;
- if (ismore)
- *fpc++ = FF_MORE;
- if (ischop)
- *fpc++ = FF_CHOP;
- }
- base = s;
- skipspaces = 0;
- continue;
- }
+ }
+ else { /* text field */
+ I32 prespace = 0;
+ bool ismore = FALSE;
+
+ if (*s == '>') {
+ while (*++s == '>') ;
+ prespace = FF_SPACE;
+ }
+ else if (*s == '|') {
+ while (*++s == '|') ;
+ prespace = FF_HALFSPACE;
+ postspace = TRUE;
+ }
+ else {
+ if (*s == '<')
+ while (*++s == '<') ;
+ postspace = TRUE;
+ }
+ if (*s == '.' && s[1] == '.' && s[2] == '.') {
+ s += 3;
+ ismore = TRUE;
+ }
+ *fpc++ = s - base; /* fieldsize for FETCH */
+
+ *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
+
+ if (prespace)
+ *fpc++ = (U32)prespace; /* add SPACE or HALFSPACE */
+ *fpc++ = FF_ITEM;
+ if (ismore)
+ *fpc++ = FF_MORE;
+ if (ischop)
+ *fpc++ = FF_CHOP;
+ }
+ base = s;
+ skipspaces = 0;
+ continue;
+ }
}
*fpc++ = FF_END;
if( value >= 0 ){
if (value + eps >= pwr)
- res = TRUE;
+ res = TRUE;
} else {
if (value - eps <= -pwr)
- res = TRUE;
+ res = TRUE;
}
return res;
}
not sure where the trouble is yet. XXX */
{
- SV *const cache = datasv;
- if (SvOK(cache)) {
- STRLEN cache_len;
- const char *cache_p = SvPV(cache, cache_len);
- STRLEN take = 0;
-
- if (umaxlen) {
- /* Running in block mode and we have some cached data already.
- */
- if (cache_len >= umaxlen) {
- /* In fact, so much data we don't even need to call
- filter_read. */
- take = umaxlen;
- }
- } else {
- const char *const first_nl =
- (const char *)memchr(cache_p, '\n', cache_len);
- if (first_nl) {
- take = first_nl + 1 - cache_p;
- }
- }
- if (take) {
- sv_catpvn(buf_sv, cache_p, take);
- sv_chop(cache, cache_p + take);
- /* Definitely not EOF */
- return 1;
- }
-
- sv_catsv(buf_sv, cache);
- if (umaxlen) {
- umaxlen -= cache_len;
- }
- SvOK_off(cache);
- read_from_cache = TRUE;
- }
+ SV *const cache = datasv;
+ if (SvOK(cache)) {
+ STRLEN cache_len;
+ const char *cache_p = SvPV(cache, cache_len);
+ STRLEN take = 0;
+
+ if (umaxlen) {
+ /* Running in block mode and we have some cached data already.
+ */
+ if (cache_len >= umaxlen) {
+ /* In fact, so much data we don't even need to call
+ filter_read. */
+ take = umaxlen;
+ }
+ } else {
+ const char *const first_nl =
+ (const char *)memchr(cache_p, '\n', cache_len);
+ if (first_nl) {
+ take = first_nl + 1 - cache_p;
+ }
+ }
+ if (take) {
+ sv_catpvn(buf_sv, cache_p, take);
+ sv_chop(cache, cache_p + take);
+ /* Definitely not EOF */
+ return 1;
+ }
+
+ sv_catsv(buf_sv, cache);
+ if (umaxlen) {
+ umaxlen -= cache_len;
+ }
+ SvOK_off(cache);
+ read_from_cache = TRUE;
+ }
}
/* Filter API says that the filter appends to the contents of the buffer.
don't want to pass it in a second time.
I'm going to use a mortal in case the upstream filter croaks. */
upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
- ? sv_newmortal() : buf_sv;
+ ? newSV_type_mortal(SVt_PV) : buf_sv;
SvUPGRADE(upstream, SVt_PV);
-
+
if (filter_has_file) {
- status = FILTER_READ(idx+1, upstream, 0);
+ status = FILTER_READ(idx+1, upstream, 0);
}
if (filter_sub && status >= 0) {
- dSP;
- int count;
-
- ENTER_with_name("call_filter_sub");
- SAVE_DEFSV;
- SAVETMPS;
- EXTEND(SP, 2);
-
- DEFSV_set(upstream);
- PUSHMARK(SP);
- PUSHs(&PL_sv_zero);
- if (filter_state) {
- PUSHs(filter_state);
- }
- PUTBACK;
- count = call_sv(filter_sub, G_SCALAR|G_EVAL);
- SPAGAIN;
-
- if (count > 0) {
- SV *out = POPs;
- SvGETMAGIC(out);
- if (SvOK(out)) {
- status = SvIV(out);
- }
+ dSP;
+ int count;
+
+ ENTER_with_name("call_filter_sub");
+ SAVE_DEFSV;
+ SAVETMPS;
+ EXTEND(SP, 2);
+
+ DEFSV_set(upstream);
+ PUSHMARK(SP);
+ PUSHs(&PL_sv_zero);
+ if (filter_state) {
+ PUSHs(filter_state);
+ }
+ PUTBACK;
+ count = call_sv(filter_sub, G_SCALAR|G_EVAL);
+ SPAGAIN;
+
+ if (count > 0) {
+ SV *out = POPs;
+ SvGETMAGIC(out);
+ if (SvOK(out)) {
+ status = SvIV(out);
+ }
else {
SV * const errsv = ERRSV;
if (SvTRUE_NN(errsv))
err = newSVsv(errsv);
}
- }
+ }
- PUTBACK;
- FREETMPS;
- LEAVE_with_name("call_filter_sub");
+ PUTBACK;
+ FREETMPS;
+ LEAVE_with_name("call_filter_sub");
}
if (SvGMAGICAL(upstream)) {
- mg_get(upstream);
- if (upstream == buf_sv) mg_free(buf_sv);
+ mg_get(upstream);
+ if (upstream == buf_sv) mg_free(buf_sv);
}
if (SvIsCOW(upstream)) sv_force_normal(upstream);
if(!err && SvOK(upstream)) {
- got_p = SvPV_nomg(upstream, got_len);
- if (umaxlen) {
- if (got_len > umaxlen) {
- prune_from = got_p + umaxlen;
- }
- } else {
- char *const first_nl = (char *)memchr(got_p, '\n', got_len);
- if (first_nl && first_nl + 1 < got_p + got_len) {
- /* There's a second line here... */
- prune_from = first_nl + 1;
- }
- }
+ got_p = SvPV_nomg(upstream, got_len);
+ if (umaxlen) {
+ if (got_len > umaxlen) {
+ prune_from = got_p + umaxlen;
+ }
+ } else {
+ char *const first_nl = (char *)memchr(got_p, '\n', got_len);
+ if (first_nl && first_nl + 1 < got_p + got_len) {
+ /* There's a second line here... */
+ prune_from = first_nl + 1;
+ }
+ }
}
if (!err && prune_from) {
- /* Oh. Too long. Stuff some in our cache. */
- STRLEN cached_len = got_p + got_len - prune_from;
- SV *const cache = datasv;
-
- if (SvOK(cache)) {
- /* Cache should be empty. */
- assert(!SvCUR(cache));
- }
-
- sv_setpvn(cache, prune_from, cached_len);
- /* If you ask for block mode, you may well split UTF-8 characters.
- "If it breaks, you get to keep both parts"
- (Your code is broken if you don't put them back together again
- before something notices.) */
- if (SvUTF8(upstream)) {
- SvUTF8_on(cache);
- }
- if (SvPOK(upstream)) SvCUR_set(upstream, got_len - cached_len);
- else
- /* Cannot just use sv_setpvn, as that could free the buffer
- before we have a chance to assign it. */
- sv_usepvn(upstream, savepvn(got_p, got_len - cached_len),
- got_len - cached_len);
- *prune_from = 0;
- /* Can't yet be EOF */
- if (status == 0)
- status = 1;
+ /* Oh. Too long. Stuff some in our cache. */
+ STRLEN cached_len = got_p + got_len - prune_from;
+ SV *const cache = datasv;
+
+ if (SvOK(cache)) {
+ /* Cache should be empty. */
+ assert(!SvCUR(cache));
+ }
+
+ sv_setpvn(cache, prune_from, cached_len);
+ /* If you ask for block mode, you may well split UTF-8 characters.
+ "If it breaks, you get to keep both parts"
+ (Your code is broken if you don't put them back together again
+ before something notices.) */
+ if (SvUTF8(upstream)) {
+ SvUTF8_on(cache);
+ }
+ if (SvPOK(upstream)) SvCUR_set(upstream, got_len - cached_len);
+ else
+ /* Cannot just use sv_setpvn, as that could free the buffer
+ before we have a chance to assign it. */
+ sv_usepvn(upstream, savepvn(got_p, got_len - cached_len),
+ got_len - cached_len);
+ *prune_from = 0;
+ /* Can't yet be EOF */
+ if (status == 0)
+ status = 1;
}
/* If they are at EOF but buf_sv has something in it, then they may never
*/
if (!err && upstream != buf_sv &&
SvOK(upstream)) {
- sv_catsv_nomg(buf_sv, upstream);
+ sv_catsv_nomg(buf_sv, upstream);
}
else if (SvOK(upstream)) (void)SvPV_force_nolen(buf_sv);
if (status <= 0) {
- IoLINES(datasv) = 0;
- if (filter_state) {
- SvREFCNT_dec(filter_state);
- IoTOP_GV(datasv) = NULL;
- }
- if (filter_sub) {
- SvREFCNT_dec(filter_sub);
- IoBOTTOM_GV(datasv) = NULL;
- }
- filter_del(S_run_user_filter);
+ IoLINES(datasv) = 0;
+ if (filter_state) {
+ SvREFCNT_dec(filter_state);
+ IoTOP_GV(datasv) = NULL;
+ }
+ if (filter_sub) {
+ SvREFCNT_dec(filter_sub);
+ IoBOTTOM_GV(datasv) = NULL;
+ }
+ filter_del(S_run_user_filter);
}
if (err)
croak_sv(err);
if (status == 0 && read_from_cache) {
- /* If we read some data from the cache (and by getting here it implies
- that we emptied the cache) then we aren't yet at EOF, and mustn't
- report that to our caller. */
- return 1;
+ /* If we read some data from the cache (and by getting here it implies
+ that we emptied the cache) then we aren't yet at EOF, and mustn't
+ report that to our caller. */
+ return 1;
}
return status;
}
https://perl5.git.perl.org / perl5.git / blobdiff