hv.c

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