diff options
| -rw-r--r-- | embed.fnc | 1 | ||||
| -rw-r--r-- | embed.h | 2 | ||||
| -rw-r--r-- | mro.c | 88 | ||||
| -rw-r--r-- | proto.h | 7 | ||||
| -rw-r--r-- | t/mro/package_aliases.t | 30 |
5 files changed, 94 insertions, 34 deletions
@@ -2363,6 +2363,7 @@ s |void |mro_clean_isarev|NN HV * const isa \ |const STRLEN len \ |NULLOK HV * const exceptions s |void |mro_gather_and_rename|NN HV * const stashes \ + |NN HV * const seen_stashes \ |NULLOK HV *stash \ |NULLOK HV *oldstash \ |NN const char *name|I32 namlen @@ -1639,7 +1639,7 @@ # endif # if defined(PERL_IN_MRO_C) #define mro_clean_isarev(a,b,c,d) S_mro_clean_isarev(aTHX_ a,b,c,d) -#define mro_gather_and_rename(a,b,c,d,e) S_mro_gather_and_rename(aTHX_ a,b,c,d,e) +#define mro_gather_and_rename(a,b,c,d,e,f) S_mro_gather_and_rename(aTHX_ a,b,c,d,e,f) #define mro_get_linear_isa_dfs(a,b) S_mro_get_linear_isa_dfs(aTHX_ a,b) # endif # if defined(PERL_IN_NUMERIC_C) @@ -775,7 +775,10 @@ Perl_mro_package_moved(pTHX_ HV * const stash, HV * const oldstash, we do anything else. */ stashes = (HV *) sv_2mortal((SV *)newHV()); - mro_gather_and_rename(stashes, stash, oldstash, newname, newname_len); + mro_gather_and_rename( + stashes, (HV *) sv_2mortal((SV *)newHV()), + stash, oldstash, newname, newname_len + ); /* Iterate through the stashes, wiping isa linearisations, but leaving the isa hash (which mro_isa_changed_in needs for adjusting the @@ -802,17 +805,15 @@ Perl_mro_package_moved(pTHX_ HV * const stash, HV * const oldstash, mro_isa_changed_in on each. */ hv_iterinit(stashes); while((iter = hv_iternext(stashes))) { - if(HeVAL(iter) != &PL_sv_yes && HvENAME(HeVAL(iter))) + if(HvENAME(HeVAL(iter))) mro_isa_changed_in((HV *)HeVAL(iter)); - /* We are not holding a refcount, so eliminate the pointer before - * stashes is freed. */ - HeVAL(iter) = NULL; } } void -S_mro_gather_and_rename(pTHX_ HV * const stashes, HV *stash, HV *oldstash, - const char *name, I32 namlen) +S_mro_gather_and_rename(pTHX_ HV * const stashes, HV * const seen_stashes, + HV *stash, HV *oldstash, const char *name, + I32 namlen) { register XPVHV* xhv; register HE *entry; @@ -824,19 +825,42 @@ S_mro_gather_and_rename(pTHX_ HV * const stashes, HV *stash, HV *oldstash, PERL_ARGS_ASSERT_MRO_GATHER_AND_RENAME; + /* We use the seen_stashes hash to keep track of which packages have + been encountered so far. This must be separate from the main list of + stashes, as we need to distinguish between stashes being assigned + and stashes being replaced/deleted. (A nested stash can be on both + sides of an assignment. We cannot simply skip iterating through a + stash on the right if we have seen it on the left, as it will not + get its ename assigned to it.) + + To avoid allocating extra SVs, instead of a bitfield we can make + bizarre use of immortals: + + &PL_sv_undef: seen on the left (oldstash) + &PL_sv_no : seen on the right (stash) + &PL_sv_yes : seen on both sides + + */ + if(oldstash) { /* Add to the big list. */ HE * const entry = (HE *) hv_common( - stashes, NULL, (const char *)&oldstash, sizeof(HV *), 0, + seen_stashes, NULL, (const char *)&oldstash, sizeof(HV *), 0, HV_FETCH_LVALUE|HV_FETCH_EMPTY_HE, NULL, 0 ); - if(HeVAL(entry) == (SV *)oldstash) { + if(HeVAL(entry) == &PL_sv_undef || HeVAL(entry) == &PL_sv_yes) { oldstash = NULL; goto check_stash; } - HeVAL(entry) = (SV *)oldstash; + HeVAL(entry) + = HeVAL(entry) == &PL_sv_no ? &PL_sv_yes : &PL_sv_undef; + (void) + hv_store( + stashes, (const char *)&oldstash, sizeof(HV *), + SvREFCNT_inc_simple_NN((SV*)oldstash), 0 + ); /* Update the effective name. */ if(HvENAME_get(oldstash)) { @@ -865,11 +889,8 @@ S_mro_gather_and_rename(pTHX_ HV * const stashes, HV *stash, HV *oldstash, if(stash) { hv_ename_add(stash, name, namlen); - /* Add it to the big list. We use the stash itself as the value if - * it needs mro_isa_changed_in called on it. Otherwise we just use - * &PL_sv_yes to indicate that we have seen it. */ - - /* The stash needs mro_isa_changed_in called on it if it was + /* Add it to the big list if it needs + * mro_isa_changed_in called on it. That happens if it was * detached from the symbol table (so it had no HvENAME) before * being assigned to the spot named by the ‘name’ variable, because * its cached isa linerisation is now stale (the effective name @@ -885,12 +906,21 @@ S_mro_gather_and_rename(pTHX_ HV * const stashes, HV *stash, HV *oldstash, entry = (HE *) hv_common( - stashes, NULL, (const char *)&stash, sizeof(HV *), 0, + seen_stashes, NULL, (const char *)&stash, sizeof(HV *), 0, HV_FETCH_LVALUE|HV_FETCH_EMPTY_HE, NULL, 0 ); - if(HeVAL(entry) == &PL_sv_yes || HeVAL(entry) == (SV *)stash) + if(HeVAL(entry) == &PL_sv_yes || HeVAL(entry) == &PL_sv_no) stash = NULL; - else HeVAL(entry) = stash_had_name ? &PL_sv_yes : (SV *)stash; + else { + HeVAL(entry) + = HeVAL(entry) == &PL_sv_undef ? &PL_sv_yes : &PL_sv_no; + if(!stash_had_name) + (void) + hv_store( + stashes, (const char *)&stash, sizeof(HV *), + SvREFCNT_inc_simple_NN((SV *)stash), 0 + ); + } } if(!stash && !oldstash) @@ -913,14 +943,11 @@ S_mro_gather_and_rename(pTHX_ HV * const stashes, HV *stash, HV *oldstash, HV* revstash = gv_stashpvn(revkey, len, 0); if(!revstash) continue; - entry - = (HE *) - hv_common( - stashes, NULL, (const char *)&revstash, sizeof(HV *), 0, - HV_FETCH_LVALUE|HV_FETCH_EMPTY_HE, NULL, 0 - ); - HeVAL(entry) = (SV *)revstash; - + (void) + hv_store( + stashes, (const char *)&revstash, sizeof(HV *), + SvREFCNT_inc_simple_NN((SV *)revstash), 0 + ); } } @@ -981,7 +1008,8 @@ S_mro_gather_and_rename(pTHX_ HV * const stashes, HV *stash, HV *oldstash, sv_catpvn(namesv, key, len-2); name = SvPV_const(namesv, namlen); mro_gather_and_rename( - stashes, substash, oldsubstash, name, namlen + stashes, seen_stashes, + substash, oldsubstash, name, namlen ); } } @@ -995,9 +1023,10 @@ S_mro_gather_and_rename(pTHX_ HV * const stashes, HV *stash, HV *oldstash, /* Skip the entire loop if the hash is empty. */ if (stash && HvUSEDKEYS(stash)) { xhv = (XPVHV*)SvANY(stash); + riter = -1; /* Iterate through the new stash, skipping $seen{$key} items, - calling mro_gather_and_rename(stashes, entry, NULL, ...). */ + calling mro_gather_and_rename(stashes,seen,entry,NULL, ...). */ while (++riter <= (I32)xhv->xhv_max) { entry = (HvARRAY(stash))[riter]; @@ -1038,7 +1067,8 @@ S_mro_gather_and_rename(pTHX_ HV * const stashes, HV *stash, HV *oldstash, sv_catpvn(namesv, key, len-2); subname = SvPV_const(namesv, subnamlen); mro_gather_and_rename( - stashes, substash, NULL, subname, subnamlen + stashes, seen_stashes, + substash, NULL, subname, subnamlen ); } } @@ -5671,11 +5671,12 @@ STATIC void S_mro_clean_isarev(pTHX_ HV * const isa, const char * const name, co #define PERL_ARGS_ASSERT_MRO_CLEAN_ISAREV \ assert(isa); assert(name) -STATIC void S_mro_gather_and_rename(pTHX_ HV * const stashes, HV *stash, HV *oldstash, const char *name, I32 namlen) +STATIC void S_mro_gather_and_rename(pTHX_ HV * const stashes, HV * const seen_stashes, HV *stash, HV *oldstash, const char *name, I32 namlen) __attribute__nonnull__(pTHX_1) - __attribute__nonnull__(pTHX_4); + __attribute__nonnull__(pTHX_2) + __attribute__nonnull__(pTHX_5); #define PERL_ARGS_ASSERT_MRO_GATHER_AND_RENAME \ - assert(stashes); assert(name) + assert(stashes); assert(seen_stashes); assert(name) STATIC AV* S_mro_get_linear_isa_dfs(pTHX_ HV* stash, U32 level) __attribute__nonnull__(pTHX_1); diff --git a/t/mro/package_aliases.t b/t/mro/package_aliases.t index b4ef2027fe..f2c5c3944f 100644 --- a/t/mro/package_aliases.t +++ b/t/mro/package_aliases.t @@ -10,7 +10,7 @@ BEGIN { use strict; use warnings; -plan(tests => 19); +plan(tests => 20); { package New; @@ -236,6 +236,34 @@ fresh_perl_is { stderr => 1 }, "Assigning a nameless package over one w/subclasses updates isa caches"; +# mro_package_moved needs to make a distinction between replaced and +# assigned stashes when keeping track of what it has seen so far. +no warnings; { + no strict 'refs'; + + sub bar::blonk::blonk::phoo { "bbb" } + sub veclum::phoo { "lasrevinu" } + @feedlebomp::ISA = qw 'phoo::blonk::blonk veclum'; + *phoo::baz:: = *bar::blonk::; # now bar::blonk:: is on both sides + *phoo:: = *bar::; # here bar::blonk:: is both deleted and added + *bar:: = *boo::; # now it is only known as phoo::blonk:: + + # At this point, before the bug was fixed, %phoo::blonk::blonk:: ended + # up with no effective name, allowing it to be deleted without updating + # its subclasses’ caches. + + my $accum = ''; + + $accum .= 'feedlebomp'->phoo; # bbb + delete ${"phoo::blonk::"}{"blonk::"}; + $accum .= 'feedlebomp'->phoo; # bbb (Oops!) + @feedlebomp::ISA = @feedlebomp::ISA; + $accum .= 'feedlebomp'->phoo; # lasrevinu + + is $accum, 'bbblasrevinulasrevinu', + 'nested classes deleted & added simultaneously'; +} +use warnings; # mro_package_moved needs to check for self-referential packages. # This broke Text::Template [perl #78362]. |