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