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