hv.c

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