[perl #114924] Make method calls work with ::SUPER packages

Perl caches SUPER methods inside packages named Foo::SUPER.  But this
interferes with actual method calls on those packages (SUPER->foo,
foo::SUPER->foo).

The first time a package is looked up, it is vivified under the name
with which it is looked up.  So *SUPER:: will cause that package
to be called SUPER, and *main::SUPER:: will cause it to be named
main::SUPER.

main->SUPER::isa used to be very sensitive to the name of the
main::FOO package (where the cache is kept).  If it happened to be
called SUPER, that call would fail.

Fixing that bug (commit 3c104e59d83f) caused the CPAN module named
SUPER to fail, because SUPER->foo was now being treated as a
SUPER::method call.  gv_fetchmeth_pvn was using the ::SUPER suffix to
determine where to look for the method.  The package passed to it (the
::SUPER package) was being used to look for cached methods, but the
package with ::SUPER stripped off was being used for the rest of
lookup.  3c104e59d83f made main->SUPER::foo work by treating SUPER
as main::SUPER in that case.  Mentioning *main::SUPER:: or doing a
main->SUPER::foo call before loading SUPER.pm also caused it to fail,
even before 3c104e59d83f.

Instead of using publicly-visible packages for internal caches, we
should be keeping them internal, to avoid such side effects.

This commit adds a new member to the HvAUX struct, where a hash of GVs
is stored, to cache super methods.  I cannot simpy use a hash of CVs,
because I need GvCVGEN.  Using a hash of GVs allows the existing
method cache code to be used.

This new hash of GVs is not actually a stash, as it has no HvAUX
struct (i.e., no name, no mro_meta).  It doesn’t even need an @ISA
entry as before (which was only used to make isa caches reset), as it
shares its owner stash’s mro_meta generation numbers.  In fact, the
GVs inside it have their GvSTASH pointers pointing to the owner stash.

In terms of memory use, it is probably the same as before.  Every
stash and every iterated or weakly-referenced hash is now one pointer
larger than before, but every SUPER cache is smaller (no HvAUX, no
*ISA + @ISA + $ISA[0] + magic).

The code is a lot simpler now and uses fewer stash lookups, so it
should be faster.

This will break any XS code that expects the gv_fetchmeth_pvn to treat
the ::SUPER suffix as magical.  This behaviour was only barely docu-
mented (the suffix was mentioned, but what it did was not), and is
unused on CPAN.

8 files changed, 41 insertions, 70 deletions

diff --git a/embed.fnc b/embed.fnc
index 14f3e20bdf..2ac66449bc 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -1703,7 +1703,6 @@ sR	|I32	|do_trans_complex_utf8	|NN SV * const sv
 #if defined(PERL_IN_GV_C)
 s	|void	|gv_init_svtype	|NN GV *gv|const svtype sv_type
 s	|void	|gv_magicalize_isa	|NN GV *gv
-s	|HV*	|gv_get_super_pkg|NN const char* name|I32 namelen|U32 flags
 s	|HV*	|require_tie_mod|NN GV *gv|NN const char *varpv|NN SV* namesv \
 				|NN const char *methpv|const U32 flags
 #endif
diff --git a/embed.h b/embed.h
index a65cfd4db5..73deaf263b 100644
--- a/embed.h
+++ b/embed.h
@@ -1343,7 +1343,6 @@
 #define sequence_num(a)		S_sequence_num(aTHX_ a)
 #  endif
 #  if defined(PERL_IN_GV_C)
-#define gv_get_super_pkg(a,b,c)	S_gv_get_super_pkg(aTHX_ a,b,c)
 #define gv_init_svtype(a,b)	S_gv_init_svtype(aTHX_ a,b)
 #define gv_magicalize_isa(a)	S_gv_magicalize_isa(aTHX_ a)
 #define require_tie_mod(a,b,c,d,e)	S_require_tie_mod(aTHX_ a,b,c,d,e)
diff --git a/gv.c b/gv.c
index 01ed1f574c..55666f44cc 100644
--- a/gv.c
+++ b/gv.c
@@ -608,9 +608,12 @@ side-effect creates a glob with the given C<name> in the given C<stash>
 which in the case of success contains an alias for the subroutine, and sets
 up caching info for this glob.
 
-Currently, the only significant value for C<flags> is SVf_UTF8.
+The only significant values for C<flags> are GV_SUPER and SVf_UTF8.
+
+GV_SUPER indicates that we want to look up the method in the superclasses
+of the C<stash>.
 
-This function grants C<"SUPER"> token as a postfix of the stash name. The
+The
 GV returned from C<gv_fetchmeth> may be a method cache entry, which is not
 visible to Perl code.  So when calling C<call_sv>, you should not use
 the GV directly; instead, you should use the method's CV, which can be
@@ -629,7 +632,7 @@ Perl_gv_fetchmeth_pvn(pTHX_ HV *stash, const char *name, STRLEN len, I32 level,
     AV* linear_av;
     SV** linear_svp;
     SV* linear_sv;
-    HV* cstash;
+    HV* cstash, *cachestash;
     GV* candidate = NULL;
     CV* cand_cv = NULL;
     GV* topgv = NULL;
@@ -658,12 +661,20 @@ Perl_gv_fetchmeth_pvn(pTHX_ HV *stash, const char *name, STRLEN len, I32 level,
     assert(hvname);
     assert(name);
 
-    DEBUG_o( Perl_deb(aTHX_ "Looking for method %s in package %s\n",name,hvname) );
+    DEBUG_o( Perl_deb(aTHX_ "Looking for %smethod %s in package %s\n",
+		      flags & GV_SUPER ? "SUPER " : "",name,hvname) );
 
     topgen_cmp = HvMROMETA(stash)->cache_gen + PL_sub_generation;
 
+    if (flags & GV_SUPER) {
+	if (!HvAUX(stash)->xhv_super) HvAUX(stash)->xhv_super = newHV();
+	cachestash = HvAUX(stash)->xhv_super;
+    }
+    else cachestash = stash;
+
     /* check locally for a real method or a cache entry */
-    gvp = (GV**)hv_fetch(stash, name, is_utf8 ? -(I32)len : (I32)len, create);
+    gvp = (GV**)hv_fetch(cachestash, name, is_utf8 ? -(I32)len : (I32)len,
+			 create);
     if(gvp) {
         topgv = *gvp;
       have_gv:
@@ -687,26 +698,15 @@ Perl_gv_fetchmeth_pvn(pTHX_ HV *stash, const char *name, STRLEN len, I32 level,
             /* cache indicates no such method definitively */
             return 0;
         }
-	else if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4
+	else if (stash == cachestash
+	      && len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4
               && strnEQ(hvname, "CORE", 4)
               && S_maybe_add_coresub(aTHX_ NULL,topgv,name,len))
 	    goto have_gv;
     }
 
     packlen = HvNAMELEN_get(stash);
-    if ((packlen >= 7 && strEQ(hvname + packlen - 7, "::SUPER"))
-     || (packlen == 5 && strEQ(hvname, "SUPER"))) {
-        HV* basestash;
-        basestash = packlen == 5
-		     ? PL_defstash
-		     : gv_stashpvn(hvname, packlen - 7,
-                                GV_ADD | (HvNAMEUTF8(stash) ? SVf_UTF8 : 0));
-        linear_av = mro_get_linear_isa(basestash);
-    }
-    else {
-        linear_av = mro_get_linear_isa(stash); /* has ourselves at the top of the list */
-    }
-
+    linear_av = mro_get_linear_isa(stash); /* has ourselves at the top of the list */
     linear_svp = AvARRAY(linear_av) + 1; /* skip over self */
     items = AvFILLp(linear_av); /* no +1, to skip over self */
     while (items--) {
@@ -760,7 +760,7 @@ Perl_gv_fetchmeth_pvn(pTHX_ HV *stash, const char *name, STRLEN len, I32 level,
 
     /* Check UNIVERSAL without caching */
     if(level == 0 || level == -1) {
-        candidate = gv_fetchmeth_pvn(NULL, name, len, 1, flags);
+        candidate = gv_fetchmeth_pvn(NULL, name, len, 1, flags &~GV_SUPER);
         if(candidate) {
             cand_cv = GvCV(candidate);
             if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
@@ -899,35 +899,6 @@ C<call_sv> apply equally to these functions.
 =cut
 */
 
-STATIC HV*
-S_gv_get_super_pkg(pTHX_ const char* name, I32 namelen, U32 flags)
-{
-    AV* superisa;
-    GV** gvp;
-    GV* gv;
-    HV* stash;
-
-    PERL_ARGS_ASSERT_GV_GET_SUPER_PKG;
-
-    stash = gv_stashpvn(name, namelen, flags);
-    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 | flags);
-    gvp = (GV**)hv_fetchs(stash, "ISA", TRUE);
-    gv = *gvp;
-    gv_init(gv, stash, "ISA", 3, TRUE);
-    superisa = GvAVn(gv);
-    GvMULTI_on(gv);
-    sv_magic(MUTABLE_SV(superisa), MUTABLE_SV(gv), PERL_MAGIC_isa, NULL, 0);
-    av_push(superisa, newSVhek(CopSTASH(PL_curcop)
-			       ? HvENAME_HEK(CopSTASH(PL_curcop)) : NULL));
-
-    return stash;
-}
-
 GV *
 Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
 {
@@ -994,25 +965,20 @@ Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN le
     if (nsplit) {
 	if ((nsplit - origname) == 5 && memEQ(origname, "SUPER", 5)) {
 	    /* ->SUPER::method should really be looked up in original stash */
-	    SV * const tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_
-		     "%"HEKf"::SUPER",
-		      HEKfARG(HvENAME_HEK((HV*)CopSTASH(PL_curcop)))
-	    ));
-	    /* __PACKAGE__::SUPER stash should be autovivified */
-	    stash = gv_get_super_pkg(SvPVX_const(tmpstr), SvCUR(tmpstr), SvUTF8(tmpstr));
+	    stash = CopSTASH(PL_curcop);
+	    flags |= GV_SUPER;
 	    DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
 			 origname, HvENAME_get(stash), name) );
 	}
+	else if ((nsplit - origname) >= 7 &&
+		 strnEQ(nsplit - 7, "::SUPER", 7)) {
+            /* don't autovifify if ->NoSuchStash::SUPER::method */
+	    stash = gv_stashpvn(origname, nsplit - origname - 7, is_utf8);
+	    if (stash) flags |= GV_SUPER;
+	}
 	else {
             /* don't autovifify if ->NoSuchStash::method */
             stash = gv_stashpvn(origname, nsplit - origname, is_utf8);
-
-	    /* however, explicit calls to Pkg::SUPER::method may
-	       happen, and may require autovivification to work */
-	    if (!stash && (nsplit - origname) >= 7 &&
-		strnEQ(nsplit - 7, "::SUPER", 7) &&
-		gv_stashpvn(origname, nsplit - origname - 7, is_utf8))
-	      stash = gv_get_super_pkg(origname, nsplit - origname, flags);
 	}
 	ostash = stash;
     }
@@ -1139,6 +1105,7 @@ Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags)
 	}
 	else
 	    packname = sv_2mortal(newSVhek(HvNAME_HEK(stash)));
+	if (flags & GV_SUPER) sv_catpvs(packname, "::SUPER");
     }
     if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE, is_utf8)))
 	return NULL;
