hv.c

   1 /*    hv.c
   2  *
   3  *    Copyright (c) 1991-2000, Larry Wall
   4  *
   5  *    You may distribute under the terms of either the GNU General Public
   6  *    License or the Artistic License, as specified in the README file.
   7  *
   8  */
   9
  10 /*
  11  * "I sit beside the fire and think of all that I have seen."  --Bilbo
  12  */
  13
  14 #include "EXTERN.h"
  15 #define PERL_IN_HV_C
  16 #include "perl.h"
  17
  18 STATIC HE*
  19 S_new_he(pTHX)
  20 {
  21     HE* he;
  22     LOCK_SV_MUTEX;
  23     if (!PL_he_root)
  24         more_he();
  25     he = PL_he_root;
  26     PL_he_root = HeNEXT(he);
  27     UNLOCK_SV_MUTEX;
  28     return he;
  29 }
  30
  31 STATIC void
  32 S_del_he(pTHX_ HE *p)
  33 {
  34     LOCK_SV_MUTEX;
  35     HeNEXT(p) = (HE*)PL_he_root;
  36     PL_he_root = p;
  37     UNLOCK_SV_MUTEX;
  38 }
  39
  40 STATIC void
  41 S_more_he(pTHX)
  42 {
  43     register HE* he;
  44     register HE* heend;
  45     New(54, PL_he_root, 1008/sizeof(HE), HE);
  46     he = PL_he_root;
  47     heend = &he[1008 / sizeof(HE) - 1];
  48     while (he < heend) {
  49         HeNEXT(he) = (HE*)(he + 1);
  50         he++;
  51     }
  52     HeNEXT(he) = 0;
  53 }
  54
  55 #ifdef PURIFY
  56
  57 #define new_HE() (HE*)safemalloc(sizeof(HE))
  58 #define del_HE(p) safefree((char*)p)
  59
  60 #else
  61
  62 #define new_HE() new_he()
  63 #define del_HE(p) del_he(p)
  64
  65 #endif
  66
  67 STATIC HEK *
  68 S_save_hek(pTHX_ const char *str, I32 len, U32 hash)
  69 {
  70     char *k;
  71     register HEK *hek;
  72
  73     New(54, k, HEK_BASESIZE + len + 1, char);
  74     hek = (HEK*)k;
  75     Copy(str, HEK_KEY(hek), len, char);
  76     *(HEK_KEY(hek) + len) = '\0';
  77     HEK_LEN(hek) = len;
  78     HEK_HASH(hek) = hash;
  79     return hek;
  80 }
  81
  82 void
  83 Perl_unshare_hek(pTHX_ HEK *hek)
  84 {
  85     unsharepvn(HEK_KEY(hek),HEK_LEN(hek),HEK_HASH(hek));
  86 }
  87
  88 #if defined(USE_ITHREADS)
  89 HE *
  90 Perl_he_dup(pTHX_ HE *e, bool shared)
  91 {
  92     HE *ret;
  93
  94     if (!e)
  95         return Nullhe;
  96     /* look for it in the table first */
  97     ret = (HE*)ptr_table_fetch(PL_ptr_table, e);
  98     if (ret)
  99         return ret;
 100
 101     /* create anew and remember what it is */
 102     ret = new_HE();
 103     ptr_table_store(PL_ptr_table, e, ret);
 104
 105     HeNEXT(ret) = he_dup(HeNEXT(e),shared);
 106     if (HeKLEN(e) == HEf_SVKEY)
 107         HeKEY_sv(ret) = SvREFCNT_inc(sv_dup(HeKEY_sv(e)));
 108     else if (shared)
 109         HeKEY_hek(ret) = share_hek(HeKEY(e), HeKLEN(e), HeHASH(e));
 110     else
 111         HeKEY_hek(ret) = save_hek(HeKEY(e), HeKLEN(e), HeHASH(e));
 112     HeVAL(ret) = SvREFCNT_inc(sv_dup(HeVAL(e)));
 113     return ret;
 114 }
 115 #endif  /* USE_ITHREADS */
 116
 117 /* (klen == HEf_SVKEY) is special for MAGICAL hv entries, meaning key slot
 118  * contains an SV* */
 119
 120 /*
 121 =for apidoc hv_fetch
 122
 123 Returns the SV which corresponds to the specified key in the hash.  The
 124 C<klen> is the length of the key.  If C<lval> is set then the fetch will be
 125 part of a store.  Check that the return value is non-null before
 126 dereferencing it to a C<SV*>.
 127
 128 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
 129 information on how to use this function on tied hashes.
 130
 131 =cut
 132 */
 133
 134 SV**
 135 Perl_hv_fetch(pTHX_ HV *hv, const char *key, U32 klen, I32 lval)
 136 {
 137     register XPVHV* xhv;
 138     register U32 hash;
 139     register HE *entry;
 140     SV *sv;
 141
 142     if (!hv)
 143         return 0;
 144
 145     if (SvRMAGICAL(hv)) {
 146         if (mg_find((SV*)hv,'P')) {
 147             dTHR;
 148             sv = sv_newmortal();
 149             mg_copy((SV*)hv, sv, key, klen);
 150             PL_hv_fetch_sv = sv;
 151             return &PL_hv_fetch_sv;
 152         }
 153 #ifdef ENV_IS_CASELESS
 154         else if (mg_find((SV*)hv,'E')) {
 155             U32 i;
 156             for (i = 0; i < klen; ++i)
 157                 if (isLOWER(key[i])) {
 158                     char *nkey = strupr(SvPVX(sv_2mortal(newSVpvn(key,klen))));
 159                     SV **ret = hv_fetch(hv, nkey, klen, 0);
 160                     if (!ret && lval)
 161                         ret = hv_store(hv, key, klen, NEWSV(61,0), 0);
 162                     return ret;
 163                 }
 164         }
 165 #endif
 166     }
 167
 168     xhv = (XPVHV*)SvANY(hv);
 169     if (!xhv->xhv_array) {
 170         if (lval
 171 #ifdef DYNAMIC_ENV_FETCH  /* if it's an %ENV lookup, we may get it on the fly */
 172                  || (HvNAME(hv) && strEQ(HvNAME(hv),ENV_HV_NAME))
 173 #endif
 174                                                                   )
 175             Newz(503, xhv->xhv_array,
 176                  PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
 177         else
 178             return 0;
 179     }
 180
 181     PERL_HASH(hash, key, klen);
 182
 183     entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
 184     for (; entry; entry = HeNEXT(entry)) {
 185         if (HeHASH(entry) != hash)              /* strings can't be equal */
 186             continue;
 187         if (HeKLEN(entry) != klen)
 188             continue;
 189         if (memNE(HeKEY(entry),key,klen))       /* is this it? */
 190             continue;
 191         return &HeVAL(entry);
 192     }
 193 #ifdef DYNAMIC_ENV_FETCH  /* %ENV lookup?  If so, try to fetch the value now */
 194     if (HvNAME(hv) && strEQ(HvNAME(hv),ENV_HV_NAME)) {
 195         unsigned long len;
 196         char *env = PerlEnv_ENVgetenv_len(key,&len);
 197         if (env) {
 198             sv = newSVpvn(env,len);
 199             SvTAINTED_on(sv);
 200             return hv_store(hv,key,klen,sv,hash);
 201         }
 202     }
 203 #endif
 204     if (lval) {         /* gonna assign to this, so it better be there */
 205         sv = NEWSV(61,0);
 206         return hv_store(hv,key,klen,sv,hash);
 207     }
 208     return 0;
 209 }
 210
 211 /* returns a HE * structure with the all fields set */
 212 /* note that hent_val will be a mortal sv for MAGICAL hashes */
 213 /*
 214 =for apidoc hv_fetch_ent
 215
 216 Returns the hash entry which corresponds to the specified key in the hash.
 217 C<hash> must be a valid precomputed hash number for the given C<key>, or 0
 218 if you want the function to compute it.  IF C<lval> is set then the fetch
 219 will be part of a store.  Make sure the return value is non-null before
 220 accessing it.  The return value when C<tb> is a tied hash is a pointer to a
 221 static location, so be sure to make a copy of the structure if you need to
 222 store it somewhere.
 223
 224 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
 225 information on how to use this function on tied hashes.
 226
 227 =cut
 228 */
 229
 230 HE *
 231 Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash)
 232 {
 233     register XPVHV* xhv;
 234     register char *key;
 235     STRLEN klen;
 236     register HE *entry;
 237     SV *sv;
 238
 239     if (!hv)
 240         return 0;
 241
 242     if (SvRMAGICAL(hv)) {
 243         if (mg_find((SV*)hv,'P')) {
 244             dTHR;
 245             sv = sv_newmortal();
 246             keysv = sv_2mortal(newSVsv(keysv));
 247             mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY);
 248             if (!HeKEY_hek(&PL_hv_fetch_ent_mh)) {
 249                 char *k;
 250                 New(54, k, HEK_BASESIZE + sizeof(SV*), char);
 251                 HeKEY_hek(&PL_hv_fetch_ent_mh) = (HEK*)k;
 252             }
 253             HeSVKEY_set(&PL_hv_fetch_ent_mh, keysv);
 254             HeVAL(&PL_hv_fetch_ent_mh) = sv;
 255             return &PL_hv_fetch_ent_mh;
 256         }
 257 #ifdef ENV_IS_CASELESS
 258         else if (mg_find((SV*)hv,'E')) {
 259             U32 i;
 260             key = SvPV(keysv, klen);
 261             for (i = 0; i < klen; ++i)
 262                 if (isLOWER(key[i])) {
 263                     SV *nkeysv = sv_2mortal(newSVpvn(key,klen));
 264                     (void)strupr(SvPVX(nkeysv));
 265                     entry = hv_fetch_ent(hv, nkeysv, 0, 0);
 266                     if (!entry && lval)
 267                         entry = hv_store_ent(hv, keysv, NEWSV(61,0), hash);
 268                     return entry;
 269                 }
 270         }
 271 #endif
 272     }
 273
 274     xhv = (XPVHV*)SvANY(hv);
 275     if (!xhv->xhv_array) {
 276         if (lval
 277 #ifdef DYNAMIC_ENV_FETCH  /* if it's an %ENV lookup, we may get it on the fly */
 278                  || (HvNAME(hv) && strEQ(HvNAME(hv),ENV_HV_NAME))
 279 #endif
 280                                                                   )
 281             Newz(503, xhv->xhv_array,
 282                  PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
 283         else
 284             return 0;
 285     }
 286
 287     key = SvPV(keysv, klen);
 288
 289     if (!hash)
 290         PERL_HASH(hash, key, klen);
 291
 292     entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
 293     for (; entry; entry = HeNEXT(entry)) {
 294         if (HeHASH(entry) != hash)              /* strings can't be equal */
 295             continue;
 296         if (HeKLEN(entry) != klen)
 297             continue;
 298         if (memNE(HeKEY(entry),key,klen))       /* is this it? */
 299             continue;
 300         return entry;
 301     }
 302 #ifdef DYNAMIC_ENV_FETCH  /* %ENV lookup?  If so, try to fetch the value now */
 303     if (HvNAME(hv) && strEQ(HvNAME(hv),ENV_HV_NAME)) {
 304         unsigned long len;
 305         char *env = PerlEnv_ENVgetenv_len(key,&len);
 306         if (env) {
 307             sv = newSVpvn(env,len);
 308             SvTAINTED_on(sv);
 309             return hv_store_ent(hv,keysv,sv,hash);
 310         }
 311     }
 312 #endif
 313     if (lval) {         /* gonna assign to this, so it better be there */
 314         sv = NEWSV(61,0);
 315         return hv_store_ent(hv,keysv,sv,hash);
 316     }
 317     return 0;
 318 }
 319
 320 STATIC void
 321 S_hv_magic_check(pTHX_ HV *hv, bool *needs_copy, bool *needs_store)
 322 {
 323     MAGIC *mg = SvMAGIC(hv);
 324     *needs_copy = FALSE;
 325     *needs_store = TRUE;
 326     while (mg) {
 327         if (isUPPER(mg->mg_type)) {
 328             *needs_copy = TRUE;
 329             switch (mg->mg_type) {
 330             case 'P':
 331             case 'S':
 332                 *needs_store = FALSE;
 333             }
 334         }
 335         mg = mg->mg_moremagic;
 336     }
 337 }
 338
 339 /*
 340 =for apidoc hv_store
 341
 342 Stores an SV in a hash.  The hash key is specified as C<key> and C<klen> is
 343 the length of the key.  The C<hash> parameter is the precomputed hash
 344 value; if it is zero then Perl will compute it.  The return value will be
 345 NULL if the operation failed or if the value did not need to be actually
 346 stored within the hash (as in the case of tied hashes).  Otherwise it can
 347 be dereferenced to get the original C<SV*>.  Note that the caller is
 348 responsible for suitably incrementing the reference count of C<val> before
 349 the call, and decrementing it if the function returned NULL.
 350
 351 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
 352 information on how to use this function on tied hashes.
 353
 354 =cut
 355 */
 356
 357 SV**
 358 Perl_hv_store(pTHX_ HV *hv, const char *key, U32 klen, SV *val, register U32 hash)
 359 {
 360     register XPVHV* xhv;
 361     register I32 i;
 362     register HE *entry;
 363     register HE **oentry;
 364
 365     if (!hv)
 366         return 0;
 367
 368     xhv = (XPVHV*)SvANY(hv);
 369     if (SvMAGICAL(hv)) {
 370         bool needs_copy;
 371         bool needs_store;
 372         hv_magic_check (hv, &needs_copy, &needs_store);
 373         if (needs_copy) {
 374             mg_copy((SV*)hv, val, key, klen);
 375             if (!xhv->xhv_array && !needs_store)
 376                 return 0;
 377 #ifdef ENV_IS_CASELESS
 378             else if (mg_find((SV*)hv,'E')) {
 379                 SV *sv = sv_2mortal(newSVpvn(key,klen));
 380                 key = strupr(SvPVX(sv));
 381                 hash = 0;
 382             }
 383 #endif
 384         }
 385     }
 386     if (!hash)
 387         PERL_HASH(hash, key, klen);
 388
 389     if (!xhv->xhv_array)
 390         Newz(505, xhv->xhv_array,
 391              PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
 392
 393     oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
 394     i = 1;
 395
 396     for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
 397         if (HeHASH(entry) != hash)              /* strings can't be equal */
 398             continue;
 399         if (HeKLEN(entry) != klen)
 400             continue;
 401         if (memNE(HeKEY(entry),key,klen))       /* is this it? */
 402             continue;
 403         SvREFCNT_dec(HeVAL(entry));
 404         HeVAL(entry) = val;
 405         return &HeVAL(entry);
 406     }
 407
 408     entry = new_HE();
 409     if (HvSHAREKEYS(hv))
 410         HeKEY_hek(entry) = share_hek(key, klen, hash);
 411     else                                       /* gotta do the real thing */
 412         HeKEY_hek(entry) = save_hek(key, klen, hash);
 413     HeVAL(entry) = val;
 414     HeNEXT(entry) = *oentry;
 415     *oentry = entry;
 416
 417     xhv->xhv_keys++;
 418     if (i) {                            /* initial entry? */
 419         ++xhv->xhv_fill;
 420         if (xhv->xhv_keys > xhv->xhv_max)
 421             hsplit(hv);
 422     }
 423
 424     return &HeVAL(entry);
 425 }
 426
 427 /*
 428 =for apidoc hv_store_ent
 429
 430 Stores C<val> in a hash.  The hash key is specified as C<key>.  The C<hash>
 431 parameter is the precomputed hash value; if it is zero then Perl will
 432 compute it.  The return value is the new hash entry so created.  It will be
 433 NULL if the operation failed or if the value did not need to be actually
 434 stored within the hash (as in the case of tied hashes).  Otherwise the
 435 contents of the return value can be accessed using the C<He???> macros
 436 described here.  Note that the caller is responsible for suitably
 437 incrementing the reference count of C<val> before the call, and
 438 decrementing it if the function returned NULL.
 439
 440 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
 441 information on how to use this function on tied hashes.
 442
 443 =cut
 444 */
 445
 446 HE *
 447 Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, register U32 hash)
 448 {
 449     register XPVHV* xhv;
 450     register char *key;
 451     STRLEN klen;
 452     register I32 i;
 453     register HE *entry;
 454     register HE **oentry;
 455
 456     if (!hv)
 457         return 0;
 458
 459     xhv = (XPVHV*)SvANY(hv);
 460     if (SvMAGICAL(hv)) {
 461         dTHR;
 462         bool needs_copy;
 463         bool needs_store;
 464         hv_magic_check (hv, &needs_copy, &needs_store);
 465         if (needs_copy) {
 466             bool save_taint = PL_tainted;
 467             if (PL_tainting)
 468                 PL_tainted = SvTAINTED(keysv);
 469             keysv = sv_2mortal(newSVsv(keysv));
 470             mg_copy((SV*)hv, val, (char*)keysv, HEf_SVKEY);
 471             TAINT_IF(save_taint);
 472             if (!xhv->xhv_array && !needs_store)
 473                 return Nullhe;
 474 #ifdef ENV_IS_CASELESS
 475             else if (mg_find((SV*)hv,'E')) {
 476                 key = SvPV(keysv, klen);
 477                 keysv = sv_2mortal(newSVpvn(key,klen));
 478                 (void)strupr(SvPVX(keysv));
 479                 hash = 0;
 480             }
 481 #endif
 482         }
 483     }
 484
 485     key = SvPV(keysv, klen);
 486
 487     if (!hash)
 488         PERL_HASH(hash, key, klen);
 489
 490     if (!xhv->xhv_array)
 491         Newz(505, xhv->xhv_array,
 492              PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
 493
 494     oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
 495     i = 1;
 496
 497     for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
 498         if (HeHASH(entry) != hash)              /* strings can't be equal */
 499             continue;
 500         if (HeKLEN(entry) != klen)
 501             continue;
 502         if (memNE(HeKEY(entry),key,klen))       /* is this it? */
 503             continue;
 504         SvREFCNT_dec(HeVAL(entry));
 505         HeVAL(entry) = val;
 506         return entry;
 507     }
 508
 509     entry = new_HE();
 510     if (HvSHAREKEYS(hv))
 511         HeKEY_hek(entry) = share_hek(key, klen, hash);
 512     else                                       /* gotta do the real thing */
 513         HeKEY_hek(entry) = save_hek(key, klen, hash);
 514     HeVAL(entry) = val;
 515     HeNEXT(entry) = *oentry;
 516     *oentry = entry;
 517
 518     xhv->xhv_keys++;
 519     if (i) {                            /* initial entry? */
 520         ++xhv->xhv_fill;
 521         if (xhv->xhv_keys > xhv->xhv_max)
 522             hsplit(hv);
 523     }
 524
 525     return entry;
 526 }
 527
 528 /*
 529 =for apidoc hv_delete
 530
 531 Deletes a key/value pair in the hash.  The value SV is removed from the
 532 hash and returned to the caller.  The C<klen> is the length of the key.
 533 The C<flags> value will normally be zero; if set to G_DISCARD then NULL
 534 will be returned.
 535
 536 =cut
 537 */
 538
 539 SV *
 540 Perl_hv_delete(pTHX_ HV *hv, const char *key, U32 klen, I32 flags)
 541 {
 542     register XPVHV* xhv;
 543     register I32 i;
 544     register U32 hash;
 545     register HE *entry;
 546     register HE **oentry;
 547     SV **svp;
 548     SV *sv;
 549
 550     if (!hv)
 551         return Nullsv;
 552     if (SvRMAGICAL(hv)) {
 553         bool needs_copy;
 554         bool needs_store;
 555         hv_magic_check (hv, &needs_copy, &needs_store);
 556
 557         if (needs_copy && (svp = hv_fetch(hv, key, klen, TRUE))) {
 558             sv = *svp;
 559             mg_clear(sv);
 560             if (!needs_store) {
 561                 if (mg_find(sv, 'p')) {
 562                     sv_unmagic(sv, 'p');        /* No longer an element */
 563                     return sv;
 564                 }
 565                 return Nullsv;          /* element cannot be deleted */
 566             }
 567 #ifdef ENV_IS_CASELESS
 568             else if (mg_find((SV*)hv,'E')) {
 569                 sv = sv_2mortal(newSVpvn(key,klen));
 570                 key = strupr(SvPVX(sv));
 571             }
 572 #endif
 573         }
 574     }
 575     xhv = (XPVHV*)SvANY(hv);
 576     if (!xhv->xhv_array)
 577         return Nullsv;
 578
 579     PERL_HASH(hash, key, klen);
 580
 581     oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
 582     entry = *oentry;
 583     i = 1;
 584     for (; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
 585         if (HeHASH(entry) != hash)              /* strings can't be equal */
 586             continue;
 587         if (HeKLEN(entry) != klen)
 588             continue;
 589         if (memNE(HeKEY(entry),key,klen))       /* is this it? */
 590             continue;
 591         *oentry = HeNEXT(entry);
 592         if (i && !*oentry)
 593             xhv->xhv_fill--;
 594         if (flags & G_DISCARD)
 595             sv = Nullsv;
 596         else {
 597             sv = sv_2mortal(HeVAL(entry));
 598             HeVAL(entry) = &PL_sv_undef;
 599         }
 600         if (entry == xhv->xhv_eiter)
 601             HvLAZYDEL_on(hv);
 602         else
 603             hv_free_ent(hv, entry);
 604         --xhv->xhv_keys;
 605         return sv;
 606     }
 607     return Nullsv;
 608 }
 609
 610 /*
 611 =for apidoc hv_delete_ent
 612
 613 Deletes a key/value pair in the hash.  The value SV is removed from the
 614 hash and returned to the caller.  The C<flags> value will normally be zero;
 615 if set to G_DISCARD then NULL will be returned.  C<hash> can be a valid
 616 precomputed hash value, or 0 to ask for it to be computed.
 617
 618 =cut
 619 */
 620
 621 SV *
 622 Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash)
 623 {
 624     register XPVHV* xhv;
 625     register I32 i;
 626     register char *key;
 627     STRLEN klen;
 628     register HE *entry;
 629     register HE **oentry;
 630     SV *sv;
 631
 632     if (!hv)
 633         return Nullsv;
 634     if (SvRMAGICAL(hv)) {
 635         bool needs_copy;
 636         bool needs_store;
 637         hv_magic_check (hv, &needs_copy, &needs_store);
 638
 639         if (needs_copy && (entry = hv_fetch_ent(hv, keysv, TRUE, hash))) {
 640             sv = HeVAL(entry);
 641             mg_clear(sv);
 642             if (!needs_store) {
 643                 if (mg_find(sv, 'p')) {
 644                     sv_unmagic(sv, 'p');        /* No longer an element */
 645                     return sv;
 646                 }
 647                 return Nullsv;          /* element cannot be deleted */
 648             }
 649 #ifdef ENV_IS_CASELESS
 650             else if (mg_find((SV*)hv,'E')) {
 651                 key = SvPV(keysv, klen);
 652                 keysv = sv_2mortal(newSVpvn(key,klen));
 653                 (void)strupr(SvPVX(keysv));
 654                 hash = 0;
 655             }
 656 #endif
 657         }
 658     }
 659     xhv = (XPVHV*)SvANY(hv);
 660     if (!xhv->xhv_array)
 661         return Nullsv;
 662
 663     key = SvPV(keysv, klen);
 664
 665     if (!hash)
 666         PERL_HASH(hash, key, klen);
 667
 668     oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
 669     entry = *oentry;
 670     i = 1;
 671     for (; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
 672         if (HeHASH(entry) != hash)              /* strings can't be equal */
 673             continue;
 674         if (HeKLEN(entry) != klen)
 675             continue;
 676         if (memNE(HeKEY(entry),key,klen))       /* is this it? */
 677             continue;
 678         *oentry = HeNEXT(entry);
 679         if (i && !*oentry)
 680             xhv->xhv_fill--;
 681         if (flags & G_DISCARD)
 682             sv = Nullsv;
 683         else {
 684             sv = sv_2mortal(HeVAL(entry));
 685             HeVAL(entry) = &PL_sv_undef;
 686         }
 687         if (entry == xhv->xhv_eiter)
 688             HvLAZYDEL_on(hv);
 689         else
 690             hv_free_ent(hv, entry);
 691         --xhv->xhv_keys;
 692         return sv;
 693     }
 694     return Nullsv;
 695 }
 696
 697 /*
 698 =for apidoc hv_exists
 699
 700 Returns a boolean indicating whether the specified hash key exists.  The
 701 C<klen> is the length of the key.
 702
 703 =cut
 704 */
 705
 706 bool
 707 Perl_hv_exists(pTHX_ HV *hv, const char *key, U32 klen)
 708 {
 709     register XPVHV* xhv;
 710     register U32 hash;
 711     register HE *entry;
 712     SV *sv;
 713
 714     if (!hv)
 715         return 0;
 716
 717     if (SvRMAGICAL(hv)) {
 718         if (mg_find((SV*)hv,'P')) {
 719             dTHR;
 720             sv = sv_newmortal();
 721             mg_copy((SV*)hv, sv, key, klen);
 722             magic_existspack(sv, mg_find(sv, 'p'));
 723             return SvTRUE(sv);
 724         }
 725 #ifdef ENV_IS_CASELESS
 726         else if (mg_find((SV*)hv,'E')) {
 727             sv = sv_2mortal(newSVpvn(key,klen));
 728             key = strupr(SvPVX(sv));
 729         }
 730 #endif
 731     }
 732
 733     xhv = (XPVHV*)SvANY(hv);
 734 #ifndef DYNAMIC_ENV_FETCH
 735     if (!xhv->xhv_array)
 736         return 0;
 737 #endif
 738
 739     PERL_HASH(hash, key, klen);
 740
 741 #ifdef DYNAMIC_ENV_FETCH
 742     if (!xhv->xhv_array) entry = Null(HE*);
 743     else
 744 #endif
 745     entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
 746     for (; entry; entry = HeNEXT(entry)) {
 747         if (HeHASH(entry) != hash)              /* strings can't be equal */
 748             continue;
 749         if (HeKLEN(entry) != klen)
 750             continue;
 751         if (memNE(HeKEY(entry),key,klen))       /* is this it? */
 752             continue;
 753         return TRUE;
 754     }
 755 #ifdef DYNAMIC_ENV_FETCH  /* is it out there? */
 756     if (HvNAME(hv) && strEQ(HvNAME(hv), ENV_HV_NAME)) {
 757         unsigned long len;
 758         char *env = PerlEnv_ENVgetenv_len(key,&len);
 759         if (env) {
 760             sv = newSVpvn(env,len);
 761             SvTAINTED_on(sv);
 762             (void)hv_store(hv,key,klen,sv,hash);
 763             return TRUE;
 764         }
 765     }
 766 #endif
 767     return FALSE;
 768 }
 769
 770
 771 /*
 772 =for apidoc hv_exists_ent
 773
 774 Returns a boolean indicating whether the specified hash key exists. C<hash>
 775 can be a valid precomputed hash value, or 0 to ask for it to be
 776 computed.
 777
 778 =cut
 779 */
 780
 781 bool
 782 Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash)
 783 {
 784     register XPVHV* xhv;
 785     register char *key;
 786     STRLEN klen;
 787     register HE *entry;
 788     SV *sv;
 789
 790     if (!hv)
 791         return 0;
 792
 793     if (SvRMAGICAL(hv)) {
 794         if (mg_find((SV*)hv,'P')) {
 795             dTHR;               /* just for SvTRUE */
 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                      SvREFCNT_inc(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
1448     {
1449         dTHR;
1450         if (!found && ckWARN_d(WARN_INTERNAL))
1451             Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free non-existent shared string");
1452     }
1453 }
1454
1455 /* get a (constant) string ptr from the global string table
1456  * string will get added if it is not already there.
1457  * len and hash must both be valid for str.
1458  */
1459 HEK *
1460 Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash)
1461 {
1462     register XPVHV* xhv;
1463     register HE *entry;
1464     register HE **oentry;
1465     register I32 i = 1;
1466     I32 found = 0;
1467
1468     /* what follows is the moral equivalent of:
1469
1470     if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
1471         hv_store(PL_strtab, str, len, Nullsv, hash);
1472     */
1473     xhv = (XPVHV*)SvANY(PL_strtab);
1474     /* assert(xhv_array != 0) */
1475     LOCK_STRTAB_MUTEX;
1476     oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
1477     for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
1478         if (HeHASH(entry) != hash)              /* strings can't be equal */
1479             continue;
1480         if (HeKLEN(entry) != len)
1481             continue;
1482         if (memNE(HeKEY(entry),str,len))        /* is this it? */
1483             continue;
1484         found = 1;
1485         break;
1486     }
1487     if (!found) {
1488         entry = new_HE();
1489         HeKEY_hek(entry) = save_hek(str, len, hash);
1490         HeVAL(entry) = Nullsv;
1491         HeNEXT(entry) = *oentry;
1492         *oentry = entry;
1493         xhv->xhv_keys++;
1494         if (i) {                                /* initial entry? */
1495             ++xhv->xhv_fill;
1496             if (xhv->xhv_keys > xhv->xhv_max)
1497                 hsplit(PL_strtab);
1498         }
1499     }
1500
1501     ++HeVAL(entry);                             /* use value slot as REFCNT */
1502     UNLOCK_STRTAB_MUTEX;
1503     return HeKEY_hek(entry);
1504 }
1505
1506
1507