From: Nicholas Clark <nick@ccl4.org>
Date: Wed, 19 Nov 2003 20:37:27 +0000 (+0000)
Subject: integrate hv_delete and hv_delete_ent into hv_delete_common
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=f1317c8d183c687b884dabebf7d01723441851a4;p=p5sagit%2Fp5-mst-13.2.git

integrate hv_delete and hv_delete_ent into hv_delete_common

p4raw-id: //depot/perl@21750
---

diff --git a/embed.fnc b/embed.fnc
index 60340e0..0ca7dd4 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -1396,6 +1396,7 @@ Ap	|void	|save_set_svflags|SV* sv|U32 mask|U32 val
 Apod	|void	|hv_assert	|HV* tb
 
 #if defined(PERL_IN_HV_C) || defined(PERL_DECL_PROT)
+sM	|SV*	|hv_delete_common|HV* tb|SV* key_sv|const char* key|I32 klen|I32 flags|U32 hash
 sM	|bool	|hv_exists_common|HV* tb|SV* key_sv|const char* key|I32 klen|U32 hash
 #endif
 END_EXTERN_C
diff --git a/embed.h b/embed.h
index 8b6c57f..ce0cbd2 100644
--- a/embed.h
+++ b/embed.h
@@ -2148,6 +2148,9 @@
 #define save_set_svflags	Perl_save_set_svflags
 #if defined(PERL_IN_HV_C) || defined(PERL_DECL_PROT)
 #ifdef PERL_CORE
+#define hv_delete_common	S_hv_delete_common
+#endif
+#ifdef PERL_CORE
 #define hv_exists_common	S_hv_exists_common
 #endif
 #endif
@@ -4635,6 +4638,9 @@
 #define save_set_svflags(a,b,c)	Perl_save_set_svflags(aTHX_ a,b,c)
 #if defined(PERL_IN_HV_C) || defined(PERL_DECL_PROT)
 #ifdef PERL_CORE
+#define hv_delete_common(a,b,c,d,e,f)	S_hv_delete_common(aTHX_ a,b,c,d,e,f)
+#endif
+#ifdef PERL_CORE
 #define hv_exists_common(a,b,c,d,e)	S_hv_exists_common(aTHX_ a,b,c,d,e)
 #endif
 #endif
