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