hv.c

   1 /*    hv.c
   2  *
   3  *    Copyright (c) 1991-1999, Larry Wall
   4  *
   5  *    You may distribute under the terms of either the GNU General Public
   6  *    License or the Artistic License, as specified in the README file.
   7  *
   8  */
   9
  10 /*
  11  * "I sit beside the fire and think of all that I have seen."  --Bilbo
  12  */
  13
  14 #include "EXTERN.h"
  15 #define PERL_IN_HV_C
  16 #include "perl.h"
  17
  18 STATIC HE*
  19 S_new_he(pTHX)
  20 {
  21     HE* he;
  22     LOCK_SV_MUTEX;
  23     if (!PL_he_root)
  24         more_he();
  25     he = PL_he_root;
  26     PL_he_root = HeNEXT(he);
  27     UNLOCK_SV_MUTEX;
  28     return he;
  29 }
  30
  31 STATIC void
  32 S_del_he(pTHX_ HE *p)
  33 {
  34     LOCK_SV_MUTEX;
  35     HeNEXT(p) = (HE*)PL_he_root;
  36     PL_he_root = p;
  37     UNLOCK_SV_MUTEX;
  38 }
  39
  40 STATIC void
  41 S_more_he(pTHX)
  42 {
  43     register HE* he;
  44     register HE* heend;
  45     New(54, PL_he_root, 1008/sizeof(HE), HE);
  46     he = PL_he_root;
  47     heend = &he[1008 / sizeof(HE) - 1];
  48     while (he < heend) {
  49         HeNEXT(he) = (HE*)(he + 1);
  50         he++;
  51     }
  52     HeNEXT(he) = 0;
  53 }
  54
  55 STATIC HEK *
  56 S_save_hek(pTHX_ const char *str, I32 len, U32 hash)
  57 {
  58     char *k;
  59     register HEK *hek;
  60
  61     New(54, k, HEK_BASESIZE + len + 1, char);
  62     hek = (HEK*)k;
  63     Copy(str, HEK_KEY(hek), len, char);
  64     *(HEK_KEY(hek) + len) = '\0';
  65     HEK_LEN(hek) = len;
  66     HEK_HASH(hek) = hash;
  67     return hek;
  68 }
  69
  70 void
  71 Perl_unshare_hek(pTHX_ HEK *hek)
  72 {
  73     unsharepvn(HEK_KEY(hek),HEK_LEN(hek),HEK_HASH(hek));
  74 }
  75
  76 #if defined(USE_ITHREADS)
  77 HE *
  78 Perl_he_dup(pTHX_ HE *e, bool shared)
  79 {
  80     HE *ret;
  81
  82     if (!e)
  83         return Nullhe;
  84     /* look for it in the table first */
  85     ret = (HE*)ptr_table_fetch(PL_ptr_table, e);
  86     if (ret)
  87         return ret;
  88
  89     /* create anew and remember what it is */
  90     ret = new_he();
  91     ptr_table_store(PL_ptr_table, e, ret);
  92
  93     HeNEXT(ret) = he_dup(HeNEXT(e),shared);
  94     if (HeKLEN(e) == HEf_SVKEY)
  95         HeKEY_sv(ret) = SvREFCNT_inc(sv_dup(HeKEY_sv(e)));
  96     else if (shared)
  97         HeKEY_hek(ret) = share_hek(HeKEY(e), HeKLEN(e), HeHASH(e));
  98     else
  99         HeKEY_hek(ret) = save_hek(HeKEY(e), HeKLEN(e), HeHASH(e));
 100     HeVAL(ret) = SvREFCNT_inc(sv_dup(HeVAL(e)));
 101     return ret;
 102 }
 103 #endif  /* USE_ITHREADS */
 104
 105 /* (klen == HEf_SVKEY) is special for MAGICAL hv entries, meaning key slot
 106  * contains an SV* */
 107
 108 SV**
 109 Perl_hv_fetch(pTHX_ HV *hv, const char *key, U32 klen, I32 lval)
 110 {
 111     register XPVHV* xhv;
 112     register U32 hash;
 113     register HE *entry;
 114     SV *sv;
 115
 116     if (!hv)
 117         return 0;
 118
 119     if (SvRMAGICAL(hv)) {
 120         if (mg_find((SV*)hv,'P')) {
 121             dTHR;
 122             sv = sv_newmortal();
 123             mg_copy((SV*)hv, sv, key, klen);
 124             PL_hv_fetch_sv = sv;
 125             return &PL_hv_fetch_sv;
 126         }
 127 #ifdef ENV_IS_CASELESS
 128         else if (mg_find((SV*)hv,'E')) {
 129             U32 i;
 130             for (i = 0; i < klen; ++i)
 131                 if (isLOWER(key[i])) {
 132                     char *nkey = strupr(SvPVX(sv_2mortal(newSVpvn(key,klen))));
 133                     SV **ret = hv_fetch(hv, nkey, klen, 0);
 134                     if (!ret && lval)
 135                         ret = hv_store(hv, key, klen, NEWSV(61,0), 0);
 136                     return ret;
 137                 }
 138         }
 139 #endif
 140     }
 141
 142     xhv = (XPVHV*)SvANY(hv);
 143     if (!xhv->xhv_array) {
 144         if (lval
 145 #ifdef DYNAMIC_ENV_FETCH  /* if it's an %ENV lookup, we may get it on the fly */
 146                  || (HvNAME(hv) && strEQ(HvNAME(hv),ENV_HV_NAME))
 147 #endif
 148                                                                   )
 149             Newz(503, xhv->xhv_array,
 150                  PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
 151         else
 152             return 0;
 153     }
 154
 155     PERL_HASH(hash, key, klen);
 156
 157     entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
 158     for (; entry; entry = HeNEXT(entry)) {
 159         if (HeHASH(entry) != hash)              /* strings can't be equal */
 160             continue;
 161         if (HeKLEN(entry) != klen)
 162             continue;
 163         if (memNE(HeKEY(entry),key,klen))       /* is this it? */
 164             continue;
 165         return &HeVAL(entry);
 166     }
 167 #ifdef DYNAMIC_ENV_FETCH  /* %ENV lookup?  If so, try to fetch the value now */
 168     if (HvNAME(hv) && strEQ(HvNAME(hv),ENV_HV_NAME)) {
 169         unsigned long len;
 170         char *env = PerlEnv_ENVgetenv_len(key,&len);
 171         if (env) {
 172             sv = newSVpvn(env,len);
 173             SvTAINTED_on(sv);
 174             return hv_store(hv,key,klen,sv,hash);
 175         }
 176     }
 177 #endif
 178     if (lval) {         /* gonna assign to this, so it better be there */
 179         sv = NEWSV(61,0);
 180         return hv_store(hv,key,klen,sv,hash);
 181     }
 182     return 0;
 183 }
 184
 185 /* returns a HE * structure with the all fields set */
 186 /* note that hent_val will be a mortal sv for MAGICAL hashes */
 187 HE *
 188 Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash)
 189 {
 190     register XPVHV* xhv;
 191     register char *key;
 192     STRLEN klen;
 193     register HE *entry;
 194     SV *sv;
 195
 196     if (!hv)
 197         return 0;
 198
 199     if (SvRMAGICAL(hv)) {
 200         if (mg_find((SV*)hv,'P')) {
 201             dTHR;
 202             sv = sv_newmortal();
 203             keysv = sv_2mortal(newSVsv(keysv));
 204             mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY);
 205             if (!HeKEY_hek(&PL_hv_fetch_ent_mh)) {
 206                 char *k;
 207                 New(54, k, HEK_BASESIZE + sizeof(SV*), char);
 208                 HeKEY_hek(&PL_hv_fetch_ent_mh) = (HEK*)k;
 209             }
 210             HeSVKEY_set(&PL_hv_fetch_ent_mh, keysv);
 211             HeVAL(&PL_hv_fetch_ent_mh) = sv;
 212             return &PL_hv_fetch_ent_mh;
 213         }
 214 #ifdef ENV_IS_CASELESS
 215         else if (mg_find((SV*)hv,'E')) {
 216             U32 i;
 217             key = SvPV(keysv, klen);
 218             for (i = 0; i < klen; ++i)
 219                 if (isLOWER(key[i])) {
 220                     SV *nkeysv = sv_2mortal(newSVpvn(key,klen));
 221                     (void)strupr(SvPVX(nkeysv));
 222                     entry = hv_fetch_ent(hv, nkeysv, 0, 0);
 223                     if (!entry && lval)
 224                         entry = hv_store_ent(hv, keysv, NEWSV(61,0), hash);
 225                     return entry;
 226                 }
 227         }
 228 #endif
 229     }
 230
 231     xhv = (XPVHV*)SvANY(hv);
 232     if (!xhv->xhv_array) {
 233         if (lval
 234 #ifdef DYNAMIC_ENV_FETCH  /* if it's an %ENV lookup, we may get it on the fly */
 235                  || (HvNAME(hv) && strEQ(HvNAME(hv),ENV_HV_NAME))
 236 #endif
 237                                                                   )
 238             Newz(503, xhv->xhv_array,
 239                  PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
 240         else
 241             return 0;
 242     }
 243
 244     key = SvPV(keysv, klen);
 245
 246     if (!hash)
 247         PERL_HASH(hash, key, klen);
 248
 249     entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
 250     for (; entry; entry = HeNEXT(entry)) {
 251         if (HeHASH(entry) != hash)              /* strings can't be equal */
 252             continue;
 253         if (HeKLEN(entry) != klen)
 254             continue;
 255         if (memNE(HeKEY(entry),key,klen))       /* is this it? */
 256             continue;
 257         return entry;
 258     }
 259 #ifdef DYNAMIC_ENV_FETCH  /* %ENV lookup?  If so, try to fetch the value now */
 260     if (HvNAME(hv) && strEQ(HvNAME(hv),ENV_HV_NAME)) {
 261         unsigned long len;
 262         char *env = PerlEnv_ENVgetenv_len(key,&len);
 263         if (env) {
 264             sv = newSVpvn(env,len);
 265             SvTAINTED_on(sv);
 266             return hv_store_ent(hv,keysv,sv,hash);
 267         }
 268     }
 269 #endif
 270     if (lval) {         /* gonna assign to this, so it better be there */
 271         sv = NEWSV(61,0);
 272         return hv_store_ent(hv,keysv,sv,hash);
 273     }
 274     return 0;
 275 }
 276
 277 STATIC void
 278 S_hv_magic_check(pTHX_ HV *hv, bool *needs_copy, bool *needs_store)
 279 {
 280     MAGIC *mg = SvMAGIC(hv);
 281     *needs_copy = FALSE;
 282     *needs_store = TRUE;
 283     while (mg) {
 284         if (isUPPER(mg->mg_type)) {
 285             *needs_copy = TRUE;
 286             switch (mg->mg_type) {
 287             case 'P':
 288             case 'S':
 289                 *needs_store = FALSE;
 290             }
 291         }
 292         mg = mg->mg_moremagic;
 293     }
 294 }
 295
 296 SV**
 297 Perl_hv_store(pTHX_ HV *hv, const char *key, U32 klen, SV *val, register U32 hash)
 298 {
 299     register XPVHV* xhv;
 300     register I32 i;
 301     register HE *entry;
 302     register HE **oentry;
 303
 304     if (!hv)
 305         return 0;
 306
 307     xhv = (XPVHV*)SvANY(hv);
 308     if (SvMAGICAL(hv)) {
 309         bool needs_copy;
 310         bool needs_store;
 311         hv_magic_check (hv, &needs_copy, &needs_store);
 312         if (needs_copy) {
 313             mg_copy((SV*)hv, val, key, klen);
 314             if (!xhv->xhv_array && !needs_store)
 315                 return 0;
 316 #ifdef ENV_IS_CASELESS
 317             else if (mg_find((SV*)hv,'E')) {
 318                 SV *sv = sv_2mortal(newSVpvn(key,klen));
 319                 key = strupr(SvPVX(sv));
 320                 hash = 0;
 321             }
 322 #endif
 323         }
 324     }
 325     if (!hash)
 326         PERL_HASH(hash, key, klen);
 327
 328     if (!xhv->xhv_array)
 329         Newz(505, xhv->xhv_array,
 330              PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
 331
 332     oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
 333     i = 1;
 334
 335     for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
 336         if (HeHASH(entry) != hash)              /* strings can't be equal */
 337             continue;
 338         if (HeKLEN(entry) != klen)
 339             continue;
 340         if (memNE(HeKEY(entry),key,klen))       /* is this it? */
 341             continue;
 342         SvREFCNT_dec(HeVAL(entry));
 343         HeVAL(entry) = val;
 344         return &HeVAL(entry);
 345     }
 346
 347     entry = new_he();
 348     if (HvSHAREKEYS(hv))
 349         HeKEY_hek(entry) = share_hek(key, klen, hash);
 350     else                                       /* gotta do the real thing */
 351         HeKEY_hek(entry) = save_hek(key, klen, hash);
 352     HeVAL(entry) = val;
 353     HeNEXT(entry) = *oentry;
 354     *oentry = entry;
 355
 356     xhv->xhv_keys++;
 357     if (i) {                            /* initial entry? */
 358         ++xhv->xhv_fill;
 359         if (xhv->xhv_keys > xhv->xhv_max)
 360             hsplit(hv);
 361     }
 362
 363     return &HeVAL(entry);
 364 }
 365
 366 HE *
 367 Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, register U32 hash)
 368 {
 369     register XPVHV* xhv;
 370     register char *key;
 371     STRLEN klen;
 372     register I32 i;
 373     register HE *entry;
 374     register HE **oentry;
 375
 376     if (!hv)
 377         return 0;
 378
 379     xhv = (XPVHV*)SvANY(hv);
 380     if (SvMAGICAL(hv)) {
 381         dTHR;
 382         bool needs_copy;
 383         bool needs_store;
 384         hv_magic_check (hv, &needs_copy, &needs_store);
 385         if (needs_copy) {
 386             bool save_taint = PL_tainted;
 387             if (PL_tainting)
 388                 PL_tainted = SvTAINTED(keysv);
 389             keysv = sv_2mortal(newSVsv(keysv));
 390             mg_copy((SV*)hv, val, (char*)keysv, HEf_SVKEY);
 391             TAINT_IF(save_taint);
 392             if (!xhv->xhv_array && !needs_store)
 393                 return Nullhe;
 394 #ifdef ENV_IS_CASELESS
 395             else if (mg_find((SV*)hv,'E')) {
 396                 key = SvPV(keysv, klen);
 397                 keysv = sv_2mortal(newSVpvn(key,klen));
 398                 (void)strupr(SvPVX(keysv));
 399                 hash = 0;
 400             }
 401 #endif
 402         }
 403     }
 404
 405     key = SvPV(keysv, klen);
 406
 407     if (!hash)
 408         PERL_HASH(hash, key, klen);
 409
 410     if (!xhv->xhv_array)
 411         Newz(505, xhv->xhv_array,
 412              PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
 413
 414     oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
 415     i = 1;
 416
 417     for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
 418         if (HeHASH(entry) != hash)              /* strings can't be equal */
 419             continue;
 420         if (HeKLEN(entry) != klen)
 421             continue;
 422         if (memNE(HeKEY(entry),key,klen))       /* is this it? */
 423             continue;
 424         SvREFCNT_dec(HeVAL(entry));
 425         HeVAL(entry) = val;
 426         return entry;
 427     }
 428
 429     entry = new_he();
 430     if (HvSHAREKEYS(hv))
 431         HeKEY_hek(entry) = share_hek(key, klen, hash);
 432     else                                       /* gotta do the real thing */
 433         HeKEY_hek(entry) = save_hek(key, klen, hash);
 434     HeVAL(entry) = val;
 435     HeNEXT(entry) = *oentry;
 436     *oentry = entry;
 437
 438     xhv->xhv_keys++;
 439     if (i) {                            /* initial entry? */
 440         ++xhv->xhv_fill;
 441         if (xhv->xhv_keys > xhv->xhv_max)
 442             hsplit(hv);
 443     }
 444
 445     return entry;
 446 }
 447
 448 SV *
 449 Perl_hv_delete(pTHX_ HV *hv, const char *key, U32 klen, I32 flags)
 450 {
 451     register XPVHV* xhv;
 452     register I32 i;
 453     register U32 hash;
 454     register HE *entry;
 455     register HE **oentry;
 456     SV **svp;
 457     SV *sv;
 458
 459     if (!hv)
 460         return Nullsv;
 461     if (SvRMAGICAL(hv)) {
 462         bool needs_copy;
 463         bool needs_store;
 464         hv_magic_check (hv, &needs_copy, &needs_store);
 465
 466         if (needs_copy && (svp = hv_fetch(hv, key, klen, TRUE))) {
 467             sv = *svp;
 468             mg_clear(sv);
 469             if (!needs_store) {
 470                 if (mg_find(sv, 'p')) {
 471                     sv_unmagic(sv, 'p');        /* No longer an element */
 472                     return sv;
 473                 }
 474                 return Nullsv;          /* element cannot be deleted */
 475             }
 476 #ifdef ENV_IS_CASELESS
 477             else if (mg_find((SV*)hv,'E')) {
 478                 sv = sv_2mortal(newSVpvn(key,klen));
 479                 key = strupr(SvPVX(sv));
 480             }
 481 #endif
 482         }
 483     }
 484     xhv = (XPVHV*)SvANY(hv);
 485     if (!xhv->xhv_array)
 486         return Nullsv;
 487
 488     PERL_HASH(hash, key, klen);
 489
 490     oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
 491     entry = *oentry;
 492     i = 1;
 493     for (; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
 494         if (HeHASH(entry) != hash)              /* strings can't be equal */
 495             continue;
 496         if (HeKLEN(entry) != klen)
 497             continue;
 498         if (memNE(HeKEY(entry),key,klen))       /* is this it? */
 499             continue;
 500         *oentry = HeNEXT(entry);
 501         if (i && !*oentry)
 502             xhv->xhv_fill--;
 503         if (flags & G_DISCARD)
 504             sv = Nullsv;
 505         else
 506             sv = sv_mortalcopy(HeVAL(entry));
 507         if (entry == xhv->xhv_eiter)
 508             HvLAZYDEL_on(hv);
 509         else
 510             hv_free_ent(hv, entry);
 511         --xhv->xhv_keys;
 512         return sv;
 513     }
 514     return Nullsv;
 515 }
 516
 517 SV *
 518 Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash)
 519 {
 520     register XPVHV* xhv;
 521     register I32 i;
 522     register char *key;
 523     STRLEN klen;
 524     register HE *entry;
 525     register HE **oentry;
 526     SV *sv;
 527
 528     if (!hv)
 529         return Nullsv;
 530     if (SvRMAGICAL(hv)) {
 531         bool needs_copy;
 532         bool needs_store;
 533         hv_magic_check (hv, &needs_copy, &needs_store);
 534
 535         if (needs_copy && (entry = hv_fetch_ent(hv, keysv, TRUE, hash))) {
 536             sv = HeVAL(entry);
 537             mg_clear(sv);
 538             if (!needs_store) {
 539                 if (mg_find(sv, 'p')) {
 540                     sv_unmagic(sv, 'p');        /* No longer an element */
 541                     return sv;
 542                 }
 543                 return Nullsv;          /* element cannot be deleted */
 544             }
 545 #ifdef ENV_IS_CASELESS
 546             else if (mg_find((SV*)hv,'E')) {
 547                 key = SvPV(keysv, klen);
 548                 keysv = sv_2mortal(newSVpvn(key,klen));
 549                 (void)strupr(SvPVX(keysv));
 550                 hash = 0;
 551             }
 552 #endif
 553         }
 554     }
 555     xhv = (XPVHV*)SvANY(hv);
 556     if (!xhv->xhv_array)
 557         return Nullsv;
 558
 559     key = SvPV(keysv, klen);
 560
 561     if (!hash)
 562         PERL_HASH(hash, key, klen);
 563
 564     oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
 565     entry = *oentry;
 566     i = 1;
 567     for (; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
 568         if (HeHASH(entry) != hash)              /* strings can't be equal */
 569             continue;
 570         if (HeKLEN(entry) != klen)
 571             continue;
 572         if (memNE(HeKEY(entry),key,klen))       /* is this it? */
 573             continue;
 574         *oentry = HeNEXT(entry);
 575         if (i && !*oentry)
 576             xhv->xhv_fill--;
 577         if (flags & G_DISCARD)
 578             sv = Nullsv;
 579         else
 580             sv = sv_mortalcopy(HeVAL(entry));
 581         if (entry == xhv->xhv_eiter)
 582             HvLAZYDEL_on(hv);
 583         else
 584             hv_free_ent(hv, entry);
 585         --xhv->xhv_keys;
 586         return sv;
 587     }
 588     return Nullsv;
 589 }
 590
 591 bool
 592 Perl_hv_exists(pTHX_ HV *hv, const char *key, U32 klen)
 593 {
 594     register XPVHV* xhv;
 595     register U32 hash;
 596     register HE *entry;
 597     SV *sv;
 598
 599     if (!hv)
 600         return 0;
 601
 602     if (SvRMAGICAL(hv)) {
 603         if (mg_find((SV*)hv,'P')) {
 604             dTHR;
 605             sv = sv_newmortal();
 606             mg_copy((SV*)hv, sv, key, klen);
 607             magic_existspack(sv, mg_find(sv, 'p'));
 608             return SvTRUE(sv);
 609         }
 610 #ifdef ENV_IS_CASELESS
 611         else if (mg_find((SV*)hv,'E')) {
 612             sv = sv_2mortal(newSVpvn(key,klen));
 613             key = strupr(SvPVX(sv));
 614         }
 615 #endif
 616     }
 617
 618     xhv = (XPVHV*)SvANY(hv);
 619 #ifndef DYNAMIC_ENV_FETCH
 620     if (!xhv->xhv_array)
 621         return 0;
 622 #endif
 623
 624     PERL_HASH(hash, key, klen);
 625
 626 #ifdef DYNAMIC_ENV_FETCH
 627     if (!xhv->xhv_array) entry = Null(HE*);
 628     else
 629 #endif
 630     entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
 631     for (; entry; entry = HeNEXT(entry)) {
 632         if (HeHASH(entry) != hash)              /* strings can't be equal */
 633             continue;
 634         if (HeKLEN(entry) != klen)
 635             continue;
 636         if (memNE(HeKEY(entry),key,klen))       /* is this it? */
 637             continue;
 638         return TRUE;
 639     }
 640 #ifdef DYNAMIC_ENV_FETCH  /* is it out there? */
 641     if (HvNAME(hv) && strEQ(HvNAME(hv), ENV_HV_NAME)) {
 642         unsigned long len;
 643         char *env = PerlEnv_ENVgetenv_len(key,&len);
 644         if (env) {
 645             sv = newSVpvn(env,len);
 646             SvTAINTED_on(sv);
 647             (void)hv_store(hv,key,klen,sv,hash);
 648             return TRUE;
 649         }
 650     }
 651 #endif
 652     return FALSE;
 653 }
 654
 655
 656 bool
 657 Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash)
 658 {
 659     register XPVHV* xhv;
 660     register char *key;
 661     STRLEN klen;
 662     register HE *entry;
 663     SV *sv;
 664
 665     if (!hv)
 666         return 0;
 667
 668     if (SvRMAGICAL(hv)) {
 669         if (mg_find((SV*)hv,'P')) {
 670             dTHR;               /* just for SvTRUE */
 671             sv = sv_newmortal();
 672             keysv = sv_2mortal(newSVsv(keysv));
 673             mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY);
 674             magic_existspack(sv, mg_find(sv, 'p'));
 675             return SvTRUE(sv);
 676         }
 677 #ifdef ENV_IS_CASELESS
 678         else if (mg_find((SV*)hv,'E')) {
 679             key = SvPV(keysv, klen);
 680             keysv = sv_2mortal(newSVpvn(key,klen));
 681             (void)strupr(SvPVX(keysv));
 682             hash = 0;
 683         }
 684 #endif
 685     }
 686
 687     xhv = (XPVHV*)SvANY(hv);
 688 #ifndef DYNAMIC_ENV_FETCH
 689     if (!xhv->xhv_array)
 690         return 0;
 691 #endif
 692
 693     key = SvPV(keysv, klen);
 694     if (!hash)
 695         PERL_HASH(hash, key, klen);
 696
 697 #ifdef DYNAMIC_ENV_FETCH
 698     if (!xhv->xhv_array) entry = Null(HE*);
 699     else
 700 #endif
 701     entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
 702     for (; entry; entry = HeNEXT(entry)) {
 703         if (HeHASH(entry) != hash)              /* strings can't be equal */
 704             continue;
 705         if (HeKLEN(entry) != klen)
 706             continue;
 707         if (memNE(HeKEY(entry),key,klen))       /* is this it? */
 708             continue;
 709         return TRUE;
 710     }
 711 #ifdef DYNAMIC_ENV_FETCH  /* is it out there? */
 712     if (HvNAME(hv) && strEQ(HvNAME(hv), ENV_HV_NAME)) {
 713         unsigned long len;
 714         char *env = PerlEnv_ENVgetenv_len(key,&len);
 715         if (env) {
 716             sv = newSVpvn(env,len);
 717             SvTAINTED_on(sv);
 718             (void)hv_store_ent(hv,keysv,sv,hash);
 719             return TRUE;
 720         }
 721     }
 722 #endif
 723     return FALSE;
 724 }
 725
 726 STATIC void
 727 S_hsplit(pTHX_ HV *hv)
 728 {
 729     register XPVHV* xhv = (XPVHV*)SvANY(hv);
 730     I32 oldsize = (I32) xhv->xhv_max + 1; /* sic(k) */
 731     register I32 newsize = oldsize * 2;
 732     register I32 i;
 733     register char *a = xhv->xhv_array;
 734     register HE **aep;
 735     register HE **bep;
 736     register HE *entry;
 737     register HE **oentry;
 738
 739     PL_nomemok = TRUE;
 740 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
 741     Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
 742     if (!a) {
 743       PL_nomemok = FALSE;
 744       return;
 745     }
 746 #else
 747 #define MALLOC_OVERHEAD 16
 748     New(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
 749     if (!a) {
 750       PL_nomemok = FALSE;
 751       return;
 752     }
 753     Copy(xhv->xhv_array, a, oldsize * sizeof(HE*), char);
 754     if (oldsize >= 64) {
 755         offer_nice_chunk(xhv->xhv_array, PERL_HV_ARRAY_ALLOC_BYTES(oldsize));
 756     }
 757     else
 758         Safefree(xhv->xhv_array);
 759 #endif
 760
 761     PL_nomemok = FALSE;
 762     Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char);     /* zero 2nd half*/
 763     xhv->xhv_max = --newsize;
 764     xhv->xhv_array = a;
 765     aep = (HE**)a;
 766
 767     for (i=0; i<oldsize; i++,aep++) {
 768         if (!*aep)                              /* non-existent */
 769             continue;
 770         bep = aep+oldsize;
 771         for (oentry = aep, entry = *aep; entry; entry = *oentry) {
 772             if ((HeHASH(entry) & newsize) != i) {
 773                 *oentry = HeNEXT(entry);
 774                 HeNEXT(entry) = *bep;
 775                 if (!*bep)
 776                     xhv->xhv_fill++;
 777                 *bep = entry;
 778                 continue;
 779             }
 780             else
 781                 oentry = &HeNEXT(entry);
 782         }
 783         if (!*aep)                              /* everything moved */
 784             xhv->xhv_fill--;
 785     }
 786 }
 787
 788 void
 789 Perl_hv_ksplit(pTHX_ HV *hv, IV newmax)
 790 {
 791     register XPVHV* xhv = (XPVHV*)SvANY(hv);
 792     I32 oldsize = (I32) xhv->xhv_max + 1; /* sic(k) */
 793     register I32 newsize;
 794     register I32 i;
 795     register I32 j;
 796     register char *a;
 797     register HE **aep;
 798     register HE *entry;
 799     register HE **oentry;
 800
 801     newsize = (I32) newmax;                     /* possible truncation here */
 802     if (newsize != newmax || newmax <= oldsize)
 803         return;
 804     while ((newsize & (1 + ~newsize)) != newsize) {
 805         newsize &= ~(newsize & (1 + ~newsize)); /* get proper power of 2 */
 806     }
 807     if (newsize < newmax)
 808         newsize *= 2;
 809     if (newsize < newmax)
 810         return;                                 /* overflow detection */
 811
 812     a = xhv->xhv_array;
 813     if (a) {
 814         PL_nomemok = TRUE;
 815 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
 816         Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
 817         if (!a) {
 818           PL_nomemok = FALSE;
 819           return;
 820         }
 821 #else
 822         New(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
 823         if (!a) {
 824           PL_nomemok = FALSE;
 825           return;
 826         }
 827         Copy(xhv->xhv_array, a, oldsize * sizeof(HE*), char);
 828         if (oldsize >= 64) {
 829             offer_nice_chunk(xhv->xhv_array, PERL_HV_ARRAY_ALLOC_BYTES(oldsize));
 830         }
 831         else
 832             Safefree(xhv->xhv_array);
 833 #endif
 834         PL_nomemok = FALSE;
 835         Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
 836     }
 837     else {
 838         Newz(0, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
 839     }
 840     xhv->xhv_max = --newsize;
 841     xhv->xhv_array = a;
 842     if (!xhv->xhv_fill)                         /* skip rest if no entries */
 843         return;
 844
 845     aep = (HE**)a;
 846     for (i=0; i<oldsize; i++,aep++) {
 847         if (!*aep)                              /* non-existent */
 848             continue;
 849         for (oentry = aep, entry = *aep; entry; entry = *oentry) {
 850             if ((j = (HeHASH(entry) & newsize)) != i) {
 851                 j -= i;
 852                 *oentry = HeNEXT(entry);
 853                 if (!(HeNEXT(entry) = aep[j]))
 854                     xhv->xhv_fill++;
 855                 aep[j] = entry;
 856                 continue;
 857             }
 858             else
 859                 oentry = &HeNEXT(entry);
 860         }
 861         if (!*aep)                              /* everything moved */
 862             xhv->xhv_fill--;
 863     }
 864 }
 865
 866 HV *
 867 Perl_newHV(pTHX)
 868 {
 869     register HV *hv;
 870     register XPVHV* xhv;
 871
 872     hv = (HV*)NEWSV(502,0);
 873     sv_upgrade((SV *)hv, SVt_PVHV);
 874     xhv = (XPVHV*)SvANY(hv);
 875     SvPOK_off(hv);
 876     SvNOK_off(hv);
 877 #ifndef NODEFAULT_SHAREKEYS
 878     HvSHAREKEYS_on(hv);         /* key-sharing on by default */
 879 #endif
 880     xhv->xhv_max = 7;           /* start with 8 buckets */
 881     xhv->xhv_fill = 0;
 882     xhv->xhv_pmroot = 0;
 883     (void)hv_iterinit(hv);      /* so each() will start off right */
 884     return hv;
 885 }
 886
 887 HV *
 888 Perl_newHVhv(pTHX_ HV *ohv)
 889 {
 890     register HV *hv;
 891     STRLEN hv_max = ohv ? HvMAX(ohv) : 0;
 892     STRLEN hv_fill = ohv ? HvFILL(ohv) : 0;
 893
 894     hv = newHV();
 895     while (hv_max && hv_max + 1 >= hv_fill * 2)
 896         hv_max = hv_max / 2;    /* Is always 2^n-1 */
 897     HvMAX(hv) = hv_max;
 898     if (!hv_fill)
 899         return hv;
 900
 901 #if 0
 902     if (! SvTIED_mg((SV*)ohv, 'P')) {
 903         /* Quick way ???*/
 904     }
 905     else
 906 #endif
 907     {
 908         HE *entry;
 909         I32 hv_riter = HvRITER(ohv);    /* current root of iterator */
 910         HE *hv_eiter = HvEITER(ohv);    /* current entry of iterator */
 911
 912         /* Slow way */
 913         hv_iterinit(ohv);
 914         while (entry = hv_iternext(ohv)) {
 915             hv_store(hv, HeKEY(entry), HeKLEN(entry),
 916                      SvREFCNT_inc(HeVAL(entry)), HeHASH(entry));
 917         }
 918         HvRITER(ohv) = hv_riter;
 919         HvEITER(ohv) = hv_eiter;
 920     }
 921
 922     return hv;
 923 }
 924
 925 void
 926 Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry)
 927 {
 928     SV *val;
 929
 930     if (!entry)
 931         return;
 932     val = HeVAL(entry);
 933     if (val && isGV(val) && GvCVu(val) && HvNAME(hv))
 934         PL_sub_generation++;    /* may be deletion of method from stash */
 935     SvREFCNT_dec(val);
 936     if (HeKLEN(entry) == HEf_SVKEY) {
 937         SvREFCNT_dec(HeKEY_sv(entry));
 938         Safefree(HeKEY_hek(entry));
 939     }
 940     else if (HvSHAREKEYS(hv))
 941         unshare_hek(HeKEY_hek(entry));
 942     else
 943         Safefree(HeKEY_hek(entry));
 944     del_he(entry);
 945 }
 946
 947 void
 948 Perl_hv_delayfree_ent(pTHX_ HV *hv, register HE *entry)
 949 {
 950     if (!entry)
 951         return;
 952     if (isGV(HeVAL(entry)) && GvCVu(HeVAL(entry)) && HvNAME(hv))
 953         PL_sub_generation++;    /* may be deletion of method from stash */
 954     sv_2mortal(HeVAL(entry));   /* free between statements */
 955     if (HeKLEN(entry) == HEf_SVKEY) {
 956         sv_2mortal(HeKEY_sv(entry));
 957         Safefree(HeKEY_hek(entry));
 958     }
 959     else if (HvSHAREKEYS(hv))
 960         unshare_hek(HeKEY_hek(entry));
 961     else
 962         Safefree(HeKEY_hek(entry));
 963     del_he(entry);
 964 }
 965
 966 void
 967 Perl_hv_clear(pTHX_ HV *hv)
 968 {
 969     register XPVHV* xhv;
 970     if (!hv)
 971         return;
 972     xhv = (XPVHV*)SvANY(hv);
 973     hfreeentries(hv);
 974     xhv->xhv_fill = 0;
 975     xhv->xhv_keys = 0;
 976     if (xhv->xhv_array)
 977         (void)memzero(xhv->xhv_array, (xhv->xhv_max + 1) * sizeof(HE*));
 978
 979     if (SvRMAGICAL(hv))
 980         mg_clear((SV*)hv);
 981 }
 982
 983 STATIC void
 984 S_hfreeentries(pTHX_ HV *hv)
 985 {
 986     register HE **array;
 987     register HE *entry;
 988     register HE *oentry = Null(HE*);
 989     I32 riter;
 990     I32 max;
 991
 992     if (!hv)
 993         return;
 994     if (!HvARRAY(hv))
 995         return;
 996
 997     riter = 0;
 998     max = HvMAX(hv);
 999     array = HvARRAY(hv);
1000     entry = array[0];
1001     for (;;) {
1002         if (entry) {
1003             oentry = entry;
1004             entry = HeNEXT(entry);
1005             hv_free_ent(hv, oentry);
1006         }
1007         if (!entry) {
1008             if (++riter > max)
1009                 break;
1010             entry = array[riter];
1011         }
1012     }
1013     (void)hv_iterinit(hv);
1014 }
1015
1016 void
1017 Perl_hv_undef(pTHX_ HV *hv)
1018 {
1019     register XPVHV* xhv;
1020     if (!hv)
1021         return;
1022     xhv = (XPVHV*)SvANY(hv);
1023     hfreeentries(hv);
1024     Safefree(xhv->xhv_array);
1025     if (HvNAME(hv)) {
1026         Safefree(HvNAME(hv));
1027         HvNAME(hv) = 0;
1028     }
1029     xhv->xhv_array = 0;
1030     xhv->xhv_max = 7;           /* it's a normal hash */
1031     xhv->xhv_fill = 0;
1032     xhv->xhv_keys = 0;
1033
1034     if (SvRMAGICAL(hv))
1035         mg_clear((SV*)hv);
1036 }
1037
1038 I32
1039 Perl_hv_iterinit(pTHX_ HV *hv)
1040 {
1041     register XPVHV* xhv;
1042     HE *entry;
1043
1044     if (!hv)
1045         Perl_croak(aTHX_ "Bad hash");
1046     xhv = (XPVHV*)SvANY(hv);
1047     entry = xhv->xhv_eiter;
1048     if (entry && HvLAZYDEL(hv)) {       /* was deleted earlier? */
1049         HvLAZYDEL_off(hv);
1050         hv_free_ent(hv, entry);
1051     }
1052     xhv->xhv_riter = -1;
1053     xhv->xhv_eiter = Null(HE*);
1054     return xhv->xhv_keys;       /* used to be xhv->xhv_fill before 5.004_65 */
1055 }
1056
1057 HE *
1058 Perl_hv_iternext(pTHX_ HV *hv)
1059 {
1060     register XPVHV* xhv;
1061     register HE *entry;
1062     HE *oldentry;
1063     MAGIC* mg;
1064
1065     if (!hv)
1066         Perl_croak(aTHX_ "Bad hash");
1067     xhv = (XPVHV*)SvANY(hv);
1068     oldentry = entry = xhv->xhv_eiter;
1069
1070     if (mg = SvTIED_mg((SV*)hv, 'P')) {
1071         SV *key = sv_newmortal();
1072         if (entry) {
1073             sv_setsv(key, HeSVKEY_force(entry));
1074             SvREFCNT_dec(HeSVKEY(entry));       /* get rid of previous key */
1075         }
1076         else {
1077             char *k;
1078             HEK *hek;
1079
1080             xhv->xhv_eiter = entry = new_he();  /* one HE per MAGICAL hash */
1081             Zero(entry, 1, HE);
1082             Newz(54, k, HEK_BASESIZE + sizeof(SV*), char);
1083             hek = (HEK*)k;
1084             HeKEY_hek(entry) = hek;
1085             HeKLEN(entry) = HEf_SVKEY;
1086         }
1087         magic_nextpack((SV*) hv,mg,key);
1088         if (SvOK(key)) {
1089             /* force key to stay around until next time */
1090             HeSVKEY_set(entry, SvREFCNT_inc(key));
1091             return entry;               /* beware, hent_val is not set */
1092         }
1093         if (HeVAL(entry))
1094             SvREFCNT_dec(HeVAL(entry));
1095         Safefree(HeKEY_hek(entry));
1096         del_he(entry);
1097         xhv->xhv_eiter = Null(HE*);
1098         return Null(HE*);
1099     }
1100 #ifdef DYNAMIC_ENV_FETCH  /* set up %ENV for iteration */
1101     if (!entry && HvNAME(hv) && strEQ(HvNAME(hv), ENV_HV_NAME))
1102         prime_env_iter();
1103 #endif
1104
1105     if (!xhv->xhv_array)
1106         Newz(506, xhv->xhv_array,
1107              PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
1108     if (entry)
1109         entry = HeNEXT(entry);
1110     while (!entry) {
1111         ++xhv->xhv_riter;
1112         if (xhv->xhv_riter > xhv->xhv_max) {
1113             xhv->xhv_riter = -1;
1114             break;
1115         }
1116         entry = ((HE**)xhv->xhv_array)[xhv->xhv_riter];
1117     }
1118
1119     if (oldentry && HvLAZYDEL(hv)) {            /* was deleted earlier? */
1120         HvLAZYDEL_off(hv);
1121         hv_free_ent(hv, oldentry);
1122     }
1123
1124     xhv->xhv_eiter = entry;
1125     return entry;
1126 }
1127
1128 char *
1129 Perl_hv_iterkey(pTHX_ register HE *entry, I32 *retlen)
1130 {
1131     if (HeKLEN(entry) == HEf_SVKEY) {
1132         STRLEN len;
1133         char *p = SvPV(HeKEY_sv(entry), len);
1134         *retlen = len;
1135         return p;
1136     }
1137     else {
1138         *retlen = HeKLEN(entry);
1139         return HeKEY(entry);
1140     }
1141 }
1142
1143 /* unlike hv_iterval(), this always returns a mortal copy of the key */
1144 SV *
1145 Perl_hv_iterkeysv(pTHX_ register HE *entry)
1146 {
1147     if (HeKLEN(entry) == HEf_SVKEY)
1148         return sv_mortalcopy(HeKEY_sv(entry));
1149     else
1150         return sv_2mortal(newSVpvn((HeKLEN(entry) ? HeKEY(entry) : ""),
1151                                   HeKLEN(entry)));
1152 }
1153
1154 SV *
1155 Perl_hv_iterval(pTHX_ HV *hv, register HE *entry)
1156 {
1157     if (SvRMAGICAL(hv)) {
1158         if (mg_find((SV*)hv,'P')) {
1159             SV* sv = sv_newmortal();
1160             if (HeKLEN(entry) == HEf_SVKEY)
1161                 mg_copy((SV*)hv, sv, (char*)HeKEY_sv(entry), HEf_SVKEY);
1162             else mg_copy((SV*)hv, sv, HeKEY(entry), HeKLEN(entry));
1163             return sv;
1164         }
1165     }
1166     return HeVAL(entry);
1167 }
1168
1169 SV *
1170 Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen)
1171 {
1172     HE *he;
1173     if ( (he = hv_iternext(hv)) == NULL)
1174         return NULL;
1175     *key = hv_iterkey(he, retlen);
1176     return hv_iterval(hv, he);
1177 }
1178
1179 void
1180 Perl_hv_magic(pTHX_ HV *hv, GV *gv, int how)
1181 {
1182     sv_magic((SV*)hv, (SV*)gv, how, Nullch, 0);
1183 }
1184
1185 char*
1186 Perl_sharepvn(pTHX_ const char *sv, I32 len, U32 hash)
1187 {
1188     return HEK_KEY(share_hek(sv, len, hash));
1189 }
1190
1191 /* possibly free a shared string if no one has access to it
1192  * len and hash must both be valid for str.
1193  */
1194 void
1195 Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
1196 {
1197     register XPVHV* xhv;
1198     register HE *entry;
1199     register HE **oentry;
1200     register I32 i = 1;
1201     I32 found = 0;
1202
1203     /* what follows is the moral equivalent of:
1204     if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) {
1205         if (--*Svp == Nullsv)
1206             hv_delete(PL_strtab, str, len, G_DISCARD, hash);
1207     } */
1208     xhv = (XPVHV*)SvANY(PL_strtab);
1209     /* assert(xhv_array != 0) */
1210     LOCK_STRTAB_MUTEX;
1211     oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
1212     for (entry = *oentry; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
1213         if (HeHASH(entry) != hash)              /* strings can't be equal */
1214             continue;
1215         if (HeKLEN(entry) != len)
1216             continue;
1217         if (memNE(HeKEY(entry),str,len))        /* is this it? */
1218             continue;
1219         found = 1;
1220         if (--HeVAL(entry) == Nullsv) {
1221             *oentry = HeNEXT(entry);
1222             if (i && !*oentry)
1223                 xhv->xhv_fill--;
1224             Safefree(HeKEY_hek(entry));
1225             del_he(entry);
1226             --xhv->xhv_keys;
1227         }
1228         break;
1229     }
1230     UNLOCK_STRTAB_MUTEX;
1231
1232     {
1233         dTHR;
1234         if (!found && ckWARN_d(WARN_INTERNAL))
1235             Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free non-existent shared string");
1236     }
1237 }
1238
1239 /* get a (constant) string ptr from the global string table
1240  * string will get added if it is not already there.
1241  * len and hash must both be valid for str.
1242  */
1243 HEK *
1244 Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash)
1245 {
1246     register XPVHV* xhv;
1247     register HE *entry;
1248     register HE **oentry;
1249     register I32 i = 1;
1250     I32 found = 0;
1251
1252     /* what follows is the moral equivalent of:
1253
1254     if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
1255         hv_store(PL_strtab, str, len, Nullsv, hash);
1256     */
1257     xhv = (XPVHV*)SvANY(PL_strtab);
1258     /* assert(xhv_array != 0) */
1259     LOCK_STRTAB_MUTEX;
1260     oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
1261     for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
1262         if (HeHASH(entry) != hash)              /* strings can't be equal */
1263             continue;
1264         if (HeKLEN(entry) != len)
1265             continue;
1266         if (memNE(HeKEY(entry),str,len))        /* is this it? */
1267             continue;
1268         found = 1;
1269         break;
1270     }
1271     if (!found) {
1272         entry = new_he();
1273         HeKEY_hek(entry) = save_hek(str, len, hash);
1274         HeVAL(entry) = Nullsv;
1275         HeNEXT(entry) = *oentry;
1276         *oentry = entry;
1277         xhv->xhv_keys++;
1278         if (i) {                                /* initial entry? */
1279             ++xhv->xhv_fill;
1280             if (xhv->xhv_keys > xhv->xhv_max)
1281                 hsplit(PL_strtab);
1282         }
1283     }
1284
1285     ++HeVAL(entry);                             /* use value slot as REFCNT */
1286     UNLOCK_STRTAB_MUTEX;
1287     return HeKEY_hek(entry);
1288 }
1289
1290
1291