Revert change 23843.

[perl5.git] / hv.c

diff --git a/hv.c b/hv.c
index d1f7682..bb8cef6 100644 (file)
--- a/hv.c
+++ b/hv.c
@@ -1,6 +1,7 @@
 /*    hv.c
  *
 /*    hv.c
  *

- *    Copyright (c) 1991-2003, Larry Wall
+ *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
+ *    2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others

  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.


@@ -13,12 +14,25 @@
 
 /* 
 =head1 Hash Manipulation Functions
 
 /* 
 =head1 Hash Manipulation Functions

+
+A HV structure represents a Perl hash. It consists mainly of an array
+of pointers, each of which points to a linked list of HE structures. The
+array is indexed by the hash function of the key, so each linked list
+represents all the hash entries with the same hash value. Each HE contains
+a pointer to the actual value, plus a pointer to a HEK structure which
+holds the key and hash value.
+
+=cut
+

 */
 
 #include "EXTERN.h"
 #define PERL_IN_HV_C
 */
 
 #include "EXTERN.h"
 #define PERL_IN_HV_C

+#define PERL_HASH_INTERNAL_ACCESS

 #include "perl.h"
 
 #include "perl.h"
 

+#define HV_MAX_LENGTH_BEFORE_SPLIT 14
+

 STATIC HE*
 S_new_he(pTHX)
 {
 STATIC HE*
 S_new_he(pTHX)
 {


@@ -76,6 +90,7 @@ S_more_he(pTHX)
 STATIC HEK *
 S_save_hek_flags(pTHX_ const char *str, I32 len, U32 hash, int flags)
 {
 STATIC HEK *
 S_save_hek_flags(pTHX_ const char *str, I32 len, U32 hash, int flags)
 {

+    int flags_masked = flags & HVhek_MASK;

     char *k;
     register HEK *hek;
 
     char *k;
     register HEK *hek;
 


@@ -85,10 +100,30 @@ S_save_hek_flags(pTHX_ const char *str, I32 len, U32 hash, int flags)
     HEK_KEY(hek)[len] = 0;
     HEK_LEN(hek) = len;
     HEK_HASH(hek) = hash;
     HEK_KEY(hek)[len] = 0;
     HEK_LEN(hek) = len;
     HEK_HASH(hek) = hash;

-    HEK_FLAGS(hek) = (unsigned char)flags;
+    HEK_FLAGS(hek) = (unsigned char)flags_masked;
+
+    if (flags & HVhek_FREEKEY)
+       Safefree(str);

     return hek;
 }
 
     return hek;
 }
 

+/* free the pool of temporary HE/HEK pairs retunrned by hv_fetch_ent
+ * for tied hashes */
+
+void
+Perl_free_tied_hv_pool(pTHX)
+{
+    HE *ohe;
+    HE *he = PL_hv_fetch_ent_mh;
+    while (he) {
+       Safefree(HeKEY_hek(he));
+       ohe = he;
+       he = HeNEXT(he);
+       del_HE(ohe);
+    }
+    PL_hv_fetch_ent_mh = Nullhe;
+}
+

 #if defined(USE_ITHREADS)
 HE *
 Perl_he_dup(pTHX_ HE *e, bool shared, CLONE_PARAMS* param)
 #if defined(USE_ITHREADS)
 HE *
 Perl_he_dup(pTHX_ HE *e, bool shared, CLONE_PARAMS* param)


@@ -107,8 +142,12 @@ Perl_he_dup(pTHX_ HE *e, bool shared, CLONE_PARAMS* param)
     ptr_table_store(PL_ptr_table, e, ret);
 
     HeNEXT(ret) = he_dup(HeNEXT(e),shared, param);
     ptr_table_store(PL_ptr_table, e, ret);
 
     HeNEXT(ret) = he_dup(HeNEXT(e),shared, param);

-    if (HeKLEN(e) == HEf_SVKEY)
+    if (HeKLEN(e) == HEf_SVKEY) {
+       char *k;
+       New(54, k, HEK_BASESIZE + sizeof(SV*), char);
+       HeKEY_hek(ret) = (HEK*)k;

        HeKEY_sv(ret) = SvREFCNT_inc(sv_dup(HeKEY_sv(e), param));
        HeKEY_sv(ret) = SvREFCNT_inc(sv_dup(HeKEY_sv(e), param));

+    }

     else if (shared)
        HeKEY_hek(ret) = share_hek_flags(HeKEY(e), HeKLEN(e), HeHASH(e),
                                          HeKFLAGS(e));
     else if (shared)
        HeKEY_hek(ret) = share_hek_flags(HeKEY(e), HeKLEN(e), HeHASH(e),
                                          HeKFLAGS(e));


@@ -130,7 +169,7 @@ S_hv_notallowed(pTHX_ int flags, const char *key, I32 klen,
     }
     else {
        /* Need to free saved eventually assign to mortal SV */
     }
     else {
        /* Need to free saved eventually assign to mortal SV */

-       SV *sv = sv_newmortal();
+       /* XXX is this line an error ???:  SV *sv = sv_newmortal(); */

        sv_usepvn(sv, (char *) key, klen);
     }
     if (flags & HVhek_UTF8) {
        sv_usepvn(sv, (char *) key, klen);
     }
     if (flags & HVhek_UTF8) {


@@ -143,13 +182,30 @@ S_hv_notallowed(pTHX_ int flags, const char *key, I32 klen,
 /* (klen == HEf_SVKEY) is special for MAGICAL hv entries, meaning key slot
  * contains an SV* */
 
 /* (klen == HEf_SVKEY) is special for MAGICAL hv entries, meaning key slot
  * contains an SV* */
 

+#define HV_FETCH_ISSTORE   0x01
+#define HV_FETCH_ISEXISTS  0x02
+#define HV_FETCH_LVALUE    0x04
+#define HV_FETCH_JUST_SV   0x08
+

 /*
 /*

-=for apidoc hv_fetch
+=for apidoc hv_store

 
 

-Returns the SV which corresponds to the specified key in the hash.  The
-C<klen> is the length of the key.  If C<lval> is set then the fetch will be
-part of a store.  Check that the return value is non-null before
-dereferencing it to an C<SV*>.
+Stores an SV in a hash.  The hash key is specified as C<key> and C<klen> is
+the length of the key.  The C<hash> parameter is the precomputed hash
+value; if it is zero then Perl will compute it.  The return value will be
+NULL if the operation failed or if the value did not need to be actually
+stored within the hash (as in the case of tied hashes).  Otherwise it can
+be dereferenced to get the original C<SV*>.  Note that the caller is
+responsible for suitably incrementing the reference count of C<val> before
+the call, and decrementing it if the function returned NULL.  Effectively
+a successful hv_store takes ownership of one reference to C<val>.  This is
+usually what you want; a newly created SV has a reference count of one, so
+if all your code does is create SVs then store them in a hash, hv_store
+will own the only reference to the new SV, and your code doesn't need to do
+anything further to tidy up.  hv_store is not implemented as a call to
+hv_store_ent, and does not create a temporary SV for the key, so if your
+key data is not already in SV form then use hv_store in preference to
+hv_store_ent.

 
 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
 information on how to use this function on tied hashes.
 
 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
 information on how to use this function on tied hashes.


@@ -157,166 +213,144 @@ information on how to use this function on tied hashes.
 =cut
 */
 
 =cut
 */
 

-

 SV**
 SV**

-Perl_hv_fetch(pTHX_ HV *hv, const char *key, I32 klen, I32 lval)
+Perl_hv_store(pTHX_ HV *hv, const char *key, I32 klen_i32, SV *val, U32 hash)

 {
 {

-    bool is_utf8 = FALSE;
-    const char *keysave = key;
-    int flags = 0;
-
-    if (klen < 0) {
-      klen = -klen;
-      is_utf8 = TRUE;
-    }
+    HE *hek;
+    STRLEN klen;
+    int flags;

 
 

-    if (is_utf8) {
-       STRLEN tmplen = klen;
-       /* Just casting the &klen to (STRLEN) won't work well
-        * if STRLEN and I32 are of different widths. --jhi */
-       key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
-       klen = tmplen;
-        /* If we were able to downgrade here, then than means that we were
-           passed in a key which only had chars 0-255, but was utf8 encoded.  */
-        if (is_utf8)
-            flags = HVhek_UTF8;
-        /* If we found we were able to downgrade the string to bytes, then
-           we should flag that it needs upgrading on keys or each.  */
-        if (key != keysave)
-            flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
+    if (klen_i32 < 0) {
+       klen = -klen_i32;
+       flags = HVhek_UTF8;
+    } else {
+       klen = klen_i32;
+       flags = 0;

     }
     }

+    hek = hv_fetch_common (hv, NULL, key, klen, flags,
+                          (HV_FETCH_ISSTORE|HV_FETCH_JUST_SV), val, hash);
+    return hek ? &HeVAL(hek) : NULL;
+}

 
 

-    return hv_fetch_flags (hv, key, klen, lval, flags);
+SV**
+Perl_hv_store_flags(pTHX_ HV *hv, const char *key, I32 klen, SV *val,
+                 register U32 hash, int flags)
+{
+    HE *hek = hv_fetch_common (hv, NULL, key, klen, flags,
+                              (HV_FETCH_ISSTORE|HV_FETCH_JUST_SV), val, hash);
+    return hek ? &HeVAL(hek) : NULL;

 }
 
 }
 

-STATIC SV**
-S_hv_fetch_flags(pTHX_ HV *hv, const char *key, I32 klen, I32 lval, int flags)
+/*
+=for apidoc hv_store_ent
+
+Stores C<val> in a hash.  The hash key is specified as C<key>.  The C<hash>
+parameter is the precomputed hash value; if it is zero then Perl will
+compute it.  The return value is the new hash entry so created.  It will be
+NULL if the operation failed or if the value did not need to be actually
+stored within the hash (as in the case of tied hashes).  Otherwise the
+contents of the return value can be accessed using the C<He?> macros
+described here.  Note that the caller is responsible for suitably
+incrementing the reference count of C<val> before the call, and
+decrementing it if the function returned NULL.  Effectively a successful
+hv_store_ent takes ownership of one reference to C<val>.  This is
+usually what you want; a newly created SV has a reference count of one, so
+if all your code does is create SVs then store them in a hash, hv_store
+will own the only reference to the new SV, and your code doesn't need to do
+anything further to tidy up.  Note that hv_store_ent only reads the C<key>;
+unlike C<val> it does not take ownership of it, so maintaining the correct
+reference count on C<key> is entirely the caller's responsibility.  hv_store
+is not implemented as a call to hv_store_ent, and does not create a temporary
+SV for the key, so if your key data is not already in SV form then use
+hv_store in preference to hv_store_ent.
+
+See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
+information on how to use this function on tied hashes.
+
+=cut
+*/
+
+HE *
+Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, U32 hash)

 {
 {

-    register XPVHV* xhv;
-    register U32 hash;
-    register HE *entry;
-    SV *sv;
+  return hv_fetch_common(hv, keysv, NULL, 0, 0, HV_FETCH_ISSTORE, val, hash);
+}

 
 

-    if (!hv)
-       return 0;
+/*
+=for apidoc hv_exists

 
 

-    if (SvRMAGICAL(hv)) {
-        /* All this clause seems to be utf8 unaware.
-           By moving the utf8 stuff out to hv_fetch_flags I need to ensure
-           key doesn't leak. I've not tried solving the utf8-ness.
-           NWC.
-        */
-       if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
-           sv = sv_newmortal();
-           mg_copy((SV*)hv, sv, key, klen);
-            if (flags & HVhek_FREEKEY)
-                Safefree(key);
-           PL_hv_fetch_sv = sv;
-           return &PL_hv_fetch_sv;
-       }
-#ifdef ENV_IS_CASELESS
-       else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
-           I32 i;
-           for (i = 0; i < klen; ++i)
-               if (isLOWER(key[i])) {
-                   char *nkey = strupr(SvPVX(sv_2mortal(newSVpvn(key,klen))));
-                   SV **ret = hv_fetch(hv, nkey, klen, 0);
-                   if (!ret && lval) {
-                       ret = hv_store_flags(hv, key, klen, NEWSV(61,0), 0,
-                                             flags);
-                    } else if (flags & HVhek_FREEKEY)
-                        Safefree(key);
-                   return ret;
-               }
-       }
-#endif
-    }
+Returns a boolean indicating whether the specified hash key exists.  The
+C<klen> is the length of the key.

 
 

-    /* We use xhv->xhv_foo fields directly instead of HvFOO(hv) to
-       avoid unnecessary pointer dereferencing. */
-    xhv = (XPVHV*)SvANY(hv);
-    if (!xhv->xhv_array /* !HvARRAY(hv) */) {
-       if (lval
-#ifdef DYNAMIC_ENV_FETCH  /* if it's an %ENV lookup, we may get it on the fly */
-                || (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
-#endif
-                                                                 )
-           Newz(503, xhv->xhv_array /* HvARRAY(hv) */,
-                PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
-                char);
-       else {
-            if (flags & HVhek_FREEKEY)
-                Safefree(key);
-           return 0;
-        }
+=cut
+*/
+
+bool
+Perl_hv_exists(pTHX_ HV *hv, const char *key, I32 klen_i32)
+{
+    STRLEN klen;
+    int flags;
+
+    if (klen_i32 < 0) {
+       klen = -klen_i32;
+       flags = HVhek_UTF8;
+    } else {
+       klen = klen_i32;
+       flags = 0;

     }
     }

+    return hv_fetch_common(hv, NULL, key, klen, flags, HV_FETCH_ISEXISTS, 0, 0)
+       ? TRUE : FALSE;
+}

 
 

-    PERL_HASH(hash, key, klen);
+/*
+=for apidoc hv_fetch

 
 

-    /* 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) != (I32)klen)
-           continue;
-       if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen))        /* is this it? */
-           continue;
-        /* flags is 0 if not utf8. need HeKFLAGS(entry) also 0.
-           flags is 1 if utf8. need HeKFLAGS(entry) also 1.
-           xor is true if bits differ, in which case this isn't a match.  */
-       if ((HeKFLAGS(entry) ^ flags) & HVhek_UTF8)
-           continue;
-        if (lval && HeKFLAGS(entry) != flags) {
-            /* We match if HVhek_UTF8 bit in our flags and hash key's match.
-               But if entry was set previously with HVhek_WASUTF8 and key now
-               doesn't (or vice versa) then we should change the key's flag,
-               as this is assignment.  */
-            if (HvSHAREKEYS(hv)) {
-                /* Need to swap the key we have for a key with the flags we
-                   need. As keys are shared we can't just write to the flag,
-                   so we share the new one, unshare the old one.  */
-                int flags_nofree = flags & ~HVhek_FREEKEY;
-                HEK *new_hek = share_hek_flags(key, klen, hash, flags_nofree);
-                unshare_hek (HeKEY_hek(entry));
-                HeKEY_hek(entry) = new_hek;
-            }
-            else
-                HeKFLAGS(entry) = flags;
-        }
-        if (flags & HVhek_FREEKEY)
-            Safefree(key);
-       /* if we find a placeholder, we pretend we haven't found anything */
-       if (HeVAL(entry) == &PL_sv_undef)
-           break;
-       return &HeVAL(entry);
+Returns the SV which corresponds to the specified key in the hash.  The
+C<klen> is the length of the key.  If C<lval> is set then the fetch will be
+part of a store.  Check that the return value is non-null before
+dereferencing it to an C<SV*>.

 
 

+See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
+information on how to use this function on tied hashes.
+
+=cut
+*/
+
+SV**
+Perl_hv_fetch(pTHX_ HV *hv, const char *key, I32 klen_i32, I32 lval)
+{
+    HE *hek;
+    STRLEN klen;
+    int flags;
+
+    if (klen_i32 < 0) {
+       klen = -klen_i32;
+       flags = HVhek_UTF8;
+    } else {
+       klen = klen_i32;
+       flags = 0;

     }
     }

-#ifdef DYNAMIC_ENV_FETCH  /* %ENV lookup?  If so, try to fetch the value now */
-    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);
-           if (flags & HVhek_FREEKEY)
-               Safefree(key);
-           return hv_store(hv,key,klen,sv,hash);
-       }
-    }
-#endif
-    if (!entry && SvREADONLY(hv)) {
-       S_hv_notallowed(aTHX_ flags, key, klen,
-                       "access disallowed key '%"SVf"' in"
-                       );
-    }
-    if (lval) {                /* gonna assign to this, so it better be there */
-       sv = NEWSV(61,0);
-        return hv_store_flags(hv,key,klen,sv,hash,flags);
-    }
-    if (flags & HVhek_FREEKEY)
-        Safefree(key);
-    return 0;
+    hek = hv_fetch_common (hv, NULL, key, klen, flags,
+                          HV_FETCH_JUST_SV | (lval ? HV_FETCH_LVALUE : 0),
+                          Nullsv, 0);
+    return hek ? &HeVAL(hek) : NULL;
+}
+
+/*
+=for apidoc hv_exists_ent
+
+Returns a boolean indicating whether the specified hash key exists. C<hash>
+can be a valid precomputed hash value, or 0 to ask for it to be
+computed.
+
+=cut
+*/
+
+bool
+Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash)
+{
+    return hv_fetch_common(hv, keysv, NULL, 0, 0, HV_FETCH_ISEXISTS, 0, hash)
+       ? TRUE : FALSE;

 }
 
 /* returns an HE * structure with the all fields set */
 }
 
 /* returns an HE * structure with the all fields set */


