hv.c

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