Reset isa on stash manipulation

This only applies to glob-to-glob assignments and deletions of stash
elements. Other types of stash manipulation are dealt with by subse-
quent patches.

It adds mro_package_moved, a private function that iterates through
subpackages, calling mro_isa_changed_in on each.

This is related to [perl #75176], but is not the same bug. It simply
got in the way of fixing [perl #75176].

8 files changed, 201 insertions, 5 deletions

diff --git a/embed.fnc b/embed.fnc
index 45b2419c8a..fe70aa9a1f 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -2356,6 +2356,7 @@ sd	|AV*	|mro_get_linear_isa_dfs|NN HV* stash|U32 level
 : Used in hv.c, mg.c, pp.c, sv.c
 pd	|void   |mro_isa_changed_in|NN HV* stash
 Apd	|void	|mro_method_changed_in	|NN HV* stash
+pdx	|void	|mro_package_moved	|NN const HV *stash
 : Only used in perl.c
 p	|void   |boot_core_mro
 Apon	|void	|sys_init	|NN int* argc|NN char*** argv
diff --git a/embed.h b/embed.h
index 8732fd813f..0e06f08ccb 100644
--- a/embed.h
+++ b/embed.h
@@ -1042,6 +1042,7 @@
 #define mg_localize(a,b,c)	Perl_mg_localize(aTHX_ a,b,c)
 #define mode_from_discipline(a,b)	Perl_mode_from_discipline(aTHX_ a,b)
 #define mro_isa_changed_in(a)	Perl_mro_isa_changed_in(aTHX_ a)
+#define mro_package_moved(a)	Perl_mro_package_moved(aTHX_ a)
 #define munge_qwlist_to_paren_list(a)	Perl_munge_qwlist_to_paren_list(aTHX_ a)
 #define my_attrs(a,b)		Perl_my_attrs(aTHX_ a,b)
 #define my_clearenv()		Perl_my_clearenv(aTHX)
diff --git a/hv.c b/hv.c
index a04e4c51c1..dc873ab8e8 100644
--- a/hv.c
+++ b/hv.c
@@ -692,8 +692,32 @@ Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
 		}
 		HeVAL(entry) = val;
 	    } else if (action & HV_FETCH_ISSTORE) {
-		SvREFCNT_dec(HeVAL(entry));
+		bool moving_package = FALSE;
+		SV *old_val = HeVAL(entry);
+
+		/* If this is a stash and the key ends with ::, then some-
+		   one is aliasing (or moving) a package. */
+		if (HvNAME(hv)) {
+		    if (keysv) key = SvPV(keysv, klen);
+		    if (klen > 1
+		     && key[klen-2] == ':' && key[klen-1] == ':') {
+			if(SvTYPE(old_val) == SVt_PVGV) {
+			    const HV * const old_stash
+			     = GvHV((GV *)old_val);
+			    if(old_stash && HvNAME(old_stash))
+				mro_package_moved(old_stash);
+			}
+			moving_package = TRUE;
+		    }
+		}
+
+		SvREFCNT_dec(old_val);
 		HeVAL(entry) = val;
+
+		if (moving_package && SvTYPE(val) == SVt_PVGV) {
+		    const HV * const stash = GvHV((GV *)val);
+		    if (stash && HvNAME(stash)) mro_package_moved(stash);
+		}
 	    }
 	} else if (HeVAL(entry) == &PL_sv_placeholder) {
 	    /* if we find a placeholder, we pretend we haven't found
@@ -1036,6 +1060,18 @@ S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
 	    HvPLACEHOLDERS(hv)++;
 	} else {
 	    *oentry = HeNEXT(entry);
+
+	    /* If this is a stash and the key ends with ::, then someone is 
+	       deleting a package. */
+	    if (sv && HvNAME(hv)) {
+		if (keysv) key = SvPV(keysv, klen);
+		if (klen > 1 && key[klen-2] == ':' && key[klen-1] == ':'
+		 && SvTYPE(sv) == SVt_PVGV) {
+		    const HV * const stash = GvHV((GV *)sv);
+		    if (stash && HvNAME(stash)) mro_package_moved(stash);
+		}
+	    }
+
 	    if (SvOOK(hv) && entry == HvAUX(hv)->xhv_eiter /* HvEITER(hv) */)
 		HvLAZYDEL_on(hv);
 	    else
diff --git a/mro.c b/mro.c
index 488e564684..bd59465eb3 100644
--- a/mro.c
+++ b/mro.c
@@ -549,6 +549,56 @@ Perl_mro_isa_changed_in(pTHX_ HV* stash)
 }
 
 /*
+=for apidoc mro_package_moved
+
+Invalidates isa caches on this stash, on all subpackages nested inside it,
+and on the subclasses of all those.
+
+=cut
+*/
+void
+Perl_mro_package_moved(pTHX_ const HV *stash)
+{
+    register XPVHV* xhv;
+    register HE *entry;
+    I32 riter = -1;
+
+    PERL_ARGS_ASSERT_MRO_PACKAGE_MOVED;
+
+    mro_isa_changed_in((HV *)stash);
+
+    if(!HvARRAY(stash)) return;
+
+    /* This is partly based on code in hv_iternext_flags. We are not call-
+       ing that here, as we want to avoid resetting the hash iterator. */
+
+    xhv = (XPVHV*)SvANY(stash);
+
+    /* Skip the entire loop if the hash is empty.   */
+    if (HvUSEDKEYS(stash)) {
+	while (++riter <= (I32)xhv->xhv_max) {
+	    entry = (HvARRAY(stash))[riter];
+
+	    /* Iterate through the entries in this list */
+	    for(; entry; entry = HeNEXT(entry)) {
+		const char* key;
+		I32 len;
+
+		/* If this entry is not a glob, ignore it.
+		   Try the next.  */
+		if (!isGV(HeVAL(entry))) continue;
+
+		key = hv_iterkey(entry, &len);
+		if(len > 1 && key[len-2] == ':' && key[len-1] == ':') {
+		    const HV * const stash = GvHV(HeVAL(entry));
+		    if(stash && HvNAME(stash)) mro_package_moved(stash);
+		}
+	    }
+	}
+    }
+}
+
+/*
 =for apidoc mro_method_changed_in
 
 Invalidates method caching on any child classes
diff --git a/pod/perldelta.pod b/pod/perldelta.pod
index f91e474a70..9f495266dd 100644
--- a/pod/perldelta.pod
+++ b/pod/perldelta.pod
@@ -703,6 +703,13 @@ Stringifying a scalar containing -0.0 no longer has the affect of turning
 false into true
 L<[perl #45133]|http://rt.perl.org/rt3/Public/Bug/Display.html?id=45133>.
 
+=item *
+
+Aliasing packages by assigning to globs or deleting packages by deleting
+their containing stash elements used to have erratic effects on method
+resolution, because the internal 'isa' caches were not reset. This has been
+fixed.
+
 =back
 
 =head1 Known Problems
diff --git a/proto.h b/proto.h
index 076cac6024..aaa7c5c15f 100644
--- a/proto.h
+++ b/proto.h
@@ -2221,6 +2221,11 @@ PERL_CALLCONV void	Perl_mro_method_changed_in(pTHX_ HV* stash)
 #define PERL_ARGS_ASSERT_MRO_METHOD_CHANGED_IN	\
 	assert(stash)
 
+PERL_CALLCONV void	Perl_mro_package_moved(pTHX_ const HV *stash)
+			__attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_MRO_PACKAGE_MOVED	\
+	assert(stash)
+
 PERL_CALLCONV void	Perl_mro_register(pTHX_ const struct mro_alg *mro)
 			__attribute__nonnull__(pTHX_1);
 #define PERL_ARGS_ASSERT_MRO_REGISTER	\
diff --git a/sv.c b/sv.c
index 4178dd356d..679f0dbb98 100644
--- a/sv.c
+++ b/sv.c
@@ -3581,7 +3581,8 @@ copy-ish functions and macros use this underneath.
 static void
 S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype)
 {
-    I32 mro_changes = 0; /* 1 = method, 2 = isa */
+    I32 mro_changes = 0; /* 1 = method, 2 = isa, 3 = recursive isa */
+    HV *old_stash;
 
     PERL_ARGS_ASSERT_GLOB_ASSIGN_GLOB;
 
