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