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