@@ -3627,8 +3628,23 @@ S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype)
         mro_changes = 1;
     }
 
-    if(strEQ(GvNAME((const GV *)dstr),"ISA"))
-        mro_changes = 2;
+    /* We don’t need to check the name of the destination if it was not a
+       glob to begin with. */
+    if(dtype == SVt_PVGV) {
+        const char * const name = GvNAME((const GV *)dstr);
+        if(strEQ(name,"ISA"))
+            mro_changes = 2;
+        else {
+            const STRLEN len = GvNAMELEN(dstr);
+            if (len > 1 && name[len-2] == ':' && name[len-1] == ':') {
+                mro_changes = 3;
+
+                /* Set aside the old stash, so we can reset isa caches on
+                   its subclasses. */
+                old_stash = GvHV(dstr);
+            }
+        }
+    }
 
     gp_free(MUTABLE_GV(dstr));
     isGV_with_GP_off(dstr);
@@ -3645,6 +3661,11 @@ S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype)
 	}
     GvMULTI_on(dstr);
     if(mro_changes == 2) mro_isa_changed_in(GvSTASH(dstr));
+    else if(mro_changes == 3) {
+	const HV * const stash = GvHV(dstr);
+	if(stash && HvNAME(stash)) mro_package_moved(stash);
+	if(old_stash && HvNAME(old_stash)) mro_package_moved(old_stash);
+    }
     else if(mro_changes) mro_method_changed_in(GvSTASH(dstr));
     return;
 }
