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