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