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