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