hv.c

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