X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/7776003ecba252f04a5359ee75d84770ad318f9a..6d59e610a3f269be73ffea56a90d1cd7dc8bf2fd:/pp.c diff --git a/pp.c b/pp.c index 18c3f03..6d575f7 100644 --- a/pp.c +++ b/pp.c @@ -62,6 +62,7 @@ PP(pp_stub) /* Pushy stuff. */ +/* This is also called directly by pp_lvavref. */ PP(pp_padav) { dSP; dTARGET; @@ -417,12 +418,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))))); } @@ -751,7 +752,7 @@ PP(pp_trans) 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; @@ -773,16 +774,17 @@ PP(pp_trans) /* 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); @@ -791,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()); } } @@ -831,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 { @@ -862,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); } @@ -879,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) @@ -888,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); @@ -903,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) { @@ -935,6 +934,7 @@ S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping) sv_setpvs(retval, ""); SvSETMAGIC(sv); } + return count; } @@ -945,9 +945,9 @@ 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; } @@ -959,11 +959,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; @@ -1095,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; } @@ -1649,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; } @@ -1694,37 +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)) { *SP = sv_mortalcopy(*SP); } SvTEMP_off((*SP)); } -#endif SP--; } MARK++; @@ -1765,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; @@ -2065,7 +2051,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 { @@ -2717,7 +2703,11 @@ PP(pp_sin) const NV value = SvNV_nomg(arg); NV result = NV_NAN; if (neg_report) { /* log or sqrt */ - if (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0)) { + 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); @@ -2768,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; @@ -2842,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 { @@ -2960,7 +2956,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)) @@ -3190,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); } @@ -3227,6 +3225,8 @@ PP(pp_vec) } sv_setuv(ret, do_vecget(src, offset, size)); + if (!lvalue) + SvSETMAGIC(ret); PUSHs(ret); RETURN; } @@ -3262,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, @@ -3284,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); } @@ -3370,9 +3370,9 @@ PP(pp_ord) 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; } @@ -3392,7 +3392,7 @@ PP(pp_chr) SV *top = POPs; SvGETMAGIC(top); - if (SvNOK(top) && Perl_isinfnan(SvNV(top))) + if (UNLIKELY(isinfnansv(top))) Perl_croak(aTHX_ "Cannot chr %"NVgf, SvNV(top)); else { if (!IN_BYTES /* under bytes, chr(-1) eq chr(0xff), etc. */ @@ -3424,7 +3424,7 @@ PP(pp_chr) *tmps = '\0'; (void)SvPOK_only(TARG); SvUTF8_on(TARG); - XPUSHs(TARG); + XPUSHTARG; RETURN; } @@ -3435,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)) @@ -3451,7 +3451,7 @@ PP(pp_chr) } } - XPUSHs(TARG); + XPUSHTARG; RETURN; } @@ -3467,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); } @@ -3496,6 +3495,7 @@ PP(pp_crypt) # else sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right))); # endif + SvUTF8_off(TARG); SETTARG; RETURN; #else @@ -5517,7 +5517,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; @@ -5550,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); @@ -5566,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))) { @@ -6150,6 +6151,212 @@ 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); + { + MAGIC *mg; + HV *stash; + switch (left ? SvTYPE(left) : 0) { + 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: