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