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