X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=fc89183c775c6f5d4bf3e79b96f3c65d6801be05;hb=360321b398f5e797c408b6d6c60b7da3cca5e324;hp=fb3e7dc8599c02cb1aa05b83db912c8ac84f42ac;hpb=a28509cc00517ad2ad1f6e022f1be6ab8f1ad18e;p=p5sagit%2Fp5-mst-13.2.git diff --git a/sv.c b/sv.c index fb3e7dc..fc89183 100644 --- a/sv.c +++ b/sv.c @@ -165,13 +165,30 @@ Public API: * "A time to plant, and a time to uproot what was planted..." */ +/* + * nice_chunk and nice_chunk size need to be set + * and queried under the protection of sv_mutex + */ +void +Perl_offer_nice_chunk(pTHX_ void *chunk, U32 chunk_size) +{ + void *new_chunk; + U32 new_chunk_size; + LOCK_SV_MUTEX; + new_chunk = (void *)(chunk); + new_chunk_size = (chunk_size); + if (new_chunk_size > PL_nice_chunk_size) { + Safefree(PL_nice_chunk); + PL_nice_chunk = (char *) new_chunk; + PL_nice_chunk_size = new_chunk_size; + } else { + Safefree(chunk); + } + UNLOCK_SV_MUTEX; +} #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 +# define FREE_SV_DEBUG_FILE(sv) Safefree((sv)->sv_debug_file) #else # define FREE_SV_DEBUG_FILE(sv) #endif @@ -209,7 +226,7 @@ S_more_sv(pTHX) } else { char *chunk; /* must use New here to match call to */ - New(704,chunk,PERL_ARENA_SIZE,char); /* Safefree() in sv_free_arenas() */ + Newx(chunk,PERL_ARENA_SIZE,char); /* Safefree() in sv_free_arenas() */ sv_add_arena(chunk, PERL_ARENA_SIZE, 0); } uproot_SV(sv); @@ -239,11 +256,7 @@ S_new_SV(pTHX) (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; } @@ -286,8 +299,8 @@ S_del_sv(pTHX_ SV *p) SV* sva; bool ok = 0; for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) { - SV *sv = sva + 1; - SV *svend = &sva[SvREFCNT(sva)]; + const SV * const sv = sva + 1; + const SV * const svend = &sva[SvREFCNT(sva)]; if (p >= sv && p < svend) { ok = 1; break; @@ -366,7 +379,7 @@ S_visit(pTHX_ SVFUNC_t f, U32 flags, U32 mask) I32 visited = 0; for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) { - register SV * const svend = &sva[SvREFCNT(sva)]; + register const SV * const svend = &sva[SvREFCNT(sva)]; register SV* sv; for (sv = sva + 1; sv < svend; ++sv) { if (SvTYPE(sv) != SVTYPEMASK @@ -414,20 +427,21 @@ Perl_sv_report_used(pTHX) /* called by sv_clean_objs() for each live SV */ static void -do_clean_objs(pTHX_ SV *sv) -{ - SV* rv; - - if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) { - DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv))); - if (SvWEAKREF(sv)) { - sv_del_backref(sv); - SvWEAKREF_off(sv); - SvRV_set(sv, NULL); - } else { - SvROK_off(sv); - SvRV_set(sv, NULL); - SvREFCNT_dec(rv); +do_clean_objs(pTHX_ SV *ref) +{ + if (SvROK(ref)) { + SV * const target = SvRV(ref); + if (SvOBJECT(target)) { + DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(ref))); + if (SvWEAKREF(ref)) { + sv_del_backref(target, ref); + SvWEAKREF_off(ref); + SvRV_set(ref, NULL); + } else { + SvROK_off(ref); + SvRV_set(ref, NULL); + SvREFCNT_dec(target); + } } } @@ -441,7 +455,11 @@ static void do_clean_named_objs(pTHX_ SV *sv) { if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) { - if ( SvOBJECT(GvSV(sv)) || + if (( +#ifdef PERL_DONT_CREATE_GVSV + GvSV(sv) && +#endif + SvOBJECT(GvSV(sv))) || (GvAV(sv) && SvOBJECT(GvAV(sv))) || (GvHV(sv) && SvOBJECT(GvHV(sv))) || (GvIO(sv) && SvOBJECT(GvIO(sv))) || @@ -509,6 +527,15 @@ Perl_sv_clean_all(pTHX) return cleaned; } +static void +S_free_arena(pTHX_ void **root) { + while (root) { + void ** const next = *(void **)root; + Safefree(root); + root = next; + } +} + /* =for apidoc sv_free_arenas @@ -518,12 +545,18 @@ heads and bodies within the arenas must already have been freed. =cut */ +#define free_arena(name) \ + STMT_START { \ + S_free_arena(aTHX_ (void**) PL_ ## name ## _arenaroot); \ + PL_ ## name ## _arenaroot = 0; \ + PL_ ## name ## _root = 0; \ + } STMT_END + void Perl_sv_free_arenas(pTHX) { SV* sva; SV* svanext; - void *arena, *arenanext; /* Free arenas here, but be careful about fake ones. (We assume contiguity of the fake ones with the corresponding real ones.) */ @@ -536,110 +569,24 @@ Perl_sv_free_arenas(pTHX) if (!SvFAKE(sva)) Safefree(sva); } - - for (arena = PL_xnv_arenaroot; arena; arena = arenanext) { - arenanext = *(void **)arena; - Safefree(arena); - } - PL_xnv_arenaroot = 0; - PL_xnv_root = 0; - - for (arena = PL_xpv_arenaroot; arena; arena = arenanext) { - arenanext = *(void **)arena; - Safefree(arena); - } - PL_xpv_arenaroot = 0; - PL_xpv_root = 0; - - for (arena = PL_xpviv_arenaroot; arena; arena = arenanext) { - arenanext = *(void **)arena; - Safefree(arena); - } - PL_xpviv_arenaroot = 0; - PL_xpviv_root = 0; - - for (arena = PL_xpvnv_arenaroot; arena; arena = arenanext) { - arenanext = *(void **)arena; - Safefree(arena); - } - PL_xpvnv_arenaroot = 0; - PL_xpvnv_root = 0; - - for (arena = PL_xpvcv_arenaroot; arena; arena = arenanext) { - arenanext = *(void **)arena; - Safefree(arena); - } - PL_xpvcv_arenaroot = 0; - PL_xpvcv_root = 0; - - for (arena = PL_xpvav_arenaroot; arena; arena = arenanext) { - arenanext = *(void **)arena; - Safefree(arena); - } - PL_xpvav_arenaroot = 0; - PL_xpvav_root = 0; - - for (arena = PL_xpvhv_arenaroot; arena; arena = arenanext) { - arenanext = *(void **)arena; - Safefree(arena); - } - PL_xpvhv_arenaroot = 0; - PL_xpvhv_root = 0; - - for (arena = PL_xpvmg_arenaroot; arena; arena = arenanext) { - arenanext = *(void **)arena; - Safefree(arena); - } - PL_xpvmg_arenaroot = 0; - PL_xpvmg_root = 0; - - for (arena = PL_xpvgv_arenaroot; arena; arena = arenanext) { - arenanext = *(void **)arena; - Safefree(arena); - } - PL_xpvgv_arenaroot = 0; - PL_xpvgv_root = 0; - - for (arena = PL_xpvlv_arenaroot; arena; arena = arenanext) { - arenanext = *(void **)arena; - Safefree(arena); - } - PL_xpvlv_arenaroot = 0; - PL_xpvlv_root = 0; - - for (arena = PL_xpvbm_arenaroot; arena; arena = arenanext) { - arenanext = *(void **)arena; - Safefree(arena); - } - PL_xpvbm_arenaroot = 0; - PL_xpvbm_root = 0; - - { - HE *he; - HE *he_next; - for (he = PL_he_arenaroot; he; he = he_next) { - he_next = HeNEXT(he); - Safefree(he); - } - } - PL_he_arenaroot = 0; - PL_he_root = 0; - + + free_arena(xnv); + free_arena(xpv); + free_arena(xpviv); + free_arena(xpvnv); + free_arena(xpvcv); + free_arena(xpvav); + free_arena(xpvhv); + free_arena(xpvmg); + free_arena(xpvgv); + free_arena(xpvlv); + free_arena(xpvbm); + free_arena(he); #if defined(USE_ITHREADS) - { - struct ptr_tbl_ent *pte; - struct ptr_tbl_ent *pte_next; - for (pte = PL_pte_arenaroot; pte; pte = pte_next) { - pte_next = pte->next; - Safefree(pte); - } - } - PL_pte_arenaroot = 0; - PL_pte_root = 0; + free_arena(pte); #endif - if (PL_nice_chunk) - Safefree(PL_nice_chunk); + Safefree(PL_nice_chunk); PL_nice_chunk = Nullch; PL_nice_chunk_size = 0; PL_sv_arenaroot = 0; @@ -722,11 +669,9 @@ S_find_array_subscript(pTHX_ AV *av, SV* val) #define FUV_SUBSCRIPT_WITHIN 4 /* "within @foo" */ STATIC SV* -S_varname(pTHX_ GV *gv, const char *gvtype, PADOFFSET targ, +S_varname(pTHX_ GV *gv, const char gvtype, PADOFFSET targ, SV* keyname, I32 aindex, int subscript_type) { - AV *av; - SV *sv; SV * const name = sv_newmortal(); if (gv) { @@ -736,16 +681,16 @@ S_varname(pTHX_ GV *gv, const char *gvtype, PADOFFSET targ, * directly */ const char *p; - HV *hv = GvSTASH(gv); - sv_setpv(name, gvtype); + HV * const hv = GvSTASH(gv); if (!hv) p = "???"; else if (!(p=HvNAME_get(hv))) p = "__ANON__"; - if (strNE(p, "main")) { - sv_catpv(name,p); - sv_catpvn(name,"::", 2); - } + if (strEQ(p, "main")) + sv_setpvn(name, &gvtype, 1); + else + Perl_sv_setpvf(aTHX_ name, "%c%s::", gvtype, p); + if (GvNAMELEN(gv)>= 1 && ((unsigned int)*GvNAME(gv)) <= 26) { /* handle $^FOO */ @@ -756,22 +701,22 @@ S_varname(pTHX_ GV *gv, const char *gvtype, PADOFFSET targ, sv_catpvn(name,GvNAME(gv),GvNAMELEN(gv)); } else { - U32 u; - CV *cv = find_runcv(&u); - STRLEN len; - const char *str; + U32 unused; + CV * const cv = find_runcv(&unused); + SV *sv; + AV *av; + if (!cv || !CvPADLIST(cv)) - return Nullsv;; + return Nullsv; av = (AV*)(*av_fetch(CvPADLIST(cv), 0, FALSE)); sv = *av_fetch(av, targ, FALSE); /* SvLEN in a pad name is not to be trusted */ - str = SvPV(sv,len); - sv_setpvn(name, str, len); + sv_setpv(name, SvPV_nolen_const(sv)); } if (subscript_type == FUV_SUBSCRIPT_HASH) { + SV * const sv = NEWSV(0,0); *SvPVX(name) = '$'; - sv = NEWSV(0,0); Perl_sv_catpvf(aTHX_ name, "{%s}", pv_display(sv,SvPVX_const(keyname), SvCUR(keyname), 0, 32)); SvREFCNT_dec(sv); @@ -813,7 +758,6 @@ S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match) dVAR; SV *sv; AV *av; - SV **svp; GV *gv; OP *o, *o2, *kid; @@ -866,25 +810,26 @@ S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match) if (match && subscript_type == FUV_SUBSCRIPT_WITHIN) break; - return S_varname(aTHX_ gv, hash ? "%" : "@", obase->op_targ, + return varname(gv, hash ? '%' : '@', obase->op_targ, keysv, index, subscript_type); } case OP_PADSV: if (match && PAD_SVl(obase->op_targ) != uninit_sv) break; - return S_varname(aTHX_ Nullgv, "$", obase->op_targ, + return varname(Nullgv, '$', obase->op_targ, Nullsv, 0, FUV_SUBSCRIPT_NONE); case OP_GVSV: gv = cGVOPx_gv(obase); if (!gv || (match && GvSV(gv) != uninit_sv)) break; - return S_varname(aTHX_ gv, "$", 0, Nullsv, 0, FUV_SUBSCRIPT_NONE); + return varname(gv, '$', 0, Nullsv, 0, FUV_SUBSCRIPT_NONE); case OP_AELEMFAST: if (obase->op_flags & OPf_SPECIAL) { /* lexical array */ if (match) { + SV **svp; av = (AV*)PAD_SV(obase->op_targ); if (!av || SvRMAGICAL(av)) break; @@ -892,7 +837,7 @@ S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match) if (!svp || *svp != uninit_sv) break; } - return S_varname(aTHX_ Nullgv, "$", obase->op_targ, + return varname(Nullgv, '$', obase->op_targ, Nullsv, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY); } else { @@ -900,6 +845,7 @@ S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match) if (!gv) break; if (match) { + SV **svp; av = GvAV(gv); if (!av || SvRMAGICAL(av)) break; @@ -907,7 +853,7 @@ S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match) if (!svp || *svp != uninit_sv) break; } - return S_varname(aTHX_ gv, "$", 0, + return varname(gv, '$', 0, Nullsv, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY); } break; @@ -956,16 +902,16 @@ S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match) break; } else { - svp = av_fetch((AV*)sv, SvIV(cSVOPx_sv(kid)), FALSE); + SV ** const svp = av_fetch((AV*)sv, SvIV(cSVOPx_sv(kid)), FALSE); if (!svp || *svp != uninit_sv) break; } } if (obase->op_type == OP_HELEM) - return S_varname(aTHX_ gv, "%", o->op_targ, + return varname(gv, '%', o->op_targ, cSVOPx_sv(kid), 0, FUV_SUBSCRIPT_HASH); else - return S_varname(aTHX_ gv, "@", o->op_targ, Nullsv, + return varname(gv, '@', o->op_targ, Nullsv, SvIV(cSVOPx_sv(kid)), FUV_SUBSCRIPT_ARRAY); ; } @@ -973,22 +919,22 @@ S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match) /* index is an expression; * attempt to find a match within the aggregate */ if (obase->op_type == OP_HELEM) { - SV *keysv = S_find_hash_subscript(aTHX_ (HV*)sv, uninit_sv); + SV * const keysv = S_find_hash_subscript(aTHX_ (HV*)sv, uninit_sv); if (keysv) - return S_varname(aTHX_ gv, "%", o->op_targ, + return varname(gv, '%', o->op_targ, keysv, 0, FUV_SUBSCRIPT_HASH); } else { const I32 index = S_find_array_subscript(aTHX_ (AV*)sv, uninit_sv); if (index >= 0) - return S_varname(aTHX_ gv, "@", o->op_targ, + return varname(gv, '@', o->op_targ, Nullsv, index, FUV_SUBSCRIPT_ARRAY); } if (match) break; - return S_varname(aTHX_ gv, + return varname(gv, (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) - ? "@" : "%", + ? '@' : '%', o->op_targ, Nullsv, 0, FUV_SUBSCRIPT_WITHIN); } @@ -1010,7 +956,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 varname(gv, '$', 0, Nullsv, 0, FUV_SUBSCRIPT_NONE); } /* other possibilities not handled are: @@ -1055,7 +1001,7 @@ S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match) case OP_SCHOMP: case OP_CHOMP: if (SvROK(PL_rs) && uninit_sv == SvRV(PL_rs)) - return sv_2mortal(newSVpv("${$/}", 0)); + return sv_2mortal(newSVpvn("${$/}", 5)); /* FALL THROUGH */ default: @@ -1120,7 +1066,7 @@ Perl_report_uninit(pTHX_ SV* uninit_sv) sv_insert(varname, 0, 0, " ", 1); } Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit, - varname ? SvPV_nolen(varname) : "", + varname ? SvPV_nolen_const(varname) : "", " in ", OP_DESC(PL_op)); } else @@ -1128,543 +1074,119 @@ Perl_report_uninit(pTHX_ SV* uninit_sv) "", "", ""); } -/* allocate another arena's worth of NV bodies */ - -STATIC void -S_more_xnv(pTHX) -{ - NV* xnv; - NV* xnvend; - void *ptr; - New(711, ptr, PERL_ARENA_SIZE/sizeof(NV), NV); - *((void **) ptr) = (void *)PL_xnv_arenaroot; - PL_xnv_arenaroot = ptr; - - xnv = (NV*) ptr; - xnvend = &xnv[PERL_ARENA_SIZE / sizeof(NV) - 1]; - xnv += (sizeof(XPVIV) - 1) / sizeof(NV) + 1; /* fudge by sizeof XPVIV */ - PL_xnv_root = xnv; - while (xnv < xnvend) { - *(NV**)xnv = (NV*)(xnv + 1); - xnv++; - } - *(NV**)xnv = 0; -} - -/* allocate another arena's worth of struct xpv */ - -STATIC void -S_more_xpv(pTHX) -{ - xpv_allocated* xpv; - xpv_allocated* xpvend; - New(713, xpv, PERL_ARENA_SIZE/sizeof(xpv_allocated), xpv_allocated); - *((xpv_allocated**)xpv) = PL_xpv_arenaroot; - PL_xpv_arenaroot = xpv; - - xpvend = &xpv[PERL_ARENA_SIZE / sizeof(xpv_allocated) - 1]; - PL_xpv_root = ++xpv; - while (xpv < xpvend) { - *((xpv_allocated**)xpv) = xpv + 1; - xpv++; - } - *((xpv_allocated**)xpv) = 0; -} - -/* allocate another arena's worth of struct xpviv */ - -STATIC void -S_more_xpviv(pTHX) -{ - xpviv_allocated* xpviv; - xpviv_allocated* xpvivend; - New(713, xpviv, PERL_ARENA_SIZE/sizeof(xpviv_allocated), xpviv_allocated); - *((xpviv_allocated**)xpviv) = PL_xpviv_arenaroot; - PL_xpviv_arenaroot = xpviv; - - xpvivend = &xpviv[PERL_ARENA_SIZE / sizeof(xpviv_allocated) - 1]; - PL_xpviv_root = ++xpviv; - while (xpviv < xpvivend) { - *((xpviv_allocated**)xpviv) = xpviv + 1; - xpviv++; - } - *((xpviv_allocated**)xpviv) = 0; -} - -/* allocate another arena's worth of struct xpvnv */ - -STATIC void -S_more_xpvnv(pTHX) -{ - XPVNV* xpvnv; - XPVNV* xpvnvend; - New(715, xpvnv, PERL_ARENA_SIZE/sizeof(XPVNV), XPVNV); - *((XPVNV**)xpvnv) = PL_xpvnv_arenaroot; - PL_xpvnv_arenaroot = xpvnv; - - xpvnvend = &xpvnv[PERL_ARENA_SIZE / sizeof(XPVNV) - 1]; - PL_xpvnv_root = ++xpvnv; - while (xpvnv < xpvnvend) { - *((XPVNV**)xpvnv) = xpvnv + 1; - xpvnv++; - } - *((XPVNV**)xpvnv) = 0; -} - -/* allocate another arena's worth of struct xpvcv */ - -STATIC void -S_more_xpvcv(pTHX) -{ - XPVCV* xpvcv; - XPVCV* xpvcvend; - New(716, xpvcv, PERL_ARENA_SIZE/sizeof(XPVCV), XPVCV); - *((XPVCV**)xpvcv) = PL_xpvcv_arenaroot; - PL_xpvcv_arenaroot = xpvcv; - - xpvcvend = &xpvcv[PERL_ARENA_SIZE / sizeof(XPVCV) - 1]; - PL_xpvcv_root = ++xpvcv; - while (xpvcv < xpvcvend) { - *((XPVCV**)xpvcv) = xpvcv + 1; - xpvcv++; - } - *((XPVCV**)xpvcv) = 0; -} - -/* allocate another arena's worth of struct xpvav */ - -STATIC void -S_more_xpvav(pTHX) -{ - xpvav_allocated* xpvav; - xpvav_allocated* xpvavend; - New(717, xpvav, PERL_ARENA_SIZE/sizeof(xpvav_allocated), - xpvav_allocated); - *((xpvav_allocated**)xpvav) = PL_xpvav_arenaroot; - PL_xpvav_arenaroot = xpvav; - - xpvavend = &xpvav[PERL_ARENA_SIZE / sizeof(xpvav_allocated) - 1]; - PL_xpvav_root = ++xpvav; - while (xpvav < xpvavend) { - *((xpvav_allocated**)xpvav) = xpvav + 1; - xpvav++; - } - *((xpvav_allocated**)xpvav) = 0; -} - -/* allocate another arena's worth of struct xpvhv */ - -STATIC void -S_more_xpvhv(pTHX) -{ - xpvhv_allocated* xpvhv; - xpvhv_allocated* xpvhvend; - New(718, xpvhv, PERL_ARENA_SIZE/sizeof(xpvhv_allocated), - xpvhv_allocated); - *((xpvhv_allocated**)xpvhv) = PL_xpvhv_arenaroot; - PL_xpvhv_arenaroot = xpvhv; - - xpvhvend = &xpvhv[PERL_ARENA_SIZE / sizeof(xpvhv_allocated) - 1]; - PL_xpvhv_root = ++xpvhv; - while (xpvhv < xpvhvend) { - *((xpvhv_allocated**)xpvhv) = xpvhv + 1; - xpvhv++; - } - *((xpvhv_allocated**)xpvhv) = 0; -} - -/* allocate another arena's worth of struct xpvmg */ - -STATIC void -S_more_xpvmg(pTHX) -{ - XPVMG* xpvmg; - XPVMG* xpvmgend; - New(719, xpvmg, PERL_ARENA_SIZE/sizeof(XPVMG), XPVMG); - *((XPVMG**)xpvmg) = PL_xpvmg_arenaroot; - PL_xpvmg_arenaroot = xpvmg; - - xpvmgend = &xpvmg[PERL_ARENA_SIZE / sizeof(XPVMG) - 1]; - PL_xpvmg_root = ++xpvmg; - while (xpvmg < xpvmgend) { - *((XPVMG**)xpvmg) = xpvmg + 1; - xpvmg++; - } - *((XPVMG**)xpvmg) = 0; -} - -/* allocate another arena's worth of struct xpvgv */ - -STATIC void -S_more_xpvgv(pTHX) +STATIC void * +S_more_bodies (pTHX_ void **arena_root, void **root, size_t size) { - XPVGV* xpvgv; - XPVGV* xpvgvend; - New(720, xpvgv, PERL_ARENA_SIZE/sizeof(XPVGV), XPVGV); - *((XPVGV**)xpvgv) = PL_xpvgv_arenaroot; - PL_xpvgv_arenaroot = xpvgv; - - xpvgvend = &xpvgv[PERL_ARENA_SIZE / sizeof(XPVGV) - 1]; - PL_xpvgv_root = ++xpvgv; - while (xpvgv < xpvgvend) { - *((XPVGV**)xpvgv) = xpvgv + 1; - xpvgv++; - } - *((XPVGV**)xpvgv) = 0; -} + char *start; + const char *end; + const size_t count = PERL_ARENA_SIZE/size; + Newx(start, count*size, char); + *((void **) start) = *arena_root; + *arena_root = (void *)start; -/* allocate another arena's worth of struct xpvlv */ - -STATIC void -S_more_xpvlv(pTHX) -{ - XPVLV* xpvlv; - XPVLV* xpvlvend; - New(720, xpvlv, PERL_ARENA_SIZE/sizeof(XPVLV), XPVLV); - *((XPVLV**)xpvlv) = PL_xpvlv_arenaroot; - PL_xpvlv_arenaroot = xpvlv; + end = start + (count-1) * size; - xpvlvend = &xpvlv[PERL_ARENA_SIZE / sizeof(XPVLV) - 1]; - PL_xpvlv_root = ++xpvlv; - while (xpvlv < xpvlvend) { - *((XPVLV**)xpvlv) = xpvlv + 1; - xpvlv++; - } - *((XPVLV**)xpvlv) = 0; -} + /* The initial slot is used to link the arenas together, so it isn't to be + linked into the list of ready-to-use bodies. */ -/* allocate another arena's worth of struct xpvbm */ + start += size; -STATIC void -S_more_xpvbm(pTHX) -{ - XPVBM* xpvbm; - XPVBM* xpvbmend; - New(721, xpvbm, PERL_ARENA_SIZE/sizeof(XPVBM), XPVBM); - *((XPVBM**)xpvbm) = PL_xpvbm_arenaroot; - PL_xpvbm_arenaroot = xpvbm; + *root = (void *)start; - xpvbmend = &xpvbm[PERL_ARENA_SIZE / sizeof(XPVBM) - 1]; - PL_xpvbm_root = ++xpvbm; - while (xpvbm < xpvbmend) { - *((XPVBM**)xpvbm) = xpvbm + 1; - xpvbm++; + while (start < end) { + char * const next = start + size; + *(void**) start = (void *)next; + start = next; } - *((XPVBM**)xpvbm) = 0; -} - -/* grab a new NV body from the free list, allocating more if necessary */ - -STATIC XPVNV* -S_new_xnv(pTHX) -{ - NV* xnv; - LOCK_SV_MUTEX; - if (!PL_xnv_root) - S_more_xnv(aTHX); - xnv = PL_xnv_root; - PL_xnv_root = *(NV**)xnv; - UNLOCK_SV_MUTEX; - return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv)); -} - -/* return an NV body to the free list */ - -STATIC void -S_del_xnv(pTHX_ XPVNV *p) -{ - NV* xnv = (NV*)((char*)(p) + STRUCT_OFFSET(XPVNV, xnv_nv)); - LOCK_SV_MUTEX; - *(NV**)xnv = PL_xnv_root; - PL_xnv_root = xnv; - UNLOCK_SV_MUTEX; -} - -/* grab a new struct xpv from the free list, allocating more if necessary */ - -STATIC XPV* -S_new_xpv(pTHX) -{ - xpv_allocated* xpv; - LOCK_SV_MUTEX; - if (!PL_xpv_root) - S_more_xpv(aTHX); - xpv = PL_xpv_root; - PL_xpv_root = *(xpv_allocated**)xpv; - UNLOCK_SV_MUTEX; - /* If xpv_allocated is the same structure as XPV then the two OFFSETs - sum to zero, and the pointer is unchanged. If the allocated structure - is smaller (no initial IV actually allocated) then the net effect is - to subtract the size of the IV from the pointer, to return a new pointer - as if an initial IV were actually allocated. */ - return (XPV*)((char*)xpv - STRUCT_OFFSET(XPV, xpv_cur) - + STRUCT_OFFSET(xpv_allocated, xpv_cur)); -} - -/* return a struct xpv to the free list */ + *(void **)start = 0; -STATIC void -S_del_xpv(pTHX_ XPV *p) -{ - xpv_allocated* xpv - = (xpv_allocated*)((char*)(p) + STRUCT_OFFSET(XPV, xpv_cur) - - STRUCT_OFFSET(xpv_allocated, xpv_cur)); - LOCK_SV_MUTEX; - *(xpv_allocated**)xpv = PL_xpv_root; - PL_xpv_root = xpv; - UNLOCK_SV_MUTEX; + return *root; } -/* grab a new struct xpviv from the free list, allocating more if necessary */ +/* grab a new thing from the free list, allocating more if necessary */ -STATIC XPVIV* -S_new_xpviv(pTHX) -{ - xpviv_allocated* xpviv; - LOCK_SV_MUTEX; - if (!PL_xpviv_root) - S_more_xpviv(aTHX); - xpviv = PL_xpviv_root; - PL_xpviv_root = *(xpviv_allocated**)xpviv; - UNLOCK_SV_MUTEX; - /* If xpviv_allocated is the same structure as XPVIV then the two OFFSETs - sum to zero, and the pointer is unchanged. If the allocated structure - is smaller (no initial IV actually allocated) then the net effect is - to subtract the size of the IV from the pointer, to return a new pointer - as if an initial IV were actually allocated. */ - return (XPVIV*)((char*)xpviv - STRUCT_OFFSET(XPVIV, xpv_cur) - + STRUCT_OFFSET(xpviv_allocated, xpv_cur)); -} - -/* return a struct xpviv to the free list */ +/* 1st, the inline version */ -STATIC void -S_del_xpviv(pTHX_ XPVIV *p) -{ - xpviv_allocated* xpviv - = (xpviv_allocated*)((char*)(p) + STRUCT_OFFSET(XPVIV, xpv_cur) - - STRUCT_OFFSET(xpviv_allocated, xpv_cur)); - LOCK_SV_MUTEX; - *(xpviv_allocated**)xpviv = PL_xpviv_root; - PL_xpviv_root = xpviv; - UNLOCK_SV_MUTEX; -} - -/* grab a new struct xpvnv from the free list, allocating more if necessary */ - -STATIC XPVNV* -S_new_xpvnv(pTHX) -{ - XPVNV* xpvnv; - LOCK_SV_MUTEX; - if (!PL_xpvnv_root) - S_more_xpvnv(aTHX); - xpvnv = PL_xpvnv_root; - PL_xpvnv_root = *(XPVNV**)xpvnv; - UNLOCK_SV_MUTEX; - return xpvnv; -} - -/* return a struct xpvnv to the free list */ - -STATIC void -S_del_xpvnv(pTHX_ XPVNV *p) -{ - LOCK_SV_MUTEX; - *(XPVNV**)p = PL_xpvnv_root; - PL_xpvnv_root = p; - UNLOCK_SV_MUTEX; -} - -/* grab a new struct xpvcv from the free list, allocating more if necessary */ - -STATIC XPVCV* -S_new_xpvcv(pTHX) -{ - XPVCV* xpvcv; - LOCK_SV_MUTEX; - if (!PL_xpvcv_root) - S_more_xpvcv(aTHX); - xpvcv = PL_xpvcv_root; - PL_xpvcv_root = *(XPVCV**)xpvcv; - UNLOCK_SV_MUTEX; - return xpvcv; -} - -/* return a struct xpvcv to the free list */ - -STATIC void -S_del_xpvcv(pTHX_ XPVCV *p) -{ - LOCK_SV_MUTEX; - *(XPVCV**)p = PL_xpvcv_root; - PL_xpvcv_root = p; - UNLOCK_SV_MUTEX; -} - -/* grab a new struct xpvav from the free list, allocating more if necessary */ - -STATIC XPVAV* -S_new_xpvav(pTHX) -{ - xpvav_allocated* xpvav; - LOCK_SV_MUTEX; - if (!PL_xpvav_root) - S_more_xpvav(aTHX); - xpvav = PL_xpvav_root; - PL_xpvav_root = *(xpvav_allocated**)xpvav; - UNLOCK_SV_MUTEX; - return (XPVAV*)((char*)xpvav - STRUCT_OFFSET(XPVAV, xav_fill) - + STRUCT_OFFSET(xpvav_allocated, xav_fill)); -} - -/* return a struct xpvav to the free list */ - -STATIC void -S_del_xpvav(pTHX_ XPVAV *p) -{ - xpvav_allocated* xpvav - = (xpvav_allocated*)((char*)(p) + STRUCT_OFFSET(XPVAV, xav_fill) - - STRUCT_OFFSET(xpvav_allocated, xav_fill)); - LOCK_SV_MUTEX; - *(xpvav_allocated**)xpvav = PL_xpvav_root; - PL_xpvav_root = xpvav; - UNLOCK_SV_MUTEX; -} - -/* grab a new struct xpvhv from the free list, allocating more if necessary */ - -STATIC XPVHV* -S_new_xpvhv(pTHX) -{ - xpvhv_allocated* xpvhv; - LOCK_SV_MUTEX; - if (!PL_xpvhv_root) - S_more_xpvhv(aTHX); - xpvhv = PL_xpvhv_root; - PL_xpvhv_root = *(xpvhv_allocated**)xpvhv; - UNLOCK_SV_MUTEX; - return (XPVHV*)((char*)xpvhv - STRUCT_OFFSET(XPVHV, xhv_fill) - + STRUCT_OFFSET(xpvhv_allocated, xhv_fill)); -} - -/* return a struct xpvhv to the free list */ - -STATIC void -S_del_xpvhv(pTHX_ XPVHV *p) -{ - xpvhv_allocated* xpvhv - = (xpvhv_allocated*)((char*)(p) + STRUCT_OFFSET(XPVHV, xhv_fill) - - STRUCT_OFFSET(xpvhv_allocated, xhv_fill)); - LOCK_SV_MUTEX; - *(xpvhv_allocated**)xpvhv = PL_xpvhv_root; - PL_xpvhv_root = xpvhv; - UNLOCK_SV_MUTEX; -} - -/* grab a new struct xpvmg from the free list, allocating more if necessary */ - -STATIC XPVMG* -S_new_xpvmg(pTHX) -{ - XPVMG* xpvmg; - LOCK_SV_MUTEX; - if (!PL_xpvmg_root) - S_more_xpvmg(aTHX); - xpvmg = PL_xpvmg_root; - PL_xpvmg_root = *(XPVMG**)xpvmg; - UNLOCK_SV_MUTEX; - return xpvmg; -} - -/* return a struct xpvmg to the free list */ - -STATIC void -S_del_xpvmg(pTHX_ XPVMG *p) -{ - LOCK_SV_MUTEX; - *(XPVMG**)p = PL_xpvmg_root; - PL_xpvmg_root = p; - UNLOCK_SV_MUTEX; -} - -/* grab a new struct xpvgv from the free list, allocating more if necessary */ - -STATIC XPVGV* -S_new_xpvgv(pTHX) -{ - XPVGV* xpvgv; - LOCK_SV_MUTEX; - if (!PL_xpvgv_root) - S_more_xpvgv(aTHX); - xpvgv = PL_xpvgv_root; - PL_xpvgv_root = *(XPVGV**)xpvgv; - UNLOCK_SV_MUTEX; - return xpvgv; -} - -/* return a struct xpvgv to the free list */ - -STATIC void -S_del_xpvgv(pTHX_ XPVGV *p) -{ - LOCK_SV_MUTEX; - *(XPVGV**)p = PL_xpvgv_root; - PL_xpvgv_root = p; - UNLOCK_SV_MUTEX; -} +#define new_body_inline(xpv, arena_root, root, size) \ + STMT_START { \ + LOCK_SV_MUTEX; \ + xpv = *((void **)(root)) \ + ? *((void **)(root)) : S_more_bodies(aTHX_ arena_root, root, size); \ + *(root) = *(void**)(xpv); \ + UNLOCK_SV_MUTEX; \ + } STMT_END -/* grab a new struct xpvlv from the free list, allocating more if necessary */ +/* now use the inline version in the proper function */ -STATIC XPVLV* -S_new_xpvlv(pTHX) +STATIC void * +S_new_body(pTHX_ void **arena_root, void **root, size_t size) { - XPVLV* xpvlv; - LOCK_SV_MUTEX; - if (!PL_xpvlv_root) - S_more_xpvlv(aTHX); - xpvlv = PL_xpvlv_root; - PL_xpvlv_root = *(XPVLV**)xpvlv; - UNLOCK_SV_MUTEX; - return xpvlv; + void *xpv; + new_body_inline(xpv, arena_root, root, size); + return xpv; } -/* return a struct xpvlv to the free list */ +/* return a thing to the free list */ -STATIC void -S_del_xpvlv(pTHX_ XPVLV *p) -{ - LOCK_SV_MUTEX; - *(XPVLV**)p = PL_xpvlv_root; - PL_xpvlv_root = p; - UNLOCK_SV_MUTEX; -} +#define del_body(thing, root) \ + STMT_START { \ + void **thing_copy = (void **)thing; \ + LOCK_SV_MUTEX; \ + *thing_copy = *root; \ + *root = (void*)thing_copy; \ + UNLOCK_SV_MUTEX; \ + } STMT_END -/* grab a new struct xpvbm from the free list, allocating more if necessary */ +/* Conventionally we simply malloc() a big block of memory, then divide it + up into lots of the thing that we're allocating. -STATIC XPVBM* -S_new_xpvbm(pTHX) -{ - XPVBM* xpvbm; - LOCK_SV_MUTEX; - if (!PL_xpvbm_root) - S_more_xpvbm(aTHX); - xpvbm = PL_xpvbm_root; - PL_xpvbm_root = *(XPVBM**)xpvbm; - UNLOCK_SV_MUTEX; - return xpvbm; -} + This macro will expand to call to S_new_body. So for XPVBM (with ithreads), + it would become -/* return a struct xpvbm to the free list */ + S_new_body(my_perl, (void**)&(my_perl->Ixpvbm_arenaroot), + (void**)&(my_perl->Ixpvbm_root), sizeof(XPVBM), 0) +*/ -STATIC void -S_del_xpvbm(pTHX_ XPVBM *p) -{ - LOCK_SV_MUTEX; - *(XPVBM**)p = PL_xpvbm_root; - PL_xpvbm_root = p; - UNLOCK_SV_MUTEX; -} +#define new_body_type(TYPE,lctype) \ + S_new_body(aTHX_ (void**)&PL_ ## lctype ## _arenaroot, \ + (void**)&PL_ ## lctype ## _root, \ + sizeof(TYPE)) + +#define del_body_type(p,TYPE,lctype) \ + del_body((void*)p, (void**)&PL_ ## lctype ## _root) + +/* But for some types, we cheat. The type starts with some members that are + never accessed. So we allocate the substructure, starting at the first used + member, then adjust the pointer back in memory by the size of the bit not + allocated, so it's as if we allocated the full structure. + (But things will all go boom if you write to the part that is "not there", + because you'll be overwriting the last members of the preceding structure + in memory.) + + We calculate the correction using the STRUCT_OFFSET macro. For example, if + xpv_allocated is the same structure as XPV then the two OFFSETs sum to zero, + and the pointer is unchanged. If the allocated structure is smaller (no + initial NV actually allocated) then the net effect is to subtract the size + of the NV from the pointer, to return a new pointer as if an initial NV were + actually allocated. + + This is the same trick as was used for NV and IV bodies. Ironically it + doesn't need to be used for NV bodies any more, because NV is now at the + start of the structure. IV bodies don't need it either, because they are + no longer allocated. */ + +#define new_body_allocated(TYPE,lctype,member) \ + (void*)((char*)S_new_body(aTHX_ (void**)&PL_ ## lctype ## _arenaroot, \ + (void**)&PL_ ## lctype ## _root, \ + sizeof(lctype ## _allocated)) - \ + STRUCT_OFFSET(TYPE, member) \ + + STRUCT_OFFSET(lctype ## _allocated, member)) + + +#define del_body_allocated(p,TYPE,lctype,member) \ + del_body((void*)((char*)p + STRUCT_OFFSET(TYPE, member) \ + - STRUCT_OFFSET(lctype ## _allocated, member)), \ + (void**)&PL_ ## lctype ## _root) #define my_safemalloc(s) (void*)safemalloc(s) #define my_safefree(p) safefree((char*)p) @@ -1706,38 +1228,38 @@ S_del_xpvbm(pTHX_ XPVBM *p) #else /* !PURIFY */ -#define new_XNV() (void*)new_xnv() -#define del_XNV(p) del_xnv((XPVNV*) p) +#define new_XNV() new_body_type(NV, xnv) +#define del_XNV(p) del_body_type(p, NV, xnv) -#define new_XPV() (void*)new_xpv() -#define del_XPV(p) del_xpv((XPV *)p) +#define new_XPV() new_body_allocated(XPV, xpv, xpv_cur) +#define del_XPV(p) del_body_allocated(p, XPV, xpv, xpv_cur) -#define new_XPVIV() (void*)new_xpviv() -#define del_XPVIV(p) del_xpviv((XPVIV *)p) +#define new_XPVIV() new_body_allocated(XPVIV, xpviv, xpv_cur) +#define del_XPVIV(p) del_body_allocated(p, XPVIV, xpviv, xpv_cur) -#define new_XPVNV() (void*)new_xpvnv() -#define del_XPVNV(p) del_xpvnv((XPVNV *)p) +#define new_XPVNV() new_body_type(XPVNV, xpvnv) +#define del_XPVNV(p) del_body_type(p, XPVNV, xpvnv) -#define new_XPVCV() (void*)new_xpvcv() -#define del_XPVCV(p) del_xpvcv((XPVCV *)p) +#define new_XPVCV() new_body_type(XPVCV, xpvcv) +#define del_XPVCV(p) del_body_type(p, XPVCV, xpvcv) -#define new_XPVAV() (void*)new_xpvav() -#define del_XPVAV(p) del_xpvav((XPVAV *)p) +#define new_XPVAV() new_body_allocated(XPVAV, xpvav, xav_fill) +#define del_XPVAV(p) del_body_allocated(p, XPVAV, xpvav, xav_fill) -#define new_XPVHV() (void*)new_xpvhv() -#define del_XPVHV(p) del_xpvhv((XPVHV *)p) +#define new_XPVHV() new_body_allocated(XPVHV, xpvhv, xhv_fill) +#define del_XPVHV(p) del_body_allocated(p, XPVHV, xpvhv, xhv_fill) -#define new_XPVMG() (void*)new_xpvmg() -#define del_XPVMG(p) del_xpvmg((XPVMG *)p) +#define new_XPVMG() new_body_type(XPVMG, xpvmg) +#define del_XPVMG(p) del_body_type(p, XPVMG, xpvmg) -#define new_XPVGV() (void*)new_xpvgv() -#define del_XPVGV(p) del_xpvgv((XPVGV *)p) +#define new_XPVGV() new_body_type(XPVGV, xpvgv) +#define del_XPVGV(p) del_body_type(p, XPVGV, xpvgv) -#define new_XPVLV() (void*)new_xpvlv() -#define del_XPVLV(p) del_xpvlv((XPVLV *)p) +#define new_XPVLV() new_body_type(XPVLV, xpvlv) +#define del_XPVLV(p) del_body_type(p, XPVLV, xpvlv) -#define new_XPVBM() (void*)new_xpvbm() -#define del_XPVBM(p) del_xpvbm((XPVBM *)p) +#define new_XPVBM() new_body_type(XPVBM, xpvbm) +#define del_XPVBM(p) del_body_type(p, XPVBM, xpvbm) #endif /* PURIFY */ @@ -1757,76 +1279,129 @@ You generally want to use the C macro wrapper. See also C. =cut */ -bool +void Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt) { - - char* pv; - U32 cur; - U32 len; - IV iv; - NV nv; - MAGIC* magic; - HV* stash; + void** old_body_arena; + size_t old_body_offset; + size_t old_body_length; /* Well, the length to copy. */ + void* old_body; +#ifndef NV_ZERO_IS_ALLBITS_ZERO + /* If NV 0.0 is store as all bits 0 then Zero() already creates a correct + 0.0 for us. */ + bool zero_nv = TRUE; +#endif + void* new_body; + size_t new_body_length; + size_t new_body_offset; + void** new_body_arena; + void** new_body_arenaroot; + const U32 old_type = SvTYPE(sv); if (mt != SVt_PV && SvIsCOW(sv)) { sv_force_normal_flags(sv, 0); } if (SvTYPE(sv) == mt) - return TRUE; + return; + + if (SvTYPE(sv) > mt) + Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d", + (int)SvTYPE(sv), (int)mt); + + + old_body = SvANY(sv); + old_body_arena = 0; + old_body_offset = 0; + old_body_length = 0; + new_body_offset = 0; + new_body_length = ~0; + + /* Copying structures onto other structures that have been neatly zeroed + has a subtle gotcha. Consider XPVMG + + +------+------+------+------+------+-------+-------+ + | NV | CUR | LEN | IV | MAGIC | STASH | + +------+------+------+------+------+-------+-------+ + 0 4 8 12 16 20 24 28 - pv = NULL; - cur = 0; - len = 0; - iv = 0; - nv = 0.0; - magic = NULL; - stash = Nullhv; + where NVs are aligned to 8 bytes, so that sizeof that structure is + actually 32 bytes long, with 4 bytes of padding at the end: + + +------+------+------+------+------+-------+-------+------+ + | NV | CUR | LEN | IV | MAGIC | STASH | ??? | + +------+------+------+------+------+-------+-------+------+ + 0 4 8 12 16 20 24 28 32 + + so what happens if you allocate memory for this structure: + + +------+------+------+------+------+-------+-------+------+------+... + | NV | CUR | LEN | IV | MAGIC | STASH | GP | NAME | + +------+------+------+------+------+-------+-------+------+------+... + 0 4 8 12 16 20 24 28 32 36 + + zero it, then copy sizeof(XPVMG) bytes on top of it? Not quite what you + expect, because you copy the area marked ??? onto GP. Now, ??? may have + started out as zero once, but it's quite possible that it isn't. So now, + rather than a nicely zeroed GP, you have it pointing somewhere random. + Bugs ensue. + + (In fact, GP ends up pointing at a previous GP structure, because the + principle cause of the padding in XPVMG getting garbage is a copy of + sizeof(XPVMG) bytes from a XPVGV structure in sv_unglob) + + So we are careful and work out the size of used parts of all the + structures. */ switch (SvTYPE(sv)) { case SVt_NULL: break; case SVt_IV: - iv = SvIVX(sv); if (mt == SVt_NV) mt = SVt_PVNV; else if (mt < SVt_PVIV) mt = SVt_PVIV; + old_body_offset = STRUCT_OFFSET(XPVIV, xiv_iv); + old_body_length = sizeof(IV); break; case SVt_NV: - nv = SvNVX(sv); - del_XNV(SvANY(sv)); + old_body_arena = (void **) &PL_xnv_root; + old_body_length = sizeof(NV); +#ifndef NV_ZERO_IS_ALLBITS_ZERO + zero_nv = FALSE; +#endif if (mt < SVt_PVNV) mt = SVt_PVNV; break; case SVt_RV: - pv = (char*)SvRV(sv); break; case SVt_PV: - pv = SvPVX_mutable(sv); - cur = SvCUR(sv); - len = SvLEN(sv); - del_XPV(SvANY(sv)); + old_body_arena = (void **) &PL_xpv_root; + old_body_offset = STRUCT_OFFSET(XPV, xpv_cur) + - STRUCT_OFFSET(xpv_allocated, xpv_cur); + old_body_length = STRUCT_OFFSET(XPV, xpv_len) + + sizeof (((XPV*)SvANY(sv))->xpv_len) + - old_body_offset; if (mt <= SVt_IV) mt = SVt_PVIV; else if (mt == SVt_NV) mt = SVt_PVNV; break; case SVt_PVIV: - pv = SvPVX_mutable(sv); - cur = SvCUR(sv); - len = SvLEN(sv); - iv = SvIVX(sv); - del_XPVIV(SvANY(sv)); + old_body_arena = (void **) &PL_xpviv_root; + old_body_offset = STRUCT_OFFSET(XPVIV, xpv_cur) + - STRUCT_OFFSET(xpviv_allocated, xpv_cur); + old_body_length = STRUCT_OFFSET(XPVIV, xiv_u) + + sizeof (((XPVIV*)SvANY(sv))->xiv_u) + - old_body_offset; break; case SVt_PVNV: - pv = SvPVX_mutable(sv); - cur = SvCUR(sv); - len = SvLEN(sv); - iv = SvIVX(sv); - nv = SvNVX(sv); - del_XPVNV(SvANY(sv)); + old_body_arena = (void **) &PL_xpvnv_root; + old_body_length = STRUCT_OFFSET(XPVNV, xiv_u) + + sizeof (((XPVNV*)SvANY(sv))->xiv_u); +#ifndef NV_ZERO_IS_ALLBITS_ZERO + zero_nv = FALSE; +#endif break; case SVt_PVMG: /* Because the XPVMG of PL_mess_sv isn't allocated from the arena, @@ -1837,14 +1412,12 @@ Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt) Given that it only has meaning inside the pad, it shouldn't be set on anything that can get upgraded. */ assert((SvFLAGS(sv) & SVpad_TYPED) == 0); - pv = SvPVX_mutable(sv); - cur = SvCUR(sv); - len = SvLEN(sv); - iv = SvIVX(sv); - nv = SvNVX(sv); - magic = SvMAGIC(sv); - stash = SvSTASH(sv); - del_XPVMG(SvANY(sv)); + old_body_arena = (void **) &PL_xpvmg_root; + old_body_length = STRUCT_OFFSET(XPVMG, xmg_stash) + + sizeof (((XPVMG*)SvANY(sv))->xmg_stash); +#ifndef NV_ZERO_IS_ALLBITS_ZERO + zero_nv = FALSE; +#endif break; default: Perl_croak(aTHX_ "Can't upgrade that kind of scalar"); @@ -1857,119 +1430,167 @@ Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt) case SVt_NULL: Perl_croak(aTHX_ "Can't upgrade to undef"); case SVt_IV: + assert(old_type == SVt_NULL); SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv)); - SvIV_set(sv, iv); - break; + SvIV_set(sv, 0); + return; case SVt_NV: + assert(old_type == SVt_NULL); SvANY(sv) = new_XNV(); - SvNV_set(sv, nv); - break; + SvNV_set(sv, 0); + return; case SVt_RV: + assert(old_type == SVt_NULL); SvANY(sv) = &sv->sv_u.svu_rv; - SvRV_set(sv, (SV*)pv); - break; + SvRV_set(sv, 0); + return; case SVt_PVHV: SvANY(sv) = new_XPVHV(); HvFILL(sv) = 0; HvMAX(sv) = 0; HvTOTALKEYS(sv) = 0; - /* Fall through... */ - if (0) { - case SVt_PVAV: - SvANY(sv) = new_XPVAV(); - AvMAX(sv) = -1; - AvFILLp(sv) = -1; - AvALLOC(sv) = 0; - AvREAL_only(sv); - } - /* 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); + goto hv_av_common; + + case SVt_PVAV: + SvANY(sv) = new_XPVAV(); + AvMAX(sv) = -1; + AvFILLp(sv) = -1; + AvALLOC(sv) = 0; + AvREAL_only(sv); + + hv_av_common: + /* SVt_NULL isn't the only thing upgraded to AV or HV. + The target created by newSVrv also is, and it can have magic. + However, it never has SvPVX set. + */ + if (old_type >= SVt_RV) { + assert(SvPVX_const(sv) == 0); + } + + /* Could put this in the else clause below, as PVMG must have SvPVX + 0 already (the assertion above) */ SvPV_set(sv, (char*)0); - SvMAGIC_set(sv, magic); - SvSTASH_set(sv, stash); + + if (old_type >= SVt_PVMG) { + SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_magic); + SvSTASH_set(sv, ((XPVMG*)old_body)->xmg_stash); + } else { + SvMAGIC_set(sv, 0); + SvSTASH_set(sv, 0); + } break; case SVt_PVIO: - SvANY(sv) = new_XPVIO(); - Zero(SvANY(sv), 1, XPVIO); - IoPAGE_LEN(sv) = 60; - goto set_magic_common; + new_body = new_XPVIO(); + new_body_length = sizeof(XPVIO); + goto zero; case SVt_PVFM: - SvANY(sv) = new_XPVFM(); - Zero(SvANY(sv), 1, XPVFM); - goto set_magic_common; + new_body = new_XPVFM(); + new_body_length = sizeof(XPVFM); + goto zero; + case SVt_PVBM: - SvANY(sv) = new_XPVBM(); - BmRARE(sv) = 0; - BmUSEFUL(sv) = 0; - BmPREVIOUS(sv) = 0; - goto set_magic_common; + new_body_length = sizeof(XPVBM); + new_body_arena = (void **) &PL_xpvbm_root; + new_body_arenaroot = (void **) &PL_xpvbm_arenaroot; + goto new_body; 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; + new_body_length = sizeof(XPVGV); + new_body_arena = (void **) &PL_xpvgv_root; + new_body_arenaroot = (void **) &PL_xpvgv_arenaroot; + goto new_body; case SVt_PVCV: - SvANY(sv) = new_XPVCV(); - Zero(SvANY(sv), 1, XPVCV); - goto set_magic_common; + new_body_length = sizeof(XPVCV); + new_body_arena = (void **) &PL_xpvcv_root; + new_body_arenaroot = (void **) &PL_xpvcv_arenaroot; + goto new_body; 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; - /* 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(); + new_body_length = sizeof(XPVLV); + new_body_arena = (void **) &PL_xpvlv_root; + new_body_arenaroot = (void **) &PL_xpvlv_arenaroot; + goto new_body; + case SVt_PVMG: + new_body_length = sizeof(XPVMG); + new_body_arena = (void **) &PL_xpvmg_root; + new_body_arenaroot = (void **) &PL_xpvmg_arenaroot; + goto new_body; + case SVt_PVNV: + new_body_length = sizeof(XPVNV); + new_body_arena = (void **) &PL_xpvnv_root; + new_body_arenaroot = (void **) &PL_xpvnv_arenaroot; + goto new_body; + case SVt_PVIV: + new_body_offset = STRUCT_OFFSET(XPVIV, xpv_cur) + - STRUCT_OFFSET(xpviv_allocated, xpv_cur); + new_body_length = sizeof(XPVIV) - new_body_offset; + new_body_arena = (void **) &PL_xpviv_root; + new_body_arenaroot = (void **) &PL_xpviv_arenaroot; + /* XXX Is this still needed? Was it ever needed? Surely as there is + no route from NV to PVIV, NOK can never be true */ + if (SvNIOK(sv)) + (void)SvIOK_on(sv); + SvNOK_off(sv); + goto new_body_no_NV; + case SVt_PV: + new_body_offset = STRUCT_OFFSET(XPV, xpv_cur) + - STRUCT_OFFSET(xpv_allocated, xpv_cur); + new_body_length = sizeof(XPV) - new_body_offset; + new_body_arena = (void **) &PL_xpv_root; + new_body_arenaroot = (void **) &PL_xpv_arenaroot; + new_body_no_NV: + /* PV and PVIV don't have an NV slot. */ +#ifndef NV_ZERO_IS_ALLBITS_ZERO + zero_nv = FALSE; +#endif + + new_body: + assert(new_body_length); +#ifndef PURIFY + /* This points to the start of the allocated area. */ + new_body_inline(new_body, new_body_arenaroot, new_body_arena, + new_body_length); +#else + /* We always allocated the full length item with PURIFY */ + new_body_length += new_body_offset; + new_body_offset = 0; + new_body = my_safemalloc(new_body_length); + +#endif + zero: + Zero(new_body, new_body_length, char); + new_body = ((char *)new_body) - new_body_offset; + SvANY(sv) = new_body; + + if (old_body_length) { + Copy((char *)old_body + old_body_offset, + (char *)new_body + old_body_offset, + old_body_length, char); } - SvPV_set(sv, pv); - SvCUR_set(sv, cur); - SvLEN_set(sv, len); + +#ifndef NV_ZERO_IS_ALLBITS_ZERO + if (zero_nv) + SvNV_set(sv, 0); +#endif + + if (mt == SVt_PVIO) + IoPAGE_LEN(sv) = 60; + if (old_type < SVt_RV) + SvPV_set(sv, 0); break; + default: + Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu", mt); + } + + + if (old_body_arena) { +#ifdef PURIFY + my_safefree(old_body); +#else + del_body((void*)((char*)old_body + old_body_offset), + old_body_arena); +#endif } - return TRUE; } /* @@ -1988,7 +1609,7 @@ Perl_sv_backoff(pTHX_ register SV *sv) assert(SvTYPE(sv) != SVt_PVHV); assert(SvTYPE(sv) != SVt_PVAV); if (SvIVX(sv)) { - const char *s = SvPVX_const(sv); + const char * const s = SvPVX_const(sv); SvLEN_set(sv, SvLEN(sv) + SvIVX(sv)); SvPV_set(sv, SvPVX(sv) - SvIVX(sv)); SvIV_set(sv, 0); @@ -2024,11 +1645,11 @@ Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen) sv_unref(sv); if (SvTYPE(sv) < SVt_PV) { sv_upgrade(sv, SVt_PV); - s = SvPVX(sv); + s = SvPVX_mutable(sv); } else if (SvOOK(sv)) { /* pv is offset? */ sv_backoff(sv); - s = SvPVX(sv); + s = SvPVX_mutable(sv); if (newlen > SvLEN(sv)) newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */ #ifdef HAS_64K_LIMIT @@ -2043,7 +1664,7 @@ Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen) newlen = PERL_STRLEN_ROUNDUP(newlen); if (SvLEN(sv) && s) { #ifdef MYMALLOC - const STRLEN l = malloced_size((void*)SvPVX(sv)); + const STRLEN l = malloced_size((void*)SvPVX_const(sv)); if (newlen <= l) { SvLEN_set(sv, l); return s; @@ -2157,21 +1778,9 @@ Like C, but also handles 'set' magic. void Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u) { - /* With these two if statements: - u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865 - - without - u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865 - - If you wish to remove them, please benchmark to see what the effect is - */ - if (u <= (UV)IV_MAX) { - sv_setiv(sv, (IV)u); - } else { - sv_setiv(sv, 0); - SvIsUV_on(sv); - sv_setuv(sv,u); - } + sv_setiv(sv, 0); + SvIsUV_on(sv); + sv_setuv(sv,u); SvSETMAGIC(sv); } @@ -2237,14 +1846,14 @@ S_not_a_number(pTHX_ SV *sv) { SV *dsv; char tmpbuf[64]; - char *pv; + const char *pv; if (DO_UTF8(sv)) { - dsv = sv_2mortal(newSVpv("", 0)); + dsv = sv_2mortal(newSVpvn("", 0)); pv = sv_uni_display(dsv, sv, 10, 0); } else { char *d = tmpbuf; - char *limit = tmpbuf + sizeof(tmpbuf) - 8; + const char * const limit = tmpbuf + sizeof(tmpbuf) - 8; /* each *s can expand to 4 chars + "...\0", i.e. need room for 8 chars */ @@ -2497,7 +2106,7 @@ Perl_sv_2iv_flags(pTHX_ register SV *sv, I32 flags) return asIV(sv); if (!SvROK(sv)) { if (!(SvFLAGS(sv) & SVs_PADTMP)) { - if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing) + if (!PL_localizing && ckWARN(WARN_UNINITIALIZED)) report_uninit(sv); } return 0; @@ -2505,11 +2114,13 @@ Perl_sv_2iv_flags(pTHX_ register SV *sv, I32 flags) } if (SvTHINKFIRST(sv)) { if (SvROK(sv)) { - SV* tmpstr; - if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) && - (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) - return SvIV(tmpstr); - return PTR2IV(SvRV(sv)); + if (SvAMAGIC(sv)) { + SV * const tmpstr=AMG_CALLun(sv,numer); + if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) { + return SvIV(tmpstr); + } + } + return PTR2IV(SvRV(sv)); } if (SvIsCOW(sv)) { sv_force_normal_flags(sv, 0); @@ -2757,7 +2368,7 @@ Perl_sv_2iv_flags(pTHX_ register SV *sv, I32 flags) #endif /* NV_PRESERVES_UV */ } } else { - if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP)) + if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED)) report_uninit(sv); if (SvTYPE(sv) < SVt_IV) /* Typically the caller expects that sv_any is not NULL now. */ @@ -2805,7 +2416,7 @@ Perl_sv_2uv_flags(pTHX_ register SV *sv, I32 flags) return asUV(sv); if (!SvROK(sv)) { if (!(SvFLAGS(sv) & SVs_PADTMP)) { - if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing) + if (!PL_localizing && ckWARN(WARN_UNINITIALIZED)) report_uninit(sv); } return 0; @@ -3046,7 +2657,7 @@ Perl_sv_2uv_flags(pTHX_ register SV *sv, I32 flags) } else { if (!(SvFLAGS(sv) & SVs_PADTMP)) { - if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing) + if (!PL_localizing && ckWARN(WARN_UNINITIALIZED)) report_uninit(sv); } if (SvTYPE(sv) < SVt_IV) @@ -3080,7 +2691,7 @@ Perl_sv_2nv(pTHX_ register SV *sv) if (SvNOKp(sv)) return SvNVX(sv); if (SvPOKp(sv) && SvLEN(sv)) { - if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && + if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) && !grok_number(SvPVX_const(sv), SvCUR(sv), NULL)) not_a_number(sv); return Atof(SvPVX_const(sv)); @@ -3093,7 +2704,7 @@ Perl_sv_2nv(pTHX_ register SV *sv) } if (!SvROK(sv)) { if (!(SvFLAGS(sv) & SVs_PADTMP)) { - if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing) + if (!PL_localizing && ckWARN(WARN_UNINITIALIZED)) report_uninit(sv); } return (NV)0; @@ -3160,7 +2771,7 @@ Perl_sv_2nv(pTHX_ register SV *sv) else if (SvPOKp(sv) && SvLEN(sv)) { UV value; const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value); - if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !numtype) + if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC)) not_a_number(sv); #ifdef NV_PRESERVES_UV if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) @@ -3242,7 +2853,7 @@ Perl_sv_2nv(pTHX_ register SV *sv) #endif /* NV_PRESERVES_UV */ } else { - if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP)) + if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED)) report_uninit(sv); if (SvTYPE(sv) < SVt_NV) /* Typically the caller expects that sv_any is not NULL now. */ @@ -3340,10 +2951,10 @@ Perl_sv_2pv_nolen(pTHX_ register SV *sv) */ static char * -uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob) +S_uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob) { char *ptr = buf + TYPE_CHARS(UV); - char *ebuf = ptr; + char * const ebuf = ptr; int sign; if (is_uv) @@ -3427,7 +3038,7 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) } if (!SvROK(sv)) { if (!(SvFLAGS(sv) & SVs_PADTMP)) { - if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing) + if (!PL_localizing && ckWARN(WARN_UNINITIALIZED)) report_uninit(sv); } if (lp) @@ -3441,7 +3052,22 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) register const char *typestr; if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) { - char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr); + /* Unwrap this: */ + /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr); */ + + char *pv; + if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) { + if (flags & SV_CONST_RETURN) { + pv = (char *) SvPVX_const(tmpstr); + } else { + pv = (flags & SV_MUTABLE_RETURN) + ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr); + } + if (lp) + *lp = SvCUR(tmpstr); + } else { + pv = sv_2pv_flags(tmpstr, lp, flags); + } if (SvUTF8(tmpstr)) SvUTF8_on(sv); else @@ -3520,7 +3146,7 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) } } - New(616, mg->mg_ptr, mg->mg_len + 1 + left, char); + Newx(mg->mg_ptr, mg->mg_len + 1 + left, char); Copy("(?", mg->mg_ptr, 2, char); Copy(reflags, mg->mg_ptr+2, left, char); Copy(":", mg->mg_ptr+left+2, 1, char); @@ -3598,7 +3224,8 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf); else ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf); - SvGROW(sv, (STRLEN)(ebuf - ptr + 1)); /* inlined from sv_setpvn */ + /* inlined from sv_setpvn */ + SvGROW_mutable(sv, (STRLEN)(ebuf - ptr + 1)); Move(ptr,SvPVX_mutable(sv),ebuf - ptr,char); SvCUR_set(sv, ebuf - ptr); s = SvEND(sv); @@ -3614,8 +3241,7 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) if (SvTYPE(sv) < SVt_PVNV) sv_upgrade(sv, SVt_PVNV); /* The +20 is pure guesswork. Configure test needed. --jhi */ - SvGROW(sv, NV_DIG + 20); - s = SvPVX_mutable(sv); + s = SvGROW_mutable(sv, NV_DIG + 20); olderrno = errno; /* some Xenix systems wipe out errno here */ #ifdef apollo if (SvNVX(sv) == 0.0) @@ -3637,8 +3263,7 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) #endif } else { - if (ckWARN(WARN_UNINITIALIZED) - && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP)) + if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED)) report_uninit(sv); if (lp) *lp = 0; @@ -3648,7 +3273,7 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) return (char *)""; } { - STRLEN len = s - SvPVX_const(sv); + const STRLEN len = s - SvPVX_const(sv); if (lp) *lp = len; SvCUR_set(sv, len); @@ -3697,10 +3322,10 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) SvUPGRADE(sv, SVt_PV); if (lp) *lp = len; - s = SvGROW(sv, len + 1); + s = SvGROW_mutable(sv, len + 1); SvCUR_set(sv, len); SvPOKp_on(sv); - return strcpy(s, t); + return memcpy(s, t, len + 1); } } @@ -3722,8 +3347,7 @@ void Perl_sv_copypv(pTHX_ SV *dsv, register SV *ssv) { STRLEN len; - const char *s; - s = SvPV_const(ssv,len); + const char * const s = SvPV_const(ssv,len); sv_setpvn(dsv,s,len); if (SvUTF8(ssv)) SvUTF8_on(dsv); @@ -3764,7 +3388,7 @@ char * Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp) { sv_utf8_downgrade(sv,0); - return SvPV(sv,*lp); + return lp ? SvPV(sv,*lp) : SvPV_nolen(sv); } /* @@ -3799,7 +3423,7 @@ char * Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp) { sv_utf8_upgrade(sv); - return SvPV(sv,*lp); + return lp ? SvPV(sv,*lp) : SvPV_nolen(sv); } /* @@ -3814,8 +3438,7 @@ sv_true() or its macro equivalent. bool Perl_sv_2bool(pTHX_ register SV *sv) { - if (SvGMAGICAL(sv)) - mg_get(sv); + SvGETMAGIC(sv); if (!SvOK(sv)) return 0; @@ -3827,8 +3450,8 @@ Perl_sv_2bool(pTHX_ register SV *sv) return SvRV(sv) != 0; } if (SvPOKp(sv)) { - register XPV* Xpvtmp; - if ((Xpvtmp = (XPV*)SvANY(sv)) && + register XPV* const Xpvtmp = (XPV*)SvANY(sv); + if (Xpvtmp && (*sv->sv_u.svu_pv > '0' || Xpvtmp->xpv_cur > 1 || (Xpvtmp->xpv_cur && *sv->sv_u.svu_pv != '0'))) @@ -3916,23 +3539,23 @@ Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags) * 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; + const U8 *s = (U8 *) SvPVX_const(sv); + const U8 *e = (U8 *) SvEND(sv); + const U8 *t = s; int hibit = 0; while (t < e) { - U8 ch = *t++; + const 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); + U8 * const recoded = bytes_to_utf8((U8*)s, &len); SvPV_free(sv); /* No longer using what was there before. */ - SvPV_set(sv, (char*)s); + SvPV_set(sv, (char*)recoded); SvCUR_set(sv, len - 1); SvLEN_set(sv, len); /* No longer know the real size. */ } @@ -4024,8 +3647,8 @@ bool Perl_sv_utf8_decode(pTHX_ register SV *sv) { if (SvPOKp(sv)) { - U8 *c; - U8 *e; + const U8 *c; + const U8 *e; /* The octets may have got themselves encoded - get them back as * bytes @@ -4036,12 +3659,12 @@ Perl_sv_utf8_decode(pTHX_ register SV *sv) /* it is actually just a matter of turning the utf8 flag on, but * we want to make sure everything inside is valid utf8 first. */ - c = (U8 *) SvPVX(sv); + c = (const U8 *) SvPVX_const(sv); if (!is_utf8_string(c, SvCUR(sv)+1)) return FALSE; - e = (U8 *) SvEND(sv); + e = (const U8 *) SvEND(sv); while (c < e) { - U8 ch = *c++; + const U8 ch = *c++; if (!UTF8_IS_INVARIANT(ch)) { SvUTF8_on(sv); break; @@ -4236,7 +3859,9 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) if (dtype != SVt_PVLV) sv_upgrade(dstr, SVt_PVGV); sv_magic(dstr, dstr, PERL_MAGIC_glob, Nullch, 0); - GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr)); + GvSTASH(dstr) = GvSTASH(sstr); + if (GvSTASH(dstr)) + Perl_sv_add_backref(aTHX_ (SV*)GvSTASH(dstr), dstr); GvNAME(dstr) = savepvn(name, len); GvNAMELEN(dstr) = len; SvFAKE_on(dstr); /* can coerce to non-glob */ @@ -4289,7 +3914,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) if (sflags & SVf_ROK) { if (dtype >= SVt_PV) { if (dtype == SVt_PVGV) { - SV *sref = SvREFCNT_inc(SvRV(sstr)); + SV * const sref = SvREFCNT_inc(SvRV(sstr)); SV *dref = 0; const int intro = GvINTRO(dstr); @@ -4343,7 +3968,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) else dref = (SV*)GvCV(dstr); if (GvCV(dstr) != (CV*)sref) { - CV* cv = GvCV(dstr); + CV* const cv = GvCV(dstr); if (cv) { if (!GvCVGEN((GV*)dstr) && (CvROOT(cv) || CvXSUB(cv))) @@ -4373,7 +3998,8 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) } if (!intro) cv_ckproto(cv, (GV*)dstr, - SvPOK(sref) ? SvPVX(sref) : Nullch); + SvPOK(sref) + ? SvPVX_const(sref) : Nullch); } GvCV(dstr) = (CV*)sref; GvCVGEN(dstr) = 0; /* Switch off cacheness. */ @@ -4521,13 +4147,8 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) } #endif /* Initial code is common. */ - if (SvPVX_const(dstr)) { /* we know that dtype >= SVt_PV */ - if (SvOOK(dstr)) { - SvFLAGS(dstr) &= ~SVf_OOK; - Safefree(SvPVX_const(dstr) - SvIVX(dstr)); - } - else if (SvLEN(dstr)) - Safefree(SvPVX_const(dstr)); + if (SvPVX_const(dstr)) { /* we know that dtype >= SVt_PV */ + SvPV_free(dstr); } if (!isSwipe) { @@ -4546,16 +4167,13 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) #endif { /* SvIsCOW_shared_hash */ - UV hash = SvSHARED_HASH(sstr); DEBUG_C(PerlIO_printf(Perl_debug_log, "Copy on write: Sharing hash\n")); - assert (SvTYPE(dstr) >= SVt_PVIV); + assert (SvTYPE(dstr) >= SVt_PV); SvPV_set(dstr, - sharepvn(SvPVX_const(sstr), - (sflags & SVf_UTF8?-cur:cur), hash)); - SvUV_set(dstr, hash); - } + HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr))))); + } SvLEN_set(dstr, len); SvCUR_set(dstr, cur); SvREADONLY_on(dstr); @@ -4578,7 +4196,6 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) } if (sflags & SVf_UTF8) SvUTF8_on(dstr); - /*SUPPRESS 560*/ if (sflags & SVp_NOK) { SvNOKp_on(dstr); if (sflags & SVf_NOK) @@ -4692,11 +4309,9 @@ Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr) if (SvLEN(sstr) == 0) { /* source is a COW shared hash key. */ - UV hash = SvSHARED_HASH(sstr); DEBUG_C(PerlIO_printf(Perl_debug_log, "Fast copy on write: Sharing hash\n")); - SvUV_set(dstr, hash); - new_pv = sharepvn(SvPVX_const(sstr), (SvUTF8(sstr)?-cur:cur), hash); + new_pv = HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)))); goto common_exit; } SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr)); @@ -4754,8 +4369,7 @@ Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN } SvUPGRADE(sv, SVt_PV); - SvGROW(sv, len + 1); - dptr = SvPVX(sv); + dptr = SvGROW(sv, len + 1); Move(ptr,dptr,len,char); dptr[len] = '\0'; SvCUR_set(sv, len); @@ -4881,12 +4495,11 @@ Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len (which it can do by means other than releasing copy-on-write Svs) or by changing the other copy-on-write SVs in the loop. */ STATIC void -S_sv_release_COW(pTHX_ register SV *sv, const char *pvx, STRLEN cur, STRLEN len, - U32 hash, SV *after) +S_sv_release_COW(pTHX_ register SV *sv, const char *pvx, STRLEN len, SV *after) { if (len) { /* this SV was SvIsCOW_normal(sv) */ /* we need to find the SV pointing to us. */ - SV *current = SV_COW_NEXT_SV(after); + SV * const current = SV_COW_NEXT_SV(after); if (current == sv) { /* The SV we point to points back to us (there were only two of us @@ -4909,7 +4522,7 @@ S_sv_release_COW(pTHX_ register SV *sv, const char *pvx, STRLEN cur, STRLEN len, SV_COW_NEXT_SV_SET(current, after); } } else { - unsharepvn(pvx, SvUTF8(sv) ? -(I32)cur : cur, hash); + unshare_hek(SvSHARED_HEK_FROM_PV(pvx)); } } @@ -4945,10 +4558,9 @@ Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags) if (SvREADONLY(sv)) { /* At this point I believe I should acquire a global SV mutex. */ if (SvFAKE(sv)) { - const char *pvx = SvPVX_const(sv); + const char * const pvx = SvPVX_const(sv); const STRLEN len = SvLEN(sv); const STRLEN cur = SvCUR(sv); - const U32 hash = SvSHARED_HASH(sv); SV * const next = SV_COW_NEXT_SV(sv); /* next COW sv in the loop. */ if (DEBUG_C_TEST) { PerlIO_printf(Perl_debug_log, @@ -4958,7 +4570,7 @@ 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: */ + /* This SV doesn't own the buffer, so need to Newx() a new one: */ SvPV_set(sv, (char*)0); SvLEN_set(sv, 0); if (flags & SV_COW_DROP_PV) { @@ -4970,7 +4582,7 @@ Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags) SvCUR_set(sv, cur); *SvEND(sv) = '\0'; } - sv_release_COW(sv, pvx, cur, len, hash, next); + sv_release_COW(sv, pvx, len, next); if (DEBUG_C_TEST) { sv_dump(sv); } @@ -4982,18 +4594,16 @@ Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags) #else if (SvREADONLY(sv)) { if (SvFAKE(sv)) { - const char *pvx = SvPVX_const(sv); - const int is_utf8 = SvUTF8(sv); + const char * const pvx = SvPVX_const(sv); const STRLEN len = SvCUR(sv); - const U32 hash = SvSHARED_HASH(sv); SvFAKE_off(sv); SvREADONLY_off(sv); SvPV_set(sv, Nullch); SvLEN_set(sv, 0); SvGROW(sv, len + 1); - Move(pvx,SvPVX_const(sv),len,char); + Move(pvx,SvPVX(sv),len,char); *SvEND(sv) = '\0'; - unsharepvn(pvx, is_utf8 ? -(I32)len : len, hash); + unshare_hek(SvSHARED_HEK_FROM_PV(pvx)); } else if (IN_PERL_RUNTIME) Perl_croak(aTHX_ PL_no_modify); @@ -5050,7 +4660,7 @@ Perl_sv_chop(pTHX_ register SV *sv, register const char *ptr) const char *pvx = SvPVX_const(sv); const STRLEN len = SvCUR(sv); SvGROW(sv, len + 1); - Move(pvx,SvPVX_const(sv),len,char); + Move(pvx,SvPVX(sv),len,char); *SvEND(sv) = '\0'; } SvIV_set(sv, 0); @@ -5181,7 +4791,7 @@ Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags) SV* csv = sv_2mortal(newSVpvn(spv, slen)); sv_utf8_upgrade(csv); - spv = SvPV(csv, slen); + spv = SvPV_const(csv, slen); } else sv_utf8_upgrade_nomg(dsv); @@ -5299,7 +4909,7 @@ Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, const MGVTBL *vtable, if (SvTYPE(sv) < SVt_PVMG) { SvUPGRADE(sv, SVt_PVMG); } - Newz(702,mg, 1, MAGIC); + Newxz(mg, 1, MAGIC); mg->mg_moremagic = SvMAGIC(sv); SvMAGIC_set(sv, mg); @@ -5378,7 +4988,7 @@ to add more than one instance of the same 'how'. void Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen) { - const MGVTBL *vtable = 0; + const MGVTBL *vtable; MAGIC* mg; #ifdef PERL_OLD_COPY_ON_WRITE @@ -5386,7 +4996,12 @@ Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 nam sv_force_normal_flags(sv, 0); #endif if (SvREADONLY(sv)) { - if (IN_PERL_RUNTIME + if ( + /* its okay to attach magic to shared strings; the subsequent + * upgrade to PVMG will unshare the string */ + !(SvFAKE(sv) && SvTYPE(sv) < SVt_PVMG) + + && IN_PERL_RUNTIME && how != PERL_MAGIC_regex_global && how != PERL_MAGIC_bm && how != PERL_MAGIC_fm @@ -5452,7 +5067,7 @@ Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 nam vtable = &PL_vtbl_nkeys; break; case PERL_MAGIC_dbfile: - vtable = 0; + vtable = NULL; break; case PERL_MAGIC_dbline: vtable = &PL_vtbl_dbline; @@ -5491,7 +5106,7 @@ Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 nam case PERL_MAGIC_rhash: case PERL_MAGIC_symtab: case PERL_MAGIC_vstring: - vtable = 0; + vtable = NULL; break; case PERL_MAGIC_utf8: vtable = &PL_vtbl_utf8; @@ -5519,13 +5134,14 @@ Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 nam /* Useful for attaching extension internal data to perl vars. */ /* Note that multiple extensions may clash if magical scalars */ /* etc holding private data from one are passed to another. */ + vtable = NULL; break; default: Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how); } /* Rest of work is done else where */ - mg = sv_magicext(sv,obj,how,(MGVTBL*)vtable,name,namlen); + mg = sv_magicext(sv,obj,how,vtable,name,namlen); switch (how) { case PERL_MAGIC_taint: @@ -5608,7 +5224,7 @@ Perl_sv_rvweaken(pTHX_ SV *sv) return sv; } tsv = SvRV(sv); - sv_add_backref(tsv, sv); + Perl_sv_add_backref(aTHX_ tsv, sv); SvWEAKREF_on(sv); SvREFCNT_dec(tsv); return sv; @@ -5618,8 +5234,8 @@ Perl_sv_rvweaken(pTHX_ SV *sv) * back-reference to sv onto the array associated with the backref magic. */ -STATIC void -S_sv_add_backref(pTHX_ SV *tsv, SV *sv) +void +Perl_sv_add_backref(pTHX_ SV *tsv, SV *sv) { AV *av; MAGIC *mg; @@ -5633,13 +5249,6 @@ S_sv_add_backref(pTHX_ SV *tsv, SV *sv) * by magic_killbackrefs() when tsv is being freed */ } if (AvFILLp(av) >= AvMAX(av)) { - I32 i; - SV **svp = AvARRAY(av); - for (i = AvFILLp(av); i >= 0; i--) - if (!svp[i]) { - svp[i] = sv; /* reuse the slot */ - return; - } av_extend(av, AvFILLp(av)+1); } AvARRAY(av)[++AvFILLp(av)] = sv; /* av_push() */ @@ -5650,19 +5259,37 @@ S_sv_add_backref(pTHX_ SV *tsv, SV *sv) */ STATIC void -S_sv_del_backref(pTHX_ SV *sv) +S_sv_del_backref(pTHX_ SV *tsv, SV *sv) { AV *av; SV **svp; I32 i; - SV *tsv = SvRV(sv); MAGIC *mg = NULL; + if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref))) { + if (PL_in_clean_all) + return; + } if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref))) Perl_croak(aTHX_ "panic: del_backref"); av = (AV *)mg->mg_obj; svp = AvARRAY(av); - for (i = AvFILLp(av); i >= 0; i--) - if (svp[i] == sv) svp[i] = Nullsv; + /* We shouldn't be in here more than once, but for paranoia reasons lets + not assume this. */ + for (i = AvFILLp(av); i >= 0; i--) { + if (svp[i] == sv) { + const SSize_t fill = AvFILLp(av); + if (i != fill) { + /* We weren't the last entry. + An unordered list has this property that you can take the + last element off the end to fill the hole, and it's still + an unordered list :-) + */ + svp[i] = svp[fill]; + } + svp[fill] = Nullsv; + AvFILLp(av) = fill - 1; + } + } } /* @@ -5691,7 +5318,7 @@ Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, const char *little, (void)SvPOK_only_UTF8(bigstr); if (offset + len > curlen) { SvGROW(bigstr, offset+len+1); - Zero(SvPVX_const(bigstr)+curlen, offset+len-curlen, char); + Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char); SvCUR_set(bigstr, offset+len); } @@ -5737,7 +5364,6 @@ Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, const char *little, *mid = '\0'; SvCUR_set(bigstr, mid - big); } - /*SUPPRESS 560*/ else if ((i = mid - big)) { /* faster from front */ midend -= littlelen; mid = midend; @@ -5777,8 +5403,10 @@ Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv) { const U32 refcnt = SvREFCNT(sv); SV_CHECK_THINKFIRST_COW_DROP(sv); - if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL)) - Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Reference miscount in sv_replace()"); + if (SvREFCNT(nsv) != 1) { + Perl_croak(aTHX_ "panic: reference miscount on nsv in sv_replace() (%" + UVuf " != 1)", (UV) SvREFCNT(nsv)); + } if (SvMAGICAL(sv)) { if (SvMAGICAL(nsv)) mg_free(nsv); @@ -5796,6 +5424,7 @@ Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv) sv->sv_flags = nsv->sv_flags; sv->sv_any = nsv->sv_any; sv->sv_refcnt = nsv->sv_refcnt; + sv->sv_u = nsv->sv_u; #else StructCopy(nsv,sv,SV); #endif @@ -5855,19 +5484,29 @@ void Perl_sv_clear(pTHX_ register SV *sv) { dVAR; - HV* stash; + void** old_body_arena; + size_t old_body_offset; + const U32 type = SvTYPE(sv); + assert(sv); assert(SvREFCNT(sv) == 0); + if (type <= SVt_IV) + return; + + old_body_arena = 0; + old_body_offset = 0; + if (SvOBJECT(sv)) { if (PL_defstash) { /* Still have a symbol table? */ dSP; + HV* stash; do { CV* destructor; stash = SvSTASH(sv); destructor = StashHANDLER(stash,DESTROY); if (destructor) { - SV* tmpref = newRV(sv); + SV* const tmpref = newRV(sv); SvREADONLY_on(tmpref); /* DESTROY() could be naughty */ ENTER; PUSHSTACKi(PERLSI_DESTROY); @@ -5904,18 +5543,17 @@ Perl_sv_clear(pTHX_ register SV *sv) if (SvOBJECT(sv)) { SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */ SvOBJECT_off(sv); /* Curse the object. */ - if (SvTYPE(sv) != SVt_PVIO) + if (type != SVt_PVIO) --PL_sv_objcount; /* XXX Might want something more general */ } } - if (SvTYPE(sv) >= SVt_PVMG) { + if (type >= SVt_PVMG) { if (SvMAGIC(sv)) mg_free(sv); - if (SvTYPE(sv) == SVt_PVMG && SvFLAGS(sv) & SVpad_TYPED) + if (type == SVt_PVMG && SvFLAGS(sv) & SVpad_TYPED) SvREFCNT_dec(SvSTASH(sv)); } - stash = NULL; - switch (SvTYPE(sv)) { + switch (type) { case SVt_PVIO: if (IoIFP(sv) && IoIFP(sv) != PerlIO_stdin() && @@ -5930,18 +5568,26 @@ Perl_sv_clear(pTHX_ register SV *sv) Safefree(IoTOP_NAME(sv)); Safefree(IoFMT_NAME(sv)); Safefree(IoBOTTOM_NAME(sv)); - /* FALL THROUGH */ + /* PVIOs aren't from arenas */ + goto freescalar; case SVt_PVBM: + old_body_arena = (void **) &PL_xpvbm_root; goto freescalar; case SVt_PVCV: + old_body_arena = (void **) &PL_xpvcv_root; case SVt_PVFM: + /* PVFMs aren't from arenas */ cv_undef((CV*)sv); goto freescalar; case SVt_PVHV: hv_undef((HV*)sv); + old_body_arena = (void **) &PL_xpvhv_root; + old_body_offset = STRUCT_OFFSET(XPVHV, xhv_fill); break; case SVt_PVAV: av_undef((AV*)sv); + old_body_arena = (void **) &PL_xpvav_root; + old_body_offset = STRUCT_OFFSET(XPVAV, xav_fill); break; case SVt_PVLV: if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */ @@ -5951,33 +5597,44 @@ Perl_sv_clear(pTHX_ register SV *sv) } else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV** */ SvREFCNT_dec(LvTARG(sv)); + old_body_arena = (void **) &PL_xpvlv_root; goto freescalar; case SVt_PVGV: gp_free((GV*)sv); Safefree(GvNAME(sv)); - /* cannot decrease stash refcount yet, as we might recursively delete - ourselves when the refcnt drops to zero. Delay SvREFCNT_dec - of stash until current sv is completely gone. - -- JohnPC, 27 Mar 1998 */ - stash = GvSTASH(sv); - /* FALL THROUGH */ + /* If we're in a stash, we don't own a reference to it. However it does + have a back reference to us, which needs to be cleared. */ + if (GvSTASH(sv)) + sv_del_backref((SV*)GvSTASH(sv), sv); + old_body_arena = (void **) &PL_xpvgv_root; + goto freescalar; case SVt_PVMG: + old_body_arena = (void **) &PL_xpvmg_root; + goto freescalar; case SVt_PVNV: + old_body_arena = (void **) &PL_xpvnv_root; + goto freescalar; case SVt_PVIV: + old_body_arena = (void **) &PL_xpviv_root; + old_body_offset = STRUCT_OFFSET(XPVIV, xpv_cur); freescalar: /* 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)); + SvPV_set(sv, SvPVX_mutable(sv) - SvIVX(sv)); /* Don't even bother with turning off the OOK flag. */ } - /* FALL THROUGH */ + goto pvrv_common; case SVt_PV: + old_body_arena = (void **) &PL_xpv_root; + old_body_offset = STRUCT_OFFSET(XPV, xpv_cur); case SVt_RV: + pvrv_common: if (SvROK(sv)) { + SV *target = SvRV(sv); if (SvWEAKREF(sv)) - sv_del_backref(sv); + sv_del_backref(target, sv); else - SvREFCNT_dec(SvRV(sv)); + SvREFCNT_dec(target); } #ifdef PERL_OLD_COPY_ON_WRITE else if (SvPVX_const(sv)) { @@ -5987,89 +5644,41 @@ Perl_sv_clear(pTHX_ register SV *sv) if (DEBUG_C_TEST) { PerlIO_printf(Perl_debug_log, "Copy on write: clear\n"); sv_dump(sv); - } - sv_release_COW(sv, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), - SvUVX(sv), SV_COW_NEXT_SV(sv)); - /* And drop it here. */ - SvFAKE_off(sv); - } else if (SvLEN(sv)) { - Safefree(SvPVX_const(sv)); - } - } -#else - else if (SvPVX_const(sv) && SvLEN(sv)) - Safefree(SvPVX_const(sv)); - else if (SvPVX_const(sv) && SvREADONLY(sv) && SvFAKE(sv)) { - unsharepvn(SvPVX_const(sv), - SvUTF8(sv) ? -(I32)SvCUR(sv) : SvCUR(sv), - SvUVX(sv)); - SvFAKE_off(sv); - } -#endif - break; -/* - case SVt_NV: - case SVt_IV: - case SVt_NULL: - break; -*/ - } - - switch (SvTYPE(sv)) { - case SVt_NULL: - break; - case SVt_IV: - break; - case SVt_NV: - del_XNV(SvANY(sv)); - break; - case SVt_RV: - break; - case SVt_PV: - del_XPV(SvANY(sv)); - break; - case SVt_PVIV: - del_XPVIV(SvANY(sv)); - break; - case SVt_PVNV: - del_XPVNV(SvANY(sv)); - break; - case SVt_PVMG: - del_XPVMG(SvANY(sv)); - break; - case SVt_PVLV: - del_XPVLV(SvANY(sv)); - break; - case SVt_PVAV: - del_XPVAV(SvANY(sv)); - break; - case SVt_PVHV: - del_XPVHV(SvANY(sv)); - break; - case SVt_PVCV: - del_XPVCV(SvANY(sv)); - break; - case SVt_PVGV: - del_XPVGV(SvANY(sv)); - /* code duplication for increased performance. */ - SvFLAGS(sv) &= SVf_BREAK; - SvFLAGS(sv) |= SVTYPEMASK; - /* decrease refcount of the stash that owns this GV, if any */ - if (stash) - SvREFCNT_dec(stash); - return; /* not break, SvFLAGS reset already happened */ - case SVt_PVBM: - del_XPVBM(SvANY(sv)); - break; - case SVt_PVFM: - del_XPVFM(SvANY(sv)); + } + sv_release_COW(sv, SvPVX_const(sv), SvLEN(sv), + SV_COW_NEXT_SV(sv)); + /* And drop it here. */ + SvFAKE_off(sv); + } else if (SvLEN(sv)) { + Safefree(SvPVX_const(sv)); + } + } +#else + else if (SvPVX_const(sv) && SvLEN(sv)) + Safefree(SvPVX_mutable(sv)); + else if (SvPVX_const(sv) && SvREADONLY(sv) && SvFAKE(sv)) { + unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv))); + SvFAKE_off(sv); + } +#endif break; - case SVt_PVIO: - del_XPVIO(SvANY(sv)); + case SVt_NV: + old_body_arena = (void **) &PL_xnv_root; break; } + SvFLAGS(sv) &= SVf_BREAK; SvFLAGS(sv) |= SVTYPEMASK; + +#ifndef PURIFY + if (old_body_arena) { + del_body(((char *)SvANY(sv) + old_body_offset), old_body_arena); + } + else +#endif + if (type > SVt_RV) { + my_safefree(SvANY(sv)); + } } /* @@ -6118,10 +5727,14 @@ Perl_sv_free(pTHX_ SV *sv) SvREFCNT(sv) = (~(U32)0)/2; return; } - if (ckWARN_d(WARN_INTERNAL)) + if (ckWARN_d(WARN_INTERNAL)) { Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Attempt to free unreferenced scalar: SV 0x%"UVxf pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE); +#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP + Perl_dump_sv_child(aTHX_ sv); +#endif + } return; } if (--(SvREFCNT(sv)) > 0) @@ -6250,7 +5863,7 @@ S_utf8_mg_pos_init(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i, if ((*mgp)->mg_ptr) *cachep = (STRLEN *) (*mgp)->mg_ptr; else { - Newz(0, *cachep, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN); + Newxz(*cachep, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN); (*mgp)->mg_ptr = (char *) *cachep; } assert(*cachep); @@ -6415,7 +6028,7 @@ Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp) STRLEN *cache = 0; const U8 *s = start; I32 uoffset = *offsetp; - const U8 *send = s + len; + const U8 * const send = s + len; MAGIC *mg = 0; bool found = FALSE; @@ -6517,7 +6130,7 @@ Perl_sv_pos_b2u(pTHX_ register SV* sv, I32* offsetp) * is made as in S_utf8_mg_pos(), namely that * walking backward is twice slower than * walking forward. */ - STRLEN forw = *offsetp; + const STRLEN forw = *offsetp; STRLEN backw = cache[1] - *offsetp; if (!(forw < 2 * backw)) { @@ -6572,7 +6185,7 @@ Perl_sv_pos_b2u(pTHX_ register SV* sv, I32* offsetp) assert(mg); if (!mg->mg_ptr) { - Newz(0, cache, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN); + Newxz(cache, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN); mg->mg_ptr = (char *) cache; } assert(cache); @@ -6631,12 +6244,12 @@ Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2) if (SvUTF8(sv1)) { svrecode = newSVpvn(pv2, cur2); sv_recode_to_utf8(svrecode, PL_encoding); - pv2 = SvPV(svrecode, cur2); + pv2 = SvPV_const(svrecode, cur2); } else { svrecode = newSVpvn(pv1, cur1); sv_recode_to_utf8(svrecode, PL_encoding); - pv1 = SvPV(svrecode, cur1); + pv1 = SvPV_const(svrecode, cur1); } /* Now both are in UTF-8. */ if (cur1 != cur2) { @@ -6650,7 +6263,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((const U8*)pv1, + char * const pv = (char*)bytes_from_utf8((const U8*)pv1, &cur1, &is_utf8); if (pv != pv1) pv1 = tpv = pv; @@ -6658,7 +6271,7 @@ 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((const U8*)pv2, + char * const pv = (char *)bytes_from_utf8((const U8*)pv2, &cur2, &is_utf8); if (pv != pv2) pv2 = tpv = pv; @@ -6724,7 +6337,7 @@ Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2) if (PL_encoding) { svrecode = newSVpvn(pv2, cur2); sv_recode_to_utf8(svrecode, PL_encoding); - pv2 = SvPV(svrecode, cur2); + pv2 = SvPV_const(svrecode, cur2); } else { pv2 = tpv = (char*)bytes_to_utf8((const U8*)pv2, &cur2); @@ -6734,7 +6347,7 @@ Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2) if (PL_encoding) { svrecode = newSVpvn(pv1, cur1); sv_recode_to_utf8(svrecode, PL_encoding); - pv1 = SvPV(svrecode, cur1); + pv1 = SvPV_const(svrecode, cur1); } else { pv1 = tpv = (char*)bytes_to_utf8((const U8*)pv1, &cur1); @@ -6848,12 +6461,13 @@ Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp) mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL; if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) { - char *s, *xf; + const char *s; + char *xf; STRLEN len, xlen; if (mg) Safefree(mg->mg_ptr); - s = SvPV(sv, len); + s = SvPV_const(sv, len); if ((xf = mem_collxfrm(s, len, &xlen))) { if (SvREADONLY(sv)) { SAVEFREEPV(xf); @@ -6926,7 +6540,7 @@ Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append) sv_pos_u2b(sv,&append,0); } } else if (SvUTF8(sv)) { - SV *tsv = NEWSV(0,0); + SV * const tsv = NEWSV(0,0); sv_gets(tsv, fp, 0); sv_utf8_upgrade_nomg(tsv); SvCUR_set(sv,append); @@ -7001,7 +6615,7 @@ Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append) Perl_croak(aTHX_ "Wide character in $/"); } } - rsptr = SvPV(PL_rs, rslen); + rsptr = SvPV_const(PL_rs, rslen); } } @@ -7170,7 +6784,7 @@ thats_really_all_folks: /*The big, slow, and stupid way. */ #ifdef USE_HEAP_INSTEAD_OF_STACK /* Even slower way. */ STDCHAR *buf = 0; - New(0, buf, 8192, STDCHAR); + Newx(buf, 8192, STDCHAR); assert(buf); #else STDCHAR buf[8192]; @@ -7178,7 +6792,7 @@ thats_really_all_folks: screamer2: if (rslen) { - const register STDCHAR *bpe = buf + sizeof(buf); + register const STDCHAR *bpe = buf + sizeof(buf); bp = buf; while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe) ; /* keep reading */ @@ -7259,8 +6873,7 @@ Perl_sv_inc(pTHX_ register SV *sv) if (!sv) return; - if (SvGMAGICAL(sv)) - mg_get(sv); + SvGETMAGIC(sv); if (SvTHINKFIRST(sv)) { if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0); @@ -7313,7 +6926,7 @@ Perl_sv_inc(pTHX_ register SV *sv) if (!(flags & SVp_POK) || !*SvPVX_const(sv)) { if ((flags & SVTYPEMASK) < SVt_PVIV) - sv_upgrade(sv, SVt_IV); + sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV ? SVt_PVIV : SVt_IV)); (void)SvIOK_only(sv); SvIV_set(sv, 1); return; @@ -7415,8 +7028,7 @@ Perl_sv_dec(pTHX_ register SV *sv) if (!sv) return; - if (SvGMAGICAL(sv)) - mg_get(sv); + SvGETMAGIC(sv); if (SvTHINKFIRST(sv)) { if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0); @@ -7448,7 +7060,7 @@ Perl_sv_dec(pTHX_ register SV *sv) } else { (void)SvIOK_only_UV(sv); - SvUV_set(sv, SvUVX(sv) + 1); + SvUV_set(sv, SvUVX(sv) - 1); } } else { if (SvIVX(sv) == IV_MIN) @@ -7466,10 +7078,10 @@ Perl_sv_dec(pTHX_ register SV *sv) return; } if (!(flags & SVp_POK)) { - if ((flags & SVTYPEMASK) < SVt_PVNV) - sv_upgrade(sv, SVt_NV); - SvNV_set(sv, 1.0); - (void)SvNOK_only(sv); + if ((flags & SVTYPEMASK) < SVt_PVIV) + sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV) ? SVt_PVIV : SVt_IV); + SvIV_set(sv, -1); + (void)SvIOK_only(sv); return; } #ifdef PERL_PRESERVE_IVUV @@ -7658,8 +7270,8 @@ Perl_newSVhek(pTHX_ const HEK *hek) Andreas would like keys he put in as utf8 to come back as utf8 */ STRLEN utf8_len = HEK_LEN(hek); - U8 *as_utf8 = bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len); - SV *sv = newSVpvn ((char*)as_utf8, utf8_len); + const U8 *as_utf8 = bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len); + SV * const sv = newSVpvn ((const char*)as_utf8, utf8_len); SvUTF8_on (sv); Safefree (as_utf8); /* bytes_to_utf8() allocates a new string */ @@ -7671,7 +7283,7 @@ Perl_newSVhek(pTHX_ const HEK *hek) that would contain the (wrong) hash value, and might get passed into an hv routine with a regular hash */ - SV *sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek)); + SV * const sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek)); if (HEK_UTF8(hek)) SvUTF8_on (sv); return sv; @@ -7712,10 +7324,9 @@ Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash) if (!hash) PERL_HASH(hash, src, len); new_SV(sv); - sv_upgrade(sv, SVt_PVIV); + sv_upgrade(sv, SVt_PV); 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); @@ -7914,7 +7525,7 @@ Perl_sv_reset(pTHX_ register const char *s, HV *stash) return; if (!*s) { /* reset ?? searches */ - MAGIC *mg = mg_find((SV *)stash, PERL_MAGIC_symtab); + MAGIC * const mg = mg_find((SV *)stash, PERL_MAGIC_symtab); if (mg) { PMOP *pm = (PMOP *) mg->mg_obj; while (pm) { @@ -7954,17 +7565,21 @@ Perl_sv_reset(pTHX_ register const char *s, HV *stash) continue; gv = (GV*)HeVAL(entry); sv = GvSV(gv); - if (SvTHINKFIRST(sv)) { - if (!SvREADONLY(sv) && SvROK(sv)) - sv_unref(sv); - continue; - } - SvOK_off(sv); - if (SvTYPE(sv) >= SVt_PV) { - SvCUR_set(sv, 0); - if (SvPVX_const(sv) != Nullch) - *SvPVX(sv) = '\0'; - SvTAINT(sv); + if (sv) { + if (SvTHINKFIRST(sv)) { + if (!SvREADONLY(sv) && SvROK(sv)) + sv_unref(sv); + /* XXX Is this continue a bug? Why should THINKFIRST + exempt us from resetting arrays and hashes? */ + continue; + } + SvOK_off(sv); + if (SvTYPE(sv) >= SVt_PV) { + SvCUR_set(sv, 0); + if (SvPVX_const(sv) != Nullch) + *SvPVX(sv) = '\0'; + SvTAINT(sv); + } } if (GvAV(gv)) { av_clear(GvAV(gv)); @@ -8066,10 +7681,9 @@ Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref) goto fix_gv; default: - if (SvGMAGICAL(sv)) - mg_get(sv); + SvGETMAGIC(sv); if (SvROK(sv)) { - SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */ + SV * const *sp = &sv; /* Used in tryAMAGICunDEREF macro. */ tryAMAGICunDEREF(to_cv); sv = SvRV(sv); @@ -8130,8 +7744,8 @@ Perl_sv_true(pTHX_ register SV *sv) if (!sv) return 0; if (SvPOK(sv)) { - const register XPV* tXpv; - if ((tXpv = (XPV*)SvANY(sv)) && + register const XPV* const tXpv = (XPV*)SvANY(sv); + if (tXpv && (tXpv->xpv_cur > 1 || (tXpv->xpv_cur && *sv->sv_u.svu_pv != '0'))) return 1; @@ -8214,12 +7828,10 @@ Perl_sv_nv(pTHX_ register SV *sv) char * Perl_sv_pv(pTHX_ SV *sv) { - STRLEN n_a; - if (SvPOK(sv)) return SvPVX(sv); - return sv_2pv(sv, &n_a); + return sv_2pv(sv, 0); } /* @@ -8301,19 +7913,17 @@ Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags) STRLEN len; if (SvREADONLY(sv) && !(flags & SV_MUTABLE_RETURN)) { + const char * const ref = sv_reftype(sv,0); if (PL_op) Perl_croak(aTHX_ "Can't coerce readonly %s to string in %s", - sv_reftype(sv,0), OP_NAME(PL_op)); + ref, OP_NAME(PL_op)); else - Perl_croak(aTHX_ "Can't coerce readonly %s to string", - sv_reftype(sv,0)); + Perl_croak(aTHX_ "Can't coerce readonly %s to string", ref); } - if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) { + if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0), OP_NAME(PL_op)); - } - else - s = sv_2pv_flags(sv, &len, flags); + s = sv_2pv_flags(sv, &len, flags); if (lp) *lp = len; @@ -8322,7 +7932,7 @@ Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags) sv_unref(sv); SvUPGRADE(sv, SVt_PV); /* Never FALSE */ SvGROW(sv, len + 1); - Move(s,SvPVX_const(sv),len,char); + Move(s,SvPVX(sv),len,char); SvCUR_set(sv, len); *SvEND(sv) = '\0'; } @@ -8452,7 +8062,7 @@ 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)) { - char *name = HvNAME_get(SvSTASH(sv)); + char * const name = HvNAME_get(SvSTASH(sv)); return name ? name : (char *) "__ANON__"; } else { @@ -8504,8 +8114,7 @@ Perl_sv_isobject(pTHX_ SV *sv) { if (!sv) return 0; - if (SvGMAGICAL(sv)) - mg_get(sv); + SvGETMAGIC(sv); if (!SvROK(sv)) return 0; sv = (SV*)SvRV(sv); @@ -8530,8 +8139,7 @@ Perl_sv_isa(pTHX_ SV *sv, const char *name) const char *hvname; if (!sv) return 0; - if (SvGMAGICAL(sv)) - mg_get(sv); + SvGETMAGIC(sv); if (!SvROK(sv)) return 0; sv = (SV*)SvRV(sv); @@ -8586,7 +8194,7 @@ Perl_newSVrv(pTHX_ SV *rv, const char *classname) SvROK_on(rv); if (classname) { - HV* stash = gv_stashpv(classname, TRUE); + HV* const stash = gv_stashpv(classname, TRUE); (void)sv_bless(rv, stash); } return sv; @@ -8695,7 +8303,7 @@ Note that C copies the pointer while this copies the string. */ SV* -Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n) +Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, const char *pv, STRLEN n) { sv_setpvn(newSVrv(rv,classname), pv, n); return rv; @@ -8760,7 +8368,7 @@ S_sv_unglob(pTHX_ SV *sv) if (GvGP(sv)) gp_free((GV*)sv); if (GvSTASH(sv)) { - SvREFCNT_dec(GvSTASH(sv)); + sv_del_backref((SV*)GvSTASH(sv), sv); GvSTASH(sv) = Nullhv; } sv_unmagic(sv, PERL_MAGIC_glob); @@ -8792,24 +8400,24 @@ See C. */ void -Perl_sv_unref_flags(pTHX_ SV *sv, U32 flags) +Perl_sv_unref_flags(pTHX_ SV *ref, U32 flags) { - SV* rv = SvRV(sv); + SV* const target = SvRV(ref); - if (SvWEAKREF(sv)) { - sv_del_backref(sv); - SvWEAKREF_off(sv); - SvRV_set(sv, NULL); + if (SvWEAKREF(ref)) { + sv_del_backref(target, ref); + SvWEAKREF_off(ref); + SvRV_set(ref, NULL); return; } - SvRV_set(sv, NULL); - SvROK_off(sv); - /* You can't have a || SvREADONLY(rv) here, as $a = $$a, where $a was + SvRV_set(ref, NULL); + SvROK_off(ref); + /* You can't have a || SvREADONLY(target) here, as $a = $$a, where $a was assigned to as BEGIN {$a = \"Foo"} will fail. */ - if (SvREFCNT(rv) != 1 || (flags & SV_IMMEDIATE_UNREF)) - SvREFCNT_dec(rv); + if (SvREFCNT(target) != 1 || (flags & SV_IMMEDIATE_UNREF)) + SvREFCNT_dec(target); else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */ - sv_2mortal(rv); /* Schedule for freeing later */ + sv_2mortal(target); /* Schedule for freeing later */ } /* @@ -8853,7 +8461,7 @@ void Perl_sv_untaint(pTHX_ SV *sv) { if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { - MAGIC *mg = mg_find(sv, PERL_MAGIC_taint); + MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint); if (mg) mg->mg_len &= ~1; } @@ -8870,8 +8478,8 @@ bool Perl_sv_tainted(pTHX_ SV *sv) { if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { - MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint); - if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv))) + const MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint); + if (mg && (mg->mg_len & 1) ) return TRUE; } return FALSE; @@ -8891,7 +8499,7 @@ Perl_sv_setpviv(pTHX_ SV *sv, IV iv) { char buf[TYPE_CHARS(UV)]; char *ebuf; - char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf); + char * const ptr = uiv_2buf(buf, iv, 0, 0, &ebuf); sv_setpvn(sv, ptr, ebuf - ptr); } @@ -8909,7 +8517,7 @@ Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv) { char buf[TYPE_CHARS(UV)]; char *ebuf; - char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf); + char * const ptr = uiv_2buf(buf, iv, 0, 0, &ebuf); sv_setpvn(sv, ptr, ebuf - ptr); SvSETMAGIC(sv); @@ -9199,6 +8807,11 @@ Usually used via one of its frontends C and C. =cut */ + +#define VECTORIZE_ARGS vecsv = va_arg(*args, SV*);\ + vecstr = (U8*)SvPV_const(vecsv,veclen);\ + vec_utf8 = DO_UTF8(vecsv); + /* XXX maybe_tainted is never assigned to, so the doc above is lying. */ void @@ -9221,38 +8834,38 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV /* large enough for "%#.#f" --chip */ /* what about long double NVs? --jhi */ + PERL_UNUSED_ARG(maybe_tainted); + /* no matter what, this is a string now */ (void)SvPV_force(sv, origlen); - /* special-case "", "%s", and "%-p" (SVf) */ + /* special-case "", "%s", and "%-p" (SVf - see below) */ if (patlen == 0) return; if (patlen == 2 && pat[0] == '%' && pat[1] == 's') { - if (args) { - const char *s = va_arg(*args, char*); - sv_catpv(sv, s ? s : nullstr); - } - else if (svix < svmax) { - sv_catsv(sv, *svargs); - if (DO_UTF8(*svargs)) - SvUTF8_on(sv); - } - return; + if (args) { + const char * const s = va_arg(*args, char*); + sv_catpv(sv, s ? s : nullstr); + } + else if (svix < svmax) { + sv_catsv(sv, *svargs); + if (DO_UTF8(*svargs)) + SvUTF8_on(sv); + } + return; } - if (patlen == 3 && pat[0] == '%' && - pat[1] == '-' && pat[2] == 'p') { - if (args) { - argsv = va_arg(*args, SV*); - sv_catsv(sv, argsv); - if (DO_UTF8(argsv)) - SvUTF8_on(sv); - return; - } + if (args && patlen == 3 && pat[0] == '%' && + pat[1] == '-' && pat[2] == 'p') { + argsv = va_arg(*args, SV*); + sv_catsv(sv, argsv); + if (DO_UTF8(argsv)) + SvUTF8_on(sv); + return; } #ifndef USE_LONG_DOUBLE /* special-case "%.[gf]" */ - if ( patlen <= 5 && pat[0] == '%' && pat[1] == '.' + if ( !args && patlen <= 5 && pat[0] == '%' && pat[1] == '.' && (pat[patlen-1] == 'g' || pat[patlen-1] == 'f') ) { unsigned digits = 0; const char *pp; @@ -9263,9 +8876,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV if (pp - pat == (int)patlen - 1) { NV nv; - if (args) - nv = (NV)va_arg(*args, double); - else if (svix < svmax) + if (svix < svmax) nv = SvNV(*svargs); else return; @@ -9342,7 +8953,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV STRLEN have; STRLEN need; STRLEN gap; - const char *dotstr = "."; + const char *dotstr = "."; STRLEN dotstrlen = 1; I32 efix = 0; /* explicit format parameter index */ I32 ewix = 0; /* explicit width index */ @@ -9371,8 +8982,60 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV \d+|\*(\d+\$)? width using optional (optionally specified) arg \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg [hlqLV] size - [%bcdefginopsux_DFOUX] format (mandatory) + [%bcdefginopsuxDFOUX] format (mandatory) +*/ + + if (args) { +/* + As of perl5.9.3, printf format checking is on by default. + Internally, perl uses %p formats to provide an escape to + some extended formatting. This block deals with those + extensions: if it does not match, (char*)q is reset and + the normal format processing code is used. + + Currently defined extensions are: + %p include pointer address (standard) + %-p (SVf) include an SV (previously %_) + %-p include an SV with precision + %1p (VDf) include a v-string (as %vd) + %p reserved for future extensions + + Robin Barker 2005-07-14 */ + char* r = q; + bool sv = FALSE; + STRLEN n = 0; + if (*q == '-') + sv = *q++; + EXPECT_NUMBER(q, n); + if (*q++ == 'p') { + if (sv) { /* SVf */ + if (n) { + precis = n; + has_precis = TRUE; + } + argsv = va_arg(*args, SV*); + eptr = SvPVx_const(argsv, elen); + if (DO_UTF8(argsv)) + is_utf8 = TRUE; + goto string; + } +#if vdNUMBER + else if (n == vdNUMBER) { /* VDf */ + vectorize = TRUE; + VECTORIZE_ARGS + goto format_vd; + } +#endif + else if (n) { + if (ckWARN_d(WARN_INTERNAL)) + Perl_warner(aTHX_ packWARN(WARN_INTERNAL), + "internal %%p might conflict with future printf extensions"); + } + } + q = r; + } + if (EXPECT_NUMBER(q, width)) { if (*q == '$') { ++q; @@ -9433,9 +9096,11 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV } if (!asterisk) + { if( *q == '0' ) fill = *q++; EXPECT_NUMBER(q, width); + } if (vectorize) { if (vectorarg) { @@ -9449,9 +9114,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV is_utf8 = TRUE; } if (args) { - vecsv = va_arg(*args, SV*); - vecstr = (U8*)SvPV_const(vecsv,veclen); - vec_utf8 = DO_UTF8(vecsv); + VECTORIZE_ARGS } else if (efix ? efix <= svmax : svix < svmax) { vecsv = svargs[efix ? efix-1 : svix++]; @@ -9635,21 +9298,6 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV /* INTEGERS */ case 'p': - if (left && args) { /* SVf */ - left = FALSE; - if (width) { - precis = width; - has_precis = TRUE; - width = 0; - } - if (vectorize) - goto unknown; - argsv = va_arg(*args, SV*); - eptr = SvPVx_const(argsv, elen); - if (DO_UTF8(argsv)) - is_utf8 = TRUE; - goto string; - } if (alt || vectorize) goto unknown; uv = PTR2UV(args ? va_arg(*args, void*) : argsv); @@ -9665,6 +9313,9 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV /* FALL THROUGH */ case 'd': case 'i': +#if vdNUMBER + format_vd: +#endif if (vectorize) { STRLEN ulen; if (!veclen) @@ -9981,7 +9632,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV if (PL_efloatsize < need) { Safefree(PL_efloatbuf); PL_efloatsize = need + 20; /* more fudge */ - New(906, PL_efloatbuf, PL_efloatsize, char); + Newx(PL_efloatbuf, PL_efloatsize, char); PL_efloatbuf[0] = '\0'; } @@ -10073,8 +9724,10 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV default: unknown: - if (!args && ckWARN(WARN_PRINTF) && - (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) { + if (!args + && (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF) + && ckWARN(WARN_PRINTF)) + { SV *msg = sv_newmortal(); Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ", (PL_op->op_type == OP_PRTF) ? "" : "s"); @@ -10117,9 +9770,9 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV sv_utf8_upgrade(sv); } else { - SV *nsv = sv_2mortal(newSVpvn(eptr, elen)); + SV * const nsv = sv_2mortal(newSVpvn(eptr, elen)); sv_utf8_upgrade(nsv); - eptr = SvPVX(nsv); + eptr = SvPVX_const(nsv); elen = SvCUR(nsv); } SvGROW(sv, SvCUR(sv) + elen + 1); @@ -10133,6 +9786,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1); p = SvEND(sv); if (esignlen && fill == '0') { + int i; for (i = 0; i < (int)esignlen; i++) *p++ = esignbuf[i]; } @@ -10141,10 +9795,12 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV p += gap; } if (esignlen && fill != '0') { + int i; for (i = 0; i < (int)esignlen; i++) *p++ = esignbuf[i]; } if (zeros) { + int i; for (i = zeros; i; i--) *p++ = '0'; } @@ -10220,7 +9876,7 @@ ptr_table_* functions. regcomp.c. AMS 20010712 */ REGEXP * -Perl_re_dup(pTHX_ REGEXP *r, CLONE_PARAMS *param) +Perl_re_dup(pTHX_ const REGEXP *r, CLONE_PARAMS *param) { dVAR; REGEXP *ret; @@ -10236,15 +9892,15 @@ Perl_re_dup(pTHX_ REGEXP *r, CLONE_PARAMS *param) len = r->offsets[0]; npar = r->nparens+1; - Newc(0, ret, sizeof(regexp) + (len+1)*sizeof(regnode), char, regexp); + Newxc(ret, sizeof(regexp) + (len+1)*sizeof(regnode), char, regexp); Copy(r->program, ret->program, len+1, regnode); - New(0, ret->startp, npar, I32); + Newx(ret->startp, npar, I32); Copy(r->startp, ret->startp, npar, I32); - New(0, ret->endp, npar, I32); + Newx(ret->endp, npar, I32); Copy(r->startp, ret->startp, npar, I32); - New(0, ret->substrs, 1, struct reg_substr_data); + Newx(ret->substrs, 1, struct reg_substr_data); for (s = ret->substrs->data, i = 0; i < 3; i++, s++) { s->min_offset = r->substrs->data[i].min_offset; s->max_offset = r->substrs->data[i].max_offset; @@ -10256,10 +9912,11 @@ Perl_re_dup(pTHX_ REGEXP *r, CLONE_PARAMS *param) if (r->data) { struct reg_data *d; const int count = r->data->count; + int i; - Newc(0, d, sizeof(struct reg_data) + count*sizeof(void *), + Newxc(d, sizeof(struct reg_data) + count*sizeof(void *), char, struct reg_data); - New(0, d->what, count, U8); + Newx(d->what, count, U8); d->count = count; for (i = 0; i < count; i++) { @@ -10275,7 +9932,7 @@ Perl_re_dup(pTHX_ REGEXP *r, CLONE_PARAMS *param) break; case 'f': /* This is cheating. */ - New(0, d->data[i], 1, struct regnode_charclass_class); + Newx(d->data[i], 1, struct regnode_charclass_class); StructCopy(r->data->data[i], d->data[i], struct regnode_charclass_class); ret->regstclass = (regnode*)d->data[i]; @@ -10306,7 +9963,7 @@ Perl_re_dup(pTHX_ REGEXP *r, CLONE_PARAMS *param) else ret->data = NULL; - New(0, ret->offsets, 2*len+1, U32); + Newx(ret->offsets, 2*len+1, U32); Copy(r->offsets, ret->offsets, 2*len+1, U32); ret->precomp = SAVEPVN(r->precomp, r->prelen); @@ -10338,7 +9995,8 @@ PerlIO * Perl_fp_dup(pTHX_ PerlIO *fp, char type, CLONE_PARAMS *param) { PerlIO *ret; - (void)type; + + PERL_UNUSED_ARG(type); if (!fp) return (PerlIO*)NULL; @@ -10379,7 +10037,7 @@ Perl_gp_dup(pTHX_ GP *gp, CLONE_PARAMS* param) return ret; /* create anew and remember what it is */ - Newz(0, ret, 1, GP); + Newxz(ret, 1, GP); ptr_table_store(PL_ptr_table, gp, ret); /* clone */ @@ -10392,7 +10050,6 @@ Perl_gp_dup(pTHX_ GP *gp, CLONE_PARAMS* param) ret->gp_egv = gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */ ret->gp_cv = cv_dup_inc(gp->gp_cv, param); ret->gp_cvgen = gp->gp_cvgen; - ret->gp_flags = gp->gp_flags; ret->gp_line = gp->gp_line; ret->gp_file = gp->gp_file; /* points to COP.cop_file */ return ret; @@ -10414,7 +10071,7 @@ Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS* param) for (; mg; mg = mg->mg_moremagic) { MAGIC *nmg; - Newz(0, nmg, 1, MAGIC); + Newxz(nmg, 1, MAGIC); if (mgprev) mgprev->mg_moremagic = nmg; else @@ -10478,10 +10135,10 @@ PTR_TBL_t * Perl_ptr_table_new(pTHX) { PTR_TBL_t *tbl; - Newz(0, tbl, 1, PTR_TBL_t); + Newxz(tbl, 1, PTR_TBL_t); tbl->tbl_max = 511; tbl->tbl_items = 0; - Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*); + Newxz(tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*); return tbl; } @@ -10491,48 +10148,12 @@ Perl_ptr_table_new(pTHX) # define PTR_TABLE_HASH(ptr) (PTR2UV(ptr) >> 2) #endif - - -STATIC void -S_more_pte(pTHX) -{ - struct ptr_tbl_ent* pte; - struct ptr_tbl_ent* pteend; - New(0, pte, PERL_ARENA_SIZE/sizeof(struct ptr_tbl_ent), struct ptr_tbl_ent); - pte->next = PL_pte_arenaroot; - PL_pte_arenaroot = pte; - - pteend = &pte[PERL_ARENA_SIZE / sizeof(struct ptr_tbl_ent) - 1]; - PL_pte_root = ++pte; - while (pte < pteend) { - pte->next = pte + 1; - pte++; - } - pte->next = 0; -} - -STATIC struct ptr_tbl_ent* -S_new_pte(pTHX) -{ - struct ptr_tbl_ent* pte; - if (!PL_pte_root) - S_more_pte(aTHX); - pte = PL_pte_root; - PL_pte_root = pte->next; - return pte; -} - -STATIC void -S_del_pte(pTHX_ struct ptr_tbl_ent*p) -{ - p->next = PL_pte_root; - PL_pte_root = p; -} +#define del_pte(p) del_body_type(p, struct ptr_tbl_ent, pte) /* map an existing pointer using a table */ void * -Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv) +Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, const void *sv) { PTR_TBL_ENT_t *tblent; const UV hash = PTR_TABLE_HASH(sv); @@ -10548,26 +10169,27 @@ Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv) /* add a new entry to a pointer-mapping table */ void -Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv) +Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, const void *oldsv, void *newsv) { PTR_TBL_ENT_t *tblent, **otblent; /* XXX this may be pessimal on platforms where pointers aren't good * hash values e.g. if they grow faster in the most significant * bits */ - const UV hash = PTR_TABLE_HASH(oldv); + const UV hash = PTR_TABLE_HASH(oldsv); bool empty = 1; assert(tbl); otblent = &tbl->tbl_ary[hash & tbl->tbl_max]; for (tblent = *otblent; tblent; empty=0, tblent = tblent->next) { - if (tblent->oldval == oldv) { - tblent->newval = newv; + if (tblent->oldval == oldsv) { + tblent->newval = newsv; return; } } - tblent = S_new_pte(aTHX); - tblent->oldval = oldv; - tblent->newval = newv; + new_body_inline(tblent, (void**)&PL_pte_arenaroot, (void**)&PL_pte_root, + sizeof(struct ptr_tbl_ent)); + tblent->oldval = oldsv; + tblent->newval = newsv; tblent->next = *otblent; *otblent = tblent; tbl->tbl_items++; @@ -10629,7 +10251,7 @@ Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl) if (entry) { PTR_TBL_ENT_t *oentry = entry; entry = entry->next; - S_del_pte(aTHX_ oentry); + del_pte(oentry); } if (!entry) { if (++riter > max) { @@ -10655,64 +10277,6 @@ Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl) Safefree(tbl); } -/* attempt to make everything in the typeglob readonly */ - -STATIC SV * -S_gv_share(pTHX_ SV *sstr, CLONE_PARAMS *param) -{ - GV *gv = (GV*)sstr; - SV *sv = ¶m->proto_perl->Isv_no; /* just need SvREADONLY-ness */ - - if (GvIO(gv) || GvFORM(gv)) { - GvUNIQUE_off(gv); /* GvIOs cannot be shared. nor can GvFORMs */ - } - else if (!GvCV(gv)) { - GvCV(gv) = (CV*)sv; - } - else { - /* CvPADLISTs cannot be shared */ - if (!SvREADONLY(GvCV(gv)) && !CvXSUB(GvCV(gv))) { - GvUNIQUE_off(gv); - } - } - - if (!GvUNIQUE(gv)) { -#if 0 - PerlIO_printf(Perl_debug_log, "gv_share: unable to share %s::%s\n", - HvNAME_get(GvSTASH(gv)), GvNAME(gv)); -#endif - return Nullsv; - } - - /* - * write attempts will die with - * "Modification of a read-only value attempted" - */ - if (!GvSV(gv)) { - GvSV(gv) = sv; - } - else { - SvREADONLY_on(GvSV(gv)); - } - - if (!GvAV(gv)) { - GvAV(gv) = (AV*)sv; - } - else { - SvREADONLY_on(GvAV(gv)); - } - - if (!GvHV(gv)) { - GvHV(gv) = (HV*)sv; - } - else { - SvREADONLY_on(GvHV(gv)); - } - - return sstr; /* he_dup() will SvREFCNT_inc() */ -} - -/* duplicate an SV of any type (including AV, HV etc) */ void Perl_rvpv_dup(pTHX_ SV *dstr, SV *sstr, CLONE_PARAMS* param) @@ -10737,22 +10301,11 @@ Perl_rvpv_dup(pTHX_ SV *dstr, SV *sstr, CLONE_PARAMS* param) } else { /* Special case - not normally malloced for some reason */ - if (SvREADONLY(sstr) && SvFAKE(sstr)) { - /* A "shared" PV - clone it as unshared string */ - if(SvPADTMP(sstr)) { - /* However, some of them live in the pad - and they should not have these flags - turned off */ - - SvPV_set(dstr, sharepvn(SvPVX_const(sstr), SvCUR(sstr), - SvUVX(sstr))); - SvUV_set(dstr, SvUVX(sstr)); - } else { - - SvPV_set(dstr, SAVEPVN(SvPVX_const(sstr), SvCUR(sstr))); - SvFAKE_off(dstr); - SvREADONLY_off(dstr); - } + if ((SvREADONLY(sstr) && SvFAKE(sstr))) { + /* A "shared" PV - clone it as "shared" PV */ + SvPV_set(dstr, + HEK_KEY(hek_dup(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)), + param))); } else { /* Some other special case - random pointer */ @@ -10769,6 +10322,8 @@ Perl_rvpv_dup(pTHX_ SV *dstr, SV *sstr, CLONE_PARAMS* param) } } +/* duplicate an SV of any type (including AV, HV etc) */ + SV * Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param) { @@ -10790,8 +10345,7 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param) if(SvTYPE(sstr) == SVt_PVHV && (hvname = HvNAME_get(sstr))) { /** don't clone stashes if they already exist **/ - HV* old_stash = gv_stashpv(hvname,0); - return (SV*) old_stash; + return (SV*)gv_stashpv(hvname,0); } } @@ -10846,271 +10400,284 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param) SvANY(dstr) = &(dstr->sv_u.svu_rv); Perl_rvpv_dup(aTHX_ dstr, sstr, param); break; - case SVt_PV: - SvANY(dstr) = new_XPV(); - 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_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_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_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_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); - BmPREVIOUS(dstr)= BmPREVIOUS(sstr); - break; - case SVt_PVLV: - SvANY(dstr) = new_XPVLV(); - 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); - if (LvTYPE(sstr) == 't') /* for tie: unrefcnted fake (SV**) */ - LvTARG(dstr) = dstr; - else if (LvTYPE(sstr) == 'T') /* for tie: fake HE */ - LvTARG(dstr) = (SV*)he_dup((HE*)LvTARG(sstr), 0, param); - else - LvTARG(dstr) = sv_dup_inc(LvTARG(sstr), param); - LvTYPE(dstr) = LvTYPE(sstr); - break; - case SVt_PVGV: - if (GvUNIQUE((GV*)sstr)) { - SV *share; - if ((share = gv_share(sstr, param))) { - del_SV(dstr); - dstr = share; - ptr_table_store(PL_ptr_table, sstr, dstr); -#if 0 - PerlIO_printf(Perl_debug_log, "sv_dup: sharing %s::%s\n", - HvNAME_get(GvSTASH(share)), GvNAME(share)); + default: + { + /* These are all the types that need complex bodies allocating. */ + size_t new_body_length; + size_t new_body_offset = 0; + void **new_body_arena; + void **new_body_arenaroot; + void *new_body; + + switch (SvTYPE(sstr)) { + default: + Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]", + (IV)SvTYPE(sstr)); + break; + + case SVt_PVIO: + new_body = new_XPVIO(); + new_body_length = sizeof(XPVIO); + break; + case SVt_PVFM: + new_body = new_XPVFM(); + new_body_length = sizeof(XPVFM); + break; + + case SVt_PVHV: + new_body_arena = (void **) &PL_xpvhv_root; + new_body_arenaroot = (void **) &PL_xpvhv_arenaroot; + new_body_offset = STRUCT_OFFSET(XPVHV, xhv_fill) + - STRUCT_OFFSET(xpvhv_allocated, xhv_fill); + new_body_length = STRUCT_OFFSET(XPVHV, xmg_stash) + + sizeof (((XPVHV*)SvANY(sstr))->xmg_stash) + - new_body_offset; + goto new_body; + case SVt_PVAV: + new_body_arena = (void **) &PL_xpvav_root; + new_body_arenaroot = (void **) &PL_xpvav_arenaroot; + new_body_offset = STRUCT_OFFSET(XPVAV, xav_fill) + - STRUCT_OFFSET(xpvav_allocated, xav_fill); + new_body_length = STRUCT_OFFSET(XPVHV, xmg_stash) + + sizeof (((XPVHV*)SvANY(sstr))->xmg_stash) + - new_body_offset; + goto new_body; + case SVt_PVBM: + new_body_length = sizeof(XPVBM); + new_body_arena = (void **) &PL_xpvbm_root; + new_body_arenaroot = (void **) &PL_xpvbm_arenaroot; + goto new_body; + case SVt_PVGV: + if (GvUNIQUE((GV*)sstr)) { + /* Do sharing here. */ + } + new_body_length = sizeof(XPVGV); + new_body_arena = (void **) &PL_xpvgv_root; + new_body_arenaroot = (void **) &PL_xpvgv_arenaroot; + goto new_body; + case SVt_PVCV: + new_body_length = sizeof(XPVCV); + new_body_arena = (void **) &PL_xpvcv_root; + new_body_arenaroot = (void **) &PL_xpvcv_arenaroot; + goto new_body; + case SVt_PVLV: + new_body_length = sizeof(XPVLV); + new_body_arena = (void **) &PL_xpvlv_root; + new_body_arenaroot = (void **) &PL_xpvlv_arenaroot; + goto new_body; + case SVt_PVMG: + new_body_length = sizeof(XPVMG); + new_body_arena = (void **) &PL_xpvmg_root; + new_body_arenaroot = (void **) &PL_xpvmg_arenaroot; + goto new_body; + case SVt_PVNV: + new_body_length = sizeof(XPVNV); + new_body_arena = (void **) &PL_xpvnv_root; + new_body_arenaroot = (void **) &PL_xpvnv_arenaroot; + goto new_body; + case SVt_PVIV: + new_body_offset = STRUCT_OFFSET(XPVIV, xpv_cur) + - STRUCT_OFFSET(xpviv_allocated, xpv_cur); + new_body_length = sizeof(XPVIV) - new_body_offset; + new_body_arena = (void **) &PL_xpviv_root; + new_body_arenaroot = (void **) &PL_xpviv_arenaroot; + goto new_body; + case SVt_PV: + new_body_offset = STRUCT_OFFSET(XPV, xpv_cur) + - STRUCT_OFFSET(xpv_allocated, xpv_cur); + new_body_length = sizeof(XPV) - new_body_offset; + new_body_arena = (void **) &PL_xpv_root; + new_body_arenaroot = (void **) &PL_xpv_arenaroot; + new_body: + assert(new_body_length); +#ifndef PURIFY + new_body_inline(new_body, new_body_arenaroot, new_body_arena, + new_body_length); + new_body = (void*)((char*)new_body - new_body_offset); +#else + /* We always allocated the full length item with PURIFY */ + new_body_length += new_body_offset; + new_body_offset = 0; + new_body = my_safemalloc(new_body_length); #endif - break; - } - } - SvANY(dstr) = new_XPVGV(); - 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)); - GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr), param); - GvFLAGS(dstr) = GvFLAGS(sstr); - GvGP(dstr) = gp_dup(GvGP(sstr), param); - (void)GpREFCNT_inc(GvGP(dstr)); - break; - case SVt_PVIO: - SvANY(dstr) = new_XPVIO(); - 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)) - IoOFP(dstr) = IoIFP(dstr); - else - IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr), param); - /* PL_rsfp_filters entries have fake IoDIRP() */ - if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP)) - IoDIRP(dstr) = dirp_dup(IoDIRP(sstr)); - else - IoDIRP(dstr) = IoDIRP(sstr); - IoLINES(dstr) = IoLINES(sstr); - IoPAGE(dstr) = IoPAGE(sstr); - IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr); - IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr); - 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*/ - IoTOP_GV(dstr) = gv_dup_inc(IoTOP_GV(sstr), param); - IoFMT_GV(dstr) = gv_dup_inc(IoFMT_GV(sstr), param); - IoBOTTOM_GV(dstr) = gv_dup_inc(IoBOTTOM_GV(sstr), param); - } else { - IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr), param); - IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr), param); - IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr), param); - } - IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr)); - IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr)); - IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr)); - IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr); - IoTYPE(dstr) = IoTYPE(sstr); - IoFLAGS(dstr) = IoFLAGS(sstr); - break; - case SVt_PVAV: - SvANY(dstr) = new_XPVAV(); - SvCUR_set(dstr, SvCUR(sstr)); - SvLEN_set(dstr, SvLEN(sstr)); - SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param)); - SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param)); - if (AvARRAY((AV*)sstr)) { - SV **dst_ary, **src_ary; - SSize_t items = AvFILLp((AV*)sstr) + 1; - - src_ary = AvARRAY((AV*)sstr); - Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*); - ptr_table_store(PL_ptr_table, src_ary, dst_ary); - SvPV_set(dstr, (char*)dst_ary); - AvALLOC((AV*)dstr) = dst_ary; - if (AvREAL((AV*)sstr)) { - while (items-- > 0) - *dst_ary++ = sv_dup_inc(*src_ary++, param); - } - else { - while (items-- > 0) - *dst_ary++ = sv_dup(*src_ary++, param); } - items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr); - while (items-- > 0) { - *dst_ary++ = &PL_sv_undef; + assert(new_body); + SvANY(dstr) = new_body; + + Copy(((char*)SvANY(sstr)) + new_body_offset, + ((char*)SvANY(dstr)) + new_body_offset, + new_body_length, char); + + if (SvTYPE(sstr) != SVt_PVAV && SvTYPE(sstr) != SVt_PVHV) + Perl_rvpv_dup(aTHX_ dstr, sstr, param); + + /* The Copy above means that all the source (unduplicated) pointers + are now in the destination. We can check the flags and the + pointers in either, but it's possible that there's less cache + missing by always going for the destination. + FIXME - instrument and check that assumption */ + if (SvTYPE(sstr) >= SVt_PVMG) { + if (SvMAGIC(dstr)) + SvMAGIC_set(dstr, mg_dup(SvMAGIC(dstr), param)); + if (SvSTASH(dstr)) + SvSTASH_set(dstr, hv_dup_inc(SvSTASH(dstr), param)); } - } - else { - SvPV_set(dstr, Nullch); - AvALLOC((AV*)dstr) = (SV**)NULL; - } - break; - case SVt_PVHV: - SvANY(dstr) = new_XPVHV(); - SvCUR_set(dstr, SvCUR(sstr)); - SvLEN_set(dstr, SvLEN(sstr)); - HvTOTALKEYS(dstr) = HvTOTALKEYS(sstr); - SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param)); - SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param)); - { - HEK *hvname = 0; - - if (HvARRAY((HV*)sstr)) { - STRLEN i = 0; - const bool sharekeys = !!HvSHAREKEYS(sstr); - XPVHV * const dxhv = (XPVHV*)SvANY(dstr); - XPVHV * const sxhv = (XPVHV*)SvANY(sstr); - char *darray; - New(0, darray, - PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1) - + (SvOOK(sstr) ? sizeof(struct xpvhv_aux) : 0), char); - HvARRAY(dstr) = (HE**)darray; - while (i <= sxhv->xhv_max) { - HE *source = HvARRAY(sstr)[i]; - HvARRAY(dstr)[i] - = source ? he_dup(source, sharekeys, param) : 0; - ++i; + + switch (SvTYPE(sstr)) { + case SVt_PV: + break; + case SVt_PVIV: + break; + case SVt_PVNV: + break; + case SVt_PVMG: + break; + case SVt_PVBM: + break; + case SVt_PVLV: + /* XXX LvTARGOFF sometimes holds PMOP* when DEBUGGING */ + if (LvTYPE(dstr) == 't') /* for tie: unrefcnted fake (SV**) */ + LvTARG(dstr) = dstr; + else if (LvTYPE(dstr) == 'T') /* for tie: fake HE */ + LvTARG(dstr) = (SV*)he_dup((HE*)LvTARG(dstr), 0, param); + else + LvTARG(dstr) = sv_dup_inc(LvTARG(dstr), param); + break; + case SVt_PVGV: + GvNAME(dstr) = SAVEPVN(GvNAME(dstr), GvNAMELEN(dstr)); + GvSTASH(dstr) = hv_dup(GvSTASH(dstr), param); + /* Don't call sv_add_backref here as it's going to be created + as part of the magic cloning of the symbol table. */ + GvGP(dstr) = gp_dup(GvGP(dstr), param); + (void)GpREFCNT_inc(GvGP(dstr)); + break; + case SVt_PVIO: + IoIFP(dstr) = fp_dup(IoIFP(dstr), IoTYPE(dstr), param); + if (IoOFP(dstr) == IoIFP(sstr)) + IoOFP(dstr) = IoIFP(dstr); + else + IoOFP(dstr) = fp_dup(IoOFP(dstr), IoTYPE(dstr), param); + /* PL_rsfp_filters entries have fake IoDIRP() */ + if (IoDIRP(dstr) && !(IoFLAGS(dstr) & IOf_FAKE_DIRP)) + IoDIRP(dstr) = dirp_dup(IoDIRP(dstr)); + if(IoFLAGS(dstr) & IOf_FAKE_DIRP) { + /* I have no idea why fake dirp (rsfps) + should be treated differently but otherwise + we end up with leaks -- sky*/ + IoTOP_GV(dstr) = gv_dup_inc(IoTOP_GV(dstr), param); + IoFMT_GV(dstr) = gv_dup_inc(IoFMT_GV(dstr), param); + IoBOTTOM_GV(dstr) = gv_dup_inc(IoBOTTOM_GV(dstr), param); + } else { + IoTOP_GV(dstr) = gv_dup(IoTOP_GV(dstr), param); + IoFMT_GV(dstr) = gv_dup(IoFMT_GV(dstr), param); + IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(dstr), param); } - if (SvOOK(sstr)) { - struct xpvhv_aux *saux = HvAUX(sstr); - struct xpvhv_aux *daux = HvAUX(dstr); - /* This flag isn't copied. */ - /* SvOOK_on(hv) attacks the IV flags. */ - SvFLAGS(dstr) |= SVf_OOK; - - hvname = saux->xhv_name; - daux->xhv_name = hvname ? hek_dup(hvname, param) : hvname; - - daux->xhv_riter = saux->xhv_riter; - daux->xhv_eiter = saux->xhv_eiter - ? he_dup(saux->xhv_eiter, (bool)!!HvSHAREKEYS(sstr), - param) : 0; + IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(dstr)); + IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(dstr)); + IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(dstr)); + break; + case SVt_PVAV: + if (AvARRAY((AV*)sstr)) { + SV **dst_ary, **src_ary; + SSize_t items = AvFILLp((AV*)sstr) + 1; + + src_ary = AvARRAY((AV*)sstr); + Newxz(dst_ary, AvMAX((AV*)sstr)+1, SV*); + ptr_table_store(PL_ptr_table, src_ary, dst_ary); + SvPV_set(dstr, (char*)dst_ary); + AvALLOC((AV*)dstr) = dst_ary; + if (AvREAL((AV*)sstr)) { + while (items-- > 0) + *dst_ary++ = sv_dup_inc(*src_ary++, param); + } + else { + while (items-- > 0) + *dst_ary++ = sv_dup(*src_ary++, param); + } + items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr); + while (items-- > 0) { + *dst_ary++ = &PL_sv_undef; + } } + else { + SvPV_set(dstr, Nullch); + AvALLOC((AV*)dstr) = (SV**)NULL; + } + break; + case SVt_PVHV: + { + HEK *hvname = 0; + + if (HvARRAY((HV*)sstr)) { + STRLEN i = 0; + const bool sharekeys = !!HvSHAREKEYS(sstr); + XPVHV * const dxhv = (XPVHV*)SvANY(dstr); + XPVHV * const sxhv = (XPVHV*)SvANY(sstr); + char *darray; + Newx(darray, PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1) + + (SvOOK(sstr) ? sizeof(struct xpvhv_aux) : 0), + char); + HvARRAY(dstr) = (HE**)darray; + while (i <= sxhv->xhv_max) { + const HE *source = HvARRAY(sstr)[i]; + HvARRAY(dstr)[i] = source + ? he_dup(source, sharekeys, param) : 0; + ++i; + } + if (SvOOK(sstr)) { + struct xpvhv_aux *saux = HvAUX(sstr); + struct xpvhv_aux *daux = HvAUX(dstr); + /* This flag isn't copied. */ + /* SvOOK_on(hv) attacks the IV flags. */ + SvFLAGS(dstr) |= SVf_OOK; + + hvname = saux->xhv_name; + daux->xhv_name + = hvname ? hek_dup(hvname, param) : hvname; + + daux->xhv_riter = saux->xhv_riter; + daux->xhv_eiter = saux->xhv_eiter + ? he_dup(saux->xhv_eiter, + (bool)!!HvSHAREKEYS(sstr), param) : 0; + } + } + else { + SvPV_set(dstr, Nullch); + } + /* Record stashes for possible cloning in Perl_clone(). */ + if(hvname) + av_push(param->stashes, dstr); + } + break; + case SVt_PVFM: + case SVt_PVCV: + /* NOTE: not refcounted */ + CvSTASH(dstr) = hv_dup(CvSTASH(dstr), param); + OP_REFCNT_LOCK; + CvROOT(dstr) = OpREFCNT_inc(CvROOT(dstr)); + OP_REFCNT_UNLOCK; + if (CvCONST(dstr)) { + CvXSUBANY(dstr).any_ptr = GvUNIQUE(CvGV(dstr)) ? + SvREFCNT_inc(CvXSUBANY(dstr).any_ptr) : + sv_dup_inc((SV *)CvXSUBANY(dstr).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 */ + CvGV(dstr) = (param->flags & CLONEf_JOIN_IN) ? + Nullgv : gv_dup(CvGV(dstr), param) ; + if (!(param->flags & CLONEf_COPY_STACKS)) { + CvDEPTH(dstr) = 0; + } + PAD_DUP(CvPADLIST(dstr), CvPADLIST(sstr), param); + CvOUTSIDE(dstr) = + CvWEAKOUTSIDE(sstr) + ? cv_dup( CvOUTSIDE(dstr), param) + : cv_dup_inc(CvOUTSIDE(dstr), param); + if (!CvXSUB(dstr)) + CvFILE(dstr) = SAVEPV(CvFILE(dstr)); + break; } - else { - SvPV_set(dstr, Nullch); - } - /* Record stashes for possible cloning in Perl_clone(). */ - if(hvname) - av_push(param->stashes, dstr); } - break; - case SVt_PVFM: - SvANY(dstr) = new_XPVFM(); - FmLINES(dstr) = FmLINES(sstr); - goto dup_pvcv; - /* NOTREACHED */ - case SVt_PVCV: - SvANY(dstr) = new_XPVCV(); - dup_pvcv: - 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((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 */ - CvGV(dstr) = (param->flags & CLONEf_JOIN_IN) ? - Nullgv : gv_dup(CvGV(sstr), param) ; - if (param->flags & CLONEf_COPY_STACKS) { - CvDEPTH(dstr) = CvDEPTH(sstr); - } else { - CvDEPTH(dstr) = 0; - } - PAD_DUP(CvPADLIST(dstr), CvPADLIST(sstr), param); - CvOUTSIDE_SEQ(dstr) = CvOUTSIDE_SEQ(sstr); - CvOUTSIDE(dstr) = - CvWEAKOUTSIDE(sstr) - ? cv_dup( CvOUTSIDE(sstr), param) - : cv_dup_inc(CvOUTSIDE(sstr), param); - CvFLAGS(dstr) = CvFLAGS(sstr); - CvFILE(dstr) = CvXSUB(sstr) ? CvFILE(sstr) : SAVEPV(CvFILE(sstr)); - break; - default: - Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]", (IV)SvTYPE(sstr)); - break; } if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO) @@ -11135,7 +10702,7 @@ Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param) return ncxs; /* create anew and remember what it is */ - Newz(56, ncxs, max + 1, PERL_CONTEXT); + Newxz(ncxs, max + 1, PERL_CONTEXT); ptr_table_store(PL_ptr_table, cxs, ncxs); while (ix >= 0) { @@ -11225,7 +10792,7 @@ Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param) return nsi; /* create anew and remember what it is */ - Newz(56, nsi, 1, PERL_SI); + Newxz(nsi, 1, PERL_SI); ptr_table_store(PL_ptr_table, si, nsi); nsi->si_stack = av_dup_inc(si->si_stack, param); @@ -11265,7 +10832,7 @@ Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param) */ void * -Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl) +Perl_any_dup(pTHX_ void *v, const PerlInterpreter *proto_perl) { void *ret; @@ -11292,9 +10859,9 @@ Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl) ANY * Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) { - ANY *ss = proto_perl->Tsavestack; - I32 ix = proto_perl->Tsavestack_ix; - I32 max = proto_perl->Tsavestack_max; + ANY * const ss = proto_perl->Tsavestack; + const I32 max = proto_perl->Tsavestack_max; + I32 ix = proto_perl->Tsavestack_ix; ANY *nss; SV *sv; GV *gv; @@ -11308,9 +10875,8 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) char *c = NULL; void (*dptr) (void*); void (*dxptr) (pTHX_ void*); - OP *o; - Newz(54, nss, max, ANY); + Newxz(nss, max, ANY); while (ix > 0) { I32 i = POPINT(ss,ix); @@ -11441,6 +11007,7 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) ptr = POPPTR(ss,ix); if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) { /* these are assumed to be refcounted properly */ + OP *o; switch (((OP*)ptr)->op_type) { case OP_LEAVESUB: case OP_LEAVESUBLV: @@ -11568,9 +11135,9 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) static void do_mark_cloneable_stash(pTHX_ SV *sv) { - const HEK *hvname = HvNAME_HEK((HV*)sv); + const HEK * const hvname = HvNAME_HEK((HV*)sv); if (hvname) { - GV* cloner = gv_fetchmethod_autoload((HV*)sv, "CLONE_SKIP", 0); + GV* const cloner = gv_fetchmethod_autoload((HV*)sv, "CLONE_SKIP", 0); SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */ if (cloner && GvCV(cloner)) { dSP; @@ -11784,8 +11351,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, /* create SV map for pointer relocation */ PL_ptr_table = ptr_table_new(); - /* and one for finding shared hash keys quickly */ - PL_shared_hek_table = ptr_table_new(); /* initialize these special pointers as early as possible */ SvANY(&PL_sv_undef) = NULL; @@ -11843,6 +11408,10 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, param->stashes = newAV(); /* Setup array of objects to call clone on */ + /* Set tainting stuff before PerlIO_debug can possibly get called */ + PL_tainting = proto_perl->Itainting; + PL_taint_warn = proto_perl->Itaint_warn; + #ifdef PERLIO_LAYERS /* Clone PerlIO tables as soon as we can handle general xx_dup() */ PerlIO_clone(aTHX_ proto_perl, param); @@ -11887,6 +11456,8 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_statusvalue = proto_perl->Istatusvalue; #ifdef VMS PL_statusvalue_vms = proto_perl->Istatusvalue_vms; +#else + PL_statusvalue_posix = proto_perl->Istatusvalue_posix; #endif PL_encoding = sv_dup(proto_perl->Iencoding, param); @@ -11898,7 +11469,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_regex_padav = newAV(); { const I32 len = av_len((AV*)proto_perl->Iregex_padav); - SV** regexen = AvARRAY((AV*)proto_perl->Iregex_padav); + SV** const regexen = AvARRAY((AV*)proto_perl->Iregex_padav); IV i; av_push(PL_regex_padav, sv_dup_inc(regexen[0],param)); @@ -11964,8 +11535,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_fdpid = av_dup_inc(proto_perl->Ifdpid, param); /* internal state */ - PL_tainting = proto_perl->Itainting; - PL_taint_warn = proto_perl->Itaint_warn; PL_maxo = proto_perl->Imaxo; if (proto_perl->Iop_mask) PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo); @@ -11997,12 +11566,11 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_mess_sv = Nullsv; PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv, param); - PL_ofmt = SAVEPV(proto_perl->Iofmt); /* interpreter atexit processing */ PL_exitlistlen = proto_perl->Iexitlistlen; if (PL_exitlistlen) { - New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry); + Newx(PL_exitlist, PL_exitlistlen, PerlExitListEntry); Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry); } else @@ -12042,10 +11610,8 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_origalen = proto_perl->Iorigalen; PL_pidstatus = newHV(); /* XXX flag for cloning? */ PL_osname = SAVEPV(proto_perl->Iosname); - PL_sh_path_compat = proto_perl->Ish_path_compat; /* XXX never deallocated */ PL_sighandlerp = proto_perl->Isighandlerp; - PL_runops = proto_perl->Irunops; Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char); @@ -12221,15 +11787,15 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_bitcount = Nullch; /* reinits on demand */ if (proto_perl->Ipsig_pend) { - Newz(0, PL_psig_pend, SIG_SIZE, int); + Newxz(PL_psig_pend, SIG_SIZE, int); } else { PL_psig_pend = (int*)NULL; } if (proto_perl->Ipsig_ptr) { - Newz(0, PL_psig_ptr, SIG_SIZE, SV*); - Newz(0, PL_psig_name, SIG_SIZE, SV*); + Newxz(PL_psig_ptr, SIG_SIZE, SV*); + Newxz(PL_psig_name, SIG_SIZE, SV*); for (i = 1; i < SIG_SIZE; i++) { PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i], param); PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i], param); @@ -12247,7 +11813,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_tmps_ix = proto_perl->Ttmps_ix; PL_tmps_max = proto_perl->Ttmps_max; PL_tmps_floor = proto_perl->Ttmps_floor; - Newz(50, PL_tmps_stack, PL_tmps_max, SV*); + Newxz(PL_tmps_stack, PL_tmps_max, SV*); i = 0; while (i <= PL_tmps_ix) { PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i], param); @@ -12256,7 +11822,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, /* next PUSHMARK() sets *(PL_markstack_ptr+1) */ i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack; - Newz(54, PL_markstack, i, I32); + Newxz(PL_markstack, i, I32); PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max - proto_perl->Tmarkstack); PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr @@ -12268,7 +11834,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, * NOTE: unlike the others! */ PL_scopestack_ix = proto_perl->Tscopestack_ix; PL_scopestack_max = proto_perl->Tscopestack_max; - Newz(54, PL_scopestack, PL_scopestack_max, I32); + Newxz(PL_scopestack, PL_scopestack_max, I32); Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32); /* NOTE: si_dup() looks at PL_markstack */ @@ -12288,7 +11854,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, * NOTE: unlike the others! */ PL_savestack_ix = proto_perl->Tsavestack_ix; PL_savestack_max = proto_perl->Tsavestack_max; - /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/ + /*Newxz(PL_savestack, PL_savestack_max, ANY);*/ PL_savestack = ss_dup(proto_perl, param); } else { @@ -12415,16 +11981,14 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, if (!(flags & CLONEf_KEEP_PTR_TABLE)) { ptr_table_free(PL_ptr_table); PL_ptr_table = NULL; - ptr_table_free(PL_shared_hek_table); - PL_shared_hek_table = NULL; } /* Call the ->CLONE method, if it exists, for each of the stashes identified by sv_dup() above. */ while(av_len(param->stashes) != -1) { - HV* stash = (HV*) av_shift(param->stashes); - GV* cloner = gv_fetchmethod_autoload(stash, "CLONE", 0); + HV* const stash = (HV*) av_shift(param->stashes); + GV* const cloner = gv_fetchmethod_autoload(stash, "CLONE", 0); if (cloner && GvCV(cloner)) { dSP; ENTER; @@ -12476,7 +12040,7 @@ Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding) if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) { SV *uni; STRLEN len; - char *s; + const char *s; dSP; ENTER; SAVETMPS; @@ -12500,12 +12064,11 @@ Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding) SPAGAIN; uni = POPs; PUTBACK; - s = SvPV(uni, len); + s = SvPV_const(uni, len); if (s != SvPVX_const(sv)) { SvGROW(sv, len + 1); - Move(s, SvPVX_const(sv), len, char); + Move(s, SvPVX(sv), len + 1, char); SvCUR_set(sv, len); - SvPVX(sv)[len] = 0; } FREETMPS; LEAVE;