hv.c

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