X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/8a31060d0e98afa6004d194f5c17a527289cb541..c8c7fdd1a93cac2b3a20ec43fed0b1327c000811:/sv.c diff --git a/sv.c b/sv.c index f3940d9..08eac58 100644 --- a/sv.c +++ b/sv.c @@ -22,8 +22,17 @@ #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)) +#define SV_COW_NEXT_SV_SET(current,next) SvUVX(current) = PTR2UV(next) +/* This is a pessimistic view. Scalar must be purely a read-write PV to copy- + on-write. */ +#define CAN_COW_MASK (SVs_OBJECT|SVs_GMG|SVs_SMG|SVs_RMG|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 /* ============================================================================ @@ -155,7 +164,28 @@ Public API: /* new_SV(): return a new, empty SV head */ -#define new_SV(p) \ +#ifdef DEBUG_LEAKING_SCALARS +/* provide a real function for a debugger to play with */ +STATIC SV* +S_new_SV(pTHX) +{ + SV* sv; + + LOCK_SV_MUTEX; + if (PL_sv_root) + uproot_SV(sv); + else + sv = more_sv(); + UNLOCK_SV_MUTEX; + SvANY(sv) = 0; + SvREFCNT(sv) = 1; + SvFLAGS(sv) = 0; + return sv; +} +# define new_SV(p) (p)=S_new_SV(aTHX) + +#else +# define new_SV(p) \ STMT_START { \ LOCK_SV_MUTEX; \ if (PL_sv_root) \ @@ -167,6 +197,7 @@ Public API: SvREFCNT(p) = 1; \ SvFLAGS(p) = 0; \ } STMT_END +#endif /* del_SV(): return an empty SV head to the free list */ @@ -1118,13 +1149,8 @@ S_more_xpvbm(pTHX) xpvbm->xpv_pv = 0; } -#ifdef LEAKTEST -# define my_safemalloc(s) (void*)safexmalloc(717,s) -# define my_safefree(p) safexfree((char*)p) -#else -# define my_safemalloc(s) (void*)safemalloc(s) -# define my_safefree(p) safefree((char*)p) -#endif +#define my_safemalloc(s) (void*)safemalloc(s) +#define my_safefree(p) safefree((char*)p) #ifdef PURIFY @@ -1234,8 +1260,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) @@ -1570,7 +1596,7 @@ Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen) if (newlen > SvLEN(sv)) { /* need more room? */ if (SvLEN(sv) && s) { -#if defined(MYMALLOC) && !defined(LEAKTEST) +#ifdef MYMALLOC STRLEN l = malloced_size((void*)SvPVX(sv)); if (newlen <= l) { SvLEN_set(sv, l); @@ -1580,12 +1606,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 +1629,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 +1741,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: @@ -2028,12 +2048,12 @@ Perl_sv_2iv(pTHX_ register SV *sv) if (SvROK(sv)) { SV* tmpstr; if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) && - (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv)))) + (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(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)) @@ -2325,12 +2345,12 @@ Perl_sv_2uv(pTHX_ register SV *sv) if (SvROK(sv)) { SV* tmpstr; if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) && - (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv)))) + (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(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)) @@ -2613,12 +2633,12 @@ Perl_sv_2nv(pTHX_ register SV *sv) if (SvROK(sv)) { SV* tmpstr; if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) && - (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv)))) + (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(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)) @@ -2875,16 +2895,6 @@ uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob) return ptr; } -/* sv_2pv() is now a macro using Perl_sv_2pv_flags(); - * this function provided for binary compatibility only - */ - -char * -Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp) -{ - return sv_2pv_flags(sv, lp, SV_GMAGIC); -} - /* =for apidoc sv_2pv_flags @@ -2902,7 +2912,7 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) { register char *s; int olderrno; - SV *tsv; + SV *tsv, *origsv; char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */ char *tmpbuf = tbuf; @@ -2943,8 +2953,15 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) if (SvROK(sv)) { SV* tmpstr; if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) && - (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv)))) - return SvPV(tmpstr,*lp); + (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) { + char *pv = SvPV(tmpstr, *lp); + if (SvUTF8(tmpstr)) + SvUTF8_on(sv); + else + SvUTF8_off(sv); + return pv; + } + origsv = sv; sv = (SV*)SvRV(sv); if (!sv) s = "NULLREF"; @@ -2956,7 +2973,6 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) if ( ((SvFLAGS(sv) & (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG)) == (SVs_OBJECT|SVs_RMG)) - && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp") && (mg = mg_find(sv, PERL_MAGIC_qr))) { regexp *re = (regexp *)mg->mg_obj; @@ -3012,6 +3028,7 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) need a newline */ mg->mg_len++; /* save space for it */ need_newline = 1; /* note to add it */ + break; } } } @@ -3027,6 +3044,11 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) mg->mg_ptr[mg->mg_len] = 0; } PL_reginterp_cnt += re->program[0].next_off; + + if (re->reganch & ROPT_UTF8) + SvUTF8_on(origsv); + else + SvUTF8_off(origsv); *lp = mg->mg_len; return mg->mg_ptr; } @@ -3052,15 +3074,8 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) default: s = "UNKNOWN"; break; } tsv = NEWSV(0,0); - if (SvOBJECT(sv)) { - HV *svs = SvSTASH(sv); - Perl_sv_setpvf( - aTHX_ tsv, "%s=%s", - /* [20011101.072] This bandaid for C - should eventually be removed. AMS 20011103 */ - (svs ? HvNAME(svs) : ""), s - ); - } + if (SvOBJECT(sv)) + Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s); else sv_setpv(tsv, s); Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv)); @@ -3202,26 +3217,14 @@ would lose the UTF-8'ness of the PV. void Perl_sv_copypv(pTHX_ SV *dsv, register SV *ssv) { - SV *tmpsv = sv_newmortal(); - - 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; - } - } - { - STRLEN len; - char *s; - s = SvPV(ssv,len); - sv_setpvn(tmpsv,s,len); - if (SvUTF8(ssv)) - SvUTF8_on(tmpsv); - else - SvUTF8_off(tmpsv); - SvSetSV(dsv,tmpsv); - } + STRLEN len; + char *s; + s = SvPV(ssv,len); + sv_setpvn(dsv,s,len); + if (SvUTF8(ssv)) + SvUTF8_on(dsv); + else + SvUTF8_off(dsv); } /* @@ -3354,21 +3357,6 @@ if all the bytes have hibit clear. This is not as a general purpose byte encoding to Unicode interface: use the Encode extension for that. -=cut -*/ - -/* sv_utf8_upgrade() is now a macro using sv_utf8_upgrade_flags(); - * this function provided for binary compatibility only - */ - - -STRLEN -Perl_sv_utf8_upgrade(pTHX_ register SV *sv) -{ - return sv_utf8_upgrade_flags(sv, SV_GMAGIC); -} - -/* =for apidoc sv_utf8_upgrade_flags Convert the PV of an SV to its UTF8-encoded form. @@ -3403,8 +3391,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) @@ -3460,8 +3448,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) @@ -3552,21 +3541,6 @@ You probably want to use one of the assortment of wrappers, such as C, C, C and C. - -=cut -*/ - -/* sv_setsv() is now a macro using Perl_sv_setsv_flags(); - * this function provided for binary compatibility only - */ - -void -Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) -{ - sv_setsv_flags(dstr, sstr, SV_GMAGIC); -} - -/* =for apidoc sv_setsv_flags Copies the contents of the source SV C into the destination SV @@ -3597,13 +3571,19 @@ 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); dtype = SvTYPE(dstr); SvAMAGIC_off(dstr); + if ( SvVOK(dstr) ) + { + /* need to nuke the magic */ + mg_free(dstr); + SvRMAGICAL_off(dstr); + } /* There's a lot of redundancy below but we're going for speed here */ @@ -3782,7 +3762,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) switch (SvTYPE(sref)) { case SVt_PVAV: if (intro) - SAVESPTR(GvAV(dstr)); + SAVEGENERICSV(GvAV(dstr)); else dref = (SV*)GvAV(dstr); GvAV(dstr) = (AV*)sref; @@ -3794,7 +3774,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) break; case SVt_PVHV: if (intro) - SAVESPTR(GvHV(dstr)); + SAVEGENERICSV(GvHV(dstr)); else dref = (SV*)GvHV(dstr); GvHV(dstr) = (HV*)sref; @@ -3812,7 +3792,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) GvCVGEN(dstr) = 0; /* Switch off cacheness. */ PL_sub_generation++; } - SAVESPTR(GvCV(dstr)); + SAVEGENERICSV(GvCV(dstr)); } else dref = (SV*)GvCV(dstr); @@ -3862,21 +3842,21 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) break; case SVt_PVIO: if (intro) - SAVESPTR(GvIOp(dstr)); + SAVEGENERICSV(GvIOp(dstr)); else dref = (SV*)GvIOp(dstr); GvIOp(dstr) = (IO*)sref; break; case SVt_PVFM: if (intro) - SAVESPTR(GvFORM(dstr)); + SAVEGENERICSV(GvFORM(dstr)); else dref = (SV*)GvFORM(dstr); GvFORM(dstr) = (CV*)sref; break; default: if (intro) - SAVESPTR(GvSV(dstr)); + SAVEGENERICSV(GvSV(dstr)); else dref = (SV*)GvSV(dstr); GvSV(dstr) = sref; @@ -3889,8 +3869,6 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) } if (dref) SvREFCNT_dec(dref); - if (intro) - SAVEFREESV(sref); if (SvTAINTED(sstr)) SvTAINT(dstr); return; @@ -3925,6 +3903,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 @@ -3933,13 +3912,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"); + sv_dump(sstr); + 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_SET(sstr, sstr); + } + } +#endif + /* Initial code is common. */ if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */ if (SvOOK(dstr)) { SvFLAGS(dstr) &= ~SVf_OOK; @@ -3949,25 +3976,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_SET(dstr, SV_COW_NEXT_SV(sstr)); + SV_COW_NEXT_SV_SET(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*/ @@ -3985,6 +4036,12 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) SvIsUV_on(dstr); SvIVX(dstr) = SvIVX(sstr); } + if (SvVOK(sstr)) { + MAGIC *smg = mg_find(sstr,PERL_MAGIC_vstring); + sv_magic(dstr, NULL, PERL_MAGIC_vstring, + smg->mg_ptr, smg->mg_len); + SvRMAGICAL_on(dstr); + } } else if (sflags & SVp_IOK) { if (sflags & SVf_IOK) @@ -4055,7 +4112,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; @@ -4106,7 +4163,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; @@ -4153,7 +4210,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); @@ -4186,13 +4243,65 @@ 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); + assert (SvPVX(current) == pvx); + } + /* Make the SV before us point to the SV after us. */ + SV_COW_NEXT_SV_SET(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 */ @@ -4200,6 +4309,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); + 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'; + } + sv_release_COW(sv, pvx, cur, len, hash, next); + if (DEBUG_C_TEST) { + 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); @@ -4215,6 +4363,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) @@ -4286,20 +4435,6 @@ C indicates number of bytes to copy. If the SV has the UTF8 status set, then the bytes appended should be valid UTF8. Handles 'get' magic, but not 'set' magic. See C. -=cut -*/ - -/* sv_catpvn() is now a macro using Perl_sv_catpvn_flags(); - * this function provided for binary compatibility only - */ - -void -Perl_sv_catpvn(pTHX_ SV *dsv, const char* sstr, STRLEN slen) -{ - sv_catpvn_flags(dsv, sstr, slen, SV_GMAGIC); -} - -/* =for apidoc sv_catpvn_flags Concatenates the string onto the end of the string which is in the SV. The @@ -4351,19 +4486,6 @@ Concatenates the string from SV C onto the end of the string in SV C. Modifies C but not C. Handles 'get' magic, but not 'set' magic. See C. -=cut */ - -/* sv_catsv() is now a macro using Perl_sv_catsv_flags(); - * this function provided for binary compatibility only - */ - -void -Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr) -{ - sv_catsv_flags(dstr, sstr, SV_GMAGIC); -} - -/* =for apidoc sv_catsv_flags Concatenates the string from SV C onto the end of the string in @@ -4526,7 +4648,12 @@ 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. + + */ if (!obj || obj == sv || how == PERL_MAGIC_arylen || how == PERL_MAGIC_qr || @@ -4541,6 +4668,21 @@ Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, MGVTBL *vtable, mg->mg_obj = SvREFCNT_inc(obj); mg->mg_flags |= MGf_REFCOUNTED; } + + /* Normal self-ties simply pass a null object, and instead of + using mg_obj directly, use the SvTIED_obj macro to produce a + new RV as needed. For glob "self-ties", we are tieing the PVIO + with an RV obj pointing to the glob containing the PVIO. In + this case, to avoid a reference loop, we need to weaken the + reference. + */ + + if (how == PERL_MAGIC_tiedscalar && SvTYPE(sv) == SVt_PVIO && + obj && SvROK(obj) && GvIO(SvRV(obj)) == (IO*)sv) + { + sv_rvweaken(obj); + } + mg->mg_type = how; mg->mg_len = namlen; if (name) { @@ -4574,6 +4716,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 @@ -4645,11 +4791,6 @@ Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 nam case PERL_MAGIC_dbline: vtable = &PL_vtbl_dbline; break; -#ifdef USE_5005THREADS - case PERL_MAGIC_mutex: - vtable = &PL_vtbl_mutex; - break; -#endif /* USE_5005THREADS */ #ifdef USE_LOCALE_COLLATE case PERL_MAGIC_collxfrm: vtable = &PL_vtbl_collxfrm; @@ -4680,6 +4821,9 @@ Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 nam case PERL_MAGIC_vec: vtable = &PL_vtbl_vec; break; + case PERL_MAGIC_vstring: + vtable = 0; + break; case PERL_MAGIC_substr: vtable = &PL_vtbl_substr; break; @@ -4951,7 +5095,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)) { @@ -4968,6 +5112,28 @@ Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv) sv_clear(sv); assert(!SvREFCNT(sv)); StructCopy(nsv,sv,SV); +#ifdef PERL_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. */ + SV *next; + SV *current = nsv; + while ((next = SV_COW_NEXT_SV(current)) != nsv) { + assert(next); + current = next; + assert(SvPVX(current) == SvPVX(nsv)); + } + /* Make the SV before us point to the SV after us. */ + if (DEBUG_C_TEST) { + PerlIO_printf(Perl_debug_log, "previous is\n"); + sv_dump(current); + PerlIO_printf(Perl_debug_log, + "move it from 0x%"UVxf" to 0x%"UVxf"\n", + (UV) SV_COW_NEXT_SV(current), (UV) sv); + } + SV_COW_NEXT_SV_SET(current, sv); + } +#endif SvREFCNT(sv) = refcnt; SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */ del_SV(nsv); @@ -5017,7 +5183,7 @@ Perl_sv_clear(pTHX_ register SV *sv) PUSHMARK(SP); PUSHs(&tmpref); PUTBACK; - call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR); + call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR|G_VOID); SvREFCNT(sv)--; POPSTACK; SPAGAIN; @@ -5104,6 +5270,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"); + sv_dump(sv); + } + 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)) { @@ -5112,6 +5296,7 @@ Perl_sv_clear(pTHX_ register SV *sv) SvUVX(sv)); SvFAKE_off(sv); } +#endif break; /* case SVt_NV: @@ -5372,9 +5557,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++; @@ -5466,7 +5653,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); @@ -5700,7 +5887,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); @@ -5941,13 +6133,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 || @@ -6009,8 +6206,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); @@ -6165,8 +6362,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); @@ -6661,8 +6858,14 @@ Perl_sv_reset(pTHX_ register char *s, HV *stash) if (GvHV(gv) && !HvNAME(GvHV(gv))) { hv_clear(GvHV(gv)); #ifdef USE_ENVIRON_ARRAY - if (gv == PL_envgv) + if (gv == PL_envgv +# ifdef USE_ITHREADS + && PL_curinterp == aTHX +# endif + ) + { environ[0] = Nullch; + } #endif } } @@ -6893,26 +7096,6 @@ Perl_sv_nv(pTHX_ register SV *sv) Use the C macro instead -=cut -*/ - -/* sv_pv() is now a macro using SvPV_nolen(); - * this function provided for binary compatibility only - */ - - -char * -Perl_sv_pv(pTHX_ SV *sv) -{ - STRLEN n_a; - - if (SvPOK(sv)) - return SvPVX(sv); - - return sv_2pv(sv, &n_a); -} - -/* =for apidoc sv_pvn A private implementation of the C macro for compilers which can't @@ -6949,20 +7132,6 @@ Get a sensible string out of the SV somehow. A private implementation of the C macro for compilers which can't cope with complex macro expressions. Always use the macro instead. -=cut -*/ - -/* sv_pvn_force() is now a macro using Perl_sv_pvn_force_flags(); - * this function provided for binary compatibility only - */ - -char * -Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp) -{ - return sv_pvn_force_flags(sv, lp, SV_GMAGIC); -} - -/* =for apidoc sv_pvn_force_flags Get a sensible string out of the SV somehow. @@ -6981,7 +7150,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); @@ -7019,22 +7188,6 @@ Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags) Use C instead. -=cut -*/ - -/* sv_pvbyte () is now a macro using Perl_sv_2pv_flags(); - * this function provided for binary compatibility only - */ - - -char * -Perl_sv_pvbyte(pTHX_ SV *sv) -{ - sv_utf8_downgrade(sv,0); - return sv_pv(sv); -} - -/* =for apidoc sv_pvbyten A private implementation of the C macro for compilers @@ -7073,21 +7226,6 @@ Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp) Use the C macro instead -=cut -*/ -/* sv_pvutf8 () is now a macro using Perl_sv_2pv_flags(); - * this function provided for binary compatibility only - */ - - -char * -Perl_sv_pvutf8(pTHX_ SV *sv) -{ - sv_utf8_upgrade(sv); - return sv_pv(sv); -} - -/* =for apidoc sv_pvutf8n A private implementation of the C macro for compilers @@ -7133,10 +7271,7 @@ char * Perl_sv_reftype(pTHX_ SV *sv, int ob) { if (ob && SvOBJECT(sv)) { - HV *svs = SvSTASH(sv); - /* [20011101.072] This bandaid for C should eventually - be removed. AMS 20011103 */ - return (svs ? HvNAME(svs) : ""); + return HvNAME(SvSTASH(sv)); } else { switch (SvTYPE(sv)) { @@ -7149,6 +7284,8 @@ Perl_sv_reftype(pTHX_ SV *sv, int ob) case SVt_PVNV: case SVt_PVMG: case SVt_PVBM: + if (SvVOK(sv)) + return "VSTRING"; if (SvROK(sv)) return "REF"; else @@ -7234,7 +7371,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) { @@ -7422,9 +7559,6 @@ Perl_sv_bless(pTHX_ SV *sv, HV *stash) } /* Downgrades a PVGV to a PVMG. - * - * XXX This function doesn't actually appear to be used anywhere - * DAPM 15-Jun-01 */ STATIC void @@ -7481,7 +7615,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 */ @@ -7552,44 +7686,6 @@ Perl_sv_tainted(pTHX_ SV *sv) return FALSE; } -/* -=for apidoc sv_setpviv - -Copies an integer into the given SV, also updating its string value. -Does not handle 'set' magic. See C. - -=cut -*/ - -void -Perl_sv_setpviv(pTHX_ SV *sv, IV iv) -{ - char buf[TYPE_CHARS(UV)]; - char *ebuf; - char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf); - - sv_setpvn(sv, ptr, ebuf - ptr); -} - -/* -=for apidoc sv_setpviv_mg - -Like C, but also handles 'set' magic. - -=cut -*/ - -void -Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv) -{ - char buf[TYPE_CHARS(UV)]; - char *ebuf; - char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf); - - sv_setpvn(sv, ptr, ebuf - ptr); - SvSETMAGIC(sv); -} - #if defined(PERL_IMPLICIT_CONTEXT) /* pTHX_ magic can't cope with varargs, so this is a no-context @@ -7858,7 +7954,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV } if (!args && svix < svmax && DO_UTF8(*svargs)) - has_utf8 = TRUE; + has_utf8 = TRUE; patend = (char*)pat + patlen; for (p = (char*)pat; p < patend; p = q) { @@ -7875,7 +7971,12 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV bool has_precis = FALSE; STRLEN precis = 0; bool is_utf8 = FALSE; /* is this item utf8? */ - +#ifdef HAS_LDBL_SPRINTF_BUG + /* This is to try to fix a bug with irix/nonstop-ux/powerux and + with sfio - Allen */ + bool fix_ldbl_sprintf_bug = FALSE; +#endif + char esignbuf[4]; U8 utf8buf[UTF8_MAXLEN+1]; STRLEN esignlen = 0; @@ -7886,10 +7987,10 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV * NV_DIG: mantissa takes than many decimal digits. * Plus 32: Playing safe. */ char ebuf[IV_DIG * 4 + NV_DIG + 32]; - /* large enough for "%#.#f" --chip */ + /* 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; @@ -7897,7 +7998,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; @@ -7922,7 +8030,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 @@ -8034,7 +8142,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); @@ -8073,19 +8184,19 @@ 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 (*(q + 1) == 'l') { /* lld, llf */ +#if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE) + if (*(q + 1) == 'l') { /* lld, llf */ intsize = 'q'; q += 2; break; @@ -8107,7 +8218,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; @@ -8116,7 +8229,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) { @@ -8132,7 +8245,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 @@ -8169,7 +8282,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); @@ -8185,7 +8298,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; @@ -8400,12 +8513,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"); @@ -8413,9 +8564,76 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV need = BIT_DIGITS(i); } need += has_precis ? precis : 6; /* known default */ + if (need < width) need = width; +#ifdef HAS_LDBL_SPRINTF_BUG + /* This is to try to fix a bug with irix/nonstop-ux/powerux and + with sfio - Allen */ + +# ifdef DBL_MAX +# define MY_DBL_MAX DBL_MAX +# else /* XXX guessing! HUGE_VAL may be defined as infinity, so not using */ +# if DOUBLESIZE >= 8 +# define MY_DBL_MAX 1.7976931348623157E+308L +# else +# define MY_DBL_MAX 3.40282347E+38L +# endif +# endif + +# ifdef HAS_LDBL_SPRINTF_BUG_LESS1 /* only between -1L & 1L - Allen */ +# define MY_DBL_MAX_BUG 1L +# else +# define MY_DBL_MAX_BUG MY_DBL_MAX +# endif + +# ifdef DBL_MIN +# define MY_DBL_MIN DBL_MIN +# else /* XXX guessing! -Allen */ +# if DOUBLESIZE >= 8 +# define MY_DBL_MIN 2.2250738585072014E-308L +# else +# define MY_DBL_MIN 1.17549435E-38L +# endif +# endif + + if ((intsize == 'q') && (c == 'f') && + ((nv < MY_DBL_MAX_BUG) && (nv > -MY_DBL_MAX_BUG)) && + (need < DBL_DIG)) { + /* it's going to be short enough that + * long double precision is not needed */ + + if ((nv <= 0L) && (nv >= -0L)) + fix_ldbl_sprintf_bug = TRUE; /* 0 is 0 - easiest */ + else { + /* would use Perl_fp_class as a double-check but not + * functional on IRIX - see perl.h comments */ + + if ((nv >= MY_DBL_MIN) || (nv <= -MY_DBL_MIN)) { + /* It's within the range that a double can represent */ +#if defined(DBL_MAX) && !defined(DBL_MIN) + if ((nv >= ((long double)1/DBL_MAX)) || + (nv <= (-(long double)1/DBL_MAX))) +#endif + fix_ldbl_sprintf_bug = TRUE; + } + } + if (fix_ldbl_sprintf_bug == TRUE) { + double temp; + + intsize = 0; + temp = (double)nv; + nv = (NV)temp; + } + } + +# undef MY_DBL_MAX +# undef MY_DBL_MAX_BUG +# undef MY_DBL_MIN + +#endif /* HAS_LDBL_SPRINTF_BUG */ + need += 20; /* fudge factor */ if (PL_efloatsize < need) { Safefree(PL_efloatbuf); @@ -8427,8 +8645,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. */ @@ -8459,8 +8678,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; @@ -8468,9 +8693,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; @@ -8483,6 +8707,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 */ @@ -8610,10 +8835,6 @@ ptr_table_* functions. #if defined(USE_ITHREADS) -#if defined(USE_5005THREADS) -# include "error: USE_5005THREADS and USE_ITHREADS are incompatible" -#endif - #ifndef GpREFCNT_inc # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL) #endif @@ -8916,7 +9137,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; } } @@ -9018,10 +9238,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 */ @@ -9031,7 +9251,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); } } @@ -9078,7 +9298,7 @@ void Perl_rvpv_dup(pTHX_ SV *dstr, SV *sstr, CLONE_PARAMS* param) { if (SvROK(sstr)) { - SvRV(dstr) = SvWEAKREF(sstr) + SvRV(dstr) = SvWEAKREF(sstr) ? sv_dup(SvRV(sstr), param) : sv_dup_inc(SvRV(sstr), param); } @@ -9087,6 +9307,12 @@ Perl_rvpv_dup(pTHX_ SV *dstr, SV *sstr, CLONE_PARAMS* param) if (SvLEN(sstr)) { /* Normal PV - clone whole allocated space */ SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1); + if (SvREADONLY(sstr) && SvFAKE(sstr)) { + /* Not that normal - actually sstr is copy on write. + But we are a true, independant SV, so: */ + SvREADONLY_off(dstr); + SvFAKE_off(dstr); + } } else { /* Special case - not normally malloced for some reason */ @@ -9099,7 +9325,7 @@ Perl_rvpv_dup(pTHX_ SV *dstr, SV *sstr, CLONE_PARAMS* param) else { /* Some other special case - random pointer */ SvPVX(dstr) = SvPVX(sstr); - } + } } } else { @@ -9120,6 +9346,18 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param) if (dstr) return dstr; + if(param->flags & CLONEf_JOIN_IN) { + /** We are joining here so we don't want do clone + something that is bad **/ + + if(SvTYPE(sstr) == SVt_PVHV && + HvNAME(sstr)) { + /** don't clone stashes if they already exist **/ + HV* old_stash = gv_stashpv(HvNAME(sstr),0); + return (SV*) old_stash; + } + } + /* create anew and remember what it is */ new_SV(dstr); ptr_table_store(PL_ptr_table, sstr, dstr); @@ -9212,9 +9450,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)); @@ -9372,19 +9611,12 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param) } else { CvDEPTH(dstr) = 0; } - if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) { - /* XXX padlists are real, but pretend to be not */ - AvREAL_on(CvPADLIST(sstr)); - CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr), param); - AvREAL_off(CvPADLIST(sstr)); - AvREAL_off(CvPADLIST(dstr)); - } - else - CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr), param); - if (!CvANON(sstr) || CvCLONED(sstr)) - CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr), param); - else - CvOUTSIDE(dstr) = cv_dup(CvOUTSIDE(sstr), param); + PAD_DUP(CvPADLIST(dstr), CvPADLIST(sstr), param); + CvOUTSIDE_SEQ(dstr) = CvOUTSIDE_SEQ(sstr); + CvOUTSIDE(dstr) = + CvWEAKOUTSIDE(sstr) + ? cv_dup( CvOUTSIDE(sstr), param) + : cv_dup_inc(CvOUTSIDE(sstr), param); CvFLAGS(dstr) = CvFLAGS(sstr); CvFILE(dstr) = CvXSUB(sstr) ? CvFILE(sstr) : SAVEPV(CvFILE(sstr)); break; @@ -9449,7 +9681,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; @@ -9462,9 +9694,9 @@ Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param) ncx->blk_loop.iterdata = (CxPADLOOP(cx) ? cx->blk_loop.iterdata : gv_dup((GV*)cx->blk_loop.iterdata, param)); - ncx->blk_loop.oldcurpad - = (SV**)ptr_table_fetch(PL_ptr_table, - cx->blk_loop.oldcurpad); + ncx->blk_loop.oldcomppad + = (PAD*)ptr_table_fetch(PL_ptr_table, + cx->blk_loop.oldcomppad); ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave, param); ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval, param); ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary, param); @@ -9524,6 +9756,8 @@ Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param) #define TOPLONG(ss,ix) ((ss)[ix].any_long) #define POPIV(ss,ix) ((ss)[--(ix)].any_iv) #define TOPIV(ss,ix) ((ss)[ix].any_iv) +#define POPBOOL(ss,ix) ((ss)[--(ix)].any_bool) +#define TOPBOOL(ss,ix) ((ss)[ix].any_bool) #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr) #define TOPPTR(ss,ix) ((ss)[ix].any_ptr) #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr) @@ -9811,6 +10045,12 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) sv = (SV*)POPPTR(ss,ix); TOPPTR(nss,ix) = sv_dup(sv, param); break; + case SAVEt_BOOL: + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = any_dup(ptr, proto_perl); + longval = (long)POPBOOL(ss,ix); + TOPBOOL(nss,ix) = (bool)longval; + break; default: Perl_croak(aTHX_ "panic: ss_dup inconsistency"); } @@ -9824,6 +10064,35 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) Create and return a new interpreter by cloning the current one. +perl_clone takes these flags as paramters: + +CLONEf_COPY_STACKS - is used to, well, copy the stacks also, +without it we only clone the data and zero the stacks, +with it we copy the stacks and the new perl interpreter is +ready to run at the exact same point as the previous one. +The pseudo-fork code uses COPY_STACKS while the +threads->new doesn't. + +CLONEf_KEEP_PTR_TABLE +perl_clone keeps a ptr_table with the pointer of the old +variable as a key and the new variable as a value, +this allows it to check if something has been cloned and not +clone it again but rather just use the value and increase the +refcount. If KEEP_PTR_TABLE is not set then perl_clone will kill +the ptr_table using the function +C, +reason to keep it around is if you want to dup some of your own +variable who are outside the graph perl scans, example of this +code is in threads.xs create + +CLONEf_CLONE_HOST +This is a win32 thing, it is ignored on unix, it tells perls +win32host code (which is c++) to clone itself, this is needed on +win32 if you want to run two threads at the same time, +if you just want to do some stuff in a separate perl interpreter +and then throw it away and return to the original one, +you don't need to do anything. + =cut */ @@ -9874,7 +10143,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; @@ -9905,7 +10174,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; @@ -9917,6 +10186,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; @@ -10009,12 +10279,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, /* pseudo environmental stuff */ PL_origargc = proto_perl->Iorigargc; - i = PL_origargc; - New(0, PL_origargv, i+1, char*); - PL_origargv[i] = '\0'; - while (i-- > 0) { - PL_origargv[i] = SAVEPV(proto_perl->Iorigargv[i]); - } + PL_origargv = proto_perl->Iorigargv; param->stashes = newAV(); /* Setup array of objects to call clone on */ @@ -10117,13 +10382,13 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, /* symbol tables */ PL_defstash = hv_dup_inc(proto_perl->Tdefstash, param); PL_curstash = hv_dup(proto_perl->Tcurstash, param); - PL_nullstash = hv_dup(proto_perl->Inullstash, param); PL_debstash = hv_dup(proto_perl->Idebstash, param); PL_globalstash = hv_dup(proto_perl->Iglobalstash, param); PL_curstname = sv_dup_inc(proto_perl->Icurstname, param); PL_beginav = av_dup_inc(proto_perl->Ibeginav, param); PL_beginav_save = av_dup_inc(proto_perl->Ibeginav_save, param); + PL_checkav_save = av_dup_inc(proto_perl->Icheckav_save, param); PL_endav = av_dup_inc(proto_perl->Iendav, param); PL_checkav = av_dup_inc(proto_perl->Icheckav, param); PL_initav = av_dup_inc(proto_perl->Iinitav, param); @@ -10188,12 +10453,8 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters, param); PL_compcv = cv_dup(proto_perl->Icompcv, param); - PL_comppad = av_dup(proto_perl->Icomppad, param); - PL_comppad_name = av_dup(proto_perl->Icomppad_name, param); - PL_comppad_name_fill = proto_perl->Icomppad_name_fill; - PL_comppad_name_floor = proto_perl->Icomppad_name_floor; - PL_curpad = (SV**)ptr_table_fetch(PL_ptr_table, - proto_perl->Tcurpad); + + PAD_CLONE_VARS(proto_perl, param); #ifdef HAVE_INTERP_INTERN sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern); @@ -10212,7 +10473,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_egid = proto_perl->Iegid; PL_nomemok = proto_perl->Inomemok; PL_an = proto_perl->Ian; - PL_cop_seqmax = proto_perl->Icop_seqmax; PL_op_seqmax = proto_perl->Iop_seqmax; PL_evalseq = proto_perl->Ievalseq; PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */ @@ -10254,16 +10514,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 */ @@ -10278,17 +10551,19 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_subline = proto_perl->Isubline; PL_subname = sv_dup_inc(proto_perl->Isubname, param); - PL_min_intro_pending = proto_perl->Imin_intro_pending; - PL_max_intro_pending = proto_perl->Imax_intro_pending; - PL_padix = proto_perl->Ipadix; - 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 @@ -10503,23 +10778,11 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_watchok = Nullch; PL_regdummy = proto_perl->Tregdummy; - PL_regcomp_parse = Nullch; - PL_regxend = Nullch; - PL_regcode = (regnode*)NULL; - PL_regnaughty = 0; - PL_regsawback = 0; PL_regprecomp = Nullch; PL_regnpar = 0; PL_regsize = 0; - PL_regflags = 0; - PL_regseen = 0; - PL_seen_zerolen = 0; - PL_seen_evals = 0; - PL_regcomp_rx = (regexp*)NULL; - PL_extralen = 0; PL_colorset = 0; /* reinits PL_colors[] */ /*PL_colors[6] = {0,0,0,0,0,0};*/ - PL_reg_whilem_seen = 0; PL_reginput = Nullch; PL_regbol = Nullch; PL_regeol = Nullch; @@ -10618,34 +10881,55 @@ 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)) { - SV *uni; - STRLEN len; - char *s; - dSP; - ENTER; - SAVETMPS; - PUSHMARK(sp); - EXTEND(SP, 3); - XPUSHs(encoding); - XPUSHs(sv); - XPUSHs(&PL_sv_yes); - PUTBACK; - call_method("decode", G_SCALAR); - SPAGAIN; - uni = POPs; - PUTBACK; - s = SvPV(uni, len); - if (s != SvPVX(sv)) { - SvGROW(sv, len); - Move(s, SvPVX(sv), len, char); - SvCUR_set(sv, len); - } - FREETMPS; - LEAVE; - SvUTF8_on(sv); - } - return SvPVX(sv); + if (SvPOK(sv) && !DO_UTF8(sv) && SvROK(encoding)) { + int vary = FALSE; + SV *uni; + STRLEN len; + char *s; + dSP; + ENTER; + SAVETMPS; + PUSHMARK(sp); + 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; + uni = POPs; + PUTBACK; + s = SvPV(uni, len); + { + U8 *t = (U8 *)s, *e = (U8 *)s + len; + while (t < e) { + if ((vary = !UTF8_IS_INVARIANT(*t++))) + break; + } + } + if (s != SvPVX(sv)) { + SvGROW(sv, len + 1); + Move(s, SvPVX(sv), len, char); + SvCUR_set(sv, len); + SvPVX(sv)[len] = 0; + } + FREETMPS; + LEAVE; + if (vary) + SvUTF8_on(sv); + SvUTF8_on(sv); + } + return SvPVX(sv); } +