X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=90a99dfd6207d3f296f005cc7b63d75a9297142a;hb=7e107e90b7bd52c7fb110ac98da6bb7ab38e8959;hp=f5b98491f581909fe98eadb8583a0fd742916a8c;hpb=ab01544ff4579f0986e6be613b46a4801bc31f58;p=p5sagit%2Fp5-mst-13.2.git diff --git a/sv.c b/sv.c index f5b9849..90a99df 100644 --- a/sv.c +++ b/sv.c @@ -26,7 +26,7 @@ #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 pessamistic view. Scalar must be purely a read-write PV to copy- +/* 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| \ @@ -164,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) \ @@ -176,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 */ @@ -2026,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)); } @@ -2323,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)); } @@ -2611,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)); } @@ -2931,7 +2953,7 @@ 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)))) { + (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) { char *pv = SvPV(tmpstr, *lp); if (SvUTF8(tmpstr)) SvUTF8_on(sv); @@ -4631,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 || @@ -4649,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) { @@ -4757,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; @@ -5154,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; @@ -8806,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 @@ -9575,10 +9602,12 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param) CvDEPTH(dstr) = 0; } 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; @@ -9656,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); @@ -10204,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 */ @@ -10824,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 @@ -10842,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); }