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