In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/45f11e9ca40e7c288751ad2b4f3922e3fd05c0f7?hp=40ba7a517798fdce321416d57d1c0f2a17cab67b>
- Log ----------------------------------------------------------------- commit 45f11e9ca40e7c288751ad2b4f3922e3fd05c0f7 Author: Father Chrysostomos <[email protected]> Date: Mon Sep 17 16:55:36 2012 -0700 perldelta for #114924 M pod/perldelta.pod commit aae438050a206a8067e068319ab3ee2348009463 Author: Father Chrysostomos <[email protected]> Date: Mon Sep 17 16:24:40 2012 -0700 [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. M embed.fnc M embed.h M gv.c M gv.h M hv.c M hv.h M proto.h M t/op/method.t commit 9c47725a2c7c1a5a17231082af905d106c5467fb Author: Father Chrysostomos <[email protected]> Date: Sun Sep 16 00:20:23 2012 -0700 Revert "Set PL_comppad_name on sub entry" This reverts commit d2c8bf052f5a8bb99050f6d2418d77151eb4b468. M pad.h M scope.c M scope.h M sv.c commit 62698e047b935ed44827dc9c8a013c1c41a9697d Author: Father Chrysostomos <[email protected]> Date: Sun Sep 16 00:20:07 2012 -0700 pp.c:pp_clonecv: Use find_runcv to find the padname See: https://rt.perl.org/rt3/Ticket/Display.html?id=113930#txn-1153156 By using find_runcv, we can revert d2c8bf052f. This may not be the best tradeoff in the long run, as it makes code using experimental my subs (my experimental subs?) slower. But at least we avoid slowing down existing code. M pp.c commit 441078c249a2505af353ca7b2f96789341d1b8eb Author: Father Chrysostomos <[email protected]> Date: Sat Sep 15 23:48:40 2012 -0700 pod/perlsub.pod: Warn about possible lexsub removal M pod/perlsub.pod ----------------------------------------------------------------------- Summary of changes: embed.fnc | 1 - embed.h | 1 - gv.c | 91 +++++++++++++++++------------------------------------ gv.h | 3 ++ hv.c | 2 + hv.h | 1 + pad.h | 3 +- pod/perldelta.pod | 15 +++++++++ pod/perlsub.pod | 4 +- pp.c | 3 +- proto.h | 5 --- scope.c | 1 - scope.h | 3 +- sv.c | 2 - t/op/method.t | 7 +++- 15 files changed, 62 insertions(+), 80 deletions(-) diff --git a/embed.fnc b/embed.fnc index 14f3e20..2ac6644 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 a65cfd4..73deaf2 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 01ed1f5..55666f4 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 30014b6..8e093400 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 b5e3d91..bf82c65 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 e20091e..1e32ab9 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/pad.h b/pad.h index a0b5573..f65af17 100644 --- a/pad.h +++ b/pad.h @@ -172,7 +172,7 @@ XXX DAPM it would make more sense to make the arg a PADOFFSET Clear the pointed to pad value on scope exit. (i.e. the runtime action of 'my') =for apidoc m|void|SAVECOMPPAD -Save PL_comppad_name, PL_comppad and PL_curpad. +save PL_comppad and PL_curpad =for apidoc Amx|PAD **|PadlistARRAY|PADLIST padlist @@ -318,7 +318,6 @@ Restore the old pad saved into the local variable opad by PAD_SAVE_LOCAL() #define PAD_SET_CUR_NOSAVE(padlist,nth) \ - PL_comppad_name = PadlistNAMES(padlist); \ PL_comppad = (PAD*) (PadlistARRAY(padlist)[nth]); \ PL_curpad = AvARRAY(PL_comppad); \ DEBUG_Xv(PerlIO_printf(Perl_debug_log, \ diff --git a/pod/perldelta.pod b/pod/perldelta.pod index c1b7be1..dd14be7 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -169,6 +169,14 @@ C<our sub { ... }>. These are now disallowed outside of the "lexical_subs" feature. Under the "lexical_subs" feature they have new meanings described in L<perlsub/Lexical Subroutines>. +=head2 C<gv_fetchmeth_*> and SUPER + +The various C<gv_fetchmeth_*> XS functions used to treat a package whose +named ended with ::SUPER specially. A method lookup on the Foo::SUPER +package would be treated as a SUPER method lookup on the Foo package. This +is no longer the case. To do a SUPER lookup, pass the Foo stash and the +GV_SUPER flag. + =head1 Deprecations XXX Any deprecated features, syntax, modules etc. should be listed here. In @@ -808,6 +816,13 @@ SUPER package had already been accessed by other means. Stash aliasing (C<*foo:: = *bar::>) no longer causes SUPER calls to ignore changes to methods or @ISA or use the wrong package. +=item * + +Method calls on packages whose names end in ::SUPER are no longer treated +as SUPER method calls, resulting in failure to find the method. +Furthermore, defining subroutines in such packages no longer causes them to +be found by SUPER method calls on the containing package [perl #114924]. + =back =head1 Known Problems diff --git a/pod/perlsub.pod b/pod/perlsub.pod index 3bb1f0b..993b2b5 100644 --- a/pod/perlsub.pod +++ b/pod/perlsub.pod @@ -825,8 +825,8 @@ subroutine never gets that chance. Consider; =head2 Lexical Subroutines X<my sub> X<state sub> X<our sub> X<subroutine, lexical> -B<WARNING>: Lexical subroutines are still experimental and the -implementation may change in future versions of Perl. +B<WARNING>: Lexical subroutines are still experimental. The feature may be +modified or removed in future versions of Perl. Lexical subroutines are only available under the C<use feature 'lexical_subs'> pragma, which produces a warning unless the diff --git a/pp.c b/pp.c index e587f7d..f99c460 100644 --- a/pp.c +++ b/pp.c @@ -163,7 +163,8 @@ PP(pp_clonecv) { dVAR; dTARGET; MAGIC * const mg = - mg_find(AvARRAY(PL_comppad_name)[ARGTARG], PERL_MAGIC_proto); + mg_find(PadlistNAMESARRAY(CvPADLIST(find_runcv(NULL)))[ARGTARG], + PERL_MAGIC_proto); assert(SvTYPE(TARG) == SVt_PVCV); assert(mg); assert(mg->mg_obj); diff --git a/proto.h b/proto.h index 49e5c35..3737e0b 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/scope.c b/scope.c index 6f8a8b2..c767571 100644 --- a/scope.c +++ b/scope.c @@ -1078,7 +1078,6 @@ Perl_leave_scope(pTHX_ I32 base) PL_curpad = AvARRAY(PL_comppad); else PL_curpad = NULL; - PL_comppad_name = (PADNAMELIST*)SSPOPPTR; break; case SAVEt_PADSV_AND_MORTALIZE: { diff --git a/scope.h b/scope.h index a69be5f..0fad9a3 100644 --- a/scope.h +++ b/scope.h @@ -208,8 +208,7 @@ scope has the given name. Name must be a literal string. #define SAVEHINTS() save_hints() -#define SAVECOMPPAD() save_pushptrptr(MUTABLE_SV(PL_comppad_name), \ - MUTABLE_SV(PL_comppad), SAVEt_COMPPAD) +#define SAVECOMPPAD() save_pushptr(MUTABLE_SV(PL_comppad), SAVEt_COMPPAD) #define SAVESWITCHSTACK(f,t) \ STMT_START { \ diff --git a/sv.c b/sv.c index f361259..2312a36 100644 --- a/sv.c +++ b/sv.c @@ -12469,8 +12469,6 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) TOPPTR(nss,ix) = sv_dup_inc(sv, param); /* fall through */ case SAVEt_COMPPAD: - sv = (const SV *) POPPTR(ss,ix); - TOPPTR(nss,ix) = sv_dup(sv, param); case SAVEt_NSTAB: sv = (const SV *) POPPTR(ss,ix); TOPPTR(nss,ix) = sv_dup(sv, param); diff --git a/t/op/method.t b/t/op/method.t index 584ffd9..99a244c 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'; -- Perl5 Master Repository
