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