hv.c

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