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