X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=gv.c;h=88e9993b000b1f107700d23c479f205973e86102;hb=662f1f9e0a1bbee45e1e02386151364c8517604e;hp=f0f21459a69879bd512222f9ff6a50444d5607ae;hpb=e879d94fd490498d2ab8c584f625025bbfa1d542;p=p5sagit%2Fp5-mst-13.2.git diff --git a/gv.c b/gv.c index f0f2145..88e9993 100644 --- a/gv.c +++ b/gv.c @@ -33,6 +33,7 @@ Perl stores its global variables. #include "EXTERN.h" #define PERL_IN_GV_C #include "perl.h" +#include "overload.c" static const char S_autoload[] = "AUTOLOAD"; static const STRLEN S_autolen = sizeof(S_autoload)-1; @@ -169,10 +170,24 @@ GP * Perl_newGP(pTHX_ GV *const gv) { GP *gp; + U32 hash; +#ifdef USE_ITHREADS const char *const file = (PL_curcop && CopFILE(PL_curcop)) ? CopFILE(PL_curcop) : ""; - STRLEN len = strlen(file); - U32 hash; + const STRLEN len = strlen(file); +#else + SV *const temp_sv = CopFILESV(PL_curcop); + const char *file; + STRLEN len; + + if (temp_sv) { + file = SvPVX(temp_sv); + len = SvCUR(temp_sv); + } else { + file = ""; + len = 0; + } +#endif PERL_HASH(hash, file, len); @@ -198,7 +213,8 @@ Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi) dVAR; const U32 old_type = SvTYPE(gv); const bool doproto = old_type > SVt_NULL; - const char * const proto = (doproto && SvPOK(gv)) ? SvPVX_const(gv) : NULL; + char * const proto = (doproto && SvPOK(gv)) ? SvPVX(gv) : NULL; + const STRLEN protolen = proto ? SvCUR(gv) : 0; SV *const has_constant = doproto && SvROK(gv) ? SvRV(gv) : NULL; const U32 exported_constant = has_constant ? SvPCS_IMPORTED(gv) : 0; @@ -260,13 +276,13 @@ Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi) } LEAVE; - PL_sub_generation++; + mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar($) { (shift) } sub ASDF::baz($); *ASDF::baz = \&Foo::bar */ CvGV(GvCV(gv)) = gv; CvFILE_set_from_cop(GvCV(gv), PL_curcop); CvSTASH(GvCV(gv)) = PL_curstash; if (proto) { - sv_setpv((SV*)GvCV(gv), proto); - Safefree(proto); + sv_usepvn_flags((SV*)GvCV(gv), proto, protolen, + SV_HAS_TRAILING_NUL); } } } @@ -291,7 +307,11 @@ S_gv_init_sv(pTHX_ GV *gv, I32 sv_type) case SVt_PVGV: break; default: - (void)GvSVn(gv); + if(GvSVn(gv)) { + /* Work round what appears to be a bug in Sun C++ 5.8 2005/10/13 + If we just cast GvSVn(gv) to void, it ignores evaluating it for + its side effect */ + } #endif } } @@ -306,7 +326,7 @@ accessible via @ISA and UNIVERSAL::. The argument C should be either 0 or -1. If C, as a side-effect creates a glob with the given C in the given C which in the case of success contains an alias for the subroutine, and sets -up caching info for this glob. Similarly for all the searched stashes. +up caching info for this glob. This function grants C<"SUPER"> token as a postfix of the stash name. The GV returned from C may be a method cache entry, which is not @@ -317,133 +337,138 @@ obtained from the GV with the C macro. =cut */ +/* NOTE: No support for tied ISA */ + GV * Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) { dVAR; - AV* av; - GV* topgv; - GV* gv; GV** gvp; - CV* cv; + AV* linear_av; + SV** linear_svp; + SV* linear_sv; + HV* cstash; + GV* candidate = NULL; + CV* cand_cv = NULL; + CV* old_cv; + GV* topgv = NULL; const char *hvname; - HV* lastchance = NULL; + I32 create = (level >= 0) ? 1 : 0; + I32 items; + STRLEN packlen; + U32 topgen_cmp; /* UNIVERSAL methods should be callable without a stash */ if (!stash) { - level = -1; /* probably appropriate */ + create = 0; /* probably appropriate */ if(!(stash = gv_stashpvs("UNIVERSAL", 0))) return 0; } + assert(stash); + hvname = HvNAME_get(stash); if (!hvname) - Perl_croak(aTHX_ - "Can't use anonymous symbol table for method lookup"); + 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); + assert(hvname); + assert(name); 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) - topgv = NULL; - else { - topgv = *gvp; - if (SvTYPE(topgv) != SVt_PVGV) - gv_init(topgv, stash, name, len, TRUE); - if ((cv = GvCV(topgv))) { - /* If genuine method or valid cache entry, use it */ - if (!GvCVGEN(topgv) || GvCVGEN(topgv) == PL_sub_generation) - return topgv; - /* Stale cached entry: junk it */ - SvREFCNT_dec(cv); - GvCV(topgv) = cv = NULL; - GvCVGEN(topgv) = 0; - } - else if (GvCVGEN(topgv) == PL_sub_generation) - return 0; /* cache indicates sub doesn't exist */ + topgen_cmp = HvMROMETA(stash)->cache_gen + PL_sub_generation; + + /* check locally for a real method or a cache entry */ + gvp = (GV**)hv_fetch(stash, name, len, create); + if(gvp) { + topgv = *gvp; + assert(topgv); + if (SvTYPE(topgv) != SVt_PVGV) + gv_init(topgv, stash, name, len, TRUE); + if ((cand_cv = GvCV(topgv))) { + /* If genuine method or valid cache entry, use it */ + if (!GvCVGEN(topgv) || GvCVGEN(topgv) == topgen_cmp) { + return topgv; + } + else { + /* stale cache entry, junk it and move on */ + SvREFCNT_dec(cand_cv); + GvCV(topgv) = cand_cv = NULL; + GvCVGEN(topgv) = 0; + } + } + else if (GvCVGEN(topgv) == topgen_cmp) { + /* cache indicates no such method definitively */ + return 0; + } } - gvp = (GV**)hv_fetchs(stash, "ISA", FALSE); - av = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL; - - /* create and re-create @.*::SUPER::ISA on demand */ - if (!av || !SvMAGIC(av)) { - STRLEN packlen = HvNAMELEN_get(stash); - - if (packlen >= 7 && strEQ(hvname + packlen - 7, "::SUPER")) { - HV* basestash; - - packlen -= 7; - basestash = gv_stashpvn(hvname, packlen, GV_ADD); - gvp = (GV**)hv_fetchs(basestash, "ISA", FALSE); - if (gvp && (gv = *gvp) && isGV_with_GP(gv) && (av = GvAV(gv))) { - gvp = (GV**)hv_fetchs(stash, "ISA", TRUE); - if (!gvp || !(gv = *gvp)) - Perl_croak(aTHX_ "Cannot create %s::ISA", hvname); - if (SvTYPE(gv) != SVt_PVGV) - gv_init(gv, stash, "ISA", 3, TRUE); - SvREFCNT_dec(GvAV(gv)); - GvAV(gv) = (AV*)SvREFCNT_inc_simple(av); - } - } + packlen = HvNAMELEN_get(stash); + if (packlen >= 7 && strEQ(hvname + packlen - 7, "::SUPER")) { + HV* basestash; + packlen -= 7; + basestash = gv_stashpvn(hvname, packlen, GV_ADD); + linear_av = mro_get_linear_isa(basestash); } - - if (av) { - SV** svp = AvARRAY(av); - /* NOTE: No support for tied ISA */ - I32 items = AvFILLp(av) + 1; - while (items--) { - SV* const sv = *svp++; - HV* const basestash = gv_stashsv(sv, 0); - if (!basestash) { - if (ckWARN(WARN_MISC)) - Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA", - SVfARG(sv), hvname); - continue; - } - gv = gv_fetchmeth(basestash, name, len, - (level >= 0) ? level + 1 : level - 1); - if (gv) - goto gotcha; - } + else { + linear_av = mro_get_linear_isa(stash); /* has ourselves at the top of the list */ } - /* if at top level, try UNIVERSAL */ + linear_svp = AvARRAY(linear_av) + 1; /* skip over self */ + items = AvFILLp(linear_av); /* no +1, to skip over self */ + while (items--) { + linear_sv = *linear_svp++; + assert(linear_sv); + cstash = gv_stashsv(linear_sv, 0); + + if (!cstash) { + if (ckWARN(WARN_SYNTAX)) + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA", + SVfARG(linear_sv), hvname); + continue; + } - if (level == 0 || level == -1) { - lastchance = gv_stashpvs("UNIVERSAL", 0); + assert(cstash); + + gvp = (GV**)hv_fetch(cstash, name, len, 0); + if (!gvp) continue; + candidate = *gvp; + assert(candidate); + if (SvTYPE(candidate) != SVt_PVGV) gv_init(candidate, cstash, name, len, TRUE); + if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) { + /* + * Found real method, cache method in topgv if: + * 1. topgv has no synonyms (else inheritance crosses wires) + * 2. method isn't a stub (else AUTOLOAD fails spectacularly) + */ + if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) { + if ((old_cv = GvCV(topgv))) SvREFCNT_dec(old_cv); + SvREFCNT_inc_simple_void_NN(cand_cv); + GvCV(topgv) = cand_cv; + GvCVGEN(topgv) = topgen_cmp; + } + return candidate; + } + } - if (lastchance) { - if ((gv = gv_fetchmeth(lastchance, name, len, - (level >= 0) ? level + 1 : level - 1))) - { - gotcha: - /* - * Cache method in topgv if: - * 1. topgv has no synonyms (else inheritance crosses wires) - * 2. method isn't a stub (else AUTOLOAD fails spectacularly) - */ - if (topgv && - GvREFCNT(topgv) == 1 && - (cv = GvCV(gv)) && - (CvROOT(cv) || CvXSUB(cv))) - { - if ((cv = GvCV(topgv))) - SvREFCNT_dec(cv); - GvCV(topgv) = (CV*)SvREFCNT_inc(GvCV(gv)); - GvCVGEN(topgv) = PL_sub_generation; - } - return gv; - } - else if (topgv && GvREFCNT(topgv) == 1) { - /* cache the fact that the method is not defined */ - GvCVGEN(topgv) = PL_sub_generation; - } - } + /* Check UNIVERSAL without caching */ + if(level == 0 || level == -1) { + candidate = gv_fetchmeth(NULL, name, len, 1); + if(candidate) { + cand_cv = GvCV(candidate); + if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) { + if ((old_cv = GvCV(topgv))) SvREFCNT_dec(old_cv); + SvREFCNT_inc_simple_void_NN(cand_cv); + GvCV(topgv) = cand_cv; + GvCVGEN(topgv) = topgen_cmp; + } + return candidate; + } + } + + if (topgv && GvREFCNT(topgv) == 1) { + /* cache the fact that the method is not defined */ + GvCVGEN(topgv) = topgen_cmp; } return 0; @@ -519,6 +544,48 @@ C apply equally to these functions. =cut */ +STATIC HV* +S_gv_get_super_pkg(pTHX_ const char* name, I32 namelen) +{ + AV* superisa; + GV** gvp; + GV* gv; + HV* stash; + + stash = gv_stashpvn(name, namelen, 0); + if(stash) return stash; + + /* If we must create it, give it an @ISA array containing + the real package this SUPER is for, so that it's tied + into the cache invalidation code correctly */ + stash = gv_stashpvn(name, namelen, GV_ADD); + gvp = (GV**)hv_fetchs(stash, "ISA", TRUE); + gv = *gvp; + gv_init(gv, stash, "ISA", 3, TRUE); + superisa = GvAVn(gv); + GvMULTI_on(gv); + sv_magic((SV*)superisa, (SV*)gv, PERL_MAGIC_isa, NULL, 0); +#ifdef USE_ITHREADS + av_push(superisa, newSVpv(CopSTASHPV(PL_curcop), 0)); +#else + av_push(superisa, newSVhek(CopSTASH(PL_curcop) + ? HvNAME_HEK(CopSTASH(PL_curcop)) : NULL)); +#endif + + return stash; +} + +/* FIXME. If changing this function note the comment in pp_hot's + S_method_common: + + This code tries to figure out just what went wrong with + gv_fetchmethod. It therefore needs to duplicate a lot of + the internals of that function. ... + + I'd guess that with one more flag bit that could all be moved inside + here. +*/ + GV * Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload) { @@ -547,7 +614,7 @@ Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload) SV * const tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER", CopSTASHPV(PL_curcop))); /* __PACKAGE__::SUPER stash should be autovivified */ - stash = gv_stashpvn(SvPVX_const(tmpstr), SvCUR(tmpstr), GV_ADD); + stash = gv_get_super_pkg(SvPVX_const(tmpstr), SvCUR(tmpstr)); DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n", origname, HvNAME_get(stash), name) ); } @@ -560,7 +627,7 @@ Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload) if (!stash && (nsplit - origname) >= 7 && strnEQ(nsplit - 7, "::SUPER", 7) && gv_stashpvn(origname, nsplit - origname - 7, 0)) - stash = gv_stashpvn(origname, nsplit - origname, GV_ADD); + stash = gv_get_super_pkg(origname, nsplit - origname); } ostash = stash; } @@ -697,11 +764,12 @@ S_require_tie_mod(pTHX_ GV *gv, const char *varpv, SV* namesv, const char *methp so save it. For the moment it's always a single char. */ dSP; - PUTBACK; ENTER; if ( flags & 1 ) save_scalar(gv); + PUSHSTACKi(PERLSI_MAGIC); Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, module, NULL); + POPSTACK; LEAVE; SPAGAIN; stash = gv_stashsv(namesv, 0); @@ -818,6 +886,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, const I32 add = flags & ~GV_NOADD_MASK; const char *const name_end = nambeg + full_len; const char *const name_em1 = name_end - 1; + U32 faking_it; if (flags & GV_NOTQUAL) { /* Caller promised that there is no stash, so we can skip the check. */ @@ -1004,7 +1073,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, if (*name == '!') require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1); else if (*name == '-' || *name == '+') - require_tie_mod(gv, name, newSVpvs("re::Tie::Hash::NamedCapture"), "FETCH", 0); + require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0); } } return gv; @@ -1014,12 +1083,19 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, return gv; } - /* Adding a new symbol */ + /* Adding a new symbol. + Unless of course there was already something non-GV here, in which case + we want to behave as if there was always a GV here, containing some sort + of subroutine. + Otherwise we run the risk of creating things like GvIO, which can cause + subtle bugs. eg the one that tripped up SQL::Translator */ + + faking_it = SvOK(gv); if (add & GV_ADDWARN && ckWARN_d(WARN_INTERNAL)) Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Had to create %s unexpectedly", nambeg); gv_init(gv, stash, name, len, add & GV_ADDMULTI); - gv_init_sv(gv, sv_type); + gv_init_sv(gv, faking_it ? SVt_PVCV : sv_type); if (isALPHA(name[0]) && ! (isLEXWARN_on ? ckWARN(WARN_ONCE) : (PL_dowarn & G_WARN_ON ) ) ) @@ -1117,14 +1193,14 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, break; case '\015': /* $^MATCH */ if (strEQ(name2, "ATCH")) - goto ro_magicalize; + goto magicalize; case '\017': /* $^OPEN */ if (strEQ(name2, "PEN")) goto magicalize; break; case '\020': /* $^PREMATCH $^POSTMATCH */ if (strEQ(name2, "REMATCH") || strEQ(name2, "OSTMATCH")) - goto ro_magicalize; + goto magicalize; case '\024': /* ${^TAINT} */ if (strEQ(name2, "AINT")) goto ro_magicalize; @@ -1151,14 +1227,14 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, case '8': case '9': { - /* ensures variable is only digits */ - /* ${"1foo"} fails this test (and is thus writeable) */ - /* added by japhy, but borrowed from is_gv_magical */ + /* Ensures that we have an all-digit variable, ${"1foo"} fails + this test */ + /* This snippet is taken from is_gv_magical */ const char *end = name + len; while (--end > name) { - if (!isDIGIT(*end)) return gv; + if (!isDIGIT(*end)) return gv; } - goto ro_magicalize; + goto magicalize; } } } @@ -1177,7 +1253,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, sv_type == SVt_PVIO ) { break; } PL_sawampersand = TRUE; - goto ro_magicalize; + goto magicalize; case ':': sv_setpv(GvSVn(gv),PL_chopset); @@ -1190,13 +1266,13 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, goto magicalize; case '!': - GvMULTI_on(gv); + GvMULTI_on(gv); /* If %! has been used, automatically load Errno.pm. */ sv_magic(GvSVn(gv), (SV*)gv, PERL_MAGIC_sv, name, len); /* magicalization must be done before require_tie_mod is called */ - if (sv_type == SVt_PVHV) + if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1); break; @@ -1204,37 +1280,23 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, case '+': GvMULTI_on(gv); /* no used once warnings here */ { - bool plus = (*name == '+'); - SV *stashname = newSVpvs("re::Tie::Hash::NamedCapture"); AV* const av = GvAVn(gv); - HV *const hv = GvHVn(gv); - HV *const hv_tie = newHV(); - SV *tie = newRV_noinc((SV*)hv_tie); + SV* const avc = (*name == '+') ? (SV*)av : NULL; - sv_bless(tie, gv_stashsv(stashname, GV_ADD)); - hv_magic(hv, (GV*)tie, PERL_MAGIC_tied); - sv_magic((SV*)av, (plus ? (SV*)av : NULL), PERL_MAGIC_regdata, NULL, 0); + sv_magic((SV*)av, avc, PERL_MAGIC_regdata, NULL, 0); sv_magic(GvSVn(gv), (SV*)gv, PERL_MAGIC_sv, name, len); - - if (plus) + if (avc) SvREADONLY_on(GvSVn(gv)); - else - Perl_hv_store(aTHX_ hv_tie, STR_WITH_LEN("all"), newSViv(1), 0); - - SvREADONLY_on(hv); - SvREADONLY_on(tie); SvREADONLY_on(av); - if (sv_type == SVt_PVHV) - require_tie_mod(gv, name, stashname, "FETCH", 0); - else - SvREFCNT_dec(stashname); + if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) + require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0); - break; + break; } case '*': case '#': - if (sv_type == SVt_PV && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) + if (sv_type == SVt_PV && ckWARN2_d(WARN_DEPRECATED, WARN_SYNTAX)) Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), "$%c is no longer supported", *name); break; @@ -1249,6 +1311,9 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, } goto magicalize; case '\023': /* $^S */ + ro_magicalize: + SvREADONLY_on(GvSVn(gv)); + /* FALL THROUGH */ case '1': case '2': case '3': @@ -1258,9 +1323,6 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, case '7': case '8': case '9': - ro_magicalize: - SvREADONLY_on(GvSVn(gv)); - /* FALL THROUGH */ case '[': case '^': case '~': @@ -1300,7 +1362,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, { SV * const sv = GvSVn(gv); if (!sv_derived_from(PL_patchlevel, "version")) - upg_version(PL_patchlevel); + upg_version(PL_patchlevel, TRUE); GvSV(gv) = vnumify(PL_patchlevel); SvREADONLY_on(GvSV(gv)); SvREFCNT_dec(sv); @@ -1399,24 +1461,12 @@ Perl_gv_check(pTHX_ const HV *stash) if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv)) continue; file = GvFILE(gv); - /* performance hack: if filename is absolute and it's a standard - * module, don't bother warning */ -#ifdef MACOS_TRADITIONAL -# define LIB_COMPONENT ":lib:" -#else -# define LIB_COMPONENT "/lib/" -#endif - if (file - && PERL_FILE_IS_ABSOLUTE(file) - && (instr(file, LIB_COMPONENT) || instr(file, ".pm"))) - { - continue; - } CopLINE_set(PL_curcop, GvLINE(gv)); #ifdef USE_ITHREADS CopFILE(PL_curcop) = (char *)file; /* set for warning */ #else - CopFILEGV(PL_curcop) = gv_fetchfile(file); + CopFILEGV(PL_curcop) + = gv_fetchfile_flags(file, HEK_LEN(GvFILE_HEK(gv)), 0); #endif Perl_warner(aTHX_ packWARN(WARN_ONCE), "Name \"%s::%s\" used only once: possible typo", @@ -1445,15 +1495,13 @@ Perl_gp_ref(pTHX_ GP *gp) gp->gp_refcnt++; if (gp->gp_cv) { if (gp->gp_cvgen) { - /* multi-named GPs cannot be used for method cache */ + /* If the GP they asked for a reference to contains + a method cache entry, clear it first, so that we + don't infect them with our cached entry */ SvREFCNT_dec(gp->gp_cv); gp->gp_cv = NULL; gp->gp_cvgen = 0; } - else { - /* Adding a new name to a subroutine invalidates method cache */ - PL_sub_generation++; - } } return gp; } @@ -1473,10 +1521,6 @@ Perl_gp_free(pTHX_ GV *gv) pTHX__FORMAT pTHX__VALUE); return; } - if (gp->gp_cv) { - /* Deleting the name of a subroutine invalidates method cache */ - PL_sub_generation++; - } if (--gp->gp_refcnt > 0) { if (gp->gp_egv == gv) gp->gp_egv = 0; @@ -1493,7 +1537,7 @@ Perl_gp_free(pTHX_ GV *gv) if (gp->gp_hv && SvTYPE(gp->gp_hv) == SVt_PVHV) { const char *hvname = HvNAME_get(gp->gp_hv); if (PL_stashcache && hvname) - hv_delete(PL_stashcache, hvname, HvNAMELEN_get(gp->gp_hv), + (void)hv_delete(PL_stashcache, hvname, HvNAMELEN_get(gp->gp_hv), G_DISCARD); SvREFCNT_dec(gp->gp_hv); } @@ -1532,11 +1576,14 @@ Perl_Gv_AMupdate(pTHX_ HV *stash) dVAR; MAGIC* const mg = mg_find((SV*)stash, PERL_MAGIC_overload_table); AMT amt; + const struct mro_meta* stash_meta = HvMROMETA(stash); + U32 newgen; + newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen; if (mg) { const AMT * const amtp = (AMT*)mg->mg_ptr; if (amtp->was_ok_am == PL_amagic_generation - && amtp->was_ok_sub == PL_sub_generation) { + && amtp->was_ok_sub == newgen) { return (bool)AMT_OVERLOADED(amtp); } sv_unmagic((SV*)stash, PERL_MAGIC_overload_table); @@ -1546,7 +1593,7 @@ Perl_Gv_AMupdate(pTHX_ HV *stash) Zero(&amt,1,AMT); amt.was_ok_am = PL_amagic_generation; - amt.was_ok_sub = PL_sub_generation; + amt.was_ok_sub = newgen; amt.fallback = AMGfallNO; amt.flags = 0; @@ -1579,7 +1626,7 @@ Perl_Gv_AMupdate(pTHX_ HV *stash) const char * const cooky = PL_AMG_names[i]; /* Human-readable form, for debugging: */ const char * const cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i)); - const STRLEN l = strlen(cooky); + const STRLEN l = PL_AMG_namelens[i]; DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n", cp, HvNAME_get(stash)) ); @@ -1658,9 +1705,15 @@ Perl_gv_handler(pTHX_ HV *stash, I32 id) dVAR; MAGIC *mg; AMT *amtp; + U32 newgen; + struct mro_meta* stash_meta; if (!stash || !HvNAME_get(stash)) return NULL; + + stash_meta = HvMROMETA(stash); + newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen; + mg = mg_find((SV*)stash, PERL_MAGIC_overload_table); if (!mg) { do_update: @@ -1670,7 +1723,7 @@ Perl_gv_handler(pTHX_ HV *stash, I32 id) assert(mg); amtp = (AMT*)mg->mg_ptr; if ( amtp->was_ok_am != PL_amagic_generation - || amtp->was_ok_sub != PL_sub_generation ) + || amtp->was_ok_sub != newgen ) goto do_update; if (AMT_AMAGIC(amtp)) { CV * const ret = amtp->table[id]; @@ -2004,7 +2057,8 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) PUSHs(lr>0? left: right); PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no )); if (notfound) { - PUSHs( sv_2mortal(newSVpv(AMG_id2name(method + assignshift),0))); + PUSHs( sv_2mortal(newSVpvn(AMG_id2name(method + assignshift), + AMG_id2namelen(method + assignshift)))); } PUSHs((SV*)cv); PUTBACK;