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 STATIC void
1625 S_hfreeentries(pTHX_ HV *hv)
1626 {
1627     register HE **array;
1628     register HE *entry;
1629     register HE *oentry = Null(HE*);
1630     I32 riter;
1631     I32 max;
1632
1633     if (!hv)
1634         return;
1635     if (!HvARRAY(hv))
1636         return;
1637
1638     riter = 0;
1639     max = HvMAX(hv);
1640     array = HvARRAY(hv);
1641     /* make everyone else think the array is empty, so that the destructors
1642      * called for freed entries can't recusively mess with us */
1643     HvARRAY(hv) = Null(HE**);
1644     HvFILL(hv) = 0;
1645     ((XPVHV*) SvANY(hv))->xhv_keys = 0;
1646
1647     entry = array[0];
1648     for (;;) {
1649         if (entry) {
1650             oentry = entry;
1651             entry = HeNEXT(entry);
1652             hv_free_ent(hv, oentry);
1653         }
1654         if (!entry) {
1655             if (++riter > max)
1656                 break;
1657             entry = array[riter];
1658         }
1659     }
1660     HvARRAY(hv) = array;
1661     (void)hv_iterinit(hv);
1662 }
1663
1664 /*
1665 =for apidoc hv_undef
1666
1667 Undefines the hash.
1668
1669 =cut
1670 */
1671
1672 void
1673 Perl_hv_undef(pTHX_ HV *hv)
1674 {
1675     register XPVHV* xhv;
1676     if (!hv)
1677         return;
1678     DEBUG_A(Perl_hv_assert(aTHX_ hv));
1679     xhv = (XPVHV*)SvANY(hv);
1680     hfreeentries(hv);
1681     Safefree(xhv->xhv_array /* HvARRAY(hv) */);
1682     if (HvNAME(hv)) {
1683         if(PL_stashcache)
1684             hv_delete(PL_stashcache, HvNAME(hv), strlen(HvNAME(hv)), G_DISCARD);
1685         Safefree(HvNAME(hv));
1686         HvNAME(hv) = 0;
1687     }
1688     xhv->xhv_max   = 7; /* HvMAX(hv) = 7 (it's a normal hash) */
1689     xhv->xhv_array = 0; /* HvARRAY(hv) = 0 */
1690     xhv->xhv_placeholders = 0; /* HvPLACEHOLDERS(hv) = 0 */
1691
1692     if (SvRMAGICAL(hv))
1693         mg_clear((SV*)hv);
1694 }
1695
1696 /*
1697 =for apidoc hv_iterinit
1698
1699 Prepares a starting point to traverse a hash table.  Returns the number of
1700 keys in the hash (i.e. the same as C<HvKEYS(tb)>).  The return value is
1701 currently only meaningful for hashes without tie magic.
1702
1703 NOTE: Before version 5.004_65, C<hv_iterinit> used to return the number of
1704 hash buckets that happen to be in use.  If you still need that esoteric
1705 value, you can get it through the macro C<HvFILL(tb)>.
1706
1707
1708 =cut
1709 */
1710
1711 I32
1712 Perl_hv_iterinit(pTHX_ HV *hv)
1713 {
1714     register XPVHV* xhv;
1715     HE *entry;
1716
1717     if (!hv)
1718         Perl_croak(aTHX_ "Bad hash");
1719     xhv = (XPVHV*)SvANY(hv);
1720     entry = xhv->xhv_eiter; /* HvEITER(hv) */
1721     if (entry && HvLAZYDEL(hv)) {       /* was deleted earlier? */
1722         HvLAZYDEL_off(hv);
1723         hv_free_ent(hv, entry);
1724     }
1725     xhv->xhv_riter = -1;        /* HvRITER(hv) = -1 */
1726     xhv->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */
1727     /* used to be xhv->xhv_fill before 5.004_65 */
1728     return XHvTOTALKEYS(xhv);
1729 }
1730 /*
1731 =for apidoc hv_iternext
1732
1733 Returns entries from a hash iterator.  See C<hv_iterinit>.
1734
1735 You may call C<hv_delete> or C<hv_delete_ent> on the hash entry that the
1736 iterator currently points to, without losing your place or invalidating your
1737 iterator.  Note that in this case the current entry is deleted from the hash
1738 with your iterator holding the last reference to it.  Your iterator is flagged
1739 to free the entry on the next call to C<hv_iternext>, so you must not discard
1740 your iterator immediately else the entry will leak - call C<hv_iternext> to
1741 trigger the resource deallocation.
1742
1743 =cut
1744 */
1745
1746 HE *
1747 Perl_hv_iternext(pTHX_ HV *hv)
1748 {
1749     return hv_iternext_flags(hv, 0);
1750 }
1751
1752 /*
1753 =for apidoc hv_iternext_flags
1754
1755 Returns entries from a hash iterator.  See C<hv_iterinit> and C<hv_iternext>.
1756 The C<flags> value will normally be zero; if HV_ITERNEXT_WANTPLACEHOLDERS is
1757 set the placeholders keys (for restricted hashes) will be returned in addition
1758 to normal keys. By default placeholders are automatically skipped over.
1759 Currently a placeholder is implemented with a value that is
1760 C<&Perl_sv_placeholder>. Note that the implementation of placeholders and
1761 restricted hashes may change, and the implementation currently is
1762 insufficiently abstracted for any change to be tidy.
1763
1764 =cut
1765 */
1766
1767 HE *
1768 Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags)
1769 {
1770     register XPVHV* xhv;
1771     register HE *entry;
1772     HE *oldentry;
1773     MAGIC* mg;
1774
1775     if (!hv)
1776         Perl_croak(aTHX_ "Bad hash");
1777     xhv = (XPVHV*)SvANY(hv);
1778     oldentry = entry = xhv->xhv_eiter; /* HvEITER(hv) */
1779
1780     if ((mg = SvTIED_mg((SV*)hv, PERL_MAGIC_tied))) {
1781         SV *key = sv_newmortal();
1782         if (entry) {
1783             sv_setsv(key, HeSVKEY_force(entry));
1784             SvREFCNT_dec(HeSVKEY(entry));       /* get rid of previous key */
1785         }
1786         else {
1787             char *k;
1788             HEK *hek;
1789
1790             /* one HE per MAGICAL hash */
1791             xhv->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */
1792             Zero(entry, 1, HE);
1793             Newz(54, k, HEK_BASESIZE + sizeof(SV*), char);
1794             hek = (HEK*)k;
1795             HeKEY_hek(entry) = hek;
1796             HeKLEN(entry) = HEf_SVKEY;
1797         }
1798         magic_nextpack((SV*) hv,mg,key);
1799         if (SvOK(key)) {
1800             /* force key to stay around until next time */
1801             HeSVKEY_set(entry, SvREFCNT_inc(key));
1802             return entry;               /* beware, hent_val is not set */
1803         }
1804         if (HeVAL(entry))
1805             SvREFCNT_dec(HeVAL(entry));
1806         Safefree(HeKEY_hek(entry));
1807         del_HE(entry);
1808         xhv->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */
1809         return Null(HE*);
1810     }
1811 #ifdef DYNAMIC_ENV_FETCH  /* set up %ENV for iteration */
1812     if (!entry && SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
1813         prime_env_iter();
1814 #endif
1815
1816     if (!xhv->xhv_array /* !HvARRAY(hv) */)
1817         Newz(506, xhv->xhv_array /* HvARRAY(hv) */,
1818              PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
1819              char);
1820     /* At start of hash, entry is NULL.  */
1821     if (entry)
1822     {
1823         entry = HeNEXT(entry);
1824         if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
1825             /*
1826              * Skip past any placeholders -- don't want to include them in
1827              * any iteration.
1828              */
1829             while (entry && HeVAL(entry) == &PL_sv_placeholder) {
1830                 entry = HeNEXT(entry);
1831             }
1832         }
1833     }
1834     while (!entry) {
1835         /* OK. Come to the end of the current list.  Grab the next one.  */
1836
1837         xhv->xhv_riter++; /* HvRITER(hv)++ */
1838         if (xhv->xhv_riter > (I32)xhv->xhv_max /* HvRITER(hv) > HvMAX(hv) */) {
1839             /* There is no next one.  End of the hash.  */
1840             xhv->xhv_riter = -1; /* HvRITER(hv) = -1 */
1841             break;
1842         }
1843         /* entry = (HvARRAY(hv))[HvRITER(hv)]; */
1844         entry = ((HE**)xhv->xhv_array)[xhv->xhv_riter];
1845
1846         if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
1847             /* If we have an entry, but it's a placeholder, don't count it.
1848                Try the next.  */
1849             while (entry && HeVAL(entry) == &PL_sv_placeholder)
1850                 entry = HeNEXT(entry);
1851         }
1852         /* Will loop again if this linked list starts NULL
1853            (for HV_ITERNEXT_WANTPLACEHOLDERS)
1854            or if we run through it and find only placeholders.  */
1855     }
1856
1857     if (oldentry && HvLAZYDEL(hv)) {            /* was deleted earlier? */
1858         HvLAZYDEL_off(hv);
1859         hv_free_ent(hv, oldentry);
1860     }
1861
1862     /*if (HvREHASH(hv) && entry && !HeKREHASH(entry))
1863       PerlIO_printf(PerlIO_stderr(), "Awooga %p %p\n", hv, entry);*/
1864
1865     xhv->xhv_eiter = entry; /* HvEITER(hv) = entry */
1866     return entry;
1867 }
1868
1869 /*
1870 =for apidoc hv_iterkey
1871
1872 Returns the key from the current position of the hash iterator.  See
1873 C<hv_iterinit>.
1874
1875 =cut
1876 */
1877
1878 char *
1879 Perl_hv_iterkey(pTHX_ register HE *entry, I32 *retlen)
1880 {
1881     if (HeKLEN(entry) == HEf_SVKEY) {
1882         STRLEN len;
1883         char *p = SvPV(HeKEY_sv(entry), len);
1884         *retlen = len;
1885         return p;
1886     }
1887     else {
1888         *retlen = HeKLEN(entry);
1889         return HeKEY(entry);
1890     }
1891 }
1892
1893 /* unlike hv_iterval(), this always returns a mortal copy of the key */
1894 /*
1895 =for apidoc hv_iterkeysv
1896
1897 Returns the key as an C<SV*> from the current position of the hash
1898 iterator.  The return value will always be a mortal copy of the key.  Also
1899 see C<hv_iterinit>.
1900
1901 =cut
1902 */
1903
1904 SV *
1905 Perl_hv_iterkeysv(pTHX_ register HE *entry)
1906 {
1907     if (HeKLEN(entry) != HEf_SVKEY) {
1908         HEK *hek = HeKEY_hek(entry);
1909         int flags = HEK_FLAGS(hek);
1910         SV *sv;
1911
1912         if (flags & HVhek_WASUTF8) {
1913             /* Trouble :-)
1914                Andreas would like keys he put in as utf8 to come back as utf8
1915             */
1916             STRLEN utf8_len = HEK_LEN(hek);
1917             U8 *as_utf8 = bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len);
1918
1919             sv = newSVpvn ((char*)as_utf8, utf8_len);
1920             SvUTF8_on (sv);
1921             Safefree (as_utf8); /* bytes_to_utf8() allocates a new string */
1922         } else if (flags & HVhek_REHASH) {
1923             /* We don't have a pointer to the hv, so we have to replicate the
1924                flag into every HEK. This hv is using custom a hasing
1925                algorithm. Hence we can't return a shared string scalar, as
1926                that would contain the (wrong) hash value, and might get passed
1927                into an hv routine with a regular hash  */
1928
1929             sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek));
1930             if (HEK_UTF8(hek))
1931                 SvUTF8_on (sv);
1932         } else {
1933             sv = newSVpvn_share(HEK_KEY(hek),
1934                                 (HEK_UTF8(hek) ? -HEK_LEN(hek) : HEK_LEN(hek)),
1935                                 HEK_HASH(hek));
1936         }
1937         return sv_2mortal(sv);
1938     }
1939     return sv_mortalcopy(HeKEY_sv(entry));
1940 }
1941
1942 /*
1943 =for apidoc hv_iterval
1944
1945 Returns the value from the current position of the hash iterator.  See
1946 C<hv_iterkey>.
1947
1948 =cut
1949 */
1950
1951 SV *
1952 Perl_hv_iterval(pTHX_ HV *hv, register HE *entry)
1953 {
1954     if (SvRMAGICAL(hv)) {
1955         if (mg_find((SV*)hv, PERL_MAGIC_tied)) {
1956             SV* sv = sv_newmortal();
1957             if (HeKLEN(entry) == HEf_SVKEY)
1958                 mg_copy((SV*)hv, sv, (char*)HeKEY_sv(entry), HEf_SVKEY);
1959             else mg_copy((SV*)hv, sv, HeKEY(entry), HeKLEN(entry));
1960             return sv;
1961         }
1962     }
1963     return HeVAL(entry);
1964 }
1965
1966 /*
1967 =for apidoc hv_iternextsv
1968
1969 Performs an C<hv_iternext>, C<hv_iterkey>, and C<hv_iterval> in one
1970 operation.
1971
1972 =cut
1973 */
1974
1975 SV *
1976 Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen)
1977 {
1978     HE *he;
1979     if ( (he = hv_iternext_flags(hv, 0)) == NULL)
1980         return NULL;
1981     *key = hv_iterkey(he, retlen);
1982     return hv_iterval(hv, he);
1983 }
1984
1985 /*
1986 =for apidoc hv_magic
1987
1988 Adds magic to a hash.  See C<sv_magic>.
1989
1990 =cut
1991 */
1992
1993 void
1994 Perl_hv_magic(pTHX_ HV *hv, GV *gv, int how)
1995 {
1996     sv_magic((SV*)hv, (SV*)gv, how, Nullch, 0);
1997 }
1998
1999 #if 0 /* use the macro from hv.h instead */
2000
2001 char*
2002 Perl_sharepvn(pTHX_ const char *sv, I32 len, U32 hash)
2003 {
2004     return HEK_KEY(share_hek(sv, len, hash));
2005 }
2006
2007 #endif
2008
2009 /* possibly free a shared string if no one has access to it
2010  * len and hash must both be valid for str.
2011  */
2012 void
2013 Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
2014 {
2015     unshare_hek_or_pvn (NULL, str, len, hash);
2016 }
2017
2018
2019 void
2020 Perl_unshare_hek(pTHX_ HEK *hek)
2021 {
2022     unshare_hek_or_pvn(hek, NULL, 0, 0);
2023 }
2024
2025 /* possibly free a shared string if no one has access to it
2026    hek if non-NULL takes priority over the other 3, else str, len and hash
2027    are used.  If so, len and hash must both be valid for str.
2028  */
2029 STATIC void
2030 S_unshare_hek_or_pvn(pTHX_ HEK *hek, const char *str, I32 len, U32 hash)
2031 {
2032     register XPVHV* xhv;
2033     register HE *entry;
2034     register HE **oentry;
2035     register I32 i = 1;
2036     I32 found = 0;
2037     bool is_utf8 = FALSE;
2038     int k_flags = 0;
2039     const char *save = str;
2040
2041     if (hek) {
2042         hash = HEK_HASH(hek);
2043     } else if (len < 0) {
2044         STRLEN tmplen = -len;
2045         is_utf8 = TRUE;
2046         /* See the note in hv_fetch(). --jhi */
2047         str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2048         len = tmplen;
2049         if (is_utf8)
2050             k_flags = HVhek_UTF8;
2051         if (str != save)
2052             k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2053     }
2054
2055     /* what follows is the moral equivalent of:
2056     if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) {
2057         if (--*Svp == Nullsv)
2058             hv_delete(PL_strtab, str, len, G_DISCARD, hash);
2059     } */
2060     xhv = (XPVHV*)SvANY(PL_strtab);
2061     /* assert(xhv_array != 0) */
2062     LOCK_STRTAB_MUTEX;
2063     /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
2064     oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
2065     if (hek) {
2066         for (entry = *oentry; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
2067             if (HeKEY_hek(entry) != hek)
2068                 continue;
2069             found = 1;
2070             break;
2071         }
2072     } else {
2073         int flags_masked = k_flags & HVhek_MASK;
2074         for (entry = *oentry; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
2075             if (HeHASH(entry) != hash)          /* strings can't be equal */
2076                 continue;
2077             if (HeKLEN(entry) != len)
2078                 continue;
2079             if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len))     /* is this it? */
2080                 continue;
2081             if (HeKFLAGS(entry) != flags_masked)
2082                 continue;
2083             found = 1;
2084             break;
2085         }
2086     }
2087
2088     if (found) {
2089         if (--HeVAL(entry) == Nullsv) {
2090             *oentry = HeNEXT(entry);
2091             if (i && !*oentry)
2092                 xhv->xhv_fill--; /* HvFILL(hv)-- */
2093             Safefree(HeKEY_hek(entry));
2094             del_HE(entry);
2095             xhv->xhv_keys--; /* HvKEYS(hv)-- */
2096         }
2097     }
2098
2099     UNLOCK_STRTAB_MUTEX;
2100     if (!found && ckWARN_d(WARN_INTERNAL))
2101         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
2102                     "Attempt to free non-existent shared string '%s'%s",
2103                     hek ? HEK_KEY(hek) : str,
2104                     (k_flags & HVhek_UTF8) ? " (utf8)" : "");
2105     if (k_flags & HVhek_FREEKEY)
2106         Safefree(str);
2107 }
2108
2109 /* get a (constant) string ptr from the global string table
2110  * string will get added if it is not already there.
2111  * len and hash must both be valid for str.
2112  */
2113 HEK *
2114 Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash)
2115 {
2116     bool is_utf8 = FALSE;
2117     int flags = 0;
2118     const char *save = str;
2119
2120     if (len < 0) {
2121       STRLEN tmplen = -len;
2122       is_utf8 = TRUE;
2123       /* See the note in hv_fetch(). --jhi */
2124       str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2125       len = tmplen;
2126       /* If we were able to downgrade here, then than means that we were passed
2127          in a key which only had chars 0-255, but was utf8 encoded.  */
2128       if (is_utf8)
2129           flags = HVhek_UTF8;
2130       /* If we found we were able to downgrade the string to bytes, then
2131          we should flag that it needs upgrading on keys or each.  Also flag
2132          that we need share_hek_flags to free the string.  */
2133       if (str != save)
2134           flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2135     }
2136
2137     return share_hek_flags (str, len, hash, flags);
2138 }
2139
2140 STATIC HEK *
2141 S_share_hek_flags(pTHX_ const char *str, I32 len, register U32 hash, int flags)
2142 {
2143     register XPVHV* xhv;
2144     register HE *entry;
2145     register HE **oentry;
2146     register I32 i = 1;
2147     I32 found = 0;
2148     int flags_masked = flags & HVhek_MASK;
2149
2150     /* what follows is the moral equivalent of:
2151
2152     if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
2153         hv_store(PL_strtab, str, len, Nullsv, hash);
2154
2155         Can't rehash the shared string table, so not sure if it's worth
2156         counting the number of entries in the linked list
2157     */
2158     xhv = (XPVHV*)SvANY(PL_strtab);
2159     /* assert(xhv_array != 0) */
2160     LOCK_STRTAB_MUTEX;
2161     /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
2162     oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
2163     for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
2164         if (HeHASH(entry) != hash)              /* strings can't be equal */
2165             continue;
2166         if (HeKLEN(entry) != len)
2167             continue;
2168         if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
2169             continue;
2170         if (HeKFLAGS(entry) != flags_masked)
2171             continue;
2172         found = 1;
2173         break;
2174     }
2175     if (!found) {
2176         entry = new_HE();
2177         HeKEY_hek(entry) = save_hek_flags(str, len, hash, flags);
2178         HeVAL(entry) = Nullsv;
2179         HeNEXT(entry) = *oentry;
2180         *oentry = entry;
2181         xhv->xhv_keys++; /* HvKEYS(hv)++ */
2182         if (i) {                                /* initial entry? */
2183             xhv->xhv_fill++; /* HvFILL(hv)++ */
2184         } else if (xhv->xhv_keys > (IV)xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */) {
2185                 hsplit(PL_strtab);
2186         }
2187     }
2188
2189     ++HeVAL(entry);                             /* use value slot as REFCNT */
2190     UNLOCK_STRTAB_MUTEX;
2191
2192     if (flags & HVhek_FREEKEY)
2193         Safefree(str);
2194
2195     return HeKEY_hek(entry);
2196 }
2197
2198
2199 /*
2200 =for apidoc hv_assert
2201
2202 Check that a hash is in an internally consistent state.
2203
2204 =cut
2205 */
2206
2207 void
2208 Perl_hv_assert(pTHX_ HV *hv)
2209 {
2210   HE* entry;
2211   int withflags = 0;
2212   int placeholders = 0;
2213   int real = 0;
2214   int bad = 0;
2215   I32 riter = HvRITER(hv);
2216   HE *eiter = HvEITER(hv);
2217
2218   (void)hv_iterinit(hv);
2219
2220   while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))) {
2221     /* sanity check the values */
2222     if (HeVAL(entry) == &PL_sv_placeholder) {
2223       placeholders++;
2224     } else {
2225       real++;
2226     }
2227     /* sanity check the keys */
2228     if (HeSVKEY(entry)) {
2229       /* Don't know what to check on SV keys.  */
2230     } else if (HeKUTF8(entry)) {
2231       withflags++;
2232        if (HeKWASUTF8(entry)) {
2233          PerlIO_printf(Perl_debug_log,
2234                        "hash key has both WASUFT8 and UTF8: '%.*s'\n",
2235                        (int) HeKLEN(entry),  HeKEY(entry));
2236          bad = 1;
2237        }
2238     } else if (HeKWASUTF8(entry)) {
2239       withflags++;
2240     }
2241   }
2242   if (!SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) {
2243     if (HvUSEDKEYS(hv) != real) {
2244       PerlIO_printf(Perl_debug_log, "Count %d key(s), but hash reports %d\n",
2245                     (int) real, (int) HvUSEDKEYS(hv));
2246       bad = 1;
2247     }
2248     if (HvPLACEHOLDERS(hv) != placeholders) {
2249       PerlIO_printf(Perl_debug_log,
2250                     "Count %d placeholder(s), but hash reports %d\n",
2251                     (int) placeholders, (int) HvPLACEHOLDERS(hv));
2252       bad = 1;
2253     }
2254   }
2255   if (withflags && ! HvHASKFLAGS(hv)) {
2256     PerlIO_printf(Perl_debug_log,
2257                   "Hash has HASKFLAGS off but I count %d key(s) with flags\n",
2258                   withflags);
2259     bad = 1;
2260   }
2261   if (bad) {
2262     sv_dump((SV *)hv);
2263   }
2264   HvRITER(hv) = riter;          /* Restore hash iterator state */
2265   HvEITER(hv) = eiter;
2266 }