hv.c

   1 /*    hv.c
   2  *
   3  *    Copyright (c) 1991-2001, Larry Wall
   4  *
   5  *    You may distribute under the terms of either the GNU General Public
   6  *    License or the Artistic License, as specified in the README file.
   7  *
   8  */
   9
  10 /*
  11  * "I sit beside the fire and think of all that I have seen."  --Bilbo
  12  */
  13
  14 #include "EXTERN.h"
  15 #define PERL_IN_HV_C
  16 #include "perl.h"
  17
  18
  19 STATIC HE*
  20 S_new_he(pTHX)
  21 {
  22     HE* he;
  23     LOCK_SV_MUTEX;
  24     if (!PL_he_root)
  25         more_he();
  26     he = PL_he_root;
  27     PL_he_root = HeNEXT(he);
  28     UNLOCK_SV_MUTEX;
  29     return he;
  30 }
  31
  32 STATIC void
  33 S_del_he(pTHX_ HE *p)
  34 {
  35     LOCK_SV_MUTEX;
  36     HeNEXT(p) = (HE*)PL_he_root;
  37     PL_he_root = p;
  38     UNLOCK_SV_MUTEX;
  39 }
  40
  41 STATIC void
  42 S_more_he(pTHX)
  43 {
  44     register HE* he;
  45     register HE* heend;
  46     XPV *ptr;
  47     New(54, ptr, 1008/sizeof(XPV), XPV);
  48     ptr->xpv_pv = (char*)PL_he_arenaroot;
  49     PL_he_arenaroot = ptr;
  50
  51     he = (HE*)ptr;
  52     heend = &he[1008 / sizeof(HE) - 1];
  53     PL_he_root = ++he;
  54     while (he < heend) {
  55         HeNEXT(he) = (HE*)(he + 1);
  56         he++;
  57     }
  58     HeNEXT(he) = 0;
  59 }
  60
  61 #ifdef PURIFY
  62
  63 #define new_HE() (HE*)safemalloc(sizeof(HE))
  64 #define del_HE(p) safefree((char*)p)
  65
  66 #else
  67
  68 #define new_HE() new_he()
  69 #define del_HE(p) del_he(p)
  70
  71 #endif
  72
  73 STATIC HEK *
  74 S_save_hek(pTHX_ const char *str, I32 len, U32 hash)
  75 {
  76     char *k;
  77     register HEK *hek;
  78     bool is_utf8 = FALSE;
  79
  80     if (len < 0) {
  81       len = -len;
  82       is_utf8 = TRUE;
  83     }
  84
  85     New(54, k, HEK_BASESIZE + len + 1, char);
  86     hek = (HEK*)k;
  87     Copy(str, HEK_KEY(hek), len, char);
  88     HEK_LEN(hek) = len;
  89     HEK_HASH(hek) = hash;
  90     HEK_UTF8(hek) = (char)is_utf8;
  91     return hek;
  92 }
  93
  94 void
  95 Perl_unshare_hek(pTHX_ HEK *hek)
  96 {
  97     unsharepvn(HEK_KEY(hek),HEK_UTF8(hek)?-HEK_LEN(hek):HEK_LEN(hek),
  98                 HEK_HASH(hek));
  99 }
 100
 101 #if defined(USE_ITHREADS)
 102 HE *
 103 Perl_he_dup(pTHX_ HE *e, bool shared)
 104 {
 105     HE *ret;
 106
 107     if (!e)
 108         return Nullhe;
 109     /* look for it in the table first */
 110     ret = (HE*)ptr_table_fetch(PL_ptr_table, e);
 111     if (ret)
 112         return ret;
 113
 114     /* create anew and remember what it is */
 115     ret = new_HE();
 116     ptr_table_store(PL_ptr_table, e, ret);
 117
 118     HeNEXT(ret) = he_dup(HeNEXT(e),shared);
 119     if (HeKLEN(e) == HEf_SVKEY)
 120         HeKEY_sv(ret) = SvREFCNT_inc(sv_dup(HeKEY_sv(e)));
 121     else if (shared)
 122         HeKEY_hek(ret) = share_hek(HeKEY(e), HeKLEN_UTF8(e), HeHASH(e));
 123     else
 124         HeKEY_hek(ret) = save_hek(HeKEY(e), HeKLEN_UTF8(e), HeHASH(e));
 125     HeVAL(ret) = SvREFCNT_inc(sv_dup(HeVAL(e)));
 126     return ret;
 127 }
 128 #endif  /* USE_ITHREADS */
 129
 130 /* (klen == HEf_SVKEY) is special for MAGICAL hv entries, meaning key slot
 131  * contains an SV* */
 132
 133 /*
 134 =for apidoc hv_fetch
 135
 136 Returns the SV which corresponds to the specified key in the hash.  The
 137 C<klen> is the length of the key.  If C<lval> is set then the fetch will be
 138 part of a store.  Check that the return value is non-null before
 139 dereferencing it to a C<SV*>.
 140
 141 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
 142 information on how to use this function on tied hashes.
 143
 144 =cut
 145 */
 146
 147 SV**
 148 Perl_hv_fetch(pTHX_ HV *hv, const char *key, I32 klen, I32 lval)
 149 {
 150     register U32 hash;
 151     register HE *entry;
 152     SV *sv;
 153     bool is_utf8 = FALSE;
 154     const char *keysave = key;
 155
 156     if (!hv)
 157         return 0;
 158
 159     if (klen < 0) {
 160       klen = -klen;
 161       is_utf8 = TRUE;
 162     }
 163
 164     if (SvRMAGICAL(hv)) {
 165         if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
 166             sv = sv_newmortal();
 167             mg_copy((SV*)hv, sv, key, klen);
 168             PL_hv_fetch_sv = sv;
 169             return &PL_hv_fetch_sv;
 170         }
 171 #ifdef ENV_IS_CASELESS
 172         else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
 173             U32 i;
 174             for (i = 0; i < klen; ++i)
 175                 if (isLOWER(key[i])) {
 176                     char *nkey = strupr(SvPVX(sv_2mortal(newSVpvn(key,klen))));
 177                     SV **ret = hv_fetch(hv, nkey, klen, 0);
 178                     if (!ret && lval)
 179                         ret = hv_store(hv, key, klen, NEWSV(61,0), 0);
 180                     return ret;
 181                 }
 182         }
 183 #endif
 184     }
 185
 186     if (!HvARRAY(hv)) {
 187         if (lval
 188 #ifdef DYNAMIC_ENV_FETCH  /* if it's an %ENV lookup, we may get it on the fly */
 189                  || mg_find((SV*)hv, PERL_MAGIC_env)
 190 #endif
 191                                                                   )
 192             Newz(503, HvARRAY(hv),
 193                  PERL_HV_ARRAY_ALLOC_BYTES(HvMAX(hv) + 1), char);
 194         else
 195             return 0;
 196     }
 197
 198     if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT)) {
 199         STRLEN tmplen = klen;
 200         /* Just casting the &klen to (STRLEN) won't work well
 201          * if STRLEN and I32 are of different widths. --jhi */
 202         key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
 203         klen = tmplen;
 204     }
 205
 206     PERL_HASH(hash, key, klen);
 207
 208     entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)];
 209     for (; entry; entry = HeNEXT(entry)) {
 210         if (HeHASH(entry) != hash)              /* strings can't be equal */
 211             continue;
 212         if (HeKLEN(entry) != klen)
 213             continue;
 214         if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen))        /* is this it? */
 215             continue;
 216         if (HeKUTF8(entry) != (char)is_utf8)
 217             continue;
 218         if (key != keysave)
 219             Safefree(key);
 220         return &HeVAL(entry);
 221     }
 222 #ifdef DYNAMIC_ENV_FETCH  /* %ENV lookup?  If so, try to fetch the value now */
 223     if (mg_find((SV*)hv, PERL_MAGIC_env)) {
 224         unsigned long len;
 225         char *env = PerlEnv_ENVgetenv_len(key,&len);
 226         if (env) {
 227             sv = newSVpvn(env,len);
 228             SvTAINTED_on(sv);
 229             if (key != keysave)
 230                 Safefree(key);
 231             return hv_store(hv,key,klen,sv,hash);
 232         }
 233     }
 234 #endif
 235     if (lval) {         /* gonna assign to this, so it better be there */
 236         sv = NEWSV(61,0);
 237         if (key != keysave) { /* must be is_utf8 == 0 */
 238             SV **ret = hv_store(hv,key,klen,sv,hash);
 239             Safefree(key);
 240             return ret;
 241         }
 242         else
 243             return hv_store(hv,key,is_utf8?-klen:klen,sv,hash);
 244     }
 245     if (key != keysave)
 246         Safefree(key);
 247     return 0;
 248 }
 249
 250 /* returns a HE * structure with the all fields set */
 251 /* note that hent_val will be a mortal sv for MAGICAL hashes */
 252 /*
 253 =for apidoc hv_fetch_ent
 254
 255 Returns the hash entry which corresponds to the specified key in the hash.
 256 C<hash> must be a valid precomputed hash number for the given C<key>, or 0
 257 if you want the function to compute it.  IF C<lval> is set then the fetch
 258 will be part of a store.  Make sure the return value is non-null before
 259 accessing it.  The return value when C<tb> is a tied hash is a pointer to a
 260 static location, so be sure to make a copy of the structure if you need to
 261 store it somewhere.
 262
 263 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
 264 information on how to use this function on tied hashes.
 265
 266 =cut
 267 */
 268
 269 HE *
 270 Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash)
 271 {
 272     register char *key;
 273     STRLEN klen;
 274     register HE *entry;
 275     SV *sv;
 276     bool is_utf8;
 277     char *keysave;
 278
 279     if (!hv)
 280         return 0;
 281
 282     if (SvRMAGICAL(hv)) {
 283         if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
 284             sv = sv_newmortal();
 285             keysv = sv_2mortal(newSVsv(keysv));
 286             mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY);
 287             if (!HeKEY_hek(&PL_hv_fetch_ent_mh)) {
 288                 char *k;
 289                 New(54, k, HEK_BASESIZE + sizeof(SV*), char);
 290                 HeKEY_hek(&PL_hv_fetch_ent_mh) = (HEK*)k;
 291             }
 292             HeSVKEY_set(&PL_hv_fetch_ent_mh, keysv);
 293             HeVAL(&PL_hv_fetch_ent_mh) = sv;
 294             return &PL_hv_fetch_ent_mh;
 295         }
 296 #ifdef ENV_IS_CASELESS
 297         else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
 298             U32 i;
 299             key = SvPV(keysv, klen);
 300             for (i = 0; i < klen; ++i)
 301                 if (isLOWER(key[i])) {
 302                     SV *nkeysv = sv_2mortal(newSVpvn(key,klen));
 303                     (void)strupr(SvPVX(nkeysv));
 304                     entry = hv_fetch_ent(hv, nkeysv, 0, 0);
 305                     if (!entry && lval)
 306                         entry = hv_store_ent(hv, keysv, NEWSV(61,0), hash);
 307                     return entry;
 308                 }
 309         }
 310 #endif
 311     }
 312
 313     if (!HvARRAY(hv)) {
 314         if (lval
 315 #ifdef DYNAMIC_ENV_FETCH  /* if it's an %ENV lookup, we may get it on the fly */
 316                  || mg_find((SV*)hv, PERL_MAGIC_env)
 317 #endif
 318                                                                   )
 319             Newz(503, HvARRAY(hv),
 320                  PERL_HV_ARRAY_ALLOC_BYTES(HvMAX(hv) + 1), char);
 321         else
 322             return 0;
 323     }
 324
 325     keysave = key = SvPV(keysv, klen);
 326     is_utf8 = (SvUTF8(keysv)!=0);
 327
 328     if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT))
 329         key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
 330
 331     if (!hash)
 332         PERL_HASH(hash, key, klen);
 333
 334     entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)];
 335     for (; entry; entry = HeNEXT(entry)) {
 336         if (HeHASH(entry) != hash)              /* strings can't be equal */
 337             continue;
 338         if (HeKLEN(entry) != klen)
 339             continue;
 340         if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen))        /* is this it? */
 341             continue;
 342         if (HeKUTF8(entry) != (char)is_utf8)
 343             continue;
 344         if (key != keysave)
 345             Safefree(key);
 346         return entry;
 347     }
 348 #ifdef DYNAMIC_ENV_FETCH  /* %ENV lookup?  If so, try to fetch the value now */
 349     if (mg_find((SV*)hv, PERL_MAGIC_env)) {
 350         unsigned long len;
 351         char *env = PerlEnv_ENVgetenv_len(key,&len);
 352         if (env) {
 353             sv = newSVpvn(env,len);
 354             SvTAINTED_on(sv);
 355             return hv_store_ent(hv,keysv,sv,hash);
 356         }
 357     }
 358 #endif
 359     if (key != keysave)
 360         Safefree(key);
 361     if (lval) {         /* gonna assign to this, so it better be there */
 362         sv = NEWSV(61,0);
 363         return hv_store_ent(hv,keysv,sv,hash);
 364     }
 365     return 0;
 366 }
 367
 368 STATIC void
 369 S_hv_magic_check(pTHX_ HV *hv, bool *needs_copy, bool *needs_store)
 370 {
 371     MAGIC *mg = SvMAGIC(hv);
 372     *needs_copy = FALSE;
 373     *needs_store = TRUE;
 374     while (mg) {
 375         if (isUPPER(mg->mg_type)) {
 376             *needs_copy = TRUE;
 377             switch (mg->mg_type) {
 378             case PERL_MAGIC_tied:
 379             case PERL_MAGIC_sig:
 380                 *needs_store = FALSE;
 381             }
 382         }
 383         mg = mg->mg_moremagic;
 384     }
 385 }
 386
 387 /*
 388 =for apidoc hv_store
 389
 390 Stores an SV in a hash.  The hash key is specified as C<key> and C<klen> is
 391 the length of the key.  The C<hash> parameter is the precomputed hash
 392 value; if it is zero then Perl will compute it.  The return value will be
 393 NULL if the operation failed or if the value did not need to be actually
 394 stored within the hash (as in the case of tied hashes).  Otherwise it can
 395 be dereferenced to get the original C<SV*>.  Note that the caller is
 396 responsible for suitably incrementing the reference count of C<val> before
 397 the call, and decrementing it if the function returned NULL.
 398
 399 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
 400 information on how to use this function on tied hashes.
 401
 402 =cut
 403 */
 404
 405 SV**
 406 Perl_hv_store(pTHX_ HV *hv, const char *key, I32 klen, SV *val, register U32 hash)
 407 {
 408     register I32 i;
 409     register HE *entry;
 410     register HE **oentry;
 411     bool is_utf8 = FALSE;
 412     const char *keysave = key;
 413
 414     if (!hv)
 415         return 0;
 416
 417     if (klen < 0) {
 418       klen = -klen;
 419       is_utf8 = TRUE;
 420     }
 421
 422     if (SvMAGICAL(hv)) {
 423         bool needs_copy;
 424         bool needs_store;
 425         hv_magic_check (hv, &needs_copy, &needs_store);
 426         if (needs_copy) {
 427             mg_copy((SV*)hv, val, key, klen);
 428             if (!HvARRAY(hv) && !needs_store)
 429                 return 0;
 430 #ifdef ENV_IS_CASELESS
 431             else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
 432                 key = savepvn(key,klen);
 433                 key = strupr(key);
 434                 hash = 0;
 435             }
 436 #endif
 437         }
 438     }
 439     if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT)) {
 440         STRLEN tmplen = klen;
 441         /* See the note in hv_fetch(). --jhi */
 442         key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
 443         klen = tmplen;
 444     }
 445
 446     if (!hash)
 447         PERL_HASH(hash, key, klen);
 448
 449     if (!HvARRAY(hv))
 450         Newz(505, HvARRAY(hv),
 451              PERL_HV_ARRAY_ALLOC_BYTES(HvMAX(hv) + 1), char);
 452
 453     oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)];
 454     i = 1;
 455
 456     for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
 457         if (HeHASH(entry) != hash)              /* strings can't be equal */
 458             continue;
 459         if (HeKLEN(entry) != klen)
 460             continue;
 461         if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen))        /* is this it? */
 462             continue;
 463         if (HeKUTF8(entry) != (char)is_utf8)
 464             continue;
 465         SvREFCNT_dec(HeVAL(entry));
 466         HeVAL(entry) = val;
 467         if (key != keysave)
 468             Safefree(key);
 469         return &HeVAL(entry);
 470     }
 471
 472     entry = new_HE();
 473     if (HvSHAREKEYS(hv))
 474         HeKEY_hek(entry) = share_hek(key, is_utf8?-klen:klen, hash);
 475     else                                       /* gotta do the real thing */
 476         HeKEY_hek(entry) = save_hek(key, is_utf8?-klen:klen, hash);
 477     if (key != keysave)
 478         Safefree(key);
 479     HeVAL(entry) = val;
 480     HeNEXT(entry) = *oentry;
 481     *oentry = entry;
 482
 483     HvKEYS(hv)++;
 484     if (i) {                            /* initial entry? */
 485         HvFILL(hv)++;
 486         if (HvKEYS(hv) > HvMAX(hv))
 487             hsplit(hv);
 488     }
 489
 490     return &HeVAL(entry);
 491 }
 492
 493 /*
 494 =for apidoc hv_store_ent
 495
 496 Stores C<val> in a hash.  The hash key is specified as C<key>.  The C<hash>
 497 parameter is the precomputed hash value; if it is zero then Perl will
 498 compute it.  The return value is the new hash entry so created.  It will be
 499 NULL if the operation failed or if the value did not need to be actually
 500 stored within the hash (as in the case of tied hashes).  Otherwise the
 501 contents of the return value can be accessed using the C<He?> macros
 502 described here.  Note that the caller is responsible for suitably
 503 incrementing the reference count of C<val> before the call, and
 504 decrementing it if the function returned NULL.
 505
 506 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
 507 information on how to use this function on tied hashes.
 508
 509 =cut
 510 */
 511
 512 HE *
 513 Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, register U32 hash)
 514 {
 515     register char *key;
 516     STRLEN klen;
 517     register I32 i;
 518     register HE *entry;
 519     register HE **oentry;
 520     bool is_utf8;
 521     char *keysave;
 522
 523     if (!hv)
 524         return 0;
 525
 526     if (SvMAGICAL(hv)) {
 527         bool needs_copy;
 528         bool needs_store;
 529         hv_magic_check (hv, &needs_copy, &needs_store);
 530         if (needs_copy) {
 531             bool save_taint = PL_tainted;
 532             if (PL_tainting)
 533                 PL_tainted = SvTAINTED(keysv);
 534             keysv = sv_2mortal(newSVsv(keysv));
 535             mg_copy((SV*)hv, val, (char*)keysv, HEf_SVKEY);
 536             TAINT_IF(save_taint);
 537             if (!HvARRAY(hv) && !needs_store)
 538                 return Nullhe;
 539 #ifdef ENV_IS_CASELESS
 540             else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
 541                 key = SvPV(keysv, klen);
 542                 keysv = sv_2mortal(newSVpvn(key,klen));
 543                 (void)strupr(SvPVX(keysv));
 544                 hash = 0;
 545             }
 546 #endif
 547         }
 548     }
 549
 550     keysave = key = SvPV(keysv, klen);
 551     is_utf8 = (SvUTF8(keysv) != 0);
 552
 553     if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT))
 554         key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
 555
 556     if (!hash)
 557         PERL_HASH(hash, key, klen);
 558
 559     if (!HvARRAY(hv))
 560         Newz(505, HvARRAY(hv),
 561              PERL_HV_ARRAY_ALLOC_BYTES(HvMAX(hv) + 1), char);
 562
 563     oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)];
 564     i = 1;
 565
 566     for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
 567         if (HeHASH(entry) != hash)              /* strings can't be equal */
 568             continue;
 569         if (HeKLEN(entry) != klen)
 570             continue;
 571         if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen))        /* is this it? */
 572             continue;
 573         if (HeKUTF8(entry) != (char)is_utf8)
 574             continue;
 575         SvREFCNT_dec(HeVAL(entry));
 576         HeVAL(entry) = val;
 577         if (key != keysave)
 578             Safefree(key);
 579         return entry;
 580     }
 581
 582     entry = new_HE();
 583     if (HvSHAREKEYS(hv))
 584         HeKEY_hek(entry) = share_hek(key, is_utf8?-klen:klen, hash);
 585     else                                       /* gotta do the real thing */
 586         HeKEY_hek(entry) = save_hek(key, is_utf8?-klen:klen, hash);
 587     if (key != keysave)
 588         Safefree(key);
 589     HeVAL(entry) = val;
 590     HeNEXT(entry) = *oentry;
 591     *oentry = entry;
 592
 593     HvKEYS(hv)++;
 594     if (i) {                            /* initial entry? */
 595         HvFILL(hv)++;
 596         if (HvKEYS(hv) > HvMAX(hv))
 597             hsplit(hv);
 598     }
 599
 600     return entry;
 601 }
 602
 603 /*
 604 =for apidoc hv_delete
 605
 606 Deletes a key/value pair in the hash.  The value SV is removed from the
 607 hash and returned to the caller.  The C<klen> is the length of the key.
 608 The C<flags> value will normally be zero; if set to G_DISCARD then NULL
 609 will be returned.
 610
 611 =cut
 612 */
 613
 614 SV *
 615 Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen, I32 flags)
 616 {
 617     register I32 i;
 618     register U32 hash;
 619     register HE *entry;
 620     register HE **oentry;
 621     SV **svp;
 622     SV *sv;
 623     bool is_utf8 = FALSE;
 624     const char *keysave = key;
 625
 626     if (!hv)
 627         return Nullsv;
 628     if (klen < 0) {
 629       klen = -klen;
 630       is_utf8 = TRUE;
 631     }
 632     if (SvRMAGICAL(hv)) {
 633         bool needs_copy;
 634         bool needs_store;
 635         hv_magic_check (hv, &needs_copy, &needs_store);
 636
 637         if (needs_copy && (svp = hv_fetch(hv, key, klen, TRUE))) {
 638             sv = *svp;
 639             mg_clear(sv);
 640             if (!needs_store) {
 641                 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
 642                     /* No longer an element */
 643                     sv_unmagic(sv, PERL_MAGIC_tiedelem);
 644                     return sv;
 645                 }
 646                 return Nullsv;          /* element cannot be deleted */
 647             }
 648 #ifdef ENV_IS_CASELESS
 649             else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
 650                 sv = sv_2mortal(newSVpvn(key,klen));
 651                 key = strupr(SvPVX(sv));
 652             }
 653 #endif
 654         }
 655     }
 656     if (!HvARRAY(hv))
 657         return Nullsv;
 658
 659     if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT)) {
 660         STRLEN tmplen = klen;
 661         /* See the note in hv_fetch(). --jhi */
 662         key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
 663         klen = tmplen;
 664     }
 665
 666     PERL_HASH(hash, key, klen);
 667
 668     oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)];
 669     entry = *oentry;
 670     i = 1;
 671     for (; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
 672         if (HeHASH(entry) != hash)              /* strings can't be equal */
 673             continue;
 674         if (HeKLEN(entry) != klen)
 675             continue;
 676         if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen))        /* is this it? */
 677             continue;
 678         if (HeKUTF8(entry) != (char)is_utf8)
 679             continue;
 680         if (key != keysave)
 681             Safefree(key);
 682         *oentry = HeNEXT(entry);
 683         if (i && !*oentry)
 684             HvFILL(hv)--;
 685         if (flags & G_DISCARD)
 686             sv = Nullsv;
 687         else {
 688             sv = sv_2mortal(HeVAL(entry));
 689             HeVAL(entry) = &PL_sv_undef;
 690         }
 691         if (entry == HvEITER(hv))
 692             HvLAZYDEL_on(hv);
 693         else
 694             hv_free_ent(hv, entry);
 695         HvKEYS(hv)--;
 696         return sv;
 697     }
 698     if (key != keysave)
 699         Safefree(key);
 700     return Nullsv;
 701 }
 702
 703 /*
 704 =for apidoc hv_delete_ent
 705
 706 Deletes a key/value pair in the hash.  The value SV is removed from the
 707 hash and returned to the caller.  The C<flags> value will normally be zero;
 708 if set to G_DISCARD then NULL will be returned.  C<hash> can be a valid
 709 precomputed hash value, or 0 to ask for it to be computed.
 710
 711 =cut
 712 */
 713
 714 SV *
 715 Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash)
 716 {
 717     register I32 i;
 718     register char *key;
 719     STRLEN klen;
 720     register HE *entry;
 721     register HE **oentry;
 722     SV *sv;
 723     bool is_utf8;
 724     char *keysave;
 725
 726     if (!hv)
 727         return Nullsv;
 728     if (SvRMAGICAL(hv)) {
 729         bool needs_copy;
 730         bool needs_store;
 731         hv_magic_check (hv, &needs_copy, &needs_store);
 732
 733         if (needs_copy && (entry = hv_fetch_ent(hv, keysv, TRUE, hash))) {
 734             sv = HeVAL(entry);
 735             mg_clear(sv);
 736             if (!needs_store) {
 737                 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
 738                     /* No longer an element */
 739                     sv_unmagic(sv, PERL_MAGIC_tiedelem);
 740                     return sv;
 741                 }
 742                 return Nullsv;          /* element cannot be deleted */
 743             }
 744 #ifdef ENV_IS_CASELESS
 745             else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
 746                 key = SvPV(keysv, klen);
 747                 keysv = sv_2mortal(newSVpvn(key,klen));
 748                 (void)strupr(SvPVX(keysv));
 749                 hash = 0;
 750             }
 751 #endif
 752         }
 753     }
 754     if (!HvARRAY(hv))
 755         return Nullsv;
 756
 757     keysave = key = SvPV(keysv, klen);
 758     is_utf8 = (SvUTF8(keysv) != 0);
 759
 760     if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT))
 761         key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
 762
 763     if (!hash)
 764         PERL_HASH(hash, key, klen);
 765
 766     oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)];
 767     entry = *oentry;
 768     i = 1;
 769     for (; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
 770         if (HeHASH(entry) != hash)              /* strings can't be equal */
 771             continue;
 772         if (HeKLEN(entry) != klen)
 773             continue;
 774         if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen))        /* is this it? */
 775             continue;
 776         if (HeKUTF8(entry) != (char)is_utf8)
 777             continue;
 778         if (key != keysave)
 779             Safefree(key);
 780         *oentry = HeNEXT(entry);
 781         if (i && !*oentry)
 782             HvFILL(hv)--;
 783         if (flags & G_DISCARD)
 784             sv = Nullsv;
 785         else {
 786             sv = sv_2mortal(HeVAL(entry));
 787             HeVAL(entry) = &PL_sv_undef;
 788         }
 789         if (entry == HvEITER(hv))
 790             HvLAZYDEL_on(hv);
 791         else
 792             hv_free_ent(hv, entry);
 793         HvKEYS(hv)--;
 794         return sv;
 795     }
 796     if (key != keysave)
 797         Safefree(key);
 798     return Nullsv;
 799 }
 800
 801 /*
 802 =for apidoc hv_exists
 803
 804 Returns a boolean indicating whether the specified hash key exists.  The
 805 C<klen> is the length of the key.
 806
 807 =cut
 808 */
 809
 810 bool
 811 Perl_hv_exists(pTHX_ HV *hv, const char *key, I32 klen)
 812 {
 813     register U32 hash;
 814     register HE *entry;
 815     SV *sv;
 816     bool is_utf8 = FALSE;
 817     const char *keysave = key;
 818
 819     if (!hv)
 820         return 0;
 821
 822     if (klen < 0) {
 823       klen = -klen;
 824       is_utf8 = TRUE;
 825     }
 826
 827     if (SvRMAGICAL(hv)) {
 828         if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
 829             sv = sv_newmortal();
 830             mg_copy((SV*)hv, sv, key, klen);
 831             magic_existspack(sv, mg_find(sv, PERL_MAGIC_tiedelem));
 832             return SvTRUE(sv);
 833         }
 834 #ifdef ENV_IS_CASELESS
 835         else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
 836             sv = sv_2mortal(newSVpvn(key,klen));
 837             key = strupr(SvPVX(sv));
 838         }
 839 #endif
 840     }
 841
 842 #ifndef DYNAMIC_ENV_FETCH
 843     if (!HvARRAY(hv))
 844         return 0;
 845 #endif
 846
 847     if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT)) {
 848         STRLEN tmplen = klen;
 849         /* See the note in hv_fetch(). --jhi */
 850         key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
 851         klen = tmplen;
 852     }
 853
 854     PERL_HASH(hash, key, klen);
 855
 856 #ifdef DYNAMIC_ENV_FETCH
 857     if (!HvARRAY(hv)) entry = Null(HE*);
 858     else
 859 #endif
 860     entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)];
 861     for (; entry; entry = HeNEXT(entry)) {
 862         if (HeHASH(entry) != hash)              /* strings can't be equal */
 863             continue;
 864         if (HeKLEN(entry) != klen)
 865             continue;
 866         if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen))        /* is this it? */
 867             continue;
 868         if (HeKUTF8(entry) != (char)is_utf8)
 869             continue;
 870         if (key != keysave)
 871             Safefree(key);
 872         return TRUE;
 873     }
 874 #ifdef DYNAMIC_ENV_FETCH  /* is it out there? */
 875     if (mg_find((SV*)hv, PERL_MAGIC_env)) {
 876         unsigned long len;
 877         char *env = PerlEnv_ENVgetenv_len(key,&len);
 878         if (env) {
 879             sv = newSVpvn(env,len);
 880             SvTAINTED_on(sv);
 881             (void)hv_store(hv,key,klen,sv,hash);
 882             return TRUE;
 883         }
 884     }
 885 #endif
 886     if (key != keysave)
 887         Safefree(key);
 888     return FALSE;
 889 }
 890
 891
 892 /*
 893 =for apidoc hv_exists_ent
 894
 895 Returns a boolean indicating whether the specified hash key exists. C<hash>
 896 can be a valid precomputed hash value, or 0 to ask for it to be
 897 computed.
 898
 899 =cut
 900 */
 901
 902 bool
 903 Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash)
 904 {
 905     register char *key;
 906     STRLEN klen;
 907     register HE *entry;
 908     SV *sv;
 909     bool is_utf8;
 910     char *keysave;
 911
 912     if (!hv)
 913         return 0;
 914
 915     if (SvRMAGICAL(hv)) {
 916         if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
 917            SV* svret = sv_newmortal();
 918             sv = sv_newmortal();
 919             keysv = sv_2mortal(newSVsv(keysv));
 920             mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY);
 921            magic_existspack(svret, mg_find(sv, PERL_MAGIC_tiedelem));
 922            return SvTRUE(svret);
 923         }
 924 #ifdef ENV_IS_CASELESS
 925         else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
 926             key = SvPV(keysv, klen);
 927             keysv = sv_2mortal(newSVpvn(key,klen));
 928             (void)strupr(SvPVX(keysv));
 929             hash = 0;
 930         }
 931 #endif
 932     }
 933
 934 #ifndef DYNAMIC_ENV_FETCH
 935     if (!HvARRAY(hv))
 936         return 0;
 937 #endif
 938
 939     keysave = key = SvPV(keysv, klen);
 940     is_utf8 = (SvUTF8(keysv) != 0);
 941     if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT))
 942         key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
 943     if (!hash)
 944         PERL_HASH(hash, key, klen);
 945
 946 #ifdef DYNAMIC_ENV_FETCH
 947     if (!HvARRAY(hv)) entry = Null(HE*);
 948     else
 949 #endif
 950     entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)];
 951     for (; entry; entry = HeNEXT(entry)) {
 952         if (HeHASH(entry) != hash)              /* strings can't be equal */
 953             continue;
 954         if (HeKLEN(entry) != klen)
 955             continue;
 956         if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen))        /* is this it? */
 957             continue;
 958         if (HeKUTF8(entry) != (char)is_utf8)
 959             continue;
 960         if (key != keysave)
 961             Safefree(key);
 962         return TRUE;
 963     }
 964 #ifdef DYNAMIC_ENV_FETCH  /* is it out there? */
 965     if (mg_find((SV*)hv, PERL_MAGIC_env)) {
 966         unsigned long len;
 967         char *env = PerlEnv_ENVgetenv_len(key,&len);
 968         if (env) {
 969             sv = newSVpvn(env,len);
 970             SvTAINTED_on(sv);
 971             (void)hv_store_ent(hv,keysv,sv,hash);
 972             return TRUE;
 973         }
 974     }
 975 #endif
 976     if (key != keysave)
 977         Safefree(key);
 978     return FALSE;
 979 }
 980
 981 STATIC void
 982 S_hsplit(pTHX_ HV *hv)
 983 {
 984     I32 oldsize = (I32) HvMAX(hv) + 1; /* sic(k) */
 985     register I32 newsize = oldsize * 2;
 986     register I32 i;
 987     register char *a = (char *)HvARRAY(hv);
 988     register HE **aep;
 989     register HE **bep;
 990     register HE *entry;
 991     register HE **oentry;
 992
 993     PL_nomemok = TRUE;
 994 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
 995     Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
 996     if (!a) {
 997       PL_nomemok = FALSE;
 998       return;
 999     }
1000 #else
1001     New(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1002     if (!a) {
1003       PL_nomemok = FALSE;
1004       return;
1005     }
1006     Copy(HvARRAY(hv), a, oldsize * sizeof(HE*), char);
1007     if (oldsize >= 64) {
1008         offer_nice_chunk(HvARRAY(hv), PERL_HV_ARRAY_ALLOC_BYTES(oldsize));
1009     }
1010     else
1011         Safefree(HvARRAY(hv));
1012 #endif
1013
1014     PL_nomemok = FALSE;
1015     Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char);     /* zero 2nd half*/
1016     HvMAX(hv) = --newsize;
1017     HvARRAY(hv) = a;
1018     aep = (HE**)a;
1019
1020     for (i=0; i<oldsize; i++,aep++) {
1021         if (!*aep)                              /* non-existent */
1022             continue;
1023         bep = aep+oldsize;
1024         for (oentry = aep, entry = *aep; entry; entry = *oentry) {
1025             if ((HeHASH(entry) & newsize) != i) {
1026                 *oentry = HeNEXT(entry);
1027                 HeNEXT(entry) = *bep;
1028                 if (!*bep)
1029                     HvFILL(hv)++;
1030                 *bep = entry;
1031                 continue;
1032             }
1033             else
1034                 oentry = &HeNEXT(entry);
1035         }
1036         if (!*aep)                              /* everything moved */
1037             HvFILL(hv)--;
1038     }
1039 }
1040
1041 void
1042 Perl_hv_ksplit(pTHX_ HV *hv, IV newmax)
1043 {
1044     I32 oldsize = (I32) HvMAX(hv) + 1; /* sic(k) */
1045     register I32 newsize;
1046     register I32 i;
1047     register I32 j;
1048     register char *a;
1049     register HE **aep;
1050     register HE *entry;
1051     register HE **oentry;
1052
1053     newsize = (I32) newmax;                     /* possible truncation here */
1054     if (newsize != newmax || newmax <= oldsize)
1055         return;
1056     while ((newsize & (1 + ~newsize)) != newsize) {
1057         newsize &= ~(newsize & (1 + ~newsize)); /* get proper power of 2 */
1058     }
1059     if (newsize < newmax)
1060         newsize *= 2;
1061     if (newsize < newmax)
1062         return;                                 /* overflow detection */
1063
1064     a = (char *)HvARRAY(hv);
1065     if (a) {
1066         PL_nomemok = TRUE;
1067 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
1068         Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1069         if (!a) {
1070           PL_nomemok = FALSE;
1071           return;
1072         }
1073 #else
1074         New(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1075         if (!a) {
1076           PL_nomemok = FALSE;
1077           return;
1078         }
1079         Copy(HvARRAY(hv), a, oldsize * sizeof(HE*), char);
1080         if (oldsize >= 64) {
1081             offer_nice_chunk(HvARRAY(hv), PERL_HV_ARRAY_ALLOC_BYTES(oldsize));
1082         }
1083         else
1084             Safefree(HvARRAY(hv));
1085 #endif
1086         PL_nomemok = FALSE;
1087         Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
1088     }
1089     else {
1090         Newz(0, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1091     }
1092     HvMAX(hv) = --newsize;
1093     HvARRAY(hv) = a;
1094     if (!HvFILL(hv))                            /* skip rest if no entries */
1095         return;
1096
1097     aep = (HE**)a;
1098     for (i=0; i<oldsize; i++,aep++) {
1099         if (!*aep)                              /* non-existent */
1100             continue;
1101         for (oentry = aep, entry = *aep; entry; entry = *oentry) {
1102             if ((j = (HeHASH(entry) & newsize)) != i) {
1103                 j -= i;
1104                 *oentry = HeNEXT(entry);
1105                 if (!(HeNEXT(entry) = aep[j]))
1106                     HvFILL(hv)++;
1107                 aep[j] = entry;
1108                 continue;
1109             }
1110             else
1111                 oentry = &HeNEXT(entry);
1112         }
1113         if (!*aep)                              /* everything moved */
1114             HvFILL(hv)--;
1115     }
1116 }
1117
1118 /*
1119 =for apidoc newHV
1120
1121 Creates a new HV.  The reference count is set to 1.
1122
1123 =cut
1124 */
1125
1126 HV *
1127 Perl_newHV(pTHX)
1128 {
1129     register HV *hv;
1130
1131     hv = (HV*)NEWSV(502,0);
1132     sv_upgrade((SV *)hv, SVt_PVHV);
1133     SvPOK_off(hv);
1134     SvNOK_off(hv);
1135 #ifndef NODEFAULT_SHAREKEYS
1136     HvSHAREKEYS_on(hv);         /* key-sharing on by default */
1137 #endif
1138     HvMAX(hv) = 7;              /* start with 8 buckets */
1139     HvFILL(hv) = 0;
1140     HvPMROOT(hv) = 0;
1141     (void)hv_iterinit(hv);      /* so each() will start off right */
1142     return hv;
1143 }
1144
1145 HV *
1146 Perl_newHVhv(pTHX_ HV *ohv)
1147 {
1148     register HV *hv;
1149     STRLEN hv_max = ohv ? HvMAX(ohv) : 0;
1150     STRLEN hv_fill = ohv ? HvFILL(ohv) : 0;
1151
1152     hv = newHV();
1153     while (hv_max && hv_max + 1 >= hv_fill * 2)
1154         hv_max = hv_max / 2;    /* Is always 2^n-1 */
1155     HvMAX(hv) = hv_max;
1156     if (!hv_fill)
1157         return hv;
1158
1159 #if 0
1160     if (! SvTIED_mg((SV*)ohv, PERL_MAGIC_tied)) {
1161         /* Quick way ???*/
1162     }
1163     else
1164 #endif
1165     {
1166         HE *entry;
1167         I32 hv_riter = HvRITER(ohv);    /* current root of iterator */
1168         HE *hv_eiter = HvEITER(ohv);    /* current entry of iterator */
1169
1170         /* Slow way */
1171         hv_iterinit(ohv);
1172         while ((entry = hv_iternext(ohv))) {
1173             hv_store(hv, HeKEY(entry), HeKLEN_UTF8(entry),
1174                      newSVsv(HeVAL(entry)), HeHASH(entry));
1175         }
1176         HvRITER(ohv) = hv_riter;
1177         HvEITER(ohv) = hv_eiter;
1178     }
1179
1180     return hv;
1181 }
1182
1183 void
1184 Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry)
1185 {
1186     SV *val;
1187
1188     if (!entry)
1189         return;
1190     val = HeVAL(entry);
1191     if (val && isGV(val) && GvCVu(val) && HvNAME(hv))
1192         PL_sub_generation++;    /* may be deletion of method from stash */
1193     SvREFCNT_dec(val);
1194     if (HeKLEN(entry) == HEf_SVKEY) {
1195         SvREFCNT_dec(HeKEY_sv(entry));
1196         Safefree(HeKEY_hek(entry));
1197     }
1198     else if (HvSHAREKEYS(hv))
1199         unshare_hek(HeKEY_hek(entry));
1200     else
1201         Safefree(HeKEY_hek(entry));
1202     del_HE(entry);
1203 }
1204
1205 void
1206 Perl_hv_delayfree_ent(pTHX_ HV *hv, register HE *entry)
1207 {
1208     if (!entry)
1209         return;
1210     if (isGV(HeVAL(entry)) && GvCVu(HeVAL(entry)) && HvNAME(hv))
1211         PL_sub_generation++;    /* may be deletion of method from stash */
1212     sv_2mortal(HeVAL(entry));   /* free between statements */
1213     if (HeKLEN(entry) == HEf_SVKEY) {
1214         sv_2mortal(HeKEY_sv(entry));
1215         Safefree(HeKEY_hek(entry));
1216     }
1217     else if (HvSHAREKEYS(hv))
1218         unshare_hek(HeKEY_hek(entry));
1219     else
1220         Safefree(HeKEY_hek(entry));
1221     del_HE(entry);
1222 }
1223
1224 /*
1225 =for apidoc hv_clear
1226
1227 Clears a hash, making it empty.
1228
1229 =cut
1230 */
1231
1232 void
1233 Perl_hv_clear(pTHX_ HV *hv)
1234 {
1235     if (!hv)
1236         return;
1237     hfreeentries(hv);
1238     HvFILL(hv) = 0;
1239     HvKEYS(hv) = 0;
1240     if (HvARRAY(hv))
1241         (void)memzero(HvARRAY(hv), (HvMAX(hv) + 1) * sizeof(HE*));
1242
1243     if (SvRMAGICAL(hv))
1244         mg_clear((SV*)hv);
1245 }
1246
1247 STATIC void
1248 S_hfreeentries(pTHX_ HV *hv)
1249 {
1250     register HE **array;
1251     register HE *entry;
1252     register HE *oentry = Null(HE*);
1253     I32 riter;
1254     I32 max;
1255
1256     if (!hv)
1257         return;
1258     if (!HvARRAY(hv))
1259         return;
1260
1261     riter = 0;
1262     max = HvMAX(hv);
1263     array = HvARRAY(hv);
1264     entry = array[0];
1265     for (;;) {
1266         if (entry) {
1267             oentry = entry;
1268             entry = HeNEXT(entry);
1269             hv_free_ent(hv, oentry);
1270         }
1271         if (!entry) {
1272             if (++riter > max)
1273                 break;
1274             entry = array[riter];
1275         }
1276     }
1277     (void)hv_iterinit(hv);
1278 }
1279
1280 /*
1281 =for apidoc hv_undef
1282
1283 Undefines the hash.
1284
1285 =cut
1286 */
1287
1288 void
1289 Perl_hv_undef(pTHX_ HV *hv)
1290 {
1291     if (!hv)
1292         return;
1293     hfreeentries(hv);
1294     Safefree(HvARRAY(hv));
1295     if (HvNAME(hv)) {
1296         Safefree(HvNAME(hv));
1297         HvNAME(hv) = 0;
1298     }
1299     HvARRAY(hv) = 0;
1300     HvMAX(hv)   = 7;            /* it's a normal hash */
1301     HvFILL(hv)  = 0;
1302     HvKEYS(hv)  = 0;
1303
1304     if (SvRMAGICAL(hv))
1305         mg_clear((SV*)hv);
1306 }
1307
1308 /*
1309 =for apidoc hv_iterinit
1310
1311 Prepares a starting point to traverse a hash table.  Returns the number of
1312 keys in the hash (i.e. the same as C<HvKEYS(tb)>).  The return value is
1313 currently only meaningful for hashes without tie magic.
1314
1315 NOTE: Before version 5.004_65, C<hv_iterinit> used to return the number of
1316 hash buckets that happen to be in use.  If you still need that esoteric
1317 value, you can get it through the macro C<HvFILL(tb)>.
1318
1319 =cut
1320 */
1321
1322 I32
1323 Perl_hv_iterinit(pTHX_ HV *hv)
1324 {
1325     HE *entry;
1326
1327     if (!hv)
1328         Perl_croak(aTHX_ "Bad hash");
1329     entry = HvEITER(hv);
1330     if (entry && HvLAZYDEL(hv)) {       /* was deleted earlier? */
1331         HvLAZYDEL_off(hv);
1332         hv_free_ent(hv, entry);
1333     }
1334     HvRITER(hv) = -1;
1335     HvEITER(hv) = Null(HE*);
1336     return HvKEYS(hv);          /* used to be xhv->xhv_fill before 5.004_65 */
1337 }
1338
1339 /*
1340 =for apidoc hv_iternext
1341
1342 Returns entries from a hash iterator.  See C<hv_iterinit>.
1343
1344 =cut
1345 */
1346
1347 HE *
1348 Perl_hv_iternext(pTHX_ HV *hv)
1349 {
1350     register HE *entry;
1351     HE *oldentry;
1352     MAGIC* mg;
1353
1354     if (!hv)
1355         Perl_croak(aTHX_ "Bad hash");
1356     oldentry = entry = HvEITER(hv);
1357
1358     if ((mg = SvTIED_mg((SV*)hv, PERL_MAGIC_tied))) {
1359         SV *key = sv_newmortal();
1360         if (entry) {
1361             sv_setsv(key, HeSVKEY_force(entry));
1362             SvREFCNT_dec(HeSVKEY(entry));       /* get rid of previous key */
1363         }
1364         else {
1365             char *k;
1366             HEK *hek;
1367
1368             HvEITER(hv) = entry = new_HE();  /* one HE per MAGICAL hash */
1369             Zero(entry, 1, HE);
1370             Newz(54, k, HEK_BASESIZE + sizeof(SV*), char);
1371             hek = (HEK*)k;
1372             HeKEY_hek(entry) = hek;
1373             HeKLEN(entry) = HEf_SVKEY;
1374         }
1375         magic_nextpack((SV*) hv,mg,key);
1376         if (SvOK(key)) {
1377             /* force key to stay around until next time */
1378             HeSVKEY_set(entry, SvREFCNT_inc(key));
1379             return entry;               /* beware, hent_val is not set */
1380         }
1381         if (HeVAL(entry))
1382             SvREFCNT_dec(HeVAL(entry));
1383         Safefree(HeKEY_hek(entry));
1384         del_HE(entry);
1385         HvEITER(hv) = Null(HE*);
1386         return Null(HE*);
1387     }
1388 #ifdef DYNAMIC_ENV_FETCH  /* set up %ENV for iteration */
1389     if (!entry && mg_find((SV*)hv, PERL_MAGIC_env))
1390         prime_env_iter();
1391 #endif
1392
1393     if (!HvARRAY(hv))
1394         Newz(506, HvARRAY(hv),
1395              PERL_HV_ARRAY_ALLOC_BYTES(HvMAX(hv) + 1), char);
1396     if (entry)
1397         entry = HeNEXT(entry);
1398     while (!entry) {
1399         HvRITER(hv)++;
1400         if (HvRITER(hv) > HvMAX(hv)) {
1401             HvRITER(hv) = -1;
1402             break;
1403         }
1404         entry = (HvARRAY(hv))[HvRITER(hv)];
1405     }
1406
1407     if (oldentry && HvLAZYDEL(hv)) {            /* was deleted earlier? */
1408         HvLAZYDEL_off(hv);
1409         hv_free_ent(hv, oldentry);
1410     }
1411
1412     HvEITER(hv) = entry;
1413     return entry;
1414 }
1415
1416 /*
1417 =for apidoc hv_iterkey
1418
1419 Returns the key from the current position of the hash iterator.  See
1420 C<hv_iterinit>.
1421
1422 =cut
1423 */
1424
1425 char *
1426 Perl_hv_iterkey(pTHX_ register HE *entry, I32 *retlen)
1427 {
1428     if (HeKLEN(entry) == HEf_SVKEY) {
1429         STRLEN len;
1430         char *p = SvPV(HeKEY_sv(entry), len);
1431         *retlen = len;
1432         return p;
1433     }
1434     else {
1435         *retlen = HeKLEN(entry);
1436         return HeKEY(entry);
1437     }
1438 }
1439
1440 /* unlike hv_iterval(), this always returns a mortal copy of the key */
1441 /*
1442 =for apidoc hv_iterkeysv
1443
1444 Returns the key as an C<SV*> from the current position of the hash
1445 iterator.  The return value will always be a mortal copy of the key.  Also
1446 see C<hv_iterinit>.
1447
1448 =cut
1449 */
1450
1451 SV *
1452 Perl_hv_iterkeysv(pTHX_ register HE *entry)
1453 {
1454     if (HeKLEN(entry) == HEf_SVKEY)
1455         return sv_mortalcopy(HeKEY_sv(entry));
1456     else
1457         return sv_2mortal(newSVpvn_share((HeKLEN(entry) ? HeKEY(entry) : ""),
1458                                          HeKLEN_UTF8(entry), HeHASH(entry)));
1459 }
1460
1461 /*
1462 =for apidoc hv_iterval
1463
1464 Returns the value from the current position of the hash iterator.  See
1465 C<hv_iterkey>.
1466
1467 =cut
1468 */
1469
1470 SV *
1471 Perl_hv_iterval(pTHX_ HV *hv, register HE *entry)
1472 {
1473     if (SvRMAGICAL(hv)) {
1474         if (mg_find((SV*)hv, PERL_MAGIC_tied)) {
1475             SV* sv = sv_newmortal();
1476             if (HeKLEN(entry) == HEf_SVKEY)
1477                 mg_copy((SV*)hv, sv, (char*)HeKEY_sv(entry), HEf_SVKEY);
1478             else mg_copy((SV*)hv, sv, HeKEY(entry), HeKLEN(entry));
1479             return sv;
1480         }
1481     }
1482     return HeVAL(entry);
1483 }
1484
1485 /*
1486 =for apidoc hv_iternextsv
1487
1488 Performs an C<hv_iternext>, C<hv_iterkey>, and C<hv_iterval> in one
1489 operation.
1490
1491 =cut
1492 */
1493
1494 SV *
1495 Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen)
1496 {
1497     HE *he;
1498     if ( (he = hv_iternext(hv)) == NULL)
1499         return NULL;
1500     *key = hv_iterkey(he, retlen);
1501     return hv_iterval(hv, he);
1502 }
1503
1504 /*
1505 =for apidoc hv_magic
1506
1507 Adds magic to a hash.  See C<sv_magic>.
1508
1509 =cut
1510 */
1511
1512 void
1513 Perl_hv_magic(pTHX_ HV *hv, GV *gv, int how)
1514 {
1515     sv_magic((SV*)hv, (SV*)gv, how, Nullch, 0);
1516 }
1517
1518 char*
1519 Perl_sharepvn(pTHX_ const char *sv, I32 len, U32 hash)
1520 {
1521     return HEK_KEY(share_hek(sv, len, hash));
1522 }
1523
1524 /* possibly free a shared string if no one has access to it
1525  * len and hash must both be valid for str.
1526  */
1527 void
1528 Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
1529 {
1530     HV *hv;
1531     register HE *entry;
1532     register HE **oentry;
1533     register I32 i = 1;
1534     I32 found = 0;
1535     bool is_utf8 = FALSE;
1536     const char *save = str;
1537
1538     if (len < 0) {
1539       len = -len;
1540       is_utf8 = TRUE;
1541       if (!(PL_hints & HINT_UTF8_DISTINCT)) {
1542           STRLEN tmplen = len;
1543           /* See the note in hv_fetch(). --jhi */
1544           str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
1545           len = tmplen;
1546       }
1547     }
1548
1549     /* what follows is the moral equivalent of:
1550     if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) {
1551         if (--*Svp == Nullsv)
1552             hv_delete(PL_strtab, str, len, G_DISCARD, hash);
1553     } */
1554     /* assert(xhv_array != 0) */
1555     hv = PL_strtab;
1556     LOCK_STRTAB_MUTEX;
1557     oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)];
1558     for (entry = *oentry; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
1559         if (HeHASH(entry) != hash)              /* strings can't be equal */
1560             continue;
1561         if (HeKLEN(entry) != len)
1562             continue;
1563         if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
1564             continue;
1565         if (HeKUTF8(entry) != (char)is_utf8)
1566             continue;
1567         found = 1;
1568         if (--HeVAL(entry) == Nullsv) {
1569             *oentry = HeNEXT(entry);
1570             if (i && !*oentry)
1571                 HvFILL(hv)--;
1572             Safefree(HeKEY_hek(entry));
1573             del_HE(entry);
1574             HvKEYS(hv)--;
1575         }
1576         break;
1577     }
1578     UNLOCK_STRTAB_MUTEX;
1579     if (str != save)
1580         Safefree(str);
1581     if (!found && ckWARN_d(WARN_INTERNAL))
1582         Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free non-existent shared string '%s'",str);
1583 }
1584
1585 /* get a (constant) string ptr from the global string table
1586  * string will get added if it is not already there.
1587  * len and hash must both be valid for str.
1588  */
1589 HEK *
1590 Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash)
1591 {
1592     HV *hv;
1593     register HE *entry;
1594     register HE **oentry;
1595     register I32 i = 1;
1596     I32 found = 0;
1597     bool is_utf8 = FALSE;
1598     const char *save = str;
1599
1600     if (len < 0) {
1601       len = -len;
1602       is_utf8 = TRUE;
1603       if (!(PL_hints & HINT_UTF8_DISTINCT)) {
1604           STRLEN tmplen = len;
1605           /* See the note in hv_fetch(). --jhi */
1606           str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
1607           len = tmplen;
1608       }
1609     }
1610
1611     /* what follows is the moral equivalent of:
1612
1613     if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
1614         hv_store(PL_strtab, str, len, Nullsv, hash);
1615     */
1616     /* assert(xhv_array != 0) */
1617     hv = PL_strtab;
1618     LOCK_STRTAB_MUTEX;
1619     oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)];
1620     for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
1621         if (HeHASH(entry) != hash)              /* strings can't be equal */
1622             continue;
1623         if (HeKLEN(entry) != len)
1624             continue;
1625         if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
1626             continue;
1627         if (HeKUTF8(entry) != (char)is_utf8)
1628             continue;
1629         found = 1;
1630         break;
1631     }
1632     if (!found) {
1633         entry = new_HE();
1634         HeKEY_hek(entry) = save_hek(str, is_utf8?-len:len, hash);
1635         HeVAL(entry) = Nullsv;
1636         HeNEXT(entry) = *oentry;
1637         *oentry = entry;
1638         HvKEYS(hv)++;
1639         if (i) {                                /* initial entry? */
1640             HvFILL(hv)++;
1641             if (HvKEYS(hv) > HvMAX(hv))
1642                 hsplit(hv);
1643         }
1644     }
1645
1646     ++HeVAL(entry);                             /* use value slot as REFCNT */
1647     UNLOCK_STRTAB_MUTEX;
1648     if (str != save)
1649         Safefree(str);
1650     return HeKEY_hek(entry);
1651 }