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