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