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