Make hv_undef leave HvENAME alone

unless called from sv_clear.

This is necessary as and undeffed stash, though it nominally becomes
just a plain hash and is not a stash any more, is still to be found
in the symbol table. It may even be in multiple places. HvENAME’s
raison d’être is to keep track of this. If the effective name is
deleted, then things can get out of sync as the test in the commit
demonstrates. This can cause problems if the hash is turned back
into a stash.

This does not change the deletion of the HvNAME, which is the only
difference between hv_clear and hv_undef on stashes that is visible
from Perl. caller still returns (unknown) or __ANON__::....

I tried to make this into several small commits, but each part of it
breaks things without the other parts, so this is one big commit.

These are the various parts:

• hv_undef no longer calls mro_package_named directly, as it deletes
  the effective name of the stash. It must only be called on sub-
  stashes, so hfreeentries has been modified to do that.

• hv_name_set, which has erased the HvENAME when passed a null arg
  for the value ever since effective names were added (a special case
  put it just for hv_undef), now leaves the HvENAME alone, unless the
  new HV_NAME_SETALL flag (set to 2 to allow for UTF8 in future)
  is passed.

• hv_undef does not delete the name before the call to hfreeentries
  during global destruction. That extra name deletion was added when
  hfreeentries stopped hiding the name, as CVs won’t be anonymised
  properly if they see it. It does not matter where the CVs point if
  they are to be freed shortly. This is just a speed optimisation, as
  it allows the name and effective name to be deleted in one fell
  swoop. Deleting just the name (not the effective name) can require a
  memory allocation.

• hv_undef calls mro_isa_changed_in as it used to (before it started
  using mro_package_moved), but now it happens after the entries are
  freed. Calling it first, as 5.13.6 and earlier versions did, was
  simply wrong.

• Both names are deleted from PL_stashcache. I inadvertently switched
  it back and forth between the two names in previous commits. Since
  it needed to be accounted for, it made no omit it, as that would
  just complicate things. (I think PL_stashcache is buggy, though I
  have yet to come up with a test case.)

• sv_clear now calls Perl_hv_undef_flags with the HV_NAME_SETALL
  flag, which is passed through to the second hv_name_set call,
  after hfreeentries. That determines whether the effective names
  are deleted.

• The changes at the end of hv_undef consist of pussyfooting to avoid
  unnecessary work. They make sure that everything is freed that needs
  to be and nothing is freed that must not be.

diff --git a/hv.c b/hv.c
index 7f2eed7..1f411e7 100644 (file)
--- a/hv.c
+++ b/hv.c
@@ -1646,6 +1646,8 @@ S_hfreeentries(pTHX_ HV *hv)
     const bool has_aux = SvOOK(hv);
     struct xpvhv_aux * current_aux = NULL;
     int attempts = 100;
+    
+    const bool mpm = PL_phase != PERL_PHASE_DESTRUCT && HvENAME(hv);
 
     PERL_ARGS_ASSERT_HFREEENTRIES;
 
@@ -1760,6 +1762,19 @@ S_hfreeentries(pTHX_ HV *hv)
            while (entry) {
                register HE * const oentry = entry;
                entry = HeNEXT(entry);
+               if (
+                 mpm && HeVAL(oentry) && isGV(HeVAL(oentry)) &&
+                 GvHV(HeVAL(oentry)) && HvENAME(GvHV(HeVAL(oentry)))
+               ) {
+                   STRLEN klen;
+                   const char * const key = HePV(oentry,klen);
+                   if (klen > 1 && key[klen-1]==':' && key[klen-2]==':') {
+                       mro_package_moved(
+                        NULL, GvHV(HeVAL(oentry)),
+                        (GV *)HeVAL(oentry), NULL, 0
+                       );
+                   }
+               }
                hv_free_ent(hv, oentry);
            }
        } while (--i >= 0);
@@ -1826,15 +1841,15 @@ Perl_hv_undef_flags(pTHX_ HV *hv, U32 flags)
     DEBUG_A(Perl_hv_assert(aTHX_ hv));
     xhv = (XPVHV*)SvANY(hv);
 
