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, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
 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, PERL_MAGIC_env)) {
 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, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
 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, PERL_MAGIC_env)) {
 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 PERL_MAGIC_tied:
 383             case PERL_MAGIC_sig:
 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, PERL_MAGIC_env)) {
 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, PERL_MAGIC_env)) {
 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, PERL_MAGIC_tiedelem)) {
 651                     /* No longer an element */
 652                     sv_unmagic(sv, PERL_MAGIC_tiedelem);
 653                     return sv;
 654                 }
 655                 return Nullsv;          /* element cannot be deleted */
 656             }
 657 #ifdef ENV_IS_CASELESS
 658             else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
 659                 sv = sv_2mortal(newSVpvn(key,klen));
 660                 key = strupr(SvPVX(sv));
 661             }
 662 #endif
 663         }
 664     }
 665     xhv = (XPVHV*)SvANY(hv);
 666     if (!xhv->xhv_array)
 667         return Nullsv;
 668
 669     if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT)) {
 670         STRLEN tmplen = klen;
 671         /* See the note in hv_fetch(). --jhi */
 672         key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
 673         klen = tmplen;
 674     }
 675
 676     PERL_HASH(hash, key, klen);
 677
 678     oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
 679     entry = *oentry;
 680     i = 1;
 681     for (; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
 682         if (HeHASH(entry) != hash)              /* strings can't be equal */
 683             continue;
 684         if (HeKLEN(entry) != klen)
 685             continue;
 686         if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen))        /* is this it? */
 687             continue;
 688         if (HeKUTF8(entry) != (char)is_utf8)
 689             continue;
 690         if (key != keysave)
 691             Safefree(key);
 692         *oentry = HeNEXT(entry);
 693         if (i && !*oentry)
 694             xhv->xhv_fill--;
 695         if (flags & G_DISCARD)
 696             sv = Nullsv;
 697         else {
 698             sv = sv_2mortal(HeVAL(entry));
 699             HeVAL(entry) = &PL_sv_undef;
 700         }
 701         if (entry == xhv->xhv_eiter)
 702             HvLAZYDEL_on(hv);
 703         else
 704             hv_free_ent(hv, entry);
 705         --xhv->xhv_keys;
 706         return sv;
 707     }
 708     if (key != keysave)
 709         Safefree(key);
 710     return Nullsv;
 711 }
 712
 713 /*
 714 =for apidoc hv_delete_ent
 715
 716 Deletes a key/value pair in the hash.  The value SV is removed from the
 717 hash and returned to the caller.  The C<flags> value will normally be zero;
 718 if set to G_DISCARD then NULL will be returned.  C<hash> can be a valid
 719 precomputed hash value, or 0 to ask for it to be computed.
 720
 721 =cut
 722 */
 723
 724 SV *
 725 Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash)
 726 {
 727     register XPVHV* xhv;
 728     register I32 i;
 729     register char *key;
 730     STRLEN klen;
 731     register HE *entry;
 732     register HE **oentry;
 733     SV *sv;
 734     bool is_utf8;
 735     char *keysave;
 736
 737     if (!hv)
 738         return Nullsv;
 739     if (SvRMAGICAL(hv)) {
 740         bool needs_copy;
 741         bool needs_store;
 742         hv_magic_check (hv, &needs_copy, &needs_store);
 743
 744         if (needs_copy && (entry = hv_fetch_ent(hv, keysv, TRUE, hash))) {
 745             sv = HeVAL(entry);
 746             mg_clear(sv);
 747             if (!needs_store) {
 748                 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
 749                     /* No longer an element */
 750                     sv_unmagic(sv, PERL_MAGIC_tiedelem);
 751                     return sv;
 752                 }
 753                 return Nullsv;          /* element cannot be deleted */
 754             }
 755 #ifdef ENV_IS_CASELESS
 756             else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
 757                 key = SvPV(keysv, klen);
 758                 keysv = sv_2mortal(newSVpvn(key,klen));
 759                 (void)strupr(SvPVX(keysv));
 760                 hash = 0;
 761             }
 762 #endif
 763         }
 764     }
 765     xhv = (XPVHV*)SvANY(hv);
 766     if (!xhv->xhv_array)
 767         return Nullsv;
 768
 769     keysave = key = SvPV(keysv, klen);
 770     is_utf8 = (SvUTF8(keysv) != 0);
 771
 772     if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT))
 773         key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
 774
 775     if (!hash)
 776         PERL_HASH(hash, key, klen);
 777
 778     oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
 779     entry = *oentry;
 780     i = 1;
 781     for (; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
 782         if (HeHASH(entry) != hash)              /* strings can't be equal */
 783             continue;
 784         if (HeKLEN(entry) != klen)
 785             continue;
 786         if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen))        /* is this it? */
 787             continue;
 788         if (HeKUTF8(entry) != (char)is_utf8)
 789             continue;
 790         if (key != keysave)
 791             Safefree(key);
 792         *oentry = HeNEXT(entry);
 793         if (i && !*oentry)
 794             xhv->xhv_fill--;
 795         if (flags & G_DISCARD)
 796             sv = Nullsv;
 797         else {
 798             sv = sv_2mortal(HeVAL(entry));
 799             HeVAL(entry) = &PL_sv_undef;
 800         }
 801         if (entry == xhv->xhv_eiter)
 802             HvLAZYDEL_on(hv);
 803         else
 804             hv_free_ent(hv, entry);
 805         --xhv->xhv_keys;
 806         return sv;
 807     }
 808     if (key != keysave)
 809         Safefree(key);
 810     return Nullsv;
 811 }
 812
 813 /*
 814 =for apidoc hv_exists
 815
 816 Returns a boolean indicating whether the specified hash key exists.  The
 817 C<klen> is the length of the key.
 818
 819 =cut
 820 */
 821
 822 bool
 823 Perl_hv_exists(pTHX_ HV *hv, const char *key, I32 klen)
 824 {
 825     register XPVHV* xhv;
 826     register U32 hash;
 827     register HE *entry;
 828     SV *sv;
 829     bool is_utf8 = FALSE;
 830     const char *keysave = key;
 831
 832     if (!hv)
 833         return 0;
 834
 835     if (klen < 0) {
 836       klen = -klen;
 837       is_utf8 = TRUE;
 838     }
 839
 840     if (SvRMAGICAL(hv)) {
 841         if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
 842             sv = sv_newmortal();
 843             mg_copy((SV*)hv, sv, key, klen);
 844             magic_existspack(sv, mg_find(sv, PERL_MAGIC_tiedelem));
 845             return SvTRUE(sv);
 846         }
 847 #ifdef ENV_IS_CASELESS
 848         else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
 849             sv = sv_2mortal(newSVpvn(key,klen));
 850             key = strupr(SvPVX(sv));
 851         }
 852 #endif
 853     }
 854
 855     xhv = (XPVHV*)SvANY(hv);
 856 #ifndef DYNAMIC_ENV_FETCH
 857     if (!xhv->xhv_array)
 858         return 0;
 859 #endif
 860
 861     if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT)) {
 862         STRLEN tmplen = klen;
 863         /* See the note in hv_fetch(). --jhi */
 864         key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
 865         klen = tmplen;
 866     }
 867
 868     PERL_HASH(hash, key, klen);
 869
 870 #ifdef DYNAMIC_ENV_FETCH
 871     if (!xhv->xhv_array) entry = Null(HE*);
 872     else
 873 #endif
 874     entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
 875     for (; entry; entry = HeNEXT(entry)) {
 876         if (HeHASH(entry) != hash)              /* strings can't be equal */
 877             continue;
 878         if (HeKLEN(entry) != klen)
 879             continue;
 880         if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen))        /* is this it? */
 881             continue;
 882         if (HeKUTF8(entry) != (char)is_utf8)
 883             continue;
 884         if (key != keysave)
 885             Safefree(key);
 886         return TRUE;
 887     }
 888 #ifdef DYNAMIC_ENV_FETCH  /* is it out there? */
 889     if (HvNAME(hv) && strEQ(HvNAME(hv), ENV_HV_NAME)) {
 890         unsigned long len;
 891         char *env = PerlEnv_ENVgetenv_len(key,&len);
 892         if (env) {
 893             sv = newSVpvn(env,len);
 894             SvTAINTED_on(sv);
 895             (void)hv_store(hv,key,klen,sv,hash);
 896             return TRUE;
 897         }
 898     }
 899 #endif
 900     if (key != keysave)
 901         Safefree(key);
 902     return FALSE;
 903 }
 904
 905
 906 /*
 907 =for apidoc hv_exists_ent
 908
 909 Returns a boolean indicating whether the specified hash key exists. C<hash>
 910 can be a valid precomputed hash value, or 0 to ask for it to be
 911 computed.
 912
 913 =cut
 914 */
 915
 916 bool
 917 Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash)
 918 {
 919     register XPVHV* xhv;
 920     register char *key;
 921     STRLEN klen;
 922     register HE *entry;
 923     SV *sv;
 924     bool is_utf8;
 925     char *keysave;
 926
 927     if (!hv)
 928         return 0;
 929
 930     if (SvRMAGICAL(hv)) {
 931         if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
 932            SV* svret = sv_newmortal();
 933             sv = sv_newmortal();
 934             keysv = sv_2mortal(newSVsv(keysv));
 935             mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY);
 936            magic_existspack(svret, mg_find(sv, PERL_MAGIC_tiedelem));
 937            return SvTRUE(svret);
 938         }
 939 #ifdef ENV_IS_CASELESS
 940         else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
 941             key = SvPV(keysv, klen);
 942             keysv = sv_2mortal(newSVpvn(key,klen));
 943             (void)strupr(SvPVX(keysv));
 944             hash = 0;
 945         }
 946 #endif
 947     }
 948
 949     xhv = (XPVHV*)SvANY(hv);
 950 #ifndef DYNAMIC_ENV_FETCH
 951     if (!xhv->xhv_array)
 952         return 0;
 953 #endif
 954
 955     keysave = key = SvPV(keysv, klen);
 956     is_utf8 = (SvUTF8(keysv) != 0);
 957     if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT))
 958         key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
 959     if (!hash)
 960         PERL_HASH(hash, key, klen);
 961
 962 #ifdef DYNAMIC_ENV_FETCH
 963     if (!xhv->xhv_array) entry = Null(HE*);
 964     else
 965 #endif
 966     entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
 967     for (; entry; entry = HeNEXT(entry)) {
 968         if (HeHASH(entry) != hash)              /* strings can't be equal */
 969             continue;
 970         if (HeKLEN(entry) != klen)
 971             continue;
 972         if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen))        /* is this it? */
 973             continue;
 974         if (HeKUTF8(entry) != (char)is_utf8)
 975             continue;
 976         if (key != keysave)
 977             Safefree(key);
 978         return TRUE;
 979     }
 980 #ifdef DYNAMIC_ENV_FETCH  /* is it out there? */
 981     if (HvNAME(hv) && strEQ(HvNAME(hv), ENV_HV_NAME)) {
 982         unsigned long len;
 983         char *env = PerlEnv_ENVgetenv_len(key,&len);
 984         if (env) {
 985             sv = newSVpvn(env,len);
 986             SvTAINTED_on(sv);
 987             (void)hv_store_ent(hv,keysv,sv,hash);
 988             return TRUE;
 989         }
 990     }
 991 #endif
 992     if (key != keysave)
 993         Safefree(key);
 994     return FALSE;
 995 }
 996
 997 STATIC void
 998 S_hsplit(pTHX_ HV *hv)
 999 {
1000     register XPVHV* xhv = (XPVHV*)SvANY(hv);
1001     I32 oldsize = (I32) xhv->xhv_max + 1; /* sic(k) */
1002     register I32 newsize = oldsize * 2;
1003     register I32 i;
1004     register char *a = xhv->xhv_array;
1005     register HE **aep;
1006     register HE **bep;
1007     register HE *entry;
1008     register HE **oentry;
1009
1010     PL_nomemok = TRUE;
1011 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
1012     Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1013     if (!a) {
1014       PL_nomemok = FALSE;
1015       return;
1016     }
1017 #else
1018     New(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1019     if (!a) {
1020       PL_nomemok = FALSE;
1021       return;
1022     }
1023     Copy(xhv->xhv_array, a, oldsize * sizeof(HE*), char);
1024     if (oldsize >= 64) {
1025         offer_nice_chunk(xhv->xhv_array, PERL_HV_ARRAY_ALLOC_BYTES(oldsize));
1026     }
1027     else
1028         Safefree(xhv->xhv_array);
1029 #endif
1030
1031     PL_nomemok = FALSE;
1032     Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char);     /* zero 2nd half*/
1033     xhv->xhv_max = --newsize;
1034     xhv->xhv_array = a;
1035     aep = (HE**)a;
1036
1037     for (i=0; i<oldsize; i++,aep++) {
1038         if (!*aep)                              /* non-existent */
1039             continue;
1040         bep = aep+oldsize;
1041         for (oentry = aep, entry = *aep; entry; entry = *oentry) {
1042             if ((HeHASH(entry) & newsize) != i) {
1043                 *oentry = HeNEXT(entry);
1044                 HeNEXT(entry) = *bep;
1045                 if (!*bep)
1046                     xhv->xhv_fill++;
1047                 *bep = entry;
1048                 continue;
1049             }
1050             else
1051                 oentry = &HeNEXT(entry);
1052         }
1053         if (!*aep)                              /* everything moved */
1054             xhv->xhv_fill--;
1055     }
1056 }
1057
1058 void
1059 Perl_hv_ksplit(pTHX_ HV *hv, IV newmax)
1060 {
1061     register XPVHV* xhv = (XPVHV*)SvANY(hv);
1062     I32 oldsize = (I32) xhv->xhv_max + 1; /* sic(k) */
1063     register I32 newsize;
1064     register I32 i;
1065     register I32 j;
1066     register char *a;
1067     register HE **aep;
1068     register HE *entry;
1069     register HE **oentry;
1070
1071     newsize = (I32) newmax;                     /* possible truncation here */
1072     if (newsize != newmax || newmax <= oldsize)
1073         return;
1074     while ((newsize & (1 + ~newsize)) != newsize) {
1075         newsize &= ~(newsize & (1 + ~newsize)); /* get proper power of 2 */
1076     }
1077     if (newsize < newmax)
1078         newsize *= 2;
1079     if (newsize < newmax)
1080         return;                                 /* overflow detection */
1081
1082     a = xhv->xhv_array;
1083     if (a) {
1084         PL_nomemok = TRUE;
1085 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
1086         Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1087         if (!a) {
1088           PL_nomemok = FALSE;
1089           return;
1090         }
1091 #else
1092         New(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1093         if (!a) {
1094           PL_nomemok = FALSE;
1095           return;
1096         }
1097         Copy(xhv->xhv_array, a, oldsize * sizeof(HE*), char);
1098         if (oldsize >= 64) {
1099             offer_nice_chunk(xhv->xhv_array, PERL_HV_ARRAY_ALLOC_BYTES(oldsize));
1100         }
1101         else
1102             Safefree(xhv->xhv_array);
1103 #endif
1104         PL_nomemok = FALSE;
1105         Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
1106     }
1107     else {
1108         Newz(0, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1109     }
1110     xhv->xhv_max = --newsize;
1111     xhv->xhv_array = a;
1112     if (!xhv->xhv_fill)                         /* skip rest if no entries */
1113         return;
1114
1115     aep = (HE**)a;
1116     for (i=0; i<oldsize; i++,aep++) {
1117         if (!*aep)                              /* non-existent */
1118             continue;
1119         for (oentry = aep, entry = *aep; entry; entry = *oentry) {
1120             if ((j = (HeHASH(entry) & newsize)) != i) {
1121                 j -= i;
1122                 *oentry = HeNEXT(entry);
1123                 if (!(HeNEXT(entry) = aep[j]))
1124                     xhv->xhv_fill++;
1125                 aep[j] = entry;
1126                 continue;
1127             }
1128             else
1129                 oentry = &HeNEXT(entry);
1130         }
1131         if (!*aep)                              /* everything moved */
1132             xhv->xhv_fill--;
1133     }
1134 }
1135
1136 /*
1137 =for apidoc newHV
1138
1139 Creates a new HV.  The reference count is set to 1.
1140
1141 =cut
1142 */
1143
1144 HV *
1145 Perl_newHV(pTHX)
1146 {
1147     register HV *hv;
1148     register XPVHV* xhv;
1149
1150     hv = (HV*)NEWSV(502,0);
1151     sv_upgrade((SV *)hv, SVt_PVHV);
1152     xhv = (XPVHV*)SvANY(hv);
1153     SvPOK_off(hv);
1154     SvNOK_off(hv);
1155 #ifndef NODEFAULT_SHAREKEYS
1156     HvSHAREKEYS_on(hv);         /* key-sharing on by default */
1157 #endif
1158     xhv->xhv_max = 7;           /* start with 8 buckets */
1159     xhv->xhv_fill = 0;
1160     xhv->xhv_pmroot = 0;
1161     (void)hv_iterinit(hv);      /* so each() will start off right */
1162     return hv;
1163 }
1164
1165 HV *
1166 Perl_newHVhv(pTHX_ HV *ohv)
1167 {
1168     register HV *hv;
1169     STRLEN hv_max = ohv ? HvMAX(ohv) : 0;
1170     STRLEN hv_fill = ohv ? HvFILL(ohv) : 0;
1171
1172     hv = newHV();
1173     while (hv_max && hv_max + 1 >= hv_fill * 2)
1174         hv_max = hv_max / 2;    /* Is always 2^n-1 */
1175     HvMAX(hv) = hv_max;
1176     if (!hv_fill)
1177         return hv;
1178
1179 #if 0
1180     if (! SvTIED_mg((SV*)ohv, PERL_MAGIC_tied)) {
1181         /* Quick way ???*/
1182     }
1183     else
1184 #endif
1185     {
1186         HE *entry;
1187         I32 hv_riter = HvRITER(ohv);    /* current root of iterator */
1188         HE *hv_eiter = HvEITER(ohv);    /* current entry of iterator */
1189
1190         /* Slow way */
1191         hv_iterinit(ohv);
1192         while ((entry = hv_iternext(ohv))) {
1193             hv_store(hv, HeKEY(entry), HeKLEN_UTF8(entry),
1194                      newSVsv(HeVAL(entry)), HeHASH(entry));
1195         }
1196         HvRITER(ohv) = hv_riter;
1197         HvEITER(ohv) = hv_eiter;
1198     }
1199
1200     return hv;
1201 }
1202
1203 void
1204 Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry)
1205 {
1206     SV *val;
1207
1208     if (!entry)
1209         return;
1210     val = HeVAL(entry);
1211     if (val && isGV(val) && GvCVu(val) && HvNAME(hv))
1212         PL_sub_generation++;    /* may be deletion of method from stash */
1213     SvREFCNT_dec(val);
1214     if (HeKLEN(entry) == HEf_SVKEY) {
1215         SvREFCNT_dec(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 void
1226 Perl_hv_delayfree_ent(pTHX_ HV *hv, register HE *entry)
1227 {
1228     if (!entry)
1229         return;
1230     if (isGV(HeVAL(entry)) && GvCVu(HeVAL(entry)) && HvNAME(hv))
1231         PL_sub_generation++;    /* may be deletion of method from stash */
1232     sv_2mortal(HeVAL(entry));   /* free between statements */
1233     if (HeKLEN(entry) == HEf_SVKEY) {
1234         sv_2mortal(HeKEY_sv(entry));
1235         Safefree(HeKEY_hek(entry));
1236     }
1237     else if (HvSHAREKEYS(hv))
1238         unshare_hek(HeKEY_hek(entry));
1239     else
1240         Safefree(HeKEY_hek(entry));
1241     del_HE(entry);
1242 }
1243
1244 /*
1245 =for apidoc hv_clear
1246
1247 Clears a hash, making it empty.
1248
1249 =cut
1250 */
1251
1252 void
1253 Perl_hv_clear(pTHX_ HV *hv)
1254 {
1255     register XPVHV* xhv;
1256     if (!hv)
1257         return;
1258     xhv = (XPVHV*)SvANY(hv);
1259     hfreeentries(hv);
1260     xhv->xhv_fill = 0;
1261     xhv->xhv_keys = 0;
1262     if (xhv->xhv_array)
1263         (void)memzero(xhv->xhv_array, (xhv->xhv_max + 1) * sizeof(HE*));
1264
1265     if (SvRMAGICAL(hv))
1266         mg_clear((SV*)hv);
1267 }
1268
1269 STATIC void
1270 S_hfreeentries(pTHX_ HV *hv)
1271 {
1272     register HE **array;
1273     register HE *entry;
1274     register HE *oentry = Null(HE*);
1275     I32 riter;
1276     I32 max;
1277
1278     if (!hv)
1279         return;
1280     if (!HvARRAY(hv))
1281         return;
1282
1283     riter = 0;
1284     max = HvMAX(hv);
1285     array = HvARRAY(hv);
1286     entry = array[0];
1287     for (;;) {
1288         if (entry) {
1289             oentry = entry;
1290             entry = HeNEXT(entry);
1291             hv_free_ent(hv, oentry);
1292         }
1293         if (!entry) {
1294             if (++riter > max)
1295                 break;
1296             entry = array[riter];
1297         }
1298     }
1299     (void)hv_iterinit(hv);
1300 }
1301
1302 /*
1303 =for apidoc hv_undef
1304
1305 Undefines the hash.
1306
1307 =cut
1308 */
1309
1310 void
1311 Perl_hv_undef(pTHX_ HV *hv)
1312 {
1313     register XPVHV* xhv;
1314     if (!hv)
1315         return;
1316     xhv = (XPVHV*)SvANY(hv);
1317     hfreeentries(hv);
1318     Safefree(xhv->xhv_array);
1319     if (HvNAME(hv)) {
1320         Safefree(HvNAME(hv));
1321         HvNAME(hv) = 0;
1322     }
1323     xhv->xhv_array = 0;
1324     xhv->xhv_max = 7;           /* it's a normal hash */
1325     xhv->xhv_fill = 0;
1326     xhv->xhv_keys = 0;
1327
1328     if (SvRMAGICAL(hv))
1329         mg_clear((SV*)hv);
1330 }
1331
1332 /*
1333 =for apidoc hv_iterinit
1334
1335 Prepares a starting point to traverse a hash table.  Returns the number of
1336 keys in the hash (i.e. the same as C<HvKEYS(tb)>).  The return value is
1337 currently only meaningful for hashes without tie magic.
1338
1339 NOTE: Before version 5.004_65, C<hv_iterinit> used to return the number of
1340 hash buckets that happen to be in use.  If you still need that esoteric
1341 value, you can get it through the macro C<HvFILL(tb)>.
1342
1343 =cut
1344 */
1345
1346 I32
1347 Perl_hv_iterinit(pTHX_ HV *hv)
1348 {
1349     register XPVHV* xhv;
1350     HE *entry;
1351
1352     if (!hv)
1353         Perl_croak(aTHX_ "Bad hash");
1354     xhv = (XPVHV*)SvANY(hv);
1355     entry = xhv->xhv_eiter;
1356     if (entry && HvLAZYDEL(hv)) {       /* was deleted earlier? */
1357         HvLAZYDEL_off(hv);
1358         hv_free_ent(hv, entry);
1359     }
1360     xhv->xhv_riter = -1;
1361     xhv->xhv_eiter = Null(HE*);
1362     return xhv->xhv_keys;       /* used to be xhv->xhv_fill before 5.004_65 */
1363 }
1364
1365 /*
1366 =for apidoc hv_iternext
1367
1368 Returns entries from a hash iterator.  See C<hv_iterinit>.
1369
1370 =cut
1371 */
1372
1373 HE *
1374 Perl_hv_iternext(pTHX_ HV *hv)
1375 {
1376     register XPVHV* xhv;
1377     register HE *entry;
1378     HE *oldentry;
1379     MAGIC* mg;
1380
1381     if (!hv)
1382         Perl_croak(aTHX_ "Bad hash");
1383     xhv = (XPVHV*)SvANY(hv);
1384     oldentry = entry = xhv->xhv_eiter;
1385
1386     if ((mg = SvTIED_mg((SV*)hv, PERL_MAGIC_tied))) {
1387         SV *key = sv_newmortal();
1388         if (entry) {
1389             sv_setsv(key, HeSVKEY_force(entry));
1390             SvREFCNT_dec(HeSVKEY(entry));       /* get rid of previous key */
1391         }
1392         else {
1393             char *k;
1394             HEK *hek;
1395
1396             xhv->xhv_eiter = entry = new_HE();  /* one HE per MAGICAL hash */
1397             Zero(entry, 1, HE);
1398             Newz(54, k, HEK_BASESIZE + sizeof(SV*), char);
1399             hek = (HEK*)k;
1400             HeKEY_hek(entry) = hek;
1401             HeKLEN(entry) = HEf_SVKEY;
1402         }
1403         magic_nextpack((SV*) hv,mg,key);
1404         if (SvOK(key)) {
1405             /* force key to stay around until next time */
1406             HeSVKEY_set(entry, SvREFCNT_inc(key));
1407             return entry;               /* beware, hent_val is not set */
1408         }
1409         if (HeVAL(entry))
1410             SvREFCNT_dec(HeVAL(entry));
1411         Safefree(HeKEY_hek(entry));
1412         del_HE(entry);
1413         xhv->xhv_eiter = Null(HE*);
1414         return Null(HE*);
1415     }
1416 #ifdef DYNAMIC_ENV_FETCH  /* set up %ENV for iteration */
1417     if (!entry && HvNAME(hv) && strEQ(HvNAME(hv), ENV_HV_NAME))
1418         prime_env_iter();
1419 #endif
1420
1421     if (!xhv->xhv_array)
1422         Newz(506, xhv->xhv_array,
1423              PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
1424     if (entry)
1425         entry = HeNEXT(entry);
1426     while (!entry) {
1427         ++xhv->xhv_riter;
1428         if (xhv->xhv_riter > xhv->xhv_max) {
1429             xhv->xhv_riter = -1;
1430             break;
1431         }
1432         entry = ((HE**)xhv->xhv_array)[xhv->xhv_riter];
1433     }
1434
1435     if (oldentry && HvLAZYDEL(hv)) {            /* was deleted earlier? */
1436         HvLAZYDEL_off(hv);
1437         hv_free_ent(hv, oldentry);
1438     }
1439
1440     xhv->xhv_eiter = entry;
1441     return entry;
1442 }
1443
1444 /*
1445 =for apidoc hv_iterkey
1446
1447 Returns the key from the current position of the hash iterator.  See
1448 C<hv_iterinit>.
1449
1450 =cut
1451 */
1452
1453 char *
1454 Perl_hv_iterkey(pTHX_ register HE *entry, I32 *retlen)
1455 {
1456     if (HeKLEN(entry) == HEf_SVKEY) {
1457         STRLEN len;
1458         char *p = SvPV(HeKEY_sv(entry), len);
1459         *retlen = len;
1460         return p;
1461     }
1462     else {
1463         *retlen = HeKLEN(entry);
1464         return HeKEY(entry);
1465     }
1466 }
1467
1468 /* unlike hv_iterval(), this always returns a mortal copy of the key */
1469 /*
1470 =for apidoc hv_iterkeysv
1471
1472 Returns the key as an C<SV*> from the current position of the hash
1473 iterator.  The return value will always be a mortal copy of the key.  Also
1474 see C<hv_iterinit>.
1475
1476 =cut
1477 */
1478
1479 SV *
1480 Perl_hv_iterkeysv(pTHX_ register HE *entry)
1481 {
1482     if (HeKLEN(entry) == HEf_SVKEY)
1483         return sv_mortalcopy(HeKEY_sv(entry));
1484     else
1485         return sv_2mortal(newSVpvn_share((HeKLEN(entry) ? HeKEY(entry) : ""),
1486                                          HeKLEN_UTF8(entry), HeHASH(entry)));
1487 }
1488
1489 /*
1490 =for apidoc hv_iterval
1491
1492 Returns the value from the current position of the hash iterator.  See
1493 C<hv_iterkey>.
1494
1495 =cut
1496 */
1497
1498 SV *
1499 Perl_hv_iterval(pTHX_ HV *hv, register HE *entry)
1500 {
1501     if (SvRMAGICAL(hv)) {
1502         if (mg_find((SV*)hv, PERL_MAGIC_tied)) {
1503             SV* sv = sv_newmortal();
1504             if (HeKLEN(entry) == HEf_SVKEY)
1505                 mg_copy((SV*)hv, sv, (char*)HeKEY_sv(entry), HEf_SVKEY);
1506             else mg_copy((SV*)hv, sv, HeKEY(entry), HeKLEN(entry));
1507             return sv;
1508         }
1509     }
1510     return HeVAL(entry);
1511 }
1512
1513 /*
1514 =for apidoc hv_iternextsv
1515
1516 Performs an C<hv_iternext>, C<hv_iterkey>, and C<hv_iterval> in one
1517 operation.
1518
1519 =cut
1520 */
1521
1522 SV *
1523 Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen)
1524 {
1525     HE *he;
1526     if ( (he = hv_iternext(hv)) == NULL)
1527         return NULL;
1528     *key = hv_iterkey(he, retlen);
1529     return hv_iterval(hv, he);
1530 }
1531
1532 /*
1533 =for apidoc hv_magic
1534
1535 Adds magic to a hash.  See C<sv_magic>.
1536
1537 =cut
1538 */
1539
1540 void
1541 Perl_hv_magic(pTHX_ HV *hv, GV *gv, int how)
1542 {
1543     sv_magic((SV*)hv, (SV*)gv, how, Nullch, 0);
1544 }
1545
1546 char*
1547 Perl_sharepvn(pTHX_ const char *sv, I32 len, U32 hash)
1548 {
1549     return HEK_KEY(share_hek(sv, len, hash));
1550 }
1551
1552 /* possibly free a shared string if no one has access to it
1553  * len and hash must both be valid for str.
1554  */
1555 void
1556 Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
1557 {
1558     register XPVHV* xhv;
1559     register HE *entry;
1560     register HE **oentry;
1561     register I32 i = 1;
1562     I32 found = 0;
1563     bool is_utf8 = FALSE;
1564     const char *save = str;
1565
1566     if (len < 0) {
1567       len = -len;
1568       is_utf8 = TRUE;
1569       if (!(PL_hints & HINT_UTF8_DISTINCT)) {
1570           STRLEN tmplen = len;
1571           /* See the note in hv_fetch(). --jhi */
1572           str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
1573           len = tmplen;
1574       }
1575     }
1576
1577     /* what follows is the moral equivalent of:
1578     if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) {
1579         if (--*Svp == Nullsv)
1580             hv_delete(PL_strtab, str, len, G_DISCARD, hash);
1581     } */
1582     xhv = (XPVHV*)SvANY(PL_strtab);
1583     /* assert(xhv_array != 0) */
1584     LOCK_STRTAB_MUTEX;
1585     oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
1586     for (entry = *oentry; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
1587         if (HeHASH(entry) != hash)              /* strings can't be equal */
1588             continue;
1589         if (HeKLEN(entry) != len)
1590             continue;
1591         if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
1592             continue;
1593         if (HeKUTF8(entry) != (char)is_utf8)
1594             continue;
1595         found = 1;
1596         if (--HeVAL(entry) == Nullsv) {
1597             *oentry = HeNEXT(entry);
1598             if (i && !*oentry)
1599                 xhv->xhv_fill--;
1600             Safefree(HeKEY_hek(entry));
1601             del_HE(entry);
1602             --xhv->xhv_keys;
1603         }
1604         break;
1605     }
1606     UNLOCK_STRTAB_MUTEX;
1607     if (str != save)
1608         Safefree(str);
1609     if (!found && ckWARN_d(WARN_INTERNAL))
1610         Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free non-existent shared string '%s'",str);
1611 }
1612
1613 /* get a (constant) string ptr from the global string table
1614  * string will get added if it is not already there.
1615  * len and hash must both be valid for str.
1616  */
1617 HEK *
1618 Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash)
1619 {
1620     register XPVHV* xhv;
1621     register HE *entry;
1622     register HE **oentry;
1623     register I32 i = 1;
1624     I32 found = 0;
1625     bool is_utf8 = FALSE;
1626     const char *save = str;
1627
1628     if (len < 0) {
1629       len = -len;
1630       is_utf8 = TRUE;
1631       if (!(PL_hints & HINT_UTF8_DISTINCT)) {
1632           STRLEN tmplen = len;
1633           /* See the note in hv_fetch(). --jhi */
1634           str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
1635           len = tmplen;
1636       }
1637     }
1638
1639     /* what follows is the moral equivalent of:
1640
1641     if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
1642         hv_store(PL_strtab, str, len, Nullsv, hash);
1643     */
1644     xhv = (XPVHV*)SvANY(PL_strtab);
1645     /* assert(xhv_array != 0) */
1646     LOCK_STRTAB_MUTEX;
1647     oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
1648     for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
1649         if (HeHASH(entry) != hash)              /* strings can't be equal */
1650             continue;
1651         if (HeKLEN(entry) != len)
1652             continue;
1653         if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
1654             continue;
1655         if (HeKUTF8(entry) != (char)is_utf8)
1656             continue;
1657         found = 1;
1658         break;
1659     }
1660     if (!found) {
1661         entry = new_HE();
1662         HeKEY_hek(entry) = save_hek(str, is_utf8?-len:len, hash);
1663         HeVAL(entry) = Nullsv;
1664         HeNEXT(entry) = *oentry;
1665         *oentry = entry;
1666         xhv->xhv_keys++;
1667         if (i) {                                /* initial entry? */
1668             ++xhv->xhv_fill;
1669             if (xhv->xhv_keys > xhv->xhv_max)
1670                 hsplit(PL_strtab);
1671         }
1672     }
1673
1674     ++HeVAL(entry);                             /* use value slot as REFCNT */
1675     UNLOCK_STRTAB_MUTEX;
1676     if (str != save)
1677         Safefree(str);
1678     return HeKEY_hek(entry);
1679 }