This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix package assignment with nested aliased packages
authorFather Chrysostomos <sprout@cpan.org>
Fri, 12 Nov 2010 04:29:31 +0000 (20:29 -0800)
committerFather Chrysostomos <sprout@cpan.org>
Fri, 12 Nov 2010 04:32:28 +0000 (20:32 -0800)
This commit fixes package assignments like *foo:: = *bar:: when both
foo and bar contain nested stashes that are aliases of each other.

mro_package_moved (actually, its auxiliary routine) need to keep a
list of stashes that have been seen as a separate list from those that
are going to have mro_isa_changed_in called on them. Otherwise, some
stashes will simply not be iterated through.

See the test that this adds and its comments. @ISA = @ISA should never
have any effect visible to Perl (with a capital), but it does in that
test case, prior to this commit.

This also fixes another bug that the test case triggered:
riter was not being reset before the second iteration in
mro_gather_and_rename.

Also, the stashes HV (aka the ‘big list’) now holds refcounts on its
elements, as that makes the code simpler as a result of the changes.

embed.fnc
embed.h
mro.c
proto.h
t/mro/package_aliases.t

index 6e3434b..8156a93 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -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
diff --git a/embed.h b/embed.h
index 0d70e87..64c352c 100644 (file)
--- a/embed.h
+++ b/embed.h
 #  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)
diff --git a/mro.c b/mro.c
index f65157a..7c40688 100644 (file)
--- a/mro.c
+++ b/mro.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
                        );
                    }
                }
diff --git a/proto.h b/proto.h
index 186c2a6..4002d67 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -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);
index b4ef202..f2c5c39 100644 (file)
@@ -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].