hv.c

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