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         I32 i;
1711         HE* entry;
1712         for (i = 0; i <= (I32) xhv->xhv_max; i++) {
1713             entry = ((HE**)xhv->xhv_array)[i];
1714             for (; entry; entry = HeNEXT(entry)) {
1715                 /* not already placeholder */
1716                 if (HeVAL(entry) != &PL_sv_undef) {
1717                     if (HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
1718                         SV* keysv = hv_iterkeysv(entry);
1719                         Perl_croak(aTHX_
1720         "Attempt to delete readonly key '%"SVf"' from a restricted hash",
1721                                    keysv);
1722                     }
1723                     SvREFCNT_dec(HeVAL(entry));
1724                     HeVAL(entry) = &PL_sv_undef;
1725                     xhv->xhv_placeholders++; /* HvPLACEHOLDERS(hv)++ */
1726                 }
1727             }
1728         }
1729         return;
1730     }
1731
1732     hfreeentries(hv);
1733     xhv->xhv_placeholders = 0; /* HvPLACEHOLDERS(hv) = 0 */
1734     if (xhv->xhv_array /* HvARRAY(hv) */)
1735         (void)memzero(xhv->xhv_array /* HvARRAY(hv) */,
1736                       (xhv->xhv_max+1 /* HvMAX(hv)+1 */) * sizeof(HE*));
1737
1738     if (SvRMAGICAL(hv))
1739         mg_clear((SV*)hv);
1740
1741     HvHASKFLAGS_off(hv);
1742 }
1743
1744 STATIC void
1745 S_hfreeentries(pTHX_ HV *hv)
1746 {
1747     register HE **array;
1748     register HE *entry;
1749     register HE *oentry = Null(HE*);
1750     I32 riter;
1751     I32 max;
1752
1753     if (!hv)
1754         return;
1755     if (!HvARRAY(hv))
1756         return;
1757
1758     riter = 0;
1759     max = HvMAX(hv);
1760     array = HvARRAY(hv);
1761     /* make everyone else think the array is empty, so that the destructors
1762      * called for freed entries can't recusively mess with us */
1763     HvARRAY(hv) = Null(HE**);
1764     HvFILL(hv) = 0;
1765     ((XPVHV*) SvANY(hv))->xhv_keys = 0;
1766
1767     entry = array[0];
1768     for (;;) {
1769         if (entry) {
1770             oentry = entry;
1771             entry = HeNEXT(entry);
1772             hv_free_ent(hv, oentry);
1773         }
1774         if (!entry) {
1775             if (++riter > max)
1776                 break;
1777             entry = array[riter];
1778         }
1779     }
1780     HvARRAY(hv) = array;
1781     (void)hv_iterinit(hv);
1782 }
1783
1784 /*
1785 =for apidoc hv_undef
1786
1787 Undefines the hash.
1788
1789 =cut
1790 */
1791
1792 void
1793 Perl_hv_undef(pTHX_ HV *hv)
1794 {
1795     register XPVHV* xhv;
1796     if (!hv)
1797         return;
1798     xhv = (XPVHV*)SvANY(hv);
1799     hfreeentries(hv);
1800     Safefree(xhv->xhv_array /* HvARRAY(hv) */);
1801     if (HvNAME(hv)) {
1802         if(PL_stashcache)
1803             hv_delete(PL_stashcache, HvNAME(hv), strlen(HvNAME(hv)), G_DISCARD);
1804         Safefree(HvNAME(hv));
1805         HvNAME(hv) = 0;
1806     }
1807     xhv->xhv_max   = 7; /* HvMAX(hv) = 7 (it's a normal hash) */
1808     xhv->xhv_array = 0; /* HvARRAY(hv) = 0 */
1809     xhv->xhv_placeholders = 0; /* HvPLACEHOLDERS(hv) = 0 */
1810
1811     if (SvRMAGICAL(hv))
1812         mg_clear((SV*)hv);
1813 }
1814
1815 /*
1816 =for apidoc hv_iterinit
1817
1818 Prepares a starting point to traverse a hash table.  Returns the number of
1819 keys in the hash (i.e. the same as C<HvKEYS(tb)>).  The return value is
1820 currently only meaningful for hashes without tie magic.
1821
1822 NOTE: Before version 5.004_65, C<hv_iterinit> used to return the number of
1823 hash buckets that happen to be in use.  If you still need that esoteric
1824 value, you can get it through the macro C<HvFILL(tb)>.
1825
1826
1827 =cut
1828 */
1829
1830 I32
1831 Perl_hv_iterinit(pTHX_ HV *hv)
1832 {
1833     register XPVHV* xhv;
1834     HE *entry;
1835
1836     if (!hv)
1837         Perl_croak(aTHX_ "Bad hash");
1838     xhv = (XPVHV*)SvANY(hv);
1839     entry = xhv->xhv_eiter; /* HvEITER(hv) */
1840     if (entry && HvLAZYDEL(hv)) {       /* was deleted earlier? */
1841         HvLAZYDEL_off(hv);
1842         hv_free_ent(hv, entry);
1843     }
1844     xhv->xhv_riter = -1;        /* HvRITER(hv) = -1 */
1845     xhv->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */
1846     /* used to be xhv->xhv_fill before 5.004_65 */
1847     return XHvTOTALKEYS(xhv);
1848 }
1849 /*
1850 =for apidoc hv_iternext
1851
1852 Returns entries from a hash iterator.  See C<hv_iterinit>.
1853
1854 You may call C<hv_delete> or C<hv_delete_ent> on the hash entry that the
1855 iterator currently points to, without losing your place or invalidating your
1856 iterator.  Note that in this case the current entry is deleted from the hash
1857 with your iterator holding the last reference to it.  Your iterator is flagged
1858 to free the entry on the next call to C<hv_iternext>, so you must not discard
1859 your iterator immediately else the entry will leak - call C<hv_iternext> to
1860 trigger the resource deallocation.
1861
1862 =cut
1863 */
1864
1865 HE *
1866 Perl_hv_iternext(pTHX_ HV *hv)
1867 {
1868     return hv_iternext_flags(hv, 0);
1869 }
1870
1871 /*
1872 =for apidoc hv_iternext_flags
1873
1874 Returns entries from a hash iterator.  See C<hv_iterinit> and C<hv_iternext>.
1875 The C<flags> value will normally be zero; if HV_ITERNEXT_WANTPLACEHOLDERS is
1876 set the placeholders keys (for restricted hashes) will be returned in addition
1877 to normal keys. By default placeholders are automatically skipped over.
1878 Currently a placeholder is implemented with a value that is literally
1879 <&Perl_sv_undef> (a regular C<undef> value is a normal read-write SV for which
1880 C<!SvOK> is false). Note that the implementation of placeholders and
1881 restricted hashes may change, and the implementation currently is
1882 insufficiently abstracted for any change to be tidy.
1883
1884 =cut
1885 */
1886
1887 HE *
1888 Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags)
1889 {
1890     register XPVHV* xhv;
1891     register HE *entry;
1892     HE *oldentry;
1893     MAGIC* mg;
1894
1895     if (!hv)
1896         Perl_croak(aTHX_ "Bad hash");
1897     xhv = (XPVHV*)SvANY(hv);
1898     oldentry = entry = xhv->xhv_eiter; /* HvEITER(hv) */
1899
1900     if ((mg = SvTIED_mg((SV*)hv, PERL_MAGIC_tied))) {
1901         SV *key = sv_newmortal();
1902         if (entry) {
1903             sv_setsv(key, HeSVKEY_force(entry));
1904             SvREFCNT_dec(HeSVKEY(entry));       /* get rid of previous key */
1905         }
1906         else {
1907             char *k;
1908             HEK *hek;
1909
1910             /* one HE per MAGICAL hash */
1911             xhv->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */
1912             Zero(entry, 1, HE);
1913             Newz(54, k, HEK_BASESIZE + sizeof(SV*), char);
1914             hek = (HEK*)k;
1915             HeKEY_hek(entry) = hek;
1916             HeKLEN(entry) = HEf_SVKEY;
1917         }
1918         magic_nextpack((SV*) hv,mg,key);
1919         if (SvOK(key)) {
1920             /* force key to stay around until next time */
1921             HeSVKEY_set(entry, SvREFCNT_inc(key));
1922             return entry;               /* beware, hent_val is not set */
1923         }
1924         if (HeVAL(entry))
1925             SvREFCNT_dec(HeVAL(entry));
1926         Safefree(HeKEY_hek(entry));
1927         del_HE(entry);
1928         xhv->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */
1929         return Null(HE*);
1930     }
1931 #ifdef DYNAMIC_ENV_FETCH  /* set up %ENV for iteration */
1932     if (!entry && SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
1933         prime_env_iter();
1934 #endif
1935
1936     if (!xhv->xhv_array /* !HvARRAY(hv) */)
1937         Newz(506, xhv->xhv_array /* HvARRAY(hv) */,
1938              PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
1939              char);
1940     /* At start of hash, entry is NULL.  */
1941     if (entry)
1942     {
1943         entry = HeNEXT(entry);
1944         if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
1945             /*
1946              * Skip past any placeholders -- don't want to include them in
1947              * any iteration.
1948              */
1949             while (entry && HeVAL(entry) == &PL_sv_undef) {
1950                 entry = HeNEXT(entry);
1951             }
1952         }
1953     }
1954     while (!entry) {
1955         /* OK. Come to the end of the current list.  Grab the next one.  */
1956
1957         xhv->xhv_riter++; /* HvRITER(hv)++ */
1958         if (xhv->xhv_riter > (I32)xhv->xhv_max /* HvRITER(hv) > HvMAX(hv) */) {
1959             /* There is no next one.  End of the hash.  */
1960             xhv->xhv_riter = -1; /* HvRITER(hv) = -1 */
1961             break;
1962         }
1963         /* entry = (HvARRAY(hv))[HvRITER(hv)]; */
1964         entry = ((HE**)xhv->xhv_array)[xhv->xhv_riter];
1965
1966         if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
1967             /* If we have an entry, but it's a placeholder, don't count it.
1968                Try the next.  */
1969             while (entry && HeVAL(entry) == &PL_sv_undef)
1970                 entry = HeNEXT(entry);
1971         }
1972         /* Will loop again if this linked list starts NULL
1973            (for HV_ITERNEXT_WANTPLACEHOLDERS)
1974            or if we run through it and find only placeholders.  */
1975     }
1976
1977     if (oldentry && HvLAZYDEL(hv)) {            /* was deleted earlier? */
1978         HvLAZYDEL_off(hv);
1979         hv_free_ent(hv, oldentry);
1980     }
1981
1982     xhv->xhv_eiter = entry; /* HvEITER(hv) = entry */
1983     return entry;
1984 }
1985
1986 /*
1987 =for apidoc hv_iterkey
1988
1989 Returns the key from the current position of the hash iterator.  See
1990 C<hv_iterinit>.
1991
1992 =cut
1993 */
1994
1995 char *
1996 Perl_hv_iterkey(pTHX_ register HE *entry, I32 *retlen)
1997 {
1998     if (HeKLEN(entry) == HEf_SVKEY) {
1999         STRLEN len;
2000         char *p = SvPV(HeKEY_sv(entry), len);
2001         *retlen = len;
2002         return p;
2003     }
2004     else {
2005         *retlen = HeKLEN(entry);
2006         return HeKEY(entry);
2007     }
2008 }
2009
2010 /* unlike hv_iterval(), this always returns a mortal copy of the key */
2011 /*
2012 =for apidoc hv_iterkeysv
2013
2014 Returns the key as an C<SV*> from the current position of the hash
2015 iterator.  The return value will always be a mortal copy of the key.  Also
2016 see C<hv_iterinit>.
2017
2018 =cut
2019 */
2020
2021 SV *
2022 Perl_hv_iterkeysv(pTHX_ register HE *entry)
2023 {
2024     if (HeKLEN(entry) != HEf_SVKEY) {
2025         HEK *hek = HeKEY_hek(entry);
2026         int flags = HEK_FLAGS(hek);
2027         SV *sv;
2028
2029         if (flags & HVhek_WASUTF8) {
2030             /* Trouble :-)
2031                Andreas would like keys he put in as utf8 to come back as utf8
2032             */
2033             STRLEN utf8_len = HEK_LEN(hek);
2034             U8 *as_utf8 = bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len);
2035
2036             sv = newSVpvn ((char*)as_utf8, utf8_len);
2037             SvUTF8_on (sv);
2038             Safefree (as_utf8); /* bytes_to_utf8() allocates a new string */
2039         } else {
2040             sv = newSVpvn_share(HEK_KEY(hek),
2041                                 (HEK_UTF8(hek) ? -HEK_LEN(hek) : HEK_LEN(hek)),
2042                                 HEK_HASH(hek));
2043         }
2044         return sv_2mortal(sv);
2045     }
2046     return sv_mortalcopy(HeKEY_sv(entry));
2047 }
2048
2049 /*
2050 =for apidoc hv_iterval
2051
2052 Returns the value from the current position of the hash iterator.  See
2053 C<hv_iterkey>.
2054
2055 =cut
2056 */
2057
2058 SV *
2059 Perl_hv_iterval(pTHX_ HV *hv, register HE *entry)
2060 {
2061     if (SvRMAGICAL(hv)) {
2062         if (mg_find((SV*)hv, PERL_MAGIC_tied)) {
2063             SV* sv = sv_newmortal();
2064             if (HeKLEN(entry) == HEf_SVKEY)
2065                 mg_copy((SV*)hv, sv, (char*)HeKEY_sv(entry), HEf_SVKEY);
2066             else mg_copy((SV*)hv, sv, HeKEY(entry), HeKLEN(entry));
2067             return sv;
2068         }
2069     }
2070     return HeVAL(entry);
2071 }
2072
2073 /*
2074 =for apidoc hv_iternextsv
2075
2076 Performs an C<hv_iternext>, C<hv_iterkey>, and C<hv_iterval> in one
2077 operation.
2078
2079 =cut
2080 */
2081
2082 SV *
2083 Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen)
2084 {
2085     HE *he;
2086     if ( (he = hv_iternext_flags(hv, 0)) == NULL)
2087         return NULL;
2088     *key = hv_iterkey(he, retlen);
2089     return hv_iterval(hv, he);
2090 }
2091
2092 /*
2093 =for apidoc hv_magic
2094
2095 Adds magic to a hash.  See C<sv_magic>.
2096
2097 =cut
2098 */
2099
2100 void
2101 Perl_hv_magic(pTHX_ HV *hv, GV *gv, int how)
2102 {
2103     sv_magic((SV*)hv, (SV*)gv, how, Nullch, 0);
2104 }
2105
2106 #if 0 /* use the macro from hv.h instead */
2107
2108 char*
2109 Perl_sharepvn(pTHX_ const char *sv, I32 len, U32 hash)
2110 {
2111     return HEK_KEY(share_hek(sv, len, hash));
2112 }
2113
2114 #endif
2115
2116 /* possibly free a shared string if no one has access to it
2117  * len and hash must both be valid for str.
2118  */
2119 void
2120 Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
2121 {
2122     unshare_hek_or_pvn (NULL, str, len, hash);
2123 }
2124
2125
2126 void
2127 Perl_unshare_hek(pTHX_ HEK *hek)
2128 {
2129     unshare_hek_or_pvn(hek, NULL, 0, 0);
2130 }
2131
2132 /* possibly free a shared string if no one has access to it
2133    hek if non-NULL takes priority over the other 3, else str, len and hash
2134    are used.  If so, len and hash must both be valid for str.
2135  */
2136 STATIC void
2137 S_unshare_hek_or_pvn(pTHX_ HEK *hek, const char *str, I32 len, U32 hash)
2138 {
2139     register XPVHV* xhv;
2140     register HE *entry;
2141     register HE **oentry;
2142     register I32 i = 1;
2143     I32 found = 0;
2144     bool is_utf8 = FALSE;
2145     int k_flags = 0;
2146     const char *save = str;
2147
2148     if (hek) {
2149         hash = HEK_HASH(hek);
2150     } else if (len < 0) {
2151         STRLEN tmplen = -len;
2152         is_utf8 = TRUE;
2153         /* See the note in hv_fetch(). --jhi */
2154         str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2155         len = tmplen;
2156         if (is_utf8)
2157             k_flags = HVhek_UTF8;
2158         if (str != save)
2159             k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2160     }
2161
2162     /* what follows is the moral equivalent of:
2163     if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) {
2164         if (--*Svp == Nullsv)
2165             hv_delete(PL_strtab, str, len, G_DISCARD, hash);
2166     } */
2167     xhv = (XPVHV*)SvANY(PL_strtab);
2168     /* assert(xhv_array != 0) */
2169     LOCK_STRTAB_MUTEX;
2170     /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
2171     oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
2172     if (hek) {
2173         for (entry = *oentry; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
2174             if (HeKEY_hek(entry) != hek)
2175                 continue;
2176             found = 1;
2177             break;
2178         }
2179     } else {
2180         int flags_masked = k_flags & HVhek_MASK;
2181         for (entry = *oentry; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
2182             if (HeHASH(entry) != hash)          /* strings can't be equal */
2183                 continue;
2184             if (HeKLEN(entry) != len)
2185                 continue;
2186             if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len))     /* is this it? */
2187                 continue;
2188             if (HeKFLAGS(entry) != flags_masked)
2189                 continue;
2190             found = 1;
2191             break;
2192         }
2193     }
2194
2195     if (found) {
2196         if (--HeVAL(entry) == Nullsv) {
2197             *oentry = HeNEXT(entry);
2198             if (i && !*oentry)
2199                 xhv->xhv_fill--; /* HvFILL(hv)-- */
2200             Safefree(HeKEY_hek(entry));
2201             del_HE(entry);
2202             xhv->xhv_keys--; /* HvKEYS(hv)-- */
2203         }
2204     }
2205
2206     UNLOCK_STRTAB_MUTEX;
2207     if (!found && ckWARN_d(WARN_INTERNAL))
2208         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
2209                     "Attempt to free non-existent shared string '%s'%s",
2210                     hek ? HEK_KEY(hek) : str,
2211                     (k_flags & HVhek_UTF8) ? " (utf8)" : "");
2212     if (k_flags & HVhek_FREEKEY)
2213         Safefree(str);
2214 }
2215
2216 /* get a (constant) string ptr from the global string table
2217  * string will get added if it is not already there.
2218  * len and hash must both be valid for str.
2219  */
2220 HEK *
2221 Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash)
2222 {
2223     bool is_utf8 = FALSE;
2224     int flags = 0;
2225     const char *save = str;
2226
2227     if (len < 0) {
2228       STRLEN tmplen = -len;
2229       is_utf8 = TRUE;
2230       /* See the note in hv_fetch(). --jhi */
2231       str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2232       len = tmplen;
2233       /* If we were able to downgrade here, then than means that we were passed
2234          in a key which only had chars 0-255, but was utf8 encoded.  */
2235       if (is_utf8)
2236           flags = HVhek_UTF8;
2237       /* If we found we were able to downgrade the string to bytes, then
2238          we should flag that it needs upgrading on keys or each.  Also flag
2239          that we need share_hek_flags to free the string.  */
2240       if (str != save)
2241           flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2242     }
2243
2244     return share_hek_flags (str, len, hash, flags);
2245 }
2246
2247 STATIC HEK *
2248 S_share_hek_flags(pTHX_ const char *str, I32 len, register U32 hash, int flags)
2249 {
2250     register XPVHV* xhv;
2251     register HE *entry;
2252     register HE **oentry;
2253     register I32 i = 1;
2254     I32 found = 0;
2255     int flags_masked = flags & HVhek_MASK;
2256
2257     /* what follows is the moral equivalent of:
2258
2259     if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
2260         hv_store(PL_strtab, str, len, Nullsv, hash);
2261     */
2262     xhv = (XPVHV*)SvANY(PL_strtab);
2263     /* assert(xhv_array != 0) */
2264     LOCK_STRTAB_MUTEX;
2265     /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
2266     oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
2267     for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
2268         if (HeHASH(entry) != hash)              /* strings can't be equal */
2269             continue;
2270         if (HeKLEN(entry) != len)
2271             continue;
2272         if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
2273             continue;
2274         if (HeKFLAGS(entry) != flags_masked)
2275             continue;
2276         found = 1;
2277         break;
2278     }
2279     if (!found) {
2280         entry = new_HE();
2281         HeKEY_hek(entry) = save_hek_flags(str, len, hash, flags);
2282         HeVAL(entry) = Nullsv;
2283         HeNEXT(entry) = *oentry;
2284         *oentry = entry;
2285         xhv->xhv_keys++; /* HvKEYS(hv)++ */
2286         if (i) {                                /* initial entry? */
2287             xhv->xhv_fill++; /* HvFILL(hv)++ */
2288             if (xhv->xhv_keys > (IV)xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */)
2289                 hsplit(PL_strtab);
2290         }
2291     }
2292
2293     ++HeVAL(entry);                             /* use value slot as REFCNT */
2294     UNLOCK_STRTAB_MUTEX;
2295
2296     if (flags & HVhek_FREEKEY)
2297         Safefree(str);
2298
2299     return HeKEY_hek(entry);
2300 }