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