Make more ways to move packages around reset isa caches

This makes string-to-glob assignment and hashref-to-glob assignment reset isa caches by calling mro_package_moved, if the glob’s name ends with ::. Related to [perl #75176].
Perl · Oct 10, 2010 · 3e79609 · 3e79609
1 parent 3e6edce
commit 3e79609
Show file tree

Hide file tree

Showing 2 changed files with 103 additions and 43 deletions.
diff --git a/sv.c b/sv.c
@@ -3772,7 +3772,15 @@ S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr)
 	    && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) {
 	    GvFLAGS(dstr) |= import_flag;
 	}
-	if (stype == SVt_PVAV && strEQ(GvNAME((GV*)dstr), "ISA")) {
+	if (stype == SVt_PVHV) {
+	    const char * const name = GvNAME((GV*)dstr);
+	    const STRLEN len = GvNAMELEN(dstr);
+	    if (len > 1 && name[len-2] == ':' && name[len-1] == ':') {
+		if(HvNAME(dref)) mro_package_moved((HV *)dref);
+		if(HvNAME(sref)) mro_package_moved((HV *)sref);
+	    }
+	}
+	else if (stype == SVt_PVAV && strEQ(GvNAME((GV*)dstr), "ISA")) {
 	    sv_magic(sref, dstr, PERL_MAGIC_isa, NULL, 0);
 	    mro_isa_changed_in(GvSTASH(dstr));
 	}
@@ -4016,9 +4024,27 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags)
 	else {
 	    GV *gv = gv_fetchsv(sstr, GV_ADD, SVt_PVGV);
 	    if (dstr != (const SV *)gv) {
+		const char * const name = GvNAME((const GV *)dstr);
+		const STRLEN len = GvNAMELEN(dstr);
+		HV *old_stash = NULL;
+		bool reset_isa = FALSE;
+		if (len > 1 && name[len-2] == ':' && name[len-1] == ':') {
+		    /* Set aside the old stash, so we can reset isa caches
+		       on its subclasses. */
+		    old_stash = GvHV(dstr);
+		    reset_isa = TRUE;
+		}
+
 		if (GvGP(dstr))
 		    gp_free(MUTABLE_GV(dstr));
 		GvGP(dstr) = gp_ref(GvGP(gv));
+
+		if (reset_isa) {
+		    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);
+		}
 	    }
 	}
     }

diff --git a/t/mro/package_aliases.t b/t/mro/package_aliases.t
@@ -10,7 +10,7 @@ BEGIN {
 
 use strict;
 use warnings;
-plan(tests => 10);
+plan(tests => 12);
 
 {
     package New;
@@ -38,50 +38,84 @@ 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';
+for(
+ {
+   name => 'assigning a glob to a glob',
+   code => '$life_raft = $::{"Left::"}; *Left:: = $::{"Right::"}',
+ },
+ {
+   name => 'assigning a string to a glob',
+   code => '$life_raft = $::{"Left::"}; *Left:: = "Right::"',
+ },
+ {
+   name => 'assigning a stashref to a glob',
+   code => '$life_raft = \%Left::; *Left:: = \%Right::',
+ },
+) {
+ fresh_perl_is
+   q~
+     @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;
+    __code__;
+
+     print $thing->speak, "\n";
+
+     undef $life_raft;
+     print $thing->speak, "\n";
+   ~ =~ s\__code__\$$_{code}\r,
+  "Bow-wow!\nBow-wow!\n",
+   {},
+  "replacing packages by $$_{name} updates isa caches";
 }
 
 # 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';
+for(
+ {
+   name => 'assigning a glob to a glob',
+   code => '$life_raft = $::{"Left::"}; *Left:: = $::{"Right::"}',
+ },
+ {
+   name => 'assigning a string to a glob',
+   code => '$life_raft = $::{"Left::"}; *Left:: = "Right::"',
+ },
+ {
+   name => 'assigning a stashref to a glob',
+   code => '$life_raft = \%Left::; *Left:: = \%Right::',
+ },
+) {
+ fresh_perl_is
+   q~
+     @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;
+    __code__;
+
+     print $thing->speak, "\n";
+
+     undef $life_raft;
+     print $thing->speak, "\n";
+   ~ =~ s\__code__\$$_{code}\r,
+  "Bow-wow!\nBow-wow!\n",
+   {},
+  "replacing nested packages by $$_{name} updates isa caches";
 }
 
 # Test that deleting stash elements containing