diff options
| author | Father Chrysostomos <sprout@cpan.org> | 2010-10-12 10:13:58 -0700 |
|---|---|---|
| committer | Father Chrysostomos <sprout@cpan.org> | 2010-10-12 12:52:12 -0700 |
| commit | d056e33c1ea02abb0c031adb18b181624282ba3c (patch) | |
| tree | be509216d46bd9a97ddb6013ce278f4f104d5f68 | |
| parent | 11f9f0eda0026b9120e2ceb1b15c72667d1c91ac (diff) | |
| download | perl-d056e33c1ea02abb0c031adb18b181624282ba3c.tar.gz | |
Reset isa caches on nonexistent substashes when stash trees are moved
This fixes the problem of isa cache linearisations’ and method caches’
not being reset on nonexistent packages when they are replaced with
real packages as a result of parent stashes’ being moved. This can
happen in cases like this:
@left::ISA = 'outer::inner';
@right::ISA = 'clone::inner';
{package outer::inner}
*clone:: = \%outer::;
print "ok 1", "\n" if left->isa("clone::inner");
print "ok 2", "\n" if right->isa("outer::inner");
This changes mro_package_moved’s parameter list as documented in the
diff for mro.c. See also the new comments in that function.
| -rw-r--r-- | embed.fnc | 2 | ||||
| -rw-r--r-- | embed.h | 2 | ||||
| -rw-r--r-- | hv.c | 3 | ||||
| -rw-r--r-- | mro.c | 119 | ||||
| -rw-r--r-- | proto.h | 6 | ||||
| -rw-r--r-- | sv.c | 36 | ||||
| -rw-r--r-- | t/mro/package_aliases.t | 45 |
7 files changed, 184 insertions, 29 deletions
@@ -2365,7 +2365,7 @@ sd |AV* |mro_get_linear_isa_dfs|NN HV* stash|U32 level md |void |mro_isa_changed_in|NN HV* stash pd |void |mro_isa_changed_in3|NULLOK HV* stash|NULLOK const char *stashname|STRLEN stashname_len Apd |void |mro_method_changed_in |NN HV* stash -pdx |void |mro_package_moved |NN const HV *stash +pdx |void |mro_package_moved |NULLOK HV * const stash|NULLOK const HV * const oldstash|NULLOK const GV * const gv|NULLOK const char *newname|STRLEN newname_len : Only used in perl.c p |void |boot_core_mro Apon |void |sys_init |NN int* argc|NN char*** argv @@ -1050,7 +1050,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_in3(a,b,c) Perl_mro_isa_changed_in3(aTHX_ a,b,c) -#define mro_package_moved(a) Perl_mro_package_moved(aTHX_ a) +#define mro_package_moved(a,b,c,d,e) Perl_mro_package_moved(aTHX_ a,b,c,d,e) #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) @@ -1043,7 +1043,8 @@ S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN 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 (stash && HvNAME(stash)) + mro_package_moved(NULL, stash, NULL, NULL, 0); } } @@ -570,31 +570,108 @@ Perl_mro_isa_changed_in3(pTHX_ HV* stash, const char *stashname, /* =for apidoc mro_package_moved -Invalidates isa caches on this stash, on all subpackages nested inside it, -and on the subclasses of all those. +Call this function to signal to a stash that it has been assigned to +another spot in the stash hierarchy. C<stash> is the stash that has been +assigned. C<oldstash> is the stash it replaces, if any. C<gv> is the glob +that is actually being assigned to. C<newname> and C<newname_len> are the +full name of the GV. If these last two arguments are omitted, they can be +inferred from C<oldstash> or C<gv>. + +This can also be called with a null first argument and a null C<gv>, to +indicate that C<oldstash> has been deleted. + +This function invalidates isa caches on the old stash, on all subpackages +nested inside it, and on the subclasses of all those, including +non-existent packages that have corresponding entries in C<stash>. =cut */ void -Perl_mro_package_moved(pTHX_ const HV *stash) +Perl_mro_package_moved(pTHX_ HV * const stash, const HV * const oldstash, + const GV * const gv, const char *newname, + STRLEN newname_len) { register XPVHV* xhv; register HE *entry; I32 riter = -1; + HV *seen = NULL; - PERL_ARGS_ASSERT_MRO_PACKAGE_MOVED; + assert(stash || oldstash); + assert(oldstash || gv || newname); - mro_isa_changed_in((HV *)stash); + if(!newname && oldstash) { + newname = HvNAME_get(oldstash); + newname_len = HvNAMELEN_get(oldstash); + } + if(!newname && gv) { + SV * const namesv = sv_newmortal(); + gv_fullname4(namesv, gv, NULL, 0); + newname = SvPV_const(namesv, newname_len); + newname_len -= 2; /* skip trailing :: */ + } - if(!HvARRAY(stash)) return; + mro_isa_changed_in3((HV *)oldstash, newname, newname_len); + + if( + (!stash || !HvARRAY(stash)) && (!oldstash || !HvARRAY(oldstash)) + ) 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(oldstash && HvUSEDKEYS(oldstash)) { + xhv = (XPVHV*)SvANY(oldstash); + seen = newHV(); + + /* Iterate through entries in the oldstash, calling + mro_package_moved( + corresponding_entry_in_new_stash, current_entry, ... + ) + meanwhile doing the equivalent of $seen{$key} = 1. + */ + + while (++riter <= (I32)xhv->xhv_max) { + entry = (HvARRAY(oldstash))[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] == ':') { + HV * const oldsubstash = GvHV(HeVAL(entry)); + SV ** const stashentry + = stash ? hv_fetch(stash, key, len, 0) : NULL; + HV *substash; + if( + stashentry && *stashentry + && (substash = GvHV(*stashentry)) + && HvNAME(substash) + ) + mro_package_moved( + substash, oldsubstash, NULL, NULL, 0 + ); + else if(oldsubstash && HvNAME(oldsubstash)) + mro_isa_changed_in(oldsubstash); + + (void)hv_store(seen, key, len, &PL_sv_yes, 0); + } + } + } + } /* Skip the entire loop if the hash is empty. */ - if (HvUSEDKEYS(stash)) { + if (stash && HvUSEDKEYS(stash)) { + xhv = (XPVHV*)SvANY(stash); + + /* Iterate through the new stash, skipping $seen{$key} items, + calling mro_package_moved(entry, NULL, ...). */ while (++riter <= (I32)xhv->xhv_max) { entry = (HvARRAY(stash))[riter]; @@ -609,12 +686,34 @@ Perl_mro_package_moved(pTHX_ const HV *stash) 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); + HV *substash; + + /* If this entry was seen when we iterated through the + oldstash, skip it. */ + if(seen && hv_exists(seen, key, len)) continue; + + /* We get here only if this stash has no corresponding + entry in the stash being replaced. */ + + substash = GvHV(HeVAL(entry)); + if(substash && HvNAME(substash)) { + /* Add :: and the key (minus the trailing ::) + to newname. */ + SV *namesv + = newSVpvn_flags(newname, newname_len, SVs_TEMP); + sv_catpvs(namesv, "::"); + sv_catpvn(namesv, key, len-2); + mro_package_moved( + substash, NULL, NULL, + SvPV_nolen_const(namesv), newname_len+len + ); + } } } } } + + if(seen) SvREFCNT_dec((SV *)seen); } /* @@ -2258,11 +2258,7 @@ 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_package_moved(pTHX_ HV * const stash, const HV * const oldstash, const GV * const gv, const char *newname, STRLEN newname_len); PERL_CALLCONV void Perl_mro_register(pTHX_ const struct mro_alg *mro) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_MRO_REGISTER \ @@ -3656,9 +3656,13 @@ 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); + HV * const stash = GvHV(dstr); + if((stash && HvNAME(stash)) || (old_stash && HvNAME(old_stash))) + mro_package_moved( + stash && HvNAME(stash) ? stash : NULL, + old_stash && HvNAME(old_stash) ? old_stash : NULL, + (GV *)dstr, NULL, 0 + ); } else if(mro_changes) mro_method_changed_in(GvSTASH(dstr)); return; @@ -3769,9 +3773,15 @@ S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr) 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); + if ( + len > 1 && name[len-2] == ':' && name[len-1] == ':' + && (HvNAME(dref) || HvNAME(sref)) + ) { + mro_package_moved( + HvNAME(sref) ? (HV *)sref : NULL, + HvNAME(dref) ? (HV *)dref : NULL, + (GV *)dstr, NULL, 0 + ); } } else if (stype == SVt_PVAV && strEQ(GvNAME((GV*)dstr), "ISA")) { @@ -4034,10 +4044,16 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags) 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); + HV * const stash = GvHV(dstr); + if( + (stash && HvNAME(stash)) + || (old_stash && HvNAME(old_stash)) + ) + mro_package_moved( + stash && HvNAME(stash) ? stash : NULL, + old_stash && HvNAME(old_stash) ? old_stash : NULL, + (GV *)dstr, NULL, 0 + ); } } } diff --git a/t/mro/package_aliases.t b/t/mro/package_aliases.t index c06013d0f6..3f13a7650d 100644 --- a/t/mro/package_aliases.t +++ b/t/mro/package_aliases.t @@ -10,7 +10,7 @@ BEGIN { use strict; use warnings; -plan(tests => 12); +plan(tests => 15); { package New; @@ -127,6 +127,49 @@ for( "replacing nested packages by $$_{name} updates isa caches"; } +# Another nested package test, in which the isa cache needs to be reset on +# the subclass of a package that does not exist. +# +# Parenthesized packages do not exist. +# +# outer::inner ( clone::inner ) +# | | +# left right +# +# outer -> clone +# +# This test assigns outer:: to clone::, making clone::inner an alias to +# outer::inner. +for( + { + name => 'assigning a glob to a glob', + code => '*clone:: = *outer::', + }, + { + name => 'assigning a string to a glob', + code => '*clone:: = "outer::"', + }, + { + name => 'assigning a stashref to a glob', + code => '*clone:: = \%outer::', + }, +) { + fresh_perl_is + q~ + @left::ISA = 'outer::inner'; + @right::ISA = 'clone::inner'; + {package outer::inner} + + __code__; + + print "ok 1", "\n" if left->isa("clone::inner"); + print "ok 2", "\n" if right->isa("outer::inner"); + ~ =~ s\__code__\$$_{code}\r, + "ok 1\nok 2\n", + {}, + "replacing nonexistent nested packages by $$_{name} updates isa caches"; +} + # 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 |