diff options
author | Father Chrysostomos <sprout@cpan.org> | 2010-10-09 22:29:19 -0700 |
---|---|---|
committer | Father Chrysostomos <sprout@cpan.org> | 2010-10-09 23:07:09 -0700 |
commit | 3e79609f389ec31f364ad27e763e7e5f2ebc8d1e (patch) | |
tree | 4790cdc103e047ffaa8031b4a5b03bf7d482015e | |
parent | 3e6edce2ec5de0a7a3597d5f5a127bb974b33ca8 (diff) | |
download | perl-3e79609f389ec31f364ad27e763e7e5f2ebc8d1e.tar.gz |
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].
-rw-r--r-- | sv.c | 28 | ||||
-rw-r--r-- | t/mro/package_aliases.t | 118 |
2 files changed, 103 insertions, 43 deletions
@@ -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 6520511b61..db52cbd30e 100644 --- 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 |