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