X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=5a9937509590f10bd95926423f54e4b06e3bde2b;hb=4d94824190f1d3f4307c94794486b277afd6e971;hp=076ea5c8962c1bdf794a9d7c0ea1dc12aa0174e7;hpb=f989386671918f01ee81e803b0ebff38ff623ad4;p=p5sagit%2Fp5-mst-13.2.git diff --git a/sv.c b/sv.c index 076ea5c..5a99375 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)) @@ -2892,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; @@ -2933,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"; @@ -2946,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; @@ -3002,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; } } } @@ -3017,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; } @@ -3042,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)); @@ -3192,28 +3217,14 @@ would lose the UTF-8'ness of the PV. void Perl_sv_copypv(pTHX_ SV *dsv, register SV *ssv) { - SV *tmpsv; - - 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; - 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); } /* @@ -3380,11 +3391,11 @@ 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) + if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING)) sv_recode_to_utf8(sv, PL_encoding); else { /* Assume Latin-1/EBCDIC */ /* This function could be much more efficient if we @@ -3437,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) @@ -3559,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 */ @@ -3744,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; @@ -3756,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; @@ -3774,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); @@ -3824,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; @@ -3851,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; @@ -3887,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 @@ -3895,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; @@ -3911,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*/ @@ -3947,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) @@ -4017,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; @@ -4068,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; @@ -4115,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); @@ -4148,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 */ @@ -4162,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); @@ -4177,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) @@ -4464,8 +4651,7 @@ Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, MGVTBL *vtable, 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 + have its REFCNT incremented to keep it in existence. */ if (!obj || obj == sv || @@ -4482,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) { @@ -4515,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 @@ -4586,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; @@ -4621,6 +4821,12 @@ 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_utf8: + vtable = &PL_vtbl_utf8; + break; case PERL_MAGIC_substr: vtable = &PL_vtbl_substr; break; @@ -4690,6 +4896,8 @@ Perl_sv_unmagic(pTHX_ SV *sv, int type) Safefree(mg->mg_ptr); else if (mg->mg_len == HEf_SVKEY) SvREFCNT_dec((SV*)mg->mg_ptr); + else if (mg->mg_type == PERL_MAGIC_utf8 && mg->mg_ptr) + Safefree(mg->mg_ptr); } if (mg->mg_flags & MGf_REFCOUNTED) SvREFCNT_dec(mg->mg_obj); @@ -4892,7 +5100,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)) { @@ -4909,6 +5117,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); @@ -4958,7 +5188,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; @@ -5045,6 +5275,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)) { @@ -5053,6 +5301,7 @@ Perl_sv_clear(pTHX_ register SV *sv) SvUVX(sv)); SvFAKE_off(sv); } +#endif break; /* case SVt_NV: @@ -5227,6 +5476,13 @@ UTF8 bytes as a single character. Handles magic and type coercion. =cut */ +/* + * The length is cached in PERL_UTF8_magic, in the mg_len field. Also the + * mg_ptr is used, by sv_pos_u2b(), see the comments of S_utf8_mg_pos_init(). + * (Note that the mg_len is not the length of the mg_ptr field.) + * + */ + STRLEN Perl_sv_len_utf8(pTHX_ register SV *sv) { @@ -5237,14 +5493,159 @@ Perl_sv_len_utf8(pTHX_ register SV *sv) return mg_length(sv); else { - STRLEN len; + STRLEN len, ulen; U8 *s = (U8*)SvPV(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)) + ulen = mg->mg_len; + else { + ulen = Perl_utf8_length(aTHX_ s, s + len); + if (!mg && !SvREADONLY(sv)) { + sv_magic(sv, 0, PERL_MAGIC_utf8, 0, 0); + mg = mg_find(sv, PERL_MAGIC_utf8); + assert(mg); + } + if (mg) + mg->mg_len = ulen; + } + return ulen; + } +} + +/* S_utf8_mg_pos_init() is used to initialize the mg_ptr field of + * a PERL_UTF8_magic. The mg_ptr is used to store the mapping + * between UTF-8 and byte offsets. There are two (substr offset and substr + * length, the i offset, PERL_MAGIC_UTF8_CACHESIZE) times two (UTF-8 offset + * and byte offset) cache positions. + * + * The mg_len field is used by sv_len_utf8(), see its comments. + * Note that the mg_len is not the length of the mg_ptr field. + * + */ +STATIC bool +S_utf8_mg_pos_init(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i, I32 *offsetp, U8 *s, U8 *start) +{ + bool found = FALSE; + + if (SvMAGICAL(sv) && !SvREADONLY(sv)) { + if (!*mgp) { + sv_magic(sv, 0, PERL_MAGIC_utf8, 0, 0); + *mgp = mg_find(sv, PERL_MAGIC_utf8); + } + assert(*mgp); + + if ((*mgp)->mg_ptr) + *cachep = (STRLEN *) (*mgp)->mg_ptr; + else { + Newz(0, *cachep, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN); + (*mgp)->mg_ptr = (char *) *cachep; + } + assert(*cachep); - return Perl_utf8_length(aTHX_ s, s + len); + (*cachep)[i] = *offsetp; + (*cachep)[i+1] = s - start; + found = TRUE; } + + return found; } /* + * S_utf8_mg_pos() is used to query and update mg_ptr field of + * a PERL_UTF8_magic. The mg_ptr is used to store the mapping + * between UTF-8 and byte offsets. See also the comments of + * S_utf8_mg_pos_init(). + * + */ +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) +{ + bool found = FALSE; + + if (SvMAGICAL(sv) && !SvREADONLY(sv)) { + if (!*mgp) + *mgp = mg_find(sv, PERL_MAGIC_utf8); + if (*mgp && (*mgp)->mg_ptr) { + *cachep = (STRLEN *) (*mgp)->mg_ptr; + if ((*cachep)[i] == (STRLEN)uoff) /* An exact match. */ + found = TRUE; + else { /* We will skip to the right spot. */ + STRLEN forw = 0; + STRLEN backw = 0; + U8* p = NULL; + + /* The assumption is that going backward is half + * the speed of going forward (that's where the + * 2 * backw in the below comes from). (The real + * figure of course depends on the UTF-8 data.) */ + + if ((*cachep)[i] > (STRLEN)uoff) { + forw = uoff; + backw = (*cachep)[i] - (STRLEN)uoff; + + if (forw < 2 * backw) + p = start; + else + p = start + (*cachep)[i+1]; + } + /* Try this only for the substr offset (i == 0), + * not for the substr length (i == 2). */ + else if (i == 0) { /* (*cachep)[i] < uoff */ + STRLEN ulen = sv_len_utf8(sv); + + if ((STRLEN)uoff < ulen) { + forw = (STRLEN)uoff - (*cachep)[i]; + backw = ulen - (STRLEN)uoff; + + if (forw < 2 * backw) + p = start + (*cachep)[i+1]; + else + p = send; + } + + /* If the string is not long enough for uoff, + * we could extend it, but not at this low a level. */ + } + + if (p) { + if (forw < 2 * backw) { + while (forw--) + p += UTF8SKIP(p); + } + else { + while (backw--) { + p--; + while (UTF8_IS_CONTINUATION(*p)) + p--; + } + } + + /* Update the cache. */ + (*cachep)[i] = (STRLEN)uoff; + (*cachep)[i+1] = p - start; + + found = TRUE; + } + } + if (found) { /* Setup the return values. */ + *offsetp = (*cachep)[i+1]; + *sp = start + *offsetp; + if (*sp >= send) { + *sp = send; + *offsetp = send - start; + } + else if (*sp < start) { + *sp = start; + *offsetp = 0; + } + } + } + } + return found; +} + +/* =for apidoc sv_pos_u2b Converts the value pointed to by offsetp from a count of UTF8 chars from @@ -5256,33 +5657,67 @@ type coercion. =cut */ +/* + * sv_pos_u2b() uses, like sv_pos_b2u(), the mg_ptr of the potential + * PERL_UTF8_magic of the sv to store the mapping between UTF-8 and + * byte offsets. See also the comments of S_utf8_mg_pos(). + * + */ + void Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp) { U8 *start; U8 *s; - U8 *send; - I32 uoffset = *offsetp; STRLEN len; + STRLEN *cache = 0; + STRLEN boffset = 0; if (!sv) return; start = s = (U8*)SvPV(sv, len); - send = s + len; - while (s < send && uoffset--) - s += UTF8SKIP(s); - if (s >= send) - s = send; - *offsetp = s - start; - if (lenp) { - I32 ulen = *lenp; - start = s; - while (s < send && ulen--) - s += UTF8SKIP(s); - if (s >= send) - s = send; - *lenp = s - start; + if (len) { + I32 uoffset = *offsetp; + 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; + if (!found && uoffset > 0) { + while (s < send && uoffset--) + s += UTF8SKIP(s); + if (s >= send) + s = send; + if (utf8_mg_pos_init(sv, &mg, &cache, 0, offsetp, s, start)) + boffset = cache[1]; + *offsetp = s - start; + } + if (lenp) { + found = FALSE; + start = s; + if (utf8_mg_pos(sv, &mg, &cache, 2, lenp, *lenp + *offsetp, &s, start, send)) { + *lenp -= boffset; + found = TRUE; + } + if (!found && *lenp > 0) { + I32 ulen = *lenp; + if (ulen > 0) + while (s < send && ulen--) + s += UTF8SKIP(s); + if (s >= send) + s = send; + if (utf8_mg_pos_init(sv, &mg, &cache, 2, lenp, s, start)) + cache[2] += *offsetp; + } + *lenp = s - start; + } + } + else { + *offsetp = 0; + if (lenp) + *lenp = 0; } return; } @@ -5297,11 +5732,17 @@ Handles magic and type coercion. =cut */ +/* + * sv_pos_b2u() uses, like sv_pos_u2b(), the mg_ptr of the potential + * PERL_UTF8_magic of the sv to store the mapping between UTF-8 and + * byte offsets. See also the comments of S_utf8_mg_pos(). + * + */ + void -Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp) +Perl_sv_pos_b2u(pTHX_ register SV* sv, I32* offsetp) { - U8 *s; - U8 *send; + U8* s; STRLEN len; if (!sv) @@ -5310,22 +5751,93 @@ Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp) s = (U8*)SvPV(sv, len); if ((I32)len < *offsetp) Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset"); - send = s + *offsetp; - len = 0; - while (s < send) { - 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++; + else { + U8* send = s + *offsetp; + MAGIC* mg = NULL; + STRLEN *cache = NULL; + + len = 0; + + if (SvMAGICAL(sv) && !SvREADONLY(sv)) { + mg = mg_find(sv, PERL_MAGIC_utf8); + if (mg && mg->mg_ptr) { + cache = (STRLEN *) mg->mg_ptr; + if (cache[1] == *offsetp) { + /* An exact match. */ + *offsetp = cache[0]; + + return; + } + else if (cache[1] < *offsetp) { + /* We already know part of the way. */ + len = cache[0]; + s += cache[1]; + /* Let the below loop do the rest. */ + } + else { /* cache[1] > *offsetp */ + /* We already know all of the way, now we may + * be able to walk back. The same assumption + * is made as in S_utf8_mg_pos(), namely that + * walking backward is twice slower than + * walking forward. */ + STRLEN forw = *offsetp; + STRLEN backw = cache[1] - *offsetp; + + if (!(forw < 2 * backw)) { + U8 *p = s + cache[1]; + STRLEN ubackw = 0; + + cache[1] -= backw; + + while (backw--) { + p--; + while (UTF8_IS_CONTINUATION(*p)) + p--; + ubackw++; + } + + cache[0] -= ubackw; + + return; + } + } + } } - else - break; + + while (s < send) { + 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++; + } + else + break; + } + + if (!SvREADONLY(sv)) { + if (!mg) { + sv_magic(sv, 0, PERL_MAGIC_utf8, 0, 0); + mg = mg_find(sv, PERL_MAGIC_utf8); + } + assert(mg); + + if (!mg->mg_ptr) { + Newz(0, cache, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN); + mg->mg_ptr = (char *) cache; + } + assert(cache); + + cache[0] = len; + cache[1] = *offsetp; + } + + *offsetp = len; } - *offsetp = len; return; } @@ -5409,7 +5921,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); @@ -5642,11 +6154,18 @@ Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append) register I32 cnt; I32 i = 0; I32 rspara = 0; - - SV_CHECK_THINKFIRST(sv); + I32 recsize; + + 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); + SvPOK_only(sv); /* Validate pointer */ if (PL_curcop == &PL_compiling) { /* we always read code in line mode */ @@ -5654,17 +6173,22 @@ Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append) rslen = 1; } else if (RsSNARF(PL_rs)) { + Stat_t st; + if (!PerlLIO_fstat(PerlIO_fileno(fp), &st) && st.st_size + && (recsize = st.st_size - PerlIO_tell(fp))) + goto read_record; rsptr = NULL; rslen = 0; } else if (RsRECORD(PL_rs)) { - I32 recsize, bytesread; + I32 bytesread; char *buffer; /* Grab the size of the record we're getting */ recsize = SvIV(SvRV(PL_rs)); - (void)SvPOK_only(sv); /* Validate pointer */ - buffer = SvGROW(sv, (STRLEN)(recsize + 1)); + + read_record: + buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append; /* Go yank in */ #ifdef VMS /* VMS wants read instead of fread, because fread doesn't respect */ @@ -5674,13 +6198,9 @@ Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append) #else bytesread = PerlIO_read(fp, buffer, recsize); #endif - SvCUR_set(sv, bytesread); + SvCUR_set(sv, bytesread += append); buffer[bytesread] = '\0'; - if (PerlIO_isutf8(fp)) - SvUTF8_on(sv); - else - SvUTF8_off(sv); - return(SvCUR(sv) ? SvPVX(sv) : Nullch); + goto check_utf8_and_return; } else if (RsPARA(PL_rs)) { rsptr = "\n\n"; @@ -5749,7 +6269,6 @@ Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append) /* Here is some breathtakingly efficient cheating */ cnt = PerlIO_get_cnt(fp); /* get count into register */ - (void)SvPOK_only(sv); /* validate pointer */ if ((I32)(SvLEN(sv) - append) <= cnt + 1) { /* make sure we have the room */ if (cnt > 80 && (I32)SvLEN(sv) > append) { shortbuffered = cnt - SvLEN(sv) + append + 1; @@ -5884,16 +6403,19 @@ screamer2: /* Accomodate broken VAXC compiler, which applies U8 cast to * both args of ?: operator, causing EOF to change into 255 */ - if (cnt > 0) { i = (U8)buf[cnt - 1]; } else { i = EOF; } - } - - if (cnt > 0) { - if (append) - sv_catpvn(sv, (char *) buf, cnt); + if (cnt > 0) + i = (U8)buf[cnt - 1]; else - sv_setpvn(sv, (char *) buf, cnt); + 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); + else + sv_setpvn(sv, (char *) buf, cnt); + if (i != EOF && /* joy */ (!rslen || SvCUR(sv) < rslen || @@ -5926,6 +6448,7 @@ screamer2: } } +check_utf8_and_return: if (PerlIO_isutf8(fp)) SvUTF8_on(sv); else @@ -5954,8 +6477,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); @@ -6110,8 +6633,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); @@ -6659,7 +7182,7 @@ Perl_sv_2io(pTHX_ SV *sv) else io = 0; if (!io) - Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a)); + Perl_croak(aTHX_ "Bad filehandle: %"SVf, sv); break; } return io; @@ -6740,7 +7263,8 @@ Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref) Nullop); LEAVE; if (!GvCVu(gv)) - Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a)); + Perl_croak(aTHX_ "Unable to create sub named \"%"SVf"\"", + sv); } return GvCVu(gv); } @@ -6898,7 +7422,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,10 +7543,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)) { @@ -7035,6 +7556,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 @@ -7120,7 +7643,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) { @@ -7364,7 +7887,9 @@ 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 */ + /* You can't have a || SvREADONLY(rv) here, as $a = $$a, where $a was + assigned to as BEGIN {$a = \"Foo"} will fail. */ + if (SvREFCNT(rv) != 1 || (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 */ @@ -7703,7 +8228,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) { @@ -7720,7 +8245,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; @@ -7731,10 +8261,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; @@ -7774,7 +8304,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 @@ -7886,7 +8416,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); @@ -7937,7 +8470,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV #endif case 'l': #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE) - if (*(q + 1) == 'l') { /* lld, llf */ + if (*(q + 1) == 'l') { /* lld, llf */ intsize = 'q'; q += 2; break; @@ -7959,7 +8492,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; @@ -7968,7 +8503,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) { @@ -7984,7 +8519,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 @@ -8021,7 +8556,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); @@ -8037,7 +8572,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; @@ -8252,7 +8787,6 @@ 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; /* 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 @@ -8281,17 +8815,18 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV } /* now we need (long double) if intsize == 'q', else (double) */ - nv = args ? + nv = (args && !vectorize) ? #if LONG_DOUBLESIZE > DOUBLESIZE intsize == 'q' ? - va_arg(*args, long double) : - va_arg(*args, double) + va_arg(*args, long double) : + va_arg(*args, double) #else - va_arg(*args, double) + 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 @@ -8303,9 +8838,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); @@ -8365,9 +8967,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; @@ -8380,6 +8981,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 */ @@ -8390,8 +8992,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV if (!args && ckWARN(WARN_PRINTF) && (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) { SV *msg = sv_newmortal(); - Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ", - (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf"); + Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ", + (PL_op->op_type == OP_PRTF) ? "" : "s"); if (c) { if (isPRINT(c)) Perl_sv_catpvf(aTHX_ msg, @@ -8507,10 +9109,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 @@ -8974,7 +9572,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); } @@ -8983,6 +9581,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 */ @@ -8995,7 +9599,7 @@ Perl_rvpv_dup(pTHX_ SV *dstr, SV *sstr, CLONE_PARAMS* param) else { /* Some other special case - random pointer */ SvPVX(dstr) = SvPVX(sstr); - } + } } } else { @@ -9016,6 +9620,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); @@ -9269,19 +9885,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; @@ -9359,9 +9968,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); @@ -9421,6 +10030,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) @@ -9708,6 +10319,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"); } @@ -9721,6 +10338,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 */ @@ -9907,12 +10553,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 */ @@ -10015,13 +10656,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); @@ -10086,12 +10727,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); @@ -10110,7 +10747,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 */ @@ -10152,16 +10788,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 */ @@ -10176,17 +10825,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 @@ -10401,23 +11052,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; @@ -10517,16 +11156,17 @@ 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); + 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 @@ -10535,23 +11175,32 @@ Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding) Both will default the value - let them. - XPUSHs(&PL_sv_yes); + 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 + 1); - Move(s, SvPVX(sv), len, char); - SvCUR_set(sv, len); - SvPVX(sv)[len] = 0; - } - FREETMPS; - LEAVE; - SvUTF8_on(sv); + 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); }