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