-    if ((name = HvENAME_get(hv)) && PL_phase != PERL_PHASE_DESTRUCT)
-    {
-        /* Delete the @ISA element before calling mro_package_moved, so it
-           does not see it. */
-        (void)hv_delete(hv, "ISA", 3, G_DISCARD);
-        mro_package_moved(NULL, hv, NULL, name, HvENAMELEN_get(hv));
-    }
-
-    if (name || (name = HvNAME(hv))) {
+    /* The name must be deleted before the call to hfreeeeentries so that
+       CVs are anonymised properly. But the effective name must be pre-
+       served until after that call (and only deleted afterwards if the
+       call originated from sv_clear). For stashes with one name that is
+       both the canonical name and the effective name, hv_name_set has to
+       allocate an array for storing the effective name. We can skip that
+       during global destruction, as it does not matter where the CVs point
+       if they will be freed anyway. */
+    if (PL_phase != PERL_PHASE_DESTRUCT && (name = HvNAME(hv))) {
         if (PL_stashcache)
            (void)hv_delete(PL_stashcache, name, HvNAMELEN_get(hv), G_DISCARD);
        hv_name_set(hv, NULL, 0, 0);
@@ -1843,10 +1858,30 @@ Perl_hv_undef_flags(pTHX_ HV *hv, U32 flags)
     if (SvOOK(hv)) {
       struct xpvhv_aux * const aux = HvAUX(hv);
       struct mro_meta *meta;
-      if (aux->xhv_name) {
-        if (PL_stashcache && (name = HvNAME(hv)))
+      bool zeroed = FALSE;
+
+      if ((name = HvENAME_get(hv))) {
+       if (PL_phase != PERL_PHASE_DESTRUCT) {
+           /* This must come at this point in case
+              mro_isa_changed_in dies. */
+           Zero(HvARRAY(hv), xhv->xhv_max+1 /* HvMAX(hv)+1 */, HE*);
+           zeroed = TRUE;
+
+           mro_isa_changed_in(hv);
+       }
+        if (PL_stashcache)
+           (void)hv_delete(
+                   PL_stashcache, name, HvENAMELEN_get(hv), G_DISCARD
+                 );
+      }
+
+      /* If this call originated from sv_clear, then we must check for
+       * effective names that need freeing, as well as the usual name. */
+      name = HvNAME(hv);
+      if (flags & HV_NAME_SETALL ? (const char *)aux->xhv_name : name) {
+        if (name && PL_stashcache)
            (void)hv_delete(PL_stashcache, name, HvNAMELEN_get(hv), G_DISCARD);
-       hv_name_set(hv, NULL, 0, 0);
+       hv_name_set(hv, NULL, 0, flags);
       }
       if((meta = aux->xhv_mro_meta)) {
        if (meta->mro_linear_all) {
@@ -1865,11 +1900,16 @@ Perl_hv_undef_flags(pTHX_ HV *hv, U32 flags)
        Safefree(meta);
        aux->xhv_mro_meta = NULL;
       }
+      if (!aux->xhv_name)
+       SvFLAGS(hv) &= ~SVf_OOK;
+      else if (!zeroed)
+       Zero(HvARRAY(hv), xhv->xhv_max+1 /* HvMAX(hv)+1 */, HE*);
+    }
+    if (!SvOOK(hv)) {
+       Safefree(HvARRAY(hv));
+       xhv->xhv_max   = 7;     /* HvMAX(hv) = 7 (it's a normal hash) */
+       HvARRAY(hv) = 0;
     }
-    SvFLAGS(hv) &= ~SVf_OOK;
-    Safefree(HvARRAY(hv));
-    xhv->xhv_max   = 7;        /* HvMAX(hv) = 7 (it's a normal hash) */
-    HvARRAY(hv) = 0;
     HvPLACEHOLDERS_set(hv, 0);
 
     if (SvRMAGICAL(hv))
@@ -2065,7 +2105,7 @@ Perl_hv_name_set(pTHX_ HV *hv, const char *name, U32 len, U32 flags)
        iter = HvAUX(hv);
        if (iter->xhv_name) {
            if(iter->xhv_name_count) {
-             if(!name) {
+             if(flags & HV_NAME_SETALL) {
                HEK ** const name = (HEK **)HvAUX(hv)->xhv_name;
                HEK **hekp = name + (
                    iter->xhv_name_count < 0
@@ -2096,12 +2136,19 @@ Perl_hv_name_set(pTHX_ HV *hv, const char *name, U32 len, U32 flags)
                }
              }
            }
-           else {
+           else if (flags & HV_NAME_SETALL) {
                unshare_hek_or_pvn(iter->xhv_name, 0, 0, 0);
                spot = &iter->xhv_name;
            }
+           else {
+               HEK * const existing_name = iter->xhv_name;
+               Newxc(iter->xhv_name, 2, HEK *, HEK);
+               iter->xhv_name_count = -2;
+               spot = (HEK **)iter->xhv_name;
+               spot[1] = existing_name;
+           }
        }
-       else spot = &iter->xhv_name;
+       else { spot = &iter->xhv_name; iter->xhv_name_count = 0; }
     } else {
        if (name == 0)
            return;
@@ -2111,7 +2158,6 @@ Perl_hv_name_set(pTHX_ HV *hv, const char *name, U32 len, U32 flags)
     }
     PERL_HASH(hash, name, len);
     *spot = name ? share_hek(name, len, hash) : NULL;
-    iter->xhv_name_count = 0;
 }
 
 /*

diff --git a/hv.h b/hv.h
index 602cf56..faa4bdd 100644 (file)
--- a/hv.h
+++ b/hv.h
@@ -592,6 +592,9 @@ a string/length pair, and no precomputed hash.
 #define HV_DELETE              0x40
 #define HV_FETCH_EMPTY_HE      0x80 /* Leave HeVAL null. */
 
+/* Must not conflict with HVhek_UTF8 */
+#define HV_NAME_SETALL         0x02
+
 /*
 =for apidoc newHV
 

diff --git a/sv.c b/sv.c
index 3d5dc68..8e4d016 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -6048,7 +6048,7 @@ Perl_sv_clear(pTHX_ SV *const orig_sv)
                PL_last_swash_hv = NULL;
            }
            Perl_hv_kill_backrefs(aTHX_ MUTABLE_HV(sv));
-           hv_undef(MUTABLE_HV(sv));
+           Perl_hv_undef_flags(aTHX_ MUTABLE_HV(sv), HV_NAME_SETALL);
            break;
        case SVt_PVAV:
            {

diff --git a/t/mro/package_aliases.t b/t/mro/package_aliases.t
index 29c0a95..1622251 100644 (file)
--- a/t/mro/package_aliases.t
+++ b/t/mro/package_aliases.t
@@ -10,7 +10,7 @@ BEGIN {
 
 use strict;
 use warnings;
-plan(tests => 21);
+plan(tests => 23);
 
 {
     package New;
@@ -288,3 +288,22 @@ pass("mro_package_moved and self-referential packages");
     is $accum, 'aoeaa-<undef>',
      'Deleting globs whose loc in the symtab differs from gv_fullname'
 }
+
+# Pathological test for undeffing a stash that has an alias.
+*Ghelp:: = *Neen::;
+@Subclass::ISA = 'Ghelp';
+undef %Ghelp::;
+sub Frelp::womp { "clumpren" }
+eval '
+  $Neen::whatever++;
+  @Neen::ISA = "Frelp";
+';
+is eval { 'Subclass'->womp }, 'clumpren',
+ 'Changes to @ISA after undef via original name';
+undef %Ghelp::;
+eval '
+  $Ghelp::whatever++;
+  @Ghelp::ISA = "Frelp";
+';
+is eval { 'Subclass'->womp }, 'clumpren',
+ 'Changes to @ISA after undef via alias';