In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/3e79609f389ec31f364ad27e763e7e5f2ebc8d1e?hp=f24b27537f1dd2f210904a67f653c6e3169d4bae>
- Log ----------------------------------------------------------------- commit 3e79609f389ec31f364ad27e763e7e5f2ebc8d1e Author: Father Chrysostomos <[email protected]> Date: Sat Oct 9 22:29:19 2010 -0700 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]. M sv.c M t/mro/package_aliases.t commit 3e6edce2ec5de0a7a3597d5f5a127bb974b33ca8 Author: Father Chrysostomos <[email protected]> Date: Sat Oct 9 22:18:30 2010 -0700 Avoid uninitialized warning in glob_assign_glob M sv.c commit 304474c3f9eec6df709a20e0dc0f6e58bffecd76 Author: Father Chrysostomos <[email protected]> Date: Sat Oct 9 22:18:08 2010 -0700 Remove code added by c8bbf675 that turns out to be unnecessary M hv.c commit 0507fe7a0e836cf5fec0311c908bef62c72f0087 Author: Father Chrysostomos <[email protected]> Date: Sat Oct 9 22:12:46 2010 -0700 Oops. Remove a duplicate require. M t/mro/package_aliases.t ----------------------------------------------------------------------- Summary of changes: hv.c | 25 ---------- sv.c | 30 +++++++++++- t/mro/package_aliases.t | 118 ++++++++++++++++++++++++++++++----------------- 3 files changed, 104 insertions(+), 69 deletions(-) diff --git a/hv.c b/hv.c index dc873ab..d2d594d 100644 --- a/hv.c +++ b/hv.c @@ -692,32 +692,7 @@ Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, } HeVAL(entry) = val; } else if (action & HV_FETCH_ISSTORE) { - 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 diff --git a/sv.c b/sv.c index 679f0db..abb4f32 100644 --- a/sv.c +++ b/sv.c @@ -3582,7 +3582,7 @@ static void S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype) { I32 mro_changes = 0; /* 1 = method, 2 = isa, 3 = recursive isa */ - HV *old_stash; + HV *old_stash = NULL; PERL_ARGS_ASSERT_GLOB_ASSIGN_GLOB; @@ -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 611ebf5..db52cbd 100644 --- a/t/mro/package_aliases.t +++ b/t/mro/package_aliases.t @@ -10,7 +10,7 @@ BEGIN { use strict; use warnings; -require q(./test.pl); 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 -- Perl5 Master Repository
