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         Safefree(iter->xhv_name);
1631         Safefree(iter);
1632         ((XPVHV*) SvANY(hv))->xhv_aux = 0;
1633     }
1634 }
1635
1636 /*
1637 =for apidoc hv_undef
1638
1639 Undefines the hash.
1640
1641 =cut
1642 */
1643
1644 void
1645 Perl_hv_undef(pTHX_ HV *hv)
1646 {
1647     register XPVHV* xhv;
1648     const char *name;
1649     if (!hv)
1650         return;
1651     DEBUG_A(Perl_hv_assert(aTHX_ hv));
1652     xhv = (XPVHV*)SvANY(hv);
1653     hfreeentries(hv);
1654     Safefree(HvARRAY(hv));
1655     if ((name = HvNAME_get(hv))) {
1656         /* FIXME - strlen HvNAME  */
1657         if(PL_stashcache)
1658             hv_delete(PL_stashcache, name, strlen(name), 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
1791 char **
1792 Perl_hv_name_p(pTHX_ HV *hv)
1793 {
1794     struct xpvhv_aux *iter = ((XPVHV *)SvANY(hv))->xhv_aux;
1795
1796     if (!iter) {
1797         ((XPVHV *)SvANY(hv))->xhv_aux = iter = S_hv_auxinit(aTHX);
1798     }
1799     return &(iter->xhv_name);
1800 }
1801
1802 void
1803 Perl_hv_name_set(pTHX_ HV *hv, const char *name, STRLEN len, int flags)
1804 {
1805     struct xpvhv_aux *iter = ((XPVHV *)SvANY(hv))->xhv_aux;
1806
1807     if (iter) {
1808         Safefree(iter->xhv_name);
1809     } else {
1810         if (name == 0)
1811             return;
1812
1813         ((XPVHV *)SvANY(hv))->xhv_aux = iter = S_hv_auxinit(aTHX);
1814     }
1815     iter->xhv_name = savepvn(name, len);
1816 }
1817
1818 /*
1819 =for apidoc hv_iternext
1820
1821 Returns entries from a hash iterator.  See C<hv_iterinit>.
1822
1823 You may call C<hv_delete> or C<hv_delete_ent> on the hash entry that the
1824 iterator currently points to, without losing your place or invalidating your
1825 iterator.  Note that in this case the current entry is deleted from the hash
1826 with your iterator holding the last reference to it.  Your iterator is flagged
1827 to free the entry on the next call to C<hv_iternext>, so you must not discard
1828 your iterator immediately else the entry will leak - call C<hv_iternext> to
1829 trigger the resource deallocation.
1830
1831 =cut
1832 */
1833
1834 HE *
1835 Perl_hv_iternext(pTHX_ HV *hv)
1836 {
1837     return hv_iternext_flags(hv, 0);
1838 }
1839
1840 /*
1841 =for apidoc hv_iternext_flags
1842
1843 Returns entries from a hash iterator.  See C<hv_iterinit> and C<hv_iternext>.
1844 The C<flags> value will normally be zero; if HV_ITERNEXT_WANTPLACEHOLDERS is
1845 set the placeholders keys (for restricted hashes) will be returned in addition
1846 to normal keys. By default placeholders are automatically skipped over.
1847 Currently a placeholder is implemented with a value that is
1848 C<&Perl_sv_placeholder>. Note that the implementation of placeholders and
1849 restricted hashes may change, and the implementation currently is
1850 insufficiently abstracted for any change to be tidy.
1851
1852 =cut
1853 */
1854
1855 HE *
1856 Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags)
1857 {
1858     dVAR;
1859     register XPVHV* xhv;
1860     register HE *entry;
1861     HE *oldentry;
1862     MAGIC* mg;
1863     struct xpvhv_aux *iter;
1864
1865     if (!hv)
1866         Perl_croak(aTHX_ "Bad hash");
1867     xhv = (XPVHV*)SvANY(hv);
1868     iter = xhv->xhv_aux;
1869
1870     if (!iter) {
1871         /* Too many things (well, pp_each at least) merrily assume that you can
1872            call iv_iternext without calling hv_iterinit, so we'll have to deal
1873            with it.  */
1874         hv_iterinit(hv);
1875         iter = ((XPVHV *)SvANY(hv))->xhv_aux;
1876     }
1877
1878     oldentry = entry = iter->xhv_eiter; /* HvEITER(hv) */
1879
1880     if ((mg = SvTIED_mg((SV*)hv, PERL_MAGIC_tied))) {
1881         SV *key = sv_newmortal();
1882         if (entry) {
1883             sv_setsv(key, HeSVKEY_force(entry));
1884             SvREFCNT_dec(HeSVKEY(entry));       /* get rid of previous key */
1885         }
1886         else {
1887             char *k;
1888             HEK *hek;
1889
1890             /* one HE per MAGICAL hash */
1891             iter->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */
1892             Zero(entry, 1, HE);
1893             Newz(54, k, HEK_BASESIZE + sizeof(SV*), char);
1894             hek = (HEK*)k;
1895             HeKEY_hek(entry) = hek;
1896             HeKLEN(entry) = HEf_SVKEY;
1897         }
1898         magic_nextpack((SV*) hv,mg,key);
1899         if (SvOK(key)) {
1900             /* force key to stay around until next time */
1901             HeSVKEY_set(entry, SvREFCNT_inc(key));
1902             return entry;               /* beware, hent_val is not set */
1903         }
1904         if (HeVAL(entry))
1905             SvREFCNT_dec(HeVAL(entry));
1906         Safefree(HeKEY_hek(entry));
1907         del_HE(entry);
1908         iter->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */
1909         return Null(HE*);
1910     }
1911 #ifdef DYNAMIC_ENV_FETCH  /* set up %ENV for iteration */
1912     if (!entry && SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
1913         prime_env_iter();
1914 #endif
1915
1916     if (!HvARRAY(hv)) {
1917         char *darray;
1918         Newz(506, darray,
1919              PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
1920              char);
1921         HvARRAY(hv) = (HE**) darray;
1922     }
1923     /* At start of hash, entry is NULL.  */
1924     if (entry)
1925     {
1926         entry = HeNEXT(entry);
1927         if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
1928             /*
1929              * Skip past any placeholders -- don't want to include them in
1930              * any iteration.
1931              */
1932             while (entry && HeVAL(entry) == &PL_sv_placeholder) {
1933                 entry = HeNEXT(entry);
1934             }
1935         }
1936     }
1937     while (!entry) {
1938         /* OK. Come to the end of the current list.  Grab the next one.  */
1939
1940         iter->xhv_riter++; /* HvRITER(hv)++ */
1941         if (iter->xhv_riter > (I32)xhv->xhv_max /* HvRITER(hv) > HvMAX(hv) */) {
1942             /* There is no next one.  End of the hash.  */
1943             iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
1944             break;
1945         }
1946         entry = (HvARRAY(hv))[iter->xhv_riter];
1947
1948         if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
1949             /* If we have an entry, but it's a placeholder, don't count it.
1950                Try the next.  */
1951             while (entry && HeVAL(entry) == &PL_sv_placeholder)
1952                 entry = HeNEXT(entry);
1953         }
1954         /* Will loop again if this linked list starts NULL
1955            (for HV_ITERNEXT_WANTPLACEHOLDERS)
1956            or if we run through it and find only placeholders.  */
1957     }
1958
1959     if (oldentry && HvLAZYDEL(hv)) {            /* was deleted earlier? */
1960         HvLAZYDEL_off(hv);
1961         hv_free_ent(hv, oldentry);
1962     }
1963
1964     /*if (HvREHASH(hv) && entry && !HeKREHASH(entry))
1965       PerlIO_printf(PerlIO_stderr(), "Awooga %p %p\n", hv, entry);*/
1966
1967     iter->xhv_eiter = entry; /* HvEITER(hv) = entry */
1968     return entry;
1969 }
1970
1971 /*
1972 =for apidoc hv_iterkey
1973
1974 Returns the key from the current position of the hash iterator.  See
1975 C<hv_iterinit>.
1976
1977 =cut
1978 */
1979
1980 char *
1981 Perl_hv_iterkey(pTHX_ register HE *entry, I32 *retlen)
1982 {
1983     if (HeKLEN(entry) == HEf_SVKEY) {
1984         STRLEN len;
1985         char *p = SvPV(HeKEY_sv(entry), len);
1986         *retlen = len;
1987         return p;
1988     }
1989     else {
1990         *retlen = HeKLEN(entry);
1991         return HeKEY(entry);
1992     }
1993 }
1994
1995 /* unlike hv_iterval(), this always returns a mortal copy of the key */
1996 /*
1997 =for apidoc hv_iterkeysv
1998
1999 Returns the key as an C<SV*> from the current position of the hash
2000 iterator.  The return value will always be a mortal copy of the key.  Also
2001 see C<hv_iterinit>.
2002
2003 =cut
2004 */
2005
2006 SV *
2007 Perl_hv_iterkeysv(pTHX_ register HE *entry)
2008 {
2009     if (HeKLEN(entry) != HEf_SVKEY) {
2010         HEK *hek = HeKEY_hek(entry);
2011         const int flags = HEK_FLAGS(hek);
2012         SV *sv;
2013
2014         if (flags & HVhek_WASUTF8) {
2015             /* Trouble :-)
2016                Andreas would like keys he put in as utf8 to come back as utf8
2017             */
2018             STRLEN utf8_len = HEK_LEN(hek);
2019             U8 *as_utf8 = bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len);
2020
2021             sv = newSVpvn ((char*)as_utf8, utf8_len);
2022             SvUTF8_on (sv);
2023             Safefree (as_utf8); /* bytes_to_utf8() allocates a new string */
2024         } else if (flags & HVhek_REHASH) {
2025             /* We don't have a pointer to the hv, so we have to replicate the
2026                flag into every HEK. This hv is using custom a hasing
2027                algorithm. Hence we can't return a shared string scalar, as
2028                that would contain the (wrong) hash value, and might get passed
2029                into an hv routine with a regular hash  */
2030
2031             sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek));
2032             if (HEK_UTF8(hek))
2033                 SvUTF8_on (sv);
2034         } else {
2035             sv = newSVpvn_share(HEK_KEY(hek),
2036                                 (HEK_UTF8(hek) ? -HEK_LEN(hek) : HEK_LEN(hek)),
2037                                 HEK_HASH(hek));
2038         }
2039         return sv_2mortal(sv);
2040     }
2041     return sv_mortalcopy(HeKEY_sv(entry));
2042 }
2043
2044 /*
2045 =for apidoc hv_iterval
2046
2047 Returns the value from the current position of the hash iterator.  See
2048 C<hv_iterkey>.
2049
2050 =cut
2051 */
2052
2053 SV *
2054 Perl_hv_iterval(pTHX_ HV *hv, register HE *entry)
2055 {
2056     if (SvRMAGICAL(hv)) {
2057         if (mg_find((SV*)hv, PERL_MAGIC_tied)) {
2058             SV* sv = sv_newmortal();
2059             if (HeKLEN(entry) == HEf_SVKEY)
2060                 mg_copy((SV*)hv, sv, (char*)HeKEY_sv(entry), HEf_SVKEY);
2061             else
2062                 mg_copy((SV*)hv, sv, HeKEY(entry), HeKLEN(entry));
2063             return sv;
2064         }
2065     }
2066     return HeVAL(entry);
2067 }
2068
2069 /*
2070 =for apidoc hv_iternextsv
2071
2072 Performs an C<hv_iternext>, C<hv_iterkey>, and C<hv_iterval> in one
2073 operation.
2074
2075 =cut
2076 */
2077
2078 SV *
2079 Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen)
2080 {
2081     HE *he;
2082     if ( (he = hv_iternext_flags(hv, 0)) == NULL)
2083         return NULL;
2084     *key = hv_iterkey(he, retlen);
2085     return hv_iterval(hv, he);
2086 }
2087
2088 /*
2089 =for apidoc hv_magic
2090
2091 Adds magic to a hash.  See C<sv_magic>.
2092
2093 =cut
2094 */
2095
2096 void
2097 Perl_hv_magic(pTHX_ HV *hv, GV *gv, int how)
2098 {
2099     sv_magic((SV*)hv, (SV*)gv, how, Nullch, 0);
2100 }
2101
2102 #if 0 /* use the macro from hv.h instead */
2103
2104 char*
2105 Perl_sharepvn(pTHX_ const char *sv, I32 len, U32 hash)
2106 {
2107     return HEK_KEY(share_hek(sv, len, hash));
2108 }
2109
2110 #endif
2111
2112 /* possibly free a shared string if no one has access to it
2113  * len and hash must both be valid for str.
2114  */
2115 void
2116 Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
2117 {
2118     unshare_hek_or_pvn (NULL, str, len, hash);
2119 }
2120
2121
2122 void
2123 Perl_unshare_hek(pTHX_ HEK *hek)
2124 {
2125     unshare_hek_or_pvn(hek, NULL, 0, 0);
2126 }
2127
2128 /* possibly free a shared string if no one has access to it
2129    hek if non-NULL takes priority over the other 3, else str, len and hash
2130    are used.  If so, len and hash must both be valid for str.
2131  */
2132 STATIC void
2133 S_unshare_hek_or_pvn(pTHX_ HEK *hek, const char *str, I32 len, U32 hash)
2134 {
2135     register XPVHV* xhv;
2136     register HE *entry;
2137     register HE **oentry;
2138     register I32 i = 1;
2139     bool found = 0;
2140     bool is_utf8 = FALSE;
2141     int k_flags = 0;
2142     const char *save = str;
2143
2144     if (hek) {
2145         hash = HEK_HASH(hek);
2146     } else if (len < 0) {
2147         STRLEN tmplen = -len;
2148         is_utf8 = TRUE;
2149         /* See the note in hv_fetch(). --jhi */
2150         str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2151         len = tmplen;
2152         if (is_utf8)
2153             k_flags = HVhek_UTF8;
2154         if (str != save)
2155             k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2156     }
2157
2158     /* what follows is the moral equivalent of:
2159     if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) {
2160         if (--*Svp == Nullsv)
2161             hv_delete(PL_strtab, str, len, G_DISCARD, hash);
2162     } */
2163     xhv = (XPVHV*)SvANY(PL_strtab);
2164     /* assert(xhv_array != 0) */
2165     LOCK_STRTAB_MUTEX;
2166     oentry = &(HvARRAY(PL_strtab))[hash & (I32) HvMAX(PL_strtab)];
2167     if (hek) {
2168         for (entry = *oentry; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
2169             if (HeKEY_hek(entry) != hek)
2170                 continue;
2171             found = 1;
2172             break;
2173         }
2174     } else {
2175         const int flags_masked = k_flags & HVhek_MASK;
2176         for (entry = *oentry; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
2177             if (HeHASH(entry) != hash)          /* strings can't be equal */
2178                 continue;
2179             if (HeKLEN(entry) != len)
2180                 continue;
2181             if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len))     /* is this it? */
2182                 continue;
2183             if (HeKFLAGS(entry) != flags_masked)
2184                 continue;
2185             found = 1;
2186             break;
2187         }
2188     }
2189
2190     if (found) {
2191         if (--HeVAL(entry) == Nullsv) {
2192             *oentry = HeNEXT(entry);
2193             if (i && !*oentry)
2194                 xhv->xhv_fill--; /* HvFILL(hv)-- */
2195             Safefree(HeKEY_hek(entry));
2196             del_HE(entry);
2197             xhv->xhv_keys--; /* HvKEYS(hv)-- */
2198         }
2199     }
2200
2201     UNLOCK_STRTAB_MUTEX;
2202     if (!found && ckWARN_d(WARN_INTERNAL))
2203         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
2204                     "Attempt to free non-existent shared string '%s'%s"
2205                     pTHX__FORMAT,
2206                     hek ? HEK_KEY(hek) : str,
2207                     ((k_flags & HVhek_UTF8) ? " (utf8)" : "") pTHX__VALUE);
2208     if (k_flags & HVhek_FREEKEY)
2209         Safefree(str);
2210 }
2211
2212 /* get a (constant) string ptr from the global string table
2213  * string will get added if it is not already there.
2214  * len and hash must both be valid for str.
2215  */
2216 HEK *
2217 Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash)
2218 {
2219     bool is_utf8 = FALSE;
2220     int flags = 0;
2221     const char *save = str;
2222
2223     if (len < 0) {
2224       STRLEN tmplen = -len;
2225       is_utf8 = TRUE;
2226       /* See the note in hv_fetch(). --jhi */
2227       str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2228       len = tmplen;
2229       /* If we were able to downgrade here, then than means that we were passed
2230          in a key which only had chars 0-255, but was utf8 encoded.  */
2231       if (is_utf8)
2232           flags = HVhek_UTF8;
2233       /* If we found we were able to downgrade the string to bytes, then
2234          we should flag that it needs upgrading on keys or each.  Also flag
2235          that we need share_hek_flags to free the string.  */
2236       if (str != save)
2237           flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2238     }
2239
2240     return HeKEY_hek(share_hek_flags (str, len, hash, flags));
2241 }
2242
2243 STATIC HE *
2244 S_share_hek_flags(pTHX_ const char *str, I32 len, register U32 hash, int flags)
2245 {
2246     register XPVHV* xhv;
2247     register HE *entry;
2248     register HE **oentry;
2249     register I32 i = 1;
2250     I32 found = 0;
2251     const int flags_masked = flags & HVhek_MASK;
2252
2253     /* what follows is the moral equivalent of:
2254
2255     if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
2256         hv_store(PL_strtab, str, len, Nullsv, hash);
2257
2258         Can't rehash the shared string table, so not sure if it's worth
2259         counting the number of entries in the linked list
2260     */
2261     xhv = (XPVHV*)SvANY(PL_strtab);
2262     /* assert(xhv_array != 0) */
2263     LOCK_STRTAB_MUTEX;
2264     oentry = &(HvARRAY(PL_strtab))[hash & (I32) HvMAX(PL_strtab)];
2265     for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
2266         if (HeHASH(entry) != hash)              /* strings can't be equal */
2267             continue;
2268         if (HeKLEN(entry) != len)
2269             continue;
2270         if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
2271             continue;
2272         if (HeKFLAGS(entry) != flags_masked)
2273             continue;
2274         found = 1;
2275         break;
2276     }
2277     if (!found) {
2278         entry = new_HE();
2279         HeKEY_hek(entry) = save_hek_flags(str, len, hash, flags_masked);
2280         HeVAL(entry) = Nullsv;
2281         HeNEXT(entry) = *oentry;
2282         *oentry = entry;
2283         xhv->xhv_keys++; /* HvKEYS(hv)++ */
2284         if (i) {                                /* initial entry? */
2285             xhv->xhv_fill++; /* HvFILL(hv)++ */
2286         } else if (xhv->xhv_keys > (IV)xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */) {
2287                 hsplit(PL_strtab);
2288         }
2289     }
2290
2291     ++HeVAL(entry);                             /* use value slot as REFCNT */
2292     UNLOCK_STRTAB_MUTEX;
2293
2294     if (flags & HVhek_FREEKEY)
2295         Safefree(str);
2296
2297     return entry;
2298 }
2299
2300 I32 *
2301 Perl_hv_placeholders_p(pTHX_ HV *hv)
2302 {
2303     dVAR;
2304     MAGIC *mg = mg_find((SV*)hv, PERL_MAGIC_rhash);
2305
2306     if (!mg) {
2307         mg = sv_magicext((SV*)hv, 0, PERL_MAGIC_rhash, 0, 0, 0);
2308
2309         if (!mg) {
2310             Perl_die(aTHX_ "panic: hv_placeholders_p");
2311         }
2312     }
2313     return &(mg->mg_len);
2314 }
2315
2316
2317 I32
2318 Perl_hv_placeholders_get(pTHX_ HV *hv)
2319 {
2320     dVAR;
2321     MAGIC *mg = mg_find((SV*)hv, PERL_MAGIC_rhash);
2322
2323     return mg ? mg->mg_len : 0;
2324 }
2325
2326 void
2327 Perl_hv_placeholders_set(pTHX_ HV *hv, I32 ph)
2328 {
2329     dVAR;
2330     MAGIC *mg = mg_find((SV*)hv, PERL_MAGIC_rhash);
2331
2332     if (mg) {
2333         mg->mg_len = ph;
2334     } else if (ph) {
2335         if (!sv_magicext((SV*)hv, 0, PERL_MAGIC_rhash, 0, 0, ph))
2336             Perl_die(aTHX_ "panic: hv_placeholders_set");
2337     }
2338     /* else we don't need to add magic to record 0 placeholders.  */
2339 }
2340
2341 /*
2342 =for apidoc hv_assert
2343
2344 Check that a hash is in an internally consistent state.
2345
2346 =cut
2347 */
2348
2349 void
2350 Perl_hv_assert(pTHX_ HV *hv)
2351 {
2352   dVAR;
2353   HE* entry;
2354   int withflags = 0;
2355   int placeholders = 0;
2356   int real = 0;
2357   int bad = 0;
2358   const I32 riter = HvRITER_get(hv);
2359   HE *eiter = HvEITER_get(hv);
2360
2361   (void)hv_iterinit(hv);
2362
2363   while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))) {
2364     /* sanity check the values */
2365     if (HeVAL(entry) == &PL_sv_placeholder) {
2366       placeholders++;
2367     } else {
2368       real++;
2369     }
2370     /* sanity check the keys */
2371     if (HeSVKEY(entry)) {
2372       /* Don't know what to check on SV keys.  */
2373     } else if (HeKUTF8(entry)) {
2374       withflags++;
2375        if (HeKWASUTF8(entry)) {
2376          PerlIO_printf(Perl_debug_log,
2377                        "hash key has both WASUFT8 and UTF8: '%.*s'\n",
2378                        (int) HeKLEN(entry),  HeKEY(entry));
2379          bad = 1;
2380        }
2381     } else if (HeKWASUTF8(entry)) {
2382       withflags++;
2383     }
2384   }
2385   if (!SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) {
2386     if (HvUSEDKEYS(hv) != real) {
2387       PerlIO_printf(Perl_debug_log, "Count %d key(s), but hash reports %d\n",
2388                     (int) real, (int) HvUSEDKEYS(hv));
2389       bad = 1;
2390     }
2391     if (HvPLACEHOLDERS(hv) != placeholders) {
2392       PerlIO_printf(Perl_debug_log,
2393                     "Count %d placeholder(s), but hash reports %d\n",
2394                     (int) placeholders, (int) HvPLACEHOLDERS(hv));
2395       bad = 1;
2396     }
2397   }
2398   if (withflags && ! HvHASKFLAGS(hv)) {
2399     PerlIO_printf(Perl_debug_log,
2400                   "Hash has HASKFLAGS off but I count %d key(s) with flags\n",
2401                   withflags);
2402     bad = 1;
2403   }
2404   if (bad) {
2405     sv_dump((SV *)hv);
2406   }
2407   HvRITER_set(hv, riter);               /* Restore hash iterator state */
2408   HvEITER_set(hv, eiter);
2409 }
2410
2411 /*
2412  * Local variables:
2413  * c-indentation-style: bsd
2414  * c-basic-offset: 4
2415  * indent-tabs-mode: t
2416  * End:
2417  *
2418  * ex: set ts=8 sts=4 sw=4 noet:
2419  */