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