X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=dacd535f8ed2dac026b411774e1db55d46a1d9ba;hb=da51bb9b4f7f527464b5e38aca8bcb956de1bbbc;hp=bcfbe8fea2c2cd92af3eabc7bed8c9f568c235fe;hpb=a9fe210d2c78e54078c497ec463a09bde9076605;p=p5sagit%2Fp5-mst-13.2.git diff --git a/sv.c b/sv.c index bcfbe8f..dacd535 100644 --- a/sv.c +++ b/sv.c @@ -1,7 +1,7 @@ /* sv.c * * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, - * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others + * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -443,7 +443,8 @@ static void do_clean_objs(pTHX_ SV *ref) { dVAR; - if (SvROK(ref)) { + assert (SvROK(ref)); + { SV * const target = SvRV(ref); if (SvOBJECT(target)) { DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(ref))); @@ -469,7 +470,9 @@ static void do_clean_named_objs(pTHX_ SV *sv) { dVAR; - if (SvTYPE(sv) == SVt_PVGV && isGV_with_GP(sv) && GvGP(sv)) { + assert(SvTYPE(sv) == SVt_PVGV); + assert(isGV_with_GP(sv)); + if (GvGP(sv)) { if (( #ifdef PERL_DONT_CREATE_GVSV GvSV(sv) && @@ -504,7 +507,7 @@ Perl_sv_clean_objs(pTHX) visit(do_clean_objs, SVf_ROK, SVf_ROK); #ifndef DISABLE_DESTRUCTOR_KLUDGE /* some barnacles may yet remain, clinging to typeglobs */ - visit(do_clean_named_objs, SVt_PVGV, SVTYPEMASK); + visit(do_clean_named_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP); #endif PL_in_clean_objs = FALSE; } @@ -551,7 +554,7 @@ Perl_sv_clean_all(pTHX) arena_descs, each holding info for a single arena. By separating the meta-info from the arena, we recover the 1st slot, formerly borrowed for list management. The arena_set is about the size of an - arena, avoiding the needless malloc overhead of a naive linked-list + arena, avoiding the needless malloc overhead of a naive linked-list. The cost is 1 arena-set malloc per ~320 arena-mallocs, + the unused memory in the last arena-set (1/2 on average). In trade, we get @@ -562,10 +565,7 @@ Perl_sv_clean_all(pTHX) struct arena_desc { char *arena; /* the raw storage, allocated aligned */ size_t size; /* its size ~4k typ */ - int unit_type; /* useful for arena audits */ - /* info for sv-heads (eventually) - int count, flags; - */ + U32 misc; /* type, and in future other things. */ }; struct arena_set; @@ -579,8 +579,8 @@ struct arena_set; struct arena_set { struct arena_set* next; - int set_size; /* ie ARENAS_PER_SET */ - int curr; /* index of next available arena-desc */ + unsigned int set_size; /* ie ARENAS_PER_SET */ + unsigned int curr; /* index of next available arena-desc */ struct arena_desc set[ARENAS_PER_SET]; }; @@ -598,7 +598,7 @@ Perl_sv_free_arenas(pTHX) dVAR; SV* sva; SV* svanext; - int i; + unsigned int i; /* Free arenas here, but be careful about fake ones. (We assume contiguity of the fake ones with the corresponding real ones.) */ @@ -613,21 +613,23 @@ Perl_sv_free_arenas(pTHX) } { - struct arena_set *next, *aroot = (struct arena_set*) PL_body_arenas; - - for (; aroot; aroot = next) { - const int max = aroot->curr; - for (i=0; icurr; + while (i--) { assert(aroot->set[i].arena); Safefree(aroot->set[i].arena); } - next = aroot->next; - Safefree(aroot); + aroot = aroot->next; + Safefree(current); } } PL_body_arenas = 0; - for (i=0; icurr >= (*aroot)->set_size) { + if (!aroot || aroot->curr >= aroot->set_size) { + struct arena_set *newroot; Newxz(newroot, 1, struct arena_set); newroot->set_size = ARENAS_PER_SET; - newroot->next = *aroot; - *aroot = newroot; - DEBUG_m(PerlIO_printf(Perl_debug_log, "new arenaset %p\n", (void*)*aroot)); + newroot->next = aroot; + aroot = newroot; + PL_body_arenas = (void *) newroot; + DEBUG_m(PerlIO_printf(Perl_debug_log, "new arenaset %p\n", aroot)); } /* ok, now have arena-set with at least 1 empty/available arena-desc */ - curr = (*aroot)->curr++; - adesc = &((*aroot)->set[curr]); + curr = aroot->curr++; + adesc = &(aroot->set[curr]); assert(!adesc->arena); - Newxz(adesc->arena, arena_size, char); + Newx(adesc->arena, arena_size, char); adesc->size = arena_size; + adesc->misc = misc; DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %d added: %p size %d\n", - curr, adesc->arena, arena_size)); + curr, (void*)adesc->arena, arena_size)); return adesc->arena; } @@ -887,6 +892,11 @@ static const struct body_details bodies_by_type[] = { { sizeof(HE), 0, 0, SVt_NULL, FALSE, NONV, NOARENA, FIT_ARENA(0, sizeof(HE)) }, + /* The bind placeholder pretends to be an RV for now. + Also it's marked as "can't upgrade" top stop anyone using it before it's + implemented. */ + { 0, 0, 0, SVt_BIND, TRUE, NONV, NOARENA, 0 }, + /* IVs are in the head, so the allocation size is 0. However, the slot is overloaded for PTEs. */ { sizeof(struct ptr_tbl_ent), /* This is used for PTEs. */ @@ -926,10 +936,6 @@ static const struct body_details bodies_by_type[] = { { sizeof(XPVMG), copy_length(XPVMG, xmg_stash), 0, SVt_PVMG, FALSE, HADNV, HASARENA, FIT_ARENA(0, sizeof(XPVMG)) }, - /* 36 */ - { sizeof(XPVBM), sizeof(XPVBM), 0, SVt_PVBM, TRUE, HADNV, - HASARENA, FIT_ARENA(0, sizeof(XPVBM)) }, - /* 48 */ { sizeof(XPVGV), sizeof(XPVGV), 0, SVt_PVGV, TRUE, HADNV, HASARENA, FIT_ARENA(0, sizeof(XPVGV)) }, @@ -1032,10 +1038,6 @@ static const struct body_details bodies_by_type[] = { #define new_NOARENAZ(details) \ my_safecalloc((details)->body_size + (details)->offset) -#if defined(DEBUGGING) && !defined(PERL_GLOBAL_STRUCT_PRIVATE) -static bool done_sanity_check; -#endif - STATIC void * S_more_bodies (pTHX_ svtype sv_type) { @@ -1045,10 +1047,9 @@ S_more_bodies (pTHX_ svtype sv_type) const size_t body_size = bdp->body_size; char *start; const char *end; - - assert(bdp->arena_size); - #if defined(DEBUGGING) && !defined(PERL_GLOBAL_STRUCT_PRIVATE) + static bool done_sanity_check; + /* PERL_GLOBAL_STRUCT_PRIVATE cannot coexist with global * variables like done_sanity_check. */ if (!done_sanity_check) { @@ -1061,14 +1062,16 @@ S_more_bodies (pTHX_ svtype sv_type) } #endif - start = (char*) Perl_get_arena(aTHX_ bdp->arena_size); + assert(bdp->arena_size); + + start = (char*) Perl_get_arena(aTHX_ bdp->arena_size, sv_type); end = start + bdp->arena_size - body_size; /* computed count doesnt reflect the 1st slot reservation */ DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %p end %p arena-size %d type %d size %d ct %d\n", - start, end, + (void*)start, (void*)end, (int)bdp->arena_size, sv_type, (int)body_size, (int)bdp->arena_size / (int)body_size)); @@ -1177,7 +1180,9 @@ Perl_sv_upgrade(pTHX_ register SV *sv, svtype new_type) (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) + sizeof(XPVMG) bytes from a XPVGV structure in sv_unglob. Right now + this happens to be moot because XPVGV has been re-ordered, with GP + no longer after STASH) So we are careful and work out the size of used parts of all the structures. */ @@ -1293,7 +1298,6 @@ Perl_sv_upgrade(pTHX_ register SV *sv, svtype new_type) assert(!SvNOK(sv)); case SVt_PVIO: case SVt_PVFM: - case SVt_PVBM: case SVt_PVGV: case SVt_PVCV: case SVt_PVLV: @@ -1558,8 +1562,6 @@ Like C, but also handles 'set' magic. void Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u) { - sv_setiv(sv, 0); - SvIsUV_on(sv); sv_setuv(sv,u); SvSETMAGIC(sv); } @@ -2161,7 +2163,11 @@ Perl_sv_2iv_flags(pTHX_ register SV *sv, I32 flags) dVAR; if (!sv) return 0; - if (SvGMAGICAL(sv)) { + if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) { + /* FBMs use the same flag bit as SVf_IVisUV, so must let them + cache IVs just in case. In practice it seems that they never + actually anywhere accessible by user Perl code, let alone get used + in anything other than a string context. */ if (flags & SV_GMAGIC) mg_get(sv); if (SvIOKp(sv)) @@ -2241,7 +2247,9 @@ Perl_sv_2uv_flags(pTHX_ register SV *sv, I32 flags) dVAR; if (!sv) return 0; - if (SvGMAGICAL(sv)) { + if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) { + /* FBMs use the same flag bit as SVf_IVisUV, so must let them + cache IVs just in case. */ if (flags & SV_GMAGIC) mg_get(sv); if (SvIOKp(sv)) @@ -2316,7 +2324,9 @@ Perl_sv_2nv(pTHX_ register SV *sv) dVAR; if (!sv) return 0.0; - if (SvGMAGICAL(sv)) { + if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) { + /* FBMs use the same flag bit as SVf_IVisUV, so must let them + cache IVs just in case. */ mg_get(sv); if (SvNOKp(sv)) return SvNVX(sv); @@ -2746,7 +2756,6 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) { /* I'm assuming that if both IV and NV are equally valid then converting the IV is going to be more efficient */ - const U32 isIOK = SvIOK(sv); const U32 isUIOK = SvIsUV(sv); char buf[TYPE_CHARS(UV)]; char *ebuf, *ptr; @@ -2760,12 +2769,6 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) SvCUR_set(sv, ebuf - ptr); s = SvEND(sv); *s = '\0'; - if (isIOK) - SvIOK_on(sv); - else - SvIOKp_on(sv); - if (isUIOK) - SvIsUV_on(sv); } else if (SvNOKp(sv)) { const int olderrno = errno; @@ -3170,17 +3173,18 @@ S_glob_assign_glob(pTHX_ SV *dstr, SV *sstr, const int dtype) if (dtype != SVt_PVGV) { const char * const name = GvNAME(sstr); const STRLEN len = GvNAMELEN(sstr); - /* don't upgrade SVt_PVLV: it can hold a glob */ - if (dtype != SVt_PVLV) { + { if (dtype >= SVt_PV) { SvPV_free(dstr); SvPV_set(dstr, 0); SvLEN_set(dstr, 0); SvCUR_set(dstr, 0); } - sv_upgrade(dstr, SVt_PVGV); + SvUPGRADE(dstr, SVt_PVGV); (void)SvOK_off(dstr); - SvSCREAM_on(dstr); + /* FIXME - why are we doing this, then turning it off and on again + below? */ + isGV_with_GP_on(dstr); } GvSTASH(dstr) = GvSTASH(sstr); if (GvSTASH(dstr)) @@ -3196,9 +3200,9 @@ S_glob_assign_glob(pTHX_ SV *dstr, SV *sstr, const int dtype) #endif gp_free((GV*)dstr); - SvSCREAM_off(dstr); + isGV_with_GP_off(dstr); (void)SvOK_off(dstr); - SvSCREAM_on(dstr); + isGV_with_GP_on(dstr); GvINTRO_off(dstr); /* one-shot flag */ GvGP(dstr) = gp_ref(GvGP(sstr)); if (SvTAINTED(sstr)) @@ -3336,14 +3340,14 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) if (SvIS_FREED(dstr)) { Perl_croak(aTHX_ "panic: attempt to copy value %" SVf - " to a freed scalar %p", sstr, dstr); + " to a freed scalar %p", SVfARG(sstr), (void *)dstr); } SV_CHECK_THINKFIRST_COW_DROP(dstr); if (!sstr) sstr = &PL_sv_undef; if (SvIS_FREED(sstr)) { - Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p to %p", sstr, - dstr); + Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p to %p", + (void*)sstr, (void*)dstr); } stype = SvTYPE(sstr); dtype = SvTYPE(dstr); @@ -3377,6 +3381,8 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) case SVt_PV: sv_upgrade(dstr, SVt_PVIV); break; + case SVt_PVGV: + goto end_of_first_switch; } (void)SvIOK_only(dstr); SvIV_set(dstr, SvIVX(sstr)); @@ -3403,6 +3409,8 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) case SVt_PVIV: sv_upgrade(dstr, SVt_PVNV); break; + case SVt_PVGV: + goto end_of_first_switch; } SvNV_set(dstr, SvNVX(sstr)); (void)SvNOK_only(dstr); @@ -3450,21 +3458,22 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) } break; + /* case SVt_BIND: */ + case SVt_PVLV: case SVt_PVGV: - if (dtype <= SVt_PVGV) { + if (isGV_with_GP(sstr) && dtype <= SVt_PVGV) { glob_assign_glob(dstr, sstr, dtype); return; } + /* SvVALID means that this PVGV is playing at being an FBM. */ /*FALLTHROUGH*/ case SVt_PVMG: - case SVt_PVLV: - case SVt_PVBM: if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) { mg_get(sstr); if (SvTYPE(sstr) != stype) { stype = SvTYPE(sstr); - if (stype == SVt_PVGV && dtype <= SVt_PVGV) { + if (isGV_with_GP(sstr) && stype == SVt_PVGV && dtype <= SVt_PVGV) { glob_assign_glob(dstr, sstr, dtype); return; } @@ -3475,13 +3484,35 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) else SvUPGRADE(dstr, (svtype)stype); } + end_of_first_switch: /* dstr may have been upgraded. */ dtype = SvTYPE(dstr); sflags = SvFLAGS(sstr); - if (sflags & SVf_ROK) { - if (dtype == SVt_PVGV && SvTYPE(SvRV(sstr)) == SVt_PVGV) { + if (dtype == SVt_PVCV || dtype == SVt_PVFM) { + /* Assigning to a subroutine sets the prototype. */ + if (SvOK(sstr)) { + STRLEN len; + const char *const ptr = SvPV_const(sstr, len); + + SvGROW(dstr, len + 1); + Copy(ptr, SvPVX(dstr), len + 1, char); + SvCUR_set(dstr, len); + SvPOK_only(dstr); + SvFLAGS(dstr) |= sflags & SVf_UTF8; + } else { + SvOK_off(dstr); + } + } else if (dtype == SVt_PVAV || dtype == SVt_PVHV) { + const char * const type = sv_reftype(dstr,0); + if (PL_op) + Perl_croak(aTHX_ "Cannot copy to %s in %s", type, OP_NAME(PL_op)); + else + Perl_croak(aTHX_ "Cannot copy to %s", type); + } else if (sflags & SVf_ROK) { + if (isGV_with_GP(dstr) && dtype == SVt_PVGV + && SvTYPE(SvRV(sstr)) == SVt_PVGV) { sstr = SvRV(sstr); if (sstr == dstr) { if (GvIMPORTED(dstr) != GVf_IMPORTED @@ -3515,7 +3546,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) assert(!(sflags & SVf_NOK)); assert(!(sflags & SVf_IOK)); } - else if (dtype == SVt_PVGV) { + else if (dtype == SVt_PVGV && isGV_with_GP(dstr)) { if (!(sflags & SVf_OK)) { if (ckWARN(WARN_MISC)) Perl_warner(aTHX_ packWARN(WARN_MISC), @@ -3676,7 +3707,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) SvNV_set(dstr, SvNVX(sstr)); } if (sflags & SVp_IOK) { - SvRELEASE_IVX(dstr); + SvOOK_off(dstr); SvIV_set(dstr, SvIVX(sstr)); /* Must do this otherwise some other overloaded use of 0x80000000 gets confused. I guess SVpbm_VALID */ @@ -3748,7 +3779,7 @@ Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr) if (DEBUG_C_TEST) { PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n", - sstr, dstr); + (void*)sstr, (void*)dstr); sv_dump(sstr); if (dstr) sv_dump(dstr); @@ -3981,9 +4012,9 @@ Perl_sv_usepvn_flags(pTHX_ SV *sv, char *ptr, STRLEN len, U32 flags) (which it can do by means other than releasing copy-on-write Svs) or by changing the other copy-on-write SVs in the loop. */ STATIC void -S_sv_release_COW(pTHX_ register SV *sv, const char *pvx, STRLEN len, SV *after) +S_sv_release_COW(pTHX_ register SV *sv, const char *pvx, SV *after) { - if (len) { /* this SV was SvIsCOW_normal(sv) */ + { /* this SV was SvIsCOW_normal(sv) */ /* we need to find the SV pointing to us. */ SV *current = SV_COW_NEXT_SV(after); @@ -4007,19 +4038,8 @@ S_sv_release_COW(pTHX_ register SV *sv, const char *pvx, STRLEN len, SV *after) /* Make the SV before us point to the SV after us. */ SV_COW_NEXT_SV_SET(current, after); } - } else { - unshare_hek(SvSHARED_HEK_FROM_PV(pvx)); } } - -int -Perl_sv_release_IVX(pTHX_ register SV *sv) -{ - if (SvIsCOW(sv)) - sv_force_normal_flags(sv, 0); - SvOOK_off(sv); - return 0; -} #endif /* =for apidoc sv_force_normal_flags @@ -4048,7 +4068,11 @@ Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags) 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. */ + /* next COW sv in the loop. If len is 0 then this is a shared-hash + key scalar, so we mustn't attempt to call SV_COW_NEXT_SV(), as + we'll fail an assertion. */ + SV * const next = len ? SV_COW_NEXT_SV(sv) : 0; + if (DEBUG_C_TEST) { PerlIO_printf(Perl_debug_log, "Copy on write: Force normal %ld\n", @@ -4069,7 +4093,11 @@ Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags) SvCUR_set(sv, cur); *SvEND(sv) = '\0'; } - sv_release_COW(sv, pvx, len, next); + if (len) { + sv_release_COW(sv, pvx, next); + } else { + unshare_hek(SvSHARED_HEK_FROM_PV(pvx)); + } if (DEBUG_C_TEST) { sv_dump(sv); } @@ -4337,7 +4365,7 @@ to contain an C and is stored as-is with its REFCNT incremented. =cut */ MAGIC * -Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, MGVTBL *vtable, +Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, const MGVTBL *vtable, const char* name, I32 namlen) { dVAR; @@ -4399,7 +4427,7 @@ Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, MGVTBL *vtable, else mg->mg_ptr = (char *) name; } - mg->mg_virtual = vtable; + mg->mg_virtual = (MGVTBL *) vtable; mg_magical(sv); if (SvGMAGICAL(sv)) @@ -4426,7 +4454,7 @@ void Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen) { dVAR; - MGVTBL *vtable; + const MGVTBL *vtable; MAGIC* mg; #ifdef PERL_OLD_COPY_ON_WRITE @@ -4485,9 +4513,6 @@ Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 nam case PERL_MAGIC_regdata: vtable = &PL_vtbl_regdata; break; - case PERL_MAGIC_regdata_names: - vtable = &PL_vtbl_regdata_names; - break; case PERL_MAGIC_regdatum: vtable = &PL_vtbl_regdatum; break; @@ -5089,14 +5114,15 @@ Perl_sv_clear(pTHX_ register SV *sv) } } if (type >= SVt_PVMG) { - if ((type == SVt_PVMG || type == SVt_PVGV) && SvPAD_OUR(sv)) { - SvREFCNT_dec(OURSTASH(sv)); + if (type == SVt_PVMG && SvPAD_OUR(sv)) { + SvREFCNT_dec(SvOURSTASH(sv)); } else if (SvMAGIC(sv)) mg_free(sv); if (type == SVt_PVMG && SvPAD_TYPED(sv)) SvREFCNT_dec(SvSTASH(sv)); } switch (type) { + /* case SVt_BIND: */ case SVt_PVIO: if (IoIFP(sv) && IoIFP(sv) != PerlIO_stdin() && @@ -5112,8 +5138,6 @@ Perl_sv_clear(pTHX_ register SV *sv) Safefree(IoFMT_NAME(sv)); Safefree(IoBOTTOM_NAME(sv)); goto freescalar; - case SVt_PVBM: - goto freescalar; case SVt_PVCV: case SVt_PVFM: cv_undef((CV*)sv); @@ -5133,16 +5157,16 @@ Perl_sv_clear(pTHX_ register SV *sv) } else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV** */ SvREFCNT_dec(LvTARG(sv)); - goto freescalar; case SVt_PVGV: - gp_free((GV*)sv); - if (GvNAME_HEK(sv)) { - unshare_hek(GvNAME_HEK(sv)); - } + if (isGV_with_GP(sv)) { + gp_free((GV*)sv); + if (GvNAME_HEK(sv)) + unshare_hek(GvNAME_HEK(sv)); /* 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); + if (!SvVALID(sv) && GvSTASH(sv)) + sv_del_backref((SV*)GvSTASH(sv), sv); + } case SVt_PVMG: case SVt_PVNV: case SVt_PVIV: @@ -5170,8 +5194,12 @@ Perl_sv_clear(pTHX_ register SV *sv) PerlIO_printf(Perl_debug_log, "Copy on write: clear\n"); sv_dump(sv); } - sv_release_COW(sv, SvPVX_const(sv), SvLEN(sv), - SV_COW_NEXT_SV(sv)); + if (SvLEN(sv)) { + sv_release_COW(sv, SvPVX_const(sv), SV_COW_NEXT_SV(sv)); + } else { + unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv))); + } + /* And drop it here. */ SvFAKE_off(sv); } else if (SvLEN(sv)) { @@ -5359,7 +5387,7 @@ Perl_sv_len_utf8(pTHX_ register SV *sv) PL_utf8cache = 0; Perl_croak(aTHX_ "panic: sv_len_utf8 cache %"UVuf " real %"UVuf" for %"SVf, - (UV) ulen, (UV) real, (void*)sv); + (UV) ulen, (UV) real, SVfARG(sv)); } } } @@ -5517,7 +5545,7 @@ S_sv_pos_u2b_cached(pTHX_ SV *sv, MAGIC **mgp, const U8 *const start, PL_utf8cache = 0; Perl_croak(aTHX_ "panic: sv_pos_u2b_cache cache %"UVuf " real %"UVuf" for %"SVf, - (UV) boffset, (UV) real_boffset, (void*)sv); + (UV) boffset, (UV) real_boffset, SVfARG(sv)); } } boffset = real_boffset; @@ -5639,7 +5667,7 @@ S_utf8_mg_pos_cache_update(pTHX_ SV *sv, MAGIC **mgp, STRLEN byte, STRLEN utf8, SAVEI8(PL_utf8cache); PL_utf8cache = 0; Perl_croak(aTHX_ "panic: utf8_mg_pos_cache_update cache %"UVuf - " real %"UVuf" for %"SVf, (UV) utf8, (UV) realutf8, (void*)sv); + " real %"UVuf" for %"SVf, (UV) utf8, (UV) realutf8, SVfARG(sv)); } } @@ -5862,7 +5890,7 @@ Perl_sv_pos_b2u(pTHX_ register SV* sv, I32* offsetp) PL_utf8cache = 0; Perl_croak(aTHX_ "panic: sv_pos_b2u cache %"UVuf " real %"UVuf" for %"SVf, - (UV) len, (UV) real_len, (void*)sv); + (UV) len, (UV) real_len, SVfARG(sv)); } } len = real_len; @@ -7356,7 +7384,7 @@ Perl_sv_2io(pTHX_ SV *sv) else io = 0; if (!io) - Perl_croak(aTHX_ "Bad filehandle: %"SVf, (void*)sv); + Perl_croak(aTHX_ "Bad filehandle: %"SVf, SVfARG(sv)); break; } return io; @@ -7448,7 +7476,7 @@ Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref) LEAVE; if (!GvCVu(gv)) Perl_croak(aTHX_ "Unable to create sub named \"%"SVf"\"", - (void*)sv); + SVfARG(sv)); } return GvCVu(gv); } @@ -7619,7 +7647,6 @@ Perl_sv_reftype(pTHX_ const SV *sv, int ob) case SVt_PVIV: case SVt_PVNV: case SVt_PVMG: - case SVt_PVBM: if (SvVOK(sv)) return "VSTRING"; if (SvROK(sv)) @@ -7638,6 +7665,7 @@ Perl_sv_reftype(pTHX_ const SV *sv, int ob) case SVt_PVGV: return "GLOB"; case SVt_PVFM: return "FORMAT"; case SVt_PVIO: return "IO"; + case SVt_BIND: return "BIND"; default: return "UNKNOWN"; } } @@ -7741,7 +7769,7 @@ Perl_newSVrv(pTHX_ SV *rv, const char *classname) SvROK_on(rv); if (classname) { - HV* const stash = gv_stashpv(classname, TRUE); + HV* const stash = gv_stashpv(classname, GV_ADD); (void)sv_bless(rv, stash); } return sv; @@ -7929,7 +7957,7 @@ S_sv_unglob(pTHX_ SV *sv) if (GvNAME_HEK(sv)) { unshare_hek(GvNAME_HEK(sv)); } - SvSCREAM_off(sv); + isGV_with_GP_off(sv); /* need to keep SvANY(sv) in the right arena */ xpvmg = new_XPVMG(); @@ -8384,7 +8412,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV } if (args && patlen == 3 && pat[0] == '%' && pat[1] == '-' && pat[2] == 'p') { - argsv = va_arg(*args, SV*); + argsv = (SV*)va_arg(*args, void*); sv_catsv(sv, argsv); return; } @@ -8540,7 +8568,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV precis = n; has_precis = TRUE; } - argsv = va_arg(*args, SV*); + argsv = (SV*)va_arg(*args, void*); eptr = SvPVx_const(argsv, elen); if (DO_UTF8(argsv)) is_utf8 = TRUE; @@ -9317,7 +9345,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV (UV)c & 0xFF); } else sv_catpvs(msg, "end of string"); - Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, (void*)msg); /* yes, this is reentrant */ + Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, SVfARG(msg)); /* yes, this is reentrant */ } /* output mangled stuff ... */ @@ -9458,16 +9486,78 @@ ptr_table_* functions. #define SAVEPV(p) ((p) ? savepv(p) : NULL) #define SAVEPVN(p,n) ((p) ? savepvn(p,n) : NULL) +/* clone a parser */ -/* Duplicate a regexp. Required reading: pregcomp() and pregfree() in - regcomp.c. AMS 20010712 */ - -REGEXP * -Perl_re_dup(pTHX_ const REGEXP *r, CLONE_PARAMS *param) +yy_parser * +Perl_parser_dup(pTHX_ const yy_parser *proto, CLONE_PARAMS* param) { - return CALLREGDUPE(r,param); + yy_parser *parser; + + if (!proto) + return NULL; + + /* look for it in the table first */ + parser = (yy_parser *)ptr_table_fetch(PL_ptr_table, proto); + if (parser) + return parser; + + /* create anew and remember what it is */ + Newxz(parser, 1, yy_parser); + ptr_table_store(PL_ptr_table, proto, parser); + + parser->yyerrstatus = 0; + parser->yychar = YYEMPTY; /* Cause a token to be read. */ + + /* XXX these not yet duped */ + parser->old_parser = NULL; + parser->stack = NULL; + parser->ps = NULL; + parser->stack_size = 0; + /* XXX parser->stack->state = 0; */ + + /* XXX eventually, just Copy() most of the parser struct ? */ + + parser->lex_brackets = proto->lex_brackets; + parser->lex_casemods = proto->lex_casemods; + parser->lex_brackstack = savepvn(proto->lex_brackstack, + (proto->lex_brackets < 120 ? 120 : proto->lex_brackets)); + parser->lex_casestack = savepvn(proto->lex_casestack, + (proto->lex_casemods < 12 ? 12 : proto->lex_casemods)); + parser->lex_defer = proto->lex_defer; + parser->lex_dojoin = proto->lex_dojoin; + parser->lex_expect = proto->lex_expect; + parser->lex_formbrack = proto->lex_formbrack; + parser->lex_inpat = proto->lex_inpat; + parser->lex_inwhat = proto->lex_inwhat; + parser->lex_op = proto->lex_op; + parser->lex_repl = sv_dup_inc(proto->lex_repl, param); + parser->lex_starts = proto->lex_starts; + parser->lex_stuff = sv_dup_inc(proto->lex_stuff, param); + parser->multi_close = proto->multi_close; + parser->multi_open = proto->multi_open; + parser->multi_start = proto->multi_start; + parser->pending_ident = proto->pending_ident; + parser->preambled = proto->preambled; + parser->sublex_info = proto->sublex_info; /* XXX not quite right */ + +#ifdef PERL_MAD + parser->endwhite = proto->endwhite; + parser->faketokens = proto->faketokens; + parser->lasttoke = proto->lasttoke; + parser->nextwhite = proto->nextwhite; + parser->realtokenstart = proto->realtokenstart; + parser->skipwhite = proto->skipwhite; + parser->thisclose = proto->thisclose; + parser->thismad = proto->thismad; + parser->thisopen = proto->thisopen; + parser->thisstuff = proto->thisstuff; + parser->thistoken = proto->thistoken; + parser->thiswhite = proto->thiswhite; +#endif + return parser; } + /* duplicate a file handle */ PerlIO * @@ -9562,7 +9652,7 @@ Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS* param) nmg->mg_type = mg->mg_type; nmg->mg_flags = mg->mg_flags; if (mg->mg_type == PERL_MAGIC_qr) { - nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj, param); + nmg->mg_obj = (SV*)CALLREGDUPE((REGEXP*)mg->mg_obj, param); } else if(mg->mg_type == PERL_MAGIC_backref) { /* The backref AV has its reference count deliberately bumped by @@ -9604,6 +9694,8 @@ Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS* param) return mgret; } +#endif /* USE_ITHREADS */ + /* create a new pointer-mapping table */ PTR_TBL_t * @@ -9747,6 +9839,7 @@ Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl) Safefree(tbl); } +#if defined(USE_ITHREADS) void Perl_rvpv_dup(pTHX_ SV *dstr, const SV *sstr, CLONE_PARAMS* param) @@ -9842,7 +9935,7 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param) #ifdef DEBUGGING if (SvANY(sstr) && PL_watch_pvx && SvPVX_const(sstr) == PL_watch_pvx) PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n", - PL_watch_pvx, SvPVX_const(sstr)); + (void*)PL_watch_pvx, SvPVX_const(sstr)); #endif /* don't clone objects whose class has asked us not to */ @@ -9868,6 +9961,7 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param) SvANY(dstr) = &(dstr->sv_u.svu_rv); Perl_rvpv_dup(aTHX_ dstr, sstr, param); break; + /* case SVt_BIND: */ default: { /* These are all the types that need complex bodies allocating. */ @@ -9889,7 +9983,6 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param) case SVt_PVFM: case SVt_PVHV: case SVt_PVAV: - case SVt_PVBM: case SVt_PVCV: case SVt_PVLV: case SVt_PVMG: @@ -9929,7 +10022,7 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param) FIXME - instrument and check that assumption */ if (sv_type >= SVt_PVMG) { if ((sv_type == SVt_PVMG) && SvPAD_OUR(dstr)) { - OURSTASH_set(dstr, hv_dup_inc(OURSTASH(dstr), param)); + SvOURSTASH_set(dstr, hv_dup_inc(SvOURSTASH(dstr), param)); } else if (SvMAGIC(dstr)) SvMAGIC_set(dstr, mg_dup(SvMAGIC(dstr), param)); if (SvSTASH(dstr)) @@ -9946,8 +10039,6 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param) 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**) */ @@ -9956,17 +10047,16 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param) LvTARG(dstr) = (SV*)he_dup((HE*)LvTARG(dstr), 0, param); else LvTARG(dstr) = sv_dup_inc(LvTARG(dstr), param); - break; case SVt_PVGV: - if (GvNAME_HEK(dstr)) - GvNAME_HEK(dstr) = hek_dup(GvNAME_HEK(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. */ - GvSTASH(dstr) = hv_dup(GvSTASH(dstr), param); if(isGV_with_GP(sstr)) { + if (GvNAME_HEK(dstr)) + GvNAME_HEK(dstr) = hek_dup(GvNAME_HEK(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. */ /* Danger Will Robinson - GvGP(dstr) isn't initialised at the point of this comment. */ + GvSTASH(dstr) = hv_dup(GvSTASH(dstr), param); GvGP(dstr) = gp_dup(GvGP(sstr), param); (void)GpREFCNT_inc(GvGP(dstr)); } else @@ -10285,6 +10375,7 @@ Perl_any_dup(pTHX_ void *v, const PerlInterpreter *proto_perl) ANY * Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) { + dVAR; ANY * const ss = proto_perl->Tsavestack; const I32 max = proto_perl->Tsavestack_max; I32 ix = proto_perl->Tsavestack_ix; @@ -10417,7 +10508,9 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) case OP_LEAVEWRITE: TOPPTR(nss,ix) = ptr; o = (OP*)ptr; + OP_REFCNT_LOCK; OpREFCNT_inc(o); + OP_REFCNT_UNLOCK; break; default: TOPPTR(nss,ix) = NULL; @@ -10578,6 +10671,10 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) ptr = POPPTR(ss,ix); TOPPTR(nss,ix) = DUP_WARNINGS((STRLEN*)ptr); break; + case SAVEt_PARSER: + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = parser_dup(ptr, param); + break; default: Perl_croak(aTHX_ "panic: ss_dup inconsistency (%"IVdf")", (IV) type); @@ -10922,9 +11019,11 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, SvREPADTMP(regex) ? sv_dup_inc(regex, param) : SvREFCNT_inc( - newSViv(PTR2IV(re_dup( + newSViv(PTR2IV(CALLREGDUPE( INT2PTR(REGEXP *, SvIVX(regex)), param)))) ; + if (SvFLAGS(regex) & SVf_BREAK) + SvFLAGS(sv) |= SVf_BREAK; /* unrefcnted PL_curpm */ av_push(PL_regex_padav, sv); } } @@ -10989,7 +11088,9 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, /* current interpreter roots */ PL_main_cv = cv_dup_inc(proto_perl->Imain_cv, param); + OP_REFCNT_LOCK; PL_main_root = OpREFCNT_inc(proto_perl->Imain_root); + OP_REFCNT_UNLOCK; PL_main_start = proto_perl->Imain_start; PL_eval_root = proto_perl->Ieval_root; PL_eval_start = proto_perl->Ieval_start; @@ -11004,7 +11105,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_Argv = NULL; PL_Cmd = NULL; PL_gensym = proto_perl->Igensym; - PL_preambled = proto_perl->Ipreambled; PL_preambleav = av_dup_inc(proto_perl->Ipreambleav, param); PL_laststatval = proto_perl->Ilaststatval; PL_laststype = proto_perl->Ilaststype; @@ -11025,9 +11125,17 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, if (PL_my_cxt_size) { Newx(PL_my_cxt_list, PL_my_cxt_size, void *); Copy(proto_perl->Imy_cxt_list, PL_my_cxt_list, PL_my_cxt_size, void *); +#ifdef PERL_GLOBAL_STRUCT_PRIVATE + Newx(PL_my_cxt_keys, PL_my_cxt_size, char *); + Copy(proto_perl->Imy_cxt_keys, PL_my_cxt_keys, PL_my_cxt_size, char *); +#endif } - else + else { PL_my_cxt_list = (void**)NULL; +#ifdef PERL_GLOBAL_STRUCT_PRIVATE + PL_my_cxt_keys = (void**)NULL; +#endif + } PL_modglobal = hv_dup_inc(proto_perl->Imodglobal, param); PL_custom_op_names = hv_dup_inc(proto_perl->Icustom_op_names,param); PL_custom_op_descs = hv_dup_inc(proto_perl->Icustom_op_descs,param); @@ -11076,38 +11184,12 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_cshname = proto_perl->Icshname; /* XXX never deallocated */ #endif + PL_parser = parser_dup(proto_perl->Iparser, param); + PL_lex_state = proto_perl->Ilex_state; - PL_lex_defer = proto_perl->Ilex_defer; - PL_lex_expect = proto_perl->Ilex_expect; - PL_lex_formbrack = proto_perl->Ilex_formbrack; - PL_lex_dojoin = proto_perl->Ilex_dojoin; - PL_lex_starts = proto_perl->Ilex_starts; - PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff, param); - PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl, param); - PL_lex_op = proto_perl->Ilex_op; - PL_lex_inpat = proto_perl->Ilex_inpat; - PL_lex_inwhat = proto_perl->Ilex_inwhat; - PL_lex_brackets = proto_perl->Ilex_brackets; - i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets); - PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i); - PL_lex_casemods = proto_perl->Ilex_casemods; - i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods); - PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i); #ifdef PERL_MAD Copy(proto_perl->Inexttoke, PL_nexttoke, 5, NEXTTOKE); - PL_lasttoke = proto_perl->Ilasttoke; - PL_realtokenstart = proto_perl->Irealtokenstart; - PL_faketokens = proto_perl->Ifaketokens; - PL_thismad = proto_perl->Ithismad; - PL_thistoken = proto_perl->Ithistoken; - PL_thisopen = proto_perl->Ithisopen; - PL_thisstuff = proto_perl->Ithisstuff; - PL_thisclose = proto_perl->Ithisclose; - PL_thiswhite = proto_perl->Ithiswhite; - PL_nextwhite = proto_perl->Inextwhite; - PL_skipwhite = proto_perl->Iskipwhite; - PL_endwhite = proto_perl->Iendwhite; PL_curforce = proto_perl->Icurforce; #else Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE); @@ -11115,56 +11197,30 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_nexttoke = proto_perl->Inexttoke; #endif - /* XXX This is probably masking the deeper issue of why - * SvANY(proto_perl->Ilinestr) can be NULL at this point. For test case: - * http://archive.develooper.com/perl5-porters%40perl.org/msg83298.html - * (A little debugging with a watchpoint on it may help.) - */ - if (SvANY(proto_perl->Ilinestr)) { - PL_linestr = sv_dup_inc(proto_perl->Ilinestr, param); - i = proto_perl->Ibufptr - SvPVX_const(proto_perl->Ilinestr); - PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i); - i = proto_perl->Ioldbufptr - SvPVX_const(proto_perl->Ilinestr); - PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i); - i = proto_perl->Ioldoldbufptr - SvPVX_const(proto_perl->Ilinestr); - PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i); - i = proto_perl->Ilinestart - SvPVX_const(proto_perl->Ilinestr); - PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i); - } - else { - PL_linestr = newSV(79); - sv_upgrade(PL_linestr,SVt_PVIV); - sv_setpvn(PL_linestr,"",0); - PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr); - } + PL_linestr = sv_dup_inc(proto_perl->Ilinestr, param); + i = proto_perl->Ibufptr - SvPVX_const(proto_perl->Ilinestr); + PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i); + i = proto_perl->Ioldbufptr - SvPVX_const(proto_perl->Ilinestr); + PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i); + i = proto_perl->Ioldoldbufptr - SvPVX_const(proto_perl->Ilinestr); + PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i); + i = proto_perl->Ilinestart - SvPVX_const(proto_perl->Ilinestr); + PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i); PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); - PL_pending_ident = proto_perl->Ipending_ident; - PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */ PL_expect = proto_perl->Iexpect; - PL_multi_start = proto_perl->Imulti_start; PL_multi_end = proto_perl->Imulti_end; - PL_multi_open = proto_perl->Imulti_open; - PL_multi_close = proto_perl->Imulti_close; PL_error_count = proto_perl->Ierror_count; PL_subline = proto_perl->Isubline; PL_subname = sv_dup_inc(proto_perl->Isubname, param); - /* XXX See comment on SvANY(proto_perl->Ilinestr) above */ - if (SvANY(proto_perl->Ilinestr)) { - i = proto_perl->Ilast_uni - SvPVX_const(proto_perl->Ilinestr); - PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i); - i = proto_perl->Ilast_lop - SvPVX_const(proto_perl->Ilinestr); - PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i); - PL_last_lop_op = proto_perl->Ilast_lop_op; - } - else { - PL_last_uni = SvPVX(PL_linestr); - PL_last_lop = SvPVX(PL_linestr); - PL_last_lop_op = 0; - } + i = proto_perl->Ilast_uni - SvPVX_const(proto_perl->Ilinestr); + PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i); + i = proto_perl->Ilast_lop - SvPVX_const(proto_perl->Ilinestr); + PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i); + PL_last_lop_op = proto_perl->Ilast_lop_op; PL_in_my = proto_perl->Iin_my; PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash, param); #ifdef FCRYPT @@ -11676,8 +11732,7 @@ S_varname(pTHX_ GV *gv, const char gvtype, PADOFFSET targ, return NULL; av = (AV*)(*av_fetch(CvPADLIST(cv), 0, FALSE)); sv = *av_fetch(av, targ, FALSE); - /* SvLEN in a pad name is not to be trusted */ - sv_setpv(name, SvPV_nolen_const(sv)); + sv_setpvn(name, SvPV_nolen_const(sv), SvCUR(sv)); } if (subscript_type == FUV_SUBSCRIPT_HASH) {