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