hv.c

   1 /*    hv.c
   2  *
   3  *    Copyright (c) 1991-2000, 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_LEN(hek),HEK_HASH(hek));
  98 }
  99
 100 #if defined(USE_ITHREADS)
 101 HE *
 102 Perl_he_dup(pTHX_ HE *e, bool shared)
 103 {
 104     HE *ret;
 105
 106     if (!e)
 107         return Nullhe;
 108     /* look for it in the table first */
 109     ret = (HE*)ptr_table_fetch(PL_ptr_table, e);
 110     if (ret)
 111         return ret;
 112
 113     /* create anew and remember what it is */
 114     ret = new_HE();
 115     ptr_table_store(PL_ptr_table, e, ret);
 116
 117     HeNEXT(ret) = he_dup(HeNEXT(e),shared);
 118     if (HeKLEN(e) == HEf_SVKEY)
 119         HeKEY_sv(ret) = SvREFCNT_inc(sv_dup(HeKEY_sv(e)));
 120     else if (shared)
 121  HeKEY_hek(ret) = share_hek(HeKEY(e), HeKLEN_UTF8(e), HeHASH(e));
 122     else
 123  HeKEY_hek(ret) = save_hek(HeKEY(e), HeKLEN_UTF8(e), HeHASH(e));
 124     HeVAL(ret) = SvREFCNT_inc(sv_dup(HeVAL(e)));
 125     return ret;
 126 }
 127 #endif  /* USE_ITHREADS */
 128
 129 /* (klen == HEf_SVKEY) is special for MAGICAL hv entries, meaning key slot
 130  * contains an SV* */
 131
 132 /*
 133 =for apidoc hv_fetch
 134
 135 Returns the SV which corresponds to the specified key in the hash.  The
 136 C<klen> is the length of the key.  If C<lval> is set then the fetch will be
 137 part of a store.  Check that the return value is non-null before
 138 dereferencing it to a C<SV*>.
 139
 140 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
 141 information on how to use this function on tied hashes.
 142
 143 =cut
 144 */
 145
 146 SV**
 147 Perl_hv_fetch(pTHX_ HV *hv, const char *key, I32 klen, I32 lval)
 148 {
 149     register XPVHV* xhv;
 150     register U32 hash;
 151     register HE *entry;
 152     SV *sv;
 153     bool is_utf8 = FALSE;
 154
 155     if (!hv)
 156         return 0;
 157
 158     if (klen < 0) {
 159       klen = -klen;
 160       is_utf8 = TRUE;
 161     }
 162
 163     if (SvRMAGICAL(hv)) {
 164         if (mg_find((SV*)hv,'P')) {
 165             dTHR;
 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             dTHR;
 266             sv = sv_newmortal();
 267             keysv = sv_2mortal(newSVsv(keysv));
 268             mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY);
 269             if (!HeKEY_hek(&PL_hv_fetch_ent_mh)) {
 270                 char *k;
 271                 New(54, k, HEK_BASESIZE + sizeof(SV*), char);
 272                 HeKEY_hek(&PL_hv_fetch_ent_mh) = (HEK*)k;
 273             }
 274             HeSVKEY_set(&PL_hv_fetch_ent_mh, keysv);
 275             HeVAL(&PL_hv_fetch_ent_mh) = sv;
 276             return &PL_hv_fetch_ent_mh;
 277         }
 278 #ifdef ENV_IS_CASELESS
 279         else if (mg_find((SV*)hv,'E')) {
 280             U32 i;
 281             key = SvPV(keysv, klen);
 282             for (i = 0; i < klen; ++i)
 283                 if (isLOWER(key[i])) {
 284                     SV *nkeysv = sv_2mortal(newSVpvn(key,klen));
 285                     (void)strupr(SvPVX(nkeysv));
 286                     entry = hv_fetch_ent(hv, nkeysv, 0, 0);
 287                     if (!entry && lval)
 288                         entry = hv_store_ent(hv, keysv, NEWSV(61,0), hash);
 289                     return entry;
 290                 }
 291         }
 292 #endif
 293     }
 294
 295     xhv = (XPVHV*)SvANY(hv);
 296     if (!xhv->xhv_array) {
 297         if (lval
 298 #ifdef DYNAMIC_ENV_FETCH  /* if it's an %ENV lookup, we may get it on the fly */
 299                  || (HvNAME(hv) && strEQ(HvNAME(hv),ENV_HV_NAME))
 300 #endif
 301                                                                   )
 302             Newz(503, xhv->xhv_array,
 303                  PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
 304         else
 305             return 0;
 306     }
 307
 308     key = SvPV(keysv, klen);
 309     is_utf8 = (SvUTF8(keysv)!=0);
 310
 311     if (!hash)
 312         PERL_HASH(hash, key, klen);
 313
 314     entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
 315     for (; entry; entry = HeNEXT(entry)) {
 316         if (HeHASH(entry) != hash)              /* strings can't be equal */
 317             continue;
 318         if (HeKLEN(entry) != klen)
 319             continue;
 320         if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen))        /* is this it? */
 321             continue;
 322  if (HeKUTF8(entry) != (char)is_utf8)
 323      continue;
 324         return entry;
 325     }
 326 #ifdef DYNAMIC_ENV_FETCH  /* %ENV lookup?  If so, try to fetch the value now */
 327     if (HvNAME(hv) && strEQ(HvNAME(hv),ENV_HV_NAME)) {
 328         unsigned long len;
 329         char *env = PerlEnv_ENVgetenv_len(key,&len);
 330         if (env) {
 331             sv = newSVpvn(env,len);
 332             SvTAINTED_on(sv);
 333             return hv_store_ent(hv,keysv,sv,hash);
 334         }
 335     }
 336 #endif
 337     if (lval) {         /* gonna assign to this, so it better be there */
 338         sv = NEWSV(61,0);
 339         return hv_store_ent(hv,keysv,sv,hash);
 340     }
 341     return 0;
 342 }
 343
 344 STATIC void
 345 S_hv_magic_check(pTHX_ HV *hv, bool *needs_copy, bool *needs_store)
 346 {
 347     MAGIC *mg = SvMAGIC(hv);
 348     *needs_copy = FALSE;
 349     *needs_store = TRUE;
 350     while (mg) {
 351         if (isUPPER(mg->mg_type)) {
 352             *needs_copy = TRUE;
 353             switch (mg->mg_type) {
 354             case 'P':
 355             case 'S':
 356                 *needs_store = FALSE;
 357             }
 358         }
 359         mg = mg->mg_moremagic;
 360     }
 361 }
 362
 363 /*
 364 =for apidoc hv_store
 365
 366 Stores an SV in a hash.  The hash key is specified as C<key> and C<klen> is
 367 the length of the key.  The C<hash> parameter is the precomputed hash
 368 value; if it is zero then Perl will compute it.  The return value will be
 369 NULL if the operation failed or if the value did not need to be actually
 370 stored within the hash (as in the case of tied hashes).  Otherwise it can
 371 be dereferenced to get the original C<SV*>.  Note that the caller is
 372 responsible for suitably incrementing the reference count of C<val> before
 373 the call, and decrementing it if the function returned NULL.
 374
 375 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
 376 information on how to use this function on tied hashes.
 377
 378 =cut
 379 */
 380
 381 SV**
 382 Perl_hv_store(pTHX_ HV *hv, const char *key, I32 klen, SV *val, register U32 hash)
 383 {
 384     register XPVHV* xhv;
 385     register I32 i;
 386     register HE *entry;
 387     register HE **oentry;
 388     bool is_utf8 = FALSE;
 389
 390     if (!hv)
 391         return 0;
 392
 393     if (klen < 0) {
 394       klen = -klen;
 395       is_utf8 = TRUE;
 396     }
 397
 398     xhv = (XPVHV*)SvANY(hv);
 399     if (SvMAGICAL(hv)) {
 400         bool needs_copy;
 401         bool needs_store;
 402         hv_magic_check (hv, &needs_copy, &needs_store);
 403         if (needs_copy) {
 404             mg_copy((SV*)hv, val, key, klen);
 405             if (!xhv->xhv_array && !needs_store)
 406                 return 0;
 407 #ifdef ENV_IS_CASELESS
 408             else if (mg_find((SV*)hv,'E')) {
 409                 SV *sv = sv_2mortal(newSVpvn(key,klen));
 410                 key = strupr(SvPVX(sv));
 411                 hash = 0;
 412             }
 413 #endif
 414         }
 415     }
 416     if (!hash)
 417         PERL_HASH(hash, key, klen);
 418
 419     if (!xhv->xhv_array)
 420         Newz(505, xhv->xhv_array,
 421              PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
 422
 423     oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
 424     i = 1;
 425
 426     for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
 427         if (HeHASH(entry) != hash)              /* strings can't be equal */
 428             continue;
 429         if (HeKLEN(entry) != klen)
 430             continue;
 431         if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen))        /* is this it? */
 432             continue;
 433  if (HeKUTF8(entry) != (char)is_utf8)
 434      continue;
 435         SvREFCNT_dec(HeVAL(entry));
 436         HeVAL(entry) = val;
 437         return &HeVAL(entry);
 438     }
 439
 440     entry = new_HE();
 441     if (HvSHAREKEYS(hv))
 442  HeKEY_hek(entry) = share_hek(key, is_utf8?-klen:klen, hash);
 443     else                                       /* gotta do the real thing */
 444  HeKEY_hek(entry) = save_hek(key, is_utf8?-klen:klen, hash);
 445     HeVAL(entry) = val;
 446     HeNEXT(entry) = *oentry;
 447     *oentry = entry;
 448
 449     xhv->xhv_keys++;
 450     if (i) {                            /* initial entry? */
 451         ++xhv->xhv_fill;
 452         if (xhv->xhv_keys > xhv->xhv_max)
 453             hsplit(hv);
 454     }
 455
 456     return &HeVAL(entry);
 457 }
 458
 459 /*
 460 =for apidoc hv_store_ent
 461
 462 Stores C<val> in a hash.  The hash key is specified as C<key>.  The C<hash>
 463 parameter is the precomputed hash value; if it is zero then Perl will
 464 compute it.  The return value is the new hash entry so created.  It will be
 465 NULL if the operation failed or if the value did not need to be actually
 466 stored within the hash (as in the case of tied hashes).  Otherwise the
 467 contents of the return value can be accessed using the C<He???> macros
 468 described here.  Note that the caller is responsible for suitably
 469 incrementing the reference count of C<val> before the call, and
 470 decrementing it if the function returned NULL.
 471
 472 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
 473 information on how to use this function on tied hashes.
 474
 475 =cut
 476 */
 477
 478 HE *
 479 Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, register U32 hash)
 480 {
 481     register XPVHV* xhv;
 482     register char *key;
 483     STRLEN klen;
 484     register I32 i;
 485     register HE *entry;
 486     register HE **oentry;
 487     bool is_utf8;
 488
 489     if (!hv)
 490         return 0;
 491
 492     xhv = (XPVHV*)SvANY(hv);
 493     if (SvMAGICAL(hv)) {
 494         dTHR;
 495         bool needs_copy;
 496         bool needs_store;
 497         hv_magic_check (hv, &needs_copy, &needs_store);
 498         if (needs_copy) {
 499             bool save_taint = PL_tainted;
 500             if (PL_tainting)
 501                 PL_tainted = SvTAINTED(keysv);
 502             keysv = sv_2mortal(newSVsv(keysv));
 503             mg_copy((SV*)hv, val, (char*)keysv, HEf_SVKEY);
 504             TAINT_IF(save_taint);
 505             if (!xhv->xhv_array && !needs_store)
 506                 return Nullhe;
 507 #ifdef ENV_IS_CASELESS
 508             else if (mg_find((SV*)hv,'E')) {
 509                 key = SvPV(keysv, klen);
 510                 keysv = sv_2mortal(newSVpvn(key,klen));
 511                 (void)strupr(SvPVX(keysv));
 512                 hash = 0;
 513             }
 514 #endif
 515         }
 516     }
 517
 518     key = SvPV(keysv, klen);
 519     is_utf8 = (SvUTF8(keysv) != 0);
 520
 521     if (!hash)
 522         PERL_HASH(hash, key, klen);
 523
 524     if (!xhv->xhv_array)
 525         Newz(505, xhv->xhv_array,
 526              PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
 527
 528     oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
 529     i = 1;
 530
 531     for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
 532         if (HeHASH(entry) != hash)              /* strings can't be equal */
 533             continue;
 534         if (HeKLEN(entry) != klen)
 535             continue;
 536         if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen))        /* is this it? */
 537             continue;
 538  if (HeKUTF8(entry) != (char)is_utf8)
 539      continue;
 540         SvREFCNT_dec(HeVAL(entry));
 541         HeVAL(entry) = val;
 542         return entry;
 543     }
 544
 545     entry = new_HE();
 546     if (HvSHAREKEYS(hv))
 547  HeKEY_hek(entry) = share_hek(key, is_utf8?-klen:klen, hash);
 548     else                                       /* gotta do the real thing */
 549  HeKEY_hek(entry) = save_hek(key, is_utf8?-klen:klen, hash);
 550     HeVAL(entry) = val;
 551     HeNEXT(entry) = *oentry;
 552     *oentry = entry;
 553
 554     xhv->xhv_keys++;
 555     if (i) {                            /* initial entry? */
 556         ++xhv->xhv_fill;
 557         if (xhv->xhv_keys > xhv->xhv_max)
 558             hsplit(hv);
 559     }
 560
 561     return entry;
 562 }
 563
 564 /*
 565 =for apidoc hv_delete
 566
 567 Deletes a key/value pair in the hash.  The value SV is removed from the
 568 hash and returned to the caller.  The C<klen> is the length of the key.
 569 The C<flags> value will normally be zero; if set to G_DISCARD then NULL
 570 will be returned.
 571
 572 =cut
 573 */
 574
 575 SV *
 576 Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen, I32 flags)
 577 {
 578     register XPVHV* xhv;
 579     register I32 i;
 580     register U32 hash;
 581     register HE *entry;
 582     register HE **oentry;
 583     SV **svp;
 584     SV *sv;
 585     bool is_utf8 = FALSE;
 586
 587     if (!hv)
 588         return Nullsv;
 589     if (klen < 0) {
 590       klen = -klen;
 591       is_utf8 = TRUE;
 592     }
 593     if (SvRMAGICAL(hv)) {
 594         bool needs_copy;
 595         bool needs_store;
 596         hv_magic_check (hv, &needs_copy, &needs_store);
 597
 598         if (needs_copy && (svp = hv_fetch(hv, key, klen, TRUE))) {
 599             sv = *svp;
 600             mg_clear(sv);
 601             if (!needs_store) {
 602                 if (mg_find(sv, 'p')) {
 603                     sv_unmagic(sv, 'p');        /* No longer an element */
 604                     return sv;
 605                 }
 606                 return Nullsv;          /* element cannot be deleted */
 607             }
 608 #ifdef ENV_IS_CASELESS
 609             else if (mg_find((SV*)hv,'E')) {
 610                 sv = sv_2mortal(newSVpvn(key,klen));
 611                 key = strupr(SvPVX(sv));
 612             }
 613 #endif
 614         }
 615     }
 616     xhv = (XPVHV*)SvANY(hv);
 617     if (!xhv->xhv_array)
 618         return Nullsv;
 619
 620     PERL_HASH(hash, key, klen);
 621
 622     oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
 623     entry = *oentry;
 624     i = 1;
 625     for (; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
 626         if (HeHASH(entry) != hash)              /* strings can't be equal */
 627             continue;
 628         if (HeKLEN(entry) != klen)
 629             continue;
 630         if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen))        /* is this it? */
 631             continue;
 632  if (HeKUTF8(entry) != (char)is_utf8)
 633      continue;
 634         *oentry = HeNEXT(entry);
 635         if (i && !*oentry)
 636             xhv->xhv_fill--;
 637         if (flags & G_DISCARD)
 638             sv = Nullsv;
 639         else {
 640             sv = sv_2mortal(HeVAL(entry));
 641             HeVAL(entry) = &PL_sv_undef;
 642         }
 643         if (entry == xhv->xhv_eiter)
 644             HvLAZYDEL_on(hv);
 645         else
 646             hv_free_ent(hv, entry);
 647         --xhv->xhv_keys;
 648         return sv;
 649     }
 650     return Nullsv;
 651 }
 652
 653 /*
 654 =for apidoc hv_delete_ent
 655
 656 Deletes a key/value pair in the hash.  The value SV is removed from the
 657 hash and returned to the caller.  The C<flags> value will normally be zero;
 658 if set to G_DISCARD then NULL will be returned.  C<hash> can be a valid
 659 precomputed hash value, or 0 to ask for it to be computed.
 660
 661 =cut
 662 */
 663
 664 SV *
 665 Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash)
 666 {
 667     register XPVHV* xhv;
 668     register I32 i;
 669     register char *key;
 670     STRLEN klen;
 671     register HE *entry;
 672     register HE **oentry;
 673     SV *sv;
 674     bool is_utf8;
 675
 676     if (!hv)
 677         return Nullsv;
 678     if (SvRMAGICAL(hv)) {
 679         bool needs_copy;
 680         bool needs_store;
 681         hv_magic_check (hv, &needs_copy, &needs_store);
 682
 683         if (needs_copy && (entry = hv_fetch_ent(hv, keysv, TRUE, hash))) {
 684             sv = HeVAL(entry);
 685             mg_clear(sv);
 686             if (!needs_store) {
 687                 if (mg_find(sv, 'p')) {
 688                     sv_unmagic(sv, 'p');        /* No longer an element */
 689                     return sv;
 690                 }
 691                 return Nullsv;          /* element cannot be deleted */
 692             }
 693 #ifdef ENV_IS_CASELESS
 694             else if (mg_find((SV*)hv,'E')) {
 695                 key = SvPV(keysv, klen);
 696                 keysv = sv_2mortal(newSVpvn(key,klen));
 697                 (void)strupr(SvPVX(keysv));
 698                 hash = 0;
 699             }
 700 #endif
 701         }
 702     }
 703     xhv = (XPVHV*)SvANY(hv);
 704     if (!xhv->xhv_array)
 705         return Nullsv;
 706
 707     key = SvPV(keysv, klen);
 708     is_utf8 = (SvUTF8(keysv) != 0);
 709
 710     if (!hash)
 711         PERL_HASH(hash, key, klen);
 712
 713     oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
 714     entry = *oentry;
 715     i = 1;
 716     for (; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
 717         if (HeHASH(entry) != hash)              /* strings can't be equal */
 718             continue;
 719         if (HeKLEN(entry) != klen)
 720             continue;
 721         if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen))        /* is this it? */
 722             continue;
 723  if (HeKUTF8(entry) != (char)is_utf8)
 724      continue;
 725         *oentry = HeNEXT(entry);
 726         if (i && !*oentry)
 727             xhv->xhv_fill--;
 728         if (flags & G_DISCARD)
 729             sv = Nullsv;
 730         else {
 731             sv = sv_2mortal(HeVAL(entry));
 732             HeVAL(entry) = &PL_sv_undef;
 733         }
 734         if (entry == xhv->xhv_eiter)
 735             HvLAZYDEL_on(hv);
 736         else
 737             hv_free_ent(hv, entry);
 738         --xhv->xhv_keys;
 739         return sv;
 740     }
 741     return Nullsv;
 742 }
 743
 744 /*
 745 =for apidoc hv_exists
 746
 747 Returns a boolean indicating whether the specified hash key exists.  The
 748 C<klen> is the length of the key.
 749
 750 =cut
 751 */
 752
 753 bool
 754 Perl_hv_exists(pTHX_ HV *hv, const char *key, I32 klen)
 755 {
 756     register XPVHV* xhv;
 757     register U32 hash;
 758     register HE *entry;
 759     SV *sv;
 760     bool is_utf8 = FALSE;
 761
 762     if (!hv)
 763         return 0;
 764
 765     if (klen < 0) {
 766       klen = -klen;
 767       is_utf8 = TRUE;
 768     }
 769
 770     if (SvRMAGICAL(hv)) {
 771         if (mg_find((SV*)hv,'P')) {
 772             dTHR;
 773             sv = sv_newmortal();
 774             mg_copy((SV*)hv, sv, key, klen);
 775             magic_existspack(sv, mg_find(sv, 'p'));
 776             return SvTRUE(sv);
 777         }
 778 #ifdef ENV_IS_CASELESS
 779         else if (mg_find((SV*)hv,'E')) {
 780             sv = sv_2mortal(newSVpvn(key,klen));
 781             key = strupr(SvPVX(sv));
 782         }
 783 #endif
 784     }
 785
 786     xhv = (XPVHV*)SvANY(hv);
 787 #ifndef DYNAMIC_ENV_FETCH
 788     if (!xhv->xhv_array)
 789         return 0;
 790 #endif
 791
 792     PERL_HASH(hash, key, klen);
 793
 794 #ifdef DYNAMIC_ENV_FETCH
 795     if (!xhv->xhv_array) entry = Null(HE*);
 796     else
 797 #endif
 798     entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
 799     for (; entry; entry = HeNEXT(entry)) {
 800         if (HeHASH(entry) != hash)              /* strings can't be equal */
 801             continue;
 802         if (HeKLEN(entry) != klen)
 803             continue;
 804         if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen))        /* is this it? */
 805             continue;
 806  if (HeKUTF8(entry) != (char)is_utf8)
 807      continue;
 808         return TRUE;
 809     }
 810 #ifdef DYNAMIC_ENV_FETCH  /* is it out there? */
 811     if (HvNAME(hv) && strEQ(HvNAME(hv), ENV_HV_NAME)) {
 812         unsigned long len;
 813         char *env = PerlEnv_ENVgetenv_len(key,&len);
 814         if (env) {
 815             sv = newSVpvn(env,len);
 816             SvTAINTED_on(sv);
 817             (void)hv_store(hv,key,klen,sv,hash);
 818             return TRUE;
 819         }
 820     }
 821 #endif
 822     return FALSE;
 823 }
 824
 825
 826 /*
 827 =for apidoc hv_exists_ent
 828
 829 Returns a boolean indicating whether the specified hash key exists. C<hash>
 830 can be a valid precomputed hash value, or 0 to ask for it to be
 831 computed.
 832
 833 =cut
 834 */
 835
 836 bool
 837 Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash)
 838 {
 839     register XPVHV* xhv;
 840     register char *key;
 841     STRLEN klen;
 842     register HE *entry;
 843     SV *sv;
 844
 845     if (!hv)
 846         return 0;
 847
 848     if (SvRMAGICAL(hv)) {
 849         if (mg_find((SV*)hv,'P')) {
 850             dTHR;               /* just for SvTRUE */
 851             sv = sv_newmortal();
 852             keysv = sv_2mortal(newSVsv(keysv));
 853             mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY);
 854             magic_existspack(sv, mg_find(sv, 'p'));
 855             return SvTRUE(sv);
 856         }
 857 #ifdef ENV_IS_CASELESS
 858         else if (mg_find((SV*)hv,'E')) {
 859             key = SvPV(keysv, klen);
 860             keysv = sv_2mortal(newSVpvn(key,klen));
 861             (void)strupr(SvPVX(keysv));
 862             hash = 0;
 863         }
 864 #endif
 865     }
 866
 867     xhv = (XPVHV*)SvANY(hv);
 868 #ifndef DYNAMIC_ENV_FETCH
 869     if (!xhv->xhv_array)
 870         return 0;
 871 #endif
 872
 873     key = SvPV(keysv, klen);
 874     if (!hash)
 875         PERL_HASH(hash, key, klen);
 876
 877 #ifdef DYNAMIC_ENV_FETCH
 878     if (!xhv->xhv_array) entry = Null(HE*);
 879     else
 880 #endif
 881     entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
 882     for (; entry; entry = HeNEXT(entry)) {
 883         if (HeHASH(entry) != hash)              /* strings can't be equal */
 884             continue;
 885         if (HeKLEN(entry) != klen)
 886             continue;
 887         if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen))        /* is this it? */
 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         SV *sv = newSVpvn_share((HeKLEN(entry) ? HeKEY(entry) : ""),
1396     HeKLEN(entry), HeHASH(entry));
1397  if (HeKUTF8(entry))
1398      SvUTF8_on(sv);
1399  return sv_2mortal(sv);
1400     }
1401 }
1402
1403 /*
1404 =for apidoc hv_iterval
1405
1406 Returns the value from the current position of the hash iterator.  See
1407 C<hv_iterkey>.
1408
1409 =cut
1410 */
1411
1412 SV *
1413 Perl_hv_iterval(pTHX_ HV *hv, register HE *entry)
1414 {
1415     if (SvRMAGICAL(hv)) {
1416         if (mg_find((SV*)hv,'P')) {
1417             SV* sv = sv_newmortal();
1418             if (HeKLEN(entry) == HEf_SVKEY)
1419                 mg_copy((SV*)hv, sv, (char*)HeKEY_sv(entry), HEf_SVKEY);
1420             else mg_copy((SV*)hv, sv, HeKEY(entry), HeKLEN(entry));
1421             return sv;
1422         }
1423     }
1424     return HeVAL(entry);
1425 }
1426
1427 /*
1428 =for apidoc hv_iternextsv
1429
1430 Performs an C<hv_iternext>, C<hv_iterkey>, and C<hv_iterval> in one
1431 operation.
1432
1433 =cut
1434 */
1435
1436 SV *
1437 Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen)
1438 {
1439     HE *he;
1440     if ( (he = hv_iternext(hv)) == NULL)
1441         return NULL;
1442     *key = hv_iterkey(he, retlen);
1443     return hv_iterval(hv, he);
1444 }
1445
1446 /*
1447 =for apidoc hv_magic
1448
1449 Adds magic to a hash.  See C<sv_magic>.
1450
1451 =cut
1452 */
1453
1454 void
1455 Perl_hv_magic(pTHX_ HV *hv, GV *gv, int how)
1456 {
1457     sv_magic((SV*)hv, (SV*)gv, how, Nullch, 0);
1458 }
1459
1460 char*
1461 Perl_sharepvn(pTHX_ const char *sv, I32 len, U32 hash)
1462 {
1463     return HEK_KEY(share_hek(sv, len, hash));
1464 }
1465
1466 /* possibly free a shared string if no one has access to it
1467  * len and hash must both be valid for str.
1468  */
1469 void
1470 Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
1471 {
1472     register XPVHV* xhv;
1473     register HE *entry;
1474     register HE **oentry;
1475     register I32 i = 1;
1476     I32 found = 0;
1477
1478     /* what follows is the moral equivalent of:
1479     if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) {
1480         if (--*Svp == Nullsv)
1481             hv_delete(PL_strtab, str, len, G_DISCARD, hash);
1482     } */
1483     xhv = (XPVHV*)SvANY(PL_strtab);
1484     /* assert(xhv_array != 0) */
1485     LOCK_STRTAB_MUTEX;
1486     oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
1487     for (entry = *oentry; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
1488         if (HeHASH(entry) != hash)              /* strings can't be equal */
1489             continue;
1490         if (HeKLEN(entry) != len)
1491             continue;
1492         if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
1493             continue;
1494         found = 1;
1495         if (--HeVAL(entry) == Nullsv) {
1496             *oentry = HeNEXT(entry);
1497             if (i && !*oentry)
1498                 xhv->xhv_fill--;
1499             Safefree(HeKEY_hek(entry));
1500             del_HE(entry);
1501             --xhv->xhv_keys;
1502         }
1503         break;
1504     }
1505     UNLOCK_STRTAB_MUTEX;
1506
1507     {
1508         dTHR;
1509         if (!found && ckWARN_d(WARN_INTERNAL))
1510             Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free non-existent shared string '%s'",str);
1511     }
1512 }
1513
1514 /* get a (constant) string ptr from the global string table
1515  * string will get added if it is not already there.
1516  * len and hash must both be valid for str.
1517  */
1518 HEK *
1519 Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash)
1520 {
1521     register XPVHV* xhv;
1522     register HE *entry;
1523     register HE **oentry;
1524     register I32 i = 1;
1525     I32 found = 0;
1526     bool is_utf8 = FALSE;
1527
1528     if (len < 0) {
1529       len = -len;
1530       is_utf8 = TRUE;
1531     }
1532
1533     /* what follows is the moral equivalent of:
1534
1535     if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
1536         hv_store(PL_strtab, str, len, Nullsv, hash);
1537     */
1538     xhv = (XPVHV*)SvANY(PL_strtab);
1539     /* assert(xhv_array != 0) */
1540     LOCK_STRTAB_MUTEX;
1541     oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
1542     for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
1543         if (HeHASH(entry) != hash)              /* strings can't be equal */
1544             continue;
1545         if (HeKLEN(entry) != len)
1546             continue;
1547         if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
1548             continue;
1549  if (HeKUTF8(entry) != (char)is_utf8)
1550      continue;
1551         found = 1;
1552         break;
1553     }
1554     if (!found) {
1555         entry = new_HE();
1556  HeKEY_hek(entry) = save_hek(str, is_utf8?-len:len, hash);
1557         HeVAL(entry) = Nullsv;
1558         HeNEXT(entry) = *oentry;
1559         *oentry = entry;
1560         xhv->xhv_keys++;
1561         if (i) {                                /* initial entry? */
1562             ++xhv->xhv_fill;
1563             if (xhv->xhv_keys > xhv->xhv_max)
1564                 hsplit(PL_strtab);
1565         }
1566     }
1567
1568     ++HeVAL(entry);                             /* use value slot as REFCNT */
1569     UNLOCK_STRTAB_MUTEX;
1570     return HeKEY_hek(entry);
1571 }
1572
1573
1574