@@ -341,52 +375,203 @@ information on how to use this function on tied hashes.
 HE *
 Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash)
 {
 HE *
 Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash)
 {

-    register XPVHV* xhv;
-    register char *key;
-    STRLEN klen;
-    register HE *entry;
+    return hv_fetch_common(hv, keysv, NULL, 0, 0, 
+                          (lval ? HV_FETCH_LVALUE : 0), Nullsv, hash);
+}
+
+STATIC HE *
+S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
+                 int flags, int action, SV *val, register U32 hash)
+{
+    XPVHV* xhv;
+    U32 n_links;
+    HE *entry;
+    HE **oentry;

     SV *sv;
     bool is_utf8;
     SV *sv;
     bool is_utf8;

-    int flags = 0;
-    char *keysave;
+    int masked_flags;

 
     if (!hv)
        return 0;
 
 
     if (!hv)
        return 0;
 

-    if (SvRMAGICAL(hv)) {
-       if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
-           sv = sv_newmortal();
-           keysv = sv_2mortal(newSVsv(keysv));
-           mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY);
-           if (!HeKEY_hek(&PL_hv_fetch_ent_mh)) {
-               char *k;
-               New(54, k, HEK_BASESIZE + sizeof(SV*), char);
-               HeKEY_hek(&PL_hv_fetch_ent_mh) = (HEK*)k;
+    if (keysv) {
+       if (flags & HVhek_FREEKEY)
+           Safefree(key);
+       key = SvPV(keysv, klen);
+       flags = 0;
+       is_utf8 = (SvUTF8(keysv) != 0);
+    } else {
+       is_utf8 = ((flags & HVhek_UTF8) ? TRUE : FALSE);
+    }
+
+    xhv = (XPVHV*)SvANY(hv);
+    if (SvMAGICAL(hv)) {
+       if (SvRMAGICAL(hv) && !(action & (HV_FETCH_ISSTORE|HV_FETCH_ISEXISTS)))
+         {
+           if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
+               sv = sv_newmortal();
+
+               /* XXX should be able to skimp on the HE/HEK here when
+                  HV_FETCH_JUST_SV is true.  */
+
+               if (!keysv) {
+                   keysv = newSVpvn(key, klen);
+                   if (is_utf8) {
+                       SvUTF8_on(keysv);
+                   }
+               } else {
+                   keysv = newSVsv(keysv);
+               }
+               mg_copy((SV*)hv, sv, (char *)keysv, HEf_SVKEY);
+
+               /* grab a fake HE/HEK pair from the pool or make a new one */
+               entry = PL_hv_fetch_ent_mh;
+               if (entry)
+                   PL_hv_fetch_ent_mh = HeNEXT(entry);
+               else {
+                   char *k;
+                   entry = new_HE();
+                   New(54, k, HEK_BASESIZE + sizeof(SV*), char);
+                   HeKEY_hek(entry) = (HEK*)k;
+               }
+               HeNEXT(entry) = Nullhe;
+               HeSVKEY_set(entry, keysv);
+               HeVAL(entry) = sv;
+               sv_upgrade(sv, SVt_PVLV);
+               LvTYPE(sv) = 'T';
+                /* so we can free entry when freeing sv */
+               LvTARG(sv) = (SV*)entry;
+
+               /* XXX remove at some point? */
+               if (flags & HVhek_FREEKEY)
+                   Safefree(key);
+
+               return entry;

            }
            }

-           HeSVKEY_set(&PL_hv_fetch_ent_mh, keysv);
-           HeVAL(&PL_hv_fetch_ent_mh) = sv;
-           return &PL_hv_fetch_ent_mh;
-       }

 #ifdef ENV_IS_CASELESS
 #ifdef ENV_IS_CASELESS

-       else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
-           U32 i;
-           key = SvPV(keysv, klen);
-           for (i = 0; i < klen; ++i)
-               if (isLOWER(key[i])) {
-                   SV *nkeysv = sv_2mortal(newSVpvn(key,klen));
-                   (void)strupr(SvPVX(nkeysv));
-                   entry = hv_fetch_ent(hv, nkeysv, 0, 0);
-                   if (!entry && lval)
-                       entry = hv_store_ent(hv, keysv, NEWSV(61,0), hash);
-                   return entry;
+           else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
+               U32 i;
+               for (i = 0; i < klen; ++i)
+                   if (isLOWER(key[i])) {
+                       /* Would be nice if we had a routine to do the
+                          copy and upercase in a single pass through.  */
+                       char *nkey = strupr(savepvn(key,klen));
+                       /* Note that this fetch is for nkey (the uppercased
+                          key) whereas the store is for key (the original)  */
+                       entry = hv_fetch_common(hv, Nullsv, nkey, klen,
+                                               HVhek_FREEKEY, /* free nkey */
+                                               0 /* non-LVAL fetch */,
+                                               Nullsv /* no value */,
+                                               0 /* compute hash */);
+                       if (!entry && (action & HV_FETCH_LVALUE)) {
+                           /* This call will free key if necessary.
+                              Do it this way to encourage compiler to tail
+                              call optimise.  */
+                           entry = hv_fetch_common(hv, keysv, key, klen,
+                                                   flags, HV_FETCH_ISSTORE,
+                                                   NEWSV(61,0), hash);
+                       } else {
+                           if (flags & HVhek_FREEKEY)
+                               Safefree(key);
+                       }
+                       return entry;
+                   }
+           }
+#endif
+       } /* ISFETCH */
+       else if (SvRMAGICAL(hv) && (action & HV_FETCH_ISEXISTS)) {
+           if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
+               SV* svret;
+               /* I don't understand why hv_exists_ent has svret and sv,
+                  whereas hv_exists only had one.  */
+               svret = sv_newmortal();
+               sv = sv_newmortal();
+
+               if (keysv || is_utf8) {
+                   if (!keysv) {
+                       keysv = newSVpvn(key, klen);
+                       SvUTF8_on(keysv);
+                   } else {
+                       keysv = newSVsv(keysv);
+                   }
+                   mg_copy((SV*)hv, sv, (char *)sv_2mortal(keysv), HEf_SVKEY);
+               } else {
+                   mg_copy((SV*)hv, sv, key, klen);
+               }
+               if (flags & HVhek_FREEKEY)
+                   Safefree(key);
+               magic_existspack(svret, mg_find(sv, PERL_MAGIC_tiedelem));
+               /* This cast somewhat evil, but I'm merely using NULL/
+                  not NULL to return the boolean exists.
+                  And I know hv is not NULL.  */
+               return SvTRUE(svret) ? (HE *)hv : NULL;
+               }
+#ifdef ENV_IS_CASELESS
+           else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
+               /* XXX This code isn't UTF8 clean.  */
+               const char *keysave = key;
+               /* Will need to free this, so set FREEKEY flag.  */
+               key = savepvn(key,klen);
+               key = (const char*)strupr((char*)key);
+               is_utf8 = 0;
+               hash = 0;
+               keysv = 0;
+
+               if (flags & HVhek_FREEKEY) {
+                   Safefree(keysave);

                }
                }

