Add functions for adding and deleting stash names

4 files changed, 104 insertions, 0 deletions

diff --git a/embed.fnc b/embed.fnc
index 154301738e..ccea96b569 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -2110,6 +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
 : 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 2ef2c49ce7..e14a0afa87 100644
--- a/embed.h
+++ b/embed.h
@@ -987,6 +987,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 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 808a4bf9a3..15735a30a8 100644
--- a/hv.c
+++ b/hv.c
@@ -2048,6 +2048,94 @@ Perl_hv_name_set(pTHX_ HV *hv, const char *name, U32 len, U32 flags)
     iter->xhv_name_count = 0;
 }
 
+void
+Perl_hv_name_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;
+
+    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;
+	while (hekp-- > xhv_name)
+	    if (
+	     HEK_LEN(*hekp) == (I32)len && memEQ(HEK_KEY(*hekp), name, len)
+	    ) return;
+	Renewc(aux->xhv_name, ++aux->xhv_name_count, 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
+	 && memEQ(HEK_KEY(existing_name), name, len)
+	) return;
+	Newxc(aux->xhv_name, 2, HEK *, HEK);
+	*(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)
+{
+    dVAR;
+    struct xpvhv_aux *aux;
+
+    PERL_ARGS_ASSERT_HV_NAME_DELETE;
+
+    if (len > I32_MAX)
+	Perl_croak(aTHX_ "panic: hv name too long (%"UVuf")", (UV) len);
+
+    if (!SvOOK(hv)) return;
+
+    aux = HvAUX(hv);
+    if (!aux->xhv_name) return;
+
+    if (aux->xhv_name_count) {
+	HEK ** const namep = (HEK **)aux->xhv_name;
+	HEK **victim = namep + aux->xhv_name_count;
+	while (victim-- > namep)
+	    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 */
+		    Safefree(namep);
+		    aux->xhv_name = NULL;
+		}
+		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);
+		}
+		return;
+	    }
+    }
+    else if(
+        HEK_LEN(aux->xhv_name) == (I32)len
+     && memEQ(HEK_KEY(aux->xhv_name), name, len)
+    ) {
+	unshare_hek_or_pvn(aux->xhv_name, 0, 0, 0);
+	aux->xhv_name = NULL;
+    }
+}
+
 AV **
 Perl_hv_backreferences_p(pTHX_ HV *hv) {
     struct xpvhv_aux * const iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
diff --git a/proto.h b/proto.h
index cfa12427e1..ca62817ee2 100644
--- a/proto.h
+++ b/proto.h
@@ -1344,6 +1344,18 @@ 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	\