summaryrefslogtreecommitdiff
path: root/pp_ctl.c
diff options
context:
space:
mode:
authorMichael G. Schwern <schwern@pobox.com>2020-12-28 18:04:52 -0800
committerKarl Williamson <khw@cpan.org>2021-01-17 09:18:15 -0700
commit1604cfb0273418ed479719f39def5ee559bffda2 (patch)
tree166a5ab935a029ab86cf6295d6f3cb77da22e559 /pp_ctl.c
parent557ff1b2a4ecd18fe9229e7e0eb8fa123adc5670 (diff)
downloadperl-1604cfb0273418ed479719f39def5ee559bffda2.tar.gz
style: Detabify indentation of the C code maintained by the core.
This just detabifies to get rid of the mixed tab/space indentation. Applying consistent indentation and dealing with other tabs are another issue. Done with `expand -i`. * vutil.* left alone, it's part of version. * Left regen managed files alone for now.
Diffstat (limited to 'pp_ctl.c')
-rw-r--r--pp_ctl.c5278
1 files changed, 2639 insertions, 2639 deletions
diff --git a/pp_ctl.c b/pp_ctl.c
index ed451c02e8..654ecca270 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -53,22 +53,22 @@ PP(pp_wantarray)
EXTEND(SP, 1);
if (PL_op->op_private & OPpOFFBYONE) {
- if (!(cx = caller_cx(1,NULL))) RETPUSHUNDEF;
+ if (!(cx = caller_cx(1,NULL))) RETPUSHUNDEF;
}
else {
cxix = dopopto_cursub();
if (cxix < 0)
- RETPUSHUNDEF;
+ RETPUSHUNDEF;
cx = &cxstack[cxix];
}
switch (cx->blk_gimme) {
case G_ARRAY:
- RETPUSHYES;
+ RETPUSHYES;
case G_SCALAR:
- RETPUSHNO;
+ RETPUSHNO;
default:
- RETPUSHUNDEF;
+ RETPUSHUNDEF;
}
}
@@ -90,20 +90,20 @@ PP(pp_regcomp)
bool is_bare_re= FALSE;
if (PL_op->op_flags & OPf_STACKED) {
- dMARK;
- nargs = SP - MARK;
- args = ++MARK;
+ dMARK;
+ nargs = SP - MARK;
+ args = ++MARK;
}
else {
- nargs = 1;
- args = SP;
+ nargs = 1;
+ args = SP;
}
/* prevent recompiling under /o and ithreads. */
#if defined(USE_ITHREADS)
if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) {
- SP = args-1;
- RETURN;
+ SP = args-1;
+ RETURN;
}
#endif
@@ -112,57 +112,57 @@ PP(pp_regcomp)
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
+ 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);
#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);
}
@@ -179,7 +179,7 @@ PP(pp_regcomp)
/* 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
@@ -204,82 +204,82 @@ PP(pp_substcont)
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");
+ 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 */
+ 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 ||
+ /* 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 ||
!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 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(
+ {
+ 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 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(
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
@@ -299,42 +299,42 @@ PP(pp_substcont)
}
}
- 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();
+ RETURNOP(pm->op_next);
+ NOT_REACHED; /* NOTREACHED */
+ }
+ cx->sb_iters = saviters;
}
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;
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;
{ /* 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 */
@@ -342,31 +342,31 @@ PP(pp_substcont)
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);
+ (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() */
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;
@@ -384,15 +384,15 @@ Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
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 */
@@ -410,8 +410,8 @@ Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
*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_OFFS(rx)[i].start;
+ *p++ = (UV)RX_OFFS(rx)[i].end;
}
}
@@ -431,7 +431,7 @@ S_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
#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
@@ -441,8 +441,8 @@ S_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
RX_SUBOFFSET(rx) = (I32)*p++;
RX_SUBCOFFSET(rx) = (I32)*p++;
for (i = 0; i <= RX_NPARENS(rx); ++i) {
- RX_OFFS(rx)[i].start = (I32)(*p++);
- RX_OFFS(rx)[i].end = (I32)(*p++);
+ RX_OFFS(rx)[i].start = (I32)(*p++);
+ RX_OFFS(rx)[i].end = (I32)(*p++);
}
}
@@ -455,12 +455,12 @@ S_rxres_free(pTHX_ void **rsp)
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
@@ -471,9 +471,9 @@ S_rxres_free(pTHX_ void **rsp)
PoisonFree(p, i, sizeof(UV));
#endif
- Safefree(tmp);
- Safefree(p);
- *rsp = NULL;
+ Safefree(tmp);
+ Safefree(p);
+ *rsp = NULL;
}
}
@@ -521,9 +521,9 @@ PP(pp_formline)
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);
@@ -533,76 +533,76 @@ PP(pp_formline)
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 ? !!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;
itemsize = 0;
- item_is_utf8 = DO_UTF8(sv);
+ item_is_utf8 = DO_UTF8(sv);
while (s < send) {
if (!isCNTRL(*s))
gotsome = TRUE;
@@ -619,17 +619,17 @@ PP(pp_formline)
}
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)) {
@@ -678,37 +678,37 @@ PP(pp_formline)
}
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))) ) {
@@ -726,154 +726,154 @@ PP(pp_formline)
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;
@@ -896,73 +896,73 @@ PP(pp_formline)
#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;
+ }
}
}
@@ -973,10 +973,10 @@ PP(pp_grepstart)
SV *src;
if (PL_stack_base + TOPMARK == SP) {
- (void)POPMARK;
- if (GIMME_V == G_SCALAR)
- XPUSHs(&PL_sv_zero);
- RETURNOP(PL_op->op_next->op_next);
+ (void)POPMARK;
+ if (GIMME_V == G_SCALAR)
+ XPUSHs(&PL_sv_zero);
+ RETURNOP(PL_op->op_next->op_next);
}
PL_stack_sp = PL_stack_base + TOPMARK + 1;
Perl_pp_pushmark(aTHX); /* push dst */
@@ -990,15 +990,15 @@ PP(pp_grepstart)
src = PL_stack_base[TOPMARK];
if (SvPADTMP(src)) {
- src = PL_stack_base[TOPMARK] = sv_mortalcopy(src);
- PL_tmps_floor++;
+ src = PL_stack_base[TOPMARK] = sv_mortalcopy(src);
+ PL_tmps_floor++;
}
SvTEMP_off(src);
DEFSV_set(src);
PUTBACK;
if (PL_op->op_type == OP_MAPSTART)
- Perl_pp_pushmark(aTHX); /* push top */
+ Perl_pp_pushmark(aTHX); /* push top */
return ((LOGOP*)PL_op->op_next)->op_other;
}
@@ -1017,127 +1017,127 @@ PP(pp_mapwhile)
/* 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 = (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;
- }
+ 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;
+ }
}
else {
- FREETMPS;
+ 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 */
+ SP = PL_stack_base + POPMARK; /* pop original mark */
+ if (gimme == G_SCALAR) {
+ dTARGET;
+ XPUSHi(items);
+ }
+ else if (gimme == G_ARRAY)
+ SP += items;
+ RETURN;
}
else {
- SV *src;
+ SV *src;
- ENTER_with_name("grep_item"); /* enter inner scope */
- SAVEVPTR(PL_curpm);
+ 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)) {
+ /* set $_ to the new source item */
+ src = PL_stack_base[PL_markstack_ptr[-1]];
+ if (SvPADTMP(src)) {
src = sv_mortalcopy(src);
}
- SvTEMP_off(src);
- DEFSV_set(src);
+ SvTEMP_off(src);
+ DEFSV_set(src);
- RETURNOP(cLOGOP->op_other);
+ RETURNOP(cLOGOP->op_other);
}
}
@@ -1147,12 +1147,12 @@ PP(pp_range)
{
dTARG;
if (GIMME_V == G_ARRAY)
- return NORMAL;
+ return NORMAL;
GETTARGET;
if (SvTRUE_NN(targ))
- return cLOGOP->op_other;
+ return cLOGOP->op_other;
else
- return NORMAL;
+ return NORMAL;
}
PP(pp_flip)
@@ -1160,41 +1160,41 @@ PP(pp_flip)
dSP;
if (GIMME_V == G_ARRAY) {
- RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
+ RETURNOP(((LOGOP*)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(((LOGOP*)cUNOP->op_first)->op_other);
+ }
+ }
SvPVCLEAR(TARG);
- SETs(targ);
- RETURN;
+ SETs(targ);
+ RETURN;
}
}
@@ -1206,9 +1206,9 @@ PP(pp_flip)
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))))
@@ -1218,21 +1218,21 @@ PP(pp_flop)
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) > (NV) IV_MAX)))
- DIE(aTHX_ "Range iterator outside integer range");
- i = SvIV_nomg(left);
- j = SvIV_nomg(right);
- if (j >= i) {
+ 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) {
@@ -1249,59 +1249,59 @@ PP(pp_flop)
}
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(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
+ sv_catpvs(targ, "E0");
+ }
+ SETs(targ);
}
RETURN;
@@ -1333,29 +1333,29 @@ S_dopoptolabel(pTHX_ const char *label, STRLEN len, U32 flags)
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_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:
+ {
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(
@@ -1366,14 +1366,14 @@ S_dopoptolabel(pTHX_ const char *label, STRLEN len, U32 flags)
(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;
}
@@ -1395,11 +1395,11 @@ Perl_block_gimme(pTHX)
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;
}
@@ -1411,9 +1411,9 @@ Perl_is_lvalue_sub(pTHX)
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() */
@@ -1424,9 +1424,9 @@ Perl_was_lvalue_sub(pTHX)
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
@@ -1440,11 +1440,11 @@ S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
#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
@@ -1452,11 +1452,11 @@ S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
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;
- }
+ case CXt_EVAL:
+ case CXt_FORMAT:
+ DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
+ return i;
+ }
}
return i;
}
@@ -1466,14 +1466,14 @@ S_dopoptoeval(pTHX_ I32 startingblock)
{
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;
}
@@ -1483,27 +1483,27 @@ S_dopoptoloop(pTHX_ I32 startingblock)
{
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_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;
+ }
}
return i;
}
@@ -1515,25 +1515,25 @@ S_dopoptogivenfor(pTHX_ I32 startingblock)
{
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;
}
@@ -1543,14 +1543,14 @@ S_dopoptowhen(pTHX_ I32 startingblock)
{
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;
}
@@ -1566,57 +1566,57 @@ void
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:
/* 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--;
}
}
@@ -1627,19 +1627,19 @@ Perl_qerror(pTHX_ SV *err)
PERL_ARGS_ASSERT_QERROR;
if (PL_in_eval) {
- if (PL_in_eval & EVAL_KEEPERR) {
- Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %" SVf,
+ 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
+ sv_catsv(ERRSV, err);
}
else if (PL_errors)
- sv_catsv(PL_errors, err);
+ sv_catsv(PL_errors, err);
else
- Perl_warn(aTHX_ "%" SVf, SVfARG(err));
+ Perl_warn(aTHX_ "%" SVf, SVfARG(err));
if (PL_parser)
- ++PL_parser->error_count;
+ ++PL_parser->error_count;
}
@@ -1708,7 +1708,7 @@ Perl_die_unwind(pTHX_ SV *msv)
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
@@ -1722,64 +1722,64 @@ Perl_die_unwind(pTHX_ SV *msv)
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)) {
+ /*
+ * 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));
- }
-
- while ((cxix = dopoptoeval(cxstack_ix)) < 0
- && PL_curstackinfo->si_prev)
- {
- dounwind(-1);
- POPSTACK;
- }
-
- if (cxix >= 0) {
- PERL_CONTEXT *cx;
- SV **oldsp;
+ 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;
+ }
+
+ if (cxix >= 0) {
+ PERL_CONTEXT *cx;
+ SV **oldsp;
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);
@@ -1787,12 +1787,12 @@ Perl_die_unwind(pTHX_ SV *msv)
/* 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)
+ *++oldsp = &PL_sv_undef;
+ PL_stack_sp = oldsp;
- 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.
@@ -1819,15 +1819,15 @@ Perl_die_unwind(pTHX_ SV *msv)
*/
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);
@@ -1839,9 +1839,9 @@ PP(pp_xor)
{
dSP; dPOPTOPssrl;
if (SvTRUE_NN(left) != SvTRUE_NN(right))
- RETSETYES;
+ RETSETYES;
else
- RETSETNO;
+ RETSETNO;
}
/*
@@ -1875,21 +1875,21 @@ Perl_caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp)
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];
@@ -1897,11 +1897,11 @@ Perl_caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp)
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;
@@ -1920,17 +1920,17 @@ PP(pp_caller)
if (MAXARG) {
if (has_arg)
- count = POPi;
+ count = POPi;
else (void)POPs;
}
cx = caller_cx(count + !!(PL_op->op_private & OPpOFFBYONE), &dbcx);
if (!cx) {
- if (gimme != G_ARRAY) {
- EXTEND(SP, 1);
- RETPUSHUNDEF;
- }
- RETURN;
+ if (gimme != G_ARRAY) {
+ EXTEND(SP, 1);
+ RETPUSHUNDEF;
+ }
+ RETURN;
}
CX_DEBUG(cx, "CALLER");
@@ -1940,56 +1940,56 @@ PP(pp_caller)
: NULL;
if (gimme != G_ARRAY) {
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_ARRAY));
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,
@@ -2000,61 +2000,61 @@ PP(pp_caller)
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))
+ && CopSTASH_eq(PL_curcop, PL_debstash))
{
/* slot 0 of the pad contains the original @_ */
- AV * const ary = MUTABLE_AV(AvARRAY(MUTABLE_AV(
+ 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);
+ const SSize_t off = AvARRAY(ary) - AvALLOC(ary);
- Perl_init_dbargs(aTHX);
+ Perl_init_dbargs(aTHX);
- if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
- av_extend(PL_dbargs, AvFILLp(ary) + off);
+ 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;
+ 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 ;
+ STRLEN * const 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]);
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;
}
@@ -2065,10 +2065,10 @@ PP(pp_reset)
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;
@@ -2086,39 +2086,39 @@ PP(pp_dbstate)
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;
+ dSP;
+ PERL_CONTEXT *cx;
+ const U8 gimme = G_ARRAY;
+ 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;
SAVESTACK_POS();
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(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);
/* 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 */
@@ -2127,15 +2127,15 @@ PP(pp_dbstate)
SAVEI32(PL_debug);
PL_debug = 0;
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));
- }
+ CvDEPTH(cv)++;
+ if (CvDEPTH(cv) >= 2)
+ pad_push(CvPADLIST(cv), CvDEPTH(cv));
+ PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv));
+ RETURNOP(CvSTART(cv));
+ }
}
else
- return NORMAL;
+ return NORMAL;
}
@@ -2159,7 +2159,7 @@ PP(pp_leave)
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;
@@ -2209,21 +2209,21 @@ PP(pp_enteriter)
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 = POPs;
+ itervarp = (void *)sv;
if (LIKELY(isGV(sv))) { /* symbol table variable */
itersave = GvSV(sv);
SvREFCNT_inc_simple_void(itersave);
@@ -2254,56 +2254,56 @@ PP(pp_enteriter)
/* 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 = POPs;
+ 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) ||
+ 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) ||
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);
+ }
+ 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 */ {
/* 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;
- }
+ 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 */
}
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_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
@@ -2381,7 +2381,7 @@ PP(pp_leavesublv)
/* 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;
@@ -2527,7 +2527,7 @@ PP(pp_return)
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 {
@@ -2573,7 +2573,7 @@ PP(pp_return)
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));
}
}
@@ -2584,29 +2584,29 @@ S_unwind_loop(pTHX)
{
I32 cxix;
if (PL_op->op_flags & OPf_SPECIAL) {
- cxix = dopoptoloop(cxstack_ix);
- if (cxix < 0)
- /* diag_listed_as: Can't "last" outside a loop block */
- Perl_croak(aTHX_ "Can't \"%s\" outside a loop block",
+ 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;
+ 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;
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
@@ -2615,7 +2615,7 @@ S_unwind_loop(pTHX)
label_flags | SVs_TEMP)));
}
if (cxix < cxstack_ix)
- dounwind(cxix);
+ dounwind(cxix);
return &cxstack[cxix];
}
@@ -2667,11 +2667,11 @@ PP(pp_redo)
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;
@@ -2694,47 +2694,47 @@ S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstac
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(
@@ -2745,32 +2745,32 @@ S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstac
(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)))
+ return o;
+ if (first_kid_of_binary)
+ *ops++ = UNENTERABLE;
+ }
}
*ops = 0;
return 0;
@@ -2784,7 +2784,7 @@ S_check_op_type(pTHX_ OP * const o)
* 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_
@@ -2812,74 +2812,74 @@ PP(pp_goto)
if (PL_op->op_flags & OPf_STACKED) {
/* goto EXPR or goto &foo */
- SV * const sv = POPs;
- SvGETMAGIC(sv);
+ SV * const sv = POPs;
+ 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);
+
+ 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 = dopopto_cursub();
+ 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)");
+
+ /* First do some returnish stuff. */
+
+ SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
+ FREETMPS;
+ if (cxix < cxstack_ix) {
+ dounwind(cxix);
}
cx = CX_CUR();
- cx_topblock(cx);
- SPAGAIN;
+ cx_topblock(cx);
+ SPAGAIN;
/* 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);
@@ -2890,10 +2890,10 @@ PP(pp_goto)
* 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 || AvREAL(av))
clear_defarray(av, av == arg);
- else CLEAR_ARGARRAY(av);
- }
+ 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
@@ -2901,66 +2901,66 @@ PP(pp_goto)
* 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;
+ /* 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);
}
- /* 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;
ENTER;
SAVETMPS;
SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
- /* 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 @_ */
+ /* 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 @_ */
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;
+ /* 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;
@@ -2969,78 +2969,78 @@ PP(pp_goto)
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);
+ PUTBACK;
+ (void)(*CvXSUB(cv))(aTHX_ cv);
+ LEAVE;
+ goto _return;
+ }
+ 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 putback_return;
+ }
+ }
+ else {
/* goto EXPR */
- label = SvPV_nomg_const(sv, label_len);
+ 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);
}
@@ -3049,27 +3049,27 @@ PP(pp_goto)
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;
+ 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;
+ 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:
@@ -3077,118 +3077,118 @@ PP(pp_goto)
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");
+ 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("\"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:
@@ -3204,16 +3204,16 @@ PP(pp_exit)
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
@@ -3236,18 +3236,18 @@ S_save_lines(pTHX_ AV *array, SV *sv)
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(tmpstr, s, t - s);
+ av_store(array, line++, tmpstr);
+ s = t;
}
}
@@ -3277,24 +3277,24 @@ S_docatch(pTHX_ Perl_ppaddr_t firstpp)
JMPENV_PUSH(ret);
switch (ret) {
case 0:
- PL_op = firstpp(aTHX);
+ PL_op = firstpp(aTHX);
redo_body:
- CALLRUNOPS(aTHX);
- break;
+ 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 */
+ /* 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 */
default:
- JMPENV_POP;
- PL_op = oldop;
- JMPENV_JUMP(ret);
- NOT_REACHED; /* NOTREACHED */
+ JMPENV_POP;
+ PL_op = oldop;
+ JMPENV_JUMP(ret);
+ NOT_REACHED; /* NOTREACHED */
}
JMPENV_POP;
PL_op = oldop;
@@ -3328,43 +3328,43 @@ Perl_find_runcv_where(pTHX_ U8 cond, IV arg, U32 *db_seqp)
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 && !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;
/* FALLTHROUGH */
- default:
- return cv;
- }
- }
- }
+ default:
+ return cv;
+ }
+ }
+ }
}
return cond == FIND_RUNCV_padid_eq ? NULL : PL_main_cv;
}
@@ -3385,14 +3385,14 @@ S_try_yyparse(pTHX_ int gramtype)
JMPENV_PUSH(ret);
switch (ret) {
case 0:
- ret = yyparse(gramtype) ? 1 : 0;
- break;
+ ret = yyparse(gramtype) ? 1 : 0;
+ break;
case 3:
- break;
+ break;
default:
- JMPENV_POP;
- JMPENV_JUMP(ret);
- NOT_REACHED; /* NOTREACHED */
+ JMPENV_POP;
+ JMPENV_JUMP(ret);
+ NOT_REACHED; /* NOTREACHED */
}
JMPENV_POP;
return ret;
@@ -3425,8 +3425,8 @@ S_doeval_compile(pTHX_ U8 gimme, CV* outside, U32 seq, HV *hh)
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)));
@@ -3452,14 +3452,14 @@ S_doeval_compile(pTHX_ U8 gimme, CV* outside, U32 seq, HV *hh)
/* 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);
@@ -3479,19 +3479,19 @@ S_doeval_compile(pTHX_ U8 gimme, CV* outside, U32 seq, HV *hh)
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 = HINTS_DEFAULT;
- hv_clear(GvHV(PL_hintgv));
+ PL_hints = HINTS_DEFAULT;
+ 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
@@ -3501,37 +3501,37 @@ S_doeval_compile(pTHX_ U8 gimme, CV* outside, U32 seq, HV *hh)
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);
@@ -3544,37 +3544,37 @@ S_doeval_compile(pTHX_ U8 gimme, CV* outside, U32 seq, HV *hh)
yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : 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
+ 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 */
+ if (yystatus != 3) {
+ if (PL_eval_root) {
+ op_free(PL_eval_root);
+ PL_eval_root = NULL;
+ }
+ SP = PL_stack_base + POPMARK; /* pop original mark */
cx = CX_CUR();
assert(CxTYPE(cx) == CXt_EVAL);
/* pop the CXt_EVAL, and if was a require, croak */
S_pop_eval_context_maybe_croak(aTHX_ cx, ERRSV, 2);
- }
+ }
/* die_unwind() re-croaks when in require, having popped the
* require EVAL context. So we should never catch a require
* exception here */
- assert(!in_require);
+ 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_ARRAY) PUSHs(&PL_sv_undef);
+ PUTBACK;
+ return FALSE;
}
/* Compilation successful. Now clean up */
@@ -3589,20 +3589,20 @@ S_doeval_compile(pTHX_ U8 gimme, CV* outside, U32 seq, HV *hh)
/* 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) {
+ dSP;
+ PUSHMARK(SP);
+ XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
+ PUTBACK;
+ 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;
+ OP *es = PL_eval_start;
+ call_list(PL_scopestack_ix, PL_unitcheckav);
+ PL_eval_start = es;
}
CvDEPTH(evalcv) = 1;
@@ -3649,19 +3649,19 @@ S_check_type_and_open(pTHX_ SV *name)
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
@@ -3670,17 +3670,17 @@ S_check_type_and_open(pTHX_ SV *name)
/* 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;
@@ -3708,15 +3708,15 @@ S_doopen_pm(pTHX_ SV *name)
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);
}
@@ -3733,21 +3733,21 @@ S_path_is_searchable(const char *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;
}
@@ -3861,12 +3861,12 @@ S_require_file(pTHX_ SV *sv)
DIE(aTHX_ "Missing or undefined argument to %s", op_name);
#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 && (SvGETMAGIC(*svp_cached), SvOK(*svp_cached)) ) 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)) ) RETPUSHYES;
+ }
#endif
if (!IS_SAFE_PATHNAME(name, len, op_name)) {
@@ -3892,33 +3892,33 @@ S_require_file(pTHX_ SV *sv)
*/
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 ) {
+ /* 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))
- RETPUSHYES;
- else
- DIE(aTHX_ "Attempt to reload %s aborted.\n"
- "Compilation failed in require", unixname);
- }
+ if (SvOK(*svp))
+ RETPUSHYES;
+ 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) {
@@ -3974,9 +3974,9 @@ S_require_file(pTHX_ SV *sv)
/* 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;
@@ -3986,207 +3986,207 @@ S_require_file(pTHX_ SV *sv)
* For searchable paths, just search @INC normally
*/
if (!tryrsfp && !(errno == EACCES && !path_searchable)) {
- AV * const ar = GvAVn(PL_incgv);
- SSize_t i;
+ AV * const ar = GvAVn(PL_incgv);
+ SSize_t i;
#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) {
+ {
+ 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;
+ 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);
+ 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);
- }
+ /* 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;
- }
+ 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
@@ -4195,9 +4195,9 @@ S_require_file(pTHX_ SV *sv)
*/
break;
}
- }
- }
- }
+ }
+ }
+ }
}
/* at this point we've ether opened a file (tryrsfp) or set errno */
@@ -4206,24 +4206,24 @@ S_require_file(pTHX_ SV *sv)
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")) {
+ 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;
+ const char *c;
bool utf8 = cBOOL(SvUTF8(sv));
/* if the filename, when converted from "Foo/Bar.pm"
@@ -4233,7 +4233,7 @@ S_require_file(pTHX_ SV *sv)
*
* 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);
@@ -4245,7 +4245,7 @@ S_require_file(pTHX_ SV *sv)
while (c < e && isWORDCHAR_A(*c))
c++;
}
- else if (*c == '/')
+ else if (*c == '/')
c++;
else
break;
@@ -4263,22 +4263,22 @@ S_require_file(pTHX_ SV *sv)
}
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 contains:%" SVf ")",
+ name, msg, inc);
+ }
+ }
+ DIE(aTHX_ "Can't locate %s", name);
+ }
else {
#ifdef DEFAULT_INC_EXCLUDES_DOT
Stat_t st;
@@ -4306,19 +4306,19 @@ S_require_file(pTHX_ SV *sv)
}
}
else
- SETERRNO(0, SS_NORMAL);
+ SETERRNO(0, SS_NORMAL);
/* 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 );
+ 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 );
}
/* Now parse the file */
@@ -4329,17 +4329,17 @@ S_require_file(pTHX_ SV *sv)
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(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);
}
/* switch to eval mode */
@@ -4353,9 +4353,9 @@ S_require_file(pTHX_ SV *sv)
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);
@@ -4370,13 +4370,13 @@ PP(pp_require)
RUN_PP_CATCHABLY(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);
+ 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);
}
}
@@ -4421,36 +4421,36 @@ PP(pp_entereval)
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(SvREFCNT_inc(POPs));
}
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;
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));
@@ -4459,23 +4459,23 @@ PP(pp_entereval)
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
+ )
+ );
/* 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:%" IVdf "]",
+ (unsigned long)++PL_evalseq,
+ CopFILE(PL_curcop), (IV)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);
@@ -4494,41 +4494,41 @@ PP(pp_entereval)
/* 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);
+ }
+ return PL_op->op_next;
}
}
@@ -4599,7 +4599,7 @@ void
Perl_delete_eval_scope(pTHX)
{
PERL_CONTEXT *cx;
-
+
cx = CX_CUR();
CX_LEAVE_SCOPE(cx);
cx_popeval(cx);
@@ -4614,18 +4614,18 @@ Perl_create_eval_scope(pTHX_ OP *retop, U32 flags)
{
PERL_CONTEXT *cx;
const U8 gimme = GIMME_V;
-
+
cx = cx_pushblock((CXt_EVAL|CXp_TRYBLOCK), gimme,
PL_stack_sp, PL_savestack_ix);
cx_pusheval(cx, retop, NULL);
PL_in_eval = EVAL_INEVAL;
if (flags & G_KEEPERR)
- 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. */
}
}
@@ -4781,30 +4781,30 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied)
/* 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"));
+ 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"));
+ 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"));
}
SP -= 2; /* Pop the values */
@@ -4812,433 +4812,433 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied)
/* ~~ 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))
+ RETPUSHNO;
+ else
+ RETPUSHYES;
}
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 */
- 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)
- 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;
- }
+ 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 */
+ 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)
+ 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;
+ }
}
/* ~~ %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 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))
- 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"));
+ 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 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))
+ 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))) {
+ if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
SPAGAIN;
- (void) hv_iterinit(hv);
- destroy_matcher(matcher);
- RETPUSHYES;
- }
+ (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;
- }
+ }
+ 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;
+ }
}
/* ~~ @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 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))
- 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_count(MUTABLE_AV(SvRV(e))) != av_count(other_av))
- RETPUSHNO;
- else {
+ 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))
+ 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_count(MUTABLE_AV(SvRV(e))) != av_count(other_av))
+ RETPUSHNO;
+ else {
Size_t i;
const Size_t other_len = av_count(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 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 (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 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"));
PUTBACK;
- if (svp && matcher_matches_sv(matcher, *svp)) {
+ if (svp && matcher_matches_sv(matcher, *svp)) {
SPAGAIN;
- destroy_matcher(matcher);
- RETPUSHYES;
- }
+ destroy_matcher(matcher);
+ RETPUSHYES;
+ }
+ SPAGAIN;
+ }
+ destroy_matcher(matcher);
+ RETPUSHNO;
+ }
+ }
+ 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))
+ RETPUSHYES;
+ }
+ RETPUSHNO;
+ }
+ 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;
+
+ 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;
- }
- destroy_matcher(matcher);
- RETPUSHNO;
- }
- }
- 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))
- RETPUSHYES;
- }
- RETPUSHNO;
- }
- 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;
-
- 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;
- }
- }
+ DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
+ if (SvTRUEx(POPs))
+ RETPUSHYES;
+ }
+ RETPUSHNO;
+ }
+ }
}
/* ~~ 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);
+ 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;
- }
+ PUSHs(result ? &PL_sv_yes : &PL_sv_no);
+ destroy_matcher(matcher);
+ RETURN;
+ }
}
/* ~~ 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"));
+ 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;
}
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"));
+ RETPUSHNO;
}
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 */
+ 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;
}
/* As a last resort, use string comparison */
@@ -5261,9 +5261,9 @@ PP(pp_enterwhen)
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 (gimme == G_SCALAR)
+ PUSHs(&PL_sv_undef);
+ RETURNOP(cLOGOP->op_other->op_next);
}
cx = cx_pushblock(CXt_WHEN, gimme, SP, PL_savestack_ix);
@@ -5285,9 +5285,9 @@ 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)
@@ -5305,14 +5305,14 @@ PP(pp_leavewhen)
/* 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;
}
}
@@ -5324,7 +5324,7 @@ PP(pp_continue)
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);
@@ -5348,11 +5348,11 @@ PP(pp_break)
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);
@@ -5388,35 +5388,35 @@ 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)
+ /* 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-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;
+ 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));
@@ -5426,8 +5426,8 @@ S_doparseform(pTHX_ SV *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;
@@ -5436,117 +5436,117 @@ S_doparseform(pTHX_ SV *sv)
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++;
@@ -5558,47 +5558,47 @@ S_doparseform(pTHX_ SV *sv)
}
*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;
@@ -5636,10 +5636,10 @@ S_num_overflow(NV value, I32 fldsize, I32 frcsize)
if( value >= 0 ){
if (value + eps >= pwr)
- res = TRUE;
+ res = TRUE;
} else {
if (value - eps <= -pwr)
- res = TRUE;
+ res = TRUE;
}
return res;
}
@@ -5671,41 +5671,41 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
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.
@@ -5714,97 +5714,97 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
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;
+ ? sv_newmortal() : 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
@@ -5813,31 +5813,31 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
*/
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;
}
View Lorry Controller Status