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