Files names for pragmas strict and warnings can end in .pmc

[perl5.git] / gv.c

diff --git a/gv.c b/gv.c
index 8f98f00..156f2fb 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -528,6 +528,32 @@ C<call_sv> 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;
     }
@@ -1230,7 +1256,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
        }
        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;
@@ -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) {