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     /* At start of hash, entry is NULL.  */
1859     if (entry)
1860     {
1861         entry = HeNEXT(entry);
1862         if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
1863             /*
1864              * Skip past any placeholders -- don't want to include them in
1865              * any iteration.
1866              */
1867             while (entry && HeVAL(entry) == &PL_sv_undef) {
1868                 entry = HeNEXT(entry);
1869             }
1870         }
1871     }
1872     while (!entry) {
1873         /* OK. Come to the end of the current list.  Grab the next one.  */
1874
1875         xhv->xhv_riter++; /* HvRITER(hv)++ */
1876         if (xhv->xhv_riter > (I32)xhv->xhv_max /* HvRITER(hv) > HvMAX(hv) */) {
1877             /* There is no next one.  End of the hash.  */
1878             xhv->xhv_riter = -1; /* HvRITER(hv) = -1 */
1879             break;
1880         }
1881         /* entry = (HvARRAY(hv))[HvRITER(hv)]; */
1882         entry = ((HE**)xhv->xhv_array)[xhv->xhv_riter];
1883
1884         if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
1885             /* If we have an entry, but it's a placeholder, don't count it.
1886                Try the next.  */
1887             while (entry && HeVAL(entry) == &PL_sv_undef)
1888                 entry = HeNEXT(entry);
1889         }
1890         /* Will loop again if this linked list starts NULL
1891            (for HV_ITERNEXT_WANTPLACEHOLDERS)
1892            or if we run through it and find only placeholders.  */
1893     }
1894
1895     if (oldentry && HvLAZYDEL(hv)) {            /* was deleted earlier? */
1896         HvLAZYDEL_off(hv);
1897         hv_free_ent(hv, oldentry);
1898     }
1899
1900     xhv->xhv_eiter = entry; /* HvEITER(hv) = entry */
1901     return entry;
1902 }
1903
1904 /*
1905 =for apidoc hv_iterkey
1906
1907 Returns the key from the current position of the hash iterator.  See
1908 C<hv_iterinit>.
1909
1910 =cut
1911 */
1912
1913 char *
1914 Perl_hv_iterkey(pTHX_ register HE *entry, I32 *retlen)
1915 {
1916     if (HeKLEN(entry) == HEf_SVKEY) {
1917         STRLEN len;
1918         char *p = SvPV(HeKEY_sv(entry), len);
1919         *retlen = len;
1920         return p;
1921     }
1922     else {
1923         *retlen = HeKLEN(entry);
1924         return HeKEY(entry);
1925     }
1926 }
1927
1928 /* unlike hv_iterval(), this always returns a mortal copy of the key */
1929 /*
1930 =for apidoc hv_iterkeysv
1931
1932 Returns the key as an C<SV*> from the current position of the hash
1933 iterator.  The return value will always be a mortal copy of the key.  Also
1934 see C<hv_iterinit>.
1935
1936 =cut
1937 */
1938
1939 SV *
1940 Perl_hv_iterkeysv(pTHX_ register HE *entry)
1941 {
1942     if (HeKLEN(entry) != HEf_SVKEY) {
1943         HEK *hek = HeKEY_hek(entry);
1944         int flags = HEK_FLAGS(hek);
1945         SV *sv;
1946
1947         if (flags & HVhek_WASUTF8) {
1948             /* Trouble :-)
1949                Andreas would like keys he put in as utf8 to come back as utf8
1950             */
1951             STRLEN utf8_len = HEK_LEN(hek);
1952             U8 *as_utf8 = bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len);
1953
1954             sv = newSVpvn ((char*)as_utf8, utf8_len);
1955             SvUTF8_on (sv);
1956             Safefree (as_utf8); /* bytes_to_utf8() allocates a new string */
1957         } else {
1958             sv = newSVpvn_share(HEK_KEY(hek),
1959                                 (HEK_UTF8(hek) ? -HEK_LEN(hek) : HEK_LEN(hek)),
1960                                 HEK_HASH(hek));
1961         }
1962         return sv_2mortal(sv);
1963     }
1964     return sv_mortalcopy(HeKEY_sv(entry));
1965 }
1966
1967 /*
1968 =for apidoc hv_iterval
1969
1970 Returns the value from the current position of the hash iterator.  See
1971 C<hv_iterkey>.
1972
1973 =cut
1974 */
1975
1976 SV *
1977 Perl_hv_iterval(pTHX_ HV *hv, register HE *entry)
1978 {
1979     if (SvRMAGICAL(hv)) {
1980         if (mg_find((SV*)hv, PERL_MAGIC_tied)) {
1981             SV* sv = sv_newmortal();
1982             if (HeKLEN(entry) == HEf_SVKEY)
1983                 mg_copy((SV*)hv, sv, (char*)HeKEY_sv(entry), HEf_SVKEY);
1984             else mg_copy((SV*)hv, sv, HeKEY(entry), HeKLEN(entry));
1985             return sv;
1986         }
1987     }
1988     return HeVAL(entry);
1989 }
1990
1991 /*
1992 =for apidoc hv_iternextsv
1993
1994 Performs an C<hv_iternext>, C<hv_iterkey>, and C<hv_iterval> in one
1995 operation.
1996
1997 =cut
1998 */
1999
2000 SV *
2001 Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen)
2002 {
2003     HE *he;
2004     if ( (he = hv_iternext_flags(hv, 0)) == NULL)
2005         return NULL;
2006     *key = hv_iterkey(he, retlen);
2007     return hv_iterval(hv, he);
2008 }
2009
2010 /*
2011 =for apidoc hv_magic
2012
2013 Adds magic to a hash.  See C<sv_magic>.
2014
2015 =cut
2016 */
2017
2018 void
2019 Perl_hv_magic(pTHX_ HV *hv, GV *gv, int how)
2020 {
2021     sv_magic((SV*)hv, (SV*)gv, how, Nullch, 0);
2022 }
2023
2024 #if 0 /* use the macro from hv.h instead */
2025
2026 char*
2027 Perl_sharepvn(pTHX_ const char *sv, I32 len, U32 hash)
2028 {
2029     return HEK_KEY(share_hek(sv, len, hash));
2030 }
2031
2032 #endif
2033
2034 /* possibly free a shared string if no one has access to it
2035  * len and hash must both be valid for str.
2036  */
2037 void
2038 Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
2039 {
2040     unshare_hek_or_pvn (NULL, str, len, hash);
2041 }
2042
2043
2044 void
2045 Perl_unshare_hek(pTHX_ HEK *hek)
2046 {
2047     unshare_hek_or_pvn(hek, NULL, 0, 0);
2048 }
2049
2050 /* possibly free a shared string if no one has access to it
2051    hek if non-NULL takes priority over the other 3, else str, len and hash
2052    are used.  If so, len and hash must both be valid for str.
2053  */
2054 STATIC void
2055 S_unshare_hek_or_pvn(pTHX_ HEK *hek, const char *str, I32 len, U32 hash)
2056 {
2057     register XPVHV* xhv;
2058     register HE *entry;
2059     register HE **oentry;
2060     register I32 i = 1;
2061     I32 found = 0;
2062     bool is_utf8 = FALSE;
2063     int k_flags = 0;
2064     const char *save = str;
2065
2066     if (hek) {
2067         hash = HEK_HASH(hek);
2068     } else if (len < 0) {
2069         STRLEN tmplen = -len;
2070         is_utf8 = TRUE;
2071         /* See the note in hv_fetch(). --jhi */
2072         str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2073         len = tmplen;
2074         if (is_utf8)
2075             k_flags = HVhek_UTF8;
2076         if (str != save)
2077             k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2078     }
2079
2080     /* what follows is the moral equivalent of:
2081     if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) {
2082         if (--*Svp == Nullsv)
2083             hv_delete(PL_strtab, str, len, G_DISCARD, hash);
2084     } */
2085     xhv = (XPVHV*)SvANY(PL_strtab);
2086     /* assert(xhv_array != 0) */
2087     LOCK_STRTAB_MUTEX;
2088     /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
2089     oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
2090     if (hek) {
2091         for (entry = *oentry; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
2092             if (HeKEY_hek(entry) != hek)
2093                 continue;
2094             found = 1;
2095             break;
2096         }
2097     } else {
2098         int flags_masked = k_flags & HVhek_MASK;
2099         for (entry = *oentry; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
2100             if (HeHASH(entry) != hash)          /* strings can't be equal */
2101                 continue;
2102             if (HeKLEN(entry) != len)
2103                 continue;
2104             if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len))     /* is this it? */
2105                 continue;
2106             if (HeKFLAGS(entry) != flags_masked)
2107                 continue;
2108             found = 1;
2109             break;
2110         }
2111     }
2112
2113     if (found) {
2114         if (--HeVAL(entry) == Nullsv) {
2115             *oentry = HeNEXT(entry);
2116             if (i && !*oentry)
2117                 xhv->xhv_fill--; /* HvFILL(hv)-- */
2118             Safefree(HeKEY_hek(entry));
2119             del_HE(entry);
2120             xhv->xhv_keys--; /* HvKEYS(hv)-- */
2121         }
2122     }
2123
2124     UNLOCK_STRTAB_MUTEX;
2125     if (!found && ckWARN_d(WARN_INTERNAL))
2126         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
2127                     "Attempt to free non-existent shared string '%s'%s",
2128                     hek ? HEK_KEY(hek) : str,
2129                     (k_flags & HVhek_UTF8) ? " (utf8)" : "");
2130     if (k_flags & HVhek_FREEKEY)
2131         Safefree(str);
2132 }
2133
2134 /* get a (constant) string ptr from the global string table
2135  * string will get added if it is not already there.
2136  * len and hash must both be valid for str.
2137  */
2138 HEK *
2139 Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash)
2140 {
2141     bool is_utf8 = FALSE;
2142     int flags = 0;
2143     const char *save = str;
2144
2145     if (len < 0) {
2146       STRLEN tmplen = -len;
2147       is_utf8 = TRUE;
2148       /* See the note in hv_fetch(). --jhi */
2149       str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2150       len = tmplen;
2151       /* If we were able to downgrade here, then than means that we were passed
2152          in a key which only had chars 0-255, but was utf8 encoded.  */
2153       if (is_utf8)
2154           flags = HVhek_UTF8;
2155       /* If we found we were able to downgrade the string to bytes, then
2156          we should flag that it needs upgrading on keys or each.  Also flag
2157          that we need share_hek_flags to free the string.  */
2158       if (str != save)
2159           flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2160     }
2161
2162     return share_hek_flags (str, len, hash, flags);
2163 }
2164
2165 STATIC HEK *
2166 S_share_hek_flags(pTHX_ const char *str, I32 len, register U32 hash, int flags)
2167 {
2168     register XPVHV* xhv;
2169     register HE *entry;
2170     register HE **oentry;
2171     register I32 i = 1;
2172     I32 found = 0;
2173     int flags_masked = flags & HVhek_MASK;
2174
2175     /* what follows is the moral equivalent of:
2176
2177     if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
2178         hv_store(PL_strtab, str, len, Nullsv, hash);
2179     */
2180     xhv = (XPVHV*)SvANY(PL_strtab);
2181     /* assert(xhv_array != 0) */
2182     LOCK_STRTAB_MUTEX;
2183     /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
2184     oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
2185     for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
2186         if (HeHASH(entry) != hash)              /* strings can't be equal */
2187             continue;
2188         if (HeKLEN(entry) != len)
2189             continue;
2190         if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
2191             continue;
2192         if (HeKFLAGS(entry) != flags_masked)
2193             continue;
2194         found = 1;
2195         break;
2196     }
2197     if (!found) {
2198         entry = new_HE();
2199         HeKEY_hek(entry) = save_hek_flags(str, len, hash, flags);
2200         HeVAL(entry) = Nullsv;
2201         HeNEXT(entry) = *oentry;
2202         *oentry = entry;
2203         xhv->xhv_keys++; /* HvKEYS(hv)++ */
2204         if (i) {                                /* initial entry? */
2205             xhv->xhv_fill++; /* HvFILL(hv)++ */
2206             if (xhv->xhv_keys > (IV)xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */)
2207                 hsplit(PL_strtab);
2208         }
2209     }
2210
2211     ++HeVAL(entry);                             /* use value slot as REFCNT */
2212     UNLOCK_STRTAB_MUTEX;
2213
2214     if (flags & HVhek_FREEKEY)
2215         Safefree(str);
2216
2217     return HeKEY_hek(entry);
2218 }