summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorFather Chrysostomos <sprout@cpan.org>2012-09-17 16:24:40 -0700
committerFather Chrysostomos <sprout@cpan.org>2012-09-17 16:58:27 -0700
commitaae438050a206a8067e068319ab3ee2348009463 (patch)
treefb1ed29ecd0d49c069e121c7d5e1b9628ec7641b
parent9c47725a2c7c1a5a17231082af905d106c5467fb (diff)
downloadperl-aae438050a206a8067e068319ab3ee2348009463.tar.gz
[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.
-rw-r--r--embed.fnc1
-rw-r--r--embed.h1
-rw-r--r--gv.c91
-rw-r--r--gv.h3
-rw-r--r--hv.c2
-rw-r--r--hv.h1
-rw-r--r--proto.h5
-rw-r--r--t/op/method.t7
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';