X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=2c598f7546025a277ae32cef73ff5ee01f99fa44;hb=605881df1187f0374622b9de459bb7d803f7d806;hp=501d09f81f03b280710c2634271aa302fa47a63a;hpb=78ea37eb92d97de2362f1599aa0c3f43c5e70866;p=p5sagit%2Fp5-mst-13.2.git diff --git a/sv.c b/sv.c index 501d09f..2c598f7 100644 --- a/sv.c +++ b/sv.c @@ -1,7 +1,7 @@ /* sv.c * * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, - * 2000, 2001, 2002, 2003, 2004, by Larry Wall and others + * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -49,7 +49,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) +#define SV_COW_NEXT_SV_SET(current,next) SvUV_set(current, PTR2UV(next)) /* This is a pessimistic view. Scalar must be purely a read-write PV to copy- on-write. */ #endif @@ -165,8 +165,19 @@ Public API: * "A time to plant, and a time to uproot what was planted..." */ +#ifdef DEBUG_LEAKING_SCALARS +# ifdef NETWARE +# define FREE_SV_DEBUG_FILE(sv) PerlMemfree((sv)->sv_debug_file) +# else +# define FREE_SV_DEBUG_FILE(sv) PerlMemShared_free((sv)->sv_debug_file) +# endif +#else +# define FREE_SV_DEBUG_FILE(sv) +#endif + #define plant_SV(p) \ STMT_START { \ + FREE_SV_DEBUG_FILE(p); \ SvANY(p) = (void *)PL_sv_root; \ SvFLAGS(p) = SVTYPEMASK; \ PL_sv_root = (p); \ @@ -200,6 +211,17 @@ S_new_SV(pTHX) SvANY(sv) = 0; SvREFCNT(sv) = 1; SvFLAGS(sv) = 0; + sv->sv_debug_optype = PL_op ? PL_op->op_type : 0; + sv->sv_debug_line = (U16) ((PL_copline == NOLINE) ? + (PL_curcop ? CopLINE(PL_curcop) : 0) : PL_copline); + sv->sv_debug_inpad = 0; + sv->sv_debug_cloned = 0; +# ifdef NETWARE + sv->sv_debug_file = PL_curcop ? savepv(CopFILE(PL_curcop)): NULL; +# else + sv->sv_debug_file = PL_curcop ? savesharedpv(CopFILE(PL_curcop)): NULL; +# endif + return sv; } # define new_SV(p) (p)=S_new_SV(aTHX) @@ -283,7 +305,6 @@ Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags) SV* sva = (SV*)ptr; register SV* sv; register SV* svend; - Zero(ptr, size, char); /* The first SV in an arena isn't an SV. */ SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */ @@ -297,6 +318,7 @@ Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags) sv = sva + 1; while (sv < svend) { SvANY(sv) = (void *)(SV*)(sv + 1); + SvREFCNT(sv) = 0; SvFLAGS(sv) = SVTYPEMASK; sv++; } @@ -394,10 +416,10 @@ do_clean_objs(pTHX_ SV *sv) if (SvWEAKREF(sv)) { sv_del_backref(sv); SvWEAKREF_off(sv); - SvRV(sv) = 0; + SvRV_set(sv, NULL); } else { SvROK_off(sv); - SvRV(sv) = 0; + SvRV_set(sv, NULL); SvREFCNT_dec(rv); } } @@ -623,6 +645,7 @@ Perl_sv_free_arenas(pTHX) STATIC SV* S_find_hash_subscript(pTHX_ HV *hv, SV* val) { + dVAR; register HE **array; register HE *entry; I32 i; @@ -682,7 +705,7 @@ S_find_array_subscript(pTHX_ AV *av, SV* val) #define FUV_SUBSCRIPT_WITHIN 4 /* "within @foo" */ STATIC SV* -S_varname(pTHX_ GV *gv, char *gvtype, PADOFFSET targ, +S_varname(pTHX_ GV *gv, const char *gvtype, PADOFFSET targ, SV* keyname, I32 aindex, int subscript_type) { AV *av; @@ -696,15 +719,13 @@ S_varname(pTHX_ GV *gv, char *gvtype, PADOFFSET targ, * XXX get rid of all this if gv_fullnameX() ever supports this * directly */ - char *p; + const char *p; HV *hv = GvSTASH(gv); sv_setpv(name, gvtype); if (!hv) p = "???"; - else if (!HvNAME(hv)) + else if (!(p=HvNAME(hv))) p = "__ANON__"; - else - p = HvNAME(hv); if (strNE(p, "main")) { sv_catpv(name,p); sv_catpvn(name,"::", 2); @@ -770,6 +791,7 @@ PL_comppad/PL_curpad points to the currently executing pad. STATIC SV * S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match) { + dVAR; SV *sv; AV *av; SV **svp; @@ -789,8 +811,8 @@ S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match) { bool pad = (obase->op_type == OP_PADAV || obase->op_type == OP_PADHV); bool hash = (obase->op_type == OP_PADHV || obase->op_type == OP_RV2HV); - I32 index; - SV *keysv; + I32 index = 0; + SV *keysv = Nullsv; int subscript_type = FUV_SUBSCRIPT_WITHIN; if (pad) { /* @lex, %lex */ @@ -969,7 +991,7 @@ S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match) gv = cGVOPx_gv(o); if (match && GvSV(gv) != uninit_sv) break; - return S_varname(aTHX_ gv, "$", 0, + return S_varname(aTHX_ gv, "$", 0, Nullsv, 0, FUV_SUBSCRIPT_NONE); } /* other possibilities not handled are: @@ -1072,7 +1094,7 @@ void Perl_report_uninit(pTHX_ SV* uninit_sv) { if (PL_op) { - SV* varname; + SV* varname = Nullsv; if (uninit_sv) { varname = find_uninit_var(PL_op, uninit_sv,0); if (varname) @@ -1756,13 +1778,14 @@ You generally want to use the C macro wrapper. See also C. bool Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt) { - char* pv = NULL; - U32 cur = 0; - U32 len = 0; - IV iv = 0; - NV nv = 0.0; - MAGIC* magic = NULL; - HV* stash = Nullhv; + + char* pv; + U32 cur; + U32 len; + IV iv; + NV nv; + MAGIC* magic; + HV* stash; if (mt != SVt_PV && SvIsCOW(sv)) { sv_force_normal_flags(sv, 0); @@ -1771,64 +1794,39 @@ Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt) if (SvTYPE(sv) == mt) return TRUE; - if (mt < SVt_PVIV) - (void)SvOOK_off(sv); + pv = NULL; + cur = 0; + len = 0; + iv = 0; + nv = 0.0; + magic = NULL; + stash = Nullhv; switch (SvTYPE(sv)) { case SVt_NULL: - pv = 0; - cur = 0; - len = 0; - iv = 0; - nv = 0.0; - magic = 0; - stash = 0; break; case SVt_IV: - pv = 0; - cur = 0; - len = 0; iv = SvIVX(sv); - nv = (NV)SvIVX(sv); del_XIV(SvANY(sv)); - magic = 0; - stash = 0; if (mt == SVt_NV) mt = SVt_PVNV; else if (mt < SVt_PVIV) mt = SVt_PVIV; break; case SVt_NV: - pv = 0; - cur = 0; - len = 0; nv = SvNVX(sv); - iv = I_V(nv); - magic = 0; - stash = 0; del_XNV(SvANY(sv)); - SvANY(sv) = 0; if (mt < SVt_PVNV) mt = SVt_PVNV; break; case SVt_RV: pv = (char*)SvRV(sv); - cur = 0; - len = 0; - iv = PTR2IV(pv); - nv = PTR2NV(pv); del_XRV(SvANY(sv)); - magic = 0; - stash = 0; break; case SVt_PV: pv = SvPVX(sv); cur = SvCUR(sv); len = SvLEN(sv); - iv = 0; - nv = 0.0; - magic = 0; - stash = 0; del_XPV(SvANY(sv)); if (mt <= SVt_IV) mt = SVt_PVIV; @@ -1840,9 +1838,6 @@ Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt) cur = SvCUR(sv); len = SvLEN(sv); iv = SvIVX(sv); - nv = 0.0; - magic = 0; - stash = 0; del_XPVIV(SvANY(sv)); break; case SVt_PVNV: @@ -1851,8 +1846,6 @@ Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt) len = SvLEN(sv); iv = SvIVX(sv); nv = SvNVX(sv); - magic = 0; - stash = 0; del_XPVNV(SvANY(sv)); break; case SVt_PVMG: @@ -1869,170 +1862,133 @@ Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt) Perl_croak(aTHX_ "Can't upgrade that kind of scalar"); } + SvFLAGS(sv) &= ~SVTYPEMASK; + SvFLAGS(sv) |= mt; + switch (mt) { case SVt_NULL: Perl_croak(aTHX_ "Can't upgrade to undef"); case SVt_IV: SvANY(sv) = new_XIV(); - SvIVX(sv) = iv; + SvIV_set(sv, iv); break; case SVt_NV: SvANY(sv) = new_XNV(); - SvNVX(sv) = nv; + SvNV_set(sv, nv); break; case SVt_RV: SvANY(sv) = new_XRV(); - SvRV(sv) = (SV*)pv; - break; - case SVt_PV: - SvANY(sv) = new_XPV(); - SvPVX(sv) = pv; - SvCUR(sv) = cur; - SvLEN(sv) = len; - break; - case SVt_PVIV: - SvANY(sv) = new_XPVIV(); - SvPVX(sv) = pv; - SvCUR(sv) = cur; - SvLEN(sv) = len; - SvIVX(sv) = iv; - if (SvNIOK(sv)) - (void)SvIOK_on(sv); - SvNOK_off(sv); - break; - case SVt_PVNV: - SvANY(sv) = new_XPVNV(); - SvPVX(sv) = pv; - SvCUR(sv) = cur; - SvLEN(sv) = len; - SvIVX(sv) = iv; - SvNVX(sv) = nv; - break; - case SVt_PVMG: - SvANY(sv) = new_XPVMG(); - SvPVX(sv) = pv; - SvCUR(sv) = cur; - SvLEN(sv) = len; - SvIVX(sv) = iv; - SvNVX(sv) = nv; - SvMAGIC(sv) = magic; - SvSTASH(sv) = stash; - break; - case SVt_PVLV: - SvANY(sv) = new_XPVLV(); - SvPVX(sv) = pv; - SvCUR(sv) = cur; - SvLEN(sv) = len; - SvIVX(sv) = iv; - SvNVX(sv) = nv; - SvMAGIC(sv) = magic; - SvSTASH(sv) = stash; - LvTARGOFF(sv) = 0; - LvTARGLEN(sv) = 0; - LvTARG(sv) = 0; - LvTYPE(sv) = 0; - GvGP(sv) = 0; - GvNAME(sv) = 0; - GvNAMELEN(sv) = 0; - GvSTASH(sv) = 0; - GvFLAGS(sv) = 0; - break; - case SVt_PVAV: - SvANY(sv) = new_XPVAV(); - if (pv) - Safefree(pv); - SvPVX(sv) = 0; - AvMAX(sv) = -1; - AvFILLp(sv) = -1; - SvIVX(sv) = 0; - SvNVX(sv) = 0.0; - SvMAGIC(sv) = magic; - SvSTASH(sv) = stash; - AvALLOC(sv) = 0; - AvARYLEN(sv) = 0; - AvFLAGS(sv) = 0; + SvRV_set(sv, (SV*)pv); break; case SVt_PVHV: SvANY(sv) = new_XPVHV(); - if (pv) - Safefree(pv); - SvPVX(sv) = 0; - HvFILL(sv) = 0; - HvMAX(sv) = 0; - HvTOTALKEYS(sv) = 0; - HvPLACEHOLDERS(sv) = 0; - SvMAGIC(sv) = magic; - SvSTASH(sv) = stash; HvRITER(sv) = 0; HvEITER(sv) = 0; HvPMROOT(sv) = 0; HvNAME(sv) = 0; + HvFILL(sv) = 0; + HvMAX(sv) = 0; + HvTOTALKEYS(sv) = 0; + HvPLACEHOLDERS(sv) = 0; + + /* Fall through... */ + if (0) { + case SVt_PVAV: + SvANY(sv) = new_XPVAV(); + AvMAX(sv) = -1; + AvFILLp(sv) = -1; + AvALLOC(sv) = 0; + AvARYLEN(sv)= 0; + AvFLAGS(sv) = AVf_REAL; + SvIV_set(sv, 0); + SvNV_set(sv, 0.0); + } + /* to here. */ + /* XXX? Only SVt_NULL is ever upgraded to AV or HV? */ + assert(!pv); + /* FIXME. Should be able to remove all this if()... if the above + assertion is genuinely always true. */ + if(SvOOK(sv)) { + pv -= iv; + SvFLAGS(sv) &= ~SVf_OOK; + } + Safefree(pv); + SvPV_set(sv, (char*)0); + SvMAGIC_set(sv, magic); + SvSTASH_set(sv, stash); break; + + case SVt_PVIO: + SvANY(sv) = new_XPVIO(); + Zero(SvANY(sv), 1, XPVIO); + IoPAGE_LEN(sv) = 60; + goto set_magic_common; + case SVt_PVFM: + SvANY(sv) = new_XPVFM(); + Zero(SvANY(sv), 1, XPVFM); + goto set_magic_common; + case SVt_PVBM: + SvANY(sv) = new_XPVBM(); + BmRARE(sv) = 0; + BmUSEFUL(sv) = 0; + BmPREVIOUS(sv) = 0; + goto set_magic_common; + case SVt_PVGV: + SvANY(sv) = new_XPVGV(); + GvGP(sv) = 0; + GvNAME(sv) = 0; + GvNAMELEN(sv) = 0; + GvSTASH(sv) = 0; + GvFLAGS(sv) = 0; + goto set_magic_common; case SVt_PVCV: SvANY(sv) = new_XPVCV(); Zero(SvANY(sv), 1, XPVCV); - SvPVX(sv) = pv; - SvCUR(sv) = cur; - SvLEN(sv) = len; - SvIVX(sv) = iv; - SvNVX(sv) = nv; - SvMAGIC(sv) = magic; - SvSTASH(sv) = stash; - break; - case SVt_PVGV: - SvANY(sv) = new_XPVGV(); - SvPVX(sv) = pv; - SvCUR(sv) = cur; - SvLEN(sv) = len; - SvIVX(sv) = iv; - SvNVX(sv) = nv; - SvMAGIC(sv) = magic; - SvSTASH(sv) = stash; + goto set_magic_common; + case SVt_PVLV: + SvANY(sv) = new_XPVLV(); + LvTARGOFF(sv) = 0; + LvTARGLEN(sv) = 0; + LvTARG(sv) = 0; + LvTYPE(sv) = 0; GvGP(sv) = 0; GvNAME(sv) = 0; GvNAMELEN(sv) = 0; GvSTASH(sv) = 0; GvFLAGS(sv) = 0; - break; - case SVt_PVBM: - SvANY(sv) = new_XPVBM(); - SvPVX(sv) = pv; - SvCUR(sv) = cur; - SvLEN(sv) = len; - SvIVX(sv) = iv; - SvNVX(sv) = nv; - SvMAGIC(sv) = magic; - SvSTASH(sv) = stash; - BmRARE(sv) = 0; - BmUSEFUL(sv) = 0; - BmPREVIOUS(sv) = 0; - break; - case SVt_PVFM: - SvANY(sv) = new_XPVFM(); - Zero(SvANY(sv), 1, XPVFM); - SvPVX(sv) = pv; - SvCUR(sv) = cur; - SvLEN(sv) = len; - SvIVX(sv) = iv; - SvNVX(sv) = nv; - SvMAGIC(sv) = magic; - SvSTASH(sv) = stash; - break; - case SVt_PVIO: - SvANY(sv) = new_XPVIO(); - Zero(SvANY(sv), 1, XPVIO); - SvPVX(sv) = pv; - SvCUR(sv) = cur; - SvLEN(sv) = len; - SvIVX(sv) = iv; - SvNVX(sv) = nv; - SvMAGIC(sv) = magic; - SvSTASH(sv) = stash; - IoPAGE_LEN(sv) = 60; + /* Fall through. */ + if (0) { + case SVt_PVMG: + SvANY(sv) = new_XPVMG(); + } + set_magic_common: + SvMAGIC_set(sv, magic); + SvSTASH_set(sv, stash); + /* Fall through. */ + if (0) { + case SVt_PVNV: + SvANY(sv) = new_XPVNV(); + } + SvNV_set(sv, nv); + /* Fall through. */ + if (0) { + case SVt_PVIV: + SvANY(sv) = new_XPVIV(); + if (SvNIOK(sv)) + (void)SvIOK_on(sv); + SvNOK_off(sv); + } + SvIV_set(sv, iv); + /* Fall through. */ + if (0) { + case SVt_PV: + SvANY(sv) = new_XPV(); + } + SvPV_set(sv, pv); + SvCUR_set(sv, cur); + SvLEN_set(sv, len); break; } - SvFLAGS(sv) &= ~SVTYPEMASK; - SvFLAGS(sv) |= mt; return TRUE; } @@ -2051,8 +2007,8 @@ Perl_sv_backoff(pTHX_ register SV *sv) assert(SvOOK(sv)); if (SvIVX(sv)) { char *s = SvPVX(sv); - SvLEN(sv) += SvIVX(sv); - SvPVX(sv) -= SvIVX(sv); + SvLEN_set(sv, SvLEN(sv) + SvIVX(sv)); + SvPV_set(sv, SvPVX(sv) - SvIVX(sv)); SvIV_set(sv, 0); Move(s, SvPVX(sv), SvCUR(sv)+1, char); } @@ -2112,7 +2068,7 @@ Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen) #endif Renew(s,newlen,char); } - else { + else { New(703, s, newlen, char); if (SvPVX(sv) && SvCUR(sv)) { Move(SvPVX(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char); @@ -2159,7 +2115,7 @@ Perl_sv_setiv(pTHX_ register SV *sv, IV i) OP_DESC(PL_op)); } (void)SvIOK_only(sv); /* validate number */ - SvIVX(sv) = i; + SvIV_set(sv, i); SvTAINT(sv); } @@ -2204,7 +2160,7 @@ Perl_sv_setuv(pTHX_ register SV *sv, UV u) } sv_setiv(sv, 0); SvIsUV_on(sv); - SvUVX(sv) = u; + SvUV_set(sv, u); } /* @@ -2269,7 +2225,7 @@ Perl_sv_setnv(pTHX_ register SV *sv, NV num) Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0), OP_NAME(PL_op)); } - SvNVX(sv) = num; + SvNV_set(sv, num); (void)SvNOK_only(sv); /* validate number */ SvTAINT(sv); } @@ -2480,14 +2436,14 @@ S_sv_2iuv_non_preserve(pTHX_ register SV *sv, I32 numtype) if (SvNVX(sv) < (NV)IV_MIN) { (void)SvIOKp_on(sv); (void)SvNOK_on(sv); - SvIVX(sv) = IV_MIN; + SvIV_set(sv, IV_MIN); return IS_NUMBER_UNDERFLOW_IV; } if (SvNVX(sv) > (NV)UV_MAX) { (void)SvIOKp_on(sv); (void)SvNOK_on(sv); SvIsUV_on(sv); - SvUVX(sv) = UV_MAX; + SvUV_set(sv, UV_MAX); return IS_NUMBER_OVERFLOW_UV; } (void)SvIOKp_on(sv); @@ -2495,7 +2451,7 @@ S_sv_2iuv_non_preserve(pTHX_ register SV *sv, I32 numtype) /* Can't use strtol etc to convert this string. (See truth table in sv_2iv */ if (SvNVX(sv) <= (UV)IV_MAX) { - SvIVX(sv) = I_V(SvNVX(sv)); + SvIV_set(sv, I_V(SvNVX(sv))); if ((NV)(SvIVX(sv)) == SvNVX(sv)) { SvIOK_on(sv); /* Integer is precise. NOK, IOK */ } else { @@ -2504,7 +2460,7 @@ S_sv_2iuv_non_preserve(pTHX_ register SV *sv, I32 numtype) return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV; } SvIsUV_on(sv); - SvUVX(sv) = U_V(SvNVX(sv)); + SvUV_set(sv, U_V(SvNVX(sv))); if ((NV)(SvUVX(sv)) == SvNVX(sv)) { if (SvUVX(sv) == UV_MAX) { /* As we know that NVs don't preserve UVs, UV_MAX cannot @@ -2603,7 +2559,7 @@ Perl_sv_2iv_flags(pTHX_ register SV *sv, I32 flags) answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary cases go to UV */ if (SvNVX(sv) < (NV)IV_MAX + 0.5) { - SvIVX(sv) = I_V(SvNVX(sv)); + SvIV_set(sv, I_V(SvNVX(sv))); if (SvNVX(sv) == (NV) SvIVX(sv) #ifndef NV_PRESERVES_UV && (((UV)1 << NV_PRESERVES_UV_BITS) > @@ -2641,7 +2597,7 @@ Perl_sv_2iv_flags(pTHX_ register SV *sv, I32 flags) 0x8000000000000000 which will be exact. NWC */ } else { - SvUVX(sv) = U_V(SvNVX(sv)); + SvUV_set(sv, U_V(SvNVX(sv))); if ( (SvNVX(sv) == (NV) SvUVX(sv)) #ifndef NV_PRESERVES_UV @@ -2704,15 +2660,15 @@ Perl_sv_2iv_flags(pTHX_ register SV *sv, I32 flags) if (!(numtype & IS_NUMBER_NEG)) { /* positive */; if (value <= (UV)IV_MAX) { - SvIVX(sv) = (IV)value; + SvIV_set(sv, (IV)value); } else { - SvUVX(sv) = value; + SvUV_set(sv, value); SvIsUV_on(sv); } } else { /* 2s complement assumption */ if (value <= (UV)IV_MIN) { - SvIVX(sv) = -(IV)value; + SvIV_set(sv, -(IV)value); } else { /* Too negative for an IV. This is a double upgrade, but I'm assuming it will be rare. */ @@ -2721,8 +2677,8 @@ Perl_sv_2iv_flags(pTHX_ register SV *sv, I32 flags) SvNOK_on(sv); SvIOK_off(sv); SvIOKp_on(sv); - SvNVX(sv) = -(NV)value; - SvIVX(sv) = IV_MIN; + SvNV_set(sv, -(NV)value); + SvIV_set(sv, IV_MIN); } } } @@ -2733,7 +2689,7 @@ Perl_sv_2iv_flags(pTHX_ register SV *sv, I32 flags) if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) != IS_NUMBER_IN_UV) { /* It wasn't an (integer that doesn't overflow the UV). */ - SvNVX(sv) = Atof(SvPVX(sv)); + SvNV_set(sv, Atof(SvPVX(sv))); if (! numtype && ckWARN(WARN_NUMERIC)) not_a_number(sv); @@ -2751,7 +2707,7 @@ Perl_sv_2iv_flags(pTHX_ register SV *sv, I32 flags) (void)SvIOKp_on(sv); (void)SvNOK_on(sv); if (SvNVX(sv) < (NV)IV_MAX + 0.5) { - SvIVX(sv) = I_V(SvNVX(sv)); + SvIV_set(sv, I_V(SvNVX(sv))); if ((NV)(SvIVX(sv)) == SvNVX(sv)) { SvIOK_on(sv); } else { @@ -2762,10 +2718,10 @@ Perl_sv_2iv_flags(pTHX_ register SV *sv, I32 flags) if (SvNVX(sv) > (NV)UV_MAX) { SvIsUV_on(sv); /* Integer is inaccurate. NOK, IOKp, is UV */ - SvUVX(sv) = UV_MAX; + SvUV_set(sv, UV_MAX); SvIsUV_on(sv); } else { - SvUVX(sv) = U_V(SvNVX(sv)); + SvUV_set(sv, U_V(SvNVX(sv))); /* 0xFFFFFFFFFFFFFFFF not an issue in here */ if ((NV)(SvUVX(sv)) == SvNVX(sv)) { SvIOK_on(sv); @@ -2791,7 +2747,7 @@ Perl_sv_2iv_flags(pTHX_ register SV *sv, I32 flags) /* Small enough to preserve all bits. */ (void)SvIOKp_on(sv); SvNOK_on(sv); - SvIVX(sv) = I_V(SvNVX(sv)); + SvIV_set(sv, I_V(SvNVX(sv))); if ((NV)(SvIVX(sv)) == SvNVX(sv)) SvIOK_on(sv); /* Assumption: first non-preserved integer is < IV_MAX, @@ -2908,7 +2864,7 @@ Perl_sv_2uv_flags(pTHX_ register SV *sv, I32 flags) (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */ if (SvNVX(sv) < (NV)IV_MAX + 0.5) { - SvIVX(sv) = I_V(SvNVX(sv)); + SvIV_set(sv, I_V(SvNVX(sv))); if (SvNVX(sv) == (NV) SvIVX(sv) #ifndef NV_PRESERVES_UV && (((UV)1 << NV_PRESERVES_UV_BITS) > @@ -2946,7 +2902,7 @@ Perl_sv_2uv_flags(pTHX_ register SV *sv, I32 flags) 0x8000000000000000 which will be exact. NWC */ } else { - SvUVX(sv) = U_V(SvNVX(sv)); + SvUV_set(sv, U_V(SvNVX(sv))); if ( (SvNVX(sv) == (NV) SvUVX(sv)) #ifndef NV_PRESERVES_UV @@ -3005,16 +2961,16 @@ Perl_sv_2uv_flags(pTHX_ register SV *sv, I32 flags) if (!(numtype & IS_NUMBER_NEG)) { /* positive */; if (value <= (UV)IV_MAX) { - SvIVX(sv) = (IV)value; + SvIV_set(sv, (IV)value); } else { /* it didn't overflow, and it was positive. */ - SvUVX(sv) = value; + SvUV_set(sv, value); SvIsUV_on(sv); } } else { /* 2s complement assumption */ if (value <= (UV)IV_MIN) { - SvIVX(sv) = -(IV)value; + SvIV_set(sv, -(IV)value); } else { /* Too negative for an IV. This is a double upgrade, but I'm assuming it will be rare. */ @@ -3023,8 +2979,8 @@ Perl_sv_2uv_flags(pTHX_ register SV *sv, I32 flags) SvNOK_on(sv); SvIOK_off(sv); SvIOKp_on(sv); - SvNVX(sv) = -(NV)value; - SvIVX(sv) = IV_MIN; + SvNV_set(sv, -(NV)value); + SvIV_set(sv, IV_MIN); } } } @@ -3032,7 +2988,7 @@ Perl_sv_2uv_flags(pTHX_ register SV *sv, I32 flags) if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) != IS_NUMBER_IN_UV) { /* It wasn't an integer, or it overflowed the UV. */ - SvNVX(sv) = Atof(SvPVX(sv)); + SvNV_set(sv, Atof(SvPVX(sv))); if (! numtype && ckWARN(WARN_NUMERIC)) not_a_number(sv); @@ -3049,7 +3005,7 @@ Perl_sv_2uv_flags(pTHX_ register SV *sv, I32 flags) (void)SvIOKp_on(sv); (void)SvNOK_on(sv); if (SvNVX(sv) < (NV)IV_MAX + 0.5) { - SvIVX(sv) = I_V(SvNVX(sv)); + SvIV_set(sv, I_V(SvNVX(sv))); if ((NV)(SvIVX(sv)) == SvNVX(sv)) { SvIOK_on(sv); } else { @@ -3060,10 +3016,10 @@ Perl_sv_2uv_flags(pTHX_ register SV *sv, I32 flags) if (SvNVX(sv) > (NV)UV_MAX) { SvIsUV_on(sv); /* Integer is inaccurate. NOK, IOKp, is UV */ - SvUVX(sv) = UV_MAX; + SvUV_set(sv, UV_MAX); SvIsUV_on(sv); } else { - SvUVX(sv) = U_V(SvNVX(sv)); + SvUV_set(sv, U_V(SvNVX(sv))); /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs NV preservse UV so can do correct comparison. */ if ((NV)(SvUVX(sv)) == SvNVX(sv)) { @@ -3089,7 +3045,7 @@ Perl_sv_2uv_flags(pTHX_ register SV *sv, I32 flags) /* Small enough to preserve all bits. */ (void)SvIOKp_on(sv); SvNOK_on(sv); - SvIVX(sv) = I_V(SvNVX(sv)); + SvIV_set(sv, I_V(SvNVX(sv))); if ((NV)(SvIVX(sv)) == SvNVX(sv)) SvIOK_on(sv); /* Assumption: first non-preserved integer is < IV_MAX, @@ -3204,7 +3160,7 @@ Perl_sv_2nv(pTHX_ register SV *sv) return SvNVX(sv); } if (SvIOKp(sv)) { - SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv); + SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv)); #ifdef NV_PRESERVES_UV SvNOK_on(sv); #else @@ -3226,12 +3182,12 @@ Perl_sv_2nv(pTHX_ register SV *sv) if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) == IS_NUMBER_IN_UV) { /* It's definitely an integer */ - SvNVX(sv) = (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value; + SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value); } else - SvNVX(sv) = Atof(SvPVX(sv)); + SvNV_set(sv, Atof(SvPVX(sv))); SvNOK_on(sv); #else - SvNVX(sv) = Atof(SvPVX(sv)); + SvNV_set(sv, Atof(SvPVX(sv))); /* Only set the public NV OK flag if this NV preserves the value in the PV at least as well as an IV/UV would. Not sure how to do this 100% reliably. */ @@ -3255,11 +3211,11 @@ Perl_sv_2nv(pTHX_ register SV *sv) SvIOKp_on(sv); if (numtype & IS_NUMBER_NEG) { - SvIVX(sv) = -(IV)value; + SvIV_set(sv, -(IV)value); } else if (value <= (UV)IV_MAX) { - SvIVX(sv) = (IV)value; + SvIV_set(sv, (IV)value); } else { - SvUVX(sv) = value; + SvUV_set(sv, value); SvIsUV_on(sv); } @@ -3458,7 +3414,7 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) if (!sv) { *lp = 0; - return ""; + return (char *)""; } if (SvGMAGICAL(sv)) { if (flags & SV_GMAGIC) @@ -3486,12 +3442,13 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) report_uninit(sv); } *lp = 0; - return ""; + return (char *)""; } } if (SvTHINKFIRST(sv)) { if (SvROK(sv)) { SV* tmpstr; + register const char *typestr; if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) { char *pv = SvPV(tmpstr, *lp); @@ -3504,7 +3461,7 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) origsv = sv; sv = (SV*)SvRV(sv); if (!sv) - s = "NULLREF"; + typestr = "NULLREF"; else { MAGIC *mg; @@ -3514,10 +3471,10 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG)) == (SVs_OBJECT|SVs_SMG)) && (mg = mg_find(sv, PERL_MAGIC_qr))) { - regexp *re = (regexp *)mg->mg_obj; + const regexp *re = (regexp *)mg->mg_obj; if (!mg->mg_ptr) { - char *fptr = "msix"; + const char *fptr = "msix"; char reflags[6]; char ch; int left = 0; @@ -3557,10 +3514,10 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) */ if (PMf_EXTENDED & re->reganch) { - char *endptr = re->precomp + re->prelen; + const char *endptr = re->precomp + re->prelen; while (endptr >= re->precomp) { - char c = *(endptr--); + const char c = *(endptr--); if (c == '\n') break; /* don't need another */ if (c == '#') { @@ -3600,49 +3557,45 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) case SVt_PV: case SVt_PVIV: case SVt_PVNV: - case SVt_PVBM: if (SvROK(sv)) - s = "REF"; - else - s = "SCALAR"; break; - case SVt_PVLV: s = SvROK(sv) ? "REF" + case SVt_PVBM: typestr = SvROK(sv) ? "REF" : "SCALAR"; break; + case SVt_PVLV: typestr = SvROK(sv) ? "REF" /* tied lvalues should appear to be * scalars for backwards compatitbility */ : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T') ? "SCALAR" : "LVALUE"; break; - case SVt_PVAV: s = "ARRAY"; break; - case SVt_PVHV: s = "HASH"; break; - case SVt_PVCV: s = "CODE"; break; - case SVt_PVGV: s = "GLOB"; break; - case SVt_PVFM: s = "FORMAT"; break; - case SVt_PVIO: s = "IO"; break; - default: s = "UNKNOWN"; break; + case SVt_PVAV: typestr = "ARRAY"; break; + case SVt_PVHV: typestr = "HASH"; break; + case SVt_PVCV: typestr = "CODE"; break; + case SVt_PVGV: typestr = "GLOB"; break; + case SVt_PVFM: typestr = "FORMAT"; break; + case SVt_PVIO: typestr = "IO"; break; + default: typestr = "UNKNOWN"; break; } tsv = NEWSV(0,0); - if (SvOBJECT(sv)) - if (HvNAME(SvSTASH(sv))) - Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s); - else - Perl_sv_setpvf(aTHX_ tsv, "__ANON__=%s", s); + if (SvOBJECT(sv)) { + const char *name = HvNAME(SvSTASH(sv)); + Perl_sv_setpvf(aTHX_ tsv, "%s=%s(0x%"UVxf")", + name ? name : "__ANON__" , typestr, PTR2UV(sv)); + } else - sv_setpv(tsv, s); - Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv)); + Perl_sv_setpvf(aTHX_ tsv, "%s(0x%"UVxf")", typestr, PTR2UV(sv)); goto tokensaveref; } - *lp = strlen(s); - return s; + *lp = strlen(typestr); + return (char *)typestr; } if (SvREADONLY(sv) && !SvOK(sv)) { if (ckWARN(WARN_UNINITIALIZED)) report_uninit(sv); *lp = 0; - return ""; + return (char *)""; } } if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) { /* I'm assuming that if both IV and NV are equally valid then converting the IV is going to be more efficient */ - U32 isIOK = SvIOK(sv); - U32 isUIOK = SvIsUV(sv); + const U32 isIOK = SvIOK(sv); + const U32 isUIOK = SvIsUV(sv); char buf[TYPE_CHARS(UV)]; char *ebuf, *ptr; @@ -3698,7 +3651,7 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) if (SvTYPE(sv) < SVt_PV) /* Typically the caller expects that sv_any is not NULL now. */ sv_upgrade(sv, SVt_PV); - return ""; + return (char *)""; } *lp = s - SvPVX(sv); SvCUR_set(sv, *lp); @@ -3719,8 +3672,9 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) return SvPVX(tsv); } else { + dVAR; STRLEN len; - char *t; + const char *t; if (tsv) { sv_2mortal(tsv); @@ -3741,9 +3695,8 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) *lp = len; s = SvGROW(sv, len + 1); SvCUR_set(sv, len); - (void)strcpy(s, t); SvPOKp_on(sv); - return s; + return strcpy(s, t); } } @@ -3933,16 +3886,20 @@ use the Encode extension for that. STRLEN Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags) { - U8 *s, *t, *e; - int hibit = 0; - + if (sv == &PL_sv_undef) + return 0; if (!SvPOK(sv)) { STRLEN len = 0; - (void) SvPV_force(sv,len); + if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) { + (void) sv_2pv_flags(sv,&len, flags); + if (SvUTF8(sv)) + return len; + } else { + (void) SvPV_force(sv,len); + } } if (SvUTF8(sv)) { - SvSETMAGIC(sv); return SvCUR(sv); } @@ -3953,33 +3910,33 @@ Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags) 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 - * had a FLAG in SVs to signal if there are any hibit - * chars in the PV. Given that there isn't such a flag - * make the loop as fast as possible. */ - s = (U8 *) SvPVX(sv); - e = (U8 *) SvEND(sv); - t = s; - while (t < e) { - U8 ch = *t++; - if ((hibit = !NATIVE_IS_INVARIANT(ch))) - break; - } - if (hibit) { - STRLEN len; - (void)SvOOK_off(sv); - s = (U8*)SvPVX(sv); - len = SvCUR(sv) + 1; /* Plus the \0 */ - SvPVX(sv) = (char*)bytes_to_utf8((U8*)s, &len); - SvCUR(sv) = len - 1; - if (SvLEN(sv) != 0) - Safefree(s); /* No longer using what was there before. */ - SvLEN(sv) = len; /* No longer know the real size. */ - } - /* Mark as UTF-8 even if no hibit - saves scanning loop */ - SvUTF8_on(sv); + /* This function could be much more efficient if we + * had a FLAG in SVs to signal if there are any hibit + * chars in the PV. Given that there isn't such a flag + * make the loop as fast as possible. */ + U8 *s = (U8 *) SvPVX(sv); + U8 *e = (U8 *) SvEND(sv); + U8 *t = s; + int hibit = 0; + + while (t < e) { + U8 ch = *t++; + if ((hibit = !NATIVE_IS_INVARIANT(ch))) + break; + } + if (hibit) { + STRLEN len = SvCUR(sv) + 1; /* Plus the \0 */ + s = bytes_to_utf8((U8*)s, &len); + + SvPV_free(sv); /* No longer using what was there before. */ + + SvPV_set(sv, (char*)s); + SvCUR_set(sv, len - 1); + SvLEN_set(sv, len); /* No longer know the real size. */ + } + /* Mark as UTF-8 even if no hibit - saves scanning loop */ + SvUTF8_on(sv); } - SvSETMAGIC(sv); return SvCUR(sv); } @@ -4020,7 +3977,7 @@ Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok) Perl_croak(aTHX_ "Wide character"); } } - SvCUR(sv) = len; + SvCUR_set(sv, len); } } SvUTF8_off(sv); @@ -4123,8 +4080,9 @@ function if the source SV needs to be reused. Does not handle 'set' magic. Loosely speaking, it performs a copy-by-value, obliterating any previous content of the destination. If the C parameter has the C bit set, will C on -C if appropriate, else not. C and C are -implemented in terms of this function. +C if appropriate, else not. If the C parameter has the +C bit set then the buffers of temps will not be stolen. +and C are implemented in terms of this function. You probably want to use one of the assortment of wrappers, such as C, C, C and @@ -4152,7 +4110,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) dtype = SvTYPE(dstr); SvAMAGIC_off(dstr); - if ( SvVOK(dstr) ) + if ( SvVOK(dstr) ) { /* need to nuke the magic */ mg_free(dstr); @@ -4184,7 +4142,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) break; } (void)SvIOK_only(dstr); - SvIVX(dstr) = SvIVX(sstr); + SvIV_set(dstr, SvIVX(sstr)); if (SvIsUV(sstr)) SvIsUV_on(dstr); if (SvTAINTED(sstr)) @@ -4206,7 +4164,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) sv_upgrade(dstr, SVt_PVNV); break; } - SvNVX(dstr) = SvNVX(sstr); + SvNV_set(dstr, SvNVX(sstr)); (void)SvNOK_only(dstr); if (SvTAINTED(sstr)) SvTAINT(dstr); @@ -4458,21 +4416,20 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) return; } if (SvPVX(dstr)) { - (void)SvOOK_off(dstr); /* backoff */ - if (SvLEN(dstr)) - Safefree(SvPVX(dstr)); - SvLEN(dstr)=SvCUR(dstr)=0; + SvPV_free(dstr); + SvLEN_set(dstr, 0); + SvCUR_set(dstr, 0); } } (void)SvOK_off(dstr); - SvRV(dstr) = SvREFCNT_inc(SvRV(sstr)); + SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr))); SvROK_on(dstr); if (sflags & SVp_NOK) { SvNOKp_on(dstr); /* Only set the public OK flag if the source has public OK. */ if (sflags & SVf_NOK) SvFLAGS(dstr) |= SVf_NOK; - SvNVX(dstr) = SvNVX(sstr); + SvNV_set(dstr, SvNVX(sstr)); } if (sflags & SVp_IOK) { (void)SvIOKp_on(dstr); @@ -4480,7 +4437,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) SvFLAGS(dstr) |= SVf_IOK; if (sflags & SVf_IVisUV) SvIsUV_on(dstr); - SvIVX(dstr) = SvIVX(sstr); + SvIV_set(dstr, SvIVX(sstr)); } if (SvAMAGIC(sstr)) { SvAMAGIC_on(dstr); @@ -4508,6 +4465,8 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) !(isSwipe = (sflags & SVs_TEMP) && /* slated for free anyway? */ !(sflags & SVf_OOK) && /* and not involved in OOK hack? */ + (!(flags & SV_NOSTEAL)) && + /* and we're allowed to steal temps */ SvREFCNT(sstr) == 1 && /* and no other references to it? */ SvLEN(sstr) && /* and really is a string */ /* and won't be needed again, potentially */ @@ -4583,10 +4542,10 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) SvPV_set(dstr, sharepvn(SvPVX(sstr), (sflags & SVf_UTF8?-cur:cur), hash)); - SvUVX(dstr) = hash; + SvUV_set(dstr, hash); } - SvLEN(dstr) = len; - SvCUR(dstr) = cur; + SvLEN_set(dstr, len); + SvCUR_set(dstr, cur); SvREADONLY_on(dstr); SvFAKE_on(dstr); /* Relesase a global SV mutex. */ @@ -4613,7 +4572,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) SvNOKp_on(dstr); if (sflags & SVf_NOK) SvFLAGS(dstr) |= SVf_NOK; - SvNVX(dstr) = SvNVX(sstr); + SvNV_set(dstr, SvNVX(sstr)); } if (sflags & SVp_IOK) { (void)SvIOKp_on(dstr); @@ -4621,14 +4580,14 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) SvFLAGS(dstr) |= SVf_IOK; if (sflags & SVf_IVisUV) SvIsUV_on(dstr); - SvIVX(dstr) = SvIVX(sstr); + SvIV_set(dstr, SvIVX(sstr)); } if (SvVOK(sstr)) { - MAGIC *smg = mg_find(sstr,PERL_MAGIC_vstring); + 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) @@ -4640,13 +4599,13 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */ if (sflags & SVf_IVisUV) SvIsUV_on(dstr); - SvIVX(dstr) = SvIVX(sstr); + SvIV_set(dstr, SvIVX(sstr)); if (sflags & SVp_NOK) { if (sflags & SVf_NOK) (void)SvNOK_on(dstr); else (void)SvNOKp_on(dstr); - SvNVX(dstr) = SvNVX(sstr); + SvNV_set(dstr, SvNVX(sstr)); } } else if (sflags & SVp_NOK) { @@ -4656,7 +4615,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) (void)SvOK_off(dstr); SvNOKp_on(dstr); } - SvNVX(dstr) = SvNVX(sstr); + SvNV_set(dstr, SvNVX(sstr)); } else { if (dtype == SVt_PVGV) { @@ -4725,7 +4684,7 @@ Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr) UV hash = SvUVX(sstr); DEBUG_C(PerlIO_printf(Perl_debug_log, "Fast copy on write: Sharing hash\n")); - SvUVX(dstr) = hash; + SvUV_set(dstr, hash); new_pv = sharepvn(SvPVX(sstr), (SvUTF8(sstr)?-cur:cur), hash); goto common_exit; } @@ -4747,8 +4706,8 @@ Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr) SvFLAGS(dstr) = (SVt_PVIV|SVf_POK|SVp_POK|SVf_FAKE|SVf_READONLY); if (SvUTF8(sstr)) SvUTF8_on(dstr); - SvLEN(dstr) = len; - SvCUR(dstr) = cur; + SvLEN_set(dstr, len); + SvCUR_set(dstr, cur); if (DEBUG_C_TEST) { sv_dump(dstr); } @@ -4760,7 +4719,8 @@ Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr) =for apidoc sv_setpvn Copies a string into an SV. The C parameter indicates the number of -bytes to be copied. Does not handle 'set' magic. See C. +bytes to be copied. If the C argument is NULL the SV will become +undefined. Does not handle 'set' magic. See C. =cut */ @@ -4874,11 +4834,10 @@ Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len) (void)SvOK_off(sv); return; } - (void)SvOOK_off(sv); - if (SvPVX(sv) && SvLEN(sv)) - Safefree(SvPVX(sv)); + if (SvPVX(sv)) + SvPV_free(sv); Renew(ptr, len+1, char); - SvPVX(sv) = ptr; + SvPV_set(sv, ptr); SvCUR_set(sv, len); SvLEN_set(sv, len+1); *SvEND(sv) = '\0'; @@ -4914,7 +4873,7 @@ S_sv_release_COW(pTHX_ register SV *sv, char *pvx, STRLEN cur, STRLEN len, 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.) @@ -4945,7 +4904,8 @@ Perl_sv_release_IVX(pTHX_ register SV *sv) { if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0); - return SvOOK_off(sv); + SvOOK_off(sv); + return 0; } #endif /* @@ -4985,15 +4945,15 @@ Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags) 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; + SvPV_set(sv, (char*)0); + SvLEN_set(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; + SvCUR_set(sv, cur); *SvEND(sv) = '\0'; } sv_release_COW(sv, pvx, cur, len, hash, next); @@ -5014,8 +4974,8 @@ Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags) U32 hash = SvUVX(sv); SvFAKE_off(sv); SvREADONLY_off(sv); - SvPVX(sv) = 0; - SvLEN(sv) = 0; + SvPV_set(sv, (char*)0); + SvLEN_set(sv, 0); SvGROW(sv, len + 1); Move(pvx,SvPVX(sv),len,char); *SvEND(sv) = '\0'; @@ -5079,17 +5039,17 @@ Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) Move(pvx,SvPVX(sv),len,char); *SvEND(sv) = '\0'; } - SvIVX(sv) = 0; + SvIV_set(sv, 0); /* Same SvOOK_on but SvOOK_on does a SvIOK_off and we do that anyway inside the SvNIOK_off */ - SvFLAGS(sv) |= SVf_OOK; + SvFLAGS(sv) |= SVf_OOK; } SvNIOK_off(sv); - SvLEN(sv) -= delta; - SvCUR(sv) -= delta; - SvPVX(sv) += delta; - SvIVX(sv) += delta; + SvLEN_set(sv, SvLEN(sv) - delta); + SvCUR_set(sv, SvCUR(sv) - delta); + SvPV_set(sv, SvPVX(sv) + delta); + SvIV_set(sv, SvIVX(sv) + delta); } /* sv_catpvn() is now a macro using Perl_sv_catpvn_flags(); @@ -5133,7 +5093,7 @@ Perl_sv_catpvn_flags(pTHX_ register SV *dsv, register const char *sstr, register if (sstr == dstr) sstr = SvPVX(dsv); Move(sstr, SvPVX(dsv) + dlen, slen, char); - SvCUR(dsv) += slen; + SvCUR_set(dsv, SvCUR(dsv) + slen); *SvEND(dsv) = '\0'; (void)SvPOK_only_UTF8(dsv); /* validate pointer */ SvTAINT(dsv); @@ -5256,7 +5216,7 @@ Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr) if (ptr == junk) ptr = SvPVX(sv); Move(ptr,SvPVX(sv)+tlen,len+1,char); - SvCUR(sv) += len; + SvCUR_set(sv, SvCUR(sv) + len); (void)SvPOK_only_UTF8(sv); /* validate pointer */ SvTAINT(sv); } @@ -5302,23 +5262,23 @@ Perl_newSV(pTHX_ STRLEN len) =for apidoc sv_magicext Adds magic to an SV, upgrading it if necessary. Applies the -supplied vtable and returns pointer to the magic added. +supplied vtable and returns a pointer to the magic added. -Note that sv_magicext will allow things that sv_magic will not. -In particular you can add magic to SvREADONLY SVs and and more than -one instance of the same 'how' +Note that C will allow things that C will not. +In particular, you can add magic to SvREADONLY SVs, and add more than +one instance of the same 'how'. -I C is greater then zero then a savepvn() I of C is stored, -if C is zero then C is stored as-is and - as another special -case - if C<(name && namelen == HEf_SVKEY)> then C is assumed to contain -an C and has its REFCNT incremented +If C is greater than zero then a C I of C is +stored, if C is zero then C is stored as-is and - as another +special case - if C<(name && namlen == HEf_SVKEY)> then C is assumed +to contain an C and is stored as-is with its REFCNT incremented. -(This is now used as a subroutine by sv_magic.) +(This is now used as a subroutine by C.) =cut */ MAGIC * -Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, MGVTBL *vtable, +Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, const MGVTBL *vtable, const char* name, I32 namlen) { MAGIC* mg; @@ -5328,12 +5288,12 @@ Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, MGVTBL *vtable, } Newz(702,mg, 1, MAGIC); mg->mg_moremagic = SvMAGIC(sv); - SvMAGIC(sv) = mg; + SvMAGIC_set(sv, mg); - /* 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. + /* Sometimes a magic contains 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. Note we cannot do this to avoid self-tie loops as intervening RV must have its REFCNT incremented to keep it in existence. @@ -5392,14 +5352,20 @@ Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, MGVTBL *vtable, Adds magic to an SV. First upgrades C to type C if necessary, then adds a new magic item of type C to the head of the magic list. +See C (which C now calls) for a description of the +handling of the C and C arguments. + +You need to use C to add magic to SvREADONLY SVs and also +to add more than one instance of the same 'how'. + =cut */ void Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen) { + const MGVTBL *vtable = 0; MAGIC* mg; - MGVTBL *vtable = 0; #ifdef PERL_COPY_ON_WRITE if (SvIsCOW(sv)) @@ -5542,7 +5508,7 @@ Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 nam } /* Rest of work is done else where */ - mg = sv_magicext(sv,obj,how,vtable,name,namlen); + mg = sv_magicext(sv,obj,how,(MGVTBL*)vtable,name,namlen); switch (how) { case PERL_MAGIC_taint: @@ -5573,7 +5539,7 @@ Perl_sv_unmagic(pTHX_ SV *sv, int type) mgp = &SvMAGIC(sv); for (mg = *mgp; mg; mg = *mgp) { if (mg->mg_type == type) { - MGVTBL* vtbl = mg->mg_virtual; + const MGVTBL* const vtbl = mg->mg_virtual; *mgp = mg->mg_moremagic; if (vtbl && vtbl->svt_free) CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg); @@ -5692,7 +5658,7 @@ the Perl substr() function. */ void -Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen) +Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, const char *little, STRLEN littlelen) { register char *big; register char *mid; @@ -5723,7 +5689,7 @@ Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN while (midend > mid) /* shove everything down */ *--bigend = *--midend; Move(little,big+offset,littlelen,char); - SvCUR(bigstr) += i; + SvCUR_set(bigstr, SvCUR(bigstr) + i); SvSETMAGIC(bigstr); return; } @@ -5801,15 +5767,22 @@ Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv) mg_free(nsv); else sv_upgrade(nsv, SVt_PVMG); - SvMAGIC(nsv) = SvMAGIC(sv); + SvMAGIC_set(nsv, SvMAGIC(sv)); SvFLAGS(nsv) |= SvMAGICAL(sv); SvMAGICAL_off(sv); - SvMAGIC(sv) = 0; + SvMAGIC_set(sv, NULL); } SvREFCNT(sv) = 0; sv_clear(sv); assert(!SvREFCNT(sv)); +#ifdef DEBUG_LEAKING_SCALARS + sv->sv_flags = nsv->sv_flags; + sv->sv_any = nsv->sv_any; + sv->sv_refcnt = nsv->sv_refcnt; +#else StructCopy(nsv,sv,SV); +#endif + #ifdef PERL_COPY_ON_WRITE if (SvIsCOW_normal(nsv)) { /* We need to follow the pointers around the loop to make the @@ -5855,6 +5828,7 @@ instead. void Perl_sv_clear(pTHX_ register SV *sv) { + dVAR; HV* stash; assert(sv); assert(SvREFCNT(sv) == 0); @@ -5879,15 +5853,15 @@ Perl_sv_clear(pTHX_ register SV *sv) PUSHs(tmpref); PUTBACK; call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR|G_VOID); - - + + POPSTACK; SPAGAIN; LEAVE; if(SvREFCNT(tmpref) < 2) { /* tmpref is not kept alive! */ SvREFCNT(sv)--; - SvRV(tmpref) = 0; + SvRV_set(tmpref, NULL); SvROK_off(tmpref); } SvREFCNT_dec(tmpref); @@ -5968,7 +5942,11 @@ Perl_sv_clear(pTHX_ register SV *sv) case SVt_PVNV: case SVt_PVIV: freescalar: - (void)SvOOK_off(sv); + /* Don't bother with SvOOK_off(sv); as we're only going to free it. */ + if (SvOOK(sv)) { + SvPV_set(sv, SvPVX(sv) - SvIVX(sv)); + /* Don't even bother with turning off the OOK flag. */ + } /* FALL THROUGH */ case SVt_PV: case SVt_RV: @@ -6104,6 +6082,7 @@ Normally called via a wrapper macro C. void Perl_sv_free(pTHX_ SV *sv) { + dVAR; if (!sv) return; if (SvREFCNT(sv) == 0) { @@ -6132,6 +6111,7 @@ Perl_sv_free(pTHX_ SV *sv) void Perl_sv_free2(pTHX_ SV *sv) { + dVAR; #ifdef DEBUGGING if (SvTEMP(sv)) { if (ckWARN_d(WARN_DEBUGGING)) @@ -6188,7 +6168,7 @@ UTF-8 bytes as a single character. Handles magic and type coercion. * 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 @@ -6238,11 +6218,11 @@ Perl_sv_len_utf8(pTHX_ register SV *sv) 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; + bool found = FALSE; if (SvMAGICAL(sv) && !SvREADONLY(sv)) { if (!*mgp) - *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, &PL_vtbl_utf8, 0, 0); + *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, (MGVTBL*)&PL_vtbl_utf8, 0, 0); assert(*mgp); if ((*mgp)->mg_ptr) @@ -6280,7 +6260,7 @@ S_utf8_mg_pos(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i, I32 *offsetp, I *cachep = (STRLEN *) (*mgp)->mg_ptr; ASSERT_UTF8_CACHE(*cachep); if ((*cachep)[i] == (STRLEN)uoff) /* An exact match. */ - found = TRUE; + found = TRUE; else { /* We will skip to the right spot. */ STRLEN forw = 0; STRLEN backw = 0; @@ -6341,7 +6321,7 @@ S_utf8_mg_pos(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i, I32 *offsetp, I (*cachep)[2] = 0; (*cachep)[3] = 0; } - + found = TRUE; } } @@ -6378,7 +6358,7 @@ S_utf8_mg_pos(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i, I32 *offsetp, I return found; } - + /* =for apidoc sv_pos_u2b @@ -6431,7 +6411,7 @@ Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp) if (lenp) { found = FALSE; start = s; - if (utf8_mg_pos(sv, &mg, &cache, 2, lenp, *lenp + *offsetp, &s, start, send)) { + if (utf8_mg_pos(sv, &mg, &cache, 2, lenp, *lenp, &s, start, send)) { *lenp -= boffset; found = TRUE; } @@ -6507,7 +6487,7 @@ Perl_sv_pos_b2u(pTHX_ register SV* sv, I32* offsetp) /* We already know part of the way. */ len = cache[0]; s += cache[1]; - /* Let the below loop do the rest. */ + /* Let the below loop do the rest. */ } else { /* cache[1] > *offsetp */ /* We already know all of the way, now we may @@ -6521,7 +6501,7 @@ Perl_sv_pos_b2u(pTHX_ register SV* sv, I32* offsetp) if (!(forw < 2 * backw)) { U8 *p = s + cache[1]; STRLEN ubackw = 0; - + cache[1] -= backw; while (backw--) { @@ -6600,9 +6580,9 @@ coerce its args to strings if necessary. I32 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2) { - char *pv1; + const char *pv1; STRLEN cur1; - char *pv2; + const char *pv2; STRLEN cur2; I32 eq = 0; char *tpv = Nullch; @@ -6637,8 +6617,10 @@ Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2) pv1 = SvPV(svrecode, cur1); } /* Now both are in UTF-8. */ - if (cur1 != cur2) + if (cur1 != cur2) { + SvREFCNT_dec(svrecode); return FALSE; + } } else { bool is_utf8 = TRUE; @@ -6646,7 +6628,7 @@ Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2) if (SvUTF8(sv1)) { /* sv1 is the UTF-8 one, * if is equal it must be downgrade-able */ - char *pv = (char*)bytes_from_utf8((U8*)pv1, + char *pv = (char*)bytes_from_utf8((const U8*)pv1, &cur1, &is_utf8); if (pv != pv1) pv1 = tpv = pv; @@ -6654,13 +6636,14 @@ Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2) else { /* sv2 is the UTF-8 one, * if is equal it must be downgrade-able */ - char *pv = (char *)bytes_from_utf8((U8*)pv2, + char *pv = (char *)bytes_from_utf8((const U8*)pv2, &cur2, &is_utf8); if (pv != pv2) pv2 = tpv = pv; } if (is_utf8) { /* Downgrade not possible - cannot be eq */ + assert (tpv == 0); return FALSE; } } @@ -6693,7 +6676,8 @@ I32 Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2) { STRLEN cur1, cur2; - char *pv1, *pv2, *tpv = Nullch; + const char *pv1, *pv2; + char *tpv = Nullch; I32 cmp; SV *svrecode = Nullsv; @@ -6721,7 +6705,7 @@ Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2) pv2 = SvPV(svrecode, cur2); } else { - pv2 = tpv = (char*)bytes_to_utf8((U8*)pv2, &cur2); + pv2 = tpv = (char*)bytes_to_utf8((const U8*)pv2, &cur2); } } else { @@ -6731,7 +6715,7 @@ Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2) pv1 = SvPV(svrecode, cur1); } else { - pv1 = tpv = (char*)bytes_to_utf8((U8*)pv1, &cur1); + pv1 = tpv = (char*)bytes_to_utf8((const U8*)pv1, &cur1); } } } @@ -6741,7 +6725,7 @@ Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2) } else if (!cur2) { cmp = 1; } else { - I32 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2); + const I32 retval = memcmp((const void*)pv1, (const void*)pv2, cur1 < cur2 ? cur1 : cur2); if (retval) { cmp = retval < 0 ? -1 : 1; @@ -6893,7 +6877,7 @@ appending to the currently-stored string. char * Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append) { - char *rsptr; + const char *rsptr; STRLEN rslen; register STDCHAR rslast; register STDCHAR *bp; @@ -6940,9 +6924,9 @@ Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append) rslen = 1; } else if (RsSNARF(PL_rs)) { - /* If it is a regular disk file use size from stat() as estimate - of amount we are going to read - may result in malloc-ing - more memory than we realy need if layers bellow reduce + /* If it is a regular disk file use size from stat() as estimate + of amount we are going to read - may result in malloc-ing + more memory than we realy need if layers bellow reduce size we read (e.g. CRLF or a gzip layer) */ Stat_t st; @@ -7047,12 +7031,12 @@ Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append) cnt = PerlIO_get_cnt(fp); /* get count into register */ /* make sure we have the room */ - if ((I32)(SvLEN(sv) - append) <= cnt + 1) { + if ((I32)(SvLEN(sv) - append) <= cnt + 1) { /* Not room for all of it - if we are looking for a separator and room for some + if we are looking for a separator and room for some */ if (rslen && cnt > 80 && (I32)SvLEN(sv) > append) { - /* just process what we have room for */ + /* just process what we have room for */ shortbuffered = cnt - SvLEN(sv) + append + 1; cnt -= shortbuffered; } @@ -7062,7 +7046,7 @@ Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append) SvGROW(sv, (STRLEN)(append + (cnt <= 0 ? 2 : (cnt + 1)))); } } - else + else shortbuffered = 0; bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */ ptr = (STDCHAR*)PerlIO_get_ptr(fp); @@ -7162,17 +7146,7 @@ thats_really_all_folks: else { /*The big, slow, and stupid way. */ - - /* Any stack-challenged places. */ -#if defined(EPOC) - /* EPOC: need to work around SDK features. * - * On WINS: MS VC5 generates calls to _chkstk, * - * if a "large" stack frame is allocated. * - * gcc on MARM does not generate calls like these. */ -# define USEHEAPINSTEADOFSTACK -#endif - -#ifdef USEHEAPINSTEADOFSTACK +#ifdef USE_HEAP_INSTEAD_OF_STACK /* Even slower way. */ STDCHAR *buf = 0; New(0, buf, 8192, STDCHAR); assert(buf); @@ -7182,7 +7156,7 @@ thats_really_all_folks: screamer2: if (rslen) { - register STDCHAR *bpe = buf + sizeof(buf); + const register STDCHAR *bpe = buf + sizeof(buf); bp = buf; while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe) ; /* keep reading */ @@ -7227,7 +7201,7 @@ screamer2: goto screamer2; } -#ifdef USEHEAPINSTEADOFSTACK +#ifdef USE_HEAP_INSTEAD_OF_STACK Safefree(buf); #endif } @@ -7298,20 +7272,20 @@ Perl_sv_inc(pTHX_ register SV *sv) sv_setnv(sv, UV_MAX_P1); else (void)SvIOK_only_UV(sv); - ++SvUVX(sv); + SvUV_set(sv, SvUVX(sv) + 1); } else { if (SvIVX(sv) == IV_MAX) sv_setuv(sv, (UV)IV_MAX + 1); else { (void)SvIOK_only(sv); - ++SvIVX(sv); + SvIV_set(sv, SvIVX(sv) + 1); } } return; } if (flags & SVp_NOK) { (void)SvNOK_only(sv); - SvNVX(sv) += 1.0; + SvNV_set(sv, SvNVX(sv) + 1.0); return; } @@ -7319,7 +7293,7 @@ Perl_sv_inc(pTHX_ register SV *sv) if ((flags & SVTYPEMASK) < SVt_PVIV) sv_upgrade(sv, SVt_IV); (void)SvIOK_only(sv); - SvIVX(sv) = 1; + SvIV_set(sv, 1); return; } d = SvPVX(sv); @@ -7346,7 +7320,7 @@ Perl_sv_inc(pTHX_ register SV *sv) /* sv_2iv *should* have made this an NV */ if (flags & SVp_NOK) { (void)SvNOK_only(sv); - SvNVX(sv) += 1.0; + SvNV_set(sv, SvNVX(sv) + 1.0); return; } /* I don't think we can get here. Maybe I should assert this @@ -7394,7 +7368,7 @@ Perl_sv_inc(pTHX_ register SV *sv) } /* oh,oh, the number grew */ SvGROW(sv, SvCUR(sv) + 2); - SvCUR(sv)++; + SvCUR_set(sv, SvCUR(sv) + 1); for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--) *d = d[-1]; if (isDIGIT(d[1])) @@ -7448,31 +7422,31 @@ Perl_sv_dec(pTHX_ register SV *sv) if (SvIsUV(sv)) { if (SvUVX(sv) == 0) { (void)SvIOK_only(sv); - SvIVX(sv) = -1; + SvIV_set(sv, -1); } else { (void)SvIOK_only_UV(sv); - --SvUVX(sv); + SvUV_set(sv, SvUVX(sv) + 1); } } else { if (SvIVX(sv) == IV_MIN) sv_setnv(sv, (NV)IV_MIN - 1.0); else { (void)SvIOK_only(sv); - --SvIVX(sv); + SvIV_set(sv, SvIVX(sv) - 1); } } return; } if (flags & SVp_NOK) { - SvNVX(sv) -= 1.0; + SvNV_set(sv, SvNVX(sv) - 1.0); (void)SvNOK_only(sv); return; } if (!(flags & SVp_POK)) { if ((flags & SVTYPEMASK) < SVt_PVNV) sv_upgrade(sv, SVt_NV); - SvNVX(sv) = -1.0; + SvNV_set(sv, 1.0); (void)SvNOK_only(sv); return; } @@ -7494,7 +7468,7 @@ Perl_sv_dec(pTHX_ register SV *sv) /* sv_2iv *should* have made this an NV */ if (flags & SVp_NOK) { (void)SvNOK_only(sv); - SvNVX(sv) -= 1.0; + SvNV_set(sv, SvNVX(sv) - 1.0); return; } /* I don't think we can get here. Maybe I should assert this @@ -7570,7 +7544,9 @@ Perl_sv_newmortal(pTHX) Marks an existing SV as mortal. The SV will be destroyed "soon", either by an explicit call to FREETMPS, or by an implicit call at places such as -statement boundaries. See also C and C. +statement boundaries. SvTEMP() is turned on which means that the SV's +string buffer can be "stolen" if this SV is copied. See also C +and C. =cut */ @@ -7578,6 +7554,7 @@ statement boundaries. See also C and C. SV * Perl_sv_2mortal(pTHX_ register SV *sv) { + dVAR; if (!sv) return sv; if (SvREADONLY(sv) && SvIMMORTAL(sv)) @@ -7616,7 +7593,7 @@ Perl_newSVpv(pTHX_ const char *s, STRLEN len) Creates a new SV and copies a string into it. The reference count for the SV is set to 1. Note that if C is zero, Perl will create a zero length string. You are responsible for ensuring that the source string is at least -C bytes long. +C bytes long. If the C argument is NULL the new SV will be undefined. =cut */ @@ -7654,17 +7631,17 @@ Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash) STRLEN tmplen = -len; is_utf8 = TRUE; /* See the note in hv.c:hv_fetch() --jhi */ - src = (char*)bytes_from_utf8((U8*)src, &tmplen, &is_utf8); + src = (char*)bytes_from_utf8((const U8*)src, &tmplen, &is_utf8); len = tmplen; } if (!hash) PERL_HASH(hash, src, len); new_SV(sv); sv_upgrade(sv, SVt_PVIV); - SvPVX(sv) = sharepvn(src, is_utf8?-len:len, hash); - SvCUR(sv) = len; - SvUVX(sv) = hash; - SvLEN(sv) = 0; + SvPV_set(sv, sharepvn(src, is_utf8?-len:len, hash)); + SvCUR_set(sv, len); + SvUV_set(sv, hash); + SvLEN_set(sv, 0); SvREADONLY_on(sv); SvFAKE_on(sv); SvPOK_on(sv); @@ -7799,7 +7776,7 @@ Perl_newRV_noinc(pTHX_ SV *tmpRef) new_SV(sv); sv_upgrade(sv, SVt_RV); SvTEMP_off(tmpRef); - SvRV(sv) = tmpRef; + SvRV_set(sv, tmpRef); SvROK_on(sv); return sv; } @@ -7836,13 +7813,10 @@ Perl_newSVsv(pTHX_ register SV *old) return Nullsv; } new_SV(sv); - if (SvTEMP(old)) { - SvTEMP_off(old); - sv_setsv(sv,old); - SvTEMP_on(old); - } - else - sv_setsv(sv,old); + /* SV_GMAGIC is the default for sv_setv() + SV_NOSTEAL prevents TEMP buffers being, well, stolen, and saves games + with SvTEMP_off and SvTEMP_on round a call to sv_setsv. */ + sv_setsv_flags(sv, old, SV_GMAGIC | SV_NOSTEAL); return sv; } @@ -7856,8 +7830,9 @@ Note that the perl-level function is vaguely deprecated. */ void -Perl_sv_reset(pTHX_ register char *s, HV *stash) +Perl_sv_reset(pTHX_ register const char *s, HV *stash) { + dVAR; register HE *entry; register GV *gv; register SV *sv; @@ -7905,7 +7880,7 @@ Perl_sv_reset(pTHX_ register char *s, HV *stash) sv_unref(sv); continue; } - (void)SvOK_off(sv); + SvOK_off(sv); if (SvTYPE(sv) >= SVt_PV) { SvCUR_set(sv, 0); if (SvPVX(sv) != Nullch) @@ -7950,7 +7925,6 @@ Perl_sv_2io(pTHX_ SV *sv) { IO* io; GV* gv; - STRLEN n_a; switch (SvTYPE(sv)) { case SVt_PVIO: @@ -7967,7 +7941,7 @@ Perl_sv_2io(pTHX_ SV *sv) Perl_croak(aTHX_ PL_no_usym, "filehandle"); if (SvROK(sv)) return sv_2io(SvRV(sv)); - gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO); + gv = gv_fetchsv(sv, FALSE, SVt_PVIO); if (gv) io = GvIO(gv); else @@ -7991,9 +7965,9 @@ possible to set C<*st> and C<*gvp> to the stash and GV associated with it. CV * Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref) { + dVAR; GV *gv = Nullgv; CV *cv = Nullcv; - STRLEN n_a; if (!sv) return *gvp = Nullgv, Nullcv; @@ -8034,7 +8008,7 @@ Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref) else if (isGV(sv)) gv = (GV*)sv; else - gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV); + gv = gv_fetchsv(sv, lref, SVt_PVCV); *gvp = gv; if (!gv) return Nullcv; @@ -8077,7 +8051,7 @@ Perl_sv_true(pTHX_ register SV *sv) if (!sv) return 0; if (SvPOK(sv)) { - register XPV* tXpv; + const register XPV* tXpv; if ((tXpv = (XPV*)SvANY(sv)) && (tXpv->xpv_cur > 1 || (tXpv->xpv_cur && *tXpv->xpv_pv != '0'))) @@ -8382,13 +8356,13 @@ Returns a string describing what the SV is a reference to. */ char * -Perl_sv_reftype(pTHX_ SV *sv, int ob) +Perl_sv_reftype(pTHX_ const SV *sv, int ob) { + /* The fact that I don't need to downcast to char * everywhere, only in ?: + inside return suggests a const propagation bug in g++. */ if (ob && SvOBJECT(sv)) { - if (HvNAME(SvSTASH(sv))) - return HvNAME(SvSTASH(sv)); - else - return "__ANON__"; + char *name = HvNAME(SvSTASH(sv)); + return name ? name : (char *) "__ANON__"; } else { switch (SvTYPE(sv)) { @@ -8401,18 +8375,18 @@ Perl_sv_reftype(pTHX_ SV *sv, int ob) case SVt_PVNV: case SVt_PVMG: case SVt_PVBM: - if (SvVOK(sv)) + if (SvVOK(sv)) return "VSTRING"; if (SvROK(sv)) return "REF"; else return "SCALAR"; - - case SVt_PVLV: return SvROK(sv) ? "REF" + + case SVt_PVLV: return (char *) (SvROK(sv) ? "REF" /* tied lvalues should appear to be * scalars for backwards compatitbility */ : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T') - ? "SCALAR" : "LVALUE"; + ? "SCALAR" : "LVALUE"); case SVt_PVAV: return "ARRAY"; case SVt_PVHV: return "HASH"; case SVt_PVCV: return "CODE"; @@ -8509,15 +8483,13 @@ Perl_newSVrv(pTHX_ SV *rv, const char *classname) if (SvTYPE(rv) < SVt_RV) sv_upgrade(rv, SVt_RV); else if (SvTYPE(rv) > SVt_RV) { - (void)SvOOK_off(rv); - if (SvPVX(rv) && SvLEN(rv)) - Safefree(SvPVX(rv)); + SvPV_free(rv); SvCUR_set(rv, 0); SvLEN_set(rv, 0); } - (void)SvOK_off(rv); - SvRV(rv) = sv; + SvOK_off(rv); + SvRV_set(rv, sv); SvROK_on(rv); if (classname) { @@ -8621,7 +8593,7 @@ Copies a string into a new SV, optionally blessing the SV. The length of the string must be specified with C. The C argument will be upgraded to an RV. That RV will be modified to point to the new SV. The C argument indicates the package for the blessing. Set C to -C to avoid the blessing. The new SV will have a reference count +C to avoid the blessing. The new SV will have a reference count of 1, and the RV will be returned. Note that C copies the pointer while this copies the string. @@ -8666,7 +8638,7 @@ Perl_sv_bless(pTHX_ SV *sv, HV *stash) if (SvTYPE(tmpRef) != SVt_PVIO) ++PL_sv_objcount; (void)SvUPGRADE(tmpRef, SVt_PVMG); - SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash); + SvSTASH_set(tmpRef, (HV*)SvREFCNT_inc(stash)); if (Gv_AMG(stash)) SvAMAGIC_on(sv); @@ -8734,10 +8706,10 @@ Perl_sv_unref_flags(pTHX_ SV *sv, U32 flags) if (SvWEAKREF(sv)) { sv_del_backref(sv); SvWEAKREF_off(sv); - SvRV(sv) = 0; + SvRV_set(sv, NULL); return; } - SvRV(sv) = 0; + SvRV_set(sv, NULL); SvROK_off(sv); /* You can't have a || SvREADONLY(rv) here, as $a = $$a, where $a was assigned to as BEGIN {$a = \"Foo"} will fail. */ @@ -8886,8 +8858,8 @@ Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...) /* =for apidoc sv_setpvf -Processes its arguments like C and sets an SV to the formatted -output. Does not handle 'set' magic. See C. +Works like C but copies the text into the SV instead of +appending it. Does not handle 'set' magic. See C. =cut */ @@ -8901,7 +8873,16 @@ Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...) va_end(args); } -/* backend for C and C */ +/* +=for apidoc sv_vsetpvf + +Works like C but copies the text into the SV instead of +appending it. Does not handle 'set' magic. See C. + +Usually used via its frontend C. + +=cut +*/ void Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args) @@ -8926,7 +8907,15 @@ Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...) va_end(args); } -/* backend for C C */ +/* +=for apidoc sv_vsetpvf_mg + +Like C, but also handles 'set' magic. + +Usually used via its frontend C. + +=cut +*/ void Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args) @@ -8975,9 +8964,9 @@ Processes its arguments like C and appends the formatted output to an SV. If the appended data contains "wide" characters (including, but not limited to, SVs with a UTF-8 PV formatted with %s, and characters >255 formatted with %c), the original SV might get -upgraded to UTF-8. Handles 'get' magic, but not 'set' magic. -C must typically be called after calling this function -to handle 'set' magic. +upgraded to UTF-8. Handles 'get' magic, but not 'set' magic. See +C. If the original SV was UTF-8, the pattern should be +valid UTF-8; if the original SV was bytes, the pattern should be too. =cut */ @@ -8990,7 +8979,16 @@ Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...) va_end(args); } -/* backend for C and C */ +/* +=for apidoc sv_vcatpvf + +Processes its arguments like C and appends the formatted output +to an SV. Does not handle 'set' magic. See C. + +Usually used via its frontend C. + +=cut +*/ void Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args) @@ -9015,7 +9013,15 @@ Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...) va_end(args); } -/* backend for C and C */ +/* +=for apidoc sv_vcatpvf_mg + +Like C, but also handles 'set' magic. + +Usually used via its frontend C. + +=cut +*/ void Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args) @@ -9027,10 +9033,10 @@ Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args) /* =for apidoc sv_vsetpvfn -Works like C but copies the text into the SV instead of +Works like C but copies the text into the SV instead of appending it. -Usually used via one of its frontends C and C. +Usually used via one of its frontends C and C. =cut */ @@ -9095,11 +9101,13 @@ missing (NULL). When running with taint checks enabled, indicates via C if results are untrustworthy (often due to the use of locales). -Usually used via one of its frontends C and C. +Usually used via one of its frontends C and C. =cut */ +/* XXX maybe_tainted is never assigned to, so the doc above is lying. */ + void Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted) { @@ -9108,7 +9116,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV char *patend; STRLEN origlen; I32 svix = 0; - static char nullstr[] = "(null)"; + static const char nullstr[] = "(null)"; SV *argsv = Nullsv; bool has_utf8; /* has the result utf8? */ bool pat_utf8; /* the pattern is in utf8? */ @@ -9132,7 +9140,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV switch (pat[1]) { case 's': if (args) { - char *s = va_arg(*args, char*); + const char *s = va_arg(*args, char*); sv_catpv(sv, s ? s : nullstr); } else if (svix < svmax) { @@ -9222,7 +9230,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV #endif char esignbuf[4]; - U8 utf8buf[UTF8_MAXLEN+1]; + U8 utf8buf[UTF8_MAXBYTES+1]; STRLEN esignlen = 0; char *eptr = Nullch; @@ -9246,7 +9254,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV STRLEN have; STRLEN need; STRLEN gap; - char *dotstr = "."; + const char *dotstr = "."; STRLEN dotstrlen = 1; I32 efix = 0; /* explicit format parameter index */ I32 ewix = 0; /* explicit width index */ @@ -9337,7 +9345,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV } if (!asterisk) - if( *q == '0' ) + if( *q == '0' ) fill = *q++; EXPECT_NUMBER(q, width); @@ -9361,6 +9369,18 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV vecsv = svargs[efix ? efix-1 : svix++]; vecstr = (U8*)SvPVx(vecsv,veclen); vec_utf8 = DO_UTF8(vecsv); + /* if this is a version object, we need to return the + * stringified representation (which the SvPVX has + * already done for us), but not vectorize the args + */ + if ( *q == 'd' && sv_derived_from(vecsv,"version") ) + { + q++; /* skip past the rest of the %vd format */ + eptr = (char *) vecstr; + elen = strlen(eptr); + vectorize=FALSE; + goto string; + } } else { vecstr = (U8*)""; @@ -9499,7 +9519,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV #endif elen = strlen(eptr); else { - eptr = nullstr; + eptr = (char *)nullstr; elen = sizeof nullstr - 1; } } @@ -9520,6 +9540,9 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV goto string; case '_': +#ifdef CHECK_FORMAT + format_sv: +#endif /* * The "%_" hack might have to be changed someday, * if ISO or ANSI decide to use '_' for something. @@ -9541,6 +9564,17 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV /* INTEGERS */ case 'p': +#ifdef CHECK_FORMAT + if (left) { + left = FALSE; + if (!width) + goto format_sv; /* %-p -> %_ */ + precis = width; + has_precis = TRUE; + width = 0; + goto format_sv; /* %-Np -> %.N_ */ + } +#endif if (alt || vectorize) goto unknown; uv = PTR2UV(args ? va_arg(*args, void*) : argsv); @@ -9717,19 +9751,6 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV } break; default: /* it had better be ten or less */ -#if defined(PERL_Y2KWARN) - if (ckWARN(WARN_Y2K)) { - STRLEN n; - char *s = SvPV(sv,n); - if (n >= 2 && s[n-2] == '1' && s[n-1] == '9' - && (n == 2 || !isDIGIT(s[n-3]))) - { - Perl_warner(aTHX_ packWARN(WARN_Y2K), - "Possible Y2K bug: %%%c %s", - c, "format string following '19'"); - } - } -#endif do { dig = uv % base; *--eptr = '0' + dig; @@ -10002,7 +10023,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV Copy(eptr, p, elen, char); p += elen; *p = '\0'; - SvCUR(sv) = p - SvPVX(sv); + SvCUR_set(sv, p - SvPVX(sv)); svix = osvix; continue; /* not "break" */ } @@ -10025,14 +10046,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV p = SvEND(sv); *p = '\0'; } - /* Use memchr() instead of strchr(), as eptr is not guaranteed */ - /* to point to a null-terminated string. */ - if (left && ckWARN(WARN_PRINTF) && memchr(eptr, '\n', elen) && - (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) - Perl_warner(aTHX_ packWARN(WARN_PRINTF), - "Newline in left-justified string for %sprintf", - (PL_op->op_type == OP_PRTF) ? "" : "s"); - + need = (have > width ? have : width); gap = need - have; @@ -10075,7 +10089,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV if (has_utf8) SvUTF8_on(sv); *p = '\0'; - SvCUR(sv) = p - SvPVX(sv); + SvCUR_set(sv, p - SvPVX(sv)); if (vectorize) { esignlen = 0; goto vector; @@ -10128,6 +10142,7 @@ ptr_table_* functions. REGEXP * Perl_re_dup(pTHX_ REGEXP *r, CLONE_PARAMS *param) { + dVAR; REGEXP *ret; int i, len, npar; struct reg_substr_datum *s; @@ -10160,7 +10175,7 @@ Perl_re_dup(pTHX_ REGEXP *r, CLONE_PARAMS *param) ret->regstclass = NULL; if (r->data) { struct reg_data *d; - int count = r->data->count; + const int count = r->data->count; Newc(0, d, sizeof(struct reg_data) + count*sizeof(void *), char, struct reg_data); @@ -10170,6 +10185,8 @@ Perl_re_dup(pTHX_ REGEXP *r, CLONE_PARAMS *param) for (i = 0; i < count; i++) { d->what[i] = r->data->what[i]; switch (d->what[i]) { + /* legal options are one of: sfpont + see also regcomp.h and pregfree() */ case 's': d->data[i] = sv_dup_inc((SV *)r->data->data[i], param); break; @@ -10186,11 +10203,21 @@ Perl_re_dup(pTHX_ REGEXP *r, CLONE_PARAMS *param) case 'o': /* Compiled op trees are readonly, and can thus be shared without duplication. */ + OP_REFCNT_LOCK; d->data[i] = (void*)OpREFCNT_inc((OP*)r->data->data[i]); + OP_REFCNT_UNLOCK; break; case 'n': d->data[i] = r->data->data[i]; break; + case 't': + d->data[i] = r->data->data[i]; + OP_REFCNT_LOCK; + ((reg_trie_data*)d->data[i])->refcount++; + OP_REFCNT_UNLOCK; + break; + default: + Perl_croak(aTHX_ "panic: re_dup unknown data code '%c'", r->data->what[i]); } } @@ -10231,6 +10258,8 @@ PerlIO * Perl_fp_dup(pTHX_ PerlIO *fp, char type, CLONE_PARAMS *param) { PerlIO *ret; + (void)type; + if (!fp) return (PerlIO*)NULL; @@ -10318,10 +10347,10 @@ Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS* param) nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj, param); } else if(mg->mg_type == PERL_MAGIC_backref) { - AV *av = (AV*) mg->mg_obj; + const AV * const av = (AV*) mg->mg_obj; SV **svp; I32 i; - SvREFCNT_inc(nmg->mg_obj = (SV*)newAV()); + (void)SvREFCNT_inc(nmg->mg_obj = (SV*)newAV()); svp = AvARRAY(av); for (i = AvFILLp(av); i >= 0; i--) { if (!svp[i]) continue; @@ -10506,10 +10535,6 @@ Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl) Safefree(tbl); } -#ifdef DEBUGGING -char *PL_watch_pvx; -#endif - /* attempt to make everything in the typeglob readonly */ STATIC SV * @@ -10573,15 +10598,16 @@ void Perl_rvpv_dup(pTHX_ SV *dstr, SV *sstr, CLONE_PARAMS* param) { if (SvROK(sstr)) { - SvRV(dstr) = SvWEAKREF(sstr) - ? sv_dup(SvRV(sstr), param) - : sv_dup_inc(SvRV(sstr), param); + SvRV_set(dstr, SvWEAKREF(sstr) + ? sv_dup(SvRV(sstr), param) + : sv_dup_inc(SvRV(sstr), param)); + } else if (SvPVX(sstr)) { /* Has something there */ if (SvLEN(sstr)) { /* Normal PV - clone whole allocated space */ - SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1); + SvPV_set(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: */ @@ -10598,31 +10624,35 @@ Perl_rvpv_dup(pTHX_ SV *dstr, SV *sstr, CLONE_PARAMS* param) and they should not have these flags turned off */ - SvPVX(dstr) = sharepvn(SvPVX(sstr), SvCUR(sstr), - SvUVX(sstr)); - SvUVX(dstr) = SvUVX(sstr); + SvPV_set(dstr, sharepvn(SvPVX(sstr), SvCUR(sstr), + SvUVX(sstr))); + SvUV_set(dstr, SvUVX(sstr)); } else { - SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvCUR(sstr)); + SvPV_set(dstr, SAVEPVN(SvPVX(sstr), SvCUR(sstr))); SvFAKE_off(dstr); SvREADONLY_off(dstr); } } else { /* Some other special case - random pointer */ - SvPVX(dstr) = SvPVX(sstr); + SvPV_set(dstr, SvPVX(sstr)); } } } else { /* Copy the Null */ - SvPVX(dstr) = SvPVX(sstr); + if (SvTYPE(dstr) == SVt_RV) + SvRV_set(dstr, NULL); + else + SvPV_set(dstr, 0); } } SV * Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param) { + dVAR; SV *dstr; if (!sstr || SvTYPE(sstr) == SVTYPEMASK) @@ -10646,6 +10676,19 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param) /* create anew and remember what it is */ new_SV(dstr); + +#ifdef DEBUG_LEAKING_SCALARS + dstr->sv_debug_optype = sstr->sv_debug_optype; + dstr->sv_debug_line = sstr->sv_debug_line; + dstr->sv_debug_inpad = sstr->sv_debug_inpad; + dstr->sv_debug_cloned = 1; +# ifdef NETWARE + dstr->sv_debug_file = savepv(sstr->sv_debug_file); +# else + dstr->sv_debug_file = savesharedpv(sstr->sv_debug_file); +# endif +#endif + ptr_table_store(PL_ptr_table, sstr, dstr); /* clone */ @@ -10659,17 +10702,24 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param) PL_watch_pvx, SvPVX(sstr)); #endif + /* don't clone objects whose class has asked us not to */ + if (SvOBJECT(sstr) && ! (SvFLAGS(SvSTASH(sstr)) & SVphv_CLONEABLE)) { + SvFLAGS(dstr) &= ~SVTYPEMASK; + SvOBJECT_off(dstr); + return dstr; + } + switch (SvTYPE(sstr)) { case SVt_NULL: SvANY(dstr) = NULL; break; case SVt_IV: SvANY(dstr) = new_XIV(); - SvIVX(dstr) = SvIVX(sstr); + SvIV_set(dstr, SvIVX(sstr)); break; case SVt_NV: SvANY(dstr) = new_XNV(); - SvNVX(dstr) = SvNVX(sstr); + SvNV_set(dstr, SvNVX(sstr)); break; case SVt_RV: SvANY(dstr) = new_XRV(); @@ -10677,43 +10727,43 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param) break; case SVt_PV: SvANY(dstr) = new_XPV(); - SvCUR(dstr) = SvCUR(sstr); - SvLEN(dstr) = SvLEN(sstr); + SvCUR_set(dstr, SvCUR(sstr)); + SvLEN_set(dstr, SvLEN(sstr)); Perl_rvpv_dup(aTHX_ dstr, sstr, param); break; case SVt_PVIV: SvANY(dstr) = new_XPVIV(); - SvCUR(dstr) = SvCUR(sstr); - SvLEN(dstr) = SvLEN(sstr); - SvIVX(dstr) = SvIVX(sstr); + SvCUR_set(dstr, SvCUR(sstr)); + SvLEN_set(dstr, SvLEN(sstr)); + SvIV_set(dstr, SvIVX(sstr)); Perl_rvpv_dup(aTHX_ dstr, sstr, param); break; case SVt_PVNV: SvANY(dstr) = new_XPVNV(); - SvCUR(dstr) = SvCUR(sstr); - SvLEN(dstr) = SvLEN(sstr); - SvIVX(dstr) = SvIVX(sstr); - SvNVX(dstr) = SvNVX(sstr); + SvCUR_set(dstr, SvCUR(sstr)); + SvLEN_set(dstr, SvLEN(sstr)); + SvIV_set(dstr, SvIVX(sstr)); + SvNV_set(dstr, SvNVX(sstr)); Perl_rvpv_dup(aTHX_ dstr, sstr, param); break; case SVt_PVMG: SvANY(dstr) = new_XPVMG(); - SvCUR(dstr) = SvCUR(sstr); - SvLEN(dstr) = SvLEN(sstr); - SvIVX(dstr) = SvIVX(sstr); - SvNVX(dstr) = SvNVX(sstr); - SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param); - SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param); + SvCUR_set(dstr, SvCUR(sstr)); + SvLEN_set(dstr, SvLEN(sstr)); + SvIV_set(dstr, SvIVX(sstr)); + SvNV_set(dstr, SvNVX(sstr)); + SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param)); + SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param)); Perl_rvpv_dup(aTHX_ dstr, sstr, param); break; case SVt_PVBM: SvANY(dstr) = new_XPVBM(); - SvCUR(dstr) = SvCUR(sstr); - SvLEN(dstr) = SvLEN(sstr); - SvIVX(dstr) = SvIVX(sstr); - SvNVX(dstr) = SvNVX(sstr); - SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param); - SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param); + SvCUR_set(dstr, SvCUR(sstr)); + SvLEN_set(dstr, SvLEN(sstr)); + SvIV_set(dstr, SvIVX(sstr)); + SvNV_set(dstr, SvNVX(sstr)); + SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param)); + SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param)); Perl_rvpv_dup(aTHX_ dstr, sstr, param); BmRARE(dstr) = BmRARE(sstr); BmUSEFUL(dstr) = BmUSEFUL(sstr); @@ -10721,12 +10771,12 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param) break; case SVt_PVLV: SvANY(dstr) = new_XPVLV(); - SvCUR(dstr) = SvCUR(sstr); - SvLEN(dstr) = SvLEN(sstr); - SvIVX(dstr) = SvIVX(sstr); - SvNVX(dstr) = SvNVX(sstr); - SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param); - SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param); + SvCUR_set(dstr, SvCUR(sstr)); + SvLEN_set(dstr, SvLEN(sstr)); + SvIV_set(dstr, SvIVX(sstr)); + SvNV_set(dstr, SvNVX(sstr)); + SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param)); + SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param)); Perl_rvpv_dup(aTHX_ dstr, sstr, param); LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */ LvTARGLEN(dstr) = LvTARGLEN(sstr); @@ -10753,12 +10803,12 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param) } } SvANY(dstr) = new_XPVGV(); - SvCUR(dstr) = SvCUR(sstr); - SvLEN(dstr) = SvLEN(sstr); - SvIVX(dstr) = SvIVX(sstr); - SvNVX(dstr) = SvNVX(sstr); - SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param); - SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param); + SvCUR_set(dstr, SvCUR(sstr)); + SvLEN_set(dstr, SvLEN(sstr)); + SvIV_set(dstr, SvIVX(sstr)); + SvNV_set(dstr, SvNVX(sstr)); + SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param)); + SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param)); Perl_rvpv_dup(aTHX_ dstr, sstr, param); GvNAMELEN(dstr) = GvNAMELEN(sstr); GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr)); @@ -10769,12 +10819,12 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param) break; case SVt_PVIO: SvANY(dstr) = new_XPVIO(); - SvCUR(dstr) = SvCUR(sstr); - SvLEN(dstr) = SvLEN(sstr); - SvIVX(dstr) = SvIVX(sstr); - SvNVX(dstr) = SvNVX(sstr); - SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param); - SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param); + SvCUR_set(dstr, SvCUR(sstr)); + SvLEN_set(dstr, SvLEN(sstr)); + SvIV_set(dstr, SvIVX(sstr)); + SvNV_set(dstr, SvNVX(sstr)); + SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param)); + SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param)); Perl_rvpv_dup(aTHX_ dstr, sstr, param); IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr), param); if (IoOFP(sstr) == IoIFP(sstr)) @@ -10790,7 +10840,7 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param) IoPAGE(dstr) = IoPAGE(sstr); IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr); IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr); - if(IoFLAGS(sstr) & IOf_FAKE_DIRP) { + if(IoFLAGS(sstr) & IOf_FAKE_DIRP) { /* I have no idea why fake dirp (rsfps) should be treaded differently but otherwise we end up with leaks -- sky*/ @@ -10811,12 +10861,12 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param) break; case SVt_PVAV: SvANY(dstr) = new_XPVAV(); - SvCUR(dstr) = SvCUR(sstr); - SvLEN(dstr) = SvLEN(sstr); - SvIVX(dstr) = SvIVX(sstr); - SvNVX(dstr) = SvNVX(sstr); - SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param); - SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param); + SvCUR_set(dstr, SvCUR(sstr)); + SvLEN_set(dstr, SvLEN(sstr)); + SvIV_set(dstr, SvIVX(sstr)); + SvNV_set(dstr, SvNVX(sstr)); + SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param)); + SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param)); AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr), param); AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr); if (AvARRAY((AV*)sstr)) { @@ -10826,7 +10876,7 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param) src_ary = AvARRAY((AV*)sstr); Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*); ptr_table_store(PL_ptr_table, src_ary, dst_ary); - SvPVX(dstr) = (char*)dst_ary; + SvPV_set(dstr, (char*)dst_ary); AvALLOC((AV*)dstr) = dst_ary; if (AvREAL((AV*)sstr)) { while (items-- > 0) @@ -10842,18 +10892,18 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param) } } else { - SvPVX(dstr) = Nullch; + SvPV_set(dstr, Nullch); AvALLOC((AV*)dstr) = (SV**)NULL; } break; case SVt_PVHV: SvANY(dstr) = new_XPVHV(); - SvCUR(dstr) = SvCUR(sstr); - SvLEN(dstr) = SvLEN(sstr); - SvIVX(dstr) = SvIVX(sstr); - SvNVX(dstr) = SvNVX(sstr); - SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param); - SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param); + SvCUR_set(dstr, SvCUR(sstr)); + SvLEN_set(dstr, SvLEN(sstr)); + SvIV_set(dstr, SvIVX(sstr)); + SvNV_set(dstr, SvNVX(sstr)); + SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param)); + SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param)); HvRITER((HV*)dstr) = HvRITER((HV*)sstr); if (HvARRAY((HV*)sstr)) { STRLEN i = 0; @@ -10871,7 +10921,7 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param) (bool)!!HvSHAREKEYS(sstr), param); } else { - SvPVX(dstr) = Nullch; + SvPV_set(dstr, Nullch); HvEITER((HV*)dstr) = (HE*)NULL; } HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */ @@ -10888,22 +10938,24 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param) case SVt_PVCV: SvANY(dstr) = new_XPVCV(); dup_pvcv: - SvCUR(dstr) = SvCUR(sstr); - SvLEN(dstr) = SvLEN(sstr); - SvIVX(dstr) = SvIVX(sstr); - SvNVX(dstr) = SvNVX(sstr); - SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param); - SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param); + SvCUR_set(dstr, SvCUR(sstr)); + SvLEN_set(dstr, SvLEN(sstr)); + SvIV_set(dstr, SvIVX(sstr)); + SvNV_set(dstr, SvNVX(sstr)); + SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param)); + SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param)); Perl_rvpv_dup(aTHX_ dstr, sstr, param); CvSTASH(dstr) = hv_dup(CvSTASH(sstr), param); /* NOTE: not refcounted */ CvSTART(dstr) = CvSTART(sstr); + OP_REFCNT_LOCK; CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr)); + OP_REFCNT_UNLOCK; CvXSUB(dstr) = CvXSUB(sstr); CvXSUBANY(dstr) = CvXSUBANY(sstr); if (CvCONST(sstr)) { CvXSUBANY(dstr).any_ptr = GvUNIQUE(CvGV(sstr)) ? SvREFCNT_inc(CvXSUBANY(sstr).any_ptr) : - sv_dup_inc(CvXSUBANY(sstr).any_ptr, param); + sv_dup_inc((SV *)CvXSUBANY(sstr).any_ptr, param); } /* don't dup if copying back - CvGV isn't refcounted, so the * duped GV may never be freed. A bit of a hack! DAPM */ @@ -10963,7 +11015,6 @@ Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param) else { ncx->blk_oldsp = cx->blk_oldsp; ncx->blk_oldcop = cx->blk_oldcop; - ncx->blk_oldretsp = cx->blk_oldretsp; ncx->blk_oldmarksp = cx->blk_oldmarksp; ncx->blk_oldscopesp = cx->blk_oldscopesp; ncx->blk_oldpm = cx->blk_oldpm; @@ -10980,6 +11031,7 @@ Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param) ncx->blk_sub.olddepth = cx->blk_sub.olddepth; ncx->blk_sub.hasargs = cx->blk_sub.hasargs; ncx->blk_sub.lval = cx->blk_sub.lval; + ncx->blk_sub.retop = cx->blk_sub.retop; break; case CXt_EVAL: ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval; @@ -10987,6 +11039,7 @@ Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* 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); + ncx->blk_eval.retop = cx->blk_eval.retop; break; case CXt_LOOP: ncx->blk_loop.label = cx->blk_loop.label; @@ -11011,6 +11064,7 @@ Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param) ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv, param); ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv, param); ncx->blk_sub.hasargs = cx->blk_sub.hasargs; + ncx->blk_sub.retop = cx->blk_sub.retop; break; case CXt_BLOCK: case CXt_NULL: @@ -11370,6 +11424,40 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) return nss; } + +/* if sv is a stash, call $class->CLONE_SKIP(), and set the SVphv_CLONEABLE + * flag to the result. This is done for each stash before cloning starts, + * so we know which stashes want their objects cloned */ + +static void +do_mark_cloneable_stash(pTHX_ SV *sv) +{ + if (HvNAME((HV*)sv)) { + GV* cloner = gv_fetchmethod_autoload((HV*)sv, "CLONE_SKIP", 0); + SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */ + if (cloner && GvCV(cloner)) { + dSP; + UV status; + + ENTER; + SAVETMPS; + PUSHMARK(SP); + XPUSHs(sv_2mortal(newSVpv(HvNAME((HV*)sv), 0))); + PUTBACK; + call_sv((SV*)GvCV(cloner), G_SCALAR); + SPAGAIN; + status = POPu; + PUTBACK; + FREETMPS; + LEAVE; + if (status) + SvFLAGS(sv) &= ~SVphv_CLONEABLE; + } + } +} + + + /* =for apidoc perl_clone @@ -11377,31 +11465,31 @@ Create and return a new interpreter by cloning the current one. perl_clone takes these flags as parameters: -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 +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 +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, +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 @@ -11414,6 +11502,7 @@ perl_clone_host(PerlInterpreter* proto_perl, UV flags); PerlInterpreter * perl_clone(PerlInterpreter *proto_perl, UV flags) { + dVAR; #ifdef PERL_IMPLICIT_SYS /* perlhost.h so we need to call into it @@ -11451,16 +11540,19 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, CLONE_PARAMS* param = &clone_params; PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter)); + /* for each stash, determine whether its objects should be cloned */ + S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK); PERL_SET_THX(my_perl); # ifdef DEBUGGING Poison(my_perl, 1, PerlInterpreter); + PL_op = Nullop; + PL_curcop = (COP *)Nullop; PL_markstack = 0; PL_scopestack = 0; PL_savestack = 0; PL_savestack_ix = 0; PL_savestack_max = -1; - PL_retstack = 0; PL_sig_pending = 0; Zero(&PL_debug_pad, 1, struct perl_debug_pad); # else /* !DEBUGGING */ @@ -11482,18 +11574,19 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, CLONE_PARAMS clone_params; CLONE_PARAMS* param = &clone_params; PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter)); + /* for each stash, determine whether its objects should be cloned */ + S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK); PERL_SET_THX(my_perl); - - # ifdef DEBUGGING Poison(my_perl, 1, PerlInterpreter); + PL_op = Nullop; + PL_curcop = (COP *)Nullop; PL_markstack = 0; PL_scopestack = 0; PL_savestack = 0; PL_savestack_ix = 0; PL_savestack_max = -1; - PL_retstack = 0; PL_sig_pending = 0; Zero(&PL_debug_pad, 1, struct perl_debug_pad); # else /* !DEBUGGING */ @@ -11558,20 +11651,24 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, SvANY(&PL_sv_no) = new_XPVNV(); SvREFCNT(&PL_sv_no) = (~(U32)0)/2; - SvFLAGS(&PL_sv_no) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV; - SvPVX(&PL_sv_no) = SAVEPVN(PL_No, 0); - SvCUR(&PL_sv_no) = 0; - SvLEN(&PL_sv_no) = 1; - SvNVX(&PL_sv_no) = 0; + SvFLAGS(&PL_sv_no) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK + |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV; + SvPV_set(&PL_sv_no, SAVEPVN(PL_No, 0)); + SvCUR_set(&PL_sv_no, 0); + SvLEN_set(&PL_sv_no, 1); + SvIV_set(&PL_sv_no, 0); + SvNV_set(&PL_sv_no, 0); ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no); SvANY(&PL_sv_yes) = new_XPVNV(); SvREFCNT(&PL_sv_yes) = (~(U32)0)/2; - SvFLAGS(&PL_sv_yes) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV; - SvPVX(&PL_sv_yes) = SAVEPVN(PL_Yes, 1); - SvCUR(&PL_sv_yes) = 1; - SvLEN(&PL_sv_yes) = 2; - SvNVX(&PL_sv_yes) = 1; + SvFLAGS(&PL_sv_yes) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK + |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV; + SvPV_set(&PL_sv_yes, SAVEPVN(PL_Yes, 1)); + SvCUR_set(&PL_sv_yes, 1); + SvLEN_set(&PL_sv_yes, 2); + SvIV_set(&PL_sv_yes, 1); + SvNV_set(&PL_sv_yes, 1); ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes); /* create (a non-shared!) shared string table */ @@ -12031,13 +12128,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, Newz(54, PL_scopestack, PL_scopestack_max, I32); Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32); - /* next push_return() sets PL_retstack[PL_retstack_ix] - * NOTE: unlike the others! */ - PL_retstack_ix = proto_perl->Tretstack_ix; - PL_retstack_max = proto_perl->Tretstack_max; - Newz(54, PL_retstack, PL_retstack_max, OP*); - Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, OP*); - /* NOTE: si_dup() looks at PL_markstack */ PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo, param); @@ -12097,9 +12187,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_dirty = proto_perl->Tdirty; PL_localizing = proto_perl->Tlocalizing; -#ifdef PERL_FLEXIBLE_EXCEPTIONS - PL_protect = proto_perl->Tprotect; -#endif PL_errors = sv_dup_inc(proto_perl->Terrors, param); PL_hv_fetch_ent_mh = Nullhe; PL_modcount = proto_perl->Tmodcount; @@ -12198,7 +12285,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, ENTER; SAVETMPS; PUSHMARK(SP); - XPUSHs(sv_2mortal(newSVpv(HvNAME(stash), 0))); + XPUSHs(sv_2mortal(newSVpv(HvNAME(stash), 0))); PUTBACK; call_sv((SV*)GvCV(cloner), G_DISCARD); FREETMPS; @@ -12234,6 +12321,7 @@ The PV of the sv is returned. char * Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding) { + dVAR; if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) { SV *uni; STRLEN len; @@ -12246,14 +12334,14 @@ Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding) EXTEND(SP, 3); XPUSHs(encoding); XPUSHs(sv); -/* +/* NI-S 2002/07/09 Passing sv_yes is wrong - it needs to be or'ed set of constants - for Encode::XS, while UTf-8 decode (currently) assumes a true value means + 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; @@ -12271,8 +12359,9 @@ Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding) FREETMPS; LEAVE; SvUTF8_on(sv); + return SvPVX(sv); } - return SvPVX(sv); + return SvPOKp(sv) ? SvPVX(sv) : NULL; } /* @@ -12294,6 +12383,7 @@ bool Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding, SV *ssv, int *offset, char *tstr, int tlen) { + dVAR; bool ret = FALSE; if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) { SV *offsv; @@ -12322,3 +12412,12 @@ Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding, return ret; } +/* + * Local variables: + * c-indentation-style: bsd + * c-basic-offset: 4 + * indent-tabs-mode: t + * End: + * + * vim: shiftwidth=4: +*/