hv.c

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