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 = 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         bool mpm = FALSE;
 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                         mpm = TRUE;
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         }
1057
1058         if (d_flags & G_DISCARD)
1059             sv = NULL;
1060         else {
1061             sv = sv_2mortal(HeVAL(entry));
1062             HeVAL(entry) = &PL_sv_placeholder;
1063         }
1064
1065         /*
1066          * If a restricted hash, rather than really deleting the entry, put
1067          * a placeholder there. This marks the key as being "approved", so
1068          * we can still access via not-really-existing key without raising
1069          * an error.
1070          */
1071         if (SvREADONLY(hv)) {
1072             SvREFCNT_dec(HeVAL(entry));
1073             HeVAL(entry) = &PL_sv_placeholder;
1074             /* We'll be saving this slot, so the number of allocated keys
1075              * doesn't go down, but the number placeholders goes up */
1076             HvPLACEHOLDERS(hv)++;
1077         } else {
1078             *oentry = HeNEXT(entry);
1079             if (SvOOK(hv) && entry == HvAUX(hv)->xhv_eiter /* HvEITER(hv) */)
1080                 HvLAZYDEL_on(hv);
1081             else
1082                 hv_free_ent(hv, entry);
1083             xhv->xhv_keys--; /* HvTOTALKEYS(hv)-- */
1084             if (xhv->xhv_keys == 0)
1085                 HvHASKFLAGS_off(hv);
1086         }
1087
1088         if (mpm) mro_package_moved(NULL, stash, NULL, name, namlen);
1089
1090         return sv;
1091     }
1092     if (SvREADONLY(hv)) {
1093         hv_notallowed(k_flags, key, klen,
1094                         "Attempt to delete disallowed key '%"SVf"' from"
1095                         " a restricted hash");
1096     }
1097
1098     if (k_flags & HVhek_FREEKEY)
1099         Safefree(key);
1100     return NULL;
1101 }
1102
1103 STATIC void
1104 S_hsplit(pTHX_ HV *hv)
1105 {
1106     dVAR;
1107     register XPVHV* const xhv = (XPVHV*)SvANY(hv);
1108     const I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
1109     register I32 newsize = oldsize * 2;
1110     register I32 i;
1111     char *a = (char*) HvARRAY(hv);
1112     register HE **aep;
1113     int longest_chain = 0;
1114     int was_shared;
1115
1116     PERL_ARGS_ASSERT_HSPLIT;
1117
1118     /*PerlIO_printf(PerlIO_stderr(), "hsplit called for %p which had %d\n",
1119       (void*)hv, (int) oldsize);*/
1120
1121     if (HvPLACEHOLDERS_get(hv) && !SvREADONLY(hv)) {
1122       /* Can make this clear any placeholders first for non-restricted hashes,
1123          even though Storable rebuilds restricted hashes by putting in all the
1124          placeholders (first) before turning on the readonly flag, because
1125          Storable always pre-splits the hash.  */
1126       hv_clear_placeholders(hv);
1127     }
1128
1129     PL_nomemok = TRUE;
1130 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
1131     Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize)
1132           + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char);
1133     if (!a) {
1134       PL_nomemok = FALSE;
1135       return;
1136     }
1137     if (SvOOK(hv)) {
1138         Move(&a[oldsize * sizeof(HE*)], &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux);
1139     }
1140 #else
1141     Newx(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize)
1142         + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char);
1143     if (!a) {
1144       PL_nomemok = FALSE;
1145       return;
1146     }
1147     Copy(HvARRAY(hv), a, oldsize * sizeof(HE*), char);
1148     if (SvOOK(hv)) {
1149         Copy(HvAUX(hv), &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux);
1150     }
1151     Safefree(HvARRAY(hv));
1152 #endif
1153
1154     PL_nomemok = FALSE;
1155     Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char);     /* zero 2nd half*/
1156     xhv->xhv_max = --newsize;   /* HvMAX(hv) = --newsize */
1157     HvARRAY(hv) = (HE**) a;
1158     aep = (HE**)a;
1159
1160     for (i=0; i<oldsize; i++,aep++) {
1161         int left_length = 0;
1162         int right_length = 0;
1163         HE **oentry = aep;
1164         HE *entry = *aep;
1165         register HE **bep;
1166
1167         if (!entry)                             /* non-existent */
1168             continue;
1169         bep = aep+oldsize;
1170         do {
1171             if ((HeHASH(entry) & newsize) != (U32)i) {
1172                 *oentry = HeNEXT(entry);
1173                 HeNEXT(entry) = *bep;
1174                 *bep = entry;
1175                 right_length++;
1176             }
1177             else {
1178                 oentry = &HeNEXT(entry);
1179                 left_length++;
1180             }
1181             entry = *oentry;
1182         } while (entry);
1183         /* I think we don't actually need to keep track of the longest length,
1184            merely flag if anything is too long. But for the moment while
1185            developing this code I'll track it.  */
1186         if (left_length > longest_chain)
1187             longest_chain = left_length;
1188         if (right_length > longest_chain)
1189             longest_chain = right_length;
1190     }
1191
1192
1193     /* Pick your policy for "hashing isn't working" here:  */
1194     if (longest_chain <= HV_MAX_LENGTH_BEFORE_SPLIT /* split worked?  */
1195         || HvREHASH(hv)) {
1196         return;
1197     }
1198
1199     if (hv == PL_strtab) {
1200         /* Urg. Someone is doing something nasty to the string table.
1201            Can't win.  */
1202         return;
1203     }
1204
1205     /* Awooga. Awooga. Pathological data.  */
1206     /*PerlIO_printf(PerlIO_stderr(), "%p %d of %d with %d/%d buckets\n", (void*)hv,
1207       longest_chain, HvTOTALKEYS(hv), HvFILL(hv),  1+HvMAX(hv));*/
1208
1209     ++newsize;
1210     Newxz(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize)
1211          + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char);
1212     if (SvOOK(hv)) {
1213         Copy(HvAUX(hv), &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux);
1214     }
1215
1216     was_shared = HvSHAREKEYS(hv);
1217
1218     HvSHAREKEYS_off(hv);
1219     HvREHASH_on(hv);
1220
1221     aep = HvARRAY(hv);
1222
1223     for (i=0; i<newsize; i++,aep++) {
1224         register HE *entry = *aep;
1225         while (entry) {
1226             /* We're going to trash this HE's next pointer when we chain it
1227                into the new hash below, so store where we go next.  */
1228             HE * const next = HeNEXT(entry);
1229             UV hash;
1230             HE **bep;
1231
1232             /* Rehash it */
1233             PERL_HASH_INTERNAL(hash, HeKEY(entry), HeKLEN(entry));
1234
1235             if (was_shared) {
1236                 /* Unshare it.  */
1237                 HEK * const new_hek
1238                     = save_hek_flags(HeKEY(entry), HeKLEN(entry),
1239                                      hash, HeKFLAGS(entry));
1240                 unshare_hek (HeKEY_hek(entry));
1241                 HeKEY_hek(entry) = new_hek;
1242             } else {
1243                 /* Not shared, so simply write the new hash in. */
1244                 HeHASH(entry) = hash;
1245             }
1246             /*PerlIO_printf(PerlIO_stderr(), "%d ", HeKFLAGS(entry));*/
1247             HEK_REHASH_on(HeKEY_hek(entry));
1248             /*PerlIO_printf(PerlIO_stderr(), "%d\n", HeKFLAGS(entry));*/
1249
1250             /* Copy oentry to the correct new chain.  */
1251             bep = ((HE**)a) + (hash & (I32) xhv->xhv_max);
1252             HeNEXT(entry) = *bep;
1253             *bep = entry;
1254
1255             entry = next;
1256         }
1257     }
1258     Safefree (HvARRAY(hv));
1259     HvARRAY(hv) = (HE **)a;
1260 }
1261
1262 void
1263 Perl_hv_ksplit(pTHX_ HV *hv, IV newmax)
1264 {
1265     dVAR;
1266     register XPVHV* xhv = (XPVHV*)SvANY(hv);
1267     const I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
1268     register I32 newsize;
1269     register I32 i;
1270     register char *a;
1271     register HE **aep;
1272
1273     PERL_ARGS_ASSERT_HV_KSPLIT;
1274
1275     newsize = (I32) newmax;                     /* possible truncation here */
1276     if (newsize != newmax || newmax <= oldsize)
1277         return;
1278     while ((newsize & (1 + ~newsize)) != newsize) {
1279         newsize &= ~(newsize & (1 + ~newsize)); /* get proper power of 2 */
1280     }
1281     if (newsize < newmax)
1282         newsize *= 2;
1283     if (newsize < newmax)
1284         return;                                 /* overflow detection */
1285
1286     a = (char *) HvARRAY(hv);
1287     if (a) {
1288         PL_nomemok = TRUE;
1289 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
1290         Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize)
1291               + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char);
1292         if (!a) {
1293           PL_nomemok = FALSE;
1294           return;
1295         }
1296         if (SvOOK(hv)) {
1297             Copy(&a[oldsize * sizeof(HE*)], &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux);
1298         }
1299 #else
1300         Newx(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize)
1301             + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char);
1302         if (!a) {
1303           PL_nomemok = FALSE;
1304           return;
1305         }
1306         Copy(HvARRAY(hv), a, oldsize * sizeof(HE*), char);
1307         if (SvOOK(hv)) {
1308             Copy(HvAUX(hv), &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux);
1309         }
1310         Safefree(HvARRAY(hv));
1311 #endif
1312         PL_nomemok = FALSE;
1313         Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
1314     }
1315     else {
1316         Newxz(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1317     }
1318     xhv->xhv_max = --newsize;   /* HvMAX(hv) = --newsize */
1319     HvARRAY(hv) = (HE **) a;
1320     if (!xhv->xhv_keys /* !HvTOTALKEYS(hv) */)  /* skip rest if no entries */
1321         return;
1322
1323     aep = (HE**)a;
1324     for (i=0; i<oldsize; i++,aep++) {
1325         HE **oentry = aep;
1326         HE *entry = *aep;
1327
1328         if (!entry)                             /* non-existent */
1329             continue;
1330         do {
1331             register I32 j = (HeHASH(entry) & newsize);
1332
1333             if (j != i) {
1334                 j -= i;
1335                 *oentry = HeNEXT(entry);
1336                 HeNEXT(entry) = aep[j];
1337                 aep[j] = entry;
1338             }
1339             else
1340                 oentry = &HeNEXT(entry);
1341             entry = *oentry;
1342         } while (entry);
1343     }
1344 }
1345
1346 HV *
1347 Perl_newHVhv(pTHX_ HV *ohv)
1348 {
1349     dVAR;
1350     HV * const hv = newHV();
1351     STRLEN hv_max;
1352
1353     if (!ohv || !HvTOTALKEYS(ohv))
1354         return hv;
1355     hv_max = HvMAX(ohv);
1356
1357     if (!SvMAGICAL((const SV *)ohv)) {
1358         /* It's an ordinary hash, so copy it fast. AMS 20010804 */
1359         STRLEN i;
1360         const bool shared = !!HvSHAREKEYS(ohv);
1361         HE **ents, ** const oents = (HE **)HvARRAY(ohv);
1362         char *a;
1363         Newx(a, PERL_HV_ARRAY_ALLOC_BYTES(hv_max+1), char);
1364         ents = (HE**)a;
1365
1366         /* In each bucket... */
1367         for (i = 0; i <= hv_max; i++) {
1368             HE *prev = NULL;
1369             HE *oent = oents[i];
1370
1371             if (!oent) {
1372                 ents[i] = NULL;
1373                 continue;
1374             }
1375
1376             /* Copy the linked list of entries. */
1377             for (; oent; oent = HeNEXT(oent)) {
1378                 const U32 hash   = HeHASH(oent);
1379                 const char * const key = HeKEY(oent);
1380                 const STRLEN len = HeKLEN(oent);
1381                 const int flags  = HeKFLAGS(oent);
1382                 HE * const ent   = new_HE();
1383                 SV *const val    = HeVAL(oent);
1384
1385                 HeVAL(ent) = SvIMMORTAL(val) ? val : newSVsv(val);
1386                 HeKEY_hek(ent)
1387                     = shared ? share_hek_flags(key, len, hash, flags)
1388                              :  save_hek_flags(key, len, hash, flags);
1389                 if (prev)
1390                     HeNEXT(prev) = ent;
1391                 else
1392                     ents[i] = ent;
1393                 prev = ent;
1394                 HeNEXT(ent) = NULL;
1395             }
1396         }
1397
1398         HvMAX(hv)   = hv_max;
1399         HvTOTALKEYS(hv)  = HvTOTALKEYS(ohv);
1400         HvARRAY(hv) = ents;
1401     } /* not magical */
1402     else {
1403         /* Iterate over ohv, copying keys and values one at a time. */
1404         HE *entry;
1405         const I32 riter = HvRITER_get(ohv);
1406         HE * const eiter = HvEITER_get(ohv);
1407         STRLEN hv_fill = HvFILL(ohv);
1408
1409         /* Can we use fewer buckets? (hv_max is always 2^n-1) */
1410         while (hv_max && hv_max + 1 >= hv_fill * 2)
1411             hv_max = hv_max / 2;
1412         HvMAX(hv) = hv_max;
1413
1414         hv_iterinit(ohv);
1415         while ((entry = hv_iternext_flags(ohv, 0))) {
1416             SV *const val = HeVAL(entry);
1417             (void)hv_store_flags(hv, HeKEY(entry), HeKLEN(entry),
1418                                  SvIMMORTAL(val) ? val : newSVsv(val),
1419                                  HeHASH(entry), HeKFLAGS(entry));
1420         }
1421         HvRITER_set(ohv, riter);
1422         HvEITER_set(ohv, eiter);
1423     }
1424
1425     return hv;
1426 }
1427
1428 /*
1429 =for apidoc Am|HV *|hv_copy_hints_hv|HV *ohv
1430
1431 A specialised version of L</newHVhv> for copying C<%^H>.  I<ohv> must be
1432 a pointer to a hash (which may have C<%^H> magic, but should be generally
1433 non-magical), or C<NULL> (interpreted as an empty hash).  The content
1434 of I<ohv> is copied to a new hash, which has the C<%^H>-specific magic
1435 added to it.  A pointer to the new hash is returned.
1436
1437 =cut
1438 */
1439
1440 HV *
1441 Perl_hv_copy_hints_hv(pTHX_ HV *const ohv)
1442 {
1443     HV * const hv = newHV();
1444
1445     if (ohv && HvTOTALKEYS(ohv)) {
1446         STRLEN hv_max = HvMAX(ohv);
1447         STRLEN hv_fill = HvFILL(ohv);
1448         HE *entry;
1449         const I32 riter = HvRITER_get(ohv);
1450         HE * const eiter = HvEITER_get(ohv);
1451
1452         while (hv_max && hv_max + 1 >= hv_fill * 2)
1453             hv_max = hv_max / 2;
1454         HvMAX(hv) = hv_max;
1455
1456         hv_iterinit(ohv);
1457         while ((entry = hv_iternext_flags(ohv, 0))) {
1458             SV *const sv = newSVsv(HeVAL(entry));
1459             SV *heksv = newSVhek(HeKEY_hek(entry));
1460             sv_magic(sv, NULL, PERL_MAGIC_hintselem,
1461                      (char *)heksv, HEf_SVKEY);
1462             SvREFCNT_dec(heksv);
1463             (void)hv_store_flags(hv, HeKEY(entry), HeKLEN(entry),
1464                                  sv, HeHASH(entry), HeKFLAGS(entry));
1465         }
1466         HvRITER_set(ohv, riter);
1467         HvEITER_set(ohv, eiter);
1468     }
1469     hv_magic(hv, NULL, PERL_MAGIC_hints);
1470     return hv;
1471 }
1472
1473 void
1474 Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry)
1475 {
1476     dVAR;
1477     SV *val;
1478
1479     PERL_ARGS_ASSERT_HV_FREE_ENT;
1480
1481     if (!entry)
1482         return;
1483     val = HeVAL(entry);
1484     if (val && isGV(val) && isGV_with_GP(val) && GvCVu(val) && HvENAME(hv))
1485         mro_method_changed_in(hv);      /* deletion of method from stash */
1486     SvREFCNT_dec(val);
1487     if (HeKLEN(entry) == HEf_SVKEY) {
1488         SvREFCNT_dec(HeKEY_sv(entry));
1489         Safefree(HeKEY_hek(entry));
1490     }
1491     else if (HvSHAREKEYS(hv))
1492         unshare_hek(HeKEY_hek(entry));
1493     else
1494         Safefree(HeKEY_hek(entry));
1495     del_HE(entry);
1496 }
1497
1498
1499 void
1500 Perl_hv_delayfree_ent(pTHX_ HV *hv, register HE *entry)
1501 {
1502     dVAR;
1503
1504     PERL_ARGS_ASSERT_HV_DELAYFREE_ENT;
1505
1506     if (!entry)
1507         return;
1508     /* SvREFCNT_inc to counter the SvREFCNT_dec in hv_free_ent  */
1509     sv_2mortal(SvREFCNT_inc(HeVAL(entry)));     /* free between statements */
1510     if (HeKLEN(entry) == HEf_SVKEY) {
1511         sv_2mortal(SvREFCNT_inc(HeKEY_sv(entry)));
1512     }
1513     hv_free_ent(hv, entry);
1514 }
1515
1516 /*
1517 =for apidoc hv_clear
1518
1519 Clears a hash, making it empty.
1520
1521 =cut
1522 */
1523
1524 void
1525 Perl_hv_clear(pTHX_ HV *hv)
1526 {
1527     dVAR;
1528     register XPVHV* xhv;
1529     if (!hv)
1530         return;
1531
1532     DEBUG_A(Perl_hv_assert(aTHX_ hv));
1533
1534     xhv = (XPVHV*)SvANY(hv);
1535
1536     if (SvREADONLY(hv) && HvARRAY(hv) != NULL) {
1537         /* restricted hash: convert all keys to placeholders */
1538         STRLEN i;
1539         for (i = 0; i <= xhv->xhv_max; i++) {
1540             HE *entry = (HvARRAY(hv))[i];
1541             for (; entry; entry = HeNEXT(entry)) {
1542                 /* not already placeholder */
1543                 if (HeVAL(entry) != &PL_sv_placeholder) {
1544                     if (HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
1545                         SV* const keysv = hv_iterkeysv(entry);
1546                         Perl_croak(aTHX_
1547                                    "Attempt to delete readonly key '%"SVf"' from a restricted hash",
1548                                    (void*)keysv);
1549                     }
1550                     SvREFCNT_dec(HeVAL(entry));
1551                     HeVAL(entry) = &PL_sv_placeholder;
1552                     HvPLACEHOLDERS(hv)++;
1553                 }
1554             }
1555         }
1556         goto reset;
1557     }
1558
1559     hfreeentries(hv);
1560     HvPLACEHOLDERS_set(hv, 0);
1561     if (HvARRAY(hv))
1562         Zero(HvARRAY(hv), xhv->xhv_max+1 /* HvMAX(hv)+1 */, HE*);
1563
1564     if (SvRMAGICAL(hv))
1565         mg_clear(MUTABLE_SV(hv));
1566
1567     HvHASKFLAGS_off(hv);
1568     HvREHASH_off(hv);
1569     reset:
1570     if (SvOOK(hv)) {
1571         if(HvENAME_get(hv))
1572             mro_isa_changed_in(hv);
1573         HvEITER_set(hv, NULL);
1574     }
1575 }
1576
1577 /*
1578 =for apidoc hv_clear_placeholders
1579
1580 Clears any placeholders from a hash.  If a restricted hash has any of its keys
1581 marked as readonly and the key is subsequently deleted, the key is not actually
1582 deleted but is marked by assigning it a value of &PL_sv_placeholder.  This tags
1583 it so it will be ignored by future operations such as iterating over the hash,
1584 but will still allow the hash to have a value reassigned to the key at some
1585 future point.  This function clears any such placeholder keys from the hash.
1586 See Hash::Util::lock_keys() for an example of its use.
1587
1588 =cut
1589 */
1590
1591 void
1592 Perl_hv_clear_placeholders(pTHX_ HV *hv)
1593 {
1594     dVAR;
1595     const U32 items = (U32)HvPLACEHOLDERS_get(hv);
1596
1597     PERL_ARGS_ASSERT_HV_CLEAR_PLACEHOLDERS;
1598
1599     if (items)
1600         clear_placeholders(hv, items);
1601 }
1602
1603 static void
1604 S_clear_placeholders(pTHX_ HV *hv, U32 items)
1605 {
1606     dVAR;
1607     I32 i;
1608
1609     PERL_ARGS_ASSERT_CLEAR_PLACEHOLDERS;
1610
1611     if (items == 0)
1612         return;
1613
1614     i = HvMAX(hv);
1615     do {
1616         /* Loop down the linked list heads  */
1617         bool first = TRUE;
1618         HE **oentry = &(HvARRAY(hv))[i];
1619         HE *entry;
1620
1621         while ((entry = *oentry)) {
1622             if (HeVAL(entry) == &PL_sv_placeholder) {
1623                 *oentry = HeNEXT(entry);
1624                 if (entry == HvEITER_get(hv))
1625                     HvLAZYDEL_on(hv);
1626                 else
1627                     hv_free_ent(hv, entry);
1628
1629                 if (--items == 0) {
1630                     /* Finished.  */
1631                     HvTOTALKEYS(hv) -= (IV)HvPLACEHOLDERS_get(hv);
1632                     if (HvKEYS(hv) == 0)
1633                         HvHASKFLAGS_off(hv);
1634                     HvPLACEHOLDERS_set(hv, 0);
1635                     return;
1636                 }
1637             } else {
1638                 oentry = &HeNEXT(entry);
1639                 first = FALSE;
1640             }
1641         }
1642     } while (--i >= 0);
1643     /* You can't get here, hence assertion should always fail.  */
1644     assert (items == 0);
1645     assert (0);
1646 }
1647
1648 STATIC void
1649 S_hfreeentries(pTHX_ HV *hv)
1650 {
1651     /* This is the array that we're going to restore  */
1652     HE **const orig_array = HvARRAY(hv);
1653     HEK *name;
1654     I32 name_count;
1655     int attempts = 100;
1656
1657     PERL_ARGS_ASSERT_HFREEENTRIES;
1658
1659     if (!orig_array)
1660         return;
1661
1662     if (SvOOK(hv)) {
1663         /* If the hash is actually a symbol table with a name, look after the
1664            name.  */
1665         struct xpvhv_aux *iter = HvAUX(hv);
1666
1667         name = iter->xhv_name;
1668         name_count = iter->xhv_name_count;
1669         iter->xhv_name = NULL;
1670     } else {
1671         name = NULL;
1672         name_count = 0;
1673     }
1674
1675     /* orig_array remains unchanged throughout the loop. If after freeing all
1676        the entries it turns out that one of the little blighters has triggered
1677        an action that has caused HvARRAY to be re-allocated, then we set
1678        array to the new HvARRAY, and try again.  */
1679
1680     while (1) {
1681         /* This is the one we're going to try to empty.  First time round
1682            it's the original array.  (Hopefully there will only be 1 time
1683            round) */
1684         HE ** const array = HvARRAY(hv);
1685         I32 i = HvMAX(hv);
1686
1687         /* Because we have taken xhv_name out, the only allocated pointer
1688            in the aux structure that might exist is the backreference array.
1689         */
1690
1691         if (SvOOK(hv)) {
1692             HE *entry;
1693             struct mro_meta *meta;
1694             struct xpvhv_aux *iter = HvAUX(hv);
1695             /* weak references: if called from sv_clear(), the backrefs
1696              * should already have been killed; if there are any left, its
1697              * because we're doing hv_clear() or hv_undef(), and the HV
1698              * will continue to live.
1699              * Because while freeing the entries we fake up a NULL HvARRAY
1700              * (and hence HvAUX), we need to store the backref array
1701              * somewhere else; but it still needs to be visible in case
1702              * any the things we free happen to call sv_del_backref().
1703              * We do this by storing it in magic instead.
1704              * If, during the entry freeing, a destructor happens to add
1705              * a new weak backref, then sv_add_backref will look in both
1706              * places (magic in HvAUX) for the AV, but will create a new
1707              * AV in HvAUX if it can't find one (if it finds it in magic,
1708              * it moves it back into HvAUX. So at the end of the iteration
1709              * we have to allow for this. */
1710
1711
1712             if (iter->xhv_backreferences) {
1713                 if (SvTYPE(iter->xhv_backreferences) == SVt_PVAV) {
1714                     /* The sv_magic will increase the reference count of the AV,
1715                        so we need to drop it first. */
1716                     SvREFCNT_dec(iter->xhv_backreferences);
1717                     if (AvFILLp(iter->xhv_backreferences) == -1) {
1718                         /* Turns out that the array is empty. Just free it.  */
1719                         SvREFCNT_dec(iter->xhv_backreferences);
1720
1721                     } else {
1722                         sv_magic(MUTABLE_SV(hv),
1723                                  MUTABLE_SV(iter->xhv_backreferences),
1724                                  PERL_MAGIC_backref, NULL, 0);
1725                     }
1726                 }
1727                 else {
1728                     MAGIC *mg;
1729                     sv_magic(MUTABLE_SV(hv), NULL, PERL_MAGIC_backref, NULL, 0);
1730                     mg = mg_find(MUTABLE_SV(hv), PERL_MAGIC_backref);
1731                     mg->mg_obj = (SV*)iter->xhv_backreferences;
1732                 }
1733                 iter->xhv_backreferences = NULL;
1734             }
1735
1736             entry = iter->xhv_eiter; /* HvEITER(hv) */
1737             if (entry && HvLAZYDEL(hv)) {       /* was deleted earlier? */
1738                 HvLAZYDEL_off(hv);
1739                 hv_free_ent(hv, entry);
1740             }
1741             iter->xhv_riter = -1;       /* HvRITER(hv) = -1 */
1742             iter->xhv_eiter = NULL;     /* HvEITER(hv) = NULL */
1743
1744             if((meta = iter->xhv_mro_meta)) {
1745                 if (meta->mro_linear_all) {
1746                     SvREFCNT_dec(MUTABLE_SV(meta->mro_linear_all));
1747                     meta->mro_linear_all = NULL;
1748                     /* This is just acting as a shortcut pointer.  */
1749                     meta->mro_linear_current = NULL;
1750                 } else if (meta->mro_linear_current) {
1751                     /* Only the current MRO is stored, so this owns the data.
1752                      */
1753                     SvREFCNT_dec(meta->mro_linear_current);
1754                     meta->mro_linear_current = NULL;
1755                 }
1756                 if(meta->mro_nextmethod) SvREFCNT_dec(meta->mro_nextmethod);
1757                 SvREFCNT_dec(meta->isa);
1758                 Safefree(meta);
1759                 iter->xhv_mro_meta = NULL;
1760             }
1761
1762             /* There are now no allocated pointers in the aux structure.  */
1763
1764             SvFLAGS(hv) &= ~SVf_OOK; /* Goodbye, aux structure.  */
1765             /* What aux structure?  */
1766         }
1767
1768         /* make everyone else think the array is empty, so that the destructors
1769          * called for freed entries can't recursively mess with us */
1770         HvARRAY(hv) = NULL;
1771         ((XPVHV*) SvANY(hv))->xhv_keys = 0;
1772
1773
1774         do {
1775             /* Loop down the linked list heads  */
1776             HE *entry = array[i];
1777
1778             while (entry) {
1779                 register HE * const oentry = entry;
1780                 entry = HeNEXT(entry);
1781                 hv_free_ent(hv, oentry);
1782             }
1783         } while (--i >= 0);
1784
1785         /* As there are no allocated pointers in the aux structure, it's now
1786            safe to free the array we just cleaned up, if it's not the one we're
1787            going to put back.  */
1788         if (array != orig_array) {
1789             Safefree(array);
1790         }
1791
1792         if (!HvARRAY(hv)) {
1793             /* Good. No-one added anything this time round.  */
1794             break;
1795         }
1796
1797         if (SvOOK(hv)) {
1798             /* Someone attempted to iterate or set the hash name while we had
1799                the array set to 0.  We'll catch backferences on the next time
1800                round the while loop.  */
1801             assert(HvARRAY(hv));
1802
1803             if (HvAUX(hv)->xhv_name) {
1804                 if(HvAUX(hv)->xhv_name_count) {
1805                     HEK ** const name = (HEK **)HvAUX(hv)->xhv_name;
1806                     I32 const count = HvAUX(hv)->xhv_name_count;
1807                     HEK **hekp = name + (count < 0 ? -count : count);
1808                     while(hekp-- > name)
1809                         unshare_hek_or_pvn(*hekp, 0, 0, 0);
1810                     Safefree(name);
1811                 }
1812                 else unshare_hek_or_pvn(HvAUX(hv)->xhv_name, 0, 0, 0);
1813             }
1814         }
1815
1816         if (--attempts == 0) {
1817             Perl_die(aTHX_ "panic: hfreeentries failed to free hash - something is repeatedly re-creating entries");
1818         }
1819     }
1820
1821     HvARRAY(hv) = orig_array;
1822
1823     /* If the hash was actually a symbol table, put the name back.  */
1824     if (name) {
1825         /* We have restored the original array.  If name is non-NULL, then
1826            the original array had an aux structure at the end. So this is
1827            valid:  */
1828         struct xpvhv_aux * const aux = HvAUX(hv);
1829         SvFLAGS(hv) |= SVf_OOK;
1830         aux->xhv_name = name;
1831         aux->xhv_name_count = name_count;
1832     }
1833 }
1834
1835 /*
1836 =for apidoc hv_undef
1837
1838 Undefines the hash.
1839
1840 =cut
1841 */
1842
1843 void
1844 Perl_hv_undef(pTHX_ HV *hv)
1845 {
1846     dVAR;
1847     register XPVHV* xhv;
1848     const char *name;
1849
1850     if (!hv)
1851         return;
1852     DEBUG_A(Perl_hv_assert(aTHX_ hv));
1853     xhv = (XPVHV*)SvANY(hv);
1854
1855     if ((name = HvENAME_get(hv)) && !PL_dirty)
1856         mro_isa_changed_in(hv);
1857
1858     hfreeentries(hv);
1859     if (name || (name = HvNAME(hv))) {
1860         if (PL_stashcache)
1861             (void)hv_delete(PL_stashcache, name, HvNAMELEN_get(hv), G_DISCARD);
1862         hv_name_set(hv, NULL, 0, 0);
1863     }
1864     SvFLAGS(hv) &= ~SVf_OOK;
1865     Safefree(HvARRAY(hv));
1866     xhv->xhv_max   = 7; /* HvMAX(hv) = 7 (it's a normal hash) */
1867     HvARRAY(hv) = 0;
1868     HvPLACEHOLDERS_set(hv, 0);
1869
1870     if (SvRMAGICAL(hv))
1871         mg_clear(MUTABLE_SV(hv));
1872 }
1873
1874 /*
1875 =for apidoc hv_fill
1876
1877 Returns the number of hash buckets that happen to be in use. This function is
1878 wrapped by the macro C<HvFILL>.
1879
1880 Previously this value was stored in the HV structure, rather than being
1881 calculated on demand.
1882
1883 =cut
1884 */
1885
1886 STRLEN
1887 Perl_hv_fill(pTHX_ HV const *const hv)
1888 {
1889     STRLEN count = 0;
1890     HE **ents = HvARRAY(hv);
1891
1892     PERL_ARGS_ASSERT_HV_FILL;
1893
1894     if (ents) {
1895         HE *const *const last = ents + HvMAX(hv);
1896         count = last + 1 - ents;
1897
1898         do {
1899             if (!*ents)
1900                 --count;
1901         } while (++ents <= last);
1902     }
1903     return count;
1904 }
1905
1906 static struct xpvhv_aux*
1907 S_hv_auxinit(HV *hv) {
1908     struct xpvhv_aux *iter;
1909     char *array;
1910
1911     PERL_ARGS_ASSERT_HV_AUXINIT;
1912
1913     if (!HvARRAY(hv)) {
1914         Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(HvMAX(hv) + 1)
1915             + sizeof(struct xpvhv_aux), char);
1916     } else {
1917         array = (char *) HvARRAY(hv);
1918         Renew(array, PERL_HV_ARRAY_ALLOC_BYTES(HvMAX(hv) + 1)
1919               + sizeof(struct xpvhv_aux), char);
1920     }
1921     HvARRAY(hv) = (HE**) array;
1922     /* SvOOK_on(hv) attacks the IV flags.  */
1923     SvFLAGS(hv) |= SVf_OOK;
1924     iter = HvAUX(hv);
1925
1926     iter->xhv_riter = -1;       /* HvRITER(hv) = -1 */
1927     iter->xhv_eiter = NULL;     /* HvEITER(hv) = NULL */
1928     iter->xhv_name = 0;
1929     iter->xhv_name_count = 0;
1930     iter->xhv_backreferences = 0;
1931     iter->xhv_mro_meta = NULL;
1932     return iter;
1933 }
1934
1935 /*
1936 =for apidoc hv_iterinit
1937
1938 Prepares a starting point to traverse a hash table.  Returns the number of
1939 keys in the hash (i.e. the same as C<HvKEYS(hv)>).  The return value is
1940 currently only meaningful for hashes without tie magic.
1941
1942 NOTE: Before version 5.004_65, C<hv_iterinit> used to return the number of
1943 hash buckets that happen to be in use.  If you still need that esoteric
1944 value, you can get it through the macro C<HvFILL(hv)>.
1945
1946
1947 =cut
1948 */
1949
1950 I32
1951 Perl_hv_iterinit(pTHX_ HV *hv)
1952 {
1953     PERL_ARGS_ASSERT_HV_ITERINIT;
1954
1955     /* FIXME: Are we not NULL, or do we croak? Place bets now! */
1956
1957     if (!hv)
1958         Perl_croak(aTHX_ "Bad hash");
1959
1960     if (SvOOK(hv)) {
1961         struct xpvhv_aux * const iter = HvAUX(hv);
1962         HE * const entry = iter->xhv_eiter; /* HvEITER(hv) */
1963         if (entry && HvLAZYDEL(hv)) {   /* was deleted earlier? */
1964             HvLAZYDEL_off(hv);
1965             hv_free_ent(hv, entry);
1966         }
1967         iter->xhv_riter = -1;   /* HvRITER(hv) = -1 */
1968         iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
1969     } else {
1970         hv_auxinit(hv);
1971     }
1972
1973     /* used to be xhv->xhv_fill before 5.004_65 */
1974     return HvTOTALKEYS(hv);
1975 }
1976
1977 I32 *
1978 Perl_hv_riter_p(pTHX_ HV *hv) {
1979     struct xpvhv_aux *iter;
1980
1981     PERL_ARGS_ASSERT_HV_RITER_P;
1982
1983     if (!hv)
1984         Perl_croak(aTHX_ "Bad hash");
1985
1986     iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
1987     return &(iter->xhv_riter);
1988 }
1989
1990 HE **
1991 Perl_hv_eiter_p(pTHX_ HV *hv) {
1992     struct xpvhv_aux *iter;
1993
1994     PERL_ARGS_ASSERT_HV_EITER_P;
1995
1996     if (!hv)
1997         Perl_croak(aTHX_ "Bad hash");
1998
1999     iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
2000     return &(iter->xhv_eiter);
2001 }
2002
2003 void
2004 Perl_hv_riter_set(pTHX_ HV *hv, I32 riter) {
2005     struct xpvhv_aux *iter;
2006
2007     PERL_ARGS_ASSERT_HV_RITER_SET;
2008
2009     if (!hv)
2010         Perl_croak(aTHX_ "Bad hash");
2011
2012     if (SvOOK(hv)) {
2013         iter = HvAUX(hv);
2014     } else {
2015         if (riter == -1)
2016             return;
2017
2018         iter = hv_auxinit(hv);
2019     }
2020     iter->xhv_riter = riter;
2021 }
2022
2023 void
2024 Perl_hv_eiter_set(pTHX_ HV *hv, HE *eiter) {
2025     struct xpvhv_aux *iter;
2026
2027     PERL_ARGS_ASSERT_HV_EITER_SET;
2028
2029     if (!hv)
2030         Perl_croak(aTHX_ "Bad hash");
2031
2032     if (SvOOK(hv)) {
2033         iter = HvAUX(hv);
2034     } else {
2035         /* 0 is the default so don't go malloc()ing a new structure just to
2036            hold 0.  */
2037         if (!eiter)
2038             return;
2039
2040         iter = hv_auxinit(hv);
2041     }
2042     iter->xhv_eiter = eiter;
2043 }
2044
2045 void
2046 Perl_hv_name_set(pTHX_ HV *hv, const char *name, U32 len, U32 flags)
2047 {
2048     dVAR;
2049     struct xpvhv_aux *iter;
2050     U32 hash;
2051     HEK **spot;
2052
2053     PERL_ARGS_ASSERT_HV_NAME_SET;
2054     PERL_UNUSED_ARG(flags);
2055
2056     if (len > I32_MAX)
2057         Perl_croak(aTHX_ "panic: hv name too long (%"UVuf")", (UV) len);
2058
2059     if (SvOOK(hv)) {
2060         iter = HvAUX(hv);
2061         if (iter->xhv_name) {
2062             if(iter->xhv_name_count) {
2063               if(!name) {
2064                 HEK ** const name = (HEK **)HvAUX(hv)->xhv_name;
2065                 HEK **hekp = name + (
2066                     iter->xhv_name_count < 0
2067                      ? -iter->xhv_name_count
2068                      :  iter->xhv_name_count
2069                    );
2070                 while(hekp-- > name+1)
2071                     unshare_hek_or_pvn(*hekp, 0, 0, 0);
2072                 /* The first elem may be null. */
2073                 if(*name) unshare_hek_or_pvn(*name, 0, 0, 0);
2074                 Safefree(name);
2075                 spot = &iter->xhv_name;
2076                 iter->xhv_name_count = 0;
2077               }
2078               else {
2079                 spot = (HEK **)iter->xhv_name;
2080                 if(iter->xhv_name_count > 0) {
2081                     /* shift some things over */
2082                     Renew(spot, iter->xhv_name_count, HEK *);
2083                     spot[iter->xhv_name_count++] = spot[1];
2084                     spot[1] = spot[0];
2085                 }
2086                 else if(*spot) {
2087                     unshare_hek_or_pvn(*spot, 0, 0, 0);
2088                 }
2089               }
2090             }
2091             else {
2092                 unshare_hek_or_pvn(iter->xhv_name, 0, 0, 0);
2093                 spot = &iter->xhv_name;
2094             }
2095         }
2096         else spot = &iter->xhv_name;
2097     } else {
2098         if (name == 0)
2099             return;
2100
2101         iter = hv_auxinit(hv);
2102         spot = &iter->xhv_name;
2103     }
2104     PERL_HASH(hash, name, len);
2105     *spot = name ? share_hek(name, len, hash) : NULL;
2106     iter->xhv_name_count = 0;
2107 }
2108
2109 /*
2110 =for apidoc hv_ename_add
2111
2112 Adds a name to a stash's internal list of effective names. See
2113 C<hv_ename_delete>.
2114
2115 This is called when a stash is assigned to a new location in the symbol
2116 table.
2117
2118 =cut
2119 */
2120
2121 void
2122 Perl_hv_ename_add(pTHX_ HV *hv, const char *name, U32 len)
2123 {
2124     dVAR;
2125     struct xpvhv_aux *aux = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
2126     U32 hash;
2127
2128     PERL_ARGS_ASSERT_HV_ENAME_ADD;
2129
2130     if (len > I32_MAX)
2131         Perl_croak(aTHX_ "panic: hv name too long (%"UVuf")", (UV) len);
2132
2133     PERL_HASH(hash, name, len);
2134
2135     if (aux->xhv_name_count) {
2136         HEK ** const xhv_name = (HEK **)aux->xhv_name;
2137         I32 count = aux->xhv_name_count;
2138         HEK **hekp = xhv_name + (count < 0 ? -count : count);
2139         while (hekp-- > xhv_name)
2140             if (
2141              HEK_LEN(*hekp) == (I32)len && memEQ(HEK_KEY(*hekp), name, len)
2142             ) {
2143                 if (hekp == xhv_name && count < 0)
2144                     aux->xhv_name_count = -count;
2145                 return;
2146             }
2147         if (count < 0) aux->xhv_name_count--, count = -count;
2148         else aux->xhv_name_count++;
2149         Renewc(aux->xhv_name, count + 1, HEK *, HEK);
2150         ((HEK **)aux->xhv_name)[count] = share_hek(name, len, hash);
2151     }
2152     else {
2153         HEK *existing_name = aux->xhv_name;
2154         if (
2155             existing_name && HEK_LEN(existing_name) == (I32)len
2156          && memEQ(HEK_KEY(existing_name), name, len)
2157         ) return;
2158         Newxc(aux->xhv_name, 2, HEK *, HEK);
2159         aux->xhv_name_count = existing_name ? 2 : -2;
2160         *(HEK **)aux->xhv_name = existing_name;
2161         ((HEK **)aux->xhv_name)[1] = share_hek(name, len, hash);
2162     }
2163 }
2164
2165 /*
2166 =for apidoc hv_ename_delete
2167
2168 Removes a name from a stash's internal list of effective names. If this is
2169 the name returned by C<HvENAME>, then another name in the list will take
2170 its place (C<HvENAME> will use it).
2171
2172 This is called when a stash is deleted from the symbol table.
2173
2174 =cut
2175 */
2176
2177 void
2178 Perl_hv_ename_delete(pTHX_ HV *hv, const char *name, U32 len)
2179 {
2180     dVAR;
2181     struct xpvhv_aux *aux;
2182
2183     PERL_ARGS_ASSERT_HV_ENAME_DELETE;
2184
2185     if (len > I32_MAX)
2186         Perl_croak(aTHX_ "panic: hv name too long (%"UVuf")", (UV) len);
2187
2188     if (!SvOOK(hv)) return;
2189
2190     aux = HvAUX(hv);
2191     if (!aux->xhv_name) return;
2192
2193     if (aux->xhv_name_count) {
2194         HEK ** const namep = (HEK **)aux->xhv_name;
2195         I32 const count = aux->xhv_name_count;
2196         HEK **victim = namep + (count < 0 ? -count : count);
2197         while (victim-- > namep + 1)
2198             if (
2199                 HEK_LEN(*victim) == (I32)len
2200              && memEQ(HEK_KEY(*victim), name, len)
2201             ) {
2202                 unshare_hek_or_pvn(*victim, 0, 0, 0);
2203                 if (count < 0) ++aux->xhv_name_count;
2204                 else --aux->xhv_name_count;
2205                 if (
2206                     (aux->xhv_name_count == 1 || aux->xhv_name_count == -1)
2207                  && !*namep
2208                 ) {  /* if there are none left */
2209                     Safefree(namep);
2210                     aux->xhv_name = NULL;
2211                     aux->xhv_name_count = 0;
2212                 }
2213                 else {
2214                     /* Move the last one back to fill the empty slot. It
2215                        does not matter what order they are in. */
2216                     *victim = *(namep + (count < 0 ? -count : count) - 1);
2217                 }
2218                 return;
2219             }
2220         if (
2221             count > 0 && HEK_LEN(*namep) == (I32)len
2222          && memEQ(HEK_KEY(*namep),name,len)
2223         ) {
2224             aux->xhv_name_count = -count;
2225         }
2226     }
2227     else if(
2228         HEK_LEN(aux->xhv_name) == (I32)len
2229      && memEQ(HEK_KEY(aux->xhv_name), name, len)
2230     ) {
2231         const HEK * const namehek = aux->xhv_name;
2232         Newxc(aux->xhv_name, 1, HEK *, HEK);
2233         *(const HEK **)aux->xhv_name = namehek;
2234         aux->xhv_name_count = -1;
2235     }
2236 }
2237
2238 AV **
2239 Perl_hv_backreferences_p(pTHX_ HV *hv) {
2240     struct xpvhv_aux * const iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
2241
2242     PERL_ARGS_ASSERT_HV_BACKREFERENCES_P;
2243     PERL_UNUSED_CONTEXT;
2244
2245     return &(iter->xhv_backreferences);
2246 }
2247
2248 void
2249 Perl_hv_kill_backrefs(pTHX_ HV *hv) {
2250     AV *av;
2251
2252     PERL_ARGS_ASSERT_HV_KILL_BACKREFS;
2253
2254     if (!SvOOK(hv))
2255         return;
2256
2257     av = HvAUX(hv)->xhv_backreferences;
2258
2259     if (av) {
2260         HvAUX(hv)->xhv_backreferences = 0;
2261         Perl_sv_kill_backrefs(aTHX_ MUTABLE_SV(hv), av);
2262         if (SvTYPE(av) == SVt_PVAV)
2263             SvREFCNT_dec(av);
2264     }
2265 }
2266
2267 /*
2268 hv_iternext is implemented as a macro in hv.h
2269
2270 =for apidoc hv_iternext
2271
2272 Returns entries from a hash iterator.  See C<hv_iterinit>.
2273
2274 You may call C<hv_delete> or C<hv_delete_ent> on the hash entry that the
2275 iterator currently points to, without losing your place or invalidating your
2276 iterator.  Note that in this case the current entry is deleted from the hash
2277 with your iterator holding the last reference to it.  Your iterator is flagged
2278 to free the entry on the next call to C<hv_iternext>, so you must not discard
2279 your iterator immediately else the entry will leak - call C<hv_iternext> to
2280 trigger the resource deallocation.
2281
2282 =for apidoc hv_iternext_flags
2283
2284 Returns entries from a hash iterator.  See C<hv_iterinit> and C<hv_iternext>.
2285 The C<flags> value will normally be zero; if HV_ITERNEXT_WANTPLACEHOLDERS is
2286 set the placeholders keys (for restricted hashes) will be returned in addition
2287 to normal keys. By default placeholders are automatically skipped over.
2288 Currently a placeholder is implemented with a value that is
2289 C<&Perl_sv_placeholder>. Note that the implementation of placeholders and
2290 restricted hashes may change, and the implementation currently is
2291 insufficiently abstracted for any change to be tidy.
2292
2293 =cut
2294 */
2295
2296 HE *
2297 Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags)
2298 {
2299     dVAR;
2300     register XPVHV* xhv;
2301     register HE *entry;
2302     HE *oldentry;
2303     MAGIC* mg;
2304     struct xpvhv_aux *iter;
2305
2306     PERL_ARGS_ASSERT_HV_ITERNEXT_FLAGS;
2307
2308     if (!hv)
2309         Perl_croak(aTHX_ "Bad hash");
2310
2311     xhv = (XPVHV*)SvANY(hv);
2312
2313     if (!SvOOK(hv)) {
2314         /* Too many things (well, pp_each at least) merrily assume that you can
2315            call iv_iternext without calling hv_iterinit, so we'll have to deal
2316            with it.  */
2317         hv_iterinit(hv);
2318     }
2319     iter = HvAUX(hv);
2320
2321     oldentry = entry = iter->xhv_eiter; /* HvEITER(hv) */
2322     if (SvMAGICAL(hv) && SvRMAGICAL(hv)) {
2323         if ( ( mg = mg_find((const SV *)hv, PERL_MAGIC_tied) ) ) {
2324             SV * const key = sv_newmortal();
2325             if (entry) {
2326                 sv_setsv(key, HeSVKEY_force(entry));
2327                 SvREFCNT_dec(HeSVKEY(entry));       /* get rid of previous key */
2328             }
2329             else {
2330                 char *k;
2331                 HEK *hek;
2332
2333                 /* one HE per MAGICAL hash */
2334                 iter->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */
2335                 Zero(entry, 1, HE);
2336                 Newxz(k, HEK_BASESIZE + sizeof(const SV *), char);
2337                 hek = (HEK*)k;
2338                 HeKEY_hek(entry) = hek;
2339                 HeKLEN(entry) = HEf_SVKEY;
2340             }
2341             magic_nextpack(MUTABLE_SV(hv),mg,key);
2342             if (SvOK(key)) {
2343                 /* force key to stay around until next time */
2344                 HeSVKEY_set(entry, SvREFCNT_inc_simple_NN(key));
2345                 return entry;               /* beware, hent_val is not set */
2346             }
2347             SvREFCNT_dec(HeVAL(entry));
2348             Safefree(HeKEY_hek(entry));
2349             del_HE(entry);
2350             iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
2351             return NULL;
2352         }
2353     }
2354 #if defined(DYNAMIC_ENV_FETCH) && !defined(__riscos__)  /* set up %ENV for iteration */
2355     if (!entry && SvRMAGICAL((const SV *)hv)
2356         && mg_find((const SV *)hv, PERL_MAGIC_env)) {
2357         prime_env_iter();
2358 #ifdef VMS
2359         /* The prime_env_iter() on VMS just loaded up new hash values
2360          * so the iteration count needs to be reset back to the beginning
2361          */
2362         hv_iterinit(hv);
2363         iter = HvAUX(hv);
2364         oldentry = entry = iter->xhv_eiter; /* HvEITER(hv) */
2365 #endif
2366     }
2367 #endif
2368
2369     /* hv_iterint now ensures this.  */
2370     assert (HvARRAY(hv));
2371
2372     /* At start of hash, entry is NULL.  */
2373     if (entry)
2374     {
2375         entry = HeNEXT(entry);
2376         if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
2377             /*
2378              * Skip past any placeholders -- don't want to include them in
2379              * any iteration.
2380              */
2381             while (entry && HeVAL(entry) == &PL_sv_placeholder) {
2382                 entry = HeNEXT(entry);
2383             }
2384         }
2385     }
2386
2387     /* Skip the entire loop if the hash is empty.   */
2388     if ((flags & HV_ITERNEXT_WANTPLACEHOLDERS)
2389         ? HvTOTALKEYS(hv) : HvUSEDKEYS(hv)) {
2390         while (!entry) {
2391             /* OK. Come to the end of the current list.  Grab the next one.  */
2392
2393             iter->xhv_riter++; /* HvRITER(hv)++ */
2394             if (iter->xhv_riter > (I32)xhv->xhv_max /* HvRITER(hv) > HvMAX(hv) */) {
2395                 /* There is no next one.  End of the hash.  */
2396                 iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
2397                 break;
2398             }
2399             entry = (HvARRAY(hv))[iter->xhv_riter];
2400
2401             if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
2402                 /* If we have an entry, but it's a placeholder, don't count it.
2403                    Try the next.  */
2404                 while (entry && HeVAL(entry) == &PL_sv_placeholder)
2405                     entry = HeNEXT(entry);
2406             }
2407             /* Will loop again if this linked list starts NULL
2408                (for HV_ITERNEXT_WANTPLACEHOLDERS)
2409                or if we run through it and find only placeholders.  */
2410         }
2411     }
2412
2413     if (oldentry && HvLAZYDEL(hv)) {            /* was deleted earlier? */
2414         HvLAZYDEL_off(hv);
2415         hv_free_ent(hv, oldentry);
2416     }
2417
2418     /*if (HvREHASH(hv) && entry && !HeKREHASH(entry))
2419       PerlIO_printf(PerlIO_stderr(), "Awooga %p %p\n", (void*)hv, (void*)entry);*/
2420
2421     iter->xhv_eiter = entry; /* HvEITER(hv) = entry */
2422     return entry;
2423 }
2424
2425 /*
2426 =for apidoc hv_iterkey
2427
2428 Returns the key from the current position of the hash iterator.  See
2429 C<hv_iterinit>.
2430
2431 =cut
2432 */
2433
2434 char *
2435 Perl_hv_iterkey(pTHX_ register HE *entry, I32 *retlen)
2436 {
2437     PERL_ARGS_ASSERT_HV_ITERKEY;
2438
2439     if (HeKLEN(entry) == HEf_SVKEY) {
2440         STRLEN len;
2441         char * const p = SvPV(HeKEY_sv(entry), len);
2442         *retlen = len;
2443         return p;
2444     }
2445     else {
2446         *retlen = HeKLEN(entry);
2447         return HeKEY(entry);
2448     }
2449 }
2450
2451 /* unlike hv_iterval(), this always returns a mortal copy of the key */
2452 /*
2453 =for apidoc hv_iterkeysv
2454
2455 Returns the key as an C<SV*> from the current position of the hash
2456 iterator.  The return value will always be a mortal copy of the key.  Also
2457 see C<hv_iterinit>.
2458
2459 =cut
2460 */
2461
2462 SV *
2463 Perl_hv_iterkeysv(pTHX_ register HE *entry)
2464 {
2465     PERL_ARGS_ASSERT_HV_ITERKEYSV;
2466
2467     return sv_2mortal(newSVhek(HeKEY_hek(entry)));
2468 }
2469
2470 /*
2471 =for apidoc hv_iterval
2472
2473 Returns the value from the current position of the hash iterator.  See
2474 C<hv_iterkey>.
2475
2476 =cut
2477 */
2478
2479 SV *
2480 Perl_hv_iterval(pTHX_ HV *hv, register HE *entry)
2481 {
2482     PERL_ARGS_ASSERT_HV_ITERVAL;
2483
2484     if (SvRMAGICAL(hv)) {
2485         if (mg_find((const SV *)hv, PERL_MAGIC_tied)) {
2486             SV* const sv = sv_newmortal();
2487             if (HeKLEN(entry) == HEf_SVKEY)
2488                 mg_copy(MUTABLE_SV(hv), sv, (char*)HeKEY_sv(entry), HEf_SVKEY);
2489             else
2490                 mg_copy(MUTABLE_SV(hv), sv, HeKEY(entry), HeKLEN(entry));
2491             return sv;
2492         }
2493     }
2494     return HeVAL(entry);
2495 }
2496
2497 /*
2498 =for apidoc hv_iternextsv
2499
2500 Performs an C<hv_iternext>, C<hv_iterkey>, and C<hv_iterval> in one
2501 operation.
2502
2503 =cut
2504 */
2505
2506 SV *
2507 Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen)
2508 {
2509     HE * const he = hv_iternext_flags(hv, 0);
2510
2511     PERL_ARGS_ASSERT_HV_ITERNEXTSV;
2512
2513     if (!he)
2514         return NULL;
2515     *key = hv_iterkey(he, retlen);
2516     return hv_iterval(hv, he);
2517 }
2518
2519 /*
2520
2521 Now a macro in hv.h
2522
2523 =for apidoc hv_magic
2524
2525 Adds magic to a hash.  See C<sv_magic>.
2526
2527 =cut
2528 */
2529
2530 /* possibly free a shared string if no one has access to it
2531  * len and hash must both be valid for str.
2532  */
2533 void
2534 Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
2535 {
2536     unshare_hek_or_pvn (NULL, str, len, hash);
2537 }
2538
2539
2540 void
2541 Perl_unshare_hek(pTHX_ HEK *hek)
2542 {
2543     assert(hek);
2544     unshare_hek_or_pvn(hek, NULL, 0, 0);
2545 }
2546
2547 /* possibly free a shared string if no one has access to it
2548    hek if non-NULL takes priority over the other 3, else str, len and hash
2549    are used.  If so, len and hash must both be valid for str.
2550  */
2551 STATIC void
2552 S_unshare_hek_or_pvn(pTHX_ const HEK *hek, const char *str, I32 len, U32 hash)
2553 {
2554     dVAR;
2555     register XPVHV* xhv;
2556     HE *entry;
2557     register HE **oentry;
2558     HE **first;
2559     bool is_utf8 = FALSE;
2560     int k_flags = 0;
2561     const char * const save = str;
2562     struct shared_he *he = NULL;
2563
2564     if (hek) {
2565         /* Find the shared he which is just before us in memory.  */
2566         he = (struct shared_he *)(((char *)hek)
2567                                   - STRUCT_OFFSET(struct shared_he,
2568                                                   shared_he_hek));
2569
2570         /* Assert that the caller passed us a genuine (or at least consistent)
2571            shared hek  */
2572         assert (he->shared_he_he.hent_hek == hek);
2573
2574         if (he->shared_he_he.he_valu.hent_refcount - 1) {
2575             --he->shared_he_he.he_valu.hent_refcount;
2576             return;
2577         }
2578
2579         hash = HEK_HASH(hek);
2580     } else if (len < 0) {
2581         STRLEN tmplen = -len;
2582         is_utf8 = TRUE;
2583         /* See the note in hv_fetch(). --jhi */
2584         str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2585         len = tmplen;
2586         if (is_utf8)
2587             k_flags = HVhek_UTF8;
2588         if (str != save)
2589             k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2590     }
2591
2592     /* what follows was the moral equivalent of:
2593     if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) {
2594         if (--*Svp == NULL)
2595             hv_delete(PL_strtab, str, len, G_DISCARD, hash);
2596     } */
2597     xhv = (XPVHV*)SvANY(PL_strtab);
2598     /* assert(xhv_array != 0) */
2599     first = oentry = &(HvARRAY(PL_strtab))[hash & (I32) HvMAX(PL_strtab)];
2600     if (he) {
2601         const HE *const he_he = &(he->shared_he_he);
2602         for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) {
2603             if (entry == he_he)
2604                 break;
2605         }
2606     } else {
2607         const int flags_masked = k_flags & HVhek_MASK;
2608         for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) {
2609             if (HeHASH(entry) != hash)          /* strings can't be equal */
2610                 continue;
2611             if (HeKLEN(entry) != len)
2612                 continue;
2613             if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len))     /* is this it? */
2614                 continue;
2615             if (HeKFLAGS(entry) != flags_masked)
2616                 continue;
2617             break;
2618         }
2619     }
2620
2621     if (entry) {
2622         if (--entry->he_valu.hent_refcount == 0) {
2623             *oentry = HeNEXT(entry);
2624             Safefree(entry);
2625             xhv->xhv_keys--; /* HvTOTALKEYS(hv)-- */
2626         }
2627     }
2628
2629     if (!entry)
2630         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
2631                          "Attempt to free non-existent shared string '%s'%s"
2632                          pTHX__FORMAT,
2633                          hek ? HEK_KEY(hek) : str,
2634                          ((k_flags & HVhek_UTF8) ? " (utf8)" : "") pTHX__VALUE);
2635     if (k_flags & HVhek_FREEKEY)
2636         Safefree(str);
2637 }
2638
2639 /* get a (constant) string ptr from the global string table
2640  * string will get added if it is not already there.
2641  * len and hash must both be valid for str.
2642  */
2643 HEK *
2644 Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash)
2645 {
2646     bool is_utf8 = FALSE;
2647     int flags = 0;
2648     const char * const save = str;
2649
2650     PERL_ARGS_ASSERT_SHARE_HEK;
2651
2652     if (len < 0) {
2653       STRLEN tmplen = -len;
2654       is_utf8 = TRUE;
2655       /* See the note in hv_fetch(). --jhi */
2656       str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2657       len = tmplen;
2658       /* If we were able to downgrade here, then than means that we were passed
2659          in a key which only had chars 0-255, but was utf8 encoded.  */
2660       if (is_utf8)
2661           flags = HVhek_UTF8;
2662       /* If we found we were able to downgrade the string to bytes, then
2663          we should flag that it needs upgrading on keys or each.  Also flag
2664          that we need share_hek_flags to free the string.  */
2665       if (str != save)
2666           flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2667     }
2668
2669     return share_hek_flags (str, len, hash, flags);
2670 }
2671
2672 STATIC HEK *
2673 S_share_hek_flags(pTHX_ const char *str, I32 len, register U32 hash, int flags)
2674 {
2675     dVAR;
2676     register HE *entry;
2677     const int flags_masked = flags & HVhek_MASK;
2678     const U32 hindex = hash & (I32) HvMAX(PL_strtab);
2679     register XPVHV * const xhv = (XPVHV*)SvANY(PL_strtab);
2680
2681     PERL_ARGS_ASSERT_SHARE_HEK_FLAGS;
2682
2683     /* what follows is the moral equivalent of:
2684
2685     if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
2686         hv_store(PL_strtab, str, len, NULL, hash);
2687
2688         Can't rehash the shared string table, so not sure if it's worth
2689         counting the number of entries in the linked list
2690     */
2691
2692     /* assert(xhv_array != 0) */
2693     entry = (HvARRAY(PL_strtab))[hindex];
2694     for (;entry; entry = HeNEXT(entry)) {
2695         if (HeHASH(entry) != hash)              /* strings can't be equal */
2696             continue;
2697         if (HeKLEN(entry) != len)
2698             continue;
2699         if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
2700             continue;
2701         if (HeKFLAGS(entry) != flags_masked)
2702             continue;
2703         break;
2704     }
2705
2706     if (!entry) {
2707         /* What used to be head of the list.
2708            If this is NULL, then we're the first entry for this slot, which
2709            means we need to increate fill.  */
2710         struct shared_he *new_entry;
2711         HEK *hek;
2712         char *k;
2713         HE **const head = &HvARRAY(PL_strtab)[hindex];
2714         HE *const next = *head;
2715
2716         /* We don't actually store a HE from the arena and a regular HEK.
2717            Instead we allocate one chunk of memory big enough for both,
2718            and put the HEK straight after the HE. This way we can find the
2719            HEK directly from the HE.
2720         */
2721
2722         Newx(k, STRUCT_OFFSET(struct shared_he,
2723                                 shared_he_hek.hek_key[0]) + len + 2, char);
2724         new_entry = (struct shared_he *)k;
2725         entry = &(new_entry->shared_he_he);
2726         hek = &(new_entry->shared_he_hek);
2727
2728         Copy(str, HEK_KEY(hek), len, char);
2729         HEK_KEY(hek)[len] = 0;
2730         HEK_LEN(hek) = len;
2731         HEK_HASH(hek) = hash;
2732         HEK_FLAGS(hek) = (unsigned char)flags_masked;
2733
2734         /* Still "point" to the HEK, so that other code need not know what
2735            we're up to.  */
2736         HeKEY_hek(entry) = hek;
2737         entry->he_valu.hent_refcount = 0;
2738         HeNEXT(entry) = next;
2739         *head = entry;
2740
2741         xhv->xhv_keys++; /* HvTOTALKEYS(hv)++ */
2742         if (!next) {                    /* initial entry? */
2743         } else if (xhv->xhv_keys > xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */) {
2744                 hsplit(PL_strtab);
2745         }
2746     }
2747
2748     ++entry->he_valu.hent_refcount;
2749
2750     if (flags & HVhek_FREEKEY)
2751         Safefree(str);
2752
2753     return HeKEY_hek(entry);
2754 }
2755
2756 I32 *
2757 Perl_hv_placeholders_p(pTHX_ HV *hv)
2758 {
2759     dVAR;
2760     MAGIC *mg = mg_find((const SV *)hv, PERL_MAGIC_rhash);
2761
2762     PERL_ARGS_ASSERT_HV_PLACEHOLDERS_P;
2763
2764     if (!mg) {
2765         mg = sv_magicext(MUTABLE_SV(hv), 0, PERL_MAGIC_rhash, 0, 0, 0);
2766
2767         if (!mg) {
2768             Perl_die(aTHX_ "panic: hv_placeholders_p");
2769         }
2770     }
2771     return &(mg->mg_len);
2772 }
2773
2774
2775 I32
2776 Perl_hv_placeholders_get(pTHX_ const HV *hv)
2777 {
2778     dVAR;
2779     MAGIC * const mg = mg_find((const SV *)hv, PERL_MAGIC_rhash);
2780
2781     PERL_ARGS_ASSERT_HV_PLACEHOLDERS_GET;
2782
2783     return mg ? mg->mg_len : 0;
2784 }
2785
2786 void
2787 Perl_hv_placeholders_set(pTHX_ HV *hv, I32 ph)
2788 {
2789     dVAR;
2790     MAGIC * const mg = mg_find((const SV *)hv, PERL_MAGIC_rhash);
2791
2792     PERL_ARGS_ASSERT_HV_PLACEHOLDERS_SET;
2793
2794     if (mg) {
2795         mg->mg_len = ph;
2796     } else if (ph) {
2797         if (!sv_magicext(MUTABLE_SV(hv), 0, PERL_MAGIC_rhash, 0, 0, ph))
2798             Perl_die(aTHX_ "panic: hv_placeholders_set");
2799     }
2800     /* else we don't need to add magic to record 0 placeholders.  */
2801 }
2802
2803 STATIC SV *
2804 S_refcounted_he_value(pTHX_ const struct refcounted_he *he)
2805 {
2806     dVAR;
2807     SV *value;
2808
2809     PERL_ARGS_ASSERT_REFCOUNTED_HE_VALUE;
2810
2811     switch(he->refcounted_he_data[0] & HVrhek_typemask) {
2812     case HVrhek_undef:
2813         value = newSV(0);
2814         break;
2815     case HVrhek_delete:
2816         value = &PL_sv_placeholder;
2817         break;
2818     case HVrhek_IV:
2819         value = newSViv(he->refcounted_he_val.refcounted_he_u_iv);
2820         break;
2821     case HVrhek_UV:
2822         value = newSVuv(he->refcounted_he_val.refcounted_he_u_uv);
2823         break;
2824     case HVrhek_PV:
2825     case HVrhek_PV_UTF8:
2826         /* Create a string SV that directly points to the bytes in our
2827            structure.  */
2828         value = newSV_type(SVt_PV);
2829         SvPV_set(value, (char *) he->refcounted_he_data + 1);
2830         SvCUR_set(value, he->refcounted_he_val.refcounted_he_u_len);
2831         /* This stops anything trying to free it  */
2832         SvLEN_set(value, 0);
2833         SvPOK_on(value);
2834         SvREADONLY_on(value);
2835         if ((he->refcounted_he_data[0] & HVrhek_typemask) == HVrhek_PV_UTF8)
2836             SvUTF8_on(value);
2837         break;
2838     default:
2839         Perl_croak(aTHX_ "panic: refcounted_he_value bad flags %"UVxf,
2840                    (UV)he->refcounted_he_data[0]);
2841     }
2842     return value;
2843 }
2844
2845 /*
2846 =for apidoc m|HV *|refcounted_he_chain_2hv|const struct refcounted_he *c|U32 flags
2847
2848 Generates and returns a C<HV *> representing the content of a
2849 C<refcounted_he> chain.
2850 I<flags> is currently unused and must be zero.
2851
2852 =cut
2853 */
2854 HV *
2855 Perl_refcounted_he_chain_2hv(pTHX_ const struct refcounted_he *chain, U32 flags)
2856 {
2857     dVAR;
2858     HV *hv;
2859     U32 placeholders, max;
2860
2861     if (flags)
2862         Perl_croak(aTHX_ "panic: refcounted_he_chain_2hv bad flags %"UVxf,
2863             (UV)flags);
2864
2865     /* We could chase the chain once to get an idea of the number of keys,
2866        and call ksplit.  But for now we'll make a potentially inefficient
2867        hash with only 8 entries in its array.  */
2868     hv = newHV();
2869     max = HvMAX(hv);
2870     if (!HvARRAY(hv)) {
2871         char *array;
2872         Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(max + 1), char);
2873         HvARRAY(hv) = (HE**)array;
2874     }
2875
2876     placeholders = 0;
2877     while (chain) {
2878 #ifdef USE_ITHREADS
2879         U32 hash = chain->refcounted_he_hash;
2880 #else
2881         U32 hash = HEK_HASH(chain->refcounted_he_hek);
2882 #endif
2883         HE **oentry = &((HvARRAY(hv))[hash & max]);
2884         HE *entry = *oentry;
2885         SV *value;
2886
2887         for (; entry; entry = HeNEXT(entry)) {
2888             if (HeHASH(entry) == hash) {
2889                 /* We might have a duplicate key here.  If so, entry is older
2890                    than the key we've already put in the hash, so if they are
2891                    the same, skip adding entry.  */
2892 #ifdef USE_ITHREADS
2893                 const STRLEN klen = HeKLEN(entry);
2894                 const char *const key = HeKEY(entry);
2895                 if (klen == chain->refcounted_he_keylen
2896                     && (!!HeKUTF8(entry)
2897                         == !!(chain->refcounted_he_data[0] & HVhek_UTF8))
2898                     && memEQ(key, REF_HE_KEY(chain), klen))
2899                     goto next_please;
2900 #else
2901                 if (HeKEY_hek(entry) == chain->refcounted_he_hek)
2902                     goto next_please;
2903                 if (HeKLEN(entry) == HEK_LEN(chain->refcounted_he_hek)
2904                     && HeKUTF8(entry) == HEK_UTF8(chain->refcounted_he_hek)
2905                     && memEQ(HeKEY(entry), HEK_KEY(chain->refcounted_he_hek),
2906                              HeKLEN(entry)))
2907                     goto next_please;
2908 #endif
2909             }
2910         }
2911         assert (!entry);
2912         entry = new_HE();
2913
2914 #ifdef USE_ITHREADS
2915         HeKEY_hek(entry)
2916             = share_hek_flags(REF_HE_KEY(chain),
2917                               chain->refcounted_he_keylen,
2918                               chain->refcounted_he_hash,
2919                               (chain->refcounted_he_data[0]
2920                                & (HVhek_UTF8|HVhek_WASUTF8)));
2921 #else
2922         HeKEY_hek(entry) = share_hek_hek(chain->refcounted_he_hek);
2923 #endif
2924         value = refcounted_he_value(chain);
2925         if (value == &PL_sv_placeholder)
2926             placeholders++;
2927         HeVAL(entry) = value;
2928
2929         /* Link it into the chain.  */
2930         HeNEXT(entry) = *oentry;
2931         *oentry = entry;
2932
2933         HvTOTALKEYS(hv)++;
2934
2935     next_please:
2936         chain = chain->refcounted_he_next;
2937     }
2938
2939     if (placeholders) {
2940         clear_placeholders(hv, placeholders);
2941         HvTOTALKEYS(hv) -= placeholders;
2942     }
2943
2944     /* We could check in the loop to see if we encounter any keys with key
2945        flags, but it's probably not worth it, as this per-hash flag is only
2946        really meant as an optimisation for things like Storable.  */
2947     HvHASKFLAGS_on(hv);
2948     DEBUG_A(Perl_hv_assert(aTHX_ hv));
2949
2950     return hv;
2951 }
2952
2953 /*
2954 =for apidoc m|SV *|refcounted_he_fetch_pvn|const struct refcounted_he *chain|const char *keypv|STRLEN keylen|U32 hash|U32 flags
2955
2956 Search along a C<refcounted_he> chain for an entry with the key specified
2957 by I<keypv> and I<keylen>.  If I<flags> has the C<REFCOUNTED_HE_KEY_UTF8>
2958 bit set, the key octets are interpreted as UTF-8, otherwise they
2959 are interpreted as Latin-1.  I<hash> is a precomputed hash of the key
2960 string, or zero if it has not been precomputed.  Returns a mortal scalar
2961 representing the value associated with the key, or C<&PL_sv_placeholder>
2962 if there is no value associated with the key.
2963
2964 =cut
2965 */
2966
2967 SV *
2968 Perl_refcounted_he_fetch_pvn(pTHX_ const struct refcounted_he *chain,
2969                          const char *keypv, STRLEN keylen, U32 hash, U32 flags)
2970 {
2971     dVAR;
2972     U8 utf8_flag;
2973     PERL_ARGS_ASSERT_REFCOUNTED_HE_FETCH_PVN;
2974
2975     if (flags & ~REFCOUNTED_HE_KEY_UTF8)
2976         Perl_croak(aTHX_ "panic: refcounted_he_fetch_pvn bad flags %"UVxf,
2977             (UV)flags);
2978     if (!chain)
2979         return &PL_sv_placeholder;
2980     if (flags & REFCOUNTED_HE_KEY_UTF8) {
2981         /* For searching purposes, canonicalise to Latin-1 where possible. */
2982         const char *keyend = keypv + keylen, *p;
2983         STRLEN nonascii_count = 0;
2984         for (p = keypv; p != keyend; p++) {
2985             U8 c = (U8)*p;
2986             if (c & 0x80) {
2987                 if (!((c & 0xfe) == 0xc2 && ++p != keyend &&
2988                             (((U8)*p) & 0xc0) == 0x80))
2989                     goto canonicalised_key;
2990                 nonascii_count++;
2991             }
2992         }
2993         if (nonascii_count) {
2994             char *q;
2995             const char *p = keypv, *keyend = keypv + keylen;
2996             keylen -= nonascii_count;
2997             Newx(q, keylen, char);
2998             SAVEFREEPV(q);
2999             keypv = q;
3000             for (; p != keyend; p++, q++) {
3001                 U8 c = (U8)*p;
3002                 *q = (char)
3003                     ((c & 0x80) ? ((c & 0x03) << 6) | (((U8)*++p) & 0x3f) : c);
3004             }
3005         }
3006         flags &= ~REFCOUNTED_HE_KEY_UTF8;
3007         canonicalised_key: ;
3008     }
3009     utf8_flag = (flags & REFCOUNTED_HE_KEY_UTF8) ? HVhek_UTF8 : 0;
3010     if (!hash)
3011         PERL_HASH(hash, keypv, keylen);
3012
3013     for (; chain; chain = chain->refcounted_he_next) {
3014         if (
3015 #ifdef USE_ITHREADS
3016             hash == chain->refcounted_he_hash &&
3017             keylen == chain->refcounted_he_keylen &&
3018             memEQ(REF_HE_KEY(chain), keypv, keylen) &&
3019             utf8_flag == (chain->refcounted_he_data[0] & HVhek_UTF8)
3020 #else
3021             hash == HEK_HASH(chain->refcounted_he_hek) &&
3022             keylen == (STRLEN)HEK_LEN(chain->refcounted_he_hek) &&
3023             memEQ(HEK_KEY(chain->refcounted_he_hek), keypv, keylen) &&
3024             utf8_flag == (HEK_FLAGS(chain->refcounted_he_hek) & HVhek_UTF8)
3025 #endif
3026         )
3027             return sv_2mortal(refcounted_he_value(chain));
3028     }
3029     return &PL_sv_placeholder;
3030 }
3031
3032 /*
3033 =for apidoc m|SV *|refcounted_he_fetch_pv|const struct refcounted_he *chain|const char *key|U32 hash|U32 flags
3034
3035 Like L</refcounted_he_fetch_pvn>, but takes a nul-terminated string
3036 instead of a string/length pair.
3037
3038 =cut
3039 */
3040
3041 SV *
3042 Perl_refcounted_he_fetch_pv(pTHX_ const struct refcounted_he *chain,
3043                          const char *key, U32 hash, U32 flags)
3044 {
3045     PERL_ARGS_ASSERT_REFCOUNTED_HE_FETCH_PV;
3046     return refcounted_he_fetch_pvn(chain, key, strlen(key), hash, flags);
3047 }
3048
3049 /*
3050 =for apidoc m|SV *|refcounted_he_fetch_sv|const struct refcounted_he *chain|SV *key|U32 hash|U32 flags
3051
3052 Like L</refcounted_he_fetch_pvn>, but takes a Perl scalar instead of a
3053 string/length pair.
3054
3055 =cut
3056 */
3057
3058 SV *
3059 Perl_refcounted_he_fetch_sv(pTHX_ const struct refcounted_he *chain,
3060                          SV *key, U32 hash, U32 flags)
3061 {
3062     const char *keypv;
3063     STRLEN keylen;
3064     PERL_ARGS_ASSERT_REFCOUNTED_HE_FETCH_SV;
3065     if (flags & REFCOUNTED_HE_KEY_UTF8)
3066         Perl_croak(aTHX_ "panic: refcounted_he_fetch_sv bad flags %"UVxf,
3067             (UV)flags);
3068     keypv = SvPV_const(key, keylen);
3069     if (SvUTF8(key))
3070         flags |= REFCOUNTED_HE_KEY_UTF8;
3071     if (!hash && SvIsCOW_shared_hash(key))
3072         hash = SvSHARED_HASH(key);
3073     return refcounted_he_fetch_pvn(chain, keypv, keylen, hash, flags);
3074 }
3075
3076 /*
3077 =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
3078
3079 Creates a new C<refcounted_he>.  This consists of a single key/value
3080 pair and a reference to an existing C<refcounted_he> chain (which may
3081 be empty), and thus forms a longer chain.  When using the longer chain,
3082 the new key/value pair takes precedence over any entry for the same key
3083 further along the chain.
3084
3085 The new key is specified by I<keypv> and I<keylen>.  If I<flags> has
3086 the C<REFCOUNTED_HE_KEY_UTF8> bit set, the key octets are interpreted
3087 as UTF-8, otherwise they are interpreted as Latin-1.  I<hash> is
3088 a precomputed hash of the key string, or zero if it has not been
3089 precomputed.
3090
3091 I<value> is the scalar value to store for this key.  I<value> is copied
3092 by this function, which thus does not take ownership of any reference
3093 to it, and later changes to the scalar will not be reflected in the
3094 value visible in the C<refcounted_he>.  Complex types of scalar will not
3095 be stored with referential integrity, but will be coerced to strings.
3096 I<value> may be either null or C<&PL_sv_placeholder> to indicate that no
3097 value is to be associated with the key; this, as with any non-null value,
3098 takes precedence over the existence of a value for the key further along
3099 the chain.
3100
3101 I<parent> points to the rest of the C<refcounted_he> chain to be
3102 attached to the new C<refcounted_he>.  This function takes ownership
3103 of one reference to I<parent>, and returns one reference to the new
3104 C<refcounted_he>.
3105
3106 =cut
3107 */
3108
3109 struct refcounted_he *
3110 Perl_refcounted_he_new_pvn(pTHX_ struct refcounted_he *parent,
3111         const char *keypv, STRLEN keylen, U32 hash, SV *value, U32 flags)
3112 {
3113     dVAR;
3114     STRLEN value_len = 0;
3115     const char *value_p = NULL;
3116     bool is_pv;
3117     char value_type;
3118     char hekflags;
3119     STRLEN key_offset = 1;
3120     struct refcounted_he *he;
3121     PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_PVN;
3122
3123     if (!value || value == &PL_sv_placeholder) {
3124         value_type = HVrhek_delete;
3125     } else if (SvPOK(value)) {
3126         value_type = HVrhek_PV;
3127     } else if (SvIOK(value)) {
3128         value_type = SvUOK((const SV *)value) ? HVrhek_UV : HVrhek_IV;
3129     } else if (!SvOK(value)) {
3130         value_type = HVrhek_undef;
3131     } else {
3132         value_type = HVrhek_PV;
3133     }
3134     is_pv = value_type == HVrhek_PV;
3135     if (is_pv) {
3136         /* Do it this way so that the SvUTF8() test is after the SvPV, in case
3137            the value is overloaded, and doesn't yet have the UTF-8flag set.  */
3138         value_p = SvPV_const(value, value_len);
3139         if (SvUTF8(value))
3140             value_type = HVrhek_PV_UTF8;
3141         key_offset = value_len + 2;
3142     }
3143     hekflags = value_type;
3144
3145     if (flags & REFCOUNTED_HE_KEY_UTF8) {
3146         /* Canonicalise to Latin-1 where possible. */
3147         const char *keyend = keypv + keylen, *p;
3148         STRLEN nonascii_count = 0;
3149         for (p = keypv; p != keyend; p++) {
3150             U8 c = (U8)*p;
3151             if (c & 0x80) {
3152                 if (!((c & 0xfe) == 0xc2 && ++p != keyend &&
3153                             (((U8)*p) & 0xc0) == 0x80))
3154                     goto canonicalised_key;
3155                 nonascii_count++;
3156             }
3157         }
3158         if (nonascii_count) {
3159             char *q;
3160             const char *p = keypv, *keyend = keypv + keylen;
3161             keylen -= nonascii_count;
3162             Newx(q, keylen, char);
3163             SAVEFREEPV(q);
3164             keypv = q;
3165             for (; p != keyend; p++, q++) {
3166                 U8 c = (U8)*p;
3167                 *q = (char)
3168                     ((c & 0x80) ? ((c & 0x03) << 6) | (((U8)*++p) & 0x3f) : c);
3169             }
3170         }
3171         flags &= ~REFCOUNTED_HE_KEY_UTF8;
3172         canonicalised_key: ;
3173     }
3174     if (flags & REFCOUNTED_HE_KEY_UTF8)
3175         hekflags |= HVhek_UTF8;
3176     if (!hash)
3177         PERL_HASH(hash, keypv, keylen);
3178
3179 #ifdef USE_ITHREADS
3180     he = (struct refcounted_he*)
3181         PerlMemShared_malloc(sizeof(struct refcounted_he) - 1
3182                              + keylen
3183                              + key_offset);
3184 #else
3185     he = (struct refcounted_he*)
3186         PerlMemShared_malloc(sizeof(struct refcounted_he) - 1
3187                              + key_offset);
3188 #endif
3189
3190     he->refcounted_he_next = parent;
3191
3192     if (is_pv) {
3193         Copy(value_p, he->refcounted_he_data + 1, value_len + 1, char);
3194         he->refcounted_he_val.refcounted_he_u_len = value_len;
3195     } else if (value_type == HVrhek_IV) {
3196         he->refcounted_he_val.refcounted_he_u_iv = SvIVX(value);
3197     } else if (value_type == HVrhek_UV) {
3198         he->refcounted_he_val.refcounted_he_u_uv = SvUVX(value);
3199     }
3200
3201 #ifdef USE_ITHREADS
3202     he->refcounted_he_hash = hash;
3203     he->refcounted_he_keylen = keylen;
3204     Copy(keypv, he->refcounted_he_data + key_offset, keylen, char);
3205 #else
3206     he->refcounted_he_hek = share_hek_flags(keypv, keylen, hash, hekflags);
3207 #endif
3208
3209     he->refcounted_he_data[0] = hekflags;
3210     he->refcounted_he_refcnt = 1;
3211
3212     return he;
3213 }
3214
3215 /*
3216 =for apidoc m|struct refcounted_he *|refcounted_he_new_pv|struct refcounted_he *parent|const char *key|U32 hash|SV *value|U32 flags
3217
3218 Like L</refcounted_he_new_pvn>, but takes a nul-terminated string instead
3219 of a string/length pair.
3220
3221 =cut
3222 */
3223
3224 struct refcounted_he *
3225 Perl_refcounted_he_new_pv(pTHX_ struct refcounted_he *parent,
3226         const char *key, U32 hash, SV *value, U32 flags)
3227 {
3228     PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_PV;
3229     return refcounted_he_new_pvn(parent, key, strlen(key), hash, value, flags);
3230 }
3231
3232 /*
3233 =for apidoc m|struct refcounted_he *|refcounted_he_new_sv|struct refcounted_he *parent|SV *key|U32 hash|SV *value|U32 flags
3234
3235 Like L</refcounted_he_new_pvn>, but takes a Perl scalar instead of a
3236 string/length pair.
3237
3238 =cut
3239 */
3240
3241 struct refcounted_he *
3242 Perl_refcounted_he_new_sv(pTHX_ struct refcounted_he *parent,
3243         SV *key, U32 hash, SV *value, U32 flags)
3244 {
3245     const char *keypv;
3246     STRLEN keylen;
3247     PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_SV;
3248     if (flags & REFCOUNTED_HE_KEY_UTF8)
3249         Perl_croak(aTHX_ "panic: refcounted_he_new_sv bad flags %"UVxf,
3250             (UV)flags);
3251     keypv = SvPV_const(key, keylen);
3252     if (SvUTF8(key))
3253         flags |= REFCOUNTED_HE_KEY_UTF8;
3254     if (!hash && SvIsCOW_shared_hash(key))
3255         hash = SvSHARED_HASH(key);
3256     return refcounted_he_new_pvn(parent, keypv, keylen, hash, value, flags);
3257 }
3258
3259 /*
3260 =for apidoc m|void|refcounted_he_free|struct refcounted_he *he
3261
3262 Decrements the reference count of a C<refcounted_he> by one.  If the
3263 reference count reaches zero the structure's memory is freed, which
3264 (recursively) causes a reduction of its parent C<refcounted_he>'s
3265 reference count.  It is safe to pass a null pointer to this function:
3266 no action occurs in this case.
3267
3268 =cut
3269 */
3270
3271 void
3272 Perl_refcounted_he_free(pTHX_ struct refcounted_he *he) {
3273     dVAR;
3274     PERL_UNUSED_CONTEXT;
3275
3276     while (he) {
3277         struct refcounted_he *copy;
3278         U32 new_count;
3279
3280         HINTS_REFCNT_LOCK;
3281         new_count = --he->refcounted_he_refcnt;
3282         HINTS_REFCNT_UNLOCK;
3283
3284         if (new_count) {
3285             return;
3286         }
3287
3288 #ifndef USE_ITHREADS
3289         unshare_hek_or_pvn (he->refcounted_he_hek, 0, 0, 0);
3290 #endif
3291         copy = he;
3292         he = he->refcounted_he_next;
3293         PerlMemShared_free(copy);
3294     }
3295 }
3296
3297 /*
3298 =for apidoc m|struct refcounted_he *|refcounted_he_inc|struct refcounted_he *he
3299
3300 Increment the reference count of a C<refcounted_he>.  The pointer to the
3301 C<refcounted_he> is also returned.  It is safe to pass a null pointer
3302 to this function: no action occurs and a null pointer is returned.
3303
3304 =cut
3305 */
3306
3307 struct refcounted_he *
3308 Perl_refcounted_he_inc(pTHX_ struct refcounted_he *he)
3309 {
3310     if (he) {
3311         HINTS_REFCNT_LOCK;
3312         he->refcounted_he_refcnt++;
3313         HINTS_REFCNT_UNLOCK;
3314     }
3315     return he;
3316 }
3317
3318 /* pp_entereval is aware that labels are stored with a key ':' at the top of
3319    the linked list.  */
3320 const char *
3321 Perl_fetch_cop_label(pTHX_ COP *const cop, STRLEN *len, U32 *flags) {
3322     struct refcounted_he *const chain = cop->cop_hints_hash;
3323
3324     PERL_ARGS_ASSERT_FETCH_COP_LABEL;
3325
3326     if (!chain)
3327         return NULL;
3328 #ifdef USE_ITHREADS
3329     if (chain->refcounted_he_keylen != 1)
3330         return NULL;
3331     if (*REF_HE_KEY(chain) != ':')
3332         return NULL;
3333 #else
3334     if ((STRLEN)HEK_LEN(chain->refcounted_he_hek) != 1)
3335         return NULL;
3336     if (*HEK_KEY(chain->refcounted_he_hek) != ':')
3337         return NULL;
3338 #endif
3339     /* Stop anyone trying to really mess us up by adding their own value for
3340        ':' into %^H  */
3341     if ((chain->refcounted_he_data[0] & HVrhek_typemask) != HVrhek_PV
3342         && (chain->refcounted_he_data[0] & HVrhek_typemask) != HVrhek_PV_UTF8)
3343         return NULL;
3344
3345     if (len)
3346         *len = chain->refcounted_he_val.refcounted_he_u_len;
3347     if (flags) {
3348         *flags = ((chain->refcounted_he_data[0] & HVrhek_typemask)
3349                   == HVrhek_PV_UTF8) ? SVf_UTF8 : 0;
3350     }
3351     return chain->refcounted_he_data + 1;
3352 }
3353
3354 void
3355 Perl_store_cop_label(pTHX_ COP *const cop, const char *label, STRLEN len,
3356                      U32 flags)
3357 {
3358     SV *labelsv;
3359     PERL_ARGS_ASSERT_STORE_COP_LABEL;
3360
3361     if (flags & ~(SVf_UTF8))
3362         Perl_croak(aTHX_ "panic: store_cop_label illegal flag bits 0x%" UVxf,
3363                    (UV)flags);
3364     labelsv = sv_2mortal(newSVpvn(label, len));
3365     if (flags & SVf_UTF8)
3366         SvUTF8_on(labelsv);
3367     cop->cop_hints_hash
3368         = refcounted_he_new_pvs(cop->cop_hints_hash, ":", labelsv, 0);
3369 }
3370
3371 /*
3372 =for apidoc hv_assert
3373
3374 Check that a hash is in an internally consistent state.
3375
3376 =cut
3377 */
3378
3379 #ifdef DEBUGGING
3380
3381 void
3382 Perl_hv_assert(pTHX_ HV *hv)
3383 {
3384     dVAR;
3385     HE* entry;
3386     int withflags = 0;
3387     int placeholders = 0;
3388     int real = 0;
3389     int bad = 0;
3390     const I32 riter = HvRITER_get(hv);
3391     HE *eiter = HvEITER_get(hv);
3392
3393     PERL_ARGS_ASSERT_HV_ASSERT;
3394
3395     (void)hv_iterinit(hv);
3396
3397     while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))) {
3398         /* sanity check the values */
3399         if (HeVAL(entry) == &PL_sv_placeholder)
3400             placeholders++;
3401         else
3402             real++;
3403         /* sanity check the keys */
3404         if (HeSVKEY(entry)) {
3405             NOOP;   /* Don't know what to check on SV keys.  */
3406         } else if (HeKUTF8(entry)) {
3407             withflags++;
3408             if (HeKWASUTF8(entry)) {
3409                 PerlIO_printf(Perl_debug_log,
3410                             "hash key has both WASUTF8 and UTF8: '%.*s'\n",
3411                             (int) HeKLEN(entry),  HeKEY(entry));
3412                 bad = 1;
3413             }
3414         } else if (HeKWASUTF8(entry))
3415             withflags++;
3416     }
3417     if (!SvTIED_mg((const SV *)hv, PERL_MAGIC_tied)) {
3418         static const char bad_count[] = "Count %d %s(s), but hash reports %d\n";
3419         const int nhashkeys = HvUSEDKEYS(hv);
3420         const int nhashplaceholders = HvPLACEHOLDERS_get(hv);
3421
3422         if (nhashkeys != real) {
3423             PerlIO_printf(Perl_debug_log, bad_count, real, "keys", nhashkeys );
3424             bad = 1;
3425         }
3426         if (nhashplaceholders != placeholders) {
3427             PerlIO_printf(Perl_debug_log, bad_count, placeholders, "placeholder", nhashplaceholders );
3428             bad = 1;
3429         }
3430     }
3431     if (withflags && ! HvHASKFLAGS(hv)) {
3432         PerlIO_printf(Perl_debug_log,
3433                     "Hash has HASKFLAGS off but I count %d key(s) with flags\n",
3434                     withflags);
3435         bad = 1;
3436     }
3437     if (bad) {
3438         sv_dump(MUTABLE_SV(hv));
3439     }
3440     HvRITER_set(hv, riter);             /* Restore hash iterator state */
3441     HvEITER_set(hv, eiter);
3442 }
3443
3444 #endif
3445
3446 /*
3447  * Local variables:
3448  * c-indentation-style: bsd
3449  * c-basic-offset: 4
3450  * indent-tabs-mode: t
3451  * End:
3452  *
3453  * ex: set ts=8 sts=4 sw=4 noet:
3454  */