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