diff --git a/gv.h b/gv.h
index 30014b622d..8e09340053 100644
--- a/gv.h
+++ b/gv.h
@@ -235,6 +235,9 @@ Return the CV from the GV.
 #define GV_NO_SVGMAGIC	0x800	/* Skip get-magic on an SV argument;
 				   used only by gv_fetchsv(_nomg) */
 
+/* Flags for gv_fetchmeth_pvn and gv_autoload_pvn*/
+#define GV_SUPER	0x1000	/* SUPER::method */
+
 /* Flags for gv_autoload_*/
 #define GV_AUTOLOAD_ISMETHOD 1	/* autoloading a method? */
 
diff --git a/hv.c b/hv.c
index b5e3d9133d..bf82c659ee 100644
--- a/hv.c
+++ b/hv.c
@@ -1858,6 +1858,7 @@ Perl_hv_undef_flags(pTHX_ HV *hv, U32 flags)
 	Safefree(meta);
 	aux->xhv_mro_meta = NULL;
       }
+      SvREFCNT_dec(aux->xhv_super);
       if (!aux->xhv_name_u.xhvnameu_name && ! aux->xhv_backreferences)
 	SvFLAGS(hv) &= ~SVf_OOK;
     }
@@ -1933,6 +1934,7 @@ S_hv_auxinit(HV *hv) {
     iter->xhv_name_count = 0;
     iter->xhv_backreferences = 0;
     iter->xhv_mro_meta = NULL;
+    iter->xhv_super = NULL;
     return iter;
 }
 