diff --git a/t/mro/package_aliases.t b/t/mro/package_aliases.t
index b8d03160ae..611ebf51f7 100644
--- a/t/mro/package_aliases.t
+++ b/t/mro/package_aliases.t
@@ -5,11 +5,12 @@ BEGIN {
         chdir 't' if -d 't';
         @INC = '../lib';
     }
+    require q(./test.pl);
 }
 
 use strict;
 use warnings;
-require q(./test.pl); plan(tests => 4);
+require q(./test.pl); plan(tests => 10);
 
 {
     package New;
@@ -31,3 +32,77 @@ ok (New->isa (Old::), 'New inherits from Old');
 
 isa_ok (bless ({}, Old::), New::, 'Old object');
 isa_ok (bless ({}, New::), Old::, 'New object');
+
+
+no warnings; # temporary, until bug #77358 is fixed
+
+# Test that replacing a package by assigning to an existing glob
+# invalidates the isa caches
+{
+ @Subclass::ISA = "Left";
+ @Left::ISA = "TopLeft";
+
+ sub TopLeft::speak { "Woof!" }
+ sub TopRight::speak { "Bow-wow!" }
+
+ my $thing = bless [], "Subclass";
+
+ # mro_package_moved needs to know to skip non-globs
+ $Right::{"gleck::"} = 3;
+
+ @Right::ISA = 'TopRight';
+ my $life_raft = $::{'Left::'};
+ *Left:: = $::{'Right::'};
+
+ is $thing->speak, 'Bow-wow!',
+  'rearranging packages by assigning to a stash elem updates isa caches';
+
+ undef $life_raft;
+ is $thing->speak, 'Bow-wow!',
+  'isa caches are up to date after the replaced stash is freed';
+}
+
+# Similar test, but with nested packages
+{
+ @Subclass::ISA = "Left::Side";
+ @Left::Side::ISA = "TopLeft";
+
+ sub TopLeft::speak { "Woof!" }
+ sub TopRight::speak { "Bow-wow!" }
+
+ my $thing = bless [], "Subclass";
+
+ @Right::Side::ISA = 'TopRight';
+ my $life_raft = $::{'Left::'};
+ *Left:: = $::{'Right::'};
+
+ is $thing->speak, 'Bow-wow!',
+  'moving nested packages by assigning to a stash elem updates isa caches';
+
+ undef $life_raft;
+ is $thing->speak, 'Bow-wow!',
+  'isa caches are up to date after the replaced nested stash is freed';
+}
+
+# Test that deleting stash elements containing
+# subpackages also invalidates the isa cache.
+# Maybe this does not belong in package_aliases.t, but it is closely
+# related to the tests immediately preceding.
+{
+ @Pet::ISA = ("Cur", "Hound");
+ @Cur::ISA = "Hylactete";
+
+ sub Hylactete::speak { "Arff!" }
+ sub Hound::speak { "Woof!" }
+
+ my $pet = bless [], "Pet";
+
+ my $life_raft = delete $::{'Cur::'};
+
+ is $pet->speak, 'Woof!',
+  'deleting a stash from its parent stash invalidates the isa caches';
+
+ undef $life_raft;
+ is $pet->speak, 'Woof!',
+  'the deleted stash is gone completely when freed';
+}