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