X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=9713707a4d8ee8605ccb96add6d220675ce680e5;hb=8d0ec8cffad6f81a95e1fb954a5337910142389f;hp=aa070533c91b7954f9ba17344b1fed2c0b2c0c4f;hpb=b464bac0b70c4876af1296864220315edde8461d;p=p5sagit%2Fp5-mst-13.2.git diff --git a/sv.c b/sv.c index aa07053..9713707 100644 --- a/sv.c +++ b/sv.c @@ -47,7 +47,7 @@ #define ASSERT_UTF8_CACHE(cache) NOOP #endif -#ifdef PERL_COPY_ON_WRITE +#ifdef PERL_OLD_COPY_ON_WRITE #define SV_COW_NEXT_SV(sv) INT2PTR(SV *,SvUVX(sv)) #define SV_COW_NEXT_SV_SET(current,next) SvUV_set(current, PTR2UV(next)) /* This is a pessimistic view. Scalar must be purely a read-write PV to copy- @@ -758,15 +758,12 @@ S_varname(pTHX_ GV *gv, const char *gvtype, PADOFFSET targ, else { U32 u; CV *cv = find_runcv(&u); - STRLEN len; - const char *str; if (!cv || !CvPADLIST(cv)) return Nullsv;; av = (AV*)(*av_fetch(CvPADLIST(cv), 0, FALSE)); sv = *av_fetch(av, targ, FALSE); /* SvLEN in a pad name is not to be trusted */ - str = SvPV(sv,len); - sv_setpvn(name, str, len); + sv_setpv(name, SvPV_nolen_const(sv)); } if (subscript_type == FUV_SUBSCRIPT_HASH) { @@ -1120,7 +1117,7 @@ Perl_report_uninit(pTHX_ SV* uninit_sv) sv_insert(varname, 0, 0, " ", 1); } Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit, - varname ? SvPV_nolen(varname) : "", + varname ? SvPV_nolen_const(varname) : "", " in ", OP_DESC(PL_op)); } else @@ -1757,7 +1754,7 @@ You generally want to use the C macro wrapper. See also C. =cut */ -bool +void Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt) { @@ -1774,7 +1771,7 @@ Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt) } if (SvTYPE(sv) == mt) - return TRUE; + return; pv = NULL; cur = 0; @@ -1804,7 +1801,7 @@ Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt) pv = (char*)SvRV(sv); break; case SVt_PV: - pv = SvPVX(sv); + pv = SvPVX_mutable(sv); cur = SvCUR(sv); len = SvLEN(sv); del_XPV(SvANY(sv)); @@ -1814,14 +1811,14 @@ Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt) mt = SVt_PVNV; break; case SVt_PVIV: - pv = SvPVX(sv); + pv = SvPVX_mutable(sv); cur = SvCUR(sv); len = SvLEN(sv); iv = SvIVX(sv); del_XPVIV(SvANY(sv)); break; case SVt_PVNV: - pv = SvPVX(sv); + pv = SvPVX_mutable(sv); cur = SvCUR(sv); len = SvLEN(sv); iv = SvIVX(sv); @@ -1837,7 +1834,7 @@ Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt) Given that it only has meaning inside the pad, it shouldn't be set on anything that can get upgraded. */ assert((SvFLAGS(sv) & SVpad_TYPED) == 0); - pv = SvPVX(sv); + pv = SvPVX_mutable(sv); cur = SvCUR(sv); len = SvLEN(sv); iv = SvIVX(sv); @@ -1969,7 +1966,6 @@ Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt) SvLEN_set(sv, len); break; } - return TRUE; } /* @@ -2024,11 +2020,11 @@ Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen) sv_unref(sv); if (SvTYPE(sv) < SVt_PV) { sv_upgrade(sv, SVt_PV); - s = SvPVX(sv); + s = SvPVX_mutable(sv); } else if (SvOOK(sv)) { /* pv is offset? */ sv_backoff(sv); - s = SvPVX(sv); + s = SvPVX_mutable(sv); if (newlen > SvLEN(sv)) newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */ #ifdef HAS_64K_LIMIT @@ -2037,13 +2033,13 @@ Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen) #endif } else - s = SvPVX(sv); + s = SvPVX_mutable(sv); if (newlen > SvLEN(sv)) { /* need more room? */ newlen = PERL_STRLEN_ROUNDUP(newlen); if (SvLEN(sv) && s) { #ifdef MYMALLOC - const STRLEN l = malloced_size((void*)SvPVX(sv)); + const STRLEN l = malloced_size((void*)SvPVX_const(sv)); if (newlen <= l) { SvLEN_set(sv, l); return s; @@ -2248,8 +2244,9 @@ S_not_a_number(pTHX_ SV *sv) /* each *s can expand to 4 chars + "...\0", i.e. need room for 8 chars */ - char *s, *end; - for (s = SvPVX(sv), end = s + SvCUR(sv); s < end && d < limit; s++) { + const char *s, *end; + for (s = SvPVX_const(sv), end = s + SvCUR(sv); s < end && d < limit; + s++) { int ch = *s & 0xFF; if (ch & 128 && !isPRINT_LC(ch)) { *d++ = 'M'; @@ -2322,7 +2319,7 @@ Perl_looks_like_number(pTHX_ SV *sv) len = SvCUR(sv); } else if (SvPOKp(sv)) - sbegin = SvPV(sv, len); + sbegin = SvPV_const(sv, len); else return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK); return grok_number(sbegin, len, NULL); @@ -3095,7 +3092,7 @@ Perl_sv_2nv(pTHX_ register SV *sv) if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing) report_uninit(sv); } - return 0; + return (NV)0; } } if (SvTHINKFIRST(sv)) { @@ -3209,7 +3206,7 @@ Perl_sv_2nv(pTHX_ register SV *sv) flags. NWC, 2000/11/25 */ /* Both already have p flags, so do nothing */ } else { - NV nv = SvNVX(sv); + const NV nv = SvNVX(sv); if (SvNVX(sv) < (NV)IV_MAX + 0.5) { if (SvIVX(sv) == I_V(nv)) { SvNOK_on(sv); @@ -3225,7 +3222,7 @@ Perl_sv_2nv(pTHX_ register SV *sv) if (numtype & IS_NUMBER_NOT_INT) { /* UV and NV both imprecise. */ } else { - UV nv_as_uv = U_V(nv); + const UV nv_as_uv = U_V(nv); if (value == nv_as_uv && SvUVX(sv) != UV_MAX) { SvNOK_on(sv); @@ -3275,7 +3272,7 @@ STATIC IV S_asIV(pTHX_ SV *sv) { UV value; - int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value); + const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value); if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) == IS_NUMBER_IN_UV) { @@ -3328,8 +3325,7 @@ use the macro wrapper C instead. char * Perl_sv_2pv_nolen(pTHX_ register SV *sv) { - STRLEN n_a; - return sv_2pv(sv, &n_a); + return sv_2pv(sv, 0); } /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or @@ -3396,14 +3392,20 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) char *tmpbuf = tbuf; if (!sv) { - *lp = 0; + if (lp) + *lp = 0; return (char *)""; } if (SvGMAGICAL(sv)) { if (flags & SV_GMAGIC) mg_get(sv); if (SvPOKp(sv)) { - *lp = SvCUR(sv); + if (lp) + *lp = SvCUR(sv); + if (flags & SV_MUTABLE_RETURN) + return SvPVX_mutable(sv); + if (flags & SV_CONST_RETURN) + return (char *)SvPVX_const(sv); return SvPVX(sv); } if (SvIOKp(sv)) { @@ -3424,7 +3426,8 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing) report_uninit(sv); } - *lp = 0; + if (lp) + *lp = 0; return (char *)""; } } @@ -3434,7 +3437,22 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) register const char *typestr; if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) { - char *pv = SvPV(tmpstr, *lp); + /* Unwrap this: */ + /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr); */ + + char *pv; + if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) { + if (flags & SV_CONST_RETURN) { + pv = (char *) SvPVX_const(tmpstr); + } else { + pv = (flags & SV_MUTABLE_RETURN) + ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr); + } + if (lp) + *lp = SvCUR(tmpstr); + } else { + pv = sv_2pv_flags(tmpstr, lp, flags); + } if (SvUTF8(tmpstr)) SvUTF8_on(sv); else @@ -3529,7 +3547,8 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) SvUTF8_on(origsv); else SvUTF8_off(origsv); - *lp = mg->mg_len; + if (lp) + *lp = mg->mg_len; return mg->mg_ptr; } /* Fall through */ @@ -3564,13 +3583,15 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) Perl_sv_setpvf(aTHX_ tsv, "%s(0x%"UVxf")", typestr, PTR2UV(sv)); goto tokensaveref; } - *lp = strlen(typestr); + if (lp) + *lp = strlen(typestr); return (char *)typestr; } if (SvREADONLY(sv) && !SvOK(sv)) { if (ckWARN(WARN_UNINITIALIZED)) report_uninit(sv); - *lp = 0; + if (lp) + *lp = 0; return (char *)""; } } @@ -3588,8 +3609,9 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf); else ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf); - SvGROW(sv, (STRLEN)(ebuf - ptr + 1)); /* inlined from sv_setpvn */ - Move(ptr,SvPVX(sv),ebuf - ptr,char); + /* inlined from sv_setpvn */ + SvGROW_mutable(sv, (STRLEN)(ebuf - ptr + 1)); + Move(ptr,SvPVX_mutable(sv),ebuf - ptr,char); SvCUR_set(sv, ebuf - ptr); s = SvEND(sv); *s = '\0'; @@ -3604,8 +3626,7 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) if (SvTYPE(sv) < SVt_PVNV) sv_upgrade(sv, SVt_PVNV); /* The +20 is pure guesswork. Configure test needed. --jhi */ - SvGROW(sv, NV_DIG + 20); - s = SvPVX(sv); + s = SvGROW_mutable(sv, NV_DIG + 20); olderrno = errno; /* some Xenix systems wipe out errno here */ #ifdef apollo if (SvNVX(sv) == 0.0) @@ -3630,17 +3651,26 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP)) report_uninit(sv); + if (lp) *lp = 0; if (SvTYPE(sv) < SVt_PV) /* Typically the caller expects that sv_any is not NULL now. */ sv_upgrade(sv, SVt_PV); return (char *)""; } - *lp = s - SvPVX_const(sv); - SvCUR_set(sv, *lp); + { + STRLEN len = s - SvPVX_const(sv); + if (lp) + *lp = len; + SvCUR_set(sv, len); + } SvPOK_on(sv); DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n", PTR2UV(sv),SvPVX_const(sv))); + if (flags & SV_CONST_RETURN) + return (char *)SvPVX_const(sv); + if (flags & SV_MUTABLE_RETURN) + return SvPVX_mutable(sv); return SvPVX(sv); tokensave: @@ -3651,7 +3681,8 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) if (!tsv) tsv = newSVpv(tmpbuf, 0); sv_2mortal(tsv); - *lp = SvCUR(tsv); + if (lp) + *lp = SvCUR(tsv); return SvPVX(tsv); } else { @@ -3674,9 +3705,10 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) len = 1; } #endif - (void)SvUPGRADE(sv, SVt_PV); - *lp = len; - s = SvGROW(sv, len + 1); + SvUPGRADE(sv, SVt_PV); + if (lp) + *lp = len; + s = SvGROW_mutable(sv, len + 1); SvCUR_set(sv, len); SvPOKp_on(sv); return strcpy(s, t); @@ -3701,8 +3733,8 @@ void Perl_sv_copypv(pTHX_ SV *dsv, register SV *ssv) { STRLEN len; - char *s; - s = SvPV(ssv,len); + const char *s; + s = SvPV_const(ssv,len); sv_setpvn(dsv,s,len); if (SvUTF8(ssv)) SvUTF8_on(dsv); @@ -3724,8 +3756,7 @@ Usually accessed via the C macro. char * Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv) { - STRLEN n_a; - return sv_2pvbyte(sv, &n_a); + return sv_2pvbyte(sv, 0); } /* @@ -3761,8 +3792,7 @@ Usually accessed via the C macro. char * Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv) { - STRLEN n_a; - return sv_2pvutf8(sv, &n_a); + return sv_2pvutf8(sv, 0); } /* @@ -3897,9 +3927,9 @@ Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags) * had a FLAG in SVs to signal if there are any hibit * chars in the PV. Given that there isn't such a flag * make the loop as fast as possible. */ - U8 *s = (U8 *) SvPVX(sv); - U8 *e = (U8 *) SvEND(sv); - U8 *t = s; + const U8 *s = (U8 *) SvPVX_const(sv); + const U8 *e = (U8 *) SvEND(sv); + const U8 *t = s; int hibit = 0; while (t < e) { @@ -3909,11 +3939,11 @@ Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags) } if (hibit) { STRLEN len = SvCUR(sv) + 1; /* Plus the \0 */ - s = bytes_to_utf8((U8*)s, &len); + char *recoded = bytes_to_utf8((U8*)s, &len); SvPV_free(sv); /* No longer using what was there before. */ - SvPV_set(sv, (char*)s); + SvPV_set(sv, recoded); SvCUR_set(sv, len - 1); SvLEN_set(sv, len); /* No longer know the real size. */ } @@ -4005,8 +4035,8 @@ bool Perl_sv_utf8_decode(pTHX_ register SV *sv) { if (SvPOKp(sv)) { - U8 *c; - U8 *e; + const U8 *c; + const U8 *e; /* The octets may have got themselves encoded - get them back as * bytes @@ -4017,10 +4047,10 @@ Perl_sv_utf8_decode(pTHX_ register SV *sv) /* it is actually just a matter of turning the utf8 flag on, but * we want to make sure everything inside is valid utf8 first. */ - c = (U8 *) SvPVX(sv); + c = (const U8 *) SvPVX_const(sv); if (!is_utf8_string(c, SvCUR(sv)+1)) return FALSE; - e = (U8 *) SvEND(sv); + e = (const U8 *) SvEND(sv); while (c < e) { U8 ch = *c++; if (!UTF8_IS_INVARIANT(ch)) { @@ -4174,7 +4204,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) } break; case SVt_PVFM: -#ifdef PERL_COPY_ON_WRITE +#ifdef PERL_OLD_COPY_ON_WRITE if ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS) { if (dtype < SVt_PVIV) sv_upgrade(dstr, SVt_PVIV); @@ -4260,9 +4290,9 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) } } if (stype == SVt_PVLV) - (void)SvUPGRADE(dstr, SVt_PVNV); + SvUPGRADE(dstr, SVt_PVNV); else - (void)SvUPGRADE(dstr, (U32)stype); + SvUPGRADE(dstr, (U32)stype); } sflags = SvFLAGS(sstr); @@ -4354,7 +4384,8 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) } if (!intro) cv_ckproto(cv, (GV*)dstr, - SvPOK(sref) ? SvPVX(sref) : Nullch); + SvPOK(sref) + ? SvPVX_const(sref) : Nullch); } GvCV(dstr) = (CV*)sref; GvCVGEN(dstr) = 0; /* Switch off cacheness. */ @@ -4443,10 +4474,14 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) (void)SvPOK_only(dstr); if ( -#ifdef PERL_COPY_ON_WRITE - (sflags & (SVf_FAKE | SVf_READONLY)) != (SVf_FAKE | SVf_READONLY) - && + /* We're not already COW */ + ((sflags & (SVf_FAKE | SVf_READONLY)) != (SVf_FAKE | SVf_READONLY) +#ifndef PERL_OLD_COPY_ON_WRITE + /* or we are, but dstr isn't a suitable target. */ + || (SvFLAGS(dstr) & CAN_COW_MASK) != CAN_COW_FLAGS #endif + ) + && !(isSwipe = (sflags & SVs_TEMP) && /* slated for free anyway? */ !(sflags & SVf_OOK) && /* and not involved in OOK hack? */ @@ -4456,7 +4491,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) SvLEN(sstr) && /* and really is a string */ /* and won't be needed again, potentially */ !(PL_op && PL_op->op_type == OP_AASSIGN)) -#ifdef PERL_COPY_ON_WRITE +#ifdef PERL_OLD_COPY_ON_WRITE && !((sflags & CAN_COW_MASK) == CAN_COW_FLAGS && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS && SvTYPE(sstr) >= SVt_PVIV) @@ -4470,9 +4505,8 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) SvCUR_set(dstr, len); *SvEND(dstr) = '\0'; } else { - /* If PERL_COPY_ON_WRITE is not defined, then isSwipe will always + /* If PERL_OLD_COPY_ON_WRITE is not defined, then isSwipe will always be true in here. */ -#ifdef PERL_COPY_ON_WRITE /* Either it's a shared hash key, or it's suitable for copy-on-write or we can swipe the string. */ if (DEBUG_C_TEST) { @@ -4480,6 +4514,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) sv_dump(sstr); sv_dump(dstr); } +#ifdef PERL_OLD_COPY_ON_WRITE if (!isSwipe) { /* I believe I should acquire a global SV mutex if it's a COW sv (not a shared hash key) to stop @@ -4507,28 +4542,29 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) Safefree(SvPVX_const(dstr)); } -#ifdef PERL_COPY_ON_WRITE if (!isSwipe) { /* making another shared SV. */ STRLEN cur = SvCUR(sstr); STRLEN len = SvLEN(sstr); - assert (SvTYPE(dstr) >= SVt_PVIV); +#ifdef PERL_OLD_COPY_ON_WRITE if (len) { + assert (SvTYPE(dstr) >= SVt_PVIV); /* SvIsCOW_normal */ /* splice us in between source and next-after-source. */ SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr)); SV_COW_NEXT_SV_SET(sstr, dstr); - SvPV_set(dstr, SvPVX(sstr)); - } else { + SvPV_set(dstr, SvPVX_mutable(sstr)); + } else +#endif + { /* SvIsCOW_shared_hash */ - UV hash = SvUVX(sstr); DEBUG_C(PerlIO_printf(Perl_debug_log, "Copy on write: Sharing hash\n")); + + assert (SvTYPE(dstr) >= SVt_PV); SvPV_set(dstr, - sharepvn(SvPVX_const(sstr), - (sflags & SVf_UTF8?-cur:cur), hash)); - SvUV_set(dstr, hash); - } + HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr))))); + } SvLEN_set(dstr, len); SvCUR_set(dstr, cur); SvREADONLY_on(dstr); @@ -4536,9 +4572,8 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) /* Relesase a global SV mutex. */ } else -#endif { /* Passes the swipe test. */ - SvPV_set(dstr, SvPVX(sstr)); + SvPV_set(dstr, SvPVX_mutable(sstr)); SvLEN_set(dstr, SvLEN(sstr)); SvCUR_set(dstr, SvCUR(sstr)); @@ -4629,7 +4664,7 @@ Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr) SvSETMAGIC(dstr); } -#ifdef PERL_COPY_ON_WRITE +#ifdef PERL_OLD_COPY_ON_WRITE SV * Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr) { @@ -4653,7 +4688,7 @@ Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr) } else new_SV(dstr); - (void)SvUPGRADE (dstr, SVt_PVIV); + SvUPGRADE(dstr, SVt_PVIV); assert (SvPOK(sstr)); assert (SvPOKp(sstr)); @@ -4666,17 +4701,15 @@ Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr) if (SvLEN(sstr) == 0) { /* source is a COW shared hash key. */ - UV hash = SvUVX(sstr); DEBUG_C(PerlIO_printf(Perl_debug_log, "Fast copy on write: Sharing hash\n")); - SvUV_set(dstr, hash); - new_pv = sharepvn(SvPVX_const(sstr), (SvUTF8(sstr)?-cur:cur), hash); + new_pv = HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)))); goto common_exit; } SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr)); } else { assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS); - (void)SvUPGRADE (sstr, SVt_PVIV); + SvUPGRADE(sstr, SVt_PVIV); SvREADONLY_on(sstr); SvFAKE_on(sstr); DEBUG_C(PerlIO_printf(Perl_debug_log, @@ -4684,7 +4717,7 @@ Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr) SV_COW_NEXT_SV_SET(dstr, sstr); } SV_COW_NEXT_SV_SET(sstr, dstr); - new_pv = SvPVX(sstr); + new_pv = SvPVX_mutable(sstr); common_exit: SvPV_set(dstr, new_pv); @@ -4726,10 +4759,9 @@ Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN if (iv < 0) Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen"); } - (void)SvUPGRADE(sv, SVt_PV); + SvUPGRADE(sv, SVt_PV); - SvGROW(sv, len + 1); - dptr = SvPVX(sv); + dptr = SvGROW(sv, len + 1); Move(ptr,dptr,len,char); dptr[len] = '\0'; SvCUR_set(sv, len); @@ -4772,7 +4804,7 @@ Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr) return; } len = strlen(ptr); - (void)SvUPGRADE(sv, SVt_PV); + SvUPGRADE(sv, SVt_PV); SvGROW(sv, len + 1); Move(ptr,SvPVX(sv),len+1,char); @@ -4815,7 +4847,7 @@ Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len) { STRLEN allocate; SV_CHECK_THINKFIRST_COW_DROP(sv); - (void)SvUPGRADE(sv, SVt_PV); + SvUPGRADE(sv, SVt_PV); if (!ptr) { (void)SvOK_off(sv); return; @@ -4848,15 +4880,14 @@ Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len SvSETMAGIC(sv); } -#ifdef PERL_COPY_ON_WRITE +#ifdef PERL_OLD_COPY_ON_WRITE /* Need to do this *after* making the SV normal, as we need the buffer pointer to remain valid until after we've copied it. If we let go too early, another thread could invalidate it by unsharing last of the same hash key (which it can do by means other than releasing copy-on-write Svs) or by changing the other copy-on-write SVs in the loop. */ STATIC void -S_sv_release_COW(pTHX_ register SV *sv, const char *pvx, STRLEN cur, STRLEN len, - U32 hash, SV *after) +S_sv_release_COW(pTHX_ register SV *sv, const char *pvx, STRLEN len, SV *after) { if (len) { /* this SV was SvIsCOW_normal(sv) */ /* we need to find the SV pointing to us. */ @@ -4883,7 +4914,7 @@ S_sv_release_COW(pTHX_ register SV *sv, const char *pvx, STRLEN cur, STRLEN len, SV_COW_NEXT_SV_SET(current, after); } } else { - unsharepvn(pvx, SvUTF8(sv) ? -(I32)cur : cur, hash); + unshare_hek(SvSHARED_HEK_FROM_PV(pvx)); } } @@ -4915,15 +4946,14 @@ with flags set to 0. void Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags) { -#ifdef PERL_COPY_ON_WRITE +#ifdef PERL_OLD_COPY_ON_WRITE if (SvREADONLY(sv)) { /* At this point I believe I should acquire a global SV mutex. */ if (SvFAKE(sv)) { - const char *pvx = SvPVX_const(sv); - STRLEN len = SvLEN(sv); - STRLEN cur = SvCUR(sv); - U32 hash = SvUVX(sv); - SV *next = SV_COW_NEXT_SV(sv); /* next COW sv in the loop. */ + const char *pvx = SvPVX_const(sv); + const STRLEN len = SvLEN(sv); + const STRLEN cur = SvCUR(sv); + SV * const next = SV_COW_NEXT_SV(sv); /* next COW sv in the loop. */ if (DEBUG_C_TEST) { PerlIO_printf(Perl_debug_log, "Copy on write: Force normal %ld\n", @@ -4944,7 +4974,7 @@ Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags) SvCUR_set(sv, cur); *SvEND(sv) = '\0'; } - sv_release_COW(sv, pvx, cur, len, hash, next); + sv_release_COW(sv, pvx, len, next); if (DEBUG_C_TEST) { sv_dump(sv); } @@ -4956,18 +4986,16 @@ Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags) #else if (SvREADONLY(sv)) { if (SvFAKE(sv)) { - char *pvx = SvPVX_const(sv); - const int is_utf8 = SvUTF8(sv); - STRLEN len = SvCUR(sv); - U32 hash = SvUVX(sv); + const char *pvx = SvPVX_const(sv); + const STRLEN len = SvCUR(sv); SvFAKE_off(sv); SvREADONLY_off(sv); - SvPV_set(sv, (char*)0); - SvLEN_set(sv, 0); + SvPV_set(sv, Nullch); + SvLEN_set(sv, 0); SvGROW(sv, len + 1); Move(pvx,SvPVX_const(sv),len,char); *SvEND(sv) = '\0'; - unsharepvn(pvx, is_utf8 ? -(I32)len : len, hash); + unshare_hek(SvSHARED_HEK_FROM_PV(pvx)); } else if (IN_PERL_RUNTIME) Perl_croak(aTHX_ PL_no_modify); @@ -5022,7 +5050,7 @@ Perl_sv_chop(pTHX_ register SV *sv, register const char *ptr) if (!SvOOK(sv)) { if (!SvLEN(sv)) { /* make copy of shared string */ const char *pvx = SvPVX_const(sv); - STRLEN len = SvCUR(sv); + const STRLEN len = SvCUR(sv); SvGROW(sv, len + 1); Move(pvx,SvPVX_const(sv),len,char); *SvEND(sv) = '\0'; @@ -5130,11 +5158,11 @@ and C are implemented in terms of this function. void Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags) { - char *spv; + const char *spv; STRLEN slen; if (!ssv) return; - if ((spv = SvPV(ssv, slen))) { + if ((spv = SvPV_const(ssv, slen))) { /* sutf8 and dutf8 were type bool, but under USE_ITHREADS, gcc version 2.95.2 20000220 (Debian GNU/Linux) for Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously @@ -5155,7 +5183,7 @@ Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags) SV* csv = sv_2mortal(newSVpvn(spv, slen)); sv_utf8_upgrade(csv); - spv = SvPV(csv, slen); + spv = SvPV_const(csv, slen); } else sv_utf8_upgrade_nomg(dsv); @@ -5271,7 +5299,7 @@ Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, const MGVTBL *vtable, MAGIC* mg; if (SvTYPE(sv) < SVt_PVMG) { - (void)SvUPGRADE(sv, SVt_PVMG); + SvUPGRADE(sv, SVt_PVMG); } Newz(702,mg, 1, MAGIC); mg->mg_moremagic = SvMAGIC(sv); @@ -5355,7 +5383,7 @@ Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 nam const MGVTBL *vtable = 0; MAGIC* mg; -#ifdef PERL_COPY_ON_WRITE +#ifdef PERL_OLD_COPY_ON_WRITE if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0); #endif @@ -5665,7 +5693,7 @@ Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, const char *little, (void)SvPOK_only_UTF8(bigstr); if (offset + len > curlen) { SvGROW(bigstr, offset+len+1); - Zero(SvPVX_const(bigstr)+curlen, offset+len-curlen, char); + Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char); SvCUR_set(bigstr, offset+len); } @@ -5770,6 +5798,7 @@ Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv) sv->sv_flags = nsv->sv_flags; sv->sv_any = nsv->sv_any; sv->sv_refcnt = nsv->sv_refcnt; + sv->sv_u = nsv->sv_u; #else StructCopy(nsv,sv,SV); #endif @@ -5783,7 +5812,7 @@ Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv) } -#ifdef PERL_COPY_ON_WRITE +#ifdef PERL_OLD_COPY_ON_WRITE if (SvIsCOW_normal(nsv)) { /* We need to follow the pointers around the loop to make the previous SV point to sv, rather than nsv. */ @@ -5941,7 +5970,7 @@ Perl_sv_clear(pTHX_ register SV *sv) freescalar: /* Don't bother with SvOOK_off(sv); as we're only going to free it. */ if (SvOOK(sv)) { - SvPV_set(sv, SvPVX(sv) - SvIVX(sv)); + SvPV_set(sv, SvPVX_mutable(sv) - SvIVX(sv)); /* Don't even bother with turning off the OOK flag. */ } /* FALL THROUGH */ @@ -5953,7 +5982,7 @@ Perl_sv_clear(pTHX_ register SV *sv) else SvREFCNT_dec(SvRV(sv)); } -#ifdef PERL_COPY_ON_WRITE +#ifdef PERL_OLD_COPY_ON_WRITE else if (SvPVX_const(sv)) { if (SvIsCOW(sv)) { /* I believe I need to grab the global SV mutex here and @@ -5962,8 +5991,8 @@ Perl_sv_clear(pTHX_ register SV *sv) PerlIO_printf(Perl_debug_log, "Copy on write: clear\n"); sv_dump(sv); } - sv_release_COW(sv, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), - SvUVX(sv), SV_COW_NEXT_SV(sv)); + sv_release_COW(sv, SvPVX_const(sv), SvLEN(sv), + SV_COW_NEXT_SV(sv)); /* And drop it here. */ SvFAKE_off(sv); } else if (SvLEN(sv)) { @@ -5974,9 +6003,7 @@ Perl_sv_clear(pTHX_ register SV *sv) else if (SvPVX_const(sv) && SvLEN(sv)) Safefree(SvPVX_const(sv)); else if (SvPVX_const(sv) && SvREADONLY(sv) && SvFAKE(sv)) { - unsharepvn(SvPVX_const(sv), - SvUTF8(sv) ? -(I32)SvCUR(sv) : SvCUR(sv), - SvUVX(sv)); + unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv))); SvFAKE_off(sv); } #endif @@ -6146,7 +6173,7 @@ Perl_sv_len(pTHX_ register SV *sv) if (SvGMAGICAL(sv)) len = mg_length(sv); else - (void)SvPV(sv, len); + (void)SvPV_const(sv, len); return len; } @@ -6177,7 +6204,7 @@ Perl_sv_len_utf8(pTHX_ register SV *sv) else { STRLEN len, ulen; - const U8 *s = (U8*)SvPV(sv, len); + const U8 *s = (U8*)SvPV_const(sv, len); MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : 0; if (mg && mg->mg_len != -1 && (mg->mg_len > 0 || len == 0)) { @@ -6211,7 +6238,8 @@ Perl_sv_len_utf8(pTHX_ register SV *sv) * */ STATIC bool -S_utf8_mg_pos_init(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i, I32 offsetp, U8 *s, U8 *start) +S_utf8_mg_pos_init(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i, + I32 offsetp, const U8 *s, const U8 *start) { bool found = FALSE; @@ -6244,7 +6272,7 @@ S_utf8_mg_pos_init(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i, I32 offset * */ STATIC bool -S_utf8_mg_pos(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i, I32 *offsetp, I32 uoff, U8 **sp, U8 *start, U8 *send) +S_utf8_mg_pos(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i, I32 *offsetp, I32 uoff, const U8 **sp, const U8 *start, const U8 *send) { bool found = FALSE; @@ -6376,21 +6404,21 @@ type coercion. void Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp) { - U8 *start; + const U8 *start; STRLEN len; if (!sv) return; - start = (U8*)SvPV(sv, len); + start = (U8*)SvPV_const(sv, len); if (len) { STRLEN boffset = 0; STRLEN *cache = 0; - U8 *s = start; - I32 uoffset = *offsetp; - U8 *send = s + len; - MAGIC *mg = 0; - bool found = FALSE; + const U8 *s = start; + I32 uoffset = *offsetp; + const U8 *send = s + len; + MAGIC *mg = 0; + bool found = FALSE; if (utf8_mg_pos(sv, &mg, &cache, 0, offsetp, *offsetp, &s, start, send)) found = TRUE; @@ -6452,17 +6480,17 @@ Handles magic and type coercion. void Perl_sv_pos_b2u(pTHX_ register SV* sv, I32* offsetp) { - U8* s; + const U8* s; STRLEN len; if (!sv) return; - s = (U8*)SvPV(sv, len); + s = (const U8*)SvPV_const(sv, len); if ((I32)len < *offsetp) Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset"); else { - U8* send = s + *offsetp; + const U8* send = s + *offsetp; MAGIC* mg = NULL; STRLEN *cache = NULL; @@ -6494,7 +6522,7 @@ Perl_sv_pos_b2u(pTHX_ register SV* sv, I32* offsetp) STRLEN backw = cache[1] - *offsetp; if (!(forw < 2 * backw)) { - U8 *p = s + cache[1]; + const U8 *p = s + cache[1]; STRLEN ubackw = 0; cache[1] -= backw; @@ -6588,14 +6616,14 @@ Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2) cur1 = 0; } else - pv1 = SvPV(sv1, cur1); + pv1 = SvPV_const(sv1, cur1); if (!sv2){ pv2 = ""; cur2 = 0; } else - pv2 = SvPV(sv2, cur2); + pv2 = SvPV_const(sv2, cur2); if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) { /* Differing utf8ness. @@ -6604,12 +6632,12 @@ Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2) if (SvUTF8(sv1)) { svrecode = newSVpvn(pv2, cur2); sv_recode_to_utf8(svrecode, PL_encoding); - pv2 = SvPV(svrecode, cur2); + pv2 = SvPV_const(svrecode, cur2); } else { svrecode = newSVpvn(pv1, cur1); sv_recode_to_utf8(svrecode, PL_encoding); - pv1 = SvPV(svrecode, cur1); + pv1 = SvPV_const(svrecode, cur1); } /* Now both are in UTF-8. */ if (cur1 != cur2) { @@ -6681,14 +6709,14 @@ Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2) cur1 = 0; } else - pv1 = SvPV(sv1, cur1); + pv1 = SvPV_const(sv1, cur1); if (!sv2) { pv2 = ""; cur2 = 0; } else - pv2 = SvPV(sv2, cur2); + pv2 = SvPV_const(sv2, cur2); if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) { /* Differing utf8ness. @@ -6697,7 +6725,7 @@ Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2) if (PL_encoding) { svrecode = newSVpvn(pv2, cur2); sv_recode_to_utf8(svrecode, PL_encoding); - pv2 = SvPV(svrecode, cur2); + pv2 = SvPV_const(svrecode, cur2); } else { pv2 = tpv = (char*)bytes_to_utf8((const U8*)pv2, &cur2); @@ -6707,7 +6735,7 @@ Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2) if (PL_encoding) { svrecode = newSVpvn(pv1, cur1); sv_recode_to_utf8(svrecode, PL_encoding); - pv1 = SvPV(svrecode, cur1); + pv1 = SvPV_const(svrecode, cur1); } else { pv1 = tpv = (char*)bytes_to_utf8((const U8*)pv1, &cur1); @@ -6821,12 +6849,13 @@ Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp) mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL; if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) { - char *s, *xf; + const char *s; + char *xf; STRLEN len, xlen; if (mg) Safefree(mg->mg_ptr); - s = SvPV(sv, len); + s = SvPV_const(sv, len); if ((xf = mem_collxfrm(s, len, &xlen))) { if (SvREADONLY(sv)) { SAVEFREEPV(xf); @@ -6888,7 +6917,7 @@ Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append) However, perlbench says it's slower, because the existing swipe code is faster than copy on write. Swings and roundabouts. */ - (void)SvUPGRADE(sv, SVt_PV); + SvUPGRADE(sv, SVt_PV); SvSCREAM_off(sv); @@ -6974,7 +7003,7 @@ Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append) Perl_croak(aTHX_ "Wide character in $/"); } } - rsptr = SvPV(PL_rs, rslen); + rsptr = SvPV_const(PL_rs, rslen); } } @@ -7601,6 +7630,61 @@ Perl_newSVpvn(pTHX_ const char *s, STRLEN len) return sv; } + +/* +=for apidoc newSVhek + +Creates a new SV from the hash key structure. It will generate scalars that +point to the shared string table where possible. Returns a new (undefined) +SV if the hek is NULL. + +=cut +*/ + +SV * +Perl_newSVhek(pTHX_ const HEK *hek) +{ + if (!hek) { + SV *sv; + + new_SV(sv); + return sv; + } + + if (HEK_LEN(hek) == HEf_SVKEY) { + return newSVsv(*(SV**)HEK_KEY(hek)); + } else { + const int flags = HEK_FLAGS(hek); + if (flags & HVhek_WASUTF8) { + /* Trouble :-) + Andreas would like keys he put in as utf8 to come back as utf8 + */ + STRLEN utf8_len = HEK_LEN(hek); + U8 *as_utf8 = bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len); + SV *sv = newSVpvn ((char*)as_utf8, utf8_len); + + SvUTF8_on (sv); + Safefree (as_utf8); /* bytes_to_utf8() allocates a new string */ + return sv; + } else if (flags & HVhek_REHASH) { + /* We don't have a pointer to the hv, so we have to replicate the + flag into every HEK. This hv is using custom a hasing + algorithm. Hence we can't return a shared string scalar, as + that would contain the (wrong) hash value, and might get passed + into an hv routine with a regular hash */ + + SV *sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek)); + if (HEK_UTF8(hek)) + SvUTF8_on (sv); + return sv; + } + /* This will be overwhelminly the most common case. */ + return newSVpvn_share(HEK_KEY(hek), + (HEK_UTF8(hek) ? -HEK_LEN(hek) : HEK_LEN(hek)), + HEK_HASH(hek)); + } +} + /* =for apidoc newSVpvn_share @@ -7630,10 +7714,9 @@ Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash) if (!hash) PERL_HASH(hash, src, len); new_SV(sv); - sv_upgrade(sv, SVt_PVIV); + sv_upgrade(sv, SVt_PV); SvPV_set(sv, sharepvn(src, is_utf8?-len:len, hash)); SvCUR_set(sv, len); - SvUV_set(sv, hash); SvLEN_set(sv, 0); SvREADONLY_on(sv); SvFAKE_on(sv); @@ -8132,12 +8215,10 @@ Perl_sv_nv(pTHX_ register SV *sv) char * Perl_sv_pv(pTHX_ SV *sv) { - STRLEN n_a; - if (SvPOK(sv)) return SvPVX(sv); - return sv_2pv(sv, &n_a); + return sv_2pv(sv, 0); } /* @@ -8211,22 +8292,34 @@ Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags) sv_force_normal_flags(sv, 0); if (SvPOK(sv)) { - *lp = SvCUR(sv); + if (lp) + *lp = SvCUR(sv); } else { char *s; + STRLEN len; + + if (SvREADONLY(sv) && !(flags & SV_MUTABLE_RETURN)) { + if (PL_op) + Perl_croak(aTHX_ "Can't coerce readonly %s to string in %s", + sv_reftype(sv,0), OP_NAME(PL_op)); + else + Perl_croak(aTHX_ "Can't coerce readonly %s to string", + sv_reftype(sv,0)); + } if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) { Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0), OP_NAME(PL_op)); } else - s = sv_2pv_flags(sv, lp, flags); + s = sv_2pv_flags(sv, &len, flags); + if (lp) + *lp = len; + if (s != SvPVX_const(sv)) { /* Almost, but not quite, sv_setpvn() */ - const STRLEN len = *lp; - if (SvROK(sv)) sv_unref(sv); - (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */ + SvUPGRADE(sv, SVt_PV); /* Never FALSE */ SvGROW(sv, len + 1); Move(s,SvPVX_const(sv),len,char); SvCUR_set(sv, len); @@ -8239,7 +8332,7 @@ Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags) PTR2UV(sv),SvPVX_const(sv))); } } - return SvPVX(sv); + return SvPVX_mutable(sv); } /* sv_pvbyte () is now a macro using Perl_sv_2pv_flags(); @@ -8636,7 +8729,7 @@ Perl_sv_bless(pTHX_ SV *sv, HV *stash) SvOBJECT_on(tmpRef); if (SvTYPE(tmpRef) != SVt_PVIO) ++PL_sv_objcount; - (void)SvUPGRADE(tmpRef, SVt_PVMG); + SvUPGRADE(tmpRef, SVt_PVMG); SvSTASH_set(tmpRef, (HV*)SvREFCNT_inc(stash)); if (Gv_AMG(stash)) @@ -8776,7 +8869,7 @@ bool Perl_sv_tainted(pTHX_ SV *sv) { if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { - MAGIC *mg = mg_find(sv, PERL_MAGIC_taint); + MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint); if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv))) return TRUE; } @@ -9227,10 +9320,10 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV U8 utf8buf[UTF8_MAXBYTES+1]; STRLEN esignlen = 0; - char *eptr = Nullch; + const char *eptr = Nullch; STRLEN elen = 0; SV *vecsv = Nullsv; - U8 *vecstr = Null(U8*); + const U8 *vecstr = Null(U8*); STRLEN veclen = 0; char c = 0; int i; @@ -9350,18 +9443,18 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV else vecsv = (evix ? evix <= svmax : svix < svmax) ? svargs[evix ? evix-1 : svix++] : &PL_sv_undef; - dotstr = SvPVx(vecsv, dotstrlen); + dotstr = SvPV_const(vecsv, dotstrlen); if (DO_UTF8(vecsv)) is_utf8 = TRUE; } if (args) { vecsv = va_arg(*args, SV*); - vecstr = (U8*)SvPVx(vecsv,veclen); + vecstr = (U8*)SvPV_const(vecsv,veclen); vec_utf8 = DO_UTF8(vecsv); } else if (efix ? efix <= svmax : svix < svmax) { vecsv = svargs[efix ? efix-1 : svix++]; - vecstr = (U8*)SvPVx(vecsv,veclen); + vecstr = (U8*)SvPV_const(vecsv,veclen); vec_utf8 = DO_UTF8(vecsv); /* if this is a version object, we need to return the * stringified representation (which the SvPVX_const has @@ -9370,7 +9463,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV if ( *q == 'd' && sv_derived_from(vecsv,"version") ) { q++; /* skip past the rest of the %vd format */ - eptr = (char *) vecstr; + eptr = (const char *) vecstr; elen = strlen(eptr); vectorize=FALSE; goto string; @@ -9518,7 +9611,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV } } else { - eptr = SvPVx(argsv, elen); + eptr = SvPVx_const(argsv, elen); if (DO_UTF8(argsv)) { if (has_precis && precis < elen) { I32 p = precis; @@ -9551,7 +9644,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV if (vectorize) goto unknown; argsv = va_arg(*args, SV*); - eptr = SvPVx(argsv, elen); + eptr = SvPVx_const(argsv, elen); if (DO_UTF8(argsv)) is_utf8 = TRUE; goto string; @@ -9696,54 +9789,57 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV } integer: - eptr = ebuf + sizeof ebuf; - switch (base) { - unsigned dig; - case 16: - if (!uv) - alt = FALSE; - p = (char*)((c == 'X') - ? "0123456789ABCDEF" : "0123456789abcdef"); - do { - dig = uv & 15; - *--eptr = p[dig]; - } while (uv >>= 4); - if (alt) { - esignbuf[esignlen++] = '0'; - esignbuf[esignlen++] = c; /* 'x' or 'X' */ + { + char *ptr = ebuf + sizeof ebuf; + switch (base) { + unsigned dig; + case 16: + if (!uv) + alt = FALSE; + p = (char*)((c == 'X') + ? "0123456789ABCDEF" : "0123456789abcdef"); + do { + dig = uv & 15; + *--ptr = p[dig]; + } while (uv >>= 4); + if (alt) { + esignbuf[esignlen++] = '0'; + esignbuf[esignlen++] = c; /* 'x' or 'X' */ + } + break; + case 8: + do { + dig = uv & 7; + *--ptr = '0' + dig; + } while (uv >>= 3); + if (alt && *ptr != '0') + *--ptr = '0'; + break; + case 2: + do { + dig = uv & 1; + *--ptr = '0' + dig; + } while (uv >>= 1); + if (alt) { + esignbuf[esignlen++] = '0'; + esignbuf[esignlen++] = 'b'; + } + break; + default: /* it had better be ten or less */ + do { + dig = uv % base; + *--ptr = '0' + dig; + } while (uv /= base); + break; } - break; - case 8: - do { - dig = uv & 7; - *--eptr = '0' + dig; - } while (uv >>= 3); - if (alt && *eptr != '0') - *--eptr = '0'; - break; - case 2: - do { - dig = uv & 1; - *--eptr = '0' + dig; - } while (uv >>= 1); - if (alt) { - esignbuf[esignlen++] = '0'; - esignbuf[esignlen++] = 'b'; + elen = (ebuf + sizeof ebuf) - ptr; + eptr = ptr; + if (has_precis) { + if (precis > elen) + zeros = precis - elen; + else if (precis == 0 && elen == 1 && *eptr == '0') + elen = 0; } - break; - default: /* it had better be ten or less */ - do { - dig = uv % base; - *--eptr = '0' + dig; - } while (uv /= base); - break; - } - elen = (ebuf + sizeof ebuf) - eptr; - if (has_precis) { - if (precis > elen) - zeros = precis - elen; - else if (precis == 0 && elen == 1 && *eptr == '0') - elen = 0; } break; @@ -9901,50 +9997,52 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV break; } } - eptr = ebuf + sizeof ebuf; - *--eptr = '\0'; - *--eptr = c; - /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */ + { + char *ptr = ebuf + sizeof ebuf; + *--ptr = '\0'; + *--ptr = c; + /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */ #if defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl) - if (intsize == 'q') { - /* Copy the one or more characters in a long double - * format before the 'base' ([efgEFG]) character to - * the format string. */ - static char const prifldbl[] = PERL_PRIfldbl; - char const *p = prifldbl + sizeof(prifldbl) - 3; - while (p >= prifldbl) { *--eptr = *p--; } - } + if (intsize == 'q') { + /* Copy the one or more characters in a long double + * format before the 'base' ([efgEFG]) character to + * the format string. */ + static char const prifldbl[] = PERL_PRIfldbl; + char const *p = prifldbl + sizeof(prifldbl) - 3; + while (p >= prifldbl) { *--ptr = *p--; } + } #endif - if (has_precis) { - base = precis; - do { *--eptr = '0' + (base % 10); } while (base /= 10); - *--eptr = '.'; - } - if (width) { - base = width; - do { *--eptr = '0' + (base % 10); } while (base /= 10); - } - if (fill == '0') - *--eptr = fill; - if (left) - *--eptr = '-'; - if (plus) - *--eptr = plus; - if (alt) - *--eptr = '#'; - *--eptr = '%'; - - /* No taint. Otherwise we are in the strange situation - * where printf() taints but print($float) doesn't. - * --jhi */ + if (has_precis) { + base = precis; + do { *--ptr = '0' + (base % 10); } while (base /= 10); + *--ptr = '.'; + } + if (width) { + base = width; + do { *--ptr = '0' + (base % 10); } while (base /= 10); + } + if (fill == '0') + *--ptr = fill; + if (left) + *--ptr = '-'; + if (plus) + *--ptr = plus; + if (alt) + *--ptr = '#'; + *--ptr = '%'; + + /* No taint. Otherwise we are in the strange situation + * where printf() taints but print($float) doesn't. + * --jhi */ #if defined(HAS_LONG_DOUBLE) - if (intsize == 'q') - (void)sprintf(PL_efloatbuf, eptr, nv); - else - (void)sprintf(PL_efloatbuf, eptr, (double)nv); + if (intsize == 'q') + (void)sprintf(PL_efloatbuf, ptr, nv); + else + (void)sprintf(PL_efloatbuf, ptr, (double)nv); #else - (void)sprintf(PL_efloatbuf, eptr, nv); + (void)sprintf(PL_efloatbuf, ptr, nv); #endif + } float_converted: eptr = PL_efloatbuf; elen = strlen(PL_efloatbuf); @@ -10020,7 +10118,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV else { SV *nsv = sv_2mortal(newSVpvn(eptr, elen)); sv_utf8_upgrade(nsv); - eptr = SvPVX(nsv); + eptr = SvPVX_const(nsv); elen = SvCUR(nsv); } SvGROW(sv, SvCUR(sv) + elen + 1); @@ -10225,7 +10323,7 @@ Perl_re_dup(pTHX_ REGEXP *r, CLONE_PARAMS *param) ret->subbeg = SAVEPVN(r->subbeg, r->sublen); else ret->subbeg = Nullch; -#ifdef PERL_COPY_ON_WRITE +#ifdef PERL_OLD_COPY_ON_WRITE ret->saved_copy = Nullsv; #endif @@ -10638,22 +10736,11 @@ Perl_rvpv_dup(pTHX_ SV *dstr, SV *sstr, CLONE_PARAMS* param) } else { /* Special case - not normally malloced for some reason */ - if (SvREADONLY(sstr) && SvFAKE(sstr)) { - /* A "shared" PV - clone it as unshared string */ - if(SvPADTMP(sstr)) { - /* However, some of them live in the pad - and they should not have these flags - turned off */ - - SvPV_set(dstr, sharepvn(SvPVX_const(sstr), SvCUR(sstr), - SvUVX(sstr))); - SvUV_set(dstr, SvUVX(sstr)); - } else { - - SvPV_set(dstr, SAVEPVN(SvPVX_const(sstr), SvCUR(sstr))); - SvFAKE_off(dstr); - SvREADONLY_off(dstr); - } + if ((SvREADONLY(sstr) && SvFAKE(sstr))) { + /* A "shared" PV - clone it as "shared" PV */ + SvPV_set(dstr, + HEK_KEY(hek_dup(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)), + param))); } else { /* Some other special case - random pointer */ @@ -11210,9 +11297,6 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) void (*dptr) (void*); void (*dxptr) (pTHX_ void*); OP *o; - /* Unions for circumventing strict ANSI C89 casting rules. */ - union { void *vptr; void (*dptr)(void*); } u1, u2; - union { void *vptr; void (*dxptr)(pTHX_ void*); } u3, u4; Newz(54, nss, max, ANY); @@ -11384,17 +11468,17 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) ptr = POPPTR(ss,ix); TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */ dptr = POPDPTR(ss,ix); - u1.dptr = dptr; - u2.vptr = any_dup(u1.vptr, proto_perl); - TOPDPTR(nss,ix) = u2.dptr; + TOPDPTR(nss,ix) = DPTR2FPTR(void (*)(void*), + any_dup(FPTR2DPTR(void *, dptr), + proto_perl)); break; case SAVEt_DESTRUCTOR_X: ptr = POPPTR(ss,ix); TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */ dxptr = POPDXPTR(ss,ix); - u3.dxptr = dxptr; - u4.vptr = any_dup(u3.vptr, proto_perl);; - TOPDXPTR(nss,ix) = u4.dxptr; + TOPDXPTR(nss,ix) = DPTR2FPTR(void (*)(pTHX_ void*), + any_dup(FPTR2DPTR(void *, dxptr), + proto_perl)); break; case SAVEt_REGCONTEXT: case SAVEt_ALLOC: @@ -11472,10 +11556,9 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) static void do_mark_cloneable_stash(pTHX_ SV *sv) { - const char *hvname = HvNAME_get((HV*)sv); + const HEK *hvname = HvNAME_HEK((HV*)sv); if (hvname) { GV* cloner = gv_fetchmethod_autoload((HV*)sv, "CLONE_SKIP", 0); - STRLEN len = HvNAMELEN_get((HV*)sv); SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */ if (cloner && GvCV(cloner)) { dSP; @@ -11484,7 +11567,7 @@ do_mark_cloneable_stash(pTHX_ SV *sv) ENTER; SAVETMPS; PUSHMARK(SP); - XPUSHs(sv_2mortal(newSVpvn(hvname, len))); + XPUSHs(sv_2mortal(newSVhek(hvname))); PUTBACK; call_sv((SV*)GvCV(cloner), G_SCALAR); SPAGAIN; @@ -11577,6 +11660,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, * constants; they need to be allocated as common memory and just * their pointers copied. */ + IV i; CLONE_PARAMS clone_params; CLONE_PARAMS* param = &clone_params; @@ -11688,8 +11772,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, /* create SV map for pointer relocation */ PL_ptr_table = ptr_table_new(); - /* and one for finding shared hash keys quickly */ - PL_shared_hek_table = ptr_table_new(); /* initialize these special pointers as early as possible */ SvANY(&PL_sv_undef) = NULL; @@ -12293,7 +12375,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_reg_curpm = (PMOP*)NULL; PL_reg_oldsaved = Nullch; PL_reg_oldsavedlen = 0; -#ifdef PERL_COPY_ON_WRITE +#ifdef PERL_OLD_COPY_ON_WRITE PL_nrs = Nullsv; #endif PL_reg_maxiter = 0; @@ -12319,8 +12401,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, if (!(flags & CLONEf_KEEP_PTR_TABLE)) { ptr_table_free(PL_ptr_table); PL_ptr_table = NULL; - ptr_table_free(PL_shared_hek_table); - PL_shared_hek_table = NULL; } /* Call the ->CLONE method, if it exists, for each of the stashes @@ -12334,7 +12414,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, ENTER; SAVETMPS; PUSHMARK(SP); - XPUSHs(sv_2mortal(newSVpvn(HvNAME_get(stash), HvNAMELEN_get(stash)))); + XPUSHs(sv_2mortal(newSVhek(HvNAME_HEK(stash)))); PUTBACK; call_sv((SV*)GvCV(cloner), G_DISCARD); FREETMPS; @@ -12380,7 +12460,7 @@ Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding) if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) { SV *uni; STRLEN len; - char *s; + const char *s; dSP; ENTER; SAVETMPS; @@ -12404,12 +12484,11 @@ Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding) SPAGAIN; uni = POPs; PUTBACK; - s = SvPV(uni, len); + s = SvPV_const(uni, len); if (s != SvPVX_const(sv)) { SvGROW(sv, len + 1); - Move(s, SvPVX_const(sv), len, char); + Move(s, SvPVX(sv), len + 1, char); SvCUR_set(sv, len); - SvPVX(sv)[len] = 0; } FREETMPS; LEAVE;