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