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     HvHASKFLAGS_on(hv);
1536
1537     aep = (HE **) xhv->xhv_array;
1538
1539     for (i=0; i<newsize; i++,aep++) {
1540         entry = *aep;
1541         while (entry) {
1542             /* We're going to trash this HE's next pointer when we chain it
1543                into the new hash below, so store where we go next.  */
1544             HE *next = HeNEXT(entry);
1545             UV hash;
1546
1547             /* Rehash it */
1548             PERL_HASH_INTERNAL(hash, HeKEY(entry), HeKLEN(entry));
1549
1550             if (was_shared) {
1551                 /* Unshare it.  */
1552                 HEK *new_hek
1553                     = save_hek_flags(HeKEY(entry), HeKLEN(entry),
1554                                      hash, HeKFLAGS(entry));
1555                 unshare_hek (HeKEY_hek(entry));
1556                 HeKEY_hek(entry) = new_hek;
1557             } else {
1558                 /* Not shared, so simply write the new hash in. */
1559                 HeHASH(entry) = hash;
1560             }
1561             /*PerlIO_printf(PerlIO_stderr(), "%d ", HeKFLAGS(entry));*/
1562             HEK_REHASH_on(HeKEY_hek(entry));
1563             /*PerlIO_printf(PerlIO_stderr(), "%d\n", HeKFLAGS(entry));*/
1564
1565             /* Copy oentry to the correct new chain.  */
1566             bep = ((HE**)a) + (hash & (I32) xhv->xhv_max);
1567             if (!*bep)
1568                     xhv->xhv_fill++; /* HvFILL(hv)++ */
1569             HeNEXT(entry) = *bep;
1570             *bep = entry;
1571
1572             entry = next;
1573         }
1574     }
1575     Safefree (xhv->xhv_array);
1576     xhv->xhv_array = a;         /* HvARRAY(hv) = a */
1577 }
1578
1579 void
1580 Perl_hv_ksplit(pTHX_ HV *hv, IV newmax)
1581 {
1582     register XPVHV* xhv = (XPVHV*)SvANY(hv);
1583     I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
1584     register I32 newsize;
1585     register I32 i;
1586     register I32 j;
1587     register char *a;
1588     register HE **aep;
1589     register HE *entry;
1590     register HE **oentry;
1591
1592     newsize = (I32) newmax;                     /* possible truncation here */
1593     if (newsize != newmax || newmax <= oldsize)
1594         return;
1595     while ((newsize & (1 + ~newsize)) != newsize) {
1596         newsize &= ~(newsize & (1 + ~newsize)); /* get proper power of 2 */
1597     }
1598     if (newsize < newmax)
1599         newsize *= 2;
1600     if (newsize < newmax)
1601         return;                                 /* overflow detection */
1602
1603     a = xhv->xhv_array; /* HvARRAY(hv) */
1604     if (a) {
1605         PL_nomemok = TRUE;
1606 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
1607         Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1608         if (!a) {
1609           PL_nomemok = FALSE;
1610           return;
1611         }
1612 #else
1613         New(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1614         if (!a) {
1615           PL_nomemok = FALSE;
1616           return;
1617         }
1618         Copy(xhv->xhv_array /* HvARRAY(hv) */, a, oldsize * sizeof(HE*), char);
1619         if (oldsize >= 64) {
1620             offer_nice_chunk(xhv->xhv_array /* HvARRAY(hv) */,
1621                             PERL_HV_ARRAY_ALLOC_BYTES(oldsize));
1622         }
1623         else
1624             Safefree(xhv->xhv_array /* HvARRAY(hv) */);
1625 #endif
1626         PL_nomemok = FALSE;
1627         Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
1628     }
1629     else {
1630         Newz(0, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1631     }
1632     xhv->xhv_max = --newsize;   /* HvMAX(hv) = --newsize */
1633     xhv->xhv_array = a;         /* HvARRAY(hv) = a */
1634     if (!xhv->xhv_fill /* !HvFILL(hv) */)       /* skip rest if no entries */
1635         return;
1636
1637     aep = (HE**)a;
1638     for (i=0; i<oldsize; i++,aep++) {
1639         if (!*aep)                              /* non-existent */
1640             continue;
1641         for (oentry = aep, entry = *aep; entry; entry = *oentry) {
1642             if ((j = (HeHASH(entry) & newsize)) != i) {
1643                 j -= i;
1644                 *oentry = HeNEXT(entry);
1645                 if (!(HeNEXT(entry) = aep[j]))
1646                     xhv->xhv_fill++; /* HvFILL(hv)++ */
1647                 aep[j] = entry;
1648                 continue;
1649             }
1650             else
1651                 oentry = &HeNEXT(entry);
1652         }
1653         if (!*aep)                              /* everything moved */
1654             xhv->xhv_fill--; /* HvFILL(hv)-- */
1655     }
1656 }
1657
1658 /*
1659 =for apidoc newHV
1660
1661 Creates a new HV.  The reference count is set to 1.
1662
1663 =cut
1664 */
1665
1666 HV *
1667 Perl_newHV(pTHX)
1668 {
1669     register HV *hv;
1670     register XPVHV* xhv;
1671
1672     hv = (HV*)NEWSV(502,0);
1673     sv_upgrade((SV *)hv, SVt_PVHV);
1674     xhv = (XPVHV*)SvANY(hv);
1675     SvPOK_off(hv);
1676     SvNOK_off(hv);
1677 #ifndef NODEFAULT_SHAREKEYS
1678     HvSHAREKEYS_on(hv);         /* key-sharing on by default */
1679 #endif
1680
1681     xhv->xhv_max    = 7;        /* HvMAX(hv) = 7 (start with 8 buckets) */
1682     xhv->xhv_fill   = 0;        /* HvFILL(hv) = 0 */
1683     xhv->xhv_pmroot = 0;        /* HvPMROOT(hv) = 0 */
1684     (void)hv_iterinit(hv);      /* so each() will start off right */
1685     return hv;
1686 }
1687
1688 HV *
1689 Perl_newHVhv(pTHX_ HV *ohv)
1690 {
1691     HV *hv = newHV();
1692     STRLEN hv_max, hv_fill;
1693
1694     if (!ohv || (hv_fill = HvFILL(ohv)) == 0)
1695         return hv;
1696     hv_max = HvMAX(ohv);
1697
1698     if (!SvMAGICAL((SV *)ohv)) {
1699         /* It's an ordinary hash, so copy it fast. AMS 20010804 */
1700         STRLEN i;
1701         bool shared = !!HvSHAREKEYS(ohv);
1702         HE **ents, **oents = (HE **)HvARRAY(ohv);
1703         char *a;
1704         New(0, a, PERL_HV_ARRAY_ALLOC_BYTES(hv_max+1), char);
1705         ents = (HE**)a;
1706
1707         /* In each bucket... */
1708         for (i = 0; i <= hv_max; i++) {
1709             HE *prev = NULL, *ent = NULL, *oent = oents[i];
1710
1711             if (!oent) {
1712                 ents[i] = NULL;
1713                 continue;
1714             }
1715
1716             /* Copy the linked list of entries. */
1717             for (oent = oents[i]; oent; oent = HeNEXT(oent)) {
1718                 U32 hash   = HeHASH(oent);
1719                 char *key  = HeKEY(oent);
1720                 STRLEN len = HeKLEN(oent);
1721                 int flags  = HeKFLAGS(oent);
1722
1723                 ent = new_HE();
1724                 HeVAL(ent)     = newSVsv(HeVAL(oent));
1725                 HeKEY_hek(ent)
1726                     = shared ? share_hek_flags(key, len, hash, flags)
1727                              :  save_hek_flags(key, len, hash, flags);
1728                 if (prev)
1729                     HeNEXT(prev) = ent;
1730                 else
1731                     ents[i] = ent;
1732                 prev = ent;
1733                 HeNEXT(ent) = NULL;
1734             }
1735         }
1736
1737         HvMAX(hv)   = hv_max;
1738         HvFILL(hv)  = hv_fill;
1739         HvTOTALKEYS(hv)  = HvTOTALKEYS(ohv);
1740         HvARRAY(hv) = ents;
1741     }
1742     else {
1743         /* Iterate over ohv, copying keys and values one at a time. */
1744         HE *entry;
1745         I32 riter = HvRITER(ohv);
1746         HE *eiter = HvEITER(ohv);
1747
1748         /* Can we use fewer buckets? (hv_max is always 2^n-1) */
1749         while (hv_max && hv_max + 1 >= hv_fill * 2)
1750             hv_max = hv_max / 2;
1751         HvMAX(hv) = hv_max;
1752
1753         hv_iterinit(ohv);
1754         while ((entry = hv_iternext_flags(ohv, 0))) {
1755             hv_store_flags(hv, HeKEY(entry), HeKLEN(entry),
1756                            newSVsv(HeVAL(entry)), HeHASH(entry),
1757                            HeKFLAGS(entry));
1758         }
1759         HvRITER(ohv) = riter;
1760         HvEITER(ohv) = eiter;
1761     }
1762
1763     return hv;
1764 }
1765
1766 void
1767 Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry)
1768 {
1769     SV *val;
1770
1771     if (!entry)
1772         return;
1773     val = HeVAL(entry);
1774     if (val && isGV(val) && GvCVu(val) && HvNAME(hv))
1775         PL_sub_generation++;    /* may be deletion of method from stash */
1776     SvREFCNT_dec(val);
1777     if (HeKLEN(entry) == HEf_SVKEY) {
1778         SvREFCNT_dec(HeKEY_sv(entry));
1779         Safefree(HeKEY_hek(entry));
1780     }
1781     else if (HvSHAREKEYS(hv))
1782         unshare_hek(HeKEY_hek(entry));
1783     else
1784         Safefree(HeKEY_hek(entry));
1785     del_HE(entry);
1786 }
1787
1788 void
1789 Perl_hv_delayfree_ent(pTHX_ HV *hv, register HE *entry)
1790 {
1791     if (!entry)
1792         return;
1793     if (isGV(HeVAL(entry)) && GvCVu(HeVAL(entry)) && HvNAME(hv))
1794         PL_sub_generation++;    /* may be deletion of method from stash */
1795     sv_2mortal(HeVAL(entry));   /* free between statements */
1796     if (HeKLEN(entry) == HEf_SVKEY) {
1797         sv_2mortal(HeKEY_sv(entry));
1798         Safefree(HeKEY_hek(entry));
1799     }
1800     else if (HvSHAREKEYS(hv))
1801         unshare_hek(HeKEY_hek(entry));
1802     else
1803         Safefree(HeKEY_hek(entry));
1804     del_HE(entry);
1805 }
1806
1807 /*
1808 =for apidoc hv_clear
1809
1810 Clears a hash, making it empty.
1811
1812 =cut
1813 */
1814
1815 void
1816 Perl_hv_clear(pTHX_ HV *hv)
1817 {
1818     register XPVHV* xhv;
1819     if (!hv)
1820         return;
1821
1822     xhv = (XPVHV*)SvANY(hv);
1823
1824     if (SvREADONLY(hv)) {
1825         /* restricted hash: convert all keys to placeholders */
1826         I32 i;
1827         HE* entry;
1828         for (i = 0; i <= (I32) xhv->xhv_max; i++) {
1829             entry = ((HE**)xhv->xhv_array)[i];
1830             for (; entry; entry = HeNEXT(entry)) {
1831                 /* not already placeholder */
1832                 if (HeVAL(entry) != &PL_sv_placeholder) {
1833                     if (HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
1834                         SV* keysv = hv_iterkeysv(entry);
1835                         Perl_croak(aTHX_
1836         "Attempt to delete readonly key '%"SVf"' from a restricted hash",
1837                                    keysv);
1838                     }
1839                     SvREFCNT_dec(HeVAL(entry));
1840                     HeVAL(entry) = &PL_sv_placeholder;
1841                     xhv->xhv_placeholders++; /* HvPLACEHOLDERS(hv)++ */
1842                 }
1843             }
1844         }
1845         return;
1846     }
1847
1848     hfreeentries(hv);
1849     xhv->xhv_placeholders = 0; /* HvPLACEHOLDERS(hv) = 0 */
1850     if (xhv->xhv_array /* HvARRAY(hv) */)
1851         (void)memzero(xhv->xhv_array /* HvARRAY(hv) */,
1852                       (xhv->xhv_max+1 /* HvMAX(hv)+1 */) * sizeof(HE*));
1853
1854     if (SvRMAGICAL(hv))
1855         mg_clear((SV*)hv);
1856
1857     HvHASKFLAGS_off(hv);
1858     HvREHASH_off(hv);
1859 }
1860
1861 STATIC void
1862 S_hfreeentries(pTHX_ HV *hv)
1863 {
1864     register HE **array;
1865     register HE *entry;
1866     register HE *oentry = Null(HE*);
1867     I32 riter;
1868     I32 max;
1869
1870     if (!hv)
1871         return;
1872     if (!HvARRAY(hv))
1873         return;
1874
1875     riter = 0;
1876     max = HvMAX(hv);
1877     array = HvARRAY(hv);
1878     /* make everyone else think the array is empty, so that the destructors
1879      * called for freed entries can't recusively mess with us */
1880     HvARRAY(hv) = Null(HE**);
1881     HvFILL(hv) = 0;
1882     ((XPVHV*) SvANY(hv))->xhv_keys = 0;
1883
1884     entry = array[0];
1885     for (;;) {
1886         if (entry) {
1887             oentry = entry;
1888             entry = HeNEXT(entry);
1889             hv_free_ent(hv, oentry);
1890         }
1891         if (!entry) {
1892             if (++riter > max)
1893                 break;
1894             entry = array[riter];
1895         }
1896     }
1897     HvARRAY(hv) = array;
1898     (void)hv_iterinit(hv);
1899 }
1900
1901 /*
1902 =for apidoc hv_undef
1903
1904 Undefines the hash.
1905
1906 =cut
1907 */
1908
1909 void
1910 Perl_hv_undef(pTHX_ HV *hv)
1911 {
1912     register XPVHV* xhv;
1913     if (!hv)
1914         return;
1915     xhv = (XPVHV*)SvANY(hv);
1916     hfreeentries(hv);
1917     Safefree(xhv->xhv_array /* HvARRAY(hv) */);
1918     if (HvNAME(hv)) {
1919         if(PL_stashcache)
1920             hv_delete(PL_stashcache, HvNAME(hv), strlen(HvNAME(hv)), G_DISCARD);
1921         Safefree(HvNAME(hv));
1922         HvNAME(hv) = 0;
1923     }
1924     xhv->xhv_max   = 7; /* HvMAX(hv) = 7 (it's a normal hash) */
1925     xhv->xhv_array = 0; /* HvARRAY(hv) = 0 */
1926     xhv->xhv_placeholders = 0; /* HvPLACEHOLDERS(hv) = 0 */
1927
1928     if (SvRMAGICAL(hv))
1929         mg_clear((SV*)hv);
1930 }
1931
1932 /*
1933 =for apidoc hv_iterinit
1934
1935 Prepares a starting point to traverse a hash table.  Returns the number of
1936 keys in the hash (i.e. the same as C<HvKEYS(tb)>).  The return value is
1937 currently only meaningful for hashes without tie magic.
1938
1939 NOTE: Before version 5.004_65, C<hv_iterinit> used to return the number of
1940 hash buckets that happen to be in use.  If you still need that esoteric
1941 value, you can get it through the macro C<HvFILL(tb)>.
1942
1943
1944 =cut
1945 */
1946
1947 I32
1948 Perl_hv_iterinit(pTHX_ HV *hv)
1949 {
1950     register XPVHV* xhv;
1951     HE *entry;
1952
1953     if (!hv)
1954         Perl_croak(aTHX_ "Bad hash");
1955     xhv = (XPVHV*)SvANY(hv);
1956     entry = xhv->xhv_eiter; /* HvEITER(hv) */
1957     if (entry && HvLAZYDEL(hv)) {       /* was deleted earlier? */
1958         HvLAZYDEL_off(hv);
1959         hv_free_ent(hv, entry);
1960     }
1961     xhv->xhv_riter = -1;        /* HvRITER(hv) = -1 */
1962     xhv->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */
1963     /* used to be xhv->xhv_fill before 5.004_65 */
1964     return XHvTOTALKEYS(xhv);
1965 }
1966 /*
1967 =for apidoc hv_iternext
1968
1969 Returns entries from a hash iterator.  See C<hv_iterinit>.
1970
1971 You may call C<hv_delete> or C<hv_delete_ent> on the hash entry that the
1972 iterator currently points to, without losing your place or invalidating your
1973 iterator.  Note that in this case the current entry is deleted from the hash
1974 with your iterator holding the last reference to it.  Your iterator is flagged
1975 to free the entry on the next call to C<hv_iternext>, so you must not discard
1976 your iterator immediately else the entry will leak - call C<hv_iternext> to
1977 trigger the resource deallocation.
1978
1979 =cut
1980 */
1981
1982 HE *
1983 Perl_hv_iternext(pTHX_ HV *hv)
1984 {
1985     return hv_iternext_flags(hv, 0);
1986 }
1987
1988 /*
1989 =for apidoc hv_iternext_flags
1990
1991 Returns entries from a hash iterator.  See C<hv_iterinit> and C<hv_iternext>.
1992 The C<flags> value will normally be zero; if HV_ITERNEXT_WANTPLACEHOLDERS is
1993 set the placeholders keys (for restricted hashes) will be returned in addition
1994 to normal keys. By default placeholders are automatically skipped over.
1995 Currently a placeholder is implemented with a value that is
1996 C<&Perl_sv_placeholder>. Note that the implementation of placeholders and
1997 restricted hashes may change, and the implementation currently is
1998 insufficiently abstracted for any change to be tidy.
1999
2000 =cut
2001 */
2002
2003 HE *
2004 Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags)
2005 {
2006     register XPVHV* xhv;
2007     register HE *entry;
2008     HE *oldentry;
2009     MAGIC* mg;
2010
2011     if (!hv)
2012         Perl_croak(aTHX_ "Bad hash");
2013     xhv = (XPVHV*)SvANY(hv);
2014     oldentry = entry = xhv->xhv_eiter; /* HvEITER(hv) */
2015
2016     if ((mg = SvTIED_mg((SV*)hv, PERL_MAGIC_tied))) {
2017         SV *key = sv_newmortal();
2018         if (entry) {
2019             sv_setsv(key, HeSVKEY_force(entry));
2020             SvREFCNT_dec(HeSVKEY(entry));       /* get rid of previous key */
2021         }
2022         else {
2023             char *k;
2024             HEK *hek;
2025
2026             /* one HE per MAGICAL hash */
2027             xhv->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */
2028             Zero(entry, 1, HE);
2029             Newz(54, k, HEK_BASESIZE + sizeof(SV*), char);
2030             hek = (HEK*)k;
2031             HeKEY_hek(entry) = hek;
2032             HeKLEN(entry) = HEf_SVKEY;
2033         }
2034         magic_nextpack((SV*) hv,mg,key);
2035         if (SvOK(key)) {
2036             /* force key to stay around until next time */
2037             HeSVKEY_set(entry, SvREFCNT_inc(key));
2038             return entry;               /* beware, hent_val is not set */
2039         }
2040         if (HeVAL(entry))
2041             SvREFCNT_dec(HeVAL(entry));
2042         Safefree(HeKEY_hek(entry));
2043         del_HE(entry);
2044         xhv->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */
2045         return Null(HE*);
2046     }
2047 #ifdef DYNAMIC_ENV_FETCH  /* set up %ENV for iteration */
2048     if (!entry && SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
2049         prime_env_iter();
2050 #endif
2051
2052     if (!xhv->xhv_array /* !HvARRAY(hv) */)
2053         Newz(506, xhv->xhv_array /* HvARRAY(hv) */,
2054              PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
2055              char);
2056     /* At start of hash, entry is NULL.  */
2057     if (entry)
2058     {
2059         entry = HeNEXT(entry);
2060         if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
2061             /*
2062              * Skip past any placeholders -- don't want to include them in
2063              * any iteration.
2064              */
2065             while (entry && HeVAL(entry) == &PL_sv_placeholder) {
2066                 entry = HeNEXT(entry);
2067             }
2068         }
2069     }
2070     while (!entry) {
2071         /* OK. Come to the end of the current list.  Grab the next one.  */
2072
2073         xhv->xhv_riter++; /* HvRITER(hv)++ */
2074         if (xhv->xhv_riter > (I32)xhv->xhv_max /* HvRITER(hv) > HvMAX(hv) */) {
2075             /* There is no next one.  End of the hash.  */
2076             xhv->xhv_riter = -1; /* HvRITER(hv) = -1 */
2077             break;
2078         }
2079         /* entry = (HvARRAY(hv))[HvRITER(hv)]; */
2080         entry = ((HE**)xhv->xhv_array)[xhv->xhv_riter];
2081
2082         if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
2083             /* If we have an entry, but it's a placeholder, don't count it.
2084                Try the next.  */
2085             while (entry && HeVAL(entry) == &PL_sv_placeholder)
2086                 entry = HeNEXT(entry);
2087         }
2088         /* Will loop again if this linked list starts NULL
2089            (for HV_ITERNEXT_WANTPLACEHOLDERS)
2090            or if we run through it and find only placeholders.  */
2091     }
2092
2093     if (oldentry && HvLAZYDEL(hv)) {            /* was deleted earlier? */
2094         HvLAZYDEL_off(hv);
2095         hv_free_ent(hv, oldentry);
2096     }
2097
2098     xhv->xhv_eiter = entry; /* HvEITER(hv) = entry */
2099     return entry;
2100 }
2101
2102 /*
2103 =for apidoc hv_iterkey
2104
2105 Returns the key from the current position of the hash iterator.  See
2106 C<hv_iterinit>.
2107
2108 =cut
2109 */
2110
2111 char *
2112 Perl_hv_iterkey(pTHX_ register HE *entry, I32 *retlen)
2113 {
2114     if (HeKLEN(entry) == HEf_SVKEY) {
2115         STRLEN len;
2116         char *p = SvPV(HeKEY_sv(entry), len);
2117         *retlen = len;
2118         return p;
2119     }
2120     else {
2121         *retlen = HeKLEN(entry);
2122         return HeKEY(entry);
2123     }
2124 }
2125
2126 /* unlike hv_iterval(), this always returns a mortal copy of the key */
2127 /*
2128 =for apidoc hv_iterkeysv
2129
2130 Returns the key as an C<SV*> from the current position of the hash
2131 iterator.  The return value will always be a mortal copy of the key.  Also
2132 see C<hv_iterinit>.
2133
2134 =cut
2135 */
2136
2137 SV *
2138 Perl_hv_iterkeysv(pTHX_ register HE *entry)
2139 {
2140     if (HeKLEN(entry) != HEf_SVKEY) {
2141         HEK *hek = HeKEY_hek(entry);
2142         int flags = HEK_FLAGS(hek);
2143         SV *sv;
2144
2145         if (flags & HVhek_WASUTF8) {
2146             /* Trouble :-)
2147                Andreas would like keys he put in as utf8 to come back as utf8
2148             */
2149             STRLEN utf8_len = HEK_LEN(hek);
2150             U8 *as_utf8 = bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len);
2151
2152             sv = newSVpvn ((char*)as_utf8, utf8_len);
2153             SvUTF8_on (sv);
2154             Safefree (as_utf8); /* bytes_to_utf8() allocates a new string */
2155         } else if (flags & HVhek_REHASH) {
2156             /* We don't have a pointer to the hv, so we have to replicate the
2157                flag into every HEK. This hv is using custom a hasing
2158                algorithm. Hence we can't return a shared string scalar, as
2159                that would contain the (wrong) hash value, and might get passed
2160                into an hv routine with a regular hash  */
2161
2162             sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek));
2163             if (HEK_UTF8(hek))
2164                 SvUTF8_on (sv);
2165         } else {
2166             sv = newSVpvn_share(HEK_KEY(hek),
2167                                 (HEK_UTF8(hek) ? -HEK_LEN(hek) : HEK_LEN(hek)),
2168                                 HEK_HASH(hek));
2169         }
2170         return sv_2mortal(sv);
2171     }
2172     return sv_mortalcopy(HeKEY_sv(entry));
2173 }
2174
2175 /*
2176 =for apidoc hv_iterval
2177
2178 Returns the value from the current position of the hash iterator.  See
2179 C<hv_iterkey>.
2180
2181 =cut
2182 */
2183
2184 SV *
2185 Perl_hv_iterval(pTHX_ HV *hv, register HE *entry)
2186 {
2187     if (SvRMAGICAL(hv)) {
2188         if (mg_find((SV*)hv, PERL_MAGIC_tied)) {
2189             SV* sv = sv_newmortal();
2190             if (HeKLEN(entry) == HEf_SVKEY)
2191                 mg_copy((SV*)hv, sv, (char*)HeKEY_sv(entry), HEf_SVKEY);
2192             else mg_copy((SV*)hv, sv, HeKEY(entry), HeKLEN(entry));
2193             return sv;
2194         }
2195     }
2196     return HeVAL(entry);
2197 }
2198
2199 /*
2200 =for apidoc hv_iternextsv
2201
2202 Performs an C<hv_iternext>, C<hv_iterkey>, and C<hv_iterval> in one
2203 operation.
2204
2205 =cut
2206 */
2207
2208 SV *
2209 Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen)
2210 {
2211     HE *he;
2212     if ( (he = hv_iternext_flags(hv, 0)) == NULL)
2213         return NULL;
2214     *key = hv_iterkey(he, retlen);
2215     return hv_iterval(hv, he);
2216 }
2217
2218 /*
2219 =for apidoc hv_magic
2220
2221 Adds magic to a hash.  See C<sv_magic>.
2222
2223 =cut
2224 */
2225
2226 void
2227 Perl_hv_magic(pTHX_ HV *hv, GV *gv, int how)
2228 {
2229     sv_magic((SV*)hv, (SV*)gv, how, Nullch, 0);
2230 }
2231
2232 #if 0 /* use the macro from hv.h instead */
2233
2234 char*
2235 Perl_sharepvn(pTHX_ const char *sv, I32 len, U32 hash)
2236 {
2237     return HEK_KEY(share_hek(sv, len, hash));
2238 }
2239
2240 #endif
2241
2242 /* possibly free a shared string if no one has access to it
2243  * len and hash must both be valid for str.
2244  */
2245 void
2246 Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
2247 {
2248     unshare_hek_or_pvn (NULL, str, len, hash);
2249 }
2250
2251
2252 void
2253 Perl_unshare_hek(pTHX_ HEK *hek)
2254 {
2255     unshare_hek_or_pvn(hek, NULL, 0, 0);
2256 }
2257
2258 /* possibly free a shared string if no one has access to it
2259    hek if non-NULL takes priority over the other 3, else str, len and hash
2260    are used.  If so, len and hash must both be valid for str.
2261  */
2262 STATIC void
2263 S_unshare_hek_or_pvn(pTHX_ HEK *hek, const char *str, I32 len, U32 hash)
2264 {
2265     register XPVHV* xhv;
2266     register HE *entry;
2267     register HE **oentry;
2268     register I32 i = 1;
2269     I32 found = 0;
2270     bool is_utf8 = FALSE;
2271     int k_flags = 0;
2272     const char *save = str;
2273
2274     if (hek) {
2275         hash = HEK_HASH(hek);
2276     } else if (len < 0) {
2277         STRLEN tmplen = -len;
2278         is_utf8 = TRUE;
2279         /* See the note in hv_fetch(). --jhi */
2280         str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2281         len = tmplen;
2282         if (is_utf8)
2283             k_flags = HVhek_UTF8;
2284         if (str != save)
2285             k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2286     }
2287
2288     /* what follows is the moral equivalent of:
2289     if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) {
2290         if (--*Svp == Nullsv)
2291             hv_delete(PL_strtab, str, len, G_DISCARD, hash);
2292     } */
2293     xhv = (XPVHV*)SvANY(PL_strtab);
2294     /* assert(xhv_array != 0) */
2295     LOCK_STRTAB_MUTEX;
2296     /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
2297     oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
2298     if (hek) {
2299         for (entry = *oentry; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
2300             if (HeKEY_hek(entry) != hek)
2301                 continue;
2302             found = 1;
2303             break;
2304         }
2305     } else {
2306         int flags_masked = k_flags & HVhek_MASK;
2307         for (entry = *oentry; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
2308             if (HeHASH(entry) != hash)          /* strings can't be equal */
2309                 continue;
2310             if (HeKLEN(entry) != len)
2311                 continue;
2312             if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len))     /* is this it? */
2313                 continue;
2314             if (HeKFLAGS(entry) != flags_masked)
2315                 continue;
2316             found = 1;
2317             break;
2318         }
2319     }
2320
2321     if (found) {
2322         if (--HeVAL(entry) == Nullsv) {
2323             *oentry = HeNEXT(entry);
2324             if (i && !*oentry)
2325                 xhv->xhv_fill--; /* HvFILL(hv)-- */
2326             Safefree(HeKEY_hek(entry));
2327             del_HE(entry);
2328             xhv->xhv_keys--; /* HvKEYS(hv)-- */
2329         }
2330     }
2331
2332     UNLOCK_STRTAB_MUTEX;
2333     if (!found && ckWARN_d(WARN_INTERNAL))
2334         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
2335                     "Attempt to free non-existent shared string '%s'%s",
2336                     hek ? HEK_KEY(hek) : str,
2337                     (k_flags & HVhek_UTF8) ? " (utf8)" : "");
2338     if (k_flags & HVhek_FREEKEY)
2339         Safefree(str);
2340 }
2341
2342 /* get a (constant) string ptr from the global string table
2343  * string will get added if it is not already there.
2344  * len and hash must both be valid for str.
2345  */
2346 HEK *
2347 Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash)
2348 {
2349     bool is_utf8 = FALSE;
2350     int flags = 0;
2351     const char *save = str;
2352
2353     if (len < 0) {
2354       STRLEN tmplen = -len;
2355       is_utf8 = TRUE;
2356       /* See the note in hv_fetch(). --jhi */
2357       str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2358       len = tmplen;
2359       /* If we were able to downgrade here, then than means that we were passed
2360          in a key which only had chars 0-255, but was utf8 encoded.  */
2361       if (is_utf8)
2362           flags = HVhek_UTF8;
2363       /* If we found we were able to downgrade the string to bytes, then
2364          we should flag that it needs upgrading on keys or each.  Also flag
2365          that we need share_hek_flags to free the string.  */
2366       if (str != save)
2367           flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2368     }
2369
2370     return share_hek_flags (str, len, hash, flags);
2371 }
2372
2373 STATIC HEK *
2374 S_share_hek_flags(pTHX_ const char *str, I32 len, register U32 hash, int flags)
2375 {
2376     register XPVHV* xhv;
2377     register HE *entry;
2378     register HE **oentry;
2379     register I32 i = 1;
2380     I32 found = 0;
2381     int flags_masked = flags & HVhek_MASK;
2382
2383     /* what follows is the moral equivalent of:
2384
2385     if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
2386         hv_store(PL_strtab, str, len, Nullsv, hash);
2387     */
2388     xhv = (XPVHV*)SvANY(PL_strtab);
2389     /* assert(xhv_array != 0) */
2390     LOCK_STRTAB_MUTEX;
2391     /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
2392     oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
2393     for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
2394         if (HeHASH(entry) != hash)              /* strings can't be equal */
2395             continue;
2396         if (HeKLEN(entry) != len)
2397             continue;
2398         if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
2399             continue;
2400         if (HeKFLAGS(entry) != flags_masked)
2401             continue;
2402         found = 1;
2403         break;
2404     }
2405     if (!found) {
2406         entry = new_HE();
2407         HeKEY_hek(entry) = save_hek_flags(str, len, hash, flags);
2408         HeVAL(entry) = Nullsv;
2409         HeNEXT(entry) = *oentry;
2410         *oentry = entry;
2411         xhv->xhv_keys++; /* HvKEYS(hv)++ */
2412         if (i) {                                /* initial entry? */
2413             xhv->xhv_fill++; /* HvFILL(hv)++ */
2414         } else if (xhv->xhv_keys > (IV)xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */) {
2415                 hsplit(PL_strtab);
2416         }
2417     }
2418
2419     ++HeVAL(entry);                             /* use value slot as REFCNT */
2420     UNLOCK_STRTAB_MUTEX;
2421
2422     if (flags & HVhek_FREEKEY)
2423         Safefree(str);
2424
2425     return HeKEY_hek(entry);
2426 }