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