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         dTHR;
 298         bool save_taint = tainted;
 299         if (tainting)
 300             tainted = SvTAINTED(keysv);
 301         keysv = sv_2mortal(newSVsv(keysv));
 302         mg_copy((SV*)hv, val, (char*)keysv, HEf_SVKEY);
 303         TAINT_IF(save_taint);
 304         if (!xhv->xhv_array
 305             && (SvMAGIC(hv)->mg_moremagic
 306                 || (SvMAGIC(hv)->mg_type != 'E'
 307 #ifdef OVERLOAD
 308                     && SvMAGIC(hv)->mg_type != 'A'
 309 #endif /* OVERLOAD */
 310                     )))
 311           return Nullhe;
 312     }
 313
 314     key = SvPV(keysv, klen);
 315
 316     if (!hash)
 317         PERL_HASH(hash, key, klen);
 318
 319     if (!xhv->xhv_array)
 320         Newz(505, xhv->xhv_array, sizeof(HE**) * (xhv->xhv_max + 1), char);
 321
 322     oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
 323     i = 1;
 324
 325     for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
 326         if (HeHASH(entry) != hash)              /* strings can't be equal */
 327             continue;
 328         if (HeKLEN(entry) != klen)
 329             continue;
 330         if (memNE(HeKEY(entry),key,klen))       /* is this it? */
 331             continue;
 332         SvREFCNT_dec(HeVAL(entry));
 333         HeVAL(entry) = val;
 334         return entry;
 335     }
 336
 337     entry = new_he();
 338     if (HvSHAREKEYS(hv))
 339         HeKEY_hek(entry) = share_hek(key, klen, hash);
 340     else                                       /* gotta do the real thing */
 341         HeKEY_hek(entry) = save_hek(key, klen, hash);
 342     HeVAL(entry) = val;
 343     HeNEXT(entry) = *oentry;
 344     *oentry = entry;
 345
 346     xhv->xhv_keys++;
 347     if (i) {                            /* initial entry? */
 348         ++xhv->xhv_fill;
 349         if (xhv->xhv_keys > xhv->xhv_max)
 350             hsplit(hv);
 351     }
 352
 353     return entry;
 354 }
 355
 356 SV *
 357 hv_delete(HV *hv, char *key, U32 klen, I32 flags)
 358 {
 359     register XPVHV* xhv;
 360     register I32 i;
 361     register U32 hash;
 362     register HE *entry;
 363     register HE **oentry;
 364     SV *sv;
 365
 366     if (!hv)
 367         return Nullsv;
 368     if (SvRMAGICAL(hv)) {
 369         sv = *hv_fetch(hv, key, klen, TRUE);
 370         mg_clear(sv);
 371         if (mg_find(sv, 's')) {
 372             return Nullsv;              /* %SIG elements cannot be deleted */
 373         }
 374         if (mg_find(sv, 'p')) {
 375             sv_unmagic(sv, 'p');        /* No longer an element */
 376             return sv;
 377         }
 378     }
 379     xhv = (XPVHV*)SvANY(hv);
 380     if (!xhv->xhv_array)
 381         return Nullsv;
 382
 383     PERL_HASH(hash, key, klen);
 384
 385     oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
 386     entry = *oentry;
 387     i = 1;
 388     for (; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
 389         if (HeHASH(entry) != hash)              /* strings can't be equal */
 390             continue;
 391         if (HeKLEN(entry) != klen)
 392             continue;
 393         if (memNE(HeKEY(entry),key,klen))       /* is this it? */
 394             continue;
 395         *oentry = HeNEXT(entry);
 396         if (i && !*oentry)
 397             xhv->xhv_fill--;
 398         if (flags & G_DISCARD)
 399             sv = Nullsv;
 400         else
 401             sv = sv_mortalcopy(HeVAL(entry));
 402         if (entry == xhv->xhv_eiter)
 403             HvLAZYDEL_on(hv);
 404         else
 405             hv_free_ent(hv, entry);
 406         --xhv->xhv_keys;
 407         return sv;
 408     }
 409     return Nullsv;
 410 }
 411
 412 SV *
 413 hv_delete_ent(HV *hv, SV *keysv, I32 flags, U32 hash)
 414 {
 415     register XPVHV* xhv;
 416     register I32 i;
 417     register char *key;
 418     STRLEN klen;
 419     register HE *entry;
 420     register HE **oentry;
 421     SV *sv;
 422
 423     if (!hv)
 424         return Nullsv;
 425     if (SvRMAGICAL(hv)) {
 426         entry = hv_fetch_ent(hv, keysv, TRUE, hash);
 427         sv = HeVAL(entry);
 428         mg_clear(sv);
 429         if (mg_find(sv, 'p')) {
 430             sv_unmagic(sv, 'p');        /* No longer an element */
 431             return sv;
 432         }
 433     }
 434     xhv = (XPVHV*)SvANY(hv);
 435     if (!xhv->xhv_array)
 436         return Nullsv;
 437
 438     key = SvPV(keysv, klen);
 439
 440     if (!hash)
 441         PERL_HASH(hash, key, klen);
 442
 443     oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
 444     entry = *oentry;
 445     i = 1;
 446     for (; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
 447         if (HeHASH(entry) != hash)              /* strings can't be equal */
 448             continue;
 449         if (HeKLEN(entry) != klen)
 450             continue;
 451         if (memNE(HeKEY(entry),key,klen))       /* is this it? */
 452             continue;
 453         *oentry = HeNEXT(entry);
 454         if (i && !*oentry)
 455             xhv->xhv_fill--;
 456         if (flags & G_DISCARD)
 457             sv = Nullsv;
 458         else
 459             sv = sv_mortalcopy(HeVAL(entry));
 460         if (entry == xhv->xhv_eiter)
 461             HvLAZYDEL_on(hv);
 462         else
 463             hv_free_ent(hv, entry);
 464         --xhv->xhv_keys;
 465         return sv;
 466     }
 467     return Nullsv;
 468 }
 469
 470 bool
 471 hv_exists(HV *hv, char *key, U32 klen)
 472 {
 473     register XPVHV* xhv;
 474     register U32 hash;
 475     register HE *entry;
 476     SV *sv;
 477
 478     if (!hv)
 479         return 0;
 480
 481     if (SvRMAGICAL(hv)) {
 482         if (mg_find((SV*)hv,'P')) {
 483             dTHR;
 484             sv = sv_newmortal();
 485             mg_copy((SV*)hv, sv, key, klen);
 486             magic_existspack(sv, mg_find(sv, 'p'));
 487             return SvTRUE(sv);
 488         }
 489     }
 490
 491     xhv = (XPVHV*)SvANY(hv);
 492     if (!xhv->xhv_array)
 493         return 0;
 494
 495     PERL_HASH(hash, key, klen);
 496
 497     entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
 498     for (; entry; entry = HeNEXT(entry)) {
 499         if (HeHASH(entry) != hash)              /* strings can't be equal */
 500             continue;
 501         if (HeKLEN(entry) != klen)
 502             continue;
 503         if (memNE(HeKEY(entry),key,klen))       /* is this it? */
 504             continue;
 505         return TRUE;
 506     }
 507     return FALSE;
 508 }
 509
 510
 511 bool
 512 hv_exists_ent(HV *hv, SV *keysv, U32 hash)
 513 {
 514     register XPVHV* xhv;
 515     register char *key;
 516     STRLEN klen;
 517     register HE *entry;
 518     SV *sv;
 519
 520     if (!hv)
 521         return 0;
 522
 523     if (SvRMAGICAL(hv)) {
 524         if (mg_find((SV*)hv,'P')) {
 525             dTHR;               /* just for SvTRUE */
 526             sv = sv_newmortal();
 527             keysv = sv_2mortal(newSVsv(keysv));
 528             mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY);
 529             magic_existspack(sv, mg_find(sv, 'p'));
 530             return SvTRUE(sv);
 531         }
 532     }
 533
 534     xhv = (XPVHV*)SvANY(hv);
 535     if (!xhv->xhv_array)
 536         return 0;
 537
 538     key = SvPV(keysv, klen);
 539     if (!hash)
 540         PERL_HASH(hash, key, klen);
 541
 542     entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
 543     for (; entry; entry = HeNEXT(entry)) {
 544         if (HeHASH(entry) != hash)              /* strings can't be equal */
 545             continue;
 546         if (HeKLEN(entry) != klen)
 547             continue;
 548         if (memNE(HeKEY(entry),key,klen))       /* is this it? */
 549             continue;
 550         return TRUE;
 551     }
 552     return FALSE;
 553 }
 554
 555 static void
 556 hsplit(HV *hv)
 557 {
 558     register XPVHV* xhv = (XPVHV*)SvANY(hv);
 559     I32 oldsize = (I32) xhv->xhv_max + 1; /* sic(k) */
 560     register I32 newsize = oldsize * 2;
 561     register I32 i;
 562     register HE **a;
 563     register HE **b;
 564     register HE *entry;
 565     register HE **oentry;
 566 #ifndef STRANGE_MALLOC
 567     I32 tmp;
 568 #endif
 569
 570     a = (HE**)xhv->xhv_array;
 571     nomemok = TRUE;
 572 #ifdef STRANGE_MALLOC
 573     Renew(a, newsize, HE*);
 574 #else
 575     i = newsize * sizeof(HE*);
 576 #define MALLOC_OVERHEAD 16
 577     tmp = MALLOC_OVERHEAD;
 578     while (tmp - MALLOC_OVERHEAD < i)
 579         tmp += tmp;
 580     tmp -= MALLOC_OVERHEAD;
 581     tmp /= sizeof(HE*);
 582     assert(tmp >= newsize);
 583     New(2,a, tmp, HE*);
 584     Copy(xhv->xhv_array, a, oldsize, HE*);
 585     if (oldsize >= 64) {
 586         offer_nice_chunk(xhv->xhv_array,
 587                          oldsize * sizeof(HE*) * 2 - MALLOC_OVERHEAD);
 588     }
 589     else
 590         Safefree(xhv->xhv_array);
 591 #endif
 592
 593     nomemok = FALSE;
 594     Zero(&a[oldsize], oldsize, HE*);            /* zero 2nd half*/
 595     xhv->xhv_max = --newsize;
 596     xhv->xhv_array = (char*)a;
 597
 598     for (i=0; i<oldsize; i++,a++) {
 599         if (!*a)                                /* non-existent */
 600             continue;
 601         b = a+oldsize;
 602         for (oentry = a, entry = *a; entry; entry = *oentry) {
 603             if ((HeHASH(entry) & newsize) != i) {
 604                 *oentry = HeNEXT(entry);
 605                 HeNEXT(entry) = *b;
 606                 if (!*b)
 607                     xhv->xhv_fill++;
 608                 *b = entry;
 609                 continue;
 610             }
 611             else
 612                 oentry = &HeNEXT(entry);
 613         }
 614         if (!*a)                                /* everything moved */
 615             xhv->xhv_fill--;
 616     }
 617 }
 618
 619 void
 620 hv_ksplit(HV *hv, IV newmax)
 621 {
 622     register XPVHV* xhv = (XPVHV*)SvANY(hv);
 623     I32 oldsize = (I32) xhv->xhv_max + 1; /* sic(k) */
 624     register I32 newsize;
 625     register I32 i;
 626     register I32 j;
 627     register HE **a;
 628     register HE *entry;
 629     register HE **oentry;
 630
 631     newsize = (I32) newmax;                     /* possible truncation here */
 632     if (newsize != newmax || newmax <= oldsize)
 633         return;
 634     while ((newsize & (1 + ~newsize)) != newsize) {
 635         newsize &= ~(newsize & (1 + ~newsize)); /* get proper power of 2 */
 636     }
 637     if (newsize < newmax)
 638         newsize *= 2;
 639     if (newsize < newmax)
 640         return;                                 /* overflow detection */
 641
 642     a = (HE**)xhv->xhv_array;
 643     if (a) {
 644         nomemok = TRUE;
 645 #ifdef STRANGE_MALLOC
 646         Renew(a, newsize, HE*);
 647 #else
 648         i = newsize * sizeof(HE*);
 649         j = MALLOC_OVERHEAD;
 650         while (j - MALLOC_OVERHEAD < i)
 651             j += j;
 652         j -= MALLOC_OVERHEAD;
 653         j /= sizeof(HE*);
 654         assert(j >= newsize);
 655         New(2, a, j, HE*);
 656         Copy(xhv->xhv_array, a, oldsize, HE*);
 657         if (oldsize >= 64) {
 658             offer_nice_chunk(xhv->xhv_array,
 659                              oldsize * sizeof(HE*) * 2 - MALLOC_OVERHEAD);
 660         }
 661         else
 662             Safefree(xhv->xhv_array);
 663 #endif
 664         nomemok = FALSE;
 665         Zero(&a[oldsize], newsize-oldsize, HE*); /* zero 2nd half*/
 666     }
 667     else {
 668         Newz(0, a, newsize, HE*);
 669     }
 670     xhv->xhv_max = --newsize;
 671     xhv->xhv_array = (char*)a;
 672     if (!xhv->xhv_fill)                         /* skip rest if no entries */
 673         return;
 674
 675     for (i=0; i<oldsize; i++,a++) {
 676         if (!*a)                                /* non-existent */
 677             continue;
 678         for (oentry = a, entry = *a; entry; entry = *oentry) {
 679             if ((j = (HeHASH(entry) & newsize)) != i) {
 680                 j -= i;
 681                 *oentry = HeNEXT(entry);
 682                 if (!(HeNEXT(entry) = a[j]))
 683                     xhv->xhv_fill++;
 684                 a[j] = entry;
 685                 continue;
 686             }
 687             else
 688                 oentry = &HeNEXT(entry);
 689         }
 690         if (!*a)                                /* everything moved */
 691             xhv->xhv_fill--;
 692     }
 693 }
 694
 695 HV *
 696 newHV(void)
 697 {
 698     register HV *hv;
 699     register XPVHV* xhv;
 700
 701     hv = (HV*)NEWSV(502,0);
 702     sv_upgrade((SV *)hv, SVt_PVHV);
 703     xhv = (XPVHV*)SvANY(hv);
 704     SvPOK_off(hv);
 705     SvNOK_off(hv);
 706 #ifndef NODEFAULT_SHAREKEYS
 707     HvSHAREKEYS_on(hv);         /* key-sharing on by default */
 708 #endif
 709     xhv->xhv_max = 7;           /* start with 8 buckets */
 710     xhv->xhv_fill = 0;
 711     xhv->xhv_pmroot = 0;
 712     (void)hv_iterinit(hv);      /* so each() will start off right */
 713     return hv;
 714 }
 715
 716 void
 717 hv_free_ent(HV *hv, register HE *entry)
 718 {
 719     if (!entry)
 720         return;
 721     if (isGV(HeVAL(entry)) && GvCVu(HeVAL(entry)) && HvNAME(hv))
 722         sub_generation++;       /* may be deletion of method from stash */
 723     SvREFCNT_dec(HeVAL(entry));
 724     if (HeKLEN(entry) == HEf_SVKEY) {
 725         SvREFCNT_dec(HeKEY_sv(entry));
 726         Safefree(HeKEY_hek(entry));
 727     }
 728     else if (HvSHAREKEYS(hv))
 729         unshare_hek(HeKEY_hek(entry));
 730     else
 731         Safefree(HeKEY_hek(entry));
 732     del_he(entry);
 733 }
 734
 735 void
 736 hv_delayfree_ent(HV *hv, register HE *entry)
 737 {
 738     if (!entry)
 739         return;
 740     if (isGV(HeVAL(entry)) && GvCVu(HeVAL(entry)) && HvNAME(hv))
 741         sub_generation++;       /* may be deletion of method from stash */
 742     sv_2mortal(HeVAL(entry));   /* free between statements */
 743     if (HeKLEN(entry) == HEf_SVKEY) {
 744         sv_2mortal(HeKEY_sv(entry));
 745         Safefree(HeKEY_hek(entry));
 746     }
 747     else if (HvSHAREKEYS(hv))
 748         unshare_hek(HeKEY_hek(entry));
 749     else
 750         Safefree(HeKEY_hek(entry));
 751     del_he(entry);
 752 }
 753
 754 void
 755 hv_clear(HV *hv)
 756 {
 757     register XPVHV* xhv;
 758     if (!hv)
 759         return;
 760     xhv = (XPVHV*)SvANY(hv);
 761     hfreeentries(hv);
 762     xhv->xhv_fill = 0;
 763     xhv->xhv_keys = 0;
 764     if (xhv->xhv_array)
 765         (void)memzero(xhv->xhv_array, (xhv->xhv_max + 1) * sizeof(HE*));
 766
 767     if (SvRMAGICAL(hv))
 768         mg_clear((SV*)hv);
 769 }
 770
 771 static void
 772 hfreeentries(HV *hv)
 773 {
 774     register HE **array;
 775     register HE *entry;
 776     register HE *oentry = Null(HE*);
 777     I32 riter;
 778     I32 max;
 779
 780     if (!hv)
 781         return;
 782     if (!HvARRAY(hv))
 783         return;
 784
 785     riter = 0;
 786     max = HvMAX(hv);
 787     array = HvARRAY(hv);
 788     entry = array[0];
 789     for (;;) {
 790         if (entry) {
 791             oentry = entry;
 792             entry = HeNEXT(entry);
 793             hv_free_ent(hv, oentry);
 794         }
 795         if (!entry) {
 796             if (++riter > max)
 797                 break;
 798             entry = array[riter];
 799         }
 800     }
 801     (void)hv_iterinit(hv);
 802 }
 803
 804 void
 805 hv_undef(HV *hv)
 806 {
 807     register XPVHV* xhv;
 808     if (!hv)
 809         return;
 810     xhv = (XPVHV*)SvANY(hv);
 811     hfreeentries(hv);
 812     Safefree(xhv->xhv_array);
 813     if (HvNAME(hv)) {
 814         Safefree(HvNAME(hv));
 815         HvNAME(hv) = 0;
 816     }
 817     xhv->xhv_array = 0;
 818     xhv->xhv_max = 7;           /* it's a normal hash */
 819     xhv->xhv_fill = 0;
 820     xhv->xhv_keys = 0;
 821
 822     if (SvRMAGICAL(hv))
 823         mg_clear((SV*)hv);
 824 }
 825
 826 I32
 827 hv_iterinit(HV *hv)
 828 {
 829     register XPVHV* xhv;
 830     HE *entry;
 831
 832     if (!hv)
 833         croak("Bad hash");
 834     xhv = (XPVHV*)SvANY(hv);
 835     entry = xhv->xhv_eiter;
 836 #ifdef DYNAMIC_ENV_FETCH  /* set up %ENV for iteration */
 837     if (HvNAME(hv) && strEQ(HvNAME(hv), ENV_HV_NAME))
 838         prime_env_iter();
 839 #endif
 840     if (entry && HvLAZYDEL(hv)) {       /* was deleted earlier? */
 841         HvLAZYDEL_off(hv);
 842         hv_free_ent(hv, entry);
 843     }
 844     xhv->xhv_riter = -1;
 845     xhv->xhv_eiter = Null(HE*);
 846     return xhv->xhv_fill;       /* should be xhv->xhv_keys? May change later */
 847 }
 848
 849 HE *
 850 hv_iternext(HV *hv)
 851 {
 852     register XPVHV* xhv;
 853     register HE *entry;
 854     HE *oldentry;
 855     MAGIC* mg;
 856
 857     if (!hv)
 858         croak("Bad hash");
 859     xhv = (XPVHV*)SvANY(hv);
 860     oldentry = entry = xhv->xhv_eiter;
 861
 862     if (SvRMAGICAL(hv) && (mg = mg_find((SV*)hv,'P'))) {
 863         SV *key = sv_newmortal();
 864         if (entry) {
 865             sv_setsv(key, HeSVKEY_force(entry));
 866             SvREFCNT_dec(HeSVKEY(entry));       /* get rid of previous key */
 867         }
 868         else {
 869             char *k;
 870             HEK *hek;
 871
 872             xhv->xhv_eiter = entry = new_he();  /* one HE per MAGICAL hash */
 873             Zero(entry, 1, HE);
 874             Newz(54, k, HEK_BASESIZE + sizeof(SV*), char);
 875             hek = (HEK*)k;
 876             HeKEY_hek(entry) = hek;
 877             HeKLEN(entry) = HEf_SVKEY;
 878         }
 879         magic_nextpack((SV*) hv,mg,key);
 880         if (SvOK(key)) {
 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