summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorFather Chrysostomos <sprout@cpan.org>2010-11-08 19:24:07 -0800
committerFather Chrysostomos <sprout@cpan.org>2010-11-08 19:25:47 -0800
commit80ebaca223149b3ac705ec4546d4483110daf2d8 (patch)
tree259d50d0cd37a79907d28d75efd849b14ef84f5f
parent84601d63a7e34958da47dad1e61e27cb3bd467d1 (diff)
downloadperl-80ebaca223149b3ac705ec4546d4483110daf2d8.tar.gz
[perl #75176] Symbol::delete_package does not free certain memory associated with package::ISA
This commit makes @ISA changes and package aliasing update PL_isarev properly, removing old, unnecessary entries in addition to adding new entries. So now it is capable of shrinking, not just growing. ------------ Gory Details ------------ There is a chicken-and-egg problem when it comes to calling mro_isa_changed_in on the affected classes: When an isa linearisation is recalculated, it uses the existing linearisations of the super- classes (if any) (or at least the DFS implementation does). Since an assigned package (e.g., the *b:: in *a:: = *b::) can contain nested packages that inherit from each other in any order (b::c isa b::c::d or b::c::e isa b::c), this means that mro_isa_changed_in *must not* be called on any stash while another stash contains stale data. So mro_package_moved has been restructured. It is no longer recurs- ive. The recursive code for iterating through nested stashes has been moved into a separate, static routine: mro_gather_and_rename. Instead of calling mro_isa_changed_in during the iteration, it adds all the classes to ‘the big hash’, which mro_package_moved holds a pointer to. When mro_gather_and_rename returns, mro_package_moved iterates through the big hash twice: the first time to wipe caches; the second to call mro_isa_changed_in on all the stashes. This ‘big hash’ is now used in place of the seen_stashes that mro_package_moved used before. Both mro_package_moved and mro_isa_changed_in now use the existing mrometa->isa hash to determine which classes used to be superclasses of the stash in question. A separate routine, S_mro_clean_isarev, deletes entries mention in isa, except for those that still exist in the new isa hash. mro_isa_changed_in now does two iterations through isarev, just like mro_package_moved. It has to call get_linear_isa on the subclasses so that it can see what is in the new meta->isa hash created thereby. Consequently, it has to make sure that all the subclasses have their caches deleted before it can update anything. It makes the same changes to isarev for each subclass that are made further down on the class for which mro_isa_changed_in was called. Yes, it is repetitive. But calling mro_isa_changed_in recursively has more overhead and would do more unnecessary work. (Maybe we could make some macros for this repetitive code.) The loop through the superclasses near the end of mro_isa_changed_in no longer adds the subclasses to all the superclasses’ isarev hashes, because that is taken care of further up. ------------ Side Effects ------------ One result of this change is that mro::is_universal no longer returns true for classes that are no longer universal. I consider that a bug fix. ------------- Miscellaneous ------------- This also removes obsolete comments in mro_isa_changed_in, concerning fake and universal flags on stashes, that have been invalid since dd69841bebe.
-rw-r--r--embed.fnc8
-rw-r--r--embed.h2
-rw-r--r--mro.c392
-rw-r--r--proto.h12
-rw-r--r--t/mro/basic.t2
-rw-r--r--t/mro/isarev.t39
-rw-r--r--t/op/universal.t2
7 files changed, 360 insertions, 97 deletions
diff --git a/embed.fnc b/embed.fnc
index c9d054d558..7af946bceb 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -2354,6 +2354,14 @@ p |struct mro_meta* |mro_meta_dup |NN struct mro_meta* smeta|NN CLONE_PARAMS* pa
Apd |AV* |mro_get_linear_isa|NN HV* stash
#if defined(PERL_IN_MRO_C)
sd |AV* |mro_get_linear_isa_dfs|NN HV* stash|U32 level
+s |void |mro_clean_isarev|NN HV * const isa \
+ |NN const char * const name \
+ |const STRLEN len \
+ |NULLOK HV * const exceptions
+s |void |mro_gather_and_rename|NN HV * const stashes \
+ |NULLOK HV *stash \
+ |NULLOK HV *oldstash \
+ |NN const char *name|I32 namlen
#endif
: Used in hv.c, mg.c, pp.c, sv.c
md |void |mro_isa_changed_in|NN HV* stash
diff --git a/embed.h b/embed.h
index ac080b76c1..7f079b7b0f 100644
--- a/embed.h
+++ b/embed.h
@@ -1639,6 +1639,8 @@
#define unwind_handler_stack(a) S_unwind_handler_stack(aTHX_ a)
# endif
# if defined(PERL_IN_MRO_C)
+#define mro_clean_isarev(a,b,c,d) S_mro_clean_isarev(aTHX_ a,b,c,d)
+#define mro_gather_and_rename(a,b,c,d,e) S_mro_gather_and_rename(aTHX_ a,b,c,d,e)
#define mro_get_linear_isa_dfs(a,b) S_mro_get_linear_isa_dfs(aTHX_ a,b)
# endif
# if defined(PERL_IN_NUMERIC_C)
diff --git a/mro.c b/mro.c
index 4d6563d228..47f99e4129 100644
--- a/mro.c
+++ b/mro.c
@@ -466,6 +466,7 @@ Perl_mro_isa_changed_in3(pTHX_ HV* stash, const char *stashname,
I32 items;
bool is_universal;
struct mro_meta * meta = NULL;
+ HV *isa = NULL;
if(!stashname && stash) {
stashname = HvENAME_get(stash);
@@ -491,7 +492,8 @@ Perl_mro_isa_changed_in3(pTHX_ HV* stash, const char *stashname,
meta->mro_linear_current = NULL;
}
if (meta->isa) {
- SvREFCNT_dec(meta->isa);
+ /* Steal it for our own purposes. */
+ isa = (HV *)sv_2mortal((SV *)meta->isa);
meta->isa = NULL;
}
@@ -519,9 +521,25 @@ Perl_mro_isa_changed_in3(pTHX_ HV* stash, const char *stashname,
if(meta && meta->mro_nextmethod) hv_clear(meta->mro_nextmethod);
/* Iterate the isarev (classes that are our children),
- wiping out their linearization, method and isa caches */
+ wiping out their linearization, method and isa caches
+ and upating PL_isarev. */
if(isarev) {
- hv_iterinit(isarev);
+ HV *isa_hashes = NULL;
+
+ /* We have to iterate through isarev twice to avoid a chicken and
+ * egg problem: if A inherits from B and both are in isarev, A might
+ * be processed before B and use B’s previous linearisation.
+ */
+
+ /* First iteration: Wipe everything, but stash away the isa hashes
+ * since we still need them for updating PL_isarev.
+ */
+
+ if(hv_iterinit(isarev)) {
+ /* Only create the hash if we need it; i.e., if isarev has
+ any elements. */
+ isa_hashes = (HV *)sv_2mortal((SV *)newHV());
+ }
while((iter = hv_iternext(isarev))) {
I32 len;
const char* const revkey = hv_iterkey(iter, &len);
@@ -544,21 +562,85 @@ Perl_mro_isa_changed_in3(pTHX_ HV* stash, const char *stashname,
revmeta->cache_gen++;
if(revmeta->mro_nextmethod)
hv_clear(revmeta->mro_nextmethod);
- if (revmeta->isa) {
- SvREFCNT_dec(revmeta->isa);
- revmeta->isa = NULL;
- }
+
+ (void)
+ hv_store(
+ isa_hashes, (const char*)&revstash, sizeof(HV *),
+ revmeta->isa ? (SV *)revmeta->isa : &PL_sv_undef, 0
+ );
+ revmeta->isa = NULL;
+ }
+
+ /* Second pass: Update PL_isarev. We can just use isa_hashes to
+ * avoid another round of stash lookups. */
+
+ /* isarev might be deleted from PL_isarev during this loop, so hang
+ * on to it. */
+ SvREFCNT_inc_simple_void_NN(sv_2mortal((SV *)isarev));
+
+ if(isa_hashes) {
+ hv_iterinit(isa_hashes);
+ while((iter = hv_iternext(isa_hashes))) {
+ HV* const revstash = *(HV **)HEK_KEY(HeKEY_hek(iter));
+ HV * const isa = (HV *)HeVAL(iter);
+ const HEK *namehek;
+
+ /* Re-calculate the linearisation, unless a previous iter-
+ ation was for a subclass of this class. */
+ if(!HvMROMETA(revstash)->isa)
+ (void)mro_get_linear_isa(revstash);
+
+ /* We're starting at the 2nd element, skipping revstash */
+ linear_mro = mro_get_linear_isa(revstash);
+ svp = AvARRAY(linear_mro) + 1;
+ items = AvFILLp(linear_mro);
+
+ namehek = HvENAME_HEK(revstash);
+ if (!namehek) namehek = HvNAME_HEK(revstash);
+
+ while (items--) {
+ SV* const sv = *svp++;
+ HV* mroisarev;
+
+ HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0);
+
+ /* That fetch should not fail. But if it had to create
+ a new SV for us, then will need to upgrade it to an
+ HV (which sv_upgrade() can now do for us). */
+
+ mroisarev = MUTABLE_HV(HeVAL(he));
+
+ SvUPGRADE(MUTABLE_SV(mroisarev), SVt_PVHV);
+
+ /* 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. */
+
+ (void)
+ hv_store(
+ mroisarev, HEK_KEY(namehek), HEK_LEN(namehek),
+ &PL_sv_yes, 0
+ );
+ }
+
+ if((SV *)isa != &PL_sv_undef)
+ mro_clean_isarev(
+ isa, HEK_KEY(namehek), HEK_LEN(namehek),
+ HvMROMETA(revstash)->isa
+ );
+ }
}
}
- /* Now iterate our MRO (parents), and do a few things:
- 1) instantiate with the "fake" flag if they don't exist
- 2) flag them as universal if we are universal
- 3) Add everything from our isarev to their isarev
+ /* Now iterate our MRO (parents), and:
+ 1) Add ourselves and everything from our isarev to their isarev
+ 2) Delete the parent’s entry from the (now temporary) isa hash
*/
/* This only applies if the stash exists. */
- if(!stash) return;
+ if(!stash) goto clean_up_isarev;
/* We're starting at the 2nd element, skipping ourselves here */
linear_mro = mro_get_linear_isa(stash);
@@ -585,13 +667,36 @@ Perl_mro_isa_changed_in3(pTHX_ HV* stash, const char *stashname,
case where it doesn't exist. */
(void)hv_store(mroisarev, stashname, stashname_len, &PL_sv_yes, 0);
+ }
+
+ clean_up_isarev:
+ /* Delete our name from our former parents’ isarevs. */
+ if(isa && HvARRAY(isa))
+ mro_clean_isarev(isa, stashname, stashname_len, meta->isa);
+}
+
+/* Deletes name from all the isarev entries listed in isa */
+STATIC void
+S_mro_clean_isarev(pTHX_ HV * const isa, const char * const name,
+ const STRLEN len, HV * const exceptions)
+{
+ HE* iter;
- if(isarev) {
- hv_iterinit(isarev);
- while((iter = hv_iternext(isarev))) {
- I32 revkeylen;
- char* const revkey = hv_iterkey(iter, &revkeylen);
- (void)hv_store(mroisarev, revkey, revkeylen, &PL_sv_yes, 0);
+ PERL_ARGS_ASSERT_MRO_CLEAN_ISAREV;
+
+ /* Delete our name from our former parents’ isarevs. */
+ if(isa && HvARRAY(isa) && hv_iterinit(isa)) {
+ SV **svp;
+ while((iter = hv_iternext(isa))) {
+ I32 klen;
+ const char * const key = hv_iterkey(iter, &klen);
+ if(exceptions && hv_exists(exceptions, key, klen)) continue;
+ svp = hv_fetch(PL_isarev, key, klen, 0);
+ if(svp) {
+ HV * const isarev = (HV *)*svp;
+ (void)hv_delete(isarev, name, len, G_DISCARD);
+ if(!HvARRAY(isarev) || !HvKEYS(isarev))
+ (void)hv_delete(PL_isarev, key, klen, G_DISCARD);
}
}
}
@@ -614,6 +719,9 @@ This function invalidates isa caches on the old stash, on all subpackages
nested inside it, and on the subclasses of all those, including
non-existent packages that have corresponding entries in C<stash>.
+It also sets the effective names (C<HvENAME>) on all the stashes as
+appropriate.
+
=cut
*/
void
@@ -621,20 +729,11 @@ Perl_mro_package_moved(pTHX_ HV * const stash, HV * const oldstash,
const GV *gv, const char *newname,
I32 newname_len)
{
- register XPVHV* xhv;
- register HE *entry;
- I32 riter = -1;
- HV *seen = NULL;
- HV *seen_stashes = NULL;
- const bool stash_had_name = stash && HvENAME(stash);
-
- /* If newname_len is negative, then gv is actually the caller’s hash of
- stashes that have been seen so far. */
+ HV *stashes;
+ HE* iter;
assert(stash || oldstash);
- assert((gv && newname_len >= 0) || newname);
-
- if(newname_len < 0) seen_stashes = (HV *)gv, gv = NULL;
+ assert(gv || newname);
/* Determine the name of the location that stash was assigned to
* or from which oldstash was removed.
@@ -663,28 +762,168 @@ Perl_mro_package_moved(pTHX_ HV * const stash, HV * const oldstash,
}
if(newname_len < 0) newname_len = -newname_len;
- if(oldstash && HvENAME_get(oldstash)) {
- if(PL_stashcache)
+ /* Get a list of all the affected classes. */
+ /* We cannot simply pass them all to mro_isa_changed_in to avoid
+ the list, as that function assumes that only one package has
+ changed. It does not work with:
+
+ @foo::ISA = qw( B B::B );
+ *B:: = delete $::{"A::"};
+
+ as neither B nor B::B can be updated before the other, since they
+ will reset caches on foo, which will see either B or B::B with the
+ wrong name. The names must be set on *all* affected stashes before
+ we do anything else.
+ */
+ stashes = (HV *) sv_2mortal((SV *)newHV());
+ mro_gather_and_rename(stashes, stash, oldstash, newname, newname_len);
+
+ /* Iterate through the stashes, wiping isa linearisations, but leaving
+ the isa hash (which mro_isa_changed_in needs for adjusting the
+ isarev hashes belonging to parent classes). */
+ hv_iterinit(stashes);
+ while((iter = hv_iternext(stashes))) {
+ if(HeVAL(iter) != &PL_sv_yes && HvENAME(HeVAL(iter))) {
+ struct mro_meta* meta;
+ meta = HvMROMETA((HV *)HeVAL(iter));
+ if (meta->mro_linear_all) {
+ SvREFCNT_dec(MUTABLE_SV(meta->mro_linear_all));
+ meta->mro_linear_all = NULL;
+ /* This is just acting as a shortcut pointer. */
+ meta->mro_linear_current = NULL;
+ } else if (meta->mro_linear_current) {
+ /* Only the current MRO is stored, so this owns the data. */
+ SvREFCNT_dec(meta->mro_linear_current);
+ meta->mro_linear_current = NULL;
+ }
+ }
+ }
+
+ /* Once the caches have been wiped on all the classes, call
+ mro_isa_changed_in on each. */
+ hv_iterinit(stashes);
+ while((iter = hv_iternext(stashes))) {
+ if(HeVAL(iter) != &PL_sv_yes && HvENAME(HeVAL(iter)))
+ mro_isa_changed_in((HV *)HeVAL(iter));
+ /* We are not holding a refcount, so eliminate the pointer before
+ * stashes is freed. */
+ HeVAL(iter) = NULL;
+ }
+}
+
+void
+S_mro_gather_and_rename(pTHX_ HV * const stashes, HV *stash, HV *oldstash,
+ const char *name, I32 namlen)
+{
+ register XPVHV* xhv;
+ register HE *entry;
+ I32 riter = -1;
+ const bool stash_had_name = stash && HvENAME(stash);
+ HV *seen = NULL;
+ HV *isarev = NULL;
+ SV **svp;
+
+ PERL_ARGS_ASSERT_MRO_GATHER_AND_RENAME;
+
+ if(oldstash) {
+ /* Add to the big list. */
+ HE * const entry
+ = (HE *)
+ hv_common(
+ stashes, NULL, (const char *)&oldstash, sizeof(HV *), 0,
+ HV_FETCH_LVALUE, NULL, 0
+ );
+ if(HeVAL(entry) == (SV *)oldstash) {
+ oldstash = NULL;
+ goto check_stash;
+ }
+ HeVAL(entry) = (SV *)oldstash;
+
+ /* Update the effective name. */
+ if(HvENAME_get(oldstash)) {
+ const HEK * const enamehek = HvENAME_HEK(oldstash);
+ if(PL_stashcache)
(void)
- hv_delete(PL_stashcache, newname, newname_len, G_DISCARD);
- hv_ename_delete(oldstash, newname, newname_len);
+ hv_delete(PL_stashcache, name, namlen, G_DISCARD);
+ hv_ename_delete(oldstash, name, namlen);
+
+ /* If the name deletion caused a name change, then we are not
+ * going to call mro_isa_changed_in with this name (and not at all
+ * if it has become anonymous) so we need to delete old isarev
+ * entries here, both those in the superclasses and this class’s
+ * own list of subclasses. We simply delete the latter from
+ * from PL_isarev, since we still need it. hv_delete mortifies it
+ * for us, so sv_2mortal is not necessary. */
+ if(HvENAME_HEK(oldstash) != enamehek) {
+ const struct mro_meta * meta = HvMROMETA(oldstash);
+ if(meta->isa && HvARRAY(meta->isa))
+ mro_clean_isarev(meta->isa, name, namlen, NULL);
+ isarev = (HV *)hv_delete(PL_isarev, name, namlen, 0);
+ }
+ }
}
+ check_stash:
if(stash) {
- hv_ename_add(stash, newname, newname_len);
-
- /* If this stash had been detached from the symbol table (so it
- * had no HvENAME) before being assigned to spot whose name is in
- * newname, then its isa cache would be stale (the effective name
- * having changed), and subclasses of newname would then use that
- * cache in the mro_isa_changed_in3(oldstash...) call below. (See
+ hv_ename_add(stash, name, namlen);
+
+ /* Add it to the big list. We use the stash itself as the value if
+ * it needs mro_isa_changed_in called on it. Otherwise we just use
+ * &PL_sv_yes to indicate that we have seen it. */
+
+ /* The stash needs mro_isa_changed_in called on it if it was
+ * detached from the symbol table (so it had no HvENAME) before
+ * being assigned to the spot named by the ‘name’ variable, because
+ * its cached isa linerisation is now stale (the effective name
+ * having changed), and subclasses will then use that cache when
+ * mro_package_moved calls mro_isa_changed_in. (See
* [perl #77358].)
+ *
* If it did have a name, then its previous name is still
- * used in isa caches, and there is no need for this call.
+ * used in isa caches, and there is no need for
+ * mro_package_moved to call mro_isa_changed_in.
*/
- if(!stash_had_name) mro_isa_changed_in(stash);
+
+ entry
+ = (HE *)
+ hv_common(
+ stashes, NULL, (const char *)&stash, sizeof(HV *), 0,
+ HV_FETCH_LVALUE, NULL, 0
+ );
+ if(HeVAL(entry) == &PL_sv_yes || HeVAL(entry) == (SV *)stash)
+ stash = NULL;
+ else HeVAL(entry) = stash_had_name ? &PL_sv_yes : (SV *)stash;
}
- mro_isa_changed_in3((HV *)oldstash, newname, newname_len);
+ if(!stash && !oldstash)
+ /* Both stashes have been encountered already. */
+ return;
+
+ /* Add all the subclasses to the big list. */
+ if(
+ isarev
+ || (
+ (svp = hv_fetch(PL_isarev, name, namlen, 0))
+ && (isarev = MUTABLE_HV(*svp))
+ )
+ ) {
+ HE *iter;
+ hv_iterinit(isarev);
+ while((iter = hv_iternext(isarev))) {
+ I32 len;
+ const char* const revkey = hv_iterkey(iter, &len);
+ HV* revstash = gv_stashpvn(revkey, len, 0);
+
+ if(!revstash) continue;
+ entry
+ = (HE *)
+ hv_common(
+ stashes, NULL, (const char *)&revstash, sizeof(HV *), 0,
+ HV_FETCH_LVALUE, NULL, 0
+ );
+ HeVAL(entry) = (SV *)revstash;
+
+ }
+ }
if(
(!stash || !HvARRAY(stash)) && (!oldstash || !HvARRAY(oldstash))
@@ -697,13 +936,9 @@ Perl_mro_package_moved(pTHX_ HV * const stash, HV * const oldstash,
if(oldstash && HvUSEDKEYS(oldstash)) {
xhv = (XPVHV*)SvANY(oldstash);
seen = (HV *) sv_2mortal((SV *)newHV());
- if(!seen_stashes) seen_stashes = (HV *) sv_2mortal((SV *)newHV());
- /* Iterate through entries in the oldstash, calling
- mro_package_moved(
- corresponding_entry_in_new_stash, current_entry, ...
- )
- meanwhile doing the equivalent of $seen{$key} = 1.
+ /* Iterate through entries in the oldstash, adding them to the
+ list, meanwhile doing the equivalent of $seen{$key} = 1.
*/
while (++riter <= (I32)xhv->xhv_max) {
@@ -727,17 +962,6 @@ Perl_mro_package_moved(pTHX_ HV * const stash, HV * const oldstash,
/* Avoid main::main::main::... */
if(oldsubstash == oldstash) continue;
- if(oldsubstash) {
- HE * const entry
- = (HE *)
- hv_common(
- seen_stashes, NULL,
- (const char *)&oldsubstash, sizeof(HV *), 0,
- HV_FETCH_LVALUE, NULL, 0
- );
- if(HeVAL(entry) == &PL_sv_yes) continue;
- HeVAL(entry) = &PL_sv_yes;
- }
if(
(
@@ -750,16 +974,17 @@ Perl_mro_package_moved(pTHX_ HV * const stash, HV * const oldstash,
/* Add :: and the key (minus the trailing ::)
to newname. */
SV *namesv
- = newSVpvn_flags(newname, newname_len, SVs_TEMP);
- const char *name;
- STRLEN namlen;
- sv_catpvs(namesv, "::");
- sv_catpvn(namesv, key, len-2);
- name = SvPV_const(namesv, namlen);
- mro_package_moved(
- substash, oldsubstash,
- (GV *)seen_stashes, name, -namlen
- );
+ = newSVpvn_flags(name, namlen, SVs_TEMP);
+ {
+ const char *name;
+ STRLEN namlen;
+ sv_catpvs(namesv, "::");
+ sv_catpvn(namesv, key, len-2);
+ name = SvPV_const(namesv, namlen);
+ mro_gather_and_rename(
+ stashes, substash, oldsubstash, name, namlen
+ );
+ }
}
(void)hv_store(seen, key, len, &PL_sv_yes, 0);
@@ -771,10 +996,9 @@ Perl_mro_package_moved(pTHX_ HV * const stash, HV * const oldstash,
/* Skip the entire loop if the hash is empty. */
if (stash && HvUSEDKEYS(stash)) {
xhv = (XPVHV*)SvANY(stash);
- if(!seen_stashes) seen_stashes = (HV *) sv_2mortal((SV *)newHV());
/* Iterate through the new stash, skipping $seen{$key} items,
- calling mro_package_moved(entry, NULL, ...). */
+ calling mro_gather_and_rename(stashes, entry, NULL, ...). */
while (++riter <= (I32)xhv->xhv_max) {
entry = (HvARRAY(stash))[riter];
@@ -801,31 +1025,21 @@ Perl_mro_package_moved(pTHX_ HV * const stash, HV * const oldstash,
substash = GvHV(HeVAL(entry));
if(substash) {
SV *namesv;
- const char *name;
- STRLEN namlen;
- HE *entry;
+ const char *subname;
+ STRLEN subnamlen;
/* Avoid checking main::main::main::... */
if(substash == stash) continue;
- entry
- = (HE *)
- hv_common(
- seen_stashes, NULL,
- (const char *)&substash, sizeof(HV *), 0,
- HV_FETCH_LVALUE, NULL, 0
- );
- if(HeVAL(entry) == &PL_sv_yes) continue;
- HeVAL(entry) = &PL_sv_yes;
/* Add :: and the key (minus the trailing ::)
to newname. */
namesv
- = newSVpvn_flags(newname, newname_len, SVs_TEMP);
+ = newSVpvn_flags(name, namlen, SVs_TEMP);
sv_catpvs(namesv, "::");
sv_catpvn(namesv, key, len-2);
- name = SvPV_const(namesv, namlen);
- mro_package_moved(
- substash, NULL, (GV *)seen_stashes, name, -namlen
+ subname = SvPV_const(namesv, subnamlen);
+ mro_gather_and_rename(
+ stashes, substash, NULL, subname, subnamlen
);
}
}
diff --git a/proto.h b/proto.h
index 04bb2d8ae6..a32301abfa 100644
--- a/proto.h
+++ b/proto.h
@@ -5659,6 +5659,18 @@ STATIC void S_save_magic(pTHX_ I32 mgs_ix, SV *sv)
STATIC void S_unwind_handler_stack(pTHX_ const void *p);
#endif
#if defined(PERL_IN_MRO_C)
+STATIC void S_mro_clean_isarev(pTHX_ HV * const isa, const char * const name, const STRLEN len, HV * const exceptions)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MRO_CLEAN_ISAREV \
+ assert(isa); assert(name)
+
+STATIC void S_mro_gather_and_rename(pTHX_ HV * const stashes, HV *stash, HV *oldstash, const char *name, I32 namlen)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_4);
+#define PERL_ARGS_ASSERT_MRO_GATHER_AND_RENAME \
+ assert(stashes); assert(name)
+
STATIC AV* S_mro_get_linear_isa_dfs(pTHX_ HV* stash, U32 level)
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA_DFS \
diff --git a/t/mro/basic.t b/t/mro/basic.t
index f49695607e..353352bb61 100644
--- a/t/mro/basic.t
+++ b/t/mro/basic.t
@@ -57,7 +57,7 @@ ok(!mro::is_universal('MRO_B'));
ok(mro::is_universal('MRO_B'));
@UNIVERSAL::ISA = ();
-ok(mro::is_universal('MRO_B'));
+ok(!mro::is_universal('MRO_B'));
# is_universal, get_mro, and get_linear_isa should
# handle non-existant packages sanely
diff --git a/t/mro/isarev.t b/t/mro/isarev.t
index 01b0017b0b..c76cf9e084 100644
--- a/t/mro/isarev.t
+++ b/t/mro/isarev.t
@@ -10,7 +10,7 @@ BEGIN {
use strict;
use warnings;
-plan(tests => 15);
+plan(tests => 20);
use mro;
@@ -25,7 +25,21 @@ sub i {
goto &is;
}
-$::TODO = "[perl #75176] isarev leeks (and onions)";
+# Basic isarev updating, when @ISA changes
+@Pastern::ISA = "BodyPart::Ungulate";
+@Scur::ISA = "BodyPart::Ungulate";
+@BodyPart::Ungulate::ISA = "BodyPart";
+i BodyPart => qw [ BodyPart::Ungulate Pastern Scur ],
+ 'subclasses and subsubclasses are added to isarev';
+@Pastern::ISA = ();
+i BodyPart => qw [ BodyPart::Ungulate Scur ],
+ 'single deletion from isarev';
+@BodyPart::Ungulate::ISA = ();
+i BodyPart => qw [ ], 'recursive deletion from isarev';
+ # except underneath it is not actually recursive
+
+
+# More complicated tests that move packages around
@Huskey::ISA = "Dog";
@Dog::ISA = "Canid";
@@ -70,17 +84,18 @@ i g => qw [ Weird::Thing ],
*Caprine:: = *Chevre::;
i"Hoofed::Mammal" => qw[ Caprid ],
"replacing a stash updates isarev entries";
-i Caprine => qw[ Whatever ],
+i Chevre => qw[ Caprid::Dairy Whatever ],
"replacing nested stashes updates isarev entries";
@Disease::Eye::ISA = "Disease";
@Disease::Eye::Infectious::ISA = "Disease::Eye";
@Keratoconjunctivitis::ISA = "Disease::Ophthalmic::Infectious";
*Disease::Ophthalmic:: = *Disease::Eye::;
+{package some_random_new_symbol::Infectious} # autovivify
*Disease::Ophthalmic:: = *some_random_new_symbol::;
-i Disease => qw[ Disease::Eye ],
+i Disease => qw[ Disease::Eye Disease::Eye::Infectious ],
"replacing an alias of a stash updates isarev entries";
-i Caprine => qw[ Disease::Eye ],
+i"Disease::Eye" => qw[ Disease::Eye::Infectious ],
"replacing an alias of a stash containing another updates isarev entries";
i"some_random_new_symbol::Infectious" => qw[ Keratoconjunctivitis ],
"replacing an alias updates isarev of stashes nested in the replacement";
@@ -93,5 +108,17 @@ undef *Empty::;
{package Zilch::Empty} # autovivify it
*Empty:: = *Zilch::;
i Zilch => qw[ Null ], "assigning to an empty spot updates isarev";
-i"Zilch::Empty" => qw[ Null::Empty ],
+i"Zilch::Empty" => qw[ Null::Null ],
"assigning to an empty spot updates isarev of nested packages";
+
+# Classes inheriting from multiple classes that get moved in a single
+# assignment.
+@foo::ISA = ("B", "B::B");
+{package A::B}
+my $A = \%A::; # keep a ref
+*A:: = 'whatever'; # clobber it
+*B:: = $A; # assign to two superclasses of foo at the same time
+# There should be no A::B isarev entry.
+i"A::B" => qw [], 'assigning to two superclasses at the same time';
+ok !foo->isa("A::B"),
+ "A class must not inherit from its superclass’s former name";
diff --git a/t/op/universal.t b/t/op/universal.t
index d74686f97d..db79dcde70 100644
--- a/t/op/universal.t
+++ b/t/op/universal.t
@@ -298,7 +298,7 @@ use warnings "deprecated";
@RT66112::B::ISA = qw//;
@RT66112::C::ISA = qw/RT66112::B/;
@RT66112::T3::ISA = qw/RT66112::C/;
- ok(RT66112::T3->isa('RT66112::A'), "modify \@ISA in isa (RT66112::T3 isa RT66112::A)");
+ ok(RT66112::T3->isa('RT66112::A'), "modify \@ISA in isa (RT66112::T3 isa RT66112::A)") or require mro, diag "@{mro::get_linear_isa('RT66112::T3')}";
@RT66112::E::ISA = qw/RT66112::D/;
@RT66112::T4::ISA = qw/RT66112::E/;