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