-       }
+               flags |= HVhek_FREEKEY;
+           }

 #endif
 #endif

-    }
+       } /* ISEXISTS */
+       else if (action & HV_FETCH_ISSTORE) {
+           bool needs_copy;
+           bool needs_store;
+           hv_magic_check (hv, &needs_copy, &needs_store);
+           if (needs_copy) {
+               bool save_taint = PL_tainted;   
+               if (keysv || is_utf8) {
+                   if (!keysv) {
+                       keysv = newSVpvn(key, klen);
+                       SvUTF8_on(keysv);
+                   }
+                   if (PL_tainting)
+                       PL_tainted = SvTAINTED(keysv);
+                   keysv = sv_2mortal(newSVsv(keysv));
+                   mg_copy((SV*)hv, val, (char*)keysv, HEf_SVKEY);
+               } else {
+                   mg_copy((SV*)hv, val, key, klen);
+               }
+
+               TAINT_IF(save_taint);
+               if (!xhv->xhv_array /* !HvARRAY(hv) */ && !needs_store) {
+                   if (flags & HVhek_FREEKEY)
+                       Safefree(key);
+                   return Nullhe;
+               }
+#ifdef ENV_IS_CASELESS
+               else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
+                   /* XXX This code isn't UTF8 clean.  */
+                   const char *keysave = key;
+                   /* Will need to free this, so set FREEKEY flag.  */
+                   key = savepvn(key,klen);
+                   key = (const char*)strupr((char*)key);
+                   is_utf8 = 0;
+                   hash = 0;
+                   keysv = 0;
+
+                   if (flags & HVhek_FREEKEY) {
+                       Safefree(keysave);
+                   }
+                   flags |= HVhek_FREEKEY;
+               }
+#endif
+           }
+       } /* ISSTORE */
+    } /* SvMAGICAL */

 
 

-    xhv = (XPVHV*)SvANY(hv);

     if (!xhv->xhv_array /* !HvARRAY(hv) */) {
     if (!xhv->xhv_array /* !HvARRAY(hv) */) {

-       if (lval
+       if ((action & (HV_FETCH_LVALUE | HV_FETCH_ISSTORE))

 #ifdef DYNAMIC_ENV_FETCH  /* if it's an %ENV lookup, we may get it on the fly */
                 || (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
 #endif
 #ifdef DYNAMIC_ENV_FETCH  /* if it's an %ENV lookup, we may get it on the fly */
                 || (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
 #endif


@@ -394,262 +579,180 @@ Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash)
            Newz(503, xhv->xhv_array /* HvARRAY(hv) */,
                 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
                 char);
            Newz(503, xhv->xhv_array /* HvARRAY(hv) */,
                 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
                 char);

-       else
+#ifdef DYNAMIC_ENV_FETCH
+       else if (action & HV_FETCH_ISEXISTS) {
+           /* for an %ENV exists, if we do an insert it's by a recursive
+              store call, so avoid creating HvARRAY(hv) right now.  */
+       }
+#endif
+       else {
+           /* XXX remove at some point? */
+            if (flags & HVhek_FREEKEY)
+                Safefree(key);
+

            return 0;
            return 0;

+       }

     }
 
     }
 

-    keysave = key = SvPV(keysv, klen);
-    is_utf8 = (SvUTF8(keysv)!=0);
-

     if (is_utf8) {
     if (is_utf8) {

+       const char *keysave = key;

        key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
         if (is_utf8)
        key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
         if (is_utf8)

-            flags = HVhek_UTF8;
-        if (key != keysave)
+           flags |= HVhek_UTF8;
+       else
+           flags &= ~HVhek_UTF8;
+        if (key != keysave) {
+           if (flags & HVhek_FREEKEY)
+               Safefree(keysave);

             flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
             flags |= HVhek_WASUTF8 | HVhek_FREEKEY;

+       }

     }
 
     }
 

-    if (!hash) {
-        if SvIsCOW_shared_hash(keysv) {
+    if (HvREHASH(hv)) {
+       PERL_HASH_INTERNAL(hash, key, klen);
+       /* We don't have a pointer to the hv, so we have to replicate the
+          flag into every HEK, so that hv_iterkeysv can see it.  */
+       /* And yes, you do need this even though you are not "storing" because
+          you can flip the flags below if doing an lval lookup.  (And that
+          was put in to give the semantics Andreas was expecting.)  */
+       flags |= HVhek_REHASH;
+    } else if (!hash) {
+        if (keysv && (SvIsCOW_shared_hash(keysv))) {

             hash = SvUVX(keysv);
         } else {
             PERL_HASH(hash, key, klen);
         }
     }
 
             hash = SvUVX(keysv);
         } else {
             PERL_HASH(hash, key, klen);
         }
     }
 

-    /* entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
-    entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
-    for (; entry; entry = HeNEXT(entry)) {
+    masked_flags = (flags & HVhek_MASK);
+    n_links = 0;
+
+#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; ++n_links, entry = HeNEXT(entry)) {

        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 (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) ^ flags) & HVhek_UTF8)
+       if ((HeKFLAGS(entry) ^ masked_flags) & HVhek_UTF8)

            continue;
            continue;

-        if (lval && HeKFLAGS(entry) != flags) {
-            /* We match if HVhek_UTF8 bit in our flags and hash key's match.
-               But if entry was set previously with HVhek_WASUTF8 and key now
-               doesn't (or vice versa) then we should change the key's flag,
-               as this is assignment.  */
-            if (HvSHAREKEYS(hv)) {
-                /* Need to swap the key we have for a key with the flags we
-                   need. As keys are shared we can't just write to the flag,
-                   so we share the new one, unshare the old one.  */
-                int flags_nofree = flags & ~HVhek_FREEKEY;
-                HEK *new_hek = share_hek_flags(key, klen, hash, flags_nofree);
-                unshare_hek (HeKEY_hek(entry));
-                HeKEY_hek(entry) = new_hek;
-            }
-            else
-                HeKFLAGS(entry) = flags;
-        }
-       if (key != keysave)
-           Safefree(key);
-       /* if we find a placeholder, we pretend we haven't found anything */
-       if (HeVAL(entry) == &PL_sv_undef)
-           break;
-       return entry;
-    }
-#ifdef DYNAMIC_ENV_FETCH  /* %ENV lookup?  If so, try to fetch the value now */
-    if (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
+
+        if (action & (HV_FETCH_LVALUE|HV_FETCH_ISSTORE)) {
+           if (HeKFLAGS(entry) != masked_flags) {
+               /* We match if HVhek_UTF8 bit in our flags and hash key's
+                  match.  But if entry was set previously with HVhek_WASUTF8
+                  and key now doesn't (or vice versa) then we should change
+                  the key's flag, as this is assignment.  */
+               if (HvSHAREKEYS(hv)) {
+                   /* Need to swap the key we have for a key with the flags we
+                      need. As keys are shared we can't just write to the
+                      flag, so we share the new one, unshare the old one.  */
+                   HEK *new_hek = share_hek_flags(key, klen, hash,
+                                                  masked_flags);
+                   unshare_hek (HeKEY_hek(entry));
+                   HeKEY_hek(entry) = new_hek;
+               }
+               else
+                   HeKFLAGS(entry) = masked_flags;
+               if (masked_flags & HVhek_ENABLEHVKFLAGS)
+                   HvHASKFLAGS_on(hv);
+           }
+           if (HeVAL(entry) == &PL_sv_placeholder) {
+               /* yes, can store into placeholder slot */
+               if (action & HV_FETCH_LVALUE) {
+                   if (SvMAGICAL(hv)) {
+                       /* This preserves behaviour with the old hv_fetch
+                          implementation which at this point would bail out
+                          with a break; (at "if we find a placeholder, we
+                          pretend we haven't found anything")
+
+                          That break mean that if a placeholder were found, it
+                          caused a call into hv_store, which in turn would
+                          check magic, and if there is no magic end up pretty
+                          much back at this point (in hv_store's code).  */
+                       break;
+                   }
+                   /* LVAL fetch which actaully needs a store.  */
+                   val = NEWSV(61,0);
+                   xhv->xhv_placeholders--;
+               } else {
+                   /* store */
+                   if (val != &PL_sv_placeholder)
+                       xhv->xhv_placeholders--;
+               }
+               HeVAL(entry) = val;
+           } else if (action & HV_FETCH_ISSTORE) {
+               SvREFCNT_dec(HeVAL(entry));
+               HeVAL(entry) = val;
+           }
+       } else if (HeVAL(entry) == &PL_sv_placeholder) {
+           /* if we find a placeholder, we pretend we haven't found
+              anything */
+           break;
+       }
+       if (flags & HVhek_FREEKEY)
+           Safefree(key);
+       return entry;
+    }
+#ifdef DYNAMIC_ENV_FETCH  /* %ENV lookup?  If so, try to fetch the value now */
+    if (!(action & HV_FETCH_ISSTORE) 
+       && 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);
        unsigned long len;
        char *env = PerlEnv_ENVgetenv_len(key,&len);
        if (env) {
            sv = newSVpvn(env,len);
            SvTAINTED_on(sv);

-           return hv_store_ent(hv,keysv,sv,hash);
+           return hv_fetch_common(hv,keysv,key,klen,flags,HV_FETCH_ISSTORE,sv,
+                                  hash);

        }
     }
 #endif
        }
     }
 #endif

