hv.c

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