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