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