hv.c

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