hv.c

   1 /*    hv.c
   2  *
   3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
   4  *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 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
  13  *          of all that I have seen.
  14  *                         --Bilbo
  15  *
  16  *     [p.278 of _The Lord of the Rings_, II/iii: "The Ring Goes South"]
  17  */
  18
  19 /*
  20 =head1 Hash Manipulation Functions
  21
  22 A HV structure represents a Perl hash.  It consists mainly of an array
  23 of pointers, each of which points to a linked list of HE structures.  The
  24 array is indexed by the hash function of the key, so each linked list
  25 represents all the hash entries with the same hash value.  Each HE contains
  26 a pointer to the actual value, plus a pointer to a HEK structure which
  27 holds the key and hash value.
  28
  29 =cut
  30
  31 */
  32
  33 #include "EXTERN.h"
  34 #define PERL_IN_HV_C
  35 #define PERL_HASH_INTERNAL_ACCESS
  36 #include "perl.h"
  37
  38 #define DO_HSPLIT(xhv) ((xhv)->xhv_keys > (xhv)->xhv_max) /* HvTOTALKEYS(hv) > HvMAX(hv) */
  39 #define HV_FILL_THRESHOLD 31
  40
  41 static const char S_strtab_error[]
  42     = "Cannot modify shared string table in hv_%s";
  43
  44 #ifdef PURIFY
  45
  46 #define new_HE() (HE*)safemalloc(sizeof(HE))
  47 #define del_HE(p) safefree((char*)p)
  48
  49 #else
  50
  51 STATIC HE*
  52 S_new_he(pTHX)
  53 {
  54     dVAR;
  55     HE* he;
  56     void ** const root = &PL_body_roots[HE_SVSLOT];
  57
  58     if (!*root)
  59         Perl_more_bodies(aTHX_ HE_SVSLOT, sizeof(HE), PERL_ARENA_SIZE);
  60     he = (HE*) *root;
  61     assert(he);
  62     *root = HeNEXT(he);
  63     return he;
  64 }
  65
  66 #define new_HE() new_he()
  67 #define del_HE(p) \
  68     STMT_START { \
  69         HeNEXT(p) = (HE*)(PL_body_roots[HE_SVSLOT]);    \
  70         PL_body_roots[HE_SVSLOT] = p; \
  71     } STMT_END
  72
  73
  74
  75 #endif
  76
  77 STATIC HEK *
  78 S_save_hek_flags(const char *str, I32 len, U32 hash, int flags)
  79 {
  80     const int flags_masked = flags & HVhek_MASK;
  81     char *k;
  82     HEK *hek;
  83
  84     PERL_ARGS_ASSERT_SAVE_HEK_FLAGS;
  85
  86     Newx(k, HEK_BASESIZE + len + 2, char);
  87     hek = (HEK*)k;
  88     Copy(str, HEK_KEY(hek), len, char);
  89     HEK_KEY(hek)[len] = 0;
  90     HEK_LEN(hek) = len;
  91     HEK_HASH(hek) = hash;
  92     HEK_FLAGS(hek) = (unsigned char)flags_masked | HVhek_UNSHARED;
  93
  94     if (flags & HVhek_FREEKEY)
  95         Safefree(str);
  96     return hek;
  97 }
  98
  99 /* free the pool of temporary HE/HEK pairs returned by hv_fetch_ent
 100  * for tied hashes */
 101
 102 void
 103 Perl_free_tied_hv_pool(pTHX)
 104 {
 105     dVAR;
 106     HE *he = PL_hv_fetch_ent_mh;
 107     while (he) {
 108         HE * const ohe = he;
 109         Safefree(HeKEY_hek(he));
 110         he = HeNEXT(he);
 111         del_HE(ohe);
 112     }
 113     PL_hv_fetch_ent_mh = NULL;
 114 }
 115
 116 #if defined(USE_ITHREADS)
 117 HEK *
 118 Perl_hek_dup(pTHX_ HEK *source, CLONE_PARAMS* param)
 119 {
 120     HEK *shared;
 121
 122     PERL_ARGS_ASSERT_HEK_DUP;
 123     PERL_UNUSED_ARG(param);
 124
 125     if (!source)
 126         return NULL;
 127
 128     shared = (HEK*)ptr_table_fetch(PL_ptr_table, source);
 129     if (shared) {
 130         /* We already shared this hash key.  */
 131         (void)share_hek_hek(shared);
 132     }
 133     else {
 134         shared
 135             = share_hek_flags(HEK_KEY(source), HEK_LEN(source),
 136                               HEK_HASH(source), HEK_FLAGS(source));
 137         ptr_table_store(PL_ptr_table, source, shared);
 138     }
 139     return shared;
 140 }
 141
 142 HE *
 143 Perl_he_dup(pTHX_ const HE *e, bool shared, CLONE_PARAMS* param)
 144 {
 145     HE *ret;
 146
 147     PERL_ARGS_ASSERT_HE_DUP;
 148
 149     if (!e)
 150         return NULL;
 151     /* look for it in the table first */
 152     ret = (HE*)ptr_table_fetch(PL_ptr_table, e);
 153     if (ret)
 154         return ret;
 155
 156     /* create anew and remember what it is */
 157     ret = new_HE();
 158     ptr_table_store(PL_ptr_table, e, ret);
 159
 160     HeNEXT(ret) = he_dup(HeNEXT(e),shared, param);
 161     if (HeKLEN(e) == HEf_SVKEY) {
 162         char *k;
 163         Newx(k, HEK_BASESIZE + sizeof(const SV *), char);
 164         HeKEY_hek(ret) = (HEK*)k;
 165         HeKEY_sv(ret) = sv_dup_inc(HeKEY_sv(e), param);
 166     }
 167     else if (shared) {
 168         /* This is hek_dup inlined, which seems to be important for speed
 169            reasons.  */
 170         HEK * const source = HeKEY_hek(e);
 171         HEK *shared = (HEK*)ptr_table_fetch(PL_ptr_table, source);
 172
 173         if (shared) {
 174             /* We already shared this hash key.  */
 175             (void)share_hek_hek(shared);
 176         }
 177         else {
 178             shared
 179                 = share_hek_flags(HEK_KEY(source), HEK_LEN(source),
 180                                   HEK_HASH(source), HEK_FLAGS(source));
 181             ptr_table_store(PL_ptr_table, source, shared);
 182         }
 183         HeKEY_hek(ret) = shared;
 184     }
 185     else
 186         HeKEY_hek(ret) = save_hek_flags(HeKEY(e), HeKLEN(e), HeHASH(e),
 187                                         HeKFLAGS(e));
 188     HeVAL(ret) = sv_dup_inc(HeVAL(e), param);
 189     return ret;
 190 }
 191 #endif  /* USE_ITHREADS */
 192
 193 static void
 194 S_hv_notallowed(pTHX_ int flags, const char *key, I32 klen,
 195                 const char *msg)
 196 {
 197     SV * const sv = sv_newmortal();
 198
 199     PERL_ARGS_ASSERT_HV_NOTALLOWED;
 200
 201     if (!(flags & HVhek_FREEKEY)) {
 202         sv_setpvn(sv, key, klen);
 203     }
 204     else {
 205         /* Need to free saved eventually assign to mortal SV */
 206         /* XXX is this line an error ???:  SV *sv = sv_newmortal(); */
 207         sv_usepvn(sv, (char *) key, klen);
 208     }
 209     if (flags & HVhek_UTF8) {
 210         SvUTF8_on(sv);
 211     }
 212     Perl_croak(aTHX_ msg, SVfARG(sv));
 213 }
 214
 215 /* (klen == HEf_SVKEY) is special for MAGICAL hv entries, meaning key slot
 216  * contains an SV* */
 217
 218 /*
 219 =for apidoc hv_store
 220
 221 Stores an SV in a hash.  The hash key is specified as C<key> and the
 222 absolute value of C<klen> is the length of the key.  If C<klen> is
 223 negative the key is assumed to be in UTF-8-encoded Unicode.  The
 224 C<hash> parameter is the precomputed hash value; if it is zero then
 225 Perl will compute it.
 226
 227 The return value will be
 228 NULL if the operation failed or if the value did not need to be actually
 229 stored within the hash (as in the case of tied hashes).  Otherwise it can
 230 be dereferenced to get the original C<SV*>.  Note that the caller is
 231 responsible for suitably incrementing the reference count of C<val> before
 232 the call, and decrementing it if the function returned NULL.  Effectively
 233 a successful hv_store takes ownership of one reference to C<val>.  This is
 234 usually what you want; a newly created SV has a reference count of one, so
 235 if all your code does is create SVs then store them in a hash, hv_store
 236 will own the only reference to the new SV, and your code doesn't need to do
 237 anything further to tidy up.  hv_store is not implemented as a call to
 238 hv_store_ent, and does not create a temporary SV for the key, so if your
 239 key data is not already in SV form then use hv_store in preference to
 240 hv_store_ent.
 241
 242 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
 243 information on how to use this function on tied hashes.
 244
 245 =for apidoc hv_store_ent
 246
 247 Stores C<val> in a hash.  The hash key is specified as C<key>.  The C<hash>
 248 parameter is the precomputed hash value; if it is zero then Perl will
 249 compute it.  The return value is the new hash entry so created.  It will be
 250 NULL if the operation failed or if the value did not need to be actually
 251 stored within the hash (as in the case of tied hashes).  Otherwise the
 252 contents of the return value can be accessed using the C<He?> macros
 253 described here.  Note that the caller is responsible for suitably
 254 incrementing the reference count of C<val> before the call, and
 255 decrementing it if the function returned NULL.  Effectively a successful
 256 hv_store_ent takes ownership of one reference to C<val>.  This is
 257 usually what you want; a newly created SV has a reference count of one, so
 258 if all your code does is create SVs then store them in a hash, hv_store
 259 will own the only reference to the new SV, and your code doesn't need to do
 260 anything further to tidy up.  Note that hv_store_ent only reads the C<key>;
 261 unlike C<val> it does not take ownership of it, so maintaining the correct
 262 reference count on C<key> is entirely the caller's responsibility.  hv_store
 263 is not implemented as a call to hv_store_ent, and does not create a temporary
 264 SV for the key, so if your key data is not already in SV form then use
 265 hv_store in preference to hv_store_ent.
 266
 267 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
 268 information on how to use this function on tied hashes.
 269
 270 =for apidoc hv_exists
 271
 272 Returns a boolean indicating whether the specified hash key exists.  The
 273 absolute value of C<klen> is the length of the key.  If C<klen> is
 274 negative the key is assumed to be in UTF-8-encoded Unicode.
 275
 276 =for apidoc hv_fetch
 277
 278 Returns the SV which corresponds to the specified key in the hash.
 279 The absolute value of C<klen> is the length of the key.  If C<klen> is
 280 negative the key is assumed to be in UTF-8-encoded Unicode.  If
 281 C<lval> is set then the fetch will be part of a store.  This means that if
 282 there is no value in the hash associated with the given key, then one is
 283 created and a pointer to it is returned.  The C<SV*> it points to can be
 284 assigned to.  But always check that the
 285 return value is non-null before dereferencing it to an C<SV*>.
 286
 287 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
 288 information on how to use this function on tied hashes.
 289
 290 =for apidoc hv_exists_ent
 291
 292 Returns a boolean indicating whether
 293 the specified hash key exists.  C<hash>
 294 can be a valid precomputed hash value, or 0 to ask for it to be
 295 computed.
 296
 297 =cut
 298 */
 299
 300 /* returns an HE * structure with the all fields set */
 301 /* note that hent_val will be a mortal sv for MAGICAL hashes */
 302 /*
 303 =for apidoc hv_fetch_ent
 304
 305 Returns the hash entry which corresponds to the specified key in the hash.
 306 C<hash> must be a valid precomputed hash number for the given C<key>, or 0
 307 if you want the function to compute it.  IF C<lval> is set then the fetch
 308 will be part of a store.  Make sure the return value is non-null before
 309 accessing it.  The return value when C<hv> is a tied hash is a pointer to a
 310 static location, so be sure to make a copy of the structure if you need to
 311 store it somewhere.
 312
 313 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
 314 information on how to use this function on tied hashes.
 315
 316 =cut
 317 */
 318
 319 /* Common code for hv_delete()/hv_exists()/hv_fetch()/hv_store()  */
 320 void *
 321 Perl_hv_common_key_len(pTHX_ HV *hv, const char *key, I32 klen_i32,
 322                        const int action, SV *val, const U32 hash)
 323 {
 324     STRLEN klen;
 325     int flags;
 326
 327     PERL_ARGS_ASSERT_HV_COMMON_KEY_LEN;
 328
 329     if (klen_i32 < 0) {
 330         klen = -klen_i32;
 331         flags = HVhek_UTF8;
 332     } else {
 333         klen = klen_i32;
 334         flags = 0;
 335     }
 336     return hv_common(hv, NULL, key, klen, flags, action, val, hash);
 337 }
 338
 339 void *
 340 Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
 341                int flags, int action, SV *val, U32 hash)
 342 {
 343     dVAR;
 344     XPVHV* xhv;
 345     HE *entry;
 346     HE **oentry;
 347     SV *sv;
 348     bool is_utf8;
 349     int masked_flags;
 350     const int return_svp = action & HV_FETCH_JUST_SV;
 351
 352     if (!hv)
 353         return NULL;
 354     if (SvTYPE(hv) == (svtype)SVTYPEMASK)
 355         return NULL;
 356
 357     assert(SvTYPE(hv) == SVt_PVHV);
 358
 359     if (SvSMAGICAL(hv) && SvGMAGICAL(hv) && !(action & HV_DISABLE_UVAR_XKEY)) {
 360         MAGIC* mg;
 361         if ((mg = mg_find((const SV *)hv, PERL_MAGIC_uvar))) {
 362             struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
 363             if (uf->uf_set == NULL) {
 364                 SV* obj = mg->mg_obj;
 365
 366                 if (!keysv) {
 367                     keysv = newSVpvn_flags(key, klen, SVs_TEMP |
 368                                            ((flags & HVhek_UTF8)
 369                                             ? SVf_UTF8 : 0));
 370                 }
 371
 372                 mg->mg_obj = keysv;         /* pass key */
 373                 uf->uf_index = action;      /* pass action */
 374                 magic_getuvar(MUTABLE_SV(hv), mg);
 375                 keysv = mg->mg_obj;         /* may have changed */
 376                 mg->mg_obj = obj;
 377
 378                 /* If the key may have changed, then we need to invalidate
 379                    any passed-in computed hash value.  */
 380                 hash = 0;
 381             }
 382         }
 383     }
 384     if (keysv) {
 385         if (flags & HVhek_FREEKEY)
 386             Safefree(key);
 387         key = SvPV_const(keysv, klen);
 388         is_utf8 = (SvUTF8(keysv) != 0);
 389         if (SvIsCOW_shared_hash(keysv)) {
 390             flags = HVhek_KEYCANONICAL | (is_utf8 ? HVhek_UTF8 : 0);
 391         } else {
 392             flags = is_utf8 ? HVhek_UTF8 : 0;
 393         }
 394     } else {
 395         is_utf8 = ((flags & HVhek_UTF8) ? TRUE : FALSE);
 396     }
 397
 398     if (action & HV_DELETE) {
 399         return (void *) hv_delete_common(hv, keysv, key, klen,
 400                                          flags, action, hash);
 401     }
 402
 403     xhv = (XPVHV*)SvANY(hv);
 404     if (SvMAGICAL(hv)) {
 405         if (SvRMAGICAL(hv) && !(action & (HV_FETCH_ISSTORE|HV_FETCH_ISEXISTS))) {
 406             if (mg_find((const SV *)hv, PERL_MAGIC_tied)
 407                 || SvGMAGICAL((const SV *)hv))
 408             {
 409                 /* FIXME should be able to skimp on the HE/HEK here when
 410                    HV_FETCH_JUST_SV is true.  */
 411                 if (!keysv) {
 412                     keysv = newSVpvn_utf8(key, klen, is_utf8);
 413                 } else {
 414                     keysv = newSVsv(keysv);
 415                 }
 416                 sv = sv_newmortal();
 417                 mg_copy(MUTABLE_SV(hv), sv, (char *)keysv, HEf_SVKEY);
 418
 419                 /* grab a fake HE/HEK pair from the pool or make a new one */
 420                 entry = PL_hv_fetch_ent_mh;
 421                 if (entry)
 422                     PL_hv_fetch_ent_mh = HeNEXT(entry);
 423                 else {
 424                     char *k;
 425                     entry = new_HE();
 426                     Newx(k, HEK_BASESIZE + sizeof(const SV *), char);
 427                     HeKEY_hek(entry) = (HEK*)k;
 428                 }
 429                 HeNEXT(entry) = NULL;
 430                 HeSVKEY_set(entry, keysv);
 431                 HeVAL(entry) = sv;
 432                 sv_upgrade(sv, SVt_PVLV);
 433                 LvTYPE(sv) = 'T';
 434                  /* so we can free entry when freeing sv */
 435                 LvTARG(sv) = MUTABLE_SV(entry);
 436
 437                 /* XXX remove at some point? */
 438                 if (flags & HVhek_FREEKEY)
 439                     Safefree(key);
 440
 441                 if (return_svp) {
 442                     return entry ? (void *) &HeVAL(entry) : NULL;
 443                 }
 444                 return (void *) entry;
 445             }
 446 #ifdef ENV_IS_CASELESS
 447             else if (mg_find((const SV *)hv, PERL_MAGIC_env)) {
 448                 U32 i;
 449                 for (i = 0; i < klen; ++i)
 450                     if (isLOWER(key[i])) {
 451                         /* Would be nice if we had a routine to do the
 452                            copy and upercase in a single pass through.  */
 453                         const char * const nkey = strupr(savepvn(key,klen));
 454                         /* Note that this fetch is for nkey (the uppercased
 455                            key) whereas the store is for key (the original)  */
 456                         void *result = hv_common(hv, NULL, nkey, klen,
 457                                                  HVhek_FREEKEY, /* free nkey */
 458                                                  0 /* non-LVAL fetch */
 459                                                  | HV_DISABLE_UVAR_XKEY
 460                                                  | return_svp,
 461                                                  NULL /* no value */,
 462                                                  0 /* compute hash */);
 463                         if (!result && (action & HV_FETCH_LVALUE)) {
 464                             /* This call will free key if necessary.
 465                                Do it this way to encourage compiler to tail
 466                                call optimise.  */
 467                             result = hv_common(hv, keysv, key, klen, flags,
 468                                                HV_FETCH_ISSTORE
 469                                                | HV_DISABLE_UVAR_XKEY
 470                                                | return_svp,
 471                                                newSV(0), hash);
 472                         } else {
 473                             if (flags & HVhek_FREEKEY)
 474                                 Safefree(key);
 475                         }
 476                         return result;
 477                     }
 478             }
 479 #endif
 480         } /* ISFETCH */
 481         else if (SvRMAGICAL(hv) && (action & HV_FETCH_ISEXISTS)) {
 482             if (mg_find((const SV *)hv, PERL_MAGIC_tied)
 483                 || SvGMAGICAL((const SV *)hv)) {
 484                 /* I don't understand why hv_exists_ent has svret and sv,
 485                    whereas hv_exists only had one.  */
 486                 SV * const svret = sv_newmortal();
 487                 sv = sv_newmortal();
 488
 489                 if (keysv || is_utf8) {
 490                     if (!keysv) {
 491                         keysv = newSVpvn_utf8(key, klen, TRUE);
 492                     } else {
 493                         keysv = newSVsv(keysv);
 494                     }
 495                     mg_copy(MUTABLE_SV(hv), sv, (char *)sv_2mortal(keysv), HEf_SVKEY);
 496                 } else {
 497                     mg_copy(MUTABLE_SV(hv), sv, key, klen);
 498                 }
 499                 if (flags & HVhek_FREEKEY)
 500                     Safefree(key);
 501                 magic_existspack(svret, mg_find(sv, PERL_MAGIC_tiedelem));
 502                 /* This cast somewhat evil, but I'm merely using NULL/
 503                    not NULL to return the boolean exists.
 504                    And I know hv is not NULL.  */
 505                 return SvTRUE(svret) ? (void *)hv : NULL;
 506                 }
 507 #ifdef ENV_IS_CASELESS
 508             else if (mg_find((const SV *)hv, PERL_MAGIC_env)) {
 509                 /* XXX This code isn't UTF8 clean.  */
 510                 char * const keysave = (char * const)key;
 511                 /* Will need to free this, so set FREEKEY flag.  */
 512                 key = savepvn(key,klen);
 513                 key = (const char*)strupr((char*)key);
 514                 is_utf8 = FALSE;
 515                 hash = 0;
 516                 keysv = 0;
 517
 518                 if (flags & HVhek_FREEKEY) {
 519                     Safefree(keysave);
 520                 }
 521                 flags |= HVhek_FREEKEY;
 522             }
 523 #endif
 524         } /* ISEXISTS */
 525         else if (action & HV_FETCH_ISSTORE) {
 526             bool needs_copy;
 527             bool needs_store;
 528             hv_magic_check (hv, &needs_copy, &needs_store);
 529             if (needs_copy) {
 530                 const bool save_taint = TAINT_get;
 531                 if (keysv || is_utf8) {
 532                     if (!keysv) {
 533                         keysv = newSVpvn_utf8(key, klen, TRUE);
 534                     }
 535                     if (TAINTING_get)
 536                         TAINT_set(SvTAINTED(keysv));
 537                     keysv = sv_2mortal(newSVsv(keysv));
 538                     mg_copy(MUTABLE_SV(hv), val, (char*)keysv, HEf_SVKEY);
 539                 } else {
 540                     mg_copy(MUTABLE_SV(hv), val, key, klen);
 541                 }
 542
 543                 TAINT_IF(save_taint);
 544 #ifdef NO_TAINT_SUPPORT
 545                 PERL_UNUSED_VAR(save_taint);
 546 #endif
 547                 if (!needs_store) {
 548                     if (flags & HVhek_FREEKEY)
 549                         Safefree(key);
 550                     return NULL;
 551                 }
 552 #ifdef ENV_IS_CASELESS
 553                 else if (mg_find((const SV *)hv, PERL_MAGIC_env)) {
 554                     /* XXX This code isn't UTF8 clean.  */
 555                     const char *keysave = key;
 556                     /* Will need to free this, so set FREEKEY flag.  */
 557                     key = savepvn(key,klen);
 558                     key = (const char*)strupr((char*)key);
 559                     is_utf8 = FALSE;
 560                     hash = 0;
 561                     keysv = 0;
 562
 563                     if (flags & HVhek_FREEKEY) {
 564                         Safefree(keysave);
 565                     }
 566                     flags |= HVhek_FREEKEY;
 567                 }
 568 #endif
 569             }
 570         } /* ISSTORE */
 571     } /* SvMAGICAL */
 572
 573     if (!HvARRAY(hv)) {
 574         if ((action & (HV_FETCH_LVALUE | HV_FETCH_ISSTORE))
 575 #ifdef DYNAMIC_ENV_FETCH  /* if it's an %ENV lookup, we may get it on the fly */
 576                  || (SvRMAGICAL((const SV *)hv)
 577                      && mg_find((const SV *)hv, PERL_MAGIC_env))
 578 #endif
 579                                                                   ) {
 580             char *array;
 581             Newxz(array,
 582                  PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
 583                  char);
 584             HvARRAY(hv) = (HE**)array;
 585         }
 586 #ifdef DYNAMIC_ENV_FETCH
 587         else if (action & HV_FETCH_ISEXISTS) {
 588             /* for an %ENV exists, if we do an insert it's by a recursive
 589                store call, so avoid creating HvARRAY(hv) right now.  */
 590         }
 591 #endif
 592         else {
 593             /* XXX remove at some point? */
 594             if (flags & HVhek_FREEKEY)
 595                 Safefree(key);
 596
 597             return NULL;
 598         }
 599     }
 600
 601     if (is_utf8 && !(flags & HVhek_KEYCANONICAL)) {
 602         char * const keysave = (char *)key;
 603         key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
 604         if (is_utf8)
 605             flags |= HVhek_UTF8;
 606         else
 607             flags &= ~HVhek_UTF8;
 608         if (key != keysave) {
 609             if (flags & HVhek_FREEKEY)
 610                 Safefree(keysave);
 611             flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
 612             /* If the caller calculated a hash, it was on the sequence of
 613                octets that are the UTF-8 form. We've now changed the sequence
 614                of octets stored to that of the equivalent byte representation,
 615                so the hash we need is different.  */
 616             hash = 0;
 617         }
 618     }
 619
 620     if (!hash) {
 621         if (keysv && (SvIsCOW_shared_hash(keysv)))
 622             hash = SvSHARED_HASH(keysv);
 623         else
 624             PERL_HASH(hash, key, klen);
 625     }
 626
 627     masked_flags = (flags & HVhek_MASK);
 628
 629 #ifdef DYNAMIC_ENV_FETCH
 630     if (!HvARRAY(hv)) entry = NULL;
 631     else
 632 #endif
 633     {
 634         entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)];
 635     }
 636     for (; entry; entry = HeNEXT(entry)) {
 637         if (HeHASH(entry) != hash)              /* strings can't be equal */
 638             continue;
 639         if (HeKLEN(entry) != (I32)klen)
 640             continue;
 641         if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen))        /* is this it? */
 642             continue;
 643         if ((HeKFLAGS(entry) ^ masked_flags) & HVhek_UTF8)
 644             continue;
 645
 646         if (action & (HV_FETCH_LVALUE|HV_FETCH_ISSTORE)) {
 647             if (HeKFLAGS(entry) != masked_flags) {
 648                 /* We match if HVhek_UTF8 bit in our flags and hash key's
 649                    match.  But if entry was set previously with HVhek_WASUTF8
 650                    and key now doesn't (or vice versa) then we should change
 651                    the key's flag, as this is assignment.  */
 652                 if (HvSHAREKEYS(hv)) {
 653                     /* Need to swap the key we have for a key with the flags we
 654                        need. As keys are shared we can't just write to the
 655                        flag, so we share the new one, unshare the old one.  */
 656                     HEK * const new_hek = share_hek_flags(key, klen, hash,
 657                                                    masked_flags);
 658                     unshare_hek (HeKEY_hek(entry));
 659                     HeKEY_hek(entry) = new_hek;
 660                 }
 661                 else if (hv == PL_strtab) {
 662                     /* PL_strtab is usually the only hash without HvSHAREKEYS,
 663                        so putting this test here is cheap  */
 664                     if (flags & HVhek_FREEKEY)
 665                         Safefree(key);
 666                     Perl_croak(aTHX_ S_strtab_error,
 667                                action & HV_FETCH_LVALUE ? "fetch" : "store");
 668                 }
 669                 else
 670                     HeKFLAGS(entry) = masked_flags;
 671                 if (masked_flags & HVhek_ENABLEHVKFLAGS)
 672                     HvHASKFLAGS_on(hv);
 673             }
 674             if (HeVAL(entry) == &PL_sv_placeholder) {
 675                 /* yes, can store into placeholder slot */
 676                 if (action & HV_FETCH_LVALUE) {
 677                     if (SvMAGICAL(hv)) {
 678                         /* This preserves behaviour with the old hv_fetch
 679                            implementation which at this point would bail out
 680                            with a break; (at "if we find a placeholder, we
 681                            pretend we haven't found anything")
 682
 683                            That break mean that if a placeholder were found, it
 684                            caused a call into hv_store, which in turn would
 685                            check magic, and if there is no magic end up pretty
 686                            much back at this point (in hv_store's code).  */
 687                         break;
 688                     }
 689                     /* LVAL fetch which actually needs a store.  */
 690                     val = newSV(0);
 691                     HvPLACEHOLDERS(hv)--;
 692                 } else {
 693                     /* store */
 694                     if (val != &PL_sv_placeholder)
 695                         HvPLACEHOLDERS(hv)--;
 696                 }
 697                 HeVAL(entry) = val;
 698             } else if (action & HV_FETCH_ISSTORE) {
 699                 SvREFCNT_dec(HeVAL(entry));
 700                 HeVAL(entry) = val;
 701             }
 702         } else if (HeVAL(entry) == &PL_sv_placeholder) {
 703             /* if we find a placeholder, we pretend we haven't found
 704                anything */
 705             break;
 706         }
 707         if (flags & HVhek_FREEKEY)
 708             Safefree(key);
 709         if (return_svp) {
 710             return entry ? (void *) &HeVAL(entry) : NULL;
 711         }
 712         return entry;
 713     }
 714 #ifdef DYNAMIC_ENV_FETCH  /* %ENV lookup?  If so, try to fetch the value now */
 715     if (!(action & HV_FETCH_ISSTORE)
 716         && SvRMAGICAL((const SV *)hv)
 717         && mg_find((const SV *)hv, PERL_MAGIC_env)) {
 718         unsigned long len;
 719         const char * const env = PerlEnv_ENVgetenv_len(key,&len);
 720         if (env) {
 721             sv = newSVpvn(env,len);
 722             SvTAINTED_on(sv);
 723             return hv_common(hv, keysv, key, klen, flags,
 724                              HV_FETCH_ISSTORE|HV_DISABLE_UVAR_XKEY|return_svp,
 725                              sv, hash);
 726         }
 727     }
 728 #endif
 729
 730     if (!entry && SvREADONLY(hv) && !(action & HV_FETCH_ISEXISTS)) {
 731         hv_notallowed(flags, key, klen,
 732                         "Attempt to access disallowed key '%"SVf"' in"
 733                         " a restricted hash");
 734     }
 735     if (!(action & (HV_FETCH_LVALUE|HV_FETCH_ISSTORE))) {
 736         /* Not doing some form of store, so return failure.  */
 737         if (flags & HVhek_FREEKEY)
 738             Safefree(key);
 739         return NULL;
 740     }
 741     if (action & HV_FETCH_LVALUE) {
 742         val = action & HV_FETCH_EMPTY_HE ? NULL : newSV(0);
 743         if (SvMAGICAL(hv)) {
 744             /* At this point the old hv_fetch code would call to hv_store,
 745                which in turn might do some tied magic. So we need to make that
 746                magic check happen.  */
 747             /* gonna assign to this, so it better be there */
 748             /* If a fetch-as-store fails on the fetch, then the action is to
 749                recurse once into "hv_store". If we didn't do this, then that
 750                recursive call would call the key conversion routine again.
 751                However, as we replace the original key with the converted
 752                key, this would result in a double conversion, which would show
 753                up as a bug if the conversion routine is not idempotent.
 754                Hence the use of HV_DISABLE_UVAR_XKEY.  */
 755             return hv_common(hv, keysv, key, klen, flags,
 756                              HV_FETCH_ISSTORE|HV_DISABLE_UVAR_XKEY|return_svp,
 757                              val, hash);
 758             /* XXX Surely that could leak if the fetch-was-store fails?
 759                Just like the hv_fetch.  */
 760         }
 761     }
 762
 763     /* Welcome to hv_store...  */
 764
 765     if (!HvARRAY(hv)) {
 766         /* Not sure if we can get here.  I think the only case of oentry being
 767            NULL is for %ENV with dynamic env fetch.  But that should disappear
 768            with magic in the previous code.  */
 769         char *array;
 770         Newxz(array,
 771              PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
 772              char);
 773         HvARRAY(hv) = (HE**)array;
 774     }
 775
 776     oentry = &(HvARRAY(hv))[hash & (I32) xhv->xhv_max];
 777
 778     entry = new_HE();
 779     /* share_hek_flags will do the free for us.  This might be considered
 780        bad API design.  */
 781     if (HvSHAREKEYS(hv))
 782         HeKEY_hek(entry) = share_hek_flags(key, klen, hash, flags);
 783     else if (hv == PL_strtab) {
 784         /* PL_strtab is usually the only hash without HvSHAREKEYS, so putting
 785            this test here is cheap  */
 786         if (flags & HVhek_FREEKEY)
 787             Safefree(key);
 788         Perl_croak(aTHX_ S_strtab_error,
 789                    action & HV_FETCH_LVALUE ? "fetch" : "store");
 790     }
 791     else                                       /* gotta do the real thing */
 792         HeKEY_hek(entry) = save_hek_flags(key, klen, hash, flags);
 793     HeVAL(entry) = val;
 794
 795     if (!*oentry && SvOOK(hv)) {
 796         /* initial entry, and aux struct present.  */
 797         struct xpvhv_aux *const aux = HvAUX(hv);
 798         if (aux->xhv_fill_lazy)
 799             ++aux->xhv_fill_lazy;
 800     }
 801
 802 #ifdef PERL_HASH_RANDOMIZE_KEYS
 803     /* This logic semi-randomizes the insert order in a bucket.
 804      * Either we insert into the top, or the slot below the top,
 805      * making it harder to see if there is a collision. We also
 806      * reset the iterator randomizer if there is one.
 807      */
 808     if ( *oentry && PL_HASH_RAND_BITS_ENABLED) {
 809         PL_hash_rand_bits++;
 810         PL_hash_rand_bits= ROTL_UV(PL_hash_rand_bits,1);
 811         if ( PL_hash_rand_bits & 1 ) {
 812             HeNEXT(entry) = HeNEXT(*oentry);
 813             HeNEXT(*oentry) = entry;
 814         } else {
 815             HeNEXT(entry) = *oentry;
 816             *oentry = entry;
 817         }
 818     } else
 819 #endif
 820     {
 821         HeNEXT(entry) = *oentry;
 822         *oentry = entry;
 823     }
 824 #ifdef PERL_HASH_RANDOMIZE_KEYS
 825     if (SvOOK(hv)) {
 826         /* Currently this makes various tests warn in annoying ways.
 827          * So Silenced for now. - Yves | bogus end of comment =>* /
 828         if (HvAUX(hv)->xhv_riter != -1) {
 829             Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
 830                              "[TESTING] Inserting into a hash during each() traversal results in undefined behavior"
 831                              pTHX__FORMAT
 832                              pTHX__VALUE);
 833         }
 834         */
 835         if (PL_HASH_RAND_BITS_ENABLED) {
 836             if (PL_HASH_RAND_BITS_ENABLED == 1)
 837                 PL_hash_rand_bits += (PTRV)entry + 1;  /* we don't bother to use ptr_hash here */
 838             PL_hash_rand_bits= ROTL_UV(PL_hash_rand_bits,1);
 839         }
 840         HvAUX(hv)->xhv_rand= (U32)PL_hash_rand_bits;
 841     }
 842 #endif
 843
 844     if (val == &PL_sv_placeholder)
 845         HvPLACEHOLDERS(hv)++;
 846     if (masked_flags & HVhek_ENABLEHVKFLAGS)
 847         HvHASKFLAGS_on(hv);
 848
 849     xhv->xhv_keys++; /* HvTOTALKEYS(hv)++ */
 850     if ( DO_HSPLIT(xhv) ) {
 851         const STRLEN oldsize = xhv->xhv_max + 1;
 852         const U32 items = (U32)HvPLACEHOLDERS_get(hv);
 853
 854         if (items /* hash has placeholders  */
 855             && !SvREADONLY(hv) /* but is not a restricted hash */) {
 856             /* If this hash previously was a "restricted hash" and had
 857                placeholders, but the "restricted" flag has been turned off,
 858                then the placeholders no longer serve any useful purpose.
 859                However, they have the downsides of taking up RAM, and adding
 860                extra steps when finding used values. It's safe to clear them
 861                at this point, even though Storable rebuilds restricted hashes by
 862                putting in all the placeholders (first) before turning on the
 863                readonly flag, because Storable always pre-splits the hash.
 864                If we're lucky, then we may clear sufficient placeholders to
 865                avoid needing to split the hash at all.  */
 866             clear_placeholders(hv, items);
 867             if (DO_HSPLIT(xhv))
 868                 hsplit(hv, oldsize, oldsize * 2);
 869         } else
 870             hsplit(hv, oldsize, oldsize * 2);
 871     }
 872
 873     if (return_svp) {
 874         return entry ? (void *) &HeVAL(entry) : NULL;
 875     }
 876     return (void *) entry;
 877 }
 878
 879 STATIC void
 880 S_hv_magic_check(HV *hv, bool *needs_copy, bool *needs_store)
 881 {
 882     const MAGIC *mg = SvMAGIC(hv);
 883
 884     PERL_ARGS_ASSERT_HV_MAGIC_CHECK;
 885
 886     *needs_copy = FALSE;
 887     *needs_store = TRUE;
 888     while (mg) {
 889         if (isUPPER(mg->mg_type)) {
 890             *needs_copy = TRUE;
 891             if (mg->mg_type == PERL_MAGIC_tied) {
 892                 *needs_store = FALSE;
 893                 return; /* We've set all there is to set. */
 894             }
 895         }
 896         mg = mg->mg_moremagic;
 897     }
 898 }
 899
 900 /*
 901 =for apidoc hv_scalar
 902
 903 Evaluates the hash in scalar context and returns the result. Handles magic when the hash is tied.
 904
 905 =cut
 906 */
 907
 908 SV *
 909 Perl_hv_scalar(pTHX_ HV *hv)
 910 {
 911     SV *sv;
 912
 913     PERL_ARGS_ASSERT_HV_SCALAR;
 914
 915     if (SvRMAGICAL(hv)) {
 916         MAGIC * const mg = mg_find((const SV *)hv, PERL_MAGIC_tied);
 917         if (mg)
 918             return magic_scalarpack(hv, mg);
 919     }
 920
 921     sv = sv_newmortal();
 922     if (HvTOTALKEYS((const HV *)hv))
 923         Perl_sv_setpvf(aTHX_ sv, "%ld/%ld",
 924                 (long)HvFILL(hv), (long)HvMAX(hv) + 1);
 925     else
 926         sv_setiv(sv, 0);
 927
 928     return sv;
 929 }
 930
 931 /*
 932 =for apidoc hv_delete
 933
 934 Deletes a key/value pair in the hash.  The value's SV is removed from
 935 the hash, made mortal, and returned to the caller.  The absolute
 936 value of C<klen> is the length of the key.  If C<klen> is negative the
 937 key is assumed to be in UTF-8-encoded Unicode.  The C<flags> value
 938 will normally be zero; if set to G_DISCARD then NULL will be returned.
 939 NULL will also be returned if the key is not found.
 940
 941 =for apidoc hv_delete_ent
 942
 943 Deletes a key/value pair in the hash.  The value SV is removed from the hash,
 944 made mortal, and returned to the caller.  The C<flags> value will normally be
 945 zero; if set to G_DISCARD then NULL will be returned.  NULL will also be
 946 returned if the key is not found.  C<hash> can be a valid precomputed hash
 947 value, or 0 to ask for it to be computed.
 948
 949 =cut
 950 */
 951
 952 STATIC SV *
 953 S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
 954                    int k_flags, I32 d_flags, U32 hash)
 955 {
 956     dVAR;
 957     XPVHV* xhv;
 958     HE *entry;
 959     HE **oentry;
 960     HE *const *first_entry;
 961     bool is_utf8 = (k_flags & HVhek_UTF8) ? TRUE : FALSE;
 962     int masked_flags;
 963
 964     if (SvRMAGICAL(hv)) {
 965         bool needs_copy;
 966         bool needs_store;
 967         hv_magic_check (hv, &needs_copy, &needs_store);
 968
 969         if (needs_copy) {
 970             SV *sv;
 971             entry = (HE *) hv_common(hv, keysv, key, klen,
 972                                      k_flags & ~HVhek_FREEKEY,
 973                                      HV_FETCH_LVALUE|HV_DISABLE_UVAR_XKEY,
 974                                      NULL, hash);
 975             sv = entry ? HeVAL(entry) : NULL;
 976             if (sv) {
 977                 if (SvMAGICAL(sv)) {
 978                     mg_clear(sv);
 979                 }
 980                 if (!needs_store) {
 981                     if (mg_find(sv, PERL_MAGIC_tiedelem)) {
 982                         /* No longer an element */
 983                         sv_unmagic(sv, PERL_MAGIC_tiedelem);
 984                         return sv;
 985                     }
 986                     return NULL;                /* element cannot be deleted */
 987                 }
 988 #ifdef ENV_IS_CASELESS
 989                 else if (mg_find((const SV *)hv, PERL_MAGIC_env)) {
 990                     /* XXX This code isn't UTF8 clean.  */
 991                     keysv = newSVpvn_flags(key, klen, SVs_TEMP);
 992                     if (k_flags & HVhek_FREEKEY) {
 993                         Safefree(key);
 994                     }
 995                     key = strupr(SvPVX(keysv));
 996                     is_utf8 = 0;
 997                     k_flags = 0;
 998                     hash = 0;
 999                 }
1000 #endif
1001             }
1002         }
1003     }
1004     xhv = (XPVHV*)SvANY(hv);
1005     if (!HvARRAY(hv))
1006         return NULL;
1007
1008     if (is_utf8 && !(k_flags & HVhek_KEYCANONICAL)) {
1009         const char * const keysave = key;
1010         key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
1011
1012         if (is_utf8)
1013             k_flags |= HVhek_UTF8;
1014         else
1015             k_flags &= ~HVhek_UTF8;
1016         if (key != keysave) {
1017             if (k_flags & HVhek_FREEKEY) {
1018                 /* This shouldn't happen if our caller does what we expect,
1019                    but strictly the API allows it.  */
1020                 Safefree(keysave);
1021             }
1022             k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
1023         }
1024         HvHASKFLAGS_on(MUTABLE_SV(hv));
1025     }
1026
1027     if (!hash) {
1028         if (keysv && (SvIsCOW_shared_hash(keysv)))
1029             hash = SvSHARED_HASH(keysv);
1030         else
1031             PERL_HASH(hash, key, klen);
1032     }
1033
1034     masked_flags = (k_flags & HVhek_MASK);
1035
1036     first_entry = oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)];
1037     entry = *oentry;
1038     for (; entry; oentry = &HeNEXT(entry), entry = *oentry) {
1039         SV *sv;
1040         U8 mro_changes = 0; /* 1 = isa; 2 = package moved */
1041         GV *gv = NULL;
1042         HV *stash = NULL;
1043
1044         if (HeHASH(entry) != hash)              /* strings can't be equal */
1045             continue;
1046         if (HeKLEN(entry) != (I32)klen)
1047             continue;
1048         if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen))        /* is this it? */
1049             continue;
1050         if ((HeKFLAGS(entry) ^ masked_flags) & HVhek_UTF8)
1051             continue;
1052
1053         if (hv == PL_strtab) {
1054             if (k_flags & HVhek_FREEKEY)
1055                 Safefree(key);
1056             Perl_croak(aTHX_ S_strtab_error, "delete");
1057         }
1058
1059         /* if placeholder is here, it's already been deleted.... */
1060         if (HeVAL(entry) == &PL_sv_placeholder) {
1061             if (k_flags & HVhek_FREEKEY)
1062                 Safefree(key);
1063             return NULL;
1064         }
1065         if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
1066             hv_notallowed(k_flags, key, klen,
1067                             "Attempt to delete readonly key '%"SVf"' from"
1068                             " a restricted hash");
1069         }
1070         if (k_flags & HVhek_FREEKEY)
1071             Safefree(key);
1072
1073         /* If this is a stash and the key ends with ::, then someone is
1074          * deleting a package.
1075          */
1076         if (HeVAL(entry) && HvENAME_get(hv)) {
1077                 gv = (GV *)HeVAL(entry);
1078                 if (keysv) key = SvPV(keysv, klen);
1079                 if ((
1080                      (klen > 1 && key[klen-2] == ':' && key[klen-1] == ':')
1081                       ||
1082                      (klen == 1 && key[0] == ':')
1083                     )
1084                  && (klen != 6 || hv!=PL_defstash || memNE(key,"main::",6))
1085                  && SvTYPE(gv) == SVt_PVGV && (stash = GvHV((GV *)gv))
1086                  && HvENAME_get(stash)) {
1087                         /* A previous version of this code checked that the
1088                          * GV was still in the symbol table by fetching the
1089                          * GV with its name. That is not necessary (and
1090                          * sometimes incorrect), as HvENAME cannot be set
1091                          * on hv if it is not in the symtab. */
1092                         mro_changes = 2;
1093                         /* Hang on to it for a bit. */
1094                         SvREFCNT_inc_simple_void_NN(
1095                          sv_2mortal((SV *)gv)
1096                         );
1097                 }
1098                 else if (klen == 3 && strnEQ(key, "ISA", 3))
1099                     mro_changes = 1;
1100         }
1101
1102         sv = d_flags & G_DISCARD ? HeVAL(entry) : sv_2mortal(HeVAL(entry));
1103         HeVAL(entry) = &PL_sv_placeholder;
1104         if (sv) {
1105             /* deletion of method from stash */
1106             if (isGV(sv) && isGV_with_GP(sv) && GvCVu(sv)
1107              && HvENAME_get(hv))
1108                 mro_method_changed_in(hv);
1109         }
1110
1111         /*
1112          * If a restricted hash, rather than really deleting the entry, put
1113          * a placeholder there. This marks the key as being "approved", so
1114          * we can still access via not-really-existing key without raising
1115          * an error.
1116          */
1117         if (SvREADONLY(hv))
1118             /* We'll be saving this slot, so the number of allocated keys
1119              * doesn't go down, but the number placeholders goes up */
1120             HvPLACEHOLDERS(hv)++;
1121         else {
1122             *oentry = HeNEXT(entry);
1123             if(!*first_entry && SvOOK(hv)) {
1124                 /* removed last entry, and aux struct present.  */
1125                 struct xpvhv_aux *const aux = HvAUX(hv);
1126                 if (aux->xhv_fill_lazy)
1127                     --aux->xhv_fill_lazy;
1128             }
1129             if (SvOOK(hv) && entry == HvAUX(hv)->xhv_eiter /* HvEITER(hv) */)
1130                 HvLAZYDEL_on(hv);
1131             else {
1132                 if (SvOOK(hv) && HvLAZYDEL(hv) &&
1133                     entry == HeNEXT(HvAUX(hv)->xhv_eiter))
1134                     HeNEXT(HvAUX(hv)->xhv_eiter) = HeNEXT(entry);
1135                 hv_free_ent(hv, entry);
1136             }
1137             xhv->xhv_keys--; /* HvTOTALKEYS(hv)-- */
1138             if (xhv->xhv_keys == 0)
1139                 HvHASKFLAGS_off(hv);
1140         }
1141
1142         if (d_flags & G_DISCARD) {
1143             SvREFCNT_dec(sv);
1144             sv = NULL;
1145         }
1146
1147         if (mro_changes == 1) mro_isa_changed_in(hv);
1148         else if (mro_changes == 2)
1149             mro_package_moved(NULL, stash, gv, 1);
1150
1151         return sv;
1152     }
1153     if (SvREADONLY(hv)) {
1154         hv_notallowed(k_flags, key, klen,
1155                         "Attempt to delete disallowed key '%"SVf"' from"
1156                         " a restricted hash");
1157     }
1158
1159     if (k_flags & HVhek_FREEKEY)
1160         Safefree(key);
1161     return NULL;
1162 }
1163
1164 STATIC void
1165 S_hsplit(pTHX_ HV *hv, STRLEN const oldsize, STRLEN newsize)
1166 {
1167     dVAR;
1168     STRLEN i = 0;
1169     char *a = (char*) HvARRAY(hv);
1170     HE **aep;
1171
1172     PERL_ARGS_ASSERT_HSPLIT;
1173
1174     /*PerlIO_printf(PerlIO_stderr(), "hsplit called for %p which had %d\n",
1175       (void*)hv, (int) oldsize);*/
1176
1177     PL_nomemok = TRUE;
1178     Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize)
1179           + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char);
1180     if (!a) {
1181       PL_nomemok = FALSE;
1182       return;
1183     }
1184 #ifdef PERL_HASH_RANDOMIZE_KEYS
1185     /* the idea of this is that we create a "random" value by hashing the address of
1186      * the array, we then use the low bit to decide if we insert at the top, or insert
1187      * second from top. After each such insert we rotate the hashed value. So we can
1188      * use the same hashed value over and over, and in normal build environments use
1189      * very few ops to do so. ROTL32() should produce a single machine operation. */
1190     if (PL_HASH_RAND_BITS_ENABLED) {
1191         if (PL_HASH_RAND_BITS_ENABLED == 1)
1192             PL_hash_rand_bits += ptr_hash((PTRV)a);
1193         PL_hash_rand_bits = ROTL_UV(PL_hash_rand_bits,1);
1194     }
1195 #endif
1196
1197     if (SvOOK(hv)) {
1198         struct xpvhv_aux *const dest
1199             = (struct xpvhv_aux*) &a[newsize * sizeof(HE*)];
1200         Move(&a[oldsize * sizeof(HE*)], dest, 1, struct xpvhv_aux);
1201         /* we reset the iterator's xhv_rand as well, so they get a totally new ordering */
1202 #ifdef PERL_HASH_RANDOMIZE_KEYS
1203         dest->xhv_rand = (U32)PL_hash_rand_bits;
1204 #endif
1205         /* For now, just reset the lazy fill counter.
1206            It would be possible to update the counter in the code below
1207            instead.  */
1208         dest->xhv_fill_lazy = 0;
1209     }
1210
1211     PL_nomemok = FALSE;
1212     Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char);     /* zero 2nd half*/
1213     HvMAX(hv) = --newsize;
1214     HvARRAY(hv) = (HE**) a;
1215
1216     if (!HvTOTALKEYS(hv))       /* skip rest if no entries */
1217         return;
1218
1219     aep = (HE**)a;
1220     do {
1221         HE **oentry = aep + i;
1222         HE *entry = aep[i];
1223
1224         if (!entry)                             /* non-existent */
1225             continue;
1226         do {
1227             U32 j = (HeHASH(entry) & newsize);
1228             if (j != (U32)i) {
1229                 *oentry = HeNEXT(entry);
1230 #ifdef PERL_HASH_RANDOMIZE_KEYS
1231                 /* if the target cell is empty or PL_HASH_RAND_BITS_ENABLED is false
1232                  * insert to top, otherwise rotate the bucket rand 1 bit,
1233                  * and use the new low bit to decide if we insert at top,
1234                  * or next from top. IOW, we only rotate on a collision.*/
1235                 if (aep[j] && PL_HASH_RAND_BITS_ENABLED) {
1236                     PL_hash_rand_bits+= ROTL_UV(HeHASH(entry), 17);
1237                     PL_hash_rand_bits= ROTL_UV(PL_hash_rand_bits,1);
1238                     if (PL_hash_rand_bits & 1) {
1239                         HeNEXT(entry)= HeNEXT(aep[j]);
1240                         HeNEXT(aep[j])= entry;
1241                     } else {
1242                         /* Note, this is structured in such a way as the optimizer
1243                         * should eliminate the duplicated code here and below without
1244                         * us needing to explicitly use a goto. */
1245                         HeNEXT(entry) = aep[j];
1246                         aep[j] = entry;
1247                     }
1248                 } else
1249 #endif
1250                 {
1251                     /* see comment above about duplicated code */
1252                     HeNEXT(entry) = aep[j];
1253                     aep[j] = entry;
1254                 }
1255             }
1256             else {
1257                 oentry = &HeNEXT(entry);
1258             }
1259             entry = *oentry;
1260         } while (entry);
1261     } while (i++ < oldsize);
1262 }
1263
1264 void
1265 Perl_hv_ksplit(pTHX_ HV *hv, IV newmax)
1266 {
1267     dVAR;
1268     XPVHV* xhv = (XPVHV*)SvANY(hv);
1269     const I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
1270     I32 newsize;
1271     char *a;
1272
1273     PERL_ARGS_ASSERT_HV_KSPLIT;
1274
1275     newsize = (I32) newmax;                     /* possible truncation here */
1276     if (newsize != newmax || newmax <= oldsize)
1277         return;
1278     while ((newsize & (1 + ~newsize)) != newsize) {
1279         newsize &= ~(newsize & (1 + ~newsize)); /* get proper power of 2 */
1280     }
1281     if (newsize < newmax)
1282         newsize *= 2;
1283     if (newsize < newmax)
1284         return;                                 /* overflow detection */
1285
1286     a = (char *) HvARRAY(hv);
1287     if (a) {
1288         hsplit(hv, oldsize, newsize);
1289     } else {
1290         Newxz(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1291         xhv->xhv_max = --newsize;
1292         HvARRAY(hv) = (HE **) a;
1293     }
1294 }
1295
1296 /* IMO this should also handle cases where hv_max is smaller than hv_keys
1297  * as tied hashes could play silly buggers and mess us around. We will
1298  * do the right thing during hv_store() afterwards, but still - Yves */
1299 #define HV_SET_MAX_ADJUSTED_FOR_KEYS(hv,hv_max,hv_keys) STMT_START {\
1300     /* Can we use fewer buckets? (hv_max is always 2^n-1) */        \
1301     if (hv_max < PERL_HASH_DEFAULT_HvMAX) {                         \
1302         hv_max = PERL_HASH_DEFAULT_HvMAX;                           \
1303     } else {                                                        \
1304         while (hv_max > PERL_HASH_DEFAULT_HvMAX && hv_max + 1 >= hv_keys * 2) \
1305             hv_max = hv_max / 2;                                    \
1306     }                                                               \
1307     HvMAX(hv) = hv_max;                                             \
1308 } STMT_END
1309
1310
1311 HV *
1312 Perl_newHVhv(pTHX_ HV *ohv)
1313 {
1314     dVAR;
1315     HV * const hv = newHV();
1316     STRLEN hv_max;
1317
1318     if (!ohv || (!HvTOTALKEYS(ohv) && !SvMAGICAL((const SV *)ohv)))
1319         return hv;
1320     hv_max = HvMAX(ohv);
1321
1322     if (!SvMAGICAL((const SV *)ohv)) {
1323         /* It's an ordinary hash, so copy it fast. AMS 20010804 */
1324         STRLEN i;
1325         const bool shared = !!HvSHAREKEYS(ohv);
1326         HE **ents, ** const oents = (HE **)HvARRAY(ohv);
1327         char *a;
1328         Newx(a, PERL_HV_ARRAY_ALLOC_BYTES(hv_max+1), char);
1329         ents = (HE**)a;
1330
1331         /* In each bucket... */
1332         for (i = 0; i <= hv_max; i++) {
1333             HE *prev = NULL;
1334             HE *oent = oents[i];
1335
1336             if (!oent) {
1337                 ents[i] = NULL;
1338                 continue;
1339             }
1340
1341             /* Copy the linked list of entries. */
1342             for (; oent; oent = HeNEXT(oent)) {
1343                 const U32 hash   = HeHASH(oent);
1344                 const char * const key = HeKEY(oent);
1345                 const STRLEN len = HeKLEN(oent);
1346                 const int flags  = HeKFLAGS(oent);
1347                 HE * const ent   = new_HE();
1348                 SV *const val    = HeVAL(oent);
1349
1350                 HeVAL(ent) = SvIMMORTAL(val) ? val : newSVsv(val);
1351                 HeKEY_hek(ent)
1352                     = shared ? share_hek_flags(key, len, hash, flags)
1353                              :  save_hek_flags(key, len, hash, flags);
1354                 if (prev)
1355                     HeNEXT(prev) = ent;
1356                 else
1357                     ents[i] = ent;
1358                 prev = ent;
1359                 HeNEXT(ent) = NULL;
1360             }
1361         }
1362
1363         HvMAX(hv)   = hv_max;
1364         HvTOTALKEYS(hv)  = HvTOTALKEYS(ohv);
1365         HvARRAY(hv) = ents;
1366     } /* not magical */
1367     else {
1368         /* Iterate over ohv, copying keys and values one at a time. */
1369         HE *entry;
1370         const I32 riter = HvRITER_get(ohv);
1371         HE * const eiter = HvEITER_get(ohv);
1372         STRLEN hv_keys = HvTOTALKEYS(ohv);
1373
1374         HV_SET_MAX_ADJUSTED_FOR_KEYS(hv,hv_max,hv_keys);
1375
1376         hv_iterinit(ohv);
1377         while ((entry = hv_iternext_flags(ohv, 0))) {
1378             SV *val = hv_iterval(ohv,entry);
1379             SV * const keysv = HeSVKEY(entry);
1380             val = SvIMMORTAL(val) ? val : newSVsv(val);
1381             if (keysv)
1382                 (void)hv_store_ent(hv, keysv, val, 0);
1383             else
1384                 (void)hv_store_flags(hv, HeKEY(entry), HeKLEN(entry), val,
1385                                  HeHASH(entry), HeKFLAGS(entry));
1386         }
1387         HvRITER_set(ohv, riter);
1388         HvEITER_set(ohv, eiter);
1389     }
1390
1391     return hv;
1392 }
1393
1394 /*
1395 =for apidoc Am|HV *|hv_copy_hints_hv|HV *ohv
1396
1397 A specialised version of L</newHVhv> for copying C<%^H>.  I<ohv> must be
1398 a pointer to a hash (which may have C<%^H> magic, but should be generally
1399 non-magical), or C<NULL> (interpreted as an empty hash).  The content
1400 of I<ohv> is copied to a new hash, which has the C<%^H>-specific magic
1401 added to it.  A pointer to the new hash is returned.
1402
1403 =cut
1404 */
1405
1406 HV *
1407 Perl_hv_copy_hints_hv(pTHX_ HV *const ohv)
1408 {
1409     HV * const hv = newHV();
1410
1411     if (ohv) {
1412         STRLEN hv_max = HvMAX(ohv);
1413         STRLEN hv_keys = HvTOTALKEYS(ohv);
1414         HE *entry;
1415         const I32 riter = HvRITER_get(ohv);
1416         HE * const eiter = HvEITER_get(ohv);
1417
1418         ENTER;
1419         SAVEFREESV(hv);
1420
1421         HV_SET_MAX_ADJUSTED_FOR_KEYS(hv,hv_max,hv_keys);
1422
1423         hv_iterinit(ohv);
1424         while ((entry = hv_iternext_flags(ohv, 0))) {
1425             SV *const sv = newSVsv(hv_iterval(ohv,entry));
1426             SV *heksv = HeSVKEY(entry);
1427             if (!heksv && sv) heksv = newSVhek(HeKEY_hek(entry));
1428             if (sv) sv_magic(sv, NULL, PERL_MAGIC_hintselem,
1429                      (char *)heksv, HEf_SVKEY);
1430             if (heksv == HeSVKEY(entry))
1431                 (void)hv_store_ent(hv, heksv, sv, 0);
1432             else {
1433                 (void)hv_common(hv, heksv, HeKEY(entry), HeKLEN(entry),
1434                                  HeKFLAGS(entry), HV_FETCH_ISSTORE|HV_FETCH_JUST_SV, sv, HeHASH(entry));
1435                 SvREFCNT_dec_NN(heksv);
1436             }
1437         }
1438         HvRITER_set(ohv, riter);
1439         HvEITER_set(ohv, eiter);
1440
1441         SvREFCNT_inc_simple_void_NN(hv);
1442         LEAVE;
1443     }
1444     hv_magic(hv, NULL, PERL_MAGIC_hints);
1445     return hv;
1446 }
1447 #undef HV_SET_MAX_ADJUSTED_FOR_KEYS
1448
1449 /* like hv_free_ent, but returns the SV rather than freeing it */
1450 STATIC SV*
1451 S_hv_free_ent_ret(pTHX_ HV *hv, HE *entry)
1452 {
1453     dVAR;
1454     SV *val;
1455
1456     PERL_ARGS_ASSERT_HV_FREE_ENT_RET;
1457
1458     val = HeVAL(entry);
1459     if (HeKLEN(entry) == HEf_SVKEY) {
1460         SvREFCNT_dec(HeKEY_sv(entry));
1461         Safefree(HeKEY_hek(entry));
1462     }
1463     else if (HvSHAREKEYS(hv))
1464         unshare_hek(HeKEY_hek(entry));
1465     else
1466         Safefree(HeKEY_hek(entry));
1467     del_HE(entry);
1468     return val;
1469 }
1470
1471
1472 void
1473 Perl_hv_free_ent(pTHX_ HV *hv, HE *entry)
1474 {
1475     dVAR;
1476     SV *val;
1477
1478     PERL_ARGS_ASSERT_HV_FREE_ENT;
1479
1480     if (!entry)
1481         return;
1482     val = hv_free_ent_ret(hv, entry);
1483     SvREFCNT_dec(val);
1484 }
1485
1486
1487 void
1488 Perl_hv_delayfree_ent(pTHX_ HV *hv, HE *entry)
1489 {
1490     dVAR;
1491
1492     PERL_ARGS_ASSERT_HV_DELAYFREE_ENT;
1493
1494     if (!entry)
1495         return;
1496     /* SvREFCNT_inc to counter the SvREFCNT_dec in hv_free_ent  */
1497     sv_2mortal(SvREFCNT_inc(HeVAL(entry)));     /* free between statements */
1498     if (HeKLEN(entry) == HEf_SVKEY) {
1499         sv_2mortal(SvREFCNT_inc(HeKEY_sv(entry)));
1500     }
1501     hv_free_ent(hv, entry);
1502 }
1503
1504 /*
1505 =for apidoc hv_clear
1506
1507 Frees the all the elements of a hash, leaving it empty.
1508 The XS equivalent of C<%hash = ()>.  See also L</hv_undef>.
1509
1510 If any destructors are triggered as a result, the hv itself may
1511 be freed.
1512
1513 =cut
1514 */
1515
1516 void
1517 Perl_hv_clear(pTHX_ HV *hv)
1518 {
1519     dVAR;
1520     XPVHV* xhv;
1521     if (!hv)
1522         return;
1523
1524     DEBUG_A(Perl_hv_assert(aTHX_ hv));
1525
1526     xhv = (XPVHV*)SvANY(hv);
1527
1528     ENTER;
1529     SAVEFREESV(SvREFCNT_inc_simple_NN(hv));
1530     if (SvREADONLY(hv) && HvARRAY(hv) != NULL) {
1531         /* restricted hash: convert all keys to placeholders */
1532         STRLEN i;
1533         for (i = 0; i <= xhv->xhv_max; i++) {
1534             HE *entry = (HvARRAY(hv))[i];
1535             for (; entry; entry = HeNEXT(entry)) {
1536                 /* not already placeholder */
1537                 if (HeVAL(entry) != &PL_sv_placeholder) {
1538                     if (HeVAL(entry)) {
1539                         if (SvREADONLY(HeVAL(entry))) {
1540                             SV* const keysv = hv_iterkeysv(entry);
1541                             Perl_croak_nocontext(
1542                                 "Attempt to delete readonly key '%"SVf"' from a restricted hash",
1543                                 (void*)keysv);
1544                         }
1545                         SvREFCNT_dec_NN(HeVAL(entry));
1546                     }
1547                     HeVAL(entry) = &PL_sv_placeholder;
1548                     HvPLACEHOLDERS(hv)++;
1549                 }
1550             }
1551         }
1552     }
1553     else {
1554         hfreeentries(hv);
1555         HvPLACEHOLDERS_set(hv, 0);
1556
1557         if (SvRMAGICAL(hv))
1558             mg_clear(MUTABLE_SV(hv));
1559
1560         HvHASKFLAGS_off(hv);
1561     }
1562     if (SvOOK(hv)) {
1563         if(HvENAME_get(hv))
1564             mro_isa_changed_in(hv);
1565         HvEITER_set(hv, NULL);
1566     }
1567     LEAVE;
1568 }
1569
1570 /*
1571 =for apidoc hv_clear_placeholders
1572
1573 Clears any placeholders from a hash.  If a restricted hash has any of its keys
1574 marked as readonly and the key is subsequently deleted, the key is not actually
1575 deleted but is marked by assigning it a value of &PL_sv_placeholder.  This tags
1576 it so it will be ignored by future operations such as iterating over the hash,
1577 but will still allow the hash to have a value reassigned to the key at some
1578 future point.  This function clears any such placeholder keys from the hash.
1579 See Hash::Util::lock_keys() for an example of its use.
1580
1581 =cut
1582 */
1583
1584 void
1585 Perl_hv_clear_placeholders(pTHX_ HV *hv)
1586 {
1587     dVAR;
1588     const U32 items = (U32)HvPLACEHOLDERS_get(hv);
1589
1590     PERL_ARGS_ASSERT_HV_CLEAR_PLACEHOLDERS;
1591
1592     if (items)
1593         clear_placeholders(hv, items);
1594 }
1595
1596 static void
1597 S_clear_placeholders(pTHX_ HV *hv, U32 items)
1598 {
1599     dVAR;
1600     I32 i;
1601
1602     PERL_ARGS_ASSERT_CLEAR_PLACEHOLDERS;
1603
1604     if (items == 0)
1605         return;
1606
1607     i = HvMAX(hv);
1608     do {
1609         /* Loop down the linked list heads  */
1610         HE **oentry = &(HvARRAY(hv))[i];
1611         HE *entry;
1612
1613         while ((entry = *oentry)) {
1614             if (HeVAL(entry) == &PL_sv_placeholder) {
1615                 *oentry = HeNEXT(entry);
1616                 if (entry == HvEITER_get(hv))
1617                     HvLAZYDEL_on(hv);
1618                 else {
1619                     if (SvOOK(hv) && HvLAZYDEL(hv) &&
1620                         entry == HeNEXT(HvAUX(hv)->xhv_eiter))
1621                         HeNEXT(HvAUX(hv)->xhv_eiter) = HeNEXT(entry);
1622                     hv_free_ent(hv, entry);
1623                 }
1624
1625                 if (--items == 0) {
1626                     /* Finished.  */
1627                     HvTOTALKEYS(hv) -= (IV)HvPLACEHOLDERS_get(hv);
1628                     if (HvUSEDKEYS(hv) == 0)
1629                         HvHASKFLAGS_off(hv);
1630                     HvPLACEHOLDERS_set(hv, 0);
1631                     return;
1632                 }
1633             } else {
1634                 oentry = &HeNEXT(entry);
1635             }
1636         }
1637     } while (--i >= 0);
1638     /* You can't get here, hence assertion should always fail.  */
1639     assert (items == 0);
1640     assert (0);
1641 }
1642
1643 STATIC void
1644 S_hfreeentries(pTHX_ HV *hv)
1645 {
1646     STRLEN index = 0;
1647     XPVHV * const xhv = (XPVHV*)SvANY(hv);
1648     SV *sv;
1649
1650     PERL_ARGS_ASSERT_HFREEENTRIES;
1651
1652     while ((sv = Perl_hfree_next_entry(aTHX_ hv, &index))||xhv->xhv_keys) {
1653         SvREFCNT_dec(sv);
1654     }
1655 }
1656
1657
1658 /* hfree_next_entry()
1659  * For use only by S_hfreeentries() and sv_clear().
1660  * Delete the next available HE from hv and return the associated SV.
1661  * Returns null on empty hash. Nevertheless null is not a reliable
1662  * indicator that the hash is empty, as the deleted entry may have a
1663  * null value.
1664  * indexp is a pointer to the current index into HvARRAY. The index should
1665  * initially be set to 0. hfree_next_entry() may update it.  */
1666
1667 SV*
1668 Perl_hfree_next_entry(pTHX_ HV *hv, STRLEN *indexp)
1669 {
1670     struct xpvhv_aux *iter;
1671     HE *entry;
1672     HE ** array;
1673 #ifdef DEBUGGING
1674     STRLEN orig_index = *indexp;
1675 #endif
1676
1677     PERL_ARGS_ASSERT_HFREE_NEXT_ENTRY;
1678
1679     if (SvOOK(hv) && ((iter = HvAUX(hv)))) {
1680         if ((entry = iter->xhv_eiter)) {
1681             /* the iterator may get resurrected after each
1682              * destructor call, so check each time */
1683             if (entry && HvLAZYDEL(hv)) {       /* was deleted earlier? */
1684                 HvLAZYDEL_off(hv);
1685                 hv_free_ent(hv, entry);
1686                 /* warning: at this point HvARRAY may have been
1687                  * re-allocated, HvMAX changed etc */
1688             }
1689             iter->xhv_riter = -1;       /* HvRITER(hv) = -1 */
1690             iter->xhv_eiter = NULL;     /* HvEITER(hv) = NULL */
1691 #ifdef PERL_HASH_RANDOMIZE_KEYS
1692             iter->xhv_last_rand = iter->xhv_rand;
1693 #endif
1694         }
1695         /* Reset any cached HvFILL() to "unknown".  It's unlikely that anyone
1696            will actually call HvFILL() on a hash under destruction, so it
1697            seems pointless attempting to track the number of keys remaining.
1698            But if they do, we want to reset it again.  */
1699         if (iter->xhv_fill_lazy)
1700             iter->xhv_fill_lazy = 0;
1701     }
1702
1703     if (!((XPVHV*)SvANY(hv))->xhv_keys)
1704         return NULL;
1705
1706     array = HvARRAY(hv);
1707     assert(array);
1708     while ( ! ((entry = array[*indexp])) ) {
1709         if ((*indexp)++ >= HvMAX(hv))
1710             *indexp = 0;
1711         assert(*indexp != orig_index);
1712     }
1713     array[*indexp] = HeNEXT(entry);
1714     ((XPVHV*) SvANY(hv))->xhv_keys--;
1715
1716     if (   PL_phase != PERL_PHASE_DESTRUCT && HvENAME(hv)
1717         && HeVAL(entry) && isGV(HeVAL(entry))
1718         && GvHV(HeVAL(entry)) && HvENAME(GvHV(HeVAL(entry)))
1719     ) {
1720         STRLEN klen;
1721         const char * const key = HePV(entry,klen);
1722         if ((klen > 1 && key[klen-1]==':' && key[klen-2]==':')
1723          || (klen == 1 && key[0] == ':')) {
1724             mro_package_moved(
1725              NULL, GvHV(HeVAL(entry)),
1726              (GV *)HeVAL(entry), 0
1727             );
1728         }
1729     }
1730     return hv_free_ent_ret(hv, entry);
1731 }
1732
1733
1734 /*
1735 =for apidoc hv_undef
1736
1737 Undefines the hash.  The XS equivalent of C<undef(%hash)>.
1738
1739 As well as freeing all the elements of the hash (like hv_clear()), this
1740 also frees any auxiliary data and storage associated with the hash.
1741
1742 If any destructors are triggered as a result, the hv itself may
1743 be freed.
1744
1745 See also L</hv_clear>.
1746
1747 =cut
1748 */
1749
1750 void
1751 Perl_hv_undef_flags(pTHX_ HV *hv, U32 flags)
1752 {
1753     dVAR;
1754     XPVHV* xhv;
1755     const char *name;
1756     const bool save = !!SvREFCNT(hv);
1757
1758     if (!hv)
1759         return;
1760     DEBUG_A(Perl_hv_assert(aTHX_ hv));
1761     xhv = (XPVHV*)SvANY(hv);
1762
1763     /* The name must be deleted before the call to hfreeeeentries so that
1764        CVs are anonymised properly. But the effective name must be pre-
1765        served until after that call (and only deleted afterwards if the
1766        call originated from sv_clear). For stashes with one name that is
1767        both the canonical name and the effective name, hv_name_set has to
1768        allocate an array for storing the effective name. We can skip that
1769        during global destruction, as it does not matter where the CVs point
1770        if they will be freed anyway. */
1771     /* note that the code following prior to hfreeentries is duplicated
1772      * in sv_clear(), and changes here should be done there too */
1773     if (PL_phase != PERL_PHASE_DESTRUCT && (name = HvNAME(hv))) {
1774         if (PL_stashcache) {
1775             DEBUG_o(Perl_deb(aTHX_ "hv_undef_flags clearing PL_stashcache for '%"
1776                              HEKf"'\n", HvNAME_HEK(hv)));
1777             (void)hv_delete(PL_stashcache, name,
1778                             HEK_UTF8(HvNAME_HEK(hv)) ? -HvNAMELEN_get(hv) : HvNAMELEN_get(hv),
1779                             G_DISCARD
1780                            );
1781         }
1782         hv_name_set(hv, NULL, 0, 0);
1783     }
1784     if (save) {
1785         ENTER;
1786         SAVEFREESV(SvREFCNT_inc_simple_NN(hv));
1787     }
1788     hfreeentries(hv);
1789     if (SvOOK(hv)) {
1790       struct xpvhv_aux * const aux = HvAUX(hv);
1791       struct mro_meta *meta;
1792
1793       if ((name = HvENAME_get(hv))) {
1794         if (PL_phase != PERL_PHASE_DESTRUCT)
1795             mro_isa_changed_in(hv);
1796         if (PL_stashcache) {
1797             DEBUG_o(Perl_deb(aTHX_ "hv_undef_flags clearing PL_stashcache for effective name '%"
1798                              HEKf"'\n", HvENAME_HEK(hv)));
1799             (void)hv_delete(
1800                     PL_stashcache, name,
1801                     HEK_UTF8(HvENAME_HEK(hv)) ? -HvENAMELEN_get(hv) : HvENAMELEN_get(hv),
1802                     G_DISCARD
1803                   );
1804         }
1805       }
1806
1807       /* If this call originated from sv_clear, then we must check for
1808        * effective names that need freeing, as well as the usual name. */
1809       name = HvNAME(hv);
1810       if (flags & HV_NAME_SETALL ? !!aux->xhv_name_u.xhvnameu_name : !!name) {
1811         if (name && PL_stashcache) {
1812             DEBUG_o(Perl_deb(aTHX_ "hv_undef_flags clearing PL_stashcache for name '%"
1813                              HEKf"'\n", HvNAME_HEK(hv)));
1814             (void)hv_delete(PL_stashcache, name, (HEK_UTF8(HvNAME_HEK(hv)) ? -HvNAMELEN_get(hv) : HvNAMELEN_get(hv)), G_DISCARD);
1815         }
1816         hv_name_set(hv, NULL, 0, flags);
1817       }
1818       if((meta = aux->xhv_mro_meta)) {
1819         if (meta->mro_linear_all) {
1820             SvREFCNT_dec_NN(meta->mro_linear_all);
1821             /* mro_linear_current is just acting as a shortcut pointer,
1822                hence the else.  */
1823         }
1824         else
1825             /* Only the current MRO is stored, so this owns the data.
1826              */
1827             SvREFCNT_dec(meta->mro_linear_current);
1828         SvREFCNT_dec(meta->mro_nextmethod);
1829         SvREFCNT_dec(meta->isa);
1830         SvREFCNT_dec(meta->super);
1831         Safefree(meta);
1832         aux->xhv_mro_meta = NULL;
1833       }
1834       if (!aux->xhv_name_u.xhvnameu_name && ! aux->xhv_backreferences)
1835         SvFLAGS(hv) &= ~SVf_OOK;
1836     }
1837     if (!SvOOK(hv)) {
1838         Safefree(HvARRAY(hv));
1839         xhv->xhv_max = PERL_HASH_DEFAULT_HvMAX;        /* HvMAX(hv) = 7 (it's a normal hash) */
1840         HvARRAY(hv) = 0;
1841     }
1842     /* if we're freeing the HV, the SvMAGIC field has been reused for
1843      * other purposes, and so there can't be any placeholder magic */
1844     if (SvREFCNT(hv))
1845         HvPLACEHOLDERS_set(hv, 0);
1846
1847     if (SvRMAGICAL(hv))
1848         mg_clear(MUTABLE_SV(hv));
1849     if (save) LEAVE;
1850 }
1851
1852 /*
1853 =for apidoc hv_fill
1854
1855 Returns the number of hash buckets that happen to be in use. This function is
1856 wrapped by the macro C<HvFILL>.
1857
1858 Previously this value was always stored in the HV structure, which created an
1859 overhead on every hash (and pretty much every object) for something that was
1860 rarely used. Now we calculate it on demand the first time that it is needed,
1861 and cache it if that calculation is going to be costly to repeat. The cached
1862 value is updated by insertions and deletions, but (currently) discarded if
1863 the hash is split.
1864
1865 =cut
1866 */
1867
1868 STRLEN
1869 Perl_hv_fill(pTHX_ HV *const hv)
1870 {
1871     STRLEN count = 0;
1872     HE **ents = HvARRAY(hv);
1873     struct xpvhv_aux *aux = SvOOK(hv) ? HvAUX(hv) : NULL;
1874
1875     PERL_ARGS_ASSERT_HV_FILL;
1876
1877     /* No keys implies no buckets used.
1878        One key can only possibly mean one bucket used.  */
1879     if (HvTOTALKEYS(hv) < 2)
1880         return HvTOTALKEYS(hv);
1881
1882 #ifndef DEBUGGING
1883     if (aux && aux->xhv_fill_lazy)
1884         return aux->xhv_fill_lazy;
1885 #endif
1886
1887     if (ents) {
1888         HE *const *const last = ents + HvMAX(hv);
1889         count = last + 1 - ents;
1890
1891         do {
1892             if (!*ents)
1893                 --count;
1894         } while (++ents <= last);
1895     }
1896     if (aux) {
1897 #ifdef DEBUGGING
1898         if (aux->xhv_fill_lazy)
1899             assert(aux->xhv_fill_lazy == count);
1900 #endif
1901         aux->xhv_fill_lazy = count;
1902     } else if (HvMAX(hv) >= HV_FILL_THRESHOLD) {
1903         aux = hv_auxinit(hv);
1904         aux->xhv_fill_lazy = count;
1905     }
1906     return count;
1907 }
1908
1909 /* hash a pointer to a U32 - Used in the hash traversal randomization
1910  * and bucket order randomization code
1911  *
1912  * this code was derived from Sereal, which was derived from autobox.
1913  */
1914
1915 PERL_STATIC_INLINE U32 S_ptr_hash(PTRV u) {
1916 #if PTRSIZE == 8
1917     /*
1918      * This is one of Thomas Wang's hash functions for 64-bit integers from:
1919      * http://www.concentric.net/~Ttwang/tech/inthash.htm
1920      */
1921     u = (~u) + (u << 18);
1922     u = u ^ (u >> 31);
1923     u = u * 21;
1924     u = u ^ (u >> 11);
1925     u = u + (u << 6);
1926     u = u ^ (u >> 22);
1927 #else
1928     /*
1929      * This is one of Bob Jenkins' hash functions for 32-bit integers
1930      * from: http://burtleburtle.net/bob/hash/integer.html
1931      */
1932     u = (u + 0x7ed55d16) + (u << 12);
1933     u = (u ^ 0xc761c23c) ^ (u >> 19);
1934     u = (u + 0x165667b1) + (u << 5);
1935     u = (u + 0xd3a2646c) ^ (u << 9);
1936     u = (u + 0xfd7046c5) + (u << 3);
1937     u = (u ^ 0xb55a4f09) ^ (u >> 16);
1938 #endif
1939     return (U32)u;
1940 }
1941
1942
1943 static struct xpvhv_aux*
1944 S_hv_auxinit(pTHX_ HV *hv) {
1945     struct xpvhv_aux *iter;
1946     char *array;
1947
1948     PERL_ARGS_ASSERT_HV_AUXINIT;
1949
1950     if (!SvOOK(hv)) {
1951         if (!HvARRAY(hv)) {
1952             Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(HvMAX(hv) + 1)
1953                 + sizeof(struct xpvhv_aux), char);
1954         } else {
1955             array = (char *) HvARRAY(hv);
1956             Renew(array, PERL_HV_ARRAY_ALLOC_BYTES(HvMAX(hv) + 1)
1957                   + sizeof(struct xpvhv_aux), char);
1958         }
1959         HvARRAY(hv) = (HE**)array;
1960         SvOOK_on(hv);
1961         iter = HvAUX(hv);
1962 #ifdef PERL_HASH_RANDOMIZE_KEYS
1963         if (PL_HASH_RAND_BITS_ENABLED) {
1964             /* mix in some new state to PL_hash_rand_bits to "randomize" the traversal order*/
1965             if (PL_HASH_RAND_BITS_ENABLED == 1)
1966                 PL_hash_rand_bits += ptr_hash((PTRV)array);
1967             PL_hash_rand_bits = ROTL_UV(PL_hash_rand_bits,1);
1968         }
1969         iter->xhv_rand = (U32)PL_hash_rand_bits;
1970 #endif
1971     } else {
1972         iter = HvAUX(hv);
1973     }
1974
1975     iter->xhv_riter = -1;       /* HvRITER(hv) = -1 */
1976     iter->xhv_eiter = NULL;     /* HvEITER(hv) = NULL */
1977 #ifdef PERL_HASH_RANDOMIZE_KEYS
1978     iter->xhv_last_rand = iter->xhv_rand;
1979 #endif
1980     iter->xhv_fill_lazy = 0;
1981     iter->xhv_name_u.xhvnameu_name = 0;
1982     iter->xhv_name_count = 0;
1983     iter->xhv_backreferences = 0;
1984     iter->xhv_mro_meta = NULL;
1985     return iter;
1986 }
1987
1988 /*
1989 =for apidoc hv_iterinit
1990
1991 Prepares a starting point to traverse a hash table.  Returns the number of
1992 keys in the hash (i.e. the same as C<HvUSEDKEYS(hv)>).  The return value is
1993 currently only meaningful for hashes without tie magic.
1994
1995 NOTE: Before version 5.004_65, C<hv_iterinit> used to return the number of
1996 hash buckets that happen to be in use.  If you still need that esoteric
1997 value, you can get it through the macro C<HvFILL(hv)>.
1998
1999
2000 =cut
2001 */
2002
2003 I32
2004 Perl_hv_iterinit(pTHX_ HV *hv)
2005 {
2006     PERL_ARGS_ASSERT_HV_ITERINIT;
2007
2008     /* FIXME: Are we not NULL, or do we croak? Place bets now! */
2009
2010     if (!hv)
2011         Perl_croak(aTHX_ "Bad hash");
2012
2013     if (SvOOK(hv)) {
2014         struct xpvhv_aux * const iter = HvAUX(hv);
2015         HE * const entry = iter->xhv_eiter; /* HvEITER(hv) */
2016         if (entry && HvLAZYDEL(hv)) {   /* was deleted earlier? */
2017             HvLAZYDEL_off(hv);
2018             hv_free_ent(hv, entry);
2019         }
2020         iter->xhv_riter = -1;   /* HvRITER(hv) = -1 */
2021         iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
2022 #ifdef PERL_HASH_RANDOMIZE_KEYS
2023         iter->xhv_last_rand = iter->xhv_rand;
2024 #endif
2025     } else {
2026         hv_auxinit(hv);
2027     }
2028
2029     /* used to be xhv->xhv_fill before 5.004_65 */
2030     return HvTOTALKEYS(hv);
2031 }
2032
2033 I32 *
2034 Perl_hv_riter_p(pTHX_ HV *hv) {
2035     struct xpvhv_aux *iter;
2036
2037     PERL_ARGS_ASSERT_HV_RITER_P;
2038
2039     if (!hv)
2040         Perl_croak(aTHX_ "Bad hash");
2041
2042     iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
2043     return &(iter->xhv_riter);
2044 }
2045
2046 HE **
2047 Perl_hv_eiter_p(pTHX_ HV *hv) {
2048     struct xpvhv_aux *iter;
2049
2050     PERL_ARGS_ASSERT_HV_EITER_P;
2051
2052     if (!hv)
2053         Perl_croak(aTHX_ "Bad hash");
2054
2055     iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
2056     return &(iter->xhv_eiter);
2057 }
2058
2059 void
2060 Perl_hv_riter_set(pTHX_ HV *hv, I32 riter) {
2061     struct xpvhv_aux *iter;
2062
2063     PERL_ARGS_ASSERT_HV_RITER_SET;
2064
2065     if (!hv)
2066         Perl_croak(aTHX_ "Bad hash");
2067
2068     if (SvOOK(hv)) {
2069         iter = HvAUX(hv);
2070     } else {
2071         if (riter == -1)
2072             return;
2073
2074         iter = hv_auxinit(hv);
2075     }
2076     iter->xhv_riter = riter;
2077 }
2078
2079 void
2080 Perl_hv_rand_set(pTHX_ HV *hv, U32 new_xhv_rand) {
2081     struct xpvhv_aux *iter;
2082
2083     PERL_ARGS_ASSERT_HV_RAND_SET;
2084
2085 #ifdef PERL_HASH_RANDOMIZE_KEYS
2086     if (!hv)
2087         Perl_croak(aTHX_ "Bad hash");
2088
2089     if (SvOOK(hv)) {
2090         iter = HvAUX(hv);
2091     } else {
2092         iter = hv_auxinit(hv);
2093     }
2094     iter->xhv_rand = new_xhv_rand;
2095 #else
2096     Perl_croak(aTHX_ "This Perl has not been built with support for randomized hash key traversal but something called Perl_hv_rand_set().");
2097 #endif
2098 }
2099
2100 void
2101 Perl_hv_eiter_set(pTHX_ HV *hv, HE *eiter) {
2102     struct xpvhv_aux *iter;
2103
2104     PERL_ARGS_ASSERT_HV_EITER_SET;
2105
2106     if (!hv)
2107         Perl_croak(aTHX_ "Bad hash");
2108
2109     if (SvOOK(hv)) {
2110         iter = HvAUX(hv);
2111     } else {
2112         /* 0 is the default so don't go malloc()ing a new structure just to
2113            hold 0.  */
2114         if (!eiter)
2115             return;
2116
2117         iter = hv_auxinit(hv);
2118     }
2119     iter->xhv_eiter = eiter;
2120 }
2121
2122 void
2123 Perl_hv_name_set(pTHX_ HV *hv, const char *name, U32 len, U32 flags)
2124 {
2125     dVAR;
2126     struct xpvhv_aux *iter;
2127     U32 hash;
2128     HEK **spot;
2129
2130     PERL_ARGS_ASSERT_HV_NAME_SET;
2131
2132     if (len > I32_MAX)
2133         Perl_croak(aTHX_ "panic: hv name too long (%"UVuf")", (UV) len);
2134
2135     if (SvOOK(hv)) {
2136         iter = HvAUX(hv);
2137         if (iter->xhv_name_u.xhvnameu_name) {
2138             if(iter->xhv_name_count) {
2139               if(flags & HV_NAME_SETALL) {
2140                 HEK ** const name = HvAUX(hv)->xhv_name_u.xhvnameu_names;
2141                 HEK **hekp = name + (
2142                     iter->xhv_name_count < 0
2143                      ? -iter->xhv_name_count
2144                      :  iter->xhv_name_count
2145                    );
2146                 while(hekp-- > name+1)
2147                     unshare_hek_or_pvn(*hekp, 0, 0, 0);
2148                 /* The first elem may be null. */
2149                 if(*name) unshare_hek_or_pvn(*name, 0, 0, 0);
2150                 Safefree(name);
2151                 spot = &iter->xhv_name_u.xhvnameu_name;
2152                 iter->xhv_name_count = 0;
2153               }
2154               else {
2155                 if(iter->xhv_name_count > 0) {
2156                     /* shift some things over */
2157                     Renew(
2158                      iter->xhv_name_u.xhvnameu_names, iter->xhv_name_count + 1, HEK *
2159                     );
2160                     spot = iter->xhv_name_u.xhvnameu_names;
2161                     spot[iter->xhv_name_count] = spot[1];
2162                     spot[1] = spot[0];
2163                     iter->xhv_name_count = -(iter->xhv_name_count + 1);
2164                 }
2165                 else if(*(spot = iter->xhv_name_u.xhvnameu_names)) {
2166                     unshare_hek_or_pvn(*spot, 0, 0, 0);
2167                 }
2168               }
2169             }
2170             else if (flags & HV_NAME_SETALL) {
2171                 unshare_hek_or_pvn(iter->xhv_name_u.xhvnameu_name, 0, 0, 0);
2172                 spot = &iter->xhv_name_u.xhvnameu_name;
2173             }
2174             else {
2175                 HEK * const existing_name = iter->xhv_name_u.xhvnameu_name;
2176                 Newx(iter->xhv_name_u.xhvnameu_names, 2, HEK *);
2177                 iter->xhv_name_count = -2;
2178                 spot = iter->xhv_name_u.xhvnameu_names;
2179                 spot[1] = existing_name;
2180             }
2181         }
2182         else { spot = &iter->xhv_name_u.xhvnameu_name; iter->xhv_name_count = 0; }
2183     } else {
2184         if (name == 0)
2185             return;
2186
2187         iter = hv_auxinit(hv);
2188         spot = &iter->xhv_name_u.xhvnameu_name;
2189     }
2190     PERL_HASH(hash, name, len);
2191     *spot = name ? share_hek(name, flags & SVf_UTF8 ? -(I32)len : (I32)len, hash) : NULL;
2192 }
2193
2194 /*
2195 This is basically sv_eq_flags() in sv.c, but we avoid the magic
2196 and bytes checking.
2197 */
2198
2199 STATIC I32
2200 hek_eq_pvn_flags(pTHX_ const HEK *hek, const char* pv, const I32 pvlen, const U32 flags) {
2201     if ( (HEK_UTF8(hek) ? 1 : 0) != (flags & SVf_UTF8 ? 1 : 0) ) {
2202         if (flags & SVf_UTF8)
2203             return (bytes_cmp_utf8(
2204                         (const U8*)HEK_KEY(hek), HEK_LEN(hek),
2205                         (const U8*)pv, pvlen) == 0);
2206         else
2207             return (bytes_cmp_utf8(
2208                         (const U8*)pv, pvlen,
2209                         (const U8*)HEK_KEY(hek), HEK_LEN(hek)) == 0);
2210     }
2211     else
2212         return HEK_LEN(hek) == pvlen && ((HEK_KEY(hek) == pv)
2213                     || memEQ(HEK_KEY(hek), pv, pvlen));
2214 }
2215
2216 /*
2217 =for apidoc hv_ename_add
2218
2219 Adds a name to a stash's internal list of effective names.  See
2220 C<hv_ename_delete>.
2221
2222 This is called when a stash is assigned to a new location in the symbol
2223 table.
2224
2225 =cut
2226 */
2227
2228 void
2229 Perl_hv_ename_add(pTHX_ HV *hv, const char *name, U32 len, U32 flags)
2230 {
2231     dVAR;
2232     struct xpvhv_aux *aux = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
2233     U32 hash;
2234
2235     PERL_ARGS_ASSERT_HV_ENAME_ADD;
2236
2237     if (len > I32_MAX)
2238         Perl_croak(aTHX_ "panic: hv name too long (%"UVuf")", (UV) len);
2239
2240     PERL_HASH(hash, name, len);
2241
2242     if (aux->xhv_name_count) {
2243         HEK ** const xhv_name = aux->xhv_name_u.xhvnameu_names;
2244         I32 count = aux->xhv_name_count;
2245         HEK **hekp = xhv_name + (count < 0 ? -count : count);
2246         while (hekp-- > xhv_name)
2247             if (
2248                  (HEK_UTF8(*hekp) || (flags & SVf_UTF8))
2249                     ? hek_eq_pvn_flags(aTHX_ *hekp, name, (I32)len, flags)
2250                     : (HEK_LEN(*hekp) == (I32)len && memEQ(HEK_KEY(*hekp), name, len))
2251                ) {
2252                 if (hekp == xhv_name && count < 0)
2253                     aux->xhv_name_count = -count;
2254                 return;
2255             }
2256         if (count < 0) aux->xhv_name_count--, count = -count;
2257         else aux->xhv_name_count++;
2258         Renew(aux->xhv_name_u.xhvnameu_names, count + 1, HEK *);
2259         (aux->xhv_name_u.xhvnameu_names)[count] = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash);
2260     }
2261     else {
2262         HEK *existing_name = aux->xhv_name_u.xhvnameu_name;
2263         if (
2264             existing_name && (
2265              (HEK_UTF8(existing_name) || (flags & SVf_UTF8))
2266                 ? hek_eq_pvn_flags(aTHX_ existing_name, name, (I32)len, flags)
2267                 : (HEK_LEN(existing_name) == (I32)len && memEQ(HEK_KEY(existing_name), name, len))
2268             )
2269         ) return;
2270         Newx(aux->xhv_name_u.xhvnameu_names, 2, HEK *);
2271         aux->xhv_name_count = existing_name ? 2 : -2;
2272         *aux->xhv_name_u.xhvnameu_names = existing_name;
2273         (aux->xhv_name_u.xhvnameu_names)[1] = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash);
2274     }
2275 }
2276
2277 /*
2278 =for apidoc hv_ename_delete
2279
2280 Removes a name from a stash's internal list of effective names.  If this is
2281 the name returned by C<HvENAME>, then another name in the list will take
2282 its place (C<HvENAME> will use it).
2283
2284 This is called when a stash is deleted from the symbol table.
2285
2286 =cut
2287 */
2288
2289 void
2290 Perl_hv_ename_delete(pTHX_ HV *hv, const char *name, U32 len, U32 flags)
2291 {
2292     dVAR;
2293     struct xpvhv_aux *aux;
2294
2295     PERL_ARGS_ASSERT_HV_ENAME_DELETE;
2296
2297     if (len > I32_MAX)
2298         Perl_croak(aTHX_ "panic: hv name too long (%"UVuf")", (UV) len);
2299
2300     if (!SvOOK(hv)) return;
2301
2302     aux = HvAUX(hv);
2303     if (!aux->xhv_name_u.xhvnameu_name) return;
2304
2305     if (aux->xhv_name_count) {
2306         HEK ** const namep = aux->xhv_name_u.xhvnameu_names;
2307         I32 const count = aux->xhv_name_count;
2308         HEK **victim = namep + (count < 0 ? -count : count);
2309         while (victim-- > namep + 1)
2310             if (
2311              (HEK_UTF8(*victim) || (flags & SVf_UTF8))
2312                 ? hek_eq_pvn_flags(aTHX_ *victim, name, (I32)len, flags)
2313                 : (HEK_LEN(*victim) == (I32)len && memEQ(HEK_KEY(*victim), name, len))
2314             ) {
2315                 unshare_hek_or_pvn(*victim, 0, 0, 0);
2316                 if (count < 0) ++aux->xhv_name_count;
2317                 else --aux->xhv_name_count;
2318                 if (
2319                     (aux->xhv_name_count == 1 || aux->xhv_name_count == -1)
2320                  && !*namep
2321                 ) {  /* if there are none left */
2322                     Safefree(namep);
2323                     aux->xhv_name_u.xhvnameu_names = NULL;
2324                     aux->xhv_name_count = 0;
2325                 }
2326                 else {
2327                     /* Move the last one back to fill the empty slot. It
2328                        does not matter what order they are in. */
2329                     *victim = *(namep + (count < 0 ? -count : count) - 1);
2330                 }
2331                 return;
2332             }
2333         if (
2334             count > 0 && (HEK_UTF8(*namep) || (flags & SVf_UTF8))
2335                 ? hek_eq_pvn_flags(aTHX_ *namep, name, (I32)len, flags)
2336                 : (HEK_LEN(*namep) == (I32)len && memEQ(HEK_KEY(*namep), name, len))
2337         ) {
2338             aux->xhv_name_count = -count;
2339         }
2340     }
2341     else if(
2342         (HEK_UTF8(aux->xhv_name_u.xhvnameu_name) || (flags & SVf_UTF8))
2343                 ? hek_eq_pvn_flags(aTHX_ aux->xhv_name_u.xhvnameu_name, name, (I32)len, flags)
2344                 : (HEK_LEN(aux->xhv_name_u.xhvnameu_name) == (I32)len &&
2345                             memEQ(HEK_KEY(aux->xhv_name_u.xhvnameu_name), name, len))
2346     ) {
2347         HEK * const namehek = aux->xhv_name_u.xhvnameu_name;
2348         Newx(aux->xhv_name_u.xhvnameu_names, 1, HEK *);
2349         *aux->xhv_name_u.xhvnameu_names = namehek;
2350         aux->xhv_name_count = -1;
2351     }
2352 }
2353
2354 AV **
2355 Perl_hv_backreferences_p(pTHX_ HV *hv) {
2356     struct xpvhv_aux * const iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
2357
2358     PERL_ARGS_ASSERT_HV_BACKREFERENCES_P;
2359     PERL_UNUSED_CONTEXT;
2360
2361     return &(iter->xhv_backreferences);
2362 }
2363
2364 void
2365 Perl_hv_kill_backrefs(pTHX_ HV *hv) {
2366     AV *av;
2367
2368     PERL_ARGS_ASSERT_HV_KILL_BACKREFS;
2369
2370     if (!SvOOK(hv))
2371         return;
2372
2373     av = HvAUX(hv)->xhv_backreferences;
2374
2375     if (av) {
2376         HvAUX(hv)->xhv_backreferences = 0;
2377         Perl_sv_kill_backrefs(aTHX_ MUTABLE_SV(hv), av);
2378         if (SvTYPE(av) == SVt_PVAV)
2379             SvREFCNT_dec_NN(av);
2380     }
2381 }
2382
2383 /*
2384 hv_iternext is implemented as a macro in hv.h
2385
2386 =for apidoc hv_iternext
2387
2388 Returns entries from a hash iterator.  See C<hv_iterinit>.
2389
2390 You may call C<hv_delete> or C<hv_delete_ent> on the hash entry that the
2391 iterator currently points to, without losing your place or invalidating your
2392 iterator.  Note that in this case the current entry is deleted from the hash
2393 with your iterator holding the last reference to it.  Your iterator is flagged
2394 to free the entry on the next call to C<hv_iternext>, so you must not discard
2395 your iterator immediately else the entry will leak - call C<hv_iternext> to
2396 trigger the resource deallocation.
2397
2398 =for apidoc hv_iternext_flags
2399
2400 Returns entries from a hash iterator.  See C<hv_iterinit> and C<hv_iternext>.
2401 The C<flags> value will normally be zero; if HV_ITERNEXT_WANTPLACEHOLDERS is
2402 set the placeholders keys (for restricted hashes) will be returned in addition
2403 to normal keys. By default placeholders are automatically skipped over.
2404 Currently a placeholder is implemented with a value that is
2405 C<&PL_sv_placeholder>.  Note that the implementation of placeholders and
2406 restricted hashes may change, and the implementation currently is
2407 insufficiently abstracted for any change to be tidy.
2408
2409 =cut
2410 */
2411
2412 HE *
2413 Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags)
2414 {
2415     dVAR;
2416     XPVHV* xhv;
2417     HE *entry;
2418     HE *oldentry;
2419     MAGIC* mg;
2420     struct xpvhv_aux *iter;
2421
2422     PERL_ARGS_ASSERT_HV_ITERNEXT_FLAGS;
2423
2424     if (!hv)
2425         Perl_croak(aTHX_ "Bad hash");
2426
2427     xhv = (XPVHV*)SvANY(hv);
2428
2429     if (!SvOOK(hv)) {
2430         /* Too many things (well, pp_each at least) merrily assume that you can
2431            call hv_iternext without calling hv_iterinit, so we'll have to deal
2432            with it.  */
2433         hv_iterinit(hv);
2434     }
2435     iter = HvAUX(hv);
2436
2437     oldentry = entry = iter->xhv_eiter; /* HvEITER(hv) */
2438     if (SvMAGICAL(hv) && SvRMAGICAL(hv)) {
2439         if ( ( mg = mg_find((const SV *)hv, PERL_MAGIC_tied) ) ) {
2440             SV * const key = sv_newmortal();
2441             if (entry) {
2442                 sv_setsv(key, HeSVKEY_force(entry));
2443                 SvREFCNT_dec(HeSVKEY(entry));       /* get rid of previous key */
2444                 HeSVKEY_set(entry, NULL);
2445             }
2446             else {
2447                 char *k;
2448                 HEK *hek;
2449
2450                 /* one HE per MAGICAL hash */
2451                 iter->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */
2452                 HvLAZYDEL_on(hv); /* make sure entry gets freed */
2453                 Zero(entry, 1, HE);
2454                 Newxz(k, HEK_BASESIZE + sizeof(const SV *), char);
2455                 hek = (HEK*)k;
2456                 HeKEY_hek(entry) = hek;
2457                 HeKLEN(entry) = HEf_SVKEY;
2458             }
2459             magic_nextpack(MUTABLE_SV(hv),mg,key);
2460             if (SvOK(key)) {
2461                 /* force key to stay around until next time */
2462                 HeSVKEY_set(entry, SvREFCNT_inc_simple_NN(key));
2463                 return entry;               /* beware, hent_val is not set */
2464             }
2465             SvREFCNT_dec(HeVAL(entry));
2466             Safefree(HeKEY_hek(entry));
2467             del_HE(entry);
2468             iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
2469             HvLAZYDEL_off(hv);
2470             return NULL;
2471         }
2472     }
2473 #if defined(DYNAMIC_ENV_FETCH) && !defined(__riscos__)  /* set up %ENV for iteration */
2474     if (!entry && SvRMAGICAL((const SV *)hv)
2475         && mg_find((const SV *)hv, PERL_MAGIC_env)) {
2476         prime_env_iter();
2477 #ifdef VMS
2478         /* The prime_env_iter() on VMS just loaded up new hash values
2479          * so the iteration count needs to be reset back to the beginning
2480          */
2481         hv_iterinit(hv);
2482         iter = HvAUX(hv);
2483         oldentry = entry = iter->xhv_eiter; /* HvEITER(hv) */
2484 #endif
2485     }
2486 #endif
2487
2488     /* hv_iterinit now ensures this.  */
2489     assert (HvARRAY(hv));
2490
2491     /* At start of hash, entry is NULL.  */
2492     if (entry)
2493     {
2494         entry = HeNEXT(entry);
2495         if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
2496             /*
2497              * Skip past any placeholders -- don't want to include them in
2498              * any iteration.
2499              */
2500             while (entry && HeVAL(entry) == &PL_sv_placeholder) {
2501                 entry = HeNEXT(entry);
2502             }
2503         }
2504     }
2505
2506 #ifdef PERL_HASH_RANDOMIZE_KEYS
2507     if (iter->xhv_last_rand != iter->xhv_rand) {
2508         if (iter->xhv_riter != -1) {
2509             Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
2510                              "Use of each() on hash after insertion without resetting hash iterator results in undefined behavior"
2511                              pTHX__FORMAT
2512                              pTHX__VALUE);
2513         }
2514         iter->xhv_last_rand = iter->xhv_rand;
2515     }
2516 #endif
2517
2518     /* Skip the entire loop if the hash is empty.   */
2519     if ((flags & HV_ITERNEXT_WANTPLACEHOLDERS)
2520         ? HvTOTALKEYS(hv) : HvUSEDKEYS(hv)) {
2521         while (!entry) {
2522             /* OK. Come to the end of the current list.  Grab the next one.  */
2523
2524             iter->xhv_riter++; /* HvRITER(hv)++ */
2525             if (iter->xhv_riter > (I32)xhv->xhv_max /* HvRITER(hv) > HvMAX(hv) */) {
2526                 /* There is no next one.  End of the hash.  */
2527                 iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
2528 #ifdef PERL_HASH_RANDOMIZE_KEYS
2529                 iter->xhv_last_rand = iter->xhv_rand; /* reset xhv_last_rand so we can detect inserts during traversal */
2530 #endif
2531                 break;
2532             }
2533             entry = (HvARRAY(hv))[ PERL_HASH_ITER_BUCKET(iter) & xhv->xhv_max ];
2534
2535             if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
2536                 /* If we have an entry, but it's a placeholder, don't count it.
2537                    Try the next.  */
2538                 while (entry && HeVAL(entry) == &PL_sv_placeholder)
2539                     entry = HeNEXT(entry);
2540             }
2541             /* Will loop again if this linked list starts NULL
2542                (for HV_ITERNEXT_WANTPLACEHOLDERS)
2543                or if we run through it and find only placeholders.  */
2544         }
2545     }
2546     else {
2547         iter->xhv_riter = -1;
2548 #ifdef PERL_HASH_RANDOMIZE_KEYS
2549         iter->xhv_last_rand = iter->xhv_rand;
2550 #endif
2551     }
2552
2553     if (oldentry && HvLAZYDEL(hv)) {            /* was deleted earlier? */
2554         HvLAZYDEL_off(hv);
2555         hv_free_ent(hv, oldentry);
2556     }
2557
2558     iter->xhv_eiter = entry; /* HvEITER(hv) = entry */
2559     return entry;
2560 }
2561
2562 /*
2563 =for apidoc hv_iterkey
2564
2565 Returns the key from the current position of the hash iterator.  See
2566 C<hv_iterinit>.
2567
2568 =cut
2569 */
2570
2571 char *
2572 Perl_hv_iterkey(pTHX_ HE *entry, I32 *retlen)
2573 {
2574     PERL_ARGS_ASSERT_HV_ITERKEY;
2575
2576     if (HeKLEN(entry) == HEf_SVKEY) {
2577         STRLEN len;
2578         char * const p = SvPV(HeKEY_sv(entry), len);
2579         *retlen = len;
2580         return p;
2581     }
2582     else {
2583         *retlen = HeKLEN(entry);
2584         return HeKEY(entry);
2585     }
2586 }
2587
2588 /* unlike hv_iterval(), this always returns a mortal copy of the key */
2589 /*
2590 =for apidoc hv_iterkeysv
2591
2592 Returns the key as an C<SV*> from the current position of the hash
2593 iterator.  The return value will always be a mortal copy of the key.  Also
2594 see C<hv_iterinit>.
2595
2596 =cut
2597 */
2598
2599 SV *
2600 Perl_hv_iterkeysv(pTHX_ HE *entry)
2601 {
2602     PERL_ARGS_ASSERT_HV_ITERKEYSV;
2603
2604     return sv_2mortal(newSVhek(HeKEY_hek(entry)));
2605 }
2606
2607 /*
2608 =for apidoc hv_iterval
2609
2610 Returns the value from the current position of the hash iterator.  See
2611 C<hv_iterkey>.
2612
2613 =cut
2614 */
2615
2616 SV *
2617 Perl_hv_iterval(pTHX_ HV *hv, HE *entry)
2618 {
2619     PERL_ARGS_ASSERT_HV_ITERVAL;
2620
2621     if (SvRMAGICAL(hv)) {
2622         if (mg_find((const SV *)hv, PERL_MAGIC_tied)) {
2623             SV* const sv = sv_newmortal();
2624             if (HeKLEN(entry) == HEf_SVKEY)
2625                 mg_copy(MUTABLE_SV(hv), sv, (char*)HeKEY_sv(entry), HEf_SVKEY);
2626             else
2627                 mg_copy(MUTABLE_SV(hv), sv, HeKEY(entry), HeKLEN(entry));
2628             return sv;
2629         }
2630     }
2631     return HeVAL(entry);
2632 }
2633
2634 /*
2635 =for apidoc hv_iternextsv
2636
2637 Performs an C<hv_iternext>, C<hv_iterkey>, and C<hv_iterval> in one
2638 operation.
2639
2640 =cut
2641 */
2642
2643 SV *
2644 Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen)
2645 {
2646     HE * const he = hv_iternext_flags(hv, 0);
2647
2648     PERL_ARGS_ASSERT_HV_ITERNEXTSV;
2649
2650     if (!he)
2651         return NULL;
2652     *key = hv_iterkey(he, retlen);
2653     return hv_iterval(hv, he);
2654 }
2655
2656 /*
2657
2658 Now a macro in hv.h
2659
2660 =for apidoc hv_magic
2661
2662 Adds magic to a hash.  See C<sv_magic>.
2663
2664 =cut
2665 */
2666
2667 /* possibly free a shared string if no one has access to it
2668  * len and hash must both be valid for str.
2669  */
2670 void
2671 Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
2672 {
2673     unshare_hek_or_pvn (NULL, str, len, hash);
2674 }
2675
2676
2677 void
2678 Perl_unshare_hek(pTHX_ HEK *hek)
2679 {
2680     assert(hek);
2681     unshare_hek_or_pvn(hek, NULL, 0, 0);
2682 }
2683
2684 /* possibly free a shared string if no one has access to it
2685    hek if non-NULL takes priority over the other 3, else str, len and hash
2686    are used.  If so, len and hash must both be valid for str.
2687  */
2688 STATIC void
2689 S_unshare_hek_or_pvn(pTHX_ const HEK *hek, const char *str, I32 len, U32 hash)
2690 {
2691     dVAR;
2692     XPVHV* xhv;
2693     HE *entry;
2694     HE **oentry;
2695     bool is_utf8 = FALSE;
2696     int k_flags = 0;
2697     const char * const save = str;
2698     struct shared_he *he = NULL;
2699
2700     if (hek) {
2701         /* Find the shared he which is just before us in memory.  */
2702         he = (struct shared_he *)(((char *)hek)
2703                                   - STRUCT_OFFSET(struct shared_he,
2704                                                   shared_he_hek));
2705
2706         /* Assert that the caller passed us a genuine (or at least consistent)
2707            shared hek  */
2708         assert (he->shared_he_he.hent_hek == hek);
2709
2710         if (he->shared_he_he.he_valu.hent_refcount - 1) {
2711             --he->shared_he_he.he_valu.hent_refcount;
2712             return;
2713         }
2714
2715         hash = HEK_HASH(hek);
2716     } else if (len < 0) {
2717         STRLEN tmplen = -len;
2718         is_utf8 = TRUE;
2719         /* See the note in hv_fetch(). --jhi */
2720         str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2721         len = tmplen;
2722         if (is_utf8)
2723             k_flags = HVhek_UTF8;
2724         if (str != save)
2725             k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2726     }
2727
2728     /* what follows was the moral equivalent of:
2729     if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) {
2730         if (--*Svp == NULL)
2731             hv_delete(PL_strtab, str, len, G_DISCARD, hash);
2732     } */
2733     xhv = (XPVHV*)SvANY(PL_strtab);
2734     /* assert(xhv_array != 0) */
2735     oentry = &(HvARRAY(PL_strtab))[hash & (I32) HvMAX(PL_strtab)];
2736     if (he) {
2737         const HE *const he_he = &(he->shared_he_he);
2738         for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) {
2739             if (entry == he_he)
2740                 break;
2741         }
2742     } else {
2743         const int flags_masked = k_flags & HVhek_MASK;
2744         for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) {
2745             if (HeHASH(entry) != hash)          /* strings can't be equal */
2746                 continue;
2747             if (HeKLEN(entry) != len)
2748                 continue;
2749             if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len))     /* is this it? */
2750                 continue;
2751             if (HeKFLAGS(entry) != flags_masked)
2752                 continue;
2753             break;
2754         }
2755     }
2756
2757     if (entry) {
2758         if (--entry->he_valu.hent_refcount == 0) {
2759             *oentry = HeNEXT(entry);
2760             Safefree(entry);
2761             xhv->xhv_keys--; /* HvTOTALKEYS(hv)-- */
2762         }
2763     }
2764
2765     if (!entry)
2766         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
2767                          "Attempt to free nonexistent shared string '%s'%s"
2768                          pTHX__FORMAT,
2769                          hek ? HEK_KEY(hek) : str,
2770                          ((k_flags & HVhek_UTF8) ? " (utf8)" : "") pTHX__VALUE);
2771     if (k_flags & HVhek_FREEKEY)
2772         Safefree(str);
2773 }
2774
2775 /* get a (constant) string ptr from the global string table
2776  * string will get added if it is not already there.
2777  * len and hash must both be valid for str.
2778  */
2779 HEK *
2780 Perl_share_hek(pTHX_ const char *str, I32 len, U32 hash)
2781 {
2782     bool is_utf8 = FALSE;
2783     int flags = 0;
2784     const char * const save = str;
2785
2786     PERL_ARGS_ASSERT_SHARE_HEK;
2787
2788     if (len < 0) {
2789       STRLEN tmplen = -len;
2790       is_utf8 = TRUE;
2791       /* See the note in hv_fetch(). --jhi */
2792       str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2793       len = tmplen;
2794       /* If we were able to downgrade here, then than means that we were passed
2795          in a key which only had chars 0-255, but was utf8 encoded.  */
2796       if (is_utf8)
2797           flags = HVhek_UTF8;
2798       /* If we found we were able to downgrade the string to bytes, then
2799          we should flag that it needs upgrading on keys or each.  Also flag
2800          that we need share_hek_flags to free the string.  */
2801       if (str != save) {
2802           dVAR;
2803           PERL_HASH(hash, str, len);
2804           flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2805       }
2806     }
2807
2808     return share_hek_flags (str, len, hash, flags);
2809 }
2810
2811 STATIC HEK *
2812 S_share_hek_flags(pTHX_ const char *str, I32 len, U32 hash, int flags)
2813 {
2814     dVAR;
2815     HE *entry;
2816     const int flags_masked = flags & HVhek_MASK;
2817     const U32 hindex = hash & (I32) HvMAX(PL_strtab);
2818     XPVHV * const xhv = (XPVHV*)SvANY(PL_strtab);
2819
2820     PERL_ARGS_ASSERT_SHARE_HEK_FLAGS;
2821
2822     /* what follows is the moral equivalent of:
2823
2824     if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
2825         hv_store(PL_strtab, str, len, NULL, hash);
2826
2827         Can't rehash the shared string table, so not sure if it's worth
2828         counting the number of entries in the linked list
2829     */
2830
2831     /* assert(xhv_array != 0) */
2832     entry = (HvARRAY(PL_strtab))[hindex];
2833     for (;entry; entry = HeNEXT(entry)) {
2834         if (HeHASH(entry) != hash)              /* strings can't be equal */
2835             continue;
2836         if (HeKLEN(entry) != len)
2837             continue;
2838         if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
2839             continue;
2840         if (HeKFLAGS(entry) != flags_masked)
2841             continue;
2842         break;
2843     }
2844
2845     if (!entry) {
2846         /* What used to be head of the list.
2847            If this is NULL, then we're the first entry for this slot, which
2848            means we need to increate fill.  */
2849         struct shared_he *new_entry;
2850         HEK *hek;
2851         char *k;
2852         HE **const head = &HvARRAY(PL_strtab)[hindex];
2853         HE *const next = *head;
2854
2855         /* We don't actually store a HE from the arena and a regular HEK.
2856            Instead we allocate one chunk of memory big enough for both,
2857            and put the HEK straight after the HE. This way we can find the
2858            HE directly from the HEK.
2859         */
2860
2861         Newx(k, STRUCT_OFFSET(struct shared_he,
2862                                 shared_he_hek.hek_key[0]) + len + 2, char);
2863         new_entry = (struct shared_he *)k;
2864         entry = &(new_entry->shared_he_he);
2865         hek = &(new_entry->shared_he_hek);
2866
2867         Copy(str, HEK_KEY(hek), len, char);
2868         HEK_KEY(hek)[len] = 0;
2869         HEK_LEN(hek) = len;
2870         HEK_HASH(hek) = hash;
2871         HEK_FLAGS(hek) = (unsigned char)flags_masked;
2872
2873         /* Still "point" to the HEK, so that other code need not know what
2874            we're up to.  */
2875         HeKEY_hek(entry) = hek;
2876         entry->he_valu.hent_refcount = 0;
2877         HeNEXT(entry) = next;
2878         *head = entry;
2879
2880         xhv->xhv_keys++; /* HvTOTALKEYS(hv)++ */
2881         if (!next) {                    /* initial entry? */
2882         } else if ( DO_HSPLIT(xhv) ) {
2883             const STRLEN oldsize = xhv->xhv_max + 1;
2884             hsplit(PL_strtab, oldsize, oldsize * 2);
2885         }
2886     }
2887
2888     ++entry->he_valu.hent_refcount;
2889
2890     if (flags & HVhek_FREEKEY)
2891         Safefree(str);
2892
2893     return HeKEY_hek(entry);
2894 }
2895
2896 SSize_t *
2897 Perl_hv_placeholders_p(pTHX_ HV *hv)
2898 {
2899     dVAR;
2900     MAGIC *mg = mg_find((const SV *)hv, PERL_MAGIC_rhash);
2901
2902     PERL_ARGS_ASSERT_HV_PLACEHOLDERS_P;
2903
2904     if (!mg) {
2905         mg = sv_magicext(MUTABLE_SV(hv), 0, PERL_MAGIC_rhash, 0, 0, 0);
2906
2907         if (!mg) {
2908             Perl_die(aTHX_ "panic: hv_placeholders_p");
2909         }
2910     }
2911     return &(mg->mg_len);
2912 }
2913
2914
2915 I32
2916 Perl_hv_placeholders_get(pTHX_ const HV *hv)
2917 {
2918     dVAR;
2919     MAGIC * const mg = mg_find((const SV *)hv, PERL_MAGIC_rhash);
2920
2921     PERL_ARGS_ASSERT_HV_PLACEHOLDERS_GET;
2922
2923     return mg ? mg->mg_len : 0;
2924 }
2925
2926 void
2927 Perl_hv_placeholders_set(pTHX_ HV *hv, I32 ph)
2928 {
2929     dVAR;
2930     MAGIC * const mg = mg_find((const SV *)hv, PERL_MAGIC_rhash);
2931
2932     PERL_ARGS_ASSERT_HV_PLACEHOLDERS_SET;
2933
2934     if (mg) {
2935         mg->mg_len = ph;
2936     } else if (ph) {
2937         if (!sv_magicext(MUTABLE_SV(hv), 0, PERL_MAGIC_rhash, 0, 0, ph))
2938             Perl_die(aTHX_ "panic: hv_placeholders_set");
2939     }
2940     /* else we don't need to add magic to record 0 placeholders.  */
2941 }
2942
2943 STATIC SV *
2944 S_refcounted_he_value(pTHX_ const struct refcounted_he *he)
2945 {
2946     dVAR;
2947     SV *value;
2948
2949     PERL_ARGS_ASSERT_REFCOUNTED_HE_VALUE;
2950
2951     switch(he->refcounted_he_data[0] & HVrhek_typemask) {
2952     case HVrhek_undef:
2953         value = newSV(0);
2954         break;
2955     case HVrhek_delete:
2956         value = &PL_sv_placeholder;
2957         break;
2958     case HVrhek_IV:
2959         value = newSViv(he->refcounted_he_val.refcounted_he_u_iv);
2960         break;
2961     case HVrhek_UV:
2962         value = newSVuv(he->refcounted_he_val.refcounted_he_u_uv);
2963         break;
2964     case HVrhek_PV:
2965     case HVrhek_PV_UTF8:
2966         /* Create a string SV that directly points to the bytes in our
2967            structure.  */
2968         value = newSV_type(SVt_PV);
2969         SvPV_set(value, (char *) he->refcounted_he_data + 1);
2970         SvCUR_set(value, he->refcounted_he_val.refcounted_he_u_len);
2971         /* This stops anything trying to free it  */
2972         SvLEN_set(value, 0);
2973         SvPOK_on(value);
2974         SvREADONLY_on(value);
2975         if ((he->refcounted_he_data[0] & HVrhek_typemask) == HVrhek_PV_UTF8)
2976             SvUTF8_on(value);
2977         break;
2978     default:
2979         Perl_croak(aTHX_ "panic: refcounted_he_value bad flags %"UVxf,
2980                    (UV)he->refcounted_he_data[0]);
2981     }
2982     return value;
2983 }
2984
2985 /*
2986 =for apidoc m|HV *|refcounted_he_chain_2hv|const struct refcounted_he *c|U32 flags
2987
2988 Generates and returns a C<HV *> representing the content of a
2989 C<refcounted_he> chain.
2990 I<flags> is currently unused and must be zero.
2991
2992 =cut
2993 */
2994 HV *
2995 Perl_refcounted_he_chain_2hv(pTHX_ const struct refcounted_he *chain, U32 flags)
2996 {
2997     dVAR;
2998     HV *hv;
2999     U32 placeholders, max;
3000
3001     if (flags)
3002         Perl_croak(aTHX_ "panic: refcounted_he_chain_2hv bad flags %"UVxf,
3003             (UV)flags);
3004
3005     /* We could chase the chain once to get an idea of the number of keys,
3006        and call ksplit.  But for now we'll make a potentially inefficient
3007        hash with only 8 entries in its array.  */
3008     hv = newHV();
3009     max = HvMAX(hv);
3010     if (!HvARRAY(hv)) {
3011         char *array;
3012         Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(max + 1), char);
3013         HvARRAY(hv) = (HE**)array;
3014     }
3015
3016     placeholders = 0;
3017     while (chain) {
3018 #ifdef USE_ITHREADS
3019         U32 hash = chain->refcounted_he_hash;
3020 #else
3021         U32 hash = HEK_HASH(chain->refcounted_he_hek);
3022 #endif
3023         HE **oentry = &((HvARRAY(hv))[hash & max]);
3024         HE *entry = *oentry;
3025         SV *value;
3026
3027         for (; entry; entry = HeNEXT(entry)) {
3028             if (HeHASH(entry) == hash) {
3029                 /* We might have a duplicate key here.  If so, entry is older
3030                    than the key we've already put in the hash, so if they are
3031                    the same, skip adding entry.  */
3032 #ifdef USE_ITHREADS
3033                 const STRLEN klen = HeKLEN(entry);
3034                 const char *const key = HeKEY(entry);
3035                 if (klen == chain->refcounted_he_keylen
3036                     && (!!HeKUTF8(entry)
3037                         == !!(chain->refcounted_he_data[0] & HVhek_UTF8))
3038                     && memEQ(key, REF_HE_KEY(chain), klen))
3039                     goto next_please;
3040 #else
3041                 if (HeKEY_hek(entry) == chain->refcounted_he_hek)
3042                     goto next_please;
3043                 if (HeKLEN(entry) == HEK_LEN(chain->refcounted_he_hek)
3044                     && HeKUTF8(entry) == HEK_UTF8(chain->refcounted_he_hek)
3045                     && memEQ(HeKEY(entry), HEK_KEY(chain->refcounted_he_hek),
3046                              HeKLEN(entry)))
3047                     goto next_please;
3048 #endif
3049             }
3050         }
3051         assert (!entry);
3052         entry = new_HE();
3053
3054 #ifdef USE_ITHREADS
3055         HeKEY_hek(entry)
3056             = share_hek_flags(REF_HE_KEY(chain),
3057                               chain->refcounted_he_keylen,
3058                               chain->refcounted_he_hash,
3059                               (chain->refcounted_he_data[0]
3060                                & (HVhek_UTF8|HVhek_WASUTF8)));
3061 #else
3062         HeKEY_hek(entry) = share_hek_hek(chain->refcounted_he_hek);
3063 #endif
3064         value = refcounted_he_value(chain);
3065         if (value == &PL_sv_placeholder)
3066             placeholders++;
3067         HeVAL(entry) = value;
3068
3069         /* Link it into the chain.  */
3070         HeNEXT(entry) = *oentry;
3071         *oentry = entry;
3072
3073         HvTOTALKEYS(hv)++;
3074
3075     next_please:
3076         chain = chain->refcounted_he_next;
3077     }
3078
3079     if (placeholders) {
3080         clear_placeholders(hv, placeholders);
3081         HvTOTALKEYS(hv) -= placeholders;
3082     }
3083
3084     /* We could check in the loop to see if we encounter any keys with key
3085        flags, but it's probably not worth it, as this per-hash flag is only
3086        really meant as an optimisation for things like Storable.  */
3087     HvHASKFLAGS_on(hv);
3088     DEBUG_A(Perl_hv_assert(aTHX_ hv));
3089
3090     return hv;
3091 }
3092
3093 /*
3094 =for apidoc m|SV *|refcounted_he_fetch_pvn|const struct refcounted_he *chain|const char *keypv|STRLEN keylen|U32 hash|U32 flags
3095
3096 Search along a C<refcounted_he> chain for an entry with the key specified
3097 by I<keypv> and I<keylen>.  If I<flags> has the C<REFCOUNTED_HE_KEY_UTF8>
3098 bit set, the key octets are interpreted as UTF-8, otherwise they
3099 are interpreted as Latin-1.  I<hash> is a precomputed hash of the key
3100 string, or zero if it has not been precomputed.  Returns a mortal scalar
3101 representing the value associated with the key, or C<&PL_sv_placeholder>
3102 if there is no value associated with the key.
3103
3104 =cut
3105 */
3106
3107 SV *
3108 Perl_refcounted_he_fetch_pvn(pTHX_ const struct refcounted_he *chain,
3109                          const char *keypv, STRLEN keylen, U32 hash, U32 flags)
3110 {
3111     dVAR;
3112     U8 utf8_flag;
3113     PERL_ARGS_ASSERT_REFCOUNTED_HE_FETCH_PVN;
3114
3115     if (flags & ~(REFCOUNTED_HE_KEY_UTF8|REFCOUNTED_HE_EXISTS))
3116         Perl_croak(aTHX_ "panic: refcounted_he_fetch_pvn bad flags %"UVxf,
3117             (UV)flags);
3118     if (!chain)
3119         return &PL_sv_placeholder;
3120     if (flags & REFCOUNTED_HE_KEY_UTF8) {
3121         /* For searching purposes, canonicalise to Latin-1 where possible. */
3122         const char *keyend = keypv + keylen, *p;
3123         STRLEN nonascii_count = 0;
3124         for (p = keypv; p != keyend; p++) {
3125             if (! UTF8_IS_INVARIANT(*p)) {
3126                 if (! UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(p, keyend)) {
3127                     goto canonicalised_key;
3128                 }
3129                 nonascii_count++;
3130                 p++;
3131             }
3132         }
3133         if (nonascii_count) {
3134             char *q;
3135             const char *p = keypv, *keyend = keypv + keylen;
3136             keylen -= nonascii_count;
3137             Newx(q, keylen, char);
3138             SAVEFREEPV(q);
3139             keypv = q;
3140             for (; p != keyend; p++, q++) {
3141                 U8 c = (U8)*p;
3142                 if (UTF8_IS_INVARIANT(c)) {
3143                     *q = (char) c;
3144                 }
3145                 else {
3146                     p++;
3147                     *q = (char) TWO_BYTE_UTF8_TO_NATIVE(c, *p);
3148                 }
3149             }
3150         }
3151         flags &= ~REFCOUNTED_HE_KEY_UTF8;
3152         canonicalised_key: ;
3153     }
3154     utf8_flag = (flags & REFCOUNTED_HE_KEY_UTF8) ? HVhek_UTF8 : 0;
3155     if (!hash)
3156         PERL_HASH(hash, keypv, keylen);
3157
3158     for (; chain; chain = chain->refcounted_he_next) {
3159         if (
3160 #ifdef USE_ITHREADS
3161             hash == chain->refcounted_he_hash &&
3162             keylen == chain->refcounted_he_keylen &&
3163             memEQ(REF_HE_KEY(chain), keypv, keylen) &&
3164             utf8_flag == (chain->refcounted_he_data[0] & HVhek_UTF8)
3165 #else
3166             hash == HEK_HASH(chain->refcounted_he_hek) &&
3167             keylen == (STRLEN)HEK_LEN(chain->refcounted_he_hek) &&
3168             memEQ(HEK_KEY(chain->refcounted_he_hek), keypv, keylen) &&
3169             utf8_flag == (HEK_FLAGS(chain->refcounted_he_hek) & HVhek_UTF8)
3170 #endif
3171         ) {
3172             if (flags & REFCOUNTED_HE_EXISTS)
3173                 return (chain->refcounted_he_data[0] & HVrhek_typemask)
3174                     == HVrhek_delete
3175                     ? NULL : &PL_sv_yes;
3176             return sv_2mortal(refcounted_he_value(chain));
3177         }
3178     }
3179     return flags & REFCOUNTED_HE_EXISTS ? NULL : &PL_sv_placeholder;
3180 }
3181
3182 /*
3183 =for apidoc m|SV *|refcounted_he_fetch_pv|const struct refcounted_he *chain|const char *key|U32 hash|U32 flags
3184
3185 Like L</refcounted_he_fetch_pvn>, but takes a nul-terminated string
3186 instead of a string/length pair.
3187
3188 =cut
3189 */
3190
3191 SV *
3192 Perl_refcounted_he_fetch_pv(pTHX_ const struct refcounted_he *chain,
3193                          const char *key, U32 hash, U32 flags)
3194 {
3195     PERL_ARGS_ASSERT_REFCOUNTED_HE_FETCH_PV;
3196     return refcounted_he_fetch_pvn(chain, key, strlen(key), hash, flags);
3197 }
3198
3199 /*
3200 =for apidoc m|SV *|refcounted_he_fetch_sv|const struct refcounted_he *chain|SV *key|U32 hash|U32 flags
3201
3202 Like L</refcounted_he_fetch_pvn>, but takes a Perl scalar instead of a
3203 string/length pair.
3204
3205 =cut
3206 */
3207
3208 SV *
3209 Perl_refcounted_he_fetch_sv(pTHX_ const struct refcounted_he *chain,
3210                          SV *key, U32 hash, U32 flags)
3211 {
3212     const char *keypv;
3213     STRLEN keylen;
3214     PERL_ARGS_ASSERT_REFCOUNTED_HE_FETCH_SV;
3215     if (flags & REFCOUNTED_HE_KEY_UTF8)
3216         Perl_croak(aTHX_ "panic: refcounted_he_fetch_sv bad flags %"UVxf,
3217             (UV)flags);
3218     keypv = SvPV_const(key, keylen);
3219     if (SvUTF8(key))
3220         flags |= REFCOUNTED_HE_KEY_UTF8;
3221     if (!hash && SvIsCOW_shared_hash(key))
3222         hash = SvSHARED_HASH(key);
3223     return refcounted_he_fetch_pvn(chain, keypv, keylen, hash, flags);
3224 }
3225
3226 /*
3227 =for apidoc m|struct refcounted_he *|refcounted_he_new_pvn|struct refcounted_he *parent|const char *keypv|STRLEN keylen|U32 hash|SV *value|U32 flags
3228
3229 Creates a new C<refcounted_he>.  This consists of a single key/value
3230 pair and a reference to an existing C<refcounted_he> chain (which may
3231 be empty), and thus forms a longer chain.  When using the longer chain,
3232 the new key/value pair takes precedence over any entry for the same key
3233 further along the chain.
3234
3235 The new key is specified by I<keypv> and I<keylen>.  If I<flags> has
3236 the C<REFCOUNTED_HE_KEY_UTF8> bit set, the key octets are interpreted
3237 as UTF-8, otherwise they are interpreted as Latin-1.  I<hash> is
3238 a precomputed hash of the key string, or zero if it has not been
3239 precomputed.
3240
3241 I<value> is the scalar value to store for this key.  I<value> is copied
3242 by this function, which thus does not take ownership of any reference
3243 to it, and later changes to the scalar will not be reflected in the
3244 value visible in the C<refcounted_he>.  Complex types of scalar will not
3245 be stored with referential integrity, but will be coerced to strings.
3246 I<value> may be either null or C<&PL_sv_placeholder> to indicate that no
3247 value is to be associated with the key; this, as with any non-null value,
3248 takes precedence over the existence of a value for the key further along
3249 the chain.
3250
3251 I<parent> points to the rest of the C<refcounted_he> chain to be
3252 attached to the new C<refcounted_he>.  This function takes ownership
3253 of one reference to I<parent>, and returns one reference to the new
3254 C<refcounted_he>.
3255
3256 =cut
3257 */
3258
3259 struct refcounted_he *
3260 Perl_refcounted_he_new_pvn(pTHX_ struct refcounted_he *parent,
3261         const char *keypv, STRLEN keylen, U32 hash, SV *value, U32 flags)
3262 {
3263     dVAR;
3264     STRLEN value_len = 0;
3265     const char *value_p = NULL;
3266     bool is_pv;
3267     char value_type;
3268     char hekflags;
3269     STRLEN key_offset = 1;
3270     struct refcounted_he *he;
3271     PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_PVN;
3272
3273     if (!value || value == &PL_sv_placeholder) {
3274         value_type = HVrhek_delete;
3275     } else if (SvPOK(value)) {
3276         value_type = HVrhek_PV;
3277     } else if (SvIOK(value)) {
3278         value_type = SvUOK((const SV *)value) ? HVrhek_UV : HVrhek_IV;
3279     } else if (!SvOK(value)) {
3280         value_type = HVrhek_undef;
3281     } else {
3282         value_type = HVrhek_PV;
3283     }
3284     is_pv = value_type == HVrhek_PV;
3285     if (is_pv) {
3286         /* Do it this way so that the SvUTF8() test is after the SvPV, in case
3287            the value is overloaded, and doesn't yet have the UTF-8flag set.  */
3288         value_p = SvPV_const(value, value_len);
3289         if (SvUTF8(value))
3290             value_type = HVrhek_PV_UTF8;
3291         key_offset = value_len + 2;
3292     }
3293     hekflags = value_type;
3294
3295     if (flags & REFCOUNTED_HE_KEY_UTF8) {
3296         /* Canonicalise to Latin-1 where possible. */
3297         const char *keyend = keypv + keylen, *p;
3298         STRLEN nonascii_count = 0;
3299         for (p = keypv; p != keyend; p++) {
3300             if (! UTF8_IS_INVARIANT(*p)) {
3301                 if (! UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(p, keyend)) {
3302                     goto canonicalised_key;
3303                 }
3304                 nonascii_count++;
3305                 p++;
3306             }
3307         }
3308         if (nonascii_count) {
3309             char *q;
3310             const char *p = keypv, *keyend = keypv + keylen;
3311             keylen -= nonascii_count;
3312             Newx(q, keylen, char);
3313             SAVEFREEPV(q);
3314             keypv = q;
3315             for (; p != keyend; p++, q++) {
3316                 U8 c = (U8)*p;
3317                 if (UTF8_IS_INVARIANT(c)) {
3318                     *q = (char) c;
3319                 }
3320                 else {
3321                     p++;
3322                     *q = (char) TWO_BYTE_UTF8_TO_NATIVE(c, *p);
3323                 }
3324             }
3325         }
3326         flags &= ~REFCOUNTED_HE_KEY_UTF8;
3327         canonicalised_key: ;
3328     }
3329     if (flags & REFCOUNTED_HE_KEY_UTF8)
3330         hekflags |= HVhek_UTF8;
3331     if (!hash)
3332         PERL_HASH(hash, keypv, keylen);
3333
3334 #ifdef USE_ITHREADS
3335     he = (struct refcounted_he*)
3336         PerlMemShared_malloc(sizeof(struct refcounted_he) - 1
3337                              + keylen
3338                              + key_offset);
3339 #else
3340     he = (struct refcounted_he*)
3341         PerlMemShared_malloc(sizeof(struct refcounted_he) - 1
3342                              + key_offset);
3343 #endif
3344
3345     he->refcounted_he_next = parent;
3346
3347     if (is_pv) {
3348         Copy(value_p, he->refcounted_he_data + 1, value_len + 1, char);
3349         he->refcounted_he_val.refcounted_he_u_len = value_len;
3350     } else if (value_type == HVrhek_IV) {
3351         he->refcounted_he_val.refcounted_he_u_iv = SvIVX(value);
3352     } else if (value_type == HVrhek_UV) {
3353         he->refcounted_he_val.refcounted_he_u_uv = SvUVX(value);
3354     }
3355
3356 #ifdef USE_ITHREADS
3357     he->refcounted_he_hash = hash;
3358     he->refcounted_he_keylen = keylen;
3359     Copy(keypv, he->refcounted_he_data + key_offset, keylen, char);
3360 #else
3361     he->refcounted_he_hek = share_hek_flags(keypv, keylen, hash, hekflags);
3362 #endif
3363
3364     he->refcounted_he_data[0] = hekflags;
3365     he->refcounted_he_refcnt = 1;
3366
3367     return he;
3368 }
3369
3370 /*
3371 =for apidoc m|struct refcounted_he *|refcounted_he_new_pv|struct refcounted_he *parent|const char *key|U32 hash|SV *value|U32 flags
3372
3373 Like L</refcounted_he_new_pvn>, but takes a nul-terminated string instead
3374 of a string/length pair.
3375
3376 =cut
3377 */
3378
3379 struct refcounted_he *
3380 Perl_refcounted_he_new_pv(pTHX_ struct refcounted_he *parent,
3381         const char *key, U32 hash, SV *value, U32 flags)
3382 {
3383     PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_PV;
3384     return refcounted_he_new_pvn(parent, key, strlen(key), hash, value, flags);
3385 }
3386
3387 /*
3388 =for apidoc m|struct refcounted_he *|refcounted_he_new_sv|struct refcounted_he *parent|SV *key|U32 hash|SV *value|U32 flags
3389
3390 Like L</refcounted_he_new_pvn>, but takes a Perl scalar instead of a
3391 string/length pair.
3392
3393 =cut
3394 */
3395
3396 struct refcounted_he *
3397 Perl_refcounted_he_new_sv(pTHX_ struct refcounted_he *parent,
3398         SV *key, U32 hash, SV *value, U32 flags)
3399 {
3400     const char *keypv;
3401     STRLEN keylen;
3402     PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_SV;
3403     if (flags & REFCOUNTED_HE_KEY_UTF8)
3404         Perl_croak(aTHX_ "panic: refcounted_he_new_sv bad flags %"UVxf,
3405             (UV)flags);
3406     keypv = SvPV_const(key, keylen);
3407     if (SvUTF8(key))
3408         flags |= REFCOUNTED_HE_KEY_UTF8;
3409     if (!hash && SvIsCOW_shared_hash(key))
3410         hash = SvSHARED_HASH(key);
3411     return refcounted_he_new_pvn(parent, keypv, keylen, hash, value, flags);
3412 }
3413
3414 /*
3415 =for apidoc m|void|refcounted_he_free|struct refcounted_he *he
3416
3417 Decrements the reference count of a C<refcounted_he> by one.  If the
3418 reference count reaches zero the structure's memory is freed, which
3419 (recursively) causes a reduction of its parent C<refcounted_he>'s
3420 reference count.  It is safe to pass a null pointer to this function:
3421 no action occurs in this case.
3422
3423 =cut
3424 */
3425
3426 void
3427 Perl_refcounted_he_free(pTHX_ struct refcounted_he *he) {
3428     dVAR;
3429     PERL_UNUSED_CONTEXT;
3430
3431     while (he) {
3432         struct refcounted_he *copy;
3433         U32 new_count;
3434
3435         HINTS_REFCNT_LOCK;
3436         new_count = --he->refcounted_he_refcnt;
3437         HINTS_REFCNT_UNLOCK;
3438
3439         if (new_count) {
3440             return;
3441         }
3442
3443 #ifndef USE_ITHREADS
3444         unshare_hek_or_pvn (he->refcounted_he_hek, 0, 0, 0);
3445 #endif
3446         copy = he;
3447         he = he->refcounted_he_next;
3448         PerlMemShared_free(copy);
3449     }
3450 }
3451
3452 /*
3453 =for apidoc m|struct refcounted_he *|refcounted_he_inc|struct refcounted_he *he
3454
3455 Increment the reference count of a C<refcounted_he>.  The pointer to the
3456 C<refcounted_he> is also returned.  It is safe to pass a null pointer
3457 to this function: no action occurs and a null pointer is returned.
3458
3459 =cut
3460 */
3461
3462 struct refcounted_he *
3463 Perl_refcounted_he_inc(pTHX_ struct refcounted_he *he)
3464 {
3465     dVAR;
3466     if (he) {
3467         HINTS_REFCNT_LOCK;
3468         he->refcounted_he_refcnt++;
3469         HINTS_REFCNT_UNLOCK;
3470     }
3471     return he;
3472 }
3473
3474 /*
3475 =for apidoc cop_fetch_label
3476
3477 Returns the label attached to a cop.
3478 The flags pointer may be set to C<SVf_UTF8> or 0.
3479
3480 =cut
3481 */
3482
3483 /* pp_entereval is aware that labels are stored with a key ':' at the top of
3484    the linked list.  */
3485 const char *
3486 Perl_cop_fetch_label(pTHX_ COP *const cop, STRLEN *len, U32 *flags) {
3487     struct refcounted_he *const chain = cop->cop_hints_hash;
3488
3489     PERL_ARGS_ASSERT_COP_FETCH_LABEL;
3490
3491     if (!chain)
3492         return NULL;
3493 #ifdef USE_ITHREADS
3494     if (chain->refcounted_he_keylen != 1)
3495         return NULL;
3496     if (*REF_HE_KEY(chain) != ':')
3497         return NULL;
3498 #else
3499     if ((STRLEN)HEK_LEN(chain->refcounted_he_hek) != 1)
3500         return NULL;
3501     if (*HEK_KEY(chain->refcounted_he_hek) != ':')
3502         return NULL;
3503 #endif
3504     /* Stop anyone trying to really mess us up by adding their own value for
3505        ':' into %^H  */
3506     if ((chain->refcounted_he_data[0] & HVrhek_typemask) != HVrhek_PV
3507         && (chain->refcounted_he_data[0] & HVrhek_typemask) != HVrhek_PV_UTF8)
3508         return NULL;
3509
3510     if (len)
3511         *len = chain->refcounted_he_val.refcounted_he_u_len;
3512     if (flags) {
3513         *flags = ((chain->refcounted_he_data[0] & HVrhek_typemask)
3514                   == HVrhek_PV_UTF8) ? SVf_UTF8 : 0;
3515     }
3516     return chain->refcounted_he_data + 1;
3517 }
3518
3519 /*
3520 =for apidoc cop_store_label
3521
3522 Save a label into a C<cop_hints_hash>. You need to set flags to C<SVf_UTF8>
3523 for a utf-8 label.
3524
3525 =cut
3526 */
3527
3528 void
3529 Perl_cop_store_label(pTHX_ COP *const cop, const char *label, STRLEN len,
3530                      U32 flags)
3531 {
3532     SV *labelsv;
3533     PERL_ARGS_ASSERT_COP_STORE_LABEL;
3534
3535     if (flags & ~(SVf_UTF8))
3536         Perl_croak(aTHX_ "panic: cop_store_label illegal flag bits 0x%" UVxf,
3537                    (UV)flags);
3538     labelsv = newSVpvn_flags(label, len, SVs_TEMP);
3539     if (flags & SVf_UTF8)
3540         SvUTF8_on(labelsv);
3541     cop->cop_hints_hash
3542         = refcounted_he_new_pvs(cop->cop_hints_hash, ":", labelsv, 0);
3543 }
3544
3545 /*
3546 =for apidoc hv_assert
3547
3548 Check that a hash is in an internally consistent state.
3549
3550 =cut
3551 */
3552
3553 #ifdef DEBUGGING
3554
3555 void
3556 Perl_hv_assert(pTHX_ HV *hv)
3557 {
3558     dVAR;
3559     HE* entry;
3560     int withflags = 0;
3561     int placeholders = 0;
3562     int real = 0;
3563     int bad = 0;
3564     const I32 riter = HvRITER_get(hv);
3565     HE *eiter = HvEITER_get(hv);
3566
3567     PERL_ARGS_ASSERT_HV_ASSERT;
3568
3569     (void)hv_iterinit(hv);
3570
3571     while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))) {
3572         /* sanity check the values */
3573         if (HeVAL(entry) == &PL_sv_placeholder)
3574             placeholders++;
3575         else
3576             real++;
3577         /* sanity check the keys */
3578         if (HeSVKEY(entry)) {
3579             NOOP;   /* Don't know what to check on SV keys.  */
3580         } else if (HeKUTF8(entry)) {
3581             withflags++;
3582             if (HeKWASUTF8(entry)) {
3583                 PerlIO_printf(Perl_debug_log,
3584                             "hash key has both WASUTF8 and UTF8: '%.*s'\n",
3585                             (int) HeKLEN(entry),  HeKEY(entry));
3586                 bad = 1;
3587             }
3588         } else if (HeKWASUTF8(entry))
3589             withflags++;
3590     }
3591     if (!SvTIED_mg((const SV *)hv, PERL_MAGIC_tied)) {
3592         static const char bad_count[] = "Count %d %s(s), but hash reports %d\n";
3593         const int nhashkeys = HvUSEDKEYS(hv);
3594         const int nhashplaceholders = HvPLACEHOLDERS_get(hv);
3595
3596         if (nhashkeys != real) {
3597             PerlIO_printf(Perl_debug_log, bad_count, real, "keys", nhashkeys );
3598             bad = 1;
3599         }
3600         if (nhashplaceholders != placeholders) {
3601             PerlIO_printf(Perl_debug_log, bad_count, placeholders, "placeholder", nhashplaceholders );
3602             bad = 1;
3603         }
3604     }
3605     if (withflags && ! HvHASKFLAGS(hv)) {
3606         PerlIO_printf(Perl_debug_log,
3607                     "Hash has HASKFLAGS off but I count %d key(s) with flags\n",
3608                     withflags);
3609         bad = 1;
3610     }
3611     if (bad) {
3612         sv_dump(MUTABLE_SV(hv));
3613     }
3614     HvRITER_set(hv, riter);             /* Restore hash iterator state */
3615     HvEITER_set(hv, eiter);
3616 }
3617
3618 #endif
3619
3620 /*
3621  * Local variables:
3622  * c-indentation-style: bsd
3623  * c-basic-offset: 4
3624  * indent-tabs-mode: nil
3625  * End:
3626  *
3627  * ex: set ts=8 sts=4 sw=4 et:
3628  */