X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=70b27405529e5b90b0847f48ed4fe0a4257776bf;hb=1c7d9af3bd40a8ae4d0b1feabf16378e4446d90a;hp=afa538247d77d529bd975c3d519ad2c63b3ba403;hpb=437a6bf1fc3f48814cc26e6154b748c3f2617816;p=p5sagit%2Fp5-mst-13.2.git diff --git a/sv.c b/sv.c index afa5382..70b2740 100644 --- a/sv.c +++ b/sv.c @@ -165,6 +165,27 @@ 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 @@ -209,7 +230,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); @@ -286,8 +307,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 +387,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 +435,20 @@ Perl_sv_report_used(pTHX) /* called by sv_clean_objs() for each live SV */ static void -do_clean_objs(pTHX_ SV *sv) +do_clean_objs(pTHX_ SV *ref) { - SV* rv; + SV* target; - 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); + if (SvROK(ref) && SvOBJECT(target = SvRV(ref))) { + 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(sv); - SvRV_set(sv, NULL); - SvREFCNT_dec(rv); + SvROK_off(ref); + SvRV_set(ref, NULL); + SvREFCNT_dec(target); } } @@ -441,7 +462,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 +534,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 +552,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 +576,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 +676,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 +688,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,10 +708,13 @@ 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); + 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 */ @@ -767,8 +722,8 @@ S_varname(pTHX_ GV *gv, const char *gvtype, PADOFFSET targ, } 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); @@ -810,7 +765,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; @@ -863,25 +817,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; @@ -889,7 +844,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 { @@ -897,6 +852,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; @@ -904,7 +860,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; @@ -953,16 +909,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); ; } @@ -970,22 +926,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); } @@ -1007,7 +963,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: @@ -1052,7 +1008,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: @@ -1130,8 +1086,8 @@ S_more_bodies (pTHX_ void **arena_root, void **root, size_t size) { char *start; const char *end; - size_t count = PERL_ARENA_SIZE/size; - New(0, start, count*size, char); + const size_t count = PERL_ARENA_SIZE/size; + Newx(start, count*size, char); *((void **) start) = *arena_root; *arena_root = (void *)start; @@ -1145,7 +1101,7 @@ S_more_bodies (pTHX_ void **arena_root, void **root, size_t size) *root = (void *)start; while (start < end) { - char *next = start + size; + char * const next = start + size; *(void**) start = (void *)next; start = next; } @@ -1156,28 +1112,37 @@ S_more_bodies (pTHX_ void **arena_root, void **root, size_t size) /* grab a new thing from the free list, allocating more if necessary */ +/* 1st, the inline version */ + +#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 + +/* now use the inline version in the proper function */ + STATIC void * -S_new_body(pTHX_ void **arena_root, void **root, size_t size, size_t offset) +S_new_body(pTHX_ void **arena_root, void **root, size_t size) { void *xpv; - LOCK_SV_MUTEX; - xpv = *root ? *root : S_more_bodies(aTHX_ arena_root, root, size); - *root = *(void**)xpv; - UNLOCK_SV_MUTEX; - return (void*)((char*)xpv - offset); + new_body_inline(xpv, arena_root, root, size); + return xpv; } /* return a thing to the free list */ -STATIC void -S_del_body(pTHX_ void *thing, void **root, size_t offset) -{ - void **real_thing = (void**)((char *)thing + offset); - LOCK_SV_MUTEX; - *real_thing = *root; - *root = (void*)real_thing; - 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 /* Conventionally we simply malloc() a big block of memory, then divide it up into lots of the thing that we're allocating. @@ -1189,11 +1154,13 @@ S_del_body(pTHX_ void *thing, void **root, size_t offset) (void**)&(my_perl->Ixpvbm_root), sizeof(XPVBM), 0) */ -#define new_body(TYPE,lctype) \ +#define new_body_type(TYPE,lctype) \ S_new_body(aTHX_ (void**)&PL_ ## lctype ## _arenaroot, \ (void**)&PL_ ## lctype ## _root, \ - sizeof(TYPE), \ - 0) + 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 @@ -1216,20 +1183,17 @@ S_del_body(pTHX_ void *thing, void **root, size_t offset) no longer allocated. */ #define new_body_allocated(TYPE,lctype,member) \ - S_new_body(aTHX_ (void**)&PL_ ## lctype ## _arenaroot, \ - (void**)&PL_ ## lctype ## _root, \ - sizeof(lctype ## _allocated), \ - STRUCT_OFFSET(TYPE, member) \ - - STRUCT_OFFSET(lctype ## _allocated, 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(p,TYPE,lctype) \ - S_del_body(aTHX_ (void*)p, (void**)&PL_ ## lctype ## _root, 0) #define del_body_allocated(p,TYPE,lctype,member) \ - S_del_body(aTHX_ (void*)p, (void**)&PL_ ## lctype ## _root, \ - STRUCT_OFFSET(TYPE, member) \ - - STRUCT_OFFSET(lctype ## _allocated, 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) @@ -1271,8 +1235,8 @@ S_del_body(pTHX_ void *thing, void **root, size_t offset) #else /* !PURIFY */ -#define new_XNV() new_body(NV, xnv) -#define del_XNV(p) del_body(p, NV, xnv) +#define new_XNV() new_body_type(NV, xnv) +#define del_XNV(p) del_body_type(p, NV, xnv) #define new_XPV() new_body_allocated(XPV, xpv, xpv_cur) #define del_XPV(p) del_body_allocated(p, XPV, xpv, xpv_cur) @@ -1280,11 +1244,11 @@ S_del_body(pTHX_ void *thing, void **root, size_t offset) #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() new_body(XPVNV, xpvnv) -#define del_XPVNV(p) del_body(p, XPVNV, xpvnv) +#define new_XPVNV() new_body_type(XPVNV, xpvnv) +#define del_XPVNV(p) del_body_type(p, XPVNV, xpvnv) -#define new_XPVCV() new_body(XPVCV, xpvcv) -#define del_XPVCV(p) del_body(p, XPVCV, xpvcv) +#define new_XPVCV() new_body_type(XPVCV, xpvcv) +#define del_XPVCV(p) del_body_type(p, XPVCV, xpvcv) #define new_XPVAV() new_body_allocated(XPVAV, xpvav, xav_fill) #define del_XPVAV(p) del_body_allocated(p, XPVAV, xpvav, xav_fill) @@ -1292,17 +1256,17 @@ S_del_body(pTHX_ void *thing, void **root, size_t offset) #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() new_body(XPVMG, xpvmg) -#define del_XPVMG(p) del_body(p, XPVMG, xpvmg) +#define new_XPVMG() new_body_type(XPVMG, xpvmg) +#define del_XPVMG(p) del_body_type(p, XPVMG, xpvmg) -#define new_XPVGV() new_body(XPVGV, xpvgv) -#define del_XPVGV(p) del_body(p, XPVGV, xpvgv) +#define new_XPVGV() new_body_type(XPVGV, xpvgv) +#define del_XPVGV(p) del_body_type(p, XPVGV, xpvgv) -#define new_XPVLV() new_body(XPVLV, xpvlv) -#define del_XPVLV(p) del_body(p, XPVLV, xpvlv) +#define new_XPVLV() new_body_type(XPVLV, xpvlv) +#define del_XPVLV(p) del_body_type(p, XPVLV, xpvlv) -#define new_XPVBM() new_body(XPVBM, xpvbm) -#define del_XPVBM(p) del_body(p, XPVBM, xpvbm) +#define new_XPVBM() new_body_type(XPVBM, xpvbm) +#define del_XPVBM(p) del_body_type(p, XPVBM, xpvbm) #endif /* PURIFY */ @@ -1325,14 +1289,21 @@ You generally want to use the C macro wrapper. See also C. 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); @@ -1341,57 +1312,103 @@ Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt) if (SvTYPE(sv) == mt) return; - pv = NULL; - cur = 0; - len = 0; - iv = 0; - nv = 0.0; - magic = NULL; - stash = Nullhv; + 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 + + 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, @@ -1402,14 +1419,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"); @@ -1422,117 +1437,166 @@ 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 } } @@ -1552,7 +1616,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); @@ -1721,21 +1785,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); } @@ -1801,10 +1853,10 @@ 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; @@ -2061,7 +2113,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; @@ -2321,7 +2373,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. */ @@ -2369,7 +2421,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; @@ -2610,7 +2662,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) @@ -2644,7 +2696,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)); @@ -2657,7 +2709,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; @@ -2724,7 +2776,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)) @@ -2806,7 +2858,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. */ @@ -2904,7 +2956,7 @@ 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; @@ -2991,7 +3043,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) @@ -3099,7 +3151,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); @@ -3216,8 +3268,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; @@ -3279,7 +3330,7 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) s = SvGROW_mutable(sv, len + 1); SvCUR_set(sv, len); SvPOKp_on(sv); - return strcpy(s, t); + return memcpy(s, t, len + 1); } } @@ -3301,8 +3352,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); @@ -3406,8 +3456,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'))) @@ -3501,13 +3551,13 @@ Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags) 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 */ - U8 *recoded = 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. */ @@ -3620,7 +3670,7 @@ Perl_sv_utf8_decode(pTHX_ register SV *sv) return FALSE; e = (const U8 *) SvEND(sv); while (c < e) { - U8 ch = *c++; + const U8 ch = *c++; if (!UTF8_IS_INVARIANT(ch)) { SvUTF8_on(sv); break; @@ -3815,7 +3865,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 */ @@ -4101,13 +4153,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) { @@ -4458,7 +4505,7 @@ 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 @@ -4517,7 +4564,7 @@ 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); SV * const next = SV_COW_NEXT_SV(sv); /* next COW sv in the loop. */ @@ -4529,7 +4576,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) { @@ -4553,7 +4600,7 @@ 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 char * const pvx = SvPVX_const(sv); const STRLEN len = SvCUR(sv); SvFAKE_off(sv); SvREADONLY_off(sv); @@ -4868,7 +4915,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); @@ -4947,7 +4994,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 @@ -4955,7 +5002,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 @@ -5021,7 +5073,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; @@ -5060,7 +5112,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; @@ -5088,13 +5140,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: @@ -5177,7 +5230,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; @@ -5187,8 +5240,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; @@ -5202,13 +5255,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() */ @@ -5219,19 +5265,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; + } + } } /* @@ -5424,19 +5488,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); @@ -5473,18 +5547,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() && @@ -5499,18 +5572,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 */ @@ -5520,33 +5601,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_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)) { @@ -5567,76 +5659,30 @@ Perl_sv_clear(pTHX_ register SV *sv) } #else else if (SvPVX_const(sv) && SvLEN(sv)) - Safefree(SvPVX_const(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_NV: - case SVt_IV: - case SVt_NULL: + old_body_arena = (void **) &PL_xnv_root; 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)); - break; - case SVt_PVIO: - del_XPVIO(SvANY(sv)); - 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)); + } } /* @@ -5685,10 +5731,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) @@ -5817,7 +5867,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); @@ -5982,7 +6032,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; @@ -6084,7 +6134,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)) { @@ -6139,7 +6189,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); @@ -6217,7 +6267,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; @@ -6225,7 +6275,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; @@ -6494,7 +6544,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); @@ -6738,7 +6788,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]; @@ -6881,7 +6931,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; @@ -7016,7 +7066,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) @@ -7034,10 +7084,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 @@ -7226,8 +7276,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 */ @@ -7239,7 +7289,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; @@ -7481,7 +7531,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) { @@ -7521,17 +7571,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)); @@ -7866,19 +7920,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; @@ -8017,7 +8069,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 { @@ -8151,7 +8203,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; @@ -8260,7 +8312,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; @@ -8325,7 +8377,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); @@ -8357,24 +8409,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 */ } /* @@ -8418,7 +8470,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; } @@ -8436,7 +8488,7 @@ 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))) + if (mg && (mg->mg_len & 1) ) return TRUE; } return FALSE; @@ -8456,7 +8508,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); } @@ -8474,7 +8526,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); @@ -8764,6 +8816,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 @@ -8786,38 +8843,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; @@ -8828,9 +8885,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; @@ -8907,7 +8962,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 */ @@ -8936,8 +8991,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; @@ -8998,9 +9105,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) { @@ -9014,9 +9123,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++]; @@ -9200,21 +9307,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); @@ -9230,6 +9322,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) @@ -9546,7 +9641,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'; } @@ -9638,8 +9733,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"); @@ -9682,7 +9779,7 @@ 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_const(nsv); elen = SvCUR(nsv); @@ -9698,6 +9795,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]; } @@ -9706,10 +9804,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'; } @@ -9785,7 +9885,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; @@ -9801,15 +9901,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; @@ -9821,10 +9921,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++) { @@ -9840,7 +9941,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]; @@ -9871,7 +9972,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); @@ -9903,7 +10004,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; @@ -9944,7 +10046,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 */ @@ -9957,7 +10059,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; @@ -9979,7 +10080,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 @@ -10043,10 +10144,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; } @@ -10056,13 +10157,12 @@ Perl_ptr_table_new(pTHX) # define PTR_TABLE_HASH(ptr) (PTR2UV(ptr) >> 2) #endif -#define new_pte() new_body(struct ptr_tbl_ent, pte) -#define del_pte(p) del_body(p, struct ptr_tbl_ent, pte) +#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); @@ -10078,7 +10178,7 @@ 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 *oldv, void *newv) { PTR_TBL_ENT_t *tblent, **otblent; /* XXX this may be pessimal on platforms where pointers aren't good @@ -10095,7 +10195,8 @@ Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv) return; } } - tblent = new_pte(); + new_body_inline(tblent, (void**)&PL_pte_arenaroot, (void**)&PL_pte_root, + sizeof(struct ptr_tbl_ent)); tblent->oldval = oldv; tblent->newval = newv; tblent->next = *otblent; @@ -10185,64 +10286,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) @@ -10288,6 +10331,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) { @@ -10365,271 +10410,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) { + 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) @@ -10654,7 +10712,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) { @@ -10744,7 +10802,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); @@ -10784,7 +10842,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; @@ -10811,9 +10869,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; @@ -10827,9 +10885,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); @@ -10960,6 +11017,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: @@ -11087,9 +11145,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; @@ -11360,6 +11418,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); @@ -11415,7 +11477,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)); @@ -11481,8 +11543,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); @@ -11514,12 +11574,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 @@ -11559,10 +11618,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); @@ -11738,15 +11795,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); @@ -11764,7 +11821,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); @@ -11773,7 +11830,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 @@ -11785,7 +11842,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 */ @@ -11805,7 +11862,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 { @@ -11938,8 +11995,8 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, 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;