X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=de411a597bbe1ff3733342d762cd0c12ec9eaa20;hb=cdb061a3fd27d5d1ef0b49f7eca3a56c45076e24;hp=69a8908ed46ea070def050bf611eb1a8ef3ca8d8;hpb=bd08039be6ae803dd509ca33cf404bdcdd4bae99;p=p5sagit%2Fp5-mst-13.2.git diff --git a/sv.c b/sv.c index 69a8908..de411a5 100644 --- a/sv.c +++ b/sv.c @@ -1804,7 +1804,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 +1814,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 +1837,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); @@ -2037,7 +2037,7 @@ 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); @@ -2248,8 +2248,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 +2323,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 +3096,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 +3210,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 +3226,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 +3276,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 +3329,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 +3396,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 +3430,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 +3441,7 @@ 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); + char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr); if (SvUTF8(tmpstr)) SvUTF8_on(sv); else @@ -3529,7 +3536,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 +3572,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 *)""; } } @@ -3589,7 +3599,7 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) 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); + Move(ptr,SvPVX_mutable(sv),ebuf - ptr,char); SvCUR_set(sv, ebuf - ptr); s = SvEND(sv); *s = '\0'; @@ -3605,7 +3615,7 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) sv_upgrade(sv, SVt_PVNV); /* The +20 is pure guesswork. Configure test needed. --jhi */ SvGROW(sv, NV_DIG + 20); - s = SvPVX(sv); + s = SvPVX_mutable(sv); olderrno = errno; /* some Xenix systems wipe out errno here */ #ifdef apollo if (SvNVX(sv) == 0.0) @@ -3630,17 +3640,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 +3670,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,8 +3694,9 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) len = 1; } #endif - (void)SvUPGRADE(sv, SVt_PV); - *lp = len; + SvUPGRADE(sv, SVt_PV); + if (lp) + *lp = len; s = SvGROW(sv, len + 1); SvCUR_set(sv, len); SvPOKp_on(sv); @@ -3701,8 +3722,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 +3745,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 +3781,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); } /* @@ -4260,9 +4279,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); @@ -4443,10 +4462,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_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? */ @@ -4472,7 +4495,6 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) } else { /* If PERL_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 +4502,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) sv_dump(sstr); sv_dump(dstr); } +#ifdef PERL_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,23 +4530,27 @@ 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_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 { + } else +#endif + { /* SvIsCOW_shared_hash */ - UV hash = SvUVX(sstr); + UV hash = SvSHARED_HASH(sstr); DEBUG_C(PerlIO_printf(Perl_debug_log, "Copy on write: Sharing hash\n")); + + assert (SvTYPE(dstr) >= SVt_PVIV); SvPV_set(dstr, sharepvn(SvPVX_const(sstr), (sflags & SVf_UTF8?-cur:cur), hash)); @@ -4536,7 +4563,6 @@ 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)); SvLEN_set(dstr, SvLEN(sstr)); @@ -4653,7 +4679,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,7 +4692,7 @@ Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr) if (SvLEN(sstr) == 0) { /* source is a COW shared hash key. */ - UV hash = SvUVX(sstr); + UV hash = SvSHARED_HASH(sstr); DEBUG_C(PerlIO_printf(Perl_debug_log, "Fast copy on write: Sharing hash\n")); SvUV_set(dstr, hash); @@ -4676,7 +4702,7 @@ Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr) 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, @@ -4726,7 +4752,7 @@ 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); @@ -4772,7 +4798,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 +4841,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; @@ -4920,10 +4946,10 @@ Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags) /* 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 STRLEN len = SvLEN(sv); + const STRLEN cur = SvCUR(sv); + const U32 hash = SvSHARED_HASH(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", @@ -4956,14 +4982,14 @@ Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags) #else if (SvREADONLY(sv)) { if (SvFAKE(sv)) { - char *pvx = SvPVX_const(sv); + const char *pvx = SvPVX_const(sv); const int is_utf8 = SvUTF8(sv); - STRLEN len = SvCUR(sv); - U32 hash = SvUVX(sv); + const STRLEN len = SvCUR(sv); + const U32 hash = SvSHARED_HASH(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'; @@ -5130,11 +5156,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 @@ -5271,7 +5297,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); @@ -6146,7 +6172,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 +6203,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 +6237,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 +6271,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 +6403,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 +6479,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 +6521,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 +6615,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. @@ -6681,14 +6708,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. @@ -6888,7 +6915,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); @@ -7603,17 +7630,25 @@ Perl_newSVpvn(pTHX_ const char *s, STRLEN len) /* -=for apidoc newSVpv_hek +=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. +point to the shared string table where possible. Returns a new (undefined) +SV if the hek is NULL. =cut */ SV * -Perl_newSVpv_hek(pTHX_ const HEK *hek) +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 { @@ -8262,6 +8297,15 @@ Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags) } else { char *s; + + 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)); @@ -8273,7 +8317,7 @@ Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags) 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); @@ -8286,7 +8330,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(); @@ -8683,7 +8727,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)) @@ -9274,10 +9318,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; @@ -9397,18 +9441,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 @@ -9417,7 +9461,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; @@ -9565,7 +9609,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; @@ -9598,7 +9642,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; @@ -9743,54 +9787,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; @@ -9948,50 +9995,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); @@ -11519,10 +11568,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; @@ -11531,7 +11579,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; @@ -11624,6 +11672,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; @@ -12381,7 +12430,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;