hv.c

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