Renaming of stashes should not be visible from Perl

Change 35759254 made stashes get renamed when moved around. This had
an unintended consequence: Typeglobs, ref() return values, stringifi-
cation of blessed references and __PACKAGE__ are all affected by this.

This commit makes a new distinction between stashes’ names and effect-
ive names. Stash names are now unaffected when the stashes move
around. Only the effective names are affected. (The apparent presence
of any puns in the previous sentence is purely incidental and most
likely the result of the reader’s inferential propensity.)

To this end a new HvENAME_get macro is introduced, returning the first effective name (what HvNAME_get was returning). (Only one effective
name needs to be in effect at a time.) hv_add_name and hv_delete_name
have been renamed hv_add_ename and hv_delete_ename. hv_name_set is
modified to leave the effective names in place unless the name is
being set to NULL.

These names are now stored in HvAUX as follows: When xhv_name_count is
0, xhv_name is a HEK pointer, containing the name which is also the
effective name. When xhv_name_count is not zero, then xhv_name is a
pointer to an array of HEK pointers. If xhv_name_count is positive,
the first HEK is the name *and* one of the effective names. When
xhv_name_count is negative, the first HEK is the name and subsequent
HEKs are the effective names.

diff --git a/embed.fnc b/embed.fnc
index 3a1eb52..f900005 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -2110,8 +2110,8 @@ ApoR      |HE**   |hv_eiter_p     |NN HV *hv
 Apo    |void   |hv_riter_set   |NN HV *hv|I32 riter
 Apo    |void   |hv_eiter_set   |NN HV *hv|NULLOK HE *eiter
 Ap     |void   |hv_name_set    |NN HV *hv|NULLOK const char *name|U32 len|U32 flags
-p      |void   |hv_name_add    |NN HV *hv|NN const char *name|U32 len
-p      |void   |hv_name_delete |NN HV *hv|NN const char *name|U32 len
+p      |void   |hv_ename_add   |NN HV *hv|NN const char *name|U32 len
+p      |void   |hv_ename_delete|NN HV *hv|NN const char *name|U32 len
 : Used in dump.c and hv.c
 poM    |AV**   |hv_backreferences_p    |NN HV *hv
 #if defined(PERL_IN_DUMP_C) || defined(PERL_IN_HV_C) || defined(PERL_IN_SV_C)

diff --git a/embed.h b/embed.h
index bf62c47..134c349 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -991,8 +991,8 @@
 #define get_no_modify()                Perl_get_no_modify(aTHX)
 #define get_opargs()           Perl_get_opargs(aTHX)
 #define gv_try_downgrade(a)    Perl_gv_try_downgrade(aTHX_ a)
-#define hv_name_add(a,b,c)     Perl_hv_name_add(aTHX_ a,b,c)
-#define hv_name_delete(a,b,c)  Perl_hv_name_delete(aTHX_ a,b,c)
+#define hv_ename_add(a,b,c)    Perl_hv_ename_add(aTHX_ a,b,c)
+#define hv_ename_delete(a,b,c) Perl_hv_ename_delete(aTHX_ a,b,c)
 #define init_argv_symbols(a,b) Perl_init_argv_symbols(aTHX_ a,b)
 #define init_debugger()                Perl_init_debugger(aTHX)
 #define intro_my()             Perl_intro_my(aTHX)

diff --git a/hv.c b/hv.c
index 543b6ea..72793e5 100644 (file)
--- a/hv.c
+++ b/hv.c
@@ -1021,13 +1021,13 @@ S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
           actually detached from the hash, as mro_package_moved checks
           whether the passed gv is still in the symbol table before
           doing anything. */
