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