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