hv.c

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