hv.c

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