X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/8aa7beb669fc0c538f84c04650555a03349429da..a7fa83459a57b807d31dd217c012d13355deb026:/pp_ctl.c diff --git a/pp_ctl.c b/pp_ctl.c index fbb0e34..854c89d 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -298,6 +298,13 @@ PP(pp_substcont) s -= RX_GOFS(rx); /* Are we done */ + /* I believe that we can't set REXEC_SCREAM here if + SvSCREAM(cx->sb_targ) is true because SvPVX(cx->sb_targ) isn't always + equal to s. [See the comment before Perl_re_intuit_start(), which is + called from Perl_regexec_flags(), which says that it should be when + SvSCREAM() is true.] s, cx->sb_strend and orig will be consistent + with SvPVX(cx->sb_targ), as substconst doesn't modify cx->sb_targ + during the match. */ if (CxONCE(cx) || s < orig || !CALLREGEXEC(rx, s, cx->sb_strend, orig, (s == m) + RX_GOFS(rx), cx->sb_targ, NULL, @@ -305,7 +312,7 @@ PP(pp_substcont) ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST) : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST)))) { - SV * const targ = cx->sb_targ; + SV *targ = cx->sb_targ; assert(cx->sb_strend >= s); if(cx->sb_strend > s) { @@ -317,27 +324,32 @@ PP(pp_substcont) if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */ cx->sb_rxtainted |= SUBST_TAINT_PAT; + if (pm->op_pmflags & PMf_NONDESTRUCT) { + PUSHs(dstr); + /* From here on down we're using the copy, and leaving the + original untouched. */ + targ = dstr; + } + else { #ifdef PERL_OLD_COPY_ON_WRITE - if (SvIsCOW(targ)) { - sv_force_normal_flags(targ, SV_COW_DROP_PV); - } else + if (SvIsCOW(targ)) { + sv_force_normal_flags(targ, SV_COW_DROP_PV); + } else #endif - { - SvPV_free(targ); - } - SvPV_set(targ, SvPVX(dstr)); - SvCUR_set(targ, SvCUR(dstr)); - SvLEN_set(targ, SvLEN(dstr)); - if (DO_UTF8(dstr)) - SvUTF8_on(targ); - SvPV_set(dstr, NULL); - - if (pm->op_pmflags & PMf_NONDESTRUCT) - PUSHs(targ); - else + { + SvPV_free(targ); + } + SvPV_set(targ, SvPVX(dstr)); + SvCUR_set(targ, SvCUR(dstr)); + SvLEN_set(targ, SvLEN(dstr)); + if (DO_UTF8(dstr)) + SvUTF8_on(targ); + SvPV_set(dstr, NULL); + mPUSHi(saviters - 1); - (void)SvPOK_only_UTF8(targ); + (void)SvPOK_only_UTF8(targ); + } /* update the taint state of various various variables in * preparation for final exit. @@ -384,7 +396,8 @@ PP(pp_substcont) } cx->sb_s = RX_OFFS(rx)[0].end + orig; { /* Update the pos() information. */ - SV * const sv = cx->sb_targ; + SV * const sv + = (pm->op_pmflags & PMf_NONDESTRUCT) ? cx->sb_dstr : cx->sb_targ; MAGIC *mg; SvUPGRADE(sv, SVt_PVMG); if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) { @@ -414,7 +427,8 @@ PP(pp_substcont) if (cx->sb_iters > 1 && (cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))) - SvTAINTED_on(cx->sb_targ); + SvTAINTED_on((pm->op_pmflags & PMf_NONDESTRUCT) + ? cx->sb_dstr : cx->sb_targ); TAINT_NOT; } rxres_save(&cx->sb_rxres, rx); @@ -519,6 +533,9 @@ S_rxres_free(pTHX_ void **rsp) } } +#define FORM_NUM_BLANK (1<<30) +#define FORM_NUM_POINT (1<<29) + PP(pp_formline) { dVAR; dSP; dMARK; dORIGMARK; @@ -535,11 +552,11 @@ PP(pp_formline) I32 lines = 0; /* number of lines that have been output */ bool chopspace = (strchr(PL_chopset, ' ') != NULL); /* does $: have space */ const char *chophere = NULL; /* where to chop current item */ - char *linemark = NULL; /* pos of start of line in output */ + STRLEN linemark = 0; /* pos of start of line in output */ NV value; bool gotsome = FALSE; /* seen at least one non-blank item on this line */ STRLEN len; - STRLEN fudge; /* estimate of output size in bytes */ + STRLEN linemax; /* estimate of output size in bytes */ bool item_is_utf8 = FALSE; bool targ_is_utf8 = FALSE; const char *fmt; @@ -561,8 +578,9 @@ PP(pp_formline) SvTAINTED_on(PL_formtarget); if (DO_UTF8(PL_formtarget)) targ_is_utf8 = TRUE; - fudge = (SvCUR(formsv) * (IN_BYTES ? 1 : 3) + 1); - t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */ + linemax = (SvCUR(formsv) * (IN_BYTES ? 1 : 3) + 1); + t = SvGROW(PL_formtarget, len + linemax + 1); + /* XXX from now onwards, SvCUR(PL_formtarget) is invalid */ t += len; f = SvPV_const(formsv, len); @@ -598,7 +616,7 @@ PP(pp_formline) } ); switch (*fpc++) { case FF_LINEMARK: - linemark = t; + linemark = t - SvPVX(PL_formtarget); lines++; gotsome = FALSE; break; @@ -842,6 +860,7 @@ PP(pp_formline) * if trans, translate certain characters during the copy */ { U8 *tmp = NULL; + STRLEN grow = 0; SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget)); @@ -850,17 +869,34 @@ PP(pp_formline) source = tmp = bytes_to_utf8(source, &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 += UTF8SKIP(s); + linemark = s - (U8*)SvPVX(PL_formtarget); } /* Easy. They agree. */ assert (item_is_utf8 == targ_is_utf8); } - SvGROW(PL_formtarget, - SvCUR(PL_formtarget) + to_copy + 1); + 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); @@ -895,11 +931,11 @@ PP(pp_formline) arg = *fpc++; #if defined(USE_LONG_DOUBLE) fmt = (const char *) - ((arg & 256) ? + ((arg & FORM_NUM_POINT) ? "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl); #else fmt = (const char *) - ((arg & 256) ? + ((arg & FORM_NUM_POINT) ? "%#0*.*f" : "%0*.*f"); #endif goto ff_dec; @@ -907,15 +943,15 @@ PP(pp_formline) arg = *fpc++; #if defined(USE_LONG_DOUBLE) fmt = (const char *) - ((arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl); + ((arg & FORM_NUM_POINT) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl); #else fmt = (const char *) - ((arg & 256) ? "%#*.*f" : "%*.*f"); + ((arg & FORM_NUM_POINT) ? "%#*.*f" : "%*.*f"); #endif ff_dec: /* If the field is marked with ^ and the value is undefined, blank it out. */ - if ((arg & 512) && !SvOK(sv)) { + if ((arg & FORM_NUM_BLANK) && !SvOK(sv)) { arg = fieldsize; while (arg--) *t++ = ' '; @@ -933,7 +969,8 @@ PP(pp_formline) /* Formats aren't yet marked for locales, so assume "yes". */ { STORE_NUMERIC_STANDARD_SET_LOCAL(); - my_snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg & 255, value); + arg &= ~(FORM_NUM_POINT|FORM_NUM_BLANK); + my_snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg, value); RESTORE_NUMERIC_STANDARD(); } t += fieldsize; @@ -941,7 +978,7 @@ PP(pp_formline) case FF_NEWLINE: f++; - while (t-- > linemark && *t == ' ') ; + while (t-- > (SvPVX(PL_formtarget) + linemark) && *t == ' ') ; t++; *t++ = '\n'; break; @@ -955,7 +992,7 @@ PP(pp_formline) } } else { - t = linemark; + t = SvPVX(PL_formtarget) + linemark; lines--; } break; @@ -1432,6 +1469,20 @@ Perl_is_lvalue_sub(pTHX) return 0; } +/* only used by PUSHSUB */ +I32 +Perl_was_lvalue_sub(pTHX) +{ + dVAR; + const I32 cxix = dopoptosub(cxstack_ix-1); + assert(cxix >= 0); /* We should only be called from inside subs */ + + if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv)) + return CxLVAL(cxstack + cxix); + else + return 0; +} + STATIC I32 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock) { @@ -1554,6 +1605,9 @@ Perl_dounwind(pTHX_ I32 cxix) dVAR; I32 optype; + if (!PL_curstackinfo) /* can happen if die during thread cloning */ + return; + while (cxstack_ix > cxix) { SV *sv; register PERL_CONTEXT *cx = &cxstack[cxstack_ix]; @@ -2010,6 +2064,79 @@ PP(pp_dbstate) return NORMAL; } +STATIC SV ** +S_adjust_stack_on_leave(pTHX_ SV **newsp, SV **sp, SV **mark, I32 gimme, U32 flags) +{ + PERL_ARGS_ASSERT_ADJUST_STACK_ON_LEAVE; + + if (gimme == G_SCALAR) { + if (MARK < SP) + *++newsp = (SvFLAGS(*SP) & flags) ? *SP : sv_mortalcopy(*SP); + else { + /* MEXTEND() only updates MARK, so reuse it instead of newsp. */ + MARK = newsp; + MEXTEND(MARK, 1); + *++MARK = &PL_sv_undef; + return MARK; + } + } + else if (gimme == G_ARRAY) { + /* in case LEAVE wipes old return values */ + while (++MARK <= SP) { + if (SvFLAGS(*MARK) & flags) + *++newsp = *MARK; + else { + *++newsp = sv_mortalcopy(*MARK); + TAINT_NOT; /* Each item is independent */ + } + } + /* When this function was called with MARK == newsp, we reach this + * point with SP == newsp. */ + } + + return newsp; +} + +PP(pp_enter) +{ + dVAR; dSP; + register PERL_CONTEXT *cx; + I32 gimme = GIMME_V; + + ENTER_with_name("block"); + + SAVETMPS; + PUSHBLOCK(cx, CXt_BLOCK, SP); + + RETURN; +} + +PP(pp_leave) +{ + dVAR; dSP; + register PERL_CONTEXT *cx; + SV **newsp; + PMOP *newpm; + I32 gimme; + + if (PL_op->op_flags & OPf_SPECIAL) { + cx = &cxstack[cxstack_ix]; + cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */ + } + + POPBLOCK(cx,newpm); + + gimme = OP_GIMME(PL_op, (cxstack_ix >= 0) ? gimme : G_SCALAR); + + TAINT_NOT; + SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP); + PL_curpm = newpm; /* Don't pop $1 et al till now */ + + LEAVE_with_name("block"); + + RETURN; +} + PP(pp_enteriter) { dVAR; dSP; dMARK; @@ -2163,21 +2290,7 @@ PP(pp_leaveloop) newsp = PL_stack_base + cx->blk_loop.resetsp; TAINT_NOT; - if (gimme == G_VOID) - NOOP; - else if (gimme == G_SCALAR) { - if (mark < SP) - *++newsp = sv_mortalcopy(*SP); - else - *++newsp = &PL_sv_undef; - } - else { - while (mark < SP) { - *++newsp = sv_mortalcopy(*++mark); - TAINT_NOT; /* Each item is independent */ - } - } - SP = newsp; + SP = adjust_stack_on_leave(newsp, SP, MARK, gimme, 0); PUTBACK; POPLOOP(cx); /* Stack values are safe: release loop vars ... */ @@ -2189,6 +2302,113 @@ PP(pp_leaveloop) return NORMAL; } +STATIC void +S_return_lvalues(pTHX_ SV **mark, SV **sp, SV **newsp, I32 gimme, + PERL_CONTEXT *cx, PMOP *newpm) +{ + const bool ref = !!(CxLVAL(cx) & OPpENTERSUB_INARGS); + if (gimme == G_SCALAR) { + if (CxLVAL(cx) && !ref) { /* Leave it as it is if we can. */ + SV *sv; + const char *what = NULL; + if (MARK < SP) { + assert(MARK+1 == SP); + if ((SvPADTMP(TOPs) || + (SvFLAGS(TOPs) & (SVf_READONLY | SVf_FAKE)) + == SVf_READONLY + ) && + !SvSMAGICAL(TOPs)) { + what = + SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef" + : "a readonly value" : "a temporary"; + } + else goto copy_sv; + } + else { + /* sub:lvalue{} will take us here. */ + what = "undef"; + } + LEAVE; + cxstack_ix--; + POPSUB(cx,sv); + PL_curpm = newpm; + LEAVESUB(sv); + Perl_croak(aTHX_ + "Can't return %s from lvalue subroutine", what + ); + } + if (MARK < SP) { + copy_sv: + if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) { + *++newsp = SvREFCNT_inc(*SP); + FREETMPS; + sv_2mortal(*newsp); + } + else + *++newsp = + !SvTEMP(*SP) + ? sv_2mortal(SvREFCNT_inc_simple_NN(*SP)) + : *SP; + } + else { + EXTEND(newsp,1); + *++newsp = &PL_sv_undef; + } + if (CxLVAL(cx) & OPpENTERSUB_DEREF) { + SvGETMAGIC(TOPs); + if (!SvOK(TOPs)) { + U8 deref_type; + if (cx->blk_sub.retop->op_type == OP_RV2SV) + deref_type = OPpDEREF_SV; + else if (cx->blk_sub.retop->op_type == OP_RV2AV) + deref_type = OPpDEREF_AV; + else { + assert(cx->blk_sub.retop->op_type == OP_RV2HV); + deref_type = OPpDEREF_HV; + } + vivify_ref(TOPs, deref_type); + } + } + } + else if (gimme == G_ARRAY) { + assert (!(CxLVAL(cx) & OPpENTERSUB_DEREF)); + if (ref || !CxLVAL(cx)) + while (++MARK <= SP) + *++newsp = + SvTEMP(*MARK) + ? *MARK + : ref && SvFLAGS(*MARK) & SVs_PADTMP + ? sv_mortalcopy(*MARK) + : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK)); + else while (++MARK <= SP) { + if (*MARK != &PL_sv_undef + && (SvPADTMP(*MARK) + || (SvFLAGS(*MARK) & (SVf_READONLY|SVf_FAKE)) + == SVf_READONLY + ) + ) { + SV *sv; + /* Might be flattened array after $#array = */ + PUTBACK; + LEAVE; + cxstack_ix--; + POPSUB(cx,sv); + PL_curpm = newpm; + LEAVESUB(sv); + Perl_croak(aTHX_ + "Can't return a %s from lvalue subroutine", + SvREADONLY(TOPs) ? "readonly value" : "temporary"); + } + else + *++newsp = + SvTEMP(*MARK) + ? *MARK + : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK)); + } + } + PL_stack_sp = newsp; +} + PP(pp_return) { dVAR; dSP; dMARK; @@ -2196,6 +2416,7 @@ PP(pp_return) bool popsub2 = FALSE; bool clear_errsv = FALSE; bool lval = FALSE; + bool gmagic = FALSE; I32 gimme; SV **newsp; PMOP *newpm; @@ -2238,6 +2459,7 @@ PP(pp_return) popsub2 = TRUE; lval = !!CvLVALUE(cx->blk_sub.cv); retop = cx->blk_sub.retop; + gmagic = CxLVAL(cx) & OPpENTERSUB_DEREF; cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */ break; case CXt_EVAL: @@ -2267,11 +2489,13 @@ PP(pp_return) } TAINT_NOT; - if (gimme == G_SCALAR) { + if (lval) S_return_lvalues(aTHX_ MARK, SP, newsp, gimme, cx, newpm); + else { + if (gimme == G_SCALAR) { if (MARK < SP) { if (popsub2) { if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) { - if (SvTEMP(TOPs)) { + if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1) { *++newsp = SvREFCNT_inc(*SP); FREETMPS; sv_2mortal(*newsp); @@ -2281,26 +2505,31 @@ PP(pp_return) FREETMPS; *++newsp = sv_mortalcopy(sv); SvREFCNT_dec(sv); + if (gmagic) SvGETMAGIC(sv); } } + else if (SvTEMP(*SP) && SvREFCNT(*SP) == 1) { + *++newsp = *SP; + if (gmagic) SvGETMAGIC(*SP); + } else - *++newsp = - (lval || SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP); + *++newsp = sv_mortalcopy(*SP); } else *++newsp = sv_mortalcopy(*SP); } else *++newsp = &PL_sv_undef; - } - else if (gimme == G_ARRAY) { + } + else if (gimme == G_ARRAY) { while (++MARK <= SP) { - *++newsp = popsub2 && (lval || SvTEMP(*MARK)) + *++newsp = popsub2 && SvTEMP(*MARK) && SvREFCNT(*MARK) == 1 ? *MARK : sv_mortalcopy(*MARK); TAINT_NOT; /* Each item is independent */ } + } + PL_stack_sp = newsp; } - PL_stack_sp = newsp; LEAVE; /* Stack values are safe: */ @@ -2319,6 +2548,37 @@ PP(pp_return) return retop; } +/* This duplicates parts of pp_leavesub, so that it can share code with + * pp_return */ +PP(pp_leavesublv) +{ + dVAR; dSP; + SV **newsp; + PMOP *newpm; + I32 gimme; + register PERL_CONTEXT *cx; + SV *sv; + + if (CxMULTICALL(&cxstack[cxstack_ix])) + return 0; + + POPBLOCK(cx,newpm); + cxstack_ix++; /* temporarily protect top context */ + assert(CvLVALUE(cx->blk_sub.cv)); + + TAINT_NOT; + + S_return_lvalues(aTHX_ newsp, SP, newsp, gimme, cx, newpm); + + LEAVE; + cxstack_ix--; + POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */ + PL_curpm = newpm; /* ... and pop $1 et al */ + + LEAVESUB(sv); + return cx->blk_sub.retop; +} + PP(pp_last) { dVAR; dSP; @@ -2376,21 +2636,8 @@ PP(pp_last) } TAINT_NOT; - if (gimme == G_SCALAR) { - if (MARK < SP) - *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP)) - ? *SP : sv_mortalcopy(*SP); - else - *++newsp = &PL_sv_undef; - } - else if (gimme == G_ARRAY) { - while (++MARK <= SP) { - *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK)) - ? *MARK : sv_mortalcopy(*MARK); - TAINT_NOT; /* Each item is independent */ - } - } - SP = newsp; + SP = adjust_stack_on_leave(newsp, SP, MARK, gimme, + pop2 == CXt_SUB ? SVs_TEMP : 0); PUTBACK; LEAVE; @@ -3995,7 +4242,6 @@ PP(pp_entereval) PP(pp_leaveeval) { dVAR; dSP; - register SV **mark; SV **newsp; PMOP *newpm; I32 gimme; @@ -4012,31 +4258,8 @@ PP(pp_leaveeval) retop = cx->blk_eval.retop; TAINT_NOT; - if (gimme == G_VOID) - MARK = newsp; - else if (gimme == G_SCALAR) { - MARK = newsp + 1; - if (MARK <= SP) { - if (SvFLAGS(TOPs) & SVs_TEMP) - *MARK = TOPs; - else - *MARK = sv_mortalcopy(TOPs); - } - else { - MEXTEND(mark,0); - *MARK = &PL_sv_undef; - } - SP = MARK; - } - else { - /* in case LEAVE wipes old return values */ - for (mark = newsp + 1; mark <= SP; mark++) { - if (!(SvFLAGS(*mark) & SVs_TEMP)) { - *mark = sv_mortalcopy(*mark); - TAINT_NOT; /* Each item is independent */ - } - } - } + SP = adjust_stack_on_leave((gimme == G_VOID) ? SP : newsp, SP, newsp, + gimme, SVs_TEMP); PL_curpm = newpm; /* Don't pop $1 et al till now */ #ifdef DEBUGGING @@ -4133,33 +4356,7 @@ PP(pp_leavetry) PERL_UNUSED_VAR(optype); TAINT_NOT; - if (gimme == G_VOID) - SP = newsp; - else if (gimme == G_SCALAR) { - register SV **mark; - MARK = newsp + 1; - if (MARK <= SP) { - if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP)) - *MARK = TOPs; - else - *MARK = sv_mortalcopy(TOPs); - } - else { - MEXTEND(mark,0); - *MARK = &PL_sv_undef; - } - SP = MARK; - } - else { - /* in case LEAVE wipes old return values */ - register SV **mark; - for (mark = newsp + 1; mark <= SP; mark++) { - if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) { - *mark = sv_mortalcopy(*mark); - TAINT_NOT; /* Each item is independent */ - } - } - } + SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP); PL_curpm = newpm; /* Don't pop $1 et al till now */ LEAVE_with_name("eval_scope"); @@ -4197,33 +4394,7 @@ PP(pp_leavegiven) assert(CxTYPE(cx) == CXt_GIVEN); TAINT_NOT; - if (gimme == G_VOID) - SP = newsp; - else if (gimme == G_SCALAR) { - register SV **mark; - MARK = newsp + 1; - if (MARK <= SP) { - if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP)) - *MARK = TOPs; - else - *MARK = sv_mortalcopy(TOPs); - } - else { - MEXTEND(mark,0); - *MARK = &PL_sv_undef; - } - SP = MARK; - } - else { - /* in case LEAVE wipes old return values */ - register SV **mark; - for (mark = newsp + 1; mark <= SP; mark++) { - if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) { - *mark = sv_mortalcopy(*mark); - TAINT_NOT; /* Each item is independent */ - } - } - } + SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP); PL_curpm = newpm; /* Don't pop $1 et al till now */ LEAVE_with_name("given"); @@ -4773,7 +4944,7 @@ PP(pp_enterwhen) if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs)) RETURNOP(cLOGOP->op_other->op_next); - ENTER_with_name("eval"); + ENTER_with_name("when"); SAVETMPS; PUSHBLOCK(cx, CXt_WHEN, SP); @@ -4785,43 +4956,69 @@ PP(pp_enterwhen) PP(pp_leavewhen) { dVAR; dSP; + I32 cxix; register PERL_CONTEXT *cx; - I32 gimme __attribute__unused__; + I32 gimme; SV **newsp; PMOP *newpm; + cxix = dopoptogiven(cxstack_ix); + if (cxix < 0) + DIE(aTHX_ "Can't use when() outside a topicalizer"); + POPBLOCK(cx,newpm); assert(CxTYPE(cx) == CXt_WHEN); - SP = newsp; - PUTBACK; - + TAINT_NOT; + SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP); PL_curpm = newpm; /* pop $1 et al */ - LEAVE_with_name("eval"); - return NORMAL; + LEAVE_with_name("when"); + + if (cxix < cxstack_ix) + dounwind(cxix); + + cx = &cxstack[cxix]; + + if (CxFOREACH(cx)) { + /* clear off anything above the scope we're re-entering */ + I32 inner = PL_scopestack_ix; + + TOPBLOCK(cx); + if (PL_scopestack_ix < inner) + leave_scope(PL_scopestack[PL_scopestack_ix]); + PL_curcop = cx->blk_oldcop; + + return cx->blk_loop.my_op->op_nextop; + } + else + RETURNOP(cx->blk_givwhen.leave_op); } PP(pp_continue) { - dVAR; + dVAR; dSP; I32 cxix; register PERL_CONTEXT *cx; - I32 inner; + I32 gimme; + SV **newsp; + PMOP *newpm; cxix = dopoptowhen(cxstack_ix); if (cxix < 0) DIE(aTHX_ "Can't \"continue\" outside a when block"); + if (cxix < cxstack_ix) dounwind(cxix); - /* clear off anything above the scope we're re-entering */ - inner = PL_scopestack_ix; - TOPBLOCK(cx); - if (PL_scopestack_ix < inner) - leave_scope(PL_scopestack[PL_scopestack_ix]); - PL_curcop = cx->blk_oldcop; - return cx->blk_givwhen.leave_op; + POPBLOCK(cx,newpm); + assert(CxTYPE(cx) == CXt_WHEN); + + SP = newsp; + PL_curpm = newpm; /* pop $1 et al */ + + LEAVE_with_name("when"); + RETURNOP(cx->blk_givwhen.leave_op->op_next); } PP(pp_break) @@ -4829,34 +5026,22 @@ PP(pp_break) dVAR; I32 cxix; register PERL_CONTEXT *cx; - I32 inner; - dSP; cxix = dopoptogiven(cxstack_ix); - if (cxix < 0) { - if (PL_op->op_flags & OPf_SPECIAL) - DIE(aTHX_ "Can't use when() outside a topicalizer"); - else - DIE(aTHX_ "Can't \"break\" outside a given block"); - } - if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL))) + if (cxix < 0) + DIE(aTHX_ "Can't \"break\" outside a given block"); + + cx = &cxstack[cxix]; + if (CxFOREACH(cx)) DIE(aTHX_ "Can't \"break\" in a loop topicalizer"); if (cxix < cxstack_ix) dounwind(cxix); - - /* clear off anything above the scope we're re-entering */ - inner = PL_scopestack_ix; + + /* Restore the sp at the time we entered the given block */ TOPBLOCK(cx); - if (PL_scopestack_ix < inner) - leave_scope(PL_scopestack[PL_scopestack_ix]); - PL_curcop = cx->blk_oldcop; - if (CxFOREACH(cx)) - return (cx)->blk_loop.my_op->op_nextop; - else - /* RETURNOP calls PUTBACK which restores the old old sp */ - RETURNOP(cx->blk_givwhen.leave_op); + return cx->blk_givwhen.leave_op; } static MAGIC * @@ -4967,14 +5152,14 @@ S_doparseform(pTHX_ SV *sv) if (postspace) *fpc++ = FF_SPACE; *fpc++ = FF_LITERAL; - *fpc++ = (U16)arg; + *fpc++ = (U32)arg; } postspace = FALSE; if (s <= send) skipspaces--; if (skipspaces) { *fpc++ = FF_SKIP; - *fpc++ = (U16)skipspaces; + *fpc++ = (U32)skipspaces; } skipspaces = 0; if (s <= send) @@ -4985,7 +5170,7 @@ S_doparseform(pTHX_ SV *sv) arg = fpc - linepc + 1; else arg = 0; - *fpc++ = (U16)arg; + *fpc++ = (U32)arg; } if (s < send) { linepc = fpc; @@ -5008,7 +5193,7 @@ S_doparseform(pTHX_ SV *sv) arg = (s - base) - 1; if (arg) { *fpc++ = FF_LITERAL; - *fpc++ = (U16)arg; + *fpc++ = (U32)arg; } base = s - 1; @@ -5023,7 +5208,7 @@ S_doparseform(pTHX_ SV *sv) *fpc++ = FF_LINEGLOB; } else if (*s == '#' || (*s == '.' && s[1] == '#')) { /* @###, ^### */ - arg = ischop ? 512 : 0; + arg = ischop ? FORM_NUM_BLANK : 0; base = s - 1; while (*s == '#') s++; @@ -5031,15 +5216,15 @@ S_doparseform(pTHX_ SV *sv) const char * const f = ++s; while (*s == '#') s++; - arg |= 256 + (s - f); + arg |= FORM_NUM_POINT + (s - f); } *fpc++ = s - base; /* fieldsize for FETCH */ *fpc++ = FF_DECIMAL; - *fpc++ = (U16)arg; + *fpc++ = (U32)arg; unchopnum |= ! ischop; } else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */ - arg = ischop ? 512 : 0; + arg = ischop ? FORM_NUM_BLANK : 0; base = s - 1; s++; /* skip the '0' first */ while (*s == '#') @@ -5048,11 +5233,11 @@ S_doparseform(pTHX_ SV *sv) const char * const f = ++s; while (*s == '#') s++; - arg |= 256 + (s - f); + arg |= FORM_NUM_POINT + (s - f); } *fpc++ = s - base; /* fieldsize for FETCH */ *fpc++ = FF_0DECIMAL; - *fpc++ = (U16)arg; + *fpc++ = (U32)arg; unchopnum |= ! ischop; } else { /* text field */ @@ -5082,7 +5267,7 @@ S_doparseform(pTHX_ SV *sv) *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL; if (prespace) - *fpc++ = (U16)prespace; /* add SPACE or HALFSPACE */ + *fpc++ = (U32)prespace; /* add SPACE or HALFSPACE */ *fpc++ = FF_ITEM; if (ismore) *fpc++ = FF_MORE; @@ -5120,9 +5305,9 @@ S_num_overflow(NV value, I32 fldsize, I32 frcsize) bool res = FALSE; int intsize = fldsize - (value < 0 ? 1 : 0); - if (frcsize & 256) + if (frcsize & FORM_NUM_POINT) intsize--; - frcsize &= 255; + frcsize &= ~(FORM_NUM_POINT|FORM_NUM_BLANK); intsize -= frcsize; while (intsize--) pwr *= 10.0; @@ -5220,11 +5405,14 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) int count; ENTER_with_name("call_filter_sub"); - SAVE_DEFSV; + save_gp(PL_defgv, 0); + GvINTRO_off(PL_defgv); + SAVEGENERICSV(GvSV(PL_defgv)); SAVETMPS; EXTEND(SP, 2); DEFSV_set(upstream); + SvREFCNT_inc_simple_void_NN(upstream); PUSHMARK(SP); mPUSHi(0); if (filter_state) {