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