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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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