X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/f5ada144f34d75c136b6780e10ca13d18d44c557..1bdf3602089bbd91290b5f82acfbe4387f9e3c97:/pp_ctl.c diff --git a/pp_ctl.c b/pp_ctl.c index 524fa43..a9012ee 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -43,13 +43,20 @@ PP(pp_wantarray) dVAR; dSP; I32 cxix; + const PERL_CONTEXT *cx; EXTEND(SP, 1); - cxix = dopoptosub(cxstack_ix); - if (cxix < 0) + if (PL_op->op_private & OPpOFFBYONE) { + if (!(cx = caller_cx(1,NULL))) RETPUSHUNDEF; + } + else { + cxix = dopoptosub(cxstack_ix); + if (cxix < 0) RETPUSHUNDEF; + cx = &cxstack[cxix]; + } - switch (cxstack[cxix].blk_gimme) { + switch (cx->blk_gimme) { case G_ARRAY: RETPUSHYES; case G_SCALAR: @@ -198,9 +205,7 @@ PP(pp_regcomp) if (PL_op->op_flags & OPf_SPECIAL) PL_reginterp_cnt = I32_MAX; /* Mark as safe. */ - if (DO_UTF8(tmpstr)) { - assert (SvUTF8(tmpstr)); - } else if (SvUTF8(tmpstr)) { + if (!DO_UTF8(tmpstr) && SvUTF8(tmpstr)) { /* Not doing UTF-8, despite what the SV says. Is this only if we're trapped in use 'bytes'? */ /* Make a copy of the octet sequence, but without the flag on, @@ -209,19 +214,11 @@ PP(pp_regcomp) const char *const p = SvPV(tmpstr, len); tmpstr = newSVpvn_flags(p, len, SVs_TEMP); } - else if (SvAMAGIC(tmpstr)) { + else if (SvAMAGIC(tmpstr) || SvGMAGICAL(tmpstr)) { /* make a copy to avoid extra stringifies */ tmpstr = newSVpvn_flags(t, len, SVs_TEMP | SvUTF8(tmpstr)); } - /* If it is gmagical, create a mortal copy, but without calling - get-magic, as we have already done that. */ - if(SvGMAGICAL(tmpstr)) { - SV *mortalcopy = sv_newmortal(); - sv_setsv_flags(mortalcopy, tmpstr, 0); - tmpstr = mortalcopy; - } - if (eng) PM_SETRE(pm, CALLREGCOMP_ENG(eng, tmpstr, pm_flags)); else @@ -298,6 +295,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 +309,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 +321,30 @@ PP(pp_substcont) if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */ cx->sb_rxtainted |= SUBST_TAINT_PAT; -#ifdef PERL_OLD_COPY_ON_WRITE - if (SvIsCOW(targ)) { - sv_force_normal_flags(targ, SV_COW_DROP_PV); - } else -#endif - { - SvPV_free(targ); + if (pm->op_pmflags & PMf_NONDESTRUCT) { + PUSHs(dstr); + /* From here on down we're using the copy, and leaving the + original untouched. */ + targ = dstr; } - 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 + else { + if (SvIsCOW(targ)) { + sv_force_normal_flags(targ, SV_COW_DROP_PV); + } 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 +391,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 +422,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 +528,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; @@ -539,7 +551,7 @@ PP(pp_formline) 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 +573,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); @@ -842,6 +855,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)); @@ -858,6 +872,11 @@ PP(pp_formline) 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); @@ -865,8 +884,14 @@ PP(pp_formline) /* 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); @@ -901,11 +926,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; @@ -913,15 +938,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++ = ' '; @@ -939,7 +964,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; @@ -1274,11 +1300,11 @@ PP(pp_flop) if (RANGE_IS_NUMERIC(left,right)) { register IV i, j; IV max; - if ((SvOK(left) && SvNV(left) < IV_MIN) || - (SvOK(right) && SvNV(right) > IV_MAX)) + if ((SvOK(left) && SvNV_nomg(left) < IV_MIN) || + (SvOK(right) && SvNV_nomg(right) > IV_MAX)) DIE(aTHX_ "Range iterator outside integer range"); - i = SvIV(left); - max = SvIV(right); + i = SvIV_nomg(left); + max = SvIV_nomg(right); if (max >= i) { j = max - i + 1; EXTEND_MORTAL(j); @@ -1292,12 +1318,11 @@ PP(pp_flop) } } else { - SV * const final = sv_mortalcopy(right); - STRLEN len; - const char * const tmps = SvPV_const(final, len); + STRLEN len, llen; + const char * const lpv = SvPV_nomg_const(left, llen); + const char * const tmps = SvPV_nomg_const(right, len); - SV *sv = sv_mortalcopy(left); - SvPV_force_nolen(sv); + SV *sv = newSVpvn_flags(lpv, llen, SvUTF8(left)|SVs_TEMP); while (!SvNIOKp(sv) && SvCUR(sv) <= len) { XPUSHs(sv); if (strEQ(SvPVX_const(sv),tmps)) @@ -1438,6 +1463,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) { @@ -1560,6 +1599,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]; @@ -1602,8 +1644,8 @@ Perl_qerror(pTHX_ SV *err) if (PL_in_eval) { if (PL_in_eval & EVAL_KEEPERR) { - Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %s", - SvPV_nolen_const(err)); + Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf, + SVfARG(err)); } else sv_catsv(ERRSV, err); @@ -1708,20 +1750,21 @@ Perl_die_unwind(pTHX_ SV *msv) PL_curcop = oldcop; if (optype == OP_REQUIRE) { - const char* const msg = SvPVx_nolen_const(exceptsv); (void)hv_store(GvHVn(PL_incgv), - SvPVX_const(namesv), SvCUR(namesv), + SvPVX_const(namesv), + SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv), &PL_sv_undef, 0); /* note that unlike pp_entereval, pp_require isn't * supposed to trap errors. So now that we've popped the * EVAL that pp_require pushed, and processed the error * message, rethrow the error */ - Perl_croak(aTHX_ "%sCompilation failed in require", - *msg ? msg : "Unknown error\n"); + Perl_croak(aTHX_ "%"SVf"Compilation failed in require", + SVfARG(exceptsv ? exceptsv : newSVpvs_flags("Unknown error\n", + SVs_TEMP))); } if (in_eval & EVAL_KEEPERR) { - Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %s", - SvPV_nolen_const(exceptsv)); + Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf, + SVfARG(exceptsv)); } else { sv_setsv(ERRSV, exceptsv); @@ -1814,13 +1857,17 @@ PP(pp_caller) register const PERL_CONTEXT *cx; const PERL_CONTEXT *dbcx; I32 gimme; - const char *stashname; + const HEK *stash_hek; I32 count = 0; + bool has_arg = MAXARG && TOPs; - if (MAXARG) + if (MAXARG) { + if (has_arg) count = POPi; + else (void)POPs; + } - cx = caller_cx(count, &dbcx); + cx = caller_cx(count + !!(PL_op->op_private & OPpOFFBYONE), &dbcx); if (!cx) { if (GIMME != G_ARRAY) { EXTEND(SP, 1); @@ -1829,14 +1876,14 @@ PP(pp_caller) RETURN; } - stashname = CopSTASHPV(cx->blk_oldcop); + stash_hek = HvNAME_HEK((HV*)CopSTASH(cx->blk_oldcop)); if (GIMME != G_ARRAY) { EXTEND(SP, 1); - if (!stashname) + if (!stash_hek) PUSHs(&PL_sv_undef); else { dTARGET; - sv_setpv(TARG, stashname); + sv_sethek(TARG, stash_hek); PUSHs(TARG); } RETURN; @@ -1844,13 +1891,16 @@ PP(pp_caller) EXTEND(SP, 11); - if (!stashname) + if (!stash_hek) PUSHs(&PL_sv_undef); - else - mPUSHs(newSVpv(stashname, 0)); + else { + dTARGET; + sv_sethek(TARG, stash_hek); + PUSHTARG; + } mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0)); mPUSHi((I32)CopLINE(cx->blk_oldcop)); - if (!MAXARG) + if (!has_arg) RETURN; if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) { GV * const cvgv = CvGV(dbcx->blk_sub.cv); @@ -1902,8 +1952,7 @@ PP(pp_caller) AV * const ary = cx->blk_sub.argarray; const int off = AvARRAY(ary) - AvALLOC(ary); - if (!PL_dbargs) - Perl_init_dbargs(aTHX); + Perl_init_dbargs(aTHX); if (AvMAX(PL_dbargs) < AvFILLp(ary) + off) av_extend(PL_dbargs, AvFILLp(ary) + off); @@ -1949,7 +1998,8 @@ PP(pp_reset) { dVAR; dSP; - const char * const tmps = (MAXARG < 1) ? (const char *)"" : POPpconstx; + const char * const tmps = + (MAXARG < 1 || (!TOPs && !POPs)) ? (const char *)"" : POPpconstx; sv_reset(tmps, CopSTASH(PL_curcop)); PUSHs(&PL_sv_yes); RETURN; @@ -2016,6 +2066,85 @@ PP(pp_dbstate) return NORMAL; } +STATIC SV ** +S_adjust_stack_on_leave(pTHX_ SV **newsp, SV **sp, SV **mark, I32 gimme, U32 flags) +{ + bool padtmp = 0; + PERL_ARGS_ASSERT_ADJUST_STACK_ON_LEAVE; + + if (flags & SVs_PADTMP) { + flags &= ~SVs_PADTMP; + padtmp = 1; + } + if (gimme == G_SCALAR) { + if (MARK < SP) + *++newsp = ((SvFLAGS(*SP) & flags) || (padtmp && SvPADTMP(*SP))) + ? *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) || (padtmp && SvPADTMP(*MARK))) + *++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; @@ -2069,27 +2198,28 @@ PP(pp_enteriter) assumptions */ assert(CxTYPE(cx) == CXt_LOOP_LAZYIV); #ifdef NV_PRESERVES_UV - if ((SvOK(sv) && ((SvNV(sv) < (NV)IV_MIN) || - (SvNV(sv) > (NV)IV_MAX))) + if ((SvOK(sv) && ((SvNV_nomg(sv) < (NV)IV_MIN) || + (SvNV_nomg(sv) > (NV)IV_MAX))) || - (SvOK(right) && ((SvNV(right) > (NV)IV_MAX) || - (SvNV(right) < (NV)IV_MIN)))) + (SvOK(right) && ((SvNV_nomg(right) > (NV)IV_MAX) || + (SvNV_nomg(right) < (NV)IV_MIN)))) #else - if ((SvOK(sv) && ((SvNV(sv) <= (NV)IV_MIN) + if ((SvOK(sv) && ((SvNV_nomg(sv) <= (NV)IV_MIN) || - ((SvNV(sv) > 0) && - ((SvUV(sv) > (UV)IV_MAX) || - (SvNV(sv) > (NV)UV_MAX))))) + ((SvNV_nomg(sv) > 0) && + ((SvUV_nomg(sv) > (UV)IV_MAX) || + (SvNV_nomg(sv) > (NV)UV_MAX))))) || - (SvOK(right) && ((SvNV(right) <= (NV)IV_MIN) + (SvOK(right) && ((SvNV_nomg(right) <= (NV)IV_MIN) || - ((SvNV(right) > 0) && - ((SvUV(right) > (UV)IV_MAX) || - (SvNV(right) > (NV)UV_MAX)))))) + ((SvNV_nomg(right) > 0) && + ((SvUV_nomg(right) > (UV)IV_MAX) || + (SvNV_nomg(right) > (NV)UV_MAX)) + )))) #endif DIE(aTHX_ "Range iterator outside integer range"); - cx->blk_loop.state_u.lazyiv.cur = SvIV(sv); - cx->blk_loop.state_u.lazyiv.end = SvIV(right); + cx->blk_loop.state_u.lazyiv.cur = SvIV_nomg(sv); + cx->blk_loop.state_u.lazyiv.end = SvIV_nomg(right); #ifdef DEBUGGING /* for correct -Dstv display */ cx->blk_oldsp = sp - PL_stack_base; @@ -2169,21 +2299,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 ... */ @@ -2195,6 +2311,104 @@ 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) & OPpDEREF) { + SvGETMAGIC(TOPs); + if (!SvOK(TOPs)) { + TOPs = vivify_ref(TOPs, CxLVAL(cx) & OPpDEREF); + } + } + } + else if (gimme == G_ARRAY) { + assert (!(CxLVAL(cx) & OPpDEREF)); + 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; @@ -2259,7 +2473,8 @@ PP(pp_return) { /* Unassume the success we assumed earlier. */ (void)hv_delete(GvHVn(PL_incgv), - SvPVX_const(namesv), SvCUR(namesv), + SvPVX_const(namesv), + SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv), G_DISCARD); DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv)); } @@ -2273,11 +2488,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); @@ -2289,24 +2506,27 @@ PP(pp_return) SvREFCNT_dec(sv); } } + else if (SvTEMP(*SP) && SvREFCNT(*SP) == 1) { + *++newsp = *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: */ @@ -2325,6 +2545,36 @@ 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 */ + + 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; @@ -2382,21 +2632,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; @@ -2575,8 +2812,9 @@ PP(pp_goto) /* autoloaded stub? */ if (cv != GvCV(gv) && (cv = GvCV(gv))) goto retry; - autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), - GvNAMELEN(gv), FALSE); + autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv), + GvNAMELEN(gv), + GvNAMEUTF8(gv) ? SVf_UTF8 : 0); if (autogv && (cv = GvCV(autogv))) goto retry; tmpstr = sv_newmortal(); @@ -2639,13 +2877,26 @@ PP(pp_goto) oldsave = PL_scopestack[PL_scopestack_ix - 1]; LEAVE_SCOPE(oldsave); + /* 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"); + } + /* Now do some callish stuff. */ SAVETMPS; SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */ if (CvISXSUB(cv)) { OP* const retop = cx->blk_sub.retop; - SV **newsp __attribute__unused__; - I32 gimme __attribute__unused__; + SV **newsp PERL_UNUSED_DECL; + I32 gimme PERL_UNUSED_DECL; if (reified) { I32 index; for (index=0; indexblk_oldcop; SAVECOMPPAD(); PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv)); if (CxHASARGS(cx)) @@ -2892,6 +3144,9 @@ PP(pp_exit) if (MAXARG < 1) anum = 0; + else if (!TOPs) { + anum = 0; (void)POPs; + } else { anum = SvIVx(POPs); #ifdef VMS @@ -3108,9 +3363,9 @@ Perl_sv_compile_2op_is_broken(pTHX_ SV *sv, OP **startop, const char *code, CATCH_SET(TRUE); if (runtime) - (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq); + (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq, NULL); else - (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax); + (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax, NULL); CATCH_SET(need_catch); POPBLOCK(cx,PL_curpm); POPEVAL(cx); @@ -3166,7 +3421,7 @@ Perl_find_runcv(pTHX_ U32 *db_seqp) return cv; } else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx)) - return PL_compcv; + return cx->blk_eval.cv; } } return PL_main_cv; @@ -3211,13 +3466,22 @@ S_try_yyparse(pTHX_ int gramtype) * pushes undef (also croaks if startop != NULL). */ +/* This function is called from three places, sv_compile_2op, pp_return + * and pp_entereval. These can be distinguished as follows: + * sv_compile_2op - startop is non-null + * pp_require - startop is null; in_require is true + * pp_entereval - stortop is null; in_require is false + */ + STATIC bool -S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) +S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq, HV *hh) { dVAR; dSP; OP * const saveop = PL_op; + COP * const oldcurcop = PL_curcop; bool in_require = (saveop && saveop->op_type == OP_REQUIRE); int yystatus; + CV *evalcv; PL_in_eval = (in_require ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL)) @@ -3225,29 +3489,29 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) PUSHMARK(SP); - SAVESPTR(PL_compcv); - PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV)); - CvEVAL_on(PL_compcv); + evalcv = MUTABLE_CV(newSV_type(SVt_PVCV)); + CvEVAL_on(evalcv); assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL); - cxstack[cxstack_ix].blk_eval.cv = PL_compcv; + cxstack[cxstack_ix].blk_eval.cv = evalcv; + cxstack[cxstack_ix].blk_gimme = gimme; - CvOUTSIDE_SEQ(PL_compcv) = seq; - CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside)); + CvOUTSIDE_SEQ(evalcv) = seq; + CvOUTSIDE(evalcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside)); /* set up a scratch pad */ - CvPADLIST(PL_compcv) = pad_new(padnew_SAVE); + CvPADLIST(evalcv) = pad_new(padnew_SAVE); PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */ if (!PL_madskills) - SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */ + SAVEMORTALIZESV(evalcv); /* must remain until end of current statement */ /* make sure we compile in the right package */ if (CopSTASH_ne(PL_curcop, PL_curstash)) { - SAVESPTR(PL_curstash); - PL_curstash = CopSTASH(PL_curcop); + SAVEGENERICSV(PL_curstash); + PL_curstash = (HV *)SvREFCNT_inc_simple(CopSTASH(PL_curcop)); } /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */ SAVESPTR(PL_beginav); @@ -3262,16 +3526,61 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) PL_madskills = 0; #endif + if (!startop) ENTER_with_name("evalcomp"); + SAVESPTR(PL_compcv); + PL_compcv = evalcv; + /* try to compile it */ PL_eval_root = NULL; PL_curcop = &PL_compiling; - CopARYBASE_set(PL_curcop, 0); if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL)) PL_in_eval |= EVAL_KEEPERR; else CLEAR_ERRSV(); + if (!startop) { + SAVEHINTS(); + if (in_require) { + PL_hints = 0; + hv_clear(GvHV(PL_hintgv)); + } + else { + PL_hints = saveop->op_private & OPpEVAL_COPHH + ? oldcurcop->cop_hints : saveop->op_targ; + if (hh) { + /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */ + SvREFCNT_dec(GvHV(PL_hintgv)); + GvHV(PL_hintgv) = hh; + } + } + SAVECOMPILEWARNINGS(); + if (in_require) { + 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); + } + } + CALL_BLOCK_HOOKS(bhk_eval, saveop); /* note that yyparse() may raise an exception, e.g. C, @@ -3281,11 +3590,12 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) if (yystatus || PL_parser->error_count || !PL_eval_root) { SV **newsp; /* Used by POPBLOCK. */ - PERL_CONTEXT *cx = NULL; + PERL_CONTEXT *cx; I32 optype; /* Used by POPEVAL. */ - SV *namesv = NULL; - const char *msg; + SV *namesv; + cx = NULL; + namesv = NULL; PERL_UNUSED_VAR(newsp); PERL_UNUSED_VAR(optype); @@ -3303,11 +3613,10 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) POPEVAL(cx); namesv = cx->blk_eval.old_namesv; } - } - if (yystatus != 3) + /* POPBLOCK renders LEAVE_with_name("evalcomp") unnecessary. */ LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE. */ + } - msg = SvPVx_nolen_const(ERRSV); if (in_require) { if (!cx) { /* If cx is still NULL, it means that we didn't go in the @@ -3317,43 +3626,40 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) namesv = cx->blk_eval.old_namesv; } (void)hv_store(GvHVn(PL_incgv), - SvPVX_const(namesv), SvCUR(namesv), + SvPVX_const(namesv), + SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv), &PL_sv_undef, 0); - Perl_croak(aTHX_ "%sCompilation failed in require", - *msg ? msg : "Unknown error\n"); + Perl_croak(aTHX_ "%"SVf"Compilation failed in require", + SVfARG(ERRSV + ? ERRSV + : newSVpvs_flags("Unknown error\n", SVs_TEMP))); } else if (startop) { if (yystatus != 3) { POPBLOCK(cx,PL_curpm); POPEVAL(cx); } - Perl_croak(aTHX_ "%sCompilation failed in regexp", - (*msg ? msg : "Unknown error\n")); + Perl_croak(aTHX_ "%"SVf"Compilation failed in regexp", + SVfARG(ERRSV + ? ERRSV + : newSVpvs_flags("Unknown error\n", SVs_TEMP))); } else { - if (!*msg) { + if (!*(SvPVx_nolen_const(ERRSV))) { sv_setpvs(ERRSV, "Compilation error"); } } - PUSHs(&PL_sv_undef); + if (gimme != G_ARRAY) PUSHs(&PL_sv_undef); PUTBACK; return FALSE; } + else if (!startop) LEAVE_with_name("evalcomp"); CopLINE_set(&PL_compiling, 0); if (startop) { *startop = PL_eval_root; } else SAVEFREEOP(PL_eval_root); - /* Set the context for this new optree. - * Propagate the context from the eval(). */ - if ((gimme & G_WANT) == G_VOID) - scalarvoid(PL_eval_root); - else if ((gimme & G_WANT) == G_ARRAY) - list(PL_eval_root); - else - scalar(PL_eval_root); - DEBUG_x(dump_eval()); /* Register with debugger: */ @@ -3376,7 +3682,7 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) /* compiled okay, so do it */ - CvDEPTH(PL_compcv) = 1; + CvDEPTH(evalcv) = 1; SP = PL_stack_base + POPMARK; /* pop original mark */ PL_op = saveop; /* The caller may need it. */ PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */ @@ -3399,7 +3705,7 @@ S_check_type_and_open(pTHX_ SV *name) } #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO) - return PerlIO_openn(aTHX_ NULL, PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name); + return PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name); #else return PerlIO_open(p, PERL_SCRIPT_MODE); #endif @@ -3812,18 +4118,6 @@ PP(pp_require) CopFILE_set(&PL_compiling, tryname); lex_start(NULL, tryrsfp, 0); - SAVEHINTS(); - PL_hints = 0; - hv_clear(GvHV(PL_hintgv)); - - SAVECOMPILEWARNINGS(); - 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 (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 @@ -3849,7 +4143,7 @@ PP(pp_require) encoding = PL_encoding; PL_encoding = NULL; - if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq)) + if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq, NULL)) op = DOCATCH(PL_eval_start); else op = PL_op->op_next; @@ -3885,12 +4179,20 @@ PP(pp_entereval) char *tmpbuf = tbuf; STRLEN len; CV* runcv; - U32 seq; + U32 seq, lex_flags = 0; HV *saved_hh = NULL; + const bool bytes = PL_op->op_private & OPpEVAL_BYTES; if (PL_op->op_private & OPpEVAL_HAS_HH) { 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); + } sv = POPs; if (!SvPOK(sv)) { /* make sure we've got a plain PV (no overload etc) before testing @@ -3900,13 +4202,29 @@ PP(pp_entereval) const char * const p = SvPV_const(sv, len); sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv)); + lex_flags |= LEX_START_COPIED; + + 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; } TAINT_IF(SvTAINTED(sv)); TAINT_PROPER("eval"); ENTER_with_name("eval"); - lex_start(sv, NULL, LEX_START_SAME_FILTER); + lex_start(sv, NULL, lex_flags | (PL_op->op_private & OPpEVAL_UNICODE + ? LEX_IGNORE_UTF8_HINTS + : bytes ? LEX_EVALBYTES : LEX_START_SAME_FILTER + ) + ); SAVETMPS; /* switch to eval mode */ @@ -3925,32 +4243,6 @@ PP(pp_entereval) CopFILE_set(&PL_compiling, tmpbuf+2); SAVECOPLINE(&PL_compiling); CopLINE_set(&PL_compiling, 1); - /* 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 */ - SAVEHINTS(); - PL_hints = PL_op->op_targ; - if (saved_hh) { - /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */ - SvREFCNT_dec(GvHV(PL_hintgv)); - GvHV(PL_hintgv) = saved_hh; - } - SAVECOMPILEWARNINGS(); - PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings); - cophh_free(CopHINTHASH_get(&PL_compiling)); - if (Perl_fetch_cop_label(aTHX_ PL_curcop, 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(PL_curcop->cop_hints_hash->refcounted_he_next); - /* Check the assumption that this removed the label. */ - assert(Perl_fetch_cop_label(aTHX_ &PL_compiling, NULL, NULL) == NULL); - } - else - PL_compiling.cop_hints_hash = cophh_copy(PL_curcop->cop_hints_hash); /* special case: an eval '' executed within the DB package gets lexically * placed in the first non-DB CV rather than the current CV - this * allows the debugger to execute code, find lexicals etc, in the @@ -3967,6 +4259,11 @@ PP(pp_entereval) if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) 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; @@ -3974,7 +4271,7 @@ PP(pp_entereval) PUTBACK; - if (doeval(gimme, NULL, runcv, seq)) { + if (doeval(gimme, NULL, runcv, seq, saved_hh)) { if (was != PL_breakable_sub_gen /* Some subs defined here. */ ? (PERLDB_LINE || PERLDB_SAVESRC) : PERLDB_SAVESRC_NOSUBS) { @@ -4001,7 +4298,6 @@ PP(pp_entereval) PP(pp_leaveeval) { dVAR; dSP; - register SV **mark; SV **newsp; PMOP *newpm; I32 gimme; @@ -4010,52 +4306,32 @@ PP(pp_leaveeval) const U8 save_flags = PL_op -> op_flags; I32 optype; SV *namesv; + CV *evalcv; PERL_ASYNC_CHECK(); POPBLOCK(cx,newpm); POPEVAL(cx); namesv = cx->blk_eval.old_namesv; retop = cx->blk_eval.retop; + evalcv = cx->blk_eval.cv; 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 - assert(CvDEPTH(PL_compcv) == 1); + assert(CvDEPTH(evalcv) == 1); #endif - CvDEPTH(PL_compcv) = 0; + CvDEPTH(evalcv) = 0; if (optype == OP_REQUIRE && !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp)) { /* Unassume the success we assumed earlier. */ (void)hv_delete(GvHVn(PL_incgv), - SvPVX_const(namesv), SvCUR(namesv), + SvPVX_const(namesv), + SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv), G_DISCARD); retop = Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv)); @@ -4139,33 +4415,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"); @@ -4182,6 +4432,7 @@ PP(pp_entergiven) ENTER_with_name("given"); SAVETMPS; + SAVECLEARSV(PAD_SVl(PL_op->op_targ)); sv_setsv_mg(PAD_SV(PL_op->op_targ), POPs); PUSHBLOCK(cx, CXt_GIVEN, SP); @@ -4203,33 +4454,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"); @@ -4285,14 +4510,14 @@ S_destroy_matcher(pTHX_ PMOP *matcher) PP(pp_smartmatch) { DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n")); - return do_smartmatch(NULL, NULL); + return do_smartmatch(NULL, NULL, 0); } /* This version of do_smartmatch() implements the * table of smart matches that is found in perlsyn. */ STATIC OP * -S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) +S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied) { dVAR; dSP; @@ -4304,7 +4529,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) /* 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 (SvGMAGICAL(d)) + if (!copied && SvGMAGICAL(d)) d = sv_mortalcopy(d); } else @@ -4615,7 +4840,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) PUTBACK; DEBUG_M(Perl_deb(aTHX_ " recursively comparing array element...\n")); - (void) do_smartmatch(seen_this, seen_other); + (void) do_smartmatch(seen_this, seen_other, 0); SPAGAIN; DEBUG_M(Perl_deb(aTHX_ " recursion finished\n")); @@ -4677,7 +4902,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) PUTBACK; /* infinite recursion isn't supposed to happen here */ DEBUG_M(Perl_deb(aTHX_ " recursively testing array element...\n")); - (void) do_smartmatch(NULL, NULL); + (void) do_smartmatch(NULL, NULL, 1); SPAGAIN; DEBUG_M(Perl_deb(aTHX_ " recursion finished\n")); if (SvTRUEx(POPs)) @@ -4779,7 +5004,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); @@ -4791,43 +5016,73 @@ 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) + /* 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"); + 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; + + PERL_UNUSED_VAR(gimme); 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) @@ -4835,34 +5090,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 * @@ -4973,14 +5216,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) @@ -4991,7 +5234,7 @@ S_doparseform(pTHX_ SV *sv) arg = fpc - linepc + 1; else arg = 0; - *fpc++ = (U16)arg; + *fpc++ = (U32)arg; } if (s < send) { linepc = fpc; @@ -5014,7 +5257,7 @@ S_doparseform(pTHX_ SV *sv) arg = (s - base) - 1; if (arg) { *fpc++ = FF_LITERAL; - *fpc++ = (U16)arg; + *fpc++ = (U32)arg; } base = s - 1; @@ -5029,7 +5272,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++; @@ -5037,15 +5280,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 == '#') @@ -5054,11 +5297,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 */ @@ -5088,7 +5331,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; @@ -5126,9 +5369,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; @@ -5226,11 +5469,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) {