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