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