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     I32 isa_changing = 0;
1522
1523     if (!entry)
1524         return;
1525     val = HeVAL(entry);
1526
1527     if(HvNAME_get(hv) && val && isGV(val)) {
1528         if(GvCVu((GV*)val))
1529             mro_method_changed_in(hv);  /* deletion of method from stash */
1530         else if(GvAV((GV*)val) && strEQ(GvNAME((GV*)val), "ISA"))
1531             isa_changing = 1;
1532     }
1533
1534     SvREFCNT_dec(val);
1535     if (HeKLEN(entry) == HEf_SVKEY) {
1536         SvREFCNT_dec(HeKEY_sv(entry));
1537         Safefree(HeKEY_hek(entry));
1538     }
1539     else if (HvSHAREKEYS(hv))
1540         unshare_hek(HeKEY_hek(entry));
1541     else
1542         Safefree(HeKEY_hek(entry));
1543     del_HE(entry);
1544
1545     if(isa_changing) mro_isa_changed_in(hv);    /* deletion of @ISA from stash */
1546 }
1547
1548 void
1549 Perl_hv_delayfree_ent(pTHX_ HV *hv, register HE *entry)
1550 {
1551     dVAR;
1552     if (!entry)
1553         return;
1554     /* SvREFCNT_inc to counter the SvREFCNT_dec in hv_free_ent  */
1555     sv_2mortal(SvREFCNT_inc(HeVAL(entry)));     /* free between statements */
1556     if (HeKLEN(entry) == HEf_SVKEY) {
1557         sv_2mortal(SvREFCNT_inc(HeKEY_sv(entry)));
1558     }
1559     hv_free_ent(hv, entry);
1560 }
1561
1562 /*
1563 =for apidoc hv_clear
1564
1565 Clears a hash, making it empty.
1566
1567 =cut
1568 */
1569
1570 void
1571 Perl_hv_clear(pTHX_ HV *hv)
1572 {
1573     dVAR;
1574     register XPVHV* xhv;
1575     if (!hv)
1576         return;
1577
1578     DEBUG_A(Perl_hv_assert(aTHX_ hv));
1579
1580     xhv = (XPVHV*)SvANY(hv);
1581
1582     if (SvREADONLY(hv) && HvARRAY(hv) != NULL) {
1583         /* restricted hash: convert all keys to placeholders */
1584         STRLEN i;
1585         for (i = 0; i <= xhv->xhv_max; i++) {
1586             HE *entry = (HvARRAY(hv))[i];
1587             for (; entry; entry = HeNEXT(entry)) {
1588                 /* not already placeholder */
1589                 if (HeVAL(entry) != &PL_sv_placeholder) {
1590                     if (HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
1591                         SV* const keysv = hv_iterkeysv(entry);
1592                         Perl_croak(aTHX_
1593                                    "Attempt to delete readonly key '%"SVf"' from a restricted hash",
1594                                    (void*)keysv);
1595                     }
1596                     SvREFCNT_dec(HeVAL(entry));
1597                     HeVAL(entry) = &PL_sv_placeholder;
1598                     HvPLACEHOLDERS(hv)++;
1599                 }
1600             }
1601         }
1602         goto reset;
1603     }
1604
1605     hfreeentries(hv);
1606     HvPLACEHOLDERS_set(hv, 0);
1607     if (HvARRAY(hv))
1608         Zero(HvARRAY(hv), xhv->xhv_max+1 /* HvMAX(hv)+1 */, HE*);
1609
1610     if (SvRMAGICAL(hv))
1611         mg_clear((SV*)hv);
1612
1613     HvHASKFLAGS_off(hv);
1614     HvREHASH_off(hv);
1615     reset:
1616     if (SvOOK(hv)) {
1617         if(HvNAME_get(hv))
1618             mro_isa_changed_in(hv);
1619         HvEITER_set(hv, NULL);
1620     }
1621 }
1622
1623 /*
1624 =for apidoc hv_clear_placeholders
1625
1626 Clears any placeholders from a hash.  If a restricted hash has any of its keys
1627 marked as readonly and the key is subsequently deleted, the key is not actually
1628 deleted but is marked by assigning it a value of &PL_sv_placeholder.  This tags
1629 it so it will be ignored by future operations such as iterating over the hash,
1630 but will still allow the hash to have a value reassigned to the key at some
1631 future point.  This function clears any such placeholder keys from the hash.
1632 See Hash::Util::lock_keys() for an example of its use.
1633
1634 =cut
1635 */
1636
1637 void
1638 Perl_hv_clear_placeholders(pTHX_ HV *hv)
1639 {
1640     dVAR;
1641     const U32 items = (U32)HvPLACEHOLDERS_get(hv);
1642
1643     if (items)
1644         clear_placeholders(hv, items);
1645 }
1646
1647 static void
1648 S_clear_placeholders(pTHX_ HV *hv, U32 items)
1649 {
1650     dVAR;
1651     I32 i;
1652
1653     if (items == 0)
1654         return;
1655
1656     i = HvMAX(hv);
1657     do {
1658         /* Loop down the linked list heads  */
1659         bool first = TRUE;
1660         HE **oentry = &(HvARRAY(hv))[i];
1661         HE *entry;
1662
1663         while ((entry = *oentry)) {
1664             if (HeVAL(entry) == &PL_sv_placeholder) {
1665                 *oentry = HeNEXT(entry);
1666                 if (first && !*oentry)
1667                     HvFILL(hv)--; /* This linked list is now empty.  */
1668                 if (entry == HvEITER_get(hv))
1669                     HvLAZYDEL_on(hv);
1670                 else
1671                     hv_free_ent(hv, entry);
1672
1673                 if (--items == 0) {
1674                     /* Finished.  */
1675                     HvTOTALKEYS(hv) -= (IV)HvPLACEHOLDERS_get(hv);
1676                     if (HvKEYS(hv) == 0)
1677                         HvHASKFLAGS_off(hv);
1678                     HvPLACEHOLDERS_set(hv, 0);
1679                     return;
1680                 }
1681             } else {
1682                 oentry = &HeNEXT(entry);
1683                 first = FALSE;
1684             }
1685         }
1686     } while (--i >= 0);
1687     /* You can't get here, hence assertion should always fail.  */
1688     assert (items == 0);
1689     assert (0);
1690 }
1691
1692 STATIC void
1693 S_hfreeentries(pTHX_ HV *hv)
1694 {
1695     /* This is the array that we're going to restore  */
1696     HE **const orig_array = HvARRAY(hv);
1697     HEK *name;
1698     int attempts = 100;
1699
1700     if (!orig_array)
1701         return;
1702
1703     if (SvOOK(hv)) {
1704         /* If the hash is actually a symbol table with a name, look after the
1705            name.  */
1706         struct xpvhv_aux *iter = HvAUX(hv);
1707
1708         name = iter->xhv_name;
1709         iter->xhv_name = NULL;
1710     } else {
1711         name = NULL;
1712     }
1713
1714     /* orig_array remains unchanged throughout the loop. If after freeing all
1715        the entries it turns out that one of the little blighters has triggered
1716        an action that has caused HvARRAY to be re-allocated, then we set
1717        array to the new HvARRAY, and try again.  */
1718
1719     while (1) {
1720         /* This is the one we're going to try to empty.  First time round
1721            it's the original array.  (Hopefully there will only be 1 time
1722            round) */
1723         HE ** const array = HvARRAY(hv);
1724         I32 i = HvMAX(hv);
1725
1726         /* Because we have taken xhv_name out, the only allocated pointer
1727            in the aux structure that might exist is the backreference array.
1728         */
1729
1730         if (SvOOK(hv)) {
1731             HE *entry;
1732             struct mro_meta *meta;
1733             struct xpvhv_aux *iter = HvAUX(hv);
1734             /* If there are weak references to this HV, we need to avoid
1735                freeing them up here.  In particular we need to keep the AV
1736                visible as what we're deleting might well have weak references
1737                back to this HV, so the for loop below may well trigger
1738                the removal of backreferences from this array.  */
1739
1740             if (iter->xhv_backreferences) {
1741                 /* So donate them to regular backref magic to keep them safe.
1742                    The sv_magic will increase the reference count of the AV,
1743                    so we need to drop it first. */
1744                 SvREFCNT_dec(iter->xhv_backreferences);
1745                 if (AvFILLp(iter->xhv_backreferences) == -1) {
1746                     /* Turns out that the array is empty. Just free it.  */
1747                     SvREFCNT_dec(iter->xhv_backreferences);
1748
1749                 } else {
1750                     sv_magic((SV*)hv, (SV*)iter->xhv_backreferences,
1751                              PERL_MAGIC_backref, NULL, 0);
1752                 }
1753                 iter->xhv_backreferences = NULL;
1754             }
1755
1756             entry = iter->xhv_eiter; /* HvEITER(hv) */
1757             if (entry && HvLAZYDEL(hv)) {       /* was deleted earlier? */
1758                 HvLAZYDEL_off(hv);
1759                 hv_free_ent(hv, entry);
1760             }
1761             iter->xhv_riter = -1;       /* HvRITER(hv) = -1 */
1762             iter->xhv_eiter = NULL;     /* HvEITER(hv) = NULL */
1763
1764             if((meta = iter->xhv_mro_meta)) {
1765                 if(meta->mro_linear_dfs) SvREFCNT_dec(meta->mro_linear_dfs);
1766                 if(meta->mro_linear_c3)  SvREFCNT_dec(meta->mro_linear_c3);
1767                 if(meta->mro_nextmethod) SvREFCNT_dec(meta->mro_nextmethod);
1768                 Safefree(meta);
1769                 iter->xhv_mro_meta = NULL;
1770             }
1771
1772             /* There are now no allocated pointers in the aux structure.  */
1773
1774             SvFLAGS(hv) &= ~SVf_OOK; /* Goodbye, aux structure.  */
1775             /* What aux structure?  */
1776         }
1777
1778         /* make everyone else think the array is empty, so that the destructors
1779          * called for freed entries can't recusively mess with us */
1780         HvARRAY(hv) = NULL;
1781         HvFILL(hv) = 0;
1782         ((XPVHV*) SvANY(hv))->xhv_keys = 0;
1783
1784
1785         do {
1786             /* Loop down the linked list heads  */
1787             HE *entry = array[i];
1788
1789             while (entry) {
1790                 register HE * const oentry = entry;
1791                 entry = HeNEXT(entry);
1792                 hv_free_ent(hv, oentry);
1793             }
1794         } while (--i >= 0);
1795
1796         /* As there are no allocated pointers in the aux structure, it's now
1797            safe to free the array we just cleaned up, if it's not the one we're
1798            going to put back.  */
1799         if (array != orig_array) {
1800             Safefree(array);
1801         }
1802
1803         if (!HvARRAY(hv)) {
1804             /* Good. No-one added anything this time round.  */
1805             break;
1806         }
1807
1808         if (SvOOK(hv)) {
1809             /* Someone attempted to iterate or set the hash name while we had
1810                the array set to 0.  We'll catch backferences on the next time
1811                round the while loop.  */
1812             assert(HvARRAY(hv));
1813
1814             if (HvAUX(hv)->xhv_name) {
1815                 unshare_hek_or_pvn(HvAUX(hv)->xhv_name, 0, 0, 0);
1816             }
1817         }
1818
1819         if (--attempts == 0) {
1820             Perl_die(aTHX_ "panic: hfreeentries failed to free hash - something is repeatedly re-creating entries");
1821         }
1822     }
1823
1824     HvARRAY(hv) = orig_array;
1825
1826     /* If the hash was actually a symbol table, put the name back.  */
1827     if (name) {
1828         /* We have restored the original array.  If name is non-NULL, then
1829            the original array had an aux structure at the end. So this is
1830            valid:  */
1831         SvFLAGS(hv) |= SVf_OOK;
1832         HvAUX(hv)->xhv_name = name;
1833     }
1834 }
1835
1836 /*
1837 =for apidoc hv_undef
1838
1839 Undefines the hash.
1840
1841 =cut
1842 */
1843
1844 void
1845 Perl_hv_undef(pTHX_ HV *hv)
1846 {
1847     dVAR;
1848     register XPVHV* xhv;
1849     const char *name;
1850
1851     if (!hv)
1852         return;
1853     DEBUG_A(Perl_hv_assert(aTHX_ hv));
1854     xhv = (XPVHV*)SvANY(hv);
1855
1856     /* If it's a stash, undef the @ISA and call
1857        mro_isa_changed_in before proceeding with
1858        the rest of the destruction */
1859     if ((name = HvNAME_get(hv)) && !PL_dirty) {
1860         GV** gvp;
1861         GV* gv;
1862         AV* isa;
1863
1864         gvp = (GV**)hv_fetchs(hv, "ISA", FALSE);
1865         gv = gvp ? *gvp : NULL;
1866         isa = (gv && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
1867
1868         if(isa) av_undef(isa);
1869         mro_isa_changed_in(hv);
1870     }
1871
1872     hfreeentries(hv);
1873     if (name) {
1874         if(PL_stashcache)
1875             hv_delete(PL_stashcache, name, HvNAMELEN_get(hv), G_DISCARD);
1876         hv_name_set(hv, NULL, 0, 0);
1877     }
1878     SvFLAGS(hv) &= ~SVf_OOK;
1879     Safefree(HvARRAY(hv));
1880     xhv->xhv_max   = 7; /* HvMAX(hv) = 7 (it's a normal hash) */
1881     HvARRAY(hv) = 0;
1882     HvPLACEHOLDERS_set(hv, 0);
1883
1884     if (SvRMAGICAL(hv))
1885         mg_clear((SV*)hv);
1886 }
1887
1888 static struct xpvhv_aux*
1889 S_hv_auxinit(HV *hv) {
1890     struct xpvhv_aux *iter;
1891     char *array;
1892
1893     if (!HvARRAY(hv)) {
1894         Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(HvMAX(hv) + 1)
1895             + sizeof(struct xpvhv_aux), char);
1896     } else {
1897         array = (char *) HvARRAY(hv);
1898         Renew(array, PERL_HV_ARRAY_ALLOC_BYTES(HvMAX(hv) + 1)
1899               + sizeof(struct xpvhv_aux), char);
1900     }
1901     HvARRAY(hv) = (HE**) array;
1902     /* SvOOK_on(hv) attacks the IV flags.  */
1903     SvFLAGS(hv) |= SVf_OOK;
1904     iter = HvAUX(hv);
1905
1906     iter->xhv_riter = -1;       /* HvRITER(hv) = -1 */
1907     iter->xhv_eiter = NULL;     /* HvEITER(hv) = NULL */
1908     iter->xhv_name = 0;
1909     iter->xhv_backreferences = 0;
1910     iter->xhv_mro_meta = NULL;
1911     return iter;
1912 }
1913
1914 /*
1915 =for apidoc hv_iterinit
1916
1917 Prepares a starting point to traverse a hash table.  Returns the number of
1918 keys in the hash (i.e. the same as C<HvKEYS(tb)>).  The return value is
1919 currently only meaningful for hashes without tie magic.
1920
1921 NOTE: Before version 5.004_65, C<hv_iterinit> used to return the number of
1922 hash buckets that happen to be in use.  If you still need that esoteric
1923 value, you can get it through the macro C<HvFILL(tb)>.
1924
1925
1926 =cut
1927 */
1928
1929 I32
1930 Perl_hv_iterinit(pTHX_ HV *hv)
1931 {
1932     if (!hv)
1933         Perl_croak(aTHX_ "Bad hash");
1934
1935     if (SvOOK(hv)) {
1936         struct xpvhv_aux * const iter = HvAUX(hv);
1937         HE * const entry = iter->xhv_eiter; /* HvEITER(hv) */
1938         if (entry && HvLAZYDEL(hv)) {   /* was deleted earlier? */
1939             HvLAZYDEL_off(hv);
1940             hv_free_ent(hv, entry);
1941         }
1942         iter->xhv_riter = -1;   /* HvRITER(hv) = -1 */
1943         iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
1944     } else {
1945         hv_auxinit(hv);
1946     }
1947
1948     /* used to be xhv->xhv_fill before 5.004_65 */
1949     return HvTOTALKEYS(hv);
1950 }
1951
1952 I32 *
1953 Perl_hv_riter_p(pTHX_ HV *hv) {
1954     struct xpvhv_aux *iter;
1955
1956     if (!hv)
1957         Perl_croak(aTHX_ "Bad hash");
1958
1959     iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
1960     return &(iter->xhv_riter);
1961 }
1962
1963 HE **
1964 Perl_hv_eiter_p(pTHX_ HV *hv) {
1965     struct xpvhv_aux *iter;
1966
1967     if (!hv)
1968         Perl_croak(aTHX_ "Bad hash");
1969
1970     iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
1971     return &(iter->xhv_eiter);
1972 }
1973
1974 void
1975 Perl_hv_riter_set(pTHX_ HV *hv, I32 riter) {
1976     struct xpvhv_aux *iter;
1977
1978     if (!hv)
1979         Perl_croak(aTHX_ "Bad hash");
1980
1981     if (SvOOK(hv)) {
1982         iter = HvAUX(hv);
1983     } else {
1984         if (riter == -1)
1985             return;
1986
1987         iter = hv_auxinit(hv);
1988     }
1989     iter->xhv_riter = riter;
1990 }
1991
1992 void
1993 Perl_hv_eiter_set(pTHX_ HV *hv, HE *eiter) {
1994     struct xpvhv_aux *iter;
1995
1996     if (!hv)
1997         Perl_croak(aTHX_ "Bad hash");
1998
1999     if (SvOOK(hv)) {
2000         iter = HvAUX(hv);
2001     } else {
2002         /* 0 is the default so don't go malloc()ing a new structure just to
2003            hold 0.  */
2004         if (!eiter)
2005             return;
2006
2007         iter = hv_auxinit(hv);
2008     }
2009     iter->xhv_eiter = eiter;
2010 }
2011
2012 void
2013 Perl_hv_name_set(pTHX_ HV *hv, const char *name, U32 len, U32 flags)
2014 {
2015     dVAR;
2016     struct xpvhv_aux *iter;
2017     U32 hash;
2018
2019     PERL_UNUSED_ARG(flags);
2020
2021     if (len > I32_MAX)
2022         Perl_croak(aTHX_ "panic: hv name too long (%"UVuf")", (UV) len);
2023
2024     if (SvOOK(hv)) {
2025         iter = HvAUX(hv);
2026         if (iter->xhv_name) {
2027             unshare_hek_or_pvn(iter->xhv_name, 0, 0, 0);
2028         }
2029     } else {
2030         if (name == 0)
2031             return;
2032
2033         iter = hv_auxinit(hv);
2034     }
2035     PERL_HASH(hash, name, len);
2036     iter->xhv_name = name ? share_hek(name, len, hash) : NULL;
2037 }
2038
2039 AV **
2040 Perl_hv_backreferences_p(pTHX_ HV *hv) {
2041     struct xpvhv_aux * const iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
2042     PERL_UNUSED_CONTEXT;
2043     return &(iter->xhv_backreferences);
2044 }
2045
2046 void
2047 Perl_hv_kill_backrefs(pTHX_ HV *hv) {
2048     AV *av;
2049
2050     if (!SvOOK(hv))
2051         return;
2052
2053     av = HvAUX(hv)->xhv_backreferences;
2054
2055     if (av) {
2056         HvAUX(hv)->xhv_backreferences = 0;
2057         Perl_sv_kill_backrefs(aTHX_ (SV*) hv, av);
2058     }
2059 }
2060
2061 /*
2062 hv_iternext is implemented as a macro in hv.h
2063
2064 =for apidoc hv_iternext
2065
2066 Returns entries from a hash iterator.  See C<hv_iterinit>.
2067
2068 You may call C<hv_delete> or C<hv_delete_ent> on the hash entry that the
2069 iterator currently points to, without losing your place or invalidating your
2070 iterator.  Note that in this case the current entry is deleted from the hash
2071 with your iterator holding the last reference to it.  Your iterator is flagged
2072 to free the entry on the next call to C<hv_iternext>, so you must not discard
2073 your iterator immediately else the entry will leak - call C<hv_iternext> to
2074 trigger the resource deallocation.
2075
2076 =for apidoc hv_iternext_flags
2077
2078 Returns entries from a hash iterator.  See C<hv_iterinit> and C<hv_iternext>.
2079 The C<flags> value will normally be zero; if HV_ITERNEXT_WANTPLACEHOLDERS is
2080 set the placeholders keys (for restricted hashes) will be returned in addition
2081 to normal keys. By default placeholders are automatically skipped over.
2082 Currently a placeholder is implemented with a value that is
2083 C<&Perl_sv_placeholder>. Note that the implementation of placeholders and
2084 restricted hashes may change, and the implementation currently is
2085 insufficiently abstracted for any change to be tidy.
2086
2087 =cut
2088 */
2089
2090 HE *
2091 Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags)
2092 {
2093     dVAR;
2094     register XPVHV* xhv;
2095     register HE *entry;
2096     HE *oldentry;
2097     MAGIC* mg;
2098     struct xpvhv_aux *iter;
2099
2100     if (!hv)
2101         Perl_croak(aTHX_ "Bad hash");
2102
2103     xhv = (XPVHV*)SvANY(hv);
2104
2105     if (!SvOOK(hv)) {
2106         /* Too many things (well, pp_each at least) merrily assume that you can
2107            call iv_iternext without calling hv_iterinit, so we'll have to deal
2108            with it.  */
2109         hv_iterinit(hv);
2110     }
2111     iter = HvAUX(hv);
2112
2113     oldentry = entry = iter->xhv_eiter; /* HvEITER(hv) */
2114     if (SvMAGICAL(hv) && SvRMAGICAL(hv)) {
2115         if ( ( mg = mg_find((SV*)hv, PERL_MAGIC_tied) ) ) {
2116             SV * const key = sv_newmortal();
2117             if (entry) {
2118                 sv_setsv(key, HeSVKEY_force(entry));
2119                 SvREFCNT_dec(HeSVKEY(entry));       /* get rid of previous key */
2120             }
2121             else {
2122                 char *k;
2123                 HEK *hek;
2124
2125                 /* one HE per MAGICAL hash */
2126                 iter->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */
2127                 Zero(entry, 1, HE);
2128                 Newxz(k, HEK_BASESIZE + sizeof(SV*), char);
2129                 hek = (HEK*)k;
2130                 HeKEY_hek(entry) = hek;
2131                 HeKLEN(entry) = HEf_SVKEY;
2132             }
2133             magic_nextpack((SV*) hv,mg,key);
2134             if (SvOK(key)) {
2135                 /* force key to stay around until next time */
2136                 HeSVKEY_set(entry, SvREFCNT_inc_simple_NN(key));
2137                 return entry;               /* beware, hent_val is not set */
2138             }
2139             if (HeVAL(entry))
2140                 SvREFCNT_dec(HeVAL(entry));
2141             Safefree(HeKEY_hek(entry));
2142             del_HE(entry);
2143             iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
2144             return NULL;
2145         }
2146     }
2147 #if defined(DYNAMIC_ENV_FETCH) && !defined(__riscos__)  /* set up %ENV for iteration */
2148     if (!entry && SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
2149         prime_env_iter();
2150 #ifdef VMS
2151         /* The prime_env_iter() on VMS just loaded up new hash values
2152          * so the iteration count needs to be reset back to the beginning
2153          */
2154         hv_iterinit(hv);
2155         iter = HvAUX(hv);
2156         oldentry = entry = iter->xhv_eiter; /* HvEITER(hv) */
2157 #endif
2158     }
2159 #endif
2160
2161     /* hv_iterint now ensures this.  */
2162     assert (HvARRAY(hv));
2163
2164     /* At start of hash, entry is NULL.  */
2165     if (entry)
2166     {
2167         entry = HeNEXT(entry);
2168         if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
2169             /*
2170              * Skip past any placeholders -- don't want to include them in
2171              * any iteration.
2172              */
2173             while (entry && HeVAL(entry) == &PL_sv_placeholder) {
2174                 entry = HeNEXT(entry);
2175             }
2176         }
2177     }
2178     while (!entry) {
2179         /* OK. Come to the end of the current list.  Grab the next one.  */
2180
2181         iter->xhv_riter++; /* HvRITER(hv)++ */
2182         if (iter->xhv_riter > (I32)xhv->xhv_max /* HvRITER(hv) > HvMAX(hv) */) {
2183             /* There is no next one.  End of the hash.  */
2184             iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
2185             break;
2186         }
2187         entry = (HvARRAY(hv))[iter->xhv_riter];
2188
2189         if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
2190             /* If we have an entry, but it's a placeholder, don't count it.
2191                Try the next.  */
2192             while (entry && HeVAL(entry) == &PL_sv_placeholder)
2193                 entry = HeNEXT(entry);
2194         }
2195         /* Will loop again if this linked list starts NULL
2196            (for HV_ITERNEXT_WANTPLACEHOLDERS)
2197            or if we run through it and find only placeholders.  */
2198     }
2199
2200     if (oldentry && HvLAZYDEL(hv)) {            /* was deleted earlier? */
2201         HvLAZYDEL_off(hv);
2202         hv_free_ent(hv, oldentry);
2203     }
2204
2205     /*if (HvREHASH(hv) && entry && !HeKREHASH(entry))
2206       PerlIO_printf(PerlIO_stderr(), "Awooga %p %p\n", (void*)hv, (void*)entry);*/
2207
2208     iter->xhv_eiter = entry; /* HvEITER(hv) = entry */
2209     return entry;
2210 }
2211
2212 /*
2213 =for apidoc hv_iterkey
2214
2215 Returns the key from the current position of the hash iterator.  See
2216 C<hv_iterinit>.
2217
2218 =cut
2219 */
2220
2221 char *
2222 Perl_hv_iterkey(pTHX_ register HE *entry, I32 *retlen)
2223 {
2224     if (HeKLEN(entry) == HEf_SVKEY) {
2225         STRLEN len;
2226         char * const p = SvPV(HeKEY_sv(entry), len);
2227         *retlen = len;
2228         return p;
2229     }
2230     else {
2231         *retlen = HeKLEN(entry);
2232         return HeKEY(entry);
2233     }
2234 }
2235
2236 /* unlike hv_iterval(), this always returns a mortal copy of the key */
2237 /*
2238 =for apidoc hv_iterkeysv
2239
2240 Returns the key as an C<SV*> from the current position of the hash
2241 iterator.  The return value will always be a mortal copy of the key.  Also
2242 see C<hv_iterinit>.
2243
2244 =cut
2245 */
2246
2247 SV *
2248 Perl_hv_iterkeysv(pTHX_ register HE *entry)
2249 {
2250     return sv_2mortal(newSVhek(HeKEY_hek(entry)));
2251 }
2252
2253 /*
2254 =for apidoc hv_iterval
2255
2256 Returns the value from the current position of the hash iterator.  See
2257 C<hv_iterkey>.
2258
2259 =cut
2260 */
2261
2262 SV *
2263 Perl_hv_iterval(pTHX_ HV *hv, register HE *entry)
2264 {
2265     if (SvRMAGICAL(hv)) {
2266         if (mg_find((SV*)hv, PERL_MAGIC_tied)) {
2267             SV* const sv = sv_newmortal();
2268             if (HeKLEN(entry) == HEf_SVKEY)
2269                 mg_copy((SV*)hv, sv, (char*)HeKEY_sv(entry), HEf_SVKEY);
2270             else
2271                 mg_copy((SV*)hv, sv, HeKEY(entry), HeKLEN(entry));
2272             return sv;
2273         }
2274     }
2275     return HeVAL(entry);
2276 }
2277
2278 /*
2279 =for apidoc hv_iternextsv
2280
2281 Performs an C<hv_iternext>, C<hv_iterkey>, and C<hv_iterval> in one
2282 operation.
2283
2284 =cut
2285 */
2286
2287 SV *
2288 Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen)
2289 {
2290     HE * const he = hv_iternext_flags(hv, 0);
2291
2292     if (!he)
2293         return NULL;
2294     *key = hv_iterkey(he, retlen);
2295     return hv_iterval(hv, he);
2296 }
2297
2298 /*
2299
2300 Now a macro in hv.h
2301
2302 =for apidoc hv_magic
2303
2304 Adds magic to a hash.  See C<sv_magic>.
2305
2306 =cut
2307 */
2308
2309 /* possibly free a shared string if no one has access to it
2310  * len and hash must both be valid for str.
2311  */
2312 void
2313 Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
2314 {
2315     unshare_hek_or_pvn (NULL, str, len, hash);
2316 }
2317
2318
2319 void
2320 Perl_unshare_hek(pTHX_ HEK *hek)
2321 {
2322     assert(hek);
2323     unshare_hek_or_pvn(hek, NULL, 0, 0);
2324 }
2325
2326 /* possibly free a shared string if no one has access to it
2327    hek if non-NULL takes priority over the other 3, else str, len and hash
2328    are used.  If so, len and hash must both be valid for str.
2329  */
2330 STATIC void
2331 S_unshare_hek_or_pvn(pTHX_ const HEK *hek, const char *str, I32 len, U32 hash)
2332 {
2333     dVAR;
2334     register XPVHV* xhv;
2335     HE *entry;
2336     register HE **oentry;
2337     HE **first;
2338     bool is_utf8 = FALSE;
2339     int k_flags = 0;
2340     const char * const save = str;
2341     struct shared_he *he = NULL;
2342
2343     if (hek) {
2344         /* Find the shared he which is just before us in memory.  */
2345         he = (struct shared_he *)(((char *)hek)
2346                                   - STRUCT_OFFSET(struct shared_he,
2347                                                   shared_he_hek));
2348
2349         /* Assert that the caller passed us a genuine (or at least consistent)
2350            shared hek  */
2351         assert (he->shared_he_he.hent_hek == hek);
2352
2353         LOCK_STRTAB_MUTEX;
2354         if (he->shared_he_he.he_valu.hent_refcount - 1) {
2355             --he->shared_he_he.he_valu.hent_refcount;
2356             UNLOCK_STRTAB_MUTEX;
2357             return;
2358         }
2359         UNLOCK_STRTAB_MUTEX;
2360
2361         hash = HEK_HASH(hek);
2362     } else if (len < 0) {
2363         STRLEN tmplen = -len;
2364         is_utf8 = TRUE;
2365         /* See the note in hv_fetch(). --jhi */
2366         str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2367         len = tmplen;
2368         if (is_utf8)
2369             k_flags = HVhek_UTF8;
2370         if (str != save)
2371             k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2372     }
2373
2374     /* what follows was the moral equivalent of:
2375     if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) {
2376         if (--*Svp == NULL)
2377             hv_delete(PL_strtab, str, len, G_DISCARD, hash);
2378     } */
2379     xhv = (XPVHV*)SvANY(PL_strtab);
2380     /* assert(xhv_array != 0) */
2381     LOCK_STRTAB_MUTEX;
2382     first = oentry = &(HvARRAY(PL_strtab))[hash & (I32) HvMAX(PL_strtab)];
2383     if (he) {
2384         const HE *const he_he = &(he->shared_he_he);
2385         for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) {
2386             if (entry == he_he)
2387                 break;
2388         }
2389     } else {
2390         const int flags_masked = k_flags & HVhek_MASK;
2391         for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) {
2392             if (HeHASH(entry) != hash)          /* strings can't be equal */
2393                 continue;
2394             if (HeKLEN(entry) != len)
2395                 continue;
2396             if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len))     /* is this it? */
2397                 continue;
2398             if (HeKFLAGS(entry) != flags_masked)
2399                 continue;
2400             break;
2401         }
2402     }
2403
2404     if (entry) {
2405         if (--entry->he_valu.hent_refcount == 0) {
2406             *oentry = HeNEXT(entry);
2407             if (!*first) {
2408                 /* There are now no entries in our slot.  */
2409                 xhv->xhv_fill--; /* HvFILL(hv)-- */
2410             }
2411             Safefree(entry);
2412             xhv->xhv_keys--; /* HvTOTALKEYS(hv)-- */
2413         }
2414     }
2415
2416     UNLOCK_STRTAB_MUTEX;
2417     if (!entry && ckWARN_d(WARN_INTERNAL))
2418         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
2419                     "Attempt to free non-existent shared string '%s'%s"
2420                     pTHX__FORMAT,
2421                     hek ? HEK_KEY(hek) : str,
2422                     ((k_flags & HVhek_UTF8) ? " (utf8)" : "") pTHX__VALUE);
2423     if (k_flags & HVhek_FREEKEY)
2424         Safefree(str);
2425 }
2426
2427 /* get a (constant) string ptr from the global string table
2428  * string will get added if it is not already there.
2429  * len and hash must both be valid for str.
2430  */
2431 HEK *
2432 Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash)
2433 {
2434     bool is_utf8 = FALSE;
2435     int flags = 0;
2436     const char * const save = str;
2437
2438     if (len < 0) {
2439       STRLEN tmplen = -len;
2440       is_utf8 = TRUE;
2441       /* See the note in hv_fetch(). --jhi */
2442       str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2443       len = tmplen;
2444       /* If we were able to downgrade here, then than means that we were passed
2445          in a key which only had chars 0-255, but was utf8 encoded.  */
2446       if (is_utf8)
2447           flags = HVhek_UTF8;
2448       /* If we found we were able to downgrade the string to bytes, then
2449          we should flag that it needs upgrading on keys or each.  Also flag
2450          that we need share_hek_flags to free the string.  */
2451       if (str != save)
2452           flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2453     }
2454
2455     return share_hek_flags (str, len, hash, flags);
2456 }
2457
2458 STATIC HEK *
2459 S_share_hek_flags(pTHX_ const char *str, I32 len, register U32 hash, int flags)
2460 {
2461     dVAR;
2462     register HE *entry;
2463     const int flags_masked = flags & HVhek_MASK;
2464     const U32 hindex = hash & (I32) HvMAX(PL_strtab);
2465
2466     /* what follows is the moral equivalent of:
2467
2468     if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
2469         hv_store(PL_strtab, str, len, NULL, hash);
2470
2471         Can't rehash the shared string table, so not sure if it's worth
2472         counting the number of entries in the linked list
2473     */
2474     register XPVHV * const xhv = (XPVHV*)SvANY(PL_strtab);
2475     /* assert(xhv_array != 0) */
2476     LOCK_STRTAB_MUTEX;
2477     entry = (HvARRAY(PL_strtab))[hindex];
2478     for (;entry; entry = HeNEXT(entry)) {
2479         if (HeHASH(entry) != hash)              /* strings can't be equal */
2480             continue;
2481         if (HeKLEN(entry) != len)
2482             continue;
2483         if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
2484             continue;
2485         if (HeKFLAGS(entry) != flags_masked)
2486             continue;
2487         break;
2488     }
2489
2490     if (!entry) {
2491         /* What used to be head of the list.
2492            If this is NULL, then we're the first entry for this slot, which
2493            means we need to increate fill.  */
2494         struct shared_he *new_entry;
2495         HEK *hek;
2496         char *k;
2497         HE **const head = &HvARRAY(PL_strtab)[hindex];
2498         HE *const next = *head;
2499
2500         /* We don't actually store a HE from the arena and a regular HEK.
2501            Instead we allocate one chunk of memory big enough for both,
2502            and put the HEK straight after the HE. This way we can find the
2503            HEK directly from the HE.
2504         */
2505
2506         Newx(k, STRUCT_OFFSET(struct shared_he,
2507                                 shared_he_hek.hek_key[0]) + len + 2, char);
2508         new_entry = (struct shared_he *)k;
2509         entry = &(new_entry->shared_he_he);
2510         hek = &(new_entry->shared_he_hek);
2511
2512         Copy(str, HEK_KEY(hek), len, char);
2513         HEK_KEY(hek)[len] = 0;
2514         HEK_LEN(hek) = len;
2515         HEK_HASH(hek) = hash;
2516         HEK_FLAGS(hek) = (unsigned char)flags_masked;
2517
2518         /* Still "point" to the HEK, so that other code need not know what
2519            we're up to.  */
2520         HeKEY_hek(entry) = hek;
2521         entry->he_valu.hent_refcount = 0;
2522         HeNEXT(entry) = next;
2523         *head = entry;
2524
2525         xhv->xhv_keys++; /* HvTOTALKEYS(hv)++ */
2526         if (!next) {                    /* initial entry? */
2527             xhv->xhv_fill++; /* HvFILL(hv)++ */
2528         } else if (xhv->xhv_keys > (IV)xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */) {
2529                 hsplit(PL_strtab);
2530         }
2531     }
2532
2533     ++entry->he_valu.hent_refcount;
2534     UNLOCK_STRTAB_MUTEX;
2535
2536     if (flags & HVhek_FREEKEY)
2537         Safefree(str);
2538
2539     return HeKEY_hek(entry);
2540 }
2541
2542 STATIC SV *
2543 S_hv_magic_uvar_xkey(pTHX_ HV* hv, SV* keysv, int action)
2544 {
2545     MAGIC* mg;
2546     if ((mg = mg_find((SV*)hv, PERL_MAGIC_uvar))) {
2547         struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2548         if (uf->uf_set == NULL) {
2549             SV* obj = mg->mg_obj;
2550             mg->mg_obj = keysv;         /* pass key */
2551             uf->uf_index = action;      /* pass action */
2552             magic_getuvar((SV*)hv, mg);
2553             keysv = mg->mg_obj;         /* may have changed */
2554             mg->mg_obj = obj;
2555         }
2556     }
2557     return keysv;
2558 }
2559
2560 I32 *
2561 Perl_hv_placeholders_p(pTHX_ HV *hv)
2562 {
2563     dVAR;
2564     MAGIC *mg = mg_find((SV*)hv, PERL_MAGIC_rhash);
2565
2566     if (!mg) {
2567         mg = sv_magicext((SV*)hv, 0, PERL_MAGIC_rhash, 0, 0, 0);
2568
2569         if (!mg) {
2570             Perl_die(aTHX_ "panic: hv_placeholders_p");
2571         }
2572     }
2573     return &(mg->mg_len);
2574 }
2575
2576
2577 I32
2578 Perl_hv_placeholders_get(pTHX_ HV *hv)
2579 {
2580     dVAR;
2581     MAGIC * const mg = mg_find((SV*)hv, PERL_MAGIC_rhash);
2582
2583     return mg ? mg->mg_len : 0;
2584 }
2585
2586 void
2587 Perl_hv_placeholders_set(pTHX_ HV *hv, I32 ph)
2588 {
2589     dVAR;
2590     MAGIC * const mg = mg_find((SV*)hv, PERL_MAGIC_rhash);
2591
2592     if (mg) {
2593         mg->mg_len = ph;
2594     } else if (ph) {
2595         if (!sv_magicext((SV*)hv, 0, PERL_MAGIC_rhash, 0, 0, ph))
2596             Perl_die(aTHX_ "panic: hv_placeholders_set");
2597     }
2598     /* else we don't need to add magic to record 0 placeholders.  */
2599 }
2600
2601 STATIC SV *
2602 S_refcounted_he_value(pTHX_ const struct refcounted_he *he)
2603 {
2604     dVAR;
2605     SV *value;
2606     switch(he->refcounted_he_data[0] & HVrhek_typemask) {
2607     case HVrhek_undef:
2608         value = newSV(0);
2609         break;
2610     case HVrhek_delete:
2611         value = &PL_sv_placeholder;
2612         break;
2613     case HVrhek_IV:
2614         value = newSViv(he->refcounted_he_val.refcounted_he_u_iv);
2615         break;
2616     case HVrhek_UV:
2617         value = newSVuv(he->refcounted_he_val.refcounted_he_u_uv);
2618         break;
2619     case HVrhek_PV:
2620     case HVrhek_PV_UTF8:
2621         /* Create a string SV that directly points to the bytes in our
2622            structure.  */
2623         value = newSV_type(SVt_PV);
2624         SvPV_set(value, (char *) he->refcounted_he_data + 1);
2625         SvCUR_set(value, he->refcounted_he_val.refcounted_he_u_len);
2626         /* This stops anything trying to free it  */
2627         SvLEN_set(value, 0);
2628         SvPOK_on(value);
2629         SvREADONLY_on(value);
2630         if ((he->refcounted_he_data[0] & HVrhek_typemask) == HVrhek_PV_UTF8)
2631             SvUTF8_on(value);
2632         break;
2633     default:
2634         Perl_croak(aTHX_ "panic: refcounted_he_value bad flags %x",
2635                    he->refcounted_he_data[0]);
2636     }
2637     return value;
2638 }
2639
2640 /*
2641 =for apidoc refcounted_he_chain_2hv
2642
2643 Generates and returns a C<HV *> by walking up the tree starting at the passed
2644 in C<struct refcounted_he *>.
2645
2646 =cut
2647 */
2648 HV *
2649 Perl_refcounted_he_chain_2hv(pTHX_ const struct refcounted_he *chain)
2650 {
2651     dVAR;
2652     HV *hv = newHV();
2653     U32 placeholders = 0;
2654     /* We could chase the chain once to get an idea of the number of keys,
2655        and call ksplit.  But for now we'll make a potentially inefficient
2656        hash with only 8 entries in its array.  */
2657     const U32 max = HvMAX(hv);
2658
2659     if (!HvARRAY(hv)) {
2660         char *array;
2661         Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(max + 1), char);
2662         HvARRAY(hv) = (HE**)array;
2663     }
2664
2665     while (chain) {
2666 #ifdef USE_ITHREADS
2667         U32 hash = chain->refcounted_he_hash;
2668 #else
2669         U32 hash = HEK_HASH(chain->refcounted_he_hek);
2670 #endif
2671         HE **oentry = &((HvARRAY(hv))[hash & max]);
2672         HE *entry = *oentry;
2673         SV *value;
2674
2675         for (; entry; entry = HeNEXT(entry)) {
2676             if (HeHASH(entry) == hash) {
2677                 /* We might have a duplicate key here.  If so, entry is older
2678                    than the key we've already put in the hash, so if they are
2679                    the same, skip adding entry.  */
2680 #ifdef USE_ITHREADS
2681                 const STRLEN klen = HeKLEN(entry);
2682                 const char *const key = HeKEY(entry);
2683                 if (klen == chain->refcounted_he_keylen
2684                     && (!!HeKUTF8(entry)
2685                         == !!(chain->refcounted_he_data[0] & HVhek_UTF8))
2686                     && memEQ(key, REF_HE_KEY(chain), klen))
2687                     goto next_please;
2688 #else
2689                 if (HeKEY_hek(entry) == chain->refcounted_he_hek)
2690                     goto next_please;
2691                 if (HeKLEN(entry) == HEK_LEN(chain->refcounted_he_hek)
2692                     && HeKUTF8(entry) == HEK_UTF8(chain->refcounted_he_hek)
2693                     && memEQ(HeKEY(entry), HEK_KEY(chain->refcounted_he_hek),
2694                              HeKLEN(entry)))
2695                     goto next_please;
2696 #endif
2697             }
2698         }
2699         assert (!entry);
2700         entry = new_HE();
2701
2702 #ifdef USE_ITHREADS
2703         HeKEY_hek(entry)
2704             = share_hek_flags(REF_HE_KEY(chain),
2705                               chain->refcounted_he_keylen,
2706                               chain->refcounted_he_hash,
2707                               (chain->refcounted_he_data[0]
2708                                & (HVhek_UTF8|HVhek_WASUTF8)));
2709 #else
2710         HeKEY_hek(entry) = share_hek_hek(chain->refcounted_he_hek);
2711 #endif
2712         value = refcounted_he_value(chain);
2713         if (value == &PL_sv_placeholder)
2714             placeholders++;
2715         HeVAL(entry) = value;
2716
2717         /* Link it into the chain.  */
2718         HeNEXT(entry) = *oentry;
2719         if (!HeNEXT(entry)) {
2720             /* initial entry.   */
2721             HvFILL(hv)++;
2722         }
2723         *oentry = entry;
2724
2725         HvTOTALKEYS(hv)++;
2726
2727     next_please:
2728         chain = chain->refcounted_he_next;
2729     }
2730
2731     if (placeholders) {
2732         clear_placeholders(hv, placeholders);
2733         HvTOTALKEYS(hv) -= placeholders;
2734     }
2735
2736     /* We could check in the loop to see if we encounter any keys with key
2737        flags, but it's probably not worth it, as this per-hash flag is only
2738        really meant as an optimisation for things like Storable.  */
2739     HvHASKFLAGS_on(hv);
2740     DEBUG_A(Perl_hv_assert(aTHX_ hv));
2741
2742     return hv;
2743 }
2744
2745 SV *
2746 Perl_refcounted_he_fetch(pTHX_ const struct refcounted_he *chain, SV *keysv,
2747                          const char *key, STRLEN klen, int flags, U32 hash)
2748 {
2749     dVAR;
2750     /* Just to be awkward, if you're using this interface the UTF-8-or-not-ness
2751        of your key has to exactly match that which is stored.  */
2752     SV *value = &PL_sv_placeholder;
2753     bool is_utf8;
2754
2755     if (keysv) {
2756         if (flags & HVhek_FREEKEY)
2757             Safefree(key);
2758         key = SvPV_const(keysv, klen);
2759         flags = 0;
2760         is_utf8 = (SvUTF8(keysv) != 0);
2761     } else {
2762         is_utf8 = ((flags & HVhek_UTF8) ? TRUE : FALSE);
2763     }
2764
2765     if (!hash) {
2766         if (keysv && (SvIsCOW_shared_hash(keysv))) {
2767             hash = SvSHARED_HASH(keysv);
2768         } else {
2769             PERL_HASH(hash, key, klen);
2770         }
2771     }
2772
2773     for (; chain; chain = chain->refcounted_he_next) {
2774 #ifdef USE_ITHREADS
2775         if (hash != chain->refcounted_he_hash)
2776             continue;
2777         if (klen != chain->refcounted_he_keylen)
2778             continue;
2779         if (memNE(REF_HE_KEY(chain),key,klen))
2780             continue;
2781         if (!!is_utf8 != !!(chain->refcounted_he_data[0] & HVhek_UTF8))
2782             continue;
2783 #else
2784         if (hash != HEK_HASH(chain->refcounted_he_hek))
2785             continue;
2786         if (klen != (STRLEN)HEK_LEN(chain->refcounted_he_hek))
2787             continue;
2788         if (memNE(HEK_KEY(chain->refcounted_he_hek),key,klen))
2789             continue;
2790         if (!!is_utf8 != !!HEK_UTF8(chain->refcounted_he_hek))
2791             continue;
2792 #endif
2793
2794         value = sv_2mortal(refcounted_he_value(chain));
2795         break;
2796     }
2797
2798     if (flags & HVhek_FREEKEY)
2799         Safefree(key);
2800
2801     return value;
2802 }
2803
2804 /*
2805 =for apidoc refcounted_he_new
2806
2807 Creates a new C<struct refcounted_he>. As S<key> is copied, and value is
2808 stored in a compact form, all references remain the property of the caller.
2809 The C<struct refcounted_he> is returned with a reference count of 1.
2810
2811 =cut
2812 */
2813
2814 struct refcounted_he *
2815 Perl_refcounted_he_new(pTHX_ struct refcounted_he *const parent,
2816                        SV *const key, SV *const value) {
2817     dVAR;
2818     struct refcounted_he *he;
2819     STRLEN key_len;
2820     const char *key_p = SvPV_const(key, key_len);
2821     STRLEN value_len = 0;
2822     const char *value_p = NULL;
2823     char value_type;
2824     char flags;
2825     STRLEN key_offset;
2826     U32 hash;
2827     bool is_utf8 = SvUTF8(key) ? TRUE : FALSE;
2828
2829     if (SvPOK(value)) {
2830         value_type = HVrhek_PV;
2831     } else if (SvIOK(value)) {
2832         value_type = HVrhek_IV;
2833     } else if (value == &PL_sv_placeholder) {
2834         value_type = HVrhek_delete;
2835     } else if (!SvOK(value)) {
2836         value_type = HVrhek_undef;
2837     } else {
2838         value_type = HVrhek_PV;
2839     }
2840
2841     if (value_type == HVrhek_PV) {
2842         value_p = SvPV_const(value, value_len);
2843         key_offset = value_len + 2;
2844     } else {
2845         value_len = 0;
2846         key_offset = 1;
2847     }
2848
2849 #ifdef USE_ITHREADS
2850     he = (struct refcounted_he*)
2851         PerlMemShared_malloc(sizeof(struct refcounted_he) - 1
2852                              + key_len
2853                              + key_offset);
2854 #else
2855     he = (struct refcounted_he*)
2856         PerlMemShared_malloc(sizeof(struct refcounted_he) - 1
2857                              + key_offset);
2858 #endif
2859
2860
2861     he->refcounted_he_next = parent;
2862
2863     if (value_type == HVrhek_PV) {
2864         Copy(value_p, he->refcounted_he_data + 1, value_len + 1, char);
2865         he->refcounted_he_val.refcounted_he_u_len = value_len;
2866         /* Do it this way so that the SvUTF8() test is after the SvPV, in case
2867            the value is overloaded, and doesn't yet have the UTF-8flag set.  */
2868         if (SvUTF8(value))
2869             value_type = HVrhek_PV_UTF8;
2870     } else if (value_type == HVrhek_IV) {
2871         if (SvUOK(value)) {
2872             he->refcounted_he_val.refcounted_he_u_uv = SvUVX(value);
2873             value_type = HVrhek_UV;
2874         } else {
2875             he->refcounted_he_val.refcounted_he_u_iv = SvIVX(value);
2876         }
2877     }
2878     flags = value_type;
2879
2880     if (is_utf8) {
2881         /* Hash keys are always stored normalised to (yes) ISO-8859-1.
2882            As we're going to be building hash keys from this value in future,
2883            normalise it now.  */
2884         key_p = (char*)bytes_from_utf8((const U8*)key_p, &key_len, &is_utf8);
2885         flags |= is_utf8 ? HVhek_UTF8 : HVhek_WASUTF8;
2886     }
2887     PERL_HASH(hash, key_p, key_len);
2888
2889 #ifdef USE_ITHREADS
2890     he->refcounted_he_hash = hash;
2891     he->refcounted_he_keylen = key_len;
2892     Copy(key_p, he->refcounted_he_data + key_offset, key_len, char);
2893 #else
2894     he->refcounted_he_hek = share_hek_flags(key_p, key_len, hash, flags);
2895 #endif
2896
2897     if (flags & HVhek_WASUTF8) {
2898         /* If it was downgraded from UTF-8, then the pointer returned from
2899            bytes_from_utf8 is an allocated pointer that we must free.  */
2900         Safefree(key_p);
2901     }
2902
2903     he->refcounted_he_data[0] = flags;
2904     he->refcounted_he_refcnt = 1;
2905
2906     return he;
2907 }
2908
2909 /*
2910 =for apidoc refcounted_he_free
2911
2912 Decrements the reference count of the passed in C<struct refcounted_he *>
2913 by one. If the reference count reaches zero the structure's memory is freed,
2914 and C<refcounted_he_free> iterates onto the parent node.
2915
2916 =cut
2917 */
2918
2919 void
2920 Perl_refcounted_he_free(pTHX_ struct refcounted_he *he) {
2921     dVAR;
2922     PERL_UNUSED_CONTEXT;
2923
2924     while (he) {
2925         struct refcounted_he *copy;
2926         U32 new_count;
2927
2928         HINTS_REFCNT_LOCK;
2929         new_count = --he->refcounted_he_refcnt;
2930         HINTS_REFCNT_UNLOCK;
2931
2932         if (new_count) {
2933             return;
2934         }
2935
2936 #ifndef USE_ITHREADS
2937         unshare_hek_or_pvn (he->refcounted_he_hek, 0, 0, 0);
2938 #endif
2939         copy = he;
2940         he = he->refcounted_he_next;
2941         PerlMemShared_free(copy);
2942     }
2943 }
2944
2945 /*
2946 =for apidoc hv_assert
2947
2948 Check that a hash is in an internally consistent state.
2949
2950 =cut
2951 */
2952
2953 #ifdef DEBUGGING
2954
2955 void
2956 Perl_hv_assert(pTHX_ HV *hv)
2957 {
2958     dVAR;
2959     HE* entry;
2960     int withflags = 0;
2961     int placeholders = 0;
2962     int real = 0;
2963     int bad = 0;
2964     const I32 riter = HvRITER_get(hv);
2965     HE *eiter = HvEITER_get(hv);
2966
2967     (void)hv_iterinit(hv);
2968
2969     while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))) {
2970         /* sanity check the values */
2971         if (HeVAL(entry) == &PL_sv_placeholder)
2972             placeholders++;
2973         else
2974             real++;
2975         /* sanity check the keys */
2976         if (HeSVKEY(entry)) {
2977             NOOP;   /* Don't know what to check on SV keys.  */
2978         } else if (HeKUTF8(entry)) {
2979             withflags++;
2980             if (HeKWASUTF8(entry)) {
2981                 PerlIO_printf(Perl_debug_log,
2982                             "hash key has both WASUTF8 and UTF8: '%.*s'\n",
2983                             (int) HeKLEN(entry),  HeKEY(entry));
2984                 bad = 1;
2985             }
2986         } else if (HeKWASUTF8(entry))
2987             withflags++;
2988     }
2989     if (!SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) {
2990         static const char bad_count[] = "Count %d %s(s), but hash reports %d\n";
2991         const int nhashkeys = HvUSEDKEYS(hv);
2992         const int nhashplaceholders = HvPLACEHOLDERS_get(hv);
2993
2994         if (nhashkeys != real) {
2995             PerlIO_printf(Perl_debug_log, bad_count, real, "keys", nhashkeys );
2996             bad = 1;
2997         }
2998         if (nhashplaceholders != placeholders) {
2999             PerlIO_printf(Perl_debug_log, bad_count, placeholders, "placeholder", nhashplaceholders );
3000             bad = 1;
3001         }
3002     }
3003     if (withflags && ! HvHASKFLAGS(hv)) {
3004         PerlIO_printf(Perl_debug_log,
3005                     "Hash has HASKFLAGS off but I count %d key(s) with flags\n",
3006                     withflags);
3007         bad = 1;
3008     }
3009     if (bad) {
3010         sv_dump((SV *)hv);
3011     }
3012     HvRITER_set(hv, riter);             /* Restore hash iterator state */
3013     HvEITER_set(hv, eiter);
3014 }
3015
3016 #endif
3017
3018 /*
3019  * Local variables:
3020  * c-indentation-style: bsd
3021  * c-basic-offset: 4
3022  * indent-tabs-mode: t
3023  * End:
3024  *
3025  * ex: set ts=8 sts=4 sw=4 noet:
3026  */