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