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