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 flags)
 742 {
 743     return hv_delete_common(hv, NULL, key, klen, flags, 0);
 744 }
 745
 746 /*
 747 =for apidoc hv_delete_ent
 748
 749 Deletes a key/value pair in the hash.  The value SV is removed from the
 750 hash and returned to the caller.  The C<flags> value will normally be zero;
 751 if set to G_DISCARD then NULL will be returned.  C<hash> can be a valid
 752 precomputed hash value, or 0 to ask for it to be computed.
 753
 754 =cut
 755 */
 756
 757 SV *
 758 Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash)
 759 {
 760     return hv_delete_common(hv, keysv, NULL, 0, flags, hash);
 761 }
 762
 763 SV *
 764 S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, I32 klen_i32,
 765                    I32 flags, U32 hash)
 766 {
 767     register XPVHV* xhv;
 768     register I32 i;
 769     STRLEN klen;
 770     register HE *entry;
 771     register HE **oentry;
 772     SV *sv;
 773     bool is_utf8;
 774     int k_flags = 0;
 775     const char *keysave;
 776
 777     if (!hv)
 778         return Nullsv;
 779
 780     if (keysv) {
 781         key = SvPV(keysv, klen);
 782         is_utf8 = (SvUTF8(keysv) != 0);
 783     } else {
 784         if (klen_i32 < 0) {
 785             klen = -klen_i32;
 786             is_utf8 = TRUE;
 787         } else {
 788             klen = klen_i32;
 789             is_utf8 = FALSE;
 790         }
 791     }
 792     keysave = key;
 793
 794     if (SvRMAGICAL(hv)) {
 795         bool needs_copy;
 796         bool needs_store;
 797         hv_magic_check (hv, &needs_copy, &needs_store);
 798
 799         if (needs_copy) {
 800             sv = NULL;
 801             if (keysv) {
 802                 if ((entry = hv_fetch_ent(hv, keysv, TRUE, hash))) {
 803                     sv = HeVAL(entry);
 804                 }
 805             } else {
 806                 SV **svp;
 807                 if ((svp = hv_fetch(hv, key, is_utf8 ? -klen : klen, TRUE))) {
 808                     sv = *svp;
 809                 }
 810             }
 811             if (sv) {
 812                 if (SvMAGICAL(sv)) {
 813                     mg_clear(sv);
 814                 }
 815                 if (!needs_store) {
 816                     if (mg_find(sv, PERL_MAGIC_tiedelem)) {
 817                         /* No longer an element */
 818                         sv_unmagic(sv, PERL_MAGIC_tiedelem);
 819                         return sv;
 820                     }
 821                     return Nullsv;              /* element cannot be deleted */
 822                 }
 823             }
 824 #ifdef ENV_IS_CASELESS
 825             else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
 826                 /* XXX This code isn't UTF8 clean.  */
 827                 keysv = sv_2mortal(newSVpvn(key,klen));
 828                 keysave = key = strupr(SvPVX(keysv));
 829                 is_utf8 = 0;
 830                 hash = 0;
 831             }
 832 #endif
 833         }
 834     }
 835     xhv = (XPVHV*)SvANY(hv);
 836     if (!xhv->xhv_array /* !HvARRAY(hv) */)
 837         return Nullsv;
 838
 839     if (is_utf8) {
 840         key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
 841         if (is_utf8)
 842             k_flags = HVhek_UTF8;
 843         if (key != keysave)
 844             k_flags |= HVhek_FREEKEY;
 845     }
 846
 847     if (HvREHASH(hv)) {
 848         PERL_HASH_INTERNAL(hash, key, klen);
 849     } else if (!hash) {
 850         PERL_HASH(hash, key, klen);
 851     }
 852
 853     /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
 854     oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
 855     entry = *oentry;
 856     i = 1;
 857     for (; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
 858         if (HeHASH(entry) != hash)              /* strings can't be equal */
 859             continue;
 860         if (HeKLEN(entry) != (I32)klen)
 861             continue;
 862         if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen))        /* is this it? */
 863             continue;
 864         if ((HeKFLAGS(entry) ^ k_flags) & HVhek_UTF8)
 865             continue;
 866         if (k_flags & HVhek_FREEKEY)
 867             Safefree(key);
 868
 869         /* if placeholder is here, it's already been deleted.... */
 870         if (HeVAL(entry) == &PL_sv_placeholder)
 871         {
 872             if (SvREADONLY(hv))
 873                 return Nullsv; /* if still SvREADONLY, leave it deleted. */
 874
 875            /* okay, really delete the placeholder. */
 876            *oentry = HeNEXT(entry);
 877            if (i && !*oentry)
 878                xhv->xhv_fill--; /* HvFILL(hv)-- */
 879            if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
 880                HvLAZYDEL_on(hv);
 881            else
 882                hv_free_ent(hv, entry);
 883            xhv->xhv_keys--; /* HvKEYS(hv)-- */
 884            if (xhv->xhv_keys == 0)
 885                HvHASKFLAGS_off(hv);
 886            xhv->xhv_placeholders--;
 887            return Nullsv;
 888         }
 889         else if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
 890             S_hv_notallowed(aTHX_ k_flags, key, klen,
 891                             "delete readonly key '%"SVf"' from"
 892                             );
 893         }
 894
 895         if (flags & G_DISCARD)
 896             sv = Nullsv;
 897         else {
 898             sv = sv_2mortal(HeVAL(entry));
 899             HeVAL(entry) = &PL_sv_placeholder;
 900         }
 901
 902         /*
 903          * If a restricted hash, rather than really deleting the entry, put
 904          * a placeholder there. This marks the key as being "approved", so
 905          * we can still access via not-really-existing key without raising
 906          * an error.
 907          */
 908         if (SvREADONLY(hv)) {
 909             HeVAL(entry) = &PL_sv_placeholder;
 910             /* We'll be saving this slot, so the number of allocated keys
 911              * doesn't go down, but the number placeholders goes up */
 912             xhv->xhv_placeholders++; /* HvPLACEHOLDERS(hv)++ */
 913         } else {
 914             *oentry = HeNEXT(entry);
 915             if (i && !*oentry)
 916                 xhv->xhv_fill--; /* HvFILL(hv)-- */
 917             if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
 918                 HvLAZYDEL_on(hv);
 919             else
 920                 hv_free_ent(hv, entry);
 921             xhv->xhv_keys--; /* HvKEYS(hv)-- */
 922             if (xhv->xhv_keys == 0)
 923                 HvHASKFLAGS_off(hv);
 924         }
 925         return sv;
 926     }
 927     if (SvREADONLY(hv)) {
 928         S_hv_notallowed(aTHX_ k_flags, key, klen,
 929                         "delete disallowed key '%"SVf"' from"
 930                         );
 931     }
 932
 933     if (k_flags & HVhek_FREEKEY)
 934         Safefree(key);
 935     return Nullsv;
 936 }
 937
 938 /*
 939 =for apidoc hv_exists
 940
 941 Returns a boolean indicating whether the specified hash key exists.  The
 942 C<klen> is the length of the key.
 943
 944 =cut
 945 */
 946
 947 bool
 948 Perl_hv_exists(pTHX_ HV *hv, const char *key, I32 klen)
 949 {
 950     return hv_exists_common(hv, NULL, key, klen, 0);
 951 }
 952
 953 /*
 954 =for apidoc hv_exists_ent
 955
 956 Returns a boolean indicating whether the specified hash key exists. C<hash>
 957 can be a valid precomputed hash value, or 0 to ask for it to be
 958 computed.
 959
 960 =cut
 961 */
 962
 963 bool
 964 Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash)
 965 {
 966     return hv_exists_common(hv, keysv, NULL, 0, hash);
 967 }
 968
 969 bool
 970 S_hv_exists_common(pTHX_ HV *hv, SV *keysv, const char *key, I32 klen_i32,
 971                    U32 hash)
 972 {
 973     register XPVHV* xhv;
 974     STRLEN klen;
 975     register HE *entry;
 976     SV *sv;
 977     bool is_utf8;
 978     const char *keysave;
 979     int k_flags = 0;
 980
 981     if (!hv)
 982         return 0;
 983
 984     if (keysv) {
 985         key = SvPV(keysv, klen);
 986         is_utf8 = (SvUTF8(keysv) != 0);
 987     } else {
 988         if (klen_i32 < 0) {
 989             klen = -klen_i32;
 990             is_utf8 = TRUE;
 991         } else {
 992             klen = klen_i32;
 993             is_utf8 = FALSE;
 994         }
 995     }
 996     keysave = key;
 997
 998     if (SvRMAGICAL(hv)) {
 999         if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
1000             SV* svret;
1001
1002             if (keysv || is_utf8) {
1003                 if (!keysv) {
1004                     keysv = newSVpvn(key, klen);
1005                     SvUTF8_on(keysv);
1006                 } else {
1007                     keysv = newSVsv(keysv);
1008                 }
1009                 key = (char *)sv_2mortal(keysv);
1010                 klen = HEf_SVKEY;
1011             }
1012
1013             /* I don't understand why hv_exists_ent has svret and sv,
1014                whereas hv_exists only had one.  */
1015             svret = sv_newmortal();
1016             sv = sv_newmortal();
1017             mg_copy((SV*)hv, sv, key, klen);
1018             magic_existspack(svret, mg_find(sv, PERL_MAGIC_tiedelem));
1019             return (bool)SvTRUE(svret);
1020         }
1021 #ifdef ENV_IS_CASELESS
1022         else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
1023             /* XXX This code isn't UTF8 clean.  */
1024             keysv = sv_2mortal(newSVpvn(key,klen));
1025             keysave = key = strupr(SvPVX(keysv));
1026             is_utf8 = 0;
1027             hash = 0;
1028         }
1029 #endif
1030     }
1031
1032     xhv = (XPVHV*)SvANY(hv);
1033 #ifndef DYNAMIC_ENV_FETCH
1034     if (!xhv->xhv_array /* !HvARRAY(hv) */)
1035         return 0;
1036 #endif
1037
1038     if (is_utf8) {
1039         key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
1040         if (is_utf8)
1041             k_flags = HVhek_UTF8;
1042         if (key != keysave)
1043             k_flags |= HVhek_FREEKEY;
1044     }
1045     if (HvREHASH(hv)) {
1046         PERL_HASH_INTERNAL(hash, key, klen);
1047     } else if (!hash)
1048         PERL_HASH(hash, key, klen);
1049
1050 #ifdef DYNAMIC_ENV_FETCH
1051     if (!xhv->xhv_array /* !HvARRAY(hv) */) entry = Null(HE*);
1052     else
1053 #endif
1054     /* entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
1055     entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
1056     for (; entry; entry = HeNEXT(entry)) {
1057         if (HeHASH(entry) != hash)              /* strings can't be equal */
1058             continue;
1059         if (HeKLEN(entry) != (I32)klen)
1060             continue;
1061         if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen))        /* is this it? */
1062             continue;
1063         if ((HeKFLAGS(entry) ^ k_flags) & HVhek_UTF8)
1064             continue;
1065         if (k_flags & HVhek_FREEKEY)
1066             Safefree(key);
1067         /* If we find the key, but the value is a placeholder, return false. */
1068         if (HeVAL(entry) == &PL_sv_placeholder)
1069             return FALSE;
1070         return TRUE;
1071     }
1072 #ifdef DYNAMIC_ENV_FETCH  /* is it out there? */
1073     if (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
1074         unsigned long len;
1075         char *env = PerlEnv_ENVgetenv_len(key,&len);
1076         if (env) {
1077             sv = newSVpvn(env,len);
1078             SvTAINTED_on(sv);
1079             (void)hv_store_ent(hv,keysv,sv,hash);
1080             if (k_flags & HVhek_FREEKEY)
1081                 Safefree(key);
1082             return TRUE;
1083         }
1084     }
1085 #endif
1086     if (k_flags & HVhek_FREEKEY)
1087         Safefree(key);
1088     return FALSE;
1089 }
1090
1091
1092 STATIC void
1093 S_hsplit(pTHX_ HV *hv)
1094 {
1095     register XPVHV* xhv = (XPVHV*)SvANY(hv);
1096     I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
1097     register I32 newsize = oldsize * 2;
1098     register I32 i;
1099     register char *a = xhv->xhv_array; /* HvARRAY(hv) */
1100     register HE **aep;
1101     register HE **bep;
1102     register HE *entry;
1103     register HE **oentry;
1104     int longest_chain = 0;
1105     int was_shared;
1106
1107     PL_nomemok = TRUE;
1108 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
1109     Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1110     if (!a) {
1111       PL_nomemok = FALSE;
1112       return;
1113     }
1114 #else
1115     New(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1116     if (!a) {
1117       PL_nomemok = FALSE;
1118       return;
1119     }
1120     Copy(xhv->xhv_array /* HvARRAY(hv) */, a, oldsize * sizeof(HE*), char);
1121     if (oldsize >= 64) {
1122         offer_nice_chunk(xhv->xhv_array /* HvARRAY(hv) */,
1123                         PERL_HV_ARRAY_ALLOC_BYTES(oldsize));
1124     }
1125     else
1126         Safefree(xhv->xhv_array /* HvARRAY(hv) */);
1127 #endif
1128
1129     PL_nomemok = FALSE;
1130     Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char);     /* zero 2nd half*/
1131     xhv->xhv_max = --newsize;   /* HvMAX(hv) = --newsize */
1132     xhv->xhv_array = a;         /* HvARRAY(hv) = a */
1133     aep = (HE**)a;
1134
1135     for (i=0; i<oldsize; i++,aep++) {
1136         int left_length = 0;
1137         int right_length = 0;
1138
1139         if (!*aep)                              /* non-existent */
1140             continue;
1141         bep = aep+oldsize;
1142         for (oentry = aep, entry = *aep; entry; entry = *oentry) {
1143             if ((HeHASH(entry) & newsize) != (U32)i) {
1144                 *oentry = HeNEXT(entry);
1145                 HeNEXT(entry) = *bep;
1146                 if (!*bep)
1147                     xhv->xhv_fill++; /* HvFILL(hv)++ */
1148                 *bep = entry;
1149                 right_length++;
1150                 continue;
1151             }
1152             else {
1153                 oentry = &HeNEXT(entry);
1154                 left_length++;
1155             }
1156         }
1157         if (!*aep)                              /* everything moved */
1158             xhv->xhv_fill--; /* HvFILL(hv)-- */
1159         /* I think we don't actually need to keep track of the longest length,
1160            merely flag if anything is too long. But for the moment while
1161            developing this code I'll track it.  */
1162         if (left_length > longest_chain)
1163             longest_chain = left_length;
1164         if (right_length > longest_chain)
1165             longest_chain = right_length;
1166     }
1167
1168
1169     /* Pick your policy for "hashing isn't working" here:  */
1170     if (longest_chain <= HV_MAX_LENGTH_BEFORE_SPLIT /* split worked?  */
1171         || HvREHASH(hv)) {
1172         return;
1173     }
1174
1175     if (hv == PL_strtab) {
1176         /* Urg. Someone is doing something nasty to the string table.
1177            Can't win.  */
1178         return;
1179     }
1180
1181     /* Awooga. Awooga. Pathological data.  */
1182     /*PerlIO_printf(PerlIO_stderr(), "%p %d of %d with %d/%d buckets\n", hv,
1183       longest_chain, HvTOTALKEYS(hv), HvFILL(hv),  1+HvMAX(hv));*/
1184
1185     ++newsize;
1186     Newz(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1187     was_shared = HvSHAREKEYS(hv);
1188
1189     xhv->xhv_fill = 0;
1190     HvSHAREKEYS_off(hv);
1191     HvREHASH_on(hv);
1192
1193     aep = (HE **) xhv->xhv_array;
1194
1195     for (i=0; i<newsize; i++,aep++) {
1196         entry = *aep;
1197         while (entry) {
1198             /* We're going to trash this HE's next pointer when we chain it
1199                into the new hash below, so store where we go next.  */
1200             HE *next = HeNEXT(entry);
1201             UV hash;
1202
1203             /* Rehash it */
1204             PERL_HASH_INTERNAL(hash, HeKEY(entry), HeKLEN(entry));
1205
1206             if (was_shared) {
1207                 /* Unshare it.  */
1208                 HEK *new_hek
1209                     = save_hek_flags(HeKEY(entry), HeKLEN(entry),
1210                                      hash, HeKFLAGS(entry));
1211                 unshare_hek (HeKEY_hek(entry));
1212                 HeKEY_hek(entry) = new_hek;
1213             } else {
1214                 /* Not shared, so simply write the new hash in. */
1215                 HeHASH(entry) = hash;
1216             }
1217             /*PerlIO_printf(PerlIO_stderr(), "%d ", HeKFLAGS(entry));*/
1218             HEK_REHASH_on(HeKEY_hek(entry));
1219             /*PerlIO_printf(PerlIO_stderr(), "%d\n", HeKFLAGS(entry));*/
1220
1221             /* Copy oentry to the correct new chain.  */
1222             bep = ((HE**)a) + (hash & (I32) xhv->xhv_max);
1223             if (!*bep)
1224                     xhv->xhv_fill++; /* HvFILL(hv)++ */
1225             HeNEXT(entry) = *bep;
1226             *bep = entry;
1227
1228             entry = next;
1229         }
1230     }
1231     Safefree (xhv->xhv_array);
1232     xhv->xhv_array = a;         /* HvARRAY(hv) = a */
1233 }
1234
1235 void
1236 Perl_hv_ksplit(pTHX_ HV *hv, IV newmax)
1237 {
1238     register XPVHV* xhv = (XPVHV*)SvANY(hv);
1239     I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
1240     register I32 newsize;
1241     register I32 i;
1242     register I32 j;
1243     register char *a;
1244     register HE **aep;
1245     register HE *entry;
1246     register HE **oentry;
1247
1248     newsize = (I32) newmax;                     /* possible truncation here */
1249     if (newsize != newmax || newmax <= oldsize)
1250         return;
1251     while ((newsize & (1 + ~newsize)) != newsize) {
1252         newsize &= ~(newsize & (1 + ~newsize)); /* get proper power of 2 */
1253     }
1254     if (newsize < newmax)
1255         newsize *= 2;
1256     if (newsize < newmax)
1257         return;                                 /* overflow detection */
1258
1259     a = xhv->xhv_array; /* HvARRAY(hv) */
1260     if (a) {
1261         PL_nomemok = TRUE;
1262 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
1263         Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1264         if (!a) {
1265           PL_nomemok = FALSE;
1266           return;
1267         }
1268 #else
1269         New(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1270         if (!a) {
1271           PL_nomemok = FALSE;
1272           return;
1273         }
1274         Copy(xhv->xhv_array /* HvARRAY(hv) */, a, oldsize * sizeof(HE*), char);
1275         if (oldsize >= 64) {
1276             offer_nice_chunk(xhv->xhv_array /* HvARRAY(hv) */,
1277                             PERL_HV_ARRAY_ALLOC_BYTES(oldsize));
1278         }
1279         else
1280             Safefree(xhv->xhv_array /* HvARRAY(hv) */);
1281 #endif
1282         PL_nomemok = FALSE;
1283         Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
1284     }
1285     else {
1286         Newz(0, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1287     }
1288     xhv->xhv_max = --newsize;   /* HvMAX(hv) = --newsize */
1289     xhv->xhv_array = a;         /* HvARRAY(hv) = a */
1290     if (!xhv->xhv_fill /* !HvFILL(hv) */)       /* skip rest if no entries */
1291         return;
1292
1293     aep = (HE**)a;
1294     for (i=0; i<oldsize; i++,aep++) {
1295         if (!*aep)                              /* non-existent */
1296             continue;
1297         for (oentry = aep, entry = *aep; entry; entry = *oentry) {
1298             if ((j = (HeHASH(entry) & newsize)) != i) {
1299                 j -= i;
1300                 *oentry = HeNEXT(entry);
1301                 if (!(HeNEXT(entry) = aep[j]))
1302                     xhv->xhv_fill++; /* HvFILL(hv)++ */
1303                 aep[j] = entry;
1304                 continue;
1305             }
1306             else
1307                 oentry = &HeNEXT(entry);
1308         }
1309         if (!*aep)                              /* everything moved */
1310             xhv->xhv_fill--; /* HvFILL(hv)-- */
1311     }
1312 }
1313
1314 /*
1315 =for apidoc newHV
1316
1317 Creates a new HV.  The reference count is set to 1.
1318
1319 =cut
1320 */
1321
1322 HV *
1323 Perl_newHV(pTHX)
1324 {
1325     register HV *hv;
1326     register XPVHV* xhv;
1327
1328     hv = (HV*)NEWSV(502,0);
1329     sv_upgrade((SV *)hv, SVt_PVHV);
1330     xhv = (XPVHV*)SvANY(hv);
1331     SvPOK_off(hv);
1332     SvNOK_off(hv);
1333 #ifndef NODEFAULT_SHAREKEYS
1334     HvSHAREKEYS_on(hv);         /* key-sharing on by default */
1335 #endif
1336
1337     xhv->xhv_max    = 7;        /* HvMAX(hv) = 7 (start with 8 buckets) */
1338     xhv->xhv_fill   = 0;        /* HvFILL(hv) = 0 */
1339     xhv->xhv_pmroot = 0;        /* HvPMROOT(hv) = 0 */
1340     (void)hv_iterinit(hv);      /* so each() will start off right */
1341     return hv;
1342 }
1343
1344 HV *
1345 Perl_newHVhv(pTHX_ HV *ohv)
1346 {
1347     HV *hv = newHV();
1348     STRLEN hv_max, hv_fill;
1349
1350     if (!ohv || (hv_fill = HvFILL(ohv)) == 0)
1351         return hv;
1352     hv_max = HvMAX(ohv);
1353
1354     if (!SvMAGICAL((SV *)ohv)) {
1355         /* It's an ordinary hash, so copy it fast. AMS 20010804 */
1356         STRLEN i;
1357         bool shared = !!HvSHAREKEYS(ohv);
1358         HE **ents, **oents = (HE **)HvARRAY(ohv);
1359         char *a;
1360         New(0, a, PERL_HV_ARRAY_ALLOC_BYTES(hv_max+1), char);
1361         ents = (HE**)a;
1362
1363         /* In each bucket... */
1364         for (i = 0; i <= hv_max; i++) {
1365             HE *prev = NULL, *ent = NULL, *oent = oents[i];
1366
1367             if (!oent) {
1368                 ents[i] = NULL;
1369                 continue;
1370             }
1371
1372             /* Copy the linked list of entries. */
1373             for (oent = oents[i]; oent; oent = HeNEXT(oent)) {
1374                 U32 hash   = HeHASH(oent);
1375                 char *key  = HeKEY(oent);
1376                 STRLEN len = HeKLEN(oent);
1377                 int flags  = HeKFLAGS(oent);
1378
1379                 ent = new_HE();
1380                 HeVAL(ent)     = newSVsv(HeVAL(oent));
1381                 HeKEY_hek(ent)
1382                     = shared ? share_hek_flags(key, len, hash, flags)
1383                              :  save_hek_flags(key, len, hash, flags);
1384                 if (prev)
1385                     HeNEXT(prev) = ent;
1386                 else
1387                     ents[i] = ent;
1388                 prev = ent;
1389                 HeNEXT(ent) = NULL;
1390             }
1391         }
1392
1393         HvMAX(hv)   = hv_max;
1394         HvFILL(hv)  = hv_fill;
1395         HvTOTALKEYS(hv)  = HvTOTALKEYS(ohv);
1396         HvARRAY(hv) = ents;
1397     }
1398     else {
1399         /* Iterate over ohv, copying keys and values one at a time. */
1400         HE *entry;
1401         I32 riter = HvRITER(ohv);
1402         HE *eiter = HvEITER(ohv);
1403
1404         /* Can we use fewer buckets? (hv_max is always 2^n-1) */
1405         while (hv_max && hv_max + 1 >= hv_fill * 2)
1406             hv_max = hv_max / 2;
1407         HvMAX(hv) = hv_max;
1408
1409         hv_iterinit(ohv);
1410         while ((entry = hv_iternext_flags(ohv, 0))) {
1411             hv_store_flags(hv, HeKEY(entry), HeKLEN(entry),
1412                            newSVsv(HeVAL(entry)), HeHASH(entry),
1413                            HeKFLAGS(entry));
1414         }
1415         HvRITER(ohv) = riter;
1416         HvEITER(ohv) = eiter;
1417     }
1418
1419     return hv;
1420 }
1421
1422 void
1423 Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry)
1424 {
1425     SV *val;
1426
1427     if (!entry)
1428         return;
1429     val = HeVAL(entry);
1430     if (val && isGV(val) && GvCVu(val) && HvNAME(hv))
1431         PL_sub_generation++;    /* may be deletion of method from stash */
1432     SvREFCNT_dec(val);
1433     if (HeKLEN(entry) == HEf_SVKEY) {
1434         SvREFCNT_dec(HeKEY_sv(entry));
1435         Safefree(HeKEY_hek(entry));
1436     }
1437     else if (HvSHAREKEYS(hv))
1438         unshare_hek(HeKEY_hek(entry));
1439     else
1440         Safefree(HeKEY_hek(entry));
1441     del_HE(entry);
1442 }
1443
1444 void
1445 Perl_hv_delayfree_ent(pTHX_ HV *hv, register HE *entry)
1446 {
1447     if (!entry)
1448         return;
1449     if (isGV(HeVAL(entry)) && GvCVu(HeVAL(entry)) && HvNAME(hv))
1450         PL_sub_generation++;    /* may be deletion of method from stash */
1451     sv_2mortal(HeVAL(entry));   /* free between statements */
1452     if (HeKLEN(entry) == HEf_SVKEY) {
1453         sv_2mortal(HeKEY_sv(entry));
1454         Safefree(HeKEY_hek(entry));
1455     }
1456     else if (HvSHAREKEYS(hv))
1457         unshare_hek(HeKEY_hek(entry));
1458     else
1459         Safefree(HeKEY_hek(entry));
1460     del_HE(entry);
1461 }
1462
1463 /*
1464 =for apidoc hv_clear
1465
1466 Clears a hash, making it empty.
1467
1468 =cut
1469 */
1470
1471 void
1472 Perl_hv_clear(pTHX_ HV *hv)
1473 {
1474     register XPVHV* xhv;
1475     if (!hv)
1476         return;
1477
1478     DEBUG_A(Perl_hv_assert(aTHX_ hv));
1479
1480     xhv = (XPVHV*)SvANY(hv);
1481
1482     if (SvREADONLY(hv) && xhv->xhv_array != NULL) {
1483         /* restricted hash: convert all keys to placeholders */
1484         I32 i;
1485         HE* entry;
1486         for (i = 0; i <= (I32) xhv->xhv_max; i++) {
1487             entry = ((HE**)xhv->xhv_array)[i];
1488             for (; entry; entry = HeNEXT(entry)) {
1489                 /* not already placeholder */
1490                 if (HeVAL(entry) != &PL_sv_placeholder) {
1491                     if (HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
1492                         SV* keysv = hv_iterkeysv(entry);
1493                         Perl_croak(aTHX_
1494         "Attempt to delete readonly key '%"SVf"' from a restricted hash",
1495                                    keysv);
1496                     }
1497                     SvREFCNT_dec(HeVAL(entry));
1498                     HeVAL(entry) = &PL_sv_placeholder;
1499                     xhv->xhv_placeholders++; /* HvPLACEHOLDERS(hv)++ */
1500                 }
1501             }
1502         }
1503         return;
1504     }
1505
1506     hfreeentries(hv);
1507     xhv->xhv_placeholders = 0; /* HvPLACEHOLDERS(hv) = 0 */
1508     if (xhv->xhv_array /* HvARRAY(hv) */)
1509         (void)memzero(xhv->xhv_array /* HvARRAY(hv) */,
1510                       (xhv->xhv_max+1 /* HvMAX(hv)+1 */) * sizeof(HE*));
1511
1512     if (SvRMAGICAL(hv))
1513         mg_clear((SV*)hv);
1514
1515     HvHASKFLAGS_off(hv);
1516     HvREHASH_off(hv);
1517 }
1518
1519 /*
1520 =for apidoc hv_clear_placeholders
1521
1522 Clears any placeholders from a hash.  If a restricted hash has any of its keys
1523 marked as readonly and the key is subsequently deleted, the key is not actually
1524 deleted but is marked by assigning it a value of &PL_sv_placeholder.  This tags
1525 it so it will be ignored by future operations such as iterating over the hash,
1526 but will still allow the hash to have a value reaasigned to the key at some
1527 future point.  This function clears any such placeholder keys from the hash.
1528 See Hash::Util::lock_keys() for an example of its use.
1529
1530 =cut
1531 */
1532
1533 void
1534 Perl_hv_clear_placeholders(pTHX_ HV *hv)
1535 {
1536     I32 items;
1537     items = (I32)HvPLACEHOLDERS(hv);
1538     if (items) {
1539         HE *entry;
1540         I32 riter = HvRITER(hv);
1541         HE *eiter = HvEITER(hv);
1542         hv_iterinit(hv);
1543         /* This may look suboptimal with the items *after* the iternext, but
1544            it's quite deliberate. We only get here with items==0 if we've
1545            just deleted the last placeholder in the hash. If we've just done
1546            that then it means that the hash is in lazy delete mode, and the
1547            HE is now only referenced in our iterator. If we just quit the loop
1548            and discarded our iterator then the HE leaks. So we do the && the
1549            other way to ensure iternext is called just one more time, which
1550            has the side effect of triggering the lazy delete.  */
1551         while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
1552             && items) {
1553             SV *val = hv_iterval(hv, entry);
1554
1555             if (val == &PL_sv_placeholder) {
1556
1557                 /* It seems that I have to go back in the front of the hash
1558                    API to delete a hash, even though I have a HE structure
1559                    pointing to the very entry I want to delete, and could hold
1560                    onto the previous HE that points to it. And it's easier to
1561                    go in with SVs as I can then specify the precomputed hash,
1562                    and don't have fun and games with utf8 keys.  */
1563                 SV *key = hv_iterkeysv(entry);
1564
1565                 hv_delete_ent (hv, key, G_DISCARD, HeHASH(entry));
1566                 items--;
1567             }
1568         }
1569         HvRITER(hv) = riter;
1570         HvEITER(hv) = eiter;
1571     }
1572 }
1573
1574 STATIC void
1575 S_hfreeentries(pTHX_ HV *hv)
1576 {
1577     register HE **array;
1578     register HE *entry;
1579     register HE *oentry = Null(HE*);
1580     I32 riter;
1581     I32 max;
1582
1583     if (!hv)
1584         return;
1585     if (!HvARRAY(hv))
1586         return;
1587
1588     riter = 0;
1589     max = HvMAX(hv);
1590     array = HvARRAY(hv);
1591     /* make everyone else think the array is empty, so that the destructors
1592      * called for freed entries can't recusively mess with us */
1593     HvARRAY(hv) = Null(HE**);
1594     HvFILL(hv) = 0;
1595     ((XPVHV*) SvANY(hv))->xhv_keys = 0;
1596
1597     entry = array[0];
1598     for (;;) {
1599         if (entry) {
1600             oentry = entry;
1601             entry = HeNEXT(entry);
1602             hv_free_ent(hv, oentry);
1603         }
1604         if (!entry) {
1605             if (++riter > max)
1606                 break;
1607             entry = array[riter];
1608         }
1609     }
1610     HvARRAY(hv) = array;
1611     (void)hv_iterinit(hv);
1612 }
1613
1614 /*
1615 =for apidoc hv_undef
1616
1617 Undefines the hash.
1618
1619 =cut
1620 */
1621
1622 void
1623 Perl_hv_undef(pTHX_ HV *hv)
1624 {
1625     register XPVHV* xhv;
1626     if (!hv)
1627         return;
1628     DEBUG_A(Perl_hv_assert(aTHX_ hv));
1629     xhv = (XPVHV*)SvANY(hv);
1630     hfreeentries(hv);
1631     Safefree(xhv->xhv_array /* HvARRAY(hv) */);
1632     if (HvNAME(hv)) {
1633         if(PL_stashcache)
1634             hv_delete(PL_stashcache, HvNAME(hv), strlen(HvNAME(hv)), G_DISCARD);
1635         Safefree(HvNAME(hv));
1636         HvNAME(hv) = 0;
1637     }
1638     xhv->xhv_max   = 7; /* HvMAX(hv) = 7 (it's a normal hash) */
1639     xhv->xhv_array = 0; /* HvARRAY(hv) = 0 */
1640     xhv->xhv_placeholders = 0; /* HvPLACEHOLDERS(hv) = 0 */
1641
1642     if (SvRMAGICAL(hv))
1643         mg_clear((SV*)hv);
1644 }
1645
1646 /*
1647 =for apidoc hv_iterinit
1648
1649 Prepares a starting point to traverse a hash table.  Returns the number of
1650 keys in the hash (i.e. the same as C<HvKEYS(tb)>).  The return value is
1651 currently only meaningful for hashes without tie magic.
1652
1653 NOTE: Before version 5.004_65, C<hv_iterinit> used to return the number of
1654 hash buckets that happen to be in use.  If you still need that esoteric
1655 value, you can get it through the macro C<HvFILL(tb)>.
1656
1657
1658 =cut
1659 */
1660
1661 I32
1662 Perl_hv_iterinit(pTHX_ HV *hv)
1663 {
1664     register XPVHV* xhv;
1665     HE *entry;
1666
1667     if (!hv)
1668         Perl_croak(aTHX_ "Bad hash");
1669     xhv = (XPVHV*)SvANY(hv);
1670     entry = xhv->xhv_eiter; /* HvEITER(hv) */
1671     if (entry && HvLAZYDEL(hv)) {       /* was deleted earlier? */
1672         HvLAZYDEL_off(hv);
1673         hv_free_ent(hv, entry);
1674     }
1675     xhv->xhv_riter = -1;        /* HvRITER(hv) = -1 */
1676     xhv->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */
1677     /* used to be xhv->xhv_fill before 5.004_65 */
1678     return XHvTOTALKEYS(xhv);
1679 }
1680 /*
1681 =for apidoc hv_iternext
1682
1683 Returns entries from a hash iterator.  See C<hv_iterinit>.
1684
1685 You may call C<hv_delete> or C<hv_delete_ent> on the hash entry that the
1686 iterator currently points to, without losing your place or invalidating your
1687 iterator.  Note that in this case the current entry is deleted from the hash
1688 with your iterator holding the last reference to it.  Your iterator is flagged
1689 to free the entry on the next call to C<hv_iternext>, so you must not discard
1690 your iterator immediately else the entry will leak - call C<hv_iternext> to
1691 trigger the resource deallocation.
1692
1693 =cut
1694 */
1695
1696 HE *
1697 Perl_hv_iternext(pTHX_ HV *hv)
1698 {
1699     return hv_iternext_flags(hv, 0);
1700 }
1701
1702 /*
1703 =for apidoc hv_iternext_flags
1704
1705 Returns entries from a hash iterator.  See C<hv_iterinit> and C<hv_iternext>.
1706 The C<flags> value will normally be zero; if HV_ITERNEXT_WANTPLACEHOLDERS is
1707 set the placeholders keys (for restricted hashes) will be returned in addition
1708 to normal keys. By default placeholders are automatically skipped over.
1709 Currently a placeholder is implemented with a value that is
1710 C<&Perl_sv_placeholder>. Note that the implementation of placeholders and
1711 restricted hashes may change, and the implementation currently is
1712 insufficiently abstracted for any change to be tidy.
1713
1714 =cut
1715 */
1716
1717 HE *
1718 Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags)
1719 {
1720     register XPVHV* xhv;
1721     register HE *entry;
1722     HE *oldentry;
1723     MAGIC* mg;
1724
1725     if (!hv)
1726         Perl_croak(aTHX_ "Bad hash");
1727     xhv = (XPVHV*)SvANY(hv);
1728     oldentry = entry = xhv->xhv_eiter; /* HvEITER(hv) */
1729
1730     if ((mg = SvTIED_mg((SV*)hv, PERL_MAGIC_tied))) {
1731         SV *key = sv_newmortal();
1732         if (entry) {
1733             sv_setsv(key, HeSVKEY_force(entry));
1734             SvREFCNT_dec(HeSVKEY(entry));       /* get rid of previous key */
1735         }
1736         else {
1737             char *k;
1738             HEK *hek;
1739
1740             /* one HE per MAGICAL hash */
1741             xhv->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */
1742             Zero(entry, 1, HE);
1743             Newz(54, k, HEK_BASESIZE + sizeof(SV*), char);
1744             hek = (HEK*)k;
1745             HeKEY_hek(entry) = hek;
1746             HeKLEN(entry) = HEf_SVKEY;
1747         }
1748         magic_nextpack((SV*) hv,mg,key);
1749         if (SvOK(key)) {
1750             /* force key to stay around until next time */
1751             HeSVKEY_set(entry, SvREFCNT_inc(key));
1752             return entry;               /* beware, hent_val is not set */
1753         }
1754         if (HeVAL(entry))
1755             SvREFCNT_dec(HeVAL(entry));
1756         Safefree(HeKEY_hek(entry));
1757         del_HE(entry);
1758         xhv->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */
1759         return Null(HE*);
1760     }
1761 #ifdef DYNAMIC_ENV_FETCH  /* set up %ENV for iteration */
1762     if (!entry && SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
1763         prime_env_iter();
1764 #endif
1765
1766     if (!xhv->xhv_array /* !HvARRAY(hv) */)
1767         Newz(506, xhv->xhv_array /* HvARRAY(hv) */,
1768              PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
1769              char);
1770     /* At start of hash, entry is NULL.  */
1771     if (entry)
1772     {
1773         entry = HeNEXT(entry);
1774         if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
1775             /*
1776              * Skip past any placeholders -- don't want to include them in
1777              * any iteration.
1778              */
1779             while (entry && HeVAL(entry) == &PL_sv_placeholder) {
1780                 entry = HeNEXT(entry);
1781             }
1782         }
1783     }
1784     while (!entry) {
1785         /* OK. Come to the end of the current list.  Grab the next one.  */
1786
1787         xhv->xhv_riter++; /* HvRITER(hv)++ */
1788         if (xhv->xhv_riter > (I32)xhv->xhv_max /* HvRITER(hv) > HvMAX(hv) */) {
1789             /* There is no next one.  End of the hash.  */
1790             xhv->xhv_riter = -1; /* HvRITER(hv) = -1 */
1791             break;
1792         }
1793         /* entry = (HvARRAY(hv))[HvRITER(hv)]; */
1794         entry = ((HE**)xhv->xhv_array)[xhv->xhv_riter];
1795
1796         if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
1797             /* If we have an entry, but it's a placeholder, don't count it.
1798                Try the next.  */
1799             while (entry && HeVAL(entry) == &PL_sv_placeholder)
1800                 entry = HeNEXT(entry);
1801         }
1802         /* Will loop again if this linked list starts NULL
1803            (for HV_ITERNEXT_WANTPLACEHOLDERS)
1804            or if we run through it and find only placeholders.  */
1805     }
1806
1807     if (oldentry && HvLAZYDEL(hv)) {            /* was deleted earlier? */
1808         HvLAZYDEL_off(hv);
1809         hv_free_ent(hv, oldentry);
1810     }
1811
1812     /*if (HvREHASH(hv) && entry && !HeKREHASH(entry))
1813       PerlIO_printf(PerlIO_stderr(), "Awooga %p %p\n", hv, entry);*/
1814
1815     xhv->xhv_eiter = entry; /* HvEITER(hv) = entry */
1816     return entry;
1817 }
1818
1819 /*
1820 =for apidoc hv_iterkey
1821
1822 Returns the key from the current position of the hash iterator.  See
1823 C<hv_iterinit>.
1824
1825 =cut
1826 */
1827
1828 char *
1829 Perl_hv_iterkey(pTHX_ register HE *entry, I32 *retlen)
1830 {
1831     if (HeKLEN(entry) == HEf_SVKEY) {
1832         STRLEN len;
1833         char *p = SvPV(HeKEY_sv(entry), len);
1834         *retlen = len;
1835         return p;
1836     }
1837     else {
1838         *retlen = HeKLEN(entry);
1839         return HeKEY(entry);
1840     }
1841 }
1842
1843 /* unlike hv_iterval(), this always returns a mortal copy of the key */
1844 /*
1845 =for apidoc hv_iterkeysv
1846
1847 Returns the key as an C<SV*> from the current position of the hash
1848 iterator.  The return value will always be a mortal copy of the key.  Also
1849 see C<hv_iterinit>.
1850
1851 =cut
1852 */
1853
1854 SV *
1855 Perl_hv_iterkeysv(pTHX_ register HE *entry)
1856 {
1857     if (HeKLEN(entry) != HEf_SVKEY) {
1858         HEK *hek = HeKEY_hek(entry);
1859         int flags = HEK_FLAGS(hek);
1860         SV *sv;
1861
1862         if (flags & HVhek_WASUTF8) {
1863             /* Trouble :-)
1864                Andreas would like keys he put in as utf8 to come back as utf8
1865             */
1866             STRLEN utf8_len = HEK_LEN(hek);
1867             U8 *as_utf8 = bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len);
1868
1869             sv = newSVpvn ((char*)as_utf8, utf8_len);
1870             SvUTF8_on (sv);
1871             Safefree (as_utf8); /* bytes_to_utf8() allocates a new string */
1872         } else if (flags & HVhek_REHASH) {
1873             /* We don't have a pointer to the hv, so we have to replicate the
1874                flag into every HEK. This hv is using custom a hasing
1875                algorithm. Hence we can't return a shared string scalar, as
1876                that would contain the (wrong) hash value, and might get passed
1877                into an hv routine with a regular hash  */
1878
1879             sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek));
1880             if (HEK_UTF8(hek))
1881                 SvUTF8_on (sv);
1882         } else {
1883             sv = newSVpvn_share(HEK_KEY(hek),
1884                                 (HEK_UTF8(hek) ? -HEK_LEN(hek) : HEK_LEN(hek)),
1885                                 HEK_HASH(hek));
1886         }
1887         return sv_2mortal(sv);
1888     }
1889     return sv_mortalcopy(HeKEY_sv(entry));
1890 }
1891
1892 /*
1893 =for apidoc hv_iterval
1894
1895 Returns the value from the current position of the hash iterator.  See
1896 C<hv_iterkey>.
1897
1898 =cut
1899 */
1900
1901 SV *
1902 Perl_hv_iterval(pTHX_ HV *hv, register HE *entry)
1903 {
1904     if (SvRMAGICAL(hv)) {
1905         if (mg_find((SV*)hv, PERL_MAGIC_tied)) {
1906             SV* sv = sv_newmortal();
1907             if (HeKLEN(entry) == HEf_SVKEY)
1908                 mg_copy((SV*)hv, sv, (char*)HeKEY_sv(entry), HEf_SVKEY);
1909             else mg_copy((SV*)hv, sv, HeKEY(entry), HeKLEN(entry));
1910             return sv;
1911         }
1912     }
1913     return HeVAL(entry);
1914 }
1915
1916 /*
1917 =for apidoc hv_iternextsv
1918
1919 Performs an C<hv_iternext>, C<hv_iterkey>, and C<hv_iterval> in one
1920 operation.
1921
1922 =cut
1923 */
1924
1925 SV *
1926 Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen)
1927 {
1928     HE *he;
1929     if ( (he = hv_iternext_flags(hv, 0)) == NULL)
1930         return NULL;
1931     *key = hv_iterkey(he, retlen);
1932     return hv_iterval(hv, he);
1933 }
1934
1935 /*
1936 =for apidoc hv_magic
1937
1938 Adds magic to a hash.  See C<sv_magic>.
1939
1940 =cut
1941 */
1942
1943 void
1944 Perl_hv_magic(pTHX_ HV *hv, GV *gv, int how)
1945 {
1946     sv_magic((SV*)hv, (SV*)gv, how, Nullch, 0);
1947 }
1948
1949 #if 0 /* use the macro from hv.h instead */
1950
1951 char*
1952 Perl_sharepvn(pTHX_ const char *sv, I32 len, U32 hash)
1953 {
1954     return HEK_KEY(share_hek(sv, len, hash));
1955 }
1956
1957 #endif
1958
1959 /* possibly free a shared string if no one has access to it
1960  * len and hash must both be valid for str.
1961  */
1962 void
1963 Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
1964 {
1965     unshare_hek_or_pvn (NULL, str, len, hash);
1966 }
1967
1968
1969 void
1970 Perl_unshare_hek(pTHX_ HEK *hek)
1971 {
1972     unshare_hek_or_pvn(hek, NULL, 0, 0);
1973 }
1974
1975 /* possibly free a shared string if no one has access to it
1976    hek if non-NULL takes priority over the other 3, else str, len and hash
1977    are used.  If so, len and hash must both be valid for str.
1978  */
1979 STATIC void
1980 S_unshare_hek_or_pvn(pTHX_ HEK *hek, const char *str, I32 len, U32 hash)
1981 {
1982     register XPVHV* xhv;
1983     register HE *entry;
1984     register HE **oentry;
1985     register I32 i = 1;
1986     I32 found = 0;
1987     bool is_utf8 = FALSE;
1988     int k_flags = 0;
1989     const char *save = str;
1990
1991     if (hek) {
1992         hash = HEK_HASH(hek);
1993     } else if (len < 0) {
1994         STRLEN tmplen = -len;
1995         is_utf8 = TRUE;
1996         /* See the note in hv_fetch(). --jhi */
1997         str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
1998         len = tmplen;
1999         if (is_utf8)
2000             k_flags = HVhek_UTF8;
2001         if (str != save)
2002             k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2003     }
2004
2005     /* what follows is the moral equivalent of:
2006     if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) {
2007         if (--*Svp == Nullsv)
2008             hv_delete(PL_strtab, str, len, G_DISCARD, hash);
2009     } */
2010     xhv = (XPVHV*)SvANY(PL_strtab);
2011     /* assert(xhv_array != 0) */
2012     LOCK_STRTAB_MUTEX;
2013     /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
2014     oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
2015     if (hek) {
2016         for (entry = *oentry; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
2017             if (HeKEY_hek(entry) != hek)
2018                 continue;
2019             found = 1;
2020             break;
2021         }
2022     } else {
2023         int flags_masked = k_flags & HVhek_MASK;
2024         for (entry = *oentry; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
2025             if (HeHASH(entry) != hash)          /* strings can't be equal */
2026                 continue;
2027             if (HeKLEN(entry) != len)
2028                 continue;
2029             if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len))     /* is this it? */
2030                 continue;
2031             if (HeKFLAGS(entry) != flags_masked)
2032                 continue;
2033             found = 1;
2034             break;
2035         }
2036     }
2037
2038     if (found) {
2039         if (--HeVAL(entry) == Nullsv) {
2040             *oentry = HeNEXT(entry);
2041             if (i && !*oentry)
2042                 xhv->xhv_fill--; /* HvFILL(hv)-- */
2043             Safefree(HeKEY_hek(entry));
2044             del_HE(entry);
2045             xhv->xhv_keys--; /* HvKEYS(hv)-- */
2046         }
2047     }
2048
2049     UNLOCK_STRTAB_MUTEX;
2050     if (!found && ckWARN_d(WARN_INTERNAL))
2051         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
2052                     "Attempt to free non-existent shared string '%s'%s",
2053                     hek ? HEK_KEY(hek) : str,
2054                     (k_flags & HVhek_UTF8) ? " (utf8)" : "");
2055     if (k_flags & HVhek_FREEKEY)
2056         Safefree(str);
2057 }
2058
2059 /* get a (constant) string ptr from the global string table
2060  * string will get added if it is not already there.
2061  * len and hash must both be valid for str.
2062  */
2063 HEK *
2064 Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash)
2065 {
2066     bool is_utf8 = FALSE;
2067     int flags = 0;
2068     const char *save = str;
2069
2070     if (len < 0) {
2071       STRLEN tmplen = -len;
2072       is_utf8 = TRUE;
2073       /* See the note in hv_fetch(). --jhi */
2074       str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2075       len = tmplen;
2076       /* If we were able to downgrade here, then than means that we were passed
2077          in a key which only had chars 0-255, but was utf8 encoded.  */
2078       if (is_utf8)
2079           flags = HVhek_UTF8;
2080       /* If we found we were able to downgrade the string to bytes, then
2081          we should flag that it needs upgrading on keys or each.  Also flag
2082          that we need share_hek_flags to free the string.  */
2083       if (str != save)
2084           flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2085     }
2086
2087     return share_hek_flags (str, len, hash, flags);
2088 }
2089
2090 STATIC HEK *
2091 S_share_hek_flags(pTHX_ const char *str, I32 len, register U32 hash, int flags)
2092 {
2093     register XPVHV* xhv;
2094     register HE *entry;
2095     register HE **oentry;
2096     register I32 i = 1;
2097     I32 found = 0;
2098     int flags_masked = flags & HVhek_MASK;
2099
2100     /* what follows is the moral equivalent of:
2101
2102     if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
2103         hv_store(PL_strtab, str, len, Nullsv, hash);
2104
2105         Can't rehash the shared string table, so not sure if it's worth
2106         counting the number of entries in the linked list
2107     */
2108     xhv = (XPVHV*)SvANY(PL_strtab);
2109     /* assert(xhv_array != 0) */
2110     LOCK_STRTAB_MUTEX;
2111     /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
2112     oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
2113     for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
2114         if (HeHASH(entry) != hash)              /* strings can't be equal */
2115             continue;
2116         if (HeKLEN(entry) != len)
2117             continue;
2118         if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
2119             continue;
2120         if (HeKFLAGS(entry) != flags_masked)
2121             continue;
2122         found = 1;
2123         break;
2124     }
2125     if (!found) {
2126         entry = new_HE();
2127         HeKEY_hek(entry) = save_hek_flags(str, len, hash, flags);
2128         HeVAL(entry) = Nullsv;
2129         HeNEXT(entry) = *oentry;
2130         *oentry = entry;
2131         xhv->xhv_keys++; /* HvKEYS(hv)++ */
2132         if (i) {                                /* initial entry? */
2133             xhv->xhv_fill++; /* HvFILL(hv)++ */
2134         } else if (xhv->xhv_keys > (IV)xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */) {
2135                 hsplit(PL_strtab);
2136         }
2137     }
2138
2139     ++HeVAL(entry);                             /* use value slot as REFCNT */
2140     UNLOCK_STRTAB_MUTEX;
2141
2142     if (flags & HVhek_FREEKEY)
2143         Safefree(str);
2144
2145     return HeKEY_hek(entry);
2146 }
2147
2148
2149 /*
2150 =for apidoc hv_assert
2151
2152 Check that a hash is in an internally consistent state.
2153
2154 =cut
2155 */
2156
2157 void
2158 Perl_hv_assert(pTHX_ HV *hv)
2159 {
2160   HE* entry;
2161   int withflags = 0;
2162   int placeholders = 0;
2163   int real = 0;
2164   int bad = 0;
2165   I32 riter = HvRITER(hv);
2166   HE *eiter = HvEITER(hv);
2167
2168   (void)hv_iterinit(hv);
2169
2170   while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))) {
2171     /* sanity check the values */
2172     if (HeVAL(entry) == &PL_sv_placeholder) {
2173       placeholders++;
2174     } else {
2175       real++;
2176     }
2177     /* sanity check the keys */
2178     if (HeSVKEY(entry)) {
2179       /* Don't know what to check on SV keys.  */
2180     } else if (HeKUTF8(entry)) {
2181       withflags++;
2182        if (HeKWASUTF8(entry)) {
2183          PerlIO_printf(Perl_debug_log,
2184                        "hash key has both WASUFT8 and UTF8: '%.*s'\n",
2185                        (int) HeKLEN(entry),  HeKEY(entry));
2186          bad = 1;
2187        }
2188     } else if (HeKWASUTF8(entry)) {
2189       withflags++;
2190     }
2191   }
2192   if (!SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) {
2193     if (HvUSEDKEYS(hv) != real) {
2194       PerlIO_printf(Perl_debug_log, "Count %d key(s), but hash reports %d\n",
2195                     (int) real, (int) HvUSEDKEYS(hv));
2196       bad = 1;
2197     }
2198     if (HvPLACEHOLDERS(hv) != placeholders) {
2199       PerlIO_printf(Perl_debug_log,
2200                     "Count %d placeholder(s), but hash reports %d\n",
2201                     (int) placeholders, (int) HvPLACEHOLDERS(hv));
2202       bad = 1;
2203     }
2204   }
2205   if (withflags && ! HvHASKFLAGS(hv)) {
2206     PerlIO_printf(Perl_debug_log,
2207                   "Hash has HASKFLAGS off but I count %d key(s) with flags\n",
2208                   withflags);
2209     bad = 1;
2210   }
2211   if (bad) {
2212     sv_dump((SV *)hv);
2213   }
2214   HvRITER(hv) = riter;          /* Restore hash iterator state */
2215   HvEITER(hv) = eiter;
2216 }