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