X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/51b56f5c7c7e109a2c53226c83c2d324801d4f9b..d569e7cc1171d70b4ea183bc7c257dcf50f0ab12:/pp_ctl.c diff --git a/pp_ctl.c b/pp_ctl.c index 6fcaaef..d0b5d8d 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -35,9 +35,6 @@ #include "perl.h" #include "feature.h" -#define RUN_PP_CATCHABLY(thispp) \ - STMT_START { if (CATCH_GET) return docatch(thispp); } STMT_END - #define dopopto_cursub() \ (PL_curstackinfo->si_cxsubix >= 0 \ ? PL_curstackinfo->si_cxsubix \ @@ -53,22 +50,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; + case G_LIST: + RETPUSHYES; case G_SCALAR: - RETPUSHNO; + RETPUSHNO; default: - RETPUSHUNDEF; + RETPUSHUNDEF; } } @@ -81,7 +78,7 @@ PP(pp_regcreset) PP(pp_regcomp) { dSP; - PMOP *pm = (PMOP*)cLOGOP->op_other; + PMOP *pm = cPMOPx(cLOGOP->op_other); SV **args; int nargs; REGEXP *re = NULL; @@ -90,20 +87,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 +109,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 +176,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 @@ -192,7 +189,7 @@ PP(pp_substcont) { dSP; PERL_CONTEXT *cx = CX_CUR(); - PMOP * const pm = (PMOP*) cLOGOP->op_other; + PMOP * const pm = cPMOPx(cLOGOP->op_other); SV * const dstr = cx->sb_dstr; char *s = cx->sb_s; char *m = cx->sb_m; @@ -204,82 +201,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": pp_subst() in pp_hot.c */ + 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": pp_subst() in pp_hot.c */ + if (TAINTING_get) { + if ((cx->sb_rxtainted & SUBST_TAINT_PAT) || + ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) + == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) + ) + (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */ + + if (!(cx->sb_rxtainted & SUBST_TAINT_BOOLRET) + && (cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT)) + ) + SvTAINTED_on(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 +296,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 +339,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() */ + * See "how taint works": pp_subst() in pp_hot.c */ if (TAINTING_get) { - if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */ - cx->sb_rxtainted |= SUBST_TAINT_PAT; + if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */ + cx->sb_rxtainted |= SUBST_TAINT_PAT; - if ((cx->sb_rxtainted & SUBST_TAINT_PAT) || - ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) - == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) - ) - (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */ + if ((cx->sb_rxtainted & SUBST_TAINT_PAT) || + ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) + == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) + ) + (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */ - if (cx->sb_iters > 1 && (cx->sb_rxtainted & - (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))) - SvTAINTED_on((pm->op_pmflags & PMf_NONDESTRUCT) - ? cx->sb_dstr : cx->sb_targ); - TAINT_NOT; + if (cx->sb_iters > 1 && (cx->sb_rxtainted & + (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))) + SvTAINTED_on((pm->op_pmflags & PMf_NONDESTRUCT) + ? cx->sb_dstr : cx->sb_targ); + TAINT_NOT; } rxres_save(&cx->sb_rxres, rx); PL_curpm = pm; @@ -384,15 +381,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 +407,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 +428,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 +438,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 +452,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 +468,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 +518,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 +530,78 @@ 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 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 chars in format */ - f += *fpc++; - break; - - case FF_FETCH: /* get next item and set field size to */ - 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 literal chars */ + to_copy = *fpc++; + source = (U8 *)f; + f += to_copy; + trans = '~'; + item_is_utf8 = (targ_is_utf8) + ? cBOOL(DO_UTF8(formsv)) + : cBOOL(SvUTF8(formsv)); + goto append; + + case FF_SKIP: /* skip chars in format */ + f += *fpc++; + break; + + case FF_FETCH: /* get next item and set field size to */ + 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 +618,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)) { @@ -653,15 +652,15 @@ PP(pp_formline) break; } else { + if (size == fieldsize) + break; if (strchr(PL_chopset, *s)) { /* provisional split point */ /* for a non-space split char, we include * the split char; hence the '+1' */ chophere = s + 1; - itemsize = size; + itemsize = size + 1; } - if (size == fieldsize) - break; if (!isCNTRL(*s)) gotsome = TRUE; } @@ -678,37 +677,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 +725,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 =(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 =(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 +895,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 +972,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,18 +989,20 @@ 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 */ - return ((LOGOP*)PL_op->op_next)->op_other; + Perl_pp_pushmark(aTHX); /* push top */ + return cLOGOPx(PL_op->op_next)->op_other; } +/* pp_grepwhile() lives in pp_hot.c */ + PP(pp_mapwhile) { dSP; @@ -1017,127 +1018,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_LIST) { + /* add returned items to the collection (making mortal copies + * if necessary), then clear the current temps stack frame + * *except* for those items. We do this splicing the items + * into the start of the tmps frame (so some items may be on + * the tmps stack twice), then moving PL_tmps_floor above + * them, then freeing the frame. That way, the only tmps that + * accumulate over iterations are the return values for map. + * We have to do to this way so that everything gets correctly + * freed if we die during the map. + */ + 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_LIST) + 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); } } @@ -1146,55 +1147,55 @@ PP(pp_mapwhile) PP(pp_range) { dTARG; - if (GIMME_V == G_ARRAY) - return NORMAL; + if (GIMME_V == G_LIST) + return NORMAL; GETTARGET; if (SvTRUE_NN(targ)) - return cLOGOP->op_other; + return cLOGOP->op_other; else - return NORMAL; + return NORMAL; } PP(pp_flip) { dSP; - if (GIMME_V == G_ARRAY) { - RETURNOP(((LOGOP*)cUNOP->op_first)->op_other); + if (GIMME_V == G_LIST) { + RETURNOP(cLOGOPx(cUNOP->op_first)->op_other); } else { - dTOPss; - SV * const targ = PAD_SV(PL_op->op_targ); - int flip = 0; - - if (PL_op->op_private & OPpFLIP_LINENUM) { - if (GvIO(PL_last_in_gv)) { - flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)); - } - else { - GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV); - if (gv && GvSV(gv)) - flip = SvIV(sv) == SvIV(GvSV(gv)); - } - } else { - flip = SvTRUE_NN(sv); - } - if (flip) { - sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1); - if (PL_op->op_flags & OPf_SPECIAL) { - sv_setiv(targ, 1); - SETs(targ); - RETURN; - } - else { - sv_setiv(targ, 0); - SP--; - RETURNOP(((LOGOP*)cUNOP->op_first)->op_other); - } - } + dTOPss; + SV * const targ = PAD_SV(PL_op->op_targ); + int flip = 0; + + if (PL_op->op_private & OPpFLIP_LINENUM) { + if (GvIO(PL_last_in_gv)) { + flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)); + } + else { + GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV); + if (gv && GvSV(gv)) + flip = SvIV(sv) == SvIV(GvSV(gv)); + } + } else { + flip = SvTRUE_NN(sv); + } + if (flip) { + sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1); + if (PL_op->op_flags & OPf_SPECIAL) { + sv_setiv(targ, 1); + SETs(targ); + RETURN; + } + else { + sv_setiv(targ, 0); + SP--; + RETURNOP(cLOGOPx(cUNOP->op_first)->op_other); + } + } SvPVCLEAR(TARG); - SETs(targ); - RETURN; + SETs(targ); + RETURN; } } @@ -1206,9 +1207,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)))) @@ -1217,22 +1218,22 @@ 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) > IV_MAX))) - DIE(aTHX_ "Range iterator outside integer range"); - i = SvIV_nomg(left); - j = SvIV_nomg(right); - if (j >= i) { + if (GIMME_V == G_LIST) { + dPOPPOPssrl; + + SvGETMAGIC(left); + SvGETMAGIC(right); + + if (RANGE_IS_NUMERIC(left,right)) { + IV i, j, n; + if ((SvOK(left) && !SvIOK(left) && SvNV_nomg(left) < IV_MIN) || + (SvOK(right) && (SvIOK(right) + ? SvIsUV(right) && SvUV(right) > IV_MAX + : SvNV_nomg(right) > (NV) IV_MAX))) + DIE(aTHX_ "Range iterator outside integer range"); + i = SvIV_nomg(left); + j = SvIV_nomg(right); + if (j >= i) { /* Dance carefully around signed max. */ bool overflow = (i <= 0 && j > SSize_t_MAX + i - 1); if (!overflow) { @@ -1249,59 +1250,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(cUNOPx(cUNOP->op_first)->op_first->op_targ), 0); + sv_catpvs(targ, "E0"); + } + SETs(targ); } RETURN; @@ -1323,6 +1324,7 @@ static const char * const context_name[] = { "format", "eval", "substitution", + "defer block", }; STATIC I32 @@ -1333,29 +1335,32 @@ 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_EVAL: + if(CxTRY(cx)) + continue; + /* FALLTHROUGH */ + case CXt_SUBST: + case CXt_SUB: + case CXt_FORMAT: + case CXt_NULL: + /* diag_listed_as: Exiting subroutine via %s */ + Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s", + context_name[CxTYPE(cx)], OP_NAME(PL_op)); + if (CxTYPE(cx) == CXt_NULL) /* sort BLOCK */ + return -1; + break; + case CXt_LOOP_PLAIN: + case CXt_LOOP_LAZYIV: + case CXt_LOOP_LAZYSV: + case CXt_LOOP_LIST: + case CXt_LOOP_ARY: + { STRLEN cx_label_len = 0; U32 cx_label_flags = 0; - const char *cx_label = CxLABEL_len_flags(cx, &cx_label_len, &cx_label_flags); - if (!cx_label || !( + const char *cx_label = CxLABEL_len_flags(cx, &cx_label_len, &cx_label_flags); + if (!cx_label || !( ( (cx_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ? (flags & SVf_UTF8) ? (bytes_cmp_utf8( @@ -1366,19 +1371,26 @@ 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; } +/* +=for apidoc_section $callback +=for apidoc dowantarray + +Implements the deprecated L>. +=cut +*/ U8 Perl_dowantarray(pTHX) @@ -1395,14 +1407,22 @@ 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; } +/* +=for apidoc is_lvalue_sub + +Returns non-zero if the sub calling this function is being called in an lvalue +context. Returns 0 otherwise. + +=cut +*/ I32 Perl_is_lvalue_sub(pTHX) @@ -1411,9 +1431,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 +1444,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,23 +1460,30 @@ 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 * code block. Hide this faked entry from the world. */ if (cx->cx_type & CXp_SUB_RE_FAKE) continue; - /* FALLTHROUGH */ - case CXt_EVAL: - case CXt_FORMAT: - DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i)); - return i; - } + DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i)); + return i; + + case CXt_EVAL: + if (CxTRY(cx)) + continue; + DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i)); + return i; + + case CXt_FORMAT: + DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i)); + return i; + } } return i; } @@ -1466,14 +1493,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 +1510,30 @@ 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_EVAL: + if(CxTRY(cx)) + continue; + /* FALLTHROUGH */ + case CXt_SUBST: + case CXt_SUB: + case CXt_FORMAT: + case CXt_NULL: + /* diag_listed_as: Exiting subroutine via %s */ + Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s", + context_name[CxTYPE(cx)], OP_NAME(PL_op)); + if ((CxTYPE(cx)) == CXt_NULL) /* sort BLOCK */ + return -1; + break; + case CXt_LOOP_PLAIN: + case CXt_LOOP_LAZYIV: + case CXt_LOOP_LAZYSV: + case CXt_LOOP_LIST: + case CXt_LOOP_ARY: + DEBUG_l( Perl_deb(aTHX_ "(dopoptoloop(): found loop at cx=%ld)\n", (long)i)); + return i; + } } return i; } @@ -1515,25 +1545,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 +1573,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 +1596,58 @@ 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: + case CXt_DEFER: /* these two don't have a POPFOO() */ - break; - case CXt_FORMAT: - cx_popformat(cx); - break; - } + break; + case CXt_FORMAT: + cx_popformat(cx); + break; + } if (cxstack_ix == cxix + 1) { cx_popblock(cx); } - cxstack_ix--; + cxstack_ix--; } } @@ -1627,19 +1658,27 @@ 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)); - if (PL_parser) - ++PL_parser->error_count; + Perl_warn(aTHX_ "%" SVf, SVfARG(err)); + + if (PL_parser) { + STRLEN len; + char *err_pv = SvPV(err,len); + ++PL_parser->error_count; + if (memBEGINs(err_pv,len,"syntax error")) + { + PL_parser->error_count |= PERL_PARSE_IS_SYNTAX_ERROR_FLAG; + } + } } @@ -1672,16 +1711,14 @@ S_pop_eval_context_maybe_croak(pTHX_ PERL_CONTEXT *cx, SV *errsv, int action) if (do_croak) { const char *fmt; HV *inc_hv = GvHVn(PL_incgv); - I32 klen = SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv); - const char *key = SvPVX_const(namesv); if (action == 1) { - (void)hv_delete(inc_hv, key, klen, G_DISCARD); + (void)hv_delete_ent(inc_hv, namesv, G_DISCARD, 0); fmt = "%" SVf " did not return a true value"; errsv = namesv; } else { - (void)hv_store(inc_hv, key, klen, &PL_sv_undef, 0); + (void)hv_store_ent(inc_hv, namesv, &PL_sv_undef, 0); fmt = "%" SVf "Compilation failed in require"; if (!errsv) errsv = newSVpvs_flags("Unknown error\n", SVs_TEMP); @@ -1708,7 +1745,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 +1759,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 +1824,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 +1856,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,14 +1876,14 @@ PP(pp_xor) { dSP; dPOPTOPssrl; if (SvTRUE_NN(left) != SvTRUE_NN(right)) - RETSETYES; + RETSETYES; else - RETSETNO; + RETSETNO; } /* -=for apidoc_section CV Handling +=for apidoc_section $CV =for apidoc caller_cx @@ -1875,21 +1912,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 +1934,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 +1957,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); + cx = caller_cx(count + cBOOL(PL_op->op_private & OPpOFFBYONE), &dbcx); if (!cx) { - if (gimme != G_ARRAY) { - EXTEND(SP, 1); - RETPUSHUNDEF; - } - RETURN; + if (gimme != G_LIST) { + EXTEND(SP, 1); + RETPUSHUNDEF; + } + RETURN; } CX_DEBUG(cx, "CALLER"); @@ -1938,58 +1975,58 @@ PP(pp_caller) stash_hek = SvTYPE(CopSTASH(cx->blk_oldcop)) == SVt_PVHV ? HvNAME_HEK((HV*)CopSTASH(cx->blk_oldcop)) : NULL; - if (gimme != G_ARRAY) { + if (gimme != G_LIST) { EXTEND(SP, 1); - if (!stash_hek) - PUSHs(&PL_sv_undef); - else { - dTARGET; - sv_sethek(TARG, stash_hek); - PUSHs(TARG); - } - RETURN; + if (!stash_hek) + PUSHs(&PL_sv_undef); + else { + dTARGET; + sv_sethek(TARG, stash_hek); + PUSHs(TARG); + } + RETURN; } EXTEND(SP, 11); if (!stash_hek) - PUSHs(&PL_sv_undef); + PUSHs(&PL_sv_undef); else { - dTARGET; - sv_sethek(TARG, stash_hek); - PUSHTARG; + dTARGET; + sv_sethek(TARG, stash_hek); + PUSHTARG; } mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0)); lcop = closest_cop(cx->blk_oldcop, OpSIBLING(cx->blk_oldcop), - cx->blk_sub.retop, TRUE); + cx->blk_sub.retop, TRUE); if (!lcop) - lcop = cx->blk_oldcop; + lcop = cx->blk_oldcop; mPUSHu(CopLINE(lcop)); if (!has_arg) - RETURN; + RETURN; if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) { - /* So is ccstack[dbcxix]. */ - if (CvHASGV(dbcx->blk_sub.cv)) { - PUSHs(cv_name(dbcx->blk_sub.cv, 0, 0)); - PUSHs(boolSV(CxHASARGS(cx))); - } - else { - PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP)); - PUSHs(boolSV(CxHASARGS(cx))); - } + /* So is ccstack[dbcxix]. */ + if (CvHASGV(dbcx->blk_sub.cv)) { + PUSHs(cv_name(dbcx->blk_sub.cv, 0, 0)); + PUSHs(boolSV(CxHASARGS(cx))); + } + else { + PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP)); + PUSHs(boolSV(CxHASARGS(cx))); + } } else { - PUSHs(newSVpvs_flags("(eval)", SVs_TEMP)); - PUSHs(&PL_sv_zero); + PUSHs(newSVpvs_flags("(eval)", SVs_TEMP)); + PUSHs(&PL_sv_zero); } gimme = cx->blk_gimme; if (gimme == G_VOID) - PUSHs(&PL_sv_undef); + PUSHs(&PL_sv_undef); else - PUSHs(boolSV((gimme & G_WANT) == G_ARRAY)); + PUSHs(boolSV((gimme & G_WANT) == G_LIST)); if (CxTYPE(cx) == CXt_EVAL) { - /* eval STRING */ - if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) { + /* eval STRING */ + if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) { SV *cur_text = cx->blk_eval.cur_text; if (SvCUR(cur_text) >= 2) { PUSHs(newSVpvn_flags(SvPVX(cur_text), SvCUR(cur_text)-2, @@ -2000,61 +2037,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 ; + char *old_warnings = cx->blk_oldcop->cop_warnings; - if (old_warnings == pWARN_NONE) + if (old_warnings == pWARN_NONE) mask = newSVpvn(WARN_NONEstring, WARNsize) ; - else if (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0) + else if (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0) mask = &PL_sv_undef ; else if (old_warnings == pWARN_ALL || - (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) { - mask = newSVpvn(WARN_ALLstring, WARNsize) ; - } + (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) { + mask = newSVpvn(WARN_ALLstring, WARNsize) ; + } else - mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]); + mask = newSVpvn(old_warnings, RCPV_LEN(old_warnings)); mPUSHs(mask); } PUSHs(cx->blk_oldcop->cop_hints_hash ? - sv_2mortal(newRV_noinc(MUTABLE_SV(cop_hints_2hv(cx->blk_oldcop, 0)))) - : &PL_sv_undef); + sv_2mortal(newRV_noinc(MUTABLE_SV(cop_hints_2hv(cx->blk_oldcop, 0)))) + : &PL_sv_undef); RETURN; } @@ -2065,10 +2102,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 +2123,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_LIST; + GV * const gv = PL_DBgv; + CV * cv = NULL; if (gv && isGV_with_GP(gv)) cv = GvCV(gv); - if (!cv || (!CvROOT(cv) && !CvXSUB(cv))) - DIE(aTHX_ "No DB::DB routine defined"); + if (!cv || (!CvROOT(cv) && !CvXSUB(cv))) + DIE(aTHX_ "No DB::DB routine defined"); - if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG)) - /* don't do recursive DB::DB call */ - return NORMAL; + if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG)) + /* don't do recursive DB::DB call */ + return NORMAL; - if (CvISXSUB(cv)) { + if (CvISXSUB(cv)) { ENTER; SAVEI32(PL_debug); PL_debug = 0; 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 +2164,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 +2196,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 +2246,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 +2291,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 +2418,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; @@ -2429,7 +2466,7 @@ PP(pp_leavesublv) } } else { - assert(gimme == G_ARRAY); + assert(gimme == G_LIST); assert (!(lval & OPpDEREF)); if (is_lval) { @@ -2466,15 +2503,29 @@ PP(pp_leavesublv) return retop; } +static const char *S_defer_blockname(PERL_CONTEXT *cx) +{ + return (cx->cx_type & CXp_FINALLY) ? "finally" : "defer"; +} + PP(pp_return) { dSP; dMARK; PERL_CONTEXT *cx; - const I32 cxix = dopopto_cursub(); + I32 cxix = dopopto_cursub(); assert(cxstack_ix >= 0); if (cxix < cxstack_ix) { + I32 i; + /* Check for defer { return; } */ + for(i = cxstack_ix; i > cxix; i--) { + if(CxTYPE(&cxstack[i]) == CXt_DEFER) + /* diag_listed_as: Can't "%s" out of a "defer" block */ + /* diag_listed_as: Can't "%s" out of a "finally" block */ + Perl_croak(aTHX_ "Can't \"%s\" out of a \"%s\" block", + "return", S_defer_blockname(&cxstack[i])); + } if (cxix < 0) { if (!( PL_curstackinfo->si_type == PERLSI_SORT || ( PL_curstackinfo->si_type == PERLSI_MULTICALL @@ -2527,7 +2578,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 { @@ -2549,7 +2600,7 @@ PP(pp_return) if (oldsp != MARK) { SSize_t nargs = SP - MARK; if (nargs) { - if (cx->blk_gimme == G_ARRAY) { + if (cx->blk_gimme == G_LIST) { /* shift return args to base of call stack frame */ Move(MARK + 1, oldsp + 1, nargs, SV*); PL_stack_sp = oldsp + nargs; @@ -2563,7 +2614,7 @@ PP(pp_return) /* fall through to a normal exit */ switch (CxTYPE(cx)) { case CXt_EVAL: - return CxTRYBLOCK(cx) + return CxEVALBLOCK(cx) ? Perl_pp_leavetry(aTHX) : Perl_pp_leaveeval(aTHX); case CXt_SUB: @@ -2573,7 +2624,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 +2635,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 @@ -2614,8 +2665,18 @@ S_unwind_loop(pTHX) label_len, label_flags | SVs_TEMP))); } - if (cxix < cxstack_ix) - dounwind(cxix); + if (cxix < cxstack_ix) { + I32 i; + /* Check for defer { last ... } etc */ + for(i = cxstack_ix; i > cxix; i--) { + if(CxTYPE(&cxstack[i]) == CXt_DEFER) + /* diag_listed_as: Can't "%s" out of a "defer" block */ + /* diag_listed_as: Can't "%s" out of a "finally" block */ + Perl_croak(aTHX_ "Can't \"%s\" out of a \"%s\" block", + OP_NAME(PL_op), S_defer_blockname(&cxstack[i])); + } + dounwind(cxix); + } return &cxstack[cxix]; } @@ -2667,11 +2728,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 +2755,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 +2806,35 @@ 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))) { + if (kid->op_type == OP_PUSHDEFER) + Perl_croak(aTHX_ "Can't \"goto\" into a \"defer\" block"); + return o; + } + if (first_kid_of_binary) + *ops++ = UNENTERABLE; + } } *ops = 0; return 0; @@ -2784,7 +2848,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 +2876,83 @@ 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); + CV *old_cv = NULL; + + while (!CvROOT(cv) && !CvXSUB(cv)) { + const GV * const gv = CvGV(cv); + if (gv) { + GV *autogv; + SV *tmpstr; + /* autoloaded stub? */ + if (cv != GvCV(gv) && (cv = GvCV(gv))) + continue; + autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv), + GvNAMELEN(gv), GvNAMEUTF8(gv) ? SVf_UTF8 : 0); - if (autogv && (cv = GvCV(autogv))) - continue; - tmpstr = sv_newmortal(); - gv_efullname3(tmpstr, gv, NULL); - DIE(aTHX_ "Goto undefined subroutine &%" SVf, SVfARG(tmpstr)); - } - DIE(aTHX_ "Goto undefined subroutine"); - } - - cxix = 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)"); + + /* Check for defer { goto &...; } */ + for(ix = cxstack_ix; ix > cxix; ix--) { + if(CxTYPE(&cxstack[ix]) == CXt_DEFER) + /* diag_listed_as: Can't "%s" out of a "defer" block */ + Perl_croak(aTHX_ "Can't \"%s\" out of a \"%s\" block", + "goto", S_defer_blockname(&cxstack[ix])); + } + + /* First do some returnish stuff. */ + + SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */ + 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 +2963,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 +2974,88 @@ 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; - SvREFCNT_dec_NN(cx->blk_sub.cv); + /* A destructor called during LEAVE_SCOPE could have undefined + * our precious cv. See bug #99850. */ + if (!CvROOT(cv) && !CvXSUB(cv)) { + const GV * const gv = CvGV(cv); + if (gv) { + SV * const tmpstr = sv_newmortal(); + gv_efullname3(tmpstr, gv, NULL); + DIE(aTHX_ "Goto undefined subroutine &%" SVf, + SVfARG(tmpstr)); + } + DIE(aTHX_ "Goto undefined subroutine"); + } + + if (CxTYPE(cx) == CXt_SUB) { + CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth; + /*on XS calls defer freeing the old CV as it could + * prematurely set PL_op to NULL, which could cause + * e..g XS subs using GIMME_V to SEGV */ + if (CvISXSUB(cv)) + old_cv = cx->blk_sub.cv; + else + SvREFCNT_dec_NN(cx->blk_sub.cv); } - /* Now do some callish stuff. */ - if (CvISXSUB(cv)) { - const SSize_t items = arg ? AvFILL(arg) + 1 : 0; - const bool m = arg ? cBOOL(SvRMAGICAL(arg)) : 0; - SV** mark; + /* Now do some callish stuff. */ + if (CvISXSUB(cv)) { + const SSize_t items = arg ? AvFILL(arg) + 1 : 0; + const bool m = arg ? cBOOL(SvRMAGICAL(arg)) : 0; + SV** mark; + UNOP fake_goto_op; ENTER; SAVETMPS; SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */ + if (old_cv) + SAVEFREESV(old_cv); /* ditto, deferred freeing of old CV */ - /* put GvAV(defgv) back onto stack */ - if (items) { - EXTEND(SP, items+1); /* @_ could have been extended. */ - } - mark = SP; - if (items) { - SSize_t index; - bool r = cBOOL(AvREAL(arg)); - for (index=0; indexblk_sub.retop; + retop = cx->blk_sub.retop; PL_comppad = cx->blk_sub.prevcomppad; PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL; - /* XS subs don't have a CXt_SUB, so pop it; + /* Make a temporary a copy of the current GOTO op on the C + * stack, but with a modified gimme (we can't modify the + * real GOTO op as that's not thread-safe). This allows XS + * users of GIMME_V to get the correct calling context, + * even though there is no longer a CXt_SUB frame to + * provide that information. + */ + Copy(PL_op, &fake_goto_op, 1, UNOP); + fake_goto_op.op_flags = + (fake_goto_op.op_flags & ~OPf_WANT) + | (cx->blk_gimme & G_WANT); + PL_op = (OP*)&fake_goto_op; + + /* XS subs don't have a CXt_SUB, so pop it; * this is a cx_popblock(), less all the stuff we already did * for cx_topblock() earlier */ PL_curcop = cx->blk_oldcop; @@ -2969,78 +3064,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 +3144,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; - if (!CxTRYBLOCK(cx)) { - gotoprobe = (last_eval_cx ? - last_eval_cx->blk_eval.old_eval_root : - PL_eval_root); - last_eval_cx = cx; - break; + OP *gotoprobe = NULL; + bool leaving_eval = FALSE; + bool in_block = FALSE; + bool pseudo_block = FALSE; + PERL_CONTEXT *last_eval_cx = NULL; + + /* find label */ + + PL_lastgotoprobe = NULL; + *enterops = 0; + for (ix = cxstack_ix; ix >= 0; ix--) { + cx = &cxstack[ix]; + switch (CxTYPE(cx)) { + case CXt_EVAL: + leaving_eval = TRUE; + if (!CxEVALBLOCK(cx)) { + gotoprobe = (last_eval_cx ? + last_eval_cx->blk_eval.old_eval_root : + PL_eval_root); + last_eval_cx = cx; + break; } /* else fall through */ case CXt_LOOP_PLAIN: @@ -3077,118 +3172,121 @@ 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"); + case CXt_DEFER: + /* diag_listed_as: Can't "%s" out of a "defer" block */ + DIE(aTHX_ "Can't \"%s\" out of a \"%s\" block", "goto", S_defer_blockname(cx)); + default: + if (ix) + DIE(aTHX_ "panic: goto, type=%u, ix=%ld", + CxTYPE(cx), (long) ix); + gotoprobe = PL_main_root; + break; + } + if (gotoprobe) { OP *sibl1, *sibl2; - retop = dofindlabel(gotoprobe, label, label_len, label_flags, - enterops, enterops + GOTO_DEPTH); - if (retop) - break; - if ( (sibl1 = OpSIBLING(gotoprobe)) && - sibl1->op_type == OP_UNSTACK && - (sibl2 = OpSIBLING(sibl1))) + retop = dofindlabel(gotoprobe, label, label_len, label_flags, + enterops, enterops + GOTO_DEPTH); + if (retop) + break; + if ( (sibl1 = OpSIBLING(gotoprobe)) && + sibl1->op_type == OP_UNSTACK && + (sibl2 = OpSIBLING(sibl1))) { - retop = dofindlabel(sibl2, - label, label_len, label_flags, enterops, - enterops + GOTO_DEPTH); - if (retop) - break; - } - } - if (pseudo_block) - DIE(aTHX_ "Can't \"goto\" out of a pseudo block"); - PL_lastgotoprobe = gotoprobe; - } - if (!retop) - DIE(aTHX_ "Can't find label %" UTF8f, - UTF8fARG(label_flags, label_len, label)); - - /* if we're leaving an eval, check before we pop any frames + retop = dofindlabel(sibl2, + label, label_len, label_flags, enterops, + enterops + GOTO_DEPTH); + if (retop) + break; + } + } + if (pseudo_block) + DIE(aTHX_ "Can't \"goto\" out of a pseudo block"); + PL_lastgotoprobe = gotoprobe; + } + if (!retop) + DIE(aTHX_ "Can't find label %" UTF8f, + UTF8fARG(label_flags, label_len, label)); + + /* if we're leaving an eval, check before we pop any frames that we're not going to punt, otherwise the error - won't be caught */ + won't be caught */ - if (leaving_eval && *enterops && enterops[1]) { - I32 i; + if (leaving_eval && *enterops && enterops[1]) { + I32 i; for (i = 1; enterops[i]; i++) S_check_op_type(aTHX_ enterops[i]); - } - - if (*enterops && enterops[1]) { - I32 i = enterops[1] != UNENTERABLE - && enterops[1]->op_type == OP_ENTER && in_block - ? 2 - : 1; - if (enterops[i]) - deprecate("\"goto\" to jump into a construct"); - } - - /* pop unwanted frames */ - - if (ix < cxstack_ix) { - if (ix < 0) - DIE(aTHX_ "panic: docatch: illegal ix=%ld", (long)ix); - dounwind(ix); + } + + if (*enterops && enterops[1]) { + I32 i = enterops[1] != UNENTERABLE + && enterops[1]->op_type == OP_ENTER && in_block + ? 2 + : 1; + if (enterops[i]) + deprecate("\"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 +3302,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,35 +3334,83 @@ 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_fresh(tmpstr, s, t - s); + av_store(array, line++, tmpstr); + s = t; } } /* =for apidoc docatch -Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context. +Interpose, for the current op and RUNOPS loop, -0 is used as continue inside eval, + - a new JMPENV stack catch frame, and + - an inner RUNOPS loop to run all the remaining ops following the + current PL_op. -3 is used for a die caught by an inner eval - continue inner loop +Then handle any exceptions raised while in that loop. +For a caught eval at this level, re-enter the loop with the specified +restart op (i.e. the op following the OP_LEAVETRY etc); otherwise re-throw +the exception. -See F: je_mustcatch, when set at any runlevel to TRUE, means eval ops must -establish a local jmpenv to handle exception traps. +docatch() is intended to be used like this: + + PP(pp_entertry) + { + if (CATCH_GET) + return docatch(Perl_pp_entertry); + + ... rest of function ... + return PL_op->op_next; + } + +If a new catch frame isn't needed, the op behaves normally. Otherwise it +calls docatch(), which recursively calls pp_entertry(), this time with +CATCH_GET() false, so the rest of the body of the entertry is run. Then +docatch() calls CALLRUNOPS() which executes all the ops following the +entertry. When the loop finally finishes, control returns to docatch(), +which pops the JMPENV and returns to the parent pp_entertry(), which +itself immediately returns. Note that *all* subsequent ops are run within +the inner RUNOPS loop, not just the body of the eval. For example, in + + sub TIEARRAY { eval {1}; my $x } + tie @a, "main"; + +at the point the 'my' is executed, the C stack will look something like: + + #10 main() + #9 perl_run() # JMPENV_PUSH level 1 here + #8 S_run_body() + #7 Perl_runops_standard() # main RUNOPS loop + #6 Perl_pp_tie() + #5 Perl_call_sv() + #4 Perl_runops_standard() # unguarded RUNOPS loop: no new JMPENV + #3 Perl_pp_entertry() + #2 S_docatch() # JMPENV_PUSH level 2 here + #1 Perl_runops_standard() # docatch()'s RUNOPs loop + #0 Perl_pp_padsv() + +Basically, any section of the perl core which starts a RUNOPS loop may +make a promise that it will catch any exceptions and restart the loop if +necessary. If it's not prepared to do that (like call_sv() isn't), then +it sets CATCH_GET() to true, so that any later eval-like code knows to +set up a new handler and loop (via docatch()). + +See L for further details. =cut */ + STATIC OP * S_docatch(pTHX_ Perl_ppaddr_t firstpp) { @@ -3272,29 +3418,40 @@ S_docatch(pTHX_ Perl_ppaddr_t firstpp) OP * const oldop = PL_op; dJMPENV; - assert(CATCH_GET == TRUE); - + assert(CATCH_GET); JMPENV_PUSH(ret); + assert(!CATCH_GET); + switch (ret) { - case 0: - PL_op = firstpp(aTHX); + case 0: /* normal flow-of-control return from JMPENV_PUSH */ + + /* re-run the current op, this time executing the full body of the + * pp function */ + PL_op = firstpp(aTHX); redo_body: - CALLRUNOPS(aTHX); - break; - case 3: - /* die caught by an inner eval - continue inner loop */ - if (PL_restartop && PL_restartjmpenv == PL_top_env) { - PL_restartjmpenv = NULL; - PL_op = PL_restartop; - PL_restartop = 0; - goto redo_body; - } - /* FALLTHROUGH */ + if (PL_op) { + CALLRUNOPS(aTHX); + } + break; + + case 3: /* an exception raised within an eval */ + if (PL_restartjmpenv == PL_top_env) { + /* die caught by an inner eval - continue inner loop */ + + if (!PL_restartop) + break; + PL_restartjmpenv = NULL; + PL_op = PL_restartop; + PL_restartop = 0; + goto redo_body; + } + /* FALLTHROUGH */ + default: - JMPENV_POP; - PL_op = oldop; - JMPENV_JUMP(ret); - NOT_REACHED; /* NOTREACHED */ + JMPENV_POP; + PL_op = oldop; + JMPENV_JUMP(ret); /* re-throw the exception */ + NOT_REACHED; /* NOTREACHED */ } JMPENV_POP; PL_op = oldop; @@ -3328,76 +3485,165 @@ 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 && !CxEVALBLOCK(cx)) + cv = cx->blk_eval.cv; + if (cv) { + switch (cond) { + case FIND_RUNCV_padid_eq: + if (!CvPADLIST(cv) + || CvPADLIST(cv)->xpadl_id != (U32)arg) + continue; + return cv; + case FIND_RUNCV_level_eq: + if (level++ != arg) continue; /* FALLTHROUGH */ - default: - return cv; - } - } - } + default: + return cv; + } + } + } } return cond == FIND_RUNCV_padid_eq ? NULL : PL_main_cv; } -/* Run yyparse() in a setjmp wrapper. Returns: +/* S_try_yyparse(): + * + * Run yyparse() in a setjmp wrapper. Returns: * 0: yyparse() successful * 1: yyparse() failed * 3: yyparse() died + * + * This is used to trap Perl_croak() calls that are executed + * during the compilation process and before the code has been + * completely compiled. It is expected to be called from + * doeval_compile() only. The parameter 'caller_op' is + * only used in DEBUGGING to validate the logic is working + * correctly. + * + * See also try_run_unitcheck(). + * */ STATIC int -S_try_yyparse(pTHX_ int gramtype) +S_try_yyparse(pTHX_ int gramtype, OP *caller_op) { - int ret; + /* if we die during compilation PL_restartop and PL_restartjmpenv + * will be set by Perl_die_unwind(). We need to restore their values + * if that happens as they are intended for the case where the code + * compiles and dies during execution, not where it dies during + * compilation. PL_restartop and caller_op->op_next should be the + * same anyway, and when compilation fails then caller_op->op_next is + * used as the next op after the compile. + */ + JMPENV *restartjmpenv = PL_restartjmpenv; + OP *restartop = PL_restartop; dJMPENV; + int ret; + PERL_UNUSED_ARG(caller_op); /* only used in debugging builds */ assert(CxTYPE(CX_CUR()) == CXt_EVAL); JMPENV_PUSH(ret); switch (ret) { case 0: - ret = yyparse(gramtype) ? 1 : 0; - break; + ret = yyparse(gramtype) ? 1 : 0; + break; case 3: - break; + /* yyparse() died and we trapped the error. We need to restore + * the old PL_restartjmpenv and PL_restartop values. */ + assert(PL_restartop == caller_op->op_next); /* we expect these to match */ + PL_restartjmpenv = restartjmpenv; + PL_restartop = restartop; + break; default: - JMPENV_POP; - JMPENV_JUMP(ret); - NOT_REACHED; /* NOTREACHED */ + JMPENV_POP; + JMPENV_JUMP(ret); + NOT_REACHED; /* NOTREACHED */ } JMPENV_POP; return ret; } +/* S_try_run_unitcheck() + * + * Run PL_unitcheckav in a setjmp wrapper via call_list. + * Returns: + * 0: unitcheck blocks ran without error + * 3: a unitcheck block died + * + * This is used to trap Perl_croak() calls that are executed + * during UNITCHECK blocks executed after the compilation + * process has completed but before the code itself has been + * executed via the normal run loops. It is expected to be called + * from doeval_compile() only. The parameter 'caller_op' is + * only used in DEBUGGING to validate the logic is working + * correctly. + * + * See also try_yyparse(). + */ +STATIC int +S_try_run_unitcheck(pTHX_ OP* caller_op) +{ + /* if we die during compilation PL_restartop and PL_restartjmpenv + * will be set by Perl_die_unwind(). We need to restore their values + * if that happens as they are intended for the case where the code + * compiles and dies during execution, not where it dies during + * compilation. UNITCHECK runs after compilation completes, and + * if it dies we will execute the PL_restartop anyway via the + * failed compilation code path. PL_restartop and caller_op->op_next + * should be the same anyway, and when compilation fails then + * caller_op->op_next is used as the next op after the compile. + */ + JMPENV *restartjmpenv = PL_restartjmpenv; + OP *restartop = PL_restartop; + dJMPENV; + int ret; + PERL_UNUSED_ARG(caller_op); /* only used in debugging builds */ + + assert(CxTYPE(CX_CUR()) == CXt_EVAL); + JMPENV_PUSH(ret); + switch (ret) { + case 0: + call_list(PL_scopestack_ix, PL_unitcheckav); + break; + case 3: + /* call_list died */ + /* call_list() died and we trapped the error. We should restore + * the old PL_restartjmpenv and PL_restartop values, as they are + * used only in the case where the code was actually run. + * The assert validates that we will still execute the PL_restartop. + */ + assert(PL_restartop == caller_op->op_next); /* we expect these to match */ + PL_restartjmpenv = restartjmpenv; + PL_restartop = restartop; + break; + default: + JMPENV_POP; + JMPENV_JUMP(ret); + NOT_REACHED; /* NOTREACHED */ + } + JMPENV_POP; + return ret; +} /* Compile a require/do or an eval ''. * @@ -3425,8 +3671,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 +3698,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 +3725,20 @@ 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 = 0; - hv_clear(GvHV(PL_hintgv)); + PL_hints = HINTS_DEFAULT; + PL_prevailing_version = 0; + hv_clear(GvHV(PL_hintgv)); CLEARFEATUREBITS(); } else { - PL_hints = saveop->op_private & OPpEVAL_COPHH - ? oldcurcop->cop_hints : (U32)saveop->op_targ; + PL_hints = saveop->op_private & OPpEVAL_COPHH + ? oldcurcop->cop_hints : (U32)saveop->op_targ; /* making 'use re eval' not be in scope when compiling the * qr/mabye_has_runtime_code_block/ ensures that we don't get @@ -3501,80 +3748,85 @@ 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); - /* note that yyparse() may raise an exception, e.g. C, - * so honour CATCH_GET and trap it here if necessary */ + /* we should never be CATCH_GET true here, as our immediate callers should + * always handle that case. */ + assert(!CATCH_GET); + /* compile the code */ - /* compile the code */ - yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG); + yystatus = (!in_require) + ? S_try_yyparse(aTHX_ GRAMPROG, saveop) + : yyparse(GRAMPROG); if (yystatus || PL_parser->error_count || !PL_eval_root) { - PERL_CONTEXT *cx; + PERL_CONTEXT *cx; SV *errsv; - PL_op = saveop; - /* note that if yystatus == 3, then the require/eval died during - * compilation, so the EVAL CX block has already been popped, and - * various vars restored */ - if (yystatus != 3) { - if (PL_eval_root) { - op_free(PL_eval_root); - PL_eval_root = NULL; - } - SP = PL_stack_base + POPMARK; /* pop original mark */ + PL_op = saveop; + if (yystatus != 3) { + /* note that if yystatus == 3, then the require/eval died during + * compilation, so the EVAL CX block has already been popped, and + * various vars restored. This block applies similar steps after + * the other "failed to compile" cases in yyparse, eg, where + * yystatus=1, "failed, but did not die". */ + if (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_LIST) PUSHs(&PL_sv_undef); + PUTBACK; + return FALSE; } /* Compilation successful. Now clean up */ @@ -3589,20 +3841,42 @@ 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; + if (PL_unitcheckav && av_count(PL_unitcheckav)>0) { + OP *es = PL_eval_start; + /* TODO: are we sure we shouldn't do S_try_run_unitcheck() + * when `in_require` is true? */ + if (in_require) { + call_list(PL_scopestack_ix, PL_unitcheckav); + } + else if (S_try_run_unitcheck(aTHX_ saveop)) { + /* there was an error! */ + + /* Restore PL_OP */ + PL_op = saveop; + + SV *errsv = ERRSV; + if (!*(SvPV_nolen_const(errsv))) { + /* This happens when using: + * eval qq# UNITCHECK { die "\x00"; } #; + */ + sv_setpvs(errsv, "Unit check error"); + } + + if (gimme != G_LIST) PUSHs(&PL_sv_undef); + PUTBACK; + return FALSE; + } + PL_eval_start = es; } CvDEPTH(evalcv) = 1; @@ -3649,19 +3923,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 +3944,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 +3982,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 +4007,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 +4135,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,37 +4166,37 @@ 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) { - SVOP * const kid = (SVOP*)cUNOP->op_first; + SVOP * const kid = cSVOPx(cUNOP->op_first); if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) { /* Make sure that a bareword module name (e.g. ::Foo::Bar) @@ -3974,9 +4248,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 +4260,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_LIST); + else + count = call_sv(loader, G_LIST); + 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 '//' */ - 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 '//' */ + 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 +4469,9 @@ S_require_file(pTHX_ SV *sv) */ break; } - } - } - } + } + } + } } /* at this point we've ether opened a file (tryrsfp) or set errno */ @@ -4206,24 +4480,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 +4507,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 +4519,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 +4537,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 +4580,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 +4603,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_type(SVt_NULL) : NULL; + SV *datasv; + if (fc) sv_copypv(fc, filter_cache); + datasv = filter_add(S_run_user_filter, fc); + IoLINES(datasv) = filter_has_file; + IoTOP_GV(datasv) = MUTABLE_GV(filter_state); + IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub); } /* switch to eval mode */ @@ -4353,9 +4627,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); @@ -4367,16 +4641,24 @@ S_require_file(pTHX_ SV *sv) PP(pp_require) { - RUN_PP_CATCHABLY(Perl_pp_require); + /* If a suitable JMPENV catch frame isn't present, call docatch(), + * which will: + * - add such a frame, and + * - start a new RUNOPS loop, which will (as the first op to run), + * recursively call this pp function again. + * The main body of this function is then executed by the inner call. + */ + if (CATCH_GET) + return docatch(Perl_pp_require); { - dSP; - SV *sv = POPs; - SvGETMAGIC(sv); - PUTBACK; - return ((SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) - ? S_require_version(aTHX_ sv) - : S_require_file(aTHX_ sv); + 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); } } @@ -4410,7 +4692,17 @@ PP(pp_entereval) bool bytes; I32 old_savestack_ix; - RUN_PP_CATCHABLY(Perl_pp_entereval); + /* If a suitable JMPENV catch frame isn't present, call docatch(), + * which will: + * - add such a frame, and + * - start a new RUNOPS loop, which will (as the first op to run), + * recursively call this pp function again. + * The main body of this function is then executed by the inner call. + */ + if (CATCH_GET) + return docatch(Perl_pp_entereval); + + assert(!CATCH_GET); gimme = GIMME_V; was = PL_breakable_sub_gen; @@ -4421,36 +4713,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 +4751,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:%" LINE_Tf "]", + (unsigned long)++PL_evalseq, + CopFILE(PL_curcop), CopLINE(PL_curcop)); + tmpbuf = SvPVX(temp_sv); + len = SvCUR(temp_sv); } else - len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq); + len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq); SAVECOPFILE_FREE(&PL_compiling); CopFILE_set(&PL_compiling, tmpbuf+2); SAVECOPLINE(&PL_compiling); @@ -4494,41 +4786,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 Cs 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 Cs 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; } } @@ -4542,6 +4834,7 @@ PP(pp_leaveeval) PERL_CONTEXT *cx; OP *retop; int failed; + bool override_return = FALSE; /* is feature 'module_true' in effect? */ CV *evalcv; bool keep; @@ -4553,8 +4846,57 @@ PP(pp_leaveeval) oldsp = PL_stack_base + cx->blk_oldsp; gimme = cx->blk_gimme; - /* did require return a false value? */ - failed = CxOLD_OP_TYPE(cx) == OP_REQUIRE + bool is_require= CxOLD_OP_TYPE(cx) == OP_REQUIRE; + if (is_require) { + /* We are in an require. Check if use feature 'module_true' is enabled, + * and if so later on correct any returns from the require. */ + + /* we might be called for an OP_LEAVEEVAL or OP_RETURN opcode + * and the parse tree will look different for either case. + * so find the right op to check later */ + if (OP_TYPE_IS_OR_WAS(PL_op, OP_RETURN)) { + if (PL_op->op_flags & OPf_SPECIAL) + override_return = true; + } + else if ((PL_op->op_flags & OPf_KIDS) && OP_TYPE_IS_OR_WAS(PL_op, OP_LEAVEEVAL)){ + COP *old_pl_curcop = PL_curcop; + OP *check = cUNOPx(PL_op)->op_first; + + /* ok, we found something to check, we need to scan through + * it and find the last OP_NEXTSTATE it contains and then read the + * feature state out of the COP data it contains. + */ + if (check) { + if (!OP_TYPE_IS(check,OP_STUB)) { + const OP *kid = cLISTOPx(check)->op_first; + const OP *last_state = NULL; + + for (; kid; kid = OpSIBLING(kid)) { + if ( + OP_TYPE_IS_OR_WAS(kid, OP_NEXTSTATE) + || OP_TYPE_IS_OR_WAS(kid, OP_DBSTATE) + ){ + last_state = kid; + } + } + if (last_state) { + PL_curcop = cCOPx(last_state); + if (FEATURE_MODULE_TRUE_IS_ENABLED) { + override_return = TRUE; + } + } else { + NOT_REACHED; /* NOTREACHED */ + } + } + } else { + NOT_REACHED; /* NOTREACHED */ + } + PL_curcop = old_pl_curcop; + } + } + + /* we might override this later if 'module_true' is enabled */ + failed = is_require && !(gimme == G_SCALAR ? SvTRUE_NN(*PL_stack_sp) : PL_stack_sp > oldsp); @@ -4584,6 +4926,19 @@ PP(pp_leaveeval) #endif CvDEPTH(evalcv) = 0; + if (override_return) { + /* make sure that we use a standard return when feature 'module_load' + * is enabled. Returns from require are problematic (consider what happens + * when it is called twice) */ + if (gimme == G_SCALAR) { + /* this following is an optimization of POPs()/PUSHs(). + * and does the same thing with less bookkeeping */ + *PL_stack_sp = &PL_sv_yes; + } + assert(gimme == G_VOID || gimme == G_SCALAR); + failed = 0; + } + /* pop the CXt_EVAL, and if a require failed, croak */ S_pop_eval_context_maybe_croak(aTHX_ cx, NULL, failed); @@ -4593,13 +4948,74 @@ PP(pp_leaveeval) return retop; } +/* Ops that implement try/catch syntax + * Note the asymmetry here: + * pp_entertrycatch does two pushblocks + * pp_leavetrycatch pops only the outer one; the inner one is popped by + * pp_poptry or by stack-unwind of die within the try block + */ + +PP(pp_entertrycatch) +{ + PERL_CONTEXT *cx; + const U8 gimme = GIMME_V; + + /* If a suitable JMPENV catch frame isn't present, call docatch(), + * which will: + * - add such a frame, and + * - start a new RUNOPS loop, which will (as the first op to run), + * recursively call this pp function again. + * The main body of this function is then executed by the inner call. + */ + if (CATCH_GET) + return docatch(Perl_pp_entertrycatch); + + assert(!CATCH_GET); + + Perl_pp_enter(aTHX); /* performs cx_pushblock(CXt_BLOCK, ...) */ + + save_scalar(PL_errgv); + CLEAR_ERRSV(); + + cx = cx_pushblock((CXt_EVAL|CXp_EVALBLOCK|CXp_TRY), gimme, + PL_stack_sp, PL_savestack_ix); + cx_pushtry(cx, cLOGOP->op_other); + + PL_in_eval = EVAL_INEVAL; + + return NORMAL; +} + +PP(pp_leavetrycatch) +{ + /* leavetrycatch is leave */ + return Perl_pp_leave(aTHX); +} + +PP(pp_poptry) +{ + /* poptry is leavetry */ + return Perl_pp_leavetry(aTHX); +} + +PP(pp_catch) +{ + dTARGET; + + save_clearsv(&(PAD_SVl(PL_op->op_targ))); + sv_setsv(TARG, ERRSV); + CLEAR_ERRSV(); + + return cLOGOP->op_other; +} + /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it close to the related Perl_create_eval_scope. */ void Perl_delete_eval_scope(pTHX) { PERL_CONTEXT *cx; - + cx = CX_CUR(); CX_LEAVE_SCOPE(cx); cx_popeval(cx); @@ -4614,27 +5030,39 @@ 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, + + cx = cx_pushblock((CXt_EVAL|CXp_EVALBLOCK), 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. */ } } PP(pp_entertry) { - RUN_PP_CATCHABLY(Perl_pp_entertry); + OP *retop = cLOGOP->op_other->op_next; + + /* If a suitable JMPENV catch frame isn't present, call docatch(), + * which will: + * - add such a frame, and + * - start a new RUNOPS loop, which will (as the first op to run), + * recursively call this pp function again. + * The main body of this function is then executed by the inner call. + */ + if (CATCH_GET) + return docatch(Perl_pp_entertry); assert(!CATCH_GET); - create_eval_scope(cLOGOP->op_other->op_next, 0); + + create_eval_scope(retop, 0); + return PL_op->op_next; } @@ -4665,7 +5093,7 @@ PP(pp_leavetry) CX_LEAVE_SCOPE(cx); cx_popeval(cx); cx_popblock(cx); - retop = cx->blk_eval.retop; + retop = CxTRY(cx) ? PL_op->op_next : cx->blk_eval.retop; CX_POP(cx); CLEAR_ERRSV(); @@ -4718,7 +5146,7 @@ PP(pp_leavegiven) STATIC PMOP * S_make_matcher(pTHX_ REGEXP *re) { - PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED); + PMOP *matcher = cPMOPx(newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED)); PERL_ARGS_ASSERT_MAKE_MATCHER; @@ -4781,30 +5209,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 +5240,431 @@ 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 = (HV*)newSV_type_mortal(SVt_PVHV); + } + if (NULL == seen_other) { + seen_other = (HV*)newSV_type_mortal(SVt_PVHV); + } + for(i = 0; i < other_len; ++i) { + SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE); + SV * const * const other_elem = av_fetch(other_av, i, FALSE); + + if (!this_elem || !other_elem) { + if ((this_elem && SvOK(*this_elem)) + || (other_elem && SvOK(*other_elem))) + 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 +5687,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 +5711,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 +5731,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 +5750,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 +5774,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); @@ -5364,6 +5790,64 @@ PP(pp_break) return cx->blk_givwhen.leave_op; } +static void +_invoke_defer_block(pTHX_ U8 type, void *_arg) +{ + OP *start = (OP *)_arg; +#ifdef DEBUGGING + I32 was_cxstack_ix = cxstack_ix; +#endif + + cx_pushblock(type, G_VOID, PL_stack_sp, PL_savestack_ix); + ENTER; + SAVETMPS; + + SAVEOP(); + PL_op = start; + + CALLRUNOPS(aTHX); + + FREETMPS; + LEAVE; + + { + PERL_CONTEXT *cx; + + cx = CX_CUR(); + assert(CxTYPE(cx) == CXt_DEFER); + + PL_stack_sp = PL_stack_base + cx->blk_oldsp; + + CX_LEAVE_SCOPE(cx); + cx_popblock(cx); + CX_POP(cx); + } + + assert(cxstack_ix == was_cxstack_ix); +} + +static void +invoke_defer_block(pTHX_ void *_arg) +{ + _invoke_defer_block(aTHX_ CXt_DEFER, _arg); +} + +static void +invoke_finally_block(pTHX_ void *_arg) +{ + _invoke_defer_block(aTHX_ CXt_DEFER|CXp_FINALLY, _arg); +} + +PP(pp_pushdefer) +{ + if(PL_op->op_private & OPpDEFER_FINALLY) + SAVEDESTRUCTOR_X(invoke_finally_block, cLOGOP->op_other); + else + SAVEDESTRUCTOR_X(invoke_defer_block, cLOGOP->op_other); + + return NORMAL; +} + static MAGIC * S_doparseform(pTHX_ SV *sv) { @@ -5388,35 +5872,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) - && strnEQ(SvPVX(old), s, len) - ) { - DEBUG_f(PerlIO_printf(Perl_debug_log,"Re-using compiled format\n")); - return mg; - } - - DEBUG_f(PerlIO_printf(Perl_debug_log, "Re-compiling format\n")); - Safefree(mg->mg_ptr); - mg->mg_ptr = NULL; - SvREFCNT_dec(old); - mg->mg_obj = NULL; + /* still the same as previously-compiled string? */ + SV *old = mg->mg_obj; + if ( ! (cBOOL(SvUTF8(old)) ^ cBOOL(SvUTF8(sv))) + && len == SvCUR(old) + && strnEQ(SvPVX(old), s, len) + ) { + DEBUG_f(PerlIO_printf(Perl_debug_log,"Re-using compiled format\n")); + return mg; + } + + DEBUG_f(PerlIO_printf(Perl_debug_log, "Re-compiling format\n")); + Safefree(mg->mg_ptr); + mg->mg_ptr = NULL; + SvREFCNT_dec(old); + mg->mg_obj = NULL; } else { - DEBUG_f(PerlIO_printf(Perl_debug_log, "Compiling format\n")); - mg = sv_magicext(sv, NULL, PERL_MAGIC_fm, &PL_vtbl_fm, NULL, 0); + DEBUG_f(PerlIO_printf(Perl_debug_log, "Compiling format\n")); + mg = sv_magicext(sv, NULL, PERL_MAGIC_fm, &PL_vtbl_fm, NULL, 0); } sv_copy = newSVpvn_utf8(s, len, SvUTF8(sv)); @@ -5426,8 +5910,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 +5920,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 +6042,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 +6120,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 +6155,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 +6198,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; + ? newSV_type_mortal(SVt_PV) : buf_sv; SvUPGRADE(upstream, SVt_PV); - + if (filter_has_file) { - status = FILTER_READ(idx+1, upstream, 0); + status = FILTER_READ(idx+1, upstream, 0); } if (filter_sub && status >= 0) { - dSP; - int count; - - ENTER_with_name("call_filter_sub"); - SAVE_DEFSV; - SAVETMPS; - EXTEND(SP, 2); - - DEFSV_set(upstream); - PUSHMARK(SP); - PUSHs(&PL_sv_zero); - if (filter_state) { - PUSHs(filter_state); - } - PUTBACK; - count = call_sv(filter_sub, G_SCALAR|G_EVAL); - SPAGAIN; - - if (count > 0) { - SV *out = POPs; - SvGETMAGIC(out); - if (SvOK(out)) { - status = SvIV(out); - } + dSP; + int count; + + ENTER_with_name("call_filter_sub"); + SAVE_DEFSV; + SAVETMPS; + EXTEND(SP, 2); + + DEFSV_set(upstream); + PUSHMARK(SP); + PUSHs(&PL_sv_zero); + if (filter_state) { + PUSHs(filter_state); + } + PUTBACK; + count = call_sv(filter_sub, G_SCALAR|G_EVAL); + SPAGAIN; + + if (count > 0) { + SV *out = POPs; + SvGETMAGIC(out); + if (SvOK(out)) { + status = SvIV(out); + } else { SV * const errsv = ERRSV; if (SvTRUE_NN(errsv)) err = newSVsv(errsv); } - } + } - PUTBACK; - FREETMPS; - LEAVE_with_name("call_filter_sub"); + PUTBACK; + FREETMPS; + LEAVE_with_name("call_filter_sub"); } if (SvGMAGICAL(upstream)) { - mg_get(upstream); - if (upstream == buf_sv) mg_free(buf_sv); + mg_get(upstream); + if (upstream == buf_sv) mg_free(buf_sv); } if (SvIsCOW(upstream)) sv_force_normal(upstream); if(!err && SvOK(upstream)) { - got_p = SvPV_nomg(upstream, got_len); - if (umaxlen) { - if (got_len > umaxlen) { - prune_from = got_p + umaxlen; - } - } else { - char *const first_nl = (char *)memchr(got_p, '\n', got_len); - if (first_nl && first_nl + 1 < got_p + got_len) { - /* There's a second line here... */ - prune_from = first_nl + 1; - } - } + got_p = SvPV_nomg(upstream, got_len); + if (umaxlen) { + if (got_len > umaxlen) { + prune_from = got_p + umaxlen; + } + } else { + char *const first_nl = (char *)memchr(got_p, '\n', got_len); + if (first_nl && first_nl + 1 < got_p + got_len) { + /* There's a second line here... */ + prune_from = first_nl + 1; + } + } } if (!err && prune_from) { - /* Oh. Too long. Stuff some in our cache. */ - STRLEN cached_len = got_p + got_len - prune_from; - SV *const cache = datasv; - - if (SvOK(cache)) { - /* Cache should be empty. */ - assert(!SvCUR(cache)); - } - - sv_setpvn(cache, prune_from, cached_len); - /* If you ask for block mode, you may well split UTF-8 characters. - "If it breaks, you get to keep both parts" - (Your code is broken if you don't put them back together again - before something notices.) */ - if (SvUTF8(upstream)) { - SvUTF8_on(cache); - } - if (SvPOK(upstream)) SvCUR_set(upstream, got_len - cached_len); - else - /* Cannot just use sv_setpvn, as that could free the buffer - before we have a chance to assign it. */ - sv_usepvn(upstream, savepvn(got_p, got_len - cached_len), - got_len - cached_len); - *prune_from = 0; - /* Can't yet be EOF */ - if (status == 0) - status = 1; + /* Oh. Too long. Stuff some in our cache. */ + STRLEN cached_len = got_p + got_len - prune_from; + SV *const cache = datasv; + + if (SvOK(cache)) { + /* Cache should be empty. */ + assert(!SvCUR(cache)); + } + + sv_setpvn(cache, prune_from, cached_len); + /* If you ask for block mode, you may well split UTF-8 characters. + "If it breaks, you get to keep both parts" + (Your code is broken if you don't put them back together again + before something notices.) */ + if (SvUTF8(upstream)) { + SvUTF8_on(cache); + } + if (SvPOK(upstream)) SvCUR_set(upstream, got_len - cached_len); + else + /* Cannot just use sv_setpvn, as that could free the buffer + before we have a chance to assign it. */ + sv_usepvn(upstream, savepvn(got_p, got_len - cached_len), + got_len - cached_len); + *prune_from = 0; + /* Can't yet be EOF */ + if (status == 0) + status = 1; } /* If they are at EOF but buf_sv has something in it, then they may never @@ -5813,31 +6297,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; }