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