hv.c

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