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