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