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