hv.c

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