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