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