diff options
| -rw-r--r-- | embed.fnc | 1 | ||||
| -rw-r--r-- | embed.h | 1 | ||||
| -rw-r--r-- | gv.c | 91 | ||||
| -rw-r--r-- | gv.h | 3 | ||||
| -rw-r--r-- | hv.c | 2 | ||||
| -rw-r--r-- | hv.h | 1 | ||||
| -rw-r--r-- | proto.h | 5 | ||||
| -rw-r--r-- | t/op/method.t | 7 |
8 files changed, 41 insertions, 70 deletions
@@ -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 @@ -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) @@ -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; @@ -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? */ @@ -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; } @@ -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: */ @@ -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'; |