X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=gv.c;h=156f2fbf44e971a1293b160317f66205bb91dae0;hb=cf6c151c4d1b7ed05e154d608f547018d54674bc;hp=7ea5e47d2ad525b8982fbce7c7f3180f392d078c;hpb=dd69841bebe1fc7f7a6b248576221520a0418d52;p=p5sagit%2Fp5-mst-13.2.git diff --git a/gv.c b/gv.c index 7ea5e47..156f2fb 100644 --- a/gv.c +++ b/gv.c @@ -528,6 +528,32 @@ 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); + av_push(superisa, newSVpv(CopSTASHPV(PL_curcop), 0)); + + return stash; +} + GV * Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload) { @@ -556,7 +582,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) ); } @@ -569,7 +595,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; } @@ -1014,7 +1040,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("Tie::Hash::NamedCapture"), "FETCH", 0); + require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0); } } return gv; @@ -1127,14 +1153,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; @@ -1161,14 +1187,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; } } } @@ -1187,7 +1213,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); @@ -1224,13 +1250,13 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, SvREADONLY_on(av); if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) - require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "FETCH", 0); + require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0); 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; @@ -1245,6 +1271,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': @@ -1254,9 +1283,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 '~': @@ -1470,7 +1496,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); } @@ -1509,9 +1535,10 @@ 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 + HvMROMETA(stash)->cache_gen; + 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 @@ -1638,11 +1665,13 @@ Perl_gv_handler(pTHX_ HV *stash, I32 id) MAGIC *mg; AMT *amtp; U32 newgen; + struct mro_meta* stash_meta; if (!stash || !HvNAME_get(stash)) return NULL; - newgen = PL_sub_generation + HvMROMETA(stash)->cache_gen; + 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) {