hv.c

   1 /*    hv.c
   2  *
   3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
   4  *    2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 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 A HV structure represents a Perl hash. It consists mainly of an array
  19 of pointers, each of which points to a linked list of HE structures. The
  20 array is indexed by the hash function of the key, so each linked list
  21 represents all the hash entries with the same hash value. Each HE contains
  22 a pointer to the actual value, plus a pointer to a HEK structure which
  23 holds the key and hash value.
  24
  25 =cut
  26
  27 */
  28
  29 #include "EXTERN.h"
  30 #define PERL_IN_HV_C
  31 #define PERL_HASH_INTERNAL_ACCESS
  32 #include "perl.h"
  33
  34 #define HV_MAX_LENGTH_BEFORE_SPLIT 14
  35
  36 static const char S_strtab_error[]
  37     = "Cannot modify shared string table in hv_%s";
  38
  39 STATIC void
  40 S_more_he(pTHX)
  41 {
  42     dVAR;
  43     HE* he = (HE*) Perl_get_arena(aTHX_ PERL_ARENA_SIZE, HE_SVSLOT);
  44     HE * const heend = &he[PERL_ARENA_SIZE / sizeof(HE) - 1];
  45
  46     PL_body_roots[HE_SVSLOT] = he;
  47     while (he < heend) {
  48         HeNEXT(he) = (HE*)(he + 1);
  49         he++;
  50     }
  51     HeNEXT(he) = 0;
  52 }
  53
  54 #ifdef PURIFY
  55
  56 #define new_HE() (HE*)safemalloc(sizeof(HE))
  57 #define del_HE(p) safefree((char*)p)
  58
  59 #else
  60
  61 STATIC HE*
  62 S_new_he(pTHX)
  63 {
  64     dVAR;
  65     HE* he;
  66     void ** const root = &PL_body_roots[HE_SVSLOT];
  67
  68     if (!*root)
  69         S_more_he(aTHX);
  70     he = (HE*) *root;
  71     assert(he);
  72     *root = HeNEXT(he);
  73     return he;
  74 }
  75
  76 #define new_HE() new_he()
  77 #define del_HE(p) \
  78     STMT_START { \
  79         HeNEXT(p) = (HE*)(PL_body_roots[HE_SVSLOT]);    \
  80         PL_body_roots[HE_SVSLOT] = p; \
  81     } STMT_END
  82
  83
  84
  85 #endif
  86
  87 STATIC HEK *
  88 S_save_hek_flags(const char *str, I32 len, U32 hash, int flags)
  89 {
  90     const int flags_masked = flags & HVhek_MASK;
  91     char *k;
  92     register HEK *hek;
  93
  94     Newx(k, HEK_BASESIZE + len + 2, char);
  95     hek = (HEK*)k;
  96     Copy(str, HEK_KEY(hek), len, char);
  97     HEK_KEY(hek)[len] = 0;
  98     HEK_LEN(hek) = len;
  99     HEK_HASH(hek) = hash;
 100     HEK_FLAGS(hek) = (unsigned char)flags_masked | HVhek_UNSHARED;
 101
 102     if (flags & HVhek_FREEKEY)
 103         Safefree(str);
 104     return hek;
 105 }
 106
 107 /* free the pool of temporary HE/HEK pairs returned by hv_fetch_ent
 108  * for tied hashes */
 109
 110 void
 111 Perl_free_tied_hv_pool(pTHX)
 112 {
 113     dVAR;
 114     HE *he = PL_hv_fetch_ent_mh;
 115     while (he) {
 116         HE * const ohe = he;
 117         Safefree(HeKEY_hek(he));
 118         he = HeNEXT(he);
 119         del_HE(ohe);
 120     }
 121     PL_hv_fetch_ent_mh = NULL;
 122 }
 123
 124 #if defined(USE_ITHREADS)
 125 HEK *
 126 Perl_hek_dup(pTHX_ HEK *source, CLONE_PARAMS* param)
 127 {
 128     HEK *shared = (HEK*)ptr_table_fetch(PL_ptr_table, source);
 129
 130     PERL_UNUSED_ARG(param);
 131
 132     if (shared) {
 133         /* We already shared this hash key.  */
 134         (void)share_hek_hek(shared);
 135     }
 136     else {
 137         shared
 138             = share_hek_flags(HEK_KEY(source), HEK_LEN(source),
 139                               HEK_HASH(source), HEK_FLAGS(source));
 140         ptr_table_store(PL_ptr_table, source, shared);
 141     }
 142     return shared;
 143 }
 144
 145 HE *
 146 Perl_he_dup(pTHX_ const HE *e, bool shared, CLONE_PARAMS* param)
 147 {
 148     HE *ret;
 149
 150     if (!e)
 151         return NULL;
 152     /* look for it in the table first */
 153     ret = (HE*)ptr_table_fetch(PL_ptr_table, e);
 154     if (ret)
 155         return ret;
 156
 157     /* create anew and remember what it is */
 158     ret = new_HE();
 159     ptr_table_store(PL_ptr_table, e, ret);
 160
 161     HeNEXT(ret) = he_dup(HeNEXT(e),shared, param);
 162     if (HeKLEN(e) == HEf_SVKEY) {
 163         char *k;
 164         Newx(k, HEK_BASESIZE + sizeof(SV*), char);
 165         HeKEY_hek(ret) = (HEK*)k;
 166         HeKEY_sv(ret) = SvREFCNT_inc(sv_dup(HeKEY_sv(e), param));
 167     }
 168     else if (shared) {
 169         /* This is hek_dup inlined, which seems to be important for speed
 170            reasons.  */
 171         HEK * const source = HeKEY_hek(e);
 172         HEK *shared = (HEK*)ptr_table_fetch(PL_ptr_table, source);
 173
 174         if (shared) {
 175             /* We already shared this hash key.  */
 176             (void)share_hek_hek(shared);
 177         }
 178         else {
 179             shared
 180                 = share_hek_flags(HEK_KEY(source), HEK_LEN(source),
 181                                   HEK_HASH(source), HEK_FLAGS(source));
 182             ptr_table_store(PL_ptr_table, source, shared);
 183         }
 184         HeKEY_hek(ret) = shared;
 185     }
 186     else
 187         HeKEY_hek(ret) = save_hek_flags(HeKEY(e), HeKLEN(e), HeHASH(e),
 188                                         HeKFLAGS(e));
 189     HeVAL(ret) = SvREFCNT_inc(sv_dup(HeVAL(e), param));
 190     return ret;
 191 }
 192 #endif  /* USE_ITHREADS */
 193
 194 static void
 195 S_hv_notallowed(pTHX_ int flags, const char *key, I32 klen,
 196                 const char *msg)
 197 {
 198     SV * const sv = sv_newmortal();
 199     if (!(flags & HVhek_FREEKEY)) {
 200         sv_setpvn(sv, key, klen);
 201     }
 202     else {
 203         /* Need to free saved eventually assign to mortal SV */
 204         /* XXX is this line an error ???:  SV *sv = sv_newmortal(); */
 205         sv_usepvn(sv, (char *) key, klen);
 206     }
 207     if (flags & HVhek_UTF8) {
 208         SvUTF8_on(sv);
 209     }
 210     Perl_croak(aTHX_ msg, SVfARG(sv));
 211 }
 212
 213 /* (klen == HEf_SVKEY) is special for MAGICAL hv entries, meaning key slot
 214  * contains an SV* */
 215
 216 /*
 217 =for apidoc hv_store
 218
 219 Stores an SV in a hash.  The hash key is specified as C<key> and C<klen> is
 220 the length of the key.  The C<hash> parameter is the precomputed hash
 221 value; if it is zero then Perl will compute it.  The return value will be
 222 NULL if the operation failed or if the value did not need to be actually
 223 stored within the hash (as in the case of tied hashes).  Otherwise it can
 224 be dereferenced to get the original C<SV*>.  Note that the caller is
 225 responsible for suitably incrementing the reference count of C<val> before
 226 the call, and decrementing it if the function returned NULL.  Effectively
 227 a successful hv_store takes ownership of one reference to C<val>.  This is
 228 usually what you want; a newly created SV has a reference count of one, so
 229 if all your code does is create SVs then store them in a hash, hv_store
 230 will own the only reference to the new SV, and your code doesn't need to do
 231 anything further to tidy up.  hv_store is not implemented as a call to
 232 hv_store_ent, and does not create a temporary SV for the key, so if your
 233 key data is not already in SV form then use hv_store in preference to
 234 hv_store_ent.
 235
 236 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
 237 information on how to use this function on tied hashes.
 238
 239 =cut
 240 */
 241
 242 SV**
 243 Perl_hv_store(pTHX_ HV *hv, const char *key, I32 klen_i32, SV *val, U32 hash)
 244 {
 245     HE *hek;
 246     STRLEN klen;
 247     int flags;
 248
 249     if (klen_i32 < 0) {
 250         klen = -klen_i32;
 251         flags = HVhek_UTF8;
 252     } else {
 253         klen = klen_i32;
 254         flags = 0;
 255     }
 256     hek = (HE *) hv_common(hv, NULL, key, klen, flags,
 257                            (HV_FETCH_ISSTORE|HV_FETCH_JUST_SV), val, hash);
 258     return hek ? &HeVAL(hek) : NULL;
 259 }
 260
 261 /* Tricky to inlike this because it needs a temporary variable */
 262 SV**
 263 Perl_hv_store_flags(pTHX_ HV *hv, const char *key, I32 klen, SV *val,
 264                  register U32 hash, int flags)
 265 {
 266     HE * const hek = (HE *) hv_common(hv, NULL, key, klen, flags,
 267                                       (HV_FETCH_ISSTORE|HV_FETCH_JUST_SV), val,
 268                                       hash);
 269     return hek ? &HeVAL(hek) : NULL;
 270 }
 271
 272 /*
 273 =for apidoc hv_store_ent
 274
 275 Stores C<val> in a hash.  The hash key is specified as C<key>.  The C<hash>
 276 parameter is the precomputed hash value; if it is zero then Perl will
 277 compute it.  The return value is the new hash entry so created.  It will be
 278 NULL if the operation failed or if the value did not need to be actually
 279 stored within the hash (as in the case of tied hashes).  Otherwise the
 280 contents of the return value can be accessed using the C<He?> macros
 281 described here.  Note that the caller is responsible for suitably
 282 incrementing the reference count of C<val> before the call, and
 283 decrementing it if the function returned NULL.  Effectively a successful
 284 hv_store_ent takes ownership of one reference to C<val>.  This is
 285 usually what you want; a newly created SV has a reference count of one, so
 286 if all your code does is create SVs then store them in a hash, hv_store
 287 will own the only reference to the new SV, and your code doesn't need to do
 288 anything further to tidy up.  Note that hv_store_ent only reads the C<key>;
 289 unlike C<val> it does not take ownership of it, so maintaining the correct
 290 reference count on C<key> is entirely the caller's responsibility.  hv_store
 291 is not implemented as a call to hv_store_ent, and does not create a temporary
 292 SV for the key, so if your key data is not already in SV form then use
 293 hv_store in preference to hv_store_ent.
 294
 295 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
 296 information on how to use this function on tied hashes.
 297
 298 =cut
 299 */
 300
 301 /*
 302 =for apidoc hv_exists
 303
 304 Returns a boolean indicating whether the specified hash key exists.  The
 305 C<klen> is the length of the key.
 306
 307 =cut
 308 */
 309
 310 bool
 311 Perl_hv_exists(pTHX_ HV *hv, const char *key, I32 klen_i32)
 312 {
 313     STRLEN klen;
 314     int flags;
 315
 316     if (klen_i32 < 0) {
 317         klen = -klen_i32;
 318         flags = HVhek_UTF8;
 319     } else {
 320         klen = klen_i32;
 321         flags = 0;
 322     }
 323     return hv_common(hv, NULL, key, klen, flags, HV_FETCH_ISEXISTS, 0, 0)
 324         ? TRUE : FALSE;
 325 }
 326
 327 /*
 328 =for apidoc hv_fetch
 329
 330 Returns the SV which corresponds to the specified key in the hash.  The
 331 C<klen> is the length of the key.  If C<lval> is set then the fetch will be
 332 part of a store.  Check that the return value is non-null before
 333 dereferencing it to an C<SV*>.
 334
 335 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
 336 information on how to use this function on tied hashes.
 337
 338 =cut
 339 */
 340
 341 SV**
 342 Perl_hv_fetch(pTHX_ HV *hv, const char *key, I32 klen_i32, I32 lval)
 343 {
 344     HE *hek;
 345     STRLEN klen;
 346     int flags;
 347
 348     if (klen_i32 < 0) {
 349         klen = -klen_i32;
 350         flags = HVhek_UTF8;
 351     } else {
 352         klen = klen_i32;
 353         flags = 0;
 354     }
 355     hek = (HE *) hv_common(hv, NULL, key, klen, flags,
 356                            lval ? (HV_FETCH_JUST_SV | HV_FETCH_LVALUE)
 357                            : HV_FETCH_JUST_SV, NULL, 0);
 358     return hek ? &HeVAL(hek) : NULL;
 359 }
 360
 361 /*
 362 =for apidoc hv_exists_ent
 363
 364 Returns a boolean indicating whether the specified hash key exists. C<hash>
 365 can be a valid precomputed hash value, or 0 to ask for it to be
 366 computed.
 367
 368 =cut
 369 */
 370
 371 /* returns an HE * structure with the all fields set */
 372 /* note that hent_val will be a mortal sv for MAGICAL hashes */
 373 /*
 374 =for apidoc hv_fetch_ent
 375
 376 Returns the hash entry which corresponds to the specified key in the hash.
 377 C<hash> must be a valid precomputed hash number for the given C<key>, or 0
 378 if you want the function to compute it.  IF C<lval> is set then the fetch
 379 will be part of a store.  Make sure the return value is non-null before
 380 accessing it.  The return value when C<tb> is a tied hash is a pointer to a
 381 static location, so be sure to make a copy of the structure if you need to
 382 store it somewhere.
 383
 384 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
 385 information on how to use this function on tied hashes.
 386
 387 =cut
 388 */
 389
 390 void *
 391 Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
 392                int flags, int action, SV *val, register U32 hash)
 393 {
 394     dVAR;
 395     XPVHV* xhv;
 396     HE *entry;
 397     HE **oentry;
 398     SV *sv;
 399     bool is_utf8;
 400     int masked_flags;
 401
 402     if (!hv)
 403         return NULL;
 404     if (SvTYPE(hv) == SVTYPEMASK)
 405         return NULL;
 406
 407     assert(SvTYPE(hv) == SVt_PVHV);
 408
 409     if (SvSMAGICAL(hv) && SvGMAGICAL(hv) && !(action & HV_DISABLE_UVAR_XKEY)) {
 410         MAGIC* mg;
 411         if ((mg = mg_find((SV*)hv, PERL_MAGIC_uvar))) {
 412             struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
 413             if (uf->uf_set == NULL) {
 414                 SV* obj = mg->mg_obj;
 415
 416                 if (!keysv) {
 417                     keysv = sv_2mortal(newSVpvn(key, klen));
 418                     if (flags & HVhek_UTF8)
 419                         SvUTF8_on(keysv);
 420                 }
 421
 422                 mg->mg_obj = keysv;         /* pass key */
 423                 uf->uf_index = action;      /* pass action */
 424                 magic_getuvar((SV*)hv, mg);
 425                 keysv = mg->mg_obj;         /* may have changed */
 426                 mg->mg_obj = obj;
 427
 428                 /* If the key may have changed, then we need to invalidate
 429                    any passed-in computed hash value.  */
 430                 hash = 0;
 431             }
 432         }
 433     }
 434     if (keysv) {
 435         if (flags & HVhek_FREEKEY)
 436             Safefree(key);
 437         key = SvPV_const(keysv, klen);
 438         flags = 0;
 439         is_utf8 = (SvUTF8(keysv) != 0);
 440     } else {
 441         is_utf8 = ((flags & HVhek_UTF8) ? TRUE : FALSE);
 442     }
 443
 444     if (action & HV_DELETE) {
 445         return (HE *) hv_delete_common(hv, keysv, key, klen,
 446                                        flags | (is_utf8 ? HVhek_UTF8 : 0),
 447                                        action, hash);
 448     }
 449
 450     xhv = (XPVHV*)SvANY(hv);
 451     if (SvMAGICAL(hv)) {
 452         if (SvRMAGICAL(hv) && !(action & (HV_FETCH_ISSTORE|HV_FETCH_ISEXISTS))) {
 453             if ( mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv))
 454             {
 455                 /* XXX should be able to skimp on the HE/HEK here when
 456                    HV_FETCH_JUST_SV is true.  */
 457                 if (!keysv) {
 458                     keysv = newSVpvn(key, klen);
 459                     if (is_utf8) {
 460                         SvUTF8_on(keysv);
 461                     }
 462                 } else {
 463                     keysv = newSVsv(keysv);
 464                 }
 465                 sv = sv_newmortal();
 466                 mg_copy((SV*)hv, sv, (char *)keysv, HEf_SVKEY);
 467
 468                 /* grab a fake HE/HEK pair from the pool or make a new one */
 469                 entry = PL_hv_fetch_ent_mh;
 470                 if (entry)
 471                     PL_hv_fetch_ent_mh = HeNEXT(entry);
 472                 else {
 473                     char *k;
 474                     entry = new_HE();
 475                     Newx(k, HEK_BASESIZE + sizeof(SV*), char);
 476                     HeKEY_hek(entry) = (HEK*)k;
 477                 }
 478                 HeNEXT(entry) = NULL;
 479                 HeSVKEY_set(entry, keysv);
 480                 HeVAL(entry) = sv;
 481                 sv_upgrade(sv, SVt_PVLV);
 482                 LvTYPE(sv) = 'T';
 483                  /* so we can free entry when freeing sv */
 484                 LvTARG(sv) = (SV*)entry;
 485
 486                 /* XXX remove at some point? */
 487                 if (flags & HVhek_FREEKEY)
 488                     Safefree(key);
 489
 490                 return entry;
 491             }
 492 #ifdef ENV_IS_CASELESS
 493             else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
 494                 U32 i;
 495                 for (i = 0; i < klen; ++i)
 496                     if (isLOWER(key[i])) {
 497                         /* Would be nice if we had a routine to do the
 498                            copy and upercase in a single pass through.  */
 499                         const char * const nkey = strupr(savepvn(key,klen));
 500                         /* Note that this fetch is for nkey (the uppercased
 501                            key) whereas the store is for key (the original)  */
 502                         void *result = hv_common(hv, NULL, nkey, klen,
 503                                                  HVhek_FREEKEY, /* free nkey */
 504                                                  0 /* non-LVAL fetch */
 505                                                  | HV_DISABLE_UVAR_XKEY,
 506                                                  NULL /* no value */,
 507                                                  0 /* compute hash */);
 508                         if (!entry && (action & HV_FETCH_LVALUE)) {
 509                             /* This call will free key if necessary.
 510                                Do it this way to encourage compiler to tail
 511                                call optimise.  */
 512                             result = hv_common(hv, keysv, key, klen, flags,
 513                                                HV_FETCH_ISSTORE
 514                                                | HV_DISABLE_UVAR_XKEY,
 515                                                newSV(0), hash);
 516                         } else {
 517                             if (flags & HVhek_FREEKEY)
 518                                 Safefree(key);
 519                         }
 520                         return result;
 521                     }
 522             }
 523 #endif
 524         } /* ISFETCH */
 525         else if (SvRMAGICAL(hv) && (action & HV_FETCH_ISEXISTS)) {
 526             if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
 527                 /* I don't understand why hv_exists_ent has svret and sv,
 528                    whereas hv_exists only had one.  */
 529                 SV * const svret = sv_newmortal();
 530                 sv = sv_newmortal();
 531
 532                 if (keysv || is_utf8) {
 533                     if (!keysv) {
 534                         keysv = newSVpvn(key, klen);
 535                         SvUTF8_on(keysv);
 536                     } else {
 537                         keysv = newSVsv(keysv);
 538                     }
 539                     mg_copy((SV*)hv, sv, (char *)sv_2mortal(keysv), HEf_SVKEY);
 540                 } else {
 541                     mg_copy((SV*)hv, sv, key, klen);
 542                 }
 543                 if (flags & HVhek_FREEKEY)
 544                     Safefree(key);
 545                 magic_existspack(svret, mg_find(sv, PERL_MAGIC_tiedelem));
 546                 /* This cast somewhat evil, but I'm merely using NULL/
 547                    not NULL to return the boolean exists.
 548                    And I know hv is not NULL.  */
 549                 return SvTRUE(svret) ? (HE *)hv : NULL;
 550                 }
 551 #ifdef ENV_IS_CASELESS
 552             else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
 553                 /* XXX This code isn't UTF8 clean.  */
 554                 char * const keysave = (char * const)key;
 555                 /* Will need to free this, so set FREEKEY flag.  */
 556                 key = savepvn(key,klen);
 557                 key = (const char*)strupr((char*)key);
 558                 is_utf8 = FALSE;
 559                 hash = 0;
 560                 keysv = 0;
 561
 562                 if (flags & HVhek_FREEKEY) {
 563                     Safefree(keysave);
 564                 }
 565                 flags |= HVhek_FREEKEY;
 566             }
 567 #endif
 568         } /* ISEXISTS */
 569         else if (action & HV_FETCH_ISSTORE) {
 570             bool needs_copy;
 571             bool needs_store;
 572             hv_magic_check (hv, &needs_copy, &needs_store);
 573             if (needs_copy) {
 574                 const bool save_taint = PL_tainted;
 575                 if (keysv || is_utf8) {
 576                     if (!keysv) {
 577                         keysv = newSVpvn(key, klen);
 578                         SvUTF8_on(keysv);
 579                     }
 580                     if (PL_tainting)
 581                         PL_tainted = SvTAINTED(keysv);
 582                     keysv = sv_2mortal(newSVsv(keysv));
 583                     mg_copy((SV*)hv, val, (char*)keysv, HEf_SVKEY);
 584                 } else {
 585                     mg_copy((SV*)hv, val, key, klen);
 586                 }
 587
 588                 TAINT_IF(save_taint);
 589                 if (!needs_store) {
 590                     if (flags & HVhek_FREEKEY)
 591                         Safefree(key);
 592                     return NULL;
 593                 }
 594 #ifdef ENV_IS_CASELESS
 595                 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
 596                     /* XXX This code isn't UTF8 clean.  */
 597                     const char *keysave = key;
 598                     /* Will need to free this, so set FREEKEY flag.  */
 599                     key = savepvn(key,klen);
 600                     key = (const char*)strupr((char*)key);
 601                     is_utf8 = FALSE;
 602                     hash = 0;
 603                     keysv = 0;
 604
 605                     if (flags & HVhek_FREEKEY) {
 606                         Safefree(keysave);
 607                     }
 608                     flags |= HVhek_FREEKEY;
 609                 }
 610 #endif
 611             }
 612         } /* ISSTORE */
 613     } /* SvMAGICAL */
 614
 615     if (!HvARRAY(hv)) {
 616         if ((action & (HV_FETCH_LVALUE | HV_FETCH_ISSTORE))
 617 #ifdef DYNAMIC_ENV_FETCH  /* if it's an %ENV lookup, we may get it on the fly */
 618                  || (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
 619 #endif
 620                                                                   ) {
 621             char *array;
 622             Newxz(array,
 623                  PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
 624                  char);
 625             HvARRAY(hv) = (HE**)array;
 626         }
 627 #ifdef DYNAMIC_ENV_FETCH
 628         else if (action & HV_FETCH_ISEXISTS) {
 629             /* for an %ENV exists, if we do an insert it's by a recursive
 630                store call, so avoid creating HvARRAY(hv) right now.  */
 631         }
 632 #endif
 633         else {
 634             /* XXX remove at some point? */
 635             if (flags & HVhek_FREEKEY)
 636                 Safefree(key);
 637
 638             return 0;
 639         }
 640     }
 641
 642     if (is_utf8) {
 643         char * const keysave = (char *)key;
 644         key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
 645         if (is_utf8)
 646             flags |= HVhek_UTF8;
 647         else
 648             flags &= ~HVhek_UTF8;
 649         if (key != keysave) {
 650             if (flags & HVhek_FREEKEY)
 651                 Safefree(keysave);
 652             flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
 653         }
 654     }
 655
 656     if (HvREHASH(hv)) {
 657         PERL_HASH_INTERNAL(hash, key, klen);
 658         /* We don't have a pointer to the hv, so we have to replicate the
 659            flag into every HEK, so that hv_iterkeysv can see it.  */
 660         /* And yes, you do need this even though you are not "storing" because
 661            you can flip the flags below if doing an lval lookup.  (And that
 662            was put in to give the semantics Andreas was expecting.)  */
 663         flags |= HVhek_REHASH;
 664     } else if (!hash) {
 665         if (keysv && (SvIsCOW_shared_hash(keysv))) {
 666             hash = SvSHARED_HASH(keysv);
 667         } else {
 668             PERL_HASH(hash, key, klen);
 669         }
 670     }
 671
 672     masked_flags = (flags & HVhek_MASK);
 673
 674 #ifdef DYNAMIC_ENV_FETCH
 675     if (!HvARRAY(hv)) entry = NULL;
 676     else
 677 #endif
 678     {
 679         entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)];
 680     }
 681     for (; entry; entry = HeNEXT(entry)) {
 682         if (HeHASH(entry) != hash)              /* strings can't be equal */
 683             continue;
 684         if (HeKLEN(entry) != (I32)klen)
 685             continue;
 686         if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen))        /* is this it? */
 687             continue;
 688         if ((HeKFLAGS(entry) ^ masked_flags) & HVhek_UTF8)
 689             continue;
 690
 691         if (action & (HV_FETCH_LVALUE|HV_FETCH_ISSTORE)) {
 692             if (HeKFLAGS(entry) != masked_flags) {
 693                 /* We match if HVhek_UTF8 bit in our flags and hash key's
 694                    match.  But if entry was set previously with HVhek_WASUTF8
 695                    and key now doesn't (or vice versa) then we should change
 696                    the key's flag, as this is assignment.  */
 697                 if (HvSHAREKEYS(hv)) {
 698                     /* Need to swap the key we have for a key with the flags we
 699                        need. As keys are shared we can't just write to the
 700                        flag, so we share the new one, unshare the old one.  */
 701                     HEK * const new_hek = share_hek_flags(key, klen, hash,
 702                                                    masked_flags);
 703                     unshare_hek (HeKEY_hek(entry));
 704                     HeKEY_hek(entry) = new_hek;
 705                 }
 706                 else if (hv == PL_strtab) {
 707                     /* PL_strtab is usually the only hash without HvSHAREKEYS,
 708                        so putting this test here is cheap  */
 709                     if (flags & HVhek_FREEKEY)
 710                         Safefree(key);
 711                     Perl_croak(aTHX_ S_strtab_error,
 712                                action & HV_FETCH_LVALUE ? "fetch" : "store");
 713                 }
 714                 else
 715                     HeKFLAGS(entry) = masked_flags;
 716                 if (masked_flags & HVhek_ENABLEHVKFLAGS)
 717                     HvHASKFLAGS_on(hv);
 718             }
 719             if (HeVAL(entry) == &PL_sv_placeholder) {
 720                 /* yes, can store into placeholder slot */
 721                 if (action & HV_FETCH_LVALUE) {
 722                     if (SvMAGICAL(hv)) {
 723                         /* This preserves behaviour with the old hv_fetch
 724                            implementation which at this point would bail out
 725                            with a break; (at "if we find a placeholder, we
 726                            pretend we haven't found anything")
 727
 728                            That break mean that if a placeholder were found, it
 729                            caused a call into hv_store, which in turn would
 730                            check magic, and if there is no magic end up pretty
 731                            much back at this point (in hv_store's code).  */
 732                         break;
 733                     }
 734                     /* LVAL fetch which actaully needs a store.  */
 735                     val = newSV(0);
 736                     HvPLACEHOLDERS(hv)--;
 737                 } else {
 738                     /* store */
 739                     if (val != &PL_sv_placeholder)
 740                         HvPLACEHOLDERS(hv)--;
 741                 }
 742                 HeVAL(entry) = val;
 743             } else if (action & HV_FETCH_ISSTORE) {
 744                 SvREFCNT_dec(HeVAL(entry));
 745                 HeVAL(entry) = val;
 746             }
 747         } else if (HeVAL(entry) == &PL_sv_placeholder) {
 748             /* if we find a placeholder, we pretend we haven't found
 749                anything */
 750             break;
 751         }
 752         if (flags & HVhek_FREEKEY)
 753             Safefree(key);
 754         return entry;
 755     }
 756 #ifdef DYNAMIC_ENV_FETCH  /* %ENV lookup?  If so, try to fetch the value now */
 757     if (!(action & HV_FETCH_ISSTORE)
 758         && SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
 759         unsigned long len;
 760         const char * const env = PerlEnv_ENVgetenv_len(key,&len);
 761         if (env) {
 762             sv = newSVpvn(env,len);
 763             SvTAINTED_on(sv);
 764             return hv_common(hv, keysv, key, klen, flags,
 765                              HV_FETCH_ISSTORE|HV_DISABLE_UVAR_XKEY, sv, hash);
 766         }
 767     }
 768 #endif
 769
 770     if (!entry && SvREADONLY(hv) && !(action & HV_FETCH_ISEXISTS)) {
 771         hv_notallowed(flags, key, klen,
 772                         "Attempt to access disallowed key '%"SVf"' in"
 773                         " a restricted hash");
 774     }
 775     if (!(action & (HV_FETCH_LVALUE|HV_FETCH_ISSTORE))) {
 776         /* Not doing some form of store, so return failure.  */
 777         if (flags & HVhek_FREEKEY)
 778             Safefree(key);
 779         return 0;
 780     }
 781     if (action & HV_FETCH_LVALUE) {
 782         val = newSV(0);
 783         if (SvMAGICAL(hv)) {
 784             /* At this point the old hv_fetch code would call to hv_store,
 785                which in turn might do some tied magic. So we need to make that
 786                magic check happen.  */
 787             /* gonna assign to this, so it better be there */
 788             /* If a fetch-as-store fails on the fetch, then the action is to
 789                recurse once into "hv_store". If we didn't do this, then that
 790                recursive call would call the key conversion routine again.
 791                However, as we replace the original key with the converted
 792                key, this would result in a double conversion, which would show
 793                up as a bug if the conversion routine is not idempotent.  */
 794             return hv_common(hv, keysv, key, klen, flags,
 795                              HV_FETCH_ISSTORE|HV_DISABLE_UVAR_XKEY, val, hash);
 796             /* XXX Surely that could leak if the fetch-was-store fails?
 797                Just like the hv_fetch.  */
 798         }
 799     }
 800
 801     /* Welcome to hv_store...  */
 802
 803     if (!HvARRAY(hv)) {
 804         /* Not sure if we can get here.  I think the only case of oentry being
 805            NULL is for %ENV with dynamic env fetch.  But that should disappear
 806            with magic in the previous code.  */
 807         char *array;
 808         Newxz(array,
 809              PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
 810              char);
 811         HvARRAY(hv) = (HE**)array;
 812     }
 813
 814     oentry = &(HvARRAY(hv))[hash & (I32) xhv->xhv_max];
 815
 816     entry = new_HE();
 817     /* share_hek_flags will do the free for us.  This might be considered
 818        bad API design.  */
 819     if (HvSHAREKEYS(hv))
 820         HeKEY_hek(entry) = share_hek_flags(key, klen, hash, flags);
 821     else if (hv == PL_strtab) {
 822         /* PL_strtab is usually the only hash without HvSHAREKEYS, so putting
 823            this test here is cheap  */
 824         if (flags & HVhek_FREEKEY)
 825             Safefree(key);
 826         Perl_croak(aTHX_ S_strtab_error,
 827                    action & HV_FETCH_LVALUE ? "fetch" : "store");
 828     }
 829     else                                       /* gotta do the real thing */
 830         HeKEY_hek(entry) = save_hek_flags(key, klen, hash, flags);
 831     HeVAL(entry) = val;
 832     HeNEXT(entry) = *oentry;
 833     *oentry = entry;
 834
 835     if (val == &PL_sv_placeholder)
 836         HvPLACEHOLDERS(hv)++;
 837     if (masked_flags & HVhek_ENABLEHVKFLAGS)
 838         HvHASKFLAGS_on(hv);
 839
 840     {
 841         const HE *counter = HeNEXT(entry);
 842
 843         xhv->xhv_keys++; /* HvTOTALKEYS(hv)++ */
 844         if (!counter) {                         /* initial entry? */
 845             xhv->xhv_fill++; /* HvFILL(hv)++ */
 846         } else if (xhv->xhv_keys > (IV)xhv->xhv_max) {
 847             hsplit(hv);
 848         } else if(!HvREHASH(hv)) {
 849             U32 n_links = 1;
 850
 851             while ((counter = HeNEXT(counter)))
 852                 n_links++;
 853
 854             if (n_links > HV_MAX_LENGTH_BEFORE_SPLIT) {
 855                 /* Use only the old HvKEYS(hv) > HvMAX(hv) condition to limit
 856                    bucket splits on a rehashed hash, as we're not going to
 857                    split it again, and if someone is lucky (evil) enough to
 858                    get all the keys in one list they could exhaust our memory
 859                    as we repeatedly double the number of buckets on every
 860                    entry. Linear search feels a less worse thing to do.  */
 861                 hsplit(hv);
 862             }
 863         }
 864     }
 865
 866     return entry;
 867 }
 868
 869 STATIC void
 870 S_hv_magic_check(HV *hv, bool *needs_copy, bool *needs_store)
 871 {
 872     const MAGIC *mg = SvMAGIC(hv);
 873     *needs_copy = FALSE;
 874     *needs_store = TRUE;
 875     while (mg) {
 876         if (isUPPER(mg->mg_type)) {
 877             *needs_copy = TRUE;
 878             if (mg->mg_type == PERL_MAGIC_tied) {
 879                 *needs_store = FALSE;
 880                 return; /* We've set all there is to set. */
 881             }
 882         }
 883         mg = mg->mg_moremagic;
 884     }
 885 }
 886
 887 /*
 888 =for apidoc hv_scalar
 889
 890 Evaluates the hash in scalar context and returns the result. Handles magic when the hash is tied.
 891
 892 =cut
 893 */
 894
 895 SV *
 896 Perl_hv_scalar(pTHX_ HV *hv)
 897 {
 898     SV *sv;
 899
 900     if (SvRMAGICAL(hv)) {
 901         MAGIC * const mg = mg_find((SV*)hv, PERL_MAGIC_tied);
 902         if (mg)
 903             return magic_scalarpack(hv, mg);
 904     }
 905
 906     sv = sv_newmortal();
 907     if (HvFILL((HV*)hv))
 908         Perl_sv_setpvf(aTHX_ sv, "%ld/%ld",
 909                 (long)HvFILL(hv), (long)HvMAX(hv) + 1);
 910     else
 911         sv_setiv(sv, 0);
 912
 913     return sv;
 914 }
 915
 916 /*
 917 =for apidoc hv_delete
 918
 919 Deletes a key/value pair in the hash.  The value SV is removed from the
 920 hash and returned to the caller.  The C<klen> is the length of the key.
 921 The C<flags> value will normally be zero; if set to G_DISCARD then NULL
 922 will be returned.
 923
 924 =cut
 925 */
 926
 927 SV *
 928 Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen_i32, I32 flags)
 929 {
 930     STRLEN klen;
 931     int k_flags;
 932
 933     if (klen_i32 < 0) {
 934         klen = -klen_i32;
 935         k_flags = HVhek_UTF8;
 936     } else {
 937         klen = klen_i32;
 938         k_flags = 0;
 939     }
 940     return (SV *) hv_common(hv, NULL, key, klen, k_flags, flags | HV_DELETE,
 941                             NULL, 0);
 942 }
 943
 944 /*
 945 =for apidoc hv_delete_ent
 946
 947 Deletes a key/value pair in the hash.  The value SV is removed from the
 948 hash and returned to the caller.  The C<flags> value will normally be zero;
 949 if set to G_DISCARD then NULL will be returned.  C<hash> can be a valid
 950 precomputed hash value, or 0 to ask for it to be computed.
 951
 952 =cut
 953 */
 954
 955 STATIC SV *
 956 S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
 957                    int k_flags, I32 d_flags, U32 hash)
 958 {
 959     dVAR;
 960     register XPVHV* xhv;
 961     register HE *entry;
 962     register HE **oentry;
 963     HE *const *first_entry;
 964     bool is_utf8 = (k_flags & HVhek_UTF8) ? TRUE : FALSE;
 965     int masked_flags;
 966
 967     if (SvRMAGICAL(hv)) {
 968         bool needs_copy;
 969         bool needs_store;
 970         hv_magic_check (hv, &needs_copy, &needs_store);
 971
 972         if (needs_copy) {
 973             SV *sv;
 974             entry = (HE *) hv_common(hv, keysv, key, klen,
 975                                      k_flags & ~HVhek_FREEKEY,
 976                                      HV_FETCH_LVALUE|HV_DISABLE_UVAR_XKEY,
 977                                      NULL, hash);
 978             sv = entry ? HeVAL(entry) : NULL;
 979             if (sv) {
 980                 if (SvMAGICAL(sv)) {
 981                     mg_clear(sv);
 982                 }
 983                 if (!needs_store) {
 984                     if (mg_find(sv, PERL_MAGIC_tiedelem)) {
 985                         /* No longer an element */
 986                         sv_unmagic(sv, PERL_MAGIC_tiedelem);
 987                         return sv;
 988                     }
 989                     return NULL;                /* element cannot be deleted */
 990                 }
 991 #ifdef ENV_IS_CASELESS
 992                 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
 993                     /* XXX This code isn't UTF8 clean.  */
 994                     keysv = sv_2mortal(newSVpvn(key,klen));
 995                     if (k_flags & HVhek_FREEKEY) {
 996                         Safefree(key);
 997                     }
 998                     key = strupr(SvPVX(keysv));
 999                     is_utf8 = 0;
1000                     k_flags = 0;
1001                     hash = 0;
1002                 }
1003 #endif
1004             }
1005         }
1006     }
1007     xhv = (XPVHV*)SvANY(hv);
1008     if (!HvARRAY(hv))
1009         return NULL;
1010
1011     if (is_utf8) {
1012         const char * const keysave = key;
1013         key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
1014
1015         if (is_utf8)
1016             k_flags |= HVhek_UTF8;
1017         else
1018             k_flags &= ~HVhek_UTF8;
1019         if (key != keysave) {
1020             if (k_flags & HVhek_FREEKEY) {
1021                 /* This shouldn't happen if our caller does what we expect,
1022                    but strictly the API allows it.  */
1023                 Safefree(keysave);
1024             }
1025             k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
1026         }
1027         HvHASKFLAGS_on((SV*)hv);
1028     }
1029
1030     if (HvREHASH(hv)) {
1031         PERL_HASH_INTERNAL(hash, key, klen);
1032     } else if (!hash) {
1033         if (keysv && (SvIsCOW_shared_hash(keysv))) {
1034             hash = SvSHARED_HASH(keysv);
1035         } else {
1036             PERL_HASH(hash, key, klen);
1037         }
1038     }
1039
1040     masked_flags = (k_flags & HVhek_MASK);
1041
1042     first_entry = oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)];
1043     entry = *oentry;
1044     for (; entry; oentry = &HeNEXT(entry), entry = *oentry) {
1045         SV *sv;
1046         if (HeHASH(entry) != hash)              /* strings can't be equal */
1047             continue;
1048         if (HeKLEN(entry) != (I32)klen)
1049             continue;
1050         if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen))        /* is this it? */
1051             continue;
1052         if ((HeKFLAGS(entry) ^ masked_flags) & HVhek_UTF8)
1053             continue;
1054
1055         if (hv == PL_strtab) {
1056             if (k_flags & HVhek_FREEKEY)
1057                 Safefree(key);
1058             Perl_croak(aTHX_ S_strtab_error, "delete");
1059         }
1060
1061         /* if placeholder is here, it's already been deleted.... */
1062         if (HeVAL(entry) == &PL_sv_placeholder) {
1063             if (k_flags & HVhek_FREEKEY)
1064                 Safefree(key);
1065             return NULL;
1066         }
1067         if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
1068             hv_notallowed(k_flags, key, klen,
1069                             "Attempt to delete readonly key '%"SVf"' from"
1070                             " a restricted hash");
1071         }
1072         if (k_flags & HVhek_FREEKEY)
1073             Safefree(key);
1074
1075         if (d_flags & G_DISCARD)
1076             sv = NULL;
1077         else {
1078             sv = sv_2mortal(HeVAL(entry));
1079             HeVAL(entry) = &PL_sv_placeholder;
1080         }
1081
1082         /*
1083          * If a restricted hash, rather than really deleting the entry, put
1084          * a placeholder there. This marks the key as being "approved", so
1085          * we can still access via not-really-existing key without raising
1086          * an error.
1087          */
1088         if (SvREADONLY(hv)) {
1089             SvREFCNT_dec(HeVAL(entry));
1090             HeVAL(entry) = &PL_sv_placeholder;
1091             /* We'll be saving this slot, so the number of allocated keys
1092              * doesn't go down, but the number placeholders goes up */
1093             HvPLACEHOLDERS(hv)++;
1094         } else {
1095             *oentry = HeNEXT(entry);
1096             if(!*first_entry) {
1097                 xhv->xhv_fill--; /* HvFILL(hv)-- */
1098             }
1099             if (SvOOK(hv) && entry == HvAUX(hv)->xhv_eiter /* HvEITER(hv) */)
1100                 HvLAZYDEL_on(hv);
1101             else
1102                 hv_free_ent(hv, entry);
1103             xhv->xhv_keys--; /* HvTOTALKEYS(hv)-- */
1104             if (xhv->xhv_keys == 0)
1105                 HvHASKFLAGS_off(hv);
1106         }
1107         return sv;
1108     }
1109     if (SvREADONLY(hv)) {
1110         hv_notallowed(k_flags, key, klen,
1111                         "Attempt to delete disallowed key '%"SVf"' from"
1112                         " a restricted hash");
1113     }
1114
1115     if (k_flags & HVhek_FREEKEY)
1116         Safefree(key);
1117     return NULL;
1118 }
1119
1120 STATIC void
1121 S_hsplit(pTHX_ HV *hv)
1122 {
1123     dVAR;
1124     register XPVHV* const xhv = (XPVHV*)SvANY(hv);
1125     const I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
1126     register I32 newsize = oldsize * 2;
1127     register I32 i;
1128     char *a = (char*) HvARRAY(hv);
1129     register HE **aep;
1130     register HE **oentry;
1131     int longest_chain = 0;
1132     int was_shared;
1133
1134     /*PerlIO_printf(PerlIO_stderr(), "hsplit called for %p which had %d\n",
1135       (void*)hv, (int) oldsize);*/
1136
1137     if (HvPLACEHOLDERS_get(hv) && !SvREADONLY(hv)) {
1138       /* Can make this clear any placeholders first for non-restricted hashes,
1139          even though Storable rebuilds restricted hashes by putting in all the
1140          placeholders (first) before turning on the readonly flag, because
1141          Storable always pre-splits the hash.  */
1142       hv_clear_placeholders(hv);
1143     }
1144
1145     PL_nomemok = TRUE;
1146 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
1147     Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize)
1148           + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char);
1149     if (!a) {
1150       PL_nomemok = FALSE;
1151       return;
1152     }
1153     if (SvOOK(hv)) {
1154         Copy(&a[oldsize * sizeof(HE*)], &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux);
1155     }
1156 #else
1157     Newx(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize)
1158         + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char);
1159     if (!a) {
1160       PL_nomemok = FALSE;
1161       return;
1162     }
1163     Copy(HvARRAY(hv), a, oldsize * sizeof(HE*), char);
1164     if (SvOOK(hv)) {
1165         Copy(HvAUX(hv), &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux);
1166     }
1167     if (oldsize >= 64) {
1168         offer_nice_chunk(HvARRAY(hv),
1169                          PERL_HV_ARRAY_ALLOC_BYTES(oldsize)
1170                          + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0));
1171     }
1172     else
1173         Safefree(HvARRAY(hv));
1174 #endif
1175
1176     PL_nomemok = FALSE;
1177     Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char);     /* zero 2nd half*/
1178     xhv->xhv_max = --newsize;   /* HvMAX(hv) = --newsize */
1179     HvARRAY(hv) = (HE**) a;
1180     aep = (HE**)a;
1181
1182     for (i=0; i<oldsize; i++,aep++) {
1183         int left_length = 0;
1184         int right_length = 0;
1185         register HE *entry;
1186         register HE **bep;
1187
1188         if (!*aep)                              /* non-existent */
1189             continue;
1190         bep = aep+oldsize;
1191         for (oentry = aep, entry = *aep; entry; entry = *oentry) {
1192             if ((HeHASH(entry) & newsize) != (U32)i) {
1193                 *oentry = HeNEXT(entry);
1194                 HeNEXT(entry) = *bep;
1195                 if (!*bep)
1196                     xhv->xhv_fill++; /* HvFILL(hv)++ */
1197                 *bep = entry;
1198                 right_length++;
1199                 continue;
1200             }
1201             else {
1202                 oentry = &HeNEXT(entry);
1203                 left_length++;
1204             }
1205         }
1206         if (!*aep)                              /* everything moved */
1207             xhv->xhv_fill--; /* HvFILL(hv)-- */
1208         /* I think we don't actually need to keep track of the longest length,
1209            merely flag if anything is too long. But for the moment while
1210            developing this code I'll track it.  */
1211         if (left_length > longest_chain)
1212             longest_chain = left_length;
1213         if (right_length > longest_chain)
1214             longest_chain = right_length;
1215     }
1216
1217
1218     /* Pick your policy for "hashing isn't working" here:  */
1219     if (longest_chain <= HV_MAX_LENGTH_BEFORE_SPLIT /* split worked?  */
1220         || HvREHASH(hv)) {
1221         return;
1222     }
1223
1224     if (hv == PL_strtab) {
1225         /* Urg. Someone is doing something nasty to the string table.
1226            Can't win.  */
1227         return;
1228     }
1229
1230     /* Awooga. Awooga. Pathological data.  */
1231     /*PerlIO_printf(PerlIO_stderr(), "%p %d of %d with %d/%d buckets\n", (void*)hv,
1232       longest_chain, HvTOTALKEYS(hv), HvFILL(hv),  1+HvMAX(hv));*/
1233
1234     ++newsize;
1235     Newxz(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize)
1236          + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char);
1237     if (SvOOK(hv)) {
1238         Copy(HvAUX(hv), &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux);
1239     }
1240
1241     was_shared = HvSHAREKEYS(hv);
1242
1243     xhv->xhv_fill = 0;
1244     HvSHAREKEYS_off(hv);
1245     HvREHASH_on(hv);
1246
1247     aep = HvARRAY(hv);
1248
1249     for (i=0; i<newsize; i++,aep++) {
1250         register HE *entry = *aep;
1251         while (entry) {
1252             /* We're going to trash this HE's next pointer when we chain it
1253                into the new hash below, so store where we go next.  */
1254             HE * const next = HeNEXT(entry);
1255             UV hash;
1256             HE **bep;
1257
1258             /* Rehash it */
1259             PERL_HASH_INTERNAL(hash, HeKEY(entry), HeKLEN(entry));
1260
1261             if (was_shared) {
1262                 /* Unshare it.  */
1263                 HEK * const new_hek
1264                     = save_hek_flags(HeKEY(entry), HeKLEN(entry),
1265                                      hash, HeKFLAGS(entry));
1266                 unshare_hek (HeKEY_hek(entry));
1267                 HeKEY_hek(entry) = new_hek;
1268             } else {
1269                 /* Not shared, so simply write the new hash in. */
1270                 HeHASH(entry) = hash;
1271             }
1272             /*PerlIO_printf(PerlIO_stderr(), "%d ", HeKFLAGS(entry));*/
1273             HEK_REHASH_on(HeKEY_hek(entry));
1274             /*PerlIO_printf(PerlIO_stderr(), "%d\n", HeKFLAGS(entry));*/
1275
1276             /* Copy oentry to the correct new chain.  */
1277             bep = ((HE**)a) + (hash & (I32) xhv->xhv_max);
1278             if (!*bep)
1279                     xhv->xhv_fill++; /* HvFILL(hv)++ */
1280             HeNEXT(entry) = *bep;
1281             *bep = entry;
1282
1283             entry = next;
1284         }
1285     }
1286     Safefree (HvARRAY(hv));
1287     HvARRAY(hv) = (HE **)a;
1288 }
1289
1290 void
1291 Perl_hv_ksplit(pTHX_ HV *hv, IV newmax)
1292 {
1293     dVAR;
1294     register XPVHV* xhv = (XPVHV*)SvANY(hv);
1295     const I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
1296     register I32 newsize;
1297     register I32 i;
1298     register char *a;
1299     register HE **aep;
1300     register HE *entry;
1301     register HE **oentry;
1302
1303     newsize = (I32) newmax;                     /* possible truncation here */
1304     if (newsize != newmax || newmax <= oldsize)
1305         return;
1306     while ((newsize & (1 + ~newsize)) != newsize) {
1307         newsize &= ~(newsize & (1 + ~newsize)); /* get proper power of 2 */
1308     }
1309     if (newsize < newmax)
1310         newsize *= 2;
1311     if (newsize < newmax)
1312         return;                                 /* overflow detection */
1313
1314     a = (char *) HvARRAY(hv);
1315     if (a) {
1316         PL_nomemok = TRUE;
1317 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
1318         Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize)
1319               + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char);
1320         if (!a) {
1321           PL_nomemok = FALSE;
1322           return;
1323         }
1324         if (SvOOK(hv)) {
1325             Copy(&a[oldsize * sizeof(HE*)], &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux);
1326         }
1327 #else
1328         Newx(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize)
1329             + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char);
1330         if (!a) {
1331           PL_nomemok = FALSE;
1332           return;
1333         }
1334         Copy(HvARRAY(hv), a, oldsize * sizeof(HE*), char);
1335         if (SvOOK(hv)) {
1336             Copy(HvAUX(hv), &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux);
1337         }
1338         if (oldsize >= 64) {
1339             offer_nice_chunk(HvARRAY(hv),
1340                              PERL_HV_ARRAY_ALLOC_BYTES(oldsize)
1341                              + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0));
1342         }
1343         else
1344             Safefree(HvARRAY(hv));
1345 #endif
1346         PL_nomemok = FALSE;
1347         Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
1348     }
1349     else {
1350         Newxz(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1351     }
1352     xhv->xhv_max = --newsize;   /* HvMAX(hv) = --newsize */
1353     HvARRAY(hv) = (HE **) a;
1354     if (!xhv->xhv_fill /* !HvFILL(hv) */)       /* skip rest if no entries */
1355         return;
1356
1357     aep = (HE**)a;
1358     for (i=0; i<oldsize; i++,aep++) {
1359         if (!*aep)                              /* non-existent */
1360             continue;
1361         for (oentry = aep, entry = *aep; entry; entry = *oentry) {
1362             register I32 j = (HeHASH(entry) & newsize);
1363
1364             if (j != i) {
1365                 j -= i;
1366                 *oentry = HeNEXT(entry);
1367                 if (!(HeNEXT(entry) = aep[j]))
1368                     xhv->xhv_fill++; /* HvFILL(hv)++ */
1369                 aep[j] = entry;
1370                 continue;
1371             }
1372             else
1373                 oentry = &HeNEXT(entry);
1374         }
1375         if (!*aep)                              /* everything moved */
1376             xhv->xhv_fill--; /* HvFILL(hv)-- */
1377     }
1378 }
1379
1380 /*
1381 =for apidoc newHV
1382
1383 Creates a new HV.  The reference count is set to 1.
1384
1385 =cut
1386 */
1387
1388 HV *
1389 Perl_newHV(pTHX)
1390 {
1391     register XPVHV* xhv;
1392     HV * const hv = (HV*)newSV_type(SVt_PVHV);
1393     xhv = (XPVHV*)SvANY(hv);
1394     assert(!SvOK(hv));
1395 #ifndef NODEFAULT_SHAREKEYS
1396     HvSHAREKEYS_on(hv);         /* key-sharing on by default */
1397 #endif
1398
1399     xhv->xhv_max    = 7;        /* HvMAX(hv) = 7 (start with 8 buckets) */
1400     xhv->xhv_fill   = 0;        /* HvFILL(hv) = 0 */
1401     return hv;
1402 }
1403
1404 HV *
1405 Perl_newHVhv(pTHX_ HV *ohv)
1406 {
1407     HV * const hv = newHV();
1408     STRLEN hv_max, hv_fill;
1409
1410     if (!ohv || (hv_fill = HvFILL(ohv)) == 0)
1411         return hv;
1412     hv_max = HvMAX(ohv);
1413
1414     if (!SvMAGICAL((SV *)ohv)) {
1415         /* It's an ordinary hash, so copy it fast. AMS 20010804 */
1416         STRLEN i;
1417         const bool shared = !!HvSHAREKEYS(ohv);
1418         HE **ents, ** const oents = (HE **)HvARRAY(ohv);
1419         char *a;
1420         Newx(a, PERL_HV_ARRAY_ALLOC_BYTES(hv_max+1), char);
1421         ents = (HE**)a;
1422
1423         /* In each bucket... */
1424         for (i = 0; i <= hv_max; i++) {
1425             HE *prev = NULL;
1426             HE *oent = oents[i];
1427
1428             if (!oent) {
1429                 ents[i] = NULL;
1430                 continue;
1431             }
1432
1433             /* Copy the linked list of entries. */
1434             for (; oent; oent = HeNEXT(oent)) {
1435                 const U32 hash   = HeHASH(oent);
1436                 const char * const key = HeKEY(oent);
1437                 const STRLEN len = HeKLEN(oent);
1438                 const int flags  = HeKFLAGS(oent);
1439                 HE * const ent   = new_HE();
1440
1441                 HeVAL(ent)     = newSVsv(HeVAL(oent));
1442                 HeKEY_hek(ent)
1443                     = shared ? share_hek_flags(key, len, hash, flags)
1444                              :  save_hek_flags(key, len, hash, flags);
1445                 if (prev)
1446                     HeNEXT(prev) = ent;
1447                 else
1448                     ents[i] = ent;
1449                 prev = ent;
1450                 HeNEXT(ent) = NULL;
1451             }
1452         }
1453
1454         HvMAX(hv)   = hv_max;
1455         HvFILL(hv)  = hv_fill;
1456         HvTOTALKEYS(hv)  = HvTOTALKEYS(ohv);
1457         HvARRAY(hv) = ents;
1458     } /* not magical */
1459     else {
1460         /* Iterate over ohv, copying keys and values one at a time. */
1461         HE *entry;
1462         const I32 riter = HvRITER_get(ohv);
1463         HE * const eiter = HvEITER_get(ohv);
1464
1465         /* Can we use fewer buckets? (hv_max is always 2^n-1) */
1466         while (hv_max && hv_max + 1 >= hv_fill * 2)
1467             hv_max = hv_max / 2;
1468         HvMAX(hv) = hv_max;
1469
1470         hv_iterinit(ohv);
1471         while ((entry = hv_iternext_flags(ohv, 0))) {
1472             hv_store_flags(hv, HeKEY(entry), HeKLEN(entry),
1473                            newSVsv(HeVAL(entry)), HeHASH(entry),
1474                            HeKFLAGS(entry));
1475         }
1476         HvRITER_set(ohv, riter);
1477         HvEITER_set(ohv, eiter);
1478     }
1479
1480     return hv;
1481 }
1482
1483 /* A rather specialised version of newHVhv for copying %^H, ensuring all the
1484    magic stays on it.  */
1485 HV *
1486 Perl_hv_copy_hints_hv(pTHX_ HV *const ohv)
1487 {
1488     HV * const hv = newHV();
1489     STRLEN hv_fill;
1490
1491     if (ohv && (hv_fill = HvFILL(ohv))) {
1492         STRLEN hv_max = HvMAX(ohv);
1493         HE *entry;
1494         const I32 riter = HvRITER_get(ohv);
1495         HE * const eiter = HvEITER_get(ohv);
1496
1497         while (hv_max && hv_max + 1 >= hv_fill * 2)
1498             hv_max = hv_max / 2;
1499         HvMAX(hv) = hv_max;
1500
1501         hv_iterinit(ohv);
1502         while ((entry = hv_iternext_flags(ohv, 0))) {
1503             SV *const sv = newSVsv(HeVAL(entry));
1504             sv_magic(sv, NULL, PERL_MAGIC_hintselem,
1505                      (char *)newSVhek (HeKEY_hek(entry)), HEf_SVKEY);
1506             hv_store_flags(hv, HeKEY(entry), HeKLEN(entry),
1507                            sv, HeHASH(entry), HeKFLAGS(entry));
1508         }
1509         HvRITER_set(ohv, riter);
1510         HvEITER_set(ohv, eiter);
1511     }
1512     hv_magic(hv, NULL, PERL_MAGIC_hints);
1513     return hv;
1514 }
1515
1516 void
1517 Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry)
1518 {
1519     dVAR;
1520     SV *val;
1521
1522     if (!entry)
1523         return;
1524     val = HeVAL(entry);
1525     if (val && isGV(val) && GvCVu(val) && HvNAME_get(hv))
1526         mro_method_changed_in(hv);      /* deletion of method from stash */
1527     SvREFCNT_dec(val);
1528     if (HeKLEN(entry) == HEf_SVKEY) {
1529         SvREFCNT_dec(HeKEY_sv(entry));
1530         Safefree(HeKEY_hek(entry));
1531     }
1532     else if (HvSHAREKEYS(hv))
1533         unshare_hek(HeKEY_hek(entry));
1534     else
1535         Safefree(HeKEY_hek(entry));
1536     del_HE(entry);
1537 }
1538
1539 void
1540 Perl_hv_delayfree_ent(pTHX_ HV *hv, register HE *entry)
1541 {
1542     dVAR;
1543     if (!entry)
1544         return;
1545     /* SvREFCNT_inc to counter the SvREFCNT_dec in hv_free_ent  */
1546     sv_2mortal(SvREFCNT_inc(HeVAL(entry)));     /* free between statements */
1547     if (HeKLEN(entry) == HEf_SVKEY) {
1548         sv_2mortal(SvREFCNT_inc(HeKEY_sv(entry)));
1549     }
1550     hv_free_ent(hv, entry);
1551 }
1552
1553 /*
1554 =for apidoc hv_clear
1555
1556 Clears a hash, making it empty.
1557
1558 =cut
1559 */
1560
1561 void
1562 Perl_hv_clear(pTHX_ HV *hv)
1563 {
1564     dVAR;
1565     register XPVHV* xhv;
1566     if (!hv)
1567         return;
1568
1569     DEBUG_A(Perl_hv_assert(aTHX_ hv));
1570
1571     xhv = (XPVHV*)SvANY(hv);
1572
1573     if (SvREADONLY(hv) && HvARRAY(hv) != NULL) {
1574         /* restricted hash: convert all keys to placeholders */
1575         STRLEN i;
1576         for (i = 0; i <= xhv->xhv_max; i++) {
1577             HE *entry = (HvARRAY(hv))[i];
1578             for (; entry; entry = HeNEXT(entry)) {
1579                 /* not already placeholder */
1580                 if (HeVAL(entry) != &PL_sv_placeholder) {
1581                     if (HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
1582                         SV* const keysv = hv_iterkeysv(entry);
1583                         Perl_croak(aTHX_
1584                                    "Attempt to delete readonly key '%"SVf"' from a restricted hash",
1585                                    (void*)keysv);
1586                     }
1587                     SvREFCNT_dec(HeVAL(entry));
1588                     HeVAL(entry) = &PL_sv_placeholder;
1589                     HvPLACEHOLDERS(hv)++;
1590                 }
1591             }
1592         }
1593         goto reset;
1594     }
1595
1596     hfreeentries(hv);
1597     HvPLACEHOLDERS_set(hv, 0);
1598     if (HvARRAY(hv))
1599         Zero(HvARRAY(hv), xhv->xhv_max+1 /* HvMAX(hv)+1 */, HE*);
1600
1601     if (SvRMAGICAL(hv))
1602         mg_clear((SV*)hv);
1603
1604     HvHASKFLAGS_off(hv);
1605     HvREHASH_off(hv);
1606     reset:
1607     if (SvOOK(hv)) {
1608         if(HvNAME_get(hv))
1609             mro_isa_changed_in(hv);
1610         HvEITER_set(hv, NULL);
1611     }
1612 }
1613
1614 /*
1615 =for apidoc hv_clear_placeholders
1616
1617 Clears any placeholders from a hash.  If a restricted hash has any of its keys
1618 marked as readonly and the key is subsequently deleted, the key is not actually
1619 deleted but is marked by assigning it a value of &PL_sv_placeholder.  This tags
1620 it so it will be ignored by future operations such as iterating over the hash,
1621 but will still allow the hash to have a value reassigned to the key at some
1622 future point.  This function clears any such placeholder keys from the hash.
1623 See Hash::Util::lock_keys() for an example of its use.
1624
1625 =cut
1626 */
1627
1628 void
1629 Perl_hv_clear_placeholders(pTHX_ HV *hv)
1630 {
1631     dVAR;
1632     const U32 items = (U32)HvPLACEHOLDERS_get(hv);
1633
1634     if (items)
1635         clear_placeholders(hv, items);
1636 }
1637
1638 static void
1639 S_clear_placeholders(pTHX_ HV *hv, U32 items)
1640 {
1641     dVAR;
1642     I32 i;
1643
1644     if (items == 0)
1645         return;
1646
1647     i = HvMAX(hv);
1648     do {
1649         /* Loop down the linked list heads  */
1650         bool first = TRUE;
1651         HE **oentry = &(HvARRAY(hv))[i];
1652         HE *entry;
1653
1654         while ((entry = *oentry)) {
1655             if (HeVAL(entry) == &PL_sv_placeholder) {
1656                 *oentry = HeNEXT(entry);
1657                 if (first && !*oentry)
1658                     HvFILL(hv)--; /* This linked list is now empty.  */
1659                 if (entry == HvEITER_get(hv))
1660                     HvLAZYDEL_on(hv);
1661                 else
1662                     hv_free_ent(hv, entry);
1663
1664                 if (--items == 0) {
1665                     /* Finished.  */
1666                     HvTOTALKEYS(hv) -= (IV)HvPLACEHOLDERS_get(hv);
1667                     if (HvKEYS(hv) == 0)
1668                         HvHASKFLAGS_off(hv);
1669                     HvPLACEHOLDERS_set(hv, 0);
1670                     return;
1671                 }
1672             } else {
1673                 oentry = &HeNEXT(entry);
1674                 first = FALSE;
1675             }
1676         }
1677     } while (--i >= 0);
1678     /* You can't get here, hence assertion should always fail.  */
1679     assert (items == 0);
1680     assert (0);
1681 }
1682
1683 STATIC void
1684 S_hfreeentries(pTHX_ HV *hv)
1685 {
1686     /* This is the array that we're going to restore  */
1687     HE **const orig_array = HvARRAY(hv);
1688     HEK *name;
1689     int attempts = 100;
1690
1691     if (!orig_array)
1692         return;
1693
1694     if (SvOOK(hv)) {
1695         /* If the hash is actually a symbol table with a name, look after the
1696            name.  */
1697         struct xpvhv_aux *iter = HvAUX(hv);
1698
1699         name = iter->xhv_name;
1700         iter->xhv_name = NULL;
1701     } else {
1702         name = NULL;
1703     }
1704
1705     /* orig_array remains unchanged throughout the loop. If after freeing all
1706        the entries it turns out that one of the little blighters has triggered
1707        an action that has caused HvARRAY to be re-allocated, then we set
1708        array to the new HvARRAY, and try again.  */
1709
1710     while (1) {
1711         /* This is the one we're going to try to empty.  First time round
1712            it's the original array.  (Hopefully there will only be 1 time
1713            round) */
1714         HE ** const array = HvARRAY(hv);
1715         I32 i = HvMAX(hv);
1716
1717         /* Because we have taken xhv_name out, the only allocated pointer
1718            in the aux structure that might exist is the backreference array.
1719         */
1720
1721         if (SvOOK(hv)) {
1722             HE *entry;
1723             struct mro_meta *meta;
1724             struct xpvhv_aux *iter = HvAUX(hv);
1725             /* If there are weak references to this HV, we need to avoid
1726                freeing them up here.  In particular we need to keep the AV
1727                visible as what we're deleting might well have weak references
1728                back to this HV, so the for loop below may well trigger
1729                the removal of backreferences from this array.  */
1730
1731             if (iter->xhv_backreferences) {
1732                 /* So donate them to regular backref magic to keep them safe.
1733                    The sv_magic will increase the reference count of the AV,
1734                    so we need to drop it first. */
1735                 SvREFCNT_dec(iter->xhv_backreferences);
1736                 if (AvFILLp(iter->xhv_backreferences) == -1) {
1737                     /* Turns out that the array is empty. Just free it.  */
1738                     SvREFCNT_dec(iter->xhv_backreferences);
1739
1740                 } else {
1741                     sv_magic((SV*)hv, (SV*)iter->xhv_backreferences,
1742                              PERL_MAGIC_backref, NULL, 0);
1743                 }
1744                 iter->xhv_backreferences = NULL;
1745             }
1746
1747             entry = iter->xhv_eiter; /* HvEITER(hv) */
1748             if (entry && HvLAZYDEL(hv)) {       /* was deleted earlier? */
1749                 HvLAZYDEL_off(hv);
1750                 hv_free_ent(hv, entry);
1751             }
1752             iter->xhv_riter = -1;       /* HvRITER(hv) = -1 */
1753             iter->xhv_eiter = NULL;     /* HvEITER(hv) = NULL */
1754
1755             if((meta = iter->xhv_mro_meta)) {
1756                 if(meta->mro_linear_dfs) SvREFCNT_dec(meta->mro_linear_dfs);
1757                 if(meta->mro_linear_c3)  SvREFCNT_dec(meta->mro_linear_c3);
1758                 if(meta->mro_nextmethod) SvREFCNT_dec(meta->mro_nextmethod);
1759                 Safefree(meta);
1760                 iter->xhv_mro_meta = NULL;
1761             }
1762
1763             /* There are now no allocated pointers in the aux structure.  */
1764
1765             SvFLAGS(hv) &= ~SVf_OOK; /* Goodbye, aux structure.  */
1766             /* What aux structure?  */
1767         }
1768
1769         /* make everyone else think the array is empty, so that the destructors
1770          * called for freed entries can't recusively mess with us */
1771         HvARRAY(hv) = NULL;
1772         HvFILL(hv) = 0;
1773         ((XPVHV*) SvANY(hv))->xhv_keys = 0;
1774
1775
1776         do {
1777             /* Loop down the linked list heads  */
1778             HE *entry = array[i];
1779
1780             while (entry) {
1781                 register HE * const oentry = entry;
1782                 entry = HeNEXT(entry);
1783                 hv_free_ent(hv, oentry);
1784             }
1785         } while (--i >= 0);
1786
1787         /* As there are no allocated pointers in the aux structure, it's now
1788            safe to free the array we just cleaned up, if it's not the one we're
1789            going to put back.  */
1790         if (array != orig_array) {
1791             Safefree(array);
1792         }
1793
1794         if (!HvARRAY(hv)) {
1795             /* Good. No-one added anything this time round.  */
1796             break;
1797         }
1798
1799         if (SvOOK(hv)) {
1800             /* Someone attempted to iterate or set the hash name while we had
1801                the array set to 0.  We'll catch backferences on the next time
1802                round the while loop.  */
1803             assert(HvARRAY(hv));
1804
1805             if (HvAUX(hv)->xhv_name) {
1806                 unshare_hek_or_pvn(HvAUX(hv)->xhv_name, 0, 0, 0);
1807             }
1808         }
1809
1810         if (--attempts == 0) {
1811             Perl_die(aTHX_ "panic: hfreeentries failed to free hash - something is repeatedly re-creating entries");
1812         }
1813     }
1814
1815     HvARRAY(hv) = orig_array;
1816
1817     /* If the hash was actually a symbol table, put the name back.  */
1818     if (name) {
1819         /* We have restored the original array.  If name is non-NULL, then
1820            the original array had an aux structure at the end. So this is
1821            valid:  */
1822         SvFLAGS(hv) |= SVf_OOK;
1823         HvAUX(hv)->xhv_name = name;
1824     }
1825 }
1826
1827 /*
1828 =for apidoc hv_undef
1829
1830 Undefines the hash.
1831
1832 =cut
1833 */
1834
1835 void
1836 Perl_hv_undef(pTHX_ HV *hv)
1837 {
1838     dVAR;
1839     register XPVHV* xhv;
1840     const char *name;
1841
1842     if (!hv)
1843         return;
1844     DEBUG_A(Perl_hv_assert(aTHX_ hv));
1845     xhv = (XPVHV*)SvANY(hv);
1846
1847     if ((name = HvNAME_get(hv)) && !PL_dirty)
1848         mro_isa_changed_in(hv);
1849
1850     hfreeentries(hv);
1851     if (name) {
1852         if(PL_stashcache)
1853             hv_delete(PL_stashcache, name, HvNAMELEN_get(hv), G_DISCARD);
1854         hv_name_set(hv, NULL, 0, 0);
1855     }
1856     SvFLAGS(hv) &= ~SVf_OOK;
1857     Safefree(HvARRAY(hv));
1858     xhv->xhv_max   = 7; /* HvMAX(hv) = 7 (it's a normal hash) */
1859     HvARRAY(hv) = 0;
1860     HvPLACEHOLDERS_set(hv, 0);
1861
1862     if (SvRMAGICAL(hv))
1863         mg_clear((SV*)hv);
1864 }
1865
1866 static struct xpvhv_aux*
1867 S_hv_auxinit(HV *hv) {
1868     struct xpvhv_aux *iter;
1869     char *array;
1870
1871     if (!HvARRAY(hv)) {
1872         Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(HvMAX(hv) + 1)
1873             + sizeof(struct xpvhv_aux), char);
1874     } else {
1875         array = (char *) HvARRAY(hv);
1876         Renew(array, PERL_HV_ARRAY_ALLOC_BYTES(HvMAX(hv) + 1)
1877               + sizeof(struct xpvhv_aux), char);
1878     }
1879     HvARRAY(hv) = (HE**) array;
1880     /* SvOOK_on(hv) attacks the IV flags.  */
1881     SvFLAGS(hv) |= SVf_OOK;
1882     iter = HvAUX(hv);
1883
1884     iter->xhv_riter = -1;       /* HvRITER(hv) = -1 */
1885     iter->xhv_eiter = NULL;     /* HvEITER(hv) = NULL */
1886     iter->xhv_name = 0;
1887     iter->xhv_backreferences = 0;
1888     iter->xhv_mro_meta = NULL;
1889     return iter;
1890 }
1891
1892 /*
1893 =for apidoc hv_iterinit
1894
1895 Prepares a starting point to traverse a hash table.  Returns the number of
1896 keys in the hash (i.e. the same as C<HvKEYS(tb)>).  The return value is
1897 currently only meaningful for hashes without tie magic.
1898
1899 NOTE: Before version 5.004_65, C<hv_iterinit> used to return the number of
1900 hash buckets that happen to be in use.  If you still need that esoteric
1901 value, you can get it through the macro C<HvFILL(tb)>.
1902
1903
1904 =cut
1905 */
1906
1907 I32
1908 Perl_hv_iterinit(pTHX_ HV *hv)
1909 {
1910     if (!hv)
1911         Perl_croak(aTHX_ "Bad hash");
1912
1913     if (SvOOK(hv)) {
1914         struct xpvhv_aux * const iter = HvAUX(hv);
1915         HE * const entry = iter->xhv_eiter; /* HvEITER(hv) */
1916         if (entry && HvLAZYDEL(hv)) {   /* was deleted earlier? */
1917             HvLAZYDEL_off(hv);
1918             hv_free_ent(hv, entry);
1919         }
1920         iter->xhv_riter = -1;   /* HvRITER(hv) = -1 */
1921         iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
1922     } else {
1923         hv_auxinit(hv);
1924     }
1925
1926     /* used to be xhv->xhv_fill before 5.004_65 */
1927     return HvTOTALKEYS(hv);
1928 }
1929
1930 I32 *
1931 Perl_hv_riter_p(pTHX_ HV *hv) {
1932     struct xpvhv_aux *iter;
1933
1934     if (!hv)
1935         Perl_croak(aTHX_ "Bad hash");
1936
1937     iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
1938     return &(iter->xhv_riter);
1939 }
1940
1941 HE **
1942 Perl_hv_eiter_p(pTHX_ HV *hv) {
1943     struct xpvhv_aux *iter;
1944
1945     if (!hv)
1946         Perl_croak(aTHX_ "Bad hash");
1947
1948     iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
1949     return &(iter->xhv_eiter);
1950 }
1951
1952 void
1953 Perl_hv_riter_set(pTHX_ HV *hv, I32 riter) {
1954     struct xpvhv_aux *iter;
1955
1956     if (!hv)
1957         Perl_croak(aTHX_ "Bad hash");
1958
1959     if (SvOOK(hv)) {
1960         iter = HvAUX(hv);
1961     } else {
1962         if (riter == -1)
1963             return;
1964
1965         iter = hv_auxinit(hv);
1966     }
1967     iter->xhv_riter = riter;
1968 }
1969
1970 void
1971 Perl_hv_eiter_set(pTHX_ HV *hv, HE *eiter) {
1972     struct xpvhv_aux *iter;
1973
1974     if (!hv)
1975         Perl_croak(aTHX_ "Bad hash");
1976
1977     if (SvOOK(hv)) {
1978         iter = HvAUX(hv);
1979     } else {
1980         /* 0 is the default so don't go malloc()ing a new structure just to
1981            hold 0.  */
1982         if (!eiter)
1983             return;
1984
1985         iter = hv_auxinit(hv);
1986     }
1987     iter->xhv_eiter = eiter;
1988 }
1989
1990 void
1991 Perl_hv_name_set(pTHX_ HV *hv, const char *name, U32 len, U32 flags)
1992 {
1993     dVAR;
1994     struct xpvhv_aux *iter;
1995     U32 hash;
1996
1997     PERL_UNUSED_ARG(flags);
1998
1999     if (len > I32_MAX)
2000         Perl_croak(aTHX_ "panic: hv name too long (%"UVuf")", (UV) len);
2001
2002     if (SvOOK(hv)) {
2003         iter = HvAUX(hv);
2004         if (iter->xhv_name) {
2005             unshare_hek_or_pvn(iter->xhv_name, 0, 0, 0);
2006         }
2007     } else {
2008         if (name == 0)
2009             return;
2010
2011         iter = hv_auxinit(hv);
2012     }
2013     PERL_HASH(hash, name, len);
2014     iter->xhv_name = name ? share_hek(name, len, hash) : NULL;
2015 }
2016
2017 AV **
2018 Perl_hv_backreferences_p(pTHX_ HV *hv) {
2019     struct xpvhv_aux * const iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
2020     PERL_UNUSED_CONTEXT;
2021     return &(iter->xhv_backreferences);
2022 }
2023
2024 void
2025 Perl_hv_kill_backrefs(pTHX_ HV *hv) {
2026     AV *av;
2027
2028     if (!SvOOK(hv))
2029         return;
2030
2031     av = HvAUX(hv)->xhv_backreferences;
2032
2033     if (av) {
2034         HvAUX(hv)->xhv_backreferences = 0;
2035         Perl_sv_kill_backrefs(aTHX_ (SV*) hv, av);
2036     }
2037 }
2038
2039 /*
2040 hv_iternext is implemented as a macro in hv.h
2041
2042 =for apidoc hv_iternext
2043
2044 Returns entries from a hash iterator.  See C<hv_iterinit>.
2045
2046 You may call C<hv_delete> or C<hv_delete_ent> on the hash entry that the
2047 iterator currently points to, without losing your place or invalidating your
2048 iterator.  Note that in this case the current entry is deleted from the hash
2049 with your iterator holding the last reference to it.  Your iterator is flagged
2050 to free the entry on the next call to C<hv_iternext>, so you must not discard
2051 your iterator immediately else the entry will leak - call C<hv_iternext> to
2052 trigger the resource deallocation.
2053
2054 =for apidoc hv_iternext_flags
2055
2056 Returns entries from a hash iterator.  See C<hv_iterinit> and C<hv_iternext>.
2057 The C<flags> value will normally be zero; if HV_ITERNEXT_WANTPLACEHOLDERS is
2058 set the placeholders keys (for restricted hashes) will be returned in addition
2059 to normal keys. By default placeholders are automatically skipped over.
2060 Currently a placeholder is implemented with a value that is
2061 C<&Perl_sv_placeholder>. Note that the implementation of placeholders and
2062 restricted hashes may change, and the implementation currently is
2063 insufficiently abstracted for any change to be tidy.
2064
2065 =cut
2066 */
2067
2068 HE *
2069 Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags)
2070 {
2071     dVAR;
2072     register XPVHV* xhv;
2073     register HE *entry;
2074     HE *oldentry;
2075     MAGIC* mg;
2076     struct xpvhv_aux *iter;
2077
2078     if (!hv)
2079         Perl_croak(aTHX_ "Bad hash");
2080
2081     xhv = (XPVHV*)SvANY(hv);
2082
2083     if (!SvOOK(hv)) {
2084         /* Too many things (well, pp_each at least) merrily assume that you can
2085            call iv_iternext without calling hv_iterinit, so we'll have to deal
2086            with it.  */
2087         hv_iterinit(hv);
2088     }
2089     iter = HvAUX(hv);
2090
2091     oldentry = entry = iter->xhv_eiter; /* HvEITER(hv) */
2092     if (SvMAGICAL(hv) && SvRMAGICAL(hv)) {
2093         if ( ( mg = mg_find((SV*)hv, PERL_MAGIC_tied) ) ) {
2094             SV * const key = sv_newmortal();
2095             if (entry) {
2096                 sv_setsv(key, HeSVKEY_force(entry));
2097                 SvREFCNT_dec(HeSVKEY(entry));       /* get rid of previous key */
2098             }
2099             else {
2100                 char *k;
2101                 HEK *hek;
2102
2103                 /* one HE per MAGICAL hash */
2104                 iter->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */
2105                 Zero(entry, 1, HE);
2106                 Newxz(k, HEK_BASESIZE + sizeof(SV*), char);
2107                 hek = (HEK*)k;
2108                 HeKEY_hek(entry) = hek;
2109                 HeKLEN(entry) = HEf_SVKEY;
2110             }
2111             magic_nextpack((SV*) hv,mg,key);
2112             if (SvOK(key)) {
2113                 /* force key to stay around until next time */
2114                 HeSVKEY_set(entry, SvREFCNT_inc_simple_NN(key));
2115                 return entry;               /* beware, hent_val is not set */
2116             }
2117             if (HeVAL(entry))
2118                 SvREFCNT_dec(HeVAL(entry));
2119             Safefree(HeKEY_hek(entry));
2120             del_HE(entry);
2121             iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
2122             return NULL;
2123         }
2124     }
2125 #if defined(DYNAMIC_ENV_FETCH) && !defined(__riscos__)  /* set up %ENV for iteration */
2126     if (!entry && SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
2127         prime_env_iter();
2128 #ifdef VMS
2129         /* The prime_env_iter() on VMS just loaded up new hash values
2130          * so the iteration count needs to be reset back to the beginning
2131          */
2132         hv_iterinit(hv);
2133         iter = HvAUX(hv);
2134         oldentry = entry = iter->xhv_eiter; /* HvEITER(hv) */
2135 #endif
2136     }
2137 #endif
2138
2139     /* hv_iterint now ensures this.  */
2140     assert (HvARRAY(hv));
2141
2142     /* At start of hash, entry is NULL.  */
2143     if (entry)
2144     {
2145         entry = HeNEXT(entry);
2146         if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
2147             /*
2148              * Skip past any placeholders -- don't want to include them in
2149              * any iteration.
2150              */
2151             while (entry && HeVAL(entry) == &PL_sv_placeholder) {
2152                 entry = HeNEXT(entry);
2153             }
2154         }
2155     }
2156     while (!entry) {
2157         /* OK. Come to the end of the current list.  Grab the next one.  */
2158
2159         iter->xhv_riter++; /* HvRITER(hv)++ */
2160         if (iter->xhv_riter > (I32)xhv->xhv_max /* HvRITER(hv) > HvMAX(hv) */) {
2161             /* There is no next one.  End of the hash.  */
2162             iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
2163             break;
2164         }
2165         entry = (HvARRAY(hv))[iter->xhv_riter];
2166
2167         if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
2168             /* If we have an entry, but it's a placeholder, don't count it.
2169                Try the next.  */
2170             while (entry && HeVAL(entry) == &PL_sv_placeholder)
2171                 entry = HeNEXT(entry);
2172         }
2173         /* Will loop again if this linked list starts NULL
2174            (for HV_ITERNEXT_WANTPLACEHOLDERS)
2175            or if we run through it and find only placeholders.  */
2176     }
2177
2178     if (oldentry && HvLAZYDEL(hv)) {            /* was deleted earlier? */
2179         HvLAZYDEL_off(hv);
2180         hv_free_ent(hv, oldentry);
2181     }
2182
2183     /*if (HvREHASH(hv) && entry && !HeKREHASH(entry))
2184       PerlIO_printf(PerlIO_stderr(), "Awooga %p %p\n", (void*)hv, (void*)entry);*/
2185
2186     iter->xhv_eiter = entry; /* HvEITER(hv) = entry */
2187     return entry;
2188 }
2189
2190 /*
2191 =for apidoc hv_iterkey
2192
2193 Returns the key from the current position of the hash iterator.  See
2194 C<hv_iterinit>.
2195
2196 =cut
2197 */
2198
2199 char *
2200 Perl_hv_iterkey(pTHX_ register HE *entry, I32 *retlen)
2201 {
2202     if (HeKLEN(entry) == HEf_SVKEY) {
2203         STRLEN len;
2204         char * const p = SvPV(HeKEY_sv(entry), len);
2205         *retlen = len;
2206         return p;
2207     }
2208     else {
2209         *retlen = HeKLEN(entry);
2210         return HeKEY(entry);
2211     }
2212 }
2213
2214 /* unlike hv_iterval(), this always returns a mortal copy of the key */
2215 /*
2216 =for apidoc hv_iterkeysv
2217
2218 Returns the key as an C<SV*> from the current position of the hash
2219 iterator.  The return value will always be a mortal copy of the key.  Also
2220 see C<hv_iterinit>.
2221
2222 =cut
2223 */
2224
2225 SV *
2226 Perl_hv_iterkeysv(pTHX_ register HE *entry)
2227 {
2228     return sv_2mortal(newSVhek(HeKEY_hek(entry)));
2229 }
2230
2231 /*
2232 =for apidoc hv_iterval
2233
2234 Returns the value from the current position of the hash iterator.  See
2235 C<hv_iterkey>.
2236
2237 =cut
2238 */
2239
2240 SV *
2241 Perl_hv_iterval(pTHX_ HV *hv, register HE *entry)
2242 {
2243     if (SvRMAGICAL(hv)) {
2244         if (mg_find((SV*)hv, PERL_MAGIC_tied)) {
2245             SV* const sv = sv_newmortal();
2246             if (HeKLEN(entry) == HEf_SVKEY)
2247                 mg_copy((SV*)hv, sv, (char*)HeKEY_sv(entry), HEf_SVKEY);
2248             else
2249                 mg_copy((SV*)hv, sv, HeKEY(entry), HeKLEN(entry));
2250             return sv;
2251         }
2252     }
2253     return HeVAL(entry);
2254 }
2255
2256 /*
2257 =for apidoc hv_iternextsv
2258
2259 Performs an C<hv_iternext>, C<hv_iterkey>, and C<hv_iterval> in one
2260 operation.
2261
2262 =cut
2263 */
2264
2265 SV *
2266 Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen)
2267 {
2268     HE * const he = hv_iternext_flags(hv, 0);
2269
2270     if (!he)
2271         return NULL;
2272     *key = hv_iterkey(he, retlen);
2273     return hv_iterval(hv, he);
2274 }
2275
2276 /*
2277
2278 Now a macro in hv.h
2279
2280 =for apidoc hv_magic
2281
2282 Adds magic to a hash.  See C<sv_magic>.
2283
2284 =cut
2285 */
2286
2287 /* possibly free a shared string if no one has access to it
2288  * len and hash must both be valid for str.
2289  */
2290 void
2291 Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
2292 {
2293     unshare_hek_or_pvn (NULL, str, len, hash);
2294 }
2295
2296
2297 void
2298 Perl_unshare_hek(pTHX_ HEK *hek)
2299 {
2300     assert(hek);
2301     unshare_hek_or_pvn(hek, NULL, 0, 0);
2302 }
2303
2304 /* possibly free a shared string if no one has access to it
2305    hek if non-NULL takes priority over the other 3, else str, len and hash
2306    are used.  If so, len and hash must both be valid for str.
2307  */
2308 STATIC void
2309 S_unshare_hek_or_pvn(pTHX_ const HEK *hek, const char *str, I32 len, U32 hash)
2310 {
2311     dVAR;
2312     register XPVHV* xhv;
2313     HE *entry;
2314     register HE **oentry;
2315     HE **first;
2316     bool is_utf8 = FALSE;
2317     int k_flags = 0;
2318     const char * const save = str;
2319     struct shared_he *he = NULL;
2320
2321     if (hek) {
2322         /* Find the shared he which is just before us in memory.  */
2323         he = (struct shared_he *)(((char *)hek)
2324                                   - STRUCT_OFFSET(struct shared_he,
2325                                                   shared_he_hek));
2326
2327         /* Assert that the caller passed us a genuine (or at least consistent)
2328            shared hek  */
2329         assert (he->shared_he_he.hent_hek == hek);
2330
2331         LOCK_STRTAB_MUTEX;
2332         if (he->shared_he_he.he_valu.hent_refcount - 1) {
2333             --he->shared_he_he.he_valu.hent_refcount;
2334             UNLOCK_STRTAB_MUTEX;
2335             return;
2336         }
2337         UNLOCK_STRTAB_MUTEX;
2338
2339         hash = HEK_HASH(hek);
2340     } else if (len < 0) {
2341         STRLEN tmplen = -len;
2342         is_utf8 = TRUE;
2343         /* See the note in hv_fetch(). --jhi */
2344         str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2345         len = tmplen;
2346         if (is_utf8)
2347             k_flags = HVhek_UTF8;
2348         if (str != save)
2349             k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2350     }
2351
2352     /* what follows was the moral equivalent of:
2353     if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) {
2354         if (--*Svp == NULL)
2355             hv_delete(PL_strtab, str, len, G_DISCARD, hash);
2356     } */
2357     xhv = (XPVHV*)SvANY(PL_strtab);
2358     /* assert(xhv_array != 0) */
2359     LOCK_STRTAB_MUTEX;
2360     first = oentry = &(HvARRAY(PL_strtab))[hash & (I32) HvMAX(PL_strtab)];
2361     if (he) {
2362         const HE *const he_he = &(he->shared_he_he);
2363         for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) {
2364             if (entry == he_he)
2365                 break;
2366         }
2367     } else {
2368         const int flags_masked = k_flags & HVhek_MASK;
2369         for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) {
2370             if (HeHASH(entry) != hash)          /* strings can't be equal */
2371                 continue;
2372             if (HeKLEN(entry) != len)
2373                 continue;
2374             if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len))     /* is this it? */
2375                 continue;
2376             if (HeKFLAGS(entry) != flags_masked)
2377                 continue;
2378             break;
2379         }
2380     }
2381
2382     if (entry) {
2383         if (--entry->he_valu.hent_refcount == 0) {
2384             *oentry = HeNEXT(entry);
2385             if (!*first) {
2386                 /* There are now no entries in our slot.  */
2387                 xhv->xhv_fill--; /* HvFILL(hv)-- */
2388             }
2389             Safefree(entry);
2390             xhv->xhv_keys--; /* HvTOTALKEYS(hv)-- */
2391         }
2392     }
2393
2394     UNLOCK_STRTAB_MUTEX;
2395     if (!entry && ckWARN_d(WARN_INTERNAL))
2396         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
2397                     "Attempt to free non-existent shared string '%s'%s"
2398                     pTHX__FORMAT,
2399                     hek ? HEK_KEY(hek) : str,
2400                     ((k_flags & HVhek_UTF8) ? " (utf8)" : "") pTHX__VALUE);
2401     if (k_flags & HVhek_FREEKEY)
2402         Safefree(str);
2403 }
2404
2405 /* get a (constant) string ptr from the global string table
2406  * string will get added if it is not already there.
2407  * len and hash must both be valid for str.
2408  */
2409 HEK *
2410 Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash)
2411 {
2412     bool is_utf8 = FALSE;
2413     int flags = 0;
2414     const char * const save = str;
2415
2416     if (len < 0) {
2417       STRLEN tmplen = -len;
2418       is_utf8 = TRUE;
2419       /* See the note in hv_fetch(). --jhi */
2420       str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2421       len = tmplen;
2422       /* If we were able to downgrade here, then than means that we were passed
2423          in a key which only had chars 0-255, but was utf8 encoded.  */
2424       if (is_utf8)
2425           flags = HVhek_UTF8;
2426       /* If we found we were able to downgrade the string to bytes, then
2427          we should flag that it needs upgrading on keys or each.  Also flag
2428          that we need share_hek_flags to free the string.  */
2429       if (str != save)
2430           flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2431     }
2432
2433     return share_hek_flags (str, len, hash, flags);
2434 }
2435
2436 STATIC HEK *
2437 S_share_hek_flags(pTHX_ const char *str, I32 len, register U32 hash, int flags)
2438 {
2439     dVAR;
2440     register HE *entry;
2441     const int flags_masked = flags & HVhek_MASK;
2442     const U32 hindex = hash & (I32) HvMAX(PL_strtab);
2443
2444     /* what follows is the moral equivalent of:
2445
2446     if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
2447         hv_store(PL_strtab, str, len, NULL, hash);
2448
2449         Can't rehash the shared string table, so not sure if it's worth
2450         counting the number of entries in the linked list
2451     */
2452     register XPVHV * const xhv = (XPVHV*)SvANY(PL_strtab);
2453     /* assert(xhv_array != 0) */
2454     LOCK_STRTAB_MUTEX;
2455     entry = (HvARRAY(PL_strtab))[hindex];
2456     for (;entry; entry = HeNEXT(entry)) {
2457         if (HeHASH(entry) != hash)              /* strings can't be equal */
2458             continue;
2459         if (HeKLEN(entry) != len)
2460             continue;
2461         if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
2462             continue;
2463         if (HeKFLAGS(entry) != flags_masked)
2464             continue;
2465         break;
2466     }
2467
2468     if (!entry) {
2469         /* What used to be head of the list.
2470            If this is NULL, then we're the first entry for this slot, which
2471            means we need to increate fill.  */
2472         struct shared_he *new_entry;
2473         HEK *hek;
2474         char *k;
2475         HE **const head = &HvARRAY(PL_strtab)[hindex];
2476         HE *const next = *head;
2477
2478         /* We don't actually store a HE from the arena and a regular HEK.
2479            Instead we allocate one chunk of memory big enough for both,
2480            and put the HEK straight after the HE. This way we can find the
2481            HEK directly from the HE.
2482         */
2483
2484         Newx(k, STRUCT_OFFSET(struct shared_he,
2485                                 shared_he_hek.hek_key[0]) + len + 2, char);
2486         new_entry = (struct shared_he *)k;
2487         entry = &(new_entry->shared_he_he);
2488         hek = &(new_entry->shared_he_hek);
2489
2490         Copy(str, HEK_KEY(hek), len, char);
2491         HEK_KEY(hek)[len] = 0;
2492         HEK_LEN(hek) = len;
2493         HEK_HASH(hek) = hash;
2494         HEK_FLAGS(hek) = (unsigned char)flags_masked;
2495
2496         /* Still "point" to the HEK, so that other code need not know what
2497            we're up to.  */
2498         HeKEY_hek(entry) = hek;
2499         entry->he_valu.hent_refcount = 0;
2500         HeNEXT(entry) = next;
2501         *head = entry;
2502
2503         xhv->xhv_keys++; /* HvTOTALKEYS(hv)++ */
2504         if (!next) {                    /* initial entry? */
2505             xhv->xhv_fill++; /* HvFILL(hv)++ */
2506         } else if (xhv->xhv_keys > (IV)xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */) {
2507                 hsplit(PL_strtab);
2508         }
2509     }
2510
2511     ++entry->he_valu.hent_refcount;
2512     UNLOCK_STRTAB_MUTEX;
2513
2514     if (flags & HVhek_FREEKEY)
2515         Safefree(str);
2516
2517     return HeKEY_hek(entry);
2518 }
2519
2520 I32 *
2521 Perl_hv_placeholders_p(pTHX_ HV *hv)
2522 {
2523     dVAR;
2524     MAGIC *mg = mg_find((SV*)hv, PERL_MAGIC_rhash);
2525
2526     if (!mg) {
2527         mg = sv_magicext((SV*)hv, 0, PERL_MAGIC_rhash, 0, 0, 0);
2528
2529         if (!mg) {
2530             Perl_die(aTHX_ "panic: hv_placeholders_p");
2531         }
2532     }
2533     return &(mg->mg_len);
2534 }
2535
2536
2537 I32
2538 Perl_hv_placeholders_get(pTHX_ HV *hv)
2539 {
2540     dVAR;
2541     MAGIC * const mg = mg_find((SV*)hv, PERL_MAGIC_rhash);
2542
2543     return mg ? mg->mg_len : 0;
2544 }
2545
2546 void
2547 Perl_hv_placeholders_set(pTHX_ HV *hv, I32 ph)
2548 {
2549     dVAR;
2550     MAGIC * const mg = mg_find((SV*)hv, PERL_MAGIC_rhash);
2551
2552     if (mg) {
2553         mg->mg_len = ph;
2554     } else if (ph) {
2555         if (!sv_magicext((SV*)hv, 0, PERL_MAGIC_rhash, 0, 0, ph))
2556             Perl_die(aTHX_ "panic: hv_placeholders_set");
2557     }
2558     /* else we don't need to add magic to record 0 placeholders.  */
2559 }
2560
2561 STATIC SV *
2562 S_refcounted_he_value(pTHX_ const struct refcounted_he *he)
2563 {
2564     dVAR;
2565     SV *value;
2566     switch(he->refcounted_he_data[0] & HVrhek_typemask) {
2567     case HVrhek_undef:
2568         value = newSV(0);
2569         break;
2570     case HVrhek_delete:
2571         value = &PL_sv_placeholder;
2572         break;
2573     case HVrhek_IV:
2574         value = newSViv(he->refcounted_he_val.refcounted_he_u_iv);
2575         break;
2576     case HVrhek_UV:
2577         value = newSVuv(he->refcounted_he_val.refcounted_he_u_uv);
2578         break;
2579     case HVrhek_PV:
2580     case HVrhek_PV_UTF8:
2581         /* Create a string SV that directly points to the bytes in our
2582            structure.  */
2583         value = newSV_type(SVt_PV);
2584         SvPV_set(value, (char *) he->refcounted_he_data + 1);
2585         SvCUR_set(value, he->refcounted_he_val.refcounted_he_u_len);
2586         /* This stops anything trying to free it  */
2587         SvLEN_set(value, 0);
2588         SvPOK_on(value);
2589         SvREADONLY_on(value);
2590         if ((he->refcounted_he_data[0] & HVrhek_typemask) == HVrhek_PV_UTF8)
2591             SvUTF8_on(value);
2592         break;
2593     default:
2594         Perl_croak(aTHX_ "panic: refcounted_he_value bad flags %x",
2595                    he->refcounted_he_data[0]);
2596     }
2597     return value;
2598 }
2599
2600 /*
2601 =for apidoc refcounted_he_chain_2hv
2602
2603 Generates and returns a C<HV *> by walking up the tree starting at the passed
2604 in C<struct refcounted_he *>.
2605
2606 =cut
2607 */
2608 HV *
2609 Perl_refcounted_he_chain_2hv(pTHX_ const struct refcounted_he *chain)
2610 {
2611     dVAR;
2612     HV *hv = newHV();
2613     U32 placeholders = 0;
2614     /* We could chase the chain once to get an idea of the number of keys,
2615        and call ksplit.  But for now we'll make a potentially inefficient
2616        hash with only 8 entries in its array.  */
2617     const U32 max = HvMAX(hv);
2618
2619     if (!HvARRAY(hv)) {
2620         char *array;
2621         Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(max + 1), char);
2622         HvARRAY(hv) = (HE**)array;
2623     }
2624
2625     while (chain) {
2626 #ifdef USE_ITHREADS
2627         U32 hash = chain->refcounted_he_hash;
2628 #else
2629         U32 hash = HEK_HASH(chain->refcounted_he_hek);
2630 #endif
2631         HE **oentry = &((HvARRAY(hv))[hash & max]);
2632         HE *entry = *oentry;
2633         SV *value;
2634
2635         for (; entry; entry = HeNEXT(entry)) {
2636             if (HeHASH(entry) == hash) {
2637                 /* We might have a duplicate key here.  If so, entry is older
2638                    than the key we've already put in the hash, so if they are
2639                    the same, skip adding entry.  */
2640 #ifdef USE_ITHREADS
2641                 const STRLEN klen = HeKLEN(entry);
2642                 const char *const key = HeKEY(entry);
2643                 if (klen == chain->refcounted_he_keylen
2644                     && (!!HeKUTF8(entry)
2645                         == !!(chain->refcounted_he_data[0] & HVhek_UTF8))
2646                     && memEQ(key, REF_HE_KEY(chain), klen))
2647                     goto next_please;
2648 #else
2649                 if (HeKEY_hek(entry) == chain->refcounted_he_hek)
2650                     goto next_please;
2651                 if (HeKLEN(entry) == HEK_LEN(chain->refcounted_he_hek)
2652                     && HeKUTF8(entry) == HEK_UTF8(chain->refcounted_he_hek)
2653                     && memEQ(HeKEY(entry), HEK_KEY(chain->refcounted_he_hek),
2654                              HeKLEN(entry)))
2655                     goto next_please;
2656 #endif
2657             }
2658         }
2659         assert (!entry);
2660         entry = new_HE();
2661
2662 #ifdef USE_ITHREADS
2663         HeKEY_hek(entry)
2664             = share_hek_flags(REF_HE_KEY(chain),
2665                               chain->refcounted_he_keylen,
2666                               chain->refcounted_he_hash,
2667                               (chain->refcounted_he_data[0]
2668                                & (HVhek_UTF8|HVhek_WASUTF8)));
2669 #else
2670         HeKEY_hek(entry) = share_hek_hek(chain->refcounted_he_hek);
2671 #endif
2672         value = refcounted_he_value(chain);
2673         if (value == &PL_sv_placeholder)
2674             placeholders++;
2675         HeVAL(entry) = value;
2676
2677         /* Link it into the chain.  */
2678         HeNEXT(entry) = *oentry;
2679         if (!HeNEXT(entry)) {
2680             /* initial entry.   */
2681             HvFILL(hv)++;
2682         }
2683         *oentry = entry;
2684
2685         HvTOTALKEYS(hv)++;
2686
2687     next_please:
2688         chain = chain->refcounted_he_next;
2689     }
2690
2691     if (placeholders) {
2692         clear_placeholders(hv, placeholders);
2693         HvTOTALKEYS(hv) -= placeholders;
2694     }
2695
2696     /* We could check in the loop to see if we encounter any keys with key
2697        flags, but it's probably not worth it, as this per-hash flag is only
2698        really meant as an optimisation for things like Storable.  */
2699     HvHASKFLAGS_on(hv);
2700     DEBUG_A(Perl_hv_assert(aTHX_ hv));
2701
2702     return hv;
2703 }
2704
2705 SV *
2706 Perl_refcounted_he_fetch(pTHX_ const struct refcounted_he *chain, SV *keysv,
2707                          const char *key, STRLEN klen, int flags, U32 hash)
2708 {
2709     dVAR;
2710     /* Just to be awkward, if you're using this interface the UTF-8-or-not-ness
2711        of your key has to exactly match that which is stored.  */
2712     SV *value = &PL_sv_placeholder;
2713     bool is_utf8;
2714
2715     if (keysv) {
2716         if (flags & HVhek_FREEKEY)
2717             Safefree(key);
2718         key = SvPV_const(keysv, klen);
2719         flags = 0;
2720         is_utf8 = (SvUTF8(keysv) != 0);
2721     } else {
2722         is_utf8 = ((flags & HVhek_UTF8) ? TRUE : FALSE);
2723     }
2724
2725     if (!hash) {
2726         if (keysv && (SvIsCOW_shared_hash(keysv))) {
2727             hash = SvSHARED_HASH(keysv);
2728         } else {
2729             PERL_HASH(hash, key, klen);
2730         }
2731     }
2732
2733     for (; chain; chain = chain->refcounted_he_next) {
2734 #ifdef USE_ITHREADS
2735         if (hash != chain->refcounted_he_hash)
2736             continue;
2737         if (klen != chain->refcounted_he_keylen)
2738             continue;
2739         if (memNE(REF_HE_KEY(chain),key,klen))
2740             continue;
2741         if (!!is_utf8 != !!(chain->refcounted_he_data[0] & HVhek_UTF8))
2742             continue;
2743 #else
2744         if (hash != HEK_HASH(chain->refcounted_he_hek))
2745             continue;
2746         if (klen != (STRLEN)HEK_LEN(chain->refcounted_he_hek))
2747             continue;
2748         if (memNE(HEK_KEY(chain->refcounted_he_hek),key,klen))
2749             continue;
2750         if (!!is_utf8 != !!HEK_UTF8(chain->refcounted_he_hek))
2751             continue;
2752 #endif
2753
2754         value = sv_2mortal(refcounted_he_value(chain));
2755         break;
2756     }
2757
2758     if (flags & HVhek_FREEKEY)
2759         Safefree(key);
2760
2761     return value;
2762 }
2763
2764 /*
2765 =for apidoc refcounted_he_new
2766
2767 Creates a new C<struct refcounted_he>. As S<key> is copied, and value is
2768 stored in a compact form, all references remain the property of the caller.
2769 The C<struct refcounted_he> is returned with a reference count of 1.
2770
2771 =cut
2772 */
2773
2774 struct refcounted_he *
2775 Perl_refcounted_he_new(pTHX_ struct refcounted_he *const parent,
2776                        SV *const key, SV *const value) {
2777     dVAR;
2778     struct refcounted_he *he;
2779     STRLEN key_len;
2780     const char *key_p = SvPV_const(key, key_len);
2781     STRLEN value_len = 0;
2782     const char *value_p = NULL;
2783     char value_type;
2784     char flags;
2785     STRLEN key_offset;
2786     U32 hash;
2787     bool is_utf8 = SvUTF8(key) ? TRUE : FALSE;
2788
2789     if (SvPOK(value)) {
2790         value_type = HVrhek_PV;
2791     } else if (SvIOK(value)) {
2792         value_type = HVrhek_IV;
2793     } else if (value == &PL_sv_placeholder) {
2794         value_type = HVrhek_delete;
2795     } else if (!SvOK(value)) {
2796         value_type = HVrhek_undef;
2797     } else {
2798         value_type = HVrhek_PV;
2799     }
2800
2801     if (value_type == HVrhek_PV) {
2802         value_p = SvPV_const(value, value_len);
2803         key_offset = value_len + 2;
2804     } else {
2805         value_len = 0;
2806         key_offset = 1;
2807     }
2808
2809 #ifdef USE_ITHREADS
2810     he = (struct refcounted_he*)
2811         PerlMemShared_malloc(sizeof(struct refcounted_he) - 1
2812                              + key_len
2813                              + key_offset);
2814 #else
2815     he = (struct refcounted_he*)
2816         PerlMemShared_malloc(sizeof(struct refcounted_he) - 1
2817                              + key_offset);
2818 #endif
2819
2820
2821     he->refcounted_he_next = parent;
2822
2823     if (value_type == HVrhek_PV) {
2824         Copy(value_p, he->refcounted_he_data + 1, value_len + 1, char);
2825         he->refcounted_he_val.refcounted_he_u_len = value_len;
2826         /* Do it this way so that the SvUTF8() test is after the SvPV, in case
2827            the value is overloaded, and doesn't yet have the UTF-8flag set.  */
2828         if (SvUTF8(value))
2829             value_type = HVrhek_PV_UTF8;
2830     } else if (value_type == HVrhek_IV) {
2831         if (SvUOK(value)) {
2832             he->refcounted_he_val.refcounted_he_u_uv = SvUVX(value);
2833             value_type = HVrhek_UV;
2834         } else {
2835             he->refcounted_he_val.refcounted_he_u_iv = SvIVX(value);
2836         }
2837     }
2838     flags = value_type;
2839
2840     if (is_utf8) {
2841         /* Hash keys are always stored normalised to (yes) ISO-8859-1.
2842            As we're going to be building hash keys from this value in future,
2843            normalise it now.  */
2844         key_p = (char*)bytes_from_utf8((const U8*)key_p, &key_len, &is_utf8);
2845         flags |= is_utf8 ? HVhek_UTF8 : HVhek_WASUTF8;
2846     }
2847     PERL_HASH(hash, key_p, key_len);
2848
2849 #ifdef USE_ITHREADS
2850     he->refcounted_he_hash = hash;
2851     he->refcounted_he_keylen = key_len;
2852     Copy(key_p, he->refcounted_he_data + key_offset, key_len, char);
2853 #else
2854     he->refcounted_he_hek = share_hek_flags(key_p, key_len, hash, flags);
2855 #endif
2856
2857     if (flags & HVhek_WASUTF8) {
2858         /* If it was downgraded from UTF-8, then the pointer returned from
2859            bytes_from_utf8 is an allocated pointer that we must free.  */
2860         Safefree(key_p);
2861     }
2862
2863     he->refcounted_he_data[0] = flags;
2864     he->refcounted_he_refcnt = 1;
2865
2866     return he;
2867 }
2868
2869 /*
2870 =for apidoc refcounted_he_free
2871
2872 Decrements the reference count of the passed in C<struct refcounted_he *>
2873 by one. If the reference count reaches zero the structure's memory is freed,
2874 and C<refcounted_he_free> iterates onto the parent node.
2875
2876 =cut
2877 */
2878
2879 void
2880 Perl_refcounted_he_free(pTHX_ struct refcounted_he *he) {
2881     dVAR;
2882     PERL_UNUSED_CONTEXT;
2883
2884     while (he) {
2885         struct refcounted_he *copy;
2886         U32 new_count;
2887
2888         HINTS_REFCNT_LOCK;
2889         new_count = --he->refcounted_he_refcnt;
2890         HINTS_REFCNT_UNLOCK;
2891
2892         if (new_count) {
2893             return;
2894         }
2895
2896 #ifndef USE_ITHREADS
2897         unshare_hek_or_pvn (he->refcounted_he_hek, 0, 0, 0);
2898 #endif
2899         copy = he;
2900         he = he->refcounted_he_next;
2901         PerlMemShared_free(copy);
2902     }
2903 }
2904
2905 /*
2906 =for apidoc hv_assert
2907
2908 Check that a hash is in an internally consistent state.
2909
2910 =cut
2911 */
2912
2913 #ifdef DEBUGGING
2914
2915 void
2916 Perl_hv_assert(pTHX_ HV *hv)
2917 {
2918     dVAR;
2919     HE* entry;
2920     int withflags = 0;
2921     int placeholders = 0;
2922     int real = 0;
2923     int bad = 0;
2924     const I32 riter = HvRITER_get(hv);
2925     HE *eiter = HvEITER_get(hv);
2926
2927     (void)hv_iterinit(hv);
2928
2929     while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))) {
2930         /* sanity check the values */
2931         if (HeVAL(entry) == &PL_sv_placeholder)
2932             placeholders++;
2933         else
2934             real++;
2935         /* sanity check the keys */
2936         if (HeSVKEY(entry)) {
2937             NOOP;   /* Don't know what to check on SV keys.  */
2938         } else if (HeKUTF8(entry)) {
2939             withflags++;
2940             if (HeKWASUTF8(entry)) {
2941                 PerlIO_printf(Perl_debug_log,
2942                             "hash key has both WASUTF8 and UTF8: '%.*s'\n",
2943                             (int) HeKLEN(entry),  HeKEY(entry));
2944                 bad = 1;
2945             }
2946         } else if (HeKWASUTF8(entry))
2947             withflags++;
2948     }
2949     if (!SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) {
2950         static const char bad_count[] = "Count %d %s(s), but hash reports %d\n";
2951         const int nhashkeys = HvUSEDKEYS(hv);
2952         const int nhashplaceholders = HvPLACEHOLDERS_get(hv);
2953
2954         if (nhashkeys != real) {
2955             PerlIO_printf(Perl_debug_log, bad_count, real, "keys", nhashkeys );
2956             bad = 1;
2957         }
2958         if (nhashplaceholders != placeholders) {
2959             PerlIO_printf(Perl_debug_log, bad_count, placeholders, "placeholder", nhashplaceholders );
2960             bad = 1;
2961         }
2962     }
2963     if (withflags && ! HvHASKFLAGS(hv)) {
2964         PerlIO_printf(Perl_debug_log,
2965                     "Hash has HASKFLAGS off but I count %d key(s) with flags\n",
2966                     withflags);
2967         bad = 1;
2968     }
2969     if (bad) {
2970         sv_dump((SV *)hv);
2971     }
2972     HvRITER_set(hv, riter);             /* Restore hash iterator state */
2973     HvEITER_set(hv, eiter);
2974 }
2975
2976 #endif
2977
2978 /*
2979  * Local variables:
2980  * c-indentation-style: bsd
2981  * c-basic-offset: 4
2982  * indent-tabs-mode: t
2983  * End:
2984  *
2985  * ex: set ts=8 sts=4 sw=4 noet:
2986  */