-    if (!entry && SvREADONLY(hv)) {
+
+    if (!entry && SvREADONLY(hv) && !(action & HV_FETCH_ISEXISTS)) {

        S_hv_notallowed(aTHX_ flags, key, klen,
                        "access disallowed key '%"SVf"' in"
                        );
     }
        S_hv_notallowed(aTHX_ flags, key, klen,
                        "access disallowed key '%"SVf"' in"
                        );
     }

-    if (flags & HVhek_FREEKEY)
-       Safefree(key);
-    if (lval) {                /* gonna assign to this, so it better be there */
-       sv = NEWSV(61,0);
-       return hv_store_ent(hv,keysv,sv,hash);
-    }
-    return 0;
-}
-
-STATIC void
-S_hv_magic_check(pTHX_ HV *hv, bool *needs_copy, bool *needs_store)
-{
-    MAGIC *mg = SvMAGIC(hv);
-    *needs_copy = FALSE;
-    *needs_store = TRUE;
-    while (mg) {
-       if (isUPPER(mg->mg_type)) {
-           *needs_copy = TRUE;
-           switch (mg->mg_type) {
-           case PERL_MAGIC_tied:
-           case PERL_MAGIC_sig:
-               *needs_store = FALSE;
-           }
-       }
-       mg = mg->mg_moremagic;
-    }
-}
-
-/*
-=for apidoc hv_store
-
-Stores an SV in a hash.  The hash key is specified as C<key> and C<klen> is
-the length of the key.  The C<hash> parameter is the precomputed hash
-value; if it is zero then Perl will compute it.  The return value will be
-NULL if the operation failed or if the value did not need to be actually
-stored within the hash (as in the case of tied hashes).  Otherwise it can
-be dereferenced to get the original C<SV*>.  Note that the caller is
-responsible for suitably incrementing the reference count of C<val> before
-the call, and decrementing it if the function returned NULL.  Effectively
-a successful hv_store takes ownership of one reference to C<val>.  This is
-usually what you want; a newly created SV has a reference count of one, so
-if all your code does is create SVs then store them in a hash, hv_store
-will own the only reference to the new SV, and your code doesn't need to do
-anything further to tidy up.  hv_store is not implemented as a call to
-hv_store_ent, and does not create a temporary SV for the key, so if your
-key data is not already in SV form then use hv_store in preference to
-hv_store_ent.
-
-See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
-information on how to use this function on tied hashes.
-
-=cut
-*/
-
-SV**
-Perl_hv_store(pTHX_ HV *hv, const char *key, I32 klen, SV *val, U32 hash)
-{
-    bool is_utf8 = FALSE;
-    const char *keysave = key;
-    int flags = 0;
-
-    if (klen < 0) {
-      klen = -klen;
-      is_utf8 = TRUE;
-    }
-
-    if (is_utf8) {
-       STRLEN tmplen = klen;
-       /* Just casting the &klen to (STRLEN) won't work well
-        * if STRLEN and I32 are of different widths. --jhi */
-       key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
-       klen = tmplen;
-        /* If we were able to downgrade here, then than means that we were
-           passed in a key which only had chars 0-255, but was utf8 encoded.  */
-        if (is_utf8)
-            flags = HVhek_UTF8;
-        /* If we found we were able to downgrade the string to bytes, then
-           we should flag that it needs upgrading on keys or each.  */
-        if (key != keysave)
-            flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
-    }
-
-    return hv_store_flags (hv, key, klen, val, hash, flags);
-}
-
-SV**
-Perl_hv_store_flags(pTHX_ HV *hv, const char *key, I32 klen, SV *val,
-                 register U32 hash, int flags)
-{
-    register XPVHV* xhv;
-    register I32 i;
-    register HE *entry;
-    register HE **oentry;
-
-    if (!hv)
+    if (!(action & (HV_FETCH_LVALUE|HV_FETCH_ISSTORE))) {
+       /* Not doing some form of store, so return failure.  */
+       if (flags & HVhek_FREEKEY)
+           Safefree(key);

        return 0;
        return 0;

-
-    xhv = (XPVHV*)SvANY(hv);
-    if (SvMAGICAL(hv)) {
-       bool needs_copy;
-       bool needs_store;
-       hv_magic_check (hv, &needs_copy, &needs_store);
-       if (needs_copy) {
-           mg_copy((SV*)hv, val, key, klen);
-           if (!xhv->xhv_array /* !HvARRAY */ && !needs_store) {
-                if (flags & HVhek_FREEKEY)
-                    Safefree(key);
-               return 0;
-            }
-#ifdef ENV_IS_CASELESS
-           else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
-               key = savepvn(key,klen);
-               key = (const char*)strupr((char*)key);
-               hash = 0;
-           }
-#endif
+    }
+    if (action & HV_FETCH_LVALUE) {
+       val = NEWSV(61,0);
+       if (SvMAGICAL(hv)) {
+           /* At this point the old hv_fetch code would call to hv_store,
+              which in turn might do some tied magic. So we need to make that
+              magic check happen.  */
+           /* gonna assign to this, so it better be there */
+           return hv_fetch_common(hv, keysv, key, klen, flags,
+                                  HV_FETCH_ISSTORE, val, hash);
+           /* XXX Surely that could leak if the fetch-was-store fails?
+              Just like the hv_fetch.  */

        }
     }
 
        }
     }
 

-    if (flags)
-        HvHASKFLAGS_on((SV*)hv);
-
-    if (!hash)
-       PERL_HASH(hash, key, klen);
+    /* Welcome to hv_store...  */

 
 

-    if (!xhv->xhv_array /* !HvARRAY(hv) */)
-       Newz(505, xhv->xhv_array /* HvARRAY(hv) */,
+    if (!xhv->xhv_array) {
+       /* Not sure if we can get here.  I think the only case of oentry being
+          NULL is for %ENV with dynamic env fetch.  But that should disappear
+          with magic in the previous code.  */
+       Newz(503, xhv->xhv_array /* HvARRAY(hv) */,

             PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
             char);
             PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
             char);

-
-    /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
-    oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
-    i = 1;
-
-    for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
-       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) ^ flags) & HVhek_UTF8)
-           continue;
-       if (HeVAL(entry) == &PL_sv_undef)
-           xhv->xhv_placeholders--; /* yes, can store into placeholder slot */
-       else
-           SvREFCNT_dec(HeVAL(entry));
-        if (flags & HVhek_PLACEHOLD) {
-            /* We have been requested to insert a placeholder. Currently
-               only Storable is allowed to do this.  */
-            xhv->xhv_placeholders++;
-            HeVAL(entry) = &PL_sv_undef;
-        } else
-            HeVAL(entry) = val;
-
-        if (HeKFLAGS(entry) != flags) {
-            /* We match if HVhek_UTF8 bit in our flags and hash key's match.
-               But if entry was set previously with HVhek_WASUTF8 and key now
-               doesn't (or vice versa) then we should change the key's flag,
-               as this is assignment.  */
-            if (HvSHAREKEYS(hv)) {
-                /* Need to swap the key we have for a key with the flags we
-                   need. As keys are shared we can't just write to the flag,
-                   so we share the new one, unshare the old one.  */
-                int flags_nofree = flags & ~HVhek_FREEKEY;
-                HEK *new_hek = share_hek_flags(key, klen, hash, flags_nofree);
-                unshare_hek (HeKEY_hek(entry));
-                HeKEY_hek(entry) = new_hek;
-            }
-            else
-                HeKFLAGS(entry) = flags;
-        }
-        if (flags & HVhek_FREEKEY)
-            Safefree(key);
-       return &HeVAL(entry);

     }
 
     }
 

