hv.c

   1 /*    hv.c
   2  *
   3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
   4  *    2000, 2001, 2002, 2003, by Larry Wall and others
   5  *
   6  *    You may distribute under the terms of either the GNU General Public
   7  *    License or the Artistic License, as specified in the README file.
   8  *
   9  */
  10
  11 /*
  12  * "I sit beside the fire and think of all that I have seen."  --Bilbo
  13  */
  14
  15 /*
  16 =head1 Hash Manipulation Functions
  17 */
  18
  19 #include "EXTERN.h"
  20 #define PERL_IN_HV_C
  21 #define PERL_HASH_INTERNAL_ACCESS
  22 #include "perl.h"
  23
  24 #define HV_MAX_LENGTH_BEFORE_SPLIT 14
  25
  26 STATIC HE*
  27 S_new_he(pTHX)
  28 {
  29     HE* he;
  30     LOCK_SV_MUTEX;
  31     if (!PL_he_root)
  32         more_he();
  33     he = PL_he_root;
  34     PL_he_root = HeNEXT(he);
  35     UNLOCK_SV_MUTEX;
  36     return he;
  37 }
  38
  39 STATIC void
  40 S_del_he(pTHX_ HE *p)
  41 {
  42     LOCK_SV_MUTEX;
  43     HeNEXT(p) = (HE*)PL_he_root;
  44     PL_he_root = p;
  45     UNLOCK_SV_MUTEX;
  46 }
  47
  48 STATIC void
  49 S_more_he(pTHX)
  50 {
  51     register HE* he;
  52     register HE* heend;
  53     XPV *ptr;
  54     New(54, ptr, 1008/sizeof(XPV), XPV);
  55     ptr->xpv_pv = (char*)PL_he_arenaroot;
  56     PL_he_arenaroot = ptr;
  57
  58     he = (HE*)ptr;
  59     heend = &he[1008 / sizeof(HE) - 1];
  60     PL_he_root = ++he;
  61     while (he < heend) {
  62         HeNEXT(he) = (HE*)(he + 1);
  63         he++;
  64     }
  65     HeNEXT(he) = 0;
  66 }
  67
  68 #ifdef PURIFY
  69
  70 #define new_HE() (HE*)safemalloc(sizeof(HE))
  71 #define del_HE(p) safefree((char*)p)
  72
  73 #else
  74
  75 #define new_HE() new_he()
  76 #define del_HE(p) del_he(p)
  77
  78 #endif
  79
  80 STATIC HEK *
  81 S_save_hek_flags(pTHX_ const char *str, I32 len, U32 hash, int flags)
  82 {
  83     char *k;
  84     register HEK *hek;
  85
  86     New(54, k, HEK_BASESIZE + len + 2, char);
  87     hek = (HEK*)k;
  88     Copy(str, HEK_KEY(hek), len, char);
  89     HEK_KEY(hek)[len] = 0;
  90     HEK_LEN(hek) = len;
  91     HEK_HASH(hek) = hash;
  92     HEK_FLAGS(hek) = (unsigned char)flags;
  93     return hek;
  94 }
  95
  96 /* free the pool of temporary HE/HEK pairs retunrned by hv_fetch_ent
  97  * for tied hashes */
  98
  99 void
 100 Perl_free_tied_hv_pool(pTHX)
 101 {
 102     HE *ohe;
 103     HE *he = PL_hv_fetch_ent_mh;
 104     while (he) {
 105         Safefree(HeKEY_hek(he));
 106         ohe = he;
 107         he = HeNEXT(he);
 108         del_HE(ohe);
 109     }
 110     PL_hv_fetch_ent_mh = Nullhe;
 111 }
 112
 113 #if defined(USE_ITHREADS)
 114 HE *
 115 Perl_he_dup(pTHX_ HE *e, bool shared, CLONE_PARAMS* param)
 116 {
 117     HE *ret;
 118
 119     if (!e)
 120         return Nullhe;
 121     /* look for it in the table first */
 122     ret = (HE*)ptr_table_fetch(PL_ptr_table, e);
 123     if (ret)
 124         return ret;
 125
 126     /* create anew and remember what it is */
 127     ret = new_HE();
 128     ptr_table_store(PL_ptr_table, e, ret);
 129
 130     HeNEXT(ret) = he_dup(HeNEXT(e),shared, param);
 131     if (HeKLEN(e) == HEf_SVKEY) {
 132         char *k;
 133         New(54, k, HEK_BASESIZE + sizeof(SV*), char);
 134         HeKEY_hek(ret) = (HEK*)k;
 135         HeKEY_sv(ret) = SvREFCNT_inc(sv_dup(HeKEY_sv(e), param));
 136     }
 137     else if (shared)
 138         HeKEY_hek(ret) = share_hek_flags(HeKEY(e), HeKLEN(e), HeHASH(e),
 139                                          HeKFLAGS(e));
 140     else
 141         HeKEY_hek(ret) = save_hek_flags(HeKEY(e), HeKLEN(e), HeHASH(e),
 142                                         HeKFLAGS(e));
 143     HeVAL(ret) = SvREFCNT_inc(sv_dup(HeVAL(e), param));
 144     return ret;
 145 }
 146 #endif  /* USE_ITHREADS */
 147
 148 static void
 149 S_hv_notallowed(pTHX_ int flags, const char *key, I32 klen,
 150                 const char *msg)
 151 {
 152     SV *sv = sv_newmortal(), *esv = sv_newmortal();
 153     if (!(flags & HVhek_FREEKEY)) {
 154         sv_setpvn(sv, key, klen);
 155     }
 156     else {
 157         /* Need to free saved eventually assign to mortal SV */
 158         /* XXX is this line an error ???:  SV *sv = sv_newmortal(); */
 159         sv_usepvn(sv, (char *) key, klen);
 160     }
 161     if (flags & HVhek_UTF8) {
 162         SvUTF8_on(sv);
 163     }
 164     Perl_sv_setpvf(aTHX_ esv, "Attempt to %s a restricted hash", msg);
 165     Perl_croak(aTHX_ SvPVX(esv), sv);
 166 }
 167
 168 /* (klen == HEf_SVKEY) is special for MAGICAL hv entries, meaning key slot
 169  * contains an SV* */
 170
 171 /*
 172 =for apidoc hv_fetch
 173
 174 Returns the SV which corresponds to the specified key in the hash.  The
 175 C<klen> is the length of the key.  If C<lval> is set then the fetch will be
 176 part of a store.  Check that the return value is non-null before
 177 dereferencing it to an C<SV*>.
 178
 179 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
 180 information on how to use this function on tied hashes.
 181
 182 =cut
 183 */
 184
 185
 186 SV**
 187 Perl_hv_fetch(pTHX_ HV *hv, const char *key, I32 klen, I32 lval)
 188 {
 189     bool is_utf8 = FALSE;
 190     const char *keysave = key;
 191     int flags = 0;
 192
 193     if (klen < 0) {
 194       klen = -klen;
 195       is_utf8 = TRUE;
 196     }
 197
 198     if (is_utf8) {
 199         STRLEN tmplen = klen;
 200         /* Just casting the &klen to (STRLEN) won't work well
 201          * if STRLEN and I32 are of different widths. --jhi */
 202         key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
 203         klen = tmplen;
 204         /* If we were able to downgrade here, then than means that we were
 205            passed in a key which only had chars 0-255, but was utf8 encoded.  */
 206         if (is_utf8)
 207             flags = HVhek_UTF8;
 208         /* If we found we were able to downgrade the string to bytes, then
 209            we should flag that it needs upgrading on keys or each.  */
 210         if (key != keysave)
 211             flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
 212     }
 213
 214     return hv_fetch_flags (hv, key, klen, lval, flags);
 215 }
 216
 217 STATIC SV**
 218 S_hv_fetch_flags(pTHX_ HV *hv, const char *key, I32 klen, I32 lval, int flags)
 219 {
 220     register XPVHV* xhv;
 221     register U32 hash;
 222     register HE *entry;
 223     SV *sv;
 224
 225     if (!hv)
 226         return 0;
 227
 228     if (SvRMAGICAL(hv)) {
 229         if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
 230             sv = sv_newmortal();
 231             sv_upgrade(sv, SVt_PVLV);
 232             if (flags & HVhek_UTF8) {
 233                 /* This hack based on the code in hv_exists_ent seems to be
 234                    the easiest way to pass the utf8 flag through and fix
 235                    the bug in hv_exists for tied hashes with utf8 keys.  */
 236                 SV *keysv = sv_2mortal(newSVpvn(key, klen));
 237                 SvUTF8_on(keysv);
 238                 mg_copy((SV*)hv, sv, (char *)keysv, HEf_SVKEY);
 239             } else {
 240                 mg_copy((SV*)hv, sv, key, klen);
 241             }
 242             if (flags & HVhek_FREEKEY)
 243                 Safefree(key);
 244             LvTYPE(sv) = 't';
 245             LvTARG(sv) = sv; /* fake (SV**) */
 246             return &(LvTARG(sv));
 247         }
 248 #ifdef ENV_IS_CASELESS
 249         else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
 250             I32 i;
 251             for (i = 0; i < klen; ++i)
 252                 if (isLOWER(key[i])) {
 253                     char *nkey = strupr(SvPVX(sv_2mortal(newSVpvn(key,klen))));
 254                     SV **ret = hv_fetch(hv, nkey, klen, 0);
 255                     if (!ret && lval) {
 256                         ret = hv_store_flags(hv, key, klen, NEWSV(61,0), 0,
 257                                              flags);
 258                     } else if (flags & HVhek_FREEKEY)
 259                         Safefree(key);
 260                     return ret;
 261                 }
 262         }
 263 #endif
 264     }
 265
 266     /* We use xhv->xhv_foo fields directly instead of HvFOO(hv) to
 267        avoid unnecessary pointer dereferencing. */
 268     xhv = (XPVHV*)SvANY(hv);
 269     if (!xhv->xhv_array /* !HvARRAY(hv) */) {
 270         if (lval
 271 #ifdef DYNAMIC_ENV_FETCH  /* if it's an %ENV lookup, we may get it on the fly */
 272                  || (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
 273 #endif
 274                                                                   )
 275             Newz(503, xhv->xhv_array /* HvARRAY(hv) */,
 276                  PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
 277                  char);
 278         else {
 279             if (flags & HVhek_FREEKEY)
 280                 Safefree(key);
 281             return 0;
 282         }
 283     }
 284
 285     if (HvREHASH(hv)) {
 286         PERL_HASH_INTERNAL(hash, key, klen);
 287         /* Yes, you do need this even though you are not "storing" because
 288            you can flip the flags below if doing an lval lookup.  (And that
 289            was put in to give the semantics Andreas was expecting.)  */
 290         flags |= HVhek_REHASH;
 291     } else {
 292         PERL_HASH(hash, key, klen);
 293     }
 294
 295     /* entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
 296     entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
 297     for (; entry; entry = HeNEXT(entry)) {
 298         if (!HeKEY_hek(entry))
 299             continue;
 300         if (HeHASH(entry) != hash)              /* strings can't be equal */
 301             continue;
 302         if (HeKLEN(entry) != (I32)klen)
 303             continue;
 304         if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen))        /* is this it? */
 305             continue;
 306         /* flags is 0 if not utf8. need HeKFLAGS(entry) also 0.
 307            flags is 1 if utf8. need HeKFLAGS(entry) also 1.
 308            xor is true if bits differ, in which case this isn't a match.  */
 309         if ((HeKFLAGS(entry) ^ flags) & HVhek_UTF8)
 310             continue;
 311         if (lval && HeKFLAGS(entry) != flags) {
 312             /* We match if HVhek_UTF8 bit in our flags and hash key's match.
 313                But if entry was set previously with HVhek_WASUTF8 and key now
 314                doesn't (or vice versa) then we should change the key's flag,
 315                as this is assignment.  */
 316             if (HvSHAREKEYS(hv)) {
 317                 /* Need to swap the key we have for a key with the flags we
 318                    need. As keys are shared we can't just write to the flag,
 319                    so we share the new one, unshare the old one.  */
 320                 int flags_nofree = flags & ~HVhek_FREEKEY;
 321                 HEK *new_hek = share_hek_flags(key, klen, hash, flags_nofree);
 322                 unshare_hek (HeKEY_hek(entry));
 323                 HeKEY_hek(entry) = new_hek;
 324             }
 325             else
 326                 HeKFLAGS(entry) = flags;
 327             if (flags & HVhek_ENABLEHVKFLAGS)
 328                 HvHASKFLAGS_on(hv);
 329         }
 330         if (flags & HVhek_FREEKEY)
 331             Safefree(key);
 332         /* if we find a placeholder, we pretend we haven't found anything */
 333         if (HeVAL(entry) == &PL_sv_placeholder)
 334             break;
 335         return &HeVAL(entry);
 336
 337     }
 338 #ifdef DYNAMIC_ENV_FETCH  /* %ENV lookup?  If so, try to fetch the value now */
 339     if (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
 340         unsigned long len;
 341         char *env = PerlEnv_ENVgetenv_len(key,&len);
 342         if (env) {
 343             sv = newSVpvn(env,len);
 344             SvTAINTED_on(sv);
 345             if (flags & HVhek_FREEKEY)
 346                 Safefree(key);
 347             return hv_store(hv,key,klen,sv,hash);
 348         }
 349     }
 350 #endif
 351     if (!entry && SvREADONLY(hv)) {
 352         S_hv_notallowed(aTHX_ flags, key, klen,
 353                         "access disallowed key '%"SVf"' in"
 354                         );
 355     }
 356     if (lval) {         /* gonna assign to this, so it better be there */
 357         sv = NEWSV(61,0);
 358         return hv_store_flags(hv,key,klen,sv,hash,flags);
 359     }
 360     if (flags & HVhek_FREEKEY)
 361         Safefree(key);
 362     return 0;
 363 }
 364
 365 /* returns an HE * structure with the all fields set */
 366 /* note that hent_val will be a mortal sv for MAGICAL hashes */
 367 /*
 368 =for apidoc hv_fetch_ent
 369
 370 Returns the hash entry which corresponds to the specified key in the hash.
 371 C<hash> must be a valid precomputed hash number for the given C<key>, or 0
 372 if you want the function to compute it.  IF C<lval> is set then the fetch
 373 will be part of a store.  Make sure the return value is non-null before
 374 accessing it.  The return value when C<tb> is a tied hash is a pointer to a
 375 static location, so be sure to make a copy of the structure if you need to
 376 store it somewhere.
 377
 378 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
 379 information on how to use this function on tied hashes.
 380
 381 =cut
 382 */
 383
 384 HE *
 385 Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash)
 386 {
 387     register XPVHV* xhv;
 388     register char *key;
 389     STRLEN klen;
 390     register HE *entry;
 391     SV *sv;
 392     bool is_utf8;
 393     int flags = 0;
 394     char *keysave;
 395
 396     if (!hv)
 397         return 0;
 398
 399     if (SvRMAGICAL(hv)) {
 400         if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
 401             sv = sv_newmortal();
 402             keysv = newSVsv(keysv);
 403             mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY);
 404             /* grab a fake HE/HEK pair from the pool or make a new one */
 405             entry = PL_hv_fetch_ent_mh;
 406             if (entry)
 407                 PL_hv_fetch_ent_mh = HeNEXT(entry);
 408             else {
 409                 char *k;
 410                 entry = new_HE();
 411                 New(54, k, HEK_BASESIZE + sizeof(SV*), char);
 412                 HeKEY_hek(entry) = (HEK*)k;
 413             }
 414             HeNEXT(entry) = Nullhe;
 415             HeSVKEY_set(entry, keysv);
 416             HeVAL(entry) = sv;
 417             sv_upgrade(sv, SVt_PVLV);
 418             LvTYPE(sv) = 'T';
 419             LvTARG(sv) = (SV*)entry; /* so we can free entry when freeing sv */
 420             return entry;
 421         }
 422 #ifdef ENV_IS_CASELESS
 423         else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
 424             U32 i;
 425             key = SvPV(keysv, klen);
 426             for (i = 0; i < klen; ++i)
 427                 if (isLOWER(key[i])) {
 428                     SV *nkeysv = sv_2mortal(newSVpvn(key,klen));
 429                     (void)strupr(SvPVX(nkeysv));
 430                     entry = hv_fetch_ent(hv, nkeysv, 0, 0);
 431                     if (!entry && lval)
 432                         entry = hv_store_ent(hv, keysv, NEWSV(61,0), hash);
 433                     return entry;
 434                 }
 435         }
 436 #endif
 437     }
 438
 439     keysave = key = SvPV(keysv, klen);
 440     xhv = (XPVHV*)SvANY(hv);
 441     if (!xhv->xhv_array /* !HvARRAY(hv) */) {
 442         if (lval
 443 #ifdef DYNAMIC_ENV_FETCH  /* if it's an %ENV lookup, we may get it on the fly */
 444                  || (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
 445 #endif
 446                                                                   )
 447             Newz(503, xhv->xhv_array /* HvARRAY(hv) */,
 448                  PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
 449                  char);
 450         else
 451             return 0;
 452     }
 453
 454     is_utf8 = (SvUTF8(keysv)!=0);
 455
 456     if (is_utf8) {
 457         key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
 458         if (is_utf8)
 459             flags = HVhek_UTF8;
 460         if (key != keysave)
 461             flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
 462     }
 463
 464     if (HvREHASH(hv)) {
 465         PERL_HASH_INTERNAL(hash, key, klen);
 466         /* Yes, you do need this even though you are not "storing" because
 467            you can flip the flags below if doing an lval lookup.  (And that
 468            was put in to give the semantics Andreas was expecting.)  */
 469         flags |= HVhek_REHASH;
 470     } else if (!hash) {
 471         if SvIsCOW_shared_hash(keysv) {
 472             hash = SvUVX(keysv);
 473         } else {
 474             PERL_HASH(hash, key, klen);
 475         }
 476     }
 477
 478     /* entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
 479     entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
 480     for (; entry; entry = HeNEXT(entry)) {
 481         if (HeHASH(entry) != hash)              /* strings can't be equal */
 482             continue;
 483         if (HeKLEN(entry) != (I32)klen)
 484             continue;
 485         if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen))        /* is this it? */
 486             continue;
 487         if ((HeKFLAGS(entry) ^ flags) & HVhek_UTF8)
 488             continue;
 489         if (lval && HeKFLAGS(entry) != flags) {
 490             /* We match if HVhek_UTF8 bit in our flags and hash key's match.
 491                But if entry was set previously with HVhek_WASUTF8 and key now
 492                doesn't (or vice versa) then we should change the key's flag,
 493                as this is assignment.  */
 494             if (HvSHAREKEYS(hv)) {
 495                 /* Need to swap the key we have for a key with the flags we
 496                    need. As keys are shared we can't just write to the flag,
 497                    so we share the new one, unshare the old one.  */
 498                 int flags_nofree = flags & ~HVhek_FREEKEY;
 499                 HEK *new_hek = share_hek_flags(key, klen, hash, flags_nofree);
 500                 unshare_hek (HeKEY_hek(entry));
 501                 HeKEY_hek(entry) = new_hek;
 502             }
 503             else
 504                 HeKFLAGS(entry) = flags;
 505             if (flags & HVhek_ENABLEHVKFLAGS)
 506                 HvHASKFLAGS_on(hv);
 507         }
 508         if (key != keysave)
 509             Safefree(key);
 510         /* if we find a placeholder, we pretend we haven't found anything */
 511         if (HeVAL(entry) == &PL_sv_placeholder)
 512             break;
 513         return entry;
 514     }
 515 #ifdef DYNAMIC_ENV_FETCH  /* %ENV lookup?  If so, try to fetch the value now */
 516     if (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
 517         unsigned long len;
 518         char *env = PerlEnv_ENVgetenv_len(key,&len);
 519         if (env) {
 520             sv = newSVpvn(env,len);
 521             SvTAINTED_on(sv);
 522             return hv_store_ent(hv,keysv,sv,hash);
 523         }
 524     }
 525 #endif
 526     if (!entry && SvREADONLY(hv)) {
 527         S_hv_notallowed(aTHX_ flags, key, klen,
 528                         "access disallowed key '%"SVf"' in"
 529                         );
 530     }
 531     if (flags & HVhek_FREEKEY)
 532         Safefree(key);
 533     if (lval) {         /* gonna assign to this, so it better be there */
 534         sv = NEWSV(61,0);
 535         return hv_store_ent(hv,keysv,sv,hash);
 536     }
 537     return 0;
 538 }
 539
 540 STATIC void
 541 S_hv_magic_check(pTHX_ HV *hv, bool *needs_copy, bool *needs_store)
 542 {
 543     MAGIC *mg = SvMAGIC(hv);
 544     *needs_copy = FALSE;
 545     *needs_store = TRUE;
 546     while (mg) {
 547         if (isUPPER(mg->mg_type)) {
 548             *needs_copy = TRUE;
 549             switch (mg->mg_type) {
 550             case PERL_MAGIC_tied:
 551             case PERL_MAGIC_sig:
 552                 *needs_store = FALSE;
 553             }
 554         }
 555         mg = mg->mg_moremagic;
 556     }
 557 }
 558
 559 /*
 560 =for apidoc hv_store
 561
 562 Stores an SV in a hash.  The hash key is specified as C<key> and C<klen> is
 563 the length of the key.  The C<hash> parameter is the precomputed hash
 564 value; if it is zero then Perl will compute it.  The return value will be
 565 NULL if the operation failed or if the value did not need to be actually
 566 stored within the hash (as in the case of tied hashes).  Otherwise it can
 567 be dereferenced to get the original C<SV*>.  Note that the caller is
 568 responsible for suitably incrementing the reference count of C<val> before
 569 the call, and decrementing it if the function returned NULL.  Effectively
 570 a successful hv_store takes ownership of one reference to C<val>.  This is
 571 usually what you want; a newly created SV has a reference count of one, so
 572 if all your code does is create SVs then store them in a hash, hv_store
 573 will own the only reference to the new SV, and your code doesn't need to do
 574 anything further to tidy up.  hv_store is not implemented as a call to
 575 hv_store_ent, and does not create a temporary SV for the key, so if your
 576 key data is not already in SV form then use hv_store in preference to
 577 hv_store_ent.
 578
 579 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
 580 information on how to use this function on tied hashes.
 581
 582 =cut
 583 */
 584
 585 SV**
 586 Perl_hv_store(pTHX_ HV *hv, const char *key, I32 klen, SV *val, U32 hash)
 587 {
 588     bool is_utf8 = FALSE;
 589     const char *keysave = key;
 590     int flags = 0;
 591
 592     if (klen < 0) {
 593       klen = -klen;
 594       is_utf8 = TRUE;
 595     }
 596
 597     if (is_utf8) {
 598         STRLEN tmplen = klen;
 599         /* Just casting the &klen to (STRLEN) won't work well
 600          * if STRLEN and I32 are of different widths. --jhi */
 601         key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
 602         klen = tmplen;
 603         /* If we were able to downgrade here, then than means that we were
 604            passed in a key which only had chars 0-255, but was utf8 encoded.  */
 605         if (is_utf8)
 606             flags = HVhek_UTF8;
 607         /* If we found we were able to downgrade the string to bytes, then
 608            we should flag that it needs upgrading on keys or each.  */
 609         if (key != keysave)
 610             flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
 611     }
 612
 613     return hv_store_flags (hv, key, klen, val, hash, flags);
 614 }
 615
 616 SV**
 617 Perl_hv_store_flags(pTHX_ HV *hv, const char *key, I32 klen, SV *val,
 618                  register U32 hash, int flags)
 619 {
 620     register XPVHV* xhv;
 621     register U32 n_links;
 622     register HE *entry;
 623     register HE **oentry;
 624
 625     if (!hv)
 626         return 0;
 627
 628     xhv = (XPVHV*)SvANY(hv);
 629     if (SvMAGICAL(hv)) {
 630         bool needs_copy;
 631         bool needs_store;
 632         hv_magic_check (hv, &needs_copy, &needs_store);
 633         if (needs_copy) {
 634             if (flags & HVhek_UTF8) {
 635                 /* This hack based on the code in hv_exists_ent seems to be
 636                    the easiest way to pass the utf8 flag through and fix
 637                    the bug in hv_exists for tied hashes with utf8 keys.  */
 638                 SV *keysv = sv_2mortal(newSVpvn(key, klen));
 639                 SvUTF8_on(keysv);
 640                 mg_copy((SV*)hv, val, (char *)keysv, HEf_SVKEY);
 641             } else {
 642                 mg_copy((SV*)hv, val, key, klen);
 643             }
 644             if (!xhv->xhv_array /* !HvARRAY */ && !needs_store) {
 645                 if (flags & HVhek_FREEKEY)
 646                     Safefree(key);
 647                 return 0;
 648             }
 649 #ifdef ENV_IS_CASELESS
 650             else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
 651                 key = savepvn(key,klen);
 652                 key = (const char*)strupr((char*)key);
 653                 hash = 0;
 654             }
 655 #endif
 656         }
 657     }
 658
 659     if (flags)
 660         HvHASKFLAGS_on((SV*)hv);
 661
 662     if (HvREHASH(hv)) {
 663         /* We don't have a pointer to the hv, so we have to replicate the
 664            flag into every HEK, so that hv_iterkeysv can see it.  */
 665         flags |= HVhek_REHASH;
 666         PERL_HASH_INTERNAL(hash, key, klen);
 667     } else if (!hash)
 668         PERL_HASH(hash, key, klen);
 669
 670     if (!xhv->xhv_array /* !HvARRAY(hv) */)
 671         Newz(505, xhv->xhv_array /* HvARRAY(hv) */,
 672              PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
 673              char);
 674
 675     /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
 676     oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
 677
 678     n_links = 0;
 679
 680     for (entry = *oentry; entry; ++n_links, entry = HeNEXT(entry)) {
 681         if (HeHASH(entry) != hash)              /* strings can't be equal */
 682             continue;
 683         if (HeKLEN(entry) != (I32)klen)
 684             continue;
 685         if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen))        /* is this it? */
 686             continue;
 687         if ((HeKFLAGS(entry) ^ flags) & HVhek_UTF8)
 688             continue;
 689         if (HeVAL(entry) == &PL_sv_placeholder)
 690             xhv->xhv_placeholders--; /* yes, can store into placeholder slot */
 691         else
 692             SvREFCNT_dec(HeVAL(entry));
 693         if (flags & HVhek_PLACEHOLD) {
 694             /* We have been requested to insert a placeholder. Currently
 695                only Storable is allowed to do this.  */
 696             xhv->xhv_placeholders++;
 697             HeVAL(entry) = &PL_sv_placeholder;
 698         } else
 699             HeVAL(entry) = val;
 700
 701         if (HeKFLAGS(entry) != flags) {
 702             /* We match if HVhek_UTF8 bit in our flags and hash key's match.
 703                But if entry was set previously with HVhek_WASUTF8 and key now
 704                doesn't (or vice versa) then we should change the key's flag,
 705                as this is assignment.  */
 706             if (HvSHAREKEYS(hv)) {
 707                 /* Need to swap the key we have for a key with the flags we
 708                    need. As keys are shared we can't just write to the flag,
 709                    so we share the new one, unshare the old one.  */
 710                 int flags_nofree = flags & ~HVhek_FREEKEY;
 711                 HEK *new_hek = share_hek_flags(key, klen, hash, flags_nofree);
 712                 unshare_hek (HeKEY_hek(entry));
 713                 HeKEY_hek(entry) = new_hek;
 714             }
 715             else
 716                 HeKFLAGS(entry) = flags;
 717         }
 718         if (flags & HVhek_FREEKEY)
 719             Safefree(key);
 720         return &HeVAL(entry);
 721     }
 722
 723     if (SvREADONLY(hv)) {
 724         S_hv_notallowed(aTHX_ flags, key, klen,
 725                         "access disallowed key '%"SVf"' to"
 726                         );
 727     }
 728
 729     entry = new_HE();
 730     /* share_hek_flags will do the free for us.  This might be considered
 731        bad API design.  */
 732     if (HvSHAREKEYS(hv))
 733         HeKEY_hek(entry) = share_hek_flags(key, klen, hash, flags);
 734     else                                       /* gotta do the real thing */
 735         HeKEY_hek(entry) = save_hek_flags(key, klen, hash, flags);
 736     if (flags & HVhek_PLACEHOLD) {
 737         /* We have been requested to insert a placeholder. Currently
 738            only Storable is allowed to do this.  */
 739         xhv->xhv_placeholders++;
 740         HeVAL(entry) = &PL_sv_placeholder;
 741     } else
 742         HeVAL(entry) = val;
 743     HeNEXT(entry) = *oentry;
 744     *oentry = entry;
 745
 746     xhv->xhv_keys++; /* HvKEYS(hv)++ */
 747     if (!n_links) {                             /* initial entry? */
 748         xhv->xhv_fill++; /* HvFILL(hv)++ */
 749     } else if ((xhv->xhv_keys > (IV)xhv->xhv_max)
 750                || ((n_links > HV_MAX_LENGTH_BEFORE_SPLIT) && !HvREHASH(hv))) {
 751         /* Use the old HvKEYS(hv) > HvMAX(hv) condition to limit bucket
 752            splits on a rehashed hash, as we're not going to split it again,
 753            and if someone is lucky (evil) enough to get all the keys in one
 754            list they could exhaust our memory as we repeatedly double the
 755            number of buckets on every entry. Linear search feels a less worse
 756            thing to do.  */
 757         hsplit(hv);
 758     }
 759
 760     return &HeVAL(entry);
 761 }
 762
 763 /*
 764 =for apidoc hv_store_ent
 765
 766 Stores C<val> in a hash.  The hash key is specified as C<key>.  The C<hash>
 767 parameter is the precomputed hash value; if it is zero then Perl will
 768 compute it.  The return value is the new hash entry so created.  It will be
 769 NULL if the operation failed or if the value did not need to be actually
 770 stored within the hash (as in the case of tied hashes).  Otherwise the
 771 contents of the return value can be accessed using the C<He?> macros
 772 described here.  Note that the caller is responsible for suitably
 773 incrementing the reference count of C<val> before the call, and
 774 decrementing it if the function returned NULL.  Effectively a successful
 775 hv_store_ent takes ownership of one reference to C<val>.  This is
 776 usually what you want; a newly created SV has a reference count of one, so
 777 if all your code does is create SVs then store them in a hash, hv_store
 778 will own the only reference to the new SV, and your code doesn't need to do
 779 anything further to tidy up.  Note that hv_store_ent only reads the C<key>;
 780 unlike C<val> it does not take ownership of it, so maintaining the correct
 781 reference count on C<key> is entirely the caller's responsibility.  hv_store
 782 is not implemented as a call to hv_store_ent, and does not create a temporary
 783 SV for the key, so if your key data is not already in SV form then use
 784 hv_store in preference to hv_store_ent.
 785
 786 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
 787 information on how to use this function on tied hashes.
 788
 789 =cut
 790 */
 791
 792 HE *
 793 Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, U32 hash)
 794 {
 795     XPVHV* xhv;
 796     char *key;
 797     STRLEN klen;
 798     U32 n_links;
 799     HE *entry;
 800     HE **oentry;
 801     bool is_utf8;
 802     int flags = 0;
 803     char *keysave;
 804
 805     if (!hv)
 806         return 0;
 807
 808     xhv = (XPVHV*)SvANY(hv);
 809     if (SvMAGICAL(hv)) {
 810         bool needs_copy;
 811         bool needs_store;
 812         hv_magic_check (hv, &needs_copy, &needs_store);
 813         if (needs_copy) {
 814             bool save_taint = PL_tainted;
 815             if (PL_tainting)
 816                 PL_tainted = SvTAINTED(keysv);
 817             keysv = sv_2mortal(newSVsv(keysv));
 818             mg_copy((SV*)hv, val, (char*)keysv, HEf_SVKEY);
 819             TAINT_IF(save_taint);
 820             if (!xhv->xhv_array /* !HvARRAY(hv) */ && !needs_store)
 821                 return Nullhe;
 822 #ifdef ENV_IS_CASELESS
 823             else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
 824                 key = SvPV(keysv, klen);
 825                 keysv = sv_2mortal(newSVpvn(key,klen));
 826                 (void)strupr(SvPVX(keysv));
 827                 hash = 0;
 828             }
 829 #endif
 830         }
 831     }
 832
 833     keysave = key = SvPV(keysv, klen);
 834     is_utf8 = (SvUTF8(keysv) != 0);
 835
 836     if (is_utf8) {
 837         key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
 838         if (is_utf8)
 839             flags = HVhek_UTF8;
 840         if (key != keysave)
 841             flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
 842         HvHASKFLAGS_on((SV*)hv);
 843     }
 844
 845     if (HvREHASH(hv)) {
 846         /* We don't have a pointer to the hv, so we have to replicate the
 847            flag into every HEK, so that hv_iterkeysv can see it.  */
 848         flags |= HVhek_REHASH;
 849         PERL_HASH_INTERNAL(hash, key, klen);
 850     } else if (!hash) {
 851         if SvIsCOW_shared_hash(keysv) {
 852             hash = SvUVX(keysv);
 853         } else {
 854             PERL_HASH(hash, key, klen);
 855         }
 856     }
 857
 858     if (!xhv->xhv_array /* !HvARRAY(hv) */)
 859         Newz(505, xhv->xhv_array /* HvARRAY(hv) */,
 860              PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
 861              char);
 862
 863     /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
 864     oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
 865     n_links = 0;
 866     entry = *oentry;
 867     for (; entry; ++n_links, entry = HeNEXT(entry)) {
 868         if (HeHASH(entry) != hash)              /* strings can't be equal */
 869             continue;
 870         if (HeKLEN(entry) != (I32)klen)
 871             continue;
 872         if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen))        /* is this it? */
 873             continue;
 874         if ((HeKFLAGS(entry) ^ flags) & HVhek_UTF8)
 875             continue;
 876         if (HeVAL(entry) == &PL_sv_placeholder)
 877             xhv->xhv_placeholders--; /* yes, can store into placeholder slot */
 878         else
 879             SvREFCNT_dec(HeVAL(entry));
 880         HeVAL(entry) = val;
 881         if (HeKFLAGS(entry) != flags) {
 882             /* We match if HVhek_UTF8 bit in our flags and hash key's match.
 883                But if entry was set previously with HVhek_WASUTF8 and key now
 884                doesn't (or vice versa) then we should change the key's flag,
 885                as this is assignment.  */
 886             if (HvSHAREKEYS(hv)) {
 887                 /* Need to swap the key we have for a key with the flags we
 888                    need. As keys are shared we can't just write to the flag,
 889                    so we share the new one, unshare the old one.  */
 890                 int flags_nofree = flags & ~HVhek_FREEKEY;
 891                 HEK *new_hek = share_hek_flags(key, klen, hash, flags_nofree);
 892                 unshare_hek (HeKEY_hek(entry));
 893                 HeKEY_hek(entry) = new_hek;
 894             }
 895             else
 896                 HeKFLAGS(entry) = flags;
 897         }
 898         if (flags & HVhek_FREEKEY)
 899             Safefree(key);
 900         return entry;
 901     }
 902
 903     if (SvREADONLY(hv)) {
 904         S_hv_notallowed(aTHX_ flags, key, klen,
 905                         "access disallowed key '%"SVf"' to"
 906                         );
 907     }
 908
 909     entry = new_HE();
 910     /* share_hek_flags will do the free for us.  This might be considered
 911        bad API design.  */
 912     if (HvSHAREKEYS(hv))
 913         HeKEY_hek(entry) = share_hek_flags(key, klen, hash, flags);
 914     else                                       /* gotta do the real thing */
 915         HeKEY_hek(entry) = save_hek_flags(key, klen, hash, flags);
 916     HeVAL(entry) = val;
 917     HeNEXT(entry) = *oentry;
 918     *oentry = entry;
 919
 920     xhv->xhv_keys++; /* HvKEYS(hv)++ */
 921     if (!n_links) {                             /* initial entry? */
 922         xhv->xhv_fill++; /* HvFILL(hv)++ */
 923     } else if ((xhv->xhv_keys > (IV)xhv->xhv_max)
 924                || ((n_links > HV_MAX_LENGTH_BEFORE_SPLIT) && !HvREHASH(hv))) {
 925         /* Use only the old HvKEYS(hv) > HvMAX(hv) condition to limit bucket
 926            splits on a rehashed hash, as we're not going to split it again,
 927            and if someone is lucky (evil) enough to get all the keys in one
 928            list they could exhaust our memory as we repeatedly double the
 929            number of buckets on every entry. Linear search feels a less worse
 930            thing to do.  */
 931         hsplit(hv);
 932     }
 933
 934     return entry;
 935 }
 936
 937 /*
 938 =for apidoc hv_delete
 939
 940 Deletes a key/value pair in the hash.  The value SV is removed from the
 941 hash and returned to the caller.  The C<klen> is the length of the key.
 942 The C<flags> value will normally be zero; if set to G_DISCARD then NULL
 943 will be returned.
 944
 945 =cut
 946 */
 947
 948 SV *
 949 Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen, I32 flags)
 950 {
 951     register XPVHV* xhv;
 952     register I32 i;
 953     register U32 hash;
 954     register HE *entry;
 955     register HE **oentry;
 956     SV **svp;
 957     SV *sv;
 958     bool is_utf8 = FALSE;
 959     int k_flags = 0;
 960     const char *keysave = key;
 961
 962     if (!hv)
 963         return Nullsv;
 964     if (klen < 0) {
 965         klen = -klen;
 966         is_utf8 = TRUE;
 967     }
 968     if (SvRMAGICAL(hv)) {
 969         bool needs_copy;
 970         bool needs_store;
 971         hv_magic_check (hv, &needs_copy, &needs_store);
 972
 973 // XXX PerlIO_printf(PerlIO_stderr(), "%d %d\n", is_utf8, klen);
 974         if (needs_copy
 975             && (svp = hv_fetch(hv, key, is_utf8 ? -klen : klen, TRUE))) {
 976             sv = *svp;
 977             if (SvMAGICAL(sv)) {
 978                 mg_clear(sv);
 979             }
 980             if (!needs_store) {
 981                 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
 982                     /* No longer an element */
 983                     sv_unmagic(sv, PERL_MAGIC_tiedelem);
 984                     return sv;
 985                 }
 986                 return Nullsv;          /* element cannot be deleted */
 987             }
 988 #ifdef ENV_IS_CASELESS
 989             else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
 990                 sv = sv_2mortal(newSVpvn(key,klen));
 991                 key = strupr(SvPVX(sv));
 992             }
 993 #endif
 994         }
 995     }
 996     xhv = (XPVHV*)SvANY(hv);
 997     if (!xhv->xhv_array /* !HvARRAY(hv) */)
 998         return Nullsv;
 999