-       if (HeVAL(entry) && HvNAME(hv)) {
+       if (HeVAL(entry) && HvENAME_get(hv)) {
                if (keysv) key = SvPV(keysv, klen);
                if (klen > 1 && key[klen-2] == ':' && key[klen-1] == ':'
                 && (klen != 6 || hv!=PL_defstash || memNE(key,"main::",6))
                 && SvTYPE(HeVAL(entry)) == SVt_PVGV) {
                    HV * const stash = GvHV((GV *)HeVAL(entry));
-                   if (stash && HvNAME(stash))
+                   if (stash && HvENAME_get(stash))
                        mro_package_moved(
                         NULL, stash, (GV *)HeVAL(entry), NULL, 0
                        );
@@ -1627,7 +1627,7 @@ S_hfreeentries(pTHX_ HV *hv)
     /* This is the array that we're going to restore  */
     HE **const orig_array = HvARRAY(hv);
     HEK *name;
-    U32 name_count;
+    I32 name_count;
     int attempts = 100;
 
     PERL_ARGS_ASSERT_HFREEENTRIES;
@@ -1779,7 +1779,8 @@ S_hfreeentries(pTHX_ HV *hv)
            if (HvAUX(hv)->xhv_name) {
                if(HvAUX(hv)->xhv_name_count) {
                    HEK ** const name = (HEK **)HvAUX(hv)->xhv_name;
-                   HEK **hekp = name + HvAUX(hv)->xhv_name_count;
+                   I32 const count = HvAUX(hv)->xhv_name_count;
+                   HEK **hekp = name + (count < 0 ? -count : count);
                    while(hekp-- > name) 
                        unshare_hek_or_pvn(*hekp, 0, 0, 0);
                    Safefree(name);
@@ -2023,6 +2024,7 @@ Perl_hv_name_set(pTHX_ HV *hv, const char *name, U32 len, U32 flags)
     dVAR;
     struct xpvhv_aux *iter;
     U32 hash;
+    HEK **spot;
 
     PERL_ARGS_ASSERT_HV_NAME_SET;
     PERL_UNUSED_ARG(flags);
@@ -2034,76 +2036,103 @@ 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) {
                HEK ** const name = (HEK **)HvAUX(hv)->xhv_name;
-               HEK **hekp = name + HvAUX(hv)->xhv_name_count;
-               while(hekp-- > name) 
+               HEK **hekp = name + (
+                   iter->xhv_name_count < 0
+                    ? -iter->xhv_name_count
+                    :  iter->xhv_name_count
+                  );
+               while(hekp-- > name+1) 
                    unshare_hek_or_pvn(*hekp, 0, 0, 0);
+               /* The first elem may be null. */
+               if(*name) unshare_hek_or_pvn(*name, 0, 0, 0);
                Safefree(name);
+               spot = &iter->xhv_name;
+               iter->xhv_name_count = 0;
+             }
+             else {
+               spot = (HEK **)iter->xhv_name;
+               if(iter->xhv_name_count > 0) {
+                   /* shift some things over */
+                   Renew(spot, iter->xhv_name_count, HEK *);
+                   spot[iter->xhv_name_count++] = spot[1];
+                   spot[1] = spot[0];
+               }
+               else if(*spot) {
+                   unshare_hek_or_pvn(*spot, 0, 0, 0);
+               }
+             }
+           }
+           else {
+               unshare_hek_or_pvn(iter->xhv_name, 0, 0, 0);
+               spot = &iter->xhv_name;
            }
-           else unshare_hek_or_pvn(iter->xhv_name, 0, 0, 0);
        }
+       else spot = &iter->xhv_name;
     } else {
        if (name == 0)
            return;
 
        iter = hv_auxinit(hv);
+       spot = &iter->xhv_name;
     }
     PERL_HASH(hash, name, len);
-    iter->xhv_name = name ? share_hek(name, len, hash) : NULL;
+    *spot = name ? share_hek(name, len, hash) : NULL;
     iter->xhv_name_count = 0;
 }
 
 void
-Perl_hv_name_add(pTHX_ HV *hv, const char *name, U32 len)
+Perl_hv_ename_add(pTHX_ HV *hv, const char *name, U32 len)
 {
     dVAR;
     struct xpvhv_aux *aux = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
     U32 hash;
 
-    PERL_ARGS_ASSERT_HV_NAME_ADD;
+    PERL_ARGS_ASSERT_HV_ENAME_ADD;
 
     if (len > I32_MAX)
        Perl_croak(aTHX_ "panic: hv name too long (%"UVuf")", (UV) len);
 
     PERL_HASH(hash, name, len);
 
-    if (!aux->xhv_name) {
-       aux->xhv_name = share_hek(name, len, hash);
-       return;
-    }
-
     if (aux->xhv_name_count) {
        HEK ** const xhv_name = (HEK **)aux->xhv_name;
-       HEK **hekp = xhv_name + aux->xhv_name_count;
-       U32 count = aux->xhv_name_count;
+       I32 count = aux->xhv_name_count;
+       HEK **hekp = xhv_name + (count < 0 ? -count : count);
        while (hekp-- > xhv_name)
            if (
             HEK_LEN(*hekp) == (I32)len && memEQ(HEK_KEY(*hekp), name, len)
-           ) return;
-       aux->xhv_name_count++;
-       Renewc(aux->xhv_name, aux->xhv_name_count, HEK *, HEK);
+           ) {
+               if (hekp == xhv_name && count < 0)
+                   aux->xhv_name_count = -count;
+               return;
+           }
+       if (count < 0) aux->xhv_name_count--, count = -count;
+       else aux->xhv_name_count++;
+       Renewc(aux->xhv_name, count + 1, HEK *, HEK);
        ((HEK **)aux->xhv_name)[count] = share_hek(name, len, hash);
     }
     else {
        HEK *existing_name = aux->xhv_name;
        if (
-           HEK_LEN(existing_name) == (I32)len
+           existing_name && HEK_LEN(existing_name) == (I32)len
         && memEQ(HEK_KEY(existing_name), name, len)
        ) return;
        Newxc(aux->xhv_name, 2, HEK *, HEK);
-       aux->xhv_name_count = 2;
+       aux->xhv_name_count = existing_name ? 2 : -2;
        *(HEK **)aux->xhv_name = existing_name;
        ((HEK **)aux->xhv_name)[1] = share_hek(name, len, hash);
     }
 }
 
 void