-    if (SvREADONLY(hv)) {
-       S_hv_notallowed(aTHX_ flags, key, klen,
-                       "access disallowed key '%"SVf"' to"
-                       );
-    }
+    oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];

 
     entry = new_HE();
     /* share_hek_flags will do the free for us.  This might be considered
 
     entry = new_HE();
     /* share_hek_flags will do the free for us.  This might be considered


@@ -658,186 +761,78 @@ Perl_hv_store_flags(pTHX_ HV *hv, const char *key, I32 klen, SV *val,
        HeKEY_hek(entry) = share_hek_flags(key, klen, hash, flags);
     else                                       /* gotta do the real thing */
        HeKEY_hek(entry) = save_hek_flags(key, klen, hash, flags);
        HeKEY_hek(entry) = share_hek_flags(key, klen, hash, flags);
     else                                       /* gotta do the real thing */
        HeKEY_hek(entry) = save_hek_flags(key, klen, hash, flags);

-    if (flags & HVhek_PLACEHOLD) {
-        /* We have been requested to insert a placeholder. Currently
-           only Storable is allowed to do this.  */
-        xhv->xhv_placeholders++;
-        HeVAL(entry) = &PL_sv_undef;
-    } else
-        HeVAL(entry) = val;
+    HeVAL(entry) = val;

     HeNEXT(entry) = *oentry;
     *oentry = entry;
 
     HeNEXT(entry) = *oentry;
     *oentry = entry;
 

+    if (val == &PL_sv_placeholder)
+       xhv->xhv_placeholders++;
+    if (masked_flags & HVhek_ENABLEHVKFLAGS)
+       HvHASKFLAGS_on(hv);
+

     xhv->xhv_keys++; /* HvKEYS(hv)++ */
     xhv->xhv_keys++; /* HvKEYS(hv)++ */

-    if (i) {                           /* initial entry? */
+    if (!n_links) {                            /* initial entry? */

        xhv->xhv_fill++; /* HvFILL(hv)++ */
        xhv->xhv_fill++; /* HvFILL(hv)++ */

-       if (xhv->xhv_keys > (IV)xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */)
-           hsplit(hv);
+    } else if ((xhv->xhv_keys > (IV)xhv->xhv_max)
+              || ((n_links > HV_MAX_LENGTH_BEFORE_SPLIT) && !HvREHASH(hv))) {
+       /* Use only the old HvKEYS(hv) > HvMAX(hv) condition to limit bucket
+          splits on a rehashed hash, as we're not going to split it again,
+          and if someone is lucky (evil) enough to get all the keys in one
+          list they could exhaust our memory as we repeatedly double the
+          number of buckets on every entry. Linear search feels a less worse
+          thing to do.  */
+        hsplit(hv);

     }
 
     }
 

-    return &HeVAL(entry);
+    return entry;

 }
 
 }
 

-/*
-=for apidoc hv_store_ent
-
-Stores C<val> in a hash.  The hash key is specified as C<key>.  The C<hash>
-parameter is the precomputed hash value; if it is zero then Perl will
-compute it.  The return value is the new hash entry so created.  It will be
-NULL if the operation failed or if the value did not need to be actually
-stored within the hash (as in the case of tied hashes).  Otherwise the
-contents of the return value can be accessed using the C<He?> macros
-described here.  Note that the caller is responsible for suitably
-incrementing the reference count of C<val> before the call, and
-decrementing it if the function returned NULL.  Effectively a successful
-hv_store_ent takes ownership of one reference to C<val>.  This is
-usually what you want; a newly created SV has a reference count of one, so
-if all your code does is create SVs then store them in a hash, hv_store
-will own the only reference to the new SV, and your code doesn't need to do
-anything further to tidy up.  Note that hv_store_ent only reads the C<key>;
-unlike C<val> it does not take ownership of it, so maintaining the correct
-reference count on C<key> is entirely the caller's responsibility.  hv_store
-is not implemented as a call to hv_store_ent, and does not create a temporary
-SV for the key, so if your key data is not already in SV form then use
-hv_store in preference to hv_store_ent.
-
-See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
-information on how to use this function on tied hashes.
-
-=cut
-*/
-
-HE *
-Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, U32 hash)
+STATIC void
+S_hv_magic_check(pTHX_ HV *hv, bool *needs_copy, bool *needs_store)

 {
 {

-    XPVHV* xhv;
-    char *key;
-    STRLEN klen;
-    I32 i;
-    HE *entry;
-    HE **oentry;
-    bool is_utf8;
-    int flags = 0;
-    char *keysave;
-
-    if (!hv)
-       return 0;
-
-    xhv = (XPVHV*)SvANY(hv);
-    if (SvMAGICAL(hv)) {
-       bool needs_copy;
-       bool needs_store;
-       hv_magic_check (hv, &needs_copy, &needs_store);
-       if (needs_copy) {
-           bool save_taint = PL_tainted;
-           if (PL_tainting)
-               PL_tainted = SvTAINTED(keysv);
-           keysv = sv_2mortal(newSVsv(keysv));
-           mg_copy((SV*)hv, val, (char*)keysv, HEf_SVKEY);
-           TAINT_IF(save_taint);
-           if (!xhv->xhv_array /* !HvARRAY(hv) */ && !needs_store)
-               return Nullhe;
-#ifdef ENV_IS_CASELESS
-           else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
-               key = SvPV(keysv, klen);
-               keysv = sv_2mortal(newSVpvn(key,klen));
-               (void)strupr(SvPVX(keysv));
-               hash = 0;
+    MAGIC *mg = SvMAGIC(hv);
+    *needs_copy = FALSE;
+    *needs_store = TRUE;
+    while (mg) {
+       if (isUPPER(mg->mg_type)) {
+           *needs_copy = TRUE;
+           switch (mg->mg_type) {
+           case PERL_MAGIC_tied:
+           case PERL_MAGIC_sig:
+               *needs_store = FALSE;

            }
            }

-#endif

        }
        }

+       mg = mg->mg_moremagic;

     }
     }

+}

 
 

-    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)
-            flags = HVhek_UTF8;
-        if (key != keysave)
-            flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
-        HvHASKFLAGS_on((SV*)hv);
-    }
-
-    if (!hash) {
-        if SvIsCOW_shared_hash(keysv) {
-            hash = SvUVX(keysv);
-        } else {
-            PERL_HASH(hash, key, klen);
-        }
-    }
-
-    if (!xhv->xhv_array /* !HvARRAY(hv) */)
-       Newz(505, xhv->xhv_array /* HvARRAY(hv) */,
-            PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
-            char);
-
-    /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
-    oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
-    i = 1;
-    entry = *oentry;
-    for (; entry; i=0, entry = HeNEXT(entry)) {
-       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) ^ flags) & HVhek_UTF8)
-           continue;
-       if (HeVAL(entry) == &PL_sv_undef)
-           xhv->xhv_placeholders--; /* yes, can store into placeholder slot */
-       else
-           SvREFCNT_dec(HeVAL(entry));
-       HeVAL(entry) = val;
-        if (HeKFLAGS(entry) != flags) {
-            /* We match if HVhek_UTF8 bit in our flags and hash key's match.
-               But if entry was set previously with HVhek_WASUTF8 and key now
-               doesn't (or vice versa) then we should change the key's flag,
-               as this is assignment.  */
-            if (HvSHAREKEYS(hv)) {
-                /* Need to swap the key we have for a key with the flags we
-                   need. As keys are shared we can't just write to the flag,
-                   so we share the new one, unshare the old one.  */
-                int flags_nofree = flags & ~HVhek_FREEKEY;
-                HEK *new_hek = share_hek_flags(key, klen, hash, flags_nofree);
-                unshare_hek (HeKEY_hek(entry));
-                HeKEY_hek(entry) = new_hek;
-            }
-            else
-                HeKFLAGS(entry) = flags;
-        }
-        if (flags & HVhek_FREEKEY)
-           Safefree(key);
-       return entry;
-    }
-
-    if (SvREADONLY(hv)) {
-       S_hv_notallowed(aTHX_ flags, key, klen,
-                       "access disallowed key '%"SVf"' to"
-                       );
-    }
+/*
+=for apidoc hv_scalar

 
 

-    entry = new_HE();
-    /* share_hek_flags will do the free for us.  This might be considered
-       bad API design.  */
-    if (HvSHAREKEYS(hv))
-       HeKEY_hek(entry) = share_hek_flags(key, klen, hash, flags);
-    else                                       /* gotta do the real thing */
-       HeKEY_hek(entry) = save_hek_flags(key, klen, hash, flags);
-    HeVAL(entry) = val;
-    HeNEXT(entry) = *oentry;
-    *oentry = entry;
+Evaluates the hash in scalar context and returns the result. Handles magic when the hash is tied.

 
 

-    xhv->xhv_keys++; /* HvKEYS(hv)++ */
-    if (i) {                           /* initial entry? */
-       xhv->xhv_fill++; /* HvFILL(hv)++ */
-       if (xhv->xhv_keys > (IV)xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */)
-           hsplit(hv);
-    }
+=cut
+*/

 
 

-    return entry;
+SV *
+Perl_hv_scalar(pTHX_ HV *hv)
+{
+    MAGIC *mg;
+    SV *sv;
+    
+    if ((SvRMAGICAL(hv) && (mg = mg_find((SV*)hv, PERL_MAGIC_tied)))) {
+        sv = magic_scalarpack(hv, mg);
+        return sv;
+    } 
+
+    sv = sv_newmortal();
+    if (HvFILL((HV*)hv)) 
+        Perl_sv_setpvf(aTHX_ sv, "%ld/%ld",
+                (long)HvFILL(hv), (long)HvMAX(hv) + 1);
+    else
+        sv_setiv(sv, 0);
+    
+    return sv;

 }
 
 /*
 }
 
 /*


@@ -852,151 +847,18 @@ will be returned.
 */
 
 SV *
 */
 
 SV *

-Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen, I32 flags)
+Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen_i32, 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;
+    STRLEN klen;

     int k_flags = 0;
     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, 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;
