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