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