-    }
-
-    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_undef)
-       {
-           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_undef;
-       }
-
-       /*
-        * 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_undef;
-           /* 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;
+
+    if (klen_i32 < 0) {
+       klen = -klen_i32;
+       k_flags |= HVhek_UTF8;
+    } else {
+       klen = klen_i32;
+    }
+    return hv_delete_common(hv, NULL, key, klen, k_flags, flags, 0);

 }
 
 /*
 }
 
 /*


@@ -1013,64 +875,106 @@ 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)
 {
 SV *
 Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash)
 {

+    return hv_delete_common(hv, keysv, NULL, 0, 0, flags, hash);
+}
+
+STATIC SV *
+S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
+                  int k_flags, I32 d_flags, U32 hash)
+{

     register XPVHV* xhv;
     register I32 i;
     register XPVHV* xhv;
     register I32 i;

-    register char *key;
-    STRLEN klen;

     register HE *entry;
     register HE **oentry;
     SV *sv;
     bool is_utf8;
     register HE *entry;
     register HE **oentry;
     SV *sv;
     bool is_utf8;

-    int k_flags = 0;
-    char *keysave;
+    int masked_flags;

 
     if (!hv)
        return Nullsv;
 
     if (!hv)
        return Nullsv;

+
+    if (keysv) {
+       if (k_flags & HVhek_FREEKEY)
+           Safefree(key);
+       key = SvPV(keysv, klen);
+       k_flags = 0;
+       is_utf8 = (SvUTF8(keysv) != 0);
+    } else {
+       is_utf8 = ((k_flags & HVhek_UTF8) ? TRUE : FALSE);
+    }
+

     if (SvRMAGICAL(hv)) {
        bool needs_copy;
        bool needs_store;
        hv_magic_check (hv, &needs_copy, &needs_store);
 
     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_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 (needs_copy) {
+           entry = hv_fetch_common(hv, keysv, key, klen,
+                                   k_flags & ~HVhek_FREEKEY, HV_FETCH_LVALUE,
+                                   Nullsv, hash);
+           sv = entry ? HeVAL(entry) : NULL;
+           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
 #ifdef ENV_IS_CASELESS

-           else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
-               key = SvPV(keysv, klen);
-               keysv = sv_2mortal(newSVpvn(key,klen));
-               (void)strupr(SvPVX(keysv));
-               hash = 0;
-           }
+               else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
+                   /* XXX This code isn't UTF8 clean.  */
+                   keysv = sv_2mortal(newSVpvn(key,klen));
+                   if (k_flags & HVhek_FREEKEY) {
+                       Safefree(key);
+                   }
+                   key = strupr(SvPVX(keysv));
+                   is_utf8 = 0;
+                   k_flags = 0;
+                   hash = 0;
+               }

 #endif
 #endif

+           }

        }
     }
     xhv = (XPVHV*)SvANY(hv);
     if (!xhv->xhv_array /* !HvARRAY(hv) */)
        return Nullsv;
 
        }
     }
     xhv = (XPVHV*)SvANY(hv);
     if (!xhv->xhv_array /* !HvARRAY(hv) */)
        return Nullsv;
 

-    keysave = key = SvPV(keysv, klen);
-    is_utf8 = (SvUTF8(keysv) != 0);
-

     if (is_utf8) {
     if (is_utf8) {

-       key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
+    const char *keysave = key;
+    key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
+

         if (is_utf8)
         if (is_utf8)

-            k_flags = HVhek_UTF8;
-        if (key != keysave)
-            k_flags |= HVhek_FREEKEY;
+            k_flags |= HVhek_UTF8;
+       else
+            k_flags &= ~HVhek_UTF8;
+        if (key != keysave) {
+           if (k_flags & HVhek_FREEKEY) {
+               /* This shouldn't happen if our caller does what we expect,
+                  but strictly the API allows it.  */
+               Safefree(keysave);
+           }
+           k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
+       }
+        HvHASKFLAGS_on((SV*)hv);
+    }
+
+    if (HvREHASH(hv)) {
+       PERL_HASH_INTERNAL(hash, key, klen);
+    } else if (!hash) {
+        if (keysv && (SvIsCOW_shared_hash(keysv))) {
+            hash = SvUVX(keysv);
+        } else {
+            PERL_HASH(hash, key, klen);
+        }

     }
 
     }
 

-    if (!hash)
-       PERL_HASH(hash, key, klen);
+    masked_flags = (k_flags & HVhek_MASK);

 
     /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
     oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
 
     /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
     oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];


@@ -1083,42 +987,29 @@ Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash)
            continue;
        if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen))        /* is this it? */
            continue;
            continue;
        if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen))        /* is this it? */
            continue;

-       if ((HeKFLAGS(entry) ^ k_flags) & HVhek_UTF8)
+       if ((HeKFLAGS(entry) ^ masked_flags) & HVhek_UTF8)

            continue;
            continue;

-        if (k_flags & HVhek_FREEKEY)
-            Safefree(key);

 
        /* if placeholder is here, it's already been deleted.... */
 
        /* if placeholder is here, it's already been deleted.... */

-       if (HeVAL(entry) == &PL_sv_undef)
+       if (HeVAL(entry) == &PL_sv_placeholder)

        {
        {

-           if (SvREADONLY(hv))
-               return Nullsv; /* if still SvREADONLY, leave it deleted. */
-
-           /* 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;
+         if (k_flags & HVhek_FREEKEY)
+            Safefree(key);
+         return Nullsv;

        }
        else if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
            S_hv_notallowed(aTHX_ k_flags, key, klen,
                            "delete readonly key '%"SVf"' from"
                            );
        }
        }
        else if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
            S_hv_notallowed(aTHX_ k_flags, key, klen,
                            "delete readonly key '%"SVf"' from"
                            );
        }

+        if (k_flags & HVhek_FREEKEY)
+            Safefree(key);

 
 

-       if (flags & G_DISCARD)
+       if (d_flags & G_DISCARD)

            sv = Nullsv;
        else {
            sv = sv_2mortal(HeVAL(entry));
            sv = Nullsv;
        else {
            sv = sv_2mortal(HeVAL(entry));

-           HeVAL(entry) = &PL_sv_undef;
+           HeVAL(entry) = &PL_sv_placeholder;

        }
 
        /*
        }
 
        /*


@@ -1128,7 +1019,8 @@ Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash)
         * an error.
         */
        if (SvREADONLY(hv)) {
         * an error.
         */
        if (SvREADONLY(hv)) {

-           HeVAL(entry) = &PL_sv_undef;
+           SvREFCNT_dec(HeVAL(entry));
+           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)++ */
            /* 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)++ */


@@ -1157,214 +1049,6 @@ Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash)
     return Nullsv;
 }
 
     return Nullsv;
 }
 

-/*
-=for apidoc hv_exists
-
-Returns a boolean indicating whether the specified hash key exists.  The
-C<klen> is the length of the key.
-
-=cut
-*/
-
-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();
-           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;
-    }
-
-    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_undef)
-           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;
-}
-
-
-/*
-=for apidoc hv_exists_ent
-
-Returns a boolean indicating whether the specified hash key exists. C<hash>
-can be a valid precomputed hash value, or 0 to ask for it to be
-computed.
-
-=cut
-*/
-
-bool
-Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash)
-{
-    register XPVHV* xhv;
-    register char *key;
-    STRLEN klen;
-    register HE *entry;
-    SV *sv;
-    bool is_utf8;
-    char *keysave;
-    int k_flags = 0;
-
-    if (!hv)
-       return 0;
-
-    if (SvRMAGICAL(hv)) {
-       if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
-          SV* 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);
-       }
-#ifdef ENV_IS_CASELESS
-       else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
-           key = SvPV(keysv, klen);
-           keysv = sv_2mortal(newSVpvn(key,klen));
-           (void)strupr(SvPVX(keysv));
-           hash = 0;
-       }
-#endif
-    }
-
-    xhv = (XPVHV*)SvANY(hv);
-#ifndef DYNAMIC_ENV_FETCH
-    if (!xhv->xhv_array /* !HvARRAY(hv) */)
-       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)
-            k_flags = HVhek_UTF8;
-        if (key != keysave)
-            k_flags |= HVhek_FREEKEY;
-    }
-    if (!hash)
-       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) != (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 we find the key, but the value is a placeholder, return false. */
-       if (HeVAL(entry) == &PL_sv_undef)
-           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_ent(hv,keysv,sv,hash);
-            if (k_flags & HVhek_FREEKEY)
-                Safefree(key);
-           return TRUE;
-       }
-    }
-#endif
-    if (k_flags & HVhek_FREEKEY)
-        Safefree(key);
-    return FALSE;
-}
-

 STATIC void
 S_hsplit(pTHX_ HV *hv)
 {
 STATIC void
 S_hsplit(pTHX_ HV *hv)
 {


@@ -1377,7 +1061,20 @@ S_hsplit(pTHX_ HV *hv)
     register HE **bep;
     register HE *entry;
     register HE **oentry;
     register HE **bep;
     register HE *entry;
     register HE **oentry;

+    int longest_chain = 0;
+    int was_shared;
+
+    /*PerlIO_printf(PerlIO_stderr(), "hsplit called for %p which had %d\n",
+      hv, (int) oldsize);*/

 
 

+    if (HvPLACEHOLDERS(hv) && !SvREADONLY(hv)) {
+      /* Can make this clear any placeholders first for non-restricted hashes,
+        even though Storable rebuilds restricted hashes by putting in all the
+        placeholders (first) before turning on the readonly flag, because
+        Storable always pre-splits the hash.  */
+      hv_clear_placeholders(hv);
+    }
+              

     PL_nomemok = TRUE;
 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
     Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
     PL_nomemok = TRUE;
 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
     Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);


@@ -1407,6 +1104,9 @@ S_hsplit(pTHX_ HV *hv)
     aep = (HE**)a;
 
     for (i=0; i<oldsize; i++,aep++) {
     aep = (HE**)a;
 
     for (i=0; i<oldsize; i++,aep++) {

+       int left_length = 0;
+       int right_length = 0;
+

        if (!*aep)                              /* non-existent */
            continue;
        bep = aep+oldsize;
        if (!*aep)                              /* non-existent */
            continue;
        bep = aep+oldsize;


@@ -1417,14 +1117,90 @@ S_hsplit(pTHX_ HV *hv)
                if (!*bep)
                    xhv->xhv_fill++; /* HvFILL(hv)++ */
                *bep = entry;
                if (!*bep)
                    xhv->xhv_fill++; /* HvFILL(hv)++ */
                *bep = entry;

+               right_length++;

                continue;
            }
                continue;
            }

-           else
+           else {

                oentry = &HeNEXT(entry);
                oentry = &HeNEXT(entry);

+               left_length++;
+           }

        }
        if (!*aep)                              /* everything moved */
            xhv->xhv_fill--; /* HvFILL(hv)-- */
        }
        if (!*aep)                              /* everything moved */
            xhv->xhv_fill--; /* HvFILL(hv)-- */

