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