X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=90a99dfd6207d3f296f005cc7b63d75a9297142a;hb=7e107e90b7bd52c7fb110ac98da6bb7ab38e8959;hp=aad6c34fed826d7425be833d73ff9a3b807bc786;hpb=ece599bdb7307c953714bad8b5a320ffa2cd0857;p=p5sagit%2Fp5-mst-13.2.git diff --git a/sv.c b/sv.c index aad6c34..90a99df 100644 --- a/sv.c +++ b/sv.c @@ -25,11 +25,12 @@ #ifdef PERL_COPY_ON_WRITE #define SV_COW_NEXT_SV(sv) INT2PTR(SV *,SvUVX(sv)) -/* This is a pessamistic view. Scalar must be purely a read-write PV to copy- +#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|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_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 @@ -163,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) \ @@ -175,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 */ @@ -1126,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 @@ -1578,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); @@ -2030,7 +2048,7 @@ 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)); } @@ -2327,7 +2345,7 @@ 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)); } @@ -2615,7 +2633,7 @@ 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)); } @@ -2894,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; @@ -2935,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"; @@ -2948,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; @@ -3004,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; } } } @@ -3019,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; } @@ -3044,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)); @@ -3194,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); } /* @@ -3569,6 +3578,12 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) 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 */ @@ -3933,8 +3948,8 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) if (DEBUG_C_TEST) { PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n"); - Perl_sv_dump(sstr); - Perl_sv_dump(dstr); + sv_dump(sstr); + sv_dump(dstr); } if (!isSwipe) { /* I believe I should acquire a global SV mutex if @@ -3949,7 +3964,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) SvFAKE_on(sstr); /* Make the source SV into a loop of 1. (about to become 2) */ - SV_COW_NEXT_SV(sstr) = sstr; + SV_COW_NEXT_SV_SET(sstr, sstr); } } #endif @@ -3972,8 +3987,8 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) if (len) { /* SvIsCOW_normal */ /* splice us in between source and next-after-source. */ - SV_COW_NEXT_SV(dstr) = SV_COW_NEXT_SV(sstr); - SV_COW_NEXT_SV(sstr) = dstr; + 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 */ @@ -4024,9 +4039,9 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) SvIVX(dstr) = SvIVX(sstr); } if (SvVOK(sstr)) { - MAGIC *mg = SvMAGIC(sstr); - sv_magicext(dstr, NULL, PERL_MAGIC_vstring, NULL, - mg->mg_ptr, mg->mg_len); + MAGIC *smg = mg_find(sstr,PERL_MAGIC_vstring); + sv_magic(dstr, NULL, PERL_MAGIC_vstring, + smg->mg_ptr, smg->mg_len); SvRMAGICAL_on(dstr); } } @@ -4259,9 +4274,10 @@ S_sv_release_COW(pTHX_ register SV *sv, char *pvx, STRLEN cur, STRLEN len, /* 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(current) = after; + SV_COW_NEXT_SV_SET(current, after); } } else { unsharepvn(pvx, SvUTF8(sv) ? -(I32)cur : cur, hash); @@ -4308,7 +4324,7 @@ Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags) PerlIO_printf(Perl_debug_log, "Copy on write: Force normal %ld\n", (long) flags); - Perl_sv_dump(sv); + sv_dump(sv); } SvFAKE_off(sv); SvREADONLY_off(sv); @@ -4324,9 +4340,9 @@ Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags) SvCUR(sv) = cur; *SvEND(sv) = '\0'; } - S_sv_release_COW(sv, pvx, cur, len, hash, next); + sv_release_COW(sv, pvx, cur, len, hash, next); if (DEBUG_C_TEST) { - Perl_sv_dump(sv); + sv_dump(sv); } } else if (PL_curcop != &PL_compiling) @@ -4637,8 +4653,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 || @@ -4655,6 +4670,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) { @@ -4763,11 +4793,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; @@ -4798,6 +4823,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; @@ -5086,6 +5114,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); @@ -5135,7 +5185,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; @@ -5229,9 +5279,9 @@ Perl_sv_clear(pTHX_ register SV *sv) then recheck the COW status. */ if (DEBUG_C_TEST) { PerlIO_printf(Perl_debug_log, "Copy on write: clear\n"); - Perl_sv_dump(sv); + sv_dump(sv); } - S_sv_release_COW(sv, SvPVX(sv), SvCUR(sv), SvLEN(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); @@ -7223,10 +7273,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)) { @@ -7909,7 +7956,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) { @@ -7926,7 +7973,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; @@ -7937,7 +7989,7 @@ 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 = Nullsv; @@ -8146,7 +8198,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; @@ -8494,10 +8546,10 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV 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); @@ -8514,9 +8566,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); @@ -8718,10 +8837,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 @@ -9185,7 +9300,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); } @@ -9194,6 +9309,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 */ @@ -9206,7 +9327,7 @@ Perl_rvpv_dup(pTHX_ SV *dstr, SV *sstr, CLONE_PARAMS* param) else { /* Some other special case - random pointer */ SvPVX(dstr) = SvPVX(sstr); - } + } } } else { @@ -9480,19 +9601,13 @@ 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); + PAD_DUP(CvPADLIST(dstr), CvPADLIST(sstr), param); + /* anon prototypes aren't refcounted */ if (!CvANON(sstr) || CvCLONED(sstr)) CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr), param); else CvOUTSIDE(dstr) = cv_dup(CvOUTSIDE(sstr), param); + CvOUTSIDE_SEQ(dstr) = CvOUTSIDE_SEQ(sstr); CvFLAGS(dstr) = CvFLAGS(sstr); CvFILE(dstr) = CvXSUB(sstr) ? CvFILE(sstr) : SAVEPV(CvFILE(sstr)); break; @@ -9570,9 +9685,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); @@ -10118,12 +10233,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 */ @@ -10226,7 +10336,6 @@ 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); @@ -10298,12 +10407,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); @@ -10322,7 +10427,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 */ @@ -10401,12 +10505,6 @@ 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; - /* XXX See comment on SvANY(proto_perl->Ilinestr) above */ if (SvANY(proto_perl->Ilinestr)) { i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr); @@ -10750,16 +10848,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 @@ -10768,23 +10867,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); }