+       /* I think we don't actually need to keep track of the longest length,
+          merely flag if anything is too long. But for the moment while
+          developing this code I'll track it.  */
+       if (left_length > longest_chain)
+           longest_chain = left_length;
+       if (right_length > longest_chain)
+           longest_chain = right_length;
+    }
+
+
+    /* Pick your policy for "hashing isn't working" here:  */
+    if (longest_chain <= HV_MAX_LENGTH_BEFORE_SPLIT /* split worked?  */
+       || HvREHASH(hv)) {
+       return;
+    }
+
+    if (hv == PL_strtab) {
+       /* Urg. Someone is doing something nasty to the string table.
+          Can't win.  */
+       return;
+    }
+
+    /* Awooga. Awooga. Pathological data.  */
+    /*PerlIO_printf(PerlIO_stderr(), "%p %d of %d with %d/%d buckets\n", hv,
+      longest_chain, HvTOTALKEYS(hv), HvFILL(hv),  1+HvMAX(hv));*/
+
+    ++newsize;
+    Newz(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
+    was_shared = HvSHAREKEYS(hv);
+
+    xhv->xhv_fill = 0;
+    HvSHAREKEYS_off(hv);
+    HvREHASH_on(hv);
+
+    aep = (HE **) xhv->xhv_array;
+
+    for (i=0; i<newsize; i++,aep++) {
+       entry = *aep;
+       while (entry) {
+           /* We're going to trash this HE's next pointer when we chain it
+              into the new hash below, so store where we go next.  */
+           HE *next = HeNEXT(entry);
+           UV hash;
+
+           /* Rehash it */
+           PERL_HASH_INTERNAL(hash, HeKEY(entry), HeKLEN(entry));
+
+           if (was_shared) {
+               /* Unshare it.  */
+               HEK *new_hek
+                   = save_hek_flags(HeKEY(entry), HeKLEN(entry),
+                                    hash, HeKFLAGS(entry));
+               unshare_hek (HeKEY_hek(entry));
+               HeKEY_hek(entry) = new_hek;
+           } else {
+               /* Not shared, so simply write the new hash in. */
+               HeHASH(entry) = hash;
+           }
+           /*PerlIO_printf(PerlIO_stderr(), "%d ", HeKFLAGS(entry));*/
+           HEK_REHASH_on(HeKEY_hek(entry));
+           /*PerlIO_printf(PerlIO_stderr(), "%d\n", HeKFLAGS(entry));*/
+
+           /* Copy oentry to the correct new chain.  */
+           bep = ((HE**)a) + (hash & (I32) xhv->xhv_max);
+           if (!*bep)
+                   xhv->xhv_fill++; /* HvFILL(hv)++ */
+           HeNEXT(entry) = *bep;
+           *bep = entry;
+
+           entry = next;
+       }

     }
     }

+    Safefree (xhv->xhv_array);
+    xhv->xhv_array = a;                /* HvARRAY(hv) = a */

 }
 
 void
 }
 
 void


@@ -1528,6 +1304,7 @@ Perl_newHV(pTHX)
 #ifndef NODEFAULT_SHAREKEYS
     HvSHAREKEYS_on(hv);         /* key-sharing on by default */
 #endif
 #ifndef NODEFAULT_SHAREKEYS
     HvSHAREKEYS_on(hv);         /* key-sharing on by default */
 #endif

+

     xhv->xhv_max    = 7;       /* HvMAX(hv) = 7 (start with 8 buckets) */
     xhv->xhv_fill   = 0;       /* HvFILL(hv) = 0 */
     xhv->xhv_pmroot = 0;       /* HvPMROOT(hv) = 0 */
     xhv->xhv_max    = 7;       /* HvMAX(hv) = 7 (start with 8 buckets) */
     xhv->xhv_fill   = 0;       /* HvFILL(hv) = 0 */
     xhv->xhv_pmroot = 0;       /* HvPMROOT(hv) = 0 */


@@ -1669,14 +1446,35 @@ Perl_hv_clear(pTHX_ HV *hv)
     if (!hv)
        return;
 
     if (!hv)
        return;
 

-    if(SvREADONLY(hv)) {
-        Perl_croak(aTHX_ "Attempt to clear a restricted hash");
-    }
+    DEBUG_A(Perl_hv_assert(aTHX_ hv));

 
     xhv = (XPVHV*)SvANY(hv);
 
     xhv = (XPVHV*)SvANY(hv);

+
+    if (SvREADONLY(hv) && xhv->xhv_array != NULL) {
+       /* restricted hash: convert all keys to placeholders */
+       I32 i;
+       HE* entry;
+       for (i = 0; i <= (I32) xhv->xhv_max; i++) {
+           entry = ((HE**)xhv->xhv_array)[i];
+           for (; entry; entry = HeNEXT(entry)) {
+               /* not already placeholder */
+               if (HeVAL(entry) != &PL_sv_placeholder) {
+                   if (HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
+                       SV* keysv = hv_iterkeysv(entry);
+                       Perl_croak(aTHX_
+       "Attempt to delete readonly key '%"SVf"' from a restricted hash",
+                                  keysv);
+                   }
+                   SvREFCNT_dec(HeVAL(entry));
+                   HeVAL(entry) = &PL_sv_placeholder;
+                   xhv->xhv_placeholders++; /* HvPLACEHOLDERS(hv)++ */
+               }
+           }
+       }
+       goto reset;
+    }
+

     hfreeentries(hv);
     hfreeentries(hv);

-    xhv->xhv_fill = 0; /* HvFILL(hv) = 0 */
-    xhv->xhv_keys = 0; /* HvKEYS(hv) = 0 */

     xhv->xhv_placeholders = 0; /* HvPLACEHOLDERS(hv) = 0 */
     if (xhv->xhv_array /* HvARRAY(hv) */)
        (void)memzero(xhv->xhv_array /* HvARRAY(hv) */,
     xhv->xhv_placeholders = 0; /* HvPLACEHOLDERS(hv) = 0 */
     if (xhv->xhv_array /* HvARRAY(hv) */)
        (void)memzero(xhv->xhv_array /* HvARRAY(hv) */,


@@ -1686,6 +1484,70 @@ Perl_hv_clear(pTHX_ HV *hv)
        mg_clear((SV*)hv);
 
     HvHASKFLAGS_off(hv);
        mg_clear((SV*)hv);
 
     HvHASKFLAGS_off(hv);

+    HvREHASH_off(hv);
+    reset:
+    HvEITER(hv) = NULL;
+}
+
+/*
+=for apidoc hv_clear_placeholders
+
+Clears any placeholders from a hash.  If a restricted hash has any of its keys
+marked as readonly and the key is subsequently deleted, the key is not actually
+deleted but is marked by assigning it a value of &PL_sv_placeholder.  This tags
+it so it will be ignored by future operations such as iterating over the hash,
+but will still allow the hash to have a value reassigned to the key at some
+future point.  This function clears any such placeholder keys from the hash.
+See Hash::Util::lock_keys() for an example of its use.
+
+=cut
+*/
+
+void
+Perl_hv_clear_placeholders(pTHX_ HV *hv)
+{
+    I32 items = (I32)HvPLACEHOLDERS(hv);
+    I32 i = HvMAX(hv);
+
+    if (items == 0)
+       return;
+
+    do {
+       /* Loop down the linked list heads  */
+       int first = 1;
+       HE **oentry = &(HvARRAY(hv))[i];
+       HE *entry = *oentry;
+
+       if (!entry)
+           continue;
+
+       for (; entry; entry = *oentry) {
+           if (HeVAL(entry) == &PL_sv_placeholder) {
+               *oentry = HeNEXT(entry);
+               if (first && !*oentry)
+                   HvFILL(hv)--; /* This linked list is now empty.  */
+               if (HvEITER(hv))
+                   HvLAZYDEL_on(hv);
+               else
+                   hv_free_ent(hv, entry);
+
+               if (--items == 0) {
+                   /* Finished.  */
+                   HvTOTALKEYS(hv) -= HvPLACEHOLDERS(hv);
+                   if (HvKEYS(hv) == 0)
+                       HvHASKFLAGS_off(hv);
+                   HvPLACEHOLDERS(hv) = 0;
+                   return;
+               }
+           } else {
+               oentry = &HeNEXT(entry);
+               first = 0;
+           }
+       }
+    } while (--i >= 0);
+    /* You can't get here, hence assertion should always fail.  */
+    assert (items == 0);
+    assert (0);

 }
 
 STATIC void
 }
 
 STATIC void


@@ -1705,6 +1567,12 @@ S_hfreeentries(pTHX_ HV *hv)
     riter = 0;
     max = HvMAX(hv);
     array = HvARRAY(hv);
     riter = 0;
     max = HvMAX(hv);
     array = HvARRAY(hv);

+    /* make everyone else think the array is empty, so that the destructors
+     * called for freed entries can't recusively mess with us */
+    HvARRAY(hv) = Null(HE**); 
+    HvFILL(hv) = 0;
+    ((XPVHV*) SvANY(hv))->xhv_keys = 0;
+

     entry = array[0];
     for (;;) {
        if (entry) {
     entry = array[0];
     for (;;) {
        if (entry) {


@@ -1718,6 +1586,7 @@ S_hfreeentries(pTHX_ HV *hv)
            entry = array[riter];
        }
     }
            entry = array[riter];
        }
     }

+    HvARRAY(hv) = array;

     (void)hv_iterinit(hv);
 }
 
     (void)hv_iterinit(hv);
 }
 


@@ -1735,6 +1604,7 @@ Perl_hv_undef(pTHX_ HV *hv)
     register XPVHV* xhv;
     if (!hv)
        return;
     register XPVHV* xhv;
     if (!hv)
        return;

+    DEBUG_A(Perl_hv_assert(aTHX_ hv));

     xhv = (XPVHV*)SvANY(hv);
     hfreeentries(hv);
     Safefree(xhv->xhv_array /* HvARRAY(hv) */);
     xhv = (XPVHV*)SvANY(hv);
     hfreeentries(hv);
     Safefree(xhv->xhv_array /* HvARRAY(hv) */);


@@ -1746,8 +1616,6 @@ Perl_hv_undef(pTHX_ HV *hv)
     }
     xhv->xhv_max   = 7;        /* HvMAX(hv) = 7 (it's a normal hash) */
     xhv->xhv_array = 0;        /* HvARRAY(hv) = 0 */
     }
     xhv->xhv_max   = 7;        /* HvMAX(hv) = 7 (it's a normal hash) */
     xhv->xhv_array = 0;        /* HvARRAY(hv) = 0 */

