From: Nicholas Clark Date: Sat, 21 May 2005 12:31:52 +0000 (+0000) Subject: Move hv_name, hv_eiter and hv_riter into a new aux structure. X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=bfcb351493b9793586f4b514100d4f902a85f4fd;p=p5sagit%2Fp5-mst-13.2.git Move hv_name, hv_eiter and hv_riter into a new aux structure. Provide (more efficient) _get and _set macros. Adjust the core to use them. p4raw-id: //depot/perl@24526 --- diff --git a/dump.c b/dump.c index f3d6657..547af9f 100644 --- a/dump.c +++ b/dump.c @@ -1060,9 +1060,10 @@ Perl_magic_dump(pTHX_ const MAGIC *mg) void Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv) { + const char *hvname; Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv)); - if (sv && HvNAME(sv)) - PerlIO_printf(file, "\t\"%s\"\n", HvNAME(sv)); + if (sv && (hvname = HvNAME_get(sv))) + PerlIO_printf(file, "\t\"%s\"\n", hvname); else PerlIO_putc(file, '\n'); } @@ -1082,9 +1083,10 @@ Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv) { Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv)); if (sv && GvNAME(sv)) { + const char *hvname; PerlIO_printf(file, "\t\""); - if (GvSTASH(sv) && HvNAME(GvSTASH(sv))) - PerlIO_printf(file, "%s\" :: \"", HvNAME(GvSTASH(sv))); + if (GvSTASH(sv) && (hvname = HvNAME_get(GvSTASH(sv)))) + PerlIO_printf(file, "%s\" :: \"", hvname); PerlIO_printf(file, "%s\"\n", GvNAME(sv)); } else @@ -1420,17 +1422,20 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo Perl_dump_indent(aTHX_ level, file, " KEYS = %"IVdf"\n", (IV)HvKEYS(sv)); Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)HvFILL(sv)); Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)HvMAX(sv)); - Perl_dump_indent(aTHX_ level, file, " RITER = %"IVdf"\n", (IV)HvRITER(sv)); - Perl_dump_indent(aTHX_ level, file, " EITER = 0x%"UVxf"\n", PTR2UV(HvEITER(sv))); + Perl_dump_indent(aTHX_ level, file, " RITER = %"IVdf"\n", (IV)HvRITER_get(sv)); + Perl_dump_indent(aTHX_ level, file, " EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv))); { MAGIC *mg = mg_find(sv, PERL_MAGIC_symtab); if (mg && mg->mg_obj) { Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj)); } } - if (HvNAME(sv)) - Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", HvNAME(sv)); - if (nest < maxnest && !HvEITER(sv)) { /* Try to preserve iterator */ + { + const char *hvname = HvNAME_get(sv); + if (hvname) + Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", hvname); + } + if (nest < maxnest && !HvEITER_get(sv)) { /* Try to preserve iterator */ HE *he; HV *hv = (HV*)sv; int count = maxnest - nest; diff --git a/embed.fnc b/embed.fnc index 11c362e..02b75ec 100644 --- a/embed.fnc +++ b/embed.fnc @@ -1397,7 +1397,12 @@ sM |HE* |hv_fetch_common|HV* tb|SV* key_sv|const char* key|STRLEN klen|int flags Apd |void |hv_clear_placeholders|HV* hb Apd |SV* |hv_scalar |HV* hv| - +Apo |I32* |hv_riter_p |HV* hv +Apo |HE** |hv_eiter_p |HV* hv +Apo |void |hv_riter_set |HV* hv|I32 riter +Apo |void |hv_eiter_set |HV* hv|HE* eiter +Apo |char** |hv_name_p |HV* hv +Apo |void |hv_name_set |HV* hv|const char *|STRLEN len|int flags Apo |I32* |hv_placeholders_p |HV* hv Apo |I32 |hv_placeholders_get |HV* hv Apo |void |hv_placeholders_set |HV* hv|I32 ph diff --git a/ext/Data/Dumper/Dumper.xs b/ext/Data/Dumper/Dumper.xs index ee1bc14..3f06b7b 100644 --- a/ext/Data/Dumper/Dumper.xs +++ b/ext/Data/Dumper/Dumper.xs @@ -14,6 +14,10 @@ static I32 DD_dump (pTHX_ SV *val, char *name, STRLEN namelen, SV *retval, I32 purity, I32 deepcopy, I32 quotekeys, SV *bless, I32 maxdepth, SV *sortkeys); +#ifndef HvNAME_get +#define HvNAME_get HvNAME +#endif + #if PERL_VERSION <= 6 /* Perl 5.6 and earlier */ # ifdef EBCDIC @@ -281,7 +285,7 @@ DD_dump(pTHX_ SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv, (void) sprintf(id, "0x%"UVxf, PTR2UV(ival)); idlen = strlen(id); if (SvOBJECT(ival)) - realpack = HvNAME(SvSTASH(ival)); + realpack = HvNAME_get(SvSTASH(ival)); else realpack = Nullch; diff --git a/ext/Devel/DProf/DProf.xs b/ext/Devel/DProf/DProf.xs index 10d4172..c840b24 100644 --- a/ext/Devel/DProf/DProf.xs +++ b/ext/Devel/DProf/DProf.xs @@ -42,8 +42,8 @@ dprof_dbg_sub_notify(pTHX_ SV *Sub) { GV *gv = cv ? CvGV(cv) : NULL; if (cv && gv) { warn("XS DBsub(%s::%s)\n", - ((GvSTASH(gv) && HvNAME(GvSTASH(gv))) ? - HvNAME(GvSTASH(gv)) : "(null)"), + ((GvSTASH(gv) && HvNAME_get(GvSTASH(gv))) ? + HvNAME_get(GvSTASH(gv)) : "(null)"), GvNAME(gv)); } else { warn("XS DBsub(unknown) at %x", Sub); @@ -371,9 +371,8 @@ prof_mark(pTHX_ opcode ptype) cv = db_get_cv(aTHX_ Sub); gv = CvGV(cv); - pname = ((GvSTASH(gv) && HvNAME(GvSTASH(gv))) - ? HvNAME(GvSTASH(gv)) - : (char *) "(null)"); + pname = GvSTASH(gv) ? HvNAME_get(GvSTASH(gv)) : 0; + pname = pname ? pname : (char *) "(null)"; gname = GvNAME(gv); set_cv_key(aTHX_ cv, pname, gname); diff --git a/ext/Opcode/Opcode.xs b/ext/Opcode/Opcode.xs index 067ffdb..78c7605 100644 --- a/ext/Opcode/Opcode.xs +++ b/ext/Opcode/Opcode.xs @@ -268,9 +268,9 @@ PPCODE: hv = gv_stashpv(Package, GV_ADDWARN); /* should exist already */ - if (strNE(HvNAME(hv),"main")) { - Safefree(HvNAME(hv)); - HvNAME(hv) = savepv("main"); /* make it think it's in main:: */ + if (strNE(HvNAME_get(hv),"main")) { + /* make it think it's in main:: */ + Perl_hv_name_set(aTHX_ hv, "main", 4, 0); hv_store(hv,"_",1,(SV *)PL_defgv,0); /* connect _ to global */ SvREFCNT_inc((SV *)PL_defgv); /* want to keep _ around! */ } diff --git a/ext/PerlIO/via/via.xs b/ext/PerlIO/via/via.xs index 36394dd..028a298 100644 --- a/ext/PerlIO/via/via.xs +++ b/ext/PerlIO/via/via.xs @@ -45,7 +45,7 @@ PerlIOVia_fetchmethod(pTHX_ PerlIOVia * s, char *method, CV ** save) { GV *gv = gv_fetchmeth(s->stash, method, strlen(method), 0); #if 0 - Perl_warn(aTHX_ "Lookup %s::%s => %p", HvNAME(s->stash), method, gv); + Perl_warn(aTHX_ "Lookup %s::%s => %p", HvNAME_get(s->stash), method, gv); #endif if (gv) { return *save = GvCV(gv); @@ -87,7 +87,7 @@ PerlIOVia_method(pTHX_ PerlIO * f, char *method, CV ** save, int flags, } if (*PerlIONext(f)) { if (!s->fh) { - GV *gv = newGVgen(HvNAME(s->stash)); + GV *gv = newGVgen(HvNAME_get(s->stash)); GvIOp(gv) = newIO(); s->fh = newRV_noinc((SV *) gv); s->io = GvIOp(gv); diff --git a/ext/Storable/Storable.xs b/ext/Storable/Storable.xs index 68d8e26..53f9543 100644 --- a/ext/Storable/Storable.xs +++ b/ext/Storable/Storable.xs @@ -107,6 +107,24 @@ typedef double NV; /* Older perls lack the NV type */ #define dVAR dNOOP #endif +#ifndef HvRITER_set +# define HvRITER_set(hv,r) (*HvRITER(hv) = r) +#endif +#ifndef HvEITER_set +# define HvEITER_set(hv,r) (*HvEITER(hv) = r) +#endif + +#ifndef HvRITER_get +# define HvRITER_get HvRITER +#endif +#ifndef HvEITER_get +# define HvEITER_get HvEITER +#endif + +#ifndef HvNAME_get +#define HvNAME_get HvNAME +#endif + #ifndef HvPLACEHOLDERS_get # define HvPLACEHOLDERS_get HvPLACEHOLDERS #endif @@ -1637,6 +1655,8 @@ static SV *pkg_fetchmeth( { GV *gv; SV *sv; + const char *hvname = HvNAME_get(pkg); + /* * The following code is the same as the one performed by UNIVERSAL::can @@ -1646,10 +1666,10 @@ static SV *pkg_fetchmeth( gv = gv_fetchmethod_autoload(pkg, method, FALSE); if (gv && isGV(gv)) { sv = newRV((SV*) GvCV(gv)); - TRACEME(("%s->%s: 0x%"UVxf, HvNAME(pkg), method, PTR2UV(sv))); + TRACEME(("%s->%s: 0x%"UVxf, hvname, method, PTR2UV(sv))); } else { sv = newSVsv(&PL_sv_undef); - TRACEME(("%s->%s: not found", HvNAME(pkg), method)); + TRACEME(("%s->%s: not found", hvname, method)); } /* @@ -1657,7 +1677,7 @@ static SV *pkg_fetchmeth( * it just won't be cached. */ - (void) hv_store(cache, HvNAME(pkg), strlen(HvNAME(pkg)), sv, 0); + (void) hv_store(cache, hvname, strlen(hvname), sv, 0); return SvOK(sv) ? sv : (SV *) 0; } @@ -1673,8 +1693,9 @@ static void pkg_hide( HV *pkg, char *method) { + const char *hvname = HvNAME_get(pkg); (void) hv_store(cache, - HvNAME(pkg), strlen(HvNAME(pkg)), newSVsv(&PL_sv_undef), 0); + hvname, strlen(hvname), newSVsv(&PL_sv_undef), 0); } /* @@ -1688,7 +1709,8 @@ static void pkg_uncache( HV *pkg, char *method) { - (void) hv_delete(cache, HvNAME(pkg), strlen(HvNAME(pkg)), G_DISCARD); + const char *hvname = HvNAME_get(pkg); + (void) hv_delete(cache, hvname, strlen(hvname), G_DISCARD); } /* @@ -1707,8 +1729,9 @@ static SV *pkg_can( { SV **svh; SV *sv; + const char *hvname = HvNAME_get(pkg); - TRACEME(("pkg_can for %s->%s", HvNAME(pkg), method)); + TRACEME(("pkg_can for %s->%s", hvname, method)); /* * Look into the cache to see whether we already have determined @@ -1718,15 +1741,15 @@ static SV *pkg_can( * that only one hook (i.e. always the same) is cached in a given cache. */ - svh = hv_fetch(cache, HvNAME(pkg), strlen(HvNAME(pkg)), FALSE); + svh = hv_fetch(cache, hvname, strlen(hvname), FALSE); if (svh) { sv = *svh; if (!SvOK(sv)) { - TRACEME(("cached %s->%s: not found", HvNAME(pkg), method)); + TRACEME(("cached %s->%s: not found", hvname, method)); return (SV *) 0; } else { TRACEME(("cached %s->%s: 0x%"UVxf, - HvNAME(pkg), method, PTR2UV(sv))); + hvname, method, PTR2UV(sv))); return sv; } } @@ -2260,8 +2283,8 @@ static int store_hash(pTHX_ stcxt_t *cxt, HV *hv) * Save possible iteration state via each() on that table. */ - riter = HvRITER(hv); - eiter = HvEITER(hv); + riter = HvRITER_get(hv); + eiter = HvEITER_get(hv); hv_iterinit(hv); /* @@ -2529,8 +2552,8 @@ static int store_hash(pTHX_ stcxt_t *cxt, HV *hv) TRACEME(("ok (hash 0x%"UVxf")", PTR2UV(hv))); out: - HvRITER(hv) = riter; /* Restore hash iterator state */ - HvEITER(hv) = eiter; + HvRITER_set(hv, riter); /* Restore hash iterator state */ + HvEITER_set(hv, eiter); return ret; } @@ -2835,7 +2858,7 @@ static int store_hook( char mtype = '\0'; /* for blessed ref to tied structures */ unsigned char eflags = '\0'; /* used when object type is SHT_EXTRA */ - TRACEME(("store_hook, classname \"%s\", tagged #%d", HvNAME(pkg), cxt->tagnum)); + TRACEME(("store_hook, classname \"%s\", tagged #%d", HvNAME_get(pkg), cxt->tagnum)); /* * Determine object type on 2 bits. @@ -2886,7 +2909,7 @@ static int store_hook( } flags = SHF_NEED_RECURSE | obj_type; - classname = HvNAME(pkg); + classname = HvNAME_get(pkg); len = strlen(classname); /* @@ -3254,7 +3277,7 @@ static int store_blessed( char *classname; I32 classnum; - TRACEME(("store_blessed, type %d, class \"%s\"", type, HvNAME(pkg))); + TRACEME(("store_blessed, type %d, class \"%s\"", type, HvNAME_get(pkg))); /* * Look for a hook for this blessed SV and redirect to store_hook() @@ -3269,7 +3292,7 @@ static int store_blessed( * This is a blessed SV without any serialization hook. */ - classname = HvNAME(pkg); + classname = HvNAME_get(pkg); len = strlen(classname); TRACEME(("blessed 0x%"UVxf" in %s, no hook: tagged #%d", @@ -4511,7 +4534,7 @@ static SV *retrieve_overloaded(pTHX_ stcxt_t *cxt, char *cname) } if (!Gv_AMG(stash)) { SV *psv = newSVpvn("require ", 8); - const char *package = HvNAME(stash); + const char *package = HvNAME_get(stash); sv_catpv(psv, package); TRACEME(("No overloading defined for package %s", package)); diff --git a/ext/threads/shared/shared.xs b/ext/threads/shared/shared.xs index dcaa7e7..aa1dcf2 100644 --- a/ext/threads/shared/shared.xs +++ b/ext/threads/shared/shared.xs @@ -529,7 +529,7 @@ sharedsv_scalar_store(pTHX_ SV *sv, shared_sv *shared) sv_setsv_nomg(SHAREDSvPTR(shared), tmp); SvREFCNT_dec(tmp); if(SvOBJECT(SvRV(sv))) { - SV* fake_stash = newSVpv(HvNAME(SvSTASH(SvRV(sv))),0); + SV* fake_stash = newSVpv(HvNAME_get(SvSTASH(SvRV(sv))),0); SvOBJECT_on(SHAREDSvPTR(target)); SvSTASH_set(SHAREDSvPTR(target), (HV*)fake_stash); } @@ -544,7 +544,7 @@ sharedsv_scalar_store(pTHX_ SV *sv, shared_sv *shared) SHARED_CONTEXT; sv_setsv_nomg(SHAREDSvPTR(shared), sv); if(SvOBJECT(sv)) { - SV* fake_stash = newSVpv(HvNAME(SvSTASH(sv)),0); + SV* fake_stash = newSVpv(HvNAME_get(SvSTASH(sv)),0); SvOBJECT_on(SHAREDSvPTR(shared)); SvSTASH_set(SHAREDSvPTR(shared), (HV*)fake_stash); } @@ -1294,7 +1294,7 @@ bless(SV* ref, ...); ENTER_LOCK; SHARED_CONTEXT; { - SV* fake_stash = newSVpv(HvNAME(stash),0); + SV* fake_stash = newSVpv(HvNAME_get(stash),0); (void)sv_bless(SHAREDSvPTR(shared),(HV*)fake_stash); } CALLER_CONTEXT; diff --git a/global.sym b/global.sym index c982795..cc938bc 100644 --- a/global.sym +++ b/global.sym @@ -675,6 +675,12 @@ Perl_save_set_svflags Perl_hv_assert Perl_hv_clear_placeholders Perl_hv_scalar +Perl_hv_riter_p +Perl_hv_eiter_p +Perl_hv_riter_set +Perl_hv_eiter_set +Perl_hv_name_p +Perl_hv_name_set Perl_hv_placeholders_p Perl_hv_placeholders_get Perl_hv_placeholders_set diff --git a/gv.c b/gv.c index 5d533f0..40a0e8d 100644 --- a/gv.c +++ b/gv.c @@ -201,6 +201,7 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) GV* gv; GV** gvp; CV* cv; + const char *hvname; /* UNIVERSAL methods should be callable without a stash */ if (!stash) { @@ -209,15 +210,16 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) return 0; } - if (!HvNAME(stash)) + hvname = HvNAME_get(stash); + if (!hvname) Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup"); if ((level > 100) || (level < -100)) Perl_croak(aTHX_ "Recursive inheritance detected while looking for method '%s' in package '%s'", - name, HvNAME(stash)); + name, hvname); - DEBUG_o( Perl_deb(aTHX_ "Looking for method %s in package %s\n",name,HvNAME(stash)) ); + DEBUG_o( Perl_deb(aTHX_ "Looking for method %s in package %s\n",name,hvname) ); gvp = (GV**)hv_fetch(stash, name, len, (level >= 0)); if (!gvp) @@ -244,19 +246,19 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) /* create and re-create @.*::SUPER::ISA on demand */ if (!av || !SvMAGIC(av)) { - const char* packname = HvNAME(stash); - STRLEN packlen = strlen(packname); + /* FIXME - get this from the symtab magic. */ + STRLEN packlen = strlen(hvname); - if (packlen >= 7 && strEQ(packname + packlen - 7, "::SUPER")) { + if (packlen >= 7 && strEQ(hvname + packlen - 7, "::SUPER")) { HV* basestash; packlen -= 7; - basestash = gv_stashpvn(packname, packlen, TRUE); + basestash = gv_stashpvn(hvname, packlen, TRUE); gvp = (GV**)hv_fetch(basestash, "ISA", 3, FALSE); if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) { gvp = (GV**)hv_fetch(stash, "ISA", 3, TRUE); if (!gvp || !(gv = *gvp)) - Perl_croak(aTHX_ "Cannot create %s::ISA", HvNAME(stash)); + Perl_croak(aTHX_ "Cannot create %s::ISA", hvname); if (SvTYPE(gv) != SVt_PVGV) gv_init(gv, stash, "ISA", 3, TRUE); SvREFCNT_dec(GvAV(gv)); @@ -275,7 +277,7 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) if (!basestash) { if (ckWARN(WARN_MISC)) Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA", - sv, HvNAME(stash)); + sv, hvname); continue; } gv = gv_fetchmeth(basestash, name, len, @@ -435,7 +437,7 @@ Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload) /* __PACKAGE__::SUPER stash should be autovivified */ stash = gv_stashpvn(SvPVX_const(tmpstr), SvCUR(tmpstr), TRUE); DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n", - origname, HvNAME(stash), name) ); + origname, HvNAME_get(stash), name) ); } else { /* don't autovifify if ->NoSuchStash::method */ @@ -500,7 +502,7 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method) stash = Nullhv; } else { - packname = HvNAME(stash); + packname = HvNAME_get(stash); } } if (!(gv = gv_fetchmeth(stash, S_autoload, S_autolen, FALSE))) @@ -629,8 +631,8 @@ Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 create) if (!GvHV(tmpgv)) GvHV(tmpgv) = newHV(); stash = GvHV(tmpgv); - if (!HvNAME(stash)) - HvNAME(stash) = savepv(name); + if (!HvNAME_get(stash)) + Perl_hv_name_set(aTHX_ stash, name, namelen, 0); return stash; } @@ -718,8 +720,8 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, if (!(stash = GvHV(gv))) stash = GvHV(gv) = newHV(); - if (!HvNAME(stash)) - HvNAME(stash) = savepvn(nambeg, namend - nambeg); + if (!HvNAME_get(stash)) + Perl_hv_name_set(aTHX, stash, nambeg, namend - nambeg, 0); } if (*namend == ':') @@ -1131,7 +1133,7 @@ Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain) } sv_setpv(sv, prefix ? prefix : ""); - name = HvNAME(hv); + name = HvNAME_get(hv); if (!name) name = "__ANON__"; @@ -1242,7 +1244,7 @@ Perl_gv_check(pTHX_ HV *stash) #endif Perl_warner(aTHX_ packWARN(WARN_ONCE), "Name \"%s::%s\" used only once: possible typo", - HvNAME(stash), GvNAME(gv)); + HvNAME_get(stash), GvNAME(gv)); } } } @@ -1304,12 +1306,14 @@ Perl_gp_free(pTHX_ GV *gv) if (gp->gp_sv) SvREFCNT_dec(gp->gp_sv); if (gp->gp_av) SvREFCNT_dec(gp->gp_av); - if (gp->gp_hv) { - if (PL_stashcache && HvNAME(gp->gp_hv)) - hv_delete(PL_stashcache, - HvNAME(gp->gp_hv), strlen(HvNAME(gp->gp_hv)), - G_DISCARD); - SvREFCNT_dec(gp->gp_hv); + /* FIXME - another reference loop GV -> symtab -> GV ? + Somehow gp->gp_hv can end up pointing at freed garbage. */ + if (gp->gp_hv && SvTYPE(gp->gp_hv) == SVt_PVHV) { + /* FIXME strlen HvNAME */ + const char *hvname = HvNAME_get(gp->gp_hv); + if (PL_stashcache && hvname) + hv_delete(PL_stashcache, hvname, strlen(hvname), G_DISCARD); + SvREFCNT_dec(gp->gp_hv); } if (gp->gp_io) SvREFCNT_dec(gp->gp_io); if (gp->gp_cv) SvREFCNT_dec(gp->gp_cv); @@ -1354,7 +1358,7 @@ Perl_Gv_AMupdate(pTHX_ HV *stash) return (bool)AMT_OVERLOADED(amtp); sv_unmagic((SV*)stash, PERL_MAGIC_overload_table); - DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME(stash)) ); + DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) ); Zero(&amt,1,AMT); amt.was_ok_am = PL_amagic_generation; @@ -1390,7 +1394,7 @@ Perl_Gv_AMupdate(pTHX_ HV *stash) const STRLEN l = strlen(cooky); DEBUG_o( Perl_deb(aTHX_ "Checking overloading of `%s' in package `%.256s'\n", - cp, HvNAME(stash)) ); + cp, HvNAME_get(stash)) ); /* don't fill the cache while looking up! Creation of inheritance stubs in intermediate packages may conflict with the logic of runtime method substitution. @@ -1404,8 +1408,9 @@ Perl_Gv_AMupdate(pTHX_ HV *stash) gv = Perl_gv_fetchmeth(aTHX_ stash, cooky, l, -1); cv = 0; if (gv && (cv = GvCV(gv))) { + const char *hvname; if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil") - && strEQ(HvNAME(GvSTASH(CvGV(cv))), "overload")) { + && strEQ(hvname = HvNAME_get(GvSTASH(CvGV(cv))), "overload")) { /* This is a hack to support autoloading..., while knowing *which* methods were declared as overloaded. */ /* GvSV contains the name of the method. */ @@ -1413,7 +1418,7 @@ Perl_Gv_AMupdate(pTHX_ HV *stash) DEBUG_o( Perl_deb(aTHX_ "Resolving method `%"SVf256\ "' for overloaded `%s' in package `%.256s'\n", - GvSV(gv), cp, HvNAME(stash)) ); + GvSV(gv), cp, hvname) ); if (!SvPOK(GvSV(gv)) || !(ngv = gv_fetchmethod_autoload(stash, SvPVX_const(GvSV(gv)), FALSE))) @@ -1425,12 +1430,12 @@ Perl_Gv_AMupdate(pTHX_ HV *stash) "in package `%.256s'", (GvCVGEN(gv) ? "Stub found while resolving" : "Can't resolve"), - name, cp, HvNAME(stash)); + name, cp, hvname); } cv = GvCV(gv = ngv); } DEBUG_o( Perl_deb(aTHX_ "Overloading `%s' in package `%.256s' via `%.256s::%.256s' \n", - cp, HvNAME(stash), HvNAME(GvSTASH(CvGV(cv))), + cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv))) ); filled = 1; if (i < DESTROY_amg) @@ -1465,7 +1470,7 @@ Perl_gv_handler(pTHX_ HV *stash, I32 id) MAGIC *mg; AMT *amtp; - if (!stash || !HvNAME(stash)) + if (!stash || !HvNAME_get(stash)) return Nullcv; mg = mg_find((SV*)stash, PERL_MAGIC_overload_table); if (!mg) { @@ -1696,7 +1701,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) "in overloaded package ": "has no overloaded magic", SvAMAGIC(left)? - HvNAME(SvSTASH(SvRV(left))): + HvNAME_get(SvSTASH(SvRV(left))): "", SvAMAGIC(right)? ",\n\tright argument in overloaded package ": @@ -1704,7 +1709,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) ? "" : ",\n\tright argument has no overloaded magic"), SvAMAGIC(right)? - HvNAME(SvSTASH(SvRV(right))): + HvNAME_get(SvSTASH(SvRV(right))): "")); if (amtp && amtp->fallback >= AMGfallYES) { DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX_const(msg)) ); @@ -1729,7 +1734,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) flags & AMGf_unary? "" : lr==1 ? " for right argument": " for left argument", flags & AMGf_unary? " for argument" : "", - stash ? HvNAME(stash) : "null", + stash ? HvNAME_get(stash) : "null", fl? ",\n\tassignment variant used": "") ); } #endif diff --git a/hv.c b/hv.c index c12d20e..4daaf33 100644 --- a/hv.c +++ b/hv.c @@ -1027,7 +1027,8 @@ S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, *oentry = HeNEXT(entry); if (i && !*oentry) xhv->xhv_fill--; /* HvFILL(hv)-- */ - if (entry == xhv->xhv_eiter /* HvEITER(hv) */) + if (xhv->xhv_aux && entry + == ((struct xpvhv_aux *)xhv->xhv_aux)->xhv_eiter /* HvEITER(hv) */) HvLAZYDEL_on(hv); else hv_free_ent(hv, entry); @@ -1307,7 +1308,7 @@ Perl_newHV(pTHX) xhv->xhv_max = 7; /* HvMAX(hv) = 7 (start with 8 buckets) */ xhv->xhv_fill = 0; /* HvFILL(hv) = 0 */ - (void)hv_iterinit(hv); /* so each() will start off right */ + xhv->xhv_aux = 0; return hv; } @@ -1368,8 +1369,8 @@ Perl_newHVhv(pTHX_ HV *ohv) else { /* Iterate over ohv, copying keys and values one at a time. */ HE *entry; - const I32 riter = HvRITER(ohv); - HE * const eiter = HvEITER(ohv); + const I32 riter = HvRITER_get(ohv); + HE * const eiter = HvEITER_get(ohv); /* Can we use fewer buckets? (hv_max is always 2^n-1) */ while (hv_max && hv_max + 1 >= hv_fill * 2) @@ -1382,8 +1383,8 @@ Perl_newHVhv(pTHX_ HV *ohv) newSVsv(HeVAL(entry)), HeHASH(entry), HeKFLAGS(entry)); } - HvRITER(ohv) = riter; - HvEITER(ohv) = eiter; + HvRITER_set(ohv, riter); + HvEITER_set(ohv, eiter); } return hv; @@ -1397,7 +1398,7 @@ Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry) if (!entry) return; val = HeVAL(entry); - if (val && isGV(val) && GvCVu(val) && HvNAME(hv)) + if (val && isGV(val) && GvCVu(val) && HvNAME_get(hv)) PL_sub_generation++; /* may be deletion of method from stash */ SvREFCNT_dec(val); if (HeKLEN(entry) == HEf_SVKEY) { @@ -1416,7 +1417,7 @@ Perl_hv_delayfree_ent(pTHX_ HV *hv, register HE *entry) { if (!entry) return; - if (isGV(HeVAL(entry)) && GvCVu(HeVAL(entry)) && HvNAME(hv)) + if (isGV(HeVAL(entry)) && GvCVu(HeVAL(entry)) && HvNAME_get(hv)) PL_sub_generation++; /* may be deletion of method from stash */ sv_2mortal(HeVAL(entry)); /* free between statements */ if (HeKLEN(entry) == HEf_SVKEY) { @@ -1485,7 +1486,9 @@ Perl_hv_clear(pTHX_ HV *hv) HvHASKFLAGS_off(hv); HvREHASH_off(hv); reset: - HvEITER(hv) = NULL; + if (xhv->xhv_aux) { + HvEITER_set(hv, NULL); + } } /* @@ -1526,7 +1529,7 @@ Perl_hv_clear_placeholders(pTHX_ HV *hv) *oentry = HeNEXT(entry); if (first && !*oentry) HvFILL(hv)--; /* This linked list is now empty. */ - if (HvEITER(hv)) + if (HvEITER_get(hv)) HvLAZYDEL_on(hv); else hv_free_ent(hv, entry); @@ -1557,6 +1560,7 @@ S_hfreeentries(pTHX_ HV *hv) register HE *entry; I32 riter; I32 max; + struct xpvhv_aux *iter; if (!hv) return; @@ -1586,7 +1590,17 @@ S_hfreeentries(pTHX_ HV *hv) } } HvARRAY(hv) = array; - (void)hv_iterinit(hv); + + iter = ((XPVHV*) SvANY(hv))->xhv_aux; + if (iter) { + entry = iter->xhv_eiter; /* HvEITER(hv) */ + if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */ + HvLAZYDEL_off(hv); + hv_free_ent(hv, entry); + } + Safefree(iter); + ((XPVHV*) SvANY(hv))->xhv_aux = 0; + } } /* @@ -1601,17 +1615,18 @@ void Perl_hv_undef(pTHX_ HV *hv) { register XPVHV* xhv; + const char *name; if (!hv) return; DEBUG_A(Perl_hv_assert(aTHX_ hv)); xhv = (XPVHV*)SvANY(hv); hfreeentries(hv); Safefree(xhv->xhv_array /* HvARRAY(hv) */); - if (HvNAME(hv)) { + if ((name = HvNAME_get(hv))) { + /* FIXME - strlen HvNAME */ if(PL_stashcache) - hv_delete(PL_stashcache, HvNAME(hv), strlen(HvNAME(hv)), G_DISCARD); - Safefree(HvNAME(hv)); - HvNAME(hv) = 0; + hv_delete(PL_stashcache, name, strlen(name), G_DISCARD); + Perl_hv_name_set(aTHX_ hv, 0, 0, 0); } xhv->xhv_max = 7; /* HvMAX(hv) = 7 (it's a normal hash) */ xhv->xhv_array = 0; /* HvARRAY(hv) = 0 */ @@ -1621,6 +1636,19 @@ Perl_hv_undef(pTHX_ HV *hv) mg_clear((SV*)hv); } +struct xpvhv_aux* +S_hv_auxinit(aTHX) { + struct xpvhv_aux *iter; + + New(0, iter, 1, struct xpvhv_aux); + + iter->xhv_riter = -1; /* HvRITER(hv) = -1 */ + iter->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */ + iter->xhv_name = 0; + + return iter; +} + /* =for apidoc hv_iterinit @@ -1641,20 +1669,120 @@ Perl_hv_iterinit(pTHX_ HV *hv) { register XPVHV* xhv; HE *entry; + struct xpvhv_aux *iter; if (!hv) Perl_croak(aTHX_ "Bad hash"); xhv = (XPVHV*)SvANY(hv); - entry = xhv->xhv_eiter; /* HvEITER(hv) */ - if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */ - HvLAZYDEL_off(hv); - hv_free_ent(hv, entry); + + iter = xhv->xhv_aux; + if (iter) { + entry = iter->xhv_eiter; /* HvEITER(hv) */ + if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */ + HvLAZYDEL_off(hv); + hv_free_ent(hv, entry); + } + iter->xhv_riter = -1; /* HvRITER(hv) = -1 */ + iter->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */ + } else { + xhv->xhv_aux = S_hv_auxinit(aTHX); } - xhv->xhv_riter = -1; /* HvRITER(hv) = -1 */ - xhv->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */ + /* used to be xhv->xhv_fill before 5.004_65 */ return XHvTOTALKEYS(xhv); } + +I32 * +Perl_hv_riter_p(pTHX_ HV *hv) { + struct xpvhv_aux *iter; + + if (!hv) + Perl_croak(aTHX_ "Bad hash"); + + iter = ((XPVHV *)SvANY(hv))->xhv_aux; + if (!iter) { + ((XPVHV *)SvANY(hv))->xhv_aux = iter = S_hv_auxinit(aTHX); + } + return &(iter->xhv_riter); +} + +HE ** +Perl_hv_eiter_p(pTHX_ HV *hv) { + struct xpvhv_aux *iter; + + if (!hv) + Perl_croak(aTHX_ "Bad hash"); + + iter = ((XPVHV *)SvANY(hv))->xhv_aux; + if (!iter) { + ((XPVHV *)SvANY(hv))->xhv_aux = iter = S_hv_auxinit(aTHX); + } + return &(iter->xhv_eiter); +} + +void +Perl_hv_riter_set(pTHX_ HV *hv, I32 riter) { + struct xpvhv_aux *iter; + + if (!hv) + Perl_croak(aTHX_ "Bad hash"); + + + iter = ((XPVHV *)SvANY(hv))->xhv_aux; + if (!iter) { + if (riter == -1) + return; + + ((XPVHV *)SvANY(hv))->xhv_aux = iter = S_hv_auxinit(aTHX); + } + iter->xhv_riter = riter; +} + +void +Perl_hv_eiter_set(pTHX_ HV *hv, HE *eiter) { + struct xpvhv_aux *iter; + + if (!hv) + Perl_croak(aTHX_ "Bad hash"); + + iter = ((XPVHV *)SvANY(hv))->xhv_aux; + if (!iter) { + /* 0 is the default so don't go malloc()ing a new structure just to + hold 0. */ + if (!eiter) + return; + + ((XPVHV *)SvANY(hv))->xhv_aux = iter = S_hv_auxinit(aTHX); + } + iter->xhv_eiter = eiter; +} + + +char ** +Perl_hv_name_p(pTHX_ HV *hv) +{ + struct xpvhv_aux *iter = ((XPVHV *)SvANY(hv))->xhv_aux; + + if (!iter) { + ((XPVHV *)SvANY(hv))->xhv_aux = iter = S_hv_auxinit(aTHX); + } + return &(iter->xhv_name); +} + +void +Perl_hv_name_set(pTHX_ HV *hv, const char *name, STRLEN len, int flags) +{ + struct xpvhv_aux *iter = ((XPVHV *)SvANY(hv))->xhv_aux; + + if (!iter) { + if (name == 0) + return; + + ((XPVHV *)SvANY(hv))->xhv_aux = iter = S_hv_auxinit(aTHX); + } + iter->xhv_name = savepvn(name, len); +} + /* =for apidoc hv_iternext @@ -1700,11 +1828,22 @@ Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags) register HE *entry; HE *oldentry; MAGIC* mg; + struct xpvhv_aux *iter; if (!hv) Perl_croak(aTHX_ "Bad hash"); xhv = (XPVHV*)SvANY(hv); - oldentry = entry = xhv->xhv_eiter; /* HvEITER(hv) */ + iter = xhv->xhv_aux; + + if (!iter) { + /* Too many things (well, pp_each at least) merrily assume that you can + call iv_iternext without calling hv_iterinit, so we'll have to deal + with it. */ + hv_iterinit(hv); + iter = ((XPVHV *)SvANY(hv))->xhv_aux; + } + + oldentry = entry = iter->xhv_eiter; /* HvEITER(hv) */ if ((mg = SvTIED_mg((SV*)hv, PERL_MAGIC_tied))) { SV *key = sv_newmortal(); @@ -1717,7 +1856,7 @@ Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags) HEK *hek; /* one HE per MAGICAL hash */ - xhv->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */ + iter->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */ Zero(entry, 1, HE); Newz(54, k, HEK_BASESIZE + sizeof(SV*), char); hek = (HEK*)k; @@ -1734,7 +1873,7 @@ Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags) SvREFCNT_dec(HeVAL(entry)); Safefree(HeKEY_hek(entry)); del_HE(entry); - xhv->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */ + iter->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */ return Null(HE*); } #ifdef DYNAMIC_ENV_FETCH /* set up %ENV for iteration */ @@ -1763,14 +1902,14 @@ Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags) while (!entry) { /* OK. Come to the end of the current list. Grab the next one. */ - xhv->xhv_riter++; /* HvRITER(hv)++ */ - if (xhv->xhv_riter > (I32)xhv->xhv_max /* HvRITER(hv) > HvMAX(hv) */) { + iter->xhv_riter++; /* HvRITER(hv)++ */ + if (iter->xhv_riter > (I32)xhv->xhv_max /* HvRITER(hv) > HvMAX(hv) */) { /* There is no next one. End of the hash. */ - xhv->xhv_riter = -1; /* HvRITER(hv) = -1 */ + iter->xhv_riter = -1; /* HvRITER(hv) = -1 */ break; } /* entry = (HvARRAY(hv))[HvRITER(hv)]; */ - entry = ((HE**)xhv->xhv_array)[xhv->xhv_riter]; + entry = ((HE**)xhv->xhv_array)[iter->xhv_riter]; if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) { /* If we have an entry, but it's a placeholder, don't count it. @@ -1791,7 +1930,7 @@ Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags) /*if (HvREHASH(hv) && entry && !HeKREHASH(entry)) PerlIO_printf(PerlIO_stderr(), "Awooga %p %p\n", hv, entry);*/ - xhv->xhv_eiter = entry; /* HvEITER(hv) = entry */ + iter->xhv_eiter = entry; /* HvEITER(hv) = entry */ return entry; } @@ -2184,8 +2323,8 @@ Perl_hv_assert(pTHX_ HV *hv) int placeholders = 0; int real = 0; int bad = 0; - const I32 riter = HvRITER(hv); - HE *eiter = HvEITER(hv); + const I32 riter = HvRITER_get(hv); + HE *eiter = HvEITER_get(hv); (void)hv_iterinit(hv); @@ -2233,8 +2372,8 @@ Perl_hv_assert(pTHX_ HV *hv) if (bad) { sv_dump((SV *)hv); } - HvRITER(hv) = riter; /* Restore hash iterator state */ - HvEITER(hv) = eiter; + HvRITER_set(hv, riter); /* Restore hash iterator state */ + HvEITER_set(hv, eiter); } /* diff --git a/hv.h b/hv.h index da3e0e6..2388113 100644 --- a/hv.h +++ b/hv.h @@ -29,6 +29,16 @@ struct hek { is UTF-8 */ }; + +/* Subject to change. + Don't access this directly. +*/ +struct xpvhv_aux { + char *xhv_name; /* name, if a symbol table */ + HE *xhv_eiter; /* current entry of iterator */ + I32 xhv_riter; /* current root of iterator */ +}; + /* hash structure: */ /* This structure must match the beginning of struct xpvmg in sv.h. */ struct xpvhv { @@ -40,10 +50,8 @@ struct xpvhv { MAGIC* xmg_magic; /* magic for scalar array */ HV* xmg_stash; /* class package */ - I32 xhv_riter; /* current root of iterator */ - HE *xhv_eiter; /* current entry of iterator */ + struct xpvhv_aux* xhv_aux; /* list of pm's for this package is now stored in symtab magic. */ - char *xhv_name; /* name, if a symbol table */ }; /* hash a key */ @@ -178,9 +186,19 @@ C. #define HvARRAY(hv) (*(HE***)&((XPVHV*) SvANY(hv))->xhv_array) #define HvFILL(hv) ((XPVHV*) SvANY(hv))->xhv_fill #define HvMAX(hv) ((XPVHV*) SvANY(hv))->xhv_max -#define HvRITER(hv) ((XPVHV*) SvANY(hv))->xhv_riter -#define HvEITER(hv) ((XPVHV*) SvANY(hv))->xhv_eiter -#define HvNAME(hv) ((XPVHV*) SvANY(hv))->xhv_name +#define HvRITER(hv) (*Perl_hv_riter_p(aTHX_ (HV*)(hv))) +#define HvEITER(hv) (*Perl_hv_eiter_p(aTHX_ (HV*)(hv))) +#define HvRITER_set(hv,r) Perl_hv_riter_set(aTHX_ (HV*)(hv), r) +#define HvEITER_set(hv,e) Perl_hv_eiter_set(aTHX_ (HV*)(hv), e) +#define HvRITER_get(hv) (((XPVHV *)SvANY(hv))->xhv_aux ? \ + ((struct xpvhv_aux*)((XPVHV *)SvANY(hv))->xhv_aux)->xhv_riter : -1) +#define HvEITER_get(hv) (((XPVHV *)SvANY(hv))->xhv_aux ? \ + ((struct xpvhv_aux *)((XPVHV *)SvANY(hv))->xhv_aux)->xhv_eiter : 0) +#define HvNAME(hv) (*Perl_hv_name_p(aTHX_ (HV*)hv)) +/* FIXME - all of these should use a UTF8 aware API, which should also involve + getting the length. */ +#define HvNAME_get(hv) (((XPVHV *)SvANY(hv))->xhv_aux ? \ + ((struct xpvhv_aux *)((XPVHV *)SvANY(hv))->xhv_aux)->xhv_name : 0) /* the number of keys (including any placeholers) */ #define XHvTOTALKEYS(xhv) ((xhv)->xhv_keys) @@ -318,3 +336,13 @@ C. /* available as a function in hv.c */ #define Perl_sharepvn(sv, len, hash) HEK_KEY(share_hek(sv, len, hash)) #define sharepvn(sv, len, hash) Perl_sharepvn(sv, len, hash) + +/* + * Local variables: + * c-indentation-style: bsd + * c-basic-offset: 4 + * indent-tabs-mode: t + * End: + * + * ex: set ts=8 sts=4 sw=4 noet: + */ diff --git a/mg.c b/mg.c index 1611d1f..f15dc26 100644 --- a/mg.c +++ b/mg.c @@ -1605,13 +1605,13 @@ Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg) if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) { SV *key; - if (HvEITER(hv)) + if (HvEITER_get(hv)) /* we are in an iteration so the hash cannot be empty */ return &PL_sv_yes; /* no xhv_eiter so now use FIRSTKEY */ key = sv_newmortal(); magic_nextpack((SV*)hv, mg, key); - HvEITER(hv) = NULL; /* need to reset iterator */ + HvEITER_set(hv, NULL); /* need to reset iterator */ return SvOK(key) ? &PL_sv_yes : &PL_sv_no; } diff --git a/op.c b/op.c index 17522bf..0e1e6b8 100644 --- a/op.c +++ b/op.c @@ -1535,7 +1535,7 @@ S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my) ENTER; /* need to protect against side-effects of 'use' */ SAVEINT(PL_expect); if (stash) - stashsv = newSVpv(HvNAME(stash), 0); + stashsv = newSVpv(HvNAME_get(stash), 0); else stashsv = &PL_sv_no; @@ -1589,7 +1589,7 @@ S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp) /* Build up the real arg-list. */ if (stash) - stashsv = newSVpv(HvNAME(stash), 0); + stashsv = newSVpv(HvNAME_get(stash), 0); else stashsv = &PL_sv_no; arg = newOP(OP_PADSV, 0); @@ -4654,7 +4654,7 @@ Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename) else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) { /* already defined (or promised) */ if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv)) - && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) { + && strEQ(HvNAME_get(GvSTASH(CvGV(cv))), "autouse"))) { const line_t oldline = CopLINE(PL_curcop); if (PL_copline != NOLINE) CopLINE_set(PL_curcop, PL_copline); @@ -6805,7 +6805,7 @@ Perl_peep(pTHX_ register OP *o) { Perl_croak(aTHX_ "No such class field \"%s\" " "in variable %s of type %s", - key, SvPV_nolen(lexname), HvNAME(SvSTASH(lexname))); + key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname))); } break; @@ -6862,7 +6862,7 @@ Perl_peep(pTHX_ register OP *o) { Perl_croak(aTHX_ "No such class field \"%s\" " "in variable %s of type %s", - key, SvPV_nolen(lexname), HvNAME(SvSTASH(lexname))); + key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname))); } } break; @@ -7134,7 +7134,7 @@ const_sv_xsub(pTHX_ CV* cv) if (items != 0) { #if 0 Perl_croak(aTHX_ "usage: %s::%s()", - HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv))); + HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv))); #endif } EXTEND(sp, 1); diff --git a/op.h b/op.h index 95cc1e6..f949179 100644 --- a/op.h +++ b/op.h @@ -330,13 +330,13 @@ struct pmop { # define PmopSTASHPV_set(o,pv) (PmopSTASHPV(o) = savesharedpv(pv)) # define PmopSTASH(o) (PmopSTASHPV(o) \ ? gv_stashpv(PmopSTASHPV(o),GV_ADD) : Nullhv) -# define PmopSTASH_set(o,hv) PmopSTASHPV_set(o, ((hv) ? HvNAME(hv) : Nullch)) +# define PmopSTASH_set(o,hv) PmopSTASHPV_set(o, ((hv) ? HvNAME_get(hv) : Nullch)) # define PmopSTASH_free(o) PerlMemShared_free(PmopSTASHPV(o)) #else # define PmopSTASH(o) ((o)->op_pmstash) # define PmopSTASH_set(o,hv) ((o)->op_pmstash = (hv)) -# define PmopSTASHPV(o) (PmopSTASH(o) ? HvNAME(PmopSTASH(o)) : Nullch) +# define PmopSTASHPV(o) (PmopSTASH(o) ? HvNAME_get(PmopSTASH(o)) : Nullch) /* op_pmstash is not refcounted */ # define PmopSTASHPV_set(o,pv) PmopSTASH_set((o), gv_stashpv(pv,GV_ADD)) # define PmopSTASH_free(o) diff --git a/perl.c b/perl.c index c6e5ee3..4ebcefa 100644 --- a/perl.c +++ b/perl.c @@ -3061,7 +3061,7 @@ S_init_main_stash(pTHX) SvREFCNT_dec(GvHV(gv)); GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash); SvREADONLY_on(gv); - HvNAME(PL_defstash) = savepvn("main", 4); + Perl_hv_name_set(aTHX_ PL_defstash, "main", 4, 0); PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV))); GvMULTI_on(PL_incgv); PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */ diff --git a/pp.c b/pp.c index 19e740b..f4d1163 100644 --- a/pp.c +++ b/pp.c @@ -600,7 +600,7 @@ PP(pp_gelem) break; case 'P': if (strEQ(elem2, "ACKAGE")) { - const char *name = HvNAME(GvSTASH(gv)); + const char *name = HvNAME_get(GvSTASH(gv)); sv = newSVpv(name ? name : "__ANON__", 0); } break; diff --git a/pp_hot.c b/pp_hot.c index 93184cf..1f9abc3 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -1717,7 +1717,7 @@ PP(pp_helem) RETURN; } if (PL_op->op_private & OPpLVAL_INTRO) { - if (HvNAME(hv) && isGV(*svp)) + if (HvNAME_get(hv) && isGV(*svp)) save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL)); else { if (!preeminent) { @@ -3089,7 +3089,7 @@ S_method_common(pTHX_ SV* meth, U32* hashp) if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) { /* the method name is unqualified or starts with SUPER:: */ packname = sep ? CopSTASHPV(PL_curcop) : - stash ? HvNAME(stash) : packname; + stash ? HvNAME_get(stash) : packname; if (!packname) Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup"); diff --git a/pp_sys.c b/pp_sys.c index a75b87c..ab55aff 100644 --- a/pp_sys.c +++ b/pp_sys.c @@ -798,7 +798,7 @@ PP(pp_tie) switch(SvTYPE(varsv)) { case SVt_PVHV: methname = "TIEHASH"; - HvEITER((HV *)varsv) = Null(HE *); + HvEITER_set((HV *)varsv, 0); break; case SVt_PVAV: methname = "TIEARRAY"; diff --git a/proto.h b/proto.h index 8f8ab0a..3b07c32 100644 --- a/proto.h +++ b/proto.h @@ -2311,7 +2311,12 @@ STATIC HE* S_hv_fetch_common(pTHX_ HV* tb, SV* key_sv, const char* key, STRLEN k PERL_CALLCONV void Perl_hv_clear_placeholders(pTHX_ HV* hb); PERL_CALLCONV SV* Perl_hv_scalar(pTHX_ HV* hv); - +PERL_CALLCONV I32* Perl_hv_riter_p(pTHX_ HV* hv); +PERL_CALLCONV HE** Perl_hv_eiter_p(pTHX_ HV* hv); +PERL_CALLCONV void Perl_hv_riter_set(pTHX_ HV* hv, I32 riter); +PERL_CALLCONV void Perl_hv_eiter_set(pTHX_ HV* hv, HE* eiter); +PERL_CALLCONV char** Perl_hv_name_p(pTHX_ HV* hv); +PERL_CALLCONV void Perl_hv_name_set(pTHX_ HV* hv, const char *, STRLEN len, int flags); PERL_CALLCONV I32* Perl_hv_placeholders_p(pTHX_ HV* hv); PERL_CALLCONV I32 Perl_hv_placeholders_get(pTHX_ HV* hv); PERL_CALLCONV void Perl_hv_placeholders_set(pTHX_ HV* hv, I32 ph); diff --git a/sv.c b/sv.c index 49e02f2..51a3896 100644 --- a/sv.c +++ b/sv.c @@ -754,7 +754,7 @@ S_varname(pTHX_ GV *gv, const char *gvtype, PADOFFSET targ, sv_setpv(name, gvtype); if (!hv) p = "???"; - else if (!(p=HvNAME(hv))) + else if (!(p=HvNAME_get(hv))) p = "__ANON__"; if (strNE(p, "main")) { sv_catpv(name,p); @@ -1970,9 +1970,7 @@ Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt) break; case SVt_PVHV: SvANY(sv) = new_XPVHV(); - HvRITER(sv) = 0; - HvEITER(sv) = 0; - HvNAME(sv) = 0; + ((XPVHV*) SvANY(sv))->xhv_aux = 0; HvFILL(sv) = 0; HvMAX(sv) = 0; HvTOTALKEYS(sv) = 0; @@ -3659,7 +3657,7 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) } tsv = NEWSV(0,0); if (SvOBJECT(sv)) { - const char *name = HvNAME(SvSTASH(sv)); + const char *name = HvNAME_get(SvSTASH(sv)); Perl_sv_setpvf(aTHX_ tsv, "%s=%s(0x%"UVxf")", name ? name : "__ANON__" , typestr, PTR2UV(sv)); } @@ -4451,7 +4449,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) CvCONST(cv) ? "Constant subroutine %s::%s redefined" : "Subroutine %s::%s redefined", - HvNAME(GvSTASH((GV*)dstr)), + HvNAME_get(GvSTASH((GV*)dstr)), GvENAME((GV*)dstr)); } } @@ -5561,6 +5559,7 @@ Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 nam case PERL_MAGIC_vec: vtable = &PL_vtbl_vec; break; + case PERL_MAGIC_rhash: case PERL_MAGIC_symtab: case PERL_MAGIC_vstring: vtable = 0; @@ -5961,7 +5960,7 @@ Perl_sv_clear(pTHX_ register SV *sv) if (SvREFCNT(sv)) { if (PL_in_clean_objs) Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'", - HvNAME(stash)); + HvNAME_get(stash)); /* DESTROY gave object new lease on life */ return; } @@ -7983,7 +7982,7 @@ Perl_sv_reset(pTHX_ register const char *s, HV *stash) if (GvAV(gv)) { av_clear(GvAV(gv)); } - if (GvHV(gv) && !HvNAME(GvHV(gv))) { + if (GvHV(gv) && !HvNAME_get(GvHV(gv))) { hv_clear(GvHV(gv)); #ifndef PERL_MICRO #ifdef USE_ENVIRON_ARRAY @@ -8454,7 +8453,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(SvSTASH(sv)); + char *name = HvNAME_get(SvSTASH(sv)); return name ? name : (char *) "__ANON__"; } else { @@ -8529,6 +8528,7 @@ an inheritance relationship. int Perl_sv_isa(pTHX_ SV *sv, const char *name) { + const char *hvname; if (!sv) return 0; if (SvGMAGICAL(sv)) @@ -8538,10 +8538,11 @@ Perl_sv_isa(pTHX_ SV *sv, const char *name) sv = (SV*)SvRV(sv); if (!SvOBJECT(sv)) return 0; - if (!HvNAME(SvSTASH(sv))) + hvname = HvNAME_get(SvSTASH(sv)); + if (!hvname) return 0; - return strEQ(HvNAME(SvSTASH(sv)), name); + return strEQ(hvname, name); } /* @@ -10676,7 +10677,7 @@ S_gv_share(pTHX_ SV *sstr, CLONE_PARAMS *param) if (!GvUNIQUE(gv)) { #if 0 PerlIO_printf(Perl_debug_log, "gv_share: unable to share %s::%s\n", - HvNAME(GvSTASH(gv)), GvNAME(gv)); + HvNAME_get(GvSTASH(gv)), GvNAME(gv)); #endif return Nullsv; } @@ -10782,11 +10783,12 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param) if(param->flags & CLONEf_JOIN_IN) { /** We are joining here so we don't want do clone something that is bad **/ + const char *hvname; if(SvTYPE(sstr) == SVt_PVHV && - HvNAME(sstr)) { + (hvname = HvNAME_get(sstr))) { /** don't clone stashes if they already exist **/ - HV* old_stash = gv_stashpv(HvNAME(sstr),0); + HV* old_stash = gv_stashpv(hvname,0); return (SV*) old_stash; } } @@ -10914,7 +10916,7 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param) ptr_table_store(PL_ptr_table, sstr, dstr); #if 0 PerlIO_printf(Perl_debug_log, "sv_dup: sharing %s::%s\n", - HvNAME(GvSTASH(share)), GvNAME(share)); + HvNAME_get(GvSTASH(share)), GvNAME(share)); #endif break; } @@ -11020,30 +11022,43 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param) SvNV_set(dstr, SvNVX(sstr)); SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param)); SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param)); - HvRITER((HV*)dstr) = HvRITER((HV*)sstr); - if (HvARRAY((HV*)sstr)) { - STRLEN i = 0; - XPVHV *dxhv = (XPVHV*)SvANY(dstr); - XPVHV *sxhv = (XPVHV*)SvANY(sstr); - Newz(0, dxhv->xhv_array, - PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char); - while (i <= sxhv->xhv_max) { - ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i], - (bool)!!HvSHAREKEYS(sstr), - param); - ++i; + { + const char *hvname = HvNAME_get((HV*)sstr); + struct xpvhv_aux *aux = ((XPVHV *)SvANY(sstr))->xhv_aux; + + if (aux) { + New(0, ((XPVHV *)SvANY(dstr))->xhv_aux, 1, struct xpvhv_aux); + HvRITER_set((HV*)dstr, HvRITER_get((HV*)sstr)); + /* FIXME strlen HvNAME */ + Perl_hv_name_set(aTHX_ (HV*) dstr, hvname, + hvname ? strlen(hvname) : 0, + 0); + } else { + ((XPVHV *)SvANY(dstr))->xhv_aux = 0; } - dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, - (bool)!!HvSHAREKEYS(sstr), param); - } - else { - SvPV_set(dstr, Nullch); - HvEITER((HV*)dstr) = (HE*)NULL; + if (HvARRAY((HV*)sstr)) { + STRLEN i = 0; + XPVHV *dxhv = (XPVHV*)SvANY(dstr); + XPVHV *sxhv = (XPVHV*)SvANY(sstr); + Newz(0, dxhv->xhv_array, + PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char); + while (i <= sxhv->xhv_max) { + ((HE**)dxhv->xhv_array)[i] + = he_dup(((HE**)sxhv->xhv_array)[i], + (bool)!!HvSHAREKEYS(sstr), param); + ++i; + } + HvEITER_set(dstr, he_dup(HvEITER_get(sstr), + (bool)!!HvSHAREKEYS(sstr), param)); + } + else { + SvPV_set(dstr, Nullch); + HvEITER_set((HV*)dstr, (HE*)NULL); + } + /* Record stashes for possible cloning in Perl_clone(). */ + if(hvname) + av_push(param->stashes, dstr); } - HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr)); - /* Record stashes for possible cloning in Perl_clone(). */ - if(HvNAME((HV*)dstr)) - av_push(param->stashes, dstr); break; case SVt_PVFM: SvANY(dstr) = new_XPVFM(); @@ -11547,7 +11562,8 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) static void do_mark_cloneable_stash(pTHX_ SV *sv) { - if (HvNAME((HV*)sv)) { + const char *hvname = HvNAME_get((HV*)sv); + if (hvname) { GV* cloner = gv_fetchmethod_autoload((HV*)sv, "CLONE_SKIP", 0); SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */ if (cloner && GvCV(cloner)) { @@ -11557,7 +11573,7 @@ do_mark_cloneable_stash(pTHX_ SV *sv) ENTER; SAVETMPS; PUSHMARK(SP); - XPUSHs(sv_2mortal(newSVpv(HvNAME((HV*)sv), 0))); + XPUSHs(sv_2mortal(newSVpv(hvname, 0))); PUTBACK; call_sv((SV*)GvCV(cloner), G_SCALAR); SPAGAIN; @@ -12406,7 +12422,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, ENTER; SAVETMPS; PUSHMARK(SP); - XPUSHs(sv_2mortal(newSVpv(HvNAME(stash), 0))); + XPUSHs(sv_2mortal(newSVpv(HvNAME_get(stash), 0))); PUTBACK; call_sv((SV*)GvCV(cloner), G_DISCARD); FREETMPS; diff --git a/toke.c b/toke.c index b570040..d496f48 100644 --- a/toke.c +++ b/toke.c @@ -4346,7 +4346,7 @@ Perl_yylex(pTHX) case KEY___PACKAGE__: yylval.opval = (OP*)newSVOP(OP_CONST, 0, (PL_curstash - ? newSVpv(HvNAME(PL_curstash), 0) + ? newSVpv(HvNAME_get(PL_curstash), 0) : &PL_sv_undef)); TERM(THING); @@ -4358,7 +4358,7 @@ Perl_yylex(pTHX) if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) { const char *pname = "main"; if (PL_tokenbuf[2] == 'D') - pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash); + pname = HvNAME_get(PL_curstash ? PL_curstash : PL_defstash); gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), TRUE, SVt_PVIO); GvMULTI_on(gv); if (!GvIO(gv)) @@ -5536,7 +5536,7 @@ S_pending_ident(pTHX) /* might be an "our" variable" */ if (PAD_COMPNAME_FLAGS(tmp) & SVpad_OUR) { /* build ops for a bareword */ - SV *sym = newSVpv(HvNAME(PAD_COMPNAME_OURSTASH(tmp)), 0); + SV *sym = newSVpv(HvNAME_get(PAD_COMPNAME_OURSTASH(tmp)), 0); sv_catpvn(sym, "::", 2); sv_catpv(sym, PL_tokenbuf+1); yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym); @@ -9737,7 +9737,7 @@ S_scan_inputsymbol(pTHX_ char *start) if ((tmp = pad_findmy(d)) != NOT_IN_PAD) { if (PAD_COMPNAME_FLAGS(tmp) & SVpad_OUR) { SV *sym = sv_2mortal( - newSVpv(HvNAME(PAD_COMPNAME_OURSTASH(tmp)),0)); + newSVpv(HvNAME_get(PAD_COMPNAME_OURSTASH(tmp)),0)); sv_catpvn(sym, "::", 2); sv_catpv(sym, d+1); d = SvPVX(sym); diff --git a/universal.c b/universal.c index b62e368..e02bf00 100644 --- a/universal.c +++ b/universal.c @@ -40,13 +40,16 @@ S_isa_lookup(pTHX_ HV *stash, const char *name, HV* name_stash, GV** gvp; HV* hv = Nullhv; SV* subgen = Nullsv; + const char *hvname; /* A stash/class can go by many names (ie. User == main::User), so we compare the stash itself just in case */ if (name_stash && (stash == name_stash)) return &PL_sv_yes; - if (strEQ(HvNAME(stash), name)) + hvname = HvNAME_get(stash); + + if (strEQ(hvname, name)) return &PL_sv_yes; if (strEQ(name, "UNIVERSAL")) @@ -54,7 +57,7 @@ S_isa_lookup(pTHX_ HV *stash, const char *name, HV* name_stash, if (level > 100) Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'", - HvNAME(stash)); + hvname); gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, FALSE); @@ -66,13 +69,13 @@ S_isa_lookup(pTHX_ HV *stash, const char *name, HV* name_stash, SV** svp = (SV**)hv_fetch(hv, name, len, FALSE); if (svp && (sv = *svp) != (SV*)&PL_sv_undef) { DEBUG_o( Perl_deb(aTHX_ "Using cached ISA %s for package %s\n", - name, HvNAME(stash)) ); + name, hvname) ); return sv; } } else { DEBUG_o( Perl_deb(aTHX_ "ISA Cache in package %s is stale\n", - HvNAME(stash)) ); + hvname) ); hv_clear(hv); sv_setiv(subgen, PL_sub_generation); } @@ -106,8 +109,8 @@ S_isa_lookup(pTHX_ HV *stash, const char *name, HV* name_stash, if (!basestash) { if (ckWARN(WARN_MISC)) Perl_warner(aTHX_ packWARN(WARN_SYNTAX), - "Can't locate package %"SVf" for @%s::ISA", - sv, HvNAME(stash)); + "Can't locate package %"SVf" for @%s::ISA", + sv, hvname); continue; } if (&PL_sv_yes == isa_lookup(basestash, name, name_stash, @@ -348,11 +351,12 @@ XS(XS_UNIVERSAL_VERSION) SV *req = ST(1); if (undef) { - if (pkg) + if (pkg) { + const char *name = HvNAME_get(pkg); Perl_croak(aTHX_ - "%s does not define $%s::VERSION--version check failed", - HvNAME(pkg), HvNAME(pkg)); - else { + "%s does not define $%s::VERSION--version check failed", + name, name); + } else { STRLEN n_a; Perl_croak(aTHX_ "%s defines neither package nor VERSION--version check failed", @@ -370,7 +374,7 @@ XS(XS_UNIVERSAL_VERSION) if ( vcmp( req, sv ) > 0 ) Perl_croak(aTHX_ "%s version %"SVf" (%"SVf") required--" - "this is only version %"SVf" (%"SVf")", HvNAME(pkg), + "this is only version %"SVf" (%"SVf")", HvNAME_get(pkg), vnumify(req),vnormal(req),vnumify(sv),vnormal(sv)); } diff --git a/xsutils.c b/xsutils.c index 5956ff2..7cdf41a 100644 --- a/xsutils.c +++ b/xsutils.c @@ -258,7 +258,7 @@ usage: sv = SvRV(rv); if (SvOBJECT(sv)) - sv_setpv(TARG, HvNAME(SvSTASH(sv))); + sv_setpv(TARG, HvNAME_get(SvSTASH(sv))); #if 0 /* this was probably a bad idea */ else if (SvPADMY(sv)) sv_setsv(TARG, &PL_sv_no); /* unblessed lexical */ @@ -284,7 +284,7 @@ usage: break; } if (stash) - sv_setpv(TARG, HvNAME(stash)); + sv_setpv(TARG, HvNAME_get(stash)); } SvSETMAGIC(TARG);