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