X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/dc3bf405700292479bd7ac9b4b914cabd6567c33..cea80896350bf9218a73437b32b19656cee32abd:/pp.c diff --git a/pp.c b/pp.c index d4002ac..621377f 100644 --- a/pp.c +++ b/pp.c @@ -54,7 +54,6 @@ static const STRLEN capital_iota_len = sizeof(GREEK_CAPITAL_LETTER_IOTA_UTF8) - PP(pp_stub) { - dVAR; dSP; if (GIMME_V == G_SCALAR) XPUSHs(&PL_sv_undef); @@ -63,9 +62,10 @@ PP(pp_stub) /* Pushy stuff. */ +/* This is also called directly by pp_lvavref. */ PP(pp_padav) { - dVAR; dSP; dTARGET; + dSP; dTARGET; I32 gimme; assert(SvTYPE(TARG) == SVt_PVAV); if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO )) @@ -117,7 +117,7 @@ PP(pp_padav) PP(pp_padhv) { - dVAR; dSP; dTARGET; + dSP; dTARGET; I32 gimme; assert(SvTYPE(TARG) == SVt_PVHV); @@ -154,7 +154,7 @@ PP(pp_padhv) PP(pp_padcv) { - dVAR; dSP; dTARGET; + dSP; dTARGET; assert(SvTYPE(TARG) == SVt_PVCV); XPUSHs(TARG); RETURN; @@ -162,14 +162,14 @@ PP(pp_padcv) PP(pp_introcv) { - dVAR; dTARGET; + dTARGET; SvPADSTALE_off(TARG); return NORMAL; } PP(pp_clonecv) { - dVAR; dTARGET; + dTARGET; MAGIC * const mg = mg_find(PadlistNAMESARRAY(CvPADLIST(find_runcv(NULL)))[ARGTARG], PERL_MAGIC_proto); @@ -211,7 +211,6 @@ static SV * S_rv2gv(pTHX_ SV *sv, const bool vivify_sv, const bool strict, const bool noinit) { - dVAR; if (!isGV(sv) || SvFAKE(sv)) SvGETMAGIC(sv); if (SvROK(sv)) { if (SvAMAGIC(sv)) { @@ -226,8 +225,9 @@ S_rv2gv(pTHX_ SV *sv, const bool vivify_sv, const bool strict, SvREFCNT_inc_void_NN(sv); sv = MUTABLE_SV(gv); } - else if (!isGV_with_GP(sv)) - return (SV *)Perl_die(aTHX_ "Not a GLOB reference"); + else if (!isGV_with_GP(sv)) { + Perl_die(aTHX_ "Not a GLOB reference"); + } } else { if (!isGV_with_GP(sv)) { @@ -250,6 +250,7 @@ S_rv2gv(pTHX_ SV *sv, const bool vivify_sv, const bool strict, const char * const name = CopSTASHPV(PL_curcop); gv = newGVgen_flags(name, HvNAMEUTF8(CopSTASH(PL_curcop)) ? SVf_UTF8 : 0 ); + SvREFCNT_inc_simple_void_NN(gv); } prepare_SV_for_RV(sv); SvRV_set(sv, MUTABLE_SV(gv)); @@ -257,8 +258,9 @@ S_rv2gv(pTHX_ SV *sv, const bool vivify_sv, const bool strict, SvSETMAGIC(sv); goto wasref; } - if (PL_op->op_flags & OPf_REF || strict) - return (SV *)Perl_die(aTHX_ PL_no_usym, "a symbol"); + if (PL_op->op_flags & OPf_REF || strict) { + Perl_die(aTHX_ PL_no_usym, "a symbol"); + } if (ckWARN(WARN_UNINITIALIZED)) report_uninit(sv); return &PL_sv_undef; @@ -271,14 +273,14 @@ S_rv2gv(pTHX_ SV *sv, const bool vivify_sv, const bool strict, return &PL_sv_undef; } else { - if (strict) - return - (SV *)Perl_die(aTHX_ - S_no_symref_sv, - sv, - (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), - "a symbol" - ); + if (strict) { + Perl_die(aTHX_ + S_no_symref_sv, + sv, + (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), + "a symbol" + ); + } if ((PL_op->op_private & (OPpLVAL_INTRO|OPpDONT_INIT_GV)) == OPpDONT_INIT_GV) { /* We are the target of a coderef assignment. Return @@ -303,7 +305,7 @@ S_rv2gv(pTHX_ SV *sv, const bool vivify_sv, const bool strict, PP(pp_rv2gv) { - dVAR; dSP; dTOPss; + dSP; dTOPss; sv = S_rv2gv(aTHX_ sv, PL_op->op_private & OPpDEREF, @@ -322,7 +324,6 @@ GV * Perl_softref2xv(pTHX_ SV *const sv, const char *const what, const svtype type, SV ***spp) { - dVAR; GV *gv; PERL_ARGS_ASSERT_SOFTREF2XV; @@ -365,7 +366,7 @@ Perl_softref2xv(pTHX_ SV *const sv, const char *const what, PP(pp_rv2sv) { - dVAR; dSP; dTOPss; + dSP; dTOPss; GV *gv = NULL; SvGETMAGIC(sv); @@ -413,16 +414,16 @@ PP(pp_rv2sv) PP(pp_av2arylen) { - dVAR; dSP; + dSP; AV * const av = MUTABLE_AV(TOPs); const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET; if (lvalue) { - SV ** const sv = Perl_av_arylen_p(aTHX_ MUTABLE_AV(av)); - if (!*sv) { - *sv = newSV_type(SVt_PVMG); - sv_magic(*sv, MUTABLE_SV(av), PERL_MAGIC_arylen, NULL, 0); + SV ** const svp = Perl_av_arylen_p(aTHX_ MUTABLE_AV(av)); + if (!*svp) { + *svp = newSV_type(SVt_PVMG); + sv_magic(*svp, MUTABLE_SV(av), PERL_MAGIC_arylen, NULL, 0); } - SETs(*sv); + SETs(*svp); } else { SETs(sv_2mortal(newSViv(AvFILL(MUTABLE_AV(av))))); } @@ -431,7 +432,7 @@ PP(pp_av2arylen) PP(pp_pos) { - dVAR; dSP; dPOPss; + dSP; dPOPss; if (PL_op->op_flags & OPf_MOD || LVRET) { SV * const ret = sv_2mortal(newSV_type(SVt_PVLV));/* Not TARG RT#67838 */ @@ -457,7 +458,7 @@ PP(pp_pos) PP(pp_rv2cv) { - dVAR; dSP; + dSP; GV *gv; HV *stash_unused; const I32 flags = (PL_op->op_flags & OPf_SPECIAL) @@ -472,7 +473,9 @@ PP(pp_rv2cv) CV *cv = sv_2cv(TOPs, &stash_unused, &gv, flags); if (cv) NOOP; else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) { - cv = MUTABLE_CV(gv); + cv = SvTYPE(SvRV(gv)) == SVt_PVCV + ? MUTABLE_CV(SvRV(gv)) + : MUTABLE_CV(gv); } else cv = MUTABLE_CV(&PL_sv_undef); @@ -482,7 +485,7 @@ PP(pp_rv2cv) PP(pp_prototype) { - dVAR; dSP; + dSP; CV *cv; HV *stash; GV *gv; @@ -515,7 +518,7 @@ PP(pp_prototype) PP(pp_anoncode) { - dVAR; dSP; + dSP; CV *cv = MUTABLE_CV(PAD_SV(PL_op->op_targ)); if (CvCLONE(cv)) cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv)))); @@ -526,14 +529,14 @@ PP(pp_anoncode) PP(pp_srefgen) { - dVAR; dSP; + dSP; *SP = refto(*SP); RETURN; } PP(pp_refgen) { - dVAR; dSP; dMARK; + dSP; dMARK; if (GIMME != G_ARRAY) { if (++MARK <= SP) *MARK = *SP; @@ -552,7 +555,6 @@ PP(pp_refgen) STATIC SV* S_refto(pTHX_ SV *sv) { - dVAR; SV* rv; PERL_ARGS_ASSERT_REFTO; @@ -572,7 +574,6 @@ S_refto(pTHX_ SV *sv) SvREFCNT_inc_void_NN(sv); } else if (SvPADTMP(sv)) { - assert(!IS_PADGV(sv)); sv = newSVsv(sv); } else { @@ -588,21 +589,26 @@ S_refto(pTHX_ SV *sv) PP(pp_ref) { - dVAR; dSP; dTARGET; - SV * const sv = POPs; + dSP; + SV * const sv = TOPs; SvGETMAGIC(sv); if (!SvROK(sv)) - RETPUSHNO; + SETs(&PL_sv_no); + else { + dTARGET; + SETs(TARG); + /* use the return value that is in a register, its the same as TARG */ + TARG = sv_ref(TARG,SvRV(sv),TRUE); + SvSETMAGIC(TARG); + } - (void)sv_ref(TARG,SvRV(sv),TRUE); - PUSHTARG; - RETURN; + return NORMAL; } PP(pp_bless) { - dVAR; dSP; + dSP; HV *stash; if (MAXARG == 1) @@ -643,7 +649,7 @@ PP(pp_bless) PP(pp_gelem) { - dVAR; dSP; + dSP; SV *sv = POPs; STRLEN len; @@ -722,7 +728,7 @@ PP(pp_gelem) PP(pp_study) { - dVAR; dSP; dPOPss; + dSP; dPOPss; STRLEN len; (void)SvPV(sv, len); @@ -736,14 +742,17 @@ PP(pp_study) RETPUSHYES; } + +/* also used for: pp_transr() */ + PP(pp_trans) { - dVAR; dSP; dTARG; + dSP; dTARG; SV *sv; if (PL_op->op_flags & OPf_STACKED) sv = POPs; - else if (PL_op->op_private & OPpTARGET_MY) + else if (ARGTARG) sv = GETTARGET; else { sv = DEFSV; @@ -765,17 +774,17 @@ PP(pp_trans) /* Lvalue operators. */ -static void +static size_t S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping) { - dVAR; STRLEN len; char *s; + size_t count = 0; PERL_ARGS_ASSERT_DO_CHOMP; if (chomping && (RsSNARF(PL_rs) || RsRECORD(PL_rs))) - return; + return 0; if (SvTYPE(sv) == SVt_PVAV) { I32 i; AV *const av = MUTABLE_AV(sv); @@ -784,33 +793,30 @@ S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping) for (i = 0; i <= max; i++) { sv = MUTABLE_SV(av_fetch(av, i, FALSE)); if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef)) - do_chomp(retval, sv, chomping); + count += do_chomp(retval, sv, chomping); } - return; + return count; } else if (SvTYPE(sv) == SVt_PVHV) { HV* const hv = MUTABLE_HV(sv); HE* entry; (void)hv_iterinit(hv); while ((entry = hv_iternext(hv))) - do_chomp(retval, hv_iterval(hv,entry), chomping); - return; + count += do_chomp(retval, hv_iterval(hv,entry), chomping); + return count; } else if (SvREADONLY(sv)) { Perl_croak_no_modify(); } - else if (SvIsCOW(sv)) { - sv_force_normal_flags(sv, 0); - } - if (PL_encoding) { + if (IN_ENCODING) { if (!SvUTF8(sv)) { /* XXX, here sv is utf8-ized as a side-effect! If encoding.pm is used properly, almost string-generating operations, including literal strings, chr(), input data, etc. should have been utf8-ized already, right? */ - sv_recode_to_utf8(sv, PL_encoding); + sv_recode_to_utf8(sv, _get_encoding()); } } @@ -824,11 +830,11 @@ S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping) if (RsPARA(PL_rs)) { if (*s != '\n') goto nope; - ++SvIVX(retval); + ++count; while (len && s[-1] == '\n') { --len; --s; - ++SvIVX(retval); + ++count; } } else { @@ -855,11 +861,11 @@ S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping) } rsptr = temp_buffer; } - else if (PL_encoding) { + else if (IN_ENCODING) { /* RS is 8 bit, encoding.pm is used. * Do not recode PL_rs as a side-effect. */ svrecode = newSVpvn(rsptr, rslen); - sv_recode_to_utf8(svrecode, PL_encoding); + sv_recode_to_utf8(svrecode, _get_encoding()); rsptr = SvPV_const(svrecode, rslen); rs_charlen = sv_len_utf8(svrecode); } @@ -872,7 +878,7 @@ S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping) if (rslen == 1) { if (*s != *rsptr) goto nope; - ++SvIVX(retval); + ++count; } else { if (len < rslen - 1) @@ -881,10 +887,10 @@ S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping) s -= rslen - 1; if (memNE(s, rsptr, rslen)) goto nope; - SvIVX(retval) += rs_charlen; + count += rs_charlen; } } - s = SvPV_force_nomg_nolen(sv); + SvPV_force_nomg_nolen(sv); SvCUR_set(sv, len); *SvEND(sv) = '\0'; SvNIOK_off(sv); @@ -896,7 +902,7 @@ S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping) Safefree(temp_buffer); } else { - if (len && !SvPOK(sv)) + if (len && (!SvPOK(sv) || SvIsCOW(sv))) s = SvPV_force_nomg(sv, len); if (DO_UTF8(sv)) { if (s && len) { @@ -928,29 +934,37 @@ S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping) sv_setpvs(retval, ""); SvSETMAGIC(sv); } + return count; } + +/* also used for: pp_schomp() */ + PP(pp_schop) { - dVAR; dSP; dTARGET; + dSP; dTARGET; const bool chomping = PL_op->op_type == OP_SCHOMP; + const size_t count = do_chomp(TARG, TOPs, chomping); if (chomping) - sv_setiv(TARG, 0); - do_chomp(TARG, TOPs, chomping); + sv_setiv(TARG, count); SETTARG; RETURN; } + +/* also used for: pp_chomp() */ + PP(pp_chop) { - dVAR; dSP; dMARK; dTARGET; dORIGMARK; + dSP; dMARK; dTARGET; dORIGMARK; const bool chomping = PL_op->op_type == OP_CHOMP; + size_t count = 0; - if (chomping) - sv_setiv(TARG, 0); while (MARK < SP) - do_chomp(TARG, *++MARK, chomping); + count += do_chomp(TARG, *++MARK, chomping); + if (chomping) + sv_setiv(TARG, count); SP = ORIGMARK; XPUSHTARG; RETURN; @@ -958,7 +972,7 @@ PP(pp_chop) PP(pp_undef) { - dVAR; dSP; + dSP; SV *sv; if (!PL_op->op_private) { @@ -970,7 +984,8 @@ PP(pp_undef) if (!sv) RETPUSHUNDEF; - SV_CHECK_THINKFIRST_COW_DROP(sv); + if (SvTHINKFIRST(sv)) + sv_force_normal_flags(sv, SV_COW_DROP_PV|SV_IMMEDIATE_UNREF); switch (SvTYPE(sv)) { case SVt_NULL: @@ -995,18 +1010,8 @@ PP(pp_undef) )); /* FALLTHROUGH */ case SVt_PVFM: - { /* let user-undef'd sub keep its identity */ - GV* const gv = CvGV((const CV *)sv); - HEK * const hek = CvNAME_HEK((CV *)sv); - if (hek) share_hek_hek(hek); - cv_undef(MUTABLE_CV(sv)); - if (gv) CvGV_set(MUTABLE_CV(sv), gv); - else if (hek) { - SvANY((CV *)sv)->xcv_gv_u.xcv_hek = hek; - CvNAMED_on(sv); - } - } + cv_undef_flags(MUTABLE_CV(sv), CV_UNDEF_KEEP_NAME); break; case SVt_PVGV: assert(isGV_with_GP(sv)); @@ -1065,9 +1070,12 @@ PP(pp_undef) RETPUSHUNDEF; } + +/* also used for: pp_i_postdec() pp_i_postinc() pp_postdec() */ + PP(pp_postinc) { - dVAR; dSP; dTARGET; + dSP; dTARGET; const bool inc = PL_op->op_type == OP_POSTINC || PL_op->op_type == OP_I_POSTINC; if (SvTYPE(TOPs) >= SVt_PVAV || (isGV_with_GP(TOPs) && !SvFAKE(TOPs))) @@ -1088,7 +1096,7 @@ PP(pp_postinc) /* special case for undef: see thread at 2003-03/msg00536.html in archive */ if (inc && !SvOK(TARG)) sv_setiv(TARG, 0); - SETs(TARG); + SETTARG; return NORMAL; } @@ -1096,7 +1104,7 @@ PP(pp_postinc) PP(pp_pow) { - dVAR; dSP; dATARGET; SV *svl, *svr; + dSP; dATARGET; SV *svl, *svr; #ifdef PERL_PRESERVE_IVUV bool is_int = 0; #endif @@ -1263,7 +1271,7 @@ PP(pp_pow) PP(pp_multiply) { - dVAR; dSP; dATARGET; SV *svl, *svr; + dSP; dATARGET; SV *svl, *svr; tryAMAGICbin_MG(mult_amg, AMGf_assign|AMGf_numeric); svr = TOPs; svl = TOPm1s; @@ -1385,7 +1393,7 @@ PP(pp_multiply) PP(pp_divide) { - dVAR; dSP; dATARGET; SV *svl, *svr; + dSP; dATARGET; SV *svl, *svr; tryAMAGICbin_MG(div_amg, AMGf_assign|AMGf_numeric); svr = TOPs; svl = TOPm1s; @@ -1505,7 +1513,7 @@ PP(pp_divide) PP(pp_modulo) { - dVAR; dSP; dATARGET; + dSP; dATARGET; tryAMAGICbin_MG(modulo_amg, AMGf_assign|AMGf_numeric); { UV left = 0; @@ -1632,7 +1640,7 @@ PP(pp_modulo) PP(pp_repeat) { - dVAR; dSP; dATARGET; + dSP; dATARGET; IV count; SV *sv; @@ -1642,6 +1650,25 @@ PP(pp_repeat) SvGETMAGIC(sv); } else { + if (UNLIKELY(PL_op->op_private & OPpREPEAT_DOLIST)) { + /* The parser saw this as a list repeat, and there + are probably several items on the stack. But we're + in scalar/void context, and there's no pp_list to save us + now. So drop the rest of the items -- robin@kitsite.com + */ + dMARK; + if (MARK + 1 < SP) { + MARK[1] = TOPm1s; + MARK[2] = TOPs; + } + else { + dTOPss; + ASSUME(MARK + 1 == SP); + XPUSHs(sv); + MARK[1] = &PL_sv_undef; + } + SP = MARK + 2; + } tryAMAGICbin_MG(repeat_amg, AMGf_assign); sv = POPs; } @@ -1654,23 +1681,25 @@ PP(pp_repeat) else count = uv; } else { - const IV iv = SvIV_nomg(sv); - if (iv < 0) - count = 0; - else - count = iv; + count = SvIV_nomg(sv); } } else if (SvNOKp(sv)) { const NV nv = SvNV_nomg(sv); if (nv < 0.0) - count = 0; + count = -1; /* An arbitrary negative integer */ else count = (IV)nv; } else count = SvIV_nomg(sv); + if (count < 0) { + count = 0; + Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC), + "Negative repeat count does nothing"); + } + if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) { dMARK; static const char* const oom_list_extend = "Out of memory during list extend"; @@ -1685,38 +1714,12 @@ PP(pp_repeat) MEXTEND(MARK, max); if (count > 1) { while (SP > MARK) { -#if 0 - /* This code was intended to fix 20010809.028: - - $x = 'abcd'; - for (($x =~ /./g) x 2) { - print chop; # "abcdabcd" expected as output. - } - - * but that change (#11635) broke this code: - - $x = [("foo")x2]; # only one "foo" ended up in the anonlist. - - * I can't think of a better fix that doesn't introduce - * an efficiency hit by copying the SVs. The stack isn't - * refcounted, and mortalisation obviously doesn't - * Do The Right Thing when the stack has more than - * one pointer to the same mortal value. - * .robin. - */ - if (*SP) { - *SP = sv_2mortal(newSVsv(*SP)); - SvREADONLY_on(*SP); - } -#else if (*SP) { if (mod && SvPADTMP(*SP)) { - assert(!IS_PADGV(*SP)); *SP = sv_mortalcopy(*SP); } SvTEMP_off((*SP)); } -#endif SP--; } MARK++; @@ -1757,15 +1760,6 @@ PP(pp_repeat) else (void)SvPOK_only(TARG); - if (PL_op->op_private & OPpREPEAT_DOLIST) { - /* The parser saw this as a list repeat, and there - are probably several items on the stack. But we're - in scalar context, and there's no pp_list to save us - now. So drop the rest of the items -- robin@kitsite.com - */ - dMARK; - SP = MARK; - } PUSHTARG; } RETURN; @@ -1773,7 +1767,7 @@ PP(pp_repeat) PP(pp_subtract) { - dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr; + dSP; dATARGET; bool useleft; SV *svl, *svr; tryAMAGICbin_MG(subtr_amg, AMGf_assign|AMGf_numeric); svr = TOPs; svl = TOPm1s; @@ -1892,7 +1886,7 @@ PP(pp_subtract) PP(pp_left_shift) { - dVAR; dSP; dATARGET; SV *svl, *svr; + dSP; dATARGET; SV *svl, *svr; tryAMAGICbin_MG(lshift_amg, AMGf_assign|AMGf_numeric); svr = POPs; svl = TOPs; @@ -1912,7 +1906,7 @@ PP(pp_left_shift) PP(pp_right_shift) { - dVAR; dSP; dATARGET; SV *svl, *svr; + dSP; dATARGET; SV *svl, *svr; tryAMAGICbin_MG(rshift_amg, AMGf_assign|AMGf_numeric); svr = POPs; svl = TOPs; @@ -1932,7 +1926,7 @@ PP(pp_right_shift) PP(pp_lt) { - dVAR; dSP; + dSP; SV *left, *right; tryAMAGICbin_MG(lt_amg, AMGf_set|AMGf_numeric); @@ -1948,7 +1942,7 @@ PP(pp_lt) PP(pp_gt) { - dVAR; dSP; + dSP; SV *left, *right; tryAMAGICbin_MG(gt_amg, AMGf_set|AMGf_numeric); @@ -1964,7 +1958,7 @@ PP(pp_gt) PP(pp_le) { - dVAR; dSP; + dSP; SV *left, *right; tryAMAGICbin_MG(le_amg, AMGf_set|AMGf_numeric); @@ -1980,7 +1974,7 @@ PP(pp_le) PP(pp_ge) { - dVAR; dSP; + dSP; SV *left, *right; tryAMAGICbin_MG(ge_amg, AMGf_set|AMGf_numeric); @@ -1996,7 +1990,7 @@ PP(pp_ge) PP(pp_ne) { - dVAR; dSP; + dSP; SV *left, *right; tryAMAGICbin_MG(ne_amg, AMGf_set|AMGf_numeric); @@ -2019,8 +2013,6 @@ PP(pp_ne) I32 Perl_do_ncmp(pTHX_ SV* const left, SV * const right) { - dVAR; - PERL_ARGS_ASSERT_DO_NCMP; #ifdef PERL_PRESERVE_IVUV /* Fortunately it seems NaN isn't IOK */ @@ -2086,7 +2078,7 @@ Perl_do_ncmp(pTHX_ SV* const left, SV * const right) PP(pp_ncmp) { - dVAR; dSP; + dSP; SV *left, *right; I32 value; tryAMAGICbin_MG(ncmp_amg, AMGf_numeric); @@ -2103,9 +2095,12 @@ PP(pp_ncmp) RETURN; } + +/* also used for: pp_sge() pp_sgt() pp_slt() */ + PP(pp_sle) { - dVAR; dSP; + dSP; int amg_type = sle_amg; int multiplier = 1; @@ -2134,7 +2129,7 @@ PP(pp_sle) { dPOPTOPssrl; const int cmp = -#ifdef USE_LC_COLLATE +#ifdef USE_LOCALE_COLLATE (IN_LC_RUNTIME(LC_COLLATE)) ? sv_cmp_locale_flags(left, right, 0) : @@ -2147,7 +2142,7 @@ PP(pp_sle) PP(pp_seq) { - dVAR; dSP; + dSP; tryAMAGICbin_MG(seq_amg, AMGf_set); { dPOPTOPssrl; @@ -2158,7 +2153,7 @@ PP(pp_seq) PP(pp_sne) { - dVAR; dSP; + dSP; tryAMAGICbin_MG(sne_amg, AMGf_set); { dPOPTOPssrl; @@ -2169,12 +2164,12 @@ PP(pp_sne) PP(pp_scmp) { - dVAR; dSP; dTARGET; + dSP; dTARGET; tryAMAGICbin_MG(scmp_amg, 0); { dPOPTOPssrl; const int cmp = -#ifdef USE_LC_COLLATE +#ifdef USE_LOCALE_COLLATE (IN_LC_RUNTIME(LC_COLLATE)) ? sv_cmp_locale_flags(left, right, 0) : @@ -2187,7 +2182,7 @@ PP(pp_scmp) PP(pp_bit_and) { - dVAR; dSP; dATARGET; + dSP; dATARGET; tryAMAGICbin_MG(band_amg, AMGf_assign); { dPOPTOPssrl; @@ -2213,9 +2208,12 @@ PP(pp_bit_and) } } + +/* also used for: pp_bit_xor() */ + PP(pp_bit_or) { - dVAR; dSP; dATARGET; + dSP; dATARGET; const int op_type = PL_op->op_type; tryAMAGICbin_MG((op_type == OP_BIT_OR ? bor_amg : bxor_amg), AMGf_assign); @@ -2272,7 +2270,7 @@ S_negate_string(pTHX) PP(pp_negate) { - dVAR; dSP; dTARGET; + dSP; dTARGET; tryAMAGICun_MG(neg_amg, AMGf_numeric); if (S_negate_string(aTHX)) return NORMAL; { @@ -2316,7 +2314,7 @@ PP(pp_negate) PP(pp_not) { - dVAR; dSP; + dSP; tryAMAGICun_MG(not_amg, AMGf_set); *PL_stack_sp = boolSV(!SvTRUE_nomg(*PL_stack_sp)); return NORMAL; @@ -2324,7 +2322,7 @@ PP(pp_not) PP(pp_complement) { - dVAR; dSP; dTARGET; + dSP; dTARGET; tryAMAGICun_MG(compl_amg, AMGf_numeric); { dTOPss; @@ -2425,7 +2423,7 @@ PP(pp_complement) PP(pp_i_multiply) { - dVAR; dSP; dATARGET; + dSP; dATARGET; tryAMAGICbin_MG(mult_amg, AMGf_assign); { dPOPTOPiirl_nomg; @@ -2437,7 +2435,7 @@ PP(pp_i_multiply) PP(pp_i_divide) { IV num; - dVAR; dSP; dATARGET; + dSP; dATARGET; tryAMAGICbin_MG(div_amg, AMGf_assign); { dPOPTOPssrl; @@ -2464,7 +2462,7 @@ PP(pp_i_modulo) #endif { /* This is the vanilla old i_modulo. */ - dVAR; dSP; dATARGET; + dSP; dATARGET; tryAMAGICbin_MG(modulo_amg, AMGf_assign); { dPOPTOPiirl_nomg; @@ -2487,7 +2485,7 @@ PP(pp_i_modulo_1) /* This is the i_modulo with the workaround for the _moddi3 bug * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround). * See below for pp_i_modulo. */ - dVAR; dSP; dATARGET; + dSP; dATARGET; tryAMAGICbin_MG(modulo_amg, AMGf_assign); { dPOPTOPiirl_nomg; @@ -2548,7 +2546,7 @@ PP(pp_i_modulo) PP(pp_i_add) { - dVAR; dSP; dATARGET; + dSP; dATARGET; tryAMAGICbin_MG(add_amg, AMGf_assign); { dPOPTOPiirl_ul_nomg; @@ -2559,7 +2557,7 @@ PP(pp_i_add) PP(pp_i_subtract) { - dVAR; dSP; dATARGET; + dSP; dATARGET; tryAMAGICbin_MG(subtr_amg, AMGf_assign); { dPOPTOPiirl_ul_nomg; @@ -2570,7 +2568,7 @@ PP(pp_i_subtract) PP(pp_i_lt) { - dVAR; dSP; + dSP; tryAMAGICbin_MG(lt_amg, AMGf_set); { dPOPTOPiirl_nomg; @@ -2581,7 +2579,7 @@ PP(pp_i_lt) PP(pp_i_gt) { - dVAR; dSP; + dSP; tryAMAGICbin_MG(gt_amg, AMGf_set); { dPOPTOPiirl_nomg; @@ -2592,7 +2590,7 @@ PP(pp_i_gt) PP(pp_i_le) { - dVAR; dSP; + dSP; tryAMAGICbin_MG(le_amg, AMGf_set); { dPOPTOPiirl_nomg; @@ -2603,7 +2601,7 @@ PP(pp_i_le) PP(pp_i_ge) { - dVAR; dSP; + dSP; tryAMAGICbin_MG(ge_amg, AMGf_set); { dPOPTOPiirl_nomg; @@ -2614,7 +2612,7 @@ PP(pp_i_ge) PP(pp_i_eq) { - dVAR; dSP; + dSP; tryAMAGICbin_MG(eq_amg, AMGf_set); { dPOPTOPiirl_nomg; @@ -2625,7 +2623,7 @@ PP(pp_i_eq) PP(pp_i_ne) { - dVAR; dSP; + dSP; tryAMAGICbin_MG(ne_amg, AMGf_set); { dPOPTOPiirl_nomg; @@ -2636,7 +2634,7 @@ PP(pp_i_ne) PP(pp_i_ncmp) { - dVAR; dSP; dTARGET; + dSP; dTARGET; tryAMAGICbin_MG(ncmp_amg, 0); { dPOPTOPiirl_nomg; @@ -2655,7 +2653,7 @@ PP(pp_i_ncmp) PP(pp_i_negate) { - dVAR; dSP; dTARGET; + dSP; dTARGET; tryAMAGICun_MG(neg_amg, 0); if (S_negate_string(aTHX)) return NORMAL; { @@ -2670,7 +2668,7 @@ PP(pp_i_negate) PP(pp_atan2) { - dVAR; dSP; dTARGET; + dSP; dTARGET; tryAMAGICbin_MG(atan2_amg, 0); { dPOPTOPnnrl_nomg; @@ -2679,48 +2677,51 @@ PP(pp_atan2) } } + +/* also used for: pp_cos() pp_exp() pp_log() pp_sqrt() */ + PP(pp_sin) { - dVAR; dSP; dTARGET; - int amg_type = sin_amg; + dSP; dTARGET; + int amg_type = fallback_amg; const char *neg_report = NULL; - NV (*func)(NV) = Perl_sin; const int op_type = PL_op->op_type; switch (op_type) { - case OP_COS: - amg_type = cos_amg; - func = Perl_cos; - break; - case OP_EXP: - amg_type = exp_amg; - func = Perl_exp; - break; - case OP_LOG: - amg_type = log_amg; - func = Perl_log; - neg_report = "log"; - break; - case OP_SQRT: - amg_type = sqrt_amg; - func = Perl_sqrt; - neg_report = "sqrt"; - break; + case OP_SIN: amg_type = sin_amg; break; + case OP_COS: amg_type = cos_amg; break; + case OP_EXP: amg_type = exp_amg; break; + case OP_LOG: amg_type = log_amg; neg_report = "log"; break; + case OP_SQRT: amg_type = sqrt_amg; neg_report = "sqrt"; break; } + assert(amg_type != fallback_amg); tryAMAGICun_MG(amg_type, 0); { SV * const arg = POPs; const NV value = SvNV_nomg(arg); - if (neg_report) { - if (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0)) { + NV result = NV_NAN; + if (neg_report) { /* log or sqrt */ + if ( +#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan) + ! Perl_isnan(value) && +#endif + (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0))) { SET_NUMERIC_STANDARD(); /* diag_listed_as: Can't take log of %g */ DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value); } } - XPUSHn(func(value)); + switch (op_type) { + default: + case OP_SIN: result = Perl_sin(value); break; + case OP_COS: result = Perl_cos(value); break; + case OP_EXP: result = Perl_exp(value); break; + case OP_LOG: result = Perl_log(value); break; + case OP_SQRT: result = Perl_sqrt(value); break; + } + XPUSHn(result); RETURN; } } @@ -2738,7 +2739,6 @@ PP(pp_sin) PP(pp_rand) { - dVAR; if (!PL_srand_called) { (void)seedDrand01((Rand_seed_t)seed()); PL_srand_called = TRUE; @@ -2758,7 +2758,11 @@ PP(pp_rand) value = SvNV(sv); } /* 1 of 2 things can be carried through SvNV, SP or TARG, SP was carried */ +#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan) + if (! Perl_isnan(value) && value == 0.0) +#else if (value == 0.0) +#endif value = 1.0; { dTARGET; @@ -2773,7 +2777,7 @@ PP(pp_rand) PP(pp_srand) { - dVAR; dSP; dTARGET; + dSP; dTARGET; UV anum; if (MAXARG >= 1 && (TOPs || POPs)) { @@ -2811,7 +2815,7 @@ PP(pp_srand) PP(pp_int) { - dVAR; dSP; dTARGET; + dSP; dTARGET; tryAMAGICun_MG(int_amg, AMGf_numeric); { SV * const sv = TOPs; @@ -2832,7 +2836,9 @@ PP(pp_int) } else { const NV value = SvNV_nomg(sv); - if (value >= 0.0) { + if (SvNOK(sv) && UNLIKELY(Perl_isinfnan(SvNV(sv)))) + SETn(SvNV(sv)); + else if (value >= 0.0) { if (value < (NV)UV_MAX + 0.5) { SETu(U_V(value)); } else { @@ -2853,7 +2859,7 @@ PP(pp_int) PP(pp_abs) { - dVAR; dSP; dTARGET; + dSP; dTARGET; tryAMAGICun_MG(abs_amg, AMGf_numeric); { SV * const sv = TOPs; @@ -2891,9 +2897,12 @@ PP(pp_abs) RETURN; } + +/* also used for: pp_hex() */ + PP(pp_oct) { - dVAR; dSP; dTARGET; + dSP; dTARGET; const char *tmps; I32 flags = PERL_SCAN_ALLOW_UNDERSCORES; STRLEN len; @@ -2918,11 +2927,11 @@ PP(pp_oct) tmps++, len--; if (*tmps == '0') tmps++, len--; - if (*tmps == 'x' || *tmps == 'X') { + if (isALPHA_FOLD_EQ(*tmps, 'x')) { hex: result_uv = grok_hex (tmps, &len, &flags, &result_nv); } - else if (*tmps == 'b' || *tmps == 'B') + else if (isALPHA_FOLD_EQ(*tmps, 'b')) result_uv = grok_bin (tmps, &len, &flags, &result_nv); else result_uv = grok_oct (tmps, &len, &flags, &result_nv); @@ -2940,27 +2949,48 @@ PP(pp_oct) PP(pp_length) { - dVAR; dSP; dTARGET; + dSP; dTARGET; SV * const sv = TOPs; - SvGETMAGIC(sv); + U32 in_bytes = IN_BYTES; + /* simplest case shortcut */ + /* turn off SVf_UTF8 in tmp flags if HINT_BYTES on*/ + U32 svflags = (SvFLAGS(sv) ^ (in_bytes << 26)) & (SVf_POK|SVs_GMG|SVf_UTF8); + assert(HINT_BYTES == 0x00000008 && SVf_UTF8 == 0x20000000 && (SVf_UTF8 == HINT_BYTES << 26)); + SETs(TARG); + + if(LIKELY(svflags == SVf_POK)) + goto simple_pv; + if(svflags & SVs_GMG) + mg_get(sv); if (SvOK(sv)) { - if (!IN_BYTES) - SETi(sv_len_utf8_nomg(sv)); + if (!IN_BYTES) /* reread to avoid using an C auto/register */ + sv_setiv(TARG, (IV)sv_len_utf8_nomg(sv)); else { STRLEN len; - (void)SvPV_nomg_const(sv,len); - SETi(len); + /* unrolled SvPV_nomg_const(sv,len) */ + if(SvPOK_nog(sv)){ + simple_pv: + len = SvCUR(sv); + } else { + (void)sv_2pv_flags(sv, &len, 0|SV_CONST_RETURN); + } + sv_setiv(TARG, (IV)(len)); } } else { if (!SvPADTMP(TARG)) { sv_setsv_nomg(TARG, &PL_sv_undef); - SETTARG; - } - SETs(&PL_sv_undef); + } else { /* TARG is on stack at this point and is overwriten by SETs. + This branch is the odd one out, so put TARG by default on + stack earlier to let local SP go out of liveness sooner */ + SETs(&PL_sv_undef); + goto no_set_magic; + } } - RETURN; + SvSETMAGIC(TARG); + no_set_magic: + return NORMAL; /* no putback, SP didn't move in this opcode */ } /* Returns false if substring is completely outside original string. @@ -2968,16 +2998,15 @@ PP(pp_length) always be true for an explicit 0. */ bool -Perl_translate_substr_offsets(pTHX_ STRLEN curlen, IV pos1_iv, - bool pos1_is_uv, IV len_iv, - bool len_is_uv, STRLEN *posp, - STRLEN *lenp) +Perl_translate_substr_offsets( STRLEN curlen, IV pos1_iv, + bool pos1_is_uv, IV len_iv, + bool len_is_uv, STRLEN *posp, + STRLEN *lenp) { IV pos2_iv; int pos2_is_uv; PERL_ARGS_ASSERT_TRANSLATE_SUBSTR_OFFSETS; - PERL_UNUSED_CONTEXT; if (!pos1_is_uv && pos1_iv < 0 && curlen) { pos1_is_uv = curlen-1 > ~(UV)pos1_iv; @@ -3033,7 +3062,7 @@ Perl_translate_substr_offsets(pTHX_ STRLEN curlen, IV pos1_iv, PP(pp_substr) { - dVAR; dSP; dTARGET; + dSP; dTARGET; SV *sv; STRLEN curlen; STRLEN utf8_curlen; @@ -3157,7 +3186,9 @@ PP(pp_substr) } } SPAGAIN; - if (rvalue) { + if (PL_op->op_private & OPpSUBSTR_REPL_FIRST) + SP++; + else if (rvalue) { SvSETMAGIC(TARG); PUSHs(TARG); } @@ -3172,7 +3203,7 @@ bound_fail: PP(pp_vec) { - dVAR; dSP; + dSP; const IV size = POPi; const IV offset = POPi; SV * const src = POPs; @@ -3194,13 +3225,18 @@ PP(pp_vec) } sv_setuv(ret, do_vecget(src, offset, size)); + if (!lvalue) + SvSETMAGIC(ret); PUSHs(ret); RETURN; } + +/* also used for: pp_rindex() */ + PP(pp_index) { - dVAR; dSP; dTARGET; + dSP; dTARGET; SV *big; SV *little; SV *temp = NULL; @@ -3226,7 +3262,7 @@ PP(pp_index) little_utf8 = DO_UTF8(little); if (big_utf8 ^ little_utf8) { /* One needs to be upgraded. */ - if (little_utf8 && !PL_encoding) { + if (little_utf8 && !IN_ENCODING) { /* Well, maybe instead we might be able to downgrade the small string? */ char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen, @@ -3248,8 +3284,8 @@ PP(pp_index) temp = little_utf8 ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen); - if (PL_encoding) { - sv_recode_to_utf8(temp, PL_encoding); + if (IN_ENCODING) { + sv_recode_to_utf8(temp, _get_encoding()); } else { sv_utf8_upgrade(temp); } @@ -3317,7 +3353,7 @@ PP(pp_index) PP(pp_sprintf) { - dVAR; dSP; dMARK; dORIGMARK; dTARGET; + dSP; dMARK; dORIGMARK; dTARGET; SvTAINTED_off(TARG); do_sprintf(TARG, SP-MARK, MARK+1); TAINT_IF(SvTAINTED(TARG)); @@ -3328,15 +3364,15 @@ PP(pp_sprintf) PP(pp_ord) { - dVAR; dSP; dTARGET; + dSP; dTARGET; SV *argsv = POPs; STRLEN len; const U8 *s = (U8*)SvPV_const(argsv, len); - if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) { + if (IN_ENCODING && SvPOK(argsv) && !DO_UTF8(argsv)) { SV * const tmpsv = sv_2mortal(newSVsv(argsv)); - s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding); + s = (U8*)sv_recode_to_utf8(tmpsv, _get_encoding()); len = UTF8SKIP(s); /* Should be well-formed; so this is its length */ argsv = tmpsv; } @@ -3350,29 +3386,33 @@ PP(pp_ord) PP(pp_chr) { - dVAR; dSP; dTARGET; + dSP; dTARGET; char *tmps; UV value; SV *top = POPs; SvGETMAGIC(top); - if (!IN_BYTES /* under bytes, chr(-1) eq chr(0xff), etc. */ - && ((SvIOKp(top) && !SvIsUV(top) && SvIV_nomg(top) < 0) - || - ((SvNOKp(top) || (SvOK(top) && !SvIsUV(top))) - && SvNV_nomg(top) < 0.0))) { + if (UNLIKELY(isinfnansv(top))) + Perl_croak(aTHX_ "Cannot chr %"NVgf, SvNV(top)); + else { + if (!IN_BYTES /* under bytes, chr(-1) eq chr(0xff), etc. */ + && ((SvIOKp(top) && !SvIsUV(top) && SvIV_nomg(top) < 0) + || + ((SvNOKp(top) || (SvOK(top) && !SvIsUV(top))) + && SvNV_nomg(top) < 0.0))) { if (ckWARN(WARN_UTF8)) { if (SvGMAGICAL(top)) { SV *top2 = sv_newmortal(); sv_setsv_nomg(top2, top); top = top2; } - Perl_warner(aTHX_ packWARN(WARN_UTF8), - "Invalid negative number (%"SVf") in chr", SVfARG(top)); - } - value = UNICODE_REPLACEMENT; - } else { - value = SvUV_nomg(top); + Perl_warner(aTHX_ packWARN(WARN_UTF8), + "Invalid negative number (%"SVf") in chr", SVfARG(top)); + } + value = UNICODE_REPLACEMENT; + } else { + value = SvUV_nomg(top); + } } SvUPGRADE(TARG,SVt_PV); @@ -3384,7 +3424,7 @@ PP(pp_chr) *tmps = '\0'; (void)SvPOK_only(TARG); SvUTF8_on(TARG); - XPUSHs(TARG); + XPUSHTARG; RETURN; } @@ -3395,8 +3435,8 @@ PP(pp_chr) *tmps = '\0'; (void)SvPOK_only(TARG); - if (PL_encoding && !IN_BYTES) { - sv_recode_to_utf8(TARG, PL_encoding); + if (IN_ENCODING && !IN_BYTES) { + sv_recode_to_utf8(TARG, _get_encoding()); tmps = SvPVX(TARG); if (SvCUR(TARG) == 0 || ! is_utf8_string((U8*)tmps, SvCUR(TARG)) @@ -3411,14 +3451,14 @@ PP(pp_chr) } } - XPUSHs(TARG); + XPUSHTARG; RETURN; } PP(pp_crypt) { #ifdef HAS_CRYPT - dVAR; dSP; dTARGET; + dSP; dTARGET; dPOPTOPssrl; STRLEN len; const char *tmps = SvPV_const(left, len); @@ -3427,9 +3467,8 @@ PP(pp_crypt) /* If Unicode, try to downgrade. * If not possible, croak. * Yes, we made this up. */ - SV* const tsv = sv_2mortal(newSVsv(left)); + SV* const tsv = newSVpvn_flags(tmps, len, SVf_UTF8|SVs_TEMP); - SvUTF8_on(tsv); sv_utf8_downgrade(tsv, FALSE); tmps = SvPV_const(tsv, len); } @@ -3456,6 +3495,7 @@ PP(pp_crypt) # else sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right))); # endif + SvUTF8_off(TARG); SETTARG; RETURN; #else @@ -3467,6 +3507,9 @@ PP(pp_crypt) /* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level. So * most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */ + +/* also used for: pp_lcfirst() */ + PP(pp_ucfirst) { /* Actually is both lcfirst() and ucfirst(). Only the first character @@ -3474,7 +3517,6 @@ PP(pp_ucfirst) * take the source and change that one character and store it back, but not * if read-only etc, or if the length changes */ - dVAR; dSP; SV *source = TOPs; STRLEN slen; /* slen is the byte length of the whole SV. */ @@ -3727,7 +3769,6 @@ PP(pp_ucfirst) of the three tight loops. There is less and less commonality though */ PP(pp_uc) { - dVAR; dSP; SV *source = TOPs; STRLEN len; @@ -3982,7 +4023,6 @@ PP(pp_uc) PP(pp_lc) { - dVAR; dSP; SV *source = TOPs; STRLEN len; @@ -4109,7 +4149,7 @@ PP(pp_lc) PP(pp_quotemeta) { - dVAR; dSP; dTARGET; + dSP; dTARGET; SV * const sv = TOPs; STRLEN len; const char *s = SvPV_const(sv,len); @@ -4131,15 +4171,18 @@ PP(pp_quotemeta) } } else if (UTF8_IS_DOWNGRADEABLE_START(*s)) { + if ( #ifdef USE_LOCALE_CTYPE /* In locale, we quote all non-ASCII Latin1 chars. * Otherwise use the quoting rules */ - if (IN_LC_RUNTIME(LC_CTYPE) - || _isQUOTEMETA(TWO_BYTE_UTF8_TO_NATIVE(*s, *(s + 1)))) + + IN_LC_RUNTIME(LC_CTYPE) + || +#endif + _isQUOTEMETA(TWO_BYTE_UTF8_TO_NATIVE(*s, *(s + 1)))) { to_quote = TRUE; } -#endif } else if (is_QUOTEMETA_high(s)) { to_quote = TRUE; @@ -4184,7 +4227,6 @@ PP(pp_quotemeta) PP(pp_fc) { - dVAR; dTARGET; dSP; SV *source = TOPs; @@ -4195,7 +4237,8 @@ PP(pp_fc) const U8 *send; U8 *d; U8 tmpbuf[UTF8_MAXBYTES_CASE + 1]; - const bool full_folding = TRUE; + const bool full_folding = TRUE; /* This variable is here so we can easily + move to more generality later */ const U8 flags = ( full_folding ? FOLD_FLAGS_FULL : 0 ) #ifdef USE_LOCALE_CTYPE | ( IN_LC_RUNTIME(LC_CTYPE) ? FOLD_FLAGS_LOCALE : 0 ) @@ -4348,7 +4391,7 @@ PP(pp_fc) PP(pp_aslice) { - dVAR; dSP; dMARK; dORIGMARK; + dSP; dMARK; dORIGMARK; AV *const av = MUTABLE_AV(POPs); const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET); @@ -4412,7 +4455,7 @@ PP(pp_aslice) PP(pp_kvaslice) { - dVAR; dSP; dMARK; + dSP; dMARK; AV *const av = MUTABLE_AV(POPs); I32 lval = (PL_op->op_flags & OPf_MOD); SSize_t items = SP - MARK; @@ -4455,10 +4498,13 @@ PP(pp_kvaslice) RETURN; } + /* Smart dereferencing for keys, values and each */ + +/* also used for: pp_reach() pp_rvalues() */ + PP(pp_rkeys) { - dVAR; dSP; dPOPss; @@ -4496,7 +4542,6 @@ PP(pp_rkeys) PP(pp_aeach) { - dVAR; dSP; AV *array = MUTABLE_AV(POPs); const I32 gimme = GIMME_V; @@ -4520,9 +4565,9 @@ PP(pp_aeach) RETURN; } +/* also used for: pp_avalues()*/ PP(pp_akeys) { - dVAR; dSP; AV *array = MUTABLE_AV(POPs); const I32 gimme = GIMME_V; @@ -4558,7 +4603,6 @@ PP(pp_akeys) PP(pp_each) { - dVAR; dSP; HV * hash = MUTABLE_HV(POPs); HE *entry; @@ -4591,7 +4635,6 @@ PP(pp_each) STATIC OP * S_do_delete_local(pTHX) { - dVAR; dSP; const I32 gimme = GIMME_V; const MAGIC *mg; @@ -4702,7 +4745,6 @@ S_do_delete_local(pTHX) PP(pp_delete) { - dVAR; dSP; I32 gimme; I32 discard; @@ -4768,7 +4810,6 @@ PP(pp_delete) PP(pp_exists) { - dVAR; dSP; SV *tmpsv; HV *hv; @@ -4803,7 +4844,7 @@ PP(pp_exists) PP(pp_hslice) { - dVAR; dSP; dMARK; dORIGMARK; + dSP; dMARK; dORIGMARK; HV * const hv = MUTABLE_HV(POPs); const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET); const bool localizing = PL_op->op_private & OPpLVAL_INTRO; @@ -4860,7 +4901,7 @@ PP(pp_hslice) PP(pp_kvhslice) { - dVAR; dSP; dMARK; + dSP; dMARK; HV * const hv = MUTABLE_HV(POPs); I32 lval = (PL_op->op_flags & OPf_MOD); SSize_t items = SP - MARK; @@ -4911,7 +4952,6 @@ PP(pp_kvhslice) PP(pp_list) { - dVAR; I32 markidx = POPMARK; if (GIMME != G_ARRAY) { SV **mark = PL_stack_base + markidx; @@ -4928,7 +4968,6 @@ PP(pp_list) PP(pp_lslice) { - dVAR; dSP; SV ** const lastrelem = PL_stack_sp; SV ** const lastlelem = PL_stack_base + POPMARK; @@ -4968,7 +5007,6 @@ PP(pp_lslice) if (!(*lelem = firstrelem[ix])) *lelem = &PL_sv_undef; else if (mod && SvPADTMP(*lelem)) { - assert(!IS_PADGV(*lelem)); *lelem = firstrelem[ix] = sv_mortalcopy(*lelem); } } @@ -4982,7 +5020,7 @@ PP(pp_lslice) PP(pp_anonlist) { - dVAR; dSP; dMARK; + dSP; dMARK; const I32 items = SP - MARK; SV * const av = MUTABLE_SV(av_make(items, MARK+1)); SP = MARK; @@ -4993,7 +5031,7 @@ PP(pp_anonlist) PP(pp_anonhash) { - dVAR; dSP; dMARK; dORIGMARK; + dSP; dMARK; dORIGMARK; HV* const hv = newHV(); SV* const retval = sv_2mortal( PL_op->op_flags & OPf_SPECIAL ? newRV_noinc(MUTABLE_SV(hv)) @@ -5054,7 +5092,7 @@ S_deref_plain_array(pTHX_ AV *ary) PP(pp_splice) { - dVAR; dSP; dMARK; dORIGMARK; + dSP; dMARK; dORIGMARK; int num_args = (SP - MARK); AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK)); SV **src; @@ -5264,7 +5302,7 @@ PP(pp_splice) PP(pp_push) { - dVAR; dSP; dMARK; dORIGMARK; dTARGET; + dSP; dMARK; dORIGMARK; dTARGET; AV * const ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK)); const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied); @@ -5300,9 +5338,9 @@ PP(pp_push) RETURN; } +/* also used for: pp_pop()*/ PP(pp_shift) { - dVAR; dSP; AV * const av = PL_op->op_flags & OPf_SPECIAL ? MUTABLE_AV(GvAV(PL_defgv)) : DEREF_PLAIN_ARRAY(MUTABLE_AV(POPs)); @@ -5317,7 +5355,7 @@ PP(pp_shift) PP(pp_unshift) { - dVAR; dSP; dMARK; dORIGMARK; dTARGET; + dSP; dMARK; dORIGMARK; dTARGET; AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK)); const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied); @@ -5347,7 +5385,7 @@ PP(pp_unshift) PP(pp_reverse) { - dVAR; dSP; dMARK; + dSP; dMARK; if (GIMME == G_ARRAY) { if (PL_op->op_private & OPpREVERSE_INPLACE) { @@ -5478,8 +5516,8 @@ PP(pp_reverse) PP(pp_split) { - dVAR; dSP; dTARG; - AV *ary; + dSP; dTARG; + AV *ary = PL_op->op_flags & OPf_STACKED ? (AV *)POPs : NULL; IV limit = POPi; /* note, negative is forever */ SV * const sv = POPs; STRLEN len; @@ -5512,7 +5550,7 @@ PP(pp_split) #else pm = (PMOP*)POPs; #endif - if (!pm || !s) + if (!pm) DIE(aTHX_ "panic: pp_split, pm=%p, s=%p", pm, s); rx = PM_GETRE(pm); @@ -5528,12 +5566,13 @@ PP(pp_split) ary = GvAVn(pm->op_pmreplrootu.op_pmtargetgv); } #endif - else - ary = NULL; + else if (pm->op_targ) + ary = (AV *)PAD_SVl(pm->op_targ); if (ary) { realarray = 1; PUTBACK; av_extend(ary,0); + (void)sv_2mortal(SvREFCNT_inc_simple_NN(sv)); av_clear(ary); SPAGAIN; if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) { @@ -5922,7 +5961,6 @@ PP(pp_once) PP(pp_lock) { - dVAR; dSP; dTOPss; SV *retsv = sv; @@ -5936,9 +5974,11 @@ PP(pp_lock) } +/* used for: pp_padany(), pp_mapstart(), pp_custom(); plus any system ops + * that aren't implemented on a particular platform */ + PP(unimplemented_op) { - dVAR; const Optype op_type = PL_op->op_type; /* Using OP_NAME() isn't going to be helpful here. Firstly, it doesn't cope with out of range op numbers - it only "special" cases op_custom. @@ -6111,6 +6151,210 @@ PP(pp_runcv) RETURN; } +static void +S_localise_aelem_lval(pTHX_ AV * const av, SV * const keysv, + const bool can_preserve) +{ + const SSize_t ix = SvIV(keysv); + if (can_preserve ? av_exists(av, ix) : TRUE) { + SV ** const svp = av_fetch(av, ix, 1); + if (!svp || !*svp) + Perl_croak(aTHX_ PL_no_aelem, ix); + save_aelem(av, ix, svp); + } + else + SAVEADELETE(av, ix); +} + +static void +S_localise_helem_lval(pTHX_ HV * const hv, SV * const keysv, + const bool can_preserve) +{ + if (can_preserve ? hv_exists_ent(hv, keysv, 0) : TRUE) { + HE * const he = hv_fetch_ent(hv, keysv, 1, 0); + SV ** const svp = he ? &HeVAL(he) : NULL; + if (!svp || !*svp) + Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(keysv)); + save_helem_flags(hv, keysv, svp, 0); + } + else + SAVEHDELETE(hv, keysv); +} + +static void +S_localise_gv_slot(pTHX_ GV *gv, U8 type) +{ + if (type == OPpLVREF_SV) { + save_pushptrptr(gv, SvREFCNT_inc_simple(GvSV(gv)), SAVEt_GVSV); + GvSV(gv) = 0; + } + else if (type == OPpLVREF_AV) + /* XXX Inefficient, as it creates a new AV, which we are + about to clobber. */ + save_ary(gv); + else { + assert(type == OPpLVREF_HV); + /* XXX Likewise inefficient. */ + save_hash(gv); + } +} + + +PP(pp_refassign) +{ + dSP; + SV * const key = PL_op->op_private & OPpLVREF_ELEM ? POPs : NULL; + SV * const left = PL_op->op_flags & OPf_STACKED ? POPs : NULL; + dTOPss; + const char *bad = NULL; + const U8 type = PL_op->op_private & OPpLVREF_TYPE; + if (!SvROK(sv)) DIE(aTHX_ "Assigned value is not a reference"); + switch (type) { + case OPpLVREF_SV: + if (SvTYPE(SvRV(sv)) > SVt_PVLV) + bad = " SCALAR"; + break; + case OPpLVREF_AV: + if (SvTYPE(SvRV(sv)) != SVt_PVAV) + bad = "n ARRAY"; + break; + case OPpLVREF_HV: + if (SvTYPE(SvRV(sv)) != SVt_PVHV) + bad = " HASH"; + break; + case OPpLVREF_CV: + if (SvTYPE(SvRV(sv)) != SVt_PVCV) + bad = " CODE"; + } + if (bad) + /* diag_listed_as: Assigned value is not %s reference */ + DIE(aTHX_ "Assigned value is not a%s reference", bad); + switch (left ? SvTYPE(left) : 0) { + MAGIC *mg; + HV *stash; + case 0: + { + SV * const old = PAD_SV(ARGTARG); + PAD_SETSV(ARGTARG, SvREFCNT_inc_NN(SvRV(sv))); + SvREFCNT_dec(old); + if ((PL_op->op_private & (OPpLVAL_INTRO|OPpPAD_STATE)) + == OPpLVAL_INTRO) + SAVECLEARSV(PAD_SVl(ARGTARG)); + break; + } + case SVt_PVGV: + if (PL_op->op_private & OPpLVAL_INTRO) { + S_localise_gv_slot(aTHX_ (GV *)left, type); + } + gv_setref(left, sv); + SvSETMAGIC(left); + break; + case SVt_PVAV: + if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) { + S_localise_aelem_lval(aTHX_ (AV *)left, key, + SvCANEXISTDELETE(left)); + } + av_store((AV *)left, SvIV(key), SvREFCNT_inc_simple_NN(SvRV(sv))); + break; + case SVt_PVHV: + if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) + S_localise_helem_lval(aTHX_ (HV *)left, key, + SvCANEXISTDELETE(left)); + (void)hv_store_ent((HV *)left, key, SvREFCNT_inc_simple_NN(SvRV(sv)), 0); + } + if (PL_op->op_flags & OPf_MOD) + SETs(sv_2mortal(newSVsv(sv))); + /* XXX else can weak references go stale before they are read, e.g., + in leavesub? */ + RETURN; +} + +PP(pp_lvref) +{ + dSP; + SV * const ret = sv_2mortal(newSV_type(SVt_PVMG)); + SV * const elem = PL_op->op_private & OPpLVREF_ELEM ? POPs : NULL; + SV * const arg = PL_op->op_flags & OPf_STACKED ? POPs : NULL; + MAGIC * const mg = sv_magicext(ret, arg, PERL_MAGIC_lvref, + &PL_vtbl_lvref, (char *)elem, + elem ? HEf_SVKEY : (I32)ARGTARG); + mg->mg_private = PL_op->op_private; + if (PL_op->op_private & OPpLVREF_ITER) + mg->mg_flags |= MGf_PERSIST; + if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) { + if (elem) { + MAGIC *mg; + HV *stash; + const bool can_preserve = SvCANEXISTDELETE(arg); + if (SvTYPE(arg) == SVt_PVAV) + S_localise_aelem_lval(aTHX_ (AV *)arg, elem, can_preserve); + else + S_localise_helem_lval(aTHX_ (HV *)arg, elem, can_preserve); + } + else if (arg) { + S_localise_gv_slot(aTHX_ (GV *)arg, + PL_op->op_private & OPpLVREF_TYPE); + } + else if (!(PL_op->op_private & OPpPAD_STATE)) + SAVECLEARSV(PAD_SVl(ARGTARG)); + } + XPUSHs(ret); + RETURN; +} + +PP(pp_lvrefslice) +{ + dSP; dMARK; + AV * const av = (AV *)POPs; + const bool localizing = PL_op->op_private & OPpLVAL_INTRO; + bool can_preserve = FALSE; + + if (UNLIKELY(localizing)) { + MAGIC *mg; + HV *stash; + SV **svp; + + can_preserve = SvCANEXISTDELETE(av); + + if (SvTYPE(av) == SVt_PVAV) { + SSize_t max = -1; + + for (svp = MARK + 1; svp <= SP; svp++) { + const SSize_t elem = SvIV(*svp); + if (elem > max) + max = elem; + } + if (max > AvMAX(av)) + av_extend(av, max); + } + } + + while (++MARK <= SP) { + SV * const elemsv = *MARK; + if (SvTYPE(av) == SVt_PVAV) + S_localise_aelem_lval(aTHX_ av, elemsv, can_preserve); + else + S_localise_helem_lval(aTHX_ (HV *)av, elemsv, can_preserve); + *MARK = sv_2mortal(newSV_type(SVt_PVMG)); + sv_magic(*MARK,(SV *)av,PERL_MAGIC_lvref,(char *)elemsv,HEf_SVKEY); + } + RETURN; +} + +PP(pp_lvavref) +{ + if (PL_op->op_flags & OPf_STACKED) + Perl_pp_rv2av(aTHX); + else + Perl_pp_padav(aTHX); + { + dSP; + dTOPss; + SETs(0); /* special alias marker that aassign recognises */ + XPUSHs(sv); + RETURN; + } +} /* * Local variables: