In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/c8bbf675c3e9277e1dd4b1185d91c1aef2cd2594?hp=314655b3bf3a78f53857298857fbdc053e783117>
- Log ----------------------------------------------------------------- commit c8bbf675c3e9277e1dd4b1185d91c1aef2cd2594 Author: Father Chrysostomos <[email protected]> Date: Sat Oct 9 18:42:01 2010 -0700 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]. ----------------------------------------------------------------------- Summary of changes: embed.fnc | 1 + embed.h | 1 + hv.c | 38 ++++++++++++++++++++++- mro.c | 50 ++++++++++++++++++++++++++++++ pod/perldelta.pod | 7 ++++ proto.h | 5 +++ sv.c | 27 ++++++++++++++-- t/mro/package_aliases.t | 77 ++++++++++++++++++++++++++++++++++++++++++++++- 8 files changed, 201 insertions(+), 5 deletions(-) diff --git a/embed.fnc b/embed.fnc index 45b2419..fe70aa9 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 8732fd8..0e06f08 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 a04e4c5..dc873ab 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 488e564..bd59465 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 f91e474..9f49526 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 076cac6..aaa7c5c 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 4178dd3..679f0db 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 b8d0316..611ebf5 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'; +} -- Perl5 Master Repository
