hv.c

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