From dd69841bebe1fc7f7a6b248576221520a0418d52 Mon Sep 17 00:00:00 2001 From: Brandon Black Date: Sun, 29 Apr 2007 12:27:03 -0500 Subject: [PATCH] Re: mro status, etc From: "Brandon Black" Message-ID: <84621a60704291527y1b39be37l221ef66e4c828f66@mail.gmail.com> p4raw-id: //depot/perl@31107 --- embedvar.h | 2 + gv.c | 31 ++------- hv.c | 9 ++- hv.h | 16 ++--- intrpvar.h | 2 + lib/mro.pm | 14 ---- mg.c | 2 + mro.c | 183 +++++++++++++++++++++---------------------------- op.c | 4 -- perl.c | 4 ++ perlapi.h | 2 + pod/perlapi.pod | 33 +++++---- pod/perlboot.pod | 8 +-- pod/perlobj.pod | 5 +- pod/perltoot.pod | 63 ++++++++++++++++- pp.c | 9 +++ pp_hot.c | 2 +- scope.c | 5 +- sv.c | 39 +++++++++-- t/mro/method_caching.t | 33 ++++++--- universal.c | 2 +- 21 files changed, 268 insertions(+), 200 deletions(-) diff --git a/embedvar.h b/embedvar.h index e55941a..1a4ba0d 100644 --- a/embedvar.h +++ b/embedvar.h @@ -227,6 +227,7 @@ #define PL_incgv (vTHX->Iincgv) #define PL_initav (vTHX->Iinitav) #define PL_inplace (vTHX->Iinplace) +#define PL_isarev (vTHX->Iisarev) #define PL_known_layers (vTHX->Iknown_layers) #define PL_last_lop (vTHX->Ilast_lop) #define PL_last_lop_op (vTHX->Ilast_lop_op) @@ -491,6 +492,7 @@ #define PL_Iincgv PL_incgv #define PL_Iinitav PL_initav #define PL_Iinplace PL_inplace +#define PL_Iisarev PL_isarev #define PL_Iknown_layers PL_known_layers #define PL_Ilast_lop PL_last_lop #define PL_Ilast_lop_op PL_last_lop_op diff --git a/gv.c b/gv.c index fc61e8c..7ea5e47 100644 --- a/gv.c +++ b/gv.c @@ -360,7 +360,7 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) DEBUG_o( Perl_deb(aTHX_ "Looking for method %s in package %s\n",name,hvname) ); - topgen_cmp = HvMROMETA(stash)->sub_generation + PL_sub_generation; + topgen_cmp = HvMROMETA(stash)->cache_gen + PL_sub_generation; /* check locally for a real method or a cache entry */ gvp = (GV**)hv_fetch(stash, name, len, create); @@ -405,17 +405,7 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) assert(linear_sv); cstash = gv_stashsv(linear_sv, 0); - /* mg.c:Perl_magic_setisa sets the fake flag on packages it had - to create that the user did not. The "package" statement - clears it. We also check if there's anything in the symbol - table at all, which would indicate a previously "fake" package - where someone adding things via $Foo::Bar = 1 without ever - using a "package" statement. - This was all neccesary because magic_setisa needs a place to - keep isarev information on packages that aren't yet defined, - yet we still need to issue this warning when appropriate. - */ - if (!cstash || (HvMROMETA(cstash)->fake && !HvFILL(cstash))) { + if (!cstash) { if (ckWARN(WARN_SYNTAX)) Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA", SVfARG(linear_sv), hvname); @@ -1445,15 +1435,6 @@ Perl_gp_ref(pTHX_ GP *gp) gp->gp_cv = NULL; gp->gp_cvgen = 0; } - /* XXX if anyone finds a method cache regression with - the "mro" stuff, turning this else block back on - is probably the first place to look --blblack - */ - /* - else { - PL_sub_generation++; - } - */ } return gp; } @@ -1473,10 +1454,6 @@ Perl_gp_free(pTHX_ GV *gv) pTHX__FORMAT pTHX__VALUE); return; } - if (gp->gp_cv) { - /* Deleting the name of a subroutine invalidates method cache */ - PL_sub_generation++; - } if (--gp->gp_refcnt > 0) { if (gp->gp_egv == gv) gp->gp_egv = 0; @@ -1534,7 +1511,7 @@ Perl_Gv_AMupdate(pTHX_ HV *stash) AMT amt; U32 newgen; - newgen = PL_sub_generation + HvMROMETA(stash)->sub_generation; + newgen = PL_sub_generation + HvMROMETA(stash)->cache_gen; if (mg) { const AMT * const amtp = (AMT*)mg->mg_ptr; if (amtp->was_ok_am == PL_amagic_generation @@ -1665,7 +1642,7 @@ Perl_gv_handler(pTHX_ HV *stash, I32 id) if (!stash || !HvNAME_get(stash)) return NULL; - newgen = PL_sub_generation + HvMROMETA(stash)->sub_generation; + newgen = PL_sub_generation + HvMROMETA(stash)->cache_gen; mg = mg_find((SV*)stash, PERL_MAGIC_overload_table); if (!mg) { diff --git a/hv.c b/hv.c index 1bde70e..6243979 100644 --- a/hv.c +++ b/hv.c @@ -1608,6 +1608,8 @@ Perl_hv_clear(pTHX_ HV *hv) HvREHASH_off(hv); reset: if (SvOOK(hv)) { + if(HvNAME_get(hv)) + mro_isa_changed_in(hv); HvEITER_set(hv, NULL); } } @@ -1756,7 +1758,6 @@ S_hfreeentries(pTHX_ HV *hv) if((meta = iter->xhv_mro_meta)) { if(meta->mro_linear_dfs) SvREFCNT_dec(meta->mro_linear_dfs); if(meta->mro_linear_c3) SvREFCNT_dec(meta->mro_linear_c3); - if(meta->mro_isarev) SvREFCNT_dec(meta->mro_isarev); if(meta->mro_nextmethod) SvREFCNT_dec(meta->mro_nextmethod); Safefree(meta); iter->xhv_mro_meta = NULL; @@ -1845,8 +1846,12 @@ Perl_hv_undef(pTHX_ HV *hv) return; DEBUG_A(Perl_hv_assert(aTHX_ hv)); xhv = (XPVHV*)SvANY(hv); + + if ((name = HvNAME_get(hv)) && !PL_dirty) + mro_isa_changed_in(hv); + hfreeentries(hv); - if ((name = HvNAME_get(hv))) { + if (name) { if(PL_stashcache) hv_delete(PL_stashcache, name, HvNAMELEN_get(hv), G_DISCARD); hv_name_set(hv, NULL, 0, 0); diff --git a/hv.h b/hv.h index a82958f..67432e9 100644 --- a/hv.h +++ b/hv.h @@ -47,17 +47,11 @@ typedef enum { } mro_alg; struct mro_meta { - AV *mro_linear_dfs; /* cached dfs @ISA linearization */ - AV *mro_linear_c3; /* cached c3 @ISA linearization */ - HV *mro_isarev; /* reverse @ISA dependencies (who depends on us?) */ - HV *mro_nextmethod; /* next::method caching */ - U32 sub_generation; /* Like PL_sub_generation, but stash-local */ - mro_alg mro_which; /* which mro alg is in use? */ - unsigned int is_universal : 1; /* We are UNIVERSAL or a potentially - indirect member of @UNIVERSAL::ISA */ - unsigned int fake : 1; /* setisa made this fake package, - gv_fetchmeth pays attention to this, - and "package" sets it back to zero */ + AV *mro_linear_dfs; /* cached dfs @ISA linearization */ + AV *mro_linear_c3; /* cached c3 @ISA linearization */ + HV *mro_nextmethod; /* next::method caching */ + U32 cache_gen; /* Bumping this invalidates our method cache */ + mro_alg mro_which; /* which mro alg is in use? */ }; /* Subject to change. diff --git a/intrpvar.h b/intrpvar.h index 4c56f9b..25e67bd 100644 --- a/intrpvar.h +++ b/intrpvar.h @@ -535,6 +535,8 @@ PERLVARI(Islabs, I32**, NULL) /* Array of slabs that have been allocated */ PERLVARI(Islab_count, U32, 0) /* Size of the array */ #endif +PERLVARI(Iisarev, HV*, NULL) /* Reverse map of @ISA dependencies */ + /* If you are adding a U16, see the comment above on where there are 2 bytes of gap which currently will be structure padding. */ diff --git a/lib/mro.pm b/lib/mro.pm index 5b02ab3..693a0ac 100644 --- a/lib/mro.pm +++ b/lib/mro.pm @@ -141,25 +141,11 @@ For similar reasons to C above, this flag is permanent. Once it is set, it does not go away, even if the class in question really isn't universal anymore. -=head2 mro::get_global_sub_generation() - -Returns the current value of the internal perl variable -C. - =head2 mro::invalidate_all_method_caches() Increments C, which invalidates method caching in all packages. -=head2 mro::get_sub_generation($classname) - -Returns the current value of a given package's C. -This is only incremented when necessary for that package. - -If one is trying to determine whether significant (method/cache-affecting) -changes have occured for a given stash since you last checked, you should -check both this and the global one above. - =head2 mro::method_changed_in($classname) Invalidates the method cache of any classes dependent on the diff --git a/mg.c b/mg.c index ddaf2b3..9d20590 100644 --- a/mg.c +++ b/mg.c @@ -1925,6 +1925,8 @@ Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg) GV* gv; PERL_UNUSED_ARG(mg); + Perl_croak(aTHX_ "Perl_magic_setglob is dead code?"); + if (!SvOK(sv)) return 0; if (isGV_with_GP(sv)) { diff --git a/mro.c b/mro.c index 5c1a970..a541e50 100644 --- a/mro.c +++ b/mro.c @@ -33,17 +33,7 @@ Perl_mro_meta_init(pTHX_ HV* stash) assert(!(HvAUX(stash)->xhv_mro_meta)); Newxz(newmeta, 1, struct mro_meta); HvAUX(stash)->xhv_mro_meta = newmeta; - newmeta->sub_generation = 1; - - /* Manually flag UNIVERSAL as being universal. - This happens early in perl booting (when universal.c - does the newXS calls for UNIVERSAL::*), and infects - other packages as they are added to UNIVERSAL's MRO - */ - if(HvNAMELEN_get(stash) == 9 - && strEQ(HEK_KEY(HvAUX(stash)->xhv_name), "UNIVERSAL")) { - HvMROMETA(stash)->is_universal = 1; - } + newmeta->cache_gen = 1; return newmeta; } @@ -67,9 +57,6 @@ Perl_mro_meta_dup(pTHX_ struct mro_meta* smeta, CLONE_PARAMS* param) if (newmeta->mro_linear_c3) newmeta->mro_linear_c3 = (AV*) SvREFCNT_inc(sv_dup((SV*)newmeta->mro_linear_c3, param)); - if (newmeta->mro_isarev) - newmeta->mro_isarev - = (HV*) SvREFCNT_inc(sv_dup((SV*)newmeta->mro_isarev, param)); if (newmeta->mro_nextmethod) newmeta->mro_nextmethod = (HV*) SvREFCNT_inc(sv_dup((SV*)newmeta->mro_nextmethod, param)); @@ -454,8 +441,11 @@ Perl_mro_isa_changed_in(pTHX_ HV* stash) I32 items; struct mro_meta* meta; char* stashname; + STRLEN stashname_len; + bool is_universal = FALSE; stashname = HvNAME_get(stash); + stashname_len = HvNAMELEN_get(stash); /* wipe out the cached linearizations for this stash */ meta = HvMROMETA(stash); @@ -466,19 +456,26 @@ Perl_mro_isa_changed_in(pTHX_ HV* stash) /* Wipe the global method cache if this package is UNIVERSAL or one of its parents */ - if(meta->is_universal) + + svp = hv_fetch(PL_isarev, stashname, stashname_len, 0); + isarev = svp ? (HV*)*svp : NULL; + + if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL")) + || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) { PL_sub_generation++; + is_universal = TRUE; + } /* Wipe the local method cache otherwise */ else - meta->sub_generation++; + meta->cache_gen++; /* wipe next::method cache too */ if(meta->mro_nextmethod) hv_clear(meta->mro_nextmethod); /* Iterate the isarev (classes that are our children), wiping out their linearization and method caches */ - if((isarev = meta->mro_isarev)) { + if(isarev) { hv_iterinit(isarev); while((iter = hv_iternext(isarev))) { SV* revkey = hv_iterkeysv(iter); @@ -491,8 +488,8 @@ Perl_mro_isa_changed_in(pTHX_ HV* stash) SvREFCNT_dec((SV*)revmeta->mro_linear_c3); revmeta->mro_linear_dfs = NULL; revmeta->mro_linear_c3 = NULL; - if(!meta->is_universal) - revmeta->sub_generation++; + if(!is_universal) + revmeta->cache_gen++; if(revmeta->mro_nextmethod) hv_clear(revmeta->mro_nextmethod); } @@ -510,45 +507,29 @@ Perl_mro_isa_changed_in(pTHX_ HV* stash) items = AvFILLp(linear_mro); while (items--) { + HE* he; SV* const sv = *svp++; - struct mro_meta* mrometa; HV* mroisarev; - HV* mrostash = gv_stashsv(sv, 0); - if(!mrostash) { - mrostash = gv_stashsv(sv, GV_ADD); - /* - We created the package on the fly, so - that we could store isarev information. - This flag lets gv_fetchmeth know about it, - so that it can still generate the very useful - "Can't locate package Foo for @Bar::ISA" warning. - */ - HvMROMETA(mrostash)->fake = 1; + he = hv_fetch_ent(PL_isarev, sv, 0, 0); + if(!he) { + he = hv_store_ent(PL_isarev, sv, (SV*)newHV(), 0); } - - mrometa = HvMROMETA(mrostash); - mroisarev = mrometa->mro_isarev; - - /* is_universal is viral */ - if(meta->is_universal) - mrometa->is_universal = 1; - - if(!mroisarev) - mroisarev = mrometa->mro_isarev = newHV(); + mroisarev = (HV*)HeVAL(he); /* This hash only ever contains PL_sv_yes. Storing it over itself is almost as cheap as calling hv_exists, so on aggregate we expect to save time by not making two calls to the common HV code for the case where it doesn't exist. */ - hv_store(mroisarev, stashname, strlen(stashname), &PL_sv_yes, 0); + hv_store(mroisarev, stashname, stashname_len, &PL_sv_yes, 0); if(isarev) { hv_iterinit(isarev); while((iter = hv_iternext(isarev))) { - SV* revkey = hv_iterkeysv(iter); - hv_store_ent(mroisarev, revkey, &PL_sv_yes, 0); + I32 revkeylen; + char* revkey = hv_iterkey(iter, &revkeylen); + hv_store(mroisarev, revkey, revkeylen, &PL_sv_yes, 0); } } } @@ -562,40 +543,54 @@ of the given stash, so that they might notice the changes in this one. Ideally, all instances of C in -the perl source outside of C should be -replaced by calls to this. This conversion is -nearly complete. +perl source outside of C should be +replaced by calls to this. + +Perl automatically handles most of the common +ways a method might be redefined. However, there +are a few ways you could change a method in a stash +without the cache code noticing, in which case you +need to call this method afterwards: -Perl has always had problems with method caches -getting out of sync when one directly manipulates -stashes via things like C<%{Foo::} = %{Bar::}> or -C<${Foo::}{bar} = ...> or the equivalent. If -you do this in core or XS code, call this afterwards -on the destination stash to get things back in sync. +1) Directly manipulating the stash HV entries from +XS code. -If you're doing such a thing from pure perl, use -C, which -just calls this. +2) Assigning a reference to a readonly scalar +constant into a stash entry in order to create +a constant subroutine (like constant.pm +does). + +This same method is available from pure perl +via, C. =cut */ void Perl_mro_method_changed_in(pTHX_ HV *stash) { - struct mro_meta* meta = HvMROMETA(stash); + SV** svp; HV* isarev; HE* iter; + char* stashname; + STRLEN stashname_len; + + stashname = HvNAME_get(stash); + stashname_len = HvNAMELEN_get(stash); + + svp = hv_fetch(PL_isarev, stashname, stashname_len, 0); + isarev = svp ? (HV*)*svp : NULL; /* If stash is UNIVERSAL, or one of UNIVERSAL's parents, invalidate all method caches globally */ - if(meta->is_universal) { + if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL")) + || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) { PL_sub_generation++; return; } /* else, invalidate the method caches of all child classes, but not itself */ - if((isarev = meta->mro_isarev)) { + if(isarev) { hv_iterinit(isarev); while((iter = hv_iternext(isarev))) { SV* revkey = hv_iterkeysv(iter); @@ -604,7 +599,7 @@ Perl_mro_method_changed_in(pTHX_ HV *stash) if(!revstash) continue; mrometa = HvMROMETA(revstash); - mrometa->sub_generation++; + mrometa->cache_gen++; if(mrometa->mro_nextmethod) hv_clear(mrometa->mro_nextmethod); } @@ -770,7 +765,7 @@ __nextcan(pTHX_ SV* self, I32 throw_nomethod) assert(linear_sv); curstash = gv_stashsv(linear_sv, FALSE); - if (!curstash || (HvMROMETA(curstash)->fake && !HvFILL(curstash))) { + if (!curstash) { if (ckWARN(WARN_SYNTAX)) Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA", (void*)linear_sv, hvname); @@ -812,9 +807,7 @@ XS(XS_mro_set_mro); XS(XS_mro_get_mro); XS(XS_mro_get_isarev); XS(XS_mro_is_universal); -XS(XS_mro_get_global_sub_gen); XS(XS_mro_invalidate_method_caches); -XS(XS_mro_get_sub_generation); XS(XS_mro_method_changed_in); XS(XS_next_can); XS(XS_next_method); @@ -831,9 +824,7 @@ Perl_boot_core_mro(pTHX) newXSproto("mro::get_mro", XS_mro_get_mro, file, "$"); newXSproto("mro::get_isarev", XS_mro_get_isarev, file, "$"); newXSproto("mro::is_universal", XS_mro_is_universal, file, "$"); - newXSproto("mro::get_global_sub_generation", XS_mro_get_global_sub_gen, file, ""); newXSproto("mro::invalidate_all_method_caches", XS_mro_invalidate_method_caches, file, ""); - newXSproto("mro::get_sub_generation", XS_mro_get_sub_generation, file, "$"); newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$"); newXS("next::can", XS_next_can, file); newXS("next::method", XS_next_method, file); @@ -906,7 +897,7 @@ XS(XS_mro_set_mro) meta->mro_which = which; /* Only affects local method cache, not even child classes */ - meta->sub_generation++; + meta->cache_gen++; if(meta->mro_nextmethod) hv_clear(meta->mro_nextmethod); } @@ -947,7 +938,10 @@ XS(XS_mro_get_isarev) dXSARGS; SV* classname; HV* class_stash; + SV** svp; HV* isarev; + char* stashname; + STRLEN stashname_len; PERL_UNUSED_ARG(cv); @@ -960,8 +954,12 @@ XS(XS_mro_get_isarev) if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname)); SP -= items; - - if((isarev = HvMROMETA(class_stash)->mro_isarev)) { + + stashname = HvNAME_get(class_stash); + stashname_len = HvNAMELEN_get(class_stash); + svp = hv_fetch(PL_isarev, stashname, stashname_len, 0); + isarev = svp ? (HV*)*svp : NULL; + if(isarev) { HE* iter; hv_iterinit(isarev); while((iter = hv_iternext(isarev))) @@ -978,36 +976,33 @@ XS(XS_mro_is_universal) dXSARGS; SV* classname; HV* class_stash; + HV* isarev; + char* stashname; + STRLEN stashname_len; + SV** svp; PERL_UNUSED_ARG(cv); if (items != 1) - Perl_croak(aTHX_ "Usage: mro::get_mro(classname)"); + Perl_croak(aTHX_ "Usage: mro::is_universal(classname)"); classname = ST(0); class_stash = gv_stashsv(classname, 0); if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname)); - if (HvMROMETA(class_stash)->is_universal) + stashname = HvNAME_get(class_stash); + stashname_len = HvNAMELEN_get(class_stash); + + svp = hv_fetch(PL_isarev, stashname, stashname_len, 0); + isarev = svp ? (HV*)*svp : NULL; + + if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL")) + || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) XSRETURN_YES; else XSRETURN_NO; } -XS(XS_mro_get_global_sub_gen) -{ - dVAR; - dXSARGS; - - PERL_UNUSED_ARG(cv); - - if (items != 0) - Perl_croak(aTHX_ "Usage: mro::get_global_sub_generation()"); - - ST(0) = sv_2mortal(newSViv(PL_sub_generation)); - XSRETURN(1); -} - XS(XS_mro_invalidate_method_caches) { dVAR; @@ -1023,26 +1018,6 @@ XS(XS_mro_invalidate_method_caches) XSRETURN_EMPTY; } -XS(XS_mro_get_sub_generation) -{ - dVAR; - dXSARGS; - SV* classname; - HV* class_stash; - - PERL_UNUSED_ARG(cv); - - if(items != 1) - Perl_croak(aTHX_ "Usage: mro::get_sub_generation(classname)"); - - classname = ST(0); - class_stash = gv_stashsv(classname, 0); - if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname)); - - ST(0) = sv_2mortal(newSViv(HvMROMETA(class_stash)->sub_generation)); - XSRETURN(1); -} - XS(XS_mro_method_changed_in) { dVAR; diff --git a/op.c b/op.c index d623f2b..8ee0fa5 100644 --- a/op.c +++ b/op.c @@ -3650,10 +3650,6 @@ Perl_package(pTHX_ OP *o) PL_curstash = gv_stashsv(sv, GV_ADD); - /* In case mg.c:Perl_magic_setisa faked - this package earlier, we clear the fake flag */ - HvMROMETA(PL_curstash)->fake = 0; - sv_setsv(PL_curstname, sv); PL_hints |= HINT_BLOCK_SCOPE; diff --git a/perl.c b/perl.c index f48aba6..3a9d368 100644 --- a/perl.c +++ b/perl.c @@ -1074,6 +1074,8 @@ perl_destruct(pTHXx) SvREFCNT_dec(PL_errors); PL_errors = NULL; + SvREFCNT_dec(PL_isarev); + FREETMPS; if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) { if (PL_scopestack_ix != 0) @@ -2154,6 +2156,8 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) CvPADLIST(PL_compcv) = pad_new(0); + PL_isarev = newHV(); + boot_core_PerlIO(); boot_core_UNIVERSAL(); boot_core_xsutils(); diff --git a/perlapi.h b/perlapi.h index 177257a..cf29a35 100644 --- a/perlapi.h +++ b/perlapi.h @@ -332,6 +332,8 @@ END_EXTERN_C #define PL_initav (*Perl_Iinitav_ptr(aTHX)) #undef PL_inplace #define PL_inplace (*Perl_Iinplace_ptr(aTHX)) +#undef PL_isarev +#define PL_isarev (*Perl_Iisarev_ptr(aTHX)) #undef PL_known_layers #define PL_known_layers (*Perl_Iknown_layers_ptr(aTHX)) #undef PL_last_lop diff --git a/pod/perlapi.pod b/pod/perlapi.pod index cc649f0..7c0aa88 100644 --- a/pod/perlapi.pod +++ b/pod/perlapi.pod @@ -2810,20 +2810,25 @@ of the given stash, so that they might notice the changes in this one. Ideally, all instances of C in -the perl source outside of C should be -replaced by calls to this. This conversion is -nearly complete. - -Perl has always had problems with method caches -getting out of sync when one directly manipulates -stashes via things like C<%{Foo::} = %{Bar::}> or -C<${Foo::}{bar} = ...> or the equivalent. If -you do this in core or XS code, call this afterwards -on the destination stash to get things back in sync. - -If you're doing such a thing from pure perl, use -C, which -just calls this. +perl source outside of C should be +replaced by calls to this. + +Perl automatically handles most of the common +ways a method might be redefined. However, there +are a few ways you could change a method in a stash +without the cache code noticing, in which case you +need to call this method afterwards: + +1) Directly manipulating the stash HV entries from +XS code. + +2) Assigning a reference to a readonly scalar +constant into a stash entry in order to create +a constant subroutine (like constant.pm +does). + +This same method is available from pure perl +via, C. void mro_method_changed_in(HV* stash) diff --git a/pod/perlboot.pod b/pod/perlboot.pod index 927777d..bd39c44 100644 --- a/pod/perlboot.pod +++ b/pod/perlboot.pod @@ -238,10 +238,10 @@ not a simple single value, because on rare occasions, it makes sense to have more than one parent class searched for the missing methods. If C also had an C<@ISA>, then we'd check there too. The -search is recursive, depth-first, left-to-right in each C<@ISA>. -Typically, each C<@ISA> has only one element (multiple elements means -multiple inheritance and multiple headaches), so we get a nice tree of -inheritance. +search is recursive, depth-first, left-to-right in each C<@ISA> by +default (see L for alternatives). Typically, each C<@ISA> has +only one element (multiple elements means multiple inheritance and +multiple headaches), so we get a nice tree of inheritance. When we turn on C, we'll get complaints on C<@ISA>, since it's not a variable containing an explicit package name, nor is it a diff --git a/pod/perlobj.pod b/pod/perlobj.pod index 6cfa20c..b6638e8 100644 --- a/pod/perlobj.pod +++ b/pod/perlobj.pod @@ -151,8 +151,9 @@ There is a special array within each package called @ISA, which says where else to look for a method if you can't find it in the current package. This is how Perl implements inheritance. Each element of the @ISA array is just the name of another package that happens to be a -class package. The classes are searched (depth first) for missing -methods in the order that they occur in @ISA. The classes accessible +class package. The classes are searched for missing methods in +depth-first, left-to-right order by default (see L for alternative +search order and other in-depth information). The classes accessible through @ISA are known as base classes of the current class. All classes implicitly inherit from class C as their diff --git a/pod/perltoot.pod b/pod/perltoot.pod index 4a212fb..5180306 100644 --- a/pod/perltoot.pod +++ b/pod/perltoot.pod @@ -1016,7 +1016,8 @@ dubiously-OO languages like C++. The way it works is actually pretty simple: just put more than one package name in your @ISA array. When it comes time for Perl to go finding methods for your object, it looks at each of these packages in order. -Well, kinda. It's actually a fully recursive, depth-first order. +Well, kinda. It's actually a fully recursive, depth-first order by +default (see L for alternate method resolution orders). Consider a bunch of @ISA arrays like this: @First::ISA = qw( Alpha ); @@ -1120,6 +1121,66 @@ higher available. This is not the same as loading in that exact version number. No mechanism currently exists for concurrent installation of multiple versions of a module. Lamentably. +=head2 Deeper UNIVERSAL details + +It is also valid (though perhaps unwise in most cases) to put other +packages' names in @UNIVERSAL::ISA. These packages will also be +implicitly inherited by all classes, just as UNIVERSAL itself is. +However, neither UNIVERSAL nor any of its parents from the @ISA tree +are explicit base classes of all objects. To clarify, given the +following: + + @UNIVERSAL::ISA = ('REALLYUNIVERSAL'); + + package REALLYUNIVERSAL; + sub special_method { return "123" } + + package Foo; + sub normal_method { return "321" } + +Calling Foo->special_method() will return "123", but calling +Foo->isa('REALLYUNIVERSAL') or Foo->isa('UNIVERSAL') will return +false. + +If your class is using an alternate mro like C3 (see +L), method resolution within UNIVERSAL / @UNIVERSAL::ISA will +still occur in the default depth-first left-to-right manner, +after the class's C3 mro is exhausted. + +All of the above is made more intuitive by realizing what really +happens during method lookup, which is roughly like this +ugly pseudo-code: + + get_mro(class) { + # recurses down the @ISA's starting at class, + # builds a single linear array of all + # classes to search in the appropriate order. + # The method resolution order (mro) to use + # for the ordering is whichever mro "class" + # has set on it (either default (depth first + # l-to-r) or C3 ordering). + # The first entry in the list is the class + # itself. + } + + find_method(class, methname) { + foreach $class (get_mro(class)) { + if($class->has_method(methname)) { + return ref_to($class->$methname); + } + } + foreach $class (get_mro(UNIVERSAL)) { + if($class->has_method(methname)) { + return ref_to($class->$methname); + } + } + return undef; + } + +However the code that implements UNIVERSAL::isa does not +search in UNIVERSAL itself, only in the package's actual +@ISA. + =head1 Alternate Object Representations Nothing requires objects to be implemented as hash references. An object diff --git a/pp.c b/pp.c index 4903264..830d5fb 100644 --- a/pp.c +++ b/pp.c @@ -828,6 +828,15 @@ PP(pp_undef) SvSetMagicSV(sv, &PL_sv_undef); else { GP *gp; + HV *stash; + + /* undef *Foo:: */ + if((stash = GvHV((GV*)sv)) && HvNAME_get(stash)) + mro_isa_changed_in(stash); + /* undef *Pkg::meth_name ... */ + else if(GvCVu((GV*)sv) && (stash = GvSTASH((GV*)sv)) && HvNAME_get(stash)) + mro_method_changed_in(stash); + gp_free((GV*)sv); Newxz(gp, 1, GP); GvGP(sv) = gp_ref(gp); diff --git a/pp_hot.c b/pp_hot.c index 7c6e1e3..51f4967 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -3041,7 +3041,7 @@ S_method_common(pTHX_ SV* meth, U32* hashp) gv = (GV*)HeVAL(he); if (isGV(gv) && GvCV(gv) && (!GvCVGEN(gv) || GvCVGEN(gv) - == (PL_sub_generation + HvMROMETA(stash)->sub_generation))) + == (PL_sub_generation + HvMROMETA(stash)->cache_gen))) return (SV*)GvCV(gv); } } diff --git a/scope.c b/scope.c index e38dedf..4b68f1b 100644 --- a/scope.c +++ b/scope.c @@ -749,8 +749,9 @@ Perl_leave_scope(pTHX_ I32 base) gv = (GV*)SSPOPPTR; gp_free(gv); GvGP(gv) = (GP*)ptr; - if (GvCVu(gv)) - mro_method_changed_in(GvSTASH(gv)); /* putting a method back into circulation ("local")*/ + /* putting a method back into circulation ("local")*/ + if (GvCVu(gv) && (hv=GvSTASH(gv)) && HvNAME_get(hv)) + mro_method_changed_in(hv); SvREFCNT_dec(gv); break; case SAVEt_FREESV: diff --git a/sv.c b/sv.c index c6e2d57..832888d 100644 --- a/sv.c +++ b/sv.c @@ -3145,6 +3145,8 @@ copy-ish functions and macros use this underneath. static void S_glob_assign_glob(pTHX_ SV *dstr, SV *sstr, const int dtype) { + I32 method_changed = 0; + if (dtype != SVt_PVGV) { const char * const name = GvNAME(sstr); const STRLEN len = GvNAMELEN(sstr); @@ -3174,6 +3176,25 @@ S_glob_assign_glob(pTHX_ SV *dstr, SV *sstr, const int dtype) } #endif + if(GvGP((GV*)sstr)) { + /* If source has method cache entry, clear it */ + if(GvCVGEN(sstr)) { + SvREFCNT_dec(GvCV(sstr)); + GvCV(sstr) = NULL; + GvCVGEN(sstr) = 0; + } + /* If source has a real method, then a method is + going to change */ + else if(GvCV((GV*)sstr)) { + method_changed = 1; + } + } + + /* If dest already had a real method, that's a change as well */ + if(!method_changed && GvGP((GV*)dstr) && GvCVu((GV*)dstr)) { + method_changed = 1; + } + gp_free((GV*)dstr); isGV_with_GP_off(dstr); (void)SvOK_off(dstr); @@ -3188,6 +3209,7 @@ S_glob_assign_glob(pTHX_ SV *dstr, SV *sstr, const int dtype) GvIMPORTED_on(dstr); } GvMULTI_on(dstr); + if(method_changed) mro_method_changed_in(GvSTASH(dstr)); return; } @@ -3287,7 +3309,7 @@ S_glob_assign_ref(pTHX_ SV *dstr, SV *sstr) { } GvCVGEN(dstr) = 0; /* Switch off cacheness. */ GvASSUMECV_on(dstr); - mro_method_changed_in(GvSTASH(dstr)); /* sub foo { 1 } sub bar { 2 } *bar = \&foo */ + if(GvSTASH(dstr)) mro_method_changed_in(GvSTASH(dstr)); /* sub foo { 1 } sub bar { 2 } *bar = \&foo */ } *location = sref; if (import_flag && !(GvFLAGS(dstr) & import_flag) @@ -5025,6 +5047,7 @@ Perl_sv_clear(pTHX_ register SV *sv) const U32 type = SvTYPE(sv); const struct body_details *const sv_type_details = bodies_by_type + type; + HV *stash; assert(sv); assert(SvREFCNT(sv) == 0); @@ -5136,13 +5159,15 @@ Perl_sv_clear(pTHX_ register SV *sv) SvREFCNT_dec(LvTARG(sv)); case SVt_PVGV: if (isGV_with_GP(sv)) { + if(GvCVu((GV*)sv) && (stash = GvSTASH((GV*)sv)) && HvNAME_get(stash)) + mro_method_changed_in(stash); gp_free((GV*)sv); if (GvNAME_HEK(sv)) unshare_hek(GvNAME_HEK(sv)); - /* If we're in a stash, we don't own a reference to it. However it does - have a back reference to us, which needs to be cleared. */ - if (!SvVALID(sv) && GvSTASH(sv)) - sv_del_backref((SV*)GvSTASH(sv), sv); + /* If we're in a stash, we don't own a reference to it. However it does + have a back reference to us, which needs to be cleared. */ + if (!SvVALID(sv) && (stash = GvSTASH(sv))) + sv_del_backref((SV*)stash, sv); } /* FIXME. There are probably more unreferenced pointers to SVs in the interpreter struct that we should check and tidy in a similar @@ -7949,6 +7974,7 @@ S_sv_unglob(pTHX_ SV *sv) { dVAR; void *xpvmg; + HV *stash; SV * const temp = sv_newmortal(); assert(SvTYPE(sv) == SVt_PVGV); @@ -7956,6 +7982,8 @@ S_sv_unglob(pTHX_ SV *sv) gv_efullname3(temp, (GV *) sv, "*"); if (GvGP(sv)) { + if(GvCVu((GV*)sv) && (stash = GvSTASH((GV*)sv)) && HvNAME_get(stash)) + mro_method_changed_in(stash); gp_free((GV*)sv); } if (GvSTASH(sv)) { @@ -11081,6 +11109,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_initav = av_dup_inc(proto_perl->Iinitav, param); PL_sub_generation = proto_perl->Isub_generation; + PL_isarev = hv_dup_inc(proto_perl->Iisarev, param); /* funky return mechanisms */ PL_forkprocess = proto_perl->Iforkprocess; diff --git a/t/mro/method_caching.t b/t/mro/method_caching.t index a20da2a..733193a 100644 --- a/t/mro/method_caching.t +++ b/t/mro/method_caching.t @@ -17,31 +17,48 @@ require './test.pl'; { package MCTest::Base; sub foo { return $_[1]+1 }; - sub bar { 42 }; package MCTest::Derived; our @ISA = qw/MCTest::Base/; + + package Foo; our @FOO = qw//; } # These are various ways of re-defining MCTest::Base::foo and checking whether the method is cached when it shouldn't be my @testsubs = ( + sub { is(MCTest::Derived->foo(0), 1); }, sub { eval 'sub MCTest::Base::foo { return $_[1]+2 }'; is(MCTest::Derived->foo(0), 2); }, sub { eval 'sub MCTest::Base::foo($) { return $_[1]+3 }'; is(MCTest::Derived->foo(0), 3); }, sub { eval 'sub MCTest::Base::foo($) { 4 }'; is(MCTest::Derived->foo(0), 4); }, sub { *MCTest::Base::foo = sub { $_[1]+5 }; is(MCTest::Derived->foo(0), 5); }, sub { local *MCTest::Base::foo = sub { $_[1]+6 }; is(MCTest::Derived->foo(0), 6); }, sub { is(MCTest::Derived->foo(0), 5); }, - sub { sub FFF { $_[1]+9 }; local *MCTest::Base::foo = *FFF; is(MCTest::Derived->foo(0), 9); }, + sub { sub FFF { $_[1]+7 }; local *MCTest::Base::foo = *FFF; is(MCTest::Derived->foo(0), 7); }, sub { is(MCTest::Derived->foo(0), 5); }, - sub { *ASDF::asdf = sub { $_[1]+7 }; *MCTest::Base::foo = \&ASDF::asdf; is(MCTest::Derived->foo(0), 7); }, - sub { *ASDF::asdf = sub { $_[1]+7 }; *MCTest::Base::foo = \&ASDF::asdf; is(MCTest::Derived->foo(0), 7); }, + sub { sub DDD { $_[1]+8 }; *MCTest::Base::foo = *DDD; is(MCTest::Derived->foo(0), 8); }, + sub { *ASDF::asdf = sub { $_[1]+9 }; *MCTest::Base::foo = \&ASDF::asdf; is(MCTest::Derived->foo(0), 9); }, + sub { undef *MCTest::Base::foo; eval { MCTest::Derived->foo(0) }; like($@, qr/locate object method/); }, + sub { eval "sub MCTest::Base::foo($);"; *MCTest::Base::foo = \&ASDF::asdf; is(MCTest::Derived->foo(0), 9); }, + sub { *XYZ = sub { $_[1]+10 }; ${MCTest::Base::}{foo} = \&XYZ; is(MCTest::Derived->foo(0), 10); }, + sub { ${MCTest::Base::}{foo} = sub { $_[1]+11 }; is(MCTest::Derived->foo(0), 11); }, + sub { undef *MCTest::Base::foo; eval { MCTest::Derived->foo(0) }; like($@, qr/locate object method/); }, - sub { sub MCTest::Base::foo($); *MCTest::Base::foo = \&ASDF::asdf; is(MCTest::Derived->foo(0), 7); }, - sub { *XYZ = sub { $_[1]+8 }; ${MCTest::Base::}{foo} = \&XYZ; is(MCTest::Derived->foo(0), 8); }, + sub { eval 'package MCTest::Base; sub foo { $_[1]+12 }'; is(MCTest::Derived->foo(0), 12); }, + sub { eval 'package ZZZ; sub foo { $_[1]+13 }'; *MCTest::Base::foo = \&ZZZ::foo; is(MCTest::Derived->foo(0), 13); }, + sub { ${MCTest::Base::}{foo} = sub { $_[1]+14 }; is(MCTest::Derived->foo(0), 14); }, + # 5.8.8 fails this one + sub { undef *{MCTest::Base::}; eval { MCTest::Derived->foo(0) }; like($@, qr/locate object method/); }, + sub { eval 'package MCTest::Base; sub foo { $_[1]+15 }'; is(MCTest::Derived->foo(0), 15); }, + sub { undef %{MCTest::Base::}; eval { MCTest::Derived->foo(0) }; like($@, qr/locate object method/); }, + sub { eval 'package MCTest::Base; sub foo { $_[1]+16 }'; is(MCTest::Derived->foo(0), 16); }, + sub { %{MCTest::Base::} = (); eval { MCTest::Derived->foo(0) }; like($@, qr/locate object method/); }, + sub { eval 'package MCTest::Base; sub foo { $_[1]+17 }'; is(MCTest::Derived->foo(0), 17); }, + # 5.8.8 fails this one too + sub { *{MCTest::Base::} = *{Foo::}; eval { MCTest::Derived->foo(0) }; like($@, qr/locate object method/); }, sub { *MCTest::Derived::foo = \&MCTest::Base::foo; eval { MCTest::Derived::foo(0,0) }; ok(!$@); undef *MCTest::Derived::foo }, + sub { eval 'package MCTest::Base; sub foo { $_[1]+18 }'; is(MCTest::Derived->foo(0), 18); }, ); -plan(tests => scalar(@testsubs) + 1); +plan(tests => scalar(@testsubs)); -is(MCTest::Derived->foo(0), 1); $_->() for (@testsubs); diff --git a/universal.c b/universal.c index ea901da..9b0e12b 100644 --- a/universal.c +++ b/universal.c @@ -62,7 +62,7 @@ S_isa_lookup(pTHX_ HV *stash, const char *name, const HV* const name_stash, while (items--) { SV* const basename_sv = *svp++; HV* basestash = gv_stashsv(basename_sv, 0); - if (!basestash || (HvMROMETA(basestash)->fake && !HvFILL(basestash))) { + if (!basestash) { if (ckWARN(WARN_SYNTAX)) Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for the parents of %s", -- 2.7.4