hv.c

   1 /*    hv.c
   2  *
   3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
   4  *    2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
   5  *
   6  *    You may distribute under the terms of either the GNU General Public
   7  *    License or the Artistic License, as specified in the README file.
   8  *
   9  */
  10
  11 /*
  12  * "I sit beside the fire and think of all that I have seen."  --Bilbo
  13  */
  14
  15 /*
  16 =head1 Hash Manipulation Functions
  17
  18 A HV structure represents a Perl hash. It consists mainly of an array
  19 of pointers, each of which points to a linked list of HE structures. The
  20 array is indexed by the hash function of the key, so each linked list
  21 represents all the hash entries with the same hash value. Each HE contains
  22 a pointer to the actual value, plus a pointer to a HEK structure which
  23 holds the key and hash value.
  24
  25 =cut
  26
  27 */
  28
  29 #include "EXTERN.h"
  30 #define PERL_IN_HV_C
  31 #define PERL_HASH_INTERNAL_ACCESS
  32 #include "perl.h"
  33
  34 #define HV_MAX_LENGTH_BEFORE_SPLIT 14
  35
  36 static const char S_strtab_error[]
  37     = "Cannot modify shared string table in hv_%s";
  38
  39 STATIC void
  40 S_more_he(pTHX)
  41 {
  42     HE* he;
  43     HE* heend;
  44     Newx(he, PERL_ARENA_SIZE/sizeof(HE), HE);
  45     HeNEXT(he) = PL_he_arenaroot;
  46     PL_he_arenaroot = he;
  47
  48     heend = &he[PERL_ARENA_SIZE / sizeof(HE) - 1];
  49     PL_he_root = ++he;
  50     while (he < heend) {
  51         HeNEXT(he) = (HE*)(he + 1);
  52         he++;
  53     }
  54     HeNEXT(he) = 0;
  55 }
  56
  57 #ifdef PURIFY
  58
  59 #define new_HE() (HE*)safemalloc(sizeof(HE))
  60 #define del_HE(p) safefree((char*)p)
  61
  62 #else
  63
  64 STATIC HE*
  65 S_new_he(pTHX)
  66 {
  67     HE* he;
  68     LOCK_SV_MUTEX;
  69     if (!PL_he_root)
  70         S_more_he(aTHX);
  71     he = PL_he_root;
  72     PL_he_root = HeNEXT(he);
  73     UNLOCK_SV_MUTEX;
  74     return he;
  75 }
  76
  77 #define new_HE() new_he()
  78 #define del_HE(p) \
  79     STMT_START { \
  80         LOCK_SV_MUTEX; \
  81         HeNEXT(p) = (HE*)PL_he_root; \
  82         PL_he_root = p; \
  83         UNLOCK_SV_MUTEX; \
  84     } STMT_END
  85
  86
  87
  88 #endif
  89
  90 STATIC HEK *
  91 S_save_hek_flags(pTHX_ const char *str, I32 len, U32 hash, int flags)
  92 {
  93     const int flags_masked = flags & HVhek_MASK;
  94     char *k;
  95     register HEK *hek;
  96
  97     Newx(k, HEK_BASESIZE + len + 2, char);
  98     hek = (HEK*)k;
  99     Copy(str, HEK_KEY(hek), len, char);
 100     HEK_KEY(hek)[len] = 0;
 101     HEK_LEN(hek) = len;
 102     HEK_HASH(hek) = hash;
 103     HEK_FLAGS(hek) = (unsigned char)flags_masked;
 104
 105     if (flags & HVhek_FREEKEY)
 106         Safefree(str);
 107     return hek;
 108 }
 109
 110 /* free the pool of temporary HE/HEK pairs retunrned by hv_fetch_ent
 111  * for tied hashes */
 112
 113 void
 114 Perl_free_tied_hv_pool(pTHX)
 115 {
 116     HE *he = PL_hv_fetch_ent_mh;
 117     while (he) {
 118         HE * const ohe = he;
 119         Safefree(HeKEY_hek(he));
 120         he = HeNEXT(he);
 121         del_HE(ohe);
 122     }
 123     PL_hv_fetch_ent_mh = Nullhe;
 124 }
 125
 126 #if defined(USE_ITHREADS)
 127 HEK *
 128 Perl_hek_dup(pTHX_ HEK *source, CLONE_PARAMS* param)
 129 {
 130     HEK *shared = (HEK*)ptr_table_fetch(PL_ptr_table, source);
 131
 132     PERL_UNUSED_ARG(param);
 133
 134     if (shared) {
 135         /* We already shared this hash key.  */
 136         (void)share_hek_hek(shared);
 137     }
 138     else {
 139         shared
 140             = share_hek_flags(HEK_KEY(source), HEK_LEN(source),
 141                               HEK_HASH(source), HEK_FLAGS(source));
 142         ptr_table_store(PL_ptr_table, source, shared);
 143     }
 144     return shared;
 145 }
 146
 147 HE *
 148 Perl_he_dup(pTHX_ const HE *e, bool shared, CLONE_PARAMS* param)
 149 {
 150     HE *ret;
 151
 152     if (!e)
 153         return Nullhe;
 154     /* look for it in the table first */
 155     ret = (HE*)ptr_table_fetch(PL_ptr_table, e);
 156     if (ret)
 157         return ret;
 158
 159     /* create anew and remember what it is */
 160     ret = new_HE();
 161     ptr_table_store(PL_ptr_table, e, ret);
 162
 163     HeNEXT(ret) = he_dup(HeNEXT(e),shared, param);
 164     if (HeKLEN(e) == HEf_SVKEY) {
 165         char *k;
 166         Newx(k, HEK_BASESIZE + sizeof(SV*), char);
 167         HeKEY_hek(ret) = (HEK*)k;
 168         HeKEY_sv(ret) = SvREFCNT_inc(sv_dup(HeKEY_sv(e), param));
 169     }
 170     else if (shared) {
 171         /* This is hek_dup inlined, which seems to be important for speed
 172            reasons.  */
 173         HEK * const source = HeKEY_hek(e);
 174         HEK *shared = (HEK*)ptr_table_fetch(PL_ptr_table, source);
 175
 176         if (shared) {
 177             /* We already shared this hash key.  */
 178             (void)share_hek_hek(shared);
 179         }
 180         else {
 181             shared
 182                 = share_hek_flags(HEK_KEY(source), HEK_LEN(source),
 183                                   HEK_HASH(source), HEK_FLAGS(source));
 184             ptr_table_store(PL_ptr_table, source, shared);
 185         }
 186         HeKEY_hek(ret) = shared;
 187     }
 188     else
 189         HeKEY_hek(ret) = save_hek_flags(HeKEY(e), HeKLEN(e), HeHASH(e),
 190                                         HeKFLAGS(e));
 191     HeVAL(ret) = SvREFCNT_inc(sv_dup(HeVAL(e), param));
 192     return ret;
 193 }
 194 #endif  /* USE_ITHREADS */
 195
 196 static void
 197 S_hv_notallowed(pTHX_ int flags, const char *key, I32 klen,
 198                 const char *msg)
 199 {
 200     SV * const sv = sv_newmortal();
 201     if (!(flags & HVhek_FREEKEY)) {
 202         sv_setpvn(sv, key, klen);
 203     }
 204     else {
 205         /* Need to free saved eventually assign to mortal SV */
 206         /* XXX is this line an error ???:  SV *sv = sv_newmortal(); */
 207         sv_usepvn(sv, (char *) key, klen);
 208     }
 209     if (flags & HVhek_UTF8) {
 210         SvUTF8_on(sv);
 211     }
 212     Perl_croak(aTHX_ msg, sv);
 213 }
 214
 215 /* (klen == HEf_SVKEY) is special for MAGICAL hv entries, meaning key slot
 216  * contains an SV* */
 217
 218 #define HV_FETCH_ISSTORE   0x01
 219 #define HV_FETCH_ISEXISTS  0x02
 220 #define HV_FETCH_LVALUE    0x04
 221 #define HV_FETCH_JUST_SV   0x08
 222
 223 /*
 224 =for apidoc hv_store
 225
 226 Stores an SV in a hash.  The hash key is specified as C<key> and C<klen> is
 227 the length of the key.  The C<hash> parameter is the precomputed hash
 228 value; if it is zero then Perl will compute it.  The return value will be
 229 NULL if the operation failed or if the value did not need to be actually
 230 stored within the hash (as in the case of tied hashes).  Otherwise it can
 231 be dereferenced to get the original C<SV*>.  Note that the caller is
 232 responsible for suitably incrementing the reference count of C<val> before
 233 the call, and decrementing it if the function returned NULL.  Effectively
 234 a successful hv_store takes ownership of one reference to C<val>.  This is
 235 usually what you want; a newly created SV has a reference count of one, so
 236 if all your code does is create SVs then store them in a hash, hv_store
 237 will own the only reference to the new SV, and your code doesn't need to do
 238 anything further to tidy up.  hv_store is not implemented as a call to
 239 hv_store_ent, and does not create a temporary SV for the key, so if your
 240 key data is not already in SV form then use hv_store in preference to
 241 hv_store_ent.
 242
 243 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
 244 information on how to use this function on tied hashes.
 245
 246 =cut
 247 */
 248
 249 SV**
 250 Perl_hv_store(pTHX_ HV *hv, const char *key, I32 klen_i32, SV *val, U32 hash)
 251 {
 252     HE *hek;
 253     STRLEN klen;
 254     int flags;
 255
 256     if (klen_i32 < 0) {
 257         klen = -klen_i32;
 258         flags = HVhek_UTF8;
 259     } else {
 260         klen = klen_i32;
 261         flags = 0;
 262     }
 263     hek = hv_fetch_common (hv, NULL, key, klen, flags,
 264                            (HV_FETCH_ISSTORE|HV_FETCH_JUST_SV), val, hash);
 265     return hek ? &HeVAL(hek) : NULL;
 266 }
 267
 268 SV**
 269 Perl_hv_store_flags(pTHX_ HV *hv, const char *key, I32 klen, SV *val,
 270                  register U32 hash, int flags)
 271 {
 272     HE * const hek = hv_fetch_common (hv, NULL, key, klen, flags,
 273                                (HV_FETCH_ISSTORE|HV_FETCH_JUST_SV), val, hash);
 274     return hek ? &HeVAL(hek) : NULL;
 275 }
 276
 277 /*
 278 =for apidoc hv_store_ent
 279
 280 Stores C<val> in a hash.  The hash key is specified as C<key>.  The C<hash>
 281 parameter is the precomputed hash value; if it is zero then Perl will
 282 compute it.  The return value is the new hash entry so created.  It will be
 283 NULL if the operation failed or if the value did not need to be actually
 284 stored within the hash (as in the case of tied hashes).  Otherwise the
 285 contents of the return value can be accessed using the C<He?> macros
 286 described here.  Note that the caller is responsible for suitably
 287 incrementing the reference count of C<val> before the call, and
 288 decrementing it if the function returned NULL.  Effectively a successful
 289 hv_store_ent takes ownership of one reference to C<val>.  This is
 290 usually what you want; a newly created SV has a reference count of one, so
 291 if all your code does is create SVs then store them in a hash, hv_store
 292 will own the only reference to the new SV, and your code doesn't need to do
 293 anything further to tidy up.  Note that hv_store_ent only reads the C<key>;
 294 unlike C<val> it does not take ownership of it, so maintaining the correct
 295 reference count on C<key> is entirely the caller's responsibility.  hv_store
 296 is not implemented as a call to hv_store_ent, and does not create a temporary
 297 SV for the key, so if your key data is not already in SV form then use
 298 hv_store in preference to hv_store_ent.
 299
 300 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
 301 information on how to use this function on tied hashes.
 302
 303 =cut
 304 */
 305
 306 HE *
 307 Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, U32 hash)
 308 {
 309   return hv_fetch_common(hv, keysv, NULL, 0, 0, HV_FETCH_ISSTORE, val, hash);
 310 }
 311
 312 /*
 313 =for apidoc hv_exists
 314
 315 Returns a boolean indicating whether the specified hash key exists.  The
 316 C<klen> is the length of the key.
 317
 318 =cut
 319 */
 320
 321 bool
 322 Perl_hv_exists(pTHX_ HV *hv, const char *key, I32 klen_i32)
 323 {
 324     STRLEN klen;
 325     int flags;
 326
 327     if (klen_i32 < 0) {
 328         klen = -klen_i32;
 329         flags = HVhek_UTF8;
 330     } else {
 331         klen = klen_i32;
 332         flags = 0;
 333     }
 334     return hv_fetch_common(hv, NULL, key, klen, flags, HV_FETCH_ISEXISTS, 0, 0)
 335         ? TRUE : FALSE;
 336 }
 337
 338 /*
 339 =for apidoc hv_fetch
 340
 341 Returns the SV which corresponds to the specified key in the hash.  The
 342 C<klen> is the length of the key.  If C<lval> is set then the fetch will be
 343 part of a store.  Check that the return value is non-null before
 344 dereferencing it to an C<SV*>.
 345
 346 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
 347 information on how to use this function on tied hashes.
 348
 349 =cut
 350 */
 351
 352 SV**
 353 Perl_hv_fetch(pTHX_ HV *hv, const char *key, I32 klen_i32, I32 lval)
 354 {
 355     HE *hek;
 356     STRLEN klen;
 357     int flags;
 358
 359     if (klen_i32 < 0) {
 360         klen = -klen_i32;
 361         flags = HVhek_UTF8;
 362     } else {
 363         klen = klen_i32;
 364         flags = 0;
 365     }
 366     hek = hv_fetch_common (hv, NULL, key, klen, flags,
 367                            HV_FETCH_JUST_SV | (lval ? HV_FETCH_LVALUE : 0),
 368                            Nullsv, 0);
 369     return hek ? &HeVAL(hek) : NULL;
 370 }
 371
 372 /*
 373 =for apidoc hv_exists_ent
 374
 375 Returns a boolean indicating whether the specified hash key exists. C<hash>
 376 can be a valid precomputed hash value, or 0 to ask for it to be
 377 computed.
 378
 379 =cut
 380 */
 381
 382 bool
 383 Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash)
 384 {
 385     return hv_fetch_common(hv, keysv, NULL, 0, 0, HV_FETCH_ISEXISTS, 0, hash)
 386         ? TRUE : FALSE;
 387 }
 388
 389 /* returns an HE * structure with the all fields set */
 390 /* note that hent_val will be a mortal sv for MAGICAL hashes */
 391 /*
 392 =for apidoc hv_fetch_ent
 393
 394 Returns the hash entry which corresponds to the specified key in the hash.
 395 C<hash> must be a valid precomputed hash number for the given C<key>, or 0
 396 if you want the function to compute it.  IF C<lval> is set then the fetch
 397 will be part of a store.  Make sure the return value is non-null before
 398 accessing it.  The return value when C<tb> is a tied hash is a pointer to a
 399 static location, so be sure to make a copy of the structure if you need to
 400 store it somewhere.
 401
 402 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
 403 information on how to use this function on tied hashes.
 404
 405 =cut
 406 */
 407
 408 HE *
 409 Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash)
 410 {
 411     return hv_fetch_common(hv, keysv, NULL, 0, 0,
 412                            (lval ? HV_FETCH_LVALUE : 0), Nullsv, hash);
 413 }
 414
 415 STATIC HE *
 416 S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
 417                   int flags, int action, SV *val, register U32 hash)
 418 {
 419     dVAR;
 420     XPVHV* xhv;
 421     HE *entry;
 422     HE **oentry;
 423     SV *sv;
 424     bool is_utf8;
 425     int masked_flags;
 426
 427     if (!hv)
 428         return 0;
 429
 430     if (keysv) {
 431         if (flags & HVhek_FREEKEY)
 432             Safefree(key);
 433         key = SvPV_const(keysv, klen);
 434         flags = 0;
 435         is_utf8 = (SvUTF8(keysv) != 0);
 436     } else {
 437         is_utf8 = ((flags & HVhek_UTF8) ? TRUE : FALSE);
 438     }
 439
 440     xhv = (XPVHV*)SvANY(hv);
 441     if (SvMAGICAL(hv)) {
 442         if (SvRMAGICAL(hv) && !(action & (HV_FETCH_ISSTORE|HV_FETCH_ISEXISTS)))
 443           {
 444             if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
 445                 sv = sv_newmortal();
 446
 447                 /* XXX should be able to skimp on the HE/HEK here when
 448                    HV_FETCH_JUST_SV is true.  */
 449
 450                 if (!keysv) {
 451                     keysv = newSVpvn(key, klen);
 452                     if (is_utf8) {
 453                         SvUTF8_on(keysv);
 454                     }
 455                 } else {
 456                     keysv = newSVsv(keysv);
 457                 }
 458                 mg_copy((SV*)hv, sv, (char *)keysv, HEf_SVKEY);
 459
 460                 /* grab a fake HE/HEK pair from the pool or make a new one */
 461                 entry = PL_hv_fetch_ent_mh;
 462                 if (entry)
 463                     PL_hv_fetch_ent_mh = HeNEXT(entry);
 464                 else {
 465                     char *k;
 466                     entry = new_HE();
 467                     Newx(k, HEK_BASESIZE + sizeof(SV*), char);
 468                     HeKEY_hek(entry) = (HEK*)k;
 469                 }
 470                 HeNEXT(entry) = Nullhe;
 471                 HeSVKEY_set(entry, keysv);
 472                 HeVAL(entry) = sv;
 473                 sv_upgrade(sv, SVt_PVLV);
 474                 LvTYPE(sv) = 'T';
 475                  /* so we can free entry when freeing sv */
 476                 LvTARG(sv) = (SV*)entry;
 477
 478                 /* XXX remove at some point? */
 479                 if (flags & HVhek_FREEKEY)
 480                     Safefree(key);
 481
 482                 return entry;
 483             }
 484 #ifdef ENV_IS_CASELESS
 485             else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
 486                 U32 i;
 487                 for (i = 0; i < klen; ++i)
 488                     if (isLOWER(key[i])) {
 489                         /* Would be nice if we had a routine to do the
 490                            copy and upercase in a single pass through.  */
 491                         const char *nkey = strupr(savepvn(key,klen));
 492                         /* Note that this fetch is for nkey (the uppercased
 493                            key) whereas the store is for key (the original)  */
 494                         entry = hv_fetch_common(hv, Nullsv, nkey, klen,
 495                                                 HVhek_FREEKEY, /* free nkey */
 496                                                 0 /* non-LVAL fetch */,
 497                                                 Nullsv /* no value */,
 498                                                 0 /* compute hash */);
 499                         if (!entry && (action & HV_FETCH_LVALUE)) {
 500                             /* This call will free key if necessary.
 501                                Do it this way to encourage compiler to tail
 502                                call optimise.  */
 503                             entry = hv_fetch_common(hv, keysv, key, klen,
 504                                                     flags, HV_FETCH_ISSTORE,
 505                                                     NEWSV(61,0), hash);
 506                         } else {
 507                             if (flags & HVhek_FREEKEY)
 508                                 Safefree(key);
 509                         }
 510                         return entry;
 511                     }
 512             }
 513 #endif
 514         } /* ISFETCH */
 515         else if (SvRMAGICAL(hv) && (action & HV_FETCH_ISEXISTS)) {
 516             if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
 517                 /* I don't understand why hv_exists_ent has svret and sv,
 518                    whereas hv_exists only had one.  */
 519                 SV * const svret = sv_newmortal();
 520                 sv = sv_newmortal();
 521
 522                 if (keysv || is_utf8) {
 523                     if (!keysv) {
 524                         keysv = newSVpvn(key, klen);
 525                         SvUTF8_on(keysv);
 526                     } else {
 527                         keysv = newSVsv(keysv);
 528                     }
 529                     mg_copy((SV*)hv, sv, (char *)sv_2mortal(keysv), HEf_SVKEY);
 530                 } else {
 531                     mg_copy((SV*)hv, sv, key, klen);
 532                 }
 533                 if (flags & HVhek_FREEKEY)
 534                     Safefree(key);
 535                 magic_existspack(svret, mg_find(sv, PERL_MAGIC_tiedelem));
 536                 /* This cast somewhat evil, but I'm merely using NULL/
 537                    not NULL to return the boolean exists.
 538                    And I know hv is not NULL.  */
 539                 return SvTRUE(svret) ? (HE *)hv : NULL;
 540                 }
 541 #ifdef ENV_IS_CASELESS
 542             else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
 543                 /* XXX This code isn't UTF8 clean.  */
 544                 char * const keysave = (char * const)key;
 545                 /* Will need to free this, so set FREEKEY flag.  */
 546                 key = savepvn(key,klen);
 547                 key = (const char*)strupr((char*)key);
 548                 is_utf8 = 0;
 549                 hash = 0;
 550                 keysv = 0;
 551
 552                 if (flags & HVhek_FREEKEY) {
 553                     Safefree(keysave);
 554                 }
 555                 flags |= HVhek_FREEKEY;
 556             }
 557 #endif
 558         } /* ISEXISTS */
 559         else if (action & HV_FETCH_ISSTORE) {
 560             bool needs_copy;
 561             bool needs_store;
 562             hv_magic_check (hv, &needs_copy, &needs_store);
 563             if (needs_copy) {
 564                 const bool save_taint = PL_tainted;
 565                 if (keysv || is_utf8) {
 566                     if (!keysv) {
 567                         keysv = newSVpvn(key, klen);
 568                         SvUTF8_on(keysv);
 569                     }
 570                     if (PL_tainting)
 571                         PL_tainted = SvTAINTED(keysv);
 572                     keysv = sv_2mortal(newSVsv(keysv));
 573                     mg_copy((SV*)hv, val, (char*)keysv, HEf_SVKEY);
 574                 } else {
 575                     mg_copy((SV*)hv, val, key, klen);
 576                 }
 577
 578                 TAINT_IF(save_taint);
 579                 if (!HvARRAY(hv) && !needs_store) {
 580                     if (flags & HVhek_FREEKEY)
 581                         Safefree(key);
 582                     return Nullhe;
 583                 }
 584 #ifdef ENV_IS_CASELESS
 585                 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
 586                     /* XXX This code isn't UTF8 clean.  */
 587                     const char *keysave = key;
 588                     /* Will need to free this, so set FREEKEY flag.  */
 589                     key = savepvn(key,klen);
 590                     key = (const char*)strupr((char*)key);
 591                     is_utf8 = 0;
 592                     hash = 0;
 593                     keysv = 0;
 594
 595                     if (flags & HVhek_FREEKEY) {
 596                         Safefree(keysave);
 597                     }
 598                     flags |= HVhek_FREEKEY;
 599                 }
 600 #endif
 601             }
 602         } /* ISSTORE */
 603     } /* SvMAGICAL */
 604
 605     if (!HvARRAY(hv)) {
 606         if ((action & (HV_FETCH_LVALUE | HV_FETCH_ISSTORE))
 607 #ifdef DYNAMIC_ENV_FETCH  /* if it's an %ENV lookup, we may get it on the fly */
 608                  || (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
 609 #endif
 610                                                                   ) {
 611             char *array;
 612             Newxz(array,
 613                  PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
 614                  char);
 615             HvARRAY(hv) = (HE**)array;
 616         }
 617 #ifdef DYNAMIC_ENV_FETCH
 618         else if (action & HV_FETCH_ISEXISTS) {
 619             /* for an %ENV exists, if we do an insert it's by a recursive
 620                store call, so avoid creating HvARRAY(hv) right now.  */
 621         }
 622 #endif
 623         else {
 624             /* XXX remove at some point? */
 625             if (flags & HVhek_FREEKEY)
 626                 Safefree(key);
 627
 628             return 0;
 629         }
 630     }
 631
 632     if (is_utf8) {
 633         char * const keysave = (char * const)key;
 634         key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
 635         if (is_utf8)
 636             flags |= HVhek_UTF8;
 637         else
 638             flags &= ~HVhek_UTF8;
 639         if (key != keysave) {
 640             if (flags & HVhek_FREEKEY)
 641                 Safefree(keysave);
 642             flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
 643         }
 644     }
 645
 646     if (HvREHASH(hv)) {
 647         PERL_HASH_INTERNAL(hash, key, klen);
 648         /* We don't have a pointer to the hv, so we have to replicate the
 649            flag into every HEK, so that hv_iterkeysv can see it.  */
 650         /* And yes, you do need this even though you are not "storing" because
 651            you can flip the flags below if doing an lval lookup.  (And that
 652            was put in to give the semantics Andreas was expecting.)  */
 653         flags |= HVhek_REHASH;
 654     } else if (!hash) {
 655         if (keysv && (SvIsCOW_shared_hash(keysv))) {
 656             hash = SvSHARED_HASH(keysv);
 657         } else {
 658             PERL_HASH(hash, key, klen);
 659         }
 660     }
 661
 662     masked_flags = (flags & HVhek_MASK);
 663
 664 #ifdef DYNAMIC_ENV_FETCH
 665     if (!HvARRAY(hv)) entry = Null(HE*);
 666     else
 667 #endif
 668     {
 669         entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)];
 670     }
 671     for (; entry; entry = HeNEXT(entry)) {
 672         if (HeHASH(entry) != hash)              /* strings can't be equal */
 673             continue;
 674         if (HeKLEN(entry) != (I32)klen)
 675             continue;
 676         if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen))        /* is this it? */
 677             continue;
 678         if ((HeKFLAGS(entry) ^ masked_flags) & HVhek_UTF8)
 679             continue;
 680
 681         if (action & (HV_FETCH_LVALUE|HV_FETCH_ISSTORE)) {
 682             if (HeKFLAGS(entry) != masked_flags) {
 683                 /* We match if HVhek_UTF8 bit in our flags and hash key's
 684                    match.  But if entry was set previously with HVhek_WASUTF8
 685                    and key now doesn't (or vice versa) then we should change
 686                    the key's flag, as this is assignment.  */
 687                 if (HvSHAREKEYS(hv)) {
 688                     /* Need to swap the key we have for a key with the flags we
 689                        need. As keys are shared we can't just write to the
 690                        flag, so we share the new one, unshare the old one.  */
 691                     HEK *new_hek = share_hek_flags(key, klen, hash,
 692                                                    masked_flags);
 693                     unshare_hek (HeKEY_hek(entry));
 694                     HeKEY_hek(entry) = new_hek;
 695                 }
 696                 else if (hv == PL_strtab) {
 697                     /* PL_strtab is usually the only hash without HvSHAREKEYS,
 698                        so putting this test here is cheap  */
 699                     if (flags & HVhek_FREEKEY)
 700                         Safefree(key);
 701                     Perl_croak(aTHX_ S_strtab_error,
 702                                action & HV_FETCH_LVALUE ? "fetch" : "store");
 703                 }
 704                 else
 705                     HeKFLAGS(entry) = masked_flags;
 706                 if (masked_flags & HVhek_ENABLEHVKFLAGS)
 707                     HvHASKFLAGS_on(hv);
 708             }
 709             if (HeVAL(entry) == &PL_sv_placeholder) {
 710                 /* yes, can store into placeholder slot */
 711                 if (action & HV_FETCH_LVALUE) {
 712                     if (SvMAGICAL(hv)) {
 713                         /* This preserves behaviour with the old hv_fetch
 714                            implementation which at this point would bail out
 715                            with a break; (at "if we find a placeholder, we
 716                            pretend we haven't found anything")
 717
 718                            That break mean that if a placeholder were found, it
 719                            caused a call into hv_store, which in turn would
 720                            check magic, and if there is no magic end up pretty
 721                            much back at this point (in hv_store's code).  */
 722                         break;
 723                     }
 724                     /* LVAL fetch which actaully needs a store.  */
 725                     val = NEWSV(61,0);
 726                     HvPLACEHOLDERS(hv)--;
 727                 } else {
 728                     /* store */
 729                     if (val != &PL_sv_placeholder)
 730                         HvPLACEHOLDERS(hv)--;
 731                 }
 732                 HeVAL(entry) = val;
 733             } else if (action & HV_FETCH_ISSTORE) {
 734                 SvREFCNT_dec(HeVAL(entry));
 735                 HeVAL(entry) = val;
 736             }
 737         } else if (HeVAL(entry) == &PL_sv_placeholder) {
 738             /* if we find a placeholder, we pretend we haven't found
 739                anything */
 740             break;
 741         }
 742         if (flags & HVhek_FREEKEY)
 743             Safefree(key);
 744         return entry;
 745     }
 746 #ifdef DYNAMIC_ENV_FETCH  /* %ENV lookup?  If so, try to fetch the value now */
 747     if (!(action & HV_FETCH_ISSTORE)
 748         && SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
 749         unsigned long len;
 750         const char * const env = PerlEnv_ENVgetenv_len(key,&len);
 751         if (env) {
 752             sv = newSVpvn(env,len);
 753             SvTAINTED_on(sv);
 754             return hv_fetch_common(hv,keysv,key,klen,flags,HV_FETCH_ISSTORE,sv,
 755                                    hash);
 756         }
 757     }
 758 #endif
 759
 760     if (!entry && SvREADONLY(hv) && !(action & HV_FETCH_ISEXISTS)) {
 761         S_hv_notallowed(aTHX_ flags, key, klen,
 762                         "Attempt to access disallowed key '%"SVf"' in"
 763                         " a restricted hash");
 764     }
 765     if (!(action & (HV_FETCH_LVALUE|HV_FETCH_ISSTORE))) {
 766         /* Not doing some form of store, so return failure.  */
 767         if (flags & HVhek_FREEKEY)
 768             Safefree(key);
 769         return 0;
 770     }
 771     if (action & HV_FETCH_LVALUE) {
 772         val = NEWSV(61,0);
 773         if (SvMAGICAL(hv)) {
 774             /* At this point the old hv_fetch code would call to hv_store,
 775                which in turn might do some tied magic. So we need to make that
 776                magic check happen.  */
 777             /* gonna assign to this, so it better be there */
 778             return hv_fetch_common(hv, keysv, key, klen, flags,
 779                                    HV_FETCH_ISSTORE, val, hash);
 780             /* XXX Surely that could leak if the fetch-was-store fails?
 781                Just like the hv_fetch.  */
 782         }
 783     }
 784
 785     /* Welcome to hv_store...  */
 786
 787     if (!HvARRAY(hv)) {
 788         /* Not sure if we can get here.  I think the only case of oentry being
 789            NULL is for %ENV with dynamic env fetch.  But that should disappear
 790            with magic in the previous code.  */
 791         char *array;
 792         Newxz(array,
 793              PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
 794              char);
 795         HvARRAY(hv) = (HE**)array;
 796     }
 797
 798     oentry = &(HvARRAY(hv))[hash & (I32) xhv->xhv_max];
 799
 800     entry = new_HE();
 801     /* share_hek_flags will do the free for us.  This might be considered
 802        bad API design.  */
 803     if (HvSHAREKEYS(hv))
 804         HeKEY_hek(entry) = share_hek_flags(key, klen, hash, flags);
 805     else if (hv == PL_strtab) {
 806         /* PL_strtab is usually the only hash without HvSHAREKEYS, so putting
 807            this test here is cheap  */
 808         if (flags & HVhek_FREEKEY)
 809             Safefree(key);
 810         Perl_croak(aTHX_ S_strtab_error,
 811                    action & HV_FETCH_LVALUE ? "fetch" : "store");
 812     }
 813     else                                       /* gotta do the real thing */
 814         HeKEY_hek(entry) = save_hek_flags(key, klen, hash, flags);
 815     HeVAL(entry) = val;
 816     HeNEXT(entry) = *oentry;
 817     *oentry = entry;
 818
 819     if (val == &PL_sv_placeholder)
 820         HvPLACEHOLDERS(hv)++;
 821     if (masked_flags & HVhek_ENABLEHVKFLAGS)
 822         HvHASKFLAGS_on(hv);
 823
 824     {
 825         const HE *counter = HeNEXT(entry);
 826
 827         xhv->xhv_keys++; /* HvKEYS(hv)++ */
 828         if (!counter) {                         /* initial entry? */
 829             xhv->xhv_fill++; /* HvFILL(hv)++ */
 830         } else if (xhv->xhv_keys > (IV)xhv->xhv_max) {
 831             hsplit(hv);
 832         } else if(!HvREHASH(hv)) {
 833             U32 n_links = 1;
 834
 835             while ((counter = HeNEXT(counter)))
 836                 n_links++;
 837
 838             if (n_links > HV_MAX_LENGTH_BEFORE_SPLIT) {
 839                 /* Use only the old HvKEYS(hv) > HvMAX(hv) condition to limit
 840                    bucket splits on a rehashed hash, as we're not going to
 841                    split it again, and if someone is lucky (evil) enough to
 842                    get all the keys in one list they could exhaust our memory
 843                    as we repeatedly double the number of buckets on every
 844                    entry. Linear search feels a less worse thing to do.  */
 845                 hsplit(hv);
 846             }
 847         }
 848     }
 849
 850     return entry;
 851 }
 852
 853 STATIC void
 854 S_hv_magic_check(pTHX_ HV *hv, bool *needs_copy, bool *needs_store)
 855 {
 856     const MAGIC *mg = SvMAGIC(hv);
 857     *needs_copy = FALSE;
 858     *needs_store = TRUE;
 859     while (mg) {
 860         if (isUPPER(mg->mg_type)) {
 861             *needs_copy = TRUE;
 862             if (mg->mg_type == PERL_MAGIC_tied) {
 863                 *needs_store = FALSE;
 864                 return; /* We've set all there is to set. */
 865             }
 866         }
 867         mg = mg->mg_moremagic;
 868     }
 869 }
 870
 871 /*
 872 =for apidoc hv_scalar
 873
 874 Evaluates the hash in scalar context and returns the result. Handles magic when the hash is tied.
 875
 876 =cut
 877 */
 878
 879 SV *
 880 Perl_hv_scalar(pTHX_ HV *hv)
 881 {
 882     MAGIC *mg;
 883     SV *sv;
 884
 885     if ((SvRMAGICAL(hv) && (mg = mg_find((SV*)hv, PERL_MAGIC_tied)))) {
 886         sv = magic_scalarpack(hv, mg);
 887         return sv;
 888     }
 889
 890     sv = sv_newmortal();
 891     if (HvFILL((HV*)hv))
 892         Perl_sv_setpvf(aTHX_ sv, "%ld/%ld",
 893                 (long)HvFILL(hv), (long)HvMAX(hv) + 1);
 894     else
 895         sv_setiv(sv, 0);
 896
 897     return sv;
 898 }
 899
 900 /*
 901 =for apidoc hv_delete
 902
 903 Deletes a key/value pair in the hash.  The value SV is removed from the
 904 hash and returned to the caller.  The C<klen> is the length of the key.
 905 The C<flags> value will normally be zero; if set to G_DISCARD then NULL
 906 will be returned.
 907
 908 =cut
 909 */
 910
 911 SV *
 912 Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen_i32, I32 flags)
 913 {
 914     STRLEN klen;
 915     int k_flags = 0;
 916
 917     if (klen_i32 < 0) {
 918         klen = -klen_i32;
 919         k_flags |= HVhek_UTF8;
 920     } else {
 921         klen = klen_i32;
 922     }
 923     return hv_delete_common(hv, NULL, key, klen, k_flags, flags, 0);
 924 }
 925
 926 /*
 927 =for apidoc hv_delete_ent
 928
 929 Deletes a key/value pair in the hash.  The value SV is removed from the
 930 hash and returned to the caller.  The C<flags> value will normally be zero;
 931 if set to G_DISCARD then NULL will be returned.  C<hash> can be a valid
 932 precomputed hash value, or 0 to ask for it to be computed.
 933
 934 =cut
 935 */
 936
 937 SV *
 938 Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash)
 939 {
 940     return hv_delete_common(hv, keysv, NULL, 0, 0, flags, hash);
 941 }
 942
 943 STATIC SV *
 944 S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
 945                    int k_flags, I32 d_flags, U32 hash)
 946 {
 947     dVAR;
 948     register XPVHV* xhv;
 949     register HE *entry;
 950     register HE **oentry;
 951     HE *const *first_entry;
 952     SV *sv;
 953     bool is_utf8;
 954     int masked_flags;
 955
 956     if (!hv)
 957         return Nullsv;
 958
 959     if (keysv) {
 960         if (k_flags & HVhek_FREEKEY)
 961             Safefree(key);
 962         key = SvPV_const(keysv, klen);
 963         k_flags = 0;
 964         is_utf8 = (SvUTF8(keysv) != 0);
 965     } else {
 966         is_utf8 = ((k_flags & HVhek_UTF8) ? TRUE : FALSE);
 967     }
 968
 969     if (SvRMAGICAL(hv)) {
 970         bool needs_copy;
 971         bool needs_store;
 972         hv_magic_check (hv, &needs_copy, &needs_store);
 973
 974         if (needs_copy) {
 975             entry = hv_fetch_common(hv, keysv, key, klen,
 976                                     k_flags & ~HVhek_FREEKEY, HV_FETCH_LVALUE,
 977                                     Nullsv, hash);
 978             sv = entry ? HeVAL(entry) : NULL;
 979             if (sv) {
 980                 if (SvMAGICAL(sv)) {
 981                     mg_clear(sv);
 982                 }
 983                 if (!needs_store) {
 984                     if (mg_find(sv, PERL_MAGIC_tiedelem)) {
 985                         /* No longer an element */
 986                         sv_unmagic(sv, PERL_MAGIC_tiedelem);
 987                         return sv;
 988                     }
 989                     return Nullsv;              /* element cannot be deleted */
 990                 }
 991 #ifdef ENV_IS_CASELESS
 992                 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
 993                     /* XXX This code isn't UTF8 clean.  */
 994                     keysv = sv_2mortal(newSVpvn(key,klen));
 995                     if (k_flags & HVhek_FREEKEY) {
 996                         Safefree(key);
 997                     }
 998                     key = strupr(SvPVX(keysv));
 999                     is_utf8 = 0;
1000                     k_flags = 0;
1001                     hash = 0;
1002                 }
1003 #endif
1004             }
1005         }
1006     }
1007     xhv = (XPVHV*)SvANY(hv);
1008     if (!HvARRAY(hv))
1009         return Nullsv;
1010
1011     if (is_utf8) {
1012         const char *keysave = key;
1013         key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
1014
1015         if (is_utf8)
1016             k_flags |= HVhek_UTF8;
1017         else
1018             k_flags &= ~HVhek_UTF8;
1019         if (key != keysave) {
1020             if (k_flags & HVhek_FREEKEY) {
1021                 /* This shouldn't happen if our caller does what we expect,
1022                    but strictly the API allows it.  */
1023                 Safefree(keysave);
1024             }
1025             k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
1026         }
1027         HvHASKFLAGS_on((SV*)hv);
1028     }
1029
1030     if (HvREHASH(hv)) {
1031         PERL_HASH_INTERNAL(hash, key, klen);
1032     } else if (!hash) {
1033         if (keysv && (SvIsCOW_shared_hash(keysv))) {
1034             hash = SvSHARED_HASH(keysv);
1035         } else {
1036             PERL_HASH(hash, key, klen);
1037         }
1038     }
1039
1040     masked_flags = (k_flags & HVhek_MASK);
1041
1042     first_entry = oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)];
1043     entry = *oentry;
1044     for (; entry; oentry = &HeNEXT(entry), entry = *oentry) {
1045         if (HeHASH(entry) != hash)              /* strings can't be equal */
1046             continue;
1047         if (HeKLEN(entry) != (I32)klen)
1048             continue;
1049         if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen))        /* is this it? */
1050             continue;
1051         if ((HeKFLAGS(entry) ^ masked_flags) & HVhek_UTF8)
1052             continue;
1053
1054         if (hv == PL_strtab) {
1055             if (k_flags & HVhek_FREEKEY)
1056                 Safefree(key);
1057             Perl_croak(aTHX_ S_strtab_error, "delete");
1058         }
1059
1060         /* if placeholder is here, it's already been deleted.... */
1061         if (HeVAL(entry) == &PL_sv_placeholder)
1062         {
1063           if (k_flags & HVhek_FREEKEY)
1064             Safefree(key);
1065           return Nullsv;
1066         }
1067         else if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
1068             S_hv_notallowed(aTHX_ k_flags, key, klen,
1069                             "Attempt to delete readonly key '%"SVf"' from"
1070                             " a restricted hash");
1071         }
1072         if (k_flags & HVhek_FREEKEY)
1073             Safefree(key);
1074
1075         if (d_flags & G_DISCARD)
1076             sv = Nullsv;
1077         else {
1078             sv = sv_2mortal(HeVAL(entry));
1079             HeVAL(entry) = &PL_sv_placeholder;
1080         }
1081
1082         /*
1083          * If a restricted hash, rather than really deleting the entry, put
1084          * a placeholder there. This marks the key as being "approved", so
1085          * we can still access via not-really-existing key without raising
1086          * an error.
1087          */
1088         if (SvREADONLY(hv)) {
1089             SvREFCNT_dec(HeVAL(entry));
1090             HeVAL(entry) = &PL_sv_placeholder;
1091             /* We'll be saving this slot, so the number of allocated keys
1092              * doesn't go down, but the number placeholders goes up */
1093             HvPLACEHOLDERS(hv)++;
1094         } else {
1095             *oentry = HeNEXT(entry);
1096             if(!*first_entry) {
1097                 xhv->xhv_fill--; /* HvFILL(hv)-- */
1098             }
1099             if (SvOOK(hv) && entry == HvAUX(hv)->xhv_eiter /* HvEITER(hv) */)
1100                 HvLAZYDEL_on(hv);
1101             else
1102                 hv_free_ent(hv, entry);
1103             xhv->xhv_keys--; /* HvKEYS(hv)-- */
1104             if (xhv->xhv_keys == 0)
1105                 HvHASKFLAGS_off(hv);
1106         }
1107         return sv;
1108     }
1109     if (SvREADONLY(hv)) {
1110         S_hv_notallowed(aTHX_ k_flags, key, klen,
1111                         "Attempt to delete disallowed key '%"SVf"' from"
1112                         " a restricted hash");
1113     }
1114
1115     if (k_flags & HVhek_FREEKEY)
1116         Safefree(key);
1117     return Nullsv;
1118 }
1119
1120 STATIC void
1121 S_hsplit(pTHX_ HV *hv)
1122 {
1123     register XPVHV* xhv = (XPVHV*)SvANY(hv);
1124     const I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
1125     register I32 newsize = oldsize * 2;
1126     register I32 i;
1127     char *a = (char*) HvARRAY(hv);
1128     register HE **aep;
1129     register HE **oentry;
1130     int longest_chain = 0;
1131     int was_shared;
1132
1133     /*PerlIO_printf(PerlIO_stderr(), "hsplit called for %p which had %d\n",
1134       hv, (int) oldsize);*/
1135
1136     if (HvPLACEHOLDERS_get(hv) && !SvREADONLY(hv)) {
1137       /* Can make this clear any placeholders first for non-restricted hashes,
1138          even though Storable rebuilds restricted hashes by putting in all the
1139          placeholders (first) before turning on the readonly flag, because
1140          Storable always pre-splits the hash.  */
1141       hv_clear_placeholders(hv);
1142     }
1143
1144     PL_nomemok = TRUE;
1145 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
1146     Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize)
1147           + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char);
1148     if (!a) {
1149       PL_nomemok = FALSE;
1150       return;
1151     }
1152     if (SvOOK(hv)) {
1153         Copy(&a[oldsize * sizeof(HE*)], &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux);
1154     }
1155 #else
1156     Newx(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize)
1157         + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char);
1158     if (!a) {
1159       PL_nomemok = FALSE;
1160       return;
1161     }
1162     Copy(HvARRAY(hv), a, oldsize * sizeof(HE*), char);
1163     if (SvOOK(hv)) {
1164         Copy(HvAUX(hv), &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux);
1165     }
1166     if (oldsize >= 64) {
1167         offer_nice_chunk(HvARRAY(hv),
1168                          PERL_HV_ARRAY_ALLOC_BYTES(oldsize)
1169                          + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0));
1170     }
1171     else
1172         Safefree(HvARRAY(hv));
1173 #endif
1174
1175     PL_nomemok = FALSE;
1176     Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char);     /* zero 2nd half*/
1177     xhv->xhv_max = --newsize;   /* HvMAX(hv) = --newsize */
1178     HvARRAY(hv) = (HE**) a;
1179     aep = (HE**)a;
1180
1181     for (i=0; i<oldsize; i++,aep++) {
1182         int left_length = 0;
1183         int right_length = 0;
1184         register HE *entry;
1185         register HE **bep;
1186
1187         if (!*aep)                              /* non-existent */
1188             continue;
1189         bep = aep+oldsize;
1190         for (oentry = aep, entry = *aep; entry; entry = *oentry) {
1191             if ((HeHASH(entry) & newsize) != (U32)i) {
1192                 *oentry = HeNEXT(entry);
1193                 HeNEXT(entry) = *bep;
1194                 if (!*bep)
1195                     xhv->xhv_fill++; /* HvFILL(hv)++ */
1196                 *bep = entry;
1197                 right_length++;
1198                 continue;
1199             }
1200             else {
1201                 oentry = &HeNEXT(entry);
1202                 left_length++;
1203             }
1204         }
1205         if (!*aep)                              /* everything moved */
1206             xhv->xhv_fill--; /* HvFILL(hv)-- */
1207         /* I think we don't actually need to keep track of the longest length,
1208            merely flag if anything is too long. But for the moment while
1209            developing this code I'll track it.  */
1210         if (left_length > longest_chain)
1211             longest_chain = left_length;
1212         if (right_length > longest_chain)
1213             longest_chain = right_length;
1214     }
1215
1216
1217     /* Pick your policy for "hashing isn't working" here:  */
1218     if (longest_chain <= HV_MAX_LENGTH_BEFORE_SPLIT /* split worked?  */
1219         || HvREHASH(hv)) {
1220         return;
1221     }
1222
1223     if (hv == PL_strtab) {
1224         /* Urg. Someone is doing something nasty to the string table.
1225            Can't win.  */
1226         return;
1227     }
1228
1229     /* Awooga. Awooga. Pathological data.  */
1230     /*PerlIO_printf(PerlIO_stderr(), "%p %d of %d with %d/%d buckets\n", hv,
1231       longest_chain, HvTOTALKEYS(hv), HvFILL(hv),  1+HvMAX(hv));*/
1232
1233     ++newsize;
1234     Newxz(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize)
1235          + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char);
1236     if (SvOOK(hv)) {
1237         Copy(HvAUX(hv), &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux);
1238     }
1239
1240     was_shared = HvSHAREKEYS(hv);
1241
1242     xhv->xhv_fill = 0;
1243     HvSHAREKEYS_off(hv);
1244     HvREHASH_on(hv);
1245
1246     aep = HvARRAY(hv);
1247
1248     for (i=0; i<newsize; i++,aep++) {
1249         register HE *entry = *aep;
1250         while (entry) {
1251             /* We're going to trash this HE's next pointer when we chain it
1252                into the new hash below, so store where we go next.  */
1253             HE * const next = HeNEXT(entry);
1254             UV hash;
1255             HE **bep;
1256
1257             /* Rehash it */
1258             PERL_HASH_INTERNAL(hash, HeKEY(entry), HeKLEN(entry));
1259
1260             if (was_shared) {
1261                 /* Unshare it.  */
1262                 HEK * const new_hek
1263                     = save_hek_flags(HeKEY(entry), HeKLEN(entry),
1264                                      hash, HeKFLAGS(entry));
1265                 unshare_hek (HeKEY_hek(entry));
1266                 HeKEY_hek(entry) = new_hek;
1267             } else {
1268                 /* Not shared, so simply write the new hash in. */
1269                 HeHASH(entry) = hash;
1270             }
1271             /*PerlIO_printf(PerlIO_stderr(), "%d ", HeKFLAGS(entry));*/
1272             HEK_REHASH_on(HeKEY_hek(entry));
1273             /*PerlIO_printf(PerlIO_stderr(), "%d\n", HeKFLAGS(entry));*/
1274
1275             /* Copy oentry to the correct new chain.  */
1276             bep = ((HE**)a) + (hash & (I32) xhv->xhv_max);
1277             if (!*bep)
1278                     xhv->xhv_fill++; /* HvFILL(hv)++ */
1279             HeNEXT(entry) = *bep;
1280             *bep = entry;
1281
1282             entry = next;
1283         }
1284     }
1285     Safefree (HvARRAY(hv));
1286     HvARRAY(hv) = (HE **)a;
1287 }
1288
1289 void
1290 Perl_hv_ksplit(pTHX_ HV *hv, IV newmax)
1291 {
1292     register XPVHV* xhv = (XPVHV*)SvANY(hv);
1293     const I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
1294     register I32 newsize;
1295     register I32 i;
1296     register char *a;
1297     register HE **aep;
1298     register HE *entry;
1299     register HE **oentry;
1300
1301     newsize = (I32) newmax;                     /* possible truncation here */
1302     if (newsize != newmax || newmax <= oldsize)
1303         return;
1304     while ((newsize & (1 + ~newsize)) != newsize) {
1305         newsize &= ~(newsize & (1 + ~newsize)); /* get proper power of 2 */
1306     }
1307     if (newsize < newmax)
1308         newsize *= 2;
1309     if (newsize < newmax)
1310         return;                                 /* overflow detection */
1311
1312     a = (char *) HvARRAY(hv);
1313     if (a) {
1314         PL_nomemok = TRUE;
1315 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
1316         Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize)
1317               + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char);
1318         if (!a) {
1319           PL_nomemok = FALSE;
1320           return;
1321         }
1322         if (SvOOK(hv)) {
1323             Copy(&a[oldsize * sizeof(HE*)], &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux);
1324         }
1325 #else
1326         Newx(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize)
1327             + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char);
1328         if (!a) {
1329           PL_nomemok = FALSE;
1330           return;
1331         }
1332         Copy(HvARRAY(hv), a, oldsize * sizeof(HE*), char);
1333         if (SvOOK(hv)) {
1334             Copy(HvAUX(hv), &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux);
1335         }
1336         if (oldsize >= 64) {
1337             offer_nice_chunk(HvARRAY(hv),
1338                              PERL_HV_ARRAY_ALLOC_BYTES(oldsize)
1339                              + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0));
1340         }
1341         else
1342             Safefree(HvARRAY(hv));
1343 #endif
1344         PL_nomemok = FALSE;
1345         Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
1346     }
1347     else {
1348         Newxz(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1349     }
1350     xhv->xhv_max = --newsize;   /* HvMAX(hv) = --newsize */
1351     HvARRAY(hv) = (HE **) a;
1352     if (!xhv->xhv_fill /* !HvFILL(hv) */)       /* skip rest if no entries */
1353         return;
1354
1355     aep = (HE**)a;
1356     for (i=0; i<oldsize; i++,aep++) {
1357         if (!*aep)                              /* non-existent */
1358             continue;
1359         for (oentry = aep, entry = *aep; entry; entry = *oentry) {
1360             register I32 j;
1361             if ((j = (HeHASH(entry) & newsize)) != i) {
1362                 j -= i;
1363                 *oentry = HeNEXT(entry);
1364                 if (!(HeNEXT(entry) = aep[j]))
1365                     xhv->xhv_fill++; /* HvFILL(hv)++ */
1366                 aep[j] = entry;
1367                 continue;
1368             }
1369             else
1370                 oentry = &HeNEXT(entry);
1371         }
1372         if (!*aep)                              /* everything moved */
1373             xhv->xhv_fill--; /* HvFILL(hv)-- */
1374     }
1375 }
1376
1377 /*
1378 =for apidoc newHV
1379
1380 Creates a new HV.  The reference count is set to 1.
1381
1382 =cut
1383 */
1384
1385 HV *
1386 Perl_newHV(pTHX)
1387 {
1388     register XPVHV* xhv;
1389     HV * const hv = (HV*)NEWSV(502,0);
1390
1391     sv_upgrade((SV *)hv, SVt_PVHV);
1392     xhv = (XPVHV*)SvANY(hv);
1393     SvPOK_off(hv);
1394     SvNOK_off(hv);
1395 #ifndef NODEFAULT_SHAREKEYS
1396     HvSHAREKEYS_on(hv);         /* key-sharing on by default */
1397 #endif
1398
1399     xhv->xhv_max    = 7;        /* HvMAX(hv) = 7 (start with 8 buckets) */
1400     xhv->xhv_fill   = 0;        /* HvFILL(hv) = 0 */
1401     return hv;
1402 }
1403
1404 HV *
1405 Perl_newHVhv(pTHX_ HV *ohv)
1406 {
1407     HV * const hv = newHV();
1408     STRLEN hv_max, hv_fill;
1409
1410     if (!ohv || (hv_fill = HvFILL(ohv)) == 0)
1411         return hv;
1412     hv_max = HvMAX(ohv);
1413
1414     if (!SvMAGICAL((SV *)ohv)) {
1415         /* It's an ordinary hash, so copy it fast. AMS 20010804 */
1416         STRLEN i;
1417         const bool shared = !!HvSHAREKEYS(ohv);
1418         HE **ents, ** const oents = (HE **)HvARRAY(ohv);
1419         char *a;
1420         Newx(a, PERL_HV_ARRAY_ALLOC_BYTES(hv_max+1), char);
1421         ents = (HE**)a;
1422
1423         /* In each bucket... */
1424         for (i = 0; i <= hv_max; i++) {
1425             HE *prev = NULL, *ent = NULL;
1426             HE *oent = oents[i];
1427
1428             if (!oent) {
1429                 ents[i] = NULL;
1430                 continue;
1431             }
1432
1433             /* Copy the linked list of entries. */
1434             for (; oent; oent = HeNEXT(oent)) {
1435                 const U32 hash   = HeHASH(oent);
1436                 const char * const key = HeKEY(oent);
1437                 const STRLEN len = HeKLEN(oent);
1438                 const int flags  = HeKFLAGS(oent);
1439
1440                 ent = new_HE();
1441                 HeVAL(ent)     = newSVsv(HeVAL(oent));
1442                 HeKEY_hek(ent)
1443                     = shared ? share_hek_flags(key, len, hash, flags)
1444                              :  save_hek_flags(key, len, hash, flags);
1445                 if (prev)
1446                     HeNEXT(prev) = ent;
1447                 else
1448                     ents[i] = ent;
1449                 prev = ent;
1450                 HeNEXT(ent) = NULL;
1451             }
1452         }
1453
1454         HvMAX(hv)   = hv_max;
1455         HvFILL(hv)  = hv_fill;
1456         HvTOTALKEYS(hv)  = HvTOTALKEYS(ohv);
1457         HvARRAY(hv) = ents;
1458     } /* not magical */
1459     else {
1460         /* Iterate over ohv, copying keys and values one at a time. */
1461         HE *entry;
1462         const I32 riter = HvRITER_get(ohv);
1463         HE * const eiter = HvEITER_get(ohv);
1464
1465         /* Can we use fewer buckets? (hv_max is always 2^n-1) */
1466         while (hv_max && hv_max + 1 >= hv_fill * 2)
1467             hv_max = hv_max / 2;
1468         HvMAX(hv) = hv_max;
1469
1470         hv_iterinit(ohv);
1471         while ((entry = hv_iternext_flags(ohv, 0))) {
1472             hv_store_flags(hv, HeKEY(entry), HeKLEN(entry),
1473                            newSVsv(HeVAL(entry)), HeHASH(entry),
1474                            HeKFLAGS(entry));
1475         }
1476         HvRITER_set(ohv, riter);
1477         HvEITER_set(ohv, eiter);
1478     }
1479
1480     return hv;
1481 }
1482
1483 void
1484 Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry)
1485 {
1486     SV *val;
1487
1488     if (!entry)
1489         return;
1490     val = HeVAL(entry);
1491     if (val && isGV(val) && GvCVu(val) && HvNAME_get(hv))
1492         PL_sub_generation++;    /* may be deletion of method from stash */
1493     SvREFCNT_dec(val);
1494     if (HeKLEN(entry) == HEf_SVKEY) {
1495         SvREFCNT_dec(HeKEY_sv(entry));
1496         Safefree(HeKEY_hek(entry));
1497     }
1498     else if (HvSHAREKEYS(hv))
1499         unshare_hek(HeKEY_hek(entry));
1500     else
1501         Safefree(HeKEY_hek(entry));
1502     del_HE(entry);
1503 }
1504
1505 void
1506 Perl_hv_delayfree_ent(pTHX_ HV *hv, register HE *entry)
1507 {
1508     if (!entry)
1509         return;
1510     /* SvREFCNT_inc to counter the SvREFCNT_dec in hv_free_ent  */
1511     sv_2mortal(SvREFCNT_inc(HeVAL(entry)));     /* free between statements */
1512     if (HeKLEN(entry) == HEf_SVKEY) {
1513         sv_2mortal(SvREFCNT_inc(HeKEY_sv(entry)));
1514     }
1515     hv_free_ent(hv, entry);
1516 }
1517
1518 /*
1519 =for apidoc hv_clear
1520
1521 Clears a hash, making it empty.
1522
1523 =cut
1524 */
1525
1526 void
1527 Perl_hv_clear(pTHX_ HV *hv)
1528 {
1529     dVAR;
1530     register XPVHV* xhv;
1531     if (!hv)
1532         return;
1533
1534     DEBUG_A(Perl_hv_assert(aTHX_ hv));
1535
1536     xhv = (XPVHV*)SvANY(hv);
1537
1538     if (SvREADONLY(hv) && HvARRAY(hv) != NULL) {
1539         /* restricted hash: convert all keys to placeholders */
1540         STRLEN i;
1541         for (i = 0; i <= xhv->xhv_max; i++) {
1542             HE *entry = (HvARRAY(hv))[i];
1543             for (; entry; entry = HeNEXT(entry)) {
1544                 /* not already placeholder */
1545                 if (HeVAL(entry) != &PL_sv_placeholder) {
1546                     if (HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
1547                         SV* keysv = hv_iterkeysv(entry);
1548                         Perl_croak(aTHX_
1549         "Attempt to delete readonly key '%"SVf"' from a restricted hash",
1550                                    keysv);
1551                     }
1552                     SvREFCNT_dec(HeVAL(entry));
1553                     HeVAL(entry) = &PL_sv_placeholder;
1554                     HvPLACEHOLDERS(hv)++;
1555                 }
1556             }
1557         }
1558         goto reset;
1559     }
1560
1561     hfreeentries(hv);
1562     HvPLACEHOLDERS_set(hv, 0);
1563     if (HvARRAY(hv))
1564         (void)memzero(HvARRAY(hv),
1565                       (xhv->xhv_max+1 /* HvMAX(hv)+1 */) * sizeof(HE*));
1566
1567     if (SvRMAGICAL(hv))
1568         mg_clear((SV*)hv);
1569
1570     HvHASKFLAGS_off(hv);
1571     HvREHASH_off(hv);
1572     reset:
1573     if (SvOOK(hv)) {
1574         HvEITER_set(hv, NULL);
1575     }
1576 }
1577
1578 /*
1579 =for apidoc hv_clear_placeholders
1580
1581 Clears any placeholders from a hash.  If a restricted hash has any of its keys
1582 marked as readonly and the key is subsequently deleted, the key is not actually
1583 deleted but is marked by assigning it a value of &PL_sv_placeholder.  This tags
1584 it so it will be ignored by future operations such as iterating over the hash,
1585 but will still allow the hash to have a value reassigned to the key at some
1586 future point.  This function clears any such placeholder keys from the hash.
1587 See Hash::Util::lock_keys() for an example of its use.
1588
1589 =cut
1590 */
1591
1592 void
1593 Perl_hv_clear_placeholders(pTHX_ HV *hv)
1594 {
1595     dVAR;
1596     I32 items = (I32)HvPLACEHOLDERS_get(hv);
1597     I32 i;
1598
1599     if (items == 0)
1600         return;
1601
1602     i = HvMAX(hv);
1603     do {
1604         /* Loop down the linked list heads  */
1605         bool first = 1;
1606         HE **oentry = &(HvARRAY(hv))[i];
1607         HE *entry = *oentry;
1608
1609         if (!entry)
1610             continue;
1611
1612         for (; entry; entry = *oentry) {
1613             if (HeVAL(entry) == &PL_sv_placeholder) {
1614                 *oentry = HeNEXT(entry);
1615                 if (first && !*oentry)
1616                     HvFILL(hv)--; /* This linked list is now empty.  */
1617                 if (HvEITER_get(hv))
1618                     HvLAZYDEL_on(hv);
1619                 else
1620                     hv_free_ent(hv, entry);
1621
1622                 if (--items == 0) {
1623                     /* Finished.  */
1624                     HvTOTALKEYS(hv) -= (IV)HvPLACEHOLDERS_get(hv);
1625                     if (HvKEYS(hv) == 0)
1626                         HvHASKFLAGS_off(hv);
1627                     HvPLACEHOLDERS_set(hv, 0);
1628                     return;
1629                 }
1630             } else {
1631                 oentry = &HeNEXT(entry);
1632                 first = 0;
1633             }
1634         }
1635     } while (--i >= 0);
1636     /* You can't get here, hence assertion should always fail.  */
1637     assert (items == 0);
1638     assert (0);
1639 }
1640
1641 STATIC void
1642 S_hfreeentries(pTHX_ HV *hv)
1643 {
1644     register HE **array;
1645     register HE *entry;
1646     I32 riter;
1647     I32 max;
1648     struct xpvhv_aux *iter;
1649
1650     if (!HvARRAY(hv))
1651         return;
1652
1653     iter =  SvOOK(hv) ? HvAUX(hv) : 0;
1654
1655     riter = 0;
1656     max = HvMAX(hv);
1657     array = HvARRAY(hv);
1658     /* make everyone else think the array is empty, so that the destructors
1659      * called for freed entries can't recusively mess with us */
1660     HvARRAY(hv) = Null(HE**);
1661     SvFLAGS(hv) &= ~SVf_OOK;
1662
1663     HvFILL(hv) = 0;
1664     ((XPVHV*) SvANY(hv))->xhv_keys = 0;
1665
1666     entry = array[0];
1667     for (;;) {
1668         if (entry) {
1669             register HE * const oentry = entry;
1670             entry = HeNEXT(entry);
1671             hv_free_ent(hv, oentry);
1672         }
1673         if (!entry) {
1674             if (++riter > max)
1675                 break;
1676             entry = array[riter];
1677         }
1678     }
1679
1680     if (SvOOK(hv)) {
1681         /* Someone attempted to iterate or set the hash name while we had
1682            the array set to 0.  */
1683         assert(HvARRAY(hv));
1684
1685         if (HvAUX(hv)->xhv_name)
1686             unshare_hek_or_pvn(HvAUX(hv)->xhv_name, 0, 0, 0);
1687         /* SvOOK_off calls sv_backoff, which isn't correct.  */
1688
1689         Safefree(HvARRAY(hv));
1690         HvARRAY(hv) = 0;
1691         SvFLAGS(hv) &= ~SVf_OOK;
1692     }
1693
1694     /* FIXME - things will still go horribly wrong (or at least leak) if
1695        people attempt to add elements to the hash while we're undef()ing it  */
1696     if (iter) {
1697         entry = iter->xhv_eiter; /* HvEITER(hv) */
1698         if (entry && HvLAZYDEL(hv)) {   /* was deleted earlier? */
1699             HvLAZYDEL_off(hv);
1700             hv_free_ent(hv, entry);
1701         }
1702         iter->xhv_riter = -1;   /* HvRITER(hv) = -1 */
1703         iter->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */
1704         SvFLAGS(hv) |= SVf_OOK;
1705     }
1706
1707     HvARRAY(hv) = array;
1708 }
1709
1710 /*
1711 =for apidoc hv_undef
1712
1713 Undefines the hash.
1714
1715 =cut
1716 */
1717
1718 void
1719 Perl_hv_undef(pTHX_ HV *hv)
1720 {
1721     register XPVHV* xhv;
1722     const char *name;
1723     if (!hv)
1724         return;
1725     DEBUG_A(Perl_hv_assert(aTHX_ hv));
1726     xhv = (XPVHV*)SvANY(hv);
1727     hfreeentries(hv);
1728     if ((name = HvNAME_get(hv))) {
1729         if(PL_stashcache)
1730             hv_delete(PL_stashcache, name, HvNAMELEN_get(hv), G_DISCARD);
1731         hv_name_set(hv, Nullch, 0, 0);
1732     }
1733     SvFLAGS(hv) &= ~SVf_OOK;
1734     Safefree(HvARRAY(hv));
1735     xhv->xhv_max   = 7; /* HvMAX(hv) = 7 (it's a normal hash) */
1736     HvARRAY(hv) = 0;
1737     HvPLACEHOLDERS_set(hv, 0);
1738
1739     if (SvRMAGICAL(hv))
1740         mg_clear((SV*)hv);
1741 }
1742
1743 static struct xpvhv_aux*
1744 S_hv_auxinit(pTHX_ HV *hv) {
1745     struct xpvhv_aux *iter;
1746     char *array;
1747
1748     if (!HvARRAY(hv)) {
1749         Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(HvMAX(hv) + 1)
1750             + sizeof(struct xpvhv_aux), char);
1751     } else {
1752         array = (char *) HvARRAY(hv);
1753         Renew(array, PERL_HV_ARRAY_ALLOC_BYTES(HvMAX(hv) + 1)
1754               + sizeof(struct xpvhv_aux), char);
1755     }
1756     HvARRAY(hv) = (HE**) array;
1757     /* SvOOK_on(hv) attacks the IV flags.  */
1758     SvFLAGS(hv) |= SVf_OOK;
1759     iter = HvAUX(hv);
1760
1761     iter->xhv_riter = -1;       /* HvRITER(hv) = -1 */
1762     iter->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */
1763     iter->xhv_name = 0;
1764
1765     return iter;
1766 }
1767
1768 /*
1769 =for apidoc hv_iterinit
1770
1771 Prepares a starting point to traverse a hash table.  Returns the number of
1772 keys in the hash (i.e. the same as C<HvKEYS(tb)>).  The return value is
1773 currently only meaningful for hashes without tie magic.
1774
1775 NOTE: Before version 5.004_65, C<hv_iterinit> used to return the number of
1776 hash buckets that happen to be in use.  If you still need that esoteric
1777 value, you can get it through the macro C<HvFILL(tb)>.
1778
1779
1780 =cut
1781 */
1782
1783 I32
1784 Perl_hv_iterinit(pTHX_ HV *hv)
1785 {
1786     HE *entry;
1787
1788     if (!hv)
1789         Perl_croak(aTHX_ "Bad hash");
1790
1791     if (SvOOK(hv)) {
1792         struct xpvhv_aux *iter = HvAUX(hv);
1793         entry = iter->xhv_eiter; /* HvEITER(hv) */
1794         if (entry && HvLAZYDEL(hv)) {   /* was deleted earlier? */
1795             HvLAZYDEL_off(hv);
1796             hv_free_ent(hv, entry);
1797         }
1798         iter->xhv_riter = -1;   /* HvRITER(hv) = -1 */
1799         iter->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */
1800     } else {
1801         S_hv_auxinit(aTHX_ hv);
1802     }
1803
1804     /* used to be xhv->xhv_fill before 5.004_65 */
1805     return HvTOTALKEYS(hv);
1806 }
1807
1808 I32 *
1809 Perl_hv_riter_p(pTHX_ HV *hv) {
1810     struct xpvhv_aux *iter;
1811
1812     if (!hv)
1813         Perl_croak(aTHX_ "Bad hash");
1814
1815     iter = SvOOK(hv) ? HvAUX(hv) : S_hv_auxinit(aTHX_ hv);
1816     return &(iter->xhv_riter);
1817 }
1818
1819 HE **
1820 Perl_hv_eiter_p(pTHX_ HV *hv) {
1821     struct xpvhv_aux *iter;
1822
1823     if (!hv)
1824         Perl_croak(aTHX_ "Bad hash");
1825
1826     iter = SvOOK(hv) ? HvAUX(hv) : S_hv_auxinit(aTHX_ hv);
1827     return &(iter->xhv_eiter);
1828 }
1829
1830 void
1831 Perl_hv_riter_set(pTHX_ HV *hv, I32 riter) {
1832     struct xpvhv_aux *iter;
1833
1834     if (!hv)
1835         Perl_croak(aTHX_ "Bad hash");
1836
1837     if (SvOOK(hv)) {
1838         iter = HvAUX(hv);
1839     } else {
1840         if (riter == -1)
1841             return;
1842
1843         iter = S_hv_auxinit(aTHX_ hv);
1844     }
1845     iter->xhv_riter = riter;
1846 }
1847
1848 void
1849 Perl_hv_eiter_set(pTHX_ HV *hv, HE *eiter) {
1850     struct xpvhv_aux *iter;
1851
1852     if (!hv)
1853         Perl_croak(aTHX_ "Bad hash");
1854
1855     if (SvOOK(hv)) {
1856         iter = HvAUX(hv);
1857     } else {
1858         /* 0 is the default so don't go malloc()ing a new structure just to
1859            hold 0.  */
1860         if (!eiter)
1861             return;
1862
1863         iter = S_hv_auxinit(aTHX_ hv);
1864     }
1865     iter->xhv_eiter = eiter;
1866 }
1867
1868 void
1869 Perl_hv_name_set(pTHX_ HV *hv, const char *name, I32 len, int flags)
1870 {
1871     struct xpvhv_aux *iter;
1872     U32 hash;
1873
1874     PERL_UNUSED_ARG(flags);
1875
1876     if (SvOOK(hv)) {
1877         iter = HvAUX(hv);
1878         if (iter->xhv_name) {
1879             unshare_hek_or_pvn(iter->xhv_name, 0, 0, 0);
1880         }
1881     } else {
1882         if (name == 0)
1883             return;
1884
1885         iter = S_hv_auxinit(aTHX_ hv);
1886     }
1887     PERL_HASH(hash, name, len);
1888     iter->xhv_name = name ? share_hek(name, len, hash) : 0;
1889 }
1890
1891 /*
1892 =for apidoc hv_iternext
1893
1894 Returns entries from a hash iterator.  See C<hv_iterinit>.
1895
1896 You may call C<hv_delete> or C<hv_delete_ent> on the hash entry that the
1897 iterator currently points to, without losing your place or invalidating your
1898 iterator.  Note that in this case the current entry is deleted from the hash
1899 with your iterator holding the last reference to it.  Your iterator is flagged
1900 to free the entry on the next call to C<hv_iternext>, so you must not discard
1901 your iterator immediately else the entry will leak - call C<hv_iternext> to
1902 trigger the resource deallocation.
1903
1904 =cut
1905 */
1906
1907 HE *
1908 Perl_hv_iternext(pTHX_ HV *hv)
1909 {
1910     return hv_iternext_flags(hv, 0);
1911 }
1912
1913 /*
1914 =for apidoc hv_iternext_flags
1915
1916 Returns entries from a hash iterator.  See C<hv_iterinit> and C<hv_iternext>.
1917 The C<flags> value will normally be zero; if HV_ITERNEXT_WANTPLACEHOLDERS is
1918 set the placeholders keys (for restricted hashes) will be returned in addition
1919 to normal keys. By default placeholders are automatically skipped over.
1920 Currently a placeholder is implemented with a value that is
1921 C<&Perl_sv_placeholder>. Note that the implementation of placeholders and
1922 restricted hashes may change, and the implementation currently is
1923 insufficiently abstracted for any change to be tidy.
1924
1925 =cut
1926 */
1927
1928 HE *
1929 Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags)
1930 {
1931     dVAR;
1932     register XPVHV* xhv;
1933     register HE *entry;
1934     HE *oldentry;
1935     MAGIC* mg;
1936     struct xpvhv_aux *iter;
1937
1938     if (!hv)
1939         Perl_croak(aTHX_ "Bad hash");
1940     xhv = (XPVHV*)SvANY(hv);
1941
1942     if (!SvOOK(hv)) {
1943         /* Too many things (well, pp_each at least) merrily assume that you can
1944            call iv_iternext without calling hv_iterinit, so we'll have to deal
1945            with it.  */
1946         hv_iterinit(hv);
1947     }
1948     iter = HvAUX(hv);
1949
1950     oldentry = entry = iter->xhv_eiter; /* HvEITER(hv) */
1951
1952     if ((mg = SvTIED_mg((SV*)hv, PERL_MAGIC_tied))) {
1953         SV *key = sv_newmortal();
1954         if (entry) {
1955             sv_setsv(key, HeSVKEY_force(entry));
1956             SvREFCNT_dec(HeSVKEY(entry));       /* get rid of previous key */
1957         }
1958         else {
1959             char *k;
1960             HEK *hek;
1961
1962             /* one HE per MAGICAL hash */
1963             iter->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */
1964             Zero(entry, 1, HE);
1965             Newxz(k, HEK_BASESIZE + sizeof(SV*), char);
1966             hek = (HEK*)k;
1967             HeKEY_hek(entry) = hek;
1968             HeKLEN(entry) = HEf_SVKEY;
1969         }
1970         magic_nextpack((SV*) hv,mg,key);
1971         if (SvOK(key)) {
1972             /* force key to stay around until next time */
1973             HeSVKEY_set(entry, SvREFCNT_inc(key));
1974             return entry;               /* beware, hent_val is not set */
1975         }
1976         if (HeVAL(entry))
1977             SvREFCNT_dec(HeVAL(entry));
1978         Safefree(HeKEY_hek(entry));
1979         del_HE(entry);
1980         iter->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */
1981         return Null(HE*);
1982     }
1983 #ifdef DYNAMIC_ENV_FETCH  /* set up %ENV for iteration */
1984     if (!entry && SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
1985         prime_env_iter();
1986 #ifdef VMS
1987         /* The prime_env_iter() on VMS just loaded up new hash values
1988          * so the iteration count needs to be reset back to the beginning
1989          */
1990         hv_iterinit(hv);
1991         iter = HvAUX(hv);
1992         oldentry = entry = iter->xhv_eiter; /* HvEITER(hv) */
1993 #endif
1994     }
1995 #endif
1996
1997     /* hv_iterint now ensures this.  */
1998     assert (HvARRAY(hv));
1999
2000     /* At start of hash, entry is NULL.  */
2001     if (entry)
2002     {
2003         entry = HeNEXT(entry);
2004         if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
2005             /*
2006              * Skip past any placeholders -- don't want to include them in
2007              * any iteration.
2008              */
2009             while (entry && HeVAL(entry) == &PL_sv_placeholder) {
2010                 entry = HeNEXT(entry);
2011             }
2012         }
2013     }
2014     while (!entry) {
2015         /* OK. Come to the end of the current list.  Grab the next one.  */
2016
2017         iter->xhv_riter++; /* HvRITER(hv)++ */
2018         if (iter->xhv_riter > (I32)xhv->xhv_max /* HvRITER(hv) > HvMAX(hv) */) {
2019             /* There is no next one.  End of the hash.  */
2020             iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
2021             break;
2022         }
2023         entry = (HvARRAY(hv))[iter->xhv_riter];
2024
2025         if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
2026             /* If we have an entry, but it's a placeholder, don't count it.
2027                Try the next.  */
2028             while (entry && HeVAL(entry) == &PL_sv_placeholder)
2029                 entry = HeNEXT(entry);
2030         }
2031         /* Will loop again if this linked list starts NULL
2032            (for HV_ITERNEXT_WANTPLACEHOLDERS)
2033            or if we run through it and find only placeholders.  */
2034     }
2035
2036     if (oldentry && HvLAZYDEL(hv)) {            /* was deleted earlier? */
2037         HvLAZYDEL_off(hv);
2038         hv_free_ent(hv, oldentry);
2039     }
2040
2041     /*if (HvREHASH(hv) && entry && !HeKREHASH(entry))
2042       PerlIO_printf(PerlIO_stderr(), "Awooga %p %p\n", hv, entry);*/
2043
2044     iter->xhv_eiter = entry; /* HvEITER(hv) = entry */
2045     return entry;
2046 }
2047
2048 /*
2049 =for apidoc hv_iterkey
2050
2051 Returns the key from the current position of the hash iterator.  See
2052 C<hv_iterinit>.
2053
2054 =cut
2055 */
2056
2057 char *
2058 Perl_hv_iterkey(pTHX_ register HE *entry, I32 *retlen)
2059 {
2060     if (HeKLEN(entry) == HEf_SVKEY) {
2061         STRLEN len;
2062         char *p = SvPV(HeKEY_sv(entry), len);
2063         *retlen = len;
2064         return p;
2065     }
2066     else {
2067         *retlen = HeKLEN(entry);
2068         return HeKEY(entry);
2069     }
2070 }
2071
2072 /* unlike hv_iterval(), this always returns a mortal copy of the key */
2073 /*
2074 =for apidoc hv_iterkeysv
2075
2076 Returns the key as an C<SV*> from the current position of the hash
2077 iterator.  The return value will always be a mortal copy of the key.  Also
2078 see C<hv_iterinit>.
2079
2080 =cut
2081 */
2082
2083 SV *
2084 Perl_hv_iterkeysv(pTHX_ register HE *entry)
2085 {
2086     return sv_2mortal(newSVhek(HeKEY_hek(entry)));
2087 }
2088
2089 /*
2090 =for apidoc hv_iterval
2091
2092 Returns the value from the current position of the hash iterator.  See
2093 C<hv_iterkey>.
2094
2095 =cut
2096 */
2097
2098 SV *
2099 Perl_hv_iterval(pTHX_ HV *hv, register HE *entry)
2100 {
2101     if (SvRMAGICAL(hv)) {
2102         if (mg_find((SV*)hv, PERL_MAGIC_tied)) {
2103             SV* sv = sv_newmortal();
2104             if (HeKLEN(entry) == HEf_SVKEY)
2105                 mg_copy((SV*)hv, sv, (char*)HeKEY_sv(entry), HEf_SVKEY);
2106             else
2107                 mg_copy((SV*)hv, sv, HeKEY(entry), HeKLEN(entry));
2108             return sv;
2109         }
2110     }
2111     return HeVAL(entry);
2112 }
2113
2114 /*
2115 =for apidoc hv_iternextsv
2116
2117 Performs an C<hv_iternext>, C<hv_iterkey>, and C<hv_iterval> in one
2118 operation.
2119
2120 =cut
2121 */
2122
2123 SV *
2124 Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen)
2125 {
2126     HE *he;
2127     if ( (he = hv_iternext_flags(hv, 0)) == NULL)
2128         return NULL;
2129     *key = hv_iterkey(he, retlen);
2130     return hv_iterval(hv, he);
2131 }
2132
2133 /*
2134 =for apidoc hv_magic
2135
2136 Adds magic to a hash.  See C<sv_magic>.
2137
2138 =cut
2139 */
2140
2141 void
2142 Perl_hv_magic(pTHX_ HV *hv, GV *gv, int how)
2143 {
2144     sv_magic((SV*)hv, (SV*)gv, how, Nullch, 0);
2145 }
2146
2147 #if 0 /* use the macro from hv.h instead */
2148
2149 char*
2150 Perl_sharepvn(pTHX_ const char *sv, I32 len, U32 hash)
2151 {
2152     return HEK_KEY(share_hek(sv, len, hash));
2153 }
2154
2155 #endif
2156
2157 /* possibly free a shared string if no one has access to it
2158  * len and hash must both be valid for str.
2159  */
2160 void
2161 Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
2162 {
2163     unshare_hek_or_pvn (NULL, str, len, hash);
2164 }
2165
2166
2167 void
2168 Perl_unshare_hek(pTHX_ HEK *hek)
2169 {
2170     unshare_hek_or_pvn(hek, NULL, 0, 0);
2171 }
2172
2173 /* possibly free a shared string if no one has access to it
2174    hek if non-NULL takes priority over the other 3, else str, len and hash
2175    are used.  If so, len and hash must both be valid for str.
2176  */
2177 STATIC void
2178 S_unshare_hek_or_pvn(pTHX_ const HEK *hek, const char *str, I32 len, U32 hash)
2179 {
2180     register XPVHV* xhv;
2181     register HE *entry;
2182     register HE **oentry;
2183     HE **first;
2184     bool found = 0;
2185     bool is_utf8 = FALSE;
2186     int k_flags = 0;
2187     const char * const save = str;
2188     struct shared_he *he = 0;
2189
2190     if (hek) {
2191         /* Find the shared he which is just before us in memory.  */
2192         he = (struct shared_he *)(((char *)hek)
2193                                   - STRUCT_OFFSET(struct shared_he,
2194                                                   shared_he_hek));
2195
2196         /* Assert that the caller passed us a genuine (or at least consistent)
2197            shared hek  */
2198         assert (he->shared_he_he.hent_hek == hek);
2199
2200         LOCK_STRTAB_MUTEX;
2201         if (he->shared_he_he.hent_val - 1) {
2202             --he->shared_he_he.hent_val;
2203             UNLOCK_STRTAB_MUTEX;
2204             return;
2205         }
2206         UNLOCK_STRTAB_MUTEX;
2207
2208         hash = HEK_HASH(hek);
2209     } else if (len < 0) {
2210         STRLEN tmplen = -len;
2211         is_utf8 = TRUE;
2212         /* See the note in hv_fetch(). --jhi */
2213         str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2214         len = tmplen;
2215         if (is_utf8)
2216             k_flags = HVhek_UTF8;
2217         if (str != save)
2218             k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2219     }
2220
2221     /* what follows is the moral equivalent of:
2222     if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) {
2223         if (--*Svp == Nullsv)
2224             hv_delete(PL_strtab, str, len, G_DISCARD, hash);
2225     } */
2226     xhv = (XPVHV*)SvANY(PL_strtab);
2227     /* assert(xhv_array != 0) */
2228     LOCK_STRTAB_MUTEX;
2229     first = oentry = &(HvARRAY(PL_strtab))[hash & (I32) HvMAX(PL_strtab)];
2230     if (he) {
2231         const HE *const he_he = &(he->shared_he_he);
2232         for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) {
2233             if (entry != he_he)
2234                 continue;
2235             found = 1;
2236             break;
2237         }
2238     } else {
2239         const int flags_masked = k_flags & HVhek_MASK;
2240         for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) {
2241             if (HeHASH(entry) != hash)          /* strings can't be equal */
2242                 continue;
2243             if (HeKLEN(entry) != len)
2244                 continue;
2245             if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len))     /* is this it? */
2246                 continue;
2247             if (HeKFLAGS(entry) != flags_masked)
2248                 continue;
2249             found = 1;
2250             break;
2251         }
2252     }
2253
2254     if (found) {
2255         if (--HeVAL(entry) == Nullsv) {
2256             *oentry = HeNEXT(entry);
2257             if (!*first) {
2258                 /* There are now no entries in our slot.  */
2259                 xhv->xhv_fill--; /* HvFILL(hv)-- */
2260             }
2261             Safefree(entry);
2262             xhv->xhv_keys--; /* HvKEYS(hv)-- */
2263         }
2264     }
2265
2266     UNLOCK_STRTAB_MUTEX;
2267     if (!found && ckWARN_d(WARN_INTERNAL))
2268         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
2269                     "Attempt to free non-existent shared string '%s'%s"
2270                     pTHX__FORMAT,
2271                     hek ? HEK_KEY(hek) : str,
2272                     ((k_flags & HVhek_UTF8) ? " (utf8)" : "") pTHX__VALUE);
2273     if (k_flags & HVhek_FREEKEY)
2274         Safefree(str);
2275 }
2276
2277 /* get a (constant) string ptr from the global string table
2278  * string will get added if it is not already there.
2279  * len and hash must both be valid for str.
2280  */
2281 HEK *
2282 Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash)
2283 {
2284     bool is_utf8 = FALSE;
2285     int flags = 0;
2286     const char * const save = str;
2287
2288     if (len < 0) {
2289       STRLEN tmplen = -len;
2290       is_utf8 = TRUE;
2291       /* See the note in hv_fetch(). --jhi */
2292       str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2293       len = tmplen;
2294       /* If we were able to downgrade here, then than means that we were passed
2295          in a key which only had chars 0-255, but was utf8 encoded.  */
2296       if (is_utf8)
2297           flags = HVhek_UTF8;
2298       /* If we found we were able to downgrade the string to bytes, then
2299          we should flag that it needs upgrading on keys or each.  Also flag
2300          that we need share_hek_flags to free the string.  */
2301       if (str != save)
2302           flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2303     }
2304
2305     return share_hek_flags (str, len, hash, flags);
2306 }
2307
2308 STATIC HEK *
2309 S_share_hek_flags(pTHX_ const char *str, I32 len, register U32 hash, int flags)
2310 {
2311     register HE *entry;
2312     register HE **oentry;
2313     I32 found = 0;
2314     const int flags_masked = flags & HVhek_MASK;
2315
2316     /* what follows is the moral equivalent of:
2317
2318     if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
2319         hv_store(PL_strtab, str, len, Nullsv, hash);
2320
2321         Can't rehash the shared string table, so not sure if it's worth
2322         counting the number of entries in the linked list
2323     */
2324     register XPVHV * const xhv = (XPVHV*)SvANY(PL_strtab);
2325     /* assert(xhv_array != 0) */
2326     LOCK_STRTAB_MUTEX;
2327     oentry = &(HvARRAY(PL_strtab))[hash & (I32) HvMAX(PL_strtab)];
2328     for (entry = *oentry; entry; entry = HeNEXT(entry)) {
2329         if (HeHASH(entry) != hash)              /* strings can't be equal */
2330             continue;
2331         if (HeKLEN(entry) != len)
2332             continue;
2333         if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
2334             continue;
2335         if (HeKFLAGS(entry) != flags_masked)
2336             continue;
2337         found = 1;
2338         break;
2339     }
2340     if (!found) {
2341         /* What used to be head of the list.
2342            If this is NULL, then we're the first entry for this slot, which
2343            means we need to increate fill.  */
2344         const HE *old_first = *oentry;
2345         struct shared_he *new_entry;
2346         HEK *hek;
2347         char *k;
2348
2349         /* We don't actually store a HE from the arena and a regular HEK.
2350            Instead we allocate one chunk of memory big enough for both,
2351            and put the HEK straight after the HE. This way we can find the
2352            HEK directly from the HE.
2353         */
2354
2355         Newx(k, STRUCT_OFFSET(struct shared_he,
2356                                 shared_he_hek.hek_key[0]) + len + 2, char);
2357         new_entry = (struct shared_he *)k;
2358         entry = &(new_entry->shared_he_he);
2359         hek = &(new_entry->shared_he_hek);
2360
2361         Copy(str, HEK_KEY(hek), len, char);
2362         HEK_KEY(hek)[len] = 0;
2363         HEK_LEN(hek) = len;
2364         HEK_HASH(hek) = hash;
2365         HEK_FLAGS(hek) = (unsigned char)flags_masked;
2366
2367         /* Still "point" to the HEK, so that other code need not know what
2368            we're up to.  */
2369         HeKEY_hek(entry) = hek;
2370         HeVAL(entry) = Nullsv;
2371         HeNEXT(entry) = *oentry;
2372         *oentry = entry;
2373
2374         xhv->xhv_keys++; /* HvKEYS(hv)++ */
2375         if (!old_first) {                       /* initial entry? */
2376             xhv->xhv_fill++; /* HvFILL(hv)++ */
2377         } else if (xhv->xhv_keys > (IV)xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */) {
2378                 hsplit(PL_strtab);
2379         }
2380     }
2381
2382     ++HeVAL(entry);                             /* use value slot as REFCNT */
2383     UNLOCK_STRTAB_MUTEX;
2384
2385     if (flags & HVhek_FREEKEY)
2386         Safefree(str);
2387
2388     return HeKEY_hek(entry);
2389 }
2390
2391 I32 *
2392 Perl_hv_placeholders_p(pTHX_ HV *hv)
2393 {
2394     dVAR;
2395     MAGIC *mg = mg_find((SV*)hv, PERL_MAGIC_rhash);
2396
2397     if (!mg) {
2398         mg = sv_magicext((SV*)hv, 0, PERL_MAGIC_rhash, 0, 0, 0);
2399
2400         if (!mg) {
2401             Perl_die(aTHX_ "panic: hv_placeholders_p");
2402         }
2403     }
2404     return &(mg->mg_len);
2405 }
2406
2407
2408 I32
2409 Perl_hv_placeholders_get(pTHX_ HV *hv)
2410 {
2411     dVAR;
2412     MAGIC * const mg = mg_find((SV*)hv, PERL_MAGIC_rhash);
2413
2414     return mg ? mg->mg_len : 0;
2415 }
2416
2417 void
2418 Perl_hv_placeholders_set(pTHX_ HV *hv, I32 ph)
2419 {
2420     dVAR;
2421     MAGIC * const mg = mg_find((SV*)hv, PERL_MAGIC_rhash);
2422
2423     if (mg) {
2424         mg->mg_len = ph;
2425     } else if (ph) {
2426         if (!sv_magicext((SV*)hv, 0, PERL_MAGIC_rhash, 0, 0, ph))
2427             Perl_die(aTHX_ "panic: hv_placeholders_set");
2428     }
2429     /* else we don't need to add magic to record 0 placeholders.  */
2430 }
2431
2432 /*
2433 =for apidoc hv_assert
2434
2435 Check that a hash is in an internally consistent state.
2436
2437 =cut
2438 */
2439
2440 void
2441 Perl_hv_assert(pTHX_ HV *hv)
2442 {
2443   dVAR;
2444   HE* entry;
2445   int withflags = 0;
2446   int placeholders = 0;
2447   int real = 0;
2448   int bad = 0;
2449   const I32 riter = HvRITER_get(hv);
2450   HE *eiter = HvEITER_get(hv);
2451
2452   (void)hv_iterinit(hv);
2453
2454   while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))) {
2455     /* sanity check the values */
2456     if (HeVAL(entry) == &PL_sv_placeholder) {
2457       placeholders++;
2458     } else {
2459       real++;
2460     }
2461     /* sanity check the keys */
2462     if (HeSVKEY(entry)) {
2463       /* Don't know what to check on SV keys.  */
2464     } else if (HeKUTF8(entry)) {
2465       withflags++;
2466        if (HeKWASUTF8(entry)) {
2467          PerlIO_printf(Perl_debug_log,
2468                        "hash key has both WASUFT8 and UTF8: '%.*s'\n",
2469                        (int) HeKLEN(entry),  HeKEY(entry));
2470          bad = 1;
2471        }
2472     } else if (HeKWASUTF8(entry)) {
2473       withflags++;
2474     }
2475   }
2476   if (!SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) {
2477     if (HvUSEDKEYS(hv) != real) {
2478       PerlIO_printf(Perl_debug_log, "Count %d key(s), but hash reports %d\n",
2479                     (int) real, (int) HvUSEDKEYS(hv));
2480       bad = 1;
2481     }
2482     if (HvPLACEHOLDERS_get(hv) != placeholders) {
2483       PerlIO_printf(Perl_debug_log,
2484                     "Count %d placeholder(s), but hash reports %d\n",
2485                     (int) placeholders, (int) HvPLACEHOLDERS_get(hv));
2486       bad = 1;
2487     }
2488   }
2489   if (withflags && ! HvHASKFLAGS(hv)) {
2490     PerlIO_printf(Perl_debug_log,
2491                   "Hash has HASKFLAGS off but I count %d key(s) with flags\n",
2492                   withflags);
2493     bad = 1;
2494   }
2495   if (bad) {
2496     sv_dump((SV *)hv);
2497   }
2498   HvRITER_set(hv, riter);               /* Restore hash iterator state */
2499   HvEITER_set(hv, eiter);
2500 }
2501
2502 /*
2503  * Local variables:
2504  * c-indentation-style: bsd
2505  * c-basic-offset: 4
2506  * indent-tabs-mode: t
2507  * End:
2508  *
2509  * ex: set ts=8 sts=4 sw=4 noet:
2510  */