1000     if (is_utf8) {
1001         STRLEN tmplen = klen;
1002         /* See the note in hv_fetch(). --jhi */
1003         key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
1004         klen = tmplen;
1005         if (is_utf8)
1006             k_flags = HVhek_UTF8;
1007         if (key != keysave)
1008             k_flags |= HVhek_FREEKEY;
1009     }
1010
1011     if (HvREHASH(hv)) {
1012         PERL_HASH_INTERNAL(hash, key, klen);
1013     } else {
1014         PERL_HASH(hash, key, klen);
1015     }
1016
1017     /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
1018     oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
1019     entry = *oentry;
1020     i = 1;
1021     for (; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
1022         if (HeHASH(entry) != hash)              /* strings can't be equal */
1023             continue;
1024         if (HeKLEN(entry) != (I32)klen)
1025             continue;
1026         if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen))        /* is this it? */
1027             continue;
1028         if ((HeKFLAGS(entry) ^ k_flags) & HVhek_UTF8)
1029             continue;
1030         if (k_flags & HVhek_FREEKEY)
1031             Safefree(key);
1032         /* if placeholder is here, it's already been deleted.... */
1033         if (HeVAL(entry) == &PL_sv_placeholder)
1034         {
1035             if (SvREADONLY(hv))
1036                 return Nullsv;  /* if still SvREADONLY, leave it deleted. */
1037             else {
1038                 /* okay, really delete the placeholder... */
1039                 *oentry = HeNEXT(entry);
1040                 if (i && !*oentry)
1041                     xhv->xhv_fill--; /* HvFILL(hv)-- */
1042                 if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
1043                     HvLAZYDEL_on(hv);
1044                 else
1045                     hv_free_ent(hv, entry);
1046                 xhv->xhv_keys--; /* HvKEYS(hv)-- */
1047                 if (xhv->xhv_keys == 0)
1048                     HvHASKFLAGS_off(hv);
1049                 xhv->xhv_placeholders--;
1050                 return Nullsv;
1051             }
1052         }
1053         else if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
1054             S_hv_notallowed(aTHX_ k_flags, key, klen,
1055                             "delete readonly key '%"SVf"' from"
1056                             );
1057         }
1058
1059         if (flags & G_DISCARD)
1060             sv = Nullsv;
1061         else {
1062             sv = sv_2mortal(HeVAL(entry));
1063             HeVAL(entry) = &PL_sv_placeholder;
1064         }
1065
1066         /*
1067          * If a restricted hash, rather than really deleting the entry, put
1068          * a placeholder there. This marks the key as being "approved", so
1069          * we can still access via not-really-existing key without raising
1070          * an error.
1071          */
1072         if (SvREADONLY(hv)) {
1073             HeVAL(entry) = &PL_sv_placeholder;
1074             /* We'll be saving this slot, so the number of allocated keys
1075              * doesn't go down, but the number placeholders goes up */
1076             xhv->xhv_placeholders++; /* HvPLACEHOLDERS(hv)++ */
1077         } else {
1078             *oentry = HeNEXT(entry);
1079             if (i && !*oentry)
1080                 xhv->xhv_fill--; /* HvFILL(hv)-- */
1081             if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
1082                 HvLAZYDEL_on(hv);
1083             else
1084                 hv_free_ent(hv, entry);
1085             xhv->xhv_keys--; /* HvKEYS(hv)-- */
1086             if (xhv->xhv_keys == 0)
1087                 HvHASKFLAGS_off(hv);
1088         }
1089         return sv;
1090     }
1091     if (SvREADONLY(hv)) {
1092         S_hv_notallowed(aTHX_ k_flags, key, klen,
1093                         "access disallowed key '%"SVf"' from"
1094                         );
1095     }
1096
1097     if (k_flags & HVhek_FREEKEY)
1098         Safefree(key);
1099     return Nullsv;
1100 }
1101
1102 /*
1103 =for apidoc hv_delete_ent
1104
1105 Deletes a key/value pair in the hash.  The value SV is removed from the
1106 hash and returned to the caller.  The C<flags> value will normally be zero;
1107 if set to G_DISCARD then NULL will be returned.  C<hash> can be a valid
1108 precomputed hash value, or 0 to ask for it to be computed.
1109
1110 =cut
1111 */
1112
1113 SV *
1114 Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash)
1115 {
1116     register XPVHV* xhv;
1117     register I32 i;
1118     register char *key;
1119     STRLEN klen;
1120     register HE *entry;
1121     register HE **oentry;
1122     SV *sv;
1123     bool is_utf8;
1124     int k_flags = 0;
1125     char *keysave;
1126
1127     if (!hv)
1128         return Nullsv;
1129     if (SvRMAGICAL(hv)) {
1130         bool needs_copy;
1131         bool needs_store;
1132         hv_magic_check (hv, &needs_copy, &needs_store);
1133
1134         if (needs_copy && (entry = hv_fetch_ent(hv, keysv, TRUE, hash))) {
1135             sv = HeVAL(entry);
1136             if (SvMAGICAL(sv)) {
1137                 mg_clear(sv);
1138             }
1139             if (!needs_store) {
1140                 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
1141                     /* No longer an element */
1142                     sv_unmagic(sv, PERL_MAGIC_tiedelem);
1143                     return sv;
1144                 }
1145                 return Nullsv;          /* element cannot be deleted */
1146             }
1147 #ifdef ENV_IS_CASELESS
1148             else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
1149                 key = SvPV(keysv, klen);
1150                 keysv = sv_2mortal(newSVpvn(key,klen));
1151                 (void)strupr(SvPVX(keysv));
1152                 hash = 0;
1153             }
1154 #endif
1155         }
1156     }
1157     xhv = (XPVHV*)SvANY(hv);
1158     if (!xhv->xhv_array /* !HvARRAY(hv) */)
1159         return Nullsv;
1160
1161     keysave = key = SvPV(keysv, klen);
1162     is_utf8 = (SvUTF8(keysv) != 0);
1163
1164     if (is_utf8) {
1165         key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
1166         if (is_utf8)
1167             k_flags = HVhek_UTF8;
1168         if (key != keysave)
1169             k_flags |= HVhek_FREEKEY;
1170     }
1171
1172     if (HvREHASH(hv)) {
1173         PERL_HASH_INTERNAL(hash, key, klen);
1174     } else if (!hash) {
1175         PERL_HASH(hash, key, klen);
1176     }
1177
1178     /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
1179     oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
1180     entry = *oentry;
1181     i = 1;
1182     for (; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
1183         if (HeHASH(entry) != hash)              /* strings can't be equal */
1184             continue;
1185         if (HeKLEN(entry) != (I32)klen)
1186             continue;
1187         if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen))        /* is this it? */
1188             continue;
1189         if ((HeKFLAGS(entry) ^ k_flags) & HVhek_UTF8)
1190             continue;
1191         if (k_flags & HVhek_FREEKEY)
1192             Safefree(key);
1193
1194         /* if placeholder is here, it's already been deleted.... */
1195         if (HeVAL(entry) == &PL_sv_placeholder)
1196         {
1197             if (SvREADONLY(hv))
1198                 return Nullsv; /* if still SvREADONLY, leave it deleted. */
1199
1200            /* okay, really delete the placeholder. */
1201            *oentry = HeNEXT(entry);
1202            if (i && !*oentry)
1203                xhv->xhv_fill--; /* HvFILL(hv)-- */
1204            if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
1205                HvLAZYDEL_on(hv);
1206            else
1207                hv_free_ent(hv, entry);
1208            xhv->xhv_keys--; /* HvKEYS(hv)-- */
1209            if (xhv->xhv_keys == 0)
1210                HvHASKFLAGS_off(hv);
1211            xhv->xhv_placeholders--;
1212            return Nullsv;
1213         }
1214         else if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
1215             S_hv_notallowed(aTHX_ k_flags, key, klen,
1216                             "delete readonly key '%"SVf"' from"
1217                             );
1218         }
1219
1220         if (flags & G_DISCARD)
1221             sv = Nullsv;
1222         else {
1223             sv = sv_2mortal(HeVAL(entry));
1224             HeVAL(entry) = &PL_sv_placeholder;
1225         }
1226
1227         /*
1228          * If a restricted hash, rather than really deleting the entry, put
1229          * a placeholder there. This marks the key as being "approved", so
1230          * we can still access via not-really-existing key without raising
1231          * an error.
1232          */
1233         if (SvREADONLY(hv)) {
1234             HeVAL(entry) = &PL_sv_placeholder;
1235             /* We'll be saving this slot, so the number of allocated keys
1236              * doesn't go down, but the number placeholders goes up */
1237             xhv->xhv_placeholders++; /* HvPLACEHOLDERS(hv)++ */
1238         } else {
1239             *oentry = HeNEXT(entry);
1240             if (i && !*oentry)
1241                 xhv->xhv_fill--; /* HvFILL(hv)-- */
1242             if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
1243                 HvLAZYDEL_on(hv);
1244             else
1245                 hv_free_ent(hv, entry);
1246             xhv->xhv_keys--; /* HvKEYS(hv)-- */
1247             if (xhv->xhv_keys == 0)
1248                 HvHASKFLAGS_off(hv);
1249         }
1250         return sv;
1251     }
1252     if (SvREADONLY(hv)) {
1253         S_hv_notallowed(aTHX_ k_flags, key, klen,
1254                         "delete disallowed key '%"SVf"' from"
1255                         );
1256     }
1257
1258     if (k_flags & HVhek_FREEKEY)
1259         Safefree(key);
1260     return Nullsv;
1261 }
1262
1263 /*
1264 =for apidoc hv_exists
1265
1266 Returns a boolean indicating whether the specified hash key exists.  The
1267 C<klen> is the length of the key.
1268
1269 =cut
1270 */
1271
1272 bool
1273 Perl_hv_exists(pTHX_ HV *hv, const char *key, I32 klen)
1274 {
1275     register XPVHV* xhv;
1276     register U32 hash;
1277     register HE *entry;
1278     SV *sv;
1279     bool is_utf8 = FALSE;
1280     const char *keysave = key;
1281     int k_flags = 0;
1282
1283     if (!hv)
1284         return 0;
1285
1286     if (klen < 0) {
1287       klen = -klen;
1288       is_utf8 = TRUE;
1289     }
1290
1291     if (SvRMAGICAL(hv)) {
1292         if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
1293             sv = sv_newmortal();
1294             if (is_utf8) {
1295                 /* This hack based on the code in hv_exists_ent seems to be
1296                    the easiest way to pass the utf8 flag through and fix
1297                    the bug in hv_exists for tied hashes with utf8 keys.  */
1298                 SV *keysv = sv_2mortal(newSVpvn(key, klen));
1299                 SvUTF8_on(keysv);
1300                 key = (char *)keysv;
1301                 klen = HEf_SVKEY;
1302             }
1303             mg_copy((SV*)hv, sv, key, klen);
1304             magic_existspack(sv, mg_find(sv, PERL_MAGIC_tiedelem));
1305             return (bool)SvTRUE(sv);
1306         }
1307 #ifdef ENV_IS_CASELESS
1308         else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
1309             sv = sv_2mortal(newSVpvn(key,klen));
1310             key = strupr(SvPVX(sv));
1311         }
1312 #endif
1313     }
1314
1315     xhv = (XPVHV*)SvANY(hv);
1316 #ifndef DYNAMIC_ENV_FETCH
1317     if (!xhv->xhv_array /* !HvARRAY(hv) */)
1318         return 0;
1319 #endif
1320
1321     if (is_utf8) {
1322         STRLEN tmplen = klen;
1323         /* See the note in hv_fetch(). --jhi */
1324         key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
1325         klen = tmplen;
1326         if (is_utf8)
1327             k_flags = HVhek_UTF8;
1328         if (key != keysave)
1329             k_flags |= HVhek_FREEKEY;
1330     }
1331
1332     if (HvREHASH(hv)) {
1333         PERL_HASH_INTERNAL(hash, key, klen);
1334     } else {
1335         PERL_HASH(hash, key, klen);
1336     }
1337
1338 #ifdef DYNAMIC_ENV_FETCH
1339     if (!xhv->xhv_array /* !HvARRAY(hv) */) entry = Null(HE*);
1340     else
1341 #endif
1342     /* entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
1343     entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
1344     for (; entry; entry = HeNEXT(entry)) {
1345         if (HeHASH(entry) != hash)              /* strings can't be equal */
1346             continue;
1347         if (HeKLEN(entry) != klen)
1348             continue;
1349         if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen))        /* is this it? */
1350             continue;
1351         if ((HeKFLAGS(entry) ^ k_flags) & HVhek_UTF8)
1352             continue;
1353         if (k_flags & HVhek_FREEKEY)
1354             Safefree(key);
1355         /* If we find the key, but the value is a placeholder, return false. */
1356         if (HeVAL(entry) == &PL_sv_placeholder)
1357             return FALSE;
1358
1359         return TRUE;
1360     }
1361 #ifdef DYNAMIC_ENV_FETCH  /* is it out there? */
1362     if (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
1363         unsigned long len;
1364         char *env = PerlEnv_ENVgetenv_len(key,&len);
1365         if (env) {
1366             sv = newSVpvn(env,len);
1367             SvTAINTED_on(sv);
1368             (void)hv_store(hv,key,klen,sv,hash);
1369             if (k_flags & HVhek_FREEKEY)
1370                 Safefree(key);
1371             return TRUE;
1372         }
1373     }
1374 #endif
1375     if (k_flags & HVhek_FREEKEY)
1376         Safefree(key);
1377     return FALSE;
1378 }
1379
1380
1381 /*
1382 =for apidoc hv_exists_ent
1383
1384 Returns a boolean indicating whether the specified hash key exists. C<hash>
1385 can be a valid precomputed hash value, or 0 to ask for it to be
1386 computed.
1387
1388 =cut
1389 */
1390
1391 bool
1392 Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash)
1393 {
1394     register XPVHV* xhv;
1395     register char *key;
1396     STRLEN klen;
1397     register HE *entry;
1398     SV *sv;
1399     bool is_utf8;
1400     char *keysave;
1401     int k_flags = 0;
1402
1403     if (!hv)
1404         return 0;
1405
1406     if (SvRMAGICAL(hv)) {
1407         if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
1408            SV* svret = sv_newmortal();
1409             sv = sv_newmortal();
1410             keysv = sv_2mortal(newSVsv(keysv));
1411             mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY);
1412            magic_existspack(svret, mg_find(sv, PERL_MAGIC_tiedelem));
1413            return (bool)SvTRUE(svret);
1414         }
1415 #ifdef ENV_IS_CASELESS
1416         else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
1417             key = SvPV(keysv, klen);
1418             keysv = sv_2mortal(newSVpvn(key,klen));
1419             (void)strupr(SvPVX(keysv));
1420             hash = 0;
1421         }
1422 #endif
1423     }
1424
1425     xhv = (XPVHV*)SvANY(hv);
1426 #ifndef DYNAMIC_ENV_FETCH
1427     if (!xhv->xhv_array /* !HvARRAY(hv) */)
1428         return 0;
1429 #endif
1430
1431     keysave = key = SvPV(keysv, klen);
1432     is_utf8 = (SvUTF8(keysv) != 0);
1433     if (is_utf8) {
1434         key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
1435         if (is_utf8)
1436             k_flags = HVhek_UTF8;
1437         if (key != keysave)
1438             k_flags |= HVhek_FREEKEY;
1439     }
1440     if (HvREHASH(hv)) {
1441         PERL_HASH_INTERNAL(hash, key, klen);
1442     } else if (!hash)
1443         PERL_HASH(hash, key, klen);
1444
1445 #ifdef DYNAMIC_ENV_FETCH
1446     if (!xhv->xhv_array /* !HvARRAY(hv) */) entry = Null(HE*);
1447     else
1448 #endif
1449     /* entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
1450     entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
1451     for (; entry; entry = HeNEXT(entry)) {
1452         if (HeHASH(entry) != hash)              /* strings can't be equal */
1453             continue;
1454         if (HeKLEN(entry) != (I32)klen)
1455             continue;
1456         if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen))        /* is this it? */
1457             continue;
1458         if ((HeKFLAGS(entry) ^ k_flags) & HVhek_UTF8)
1459             continue;
1460         if (k_flags & HVhek_FREEKEY)
1461             Safefree(key);
1462         /* If we find the key, but the value is a placeholder, return false. */
1463         if (HeVAL(entry) == &PL_sv_placeholder)
1464             return FALSE;
1465         return TRUE;
1466     }
1467 #ifdef DYNAMIC_ENV_FETCH  /* is it out there? */
1468     if (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
1469         unsigned long len;
1470         char *env = PerlEnv_ENVgetenv_len(key,&len);
1471         if (env) {
1472             sv = newSVpvn(env,len);
1473             SvTAINTED_on(sv);
1474             (void)hv_store_ent(hv,keysv,sv,hash);
1475             if (k_flags & HVhek_FREEKEY)
1476                 Safefree(key);
1477             return TRUE;
1478         }
1479     }
1480 #endif
1481     if (k_flags & HVhek_FREEKEY)
1482         Safefree(key);
1483     return FALSE;
1484 }
1485
1486 STATIC void
1487 S_hsplit(pTHX_ HV *hv)
1488 {
1489     register XPVHV* xhv = (XPVHV*)SvANY(hv);
1490     I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
1491     register I32 newsize = oldsize * 2;
1492     register I32 i;
1493     register char *a = xhv->xhv_array; /* HvARRAY(hv) */
1494     register HE **aep;
1495     register HE **bep;
1496     register HE *entry;
1497     register HE **oentry;
1498     int longest_chain = 0;
1499     int was_shared;
1500
1501     PL_nomemok = TRUE;
1502 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
1503     Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1504     if (!a) {
1505       PL_nomemok = FALSE;
1506       return;
1507     }
1508 #else
1509     New(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1510     if (!a) {
1511       PL_nomemok = FALSE;
1512       return;
1513     }
1514     Copy(xhv->xhv_array /* HvARRAY(hv) */, a, oldsize * sizeof(HE*), char);
1515     if (oldsize >= 64) {
1516         offer_nice_chunk(xhv->xhv_array /* HvARRAY(hv) */,
1517                         PERL_HV_ARRAY_ALLOC_BYTES(oldsize));
1518     }
1519     else
1520         Safefree(xhv->xhv_array /* HvARRAY(hv) */);
1521 #endif
1522
1523     PL_nomemok = FALSE;
1524     Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char);     /* zero 2nd half*/
1525     xhv->xhv_max = --newsize;   /* HvMAX(hv) = --newsize */
1526     xhv->xhv_array = a;         /* HvARRAY(hv) = a */
1527     aep = (HE**)a;
1528
1529     for (i=0; i<oldsize; i++,aep++) {
1530         int left_length = 0;
1531         int right_length = 0;
1532
1533         if (!*aep)                              /* non-existent */
1534             continue;
1535         bep = aep+oldsize;
1536         for (oentry = aep, entry = *aep; entry; entry = *oentry) {
1537             if ((HeHASH(entry) & newsize) != (U32)i) {
1538                 *oentry = HeNEXT(entry);
1539                 HeNEXT(entry) = *bep;
1540                 if (!*bep)
1541                     xhv->xhv_fill++; /* HvFILL(hv)++ */
1542                 *bep = entry;
1543                 right_length++;
1544                 continue;
1545             }
1546             else {
1547                 oentry = &HeNEXT(entry);
1548                 left_length++;
1549             }
1550         }
1551         if (!*aep)                              /* everything moved */
1552             xhv->xhv_fill--; /* HvFILL(hv)-- */
1553         /* I think we don't actually need to keep track of the longest length,
1554            merely flag if anything is too long. But for the moment while
1555            developing this code I'll track it.  */
1556         if (left_length > longest_chain)
1557             longest_chain = left_length;
1558         if (right_length > longest_chain)
1559             longest_chain = right_length;
1560     }
1561
1562
1563     /* Pick your policy for "hashing isn't working" here:  */
1564     if (longest_chain <= HV_MAX_LENGTH_BEFORE_SPLIT /* split worked?  */
1565         || HvREHASH(hv)) {
1566         return;
1567     }
1568
1569     if (hv == PL_strtab) {
1570         /* Urg. Someone is doing something nasty to the string table.
1571            Can't win.  */
1572         return;
1573     }
1574
1575     /* Awooga. Awooga. Pathological data.  */
1576     /*PerlIO_printf(PerlIO_stderr(), "%p %d of %d with %d/%d buckets\n", hv,
1577       longest_chain, HvTOTALKEYS(hv), HvFILL(hv),  1+HvMAX(hv));*/
1578
1579     ++newsize;
1580     Newz(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1581     was_shared = HvSHAREKEYS(hv);
1582
1583     xhv->xhv_fill = 0;
1584     HvSHAREKEYS_off(hv);
1585     HvREHASH_on(hv);
1586
1587     aep = (HE **) xhv->xhv_array;
1588
1589     for (i=0; i<newsize; i++,aep++) {
1590         entry = *aep;
1591         while (entry) {
1592             /* We're going to trash this HE's next pointer when we chain it
1593                into the new hash below, so store where we go next.  */
1594             HE *next = HeNEXT(entry);
1595             UV hash;
1596
1597             /* Rehash it */
1598             PERL_HASH_INTERNAL(hash, HeKEY(entry), HeKLEN(entry));
1599
1600             if (was_shared) {
1601                 /* Unshare it.  */
1602                 HEK *new_hek
1603                     = save_hek_flags(HeKEY(entry), HeKLEN(entry),
1604                                      hash, HeKFLAGS(entry));
1605                 unshare_hek (HeKEY_hek(entry));
1606                 HeKEY_hek(entry) = new_hek;
1607             } else {
1608                 /* Not shared, so simply write the new hash in. */
1609                 HeHASH(entry) = hash;
1610             }
1611             /*PerlIO_printf(PerlIO_stderr(), "%d ", HeKFLAGS(entry));*/
1612             HEK_REHASH_on(HeKEY_hek(entry));
1613             /*PerlIO_printf(PerlIO_stderr(), "%d\n", HeKFLAGS(entry));*/
1614
1615             /* Copy oentry to the correct new chain.  */
1616             bep = ((HE**)a) + (hash & (I32) xhv->xhv_max);
1617             if (!*bep)
1618                     xhv->xhv_fill++; /* HvFILL(hv)++ */
1619             HeNEXT(entry) = *bep;
1620             *bep = entry;
1621
1622             entry = next;
1623         }
1624     }
1625     Safefree (xhv->xhv_array);
1626     xhv->xhv_array = a;         /* HvARRAY(hv) = a */
1627 }
1628
1629 void
1630 Perl_hv_ksplit(pTHX_ HV *hv, IV newmax)
1631 {
1632     register XPVHV* xhv = (XPVHV*)SvANY(hv);
1633     I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
1634     register I32 newsize;
1635     register I32 i;
1636     register I32 j;
1637     register char *a;
1638     register HE **aep;
1639     register HE *entry;
1640     register HE **oentry;
1641
1642     newsize = (I32) newmax;                     /* possible truncation here */
1643     if (newsize != newmax || newmax <= oldsize)
1644         return;
1645     while ((newsize & (1 + ~newsize)) != newsize) {
1646         newsize &= ~(newsize & (1 + ~newsize)); /* get proper power of 2 */
1647     }
1648     if (newsize < newmax)
1649         newsize *= 2;
1650     if (newsize < newmax)
1651         return;                                 /* overflow detection */
1652
1653     a = xhv->xhv_array; /* HvARRAY(hv) */
1654     if (a) {
1655         PL_nomemok = TRUE;
1656 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
1657         Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1658         if (!a) {
1659           PL_nomemok = FALSE;
1660           return;
1661         }
1662 #else
1663         New(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1664         if (!a) {
1665           PL_nomemok = FALSE;
1666           return;
1667         }
1668         Copy(xhv->xhv_array /* HvARRAY(hv) */, a, oldsize * sizeof(HE*), char);
1669         if (oldsize >= 64) {
1670             offer_nice_chunk(xhv->xhv_array /* HvARRAY(hv) */,
1671                             PERL_HV_ARRAY_ALLOC_BYTES(oldsize));
1672         }
1673         else
1674             Safefree(xhv->xhv_array /* HvARRAY(hv) */);
1675 #endif
1676         PL_nomemok = FALSE;
1677         Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
1678     }
1679     else {
1680         Newz(0, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1681     }
1682     xhv->xhv_max = --newsize;   /* HvMAX(hv) = --newsize */
1683     xhv->xhv_array = a;         /* HvARRAY(hv) = a */
1684     if (!xhv->xhv_fill /* !HvFILL(hv) */)       /* skip rest if no entries */
1685         return;
1686
1687     aep = (HE**)a;
1688     for (i=0; i<oldsize; i++,aep++) {
1689         if (!*aep)                              /* non-existent */
1690             continue;
1691         for (oentry = aep, entry = *aep; entry; entry = *oentry) {
1692             if ((j = (HeHASH(entry) & newsize)) != i) {
1693                 j -= i;
1694                 *oentry = HeNEXT(entry);
1695                 if (!(HeNEXT(entry) = aep[j]))
1696                     xhv->xhv_fill++; /* HvFILL(hv)++ */
1697                 aep[j] = entry;
1698                 continue;
1699             }
1700             else
1701                 oentry = &HeNEXT(entry);
1702         }
1703         if (!*aep)                              /* everything moved */
1704             xhv->xhv_fill--; /* HvFILL(hv)-- */
1705     }
1706 }
1707
1708 /*
1709 =for apidoc newHV
1710
1711 Creates a new HV.  The reference count is set to 1.
1712
1713 =cut
1714 */
1715
1716 HV *
1717 Perl_newHV(pTHX)
1718 {
1719     register HV *hv;
1720     register XPVHV* xhv;
1721
1722     hv = (HV*)NEWSV(502,0);
1723     sv_upgrade((SV *)hv, SVt_PVHV);
1724     xhv = (XPVHV*)SvANY(hv);
1725     SvPOK_off(hv);
1726     SvNOK_off(hv);
1727 #ifndef NODEFAULT_SHAREKEYS
1728     HvSHAREKEYS_on(hv);         /* key-sharing on by default */
1729 #endif
1730
1731     xhv->xhv_max    = 7;        /* HvMAX(hv) = 7 (start with 8 buckets) */
1732     xhv->xhv_fill   = 0;        /* HvFILL(hv) = 0 */
1733     xhv->xhv_pmroot = 0;        /* HvPMROOT(hv) = 0 */
1734     (void)hv_iterinit(hv);      /* so each() will start off right */
1735     return hv;
1736 }
1737
1738 HV *
1739 Perl_newHVhv(pTHX_ HV *ohv)
1740 {
1741     HV *hv = newHV();
1742     STRLEN hv_max, hv_fill;
1743
1744     if (!ohv || (hv_fill = HvFILL(ohv)) == 0)
1745         return hv;
1746     hv_max = HvMAX(ohv);
1747
1748     if (!SvMAGICAL((SV *)ohv)) {
1749         /* It's an ordinary hash, so copy it fast. AMS 20010804 */
1750         STRLEN i;
1751         bool shared = !!HvSHAREKEYS(ohv);
1752         HE **ents, **oents = (HE **)HvARRAY(ohv);
1753         char *a;
1754         New(0, a, PERL_HV_ARRAY_ALLOC_BYTES(hv_max+1), char);
1755         ents = (HE**)a;
1756
1757         /* In each bucket... */
1758         for (i = 0; i <= hv_max; i++) {
1759             HE *prev = NULL, *ent = NULL, *oent = oents[i];
1760
1761             if (!oent) {
1762                 ents[i] = NULL;
1763                 continue;
1764             }
1765
1766             /* Copy the linked list of entries. */
1767             for (oent = oents[i]; oent; oent = HeNEXT(oent)) {
1768                 U32 hash   = HeHASH(oent);
1769                 char *key  = HeKEY(oent);
1770                 STRLEN len = HeKLEN(oent);
1771                 int flags  = HeKFLAGS(oent);
1772
1773                 ent = new_HE();
1774                 HeVAL(ent)     = newSVsv(HeVAL(oent));
1775                 HeKEY_hek(ent)
1776                     = shared ? share_hek_flags(key, len, hash, flags)
1777                              :  save_hek_flags(key, len, hash, flags);
1778                 if (prev)
1779                     HeNEXT(prev) = ent;
1780                 else
1781                     ents[i] = ent;
1782                 prev = ent;
1783                 HeNEXT(ent) = NULL;
1784             }
1785         }
1786
1787         HvMAX(hv)   = hv_max;
1788         HvFILL(hv)  = hv_fill;
1789         HvTOTALKEYS(hv)  = HvTOTALKEYS(ohv);
1790         HvARRAY(hv) = ents;
1791     }
1792     else {
1793         /* Iterate over ohv, copying keys and values one at a time. */
1794         HE *entry;
1795         I32 riter = HvRITER(ohv);
1796         HE *eiter = HvEITER(ohv);
1797
1798         /* Can we use fewer buckets? (hv_max is always 2^n-1) */
1799         while (hv_max && hv_max + 1 >= hv_fill * 2)
1800             hv_max = hv_max / 2;
1801         HvMAX(hv) = hv_max;
1802
1803         hv_iterinit(ohv);
1804         while ((entry = hv_iternext_flags(ohv, 0))) {
1805             hv_store_flags(hv, HeKEY(entry), HeKLEN(entry),
1806                            newSVsv(HeVAL(entry)), HeHASH(entry),
1807                            HeKFLAGS(entry));
1808         }
1809         HvRITER(ohv) = riter;
1810         HvEITER(ohv) = eiter;
1811     }
1812
1813     return hv;
1814 }
1815
1816 void
1817 Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry)
1818 {
1819     SV *val;
1820
1821     if (!entry)
1822         return;
1823     val = HeVAL(entry);
1824     if (val && isGV(val) && GvCVu(val) && HvNAME(hv))
1825         PL_sub_generation++;    /* may be deletion of method from stash */
1826     SvREFCNT_dec(val);
1827     if (HeKLEN(entry) == HEf_SVKEY) {
1828         SvREFCNT_dec(HeKEY_sv(entry));
1829         Safefree(HeKEY_hek(entry));
1830     }
1831     else if (HvSHAREKEYS(hv))
1832         unshare_hek(HeKEY_hek(entry));
1833     else
1834         Safefree(HeKEY_hek(entry));
1835     del_HE(entry);
1836 }
1837
1838 void
1839 Perl_hv_delayfree_ent(pTHX_ HV *hv, register HE *entry)
1840 {
1841     if (!entry)
1842         return;
1843     if (isGV(HeVAL(entry)) && GvCVu(HeVAL(entry)) && HvNAME(hv))
1844         PL_sub_generation++;    /* may be deletion of method from stash */
1845     sv_2mortal(HeVAL(entry));   /* free between statements */
1846     if (HeKLEN(entry) == HEf_SVKEY) {
1847         sv_2mortal(HeKEY_sv(entry));
1848         Safefree(HeKEY_hek(entry));
1849     }
1850     else if (HvSHAREKEYS(hv))
1851         unshare_hek(HeKEY_hek(entry));
1852     else
1853         Safefree(HeKEY_hek(entry));
1854     del_HE(entry);
1855 }
1856
1857 /*
1858 =for apidoc hv_clear
1859
1860 Clears a hash, making it empty.
1861
1862 =cut
1863 */
1864
1865 void
1866 Perl_hv_clear(pTHX_ HV *hv)
1867 {
1868     register XPVHV* xhv;
1869     if (!hv)
1870         return;
1871
1872     DEBUG_A(Perl_hv_assert(aTHX_ hv));
1873
1874     xhv = (XPVHV*)SvANY(hv);
1875
1876     if (SvREADONLY(hv)) {
1877         /* restricted hash: convert all keys to placeholders */
1878         I32 i;
1879         HE* entry;
1880         for (i = 0; i <= (I32) xhv->xhv_max; i++) {
1881             entry = ((HE**)xhv->xhv_array)[i];
1882             for (; entry; entry = HeNEXT(entry)) {
1883                 /* not already placeholder */
1884                 if (HeVAL(entry) != &PL_sv_placeholder) {
1885                     if (HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
1886                         SV* keysv = hv_iterkeysv(entry);
1887                         Perl_croak(aTHX_
1888         "Attempt to delete readonly key '%"SVf"' from a restricted hash",
1889                                    keysv);
1890                     }
1891                     SvREFCNT_dec(HeVAL(entry));
1892                     HeVAL(entry) = &PL_sv_placeholder;
1893                     xhv->xhv_placeholders++; /* HvPLACEHOLDERS(hv)++ */
1894                 }
1895             }
1896         }
1897         return;
1898     }
1899
1900     hfreeentries(hv);
1901     xhv->xhv_placeholders = 0; /* HvPLACEHOLDERS(hv) = 0 */
1902     if (xhv->xhv_array /* HvARRAY(hv) */)
1903         (void)memzero(xhv->xhv_array /* HvARRAY(hv) */,
1904                       (xhv->xhv_max+1 /* HvMAX(hv)+1 */) * sizeof(HE*));
1905
1906     if (SvRMAGICAL(hv))
1907         mg_clear((SV*)hv);
1908
1909     HvHASKFLAGS_off(hv);
1910     HvREHASH_off(hv);
1911 }
1912
1913 STATIC void
1914 S_hfreeentries(pTHX_ HV *hv)
1915 {
1916     register HE **array;
1917     register HE *entry;
1918     register HE *oentry = Null(HE*);
1919     I32 riter;
1920     I32 max;
1921
1922     if (!hv)
1923         return;
1924     if (!HvARRAY(hv))
1925         return;
1926
1927     riter = 0;
1928     max = HvMAX(hv);
1929     array = HvARRAY(hv);
1930     /* make everyone else think the array is empty, so that the destructors
1931      * called for freed entries can't recusively mess with us */
1932     HvARRAY(hv) = Null(HE**);
1933     HvFILL(hv) = 0;
1934     ((XPVHV*) SvANY(hv))->xhv_keys = 0;
1935
1936     entry = array[0];
1937     for (;;) {
1938         if (entry) {
1939             oentry = entry;
1940             entry = HeNEXT(entry);
1941             hv_free_ent(hv, oentry);
1942         }
1943         if (!entry) {
1944             if (++riter > max)
1945                 break;
1946             entry = array[riter];
1947         }
1948     }
1949     HvARRAY(hv) = array;
1950     (void)hv_iterinit(hv);
1951 }
1952
1953 /*
1954 =for apidoc hv_undef
1955
1956 Undefines the hash.
1957
1958 =cut
1959 */
1960
1961 void
1962 Perl_hv_undef(pTHX_ HV *hv)
1963 {
1964     register XPVHV* xhv;
1965     if (!hv)
1966         return;
1967     DEBUG_A(Perl_hv_assert(aTHX_ hv));
1968     xhv = (XPVHV*)SvANY(hv);
1969     hfreeentries(hv);
1970     Safefree(xhv->xhv_array /* HvARRAY(hv) */);
1971     if (HvNAME(hv)) {
1972         if(PL_stashcache)
1973             hv_delete(PL_stashcache, HvNAME(hv), strlen(HvNAME(hv)), G_DISCARD);
1974         Safefree(HvNAME(hv));
1975         HvNAME(hv) = 0;
1976     }
1977     xhv->xhv_max   = 7; /* HvMAX(hv) = 7 (it's a normal hash) */
1978     xhv->xhv_array = 0; /* HvARRAY(hv) = 0 */
1979     xhv->xhv_placeholders = 0; /* HvPLACEHOLDERS(hv) = 0 */
1980
1981     if (SvRMAGICAL(hv))
1982         mg_clear((SV*)hv);
1983 }
1984
1985 /*
1986 =for apidoc hv_iterinit
1987
1988 Prepares a starting point to traverse a hash table.  Returns the number of
1989 keys in the hash (i.e. the same as C<HvKEYS(tb)>).  The return value is
1990 currently only meaningful for hashes without tie magic.
1991
1992 NOTE: Before version 5.004_65, C<hv_iterinit> used to return the number of
1993 hash buckets that happen to be in use.  If you still need that esoteric
1994 value, you can get it through the macro C<HvFILL(tb)>.
1995
1996
1997 =cut
1998 */
1999
2000 I32
2001 Perl_hv_iterinit(pTHX_ HV *hv)
2002 {
2003     register XPVHV* xhv;
2004     HE *entry;
2005
2006     if (!hv)
2007         Perl_croak(aTHX_ "Bad hash");
2008     xhv = (XPVHV*)SvANY(hv);
2009     entry = xhv->xhv_eiter; /* HvEITER(hv) */
2010     if (entry && HvLAZYDEL(hv)) {       /* was deleted earlier? */
2011         HvLAZYDEL_off(hv);
2012         hv_free_ent(hv, entry);
2013     }
2014     xhv->xhv_riter = -1;        /* HvRITER(hv) = -1 */
2015     xhv->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */
2016     /* used to be xhv->xhv_fill before 5.004_65 */
2017     return XHvTOTALKEYS(xhv);
2018 }
2019 /*
2020 =for apidoc hv_iternext
2021
2022 Returns entries from a hash iterator.  See C<hv_iterinit>.
2023
2024 You may call C<hv_delete> or C<hv_delete_ent> on the hash entry that the
2025 iterator currently points to, without losing your place or invalidating your
2026 iterator.  Note that in this case the current entry is deleted from the hash
2027 with your iterator holding the last reference to it.  Your iterator is flagged
2028 to free the entry on the next call to C<hv_iternext>, so you must not discard
2029 your iterator immediately else the entry will leak - call C<hv_iternext> to
2030 trigger the resource deallocation.
2031
2032 =cut
2033 */
2034
2035 HE *
2036 Perl_hv_iternext(pTHX_ HV *hv)
2037 {
2038     return hv_iternext_flags(hv, 0);
2039 }
2040
2041 /*
2042 =for apidoc hv_iternext_flags
2043
2044 Returns entries from a hash iterator.  See C<hv_iterinit> and C<hv_iternext>.
2045 The C<flags> value will normally be zero; if HV_ITERNEXT_WANTPLACEHOLDERS is
2046 set the placeholders keys (for restricted hashes) will be returned in addition
2047 to normal keys. By default placeholders are automatically skipped over.
2048 Currently a placeholder is implemented with a value that is
2049 C<&Perl_sv_placeholder>. Note that the implementation of placeholders and
2050 restricted hashes may change, and the implementation currently is
2051 insufficiently abstracted for any change to be tidy.
2052
2053 =cut
2054 */
2055
2056 HE *
2057 Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags)
2058 {
2059     register XPVHV* xhv;
2060     register HE *entry;
2061     HE *oldentry;
2062     MAGIC* mg;
2063
2064     if (!hv)
2065         Perl_croak(aTHX_ "Bad hash");
2066     xhv = (XPVHV*)SvANY(hv);
2067     oldentry = entry = xhv->xhv_eiter; /* HvEITER(hv) */
2068
2069     if ((mg = SvTIED_mg((SV*)hv, PERL_MAGIC_tied))) {
2070         SV *key = sv_newmortal();
2071         if (entry) {
2072             sv_setsv(key, HeSVKEY_force(entry));
2073             SvREFCNT_dec(HeSVKEY(entry));       /* get rid of previous key */
2074         }
2075         else {
2076             char *k;
2077             HEK *hek;
2078
2079             /* one HE per MAGICAL hash */
2080             xhv->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */
2081             Zero(entry, 1, HE);
2082             Newz(54, k, HEK_BASESIZE + sizeof(SV*), char);
2083             hek = (HEK*)k;
2084             HeKEY_hek(entry) = hek;
2085             HeKLEN(entry) = HEf_SVKEY;
2086         }
2087         magic_nextpack((SV*) hv,mg,key);
2088         if (SvOK(key)) {
2089             /* force key to stay around until next time */
2090             HeSVKEY_set(entry, SvREFCNT_inc(key));
2091             return entry;               /* beware, hent_val is not set */
2092         }
2093         if (HeVAL(entry))
2094             SvREFCNT_dec(HeVAL(entry));
2095         Safefree(HeKEY_hek(entry));
2096         del_HE(entry);
2097         xhv->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */
2098         return Null(HE*);
2099     }
2100 #ifdef DYNAMIC_ENV_FETCH  /* set up %ENV for iteration */
2101     if (!entry && SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
2102         prime_env_iter();
2103 #endif
2104
2105     if (!xhv->xhv_array /* !HvARRAY(hv) */)
2106         Newz(506, xhv->xhv_array /* HvARRAY(hv) */,
2107              PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
2108              char);
2109     /* At start of hash, entry is NULL.  */
2110     if (entry)
2111     {
2112         entry = HeNEXT(entry);
2113         if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
2114             /*
2115              * Skip past any placeholders -- don't want to include them in
2116              * any iteration.
2117              */
2118             while (entry && HeVAL(entry) == &PL_sv_placeholder) {
2119                 entry = HeNEXT(entry);
2120             }
2121         }
2122     }
2123     while (!entry) {
2124         /* OK. Come to the end of the current list.  Grab the next one.  */
2125
2126         xhv->xhv_riter++; /* HvRITER(hv)++ */
2127         if (xhv->xhv_riter > (I32)xhv->xhv_max /* HvRITER(hv) > HvMAX(hv) */) {
2128             /* There is no next one.  End of the hash.  */
2129             xhv->xhv_riter = -1; /* HvRITER(hv) = -1 */
2130             break;
2131         }
2132         /* entry = (HvARRAY(hv))[HvRITER(hv)]; */
2133         entry = ((HE**)xhv->xhv_array)[xhv->xhv_riter];
2134
2135         if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
2136             /* If we have an entry, but it's a placeholder, don't count it.
2137                Try the next.  */
2138             while (entry && HeVAL(entry) == &PL_sv_placeholder)
2139                 entry = HeNEXT(entry);
2140         }
2141         /* Will loop again if this linked list starts NULL
2142            (for HV_ITERNEXT_WANTPLACEHOLDERS)
2143            or if we run through it and find only placeholders.  */
2144     }
2145
2146     if (oldentry && HvLAZYDEL(hv)) {            /* was deleted earlier? */
2147         HvLAZYDEL_off(hv);
2148         hv_free_ent(hv, oldentry);
2149     }
2150
2151     /*if (HvREHASH(hv) && entry && !HeKREHASH(entry))
2152       PerlIO_printf(PerlIO_stderr(), "Awooga %p %p\n", hv, entry);*/
2153
2154     xhv->xhv_eiter = entry; /* HvEITER(hv) = entry */
2155     return entry;
2156 }
2157
2158 /*
2159 =for apidoc hv_iterkey
2160
2161 Returns the key from the current position of the hash iterator.  See
2162 C<hv_iterinit>.
2163
2164 =cut
2165 */
2166
2167 char *
2168 Perl_hv_iterkey(pTHX_ register HE *entry, I32 *retlen)
2169 {
2170     if (HeKLEN(entry) == HEf_SVKEY) {
2171         STRLEN len;
2172         char *p = SvPV(HeKEY_sv(entry), len);
2173         *retlen = len;
2174         return p;
2175     }
2176     else {
2177         *retlen = HeKLEN(entry);
2178         return HeKEY(entry);
2179     }
2180 }
2181
2182 /* unlike hv_iterval(), this always returns a mortal copy of the key */
2183 /*
2184 =for apidoc hv_iterkeysv
2185
2186 Returns the key as an C<SV*> from the current position of the hash
2187 iterator.  The return value will always be a mortal copy of the key.  Also
2188 see C<hv_iterinit>.
2189
2190 =cut
2191 */
2192
2193 SV *
2194 Perl_hv_iterkeysv(pTHX_ register HE *entry)
2195 {
2196     if (HeKLEN(entry) != HEf_SVKEY) {
2197         HEK *hek = HeKEY_hek(entry);
2198         int flags = HEK_FLAGS(hek);
2199         SV *sv;
2200
2201         if (flags & HVhek_WASUTF8) {
2202             /* Trouble :-)
2203                Andreas would like keys he put in as utf8 to come back as utf8
2204             */
2205             STRLEN utf8_len = HEK_LEN(hek);
2206             U8 *as_utf8 = bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len);
2207
2208             sv = newSVpvn ((char*)as_utf8, utf8_len);
2209             SvUTF8_on (sv);
2210             Safefree (as_utf8); /* bytes_to_utf8() allocates a new string */
2211         } else if (flags & HVhek_REHASH) {
2212             /* We don't have a pointer to the hv, so we have to replicate the
2213                flag into every HEK. This hv is using custom a hasing
2214                algorithm. Hence we can't return a shared string scalar, as
2215                that would contain the (wrong) hash value, and might get passed
2216                into an hv routine with a regular hash  */
2217
2218             sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek));
2219             if (HEK_UTF8(hek))
2220                 SvUTF8_on (sv);
2221         } else {
2222             sv = newSVpvn_share(HEK_KEY(hek),
2223                                 (HEK_UTF8(hek) ? -HEK_LEN(hek) : HEK_LEN(hek)),
2224                                 HEK_HASH(hek));
2225         }
2226         return sv_2mortal(sv);
2227     }
2228     return sv_mortalcopy(HeKEY_sv(entry));
2229 }
2230
2231 /*
2232 =for apidoc hv_iterval
2233
2234 Returns the value from the current position of the hash iterator.  See
2235 C<hv_iterkey>.
2236
2237 =cut
2238 */
2239
2240 SV *
2241 Perl_hv_iterval(pTHX_ HV *hv, register HE *entry)
2242 {
2243     if (SvRMAGICAL(hv)) {
2244         if (mg_find((SV*)hv, PERL_MAGIC_tied)) {
2245             SV* sv = sv_newmortal();
2246             if (HeKLEN(entry) == HEf_SVKEY)
2247                 mg_copy((SV*)hv, sv, (char*)HeKEY_sv(entry), HEf_SVKEY);
2248             else mg_copy((SV*)hv, sv, HeKEY(entry), HeKLEN(entry));
2249             return sv;
2250         }
2251     }
2252     return HeVAL(entry);
2253 }
2254
2255 /*
2256 =for apidoc hv_iternextsv
2257
2258 Performs an C<hv_iternext>, C<hv_iterkey>, and C<hv_iterval> in one
2259 operation.
2260
2261 =cut
2262 */
2263
2264 SV *
2265 Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen)
2266 {
2267     HE *he;
2268     if ( (he = hv_iternext_flags(hv, 0)) == NULL)
2269         return NULL;
2270     *key = hv_iterkey(he, retlen);
2271     return hv_iterval(hv, he);
2272 }
2273
2274 /*
2275 =for apidoc hv_magic
2276
2277 Adds magic to a hash.  See C<sv_magic>.
2278
2279 =cut
2280 */
2281
2282 void
2283 Perl_hv_magic(pTHX_ HV *hv, GV *gv, int how)
2284 {
2285     sv_magic((SV*)hv, (SV*)gv, how, Nullch, 0);
2286 }
2287
2288 #if 0 /* use the macro from hv.h instead */
2289
2290 char*
2291 Perl_sharepvn(pTHX_ const char *sv, I32 len, U32 hash)
2292 {
2293     return HEK_KEY(share_hek(sv, len, hash));
2294 }
2295
2296 #endif
2297
2298 /* possibly free a shared string if no one has access to it
2299  * len and hash must both be valid for str.
2300  */
2301 void
2302 Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
2303 {
2304     unshare_hek_or_pvn (NULL, str, len, hash);
2305 }
2306
2307
2308 void
2309 Perl_unshare_hek(pTHX_ HEK *hek)
2310 {
2311     unshare_hek_or_pvn(hek, NULL, 0, 0);
2312 }
2313
2314 /* possibly free a shared string if no one has access to it
2315    hek if non-NULL takes priority over the other 3, else str, len and hash
2316    are used.  If so, len and hash must both be valid for str.
2317  */
2318 STATIC void
2319 S_unshare_hek_or_pvn(pTHX_ HEK *hek, const char *str, I32 len, U32 hash)
2320 {
2321     register XPVHV* xhv;
2322     register HE *entry;
2323     register HE **oentry;
2324     register I32 i = 1;
2325     I32 found = 0;
2326     bool is_utf8 = FALSE;
2327     int k_flags = 0;
2328     const char *save = str;
2329
2330     if (hek) {
2331         hash = HEK_HASH(hek);
2332     } else if (len < 0) {
2333         STRLEN tmplen = -len;
2334         is_utf8 = TRUE;
2335         /* See the note in hv_fetch(). --jhi */
2336         str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2337         len = tmplen;
2338         if (is_utf8)
2339             k_flags = HVhek_UTF8;
2340         if (str != save)
2341             k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2342     }
2343
2344     /* what follows is the moral equivalent of:
2345     if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) {
2346         if (--*Svp == Nullsv)
2347             hv_delete(PL_strtab, str, len, G_DISCARD, hash);
2348     } */
2349     xhv = (XPVHV*)SvANY(PL_strtab);
2350     /* assert(xhv_array != 0) */
2351     LOCK_STRTAB_MUTEX;
2352     /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
2353     oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
2354     if (hek) {
2355         for (entry = *oentry; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
2356             if (HeKEY_hek(entry) != hek)
2357                 continue;
2358             found = 1;
2359             break;
2360         }
2361     } else {
2362         int flags_masked = k_flags & HVhek_MASK;
2363         for (entry = *oentry; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
2364             if (HeHASH(entry) != hash)          /* strings can't be equal */
2365                 continue;
2366             if (HeKLEN(entry) != len)
2367                 continue;
2368             if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len))     /* is this it? */
2369                 continue;
2370             if (HeKFLAGS(entry) != flags_masked)
2371                 continue;
2372             found = 1;
2373             break;
2374         }
2375     }
2376
2377     if (found) {
2378         if (--HeVAL(entry) == Nullsv) {
2379             *oentry = HeNEXT(entry);
2380             if (i && !*oentry)
2381                 xhv->xhv_fill--; /* HvFILL(hv)-- */
2382             Safefree(HeKEY_hek(entry));
2383             del_HE(entry);
2384             xhv->xhv_keys--; /* HvKEYS(hv)-- */
2385         }
2386     }
2387
2388     UNLOCK_STRTAB_MUTEX;
2389     if (!found && ckWARN_d(WARN_INTERNAL))
2390         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
2391                     "Attempt to free non-existent shared string '%s'%s",
2392                     hek ? HEK_KEY(hek) : str,
2393                     (k_flags & HVhek_UTF8) ? " (utf8)" : "");
2394     if (k_flags & HVhek_FREEKEY)
2395         Safefree(str);
2396 }
2397
2398 /* get a (constant) string ptr from the global string table
2399  * string will get added if it is not already there.
2400  * len and hash must both be valid for str.
2401  */
2402 HEK *
2403 Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash)
2404 {
2405     bool is_utf8 = FALSE;
2406     int flags = 0;
2407     const char *save = str;
2408
2409     if (len < 0) {
2410       STRLEN tmplen = -len;
2411       is_utf8 = TRUE;
2412       /* See the note in hv_fetch(). --jhi */
2413       str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2414       len = tmplen;
2415       /* If we were able to downgrade here, then than means that we were passed
2416          in a key which only had chars 0-255, but was utf8 encoded.  */
2417       if (is_utf8)
2418           flags = HVhek_UTF8;
2419       /* If we found we were able to downgrade the string to bytes, then
2420          we should flag that it needs upgrading on keys or each.  Also flag
2421          that we need share_hek_flags to free the string.  */
2422       if (str != save)
2423           flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2424     }
2425
2426     return share_hek_flags (str, len, hash, flags);
2427 }
2428
2429 STATIC HEK *
2430 S_share_hek_flags(pTHX_ const char *str, I32 len, register U32 hash, int flags)
2431 {
2432     register XPVHV* xhv;
2433     register HE *entry;
2434     register HE **oentry;
2435     register I32 i = 1;
2436     I32 found = 0;
2437     int flags_masked = flags & HVhek_MASK;
2438
2439     /* what follows is the moral equivalent of:
2440
2441     if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
2442         hv_store(PL_strtab, str, len, Nullsv, hash);
2443
2444         Can't rehash the shared string table, so not sure if it's worth
2445         counting the number of entries in the linked list
2446     */
2447     xhv = (XPVHV*)SvANY(PL_strtab);
2448     /* assert(xhv_array != 0) */
2449     LOCK_STRTAB_MUTEX;
2450     /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
2451     oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
2452     for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
2453         if (HeHASH(entry) != hash)              /* strings can't be equal */
2454             continue;
2455         if (HeKLEN(entry) != len)
2456             continue;
2457         if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
2458             continue;
2459         if (HeKFLAGS(entry) != flags_masked)
2460             continue;
2461         found = 1;
2462         break;
2463     }
2464     if (!found) {
2465         entry = new_HE();
2466         HeKEY_hek(entry) = save_hek_flags(str, len, hash, flags);
2467         HeVAL(entry) = Nullsv;
2468         HeNEXT(entry) = *oentry;
2469         *oentry = entry;
2470         xhv->xhv_keys++; /* HvKEYS(hv)++ */
2471         if (i) {                                /* initial entry? */
2472             xhv->xhv_fill++; /* HvFILL(hv)++ */
2473         } else if (xhv->xhv_keys > (IV)xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */) {
2474                 hsplit(PL_strtab);
2475         }
2476     }
2477
2478     ++HeVAL(entry);                             /* use value slot as REFCNT */
2479     UNLOCK_STRTAB_MUTEX;
2480
2481     if (flags & HVhek_FREEKEY)
2482         Safefree(str);
2483
2484     return HeKEY_hek(entry);
2485 }
2486
2487
2488 /*
2489 =for apidoc hv_assert
2490
2491 Check that a hash is in an internally consistent state.
2492
2493 =cut
2494 */
2495
2496 void
2497 Perl_hv_assert(pTHX_ HV *hv)
2498 {
2499   HE* entry;
2500   int withflags = 0;
2501   int placeholders = 0;
2502   int real = 0;
2503   int bad = 0;
2504   I32 riter = HvRITER(hv);
2505   HE *eiter = HvEITER(hv);
2506
2507   (void)hv_iterinit(hv);
2508
2509   while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))) {
2510     /* sanity check the values */
2511     if (HeVAL(entry) == &PL_sv_placeholder) {
2512       placeholders++;
2513     } else {
2514       real++;
2515     }
2516     /* sanity check the keys */
2517     if (HeSVKEY(entry)) {
2518       /* Don't know what to check on SV keys.  */
2519     } else if (HeKUTF8(entry)) {
2520       withflags++;
2521        if (HeKWASUTF8(entry)) {
2522          PerlIO_printf(Perl_debug_log,
2523                        "hash key has both WASUFT8 and UTF8: '%.*s'\n",
2524                        (int) HeKLEN(entry),  HeKEY(entry));
2525          bad = 1;
2526        }
2527     } else if (HeKWASUTF8(entry)) {
2528       withflags++;
2529     }
2530   }
2531   if (!SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) {
2532     if (HvUSEDKEYS(hv) != real) {
2533       PerlIO_printf(Perl_debug_log, "Count %d key(s), but hash reports %d\n",
2534                     (int) real, (int) HvUSEDKEYS(hv));
2535       bad = 1;
2536     }
2537     if (HvPLACEHOLDERS(hv) != placeholders) {
2538       PerlIO_printf(Perl_debug_log,
2539                     "Count %d placeholder(s), but hash reports %d\n",
2540                     (int) placeholders, (int) HvPLACEHOLDERS(hv));
2541       bad = 1;
2542     }
2543   }
2544   if (withflags && ! HvHASKFLAGS(hv)) {
2545     PerlIO_printf(Perl_debug_log,
2546                   "Hash has HASKFLAGS off but I count %d key(s) with flags\n",
2547                   withflags);
2548     bad = 1;
2549   }
2550   if (bad) {
2551     sv_dump((SV *)hv);
2552   }
2553   HvRITER(hv) = riter;          /* Restore hash iterator state */
2554   HvEITER(hv) = eiter;
2555 }