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 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             U32 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) != 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) != 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) != 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 > 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) != 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 > 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) != 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) != 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 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 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) != 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) != 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         int i, shared = !!HvSHAREKEYS(ohv);
1519         HE **ents, **oents = (HE **)HvARRAY(ohv);
1520         char *a;
1521         New(0, a, PERL_HV_ARRAY_ALLOC_BYTES(hv_max+1), char);
1522         ents = (HE**)a;
1523
1524         /* In each bucket... */
1525         for (i = 0; i <= hv_max; i++) {
1526             HE *prev = NULL, *ent = NULL, *oent = oents[i];
1527
1528             if (!oent) {
1529                 ents[i] = NULL;
1530                 continue;
1531             }
1532
1533             /* Copy the linked list of entries. */
1534             for (oent = oents[i]; oent; oent = HeNEXT(oent)) {
1535                 U32 hash   = HeHASH(oent);
1536                 char *key  = HeKEY(oent);
1537                 STRLEN len = HeKLEN(oent);
1538                 int flags  = HeKFLAGS(oent);
1539
1540                 ent = new_HE();
1541                 HeVAL(ent)     = newSVsv(HeVAL(oent));
1542                 HeKEY_hek(ent)
1543                     = shared ? share_hek_flags(key, len, hash, flags)
1544                              :  save_hek_flags(key, len, hash, flags);
1545                 if (prev)
1546                     HeNEXT(prev) = ent;
1547                 else
1548                     ents[i] = ent;
1549                 prev = ent;
1550                 HeNEXT(ent) = NULL;
1551             }
1552         }
1553
1554         HvMAX(hv)   = hv_max;
1555         HvFILL(hv)  = hv_fill;
1556         HvTOTALKEYS(hv)  = HvTOTALKEYS(ohv);
1557         HvARRAY(hv) = ents;
1558     }
1559     else {
1560         /* Iterate over ohv, copying keys and values one at a time. */
1561         HE *entry;
1562         I32 riter = HvRITER(ohv);
1563         HE *eiter = HvEITER(ohv);
1564
1565         /* Can we use fewer buckets? (hv_max is always 2^n-1) */
1566         while (hv_max && hv_max + 1 >= hv_fill * 2)
1567             hv_max = hv_max / 2;
1568         HvMAX(hv) = hv_max;
1569
1570         hv_iterinit(ohv);
1571         while ((entry = hv_iternext_flags(ohv, 0))) {
1572             hv_store_flags(hv, HeKEY(entry), HeKLEN(entry),
1573                            newSVsv(HeVAL(entry)), HeHASH(entry),
1574                            HeKFLAGS(entry));
1575         }
1576         HvRITER(ohv) = riter;
1577         HvEITER(ohv) = eiter;
1578     }
1579
1580     return hv;
1581 }
1582
1583 void
1584 Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry)
1585 {
1586     SV *val;
1587
1588     if (!entry)
1589         return;
1590     val = HeVAL(entry);
1591     if (val && isGV(val) && GvCVu(val) && HvNAME(hv))
1592         PL_sub_generation++;    /* may be deletion of method from stash */
1593     SvREFCNT_dec(val);
1594     if (HeKLEN(entry) == HEf_SVKEY) {
1595         SvREFCNT_dec(HeKEY_sv(entry));
1596         Safefree(HeKEY_hek(entry));
1597     }
1598     else if (HvSHAREKEYS(hv))
1599         unshare_hek(HeKEY_hek(entry));
1600     else
1601         Safefree(HeKEY_hek(entry));
1602     del_HE(entry);
1603 }
1604
1605 void
1606 Perl_hv_delayfree_ent(pTHX_ HV *hv, register HE *entry)
1607 {
1608     if (!entry)
1609         return;
1610     if (isGV(HeVAL(entry)) && GvCVu(HeVAL(entry)) && HvNAME(hv))
1611         PL_sub_generation++;    /* may be deletion of method from stash */
1612     sv_2mortal(HeVAL(entry));   /* free between statements */
1613     if (HeKLEN(entry) == HEf_SVKEY) {
1614         sv_2mortal(HeKEY_sv(entry));
1615         Safefree(HeKEY_hek(entry));
1616     }
1617     else if (HvSHAREKEYS(hv))
1618         unshare_hek(HeKEY_hek(entry));
1619     else
1620         Safefree(HeKEY_hek(entry));
1621     del_HE(entry);
1622 }
1623
1624 /*
1625 =for apidoc hv_clear
1626
1627 Clears a hash, making it empty.
1628
1629 =cut
1630 */
1631
1632 void
1633 Perl_hv_clear(pTHX_ HV *hv)
1634 {
1635     register XPVHV* xhv;
1636     if (!hv)
1637         return;
1638
1639     if(SvREADONLY(hv)) {
1640         Perl_croak(aTHX_ "Attempt to clear a restricted hash");
1641     }
1642
1643     xhv = (XPVHV*)SvANY(hv);
1644     hfreeentries(hv);
1645     xhv->xhv_fill = 0; /* HvFILL(hv) = 0 */
1646     xhv->xhv_keys = 0; /* HvKEYS(hv) = 0 */
1647     xhv->xhv_placeholders = 0; /* HvPLACEHOLDERS(hv) = 0 */
1648     if (xhv->xhv_array /* HvARRAY(hv) */)
1649         (void)memzero(xhv->xhv_array /* HvARRAY(hv) */,
1650                       (xhv->xhv_max+1 /* HvMAX(hv)+1 */) * sizeof(HE*));
1651
1652     if (SvRMAGICAL(hv))
1653         mg_clear((SV*)hv);
1654
1655     HvHASKFLAGS_off(hv);
1656 }
1657
1658 STATIC void
1659 S_hfreeentries(pTHX_ HV *hv)
1660 {
1661     register HE **array;
1662     register HE *entry;
1663     register HE *oentry = Null(HE*);
1664     I32 riter;
1665     I32 max;
1666
1667     if (!hv)
1668         return;
1669     if (!HvARRAY(hv))
1670         return;
1671
1672     riter = 0;
1673     max = HvMAX(hv);
1674     array = HvARRAY(hv);
1675     entry = array[0];
1676     for (;;) {
1677         if (entry) {
1678             oentry = entry;
1679             entry = HeNEXT(entry);
1680             hv_free_ent(hv, oentry);
1681         }
1682         if (!entry) {
1683             if (++riter > max)
1684                 break;
1685             entry = array[riter];
1686         }
1687     }
1688     (void)hv_iterinit(hv);
1689 }
1690
1691 /*
1692 =for apidoc hv_undef
1693
1694 Undefines the hash.
1695
1696 =cut
1697 */
1698
1699 void
1700 Perl_hv_undef(pTHX_ HV *hv)
1701 {
1702     register XPVHV* xhv;
1703     if (!hv)
1704         return;
1705     xhv = (XPVHV*)SvANY(hv);
1706     hfreeentries(hv);
1707     Safefree(xhv->xhv_array /* HvARRAY(hv) */);
1708     if (HvNAME(hv)) {
1709         Safefree(HvNAME(hv));
1710         HvNAME(hv) = 0;
1711     }
1712     xhv->xhv_max   = 7; /* HvMAX(hv) = 7 (it's a normal hash) */
1713     xhv->xhv_array = 0; /* HvARRAY(hv) = 0 */
1714     xhv->xhv_fill  = 0; /* HvFILL(hv) = 0 */
1715     xhv->xhv_keys  = 0; /* HvKEYS(hv) = 0 */
1716     xhv->xhv_placeholders = 0; /* HvPLACEHOLDERS(hv) = 0 */
1717
1718     if (SvRMAGICAL(hv))
1719         mg_clear((SV*)hv);
1720 }
1721
1722 /*
1723 =for apidoc hv_iterinit
1724
1725 Prepares a starting point to traverse a hash table.  Returns the number of
1726 keys in the hash (i.e. the same as C<HvKEYS(tb)>).  The return value is
1727 currently only meaningful for hashes without tie magic.
1728
1729 NOTE: Before version 5.004_65, C<hv_iterinit> used to return the number of
1730 hash buckets that happen to be in use.  If you still need that esoteric
1731 value, you can get it through the macro C<HvFILL(tb)>.
1732
1733
1734 =cut
1735 */
1736
1737 I32
1738 Perl_hv_iterinit(pTHX_ HV *hv)
1739 {
1740     register XPVHV* xhv;
1741     HE *entry;
1742
1743     if (!hv)
1744         Perl_croak(aTHX_ "Bad hash");
1745     xhv = (XPVHV*)SvANY(hv);
1746     entry = xhv->xhv_eiter; /* HvEITER(hv) */
1747     if (entry && HvLAZYDEL(hv)) {       /* was deleted earlier? */
1748         HvLAZYDEL_off(hv);
1749         hv_free_ent(hv, entry);
1750     }
1751     xhv->xhv_riter = -1;        /* HvRITER(hv) = -1 */
1752     xhv->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */
1753     /* used to be xhv->xhv_fill before 5.004_65 */
1754     return XHvTOTALKEYS(xhv);
1755 }
1756 /*
1757 =for apidoc hv_iternext
1758
1759 Returns entries from a hash iterator.  See C<hv_iterinit>.
1760
1761 You may call C<hv_delete> or C<hv_delete_ent> on the hash entry that the
1762 iterator currently points to, without losing your place or invalidating your
1763 iterator.  Note that in this case the current entry is deleted from the hash
1764 with your iterator holding the last reference to it.  Your iterator is flagged
1765 to free the entry on the next call to C<hv_iternext>, so you must not discard
1766 your iterator immediately else the entry will leak - call C<hv_iternext> to
1767 trigger the resource deallocation.
1768
1769 =cut
1770 */
1771
1772 HE *
1773 Perl_hv_iternext(pTHX_ HV *hv)
1774 {
1775     return hv_iternext_flags(hv, 0);
1776 }
1777
1778 /*
1779 =for apidoc hv_iternext_flags
1780
1781 Returns entries from a hash iterator.  See C<hv_iterinit> and C<hv_iternext>.
1782 The C<flags> value will normally be zero; if HV_ITERNEXT_WANTPLACEHOLDERS is
1783 set the placeholders keys (for restricted hashes) will be returned in addition
1784 to normal keys. By default placeholders are automatically skipped over.
1785 Currently a placeholder is implemented with a value that is literally
1786 <&Perl_sv_undef> (a regular C<undef> value is a normal read-write SV for which
1787 C<!SvOK> is false). Note that the implementation of placeholders and
1788 restricted hashes may change, and the implementation currently is
1789 insufficiently abstracted for any change to be tidy.
1790
1791 =cut
1792 */
1793
1794 HE *
1795 Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags)
1796 {
1797     register XPVHV* xhv;
1798     register HE *entry;
1799     HE *oldentry;
1800     MAGIC* mg;
1801
1802     if (!hv)
1803         Perl_croak(aTHX_ "Bad hash");
1804     xhv = (XPVHV*)SvANY(hv);
1805     oldentry = entry = xhv->xhv_eiter; /* HvEITER(hv) */
1806
1807     if ((mg = SvTIED_mg((SV*)hv, PERL_MAGIC_tied))) {
1808         SV *key = sv_newmortal();
1809         if (entry) {
1810             sv_setsv(key, HeSVKEY_force(entry));
1811             SvREFCNT_dec(HeSVKEY(entry));       /* get rid of previous key */
1812         }
1813         else {
1814             char *k;
1815             HEK *hek;
1816
1817             /* one HE per MAGICAL hash */
1818             xhv->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */
1819             Zero(entry, 1, HE);
1820             Newz(54, k, HEK_BASESIZE + sizeof(SV*), char);
1821             hek = (HEK*)k;
1822             HeKEY_hek(entry) = hek;
1823             HeKLEN(entry) = HEf_SVKEY;
1824         }
1825         magic_nextpack((SV*) hv,mg,key);
1826         if (SvOK(key)) {
1827             /* force key to stay around until next time */
1828             HeSVKEY_set(entry, SvREFCNT_inc(key));
1829             return entry;               /* beware, hent_val is not set */
1830         }
1831         if (HeVAL(entry))
1832             SvREFCNT_dec(HeVAL(entry));
1833         Safefree(HeKEY_hek(entry));
1834         del_HE(entry);
1835         xhv->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */
1836         return Null(HE*);
1837     }
1838 #ifdef DYNAMIC_ENV_FETCH  /* set up %ENV for iteration */
1839     if (!entry && SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
1840         prime_env_iter();
1841 #endif
1842
1843     if (!xhv->xhv_array /* !HvARRAY(hv) */)
1844         Newz(506, xhv->xhv_array /* HvARRAY(hv) */,
1845              PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
1846              char);
1847     if (entry)
1848     {
1849         entry = HeNEXT(entry);
1850         if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
1851             /*
1852              * Skip past any placeholders -- don't want to include them in
1853              * any iteration.
1854              */
1855             while (entry && HeVAL(entry) == &PL_sv_undef) {
1856                 entry = HeNEXT(entry);
1857             }
1858         }
1859     }
1860     while (!entry) {
1861         xhv->xhv_riter++; /* HvRITER(hv)++ */
1862         if (xhv->xhv_riter > xhv->xhv_max /* HvRITER(hv) > HvMAX(hv) */) {
1863             xhv->xhv_riter = -1; /* HvRITER(hv) = -1 */
1864             break;
1865         }
1866         /* entry = (HvARRAY(hv))[HvRITER(hv)]; */
1867         entry = ((HE**)xhv->xhv_array)[xhv->xhv_riter];
1868
1869         if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
1870             /* if we have an entry, but it's a placeholder, don't count it */
1871             if (entry && HeVAL(entry) == &PL_sv_undef)
1872                 entry = 0;
1873         }
1874     }
1875
1876     if (oldentry && HvLAZYDEL(hv)) {            /* was deleted earlier? */
1877         HvLAZYDEL_off(hv);
1878         hv_free_ent(hv, oldentry);
1879     }
1880
1881     xhv->xhv_eiter = entry; /* HvEITER(hv) = entry */
1882     return entry;
1883 }
1884
1885 /*
1886 =for apidoc hv_iterkey
1887
1888 Returns the key from the current position of the hash iterator.  See
1889 C<hv_iterinit>.
1890
1891 =cut
1892 */
1893
1894 char *
1895 Perl_hv_iterkey(pTHX_ register HE *entry, I32 *retlen)
1896 {
1897     if (HeKLEN(entry) == HEf_SVKEY) {
1898         STRLEN len;
1899         char *p = SvPV(HeKEY_sv(entry), len);
1900         *retlen = len;
1901         return p;
1902     }
1903     else {
1904         *retlen = HeKLEN(entry);
1905         return HeKEY(entry);
1906     }
1907 }
1908
1909 /* unlike hv_iterval(), this always returns a mortal copy of the key */
1910 /*
1911 =for apidoc hv_iterkeysv
1912
1913 Returns the key as an C<SV*> from the current position of the hash
1914 iterator.  The return value will always be a mortal copy of the key.  Also
1915 see C<hv_iterinit>.
1916
1917 =cut
1918 */
1919
1920 SV *
1921 Perl_hv_iterkeysv(pTHX_ register HE *entry)
1922 {
1923     if (HeKLEN(entry) != HEf_SVKEY) {
1924         HEK *hek = HeKEY_hek(entry);
1925         int flags = HEK_FLAGS(hek);
1926         SV *sv;
1927
1928         if (flags & HVhek_WASUTF8) {
1929             /* Trouble :-)
1930                Andreas would like keys he put in as utf8 to come back as utf8
1931             */
1932             STRLEN utf8_len = HEK_LEN(hek);
1933             U8 *as_utf8 = bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len);
1934
1935             sv = newSVpvn ((char*)as_utf8, utf8_len);
1936             SvUTF8_on (sv);
1937         } else {
1938             sv = newSVpvn_share(HEK_KEY(hek),
1939                                 (HEK_UTF8(hek) ? -HEK_LEN(hek) : HEK_LEN(hek)),
1940                                 HEK_HASH(hek));
1941         }
1942         return sv_2mortal(sv);
1943     }
1944     return sv_mortalcopy(HeKEY_sv(entry));
1945 }
1946
1947 /*
1948 =for apidoc hv_iterval
1949
1950 Returns the value from the current position of the hash iterator.  See
1951 C<hv_iterkey>.
1952
1953 =cut
1954 */
1955
1956 SV *
1957 Perl_hv_iterval(pTHX_ HV *hv, register HE *entry)
1958 {
1959     if (SvRMAGICAL(hv)) {
1960         if (mg_find((SV*)hv, PERL_MAGIC_tied)) {
1961             SV* sv = sv_newmortal();
1962             if (HeKLEN(entry) == HEf_SVKEY)
1963                 mg_copy((SV*)hv, sv, (char*)HeKEY_sv(entry), HEf_SVKEY);
1964             else mg_copy((SV*)hv, sv, HeKEY(entry), HeKLEN(entry));
1965             return sv;
1966         }
1967     }
1968     return HeVAL(entry);
1969 }
1970
1971 /*
1972 =for apidoc hv_iternextsv
1973
1974 Performs an C<hv_iternext>, C<hv_iterkey>, and C<hv_iterval> in one
1975 operation.
1976
1977 =cut
1978 */
1979
1980 SV *
1981 Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen)
1982 {
1983     HE *he;
1984     if ( (he = hv_iternext_flags(hv, 0)) == NULL)
1985         return NULL;
1986     *key = hv_iterkey(he, retlen);
1987     return hv_iterval(hv, he);
1988 }
1989
1990 /*
1991 =for apidoc hv_magic
1992
1993 Adds magic to a hash.  See C<sv_magic>.
1994
1995 =cut
1996 */
1997
1998 void
1999 Perl_hv_magic(pTHX_ HV *hv, GV *gv, int how)
2000 {
2001     sv_magic((SV*)hv, (SV*)gv, how, Nullch, 0);
2002 }
2003
2004 #if 0 /* use the macro from hv.h instead */
2005
2006 char*
2007 Perl_sharepvn(pTHX_ const char *sv, I32 len, U32 hash)
2008 {
2009     return HEK_KEY(share_hek(sv, len, hash));
2010 }
2011
2012 #endif
2013
2014 /* possibly free a shared string if no one has access to it
2015  * len and hash must both be valid for str.
2016  */
2017 void
2018 Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
2019 {
2020     unshare_hek_or_pvn (NULL, str, len, hash);
2021 }
2022
2023
2024 void
2025 Perl_unshare_hek(pTHX_ HEK *hek)
2026 {
2027     unshare_hek_or_pvn(hek, NULL, 0, 0);
2028 }
2029
2030 /* possibly free a shared string if no one has access to it
2031    hek if non-NULL takes priority over the other 3, else str, len and hash
2032    are used.  If so, len and hash must both be valid for str.
2033  */
2034 void
2035 S_unshare_hek_or_pvn(pTHX_ HEK *hek, const char *str, I32 len, U32 hash)
2036 {
2037     register XPVHV* xhv;
2038     register HE *entry;
2039     register HE **oentry;
2040     register I32 i = 1;
2041     I32 found = 0;
2042     bool is_utf8 = FALSE;
2043     int k_flags = 0;
2044     const char *save = str;
2045
2046     if (hek) {
2047         hash = HEK_HASH(hek);
2048     } else if (len < 0) {
2049         STRLEN tmplen = -len;
2050         is_utf8 = TRUE;
2051         /* See the note in hv_fetch(). --jhi */
2052         str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2053         len = tmplen;
2054         if (is_utf8)
2055             k_flags = HVhek_UTF8;
2056         if (str != save)
2057             k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2058     }
2059
2060     /* what follows is the moral equivalent of:
2061     if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) {
2062         if (--*Svp == Nullsv)
2063             hv_delete(PL_strtab, str, len, G_DISCARD, hash);
2064     } */
2065     xhv = (XPVHV*)SvANY(PL_strtab);
2066     /* assert(xhv_array != 0) */
2067     LOCK_STRTAB_MUTEX;
2068     /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
2069     oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
2070     if (hek) {
2071         for (entry = *oentry; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
2072             if (HeKEY_hek(entry) != hek)
2073                 continue;
2074             found = 1;
2075             break;
2076         }
2077     } else {
2078         int flags_masked = k_flags & HVhek_MASK;
2079         for (entry = *oentry; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
2080             if (HeHASH(entry) != hash)          /* strings can't be equal */
2081                 continue;
2082             if (HeKLEN(entry) != len)
2083                 continue;
2084             if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len))     /* is this it? */
2085                 continue;
2086             if (HeKFLAGS(entry) != flags_masked)
2087                 continue;
2088             found = 1;
2089             break;
2090         }
2091     }
2092
2093     if (found) {
2094         if (--HeVAL(entry) == Nullsv) {
2095             *oentry = HeNEXT(entry);
2096             if (i && !*oentry)
2097                 xhv->xhv_fill--; /* HvFILL(hv)-- */
2098             Safefree(HeKEY_hek(entry));
2099             del_HE(entry);
2100             xhv->xhv_keys--; /* HvKEYS(hv)-- */
2101         }
2102     }
2103
2104     UNLOCK_STRTAB_MUTEX;
2105     if (!found && ckWARN_d(WARN_INTERNAL))
2106         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
2107                     "Attempt to free non-existent shared string '%s'%s",
2108                     hek ? HEK_KEY(hek) : str,
2109                     (k_flags & HVhek_UTF8) ? " (utf8)" : "");
2110     if (k_flags & HVhek_FREEKEY)
2111         Safefree(str);
2112 }
2113
2114 /* get a (constant) string ptr from the global string table
2115  * string will get added if it is not already there.
2116  * len and hash must both be valid for str.
2117  */
2118 HEK *
2119 Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash)
2120 {
2121     bool is_utf8 = FALSE;
2122     int flags = 0;
2123     const char *save = str;
2124
2125     if (len < 0) {
2126       STRLEN tmplen = -len;
2127       is_utf8 = TRUE;
2128       /* See the note in hv_fetch(). --jhi */
2129       str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2130       len = tmplen;
2131       /* If we were able to downgrade here, then than means that we were passed
2132          in a key which only had chars 0-255, but was utf8 encoded.  */
2133       if (is_utf8)
2134           flags = HVhek_UTF8;
2135       /* If we found we were able to downgrade the string to bytes, then
2136          we should flag that it needs upgrading on keys or each.  Also flag
2137          that we need share_hek_flags to free the string.  */
2138       if (str != save)
2139           flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2140     }
2141
2142     return share_hek_flags (str, len, hash, flags);
2143 }
2144
2145 HEK *
2146 S_share_hek_flags(pTHX_ const char *str, I32 len, register U32 hash, int flags)
2147 {
2148     register XPVHV* xhv;
2149     register HE *entry;
2150     register HE **oentry;
2151     register I32 i = 1;
2152     I32 found = 0;
2153     int flags_masked = flags & HVhek_MASK;
2154
2155     /* what follows is the moral equivalent of:
2156
2157     if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
2158         hv_store(PL_strtab, str, len, Nullsv, hash);
2159     */
2160     xhv = (XPVHV*)SvANY(PL_strtab);
2161     /* assert(xhv_array != 0) */
2162     LOCK_STRTAB_MUTEX;
2163     /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
2164     oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
2165     for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
2166         if (HeHASH(entry) != hash)              /* strings can't be equal */
2167             continue;
2168         if (HeKLEN(entry) != len)
2169             continue;
2170         if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
2171             continue;
2172         if (HeKFLAGS(entry) != flags_masked)
2173             continue;
2174         found = 1;
2175         break;
2176     }
2177     if (!found) {
2178         entry = new_HE();
2179         HeKEY_hek(entry) = save_hek_flags(str, len, hash, flags);
2180         HeVAL(entry) = Nullsv;
2181         HeNEXT(entry) = *oentry;
2182         *oentry = entry;
2183         xhv->xhv_keys++; /* HvKEYS(hv)++ */
2184         if (i) {                                /* initial entry? */
2185             xhv->xhv_fill++; /* HvFILL(hv)++ */
2186             if (xhv->xhv_keys > xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */)
2187                 hsplit(PL_strtab);
2188         }
2189     }
2190
2191     ++HeVAL(entry);                             /* use value slot as REFCNT */
2192     UNLOCK_STRTAB_MUTEX;
2193
2194     if (flags & HVhek_FREEKEY)
2195         Safefree(str);
2196
2197     return HeKEY_hek(entry);
2198 }