X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=54e7d0351338e0dcfab41c498cf78ced9b4179e8;hb=46187eeb6d9336144ec364973ed57177c89816cf;hp=7e6bc2d7e4f514bda63e150dbed0f8d77b82e1cb;hpb=a6bdc2eb98f4e9bd74b51ad84203021dea610d6b;p=p5sagit%2Fp5-mst-13.2.git diff --git a/sv.c b/sv.c index 7e6bc2d..54e7d03 100644 --- a/sv.c +++ b/sv.c @@ -22,8 +22,16 @@ #include "regcomp.h" #define FCALL *f -#define SV_CHECK_THINKFIRST(sv) if (SvTHINKFIRST(sv)) sv_force_normal(sv) +#ifdef PERL_COPY_ON_WRITE +#define SV_COW_NEXT_SV(sv) INT2PTR(SV *,SvUVX(sv)) +/* This is a pessamistic view. Scalar must be purely a read-write PV to copy- + on-write. */ +#define CAN_COW_MASK (SVs_OBJECT|SVs_GMG|SVs_SMG|SVf_IOK|SVf_NOK|SVf_POK| \ + SVf_ROK|SVp_IOK|SVp_NOK|SVp_POK|SVf_FAKE|SVf_OOK| \ + SVf_BREAK|SVf_READONLY|SVf_AMAGIC) +#define CAN_COW_FLAGS (SVp_POK|SVf_POK) +#endif /* ============================================================================ @@ -1234,8 +1242,8 @@ Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt) MAGIC* magic = NULL; HV* stash = Nullhv; - if (mt != SVt_PV && SvREADONLY(sv) && SvFAKE(sv)) { - sv_force_normal(sv); + if (mt != SVt_PV && SvIsCOW(sv)) { + sv_force_normal_flags(sv, 0); } if (SvTYPE(sv) == mt) @@ -1580,12 +1588,6 @@ Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen) Renew(s,newlen,char); } else { - /* sv_force_normal_flags() must not try to unshare the new - PVX we allocate below. AMS 20010713 */ - if (SvREADONLY(sv) && SvFAKE(sv)) { - SvFAKE_off(sv); - SvREADONLY_off(sv); - } New(703, s, newlen, char); if (SvPVX(sv) && SvCUR(sv)) { Move(SvPVX(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char); @@ -1609,7 +1611,7 @@ Does not handle 'set' magic. See also C. void Perl_sv_setiv(pTHX_ register SV *sv, IV i) { - SV_CHECK_THINKFIRST(sv); + SV_CHECK_THINKFIRST_COW_DROP(sv); switch (SvTYPE(sv)) { case SVt_NULL: sv_upgrade(sv, SVt_IV); @@ -1721,7 +1723,7 @@ Does not handle 'set' magic. See also C. void Perl_sv_setnv(pTHX_ register SV *sv, NV num) { - SV_CHECK_THINKFIRST(sv); + SV_CHECK_THINKFIRST_COW_DROP(sv); switch (SvTYPE(sv)) { case SVt_NULL: case SVt_IV: @@ -2032,8 +2034,8 @@ Perl_sv_2iv(pTHX_ register SV *sv) return SvIV(tmpstr); return PTR2IV(SvRV(sv)); } - if (SvREADONLY(sv) && SvFAKE(sv)) { - sv_force_normal(sv); + if (SvIsCOW(sv)) { + sv_force_normal_flags(sv, 0); } if (SvREADONLY(sv) && !SvOK(sv)) { if (ckWARN(WARN_UNINITIALIZED)) @@ -2329,8 +2331,8 @@ Perl_sv_2uv(pTHX_ register SV *sv) return SvUV(tmpstr); return PTR2UV(SvRV(sv)); } - if (SvREADONLY(sv) && SvFAKE(sv)) { - sv_force_normal(sv); + if (SvIsCOW(sv)) { + sv_force_normal_flags(sv, 0); } if (SvREADONLY(sv) && !SvOK(sv)) { if (ckWARN(WARN_UNINITIALIZED)) @@ -2617,8 +2619,8 @@ Perl_sv_2nv(pTHX_ register SV *sv) return SvNV(tmpstr); return PTR2NV(SvRV(sv)); } - if (SvREADONLY(sv) && SvFAKE(sv)) { - sv_force_normal(sv); + if (SvIsCOW(sv)) { + sv_force_normal_flags(sv, 0); } if (SvREADONLY(sv) && !SvOK(sv)) { if (ckWARN(WARN_UNINITIALIZED)) @@ -3192,14 +3194,16 @@ would lose the UTF-8'ness of the PV. void Perl_sv_copypv(pTHX_ SV *dsv, register SV *ssv) { - SV *tmpsv = sv_newmortal(); + SV *tmpsv; - if ( SvTHINKFIRST(ssv) && SvROK(ssv) && SvAMAGIC(ssv) ) { - tmpsv = AMG_CALLun(ssv,string); + if ( SvTHINKFIRST(ssv) && SvROK(ssv) && SvAMAGIC(ssv) && + (tmpsv = AMG_CALLun(ssv,string))) { if (SvTYPE(tmpsv) != SVt_RV || (SvRV(tmpsv) != SvRV(ssv))) { SvSetSV(dsv,tmpsv); return; } + } else { + tmpsv = sv_newmortal(); } { STRLEN len; @@ -3378,8 +3382,8 @@ Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags) if (SvUTF8(sv)) return SvCUR(sv); - if (SvREADONLY(sv) && SvFAKE(sv)) { - sv_force_normal(sv); + if (SvIsCOW(sv)) { + sv_force_normal_flags(sv, 0); } if (PL_encoding) @@ -3435,8 +3439,9 @@ Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok) U8 *s; STRLEN len; - if (SvREADONLY(sv) && SvFAKE(sv)) - sv_force_normal(sv); + if (SvIsCOW(sv)) { + sv_force_normal_flags(sv, 0); + } s = (U8 *) SvPV(sv, len); if (!utf8_to_bytes(s, &len)) { if (fail_ok) @@ -3557,7 +3562,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) if (sstr == dstr) return; - SV_CHECK_THINKFIRST(dstr); + SV_CHECK_THINKFIRST_COW_DROP(dstr); if (!sstr) sstr = &PL_sv_undef; stype = SvTYPE(sstr); @@ -3885,6 +3890,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) } } else if (sflags & SVp_POK) { + bool isSwipe = 0; /* * Check to see if we can just swipe the string. If so, it's a @@ -3893,13 +3899,61 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) * has to be allocated and SvPVX(sstr) has to be freed. */ - if (SvTEMP(sstr) && /* slated for free anyway? */ - SvREFCNT(sstr) == 1 && /* and no other references to it? */ - !(sflags & SVf_OOK) && /* and not involved in OOK hack? */ - SvLEN(sstr) && /* and really is a string */ + if ( +#ifdef PERL_COPY_ON_WRITE + (sflags & (SVf_FAKE | SVf_READONLY)) != (SVf_FAKE | SVf_READONLY) + && +#endif + !(isSwipe = + (sflags & SVs_TEMP) && /* slated for free anyway? */ + !(sflags & SVf_OOK) && /* and not involved in OOK hack? */ + SvREFCNT(sstr) == 1 && /* and no other references to it? */ + SvLEN(sstr) && /* and really is a string */ /* and won't be needed again, potentially */ - !(PL_op && PL_op->op_type == OP_AASSIGN)) - { + !(PL_op && PL_op->op_type == OP_AASSIGN)) +#ifdef PERL_COPY_ON_WRITE + && !((sflags & CAN_COW_MASK) == CAN_COW_FLAGS + && SvTYPE(sstr) >= SVt_PVIV) +#endif + ) { + /* Failed the swipe test, and it's not a shared hash key either. + Have to copy the string. */ + STRLEN len = SvCUR(sstr); + SvGROW(dstr, len + 1); /* inlined from sv_setpvn */ + Move(SvPVX(sstr),SvPVX(dstr),len,char); + SvCUR_set(dstr, len); + *SvEND(dstr) = '\0'; + (void)SvPOK_only(dstr); + } 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) { + PerlIO_printf(Perl_debug_log, + "Copy on write: sstr --> dstr\n"); + Perl_sv_dump(sstr); + Perl_sv_dump(dstr); + } + if (!isSwipe) { + /* I believe I should acquire a global SV mutex if + it's a COW sv (not a shared hash key) to stop + it going un copy-on-write. + If the source SV has gone un copy on write between up there + and down here, then (assert() that) it is of the correct + form to make it copy on write again */ + if ((sflags & (SVf_FAKE | SVf_READONLY)) + != (SVf_FAKE | SVf_READONLY)) { + SvREADONLY_on(sstr); + SvFAKE_on(sstr); + /* Make the source SV into a loop of 1. + (about to become 2) */ + SV_COW_NEXT_SV(sstr) = sstr; + } + } +#endif + /* Initial code is common. */ if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */ if (SvOOK(dstr)) { SvFLAGS(dstr) &= ~SVf_OOK; @@ -3909,25 +3963,49 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) Safefree(SvPVX(dstr)); } (void)SvPOK_only(dstr); - SvPV_set(dstr, SvPVX(sstr)); - SvLEN_set(dstr, SvLEN(sstr)); - SvCUR_set(dstr, SvCUR(sstr)); - - SvTEMP_off(dstr); - (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */ - SvPV_set(sstr, Nullch); - SvLEN_set(sstr, 0); - SvCUR_set(sstr, 0); - SvTEMP_off(sstr); - } - else { /* have to copy actual string */ - STRLEN len = SvCUR(sstr); - SvGROW(dstr, len + 1); /* inlined from sv_setpvn */ - Move(SvPVX(sstr),SvPVX(dstr),len,char); - SvCUR_set(dstr, len); - *SvEND(dstr) = '\0'; - (void)SvPOK_only(dstr); - } + +#ifdef PERL_COPY_ON_WRITE + if (!isSwipe) { + /* making another shared SV. */ + STRLEN cur = SvCUR(sstr); + STRLEN len = SvLEN(sstr); + if (len) { + /* SvIsCOW_normal */ + /* splice us in between source and next-after-source. */ + SV_COW_NEXT_SV(dstr) = SV_COW_NEXT_SV(sstr); + SV_COW_NEXT_SV(sstr) = dstr; + SvPV_set(dstr, SvPVX(sstr)); + } else { + /* SvIsCOW_shared_hash */ + UV hash = SvUVX(sstr); + DEBUG_C(PerlIO_printf(Perl_debug_log, + "Copy on write: Sharing hash\n")); + SvPV_set(dstr, + sharepvn(SvPVX(sstr), + (sflags & SVf_UTF8?-cur:cur), hash)); + SvUVX(dstr) = hash; + } + SvLEN(dstr) = len; + SvCUR(dstr) = cur; + SvREADONLY_on(dstr); + SvFAKE_on(dstr); + /* Relesase a global SV mutex. */ + } + else +#endif + { /* Passes the swipe test. */ + SvPV_set(dstr, SvPVX(sstr)); + SvLEN_set(dstr, SvLEN(sstr)); + SvCUR_set(dstr, SvCUR(sstr)); + + SvTEMP_off(dstr); + (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */ + SvPV_set(sstr, Nullch); + SvLEN_set(sstr, 0); + SvCUR_set(sstr, 0); + SvTEMP_off(sstr); + } + } if (sflags & SVf_UTF8) SvUTF8_on(dstr); /*SUPPRESS 560*/ @@ -4015,7 +4093,7 @@ Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN { register char *dptr; - SV_CHECK_THINKFIRST(sv); + SV_CHECK_THINKFIRST_COW_DROP(sv); if (!ptr) { (void)SvOK_off(sv); return; @@ -4066,7 +4144,7 @@ Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr) { register STRLEN len; - SV_CHECK_THINKFIRST(sv); + SV_CHECK_THINKFIRST_COW_DROP(sv); if (!ptr) { (void)SvOK_off(sv); return; @@ -4113,7 +4191,7 @@ See C. void Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len) { - SV_CHECK_THINKFIRST(sv); + SV_CHECK_THINKFIRST_COW_DROP(sv); (void)SvUPGRADE(sv, SVt_PV); if (!ptr) { (void)SvOK_off(sv); @@ -4146,13 +4224,64 @@ Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len SvSETMAGIC(sv); } +#ifdef PERL_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, char *pvx, STRLEN cur, STRLEN len, + U32 hash, SV *after) +{ + if (len) { /* this SV was SvIsCOW_normal(sv) */ + /* we need to find the SV pointing to us. */ + SV *current = SV_COW_NEXT_SV(after); + + if (current == sv) { + /* The SV we point to points back to us (there were only two of us + in the loop.) + Hence other SV is no longer copy on write either. */ + SvFAKE_off(after); + SvREADONLY_off(after); + } else { + /* We need to follow the pointers around the loop. */ + SV *next; + while ((next = SV_COW_NEXT_SV(current)) != sv) { + assert (next); + current = next; + /* don't loop forever if the structure is bust, and we have + a pointer into a closed loop. */ + assert (current != after); + } + /* Make the SV before us point to the SV after us. */ + SV_COW_NEXT_SV(current) = after; + } + } else { + unsharepvn(pvx, SvUTF8(sv) ? -(I32)cur : cur, hash); + } +} + +int +Perl_sv_release_IVX(pTHX_ register SV *sv) +{ + if (SvIsCOW(sv)) + sv_force_normal_flags(sv, 0); + return SvOOK_off(sv); +} +#endif /* =for apidoc sv_force_normal_flags Undo various types of fakery on an SV: if the PV is a shared string, make a private copy; if we're a ref, stop refing; if we're a glob, downgrade to -an xpvmg. The C parameter gets passed to C -when unrefing. C calls this function with flags set to 0. +an xpvmg; if we're a copy-on-write scalar, this is the on-write time when +we do the copy, and is also used locally. If C is set +then a copy-on-write scalar drops its PV buffer (if any) and becomes +SvPOK_off rather than making a copy. (Used where this scalar is about to be +set to some other value. In addtion, the C parameter gets passed to +C when unrefing. C calls this function +with flags set to 0. =cut */ @@ -4160,6 +4289,45 @@ when unrefing. C calls this function with flags set to 0. void Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags) { +#ifdef PERL_COPY_ON_WRITE + if (SvREADONLY(sv)) { + /* At this point I believe I should acquire a global SV mutex. */ + if (SvFAKE(sv)) { + char *pvx = SvPVX(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. */ + if (DEBUG_C_TEST) { + PerlIO_printf(Perl_debug_log, + "Copy on write: Force normal %ld\n", + (long) flags); + Perl_sv_dump(sv); + } + SvFAKE_off(sv); + SvREADONLY_off(sv); + /* This SV doesn't own the buffer, so need to New() a new one: */ + SvPVX(sv) = 0; + SvLEN(sv) = 0; + if (flags & SV_COW_DROP_PV) { + /* OK, so we don't need to copy our buffer. */ + SvPOK_off(sv); + } else { + SvGROW(sv, cur + 1); + Move(pvx,SvPVX(sv),cur,char); + SvCUR(sv) = cur; + *SvEND(sv) = '\0'; + } + S_sv_release_COW(sv, pvx, cur, len, hash, next); + if (DEBUG_C_TEST) { + Perl_sv_dump(sv); + } + } + else if (PL_curcop != &PL_compiling) + Perl_croak(aTHX_ PL_no_modify); + /* At this point I believe that I can drop the global SV mutex. */ + } +#else if (SvREADONLY(sv)) { if (SvFAKE(sv)) { char *pvx = SvPVX(sv); @@ -4175,6 +4343,7 @@ Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags) else if (PL_curcop != &PL_compiling) Perl_croak(aTHX_ PL_no_modify); } +#endif if (SvROK(sv)) sv_unref_flags(sv, flags); else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV) @@ -4459,16 +4628,20 @@ Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, MGVTBL *vtable, /* Some magic sontains a reference loop, where the sv and object refer to each other. To prevent a reference loop that would prevent such objects being freed, we look for such loops and if we find one we - avoid incrementing the object refcount. */ + avoid incrementing the object refcount. + + Note we cannot do this to avoid self-tie loops as intervening RV must + have its REFCNT incremented to keep it in existence - instead we could + special case them in sv_free() -- NI-S + + */ if (!obj || obj == sv || how == PERL_MAGIC_arylen || how == PERL_MAGIC_qr || (SvTYPE(obj) == SVt_PVGV && (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv || GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv || - GvFORM(obj) == (CV*)sv)) || - (how == PERL_MAGIC_tiedscalar && - SvROK(obj) && (SvRV(obj) == sv || GvIO(SvRV(obj)) == (IO*)sv))) + GvFORM(obj) == (CV*)sv))) { mg->mg_obj = obj; } @@ -4509,6 +4682,10 @@ Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 nam MAGIC* mg; MGVTBL *vtable = 0; +#ifdef PERL_COPY_ON_WRITE + if (SvIsCOW(sv)) + sv_force_normal_flags(sv, 0); +#endif if (SvREADONLY(sv)) { if (PL_curcop != &PL_compiling && how != PERL_MAGIC_regex_global @@ -4886,7 +5063,7 @@ void Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv) { U32 refcnt = SvREFCNT(sv); - SV_CHECK_THINKFIRST(sv); + SV_CHECK_THINKFIRST_COW_DROP(sv); if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL)) Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Reference miscount in sv_replace()"); if (SvMAGICAL(sv)) { @@ -5039,6 +5216,24 @@ Perl_sv_clear(pTHX_ register SV *sv) else SvREFCNT_dec(SvRV(sv)); } +#ifdef PERL_COPY_ON_WRITE + else if (SvPVX(sv)) { + if (SvIsCOW(sv)) { + /* I believe I need to grab the global SV mutex here and + then recheck the COW status. */ + if (DEBUG_C_TEST) { + PerlIO_printf(Perl_debug_log, "Copy on write: clear\n"); + Perl_sv_dump(sv); + } + S_sv_release_COW(sv, SvPVX(sv), SvCUR(sv), SvLEN(sv), + SvUVX(sv), SV_COW_NEXT_SV(sv)); + /* And drop it here. */ + SvFAKE_off(sv); + } else if (SvLEN(sv)) { + Safefree(SvPVX(sv)); + } + } +#else else if (SvPVX(sv) && SvLEN(sv)) Safefree(SvPVX(sv)); else if (SvPVX(sv) && SvREADONLY(sv) && SvFAKE(sv)) { @@ -5047,6 +5242,7 @@ Perl_sv_clear(pTHX_ register SV *sv) SvUVX(sv)); SvFAKE_off(sv); } +#endif break; /* case SVt_NV: @@ -5307,9 +5503,11 @@ Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp) send = s + *offsetp; len = 0; while (s < send) { - STRLEN n; - /* Call utf8n_to_uvchr() to validate the sequence */ - utf8n_to_uvchr(s, UTF8SKIP(s), &n, 0); + STRLEN n = 1; + /* Call utf8n_to_uvchr() to validate the sequence + * (unless a simple non-UTF character) */ + if (!UTF8_IS_INVARIANT(*s)) + utf8n_to_uvchr(s, UTF8SKIP(s), &n, 0); if (n > 0) { s += n; len++; @@ -5401,7 +5599,7 @@ Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2) } if (cur1 == cur2) - eq = memEQ(pv1, pv2, cur1); + eq = (pv1 == pv2) || memEQ(pv1, pv2, cur1); if (svrecode) SvREFCNT_dec(svrecode); @@ -5635,7 +5833,12 @@ Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append) I32 i = 0; I32 rspara = 0; - SV_CHECK_THINKFIRST(sv); + SV_CHECK_THINKFIRST_COW_DROP(sv); + /* XXX. If you make this PVIV, then copy on write can copy scalars read + from <>. + 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); SvSCREAM_off(sv); @@ -5876,13 +6079,18 @@ screamer2: /* Accomodate broken VAXC compiler, which applies U8 cast to * both args of ?: operator, causing EOF to change into 255 */ - if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; } + if (cnt > 0) + i = (U8)buf[cnt - 1]; + else + i = EOF; } + if (cnt < 0) + cnt = 0; /* we do need to re-set the sv even when cnt <= 0 */ if (append) - sv_catpvn(sv, (char *) buf, cnt); + sv_catpvn(sv, (char *) buf, cnt); else - sv_setpvn(sv, (char *) buf, cnt); + sv_setpvn(sv, (char *) buf, cnt); if (i != EOF && /* joy */ (!rslen || @@ -5944,8 +6152,8 @@ Perl_sv_inc(pTHX_ register SV *sv) if (SvGMAGICAL(sv)) mg_get(sv); if (SvTHINKFIRST(sv)) { - if (SvREADONLY(sv) && SvFAKE(sv)) - sv_force_normal(sv); + if (SvIsCOW(sv)) + sv_force_normal_flags(sv, 0); if (SvREADONLY(sv)) { if (PL_curcop != &PL_compiling) Perl_croak(aTHX_ PL_no_modify); @@ -6100,8 +6308,8 @@ Perl_sv_dec(pTHX_ register SV *sv) if (SvGMAGICAL(sv)) mg_get(sv); if (SvTHINKFIRST(sv)) { - if (SvREADONLY(sv) && SvFAKE(sv)) - sv_force_normal(sv); + if (SvIsCOW(sv)) + sv_force_normal_flags(sv, 0); if (SvREADONLY(sv)) { if (PL_curcop != &PL_compiling) Perl_croak(aTHX_ PL_no_modify); @@ -6336,7 +6544,7 @@ Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash) len = tmplen; } if (!hash) - PERL_HASH(hash, (U8*)src, len); + PERL_HASH(hash, src, len); new_SV(sv); sv_upgrade(sv, SVt_PVIV); SvPVX(sv) = sharepvn(src, is_utf8?-len:len, hash); @@ -6888,7 +7096,7 @@ Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags) char *s = NULL; if (SvTHINKFIRST(sv) && !SvROK(sv)) - sv_force_normal(sv); + sv_force_normal_flags(sv, 0); if (SvPOK(sv)) { *lp = SvCUR(sv); @@ -7110,7 +7318,7 @@ Perl_newSVrv(pTHX_ SV *rv, const char *classname) new_SV(sv); - SV_CHECK_THINKFIRST(rv); + SV_CHECK_THINKFIRST_COW_DROP(rv); SvAMAGIC_off(rv); if (SvTYPE(rv) >= SVt_PVMG) { @@ -7354,7 +7562,7 @@ Perl_sv_unref_flags(pTHX_ SV *sv, U32 flags) } SvRV(sv) = 0; SvROK_off(sv); - if (SvREFCNT(rv) != 1 || SvREADONLY(rv) || flags) /* SV_IMMEDIATE_UNREF */ + if (SvREFCNT(rv) != 1 || SvREADONLY(rv) || (flags & SV_IMMEDIATE_UNREF)) SvREFCNT_dec(rv); else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */ sv_2mortal(rv); /* Schedule for freeing later */ @@ -7724,7 +7932,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV /* large enough for "%#.#f" --chip */ /* what about long double NVs? --jhi */ - SV *vecsv; + SV *vecsv = Nullsv; U8 *vecstr = Null(U8*); STRLEN veclen = 0; char c = 0; @@ -7732,7 +7940,14 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV unsigned base = 0; IV iv = 0; UV uv = 0; + /* we need a long double target in case HAS_LONG_DOUBLE but + not USE_LONG_DOUBLE + */ +#if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE + long double nv; +#else NV nv; +#endif STRLEN have; STRLEN need; STRLEN gap; @@ -7757,7 +7972,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV We allow format specification elements in this order: \d+\$ explicit format parameter index [-+ 0#]+ flags - \*?(\d+\$)?v vector with optional (optionally specified) arg + v|\*(\d+\$)?v vector with optional (optionally specified) arg \d+|\*(\d+\$)? width using optional (optionally specified) arg \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg [hlqLV] size @@ -7869,7 +8084,10 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV q++; if (*q == '*') { q++; - if (EXPECT_NUMBER(q, epix) && *q++ != '$') /* epix currently unused */ + if (EXPECT_NUMBER(q, epix) && *q++ != '$') + goto unknown; + /* XXX: todo, support specified precision parameter */ + if (epix) goto unknown; if (args) i = va_arg(*args, int); @@ -7908,18 +8126,18 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV q++; break; #endif -#if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)) +#if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE) case 'L': /* Ld */ /* FALL THROUGH */ -#endif #ifdef HAS_QUAD case 'q': /* qd */ +#endif intsize = 'q'; q++; break; #endif case 'l': -#if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)) +#if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE) if (*(q + 1) == 'l') { /* lld, llf */ intsize = 'q'; q += 2; @@ -7942,7 +8160,9 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV goto string; } - if (!args) + if (vectorize) + argsv = vecsv; + else if (!args) argsv = (efix ? efix <= svmax : svix < svmax) ? svargs[efix ? efix-1 : svix++] : &PL_sv_undef; @@ -7951,7 +8171,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV /* STRINGS */ case 'c': - uv = args ? va_arg(*args, int) : SvIVx(argsv); + uv = (args && !vectorize) ? va_arg(*args, int) : SvIVx(argsv); if ((uv > 255 || (!UNI_IS_INVARIANT(uv) && SvUTF8(sv))) && !IN_BYTES) { @@ -7967,7 +8187,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV goto string; case 's': - if (args) { + if (args && !vectorize) { eptr = va_arg(*args, char*); if (eptr) #ifdef MACOS_TRADITIONAL @@ -8004,7 +8224,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV * if ISO or ANSI decide to use '_' for something. * So we keep it hidden from users' code. */ - if (!args) + if (!args || vectorize) goto unknown; argsv = va_arg(*args, SV*); eptr = SvPVx(argsv, elen); @@ -8020,7 +8240,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV /* INTEGERS */ case 'p': - if (alt) + if (alt || vectorize) goto unknown; uv = PTR2UV(args ? va_arg(*args, void*) : argsv); base = 16; @@ -8235,12 +8455,50 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV /* This is evil, but floating point is even more evil */ - vectorize = FALSE; - nv = args ? va_arg(*args, NV) : SvNVx(argsv); + /* for SV-style calling, we can only get NV + for C-style calling, we assume %f is double; + for simplicity we allow any of %Lf, %llf, %qf for long double + */ + switch (intsize) { + case 'V': +#if defined(USE_LONG_DOUBLE) + intsize = 'q'; +#endif + break; + default: +#if defined(USE_LONG_DOUBLE) + intsize = args ? 0 : 'q'; +#endif + break; + case 'q': +#if defined(HAS_LONG_DOUBLE) + break; +#else + /* FALL THROUGH */ +#endif + case 'h': + /* FALL THROUGH */ + case 'l': + goto unknown; + } + + /* now we need (long double) if intsize == 'q', else (double) */ + nv = (args && !vectorize) ? +#if LONG_DOUBLESIZE > DOUBLESIZE + intsize == 'q' ? + va_arg(*args, long double) : + va_arg(*args, double) +#else + va_arg(*args, double) +#endif + : SvNVx(argsv); need = 0; + vectorize = FALSE; if (c != 'e' && c != 'E') { i = PERL_INT_MIN; + /* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this + will cast our (long double) to (double) */ (void)Perl_frexp(nv, &i); if (i == PERL_INT_MIN) Perl_die(aTHX_ "panic: frexp"); @@ -8262,8 +8520,9 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV eptr = ebuf + sizeof ebuf; *--eptr = '\0'; *--eptr = c; -#if defined(USE_LONG_DOUBLE) && defined(PERL_PRIfldbl) - { + /* 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. */ @@ -8294,8 +8553,14 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV /* 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); +#else (void)sprintf(PL_efloatbuf, eptr, nv); - +#endif eptr = PL_efloatbuf; elen = strlen(PL_efloatbuf); break; @@ -8303,9 +8568,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV /* SPECIAL */ case 'n': - vectorize = FALSE; i = SvCUR(sv) - origlen; - if (args) { + if (args && !vectorize) { switch (intsize) { case 'h': *(va_arg(*args, short*)) = i; break; default: *(va_arg(*args, int*)) = i; break; @@ -8318,6 +8582,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV } else sv_setuv_mg(argsv, (UV)i); + vectorize = FALSE; continue; /* not "break" */ /* UNKNOWN */ @@ -8751,7 +9016,6 @@ Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv) for (tblent = *otblent; tblent; i=0, tblent = tblent->next) { if (tblent->oldval == oldv) { tblent->newval = newv; - tbl->tbl_items++; return; } } @@ -8853,10 +9117,10 @@ char *PL_watch_pvx; /* attempt to make everything in the typeglob readonly */ STATIC SV * -S_gv_share(pTHX_ SV *sstr) +S_gv_share(pTHX_ SV *sstr, CLONE_PARAMS *param) { GV *gv = (GV*)sstr; - SV *sv = &PL_sv_no; /* just need SvREADONLY-ness */ + SV *sv = ¶m->proto_perl->Isv_no; /* just need SvREADONLY-ness */ if (GvIO(gv) || GvFORM(gv)) { GvUNIQUE_off(gv); /* GvIOs cannot be shared. nor can GvFORMs */ @@ -8866,7 +9130,7 @@ S_gv_share(pTHX_ SV *sstr) } else { /* CvPADLISTs cannot be shared */ - if (!CvXSUB(GvCV(gv))) { + if (!SvREADONLY(GvCV(gv)) && !CvXSUB(GvCV(gv))) { GvUNIQUE_off(gv); } } @@ -9047,9 +9311,10 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param) case SVt_PVGV: if (GvUNIQUE((GV*)sstr)) { SV *share; - if ((share = gv_share(sstr))) { + if ((share = gv_share(sstr, param))) { del_SV(dstr); dstr = share; + ptr_table_store(PL_ptr_table, sstr, dstr); #if 0 PerlIO_printf(Perl_debug_log, "sv_dup: sharing %s::%s\n", HvNAME(GvSTASH(share)), GvNAME(share)); @@ -9284,7 +9549,7 @@ Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param) case CXt_EVAL: ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval; ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type; - ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv, param);; + ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv, param); ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root; ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text, param); break; @@ -9709,7 +9974,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PERL_SET_THX(my_perl); # ifdef DEBUGGING - memset(my_perl, 0xab, sizeof(PerlInterpreter)); + Poison(my_perl, 1, PerlInterpreter); PL_markstack = 0; PL_scopestack = 0; PL_savestack = 0; @@ -9740,7 +10005,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, # ifdef DEBUGGING - memset(my_perl, 0xab, sizeof(PerlInterpreter)); + Poison(my_perl, 1, PerlInterpreter); PL_markstack = 0; PL_scopestack = 0; PL_savestack = 0; @@ -9752,6 +10017,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, # endif /* DEBUGGING */ #endif /* PERL_IMPLICIT_SYS */ param->flags = flags; + param->proto_perl = proto_perl; /* arena roots */ PL_xiv_arenaroot = NULL; @@ -10089,16 +10355,29 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, Copy(proto_perl->Inexttype, PL_nexttype, 5, I32); PL_nexttoke = proto_perl->Inexttoke; - PL_linestr = sv_dup_inc(proto_perl->Ilinestr, param); - i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr); - PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i); - i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr); - PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i); - i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr); - PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i); + /* XXX This is probably masking the deeper issue of why + * SvANY(proto_perl->Ilinestr) can be NULL at this point. For test case: + * http://archive.develooper.com/perl5-porters%40perl.org/msg83298.html + * (A little debugging with a watchpoint on it may help.) + */ + if (SvANY(proto_perl->Ilinestr)) { + PL_linestr = sv_dup_inc(proto_perl->Ilinestr, param); + i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr); + PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i); + i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr); + PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i); + i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr); + PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i); + i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr); + PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i); + } + else { + PL_linestr = NEWSV(65,79); + sv_upgrade(PL_linestr,SVt_PVIV); + sv_setpvn(PL_linestr,"",0); + PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr); + } PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); - i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr); - PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i); PL_pending_ident = proto_perl->Ipending_ident; PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */ @@ -10119,11 +10398,19 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_padix_floor = proto_perl->Ipadix_floor; PL_pad_reset_pending = proto_perl->Ipad_reset_pending; - i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr); - PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i); - i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr); - PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i); - PL_last_lop_op = proto_perl->Ilast_lop_op; + /* XXX See comment on SvANY(proto_perl->Ilinestr) above */ + if (SvANY(proto_perl->Ilinestr)) { + i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr); + PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i); + i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr); + PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i); + PL_last_lop_op = proto_perl->Ilast_lop_op; + } + else { + PL_last_uni = SvPVX(PL_linestr); + PL_last_lop = SvPVX(PL_linestr); + PL_last_lop_op = 0; + } PL_in_my = proto_perl->Iin_my; PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash, param); #ifdef FCRYPT @@ -10453,7 +10740,7 @@ The PV of the sv is returned. char * Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding) { - if (SvPOK(sv) && !DO_UTF8(sv) && SvROK(encoding)) { + if (SvPOK(sv) && !DO_UTF8(sv) && SvROK(encoding)) { SV *uni; STRLEN len; char *s; @@ -10464,7 +10751,16 @@ Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding) EXTEND(SP, 3); XPUSHs(encoding); XPUSHs(sv); +/* + NI-S 2002/07/09 + Passing sv_yes is wrong - it needs to be or'ed set of constants + for Encode::XS, while UTf-8 decode (currently) assumes a true value means + remove converted chars from source. + + Both will default the value - let them. + XPUSHs(&PL_sv_yes); +*/ PUTBACK; call_method("decode", G_SCALAR); SPAGAIN; @@ -10472,15 +10768,17 @@ Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding) PUTBACK; s = SvPV(uni, len); if (s != SvPVX(sv)) { - SvGROW(sv, len); + SvGROW(sv, len + 1); Move(s, SvPVX(sv), len, char); SvCUR_set(sv, len); + SvPVX(sv)[len] = 0; } FREETMPS; LEAVE; SvUTF8_on(sv); - } - return SvPVX(sv); + } + return SvPVX(sv); } +