diff --git a/hv.c b/hv.c
index 29f25a3..42cae8c 100644
--- a/hv.c
+++ b/hv.c
@@ -948,154 +948,7 @@ will be returned.
 SV *
 Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen, I32 flags)
 {
-    register XPVHV* xhv;
-    register I32 i;
-    register U32 hash;
-    register HE *entry;
-    register HE **oentry;
-    SV **svp;
-    SV *sv;
-    bool is_utf8 = FALSE;
-    int k_flags = 0;
-    const char *keysave = key;
-
-    if (!hv)
-	return Nullsv;
-    if (klen < 0) {
-	klen = -klen;
-	is_utf8 = TRUE;
-    }
-    if (SvRMAGICAL(hv)) {
-	bool needs_copy;
-	bool needs_store;
-	hv_magic_check (hv, &needs_copy, &needs_store);
-
-	if (needs_copy
-	    && (svp = hv_fetch(hv, key, is_utf8 ? -klen : klen, TRUE))) {
-	    sv = *svp;
-	    if (SvMAGICAL(sv)) {
-	        mg_clear(sv);
-	    }
-	    if (!needs_store) {
-		if (mg_find(sv, PERL_MAGIC_tiedelem)) {
-		    /* No longer an element */
-		    sv_unmagic(sv, PERL_MAGIC_tiedelem);
-		    return sv;
-		}
-		return Nullsv;          /* element cannot be deleted */
-	    }
-#ifdef ENV_IS_CASELESS
-	    else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
-		sv = sv_2mortal(newSVpvn(key,klen));
-		key = strupr(SvPVX(sv));
-	    }
-#endif
-	}
-    }
-    xhv = (XPVHV*)SvANY(hv);
-    if (!xhv->xhv_array /* !HvARRAY(hv) */)
-	return Nullsv;
-
-    if (is_utf8) {
-	STRLEN tmplen = klen;
-	/* See the note in hv_fetch(). --jhi */
-	key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
-	klen = tmplen;
-        if (is_utf8)
-            k_flags = HVhek_UTF8;
-        if (key != keysave)
-            k_flags |= HVhek_FREEKEY;
-    }
-
-    if (HvREHASH(hv)) {
-	PERL_HASH_INTERNAL(hash, key, klen);
-    } else {
-	PERL_HASH(hash, key, klen);
-    }
-
-    /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
-    oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
-    entry = *oentry;
-    i = 1;
-    for (; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
-	if (HeHASH(entry) != hash)		/* strings can't be equal */
-	    continue;
-	if (HeKLEN(entry) != (I32)klen)
-	    continue;
-	if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen))	/* is this it? */
-	    continue;
-	if ((HeKFLAGS(entry) ^ k_flags) & HVhek_UTF8)
-	    continue;
-	if (k_flags & HVhek_FREEKEY)
-	    Safefree(key);
-	/* if placeholder is here, it's already been deleted.... */
-	if (HeVAL(entry) == &PL_sv_placeholder)
-	{
-	    if (SvREADONLY(hv))
-		return Nullsv;  /* if still SvREADONLY, leave it deleted. */
-	    else {
-		/* okay, really delete the placeholder... */
-		*oentry = HeNEXT(entry);
-		if (i && !*oentry)
-		    xhv->xhv_fill--; /* HvFILL(hv)-- */
-		if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
-		    HvLAZYDEL_on(hv);
-		else
-		    hv_free_ent(hv, entry);
-		xhv->xhv_keys--; /* HvKEYS(hv)-- */
-		if (xhv->xhv_keys == 0)
-		    HvHASKFLAGS_off(hv);
-		xhv->xhv_placeholders--;
-		return Nullsv;
-	    }
-	}
-	else if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
-	    S_hv_notallowed(aTHX_ k_flags, key, klen,
-			    "delete readonly key '%"SVf"' from"
-			    );
-	}
-
-	if (flags & G_DISCARD)
-	    sv = Nullsv;
-	else {
-	    sv = sv_2mortal(HeVAL(entry));
-	    HeVAL(entry) = &PL_sv_placeholder;
-	}
-
-	/*
-	 * If a restricted hash, rather than really deleting the entry, put
-	 * a placeholder there. This marks the key as being "approved", so
-	 * we can still access via not-really-existing key without raising
-	 * an error.
-	 */
-	if (SvREADONLY(hv)) {
-	    HeVAL(entry) = &PL_sv_placeholder;
-	    /* We'll be saving this slot, so the number of allocated keys
-	     * doesn't go down, but the number placeholders goes up */
-	    xhv->xhv_placeholders++; /* HvPLACEHOLDERS(hv)++ */
-	} else {
-	    *oentry = HeNEXT(entry);
-	    if (i && !*oentry)
-		xhv->xhv_fill--; /* HvFILL(hv)-- */
-	    if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
-		HvLAZYDEL_on(hv);
-	    else
-		hv_free_ent(hv, entry);
-	    xhv->xhv_keys--; /* HvKEYS(hv)-- */
-	    if (xhv->xhv_keys == 0)
-	        HvHASKFLAGS_off(hv);
-	}
-	return sv;
-    }
-    if (SvREADONLY(hv)) {
-	S_hv_notallowed(aTHX_ k_flags, key, klen,
-			"access disallowed key '%"SVf"' from"
-			);
-    }
-
-    if (k_flags & HVhek_FREEKEY)
-	Safefree(key);
-    return Nullsv;
+    return hv_delete_common(hv, NULL, key, klen, flags, 0);
 }
 
 /*
@@ -1112,42 +965,76 @@ precomputed hash value, or 0 to ask for it to be computed.
 SV *
 Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash)
 {
+    return hv_delete_common(hv, keysv, NULL, 0, flags, hash);
+}
+
+SV *
+S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, I32 klen_i32,
+		   I32 flags, U32 hash)
+{
     register XPVHV* xhv;
     register I32 i;
-    register char *key;
     STRLEN klen;
     register HE *entry;
     register HE **oentry;
     SV *sv;
     bool is_utf8;
     int k_flags = 0;
-    char *keysave;
+    const char *keysave;
 
     if (!hv)
 	return Nullsv;
+
+    if (keysv) {
+	key = SvPV(keysv, klen);
+	is_utf8 = (SvUTF8(keysv) != 0);
+    } else {
+	if (klen_i32 < 0) {
+	    klen = -klen_i32;
+	    is_utf8 = TRUE;
+	} else {
+	    klen = klen_i32;
+	    is_utf8 = FALSE;
+	}
+    }
+    keysave = key;
+
     if (SvRMAGICAL(hv)) {
 	bool needs_copy;
 	bool needs_store;
 	hv_magic_check (hv, &needs_copy, &needs_store);
 
-	if (needs_copy && (entry = hv_fetch_ent(hv, keysv, TRUE, hash))) {
-	    sv = HeVAL(entry);
-	    if (SvMAGICAL(sv)) {
-		mg_clear(sv);
+	if (needs_copy) {
+	    sv = NULL;
+	    if (keysv) {
+		if ((entry = hv_fetch_ent(hv, keysv, TRUE, hash))) {
+		    sv = HeVAL(entry);
+		}
+	    } else {
+		SV **svp;
+		if ((svp = hv_fetch(hv, key, is_utf8 ? -klen : klen, TRUE))) {
+		    sv = *svp;
+		}
 	    }
-	    if (!needs_store) {
-		if (mg_find(sv, PERL_MAGIC_tiedelem)) {
-		    /* No longer an element */
-		    sv_unmagic(sv, PERL_MAGIC_tiedelem);
-		    return sv;
-		}		
-		return Nullsv;		/* element cannot be deleted */
+	    if (sv) {
+		if (SvMAGICAL(sv)) {
+		    mg_clear(sv);
+		}
+		if (!needs_store) {
+		    if (mg_find(sv, PERL_MAGIC_tiedelem)) {
+			/* No longer an element */
+			sv_unmagic(sv, PERL_MAGIC_tiedelem);
+			return sv;
+		    }		
+		    return Nullsv;		/* element cannot be deleted */
+		}
 	    }
 #ifdef ENV_IS_CASELESS
 	    else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