-Perl_hv_name_delete(pTHX_ HV *hv, const char *name, U32 len)
+Perl_hv_ename_delete(pTHX_ HV *hv, const char *name, U32 len)
 {
     dVAR;
     struct xpvhv_aux *aux;
 
-    PERL_ARGS_ASSERT_HV_NAME_DELETE;
+    PERL_ARGS_ASSERT_HV_ENAME_DELETE;
 
     if (len > I32_MAX)
        Perl_croak(aTHX_ "panic: hv name too long (%"UVuf")", (UV) len);
@@ -2115,24 +2144,37 @@ Perl_hv_name_delete(pTHX_ HV *hv, const char *name, U32 len)
 
     if (aux->xhv_name_count) {
        HEK ** const namep = (HEK **)aux->xhv_name;
-       HEK **victim = namep + aux->xhv_name_count;
-       while (victim-- > namep)
+       I32 const count = aux->xhv_name_count;
+       HEK **victim = namep + (count < 0 ? -count : count);
+       while (victim-- > namep + 1)
            if (
                HEK_LEN(*victim) == (I32)len
             && memEQ(HEK_KEY(*victim), name, len)
            ) {
                unshare_hek_or_pvn(*victim, 0, 0, 0);
-               if (!--aux->xhv_name_count) { /* none left */
+               if (count < 0) ++aux->xhv_name_count;
+               else --aux->xhv_name_count;
+               if (
+                   (aux->xhv_name_count == 1 || aux->xhv_name_count == -1)
+                && !*namep
+               ) {  /* if there are none left */
                    Safefree(namep);
                    aux->xhv_name = NULL;
+                   aux->xhv_name_count = 0;
                }
                else {
                    /* Move the last one back to fill the empty slot. It
                       does not matter what order they are in. */
-                   *victim = *(namep + aux->xhv_name_count);
+                   *victim = *(namep + (count < 0 ? -count : count) - 1);
                }
                return;
            }
+       if (
+           count > 0 && HEK_LEN(*namep) == (I32)len
+        && memEQ(HEK_KEY(*namep),name,len)
+       ) {
+           aux->xhv_name_count = -count;
+       }
     }
     else if(
         HEK_LEN(aux->xhv_name) == (I32)len

diff --git a/hv.h b/hv.h
index 3e4040c..655be9a 100644 (file)
--- a/hv.h
+++ b/hv.h
@@ -79,9 +79,14 @@ struct xpvhv_aux {
     HE         *xhv_eiter;     /* current entry of iterator */
     I32                xhv_riter;      /* current root of iterator */
     struct mro_meta *xhv_mro_meta;
-    U32                xhv_name_count; /* When non-zero, xhv_name is actually */
-                               /* a pointer to an array of HEKs, this */
-};                             /* being the length. */
+/* Concerning xhv_name_count: When non-zero, xhv_name is actually a pointer 
+ * to an array of HEK pointers, this being the length. The first element is
+ * the name of the stash, which may be NULL. If xhv_name_count is positive,
+ * then *xhv_name is one of the effective names. If xhv_name_count is nega-
+ * tive, then xhv_name[1] is the first effective name.
+ */
+    I32                xhv_name_count;
+};
 
 /* hash structure: */
 /* This structure must match the beginning of struct xpvmg in sv.h. */
@@ -267,10 +272,27 @@ C<SV*>.
 /* This macro may go away without notice.  */
 #define HvNAME_HEK(hv) \
        (SvOOK(hv) && HvAUX(hv)->xhv_name ? HvNAME_HEK_NN(hv) : NULL)
-#define HvNAME_get(hv) ((SvOOK(hv) && (HvAUX(hv)->xhv_name)) \
+#define HvNAME_get(hv) \
+       ((SvOOK(hv) && (HvAUX(hv)->xhv_name) && HvNAME_HEK_NN(hv)) \
                         ? HEK_KEY(HvNAME_HEK_NN(hv)) : NULL)
-#define HvNAMELEN_get(hv)      ((SvOOK(hv) && (HvAUX(hv)->xhv_name)) \
+#define HvNAMELEN_get(hv) \
+       ((SvOOK(hv) && (HvAUX(hv)->xhv_name) && HvNAME_HEK_NN(hv)) \
                                 ? HEK_LEN(HvNAME_HEK_NN(hv)) : 0)
+#ifdef PERL_CORE
+# define HvENAME_HEK_NN(hv)                                             \
+ (                                                                      \
+  HvAUX(hv)->xhv_name_count > 0   ? *(HEK **)HvAUX(hv)->xhv_name      : \
+  HvAUX(hv)->xhv_name_count < -1  ? ((HEK **)HvAUX(hv)->xhv_name)[1] : \
+  HvAUX(hv)->xhv_name_count == -1 ? NULL                              : \
+                                    HvAUX(hv)->xhv_name                 \
+ )
+# define HvENAME_get(hv) \
+       ((SvOOK(hv) && (HvAUX(hv)->xhv_name) && HvENAME_HEK_NN(hv)) \
+                        ? HEK_KEY(HvENAME_HEK_NN(hv)) : NULL)
+# define HvENAMELEN_get(hv) \
+       ((SvOOK(hv) && (HvAUX(hv)->xhv_name) && HvENAME_HEK_NN(hv)) \
+                                ? HEK_LEN(HvENAME_HEK_NN(hv)) : 0)
+#endif
 
 /* the number of keys (including any placeholers) */
 #define XHvTOTALKEYS(xhv)      ((xhv)->xhv_keys)

diff --git a/mro.c b/mro.c
index dfb1489..a584686 100644 (file)
--- a/mro.c
+++ b/mro.c
@@ -786,9 +786,9 @@ Perl_mro_package_moved(pTHX_ HV * const stash, HV * const oldstash,
        if(PL_stashcache)
            (void)
             hv_delete(PL_stashcache, newname, newname_len, G_DISCARD);
-       hv_name_delete(oldstash, newname, newname_len);
+       hv_ename_delete(oldstash, newname, newname_len);
     }
-    if(stash) hv_name_add(stash, newname, newname_len);
+    if(stash) hv_ename_add(stash, newname, newname_len);
 }
 
 /*

diff --git a/proto.h b/proto.h
index 144abe0..0027180 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -1262,6 +1262,18 @@ PERL_CALLCONV void       Perl_hv_eiter_set(pTHX_ HV *hv, HE *eiter)
 #define PERL_ARGS_ASSERT_HV_EITER_SET  \
        assert(hv)
 
+PERL_CALLCONV void     Perl_hv_ename_add(pTHX_ HV *hv, const char *name, U32 len)
+                       __attribute__nonnull__(pTHX_1)
+                       __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_HV_ENAME_ADD  \
+       assert(hv); assert(name)
+
+PERL_CALLCONV void     Perl_hv_ename_delete(pTHX_ HV *hv, const char *name, U32 len)
+                       __attribute__nonnull__(pTHX_1)
+                       __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_HV_ENAME_DELETE       \
+       assert(hv); assert(name)
+
 /* PERL_CALLCONV bool  Perl_hv_exists(pTHX_ HV *hv, const char *key, I32 klen)
                        __attribute__warn_unused_result__
                        __attribute__nonnull__(pTHX_2); */
@@ -1349,18 +1361,6 @@ PERL_CALLCONV void       Perl_hv_ksplit(pTHX_ HV *hv, IV newmax)
 #define PERL_ARGS_ASSERT_HV_MAGIC      \
        assert(hv)
 
-PERL_CALLCONV void     Perl_hv_name_add(pTHX_ HV *hv, const char *name, U32 len)
-                       __attribute__nonnull__(pTHX_1)
-                       __attribute__nonnull__(pTHX_2);
-#define PERL_ARGS_ASSERT_HV_NAME_ADD   \
-       assert(hv); assert(name)
-
-PERL_CALLCONV void     Perl_hv_name_delete(pTHX_ HV *hv, const char *name, U32 len)
-                       __attribute__nonnull__(pTHX_1)
-                       __attribute__nonnull__(pTHX_2);
-#define PERL_ARGS_ASSERT_HV_NAME_DELETE        \
-       assert(hv); assert(name)
-
 PERL_CALLCONV void     Perl_hv_name_set(pTHX_ HV *hv, const char *name, U32 len, U32 flags)
                        __attribute__nonnull__(pTHX_1);
 #define PERL_ARGS_ASSERT_HV_NAME_SET   \

diff --git a/sv.c b/sv.c
index ccb18e7..4d98e68 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -3656,7 +3656,7 @@ S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype)
     if(mro_changes == 2) mro_isa_changed_in(GvSTASH(dstr));
     else if(mro_changes == 3) {
        HV * const stash = GvHV(dstr);
-       if(old_stash ? (HV *)HvNAME(old_stash) : stash)
+       if(old_stash ? (HV *)HvENAME_get(old_stash) : stash)
            mro_package_moved(
                stash, old_stash,
                (GV *)dstr, NULL, 0
@@ -3773,7 +3773,7 @@ S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr)
            const STRLEN len = GvNAMELEN(dstr);
            if (
                len > 1 && name[len-2] == ':' && name[len-1] == ':'
-            && (!dref || HvNAME(dref))
+            && (!dref || HvENAME_get(dref))
            ) {
                mro_package_moved(
                    (HV *)sref, (HV *)dref,
@@ -4043,7 +4043,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags)
                if (reset_isa) {
                    HV * const stash = GvHV(dstr);
                    if(
-                       old_stash ? (HV *)HvNAME(old_stash) : stash
+                       old_stash ? (HV *)HvENAME_get(old_stash) : stash
                    )
                        mro_package_moved(
                         stash, old_stash,
@@ -11744,7 +11744,10 @@ S_sv_dup_common(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
                        hvname = saux->xhv_name;
                        if (saux->xhv_name_count) {
                            HEK ** const sname = (HEK **)saux->xhv_name;
-                           const U32 count = saux->xhv_name_count;
+                           const I32 count
+                            = saux->xhv_name_count < 0
+                               ? -saux->xhv_name_count
+                               :  saux->xhv_name_count;
                            HEK **shekp = sname + count;
                            HEK **dhekp;
                            Newxc(daux->xhv_name, count, HEK *, HEK);

diff --git a/t/op/stash.t b/t/op/stash.t
index 2c17022..37b1fd9 100644 (file)
--- a/t/op/stash.t
+++ b/t/op/stash.t
@@ -7,7 +7,7 @@ BEGIN {
 
 BEGIN { require "./test.pl"; }
 
-plan( tests => 38 );
+plan( tests => 46 );
 
 # Used to segfault (bug #15479)
 fresh_perl_like(
@@ -209,3 +209,39 @@ SKIP: {
     __ANON__();
     is ($c, 'main::__ANON__', '__ANON__ sub called ok');
 }
+
+# Stashes that are effectively renamed
+{
+    package rile;
+
+    my $obj  = bless [];
+    my $globref = \*tat;
+
+    # effectively rename a stash
+    *slin:: = *rile::; *rile:: = *zor::;
+    
+    ::is *$globref, "*rile::tat",
+     'globs stringify the same way when stashes are moved';
+    ::is ref $obj, "rile",
+     'ref() returns the same thing when an object’s stash is moved';
+    ::like "$obj", qr "^rile=ARRAY\(0x[\da-f]+\)\z",
+     'objects stringify the same way when their stashes are moved';
+    ::is eval '__PACKAGE__', 'rile',
+     '__PACKAGE__ returns the same thing when the current stash is moved';
+
+    # Now detach it completely from the symtab, making it effect-
+    # ively anonymous
+    my $life_raft = \%slin::;
+    *slin:: = *zor::;
+
+    ::is *$globref, "*rile::tat",
+     'globs stringify the same way when stashes are detached';
+    ::is ref $obj, "rile",
+     'ref() returns the same thing when an object’s stash is detached';
+    ::like "$obj", qr "^rile=ARRAY\(0x[\da-f]+\)\z",
+     'objects stringify the same way when their stashes are detached';
+    ::is eval '__PACKAGE__', 'rile',
+     '__PACKAGE__ returns the same when the current stash is detached';
+}
+
+