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          && !SvIsCOW(HeVAL(entry))) {
1067             hv_notallowed(k_flags, key, klen,
1068                             "Attempt to delete readonly key '%"SVf"' from"
1069                             " a restricted hash");
1070         }
1071         if (k_flags & HVhek_FREEKEY)
1072             Safefree(key);
1073
1074         /* If this is a stash and the key ends with ::, then someone is
1075          * deleting a package.
1076          */
1077         if (HeVAL(entry) && HvENAME_get(hv)) {
1078                 gv = (GV *)HeVAL(entry);
1079                 if (keysv) key = SvPV(keysv, klen);
1080                 if ((
1081                      (klen > 1 && key[klen-2] == ':' && key[klen-1] == ':')
1082                       ||
1083                      (klen == 1 && key[0] == ':')
1084                     )
1085                  && (klen != 6 || hv!=PL_defstash || memNE(key,"main::",6))
1086                  && SvTYPE(gv) == SVt_PVGV && (stash = GvHV((GV *)gv))
1087                  && HvENAME_get(stash)) {
1088                         /* A previous version of this code checked that the
1089                          * GV was still in the symbol table by fetching the
1090                          * GV with its name. That is not necessary (and
1091                          * sometimes incorrect), as HvENAME cannot be set
1092                          * on hv if it is not in the symtab. */
1093                         mro_changes = 2;
1094                         /* Hang on to it for a bit. */
1095                         SvREFCNT_inc_simple_void_NN(
1096                          sv_2mortal((SV *)gv)
1097                         );
1098                 }
1099                 else if (klen == 3 && strnEQ(key, "ISA", 3))
1100                     mro_changes = 1;
1101         }
1102
1103         sv = d_flags & G_DISCARD ? HeVAL(entry) : sv_2mortal(HeVAL(entry));
1104         HeVAL(entry) = &PL_sv_placeholder;
1105         if (sv) {
1106             /* deletion of method from stash */
1107             if (isGV(sv) && isGV_with_GP(sv) && GvCVu(sv)
1108              && HvENAME_get(hv))
1109                 mro_method_changed_in(hv);
1110         }
1111
1112         /*
1113          * If a restricted hash, rather than really deleting the entry, put
1114          * a placeholder there. This marks the key as being "approved", so
1115          * we can still access via not-really-existing key without raising
1116          * an error.
1117          */
1118         if (SvREADONLY(hv))
1119             /* We'll be saving this slot, so the number of allocated keys
1120              * doesn't go down, but the number placeholders goes up */
1121             HvPLACEHOLDERS(hv)++;
1122         else {
1123             *oentry = HeNEXT(entry);
1124             if(!*first_entry && SvOOK(hv)) {
1125                 /* removed last entry, and aux struct present.  */
1126                 struct xpvhv_aux *const aux = HvAUX(hv);
1127                 if (aux->xhv_fill_lazy)
1128                     --aux->xhv_fill_lazy;
1129             }
1130             if (SvOOK(hv) && entry == HvAUX(hv)->xhv_eiter /* HvEITER(hv) */)
1131                 HvLAZYDEL_on(hv);
1132             else {
1133                 if (SvOOK(hv) && HvLAZYDEL(hv) &&
1134                     entry == HeNEXT(HvAUX(hv)->xhv_eiter))
1135                     HeNEXT(HvAUX(hv)->xhv_eiter) = HeNEXT(entry);
1136                 hv_free_ent(hv, entry);
1137             }
1138             xhv->xhv_keys--; /* HvTOTALKEYS(hv)-- */
1139             if (xhv->xhv_keys == 0)
1140                 HvHASKFLAGS_off(hv);
1141         }
1142
1143         if (d_flags & G_DISCARD) {
1144             SvREFCNT_dec(sv);
1145             sv = NULL;
1146         }
1147
1148         if (mro_changes == 1) mro_isa_changed_in(hv);
1149         else if (mro_changes == 2)
1150             mro_package_moved(NULL, stash, gv, 1);
1151
1152         return sv;
1153     }
1154     if (SvREADONLY(hv)) {
1155         hv_notallowed(k_flags, key, klen,
1156                         "Attempt to delete disallowed key '%"SVf"' from"
1157                         " a restricted hash");
1158     }
1159
1160     if (k_flags & HVhek_FREEKEY)
1161         Safefree(key);
1162     return NULL;
1163 }
1164
1165 STATIC void
1166 S_hsplit(pTHX_ HV *hv, STRLEN const oldsize, STRLEN newsize)
1167 {
1168     dVAR;
1169     STRLEN i = 0;
1170     char *a = (char*) HvARRAY(hv);
1171     HE **aep;
1172
1173     PERL_ARGS_ASSERT_HSPLIT;
1174
1175     /*PerlIO_printf(PerlIO_stderr(), "hsplit called for %p which had %d\n",
1176       (void*)hv, (int) oldsize);*/
1177
1178     PL_nomemok = TRUE;
1179     Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize)
1180           + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char);
1181     if (!a) {
1182       PL_nomemok = FALSE;
1183       return;
1184     }
1185 #ifdef PERL_HASH_RANDOMIZE_KEYS
1186     /* the idea of this is that we create a "random" value by hashing the address of
1187      * the array, we then use the low bit to decide if we insert at the top, or insert
1188      * second from top. After each such insert we rotate the hashed value. So we can
1189      * use the same hashed value over and over, and in normal build environments use
1190      * very few ops to do so. ROTL32() should produce a single machine operation. */
1191     if (PL_HASH_RAND_BITS_ENABLED) {
1192         if (PL_HASH_RAND_BITS_ENABLED == 1)
1193             PL_hash_rand_bits += ptr_hash((PTRV)a);
1194         PL_hash_rand_bits = ROTL_UV(PL_hash_rand_bits,1);
1195     }
1196 #endif
1197
1198     if (SvOOK(hv)) {
1199         struct xpvhv_aux *const dest
1200             = (struct xpvhv_aux*) &a[newsize * sizeof(HE*)];
1201         Move(&a[oldsize * sizeof(HE*)], dest, 1, struct xpvhv_aux);
1202         /* we reset the iterator's xhv_rand as well, so they get a totally new ordering */
1203 #ifdef PERL_HASH_RANDOMIZE_KEYS
1204         dest->xhv_rand = (U32)PL_hash_rand_bits;
1205 #endif
1206         /* For now, just reset the lazy fill counter.
1207            It would be possible to update the counter in the code below
1208            instead.  */
1209         dest->xhv_fill_lazy = 0;
1210     }
1211
1212     PL_nomemok = FALSE;
1213     Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char);     /* zero 2nd half*/
1214     HvMAX(hv) = --newsize;
1215     HvARRAY(hv) = (HE**) a;
1216
1217     if (!HvTOTALKEYS(hv))       /* skip rest if no entries */
1218         return;
1219
1220     aep = (HE**)a;
1221     do {
1222         HE **oentry = aep + i;
1223         HE *entry = aep[i];
1224
1225         if (!entry)                             /* non-existent */
1226             continue;
1227         do {
1228             U32 j = (HeHASH(entry) & newsize);
1229             if (j != (U32)i) {
1230                 *oentry = HeNEXT(entry);
1231 #ifdef PERL_HASH_RANDOMIZE_KEYS
1232                 /* if the target cell is empty or PL_HASH_RAND_BITS_ENABLED is false
1233                  * insert to top, otherwise rotate the bucket rand 1 bit,
1234                  * and use the new low bit to decide if we insert at top,
1235                  * or next from top. IOW, we only rotate on a collision.*/
1236                 if (aep[j] && PL_HASH_RAND_BITS_ENABLED) {
1237                     PL_hash_rand_bits+= ROTL_UV(HeHASH(entry), 17);
1238                     PL_hash_rand_bits= ROTL_UV(PL_hash_rand_bits,1);
1239                     if (PL_hash_rand_bits & 1) {
1240                         HeNEXT(entry)= HeNEXT(aep[j]);
1241                         HeNEXT(aep[j])= entry;
1242                     } else {
1243                         /* Note, this is structured in such a way as the optimizer
1244                         * should eliminate the duplicated code here and below without
1245                         * us needing to explicitly use a goto. */
1246                         HeNEXT(entry) = aep[j];
1247                         aep[j] = entry;
1248                     }
1249                 } else
1250 #endif
1251                 {
1252                     /* see comment above about duplicated code */
1253                     HeNEXT(entry) = aep[j];
1254                     aep[j] = entry;
1255                 }
1256             }
1257             else {
1258                 oentry = &HeNEXT(entry);
1259             }
1260             entry = *oentry;
1261         } while (entry);
1262     } while (i++ < oldsize);
1263 }
1264
1265 void
1266 Perl_hv_ksplit(pTHX_ HV *hv, IV newmax)
1267 {
1268     dVAR;
1269     XPVHV* xhv = (XPVHV*)SvANY(hv);
1270     const I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
1271     I32 newsize;
1272     char *a;
1273
1274     PERL_ARGS_ASSERT_HV_KSPLIT;
1275
1276     newsize = (I32) newmax;                     /* possible truncation here */
1277     if (newsize != newmax || newmax <= oldsize)
1278         return;
1279     while ((newsize & (1 + ~newsize)) != newsize) {
1280         newsize &= ~(newsize & (1 + ~newsize)); /* get proper power of 2 */
1281     }
1282     if (newsize < newmax)
1283         newsize *= 2;
1284     if (newsize < newmax)
1285         return;                                 /* overflow detection */
1286
1287     a = (char *) HvARRAY(hv);
1288     if (a) {
1289         hsplit(hv, oldsize, newsize);
1290     } else {
1291         Newxz(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1292         xhv->xhv_max = --newsize;
1293         HvARRAY(hv) = (HE **) a;
1294     }
1295 }
1296
1297 /* IMO this should also handle cases where hv_max is smaller than hv_keys
1298  * as tied hashes could play silly buggers and mess us around. We will
1299  * do the right thing during hv_store() afterwards, but still - Yves */
1300 #define HV_SET_MAX_ADJUSTED_FOR_KEYS(hv,hv_max,hv_keys) STMT_START {\
1301     /* Can we use fewer buckets? (hv_max is always 2^n-1) */        \
1302     if (hv_max < PERL_HASH_DEFAULT_HvMAX) {                         \
1303         hv_max = PERL_HASH_DEFAULT_HvMAX;                           \
1304     } else {                                                        \
1305         while (hv_max > PERL_HASH_DEFAULT_HvMAX && hv_max + 1 >= hv_keys * 2) \
1306             hv_max = hv_max / 2;                                    \
1307     }                                                               \
1308     HvMAX(hv) = hv_max;                                             \
1309 } STMT_END
1310
1311
1312 HV *
1313 Perl_newHVhv(pTHX_ HV *ohv)
1314 {
1315     dVAR;
1316     HV * const hv = newHV();
1317     STRLEN hv_max;
1318
1319     if (!ohv || (!HvTOTALKEYS(ohv) && !SvMAGICAL((const SV *)ohv)))
1320         return hv;
1321     hv_max = HvMAX(ohv);
1322
1323     if (!SvMAGICAL((const SV *)ohv)) {
1324         /* It's an ordinary hash, so copy it fast. AMS 20010804 */
1325         STRLEN i;
1326         const bool shared = !!HvSHAREKEYS(ohv);
1327         HE **ents, ** const oents = (HE **)HvARRAY(ohv);
1328         char *a;
1329         Newx(a, PERL_HV_ARRAY_ALLOC_BYTES(hv_max+1), char);
1330         ents = (HE**)a;
1331
1332         /* In each bucket... */
1333         for (i = 0; i <= hv_max; i++) {
1334             HE *prev = NULL;
1335             HE *oent = oents[i];
1336
1337             if (!oent) {
1338                 ents[i] = NULL;
1339                 continue;
1340             }
1341
1342             /* Copy the linked list of entries. */
1343             for (; oent; oent = HeNEXT(oent)) {
1344                 const U32 hash   = HeHASH(oent);
1345                 const char * const key = HeKEY(oent);
1346                 const STRLEN len = HeKLEN(oent);
1347                 const int flags  = HeKFLAGS(oent);
1348                 HE * const ent   = new_HE();
1349                 SV *const val    = HeVAL(oent);
1350
1351                 HeVAL(ent) = SvIMMORTAL(val) ? val : newSVsv(val);
1352                 HeKEY_hek(ent)
1353                     = shared ? share_hek_flags(key, len, hash, flags)
1354                              :  save_hek_flags(key, len, hash, flags);
1355                 if (prev)
1356                     HeNEXT(prev) = ent;
1357                 else
1358                     ents[i] = ent;
1359                 prev = ent;
1360                 HeNEXT(ent) = NULL;
1361             }
1362         }
1363
1364         HvMAX(hv)   = hv_max;
1365         HvTOTALKEYS(hv)  = HvTOTALKEYS(ohv);
1366         HvARRAY(hv) = ents;
1367     } /* not magical */
1368     else {
1369         /* Iterate over ohv, copying keys and values one at a time. */
1370         HE *entry;
1371         const I32 riter = HvRITER_get(ohv);
1372         HE * const eiter = HvEITER_get(ohv);
1373         STRLEN hv_keys = HvTOTALKEYS(ohv);
1374
1375         HV_SET_MAX_ADJUSTED_FOR_KEYS(hv,hv_max,hv_keys);
1376
1377         hv_iterinit(ohv);
1378         while ((entry = hv_iternext_flags(ohv, 0))) {
1379             SV *val = hv_iterval(ohv,entry);
1380             SV * const keysv = HeSVKEY(entry);
1381             val = SvIMMORTAL(val) ? val : newSVsv(val);
1382             if (keysv)
1383                 (void)hv_store_ent(hv, keysv, val, 0);
1384             else
1385                 (void)hv_store_flags(hv, HeKEY(entry), HeKLEN(entry), val,
1386                                  HeHASH(entry), HeKFLAGS(entry));
1387         }
1388         HvRITER_set(ohv, riter);
1389         HvEITER_set(ohv, eiter);
1390     }
1391
1392     return hv;
1393 }
1394
1395 /*
1396 =for apidoc Am|HV *|hv_copy_hints_hv|HV *ohv
1397
1398 A specialised version of L</newHVhv> for copying C<%^H>.  I<ohv> must be
1399 a pointer to a hash (which may have C<%^H> magic, but should be generally
1400 non-magical), or C<NULL> (interpreted as an empty hash).  The content
1401 of I<ohv> is copied to a new hash, which has the C<%^H>-specific magic
1402 added to it.  A pointer to the new hash is returned.
1403
1404 =cut
1405 */
1406
1407 HV *
1408 Perl_hv_copy_hints_hv(pTHX_ HV *const ohv)
1409 {
1410     HV * const hv = newHV();
1411
1412     if (ohv) {
1413         STRLEN hv_max = HvMAX(ohv);
1414         STRLEN hv_keys = HvTOTALKEYS(ohv);
1415         HE *entry;
1416         const I32 riter = HvRITER_get(ohv);
1417         HE * const eiter = HvEITER_get(ohv);
1418
1419         ENTER;
1420         SAVEFREESV(hv);
1421
1422         HV_SET_MAX_ADJUSTED_FOR_KEYS(hv,hv_max,hv_keys);
1423
1424         hv_iterinit(ohv);
1425         while ((entry = hv_iternext_flags(ohv, 0))) {
1426             SV *const sv = newSVsv(hv_iterval(ohv,entry));
1427             SV *heksv = HeSVKEY(entry);
1428             if (!heksv && sv) heksv = newSVhek(HeKEY_hek(entry));
1429             if (sv) sv_magic(sv, NULL, PERL_MAGIC_hintselem,
1430                      (char *)heksv, HEf_SVKEY);
1431             if (heksv == HeSVKEY(entry))
1432                 (void)hv_store_ent(hv, heksv, sv, 0);
1433             else {
1434                 (void)hv_common(hv, heksv, HeKEY(entry), HeKLEN(entry),
1435                                  HeKFLAGS(entry), HV_FETCH_ISSTORE|HV_FETCH_JUST_SV, sv, HeHASH(entry));
1436                 SvREFCNT_dec_NN(heksv);
1437             }
1438         }
1439         HvRITER_set(ohv, riter);
1440         HvEITER_set(ohv, eiter);
1441
1442         SvREFCNT_inc_simple_void_NN(hv);
1443         LEAVE;
1444     }
1445     hv_magic(hv, NULL, PERL_MAGIC_hints);
1446     return hv;
1447 }
1448 #undef HV_SET_MAX_ADJUSTED_FOR_KEYS
1449
1450 /* like hv_free_ent, but returns the SV rather than freeing it */
1451 STATIC SV*
1452 S_hv_free_ent_ret(pTHX_ HV *hv, HE *entry)
1453 {
1454     dVAR;
1455     SV *val;
1456
1457     PERL_ARGS_ASSERT_HV_FREE_ENT_RET;
1458
1459     val = HeVAL(entry);
1460     if (HeKLEN(entry) == HEf_SVKEY) {
1461         SvREFCNT_dec(HeKEY_sv(entry));
1462         Safefree(HeKEY_hek(entry));
1463     }
1464     else if (HvSHAREKEYS(hv))
1465         unshare_hek(HeKEY_hek(entry));
1466     else
1467         Safefree(HeKEY_hek(entry));
1468     del_HE(entry);
1469     return val;
1470 }
1471
1472
1473 void
1474 Perl_hv_free_ent(pTHX_ HV *hv, HE *entry)
1475 {
1476     dVAR;
1477     SV *val;
1478
1479     PERL_ARGS_ASSERT_HV_FREE_ENT;
1480
1481     if (!entry)
1482         return;
1483     val = hv_free_ent_ret(hv, entry);
1484     SvREFCNT_dec(val);
1485 }
1486
1487
1488 void
1489 Perl_hv_delayfree_ent(pTHX_ HV *hv, HE *entry)
1490 {
1491     dVAR;
1492
1493     PERL_ARGS_ASSERT_HV_DELAYFREE_ENT;
1494
1495     if (!entry)
1496         return;
1497     /* SvREFCNT_inc to counter the SvREFCNT_dec in hv_free_ent  */
1498     sv_2mortal(SvREFCNT_inc(HeVAL(entry)));     /* free between statements */
1499     if (HeKLEN(entry) == HEf_SVKEY) {
1500         sv_2mortal(SvREFCNT_inc(HeKEY_sv(entry)));
1501     }
1502     hv_free_ent(hv, entry);
1503 }
1504
1505 /*
1506 =for apidoc hv_clear
1507
1508 Frees the all the elements of a hash, leaving it empty.
1509 The XS equivalent of C<%hash = ()>.  See also L</hv_undef>.
1510
1511 If any destructors are triggered as a result, the hv itself may
1512 be freed.
1513
1514 =cut
1515 */
1516
1517 void
1518 Perl_hv_clear(pTHX_ HV *hv)
1519 {
1520     dVAR;
1521     XPVHV* xhv;
1522     if (!hv)
1523         return;
1524
1525     DEBUG_A(Perl_hv_assert(aTHX_ hv));
1526
1527     xhv = (XPVHV*)SvANY(hv);
1528
1529     ENTER;
1530     SAVEFREESV(SvREFCNT_inc_simple_NN(hv));
1531     if (SvREADONLY(hv) && HvARRAY(hv) != NULL) {
1532         /* restricted hash: convert all keys to placeholders */
1533         STRLEN i;
1534         for (i = 0; i <= xhv->xhv_max; i++) {
1535             HE *entry = (HvARRAY(hv))[i];
1536             for (; entry; entry = HeNEXT(entry)) {
1537                 /* not already placeholder */
1538                 if (HeVAL(entry) != &PL_sv_placeholder) {
1539                     if (HeVAL(entry)) {
1540                         if (SvREADONLY(HeVAL(entry)) && !SvIsCOW(HeVAL(entry))) {
1541                             SV* const keysv = hv_iterkeysv(entry);
1542                             Perl_croak_nocontext(
1543                                 "Attempt to delete readonly key '%"SVf"' from a restricted hash",
1544                                 (void*)keysv);
1545                         }
1546                         SvREFCNT_dec_NN(HeVAL(entry));
1547                     }
1548                     HeVAL(entry) = &PL_sv_placeholder;
1549                     HvPLACEHOLDERS(hv)++;
1550                 }
1551             }
1552         }
1553     }
1554     else {
1555         hfreeentries(hv);
1556         HvPLACEHOLDERS_set(hv, 0);
1557
1558         if (SvRMAGICAL(hv))
1559             mg_clear(MUTABLE_SV(hv));
1560
1561         HvHASKFLAGS_off(hv);
1562     }
1563     if (SvOOK(hv)) {
1564         if(HvENAME_get(hv))
1565             mro_isa_changed_in(hv);
1566         HvEITER_set(hv, NULL);
1567     }
1568     LEAVE;
1569 }
1570
1571 /*
1572 =for apidoc hv_clear_placeholders
1573
1574 Clears any placeholders from a hash.  If a restricted hash has any of its keys
1575 marked as readonly and the key is subsequently deleted, the key is not actually
1576 deleted but is marked by assigning it a value of &PL_sv_placeholder.  This tags
1577 it so it will be ignored by future operations such as iterating over the hash,
1578 but will still allow the hash to have a value reassigned to the key at some
1579 future point.  This function clears any such placeholder keys from the hash.
1580 See Hash::Util::lock_keys() for an example of its use.
1581
1582 =cut
1583 */
1584
1585 void
1586 Perl_hv_clear_placeholders(pTHX_ HV *hv)
1587 {
1588     dVAR;
1589     const U32 items = (U32)HvPLACEHOLDERS_get(hv);
1590
1591     PERL_ARGS_ASSERT_HV_CLEAR_PLACEHOLDERS;
1592
1593     if (items)
1594         clear_placeholders(hv, items);
1595 }
1596
1597 static void
1598 S_clear_placeholders(pTHX_ HV *hv, U32 items)
1599 {
1600     dVAR;
1601     I32 i;
1602
1603     PERL_ARGS_ASSERT_CLEAR_PLACEHOLDERS;
1604
1605     if (items == 0)
1606         return;
1607
1608     i = HvMAX(hv);
1609     do {
1610         /* Loop down the linked list heads  */
1611         HE **oentry = &(HvARRAY(hv))[i];
1612         HE *entry;
1613
1614         while ((entry = *oentry)) {
1615             if (HeVAL(entry) == &PL_sv_placeholder) {
1616                 *oentry = HeNEXT(entry);
1617                 if (entry == HvEITER_get(hv))
1618                     HvLAZYDEL_on(hv);
1619                 else {
1620                     if (SvOOK(hv) && HvLAZYDEL(hv) &&
1621                         entry == HeNEXT(HvAUX(hv)->xhv_eiter))
1622                         HeNEXT(HvAUX(hv)->xhv_eiter) = HeNEXT(entry);
1623                     hv_free_ent(hv, entry);
1624                 }
1625
1626                 if (--items == 0) {
1627                     /* Finished.  */
1628                     HvTOTALKEYS(hv) -= (IV)HvPLACEHOLDERS_get(hv);
1629                     if (HvUSEDKEYS(hv) == 0)
1630                         HvHASKFLAGS_off(hv);
1631                     HvPLACEHOLDERS_set(hv, 0);
1632                     return;
1633                 }
1634             } else {
1635                 oentry = &HeNEXT(entry);
1636             }
1637         }
1638     } while (--i >= 0);
1639     /* You can't get here, hence assertion should always fail.  */
1640     assert (items == 0);
1641     assert (0);
1642 }
1643
1644 STATIC void
1645 S_hfreeentries(pTHX_ HV *hv)
1646 {
1647     STRLEN index = 0;
1648     XPVHV * const xhv = (XPVHV*)SvANY(hv);
1649     SV *sv;
1650
1651     PERL_ARGS_ASSERT_HFREEENTRIES;
1652
1653     while ((sv = Perl_hfree_next_entry(aTHX_ hv, &index))||xhv->xhv_keys) {
1654         SvREFCNT_dec(sv);
1655     }
1656 }
1657
1658
1659 /* hfree_next_entry()
1660  * For use only by S_hfreeentries() and sv_clear().
1661  * Delete the next available HE from hv and return the associated SV.
1662  * Returns null on empty hash. Nevertheless null is not a reliable
1663  * indicator that the hash is empty, as the deleted entry may have a
1664  * null value.
1665  * indexp is a pointer to the current index into HvARRAY. The index should
1666  * initially be set to 0. hfree_next_entry() may update it.  */
1667
1668 SV*
1669 Perl_hfree_next_entry(pTHX_ HV *hv, STRLEN *indexp)
1670 {
1671     struct xpvhv_aux *iter;
1672     HE *entry;
1673     HE ** array;
1674 #ifdef DEBUGGING
1675     STRLEN orig_index = *indexp;
1676 #endif
1677
1678     PERL_ARGS_ASSERT_HFREE_NEXT_ENTRY;
1679
1680     if (SvOOK(hv) && ((iter = HvAUX(hv)))) {
1681         if ((entry = iter->xhv_eiter)) {
1682             /* the iterator may get resurrected after each
1683              * destructor call, so check each time */
1684             if (entry && HvLAZYDEL(hv)) {       /* was deleted earlier? */
1685                 HvLAZYDEL_off(hv);
1686                 hv_free_ent(hv, entry);
1687                 /* warning: at this point HvARRAY may have been
1688                  * re-allocated, HvMAX changed etc */
1689             }
1690             iter->xhv_riter = -1;       /* HvRITER(hv) = -1 */
1691             iter->xhv_eiter = NULL;     /* HvEITER(hv) = NULL */
1692 #ifdef PERL_HASH_RANDOMIZE_KEYS
1693             iter->xhv_last_rand = iter->xhv_rand;
1694 #endif
1695         }
1696         /* Reset any cached HvFILL() to "unknown".  It's unlikely that anyone
1697            will actually call HvFILL() on a hash under destruction, so it
1698            seems pointless attempting to track the number of keys remaining.
1699            But if they do, we want to reset it again.  */
1700         if (iter->xhv_fill_lazy)
1701             iter->xhv_fill_lazy = 0;
1702     }
1703
1704     if (!((XPVHV*)SvANY(hv))->xhv_keys)
1705         return NULL;
1706
1707     array = HvARRAY(hv);
1708     assert(array);
1709     while ( ! ((entry = array[*indexp])) ) {
1710         if ((*indexp)++ >= HvMAX(hv))
1711             *indexp = 0;
1712         assert(*indexp != orig_index);
1713     }
1714     array[*indexp] = HeNEXT(entry);
1715     ((XPVHV*) SvANY(hv))->xhv_keys--;
1716
1717     if (   PL_phase != PERL_PHASE_DESTRUCT && HvENAME(hv)
1718         && HeVAL(entry) && isGV(HeVAL(entry))
1719         && GvHV(HeVAL(entry)) && HvENAME(GvHV(HeVAL(entry)))
1720     ) {
1721         STRLEN klen;
1722         const char * const key = HePV(entry,klen);
1723         if ((klen > 1 && key[klen-1]==':' && key[klen-2]==':')
1724          || (klen == 1 && key[0] == ':')) {
1725             mro_package_moved(
1726              NULL, GvHV(HeVAL(entry)),
1727              (GV *)HeVAL(entry), 0
1728             );
1729         }
1730     }
1731     return hv_free_ent_ret(hv, entry);
1732 }
1733
1734
1735 /*
1736 =for apidoc hv_undef
1737
1738 Undefines the hash.  The XS equivalent of C<undef(%hash)>.
1739
1740 As well as freeing all the elements of the hash (like hv_clear()), this
1741 also frees any auxiliary data and storage associated with the hash.
1742
1743 If any destructors are triggered as a result, the hv itself may
1744 be freed.
1745
1746 See also L</hv_clear>.
1747
1748 =cut
1749 */
1750
1751 void
1752 Perl_hv_undef_flags(pTHX_ HV *hv, U32 flags)
1753 {
1754     dVAR;
1755     XPVHV* xhv;
1756     const char *name;
1757     const bool save = !!SvREFCNT(hv);
1758
1759     if (!hv)
1760         return;
1761     DEBUG_A(Perl_hv_assert(aTHX_ hv));
1762     xhv = (XPVHV*)SvANY(hv);
1763
1764     /* The name must be deleted before the call to hfreeeeentries so that
1765        CVs are anonymised properly. But the effective name must be pre-
1766        served until after that call (and only deleted afterwards if the
1767        call originated from sv_clear). For stashes with one name that is
1768        both the canonical name and the effective name, hv_name_set has to
1769        allocate an array for storing the effective name. We can skip that
1770        during global destruction, as it does not matter where the CVs point
1771        if they will be freed anyway. */
1772     /* note that the code following prior to hfreeentries is duplicated
1773      * in sv_clear(), and changes here should be done there too */
1774     if (PL_phase != PERL_PHASE_DESTRUCT && (name = HvNAME(hv))) {
1775         if (PL_stashcache) {
1776             DEBUG_o(Perl_deb(aTHX_ "hv_undef_flags clearing PL_stashcache for '%"
1777                              HEKf"'\n", HvNAME_HEK(hv)));
1778             (void)hv_delete(PL_stashcache, name,
1779                             HEK_UTF8(HvNAME_HEK(hv)) ? -HvNAMELEN_get(hv) : HvNAMELEN_get(hv),
1780                             G_DISCARD
1781                            );
1782         }
1783         hv_name_set(hv, NULL, 0, 0);
1784     }
1785     if (save) {
1786         ENTER;
1787         SAVEFREESV(SvREFCNT_inc_simple_NN(hv));
1788     }
1789     hfreeentries(hv);
1790     if (SvOOK(hv)) {
1791       struct xpvhv_aux * const aux = HvAUX(hv);
1792       struct mro_meta *meta;
1793
1794       if ((name = HvENAME_get(hv))) {
1795         if (PL_phase != PERL_PHASE_DESTRUCT)
1796             mro_isa_changed_in(hv);
1797         if (PL_stashcache) {
1798             DEBUG_o(Perl_deb(aTHX_ "hv_undef_flags clearing PL_stashcache for effective name '%"
1799                              HEKf"'\n", HvENAME_HEK(hv)));
1800             (void)hv_delete(
1801                     PL_stashcache, name,
1802                     HEK_UTF8(HvENAME_HEK(hv)) ? -HvENAMELEN_get(hv) : HvENAMELEN_get(hv),
1803                     G_DISCARD
1804                   );
1805         }
1806       }
1807
1808       /* If this call originated from sv_clear, then we must check for
1809        * effective names that need freeing, as well as the usual name. */
1810       name = HvNAME(hv);
1811       if (flags & HV_NAME_SETALL ? !!aux->xhv_name_u.xhvnameu_name : !!name) {
1812         if (name && PL_stashcache) {
1813             DEBUG_o(Perl_deb(aTHX_ "hv_undef_flags clearing PL_stashcache for name '%"
1814                              HEKf"'\n", HvNAME_HEK(hv)));
1815             (void)hv_delete(PL_stashcache, name, (HEK_UTF8(HvNAME_HEK(hv)) ? -HvNAMELEN_get(hv) : HvNAMELEN_get(hv)), G_DISCARD);
1816         }
1817         hv_name_set(hv, NULL, 0, flags);
1818       }
1819       if((meta = aux->xhv_mro_meta)) {
1820         if (meta->mro_linear_all) {
1821             SvREFCNT_dec_NN(meta->mro_linear_all);
1822             /* mro_linear_current is just acting as a shortcut pointer,
1823                hence the else.  */
1824         }
1825         else
1826             /* Only the current MRO is stored, so this owns the data.
1827              */
1828             SvREFCNT_dec(meta->mro_linear_current);
1829         SvREFCNT_dec(meta->mro_nextmethod);
1830         SvREFCNT_dec(meta->isa);
1831         Safefree(meta);
1832         aux->xhv_mro_meta = NULL;
1833       }
1834       SvREFCNT_dec(aux->xhv_super);
1835       if (!aux->xhv_name_u.xhvnameu_name && ! aux->xhv_backreferences)
1836         SvFLAGS(hv) &= ~SVf_OOK;
1837     }
1838     if (!SvOOK(hv)) {
1839         Safefree(HvARRAY(hv));
1840         xhv->xhv_max = PERL_HASH_DEFAULT_HvMAX;        /* HvMAX(hv) = 7 (it's a normal hash) */
1841         HvARRAY(hv) = 0;
1842     }
1843     /* if we're freeing the HV, the SvMAGIC field has been reused for
1844      * other purposes, and so there can't be any placeholder magic */
1845     if (SvREFCNT(hv))
1846         HvPLACEHOLDERS_set(hv, 0);
1847
1848     if (SvRMAGICAL(hv))
1849         mg_clear(MUTABLE_SV(hv));
1850     if (save) LEAVE;
1851 }
1852
1853 /*
1854 =for apidoc hv_fill
1855
1856 Returns the number of hash buckets that happen to be in use. This function is
1857 wrapped by the macro C<HvFILL>.
1858
1859 Previously this value was always stored in the HV structure, which created an
1860 overhead on every hash (and pretty much every object) for something that was
1861 rarely used. Now we calculate it on demand the first time that it is needed,
1862 and cache it if that calculation is going to be costly to repeat. The cached
1863 value is updated by insertions and deletions, but (currently) discarded if
1864 the hash is split.
1865
1866 =cut
1867 */
1868
1869 STRLEN
1870 Perl_hv_fill(pTHX_ HV *const hv)
1871 {
1872     STRLEN count = 0;
1873     HE **ents = HvARRAY(hv);
1874     struct xpvhv_aux *aux = SvOOK(hv) ? HvAUX(hv) : NULL;
1875
1876     PERL_ARGS_ASSERT_HV_FILL;
1877
1878     /* No keys implies no buckets used.
1879        One key can only possibly mean one bucket used.  */
1880     if (HvTOTALKEYS(hv) < 2)
1881         return HvTOTALKEYS(hv);
1882
1883 #ifndef DEBUGGING
1884     if (aux && aux->xhv_fill_lazy)
1885         return aux->xhv_fill_lazy;
1886 #endif
1887
1888     if (ents) {
1889         HE *const *const last = ents + HvMAX(hv);
1890         count = last + 1 - ents;
1891
1892         do {
1893             if (!*ents)
1894                 --count;
1895         } while (++ents <= last);
1896     }
1897     if (aux) {
1898 #ifdef DEBUGGING
1899         if (aux->xhv_fill_lazy)
1900             assert(aux->xhv_fill_lazy == count);
1901 #endif
1902         aux->xhv_fill_lazy = count;
1903     } else if (HvMAX(hv) >= HV_FILL_THRESHOLD) {
1904         aux = hv_auxinit(hv);
1905         aux->xhv_fill_lazy = count;
1906     }
1907     return count;
1908 }
1909
1910 /* hash a pointer to a U32 - Used in the hash traversal randomization
1911  * and bucket order randomization code
1912  *
1913  * this code was derived from Sereal, which was derived from autobox.
1914  */
1915
1916 PERL_STATIC_INLINE U32 S_ptr_hash(PTRV u) {
1917 #if PTRSIZE == 8
1918     /*
1919      * This is one of Thomas Wang's hash functions for 64-bit integers from:
1920      * http://www.concentric.net/~Ttwang/tech/inthash.htm
1921      */
1922     u = (~u) + (u << 18);
1923     u = u ^ (u >> 31);
1924     u = u * 21;
1925     u = u ^ (u >> 11);
1926     u = u + (u << 6);
1927     u = u ^ (u >> 22);
1928 #else
1929     /*
1930      * This is one of Bob Jenkins' hash functions for 32-bit integers
1931      * from: http://burtleburtle.net/bob/hash/integer.html
1932      */
1933     u = (u + 0x7ed55d16) + (u << 12);
1934     u = (u ^ 0xc761c23c) ^ (u >> 19);
1935     u = (u + 0x165667b1) + (u << 5);
1936     u = (u + 0xd3a2646c) ^ (u << 9);
1937     u = (u + 0xfd7046c5) + (u << 3);
1938     u = (u ^ 0xb55a4f09) ^ (u >> 16);
1939 #endif
1940     return (U32)u;
1941 }
1942
1943
1944 static struct xpvhv_aux*
1945 S_hv_auxinit(pTHX_ HV *hv) {
1946     struct xpvhv_aux *iter;
1947     char *array;
1948
1949     PERL_ARGS_ASSERT_HV_AUXINIT;
1950
1951     if (!SvOOK(hv)) {
1952         if (!HvARRAY(hv)) {
1953             Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(HvMAX(hv) + 1)
1954                 + sizeof(struct xpvhv_aux), char);
1955         } else {
1956             array = (char *) HvARRAY(hv);
1957             Renew(array, PERL_HV_ARRAY_ALLOC_BYTES(HvMAX(hv) + 1)
1958                   + sizeof(struct xpvhv_aux), char);
1959         }
1960         HvARRAY(hv) = (HE**)array;
1961         SvOOK_on(hv);
1962         iter = HvAUX(hv);
1963 #ifdef PERL_HASH_RANDOMIZE_KEYS
1964         if (PL_HASH_RAND_BITS_ENABLED) {
1965             /* mix in some new state to PL_hash_rand_bits to "randomize" the traversal order*/
1966             if (PL_HASH_RAND_BITS_ENABLED == 1)
1967                 PL_hash_rand_bits += ptr_hash((PTRV)array);
1968             PL_hash_rand_bits = ROTL_UV(PL_hash_rand_bits,1);
1969         }
1970         iter->xhv_rand = (U32)PL_hash_rand_bits;
1971 #endif
1972     } else {
1973         iter = HvAUX(hv);
1974     }
1975
1976     iter->xhv_riter = -1;       /* HvRITER(hv) = -1 */
1977     iter->xhv_eiter = NULL;     /* HvEITER(hv) = NULL */
1978 #ifdef PERL_HASH_RANDOMIZE_KEYS
1979     iter->xhv_last_rand = iter->xhv_rand;
1980 #endif
1981     iter->xhv_fill_lazy = 0;
1982     iter->xhv_name_u.xhvnameu_name = 0;
1983     iter->xhv_name_count = 0;
1984     iter->xhv_backreferences = 0;
1985     iter->xhv_mro_meta = NULL;
1986     iter->xhv_super = NULL;
1987     return iter;
1988 }
1989
1990 /*
1991 =for apidoc hv_iterinit
1992
1993 Prepares a starting point to traverse a hash table.  Returns the number of
1994 keys in the hash (i.e. the same as C<HvUSEDKEYS(hv)>).  The return value is
1995 currently only meaningful for hashes without tie magic.
1996
1997 NOTE: Before version 5.004_65, C<hv_iterinit> used to return the number of
1998 hash buckets that happen to be in use.  If you still need that esoteric
1999 value, you can get it through the macro C<HvFILL(hv)>.
2000
2001
2002 =cut
2003 */
2004
2005 I32
2006 Perl_hv_iterinit(pTHX_ HV *hv)
2007 {
2008     PERL_ARGS_ASSERT_HV_ITERINIT;
2009
2010     /* FIXME: Are we not NULL, or do we croak? Place bets now! */
2011
2012     if (!hv)
2013         Perl_croak(aTHX_ "Bad hash");
2014
2015     if (SvOOK(hv)) {
2016         struct xpvhv_aux * const iter = HvAUX(hv);
2017         HE * const entry = iter->xhv_eiter; /* HvEITER(hv) */
2018         if (entry && HvLAZYDEL(hv)) {   /* was deleted earlier? */
2019             HvLAZYDEL_off(hv);
2020             hv_free_ent(hv, entry);
2021         }
2022         iter->xhv_riter = -1;   /* HvRITER(hv) = -1 */
2023         iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
2024 #ifdef PERL_HASH_RANDOMIZE_KEYS
2025         iter->xhv_last_rand = iter->xhv_rand;
2026 #endif
2027     } else {
2028         hv_auxinit(hv);
2029     }
2030
2031     /* used to be xhv->xhv_fill before 5.004_65 */
2032     return HvTOTALKEYS(hv);
2033 }
2034
2035 I32 *
2036 Perl_hv_riter_p(pTHX_ HV *hv) {
2037     struct xpvhv_aux *iter;
2038
2039     PERL_ARGS_ASSERT_HV_RITER_P;
2040
2041     if (!hv)
2042         Perl_croak(aTHX_ "Bad hash");
2043
2044     iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
2045     return &(iter->xhv_riter);
2046 }
2047
2048 HE **
2049 Perl_hv_eiter_p(pTHX_ HV *hv) {
2050     struct xpvhv_aux *iter;
2051
2052     PERL_ARGS_ASSERT_HV_EITER_P;
2053
2054     if (!hv)
2055         Perl_croak(aTHX_ "Bad hash");
2056
2057     iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
2058     return &(iter->xhv_eiter);
2059 }
2060
2061 void
2062 Perl_hv_riter_set(pTHX_ HV *hv, I32 riter) {
2063     struct xpvhv_aux *iter;
2064
2065     PERL_ARGS_ASSERT_HV_RITER_SET;
2066
2067     if (!hv)
2068         Perl_croak(aTHX_ "Bad hash");
2069
2070     if (SvOOK(hv)) {
2071         iter = HvAUX(hv);
2072     } else {
2073         if (riter == -1)
2074             return;
2075
2076         iter = hv_auxinit(hv);
2077     }
2078     iter->xhv_riter = riter;
2079 }
2080
2081 void
2082 Perl_hv_rand_set(pTHX_ HV *hv, U32 new_xhv_rand) {
2083     struct xpvhv_aux *iter;
2084
2085     PERL_ARGS_ASSERT_HV_RAND_SET;
2086
2087 #ifdef PERL_HASH_RANDOMIZE_KEYS
2088     if (!hv)
2089         Perl_croak(aTHX_ "Bad hash");
2090
2091     if (SvOOK(hv)) {
2092         iter = HvAUX(hv);
2093     } else {
2094         iter = hv_auxinit(hv);
2095     }
2096     iter->xhv_rand = new_xhv_rand;
2097 #else
2098     Perl_croak(aTHX_ "This Perl has not been built with support for randomized hash key traversal but something called Perl_hv_rand_set().");
2099 #endif
2100 }
2101
2102 void
2103 Perl_hv_eiter_set(pTHX_ HV *hv, HE *eiter) {
2104     struct xpvhv_aux *iter;
2105
2106     PERL_ARGS_ASSERT_HV_EITER_SET;
2107
2108     if (!hv)
2109         Perl_croak(aTHX_ "Bad hash");
2110
2111     if (SvOOK(hv)) {
2112         iter = HvAUX(hv);
2113     } else {
2114         /* 0 is the default so don't go malloc()ing a new structure just to
2115            hold 0.  */
2116         if (!eiter)
2117             return;
2118
2119         iter = hv_auxinit(hv);
2120     }
2121     iter->xhv_eiter = eiter;
2122 }
2123
2124 void
2125 Perl_hv_name_set(pTHX_ HV *hv, const char *name, U32 len, U32 flags)
2126 {
2127     dVAR;
2128     struct xpvhv_aux *iter;
2129     U32 hash;
2130     HEK **spot;
2131
2132     PERL_ARGS_ASSERT_HV_NAME_SET;
2133
2134     if (len > I32_MAX)
2135         Perl_croak(aTHX_ "panic: hv name too long (%"UVuf")", (UV) len);
2136
2137     if (SvOOK(hv)) {
2138         iter = HvAUX(hv);
2139         if (iter->xhv_name_u.xhvnameu_name) {
2140             if(iter->xhv_name_count) {
2141               if(flags & HV_NAME_SETALL) {
2142                 HEK ** const name = HvAUX(hv)->xhv_name_u.xhvnameu_names;
2143                 HEK **hekp = name + (
2144                     iter->xhv_name_count < 0
2145                      ? -iter->xhv_name_count
2146                      :  iter->xhv_name_count
2147                    );
2148                 while(hekp-- > name+1)
2149                     unshare_hek_or_pvn(*hekp, 0, 0, 0);
2150                 /* The first elem may be null. */
2151                 if(*name) unshare_hek_or_pvn(*name, 0, 0, 0);
2152                 Safefree(name);
2153                 spot = &iter->xhv_name_u.xhvnameu_name;
2154                 iter->xhv_name_count = 0;
2155               }
2156               else {
2157                 if(iter->xhv_name_count > 0) {
2158                     /* shift some things over */
2159                     Renew(
2160                      iter->xhv_name_u.xhvnameu_names, iter->xhv_name_count + 1, HEK *
2161                     );
2162                     spot = iter->xhv_name_u.xhvnameu_names;
2163                     spot[iter->xhv_name_count] = spot[1];
2164                     spot[1] = spot[0];
2165                     iter->xhv_name_count = -(iter->xhv_name_count + 1);
2166                 }
2167                 else if(*(spot = iter->xhv_name_u.xhvnameu_names)) {
2168                     unshare_hek_or_pvn(*spot, 0, 0, 0);
2169                 }
2170               }
2171             }
2172             else if (flags & HV_NAME_SETALL) {
2173                 unshare_hek_or_pvn(iter->xhv_name_u.xhvnameu_name, 0, 0, 0);
2174                 spot = &iter->xhv_name_u.xhvnameu_name;
2175             }
2176             else {
2177                 HEK * const existing_name = iter->xhv_name_u.xhvnameu_name;
2178                 Newx(iter->xhv_name_u.xhvnameu_names, 2, HEK *);
2179                 iter->xhv_name_count = -2;
2180                 spot = iter->xhv_name_u.xhvnameu_names;
2181                 spot[1] = existing_name;
2182             }
2183         }
2184         else { spot = &iter->xhv_name_u.xhvnameu_name; iter->xhv_name_count = 0; }
2185     } else {
2186         if (name == 0)
2187             return;
2188
2189         iter = hv_auxinit(hv);
2190         spot = &iter->xhv_name_u.xhvnameu_name;
2191     }
2192     PERL_HASH(hash, name, len);
2193     *spot = name ? share_hek(name, flags & SVf_UTF8 ? -(I32)len : (I32)len, hash) : NULL;
2194 }
2195
2196 /*
2197 This is basically sv_eq_flags() in sv.c, but we avoid the magic
2198 and bytes checking.
2199 */
2200
2201 STATIC I32
2202 hek_eq_pvn_flags(pTHX_ const HEK *hek, const char* pv, const I32 pvlen, const U32 flags) {
2203     if ( (HEK_UTF8(hek) ? 1 : 0) != (flags & SVf_UTF8 ? 1 : 0) ) {
2204         if (flags & SVf_UTF8)
2205             return (bytes_cmp_utf8(
2206                         (const U8*)HEK_KEY(hek), HEK_LEN(hek),
2207                         (const U8*)pv, pvlen) == 0);
2208         else
2209             return (bytes_cmp_utf8(
2210                         (const U8*)pv, pvlen,
2211                         (const U8*)HEK_KEY(hek), HEK_LEN(hek)) == 0);
2212     }
2213     else
2214         return HEK_LEN(hek) == pvlen && ((HEK_KEY(hek) == pv)
2215                     || memEQ(HEK_KEY(hek), pv, pvlen));
2216 }
2217
2218 /*
2219 =for apidoc hv_ename_add
2220
2221 Adds a name to a stash's internal list of effective names.  See
2222 C<hv_ename_delete>.
2223
2224 This is called when a stash is assigned to a new location in the symbol
2225 table.
2226
2227 =cut
2228 */
2229
2230 void
2231 Perl_hv_ename_add(pTHX_ HV *hv, const char *name, U32 len, U32 flags)
2232 {
2233     dVAR;
2234     struct xpvhv_aux *aux = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
2235     U32 hash;
2236
2237     PERL_ARGS_ASSERT_HV_ENAME_ADD;
2238
2239     if (len > I32_MAX)
2240         Perl_croak(aTHX_ "panic: hv name too long (%"UVuf")", (UV) len);
2241
2242     PERL_HASH(hash, name, len);
2243
2244     if (aux->xhv_name_count) {
2245         HEK ** const xhv_name = aux->xhv_name_u.xhvnameu_names;
2246         I32 count = aux->xhv_name_count;
2247         HEK **hekp = xhv_name + (count < 0 ? -count : count);
2248         while (hekp-- > xhv_name)
2249             if (
2250                  (HEK_UTF8(*hekp) || (flags & SVf_UTF8))
2251                     ? hek_eq_pvn_flags(aTHX_ *hekp, name, (I32)len, flags)
2252                     : (HEK_LEN(*hekp) == (I32)len && memEQ(HEK_KEY(*hekp), name, len))
2253                ) {
2254                 if (hekp == xhv_name && count < 0)
2255                     aux->xhv_name_count = -count;
2256                 return;
2257             }
2258         if (count < 0) aux->xhv_name_count--, count = -count;
2259         else aux->xhv_name_count++;
2260         Renew(aux->xhv_name_u.xhvnameu_names, count + 1, HEK *);
2261         (aux->xhv_name_u.xhvnameu_names)[count] = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash);
2262     }
2263     else {
2264         HEK *existing_name = aux->xhv_name_u.xhvnameu_name;
2265         if (
2266             existing_name && (
2267              (HEK_UTF8(existing_name) || (flags & SVf_UTF8))
2268                 ? hek_eq_pvn_flags(aTHX_ existing_name, name, (I32)len, flags)
2269                 : (HEK_LEN(existing_name) == (I32)len && memEQ(HEK_KEY(existing_name), name, len))
2270             )
2271         ) return;
2272         Newx(aux->xhv_name_u.xhvnameu_names, 2, HEK *);
2273         aux->xhv_name_count = existing_name ? 2 : -2;
2274         *aux->xhv_name_u.xhvnameu_names = existing_name;
2275         (aux->xhv_name_u.xhvnameu_names)[1] = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash);
2276     }
2277 }
2278
2279 /*
2280 =for apidoc hv_ename_delete
2281
2282 Removes a name from a stash's internal list of effective names.  If this is
2283 the name returned by C<HvENAME>, then another name in the list will take
2284 its place (C<HvENAME> will use it).
2285
2286 This is called when a stash is deleted from the symbol table.
2287
2288 =cut
2289 */
2290
2291 void
2292 Perl_hv_ename_delete(pTHX_ HV *hv, const char *name, U32 len, U32 flags)
2293 {
2294     dVAR;
2295     struct xpvhv_aux *aux;
2296
2297     PERL_ARGS_ASSERT_HV_ENAME_DELETE;
2298
2299     if (len > I32_MAX)
2300         Perl_croak(aTHX_ "panic: hv name too long (%"UVuf")", (UV) len);
2301
2302     if (!SvOOK(hv)) return;
2303
2304     aux = HvAUX(hv);
2305     if (!aux->xhv_name_u.xhvnameu_name) return;
2306
2307     if (aux->xhv_name_count) {
2308         HEK ** const namep = aux->xhv_name_u.xhvnameu_names;
2309         I32 const count = aux->xhv_name_count;
2310         HEK **victim = namep + (count < 0 ? -count : count);
2311         while (victim-- > namep + 1)
2312             if (
2313              (HEK_UTF8(*victim) || (flags & SVf_UTF8))
2314                 ? hek_eq_pvn_flags(aTHX_ *victim, name, (I32)len, flags)
2315                 : (HEK_LEN(*victim) == (I32)len && memEQ(HEK_KEY(*victim), name, len))
2316             ) {
2317                 unshare_hek_or_pvn(*victim, 0, 0, 0);
2318                 if (count < 0) ++aux->xhv_name_count;
2319                 else --aux->xhv_name_count;
2320                 if (
2321                     (aux->xhv_name_count == 1 || aux->xhv_name_count == -1)
2322                  && !*namep
2323                 ) {  /* if there are none left */
2324                     Safefree(namep);
2325                     aux->xhv_name_u.xhvnameu_names = NULL;
2326                     aux->xhv_name_count = 0;
2327                 }
2328                 else {
2329                     /* Move the last one back to fill the empty slot. It
2330                        does not matter what order they are in. */
2331                     *victim = *(namep + (count < 0 ? -count : count) - 1);
2332                 }
2333                 return;
2334             }
2335         if (
2336             count > 0 && (HEK_UTF8(*namep) || (flags & SVf_UTF8))
2337                 ? hek_eq_pvn_flags(aTHX_ *namep, name, (I32)len, flags)
2338                 : (HEK_LEN(*namep) == (I32)len && memEQ(HEK_KEY(*namep), name, len))
2339         ) {
2340             aux->xhv_name_count = -count;
2341         }
2342     }
2343     else if(
2344         (HEK_UTF8(aux->xhv_name_u.xhvnameu_name) || (flags & SVf_UTF8))
2345                 ? hek_eq_pvn_flags(aTHX_ aux->xhv_name_u.xhvnameu_name, name, (I32)len, flags)
2346                 : (HEK_LEN(aux->xhv_name_u.xhvnameu_name) == (I32)len &&
2347                             memEQ(HEK_KEY(aux->xhv_name_u.xhvnameu_name), name, len))
2348     ) {
2349         HEK * const namehek = aux->xhv_name_u.xhvnameu_name;
2350         Newx(aux->xhv_name_u.xhvnameu_names, 1, HEK *);
2351         *aux->xhv_name_u.xhvnameu_names = namehek;
2352         aux->xhv_name_count = -1;
2353     }
2354 }
2355
2356 AV **
2357 Perl_hv_backreferences_p(pTHX_ HV *hv) {
2358     struct xpvhv_aux * const iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
2359
2360     PERL_ARGS_ASSERT_HV_BACKREFERENCES_P;
2361     PERL_UNUSED_CONTEXT;
2362
2363     return &(iter->xhv_backreferences);
2364 }
2365
2366 void
2367 Perl_hv_kill_backrefs(pTHX_ HV *hv) {
2368     AV *av;
2369
2370     PERL_ARGS_ASSERT_HV_KILL_BACKREFS;
2371
2372     if (!SvOOK(hv))
2373         return;
2374
2375     av = HvAUX(hv)->xhv_backreferences;
2376
2377     if (av) {
2378         HvAUX(hv)->xhv_backreferences = 0;
2379         Perl_sv_kill_backrefs(aTHX_ MUTABLE_SV(hv), av);
2380         if (SvTYPE(av) == SVt_PVAV)
2381             SvREFCNT_dec_NN(av);
2382     }
2383 }
2384
2385 /*
2386 hv_iternext is implemented as a macro in hv.h
2387
2388 =for apidoc hv_iternext
2389
2390 Returns entries from a hash iterator.  See C<hv_iterinit>.
2391
2392 You may call C<hv_delete> or C<hv_delete_ent> on the hash entry that the
2393 iterator currently points to, without losing your place or invalidating your
2394 iterator.  Note that in this case the current entry is deleted from the hash
2395 with your iterator holding the last reference to it.  Your iterator is flagged
2396 to free the entry on the next call to C<hv_iternext>, so you must not discard
2397 your iterator immediately else the entry will leak - call C<hv_iternext> to
2398 trigger the resource deallocation.
2399
2400 =for apidoc hv_iternext_flags
2401
2402 Returns entries from a hash iterator.  See C<hv_iterinit> and C<hv_iternext>.
2403 The C<flags> value will normally be zero; if HV_ITERNEXT_WANTPLACEHOLDERS is
2404 set the placeholders keys (for restricted hashes) will be returned in addition
2405 to normal keys. By default placeholders are automatically skipped over.
2406 Currently a placeholder is implemented with a value that is
2407 C<&PL_sv_placeholder>.  Note that the implementation of placeholders and
2408 restricted hashes may change, and the implementation currently is
2409 insufficiently abstracted for any change to be tidy.
2410
2411 =cut
2412 */
2413
2414 HE *
2415 Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags)
2416 {
2417     dVAR;
2418     XPVHV* xhv;
2419     HE *entry;
2420     HE *oldentry;
2421     MAGIC* mg;
2422     struct xpvhv_aux *iter;
2423
2424     PERL_ARGS_ASSERT_HV_ITERNEXT_FLAGS;
2425
2426     if (!hv)
2427         Perl_croak(aTHX_ "Bad hash");
2428
2429     xhv = (XPVHV*)SvANY(hv);
2430
2431     if (!SvOOK(hv)) {
2432         /* Too many things (well, pp_each at least) merrily assume that you can
2433            call hv_iternext without calling hv_iterinit, so we'll have to deal
2434            with it.  */
2435         hv_iterinit(hv);
2436     }
2437     iter = HvAUX(hv);
2438
2439     oldentry = entry = iter->xhv_eiter; /* HvEITER(hv) */
2440     if (SvMAGICAL(hv) && SvRMAGICAL(hv)) {
2441         if ( ( mg = mg_find((const SV *)hv, PERL_MAGIC_tied) ) ) {
2442             SV * const key = sv_newmortal();
2443             if (entry) {
2444                 sv_setsv(key, HeSVKEY_force(entry));
2445                 SvREFCNT_dec(HeSVKEY(entry));       /* get rid of previous key */
2446                 HeSVKEY_set(entry, NULL);
2447             }
2448             else {
2449                 char *k;
2450                 HEK *hek;
2451
2452                 /* one HE per MAGICAL hash */
2453                 iter->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */
2454                 HvLAZYDEL_on(hv); /* make sure entry gets freed */
2455                 Zero(entry, 1, HE);
2456                 Newxz(k, HEK_BASESIZE + sizeof(const SV *), char);
2457                 hek = (HEK*)k;
2458                 HeKEY_hek(entry) = hek;
2459                 HeKLEN(entry) = HEf_SVKEY;
2460             }
2461             magic_nextpack(MUTABLE_SV(hv),mg,key);
2462             if (SvOK(key)) {
2463                 /* force key to stay around until next time */
2464                 HeSVKEY_set(entry, SvREFCNT_inc_simple_NN(key));
2465                 return entry;               /* beware, hent_val is not set */
2466             }
2467             SvREFCNT_dec(HeVAL(entry));
2468             Safefree(HeKEY_hek(entry));
2469             del_HE(entry);
2470             iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
2471             HvLAZYDEL_off(hv);
2472             return NULL;
2473         }
2474     }
2475 #if defined(DYNAMIC_ENV_FETCH) && !defined(__riscos__)  /* set up %ENV for iteration */
2476     if (!entry && SvRMAGICAL((const SV *)hv)
2477         && mg_find((const SV *)hv, PERL_MAGIC_env)) {
2478         prime_env_iter();
2479 #ifdef VMS
2480         /* The prime_env_iter() on VMS just loaded up new hash values
2481          * so the iteration count needs to be reset back to the beginning
2482          */
2483         hv_iterinit(hv);
2484         iter = HvAUX(hv);
2485         oldentry = entry = iter->xhv_eiter; /* HvEITER(hv) */
2486 #endif
2487     }
2488 #endif
2489
2490     /* hv_iterinit now ensures this.  */
2491     assert (HvARRAY(hv));
2492
2493     /* At start of hash, entry is NULL.  */
2494     if (entry)
2495     {
2496         entry = HeNEXT(entry);
2497         if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
2498             /*
2499              * Skip past any placeholders -- don't want to include them in
2500              * any iteration.
2501              */
2502             while (entry && HeVAL(entry) == &PL_sv_placeholder) {
2503                 entry = HeNEXT(entry);
2504             }
2505         }
2506     }
2507
2508 #ifdef PERL_HASH_RANDOMIZE_KEYS
2509     if (iter->xhv_last_rand != iter->xhv_rand) {
2510         if (iter->xhv_riter != -1) {
2511             Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
2512                              "Use of each() on hash after insertion without resetting hash iterator results in undefined behavior"
2513                              pTHX__FORMAT
2514                              pTHX__VALUE);
2515         }
2516         iter->xhv_last_rand = iter->xhv_rand;
2517     }
2518 #endif
2519
2520     /* Skip the entire loop if the hash is empty.   */
2521     if ((flags & HV_ITERNEXT_WANTPLACEHOLDERS)
2522         ? HvTOTALKEYS(hv) : HvUSEDKEYS(hv)) {
2523         while (!entry) {
2524             /* OK. Come to the end of the current list.  Grab the next one.  */
2525
2526             iter->xhv_riter++; /* HvRITER(hv)++ */
2527             if (iter->xhv_riter > (I32)xhv->xhv_max /* HvRITER(hv) > HvMAX(hv) */) {
2528                 /* There is no next one.  End of the hash.  */
2529                 iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
2530 #ifdef PERL_HASH_RANDOMIZE_KEYS
2531                 iter->xhv_last_rand = iter->xhv_rand; /* reset xhv_last_rand so we can detect inserts during traversal */
2532 #endif
2533                 break;
2534             }
2535             entry = (HvARRAY(hv))[ PERL_HASH_ITER_BUCKET(iter) & xhv->xhv_max ];
2536
2537             if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
2538                 /* If we have an entry, but it's a placeholder, don't count it.
2539                    Try the next.  */
2540                 while (entry && HeVAL(entry) == &PL_sv_placeholder)
2541                     entry = HeNEXT(entry);
2542             }
2543             /* Will loop again if this linked list starts NULL
2544                (for HV_ITERNEXT_WANTPLACEHOLDERS)
2545                or if we run through it and find only placeholders.  */
2546         }
2547     }
2548     else {
2549         iter->xhv_riter = -1;
2550 #ifdef PERL_HASH_RANDOMIZE_KEYS
2551         iter->xhv_last_rand = iter->xhv_rand;
2552 #endif
2553     }
2554
2555     if (oldentry && HvLAZYDEL(hv)) {            /* was deleted earlier? */
2556         HvLAZYDEL_off(hv);
2557         hv_free_ent(hv, oldentry);
2558     }
2559
2560     iter->xhv_eiter = entry; /* HvEITER(hv) = entry */
2561     return entry;
2562 }
2563
2564 /*
2565 =for apidoc hv_iterkey
2566
2567 Returns the key from the current position of the hash iterator.  See
2568 C<hv_iterinit>.
2569
2570 =cut
2571 */
2572
2573 char *
2574 Perl_hv_iterkey(pTHX_ HE *entry, I32 *retlen)
2575 {
2576     PERL_ARGS_ASSERT_HV_ITERKEY;
2577
2578     if (HeKLEN(entry) == HEf_SVKEY) {
2579         STRLEN len;
2580         char * const p = SvPV(HeKEY_sv(entry), len);
2581         *retlen = len;
2582         return p;
2583     }
2584     else {
2585         *retlen = HeKLEN(entry);
2586         return HeKEY(entry);
2587     }
2588 }
2589
2590 /* unlike hv_iterval(), this always returns a mortal copy of the key */
2591 /*
2592 =for apidoc hv_iterkeysv
2593
2594 Returns the key as an C<SV*> from the current position of the hash
2595 iterator.  The return value will always be a mortal copy of the key.  Also
2596 see C<hv_iterinit>.
2597
2598 =cut
2599 */
2600
2601 SV *
2602 Perl_hv_iterkeysv(pTHX_ HE *entry)
2603 {
2604     PERL_ARGS_ASSERT_HV_ITERKEYSV;
2605
2606     return sv_2mortal(newSVhek(HeKEY_hek(entry)));
2607 }
2608
2609 /*
2610 =for apidoc hv_iterval
2611
2612 Returns the value from the current position of the hash iterator.  See
2613 C<hv_iterkey>.
2614
2615 =cut
2616 */
2617
2618 SV *
2619 Perl_hv_iterval(pTHX_ HV *hv, HE *entry)
2620 {
2621     PERL_ARGS_ASSERT_HV_ITERVAL;
2622
2623     if (SvRMAGICAL(hv)) {
2624         if (mg_find((const SV *)hv, PERL_MAGIC_tied)) {
2625             SV* const sv = sv_newmortal();
2626             if (HeKLEN(entry) == HEf_SVKEY)
2627                 mg_copy(MUTABLE_SV(hv), sv, (char*)HeKEY_sv(entry), HEf_SVKEY);
2628             else
2629                 mg_copy(MUTABLE_SV(hv), sv, HeKEY(entry), HeKLEN(entry));
2630             return sv;
2631         }
2632     }
2633     return HeVAL(entry);
2634 }
2635
2636 /*
2637 =for apidoc hv_iternextsv
2638
2639 Performs an C<hv_iternext>, C<hv_iterkey>, and C<hv_iterval> in one
2640 operation.
2641
2642 =cut
2643 */
2644
2645 SV *
2646 Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen)
2647 {
2648     HE * const he = hv_iternext_flags(hv, 0);
2649
2650     PERL_ARGS_ASSERT_HV_ITERNEXTSV;
2651
2652     if (!he)
2653         return NULL;
2654     *key = hv_iterkey(he, retlen);
2655     return hv_iterval(hv, he);
2656 }
2657
2658 /*
2659
2660 Now a macro in hv.h
2661
2662 =for apidoc hv_magic
2663
2664 Adds magic to a hash.  See C<sv_magic>.
2665
2666 =cut
2667 */
2668
2669 /* possibly free a shared string if no one has access to it
2670  * len and hash must both be valid for str.
2671  */
2672 void
2673 Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
2674 {
2675     unshare_hek_or_pvn (NULL, str, len, hash);
2676 }
2677
2678
2679 void
2680 Perl_unshare_hek(pTHX_ HEK *hek)
2681 {
2682     assert(hek);
2683     unshare_hek_or_pvn(hek, NULL, 0, 0);
2684 }
2685
2686 /* possibly free a shared string if no one has access to it
2687    hek if non-NULL takes priority over the other 3, else str, len and hash
2688    are used.  If so, len and hash must both be valid for str.
2689  */
2690 STATIC void
2691 S_unshare_hek_or_pvn(pTHX_ const HEK *hek, const char *str, I32 len, U32 hash)
2692 {
2693     dVAR;
2694     XPVHV* xhv;
2695     HE *entry;
2696     HE **oentry;
2697     bool is_utf8 = FALSE;
2698     int k_flags = 0;
2699     const char * const save = str;
2700     struct shared_he *he = NULL;
2701
2702     if (hek) {
2703         /* Find the shared he which is just before us in memory.  */
2704         he = (struct shared_he *)(((char *)hek)
2705                                   - STRUCT_OFFSET(struct shared_he,
2706                                                   shared_he_hek));
2707
2708         /* Assert that the caller passed us a genuine (or at least consistent)
2709            shared hek  */
2710         assert (he->shared_he_he.hent_hek == hek);
2711
2712         if (he->shared_he_he.he_valu.hent_refcount - 1) {
2713             --he->shared_he_he.he_valu.hent_refcount;
2714             return;
2715         }
2716
2717         hash = HEK_HASH(hek);
2718     } else if (len < 0) {
2719         STRLEN tmplen = -len;
2720         is_utf8 = TRUE;
2721         /* See the note in hv_fetch(). --jhi */
2722         str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2723         len = tmplen;
2724         if (is_utf8)
2725             k_flags = HVhek_UTF8;
2726         if (str != save)
2727             k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2728     }
2729
2730     /* what follows was the moral equivalent of:
2731     if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) {
2732         if (--*Svp == NULL)
2733             hv_delete(PL_strtab, str, len, G_DISCARD, hash);
2734     } */
2735     xhv = (XPVHV*)SvANY(PL_strtab);
2736     /* assert(xhv_array != 0) */
2737     oentry = &(HvARRAY(PL_strtab))[hash & (I32) HvMAX(PL_strtab)];
2738     if (he) {
2739         const HE *const he_he = &(he->shared_he_he);
2740         for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) {
2741             if (entry == he_he)
2742                 break;
2743         }
2744     } else {
2745         const int flags_masked = k_flags & HVhek_MASK;
2746         for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) {
2747             if (HeHASH(entry) != hash)          /* strings can't be equal */
2748                 continue;
2749             if (HeKLEN(entry) != len)
2750                 continue;
2751             if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len))     /* is this it? */
2752                 continue;
2753             if (HeKFLAGS(entry) != flags_masked)
2754                 continue;
2755             break;
2756         }
2757     }
2758
2759     if (entry) {
2760         if (--entry->he_valu.hent_refcount == 0) {
2761             *oentry = HeNEXT(entry);
2762             Safefree(entry);
2763             xhv->xhv_keys--; /* HvTOTALKEYS(hv)-- */
2764         }
2765     }
2766
2767     if (!entry)
2768         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
2769                          "Attempt to free nonexistent shared string '%s'%s"
2770                          pTHX__FORMAT,
2771                          hek ? HEK_KEY(hek) : str,
2772                          ((k_flags & HVhek_UTF8) ? " (utf8)" : "") pTHX__VALUE);
2773     if (k_flags & HVhek_FREEKEY)
2774         Safefree(str);
2775 }
2776
2777 /* get a (constant) string ptr from the global string table
2778  * string will get added if it is not already there.
2779  * len and hash must both be valid for str.
2780  */
2781 HEK *
2782 Perl_share_hek(pTHX_ const char *str, I32 len, U32 hash)
2783 {
2784     bool is_utf8 = FALSE;
2785     int flags = 0;
2786     const char * const save = str;
2787
2788     PERL_ARGS_ASSERT_SHARE_HEK;
2789
2790     if (len < 0) {
2791       STRLEN tmplen = -len;
2792       is_utf8 = TRUE;
2793       /* See the note in hv_fetch(). --jhi */
2794       str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2795       len = tmplen;
2796       /* If we were able to downgrade here, then than means that we were passed
2797          in a key which only had chars 0-255, but was utf8 encoded.  */
2798       if (is_utf8)
2799           flags = HVhek_UTF8;
2800       /* If we found we were able to downgrade the string to bytes, then
2801          we should flag that it needs upgrading on keys or each.  Also flag
2802          that we need share_hek_flags to free the string.  */
2803       if (str != save) {
2804           dVAR;
2805           PERL_HASH(hash, str, len);
2806           flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2807       }
2808     }
2809
2810     return share_hek_flags (str, len, hash, flags);
2811 }
2812
2813 STATIC HEK *
2814 S_share_hek_flags(pTHX_ const char *str, I32 len, U32 hash, int flags)
2815 {
2816     dVAR;
2817     HE *entry;
2818     const int flags_masked = flags & HVhek_MASK;
2819     const U32 hindex = hash & (I32) HvMAX(PL_strtab);
2820     XPVHV * const xhv = (XPVHV*)SvANY(PL_strtab);
2821
2822     PERL_ARGS_ASSERT_SHARE_HEK_FLAGS;
2823
2824     /* what follows is the moral equivalent of:
2825
2826     if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
2827         hv_store(PL_strtab, str, len, NULL, hash);
2828
2829         Can't rehash the shared string table, so not sure if it's worth
2830         counting the number of entries in the linked list
2831     */
2832
2833     /* assert(xhv_array != 0) */
2834     entry = (HvARRAY(PL_strtab))[hindex];
2835     for (;entry; entry = HeNEXT(entry)) {
2836         if (HeHASH(entry) != hash)              /* strings can't be equal */
2837             continue;
2838         if (HeKLEN(entry) != len)
2839             continue;
2840         if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
2841             continue;
2842         if (HeKFLAGS(entry) != flags_masked)
2843             continue;
2844         break;
2845     }
2846
2847     if (!entry) {
2848         /* What used to be head of the list.
2849            If this is NULL, then we're the first entry for this slot, which
2850            means we need to increate fill.  */
2851         struct shared_he *new_entry;
2852         HEK *hek;
2853         char *k;
2854         HE **const head = &HvARRAY(PL_strtab)[hindex];
2855         HE *const next = *head;
2856
2857         /* We don't actually store a HE from the arena and a regular HEK.
2858            Instead we allocate one chunk of memory big enough for both,
2859            and put the HEK straight after the HE. This way we can find the
2860            HE directly from the HEK.
2861         */
2862
2863         Newx(k, STRUCT_OFFSET(struct shared_he,
2864                                 shared_he_hek.hek_key[0]) + len + 2, char);
2865         new_entry = (struct shared_he *)k;
2866         entry = &(new_entry->shared_he_he);
2867         hek = &(new_entry->shared_he_hek);
2868
2869         Copy(str, HEK_KEY(hek), len, char);
2870         HEK_KEY(hek)[len] = 0;
2871         HEK_LEN(hek) = len;
2872         HEK_HASH(hek) = hash;
2873         HEK_FLAGS(hek) = (unsigned char)flags_masked;
2874
2875         /* Still "point" to the HEK, so that other code need not know what
2876            we're up to.  */
2877         HeKEY_hek(entry) = hek;
2878         entry->he_valu.hent_refcount = 0;
2879         HeNEXT(entry) = next;
2880         *head = entry;
2881
2882         xhv->xhv_keys++; /* HvTOTALKEYS(hv)++ */
2883         if (!next) {                    /* initial entry? */
2884         } else if ( DO_HSPLIT(xhv) ) {
2885             const STRLEN oldsize = xhv->xhv_max + 1;
2886             hsplit(PL_strtab, oldsize, oldsize * 2);
2887         }
2888     }
2889
2890     ++entry->he_valu.hent_refcount;
2891
2892     if (flags & HVhek_FREEKEY)
2893         Safefree(str);
2894
2895     return HeKEY_hek(entry);
2896 }
2897
2898 SSize_t *
2899 Perl_hv_placeholders_p(pTHX_ HV *hv)
2900 {
2901     dVAR;
2902     MAGIC *mg = mg_find((const SV *)hv, PERL_MAGIC_rhash);
2903
2904     PERL_ARGS_ASSERT_HV_PLACEHOLDERS_P;
2905
2906     if (!mg) {
2907         mg = sv_magicext(MUTABLE_SV(hv), 0, PERL_MAGIC_rhash, 0, 0, 0);
2908
2909         if (!mg) {
2910             Perl_die(aTHX_ "panic: hv_placeholders_p");
2911         }
2912     }
2913     return &(mg->mg_len);
2914 }
2915
2916
2917 I32
2918 Perl_hv_placeholders_get(pTHX_ const HV *hv)
2919 {
2920     dVAR;
2921     MAGIC * const mg = mg_find((const SV *)hv, PERL_MAGIC_rhash);
2922
2923     PERL_ARGS_ASSERT_HV_PLACEHOLDERS_GET;
2924
2925     return mg ? mg->mg_len : 0;
2926 }
2927
2928 void
2929 Perl_hv_placeholders_set(pTHX_ HV *hv, I32 ph)
2930 {
2931     dVAR;
2932     MAGIC * const mg = mg_find((const SV *)hv, PERL_MAGIC_rhash);
2933
2934     PERL_ARGS_ASSERT_HV_PLACEHOLDERS_SET;
2935
2936     if (mg) {
2937         mg->mg_len = ph;
2938     } else if (ph) {
2939         if (!sv_magicext(MUTABLE_SV(hv), 0, PERL_MAGIC_rhash, 0, 0, ph))
2940             Perl_die(aTHX_ "panic: hv_placeholders_set");
2941     }
2942     /* else we don't need to add magic to record 0 placeholders.  */
2943 }
2944
2945 STATIC SV *
2946 S_refcounted_he_value(pTHX_ const struct refcounted_he *he)
2947 {
2948     dVAR;
2949     SV *value;
2950
2951     PERL_ARGS_ASSERT_REFCOUNTED_HE_VALUE;
2952
2953     switch(he->refcounted_he_data[0] & HVrhek_typemask) {
2954     case HVrhek_undef:
2955         value = newSV(0);
2956         break;
2957     case HVrhek_delete:
2958         value = &PL_sv_placeholder;
2959         break;
2960     case HVrhek_IV:
2961         value = newSViv(he->refcounted_he_val.refcounted_he_u_iv);
2962         break;
2963     case HVrhek_UV:
2964         value = newSVuv(he->refcounted_he_val.refcounted_he_u_uv);
2965         break;
2966     case HVrhek_PV:
2967     case HVrhek_PV_UTF8:
2968         /* Create a string SV that directly points to the bytes in our
2969            structure.  */
2970         value = newSV_type(SVt_PV);
2971         SvPV_set(value, (char *) he->refcounted_he_data + 1);
2972         SvCUR_set(value, he->refcounted_he_val.refcounted_he_u_len);
2973         /* This stops anything trying to free it  */
2974         SvLEN_set(value, 0);
2975         SvPOK_on(value);
2976         SvREADONLY_on(value);
2977         if ((he->refcounted_he_data[0] & HVrhek_typemask) == HVrhek_PV_UTF8)
2978             SvUTF8_on(value);
2979         break;
2980     default:
2981         Perl_croak(aTHX_ "panic: refcounted_he_value bad flags %"UVxf,
2982                    (UV)he->refcounted_he_data[0]);
2983     }
2984     return value;
2985 }
2986
2987 /*
2988 =for apidoc m|HV *|refcounted_he_chain_2hv|const struct refcounted_he *c|U32 flags
2989
2990 Generates and returns a C<HV *> representing the content of a
2991 C<refcounted_he> chain.
2992 I<flags> is currently unused and must be zero.
2993
2994 =cut
2995 */
2996 HV *
2997 Perl_refcounted_he_chain_2hv(pTHX_ const struct refcounted_he *chain, U32 flags)
2998 {
2999     dVAR;
3000     HV *hv;
3001     U32 placeholders, max;
3002
3003     if (flags)
3004         Perl_croak(aTHX_ "panic: refcounted_he_chain_2hv bad flags %"UVxf,
3005             (UV)flags);
3006
3007     /* We could chase the chain once to get an idea of the number of keys,
3008        and call ksplit.  But for now we'll make a potentially inefficient
3009        hash with only 8 entries in its array.  */
3010     hv = newHV();
3011     max = HvMAX(hv);
3012     if (!HvARRAY(hv)) {
3013         char *array;
3014         Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(max + 1), char);
3015         HvARRAY(hv) = (HE**)array;
3016     }
3017
3018     placeholders = 0;
3019     while (chain) {
3020 #ifdef USE_ITHREADS
3021         U32 hash = chain->refcounted_he_hash;
3022 #else
3023         U32 hash = HEK_HASH(chain->refcounted_he_hek);
3024 #endif
3025         HE **oentry = &((HvARRAY(hv))[hash & max]);
3026         HE *entry = *oentry;
3027         SV *value;
3028
3029         for (; entry; entry = HeNEXT(entry)) {
3030             if (HeHASH(entry) == hash) {
3031                 /* We might have a duplicate key here.  If so, entry is older
3032                    than the key we've already put in the hash, so if they are
3033                    the same, skip adding entry.  */
3034 #ifdef USE_ITHREADS
3035                 const STRLEN klen = HeKLEN(entry);
3036                 const char *const key = HeKEY(entry);
3037                 if (klen == chain->refcounted_he_keylen
3038                     && (!!HeKUTF8(entry)
3039                         == !!(chain->refcounted_he_data[0] & HVhek_UTF8))
3040                     && memEQ(key, REF_HE_KEY(chain), klen))
3041                     goto next_please;
3042 #else
3043                 if (HeKEY_hek(entry) == chain->refcounted_he_hek)
3044                     goto next_please;
3045                 if (HeKLEN(entry) == HEK_LEN(chain->refcounted_he_hek)
3046                     && HeKUTF8(entry) == HEK_UTF8(chain->refcounted_he_hek)
3047                     && memEQ(HeKEY(entry), HEK_KEY(chain->refcounted_he_hek),
3048                              HeKLEN(entry)))
3049                     goto next_please;
3050 #endif
3051             }
3052         }
3053         assert (!entry);
3054         entry = new_HE();
3055
3056 #ifdef USE_ITHREADS
3057         HeKEY_hek(entry)
3058             = share_hek_flags(REF_HE_KEY(chain),
3059                               chain->refcounted_he_keylen,
3060                               chain->refcounted_he_hash,
3061                               (chain->refcounted_he_data[0]
3062                                & (HVhek_UTF8|HVhek_WASUTF8)));
3063 #else
3064         HeKEY_hek(entry) = share_hek_hek(chain->refcounted_he_hek);
3065 #endif
3066         value = refcounted_he_value(chain);
3067         if (value == &PL_sv_placeholder)
3068             placeholders++;
3069         HeVAL(entry) = value;
3070
3071         /* Link it into the chain.  */
3072         HeNEXT(entry) = *oentry;
3073         *oentry = entry;
3074
3075         HvTOTALKEYS(hv)++;
3076
3077     next_please:
3078         chain = chain->refcounted_he_next;
3079     }
3080
3081     if (placeholders) {
3082         clear_placeholders(hv, placeholders);
3083         HvTOTALKEYS(hv) -= placeholders;
3084     }
3085
3086     /* We could check in the loop to see if we encounter any keys with key
3087        flags, but it's probably not worth it, as this per-hash flag is only
3088        really meant as an optimisation for things like Storable.  */
3089     HvHASKFLAGS_on(hv);
3090     DEBUG_A(Perl_hv_assert(aTHX_ hv));
3091
3092     return hv;
3093 }
3094
3095 /*
3096 =for apidoc m|SV *|refcounted_he_fetch_pvn|const struct refcounted_he *chain|const char *keypv|STRLEN keylen|U32 hash|U32 flags
3097
3098 Search along a C<refcounted_he> chain for an entry with the key specified
3099 by I<keypv> and I<keylen>.  If I<flags> has the C<REFCOUNTED_HE_KEY_UTF8>
3100 bit set, the key octets are interpreted as UTF-8, otherwise they
3101 are interpreted as Latin-1.  I<hash> is a precomputed hash of the key
3102 string, or zero if it has not been precomputed.  Returns a mortal scalar
3103 representing the value associated with the key, or C<&PL_sv_placeholder>
3104 if there is no value associated with the key.
3105
3106 =cut
3107 */
3108
3109 SV *
3110 Perl_refcounted_he_fetch_pvn(pTHX_ const struct refcounted_he *chain,
3111                          const char *keypv, STRLEN keylen, U32 hash, U32 flags)
3112 {
3113     dVAR;
3114     U8 utf8_flag;
3115     PERL_ARGS_ASSERT_REFCOUNTED_HE_FETCH_PVN;
3116
3117     if (flags & ~(REFCOUNTED_HE_KEY_UTF8|REFCOUNTED_HE_EXISTS))
3118         Perl_croak(aTHX_ "panic: refcounted_he_fetch_pvn bad flags %"UVxf,
3119             (UV)flags);
3120     if (!chain)
3121         return &PL_sv_placeholder;
3122     if (flags & REFCOUNTED_HE_KEY_UTF8) {
3123         /* For searching purposes, canonicalise to Latin-1 where possible. */
3124         const char *keyend = keypv + keylen, *p;
3125         STRLEN nonascii_count = 0;
3126         for (p = keypv; p != keyend; p++) {
3127             U8 c = (U8)*p;
3128             if (c & 0x80) {
3129                 if (!((c & 0xfe) == 0xc2 && ++p != keyend &&
3130                             (((U8)*p) & 0xc0) == 0x80))
3131                     goto canonicalised_key;
3132                 nonascii_count++;
3133             }
3134         }
3135         if (nonascii_count) {
3136             char *q;
3137             const char *p = keypv, *keyend = keypv + keylen;
3138             keylen -= nonascii_count;
3139             Newx(q, keylen, char);
3140             SAVEFREEPV(q);
3141             keypv = q;
3142             for (; p != keyend; p++, q++) {
3143                 U8 c = (U8)*p;
3144                 *q = (char)
3145                     ((c & 0x80) ? ((c & 0x03) << 6) | (((U8)*++p) & 0x3f) : c);
3146             }
3147         }
3148         flags &= ~REFCOUNTED_HE_KEY_UTF8;
3149         canonicalised_key: ;
3150     }
3151     utf8_flag = (flags & REFCOUNTED_HE_KEY_UTF8) ? HVhek_UTF8 : 0;
3152     if (!hash)
3153         PERL_HASH(hash, keypv, keylen);
3154
3155     for (; chain; chain = chain->refcounted_he_next) {
3156         if (
3157 #ifdef USE_ITHREADS
3158             hash == chain->refcounted_he_hash &&
3159             keylen == chain->refcounted_he_keylen &&
3160             memEQ(REF_HE_KEY(chain), keypv, keylen) &&
3161             utf8_flag == (chain->refcounted_he_data[0] & HVhek_UTF8)
3162 #else
3163             hash == HEK_HASH(chain->refcounted_he_hek) &&
3164             keylen == (STRLEN)HEK_LEN(chain->refcounted_he_hek) &&
3165             memEQ(HEK_KEY(chain->refcounted_he_hek), keypv, keylen) &&
3166             utf8_flag == (HEK_FLAGS(chain->refcounted_he_hek) & HVhek_UTF8)
3167 #endif
3168         ) {
3169             if (flags & REFCOUNTED_HE_EXISTS)
3170                 return (chain->refcounted_he_data[0] & HVrhek_typemask)
3171                     == HVrhek_delete
3172                     ? NULL : &PL_sv_yes;
3173             return sv_2mortal(refcounted_he_value(chain));
3174         }
3175     }
3176     return flags & REFCOUNTED_HE_EXISTS ? NULL : &PL_sv_placeholder;
3177 }
3178
3179 /*
3180 =for apidoc m|SV *|refcounted_he_fetch_pv|const struct refcounted_he *chain|const char *key|U32 hash|U32 flags
3181
3182 Like L</refcounted_he_fetch_pvn>, but takes a nul-terminated string
3183 instead of a string/length pair.
3184
3185 =cut
3186 */
3187
3188 SV *
3189 Perl_refcounted_he_fetch_pv(pTHX_ const struct refcounted_he *chain,
3190                          const char *key, U32 hash, U32 flags)
3191 {
3192     PERL_ARGS_ASSERT_REFCOUNTED_HE_FETCH_PV;
3193     return refcounted_he_fetch_pvn(chain, key, strlen(key), hash, flags);
3194 }
3195
3196 /*
3197 =for apidoc m|SV *|refcounted_he_fetch_sv|const struct refcounted_he *chain|SV *key|U32 hash|U32 flags
3198
3199 Like L</refcounted_he_fetch_pvn>, but takes a Perl scalar instead of a
3200 string/length pair.
3201
3202 =cut
3203 */
3204
3205 SV *
3206 Perl_refcounted_he_fetch_sv(pTHX_ const struct refcounted_he *chain,
3207                          SV *key, U32 hash, U32 flags)
3208 {
3209     const char *keypv;
3210     STRLEN keylen;
3211     PERL_ARGS_ASSERT_REFCOUNTED_HE_FETCH_SV;
3212     if (flags & REFCOUNTED_HE_KEY_UTF8)
3213         Perl_croak(aTHX_ "panic: refcounted_he_fetch_sv bad flags %"UVxf,
3214             (UV)flags);
3215     keypv = SvPV_const(key, keylen);
3216     if (SvUTF8(key))
3217         flags |= REFCOUNTED_HE_KEY_UTF8;
3218     if (!hash && SvIsCOW_shared_hash(key))
3219         hash = SvSHARED_HASH(key);
3220     return refcounted_he_fetch_pvn(chain, keypv, keylen, hash, flags);
3221 }
3222
3223 /*
3224 =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
3225
3226 Creates a new C<refcounted_he>.  This consists of a single key/value
3227 pair and a reference to an existing C<refcounted_he> chain (which may
3228 be empty), and thus forms a longer chain.  When using the longer chain,
3229 the new key/value pair takes precedence over any entry for the same key
3230 further along the chain.
3231
3232 The new key is specified by I<keypv> and I<keylen>.  If I<flags> has
3233 the C<REFCOUNTED_HE_KEY_UTF8> bit set, the key octets are interpreted
3234 as UTF-8, otherwise they are interpreted as Latin-1.  I<hash> is
3235 a precomputed hash of the key string, or zero if it has not been
3236 precomputed.
3237
3238 I<value> is the scalar value to store for this key.  I<value> is copied
3239 by this function, which thus does not take ownership of any reference
3240 to it, and later changes to the scalar will not be reflected in the
3241 value visible in the C<refcounted_he>.  Complex types of scalar will not
3242 be stored with referential integrity, but will be coerced to strings.
3243 I<value> may be either null or C<&PL_sv_placeholder> to indicate that no
3244 value is to be associated with the key; this, as with any non-null value,
3245 takes precedence over the existence of a value for the key further along
3246 the chain.
3247
3248 I<parent> points to the rest of the C<refcounted_he> chain to be
3249 attached to the new C<refcounted_he>.  This function takes ownership
3250 of one reference to I<parent>, and returns one reference to the new
3251 C<refcounted_he>.
3252
3253 =cut
3254 */
3255
3256 struct refcounted_he *
3257 Perl_refcounted_he_new_pvn(pTHX_ struct refcounted_he *parent,
3258         const char *keypv, STRLEN keylen, U32 hash, SV *value, U32 flags)
3259 {
3260     dVAR;
3261     STRLEN value_len = 0;
3262     const char *value_p = NULL;
3263     bool is_pv;
3264     char value_type;
3265     char hekflags;
3266     STRLEN key_offset = 1;
3267     struct refcounted_he *he;
3268     PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_PVN;
3269
3270     if (!value || value == &PL_sv_placeholder) {
3271         value_type = HVrhek_delete;
3272     } else if (SvPOK(value)) {
3273         value_type = HVrhek_PV;
3274     } else if (SvIOK(value)) {
3275         value_type = SvUOK((const SV *)value) ? HVrhek_UV : HVrhek_IV;
3276     } else if (!SvOK(value)) {
3277         value_type = HVrhek_undef;
3278     } else {
3279         value_type = HVrhek_PV;
3280     }
3281     is_pv = value_type == HVrhek_PV;
3282     if (is_pv) {
3283         /* Do it this way so that the SvUTF8() test is after the SvPV, in case
3284            the value is overloaded, and doesn't yet have the UTF-8flag set.  */
3285         value_p = SvPV_const(value, value_len);
3286         if (SvUTF8(value))
3287             value_type = HVrhek_PV_UTF8;
3288         key_offset = value_len + 2;
3289     }
3290     hekflags = value_type;
3291
3292     if (flags & REFCOUNTED_HE_KEY_UTF8) {
3293         /* Canonicalise to Latin-1 where possible. */
3294         const char *keyend = keypv + keylen, *p;
3295         STRLEN nonascii_count = 0;
3296         for (p = keypv; p != keyend; p++) {
3297             U8 c = (U8)*p;
3298             if (c & 0x80) {
3299                 if (!((c & 0xfe) == 0xc2 && ++p != keyend &&
3300                             (((U8)*p) & 0xc0) == 0x80))
3301                     goto canonicalised_key;
3302                 nonascii_count++;
3303             }
3304         }
3305         if (nonascii_count) {
3306             char *q;
3307             const char *p = keypv, *keyend = keypv + keylen;
3308             keylen -= nonascii_count;
3309             Newx(q, keylen, char);
3310             SAVEFREEPV(q);
3311             keypv = q;
3312             for (; p != keyend; p++, q++) {
3313                 U8 c = (U8)*p;
3314                 *q = (char)
3315                     ((c & 0x80) ? ((c & 0x03) << 6) | (((U8)*++p) & 0x3f) : c);
3316             }
3317         }
3318         flags &= ~REFCOUNTED_HE_KEY_UTF8;
3319         canonicalised_key: ;
3320     }
3321     if (flags & REFCOUNTED_HE_KEY_UTF8)
3322         hekflags |= HVhek_UTF8;
3323     if (!hash)
3324         PERL_HASH(hash, keypv, keylen);
3325
3326 #ifdef USE_ITHREADS
3327     he = (struct refcounted_he*)
3328         PerlMemShared_malloc(sizeof(struct refcounted_he) - 1
3329                              + keylen
3330                              + key_offset);
3331 #else
3332     he = (struct refcounted_he*)
3333         PerlMemShared_malloc(sizeof(struct refcounted_he) - 1
3334                              + key_offset);
3335 #endif
3336
3337     he->refcounted_he_next = parent;
3338
3339     if (is_pv) {
3340         Copy(value_p, he->refcounted_he_data + 1, value_len + 1, char);
3341         he->refcounted_he_val.refcounted_he_u_len = value_len;
3342     } else if (value_type == HVrhek_IV) {
3343         he->refcounted_he_val.refcounted_he_u_iv = SvIVX(value);
3344     } else if (value_type == HVrhek_UV) {
3345         he->refcounted_he_val.refcounted_he_u_uv = SvUVX(value);
3346     }
3347
3348 #ifdef USE_ITHREADS
3349     he->refcounted_he_hash = hash;
3350     he->refcounted_he_keylen = keylen;
3351     Copy(keypv, he->refcounted_he_data + key_offset, keylen, char);
3352 #else
3353     he->refcounted_he_hek = share_hek_flags(keypv, keylen, hash, hekflags);
3354 #endif
3355
3356     he->refcounted_he_data[0] = hekflags;
3357     he->refcounted_he_refcnt = 1;
3358
3359     return he;
3360 }
3361
3362 /*
3363 =for apidoc m|struct refcounted_he *|refcounted_he_new_pv|struct refcounted_he *parent|const char *key|U32 hash|SV *value|U32 flags
3364
3365 Like L</refcounted_he_new_pvn>, but takes a nul-terminated string instead
3366 of a string/length pair.
3367
3368 =cut
3369 */
3370
3371 struct refcounted_he *
3372 Perl_refcounted_he_new_pv(pTHX_ struct refcounted_he *parent,
3373         const char *key, U32 hash, SV *value, U32 flags)
3374 {
3375     PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_PV;
3376     return refcounted_he_new_pvn(parent, key, strlen(key), hash, value, flags);
3377 }
3378
3379 /*
3380 =for apidoc m|struct refcounted_he *|refcounted_he_new_sv|struct refcounted_he *parent|SV *key|U32 hash|SV *value|U32 flags
3381
3382 Like L</refcounted_he_new_pvn>, but takes a Perl scalar instead of a
3383 string/length pair.
3384
3385 =cut
3386 */
3387
3388 struct refcounted_he *
3389 Perl_refcounted_he_new_sv(pTHX_ struct refcounted_he *parent,
3390         SV *key, U32 hash, SV *value, U32 flags)
3391 {
3392     const char *keypv;
3393     STRLEN keylen;
3394     PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_SV;
3395     if (flags & REFCOUNTED_HE_KEY_UTF8)
3396         Perl_croak(aTHX_ "panic: refcounted_he_new_sv bad flags %"UVxf,
3397             (UV)flags);
3398     keypv = SvPV_const(key, keylen);
3399     if (SvUTF8(key))
3400         flags |= REFCOUNTED_HE_KEY_UTF8;
3401     if (!hash && SvIsCOW_shared_hash(key))
3402         hash = SvSHARED_HASH(key);
3403     return refcounted_he_new_pvn(parent, keypv, keylen, hash, value, flags);
3404 }
3405
3406 /*
3407 =for apidoc m|void|refcounted_he_free|struct refcounted_he *he
3408
3409 Decrements the reference count of a C<refcounted_he> by one.  If the
3410 reference count reaches zero the structure's memory is freed, which
3411 (recursively) causes a reduction of its parent C<refcounted_he>'s
3412 reference count.  It is safe to pass a null pointer to this function:
3413 no action occurs in this case.
3414
3415 =cut
3416 */
3417
3418 void
3419 Perl_refcounted_he_free(pTHX_ struct refcounted_he *he) {
3420     dVAR;
3421     PERL_UNUSED_CONTEXT;
3422
3423     while (he) {
3424         struct refcounted_he *copy;
3425         U32 new_count;
3426
3427         HINTS_REFCNT_LOCK;
3428         new_count = --he->refcounted_he_refcnt;
3429         HINTS_REFCNT_UNLOCK;
3430
3431         if (new_count) {
3432             return;
3433         }
3434
3435 #ifndef USE_ITHREADS
3436         unshare_hek_or_pvn (he->refcounted_he_hek, 0, 0, 0);
3437 #endif
3438         copy = he;
3439         he = he->refcounted_he_next;
3440         PerlMemShared_free(copy);
3441     }
3442 }
3443
3444 /*
3445 =for apidoc m|struct refcounted_he *|refcounted_he_inc|struct refcounted_he *he
3446
3447 Increment the reference count of a C<refcounted_he>.  The pointer to the
3448 C<refcounted_he> is also returned.  It is safe to pass a null pointer
3449 to this function: no action occurs and a null pointer is returned.
3450
3451 =cut
3452 */
3453
3454 struct refcounted_he *
3455 Perl_refcounted_he_inc(pTHX_ struct refcounted_he *he)
3456 {
3457     dVAR;
3458     if (he) {
3459         HINTS_REFCNT_LOCK;
3460         he->refcounted_he_refcnt++;
3461         HINTS_REFCNT_UNLOCK;
3462     }
3463     return he;
3464 }
3465
3466 /*
3467 =for apidoc cop_fetch_label
3468
3469 Returns the label attached to a cop.
3470 The flags pointer may be set to C<SVf_UTF8> or 0.
3471
3472 =cut
3473 */
3474
3475 /* pp_entereval is aware that labels are stored with a key ':' at the top of
3476    the linked list.  */
3477 const char *
3478 Perl_cop_fetch_label(pTHX_ COP *const cop, STRLEN *len, U32 *flags) {
3479     struct refcounted_he *const chain = cop->cop_hints_hash;
3480
3481     PERL_ARGS_ASSERT_COP_FETCH_LABEL;
3482
3483     if (!chain)
3484         return NULL;
3485 #ifdef USE_ITHREADS
3486     if (chain->refcounted_he_keylen != 1)
3487         return NULL;
3488     if (*REF_HE_KEY(chain) != ':')
3489         return NULL;
3490 #else
3491     if ((STRLEN)HEK_LEN(chain->refcounted_he_hek) != 1)
3492         return NULL;
3493     if (*HEK_KEY(chain->refcounted_he_hek) != ':')
3494         return NULL;
3495 #endif
3496     /* Stop anyone trying to really mess us up by adding their own value for
3497        ':' into %^H  */
3498     if ((chain->refcounted_he_data[0] & HVrhek_typemask) != HVrhek_PV
3499         && (chain->refcounted_he_data[0] & HVrhek_typemask) != HVrhek_PV_UTF8)
3500         return NULL;
3501
3502     if (len)
3503         *len = chain->refcounted_he_val.refcounted_he_u_len;
3504     if (flags) {
3505         *flags = ((chain->refcounted_he_data[0] & HVrhek_typemask)
3506                   == HVrhek_PV_UTF8) ? SVf_UTF8 : 0;
3507     }
3508     return chain->refcounted_he_data + 1;
3509 }
3510
3511 /*
3512 =for apidoc cop_store_label
3513
3514 Save a label into a C<cop_hints_hash>. You need to set flags to C<SVf_UTF8>
3515 for a utf-8 label.
3516
3517 =cut
3518 */
3519
3520 void
3521 Perl_cop_store_label(pTHX_ COP *const cop, const char *label, STRLEN len,
3522                      U32 flags)
3523 {
3524     SV *labelsv;
3525     PERL_ARGS_ASSERT_COP_STORE_LABEL;
3526
3527     if (flags & ~(SVf_UTF8))
3528         Perl_croak(aTHX_ "panic: cop_store_label illegal flag bits 0x%" UVxf,
3529                    (UV)flags);
3530     labelsv = newSVpvn_flags(label, len, SVs_TEMP);
3531     if (flags & SVf_UTF8)
3532         SvUTF8_on(labelsv);
3533     cop->cop_hints_hash
3534         = refcounted_he_new_pvs(cop->cop_hints_hash, ":", labelsv, 0);
3535 }
3536
3537 /*
3538 =for apidoc hv_assert
3539
3540 Check that a hash is in an internally consistent state.
3541
3542 =cut
3543 */
3544
3545 #ifdef DEBUGGING
3546
3547 void
3548 Perl_hv_assert(pTHX_ HV *hv)
3549 {
3550     dVAR;
3551     HE* entry;
3552     int withflags = 0;
3553     int placeholders = 0;
3554     int real = 0;
3555     int bad = 0;
3556     const I32 riter = HvRITER_get(hv);
3557     HE *eiter = HvEITER_get(hv);
3558
3559     PERL_ARGS_ASSERT_HV_ASSERT;
3560
3561     (void)hv_iterinit(hv);
3562
3563     while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))) {
3564         /* sanity check the values */
3565         if (HeVAL(entry) == &PL_sv_placeholder)
3566             placeholders++;
3567         else
3568             real++;
3569         /* sanity check the keys */
3570         if (HeSVKEY(entry)) {
3571             NOOP;   /* Don't know what to check on SV keys.  */
3572         } else if (HeKUTF8(entry)) {
3573             withflags++;
3574             if (HeKWASUTF8(entry)) {
3575                 PerlIO_printf(Perl_debug_log,
3576                             "hash key has both WASUTF8 and UTF8: '%.*s'\n",
3577                             (int) HeKLEN(entry),  HeKEY(entry));
3578                 bad = 1;
3579             }
3580         } else if (HeKWASUTF8(entry))
3581             withflags++;
3582     }
3583     if (!SvTIED_mg((const SV *)hv, PERL_MAGIC_tied)) {
3584         static const char bad_count[] = "Count %d %s(s), but hash reports %d\n";
3585         const int nhashkeys = HvUSEDKEYS(hv);
3586         const int nhashplaceholders = HvPLACEHOLDERS_get(hv);
3587
3588         if (nhashkeys != real) {
3589             PerlIO_printf(Perl_debug_log, bad_count, real, "keys", nhashkeys );
3590             bad = 1;
3591         }
3592         if (nhashplaceholders != placeholders) {
3593             PerlIO_printf(Perl_debug_log, bad_count, placeholders, "placeholder", nhashplaceholders );
3594             bad = 1;
3595         }
3596     }
3597     if (withflags && ! HvHASKFLAGS(hv)) {
3598         PerlIO_printf(Perl_debug_log,
3599                     "Hash has HASKFLAGS off but I count %d key(s) with flags\n",
3600                     withflags);
3601         bad = 1;
3602     }
3603     if (bad) {
3604         sv_dump(MUTABLE_SV(hv));
3605     }
3606     HvRITER_set(hv, riter);             /* Restore hash iterator state */
3607     HvEITER_set(hv, eiter);
3608 }
3609
3610 #endif
3611
3612 /*
3613  * Local variables:
3614  * c-indentation-style: bsd
3615  * c-basic-offset: 4
3616  * indent-tabs-mode: nil
3617  * End:
3618  *
3619  * ex: set ts=8 sts=4 sw=4 et:
3620  */