hv.c

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