From: Nicholas Clark <nick@ccl4.org>
Date: Wed, 19 Nov 2003 19:51:41 +0000 (+0000)
Subject: merge hv_exists and hv_exists_ent into S_hv_exists_common
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=715961523dc15717482c3eba9a533ed292b5a722;p=p5sagit%2Fp5-mst-13.2.git

merge hv_exists and hv_exists_ent into S_hv_exists_common

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

diff --git a/embed.fnc b/embed.fnc
index eb8756a..60340e0 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -1395,5 +1395,8 @@ p	|int	|get_debug_opts	|char **s
 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	|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 5d0e52d..8b6c57f 100644
--- a/embed.h
+++ b/embed.h
@@ -2146,6 +2146,11 @@
 #endif
 #endif
 #define save_set_svflags	Perl_save_set_svflags
+#if defined(PERL_IN_HV_C) || defined(PERL_DECL_PROT)
+#ifdef PERL_CORE
+#define hv_exists_common	S_hv_exists_common
+#endif
+#endif
 #define ck_anoncode		Perl_ck_anoncode
 #define ck_bitop		Perl_ck_bitop
 #define ck_concat		Perl_ck_concat
@@ -4628,6 +4633,11 @@
 #endif
 #endif
 #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_exists_common(a,b,c,d,e)	S_hv_exists_common(aTHX_ a,b,c,d,e)
+#endif
+#endif
 #define ck_anoncode(a)		Perl_ck_anoncode(aTHX_ a)
 #define ck_bitop(a)		Perl_ck_bitop(aTHX_ a)
 #define ck_concat(a)		Perl_ck_concat(aTHX_ a)
diff --git a/hv.c b/hv.c
index 5520cd9..53a0b3c 100644
--- a/hv.c
+++ b/hv.c
@@ -1271,112 +1271,9 @@ C<klen> is the length of the key.
 bool
 Perl_hv_exists(pTHX_ HV *hv, const char *key, I32 klen)
 {
-    register XPVHV* xhv;
-    register U32 hash;
-    register HE *entry;
-    SV *sv;
-    bool is_utf8 = FALSE;
-    const char *keysave = key;
-    int k_flags = 0;
-
-    if (!hv)
-	return 0;
-
-    if (klen < 0) {
-      klen = -klen;
-      is_utf8 = TRUE;
-    }
-
-    if (SvRMAGICAL(hv)) {
-	if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
-	    sv = sv_newmortal();
-	    if (is_utf8) {
-		/* This hack based on the code in hv_exists_ent seems to be
-		   the easiest way to pass the utf8 flag through and fix
-		   the bug in hv_exists for tied hashes with utf8 keys.  */
-		SV *keysv = sv_2mortal(newSVpvn(key, klen));
-		SvUTF8_on(keysv);
-		key = (char *)keysv;
-		klen = HEf_SVKEY;
-	    }
-	    mg_copy((SV*)hv, sv, key, klen);
-	    magic_existspack(sv, mg_find(sv, PERL_MAGIC_tiedelem));
-	    return (bool)SvTRUE(sv);
-	}
-#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);
-#ifndef DYNAMIC_ENV_FETCH
-    if (!xhv->xhv_array /* !HvARRAY(hv) */)
-	return 0;
-#endif
-
-    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);
-    }
-
-#ifdef DYNAMIC_ENV_FETCH
-    if (!xhv->xhv_array /* !HvARRAY(hv) */) entry = Null(HE*);
-    else
-#endif
-    /* entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
-    entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
-    for (; entry; entry = HeNEXT(entry)) {
-	if (HeHASH(entry) != hash)		/* strings can't be equal */
-	    continue;
-	if (HeKLEN(entry) != 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 we find the key, but the value is a placeholder, return false. */
-	if (HeVAL(entry) == &PL_sv_placeholder)
-	    return FALSE;
-
-	return TRUE;
-    }
-#ifdef DYNAMIC_ENV_FETCH  /* is it out there? */
-    if (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
-	unsigned long len;
-	char *env = PerlEnv_ENVgetenv_len(key,&len);
-	if (env) {
-	    sv = newSVpvn(env,len);
-	    SvTAINTED_on(sv);
-	    (void)hv_store(hv,key,klen,sv,hash);
-            if (k_flags & HVhek_FREEKEY)
-                Safefree(key);
-	    return TRUE;
-	}
-    }
-#endif
-    if (k_flags & HVhek_FREEKEY)
-        Safefree(key);
-    return FALSE;
+    return hv_exists_common(hv, NULL, key, klen, 0);
 }
 
-
 /*
 =for apidoc hv_exists_ent
 
@@ -1390,32 +1287,67 @@ computed.
 bool
 Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash)
 {
+    return hv_exists_common(hv, keysv, NULL, 0, hash);
+}
+
+bool
+S_hv_exists_common(pTHX_ HV *hv, SV *keysv, const char *key, I32 klen_i32,
+		   U32 hash)
+{
     register XPVHV* xhv;
-    register char *key;
     STRLEN klen;
     register HE *entry;
     SV *sv;
     bool is_utf8;
-    char *keysave;
+    const char *keysave;
     int k_flags = 0;
 
     if (!hv)
 	return 0;
 
+    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)) {
 	if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
-	   SV* svret = sv_newmortal();
+	    SV* svret;
+
+	    if (keysv || is_utf8) {
+		if (!keysv) {
+		    keysv = newSVpvn(key, klen);
+		    SvUTF8_on(keysv);
+		} else {
+		    keysv = newSVsv(keysv);
+		}
+		key = (char *)sv_2mortal(keysv);
+		klen = HEf_SVKEY;
+	    }
+
+	    /* I don't understand why hv_exists_ent has svret and sv,
+	       whereas hv_exists only had one.  */
+	    svret = sv_newmortal();
 	    sv = sv_newmortal();
-	    keysv = sv_2mortal(newSVsv(keysv));
-	    mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY);
-	   magic_existspack(svret, mg_find(sv, PERL_MAGIC_tiedelem));
-	   return (bool)SvTRUE(svret);
+	    mg_copy((SV*)hv, sv, key, klen);
+	    magic_existspack(svret, mg_find(sv, PERL_MAGIC_tiedelem));
+	    return (bool)SvTRUE(svret);
 	}
 #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
@@ -1427,8 +1359,6 @@ Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash)
 	return 0;
 #endif
 
-    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)
@@ -1482,6 +1412,7 @@ Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash)
     return FALSE;
 }
 
+
 STATIC void
 S_hsplit(pTHX_ HV *hv)
 {
diff --git a/proto.h b/proto.h
index 5e30627..987774a 100644
--- a/proto.h
+++ b/proto.h
@@ -1335,5 +1335,8 @@ PERL_CALLCONV int	Perl_get_debug_opts(pTHX_ char **s);
 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 bool	S_hv_exists_common(pTHX_ HV* tb, SV* key_sv, const char* key, I32 klen, U32 hash);
+#endif
 END_EXTERN_C