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