hv.c

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