hv.c

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