hv.c

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