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