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].

diff --git a/sv.c b/sv.c
index c651eb0..abb4f32 100644 (file)
--- 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
index 6520511..db52cbd 100644 (file)
--- 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