X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/bdaf10a52f7152c8c7cb0a106489016892f093cd..02a7a248fa1942d10cc4d2479e0f47432d239322:/pp.c diff --git a/pp.c b/pp.c index 3ca98cc..8c66286 100644 --- a/pp.c +++ b/pp.c @@ -78,7 +78,7 @@ PP(pp_padav) } else if (PL_op->op_private & OPpMAYBE_LVSUB) { const I32 flags = is_lvalue_sub(); if (flags && !(flags & OPpENTERSUB_INARGS)) { - if (GIMME == G_SCALAR) + if (GIMME_V == G_SCALAR) /* diag_listed_as: Can't return %s to lvalue scalar context */ Perl_croak(aTHX_ "Can't return array to lvalue scalar context"); PUSHs(TARG); @@ -130,7 +130,7 @@ PP(pp_padhv) else if (PL_op->op_private & OPpMAYBE_LVSUB) { const I32 flags = is_lvalue_sub(); if (flags && !(flags & OPpENTERSUB_INARGS)) { - if (GIMME == G_SCALAR) + if (GIMME_V == G_SCALAR) /* diag_listed_as: Can't return %s to lvalue scalar context */ Perl_croak(aTHX_ "Can't return hash to lvalue scalar context"); RETURN; @@ -170,25 +170,24 @@ PP(pp_introcv) PP(pp_clonecv) { dTARGET; - MAGIC * const mg = - mg_find(PadlistNAMESARRAY(CvPADLIST(find_runcv(NULL)))[ARGTARG], - PERL_MAGIC_proto); + CV * const protocv = PadnamePROTOCV( + PadlistNAMESARRAY(CvPADLIST(find_runcv(NULL)))[ARGTARG] + ); assert(SvTYPE(TARG) == SVt_PVCV); - assert(mg); - assert(mg->mg_obj); - if (CvISXSUB(mg->mg_obj)) { /* constant */ + assert(protocv); + if (CvISXSUB(protocv)) { /* constant */ /* XXX Should we clone it here? */ /* If this changes to use SAVECLEARSV, we can move the SAVECLEARSV to introcv and remove the SvPADSTALE_off. */ SAVEPADSVANDMORTALIZE(ARGTARG); - PAD_SVl(ARGTARG) = SvREFCNT_inc_simple_NN(mg->mg_obj); + PAD_SVl(ARGTARG) = SvREFCNT_inc_simple_NN(protocv); } else { - if (CvROOT(mg->mg_obj)) { - assert(CvCLONE(mg->mg_obj)); - assert(!CvCLONED(mg->mg_obj)); + if (CvROOT(protocv)) { + assert(CvCLONE(protocv)); + assert(!CvCLONED(protocv)); } - cv_clone_into((CV *)mg->mg_obj,(CV *)TARG); + cv_clone_into(protocv,(CV *)TARG); SAVECLEARSV(PAD_SVl(ARGTARG)); } return NORMAL; @@ -196,9 +195,6 @@ PP(pp_clonecv) /* Translations. */ -static const char S_no_symref_sv[] = - "Can't use string (\"%" SVf32 "\"%s) as %s ref while \"strict refs\" in use"; - /* In some cases this function inspects PL_op. If this function is called for new op types, more bool parameters may need to be added in place of the checks. @@ -275,7 +271,7 @@ S_rv2gv(pTHX_ SV *sv, const bool vivify_sv, const bool strict, else { if (strict) { Perl_die(aTHX_ - S_no_symref_sv, + PL_no_symref_sv, sv, (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), "a symbol" @@ -330,7 +326,7 @@ Perl_softref2xv(pTHX_ SV *const sv, const char *const what, if (PL_op->op_private & HINT_STRICT_REFS) { if (SvOK(sv)) - Perl_die(aTHX_ S_no_symref_sv, sv, + Perl_die(aTHX_ PL_no_symref_sv, sv, (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what); else Perl_die(aTHX_ PL_no_usym, what); @@ -376,15 +372,8 @@ PP(pp_rv2sv) } sv = SvRV(sv); - switch (SvTYPE(sv)) { - case SVt_PVAV: - case SVt_PVHV: - case SVt_PVCV: - case SVt_PVFM: - case SVt_PVIO: + if (SvTYPE(sv) >= SVt_PVAV) DIE(aTHX_ "Not a SCALAR reference"); - default: NOOP; - } } else { gv = MUTABLE_GV(sv); @@ -418,12 +407,12 @@ PP(pp_av2arylen) 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))))); } @@ -432,15 +421,14 @@ PP(pp_av2arylen) PP(pp_pos) { - dSP; dPOPss; + dSP; dTOPss; if (PL_op->op_flags & OPf_MOD || LVRET) { SV * const ret = sv_2mortal(newSV_type(SVt_PVLV));/* Not TARG RT#67838 */ sv_magic(ret, NULL, PERL_MAGIC_pos, NULL, 0); LvTYPE(ret) = '.'; LvTARG(ret) = SvREFCNT_inc_simple(sv); - PUSHs(ret); /* no SvSETMAGIC */ - RETURN; + SETs(ret); /* no SvSETMAGIC */ } else { const MAGIC * const mg = mg_find_mglob(sv); @@ -449,11 +437,12 @@ PP(pp_pos) STRLEN i = mg->mg_len; if (mg->mg_flags & MGf_BYTES && DO_UTF8(sv)) i = sv_pos_b2u_flags(sv, i, SV_GMAGIC|SV_CONST_RETURN); - PUSHu(i); - RETURN; + SETu(i); + return NORMAL; } - RETPUSHUNDEF; + SETs(&PL_sv_undef); } + return NORMAL; } PP(pp_rv2cv) @@ -480,7 +469,7 @@ PP(pp_rv2cv) else cv = MUTABLE_CV(&PL_sv_undef); SETs(MUTABLE_SV(cv)); - RETURN; + return NORMAL; } PP(pp_prototype) @@ -531,17 +520,20 @@ PP(pp_srefgen) { dSP; *SP = refto(*SP); - RETURN; + return NORMAL; } PP(pp_refgen) { dSP; dMARK; - if (GIMME != G_ARRAY) { + if (GIMME_V != G_ARRAY) { if (++MARK <= SP) *MARK = *SP; else + { + MEXTEND(SP, 1); *MARK = &PL_sv_undef; + } *MARK = refto(*MARK); SP = MARK; RETURN; @@ -654,7 +646,7 @@ PP(pp_gelem) SV *sv = POPs; STRLEN len; const char * const elem = SvPV_const(sv, len); - GV * const gv = MUTABLE_GV(POPs); + GV * const gv = MUTABLE_GV(TOPs); SV * tmpRef = NULL; sv = NULL; @@ -720,7 +712,7 @@ PP(pp_gelem) sv_2mortal(sv); else sv = &PL_sv_undef; - XPUSHs(sv); + SETs(sv); RETURN; } @@ -728,18 +720,20 @@ PP(pp_gelem) PP(pp_study) { - dSP; dPOPss; + dSP; dTOPss; STRLEN len; (void)SvPV(sv, len); if (len == 0 || len > I32_MAX || !SvPOK(sv) || SvUTF8(sv) || SvVALID(sv)) { /* Historically, study was skipped in these cases. */ - RETPUSHNO; + SETs(&PL_sv_no); + return NORMAL; } /* Make study a no-op. It's no longer useful and its existence complicates matters elsewhere. */ - RETPUSHYES; + SETs(&PL_sv_yes); + return NORMAL; } @@ -747,16 +741,18 @@ PP(pp_study) PP(pp_trans) { - dSP; dTARG; + dSP; SV *sv; if (PL_op->op_flags & OPf_STACKED) sv = POPs; - else if (PL_op->op_private & OPpTARGET_MY) - sv = GETTARGET; else { - sv = DEFSV; EXTEND(SP,1); + if (ARGTARG) + sv = PAD_SV(ARGTARG); + else { + sv = DEFSV; + } } if(PL_op->op_type == OP_TRANSR) { STRLEN len; @@ -766,24 +762,24 @@ PP(pp_trans) PUSHs(newsv); } else { - TARG = sv_newmortal(); - PUSHi(do_trans(sv)); + mPUSHi(do_trans(sv)); } RETURN; } /* Lvalue operators. */ -static void +static size_t S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping) { 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); @@ -792,33 +788,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()); } } @@ -832,11 +825,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 { @@ -863,11 +856,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); } @@ -880,7 +873,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) @@ -889,10 +882,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); @@ -904,7 +897,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) { @@ -936,6 +929,7 @@ S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping) sv_setpvs(retval, ""); SvSETMAGIC(sv); } + return count; } @@ -946,11 +940,11 @@ PP(pp_schop) 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; + return NORMAL; } @@ -960,11 +954,12 @@ PP(pp_chop) { 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; @@ -980,9 +975,12 @@ PP(pp_undef) RETPUSHUNDEF; } - sv = POPs; + sv = TOPs; if (!sv) - RETPUSHUNDEF; + { + SETs(&PL_sv_undef); + return NORMAL; + } if (SvTHINKFIRST(sv)) sv_force_normal_flags(sv, SV_COW_DROP_PV|SV_IMMEDIATE_UNREF); @@ -1067,7 +1065,8 @@ PP(pp_undef) SvSETMAGIC(sv); } - RETPUSHUNDEF; + SETs(&PL_sv_undef); + return NORMAL; } @@ -1096,7 +1095,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; } @@ -1299,7 +1298,8 @@ PP(pp_multiply) alow = aiv; auvok = TRUE; /* effectively it's a UV now */ } else { - alow = -aiv; /* abs, auvok == false records sign */ + /* abs, auvok == false records sign */ + alow = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv); } } if (buvok) { @@ -1310,7 +1310,8 @@ PP(pp_multiply) blow = biv; buvok = TRUE; /* effectively it's a UV now */ } else { - blow = -biv; /* abs, buvok == false records sign */ + /* abs, buvok == false records sign */ + blow = (biv == IV_MIN) ? (UV)biv : (UV)(-biv); } } @@ -1336,6 +1337,10 @@ PP(pp_multiply) /* 2s complement assumption that (UV)-IV_MIN is correct. */ /* -ve result, which could overflow an IV */ SP--; + /* can't negate IV_MIN, but there are aren't two + * integers such that !ahigh && !bhigh, where the + * product equals 0x800....000 */ + assert(product != (UV)IV_MIN); SETi( -(IV)product ); RETURN; } /* else drop to NVs below. */ @@ -1373,7 +1378,8 @@ PP(pp_multiply) /* 2s complement assumption again */ /* -ve result, which could overflow an IV */ SP--; - SETi( -(IV)product_low ); + SETi(product_low == (UV)IV_MIN + ? IV_MIN : -(IV)product_low); RETURN; } /* else drop to NVs below. */ } @@ -1435,7 +1441,7 @@ PP(pp_divide) right_non_neg = TRUE; /* effectively it's a UV now */ } else { - right = -biv; + right = (biv == IV_MIN) ? (UV)biv : (UV)(-biv); } } /* historically undef()/0 gives a "Use of uninitialized value" @@ -1456,7 +1462,7 @@ PP(pp_divide) left_non_neg = TRUE; /* effectively it's a UV now */ } else { - left = -aiv; + left = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv); } } @@ -1486,7 +1492,7 @@ PP(pp_divide) } /* 2s complement assumption */ if (result <= (UV)IV_MIN) - SETi( -(IV)result ); + SETi(result == (UV)IV_MIN ? IV_MIN : -(IV)result); else { /* It's exact but too negative for IV. */ SETn( -(NV)result ); @@ -1536,7 +1542,7 @@ PP(pp_modulo) right = biv; right_neg = FALSE; /* effectively it's a UV now */ } else { - right = -biv; + right = (biv == IV_MIN) ? (UV)biv : (UV)(-biv); } } } @@ -1566,7 +1572,7 @@ PP(pp_modulo) left = aiv; left_neg = FALSE; /* effectively it's a UV now */ } else { - left = -aiv; + left = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv); } } } @@ -1643,13 +1649,33 @@ PP(pp_repeat) dSP; dATARGET; IV count; SV *sv; + bool infnan = FALSE; - if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) { + if (GIMME_V == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) { /* TODO: think of some way of doing list-repeat overloading ??? */ sv = POPs; 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; } @@ -1666,22 +1692,30 @@ PP(pp_repeat) } } else if (SvNOKp(sv)) { - const NV nv = SvNV_nomg(sv); - if (nv < 0.0) - count = -1; /* An arbitrary negative integer */ - else - count = (IV)nv; + const NV nv = SvNV_nomg(sv); + infnan = Perl_isinfnan(nv); + if (UNLIKELY(infnan)) { + count = 0; + } else { + if (nv < 0.0) + count = -1; /* An arbitrary negative integer */ + else + count = (IV)nv; + } } else - count = SvIV_nomg(sv); + count = SvIV_nomg(sv); - if (count < 0) { + if (infnan) { + Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC), + "Non-finite repeat count does nothing"); + } else if (count < 0) { count = 0; Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC), - "Negative repeat count does nothing"); + "Negative repeat count does nothing"); } - if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) { + if (GIMME_V == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) { dMARK; static const char* const oom_list_extend = "Out of memory during list extend"; const I32 items = SP - MARK; @@ -1695,37 +1729,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)) { *SP = sv_mortalcopy(*SP); } SvTEMP_off((*SP)); } -#endif SP--; } MARK++; @@ -1766,15 +1775,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; @@ -1813,7 +1813,7 @@ PP(pp_subtract) auv = aiv; auvok = 1; /* Now acting as a sign flag. */ } else { /* 2s complement assumption for IV_MIN */ - auv = (UV)-aiv; + auv = (aiv == IV_MIN) ? (UV)aiv : (UV)-aiv; } } a_valid = 1; @@ -1833,7 +1833,7 @@ PP(pp_subtract) buv = biv; buvok = 1; } else - buv = (UV)-biv; + buv = (biv == IV_MIN) ? (UV)biv : (UV)-biv; } /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve, else "IV" now, independent of how it came in. @@ -1874,7 +1874,8 @@ PP(pp_subtract) else { /* Negate result */ if (result <= (UV)IV_MIN) - SETi( -(IV)result ); + SETi(result == (UV)IV_MIN + ? IV_MIN : -(IV)result); else { /* result valid, but out of range for IV. */ SETn( -(NV)result ); @@ -2066,7 +2067,7 @@ Perl_do_ncmp(pTHX_ SV* const left, SV * const right) return (leftuv > (UV)rightiv) - (leftuv < (UV)rightiv); } } - assert(0); /* NOTREACHED */ + NOT_REACHED; /* NOTREACHED */ } #endif { @@ -2279,7 +2280,7 @@ S_negate_string(pTHX) *SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-'; } else return FALSE; - SETTARG; PUTBACK; + SETTARG; return TRUE; } @@ -2299,21 +2300,21 @@ PP(pp_negate) /* 2s complement assumption. */ SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */ - RETURN; + return NORMAL; } else if (SvUVX(sv) <= IV_MAX) { SETi(-SvIVX(sv)); - RETURN; + return NORMAL; } } else if (SvIVX(sv) != IV_MIN) { SETi(-SvIVX(sv)); - RETURN; + return NORMAL; } #ifdef PERL_PRESERVE_IVUV else { SETu((UV)IV_MIN); - RETURN; + return NORMAL; } #endif } @@ -2324,7 +2325,7 @@ PP(pp_negate) else SETn(-SvNV_nomg(sv)); } - RETURN; + return NORMAL; } PP(pp_not) @@ -2413,7 +2414,7 @@ PP(pp_complement) SvUTF8_off(TARG); } SETTARG; - RETURN; + return NORMAL; } #ifdef LIBERAL { @@ -2430,7 +2431,7 @@ PP(pp_complement) *tmps = ~*tmps; SETTARG; } - RETURN; + return NORMAL; } } @@ -2469,7 +2470,8 @@ PP(pp_i_divide) } } -#if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS) +#if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS) \ + && ( __GLIBC__ < 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ < 8)) STATIC PP(pp_i_modulo_0) #else @@ -2492,7 +2494,8 @@ PP(pp_i_modulo) } } -#if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS) +#if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS) \ + && ( __GLIBC__ < 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ < 8)) STATIC PP(pp_i_modulo_1) @@ -2528,7 +2531,7 @@ PP(pp_i_modulo) PL_ppaddr[OP_I_MODULO] = Perl_pp_i_modulo_0; /* .. but if we have glibc, we might have a buggy _moddi3 - * (at least glicb 2.2.5 is known to have this bug), in other + * (at least glibc 2.2.5 is known to have this bug), in other * words our integer modulus with negative quad as the second * argument might be broken. Test for this and re-patch the * opcode dispatch table if that is the case, remembering to @@ -2675,7 +2678,7 @@ PP(pp_i_negate) SV * const sv = TOPs; IV const i = SvIV_nomg(sv); SETi(-i); - RETURN; + return NORMAL; } } @@ -2714,7 +2717,7 @@ PP(pp_sin) tryAMAGICun_MG(amg_type, 0); { - SV * const arg = POPs; + SV * const arg = TOPs; const NV value = SvNV_nomg(arg); NV result = NV_NAN; if (neg_report) { /* log or sqrt */ @@ -2736,8 +2739,8 @@ PP(pp_sin) case OP_LOG: result = Perl_log(value); break; case OP_SQRT: result = Perl_sqrt(value); break; } - XPUSHn(result); - RETURN; + SETn(result); + return NORMAL; } } @@ -2761,10 +2764,12 @@ PP(pp_rand) { dSP; NV value; - EXTEND(SP, 1); if (MAXARG < 1) + { + EXTEND(SP, 1); value = 1.0; + } else { SV * const sv = POPs; if(!sv) @@ -2851,8 +2856,8 @@ PP(pp_int) } else { const NV value = SvNV_nomg(sv); - if (SvNOK(sv) && UNLIKELY(Perl_isinfnan(SvNV(sv)))) - SETn(SvNV(sv)); + if (UNLIKELY(Perl_isinfnan(value))) + SETn(value); else if (value >= 0.0) { if (value < (NV)UV_MAX + 0.5) { SETu(U_V(value)); @@ -2869,7 +2874,7 @@ PP(pp_int) } } } - RETURN; + return NORMAL; } PP(pp_abs) @@ -2909,7 +2914,7 @@ PP(pp_abs) SETn(value); } } - RETURN; + return NORMAL; } @@ -2923,7 +2928,7 @@ PP(pp_oct) STRLEN len; NV result_nv; UV result_uv; - SV* const sv = POPs; + SV* const sv = TOPs; tmps = (SvPV_const(sv, len)); if (DO_UTF8(sv)) { @@ -2952,12 +2957,12 @@ PP(pp_oct) result_uv = grok_oct (tmps, &len, &flags, &result_nv); if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) { - XPUSHn(result_nv); + SETn(result_nv); } else { - XPUSHu(result_uv); + SETu(result_uv); } - RETURN; + return NORMAL; } /* String stuff. */ @@ -2971,7 +2976,7 @@ PP(pp_length) /* 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)); + STATIC_ASSERT_STMT(HINT_BYTES == 0x00000008 && SVf_UTF8 == 0x20000000 && (SVf_UTF8 == HINT_BYTES << 26)); SETs(TARG); if(LIKELY(svflags == SVf_POK)) @@ -3114,7 +3119,6 @@ PP(pp_substr) assert(!repl_sv); repl_sv = POPs; } - PUTBACK; if (lvalue && !repl_sv) { SV * ret; ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */ @@ -3130,7 +3134,6 @@ PP(pp_substr) ? (STRLEN)(UV)len_iv : (LvFLAGS(ret) |= 2, (STRLEN)(UV)-len_iv); - SPAGAIN; PUSHs(ret); /* avoid SvSETMAGIC here */ RETURN; } @@ -3200,8 +3203,9 @@ PP(pp_substr) SvREFCNT_dec(repl_sv_copy); } } - SPAGAIN; - if (rvalue) { + if (PL_op->op_private & OPpSUBSTR_REPL_FIRST) + SP++; + else if (rvalue) { SvSETMAGIC(TARG); PUSHs(TARG); } @@ -3238,6 +3242,8 @@ PP(pp_vec) } sv_setuv(ret, do_vecget(src, offset, size)); + if (!lvalue) + SvSETMAGIC(ret); PUSHs(ret); RETURN; } @@ -3273,7 +3279,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, @@ -3295,8 +3301,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); } @@ -3353,7 +3359,7 @@ PP(pp_index) retval = -1; else { retval = little_p - big_p; - if (retval > 0 && big_utf8) + if (retval > 1 && big_utf8) retval = sv_pos_b2u_flags(big, retval, SV_CONST_RETURN); } SvREFCNT_dec(temp); @@ -3377,22 +3383,22 @@ PP(pp_ord) { dSP; dTARGET; - SV *argsv = POPs; + SV *argsv = TOPs; 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; } - XPUSHu(DO_UTF8(argsv) + SETu(DO_UTF8(argsv) ? utf8n_to_uvchr(s, len, 0, UTF8_ALLOW_ANYUV) : (UV)(*s)); - RETURN; + return NORMAL; } PP(pp_chr) @@ -3400,9 +3406,11 @@ PP(pp_chr) dSP; dTARGET; char *tmps; UV value; - SV *top = POPs; + SV *top = TOPs; SvGETMAGIC(top); + if (UNLIKELY(SvAMAGIC(top))) + top = sv_2num(top); if (UNLIKELY(isinfnansv(top))) Perl_croak(aTHX_ "Cannot chr %"NVgf, SvNV(top)); else { @@ -3435,8 +3443,8 @@ PP(pp_chr) *tmps = '\0'; (void)SvPOK_only(TARG); SvUTF8_on(TARG); - XPUSHs(TARG); - RETURN; + SETTARG; + return NORMAL; } SvGROW(TARG,2); @@ -3446,8 +3454,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)) @@ -3462,8 +3470,8 @@ PP(pp_chr) } } - XPUSHs(TARG); - RETURN; + SETTARG; + return NORMAL; } PP(pp_crypt) @@ -3478,9 +3486,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); } @@ -3507,6 +3514,7 @@ PP(pp_crypt) # else sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right))); # endif + SvUTF8_off(TARG); SETTARG; RETURN; #else @@ -3597,23 +3605,27 @@ PP(pp_ucfirst) if (op_type == OP_LCFIRST) { /* lower case the first letter: no trickiness for any character */ - *tmpbuf = #ifdef USE_LOCALE_CTYPE - (IN_LC_RUNTIME(LC_CTYPE)) - ? toLOWER_LC(*s) - : + if (IN_LC_RUNTIME(LC_CTYPE)) { + _CHECK_AND_WARN_PROBLEMATIC_LOCALE; + *tmpbuf = toLOWER_LC(*s); + } + else #endif - (IN_UNI_8_BIT) - ? toLOWER_LATIN1(*s) - : toLOWER(*s); + { + *tmpbuf = (IN_UNI_8_BIT) + ? toLOWER_LATIN1(*s) + : toLOWER(*s); + } } - /* is ucfirst() */ #ifdef USE_LOCALE_CTYPE + /* is ucfirst() */ else if (IN_LC_RUNTIME(LC_CTYPE)) { if (IN_UTF8_CTYPE_LOCALE) { goto do_uni_rules; } + _CHECK_AND_WARN_PROBLEMATIC_LOCALE; *tmpbuf = (U8) toUPPER_LC(*s); /* This would be a bug if any locales have upper and title case different */ @@ -3772,7 +3784,7 @@ PP(pp_ucfirst) if (dest != source && SvTAINTED(source)) SvTAINT(dest); SvSETMAGIC(dest); - RETURN; + return NORMAL; } /* There's so much setup/teardown code common between uc and lc, I wonder if @@ -3918,6 +3930,7 @@ PP(pp_uc) if (IN_UTF8_CTYPE_LOCALE) { goto do_uni_rules; } + _CHECK_AND_WARN_PROBLEMATIC_LOCALE; for (; s < send; d++, s++) *d = (U8) toUPPER_LC(*s); } @@ -4029,7 +4042,7 @@ PP(pp_uc) if (dest != source && SvTAINTED(source)) SvTAINT(dest); SvSETMAGIC(dest); - RETURN; + return NORMAL; } PP(pp_lc) @@ -4125,6 +4138,7 @@ PP(pp_lc) * whole thing in a tight loop, for speed, */ #ifdef USE_LOCALE_CTYPE if (IN_LC_RUNTIME(LC_CTYPE)) { + _CHECK_AND_WARN_PROBLEMATIC_LOCALE; for (; s < send; d++, s++) *d = toLOWER_LC(*s); } @@ -4155,7 +4169,7 @@ PP(pp_lc) if (dest != source && SvTAINTED(source)) SvTAINT(dest); SvSETMAGIC(dest); - RETURN; + return NORMAL; } PP(pp_quotemeta) @@ -4233,7 +4247,7 @@ PP(pp_quotemeta) else sv_setpvn(TARG, s, len); SETTARG; - RETURN; + return NORMAL; } PP(pp_fc) @@ -4307,6 +4321,7 @@ PP(pp_fc) if (IN_UTF8_CTYPE_LOCALE) { goto do_uni_folding; } + _CHECK_AND_WARN_PROBLEMATIC_LOCALE; for (; s < send; d++, s++) *d = (U8) toFOLD_LC(*s); } @@ -4456,7 +4471,7 @@ PP(pp_aslice) *MARK = svp ? *svp : &PL_sv_undef; } } - if (GIMME != G_ARRAY) { + if (GIMME_V != G_ARRAY) { MARK = ORIGMARK; *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef; SP = MARK; @@ -4501,7 +4516,7 @@ PP(pp_kvaslice) } *++MARK = svp ? *svp : &PL_sv_undef; } - if (GIMME != G_ARRAY) { + if (GIMME_V != G_ARRAY) { MARK = SP - items*2; *++MARK = items > 0 ? *SP : &PL_sv_undef; SP = MARK; @@ -4619,21 +4634,15 @@ PP(pp_each) HE *entry; const I32 gimme = GIMME_V; - PUTBACK; - /* might clobber stack_sp */ entry = hv_iternext(hash); - SPAGAIN; EXTEND(SP, 2); if (entry) { SV* const sv = hv_iterkeysv(entry); - PUSHs(sv); /* won't clobber stack_sp */ + PUSHs(sv); if (gimme == G_ARRAY) { SV *val; - PUTBACK; - /* might clobber stack_sp */ val = hv_iterval(hash, entry); - SPAGAIN; PUSHs(val); } } @@ -4902,7 +4911,7 @@ PP(pp_hslice) } *MARK = svp && *svp ? *svp : &PL_sv_undef; } - if (GIMME != G_ARRAY) { + if (GIMME_V != G_ARRAY) { MARK = ORIGMARK; *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef; SP = MARK; @@ -4951,7 +4960,7 @@ PP(pp_kvhslice) } *++MARK = svp && *svp ? *svp : &PL_sv_undef; } - if (GIMME != G_ARRAY) { + if (GIMME_V != G_ARRAY) { MARK = SP - items*2; *++MARK = items > 0 ? *SP : &PL_sv_undef; SP = MARK; @@ -4964,7 +4973,7 @@ PP(pp_kvhslice) PP(pp_list) { I32 markidx = POPMARK; - if (GIMME != G_ARRAY) { + if (GIMME_V != G_ARRAY) { SV **mark = PL_stack_base + markidx; dSP; if (++MARK <= SP) @@ -4984,13 +4993,12 @@ PP(pp_lslice) SV ** const lastlelem = PL_stack_base + POPMARK; SV ** const firstlelem = PL_stack_base + POPMARK + 1; SV ** const firstrelem = lastlelem + 1; - I32 is_something_there = FALSE; const U8 mod = PL_op->op_flags & OPf_MOD; const I32 max = lastrelem - lastlelem; SV **lelem; - if (GIMME != G_ARRAY) { + if (GIMME_V != G_ARRAY) { I32 ix = SvIV(*lastlelem); if (ix < 0) ix += max; @@ -5014,7 +5022,6 @@ PP(pp_lslice) if (ix < 0 || ix >= max) *lelem = &PL_sv_undef; else { - is_something_there = TRUE; if (!(*lelem = firstrelem[ix])) *lelem = &PL_sv_undef; else if (mod && SvPADTMP(*lelem)) { @@ -5022,10 +5029,7 @@ PP(pp_lslice) } } } - if (is_something_there) - SP = lastlelem; - else - SP = firstlelem - 1; + SP = lastlelem; RETURN; } @@ -5057,7 +5061,7 @@ PP(pp_anonhash) MARK++; SvGETMAGIC(*MARK); val = newSV(0); - sv_setsv(val, *MARK); + sv_setsv_nomg(val, *MARK); } else { @@ -5179,7 +5183,7 @@ PP(pp_splice) } MARK = ORIGMARK + 1; - if (GIMME == G_ARRAY) { /* copy return vals to stack */ + if (GIMME_V == G_ARRAY) { /* copy return vals to stack */ const bool real = cBOOL(AvREAL(ary)); MEXTEND(MARK, length); if (real) @@ -5275,7 +5279,7 @@ PP(pp_splice) } MARK = ORIGMARK + 1; - if (GIMME == G_ARRAY) { /* copy return vals to stack */ + if (GIMME_V == G_ARRAY) { /* copy return vals to stack */ if (length) { const bool real = cBOOL(AvREAL(ary)); if (real) @@ -5398,7 +5402,7 @@ PP(pp_reverse) { dSP; dMARK; - if (GIMME == G_ARRAY) { + if (GIMME_V == G_ARRAY) { if (PL_op->op_private & OPpREVERSE_INPLACE) { AV *av; @@ -5528,7 +5532,7 @@ PP(pp_reverse) PP(pp_split) { dSP; dTARG; - AV *ary; + AV *ary = PL_op->op_flags & OPf_STACKED ? (AV *)POPs : NULL; IV limit = POPi; /* note, negative is forever */ SV * const sv = POPs; STRLEN len; @@ -5561,7 +5565,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); @@ -5571,18 +5575,22 @@ PP(pp_split) #ifdef USE_ITHREADS if (pm->op_pmreplrootu.op_pmtargetoff) { ary = GvAVn(MUTABLE_GV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff))); + goto have_av; } #else if (pm->op_pmreplrootu.op_pmtargetgv) { ary = GvAVn(pm->op_pmreplrootu.op_pmtargetgv); + goto have_av; } #endif - else - ary = NULL; + else if (pm->op_targ) + ary = (AV *)PAD_SVl(pm->op_targ); if (ary) { + have_av: 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))) { @@ -6239,15 +6247,17 @@ PP(pp_refassign) if (bad) /* diag_listed_as: Assigned value is not %s reference */ DIE(aTHX_ "Assigned value is not a%s reference", bad); + { + MAGIC *mg; + HV *stash; 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) + if ((PL_op->op_private & (OPpLVAL_INTRO|OPpPAD_STATE)) + == OPpLVAL_INTRO) SAVECLEARSV(PAD_SVl(ARGTARG)); break; } @@ -6269,13 +6279,14 @@ PP(pp_refassign) if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) S_localise_helem_lval(aTHX_ (HV *)left, key, SvCANEXISTDELETE(left)); - hv_store_ent((HV *)left, key, SvREFCNT_inc_simple_NN(SvRV(sv)), 0); + (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) @@ -6286,8 +6297,10 @@ PP(pp_lvref) 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 : ARGTARG); + 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; @@ -6302,7 +6315,7 @@ PP(pp_lvref) S_localise_gv_slot(aTHX_ (GV *)arg, PL_op->op_private & OPpLVREF_TYPE); } - else + else if (!(PL_op->op_private & OPpPAD_STATE)) SAVECLEARSV(PAD_SVl(ARGTARG)); } XPUSHs(ret);