-		key = SvPV(keysv, klen);
+		/* XXX This code isn't UTF8 clean.  */
 		keysv = sv_2mortal(newSVpvn(key,klen));
-		(void)strupr(SvPVX(keysv));
+		keysave = key = strupr(SvPVX(keysv));
+		is_utf8 = 0;
 		hash = 0;
 	    }
 #endif
@@ -1157,9 +1044,6 @@ Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash)
     if (!xhv->xhv_array /* !HvARRAY(hv) */)
 	return Nullsv;
 
-    keysave = key = SvPV(keysv, klen);
-    is_utf8 = (SvUTF8(keysv) != 0);
-
     if (is_utf8) {
 	key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
         if (is_utf8)
diff --git a/proto.h b/proto.h
index 987774a..394ba1b 100644
--- a/proto.h
+++ b/proto.h
@@ -1336,6 +1336,7 @@ PERL_CALLCONV void	Perl_save_set_svflags(pTHX_ SV* sv, U32 mask, U32 val);
 PERL_CALLCONV void	Perl_hv_assert(pTHX_ HV* tb);
 
 #if defined(PERL_IN_HV_C) || defined(PERL_DECL_PROT)
+STATIC SV*	S_hv_delete_common(pTHX_ HV* tb, SV* key_sv, const char* key, I32 klen, I32 flags, U32 hash);
 STATIC bool	S_hv_exists_common(pTHX_ HV* tb, SV* key_sv, const char* key, I32 klen, U32 hash);
 #endif
 END_EXTERN_C