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