X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/b454703a4259660f770f2d4a9cbb39379016df58..4e96da834c8a37737d5de382697fd3646ba68673:/pp.c diff --git a/pp.c b/pp.c index 1f27f5b..6772999 100644 --- a/pp.c +++ b/pp.c @@ -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); @@ -752,7 +748,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; @@ -774,16 +770,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); @@ -792,33 +789,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 +826,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 +857,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 +874,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 +883,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 +898,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 +930,7 @@ S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping) sv_setpvs(retval, ""); SvSETMAGIC(sv); } + return count; } @@ -946,9 +941,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; } @@ -960,11 +955,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; @@ -1080,7 +1076,7 @@ PP(pp_postinc) PL_op->op_type == OP_POSTINC || PL_op->op_type == OP_I_POSTINC; if (SvTYPE(TOPs) >= SVt_PVAV || (isGV_with_GP(TOPs) && !SvFAKE(TOPs))) Perl_croak_no_modify(); - if (!(PL_op->op_private & OPpTARGET_MY) && SvROK(TOPs)) + if (SvROK(TOPs)) TARG = sv_newmortal(); sv_setsv(TARG, TOPs); if (!SvREADONLY(TOPs) && !SvGMAGICAL(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) @@ -1096,7 +1092,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; } @@ -2051,7 +2047,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 { @@ -2454,7 +2450,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 @@ -2477,7 +2474,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) @@ -2513,7 +2511,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 @@ -2956,7 +2954,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)) @@ -3225,6 +3223,8 @@ PP(pp_vec) } sv_setuv(ret, do_vecget(src, offset, size)); + if (!lvalue) + SvSETMAGIC(ret); PUSHs(ret); RETURN; } @@ -3260,7 +3260,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, @@ -3282,8 +3282,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); } @@ -3340,7 +3340,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); @@ -3368,9 +3368,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; } @@ -3422,7 +3422,7 @@ PP(pp_chr) *tmps = '\0'; (void)SvPOK_only(TARG); SvUTF8_on(TARG); - XPUSHs(TARG); + XPUSHTARG; RETURN; } @@ -3433,8 +3433,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)) @@ -3449,7 +3449,7 @@ PP(pp_chr) } } - XPUSHs(TARG); + XPUSHTARG; RETURN; } @@ -3465,9 +3465,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); } @@ -3494,6 +3493,7 @@ PP(pp_crypt) # else sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right))); # endif + SvUTF8_off(TARG); SETTARG; RETURN; #else @@ -4971,7 +4971,6 @@ 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; @@ -5001,7 +5000,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)) { @@ -5009,10 +5007,7 @@ PP(pp_lslice) } } } - if (is_something_there) - SP = lastlelem; - else - SP = firstlelem - 1; + SP = lastlelem; RETURN; } @@ -6227,9 +6222,10 @@ 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); @@ -6258,13 +6254,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)