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