#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)
#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
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);
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);
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;
}
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;
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
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) {
HvREHASH_off(hv);
reset:
if (SvOOK(hv)) {
+ if(HvNAME_get(hv))
+ mro_isa_changed_in(hv);
HvEITER_set(hv, NULL);
}
}
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;
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);
} 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.
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. */
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<PL_sub_generation>.
-
=head2 mro::invalidate_all_method_caches()
Increments C<PL_sub_generation>, which invalidates method
caching in all packages.
-=head2 mro::get_sub_generation($classname)
-
-Returns the current value of a given package's C<sub_generation>.
-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
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)) {
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;
}
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));
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);
/* 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);
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);
}
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);
}
}
}
the changes in this one.
Ideally, all instances of C<PL_sub_generation++> in
-the perl source outside of C<mro.c> should be
-replaced by calls to this. This conversion is
-nearly complete.
+perl source outside of C<mro.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<mro::method_changed_in(classname)>, 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<mro::method_changed_in(classname)>.
=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);
if(!revstash) continue;
mrometa = HvMROMETA(revstash);
- mrometa->sub_generation++;
+ mrometa->cache_gen++;
if(mrometa->mro_nextmethod)
hv_clear(mrometa->mro_nextmethod);
}
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);
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);
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);
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);
}
dXSARGS;
SV* classname;
HV* class_stash;
+ SV** svp;
HV* isarev;
+ char* stashname;
+ STRLEN stashname_len;
PERL_UNUSED_ARG(cv);
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)))
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;
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;
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;
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)
CvPADLIST(PL_compcv) = pad_new(0);
+ PL_isarev = newHV();
+
boot_core_PerlIO();
boot_core_UNIVERSAL();
boot_core_xsutils();
#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
the changes in this one.
Ideally, all instances of C<PL_sub_generation++> in
-the perl source outside of C<mro.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<mro::method_changed_in(classname)>, which
-just calls this.
+perl source outside of C<mro.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<mro::method_changed_in(classname)>.
void mro_method_changed_in(HV* stash)
to have more than one parent class searched for the missing methods.
If C<Animal> 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<mro> 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<use strict>, we'll get complaints on C<@ISA>, since
it's not a variable containing an explicit package name, nor is it a
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<mro> 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<UNIVERSAL> as their
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<mro> for alternate method resolution orders).
Consider a bunch of @ISA arrays like this:
@First::ISA = qw( Alpha );
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<mro>), 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
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);
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);
}
}
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:
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);
}
#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);
GvIMPORTED_on(dstr);
}
GvMULTI_on(dstr);
+ if(method_changed) mro_method_changed_in(GvSTASH(dstr));
return;
}
}
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)
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);
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
{
dVAR;
void *xpvmg;
+ HV *stash;
SV * const temp = sv_newmortal();
assert(SvTYPE(sv) == SVt_PVGV);
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)) {
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;
{
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);
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",
projects / p5sagit/p5-mst-13.2.git / commitdiff