-    xhv->xhv_fill  = 0;        /* HvFILL(hv) = 0 */
-    xhv->xhv_keys  = 0;        /* HvKEYS(hv) = 0 */

     xhv->xhv_placeholders = 0; /* HvPLACEHOLDERS(hv) = 0 */
 
     if (SvRMAGICAL(hv))
     xhv->xhv_placeholders = 0; /* HvPLACEHOLDERS(hv) = 0 */
 
     if (SvRMAGICAL(hv))


@@ -1817,9 +1685,8 @@ Returns entries from a hash iterator.  See C<hv_iterinit> and C<hv_iternext>.
 The C<flags> value will normally be zero; if HV_ITERNEXT_WANTPLACEHOLDERS is
 set the placeholders keys (for restricted hashes) will be returned in addition
 to normal keys. By default placeholders are automatically skipped over.
 The C<flags> value will normally be zero; if HV_ITERNEXT_WANTPLACEHOLDERS is
 set the placeholders keys (for restricted hashes) will be returned in addition
 to normal keys. By default placeholders are automatically skipped over.

-Currently a placeholder is implemented with a value that is literally
-<&Perl_sv_undef> (a regular C<undef> value is a normal read-write SV for which
-C<!SvOK> is false). Note that the implementation of placeholders and
+Currently a placeholder is implemented with a value that is
+C<&Perl_sv_placeholder>. Note that the implementation of placeholders and

 restricted hashes may change, and the implementation currently is
 insufficiently abstracted for any change to be tidy.
 
 restricted hashes may change, and the implementation currently is
 insufficiently abstracted for any change to be tidy.
 


@@ -1888,7 +1755,7 @@ Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags)
              * Skip past any placeholders -- don't want to include them in
              * any iteration.
              */
              * Skip past any placeholders -- don't want to include them in
              * any iteration.
              */

-            while (entry && HeVAL(entry) == &PL_sv_undef) {
+            while (entry && HeVAL(entry) == &PL_sv_placeholder) {

                 entry = HeNEXT(entry);
             }
        }
                 entry = HeNEXT(entry);
             }
        }


@@ -1908,7 +1775,7 @@ Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags)
         if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
             /* If we have an entry, but it's a placeholder, don't count it.
               Try the next.  */
         if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
             /* If we have an entry, but it's a placeholder, don't count it.
               Try the next.  */

-           while (entry && HeVAL(entry) == &PL_sv_undef)
+           while (entry && HeVAL(entry) == &PL_sv_placeholder)

                entry = HeNEXT(entry);
        }
        /* Will loop again if this linked list starts NULL
                entry = HeNEXT(entry);
        }
        /* Will loop again if this linked list starts NULL


@@ -1921,6 +1788,9 @@ Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags)
        hv_free_ent(hv, oldentry);
     }
 
        hv_free_ent(hv, oldentry);
     }
 

+    /*if (HvREHASH(hv) && entry && !HeKREHASH(entry))
+      PerlIO_printf(PerlIO_stderr(), "Awooga %p %p\n", hv, entry);*/
+

     xhv->xhv_eiter = entry; /* HvEITER(hv) = entry */
     return entry;
 }
     xhv->xhv_eiter = entry; /* HvEITER(hv) = entry */
     return entry;
 }


@@ -1978,7 +1848,17 @@ Perl_hv_iterkeysv(pTHX_ register HE *entry)
             sv = newSVpvn ((char*)as_utf8, utf8_len);
             SvUTF8_on (sv);
            Safefree (as_utf8); /* bytes_to_utf8() allocates a new string */
             sv = newSVpvn ((char*)as_utf8, utf8_len);
             SvUTF8_on (sv);
            Safefree (as_utf8); /* bytes_to_utf8() allocates a new string */

-        } else {
+       } else if (flags & HVhek_REHASH) {
+           /* We don't have a pointer to the hv, so we have to replicate the
+              flag into every HEK. This hv is using custom a hasing
+              algorithm. Hence we can't return a shared string scalar, as
+              that would contain the (wrong) hash value, and might get passed
+              into an hv routine with a regular hash  */
+
+            sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek));
+           if (HEK_UTF8(hek))
+               SvUTF8_on (sv);
+       } else {

             sv = newSVpvn_share(HEK_KEY(hek),
                                 (HEK_UTF8(hek) ? -HEK_LEN(hek) : HEK_LEN(hek)),
                                 HEK_HASH(hek));
             sv = newSVpvn_share(HEK_KEY(hek),
                                 (HEK_UTF8(hek) ? -HEK_LEN(hek) : HEK_LEN(hek)),
                                 HEK_HASH(hek));


@@ -2148,9 +2028,10 @@ S_unshare_hek_or_pvn(pTHX_ HEK *hek, const char *str, I32 len, U32 hash)
     UNLOCK_STRTAB_MUTEX;
     if (!found && ckWARN_d(WARN_INTERNAL))
        Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
     UNLOCK_STRTAB_MUTEX;
     if (!found && ckWARN_d(WARN_INTERNAL))
        Perl_warner(aTHX_ packWARN(WARN_INTERNAL),

-                    "Attempt to free non-existent shared string '%s'%s",
+                    "Attempt to free non-existent shared string '%s'%s"
+                    pTHX__FORMAT,

                     hek ? HEK_KEY(hek) : str,
                     hek ? HEK_KEY(hek) : str,

-                    (k_flags & HVhek_UTF8) ? " (utf8)" : "");
+                    ((k_flags & HVhek_UTF8) ? " (utf8)" : "") pTHX__VALUE);

     if (k_flags & HVhek_FREEKEY)
        Safefree(str);
 }
     if (k_flags & HVhek_FREEKEY)
        Safefree(str);
 }


@@ -2200,6 +2081,9 @@ S_share_hek_flags(pTHX_ const char *str, I32 len, register U32 hash, int flags)
 
     if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
        hv_store(PL_strtab, str, len, Nullsv, hash);
 
     if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
        hv_store(PL_strtab, str, len, Nullsv, hash);

+
+       Can't rehash the shared string table, so not sure if it's worth
+       counting the number of entries in the linked list

     */
     xhv = (XPVHV*)SvANY(PL_strtab);
     /* assert(xhv_array != 0) */
     */
     xhv = (XPVHV*)SvANY(PL_strtab);
     /* assert(xhv_array != 0) */


@@ -2220,14 +2104,14 @@ S_share_hek_flags(pTHX_ const char *str, I32 len, register U32 hash, int flags)
     }
     if (!found) {
        entry = new_HE();
     }
     if (!found) {
        entry = new_HE();

-       HeKEY_hek(entry) = save_hek_flags(str, len, hash, flags);
+       HeKEY_hek(entry) = save_hek_flags(str, len, hash, flags_masked);

        HeVAL(entry) = Nullsv;
        HeNEXT(entry) = *oentry;
        *oentry = entry;
        xhv->xhv_keys++; /* HvKEYS(hv)++ */
        if (i) {                                /* initial entry? */
            xhv->xhv_fill++; /* HvFILL(hv)++ */
        HeVAL(entry) = Nullsv;
        HeNEXT(entry) = *oentry;
        *oentry = entry;
        xhv->xhv_keys++; /* HvKEYS(hv)++ */
        if (i) {                                /* initial entry? */
            xhv->xhv_fill++; /* HvFILL(hv)++ */

-           if (xhv->xhv_keys > (IV)xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */)
+       } else if (xhv->xhv_keys > (IV)xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */) {

                hsplit(PL_strtab);
        }
     }
                hsplit(PL_strtab);
        }
     }


@@ -2240,3 +2124,83 @@ S_share_hek_flags(pTHX_ const char *str, I32 len, register U32 hash, int flags)
 
     return HeKEY_hek(entry);
 }
 
     return HeKEY_hek(entry);
 }

+
+
+/*
+=for apidoc hv_assert
+
+Check that a hash is in an internally consistent state.
+
+=cut
+*/
+
+void
+Perl_hv_assert(pTHX_ HV *hv)
+{
+  HE* entry;
+  int withflags = 0;
+  int placeholders = 0;
+  int real = 0;
+  int bad = 0;
+  I32 riter = HvRITER(hv);
+  HE *eiter = HvEITER(hv);
+
+  (void)hv_iterinit(hv);
+
+  while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))) {
+    /* sanity check the values */
+    if (HeVAL(entry) == &PL_sv_placeholder) {
+      placeholders++;
+    } else {
+      real++;
+    }
+    /* sanity check the keys */
+    if (HeSVKEY(entry)) {
+      /* Don't know what to check on SV keys.  */
+    } else if (HeKUTF8(entry)) {
+      withflags++;
+       if (HeKWASUTF8(entry)) {
+        PerlIO_printf(Perl_debug_log,
+                      "hash key has both WASUFT8 and UTF8: '%.*s'\n",
+                      (int) HeKLEN(entry),  HeKEY(entry));
+        bad = 1;
+       }
+    } else if (HeKWASUTF8(entry)) {
+      withflags++;
+    }
+  }
+  if (!SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) {
+    if (HvUSEDKEYS(hv) != real) {
+      PerlIO_printf(Perl_debug_log, "Count %d key(s), but hash reports %d\n",
+                   (int) real, (int) HvUSEDKEYS(hv));
+      bad = 1;
+    }
+    if (HvPLACEHOLDERS(hv) != placeholders) {
+      PerlIO_printf(Perl_debug_log,
+                   "Count %d placeholder(s), but hash reports %d\n",
+                   (int) placeholders, (int) HvPLACEHOLDERS(hv));
+      bad = 1;
+    }
+  }
+  if (withflags && ! HvHASKFLAGS(hv)) {
+    PerlIO_printf(Perl_debug_log,
+                 "Hash has HASKFLAGS off but I count %d key(s) with flags\n",
+                 withflags);
+    bad = 1;
+  }
+  if (bad) {
+    sv_dump((SV *)hv);
+  }
+  HvRITER(hv) = riter;         /* Restore hash iterator state */
+  HvEITER(hv) = eiter;
+}
+
+/*
+ * Local variables:
+ * c-indentation-style: bsd
+ * c-basic-offset: 4
+ * indent-tabs-mode: t
+ * End:
+ *
+ * vim: shiftwidth=4:
+*/