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