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