From: Brandon Black <blblack@gmail.com>
Date: Sun, 7 Oct 2007 22:36:36 +0000 (-0500)
Subject: Re: [perl #46217] (resent) Typeglobs vs. SUPER:: (Hook::LexWrap failure)
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=7d3b1f61da54c4cf5210c73ac1c807d0eea47175;p=p5sagit%2Fp5-mst-13.2.git

Re: [perl #46217] (resent) Typeglobs vs. SUPER:: (Hook::LexWrap failure)
From: "Brandon Black" <blblack@gmail.com>
Message-ID: <84621a60710072036l60c29016tba8a32b8021b5b24@mail.gmail.com>

p4raw-id: //depot/perl@32065
---

diff --git a/embed.fnc b/embed.fnc
index f861bfe..0e6e3f7 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -1133,6 +1133,7 @@ sR	|I32	|do_trans_complex_utf8	|NN SV * const sv
 
 #if defined(PERL_IN_GV_C) || defined(PERL_DECL_PROT)
 s	|void	|gv_init_sv	|NN GV *gv|I32 sv_type
+s	|HV*	|gv_get_super_pkg|NN const char* name|I32 namelen
 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 910afa7..8f86f3e 100644
--- a/embed.h
+++ b/embed.h
@@ -1123,6 +1123,7 @@
 #if defined(PERL_IN_GV_C) || defined(PERL_DECL_PROT)
 #ifdef PERL_CORE
 #define gv_init_sv		S_gv_init_sv
+#define gv_get_super_pkg	S_gv_get_super_pkg
 #define require_tie_mod		S_require_tie_mod
 #endif
 #endif
@@ -3391,6 +3392,7 @@
 #if defined(PERL_IN_GV_C) || defined(PERL_DECL_PROT)
 #ifdef PERL_CORE
 #define gv_init_sv(a,b)		S_gv_init_sv(aTHX_ a,b)
+#define gv_get_super_pkg(a,b)	S_gv_get_super_pkg(aTHX_ a,b)
 #define require_tie_mod(a,b,c,d,e)	S_require_tie_mod(aTHX_ a,b,c,d,e)
 #endif
 #endif
diff --git a/gv.c b/gv.c
index 4c6b12a..156f2fb 100644
--- 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;
     }
diff --git a/proto.h b/proto.h
index 86ac3e8..cac4e52 100644
--- a/proto.h
+++ b/proto.h
@@ -3009,6 +3009,9 @@ STATIC I32	S_do_trans_complex_utf8(pTHX_ SV * const sv)
 STATIC void	S_gv_init_sv(pTHX_ GV *gv, I32 sv_type)
 			__attribute__nonnull__(pTHX_1);
 
+STATIC HV*	S_gv_get_super_pkg(pTHX_ const char* name, I32 namelen)
+			__attribute__nonnull__(pTHX_1);
+
 STATIC HV*	S_require_tie_mod(pTHX_ GV *gv, const char *varpv, SV* namesv, const char *methpv, const U32 flags)
 			__attribute__nonnull__(pTHX_1)
 			__attribute__nonnull__(pTHX_2)