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