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