diff --git a/hv.h b/hv.h
index e20091e384..1e32ab9b42 100644
--- a/hv.h
+++ b/hv.h
@@ -90,6 +90,7 @@ struct xpvhv_aux {
  */
     I32		xhv_name_count;
     struct mro_meta *xhv_mro_meta;
+    HV *	xhv_super;	/* SUPER method cache */
 };
 
 /* hash structure: */
diff --git a/proto.h b/proto.h
index 49e5c35b0d..3737e0b706 100644
--- a/proto.h
+++ b/proto.h
@@ -5565,11 +5565,6 @@ PERL_CALLCONV void	Perl_hv_kill_backrefs(pTHX_ HV *hv)
 
 #endif
 #if defined(PERL_IN_GV_C)
-STATIC HV*	S_gv_get_super_pkg(pTHX_ const char* name, I32 namelen, U32 flags)
-			__attribute__nonnull__(pTHX_1);
-#define PERL_ARGS_ASSERT_GV_GET_SUPER_PKG	\
-	assert(name)
-
 STATIC void	S_gv_init_svtype(pTHX_ GV *gv, const svtype sv_type)
 			__attribute__nonnull__(pTHX_1);
 #define PERL_ARGS_ASSERT_GV_INIT_SVTYPE	\
diff --git a/t/op/method.t b/t/op/method.t
index 584ffd99f1..99a244ce90 100644
--- a/t/op/method.t
+++ b/t/op/method.t
@@ -13,7 +13,7 @@ BEGIN {
 use strict;
 no warnings 'once';
 
-plan(tests => 110);
+plan(tests => 111);
 
 @A::ISA = 'B';
 @B::ISA = 'C';
@@ -472,3 +472,8 @@ package egakacp {
   $r = SUPER::m{@a}"b";
   ::is $r, 'arg b', 'method{@array}$more_args';
 }
+
+# [perl #114924] SUPER->method
+@SUPER::ISA = "SUPPER";
+sub SUPPER::foo { "supper" }
+is "SUPER"->foo, 'supper', 'SUPER->method';