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