hv.c

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