hv.c

   1 /*    hv.c
   2  *
   3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
   4  *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 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
  13  *          of all that I have seen.
  14  *                         --Bilbo
  15  *
  16  *     [p.278 of _The Lord of the Rings_, II/iii: "The Ring Goes South"]
  17  */
  18
  19 /*
  20 =head1 Hash Manipulation Functions
  21
  22 A HV structure represents a Perl hash. It consists mainly of an array
  23 of pointers, each of which points to a linked list of HE structures. The
  24 array is indexed by the hash function of the key, so each linked list
  25 represents all the hash entries with the same hash value. Each HE contains
  26 a pointer to the actual value, plus a pointer to a HEK structure which
  27 holds the key and hash value.
  28
  29 =cut
  30
  31 */
  32
  33 #include "EXTERN.h"
  34 #define PERL_IN_HV_C
  35 #define PERL_HASH_INTERNAL_ACCESS
  36 #include "perl.h"
  37
  38 #define HV_MAX_LENGTH_BEFORE_SPLIT 14
  39
  40 static const char S_strtab_error[]
  41     = "Cannot modify shared string table in hv_%s";
  42
  43 #ifdef PURIFY
  44
  45 #define new_HE() (HE*)safemalloc(sizeof(HE))
  46 #define del_HE(p) safefree((char*)p)
  47
  48 #else
  49
  50 STATIC HE*
  51 S_new_he(pTHX)
  52 {
  53     dVAR;
  54     HE* he;
  55     void ** const root = &PL_body_roots[HE_SVSLOT];
  56
  57     if (!*root)
  58         Perl_more_bodies(aTHX_ HE_SVSLOT, sizeof(HE), PERL_ARENA_SIZE);
  59     he = (HE*) *root;
  60     assert(he);
  61     *root = HeNEXT(he);
  62     return he;
  63 }
  64
  65 #define new_HE() new_he()
  66 #define del_HE(p) \
  67     STMT_START { \
  68         HeNEXT(p) = (HE*)(PL_body_roots[HE_SVSLOT]);    \
  69         PL_body_roots[HE_SVSLOT] = p; \
  70     } STMT_END
  71
  72
  73
  74 #endif
  75
  76 STATIC HEK *
  77 S_save_hek_flags(const char *str, I32 len, U32 hash, int flags)
  78 {
  79     const int flags_masked = flags & HVhek_MASK;
  80     char *k;
  81     register HEK *hek;
  82
  83     PERL_ARGS_ASSERT_SAVE_HEK_FLAGS;
  84
  85     Newx(k, HEK_BASESIZE + len + 2, char);
  86     hek = (HEK*)k;
  87     Copy(str, HEK_KEY(hek), len, char);
  88     HEK_KEY(hek)[len] = 0;
  89     HEK_LEN(hek) = len;
  90     HEK_HASH(hek) = hash;
  91     HEK_FLAGS(hek) = (unsigned char)flags_masked | HVhek_UNSHARED;
  92
  93     if (flags & HVhek_FREEKEY)
  94         Safefree(str);
  95     return hek;
  96 }
  97
  98 /* free the pool of temporary HE/HEK pairs returned by hv_fetch_ent
  99  * for tied hashes */
 100
 101 void
 102 Perl_free_tied_hv_pool(pTHX)
 103 {
 104     dVAR;
 105     HE *he = PL_hv_fetch_ent_mh;
 106     while (he) {
 107         HE * const ohe = he;
 108         Safefree(HeKEY_hek(he));
 109         he = HeNEXT(he);
 110         del_HE(ohe);
 111     }
 112     PL_hv_fetch_ent_mh = NULL;
 113 }
 114
 115 #if defined(USE_ITHREADS)
 116 HEK *
 117 Perl_hek_dup(pTHX_ HEK *source, CLONE_PARAMS* param)
 118 {
 119     HEK *shared;
 120
 121     PERL_ARGS_ASSERT_HEK_DUP;
 122     PERL_UNUSED_ARG(param);
 123
 124     if (!source)
 125         return NULL;
 126
 127     shared = (HEK*)ptr_table_fetch(PL_ptr_table, source);
 128     if (shared) {
 129         /* We already shared this hash key.  */
 130         (void)share_hek_hek(shared);
 131     }
 132     else {
 133         shared
 134             = share_hek_flags(HEK_KEY(source), HEK_LEN(source),
 135                               HEK_HASH(source), HEK_FLAGS(source));
 136         ptr_table_store(PL_ptr_table, source, shared);
 137     }
 138     return shared;
 139 }
 140
 141 HE *
 142 Perl_he_dup(pTHX_ const HE *e, bool shared, CLONE_PARAMS* param)
 143 {
 144     HE *ret;
 145
 146     PERL_ARGS_ASSERT_HE_DUP;
 147
 148     if (!e)
 149         return NULL;
 150     /* look for it in the table first */
 151     ret = (HE*)ptr_table_fetch(PL_ptr_table, e);
 152     if (ret)
 153         return ret;
 154
 155     /* create anew and remember what it is */
 156     ret = new_HE();
 157     ptr_table_store(PL_ptr_table, e, ret);
 158
 159     HeNEXT(ret) = he_dup(HeNEXT(e),shared, param);
 160     if (HeKLEN(e) == HEf_SVKEY) {
 161         char *k;
 162         Newx(k, HEK_BASESIZE + sizeof(const SV *), char);
 163         HeKEY_hek(ret) = (HEK*)k;
 164         HeKEY_sv(ret) = sv_dup_inc(HeKEY_sv(e), param);
 165     }
 166     else if (shared) {
 167         /* This is hek_dup inlined, which seems to be important for speed
 168            reasons.  */
 169         HEK * const source = HeKEY_hek(e);
 170         HEK *shared = (HEK*)ptr_table_fetch(PL_ptr_table, source);
 171
 172         if (shared) {
 173             /* We already shared this hash key.  */
 174             (void)share_hek_hek(shared);
 175         }
 176         else {
 177             shared
 178                 = share_hek_flags(HEK_KEY(source), HEK_LEN(source),
 179                                   HEK_HASH(source), HEK_FLAGS(source));
 180             ptr_table_store(PL_ptr_table, source, shared);
 181         }
 182         HeKEY_hek(ret) = shared;
 183     }
 184     else
 185         HeKEY_hek(ret) = save_hek_flags(HeKEY(e), HeKLEN(e), HeHASH(e),
 186                                         HeKFLAGS(e));
 187     HeVAL(ret) = sv_dup_inc(HeVAL(e), param);
 188     return ret;
 189 }
 190 #endif  /* USE_ITHREADS */
 191
 192 static void
 193 S_hv_notallowed(pTHX_ int flags, const char *key, I32 klen,
 194                 const char *msg)
 195 {
 196     SV * const sv = sv_newmortal();
 197
 198     PERL_ARGS_ASSERT_HV_NOTALLOWED;
 199
 200     if (!(flags & HVhek_FREEKEY)) {
 201         sv_setpvn(sv, key, klen);
 202     }
 203     else {
 204         /* Need to free saved eventually assign to mortal SV */
 205         /* XXX is this line an error ???:  SV *sv = sv_newmortal(); */
 206         sv_usepvn(sv, (char *) key, klen);
 207     }
 208     if (flags & HVhek_UTF8) {
 209         SvUTF8_on(sv);
 210     }
 211     Perl_croak(aTHX_ msg, SVfARG(sv));
 212 }
 213
 214 /* (klen == HEf_SVKEY) is special for MAGICAL hv entries, meaning key slot
 215  * contains an SV* */
 216
 217 /*
 218 =for apidoc hv_store
 219
 220 Stores an SV in a hash.  The hash key is specified as C<key> and C<klen> is
 221 the length of the key.  The C<hash> parameter is the precomputed hash
 222 value; if it is zero then Perl will compute it.  The return value will be
 223 NULL if the operation failed or if the value did not need to be actually
 224 stored within the hash (as in the case of tied hashes).  Otherwise it can
 225 be dereferenced to get the original C<SV*>.  Note that the caller is
 226 responsible for suitably incrementing the reference count of C<val> before
 227 the call, and decrementing it if the function returned NULL.  Effectively
 228 a successful hv_store takes ownership of one reference to C<val>.  This is
 229 usually what you want; a newly created SV has a reference count of one, so
 230 if all your code does is create SVs then store them in a hash, hv_store
 231 will own the only reference to the new SV, and your code doesn't need to do
 232 anything further to tidy up.  hv_store is not implemented as a call to
 233 hv_store_ent, and does not create a temporary SV for the key, so if your
 234 key data is not already in SV form then use hv_store in preference to
 235 hv_store_ent.
 236
 237 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
 238 information on how to use this function on tied hashes.
 239
 240 =for apidoc hv_store_ent
 241
 242 Stores C<val> in a hash.  The hash key is specified as C<key>.  The C<hash>
 243 parameter is the precomputed hash value; if it is zero then Perl will
 244 compute it.  The return value is the new hash entry so created.  It will be
 245 NULL if the operation failed or if the value did not need to be actually
 246 stored within the hash (as in the case of tied hashes).  Otherwise the
 247 contents of the return value can be accessed using the C<He?> macros
 248 described here.  Note that the caller is responsible for suitably
 249 incrementing the reference count of C<val> before the call, and
 250 decrementing it if the function returned NULL.  Effectively a successful
 251 hv_store_ent takes ownership of one reference to C<val>.  This is
 252 usually what you want; a newly created SV has a reference count of one, so
 253 if all your code does is create SVs then store them in a hash, hv_store
 254 will own the only reference to the new SV, and your code doesn't need to do
 255 anything further to tidy up.  Note that hv_store_ent only reads the C<key>;
 256 unlike C<val> it does not take ownership of it, so maintaining the correct
 257 reference count on C<key> is entirely the caller's responsibility.  hv_store
 258 is not implemented as a call to hv_store_ent, and does not create a temporary
 259 SV for the key, so if your key data is not already in SV form then use
 260 hv_store in preference to hv_store_ent.
 261
 262 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
 263 information on how to use this function on tied hashes.
 264
 265 =for apidoc hv_exists
 266
 267 Returns a boolean indicating whether the specified hash key exists.  The
 268 C<klen> is the length of the key.
 269
 270 =for apidoc hv_fetch
 271
 272 Returns the SV which corresponds to the specified key in the hash.  The
 273 C<klen> is the length of the key.  If C<lval> is set then the fetch will be
 274 part of a store.  Check that the return value is non-null before
 275 dereferencing it to an C<SV*>.
 276
 277 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
 278 information on how to use this function on tied hashes.
 279
 280 =for apidoc hv_exists_ent
 281
 282 Returns a boolean indicating whether the specified hash key exists. C<hash>
 283 can be a valid precomputed hash value, or 0 to ask for it to be
 284 computed.
 285
 286 =cut
 287 */
 288
 289 /* returns an HE * structure with the all fields set */
 290 /* note that hent_val will be a mortal sv for MAGICAL hashes */
 291 /*
 292 =for apidoc hv_fetch_ent
 293
 294 Returns the hash entry which corresponds to the specified key in the hash.
 295 C<hash> must be a valid precomputed hash number for the given C<key>, or 0
 296 if you want the function to compute it.  IF C<lval> is set then the fetch
 297 will be part of a store.  Make sure the return value is non-null before
 298 accessing it.  The return value when C<hv> is a tied hash is a pointer to a
 299 static location, so be sure to make a copy of the structure if you need to
 300 store it somewhere.
 301
 302 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
 303 information on how to use this function on tied hashes.
 304
 305 =cut
 306 */
 307
 308 /* Common code for hv_delete()/hv_exists()/hv_fetch()/hv_store()  */
 309 void *
 310 Perl_hv_common_key_len(pTHX_ HV *hv, const char *key, I32 klen_i32,
 311                        const int action, SV *val, const U32 hash)
 312 {
 313     STRLEN klen;
 314     int flags;
 315
 316     PERL_ARGS_ASSERT_HV_COMMON_KEY_LEN;
 317
 318     if (klen_i32 < 0) {
 319         klen = -klen_i32;
 320         flags = HVhek_UTF8;
 321     } else {
 322         klen = klen_i32;
 323         flags = 0;
 324     }
 325     return hv_common(hv, NULL, key, klen, flags, action, val, hash);
 326 }
 327
 328 void *
 329 Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
 330                int flags, int action, SV *val, register U32 hash)
 331 {
 332     dVAR;
 333     XPVHV* xhv;
 334     HE *entry;
 335     HE **oentry;
 336     SV *sv;
 337     bool is_utf8;
 338     int masked_flags;
 339     const int return_svp = action & HV_FETCH_JUST_SV;
 340
 341     if (!hv)
 342         return NULL;
 343     if (SvTYPE(hv) == SVTYPEMASK)
 344         return NULL;
 345
 346     assert(SvTYPE(hv) == SVt_PVHV);
 347
 348     if (SvSMAGICAL(hv) && SvGMAGICAL(hv) && !(action & HV_DISABLE_UVAR_XKEY)) {
 349         MAGIC* mg;
 350         if ((mg = mg_find((const SV *)hv, PERL_MAGIC_uvar))) {
 351             struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
 352             if (uf->uf_set == NULL) {
 353                 SV* obj = mg->mg_obj;
 354
 355                 if (!keysv) {
 356                     keysv = newSVpvn_flags(key, klen, SVs_TEMP |
 357                                            ((flags & HVhek_UTF8)
 358                                             ? SVf_UTF8 : 0));
 359                 }
 360
 361                 mg->mg_obj = keysv;         /* pass key */
 362                 uf->uf_index = action;      /* pass action */
 363                 magic_getuvar(MUTABLE_SV(hv), mg);
 364                 keysv = mg->mg_obj;         /* may have changed */
 365                 mg->mg_obj = obj;
 366
 367                 /* If the key may have changed, then we need to invalidate
 368                    any passed-in computed hash value.  */
 369                 hash = 0;
 370             }
 371         }
 372     }
 373     if (keysv) {
 374         if (flags & HVhek_FREEKEY)
 375             Safefree(key);
 376         key = SvPV_const(keysv, klen);
 377         is_utf8 = (SvUTF8(keysv) != 0);
 378         if (SvIsCOW_shared_hash(keysv)) {
 379             flags = HVhek_KEYCANONICAL | (is_utf8 ? HVhek_UTF8 : 0);
 380         } else {
 381             flags = 0;
 382         }
 383     } else {
 384         is_utf8 = ((flags & HVhek_UTF8) ? TRUE : FALSE);
 385     }
 386
 387     if (action & HV_DELETE) {
 388         return (void *) hv_delete_common(hv, keysv, key, klen,
 389                                          flags | (is_utf8 ? HVhek_UTF8 : 0),
 390                                          action, hash);
 391     }
 392
 393     xhv = (XPVHV*)SvANY(hv);
 394     if (SvMAGICAL(hv)) {
 395         if (SvRMAGICAL(hv) && !(action & (HV_FETCH_ISSTORE|HV_FETCH_ISEXISTS))) {
 396             if (mg_find((const SV *)hv, PERL_MAGIC_tied)
 397                 || SvGMAGICAL((const SV *)hv))
 398             {
 399                 /* FIXME should be able to skimp on the HE/HEK here when
 400                    HV_FETCH_JUST_SV is true.  */
 401                 if (!keysv) {
 402                     keysv = newSVpvn_utf8(key, klen, is_utf8);
 403                 } else {
 404                     keysv = newSVsv(keysv);
 405                 }
 406                 sv = sv_newmortal();
 407                 mg_copy(MUTABLE_SV(hv), sv, (char *)keysv, HEf_SVKEY);
 408
 409                 /* grab a fake HE/HEK pair from the pool or make a new one */
 410                 entry = PL_hv_fetch_ent_mh;
 411                 if (entry)
 412                     PL_hv_fetch_ent_mh = HeNEXT(entry);
 413                 else {
 414                     char *k;
 415                     entry = new_HE();
 416                     Newx(k, HEK_BASESIZE + sizeof(const SV *), char);
 417                     HeKEY_hek(entry) = (HEK*)k;
 418                 }
 419                 HeNEXT(entry) = NULL;
 420                 HeSVKEY_set(entry, keysv);
 421                 HeVAL(entry) = sv;
 422                 sv_upgrade(sv, SVt_PVLV);
 423                 LvTYPE(sv) = 'T';
 424                  /* so we can free entry when freeing sv */
 425                 LvTARG(sv) = MUTABLE_SV(entry);
 426
 427                 /* XXX remove at some point? */
 428                 if (flags & HVhek_FREEKEY)
 429                     Safefree(key);
 430
 431                 if (return_svp) {
 432                     return entry ? (void *) &HeVAL(entry) : NULL;
 433                 }
 434                 return (void *) entry;
 435             }
 436 #ifdef ENV_IS_CASELESS
 437             else if (mg_find((const SV *)hv, PERL_MAGIC_env)) {
 438                 U32 i;
 439                 for (i = 0; i < klen; ++i)
 440                     if (isLOWER(key[i])) {
 441                         /* Would be nice if we had a routine to do the
 442                            copy and upercase in a single pass through.  */
 443                         const char * const nkey = strupr(savepvn(key,klen));
 444                         /* Note that this fetch is for nkey (the uppercased
 445                            key) whereas the store is for key (the original)  */
 446                         void *result = hv_common(hv, NULL, nkey, klen,
 447                                                  HVhek_FREEKEY, /* free nkey */
 448                                                  0 /* non-LVAL fetch */
 449                                                  | HV_DISABLE_UVAR_XKEY
 450                                                  | return_svp,
 451                                                  NULL /* no value */,
 452                                                  0 /* compute hash */);
 453                         if (!result && (action & HV_FETCH_LVALUE)) {
 454                             /* This call will free key if necessary.
 455                                Do it this way to encourage compiler to tail
 456                                call optimise.  */
 457                             result = hv_common(hv, keysv, key, klen, flags,
 458                                                HV_FETCH_ISSTORE
 459                                                | HV_DISABLE_UVAR_XKEY
 460                                                | return_svp,
 461                                                newSV(0), hash);
 462                         } else {
 463                             if (flags & HVhek_FREEKEY)
 464                                 Safefree(key);
 465                         }
 466                         return result;
 467                     }
 468             }
 469 #endif
 470         } /* ISFETCH */
 471         else if (SvRMAGICAL(hv) && (action & HV_FETCH_ISEXISTS)) {
 472             if (mg_find((const SV *)hv, PERL_MAGIC_tied)
 473                 || SvGMAGICAL((const SV *)hv)) {
 474                 /* I don't understand why hv_exists_ent has svret and sv,
 475                    whereas hv_exists only had one.  */
 476                 SV * const svret = sv_newmortal();
 477                 sv = sv_newmortal();
 478
 479                 if (keysv || is_utf8) {
 480                     if (!keysv) {
 481                         keysv = newSVpvn_utf8(key, klen, TRUE);
 482                     } else {
 483                         keysv = newSVsv(keysv);
 484                     }
 485                     mg_copy(MUTABLE_SV(hv), sv, (char *)sv_2mortal(keysv), HEf_SVKEY);
 486                 } else {
 487                     mg_copy(MUTABLE_SV(hv), sv, key, klen);
 488                 }
 489                 if (flags & HVhek_FREEKEY)
 490                     Safefree(key);
 491                 magic_existspack(svret, mg_find(sv, PERL_MAGIC_tiedelem));
 492                 /* This cast somewhat evil, but I'm merely using NULL/
 493                    not NULL to return the boolean exists.
 494                    And I know hv is not NULL.  */
 495                 return SvTRUE(svret) ? (void *)hv : NULL;
 496                 }
 497 #ifdef ENV_IS_CASELESS
 498             else if (mg_find((const SV *)hv, PERL_MAGIC_env)) {
 499                 /* XXX This code isn't UTF8 clean.  */
 500                 char * const keysave = (char * const)key;
 501                 /* Will need to free this, so set FREEKEY flag.  */
 502                 key = savepvn(key,klen);
 503                 key = (const char*)strupr((char*)key);
 504                 is_utf8 = FALSE;
 505                 hash = 0;
 506                 keysv = 0;
 507
 508                 if (flags & HVhek_FREEKEY) {
 509                     Safefree(keysave);
 510                 }
 511                 flags |= HVhek_FREEKEY;
 512             }
 513 #endif
 514         } /* ISEXISTS */
 515         else if (action & HV_FETCH_ISSTORE) {
 516             bool needs_copy;
 517             bool needs_store;
 518             hv_magic_check (hv, &needs_copy, &needs_store);
 519             if (needs_copy) {
 520                 const bool save_taint = PL_tainted;
 521                 if (keysv || is_utf8) {
 522                     if (!keysv) {
 523                         keysv = newSVpvn_utf8(key, klen, TRUE);
 524                     }
 525                     if (PL_tainting)
 526                         PL_tainted = SvTAINTED(keysv);
 527                     keysv = sv_2mortal(newSVsv(keysv));
 528                     mg_copy(MUTABLE_SV(hv), val, (char*)keysv, HEf_SVKEY);
 529                 } else {
 530                     mg_copy(MUTABLE_SV(hv), val, key, klen);
 531                 }
 532
 533                 TAINT_IF(save_taint);
 534                 if (!needs_store) {
 535                     if (flags & HVhek_FREEKEY)
 536                         Safefree(key);
 537                     return NULL;
 538                 }
 539 #ifdef ENV_IS_CASELESS
 540                 else if (mg_find((const SV *)hv, PERL_MAGIC_env)) {
 541                     /* XXX This code isn't UTF8 clean.  */
 542                     const char *keysave = key;
 543                     /* Will need to free this, so set FREEKEY flag.  */
 544                     key = savepvn(key,klen);
 545                     key = (const char*)strupr((char*)key);
 546                     is_utf8 = FALSE;
 547                     hash = 0;
 548                     keysv = 0;
 549
 550                     if (flags & HVhek_FREEKEY) {
 551                         Safefree(keysave);
 552                     }
 553                     flags |= HVhek_FREEKEY;
 554                 }
 555 #endif
 556             }
 557         } /* ISSTORE */
 558     } /* SvMAGICAL */
 559
 560     if (!HvARRAY(hv)) {
 561         if ((action & (HV_FETCH_LVALUE | HV_FETCH_ISSTORE))
 562 #ifdef DYNAMIC_ENV_FETCH  /* if it's an %ENV lookup, we may get it on the fly */
 563                  || (SvRMAGICAL((const SV *)hv)
 564                      && mg_find((const SV *)hv, PERL_MAGIC_env))
 565 #endif
 566                                                                   ) {
 567             char *array;
 568             Newxz(array,
 569                  PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
 570                  char);
 571             HvARRAY(hv) = (HE**)array;
 572         }
 573 #ifdef DYNAMIC_ENV_FETCH
 574         else if (action & HV_FETCH_ISEXISTS) {
 575             /* for an %ENV exists, if we do an insert it's by a recursive
 576                store call, so avoid creating HvARRAY(hv) right now.  */
 577         }
 578 #endif
 579         else {
 580             /* XXX remove at some point? */
 581             if (flags & HVhek_FREEKEY)
 582                 Safefree(key);
 583
 584             return NULL;
 585         }
 586     }
 587
 588     if (is_utf8 & !(flags & HVhek_KEYCANONICAL)) {
 589         char * const keysave = (char *)key;
 590         key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
 591         if (is_utf8)
 592             flags |= HVhek_UTF8;
 593         else
 594             flags &= ~HVhek_UTF8;
 595         if (key != keysave) {
 596             if (flags & HVhek_FREEKEY)
 597                 Safefree(keysave);
 598             flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
 599             /* If the caller calculated a hash, it was on the sequence of
 600                octets that are the UTF-8 form. We've now changed the sequence
 601                of octets stored to that of the equivalent byte representation,
 602                so the hash we need is different.  */
 603             hash = 0;
 604         }
 605     }
 606
 607     if (HvREHASH(hv)) {
 608         PERL_HASH_INTERNAL(hash, key, klen);
 609         /* We don't have a pointer to the hv, so we have to replicate the
 610            flag into every HEK, so that hv_iterkeysv can see it.  */
 611         /* And yes, you do need this even though you are not "storing" because
 612            you can flip the flags below if doing an lval lookup.  (And that
 613            was put in to give the semantics Andreas was expecting.)  */
 614         flags |= HVhek_REHASH;
 615     } else if (!hash) {
 616         if (keysv && (SvIsCOW_shared_hash(keysv))) {
 617             hash = SvSHARED_HASH(keysv);
 618         } else {
 619             PERL_HASH(hash, key, klen);
 620         }
 621     }
 622
 623     masked_flags = (flags & HVhek_MASK);
 624
 625 #ifdef DYNAMIC_ENV_FETCH
 626     if (!HvARRAY(hv)) entry = NULL;
 627     else
 628 #endif
 629     {
 630         entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)];
 631     }
 632     for (; entry; entry = HeNEXT(entry)) {
 633         if (HeHASH(entry) != hash)              /* strings can't be equal */
 634             continue;
 635         if (HeKLEN(entry) != (I32)klen)
 636             continue;
 637         if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen))        /* is this it? */
 638             continue;
 639         if ((HeKFLAGS(entry) ^ masked_flags) & HVhek_UTF8)
 640             continue;
 641
 642         if (action & (HV_FETCH_LVALUE|HV_FETCH_ISSTORE)) {
 643             if (HeKFLAGS(entry) != masked_flags) {
 644                 /* We match if HVhek_UTF8 bit in our flags and hash key's
 645                    match.  But if entry was set previously with HVhek_WASUTF8
 646                    and key now doesn't (or vice versa) then we should change
 647                    the key's flag, as this is assignment.  */
 648                 if (HvSHAREKEYS(hv)) {
 649                     /* Need to swap the key we have for a key with the flags we
 650                        need. As keys are shared we can't just write to the
 651                        flag, so we share the new one, unshare the old one.  */
 652                     HEK * const new_hek = share_hek_flags(key, klen, hash,
 653                                                    masked_flags);
 654                     unshare_hek (HeKEY_hek(entry));
 655                     HeKEY_hek(entry) = new_hek;
 656                 }
 657                 else if (hv == PL_strtab) {
 658                     /* PL_strtab is usually the only hash without HvSHAREKEYS,
 659                        so putting this test here is cheap  */
 660                     if (flags & HVhek_FREEKEY)
 661                         Safefree(key);
 662                     Perl_croak(aTHX_ S_strtab_error,
 663                                action & HV_FETCH_LVALUE ? "fetch" : "store");
 664                 }
 665                 else
 666                     HeKFLAGS(entry) = masked_flags;
 667                 if (masked_flags & HVhek_ENABLEHVKFLAGS)
 668                     HvHASKFLAGS_on(hv);
 669             }
 670             if (HeVAL(entry) == &PL_sv_placeholder) {
 671                 /* yes, can store into placeholder slot */
 672                 if (action & HV_FETCH_LVALUE) {
 673                     if (SvMAGICAL(hv)) {
 674                         /* This preserves behaviour with the old hv_fetch
 675                            implementation which at this point would bail out
 676                            with a break; (at "if we find a placeholder, we
 677                            pretend we haven't found anything")
 678
 679                            That break mean that if a placeholder were found, it
 680                            caused a call into hv_store, which in turn would
 681                            check magic, and if there is no magic end up pretty
 682                            much back at this point (in hv_store's code).  */
 683                         break;
 684                     }
 685                     /* LVAL fetch which actaully needs a store.  */
 686                     val = newSV(0);
 687                     HvPLACEHOLDERS(hv)--;
 688                 } else {
 689                     /* store */
 690                     if (val != &PL_sv_placeholder)
 691                         HvPLACEHOLDERS(hv)--;
 692                 }
 693                 HeVAL(entry) = val;
 694             } else if (action & HV_FETCH_ISSTORE) {
 695                 HeVAL(entry) = val;
 696             }
 697         } else if (HeVAL(entry) == &PL_sv_placeholder) {
 698             /* if we find a placeholder, we pretend we haven't found
 699                anything */
 700             break;
 701         }
 702         if (flags & HVhek_FREEKEY)
 703             Safefree(key);
 704         if (return_svp) {
 705             return entry ? (void *) &HeVAL(entry) : NULL;
 706         }
 707         return entry;
 708     }
 709 #ifdef DYNAMIC_ENV_FETCH  /* %ENV lookup?  If so, try to fetch the value now */
 710     if (!(action & HV_FETCH_ISSTORE)
 711         && SvRMAGICAL((const SV *)hv)
 712         && mg_find((const SV *)hv, PERL_MAGIC_env)) {
 713         unsigned long len;
 714         const char * const env = PerlEnv_ENVgetenv_len(key,&len);
 715         if (env) {
 716             sv = newSVpvn(env,len);
 717             SvTAINTED_on(sv);
 718             return hv_common(hv, keysv, key, klen, flags,
 719                              HV_FETCH_ISSTORE|HV_DISABLE_UVAR_XKEY|return_svp,
 720                              sv, hash);
 721         }
 722     }
 723 #endif
 724
 725     if (!entry && SvREADONLY(hv) && !(action & HV_FETCH_ISEXISTS)) {
 726         hv_notallowed(flags, key, klen,
 727                         "Attempt to access disallowed key '%"SVf"' in"
 728                         " a restricted hash");
 729     }
 730     if (!(action & (HV_FETCH_LVALUE|HV_FETCH_ISSTORE))) {
 731         /* Not doing some form of store, so return failure.  */
 732         if (flags & HVhek_FREEKEY)
 733             Safefree(key);
 734         return NULL;
 735     }
 736     if (action & HV_FETCH_LVALUE) {
 737         val = newSV(0);
 738         if (SvMAGICAL(hv)) {
 739             /* At this point the old hv_fetch code would call to hv_store,
 740                which in turn might do some tied magic. So we need to make that
 741                magic check happen.  */
 742             /* gonna assign to this, so it better be there */
 743             /* If a fetch-as-store fails on the fetch, then the action is to
 744                recurse once into "hv_store". If we didn't do this, then that
 745                recursive call would call the key conversion routine again.
 746                However, as we replace the original key with the converted
 747                key, this would result in a double conversion, which would show
 748                up as a bug if the conversion routine is not idempotent.  */
 749             return hv_common(hv, keysv, key, klen, flags,
 750                              HV_FETCH_ISSTORE|HV_DISABLE_UVAR_XKEY|return_svp,
 751                              val, hash);
 752             /* XXX Surely that could leak if the fetch-was-store fails?
 753                Just like the hv_fetch.  */
 754         }
 755     }
 756
 757     /* Welcome to hv_store...  */
 758
 759     if (!HvARRAY(hv)) {
 760         /* Not sure if we can get here.  I think the only case of oentry being
 761            NULL is for %ENV with dynamic env fetch.  But that should disappear
 762            with magic in the previous code.  */
 763         char *array;
 764         Newxz(array,
 765              PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
 766              char);
 767         HvARRAY(hv) = (HE**)array;
 768     }
 769
 770     oentry = &(HvARRAY(hv))[hash & (I32) xhv->xhv_max];
 771
 772     entry = new_HE();
 773     /* share_hek_flags will do the free for us.  This might be considered
 774        bad API design.  */
 775     if (HvSHAREKEYS(hv))
 776         HeKEY_hek(entry) = share_hek_flags(key, klen, hash, flags);
 777     else if (hv == PL_strtab) {
 778         /* PL_strtab is usually the only hash without HvSHAREKEYS, so putting
 779            this test here is cheap  */
 780         if (flags & HVhek_FREEKEY)
 781             Safefree(key);
 782         Perl_croak(aTHX_ S_strtab_error,
 783                    action & HV_FETCH_LVALUE ? "fetch" : "store");
 784     }
 785     else                                       /* gotta do the real thing */
 786         HeKEY_hek(entry) = save_hek_flags(key, klen, hash, flags);
 787     HeVAL(entry) = val;
 788     HeNEXT(entry) = *oentry;
 789     *oentry = entry;
 790
 791     if (val == &PL_sv_placeholder)
 792         HvPLACEHOLDERS(hv)++;
 793     if (masked_flags & HVhek_ENABLEHVKFLAGS)
 794         HvHASKFLAGS_on(hv);
 795
 796     {
 797         const HE *counter = HeNEXT(entry);
 798
 799         xhv->xhv_keys++; /* HvTOTALKEYS(hv)++ */
 800         if (!counter) {                         /* initial entry? */
 801         } else if (xhv->xhv_keys > xhv->xhv_max) {
 802             hsplit(hv);
 803         } else if(!HvREHASH(hv)) {
 804             U32 n_links = 1;
 805
 806             while ((counter = HeNEXT(counter)))
 807                 n_links++;
 808
 809             if (n_links > HV_MAX_LENGTH_BEFORE_SPLIT) {
 810                 /* Use only the old HvKEYS(hv) > HvMAX(hv) condition to limit
 811                    bucket splits on a rehashed hash, as we're not going to
 812                    split it again, and if someone is lucky (evil) enough to
 813                    get all the keys in one list they could exhaust our memory
 814                    as we repeatedly double the number of buckets on every
 815                    entry. Linear search feels a less worse thing to do.  */
 816                 hsplit(hv);
 817             }
 818         }
 819     }
 820
 821     if (return_svp) {
 822         return entry ? (void *) &HeVAL(entry) : NULL;
 823     }
 824     return (void *) entry;
 825 }
 826
 827 STATIC void
 828 S_hv_magic_check(HV *hv, bool *needs_copy, bool *needs_store)
 829 {
 830     const MAGIC *mg = SvMAGIC(hv);
 831
 832     PERL_ARGS_ASSERT_HV_MAGIC_CHECK;
 833
 834     *needs_copy = FALSE;
 835     *needs_store = TRUE;
 836     while (mg) {
 837         if (isUPPER(mg->mg_type)) {
 838             *needs_copy = TRUE;
 839             if (mg->mg_type == PERL_MAGIC_tied) {
 840                 *needs_store = FALSE;
 841                 return; /* We've set all there is to set. */
 842             }
 843         }
 844         mg = mg->mg_moremagic;
 845     }
 846 }
 847
 848 /*
 849 =for apidoc hv_scalar
 850
 851 Evaluates the hash in scalar context and returns the result. Handles magic when the hash is tied.
 852
 853 =cut
 854 */
 855
 856 SV *
 857 Perl_hv_scalar(pTHX_ HV *hv)
 858 {
 859     SV *sv;
 860
 861     PERL_ARGS_ASSERT_HV_SCALAR;
 862
 863     if (SvRMAGICAL(hv)) {
 864         MAGIC * const mg = mg_find((const SV *)hv, PERL_MAGIC_tied);
 865         if (mg)
 866             return magic_scalarpack(hv, mg);
 867     }
 868
 869     sv = sv_newmortal();
 870     if (HvTOTALKEYS((const HV *)hv))
 871         Perl_sv_setpvf(aTHX_ sv, "%ld/%ld",
 872                 (long)HvFILL(hv), (long)HvMAX(hv) + 1);
 873     else
 874         sv_setiv(sv, 0);
 875
 876     return sv;
 877 }
 878
 879 /*
 880 =for apidoc hv_delete
 881
 882 Deletes a key/value pair in the hash.  The value SV is removed from the
 883 hash and returned to the caller.  The C<klen> is the length of the key.
 884 The C<flags> value will normally be zero; if set to G_DISCARD then NULL
 885 will be returned.
 886
 887 =for apidoc hv_delete_ent
 888
 889 Deletes a key/value pair in the hash.  The value SV is removed from the
 890 hash and returned to the caller.  The C<flags> value will normally be zero;
 891 if set to G_DISCARD then NULL will be returned.  C<hash> can be a valid
 892 precomputed hash value, or 0 to ask for it to be computed.
 893
 894 =cut
 895 */
 896
 897 STATIC SV *
 898 S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
 899                    int k_flags, I32 d_flags, U32 hash)
 900 {
 901     dVAR;
 902     register XPVHV* xhv;
 903     register HE *entry;
 904     register HE **oentry;
 905     HE *const *first_entry;
 906     bool is_utf8 = (k_flags & HVhek_UTF8) ? TRUE : FALSE;
 907     int masked_flags;
 908
 909     if (SvRMAGICAL(hv)) {
 910         bool needs_copy;
 911         bool needs_store;
 912         hv_magic_check (hv, &needs_copy, &needs_store);
 913
 914         if (needs_copy) {
 915             SV *sv;
 916             entry = (HE *) hv_common(hv, keysv, key, klen,
 917                                      k_flags & ~HVhek_FREEKEY,
 918                                      HV_FETCH_LVALUE|HV_DISABLE_UVAR_XKEY,
 919                                      NULL, hash);
 920             sv = entry ? HeVAL(entry) : NULL;
 921             if (sv) {
 922                 if (SvMAGICAL(sv)) {
 923                     mg_clear(sv);
 924                 }
 925                 if (!needs_store) {
 926                     if (mg_find(sv, PERL_MAGIC_tiedelem)) {
 927                         /* No longer an element */
 928                         sv_unmagic(sv, PERL_MAGIC_tiedelem);
 929                         return sv;
 930                     }
 931                     return NULL;                /* element cannot be deleted */
 932                 }
 933 #ifdef ENV_IS_CASELESS
 934                 else if (mg_find((const SV *)hv, PERL_MAGIC_env)) {
 935                     /* XXX This code isn't UTF8 clean.  */
 936                     keysv = newSVpvn_flags(key, klen, SVs_TEMP);
 937                     if (k_flags & HVhek_FREEKEY) {
 938                         Safefree(key);
 939                     }
 940                     key = strupr(SvPVX(keysv));
 941                     is_utf8 = 0;
 942                     k_flags = 0;
 943                     hash = 0;
 944                 }
 945 #endif
 946             }
 947         }
 948     }
 949     xhv = (XPVHV*)SvANY(hv);
 950     if (!HvARRAY(hv))
 951         return NULL;
 952
 953     if (is_utf8) {
 954         const char * const keysave = key;
 955         key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
 956
 957         if (is_utf8)
 958             k_flags |= HVhek_UTF8;
 959         else
 960             k_flags &= ~HVhek_UTF8;
 961         if (key != keysave) {
 962             if (k_flags & HVhek_FREEKEY) {
 963                 /* This shouldn't happen if our caller does what we expect,
 964                    but strictly the API allows it.  */
 965                 Safefree(keysave);
 966             }
 967             k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
 968         }
 969         HvHASKFLAGS_on(MUTABLE_SV(hv));
 970     }
 971
 972     if (HvREHASH(hv)) {
 973         PERL_HASH_INTERNAL(hash, key, klen);
 974     } else if (!hash) {
 975         if (keysv && (SvIsCOW_shared_hash(keysv))) {
 976             hash = SvSHARED_HASH(keysv);
 977         } else {
 978             PERL_HASH(hash, key, klen);
 979         }
 980     }
 981
 982     masked_flags = (k_flags & HVhek_MASK);
 983
 984     first_entry = oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)];
 985     entry = *oentry;
 986     for (; entry; oentry = &HeNEXT(entry), entry = *oentry) {
 987         SV *sv;
 988         if (HeHASH(entry) != hash)              /* strings can't be equal */
 989             continue;
 990         if (HeKLEN(entry) != (I32)klen)
 991             continue;
 992         if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen))        /* is this it? */
 993             continue;
 994         if ((HeKFLAGS(entry) ^ masked_flags) & HVhek_UTF8)
 995             continue;
 996
 997         if (hv == PL_strtab) {
 998             if (k_flags & HVhek_FREEKEY)
 999                 Safefree(key);
1000             Perl_croak(aTHX_ S_strtab_error, "delete");
1001         }
1002
1003         /* if placeholder is here, it's already been deleted.... */
1004         if (HeVAL(entry) == &PL_sv_placeholder) {
1005             if (k_flags & HVhek_FREEKEY)
1006                 Safefree(key);
1007             return NULL;
1008         }
1009         if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
1010             hv_notallowed(k_flags, key, klen,
1011                             "Attempt to delete readonly key '%"SVf"' from"
1012                             " a restricted hash");
1013         }
1014         if (k_flags & HVhek_FREEKEY)
1015             Safefree(key);
1016
1017         if (d_flags & G_DISCARD)
1018             sv = NULL;
1019         else {
1020             sv = sv_2mortal(HeVAL(entry));
1021             HeVAL(entry) = &PL_sv_placeholder;
1022         }
1023
1024         /*
1025          * If a restricted hash, rather than really deleting the entry, put
1026          * a placeholder there. This marks the key as being "approved", so
1027          * we can still access via not-really-existing key without raising
1028          * an error.
1029          */
1030         if (SvREADONLY(hv)) {
1031             SvREFCNT_dec(HeVAL(entry));
1032             HeVAL(entry) = &PL_sv_placeholder;
1033             /* We'll be saving this slot, so the number of allocated keys
1034              * doesn't go down, but the number placeholders goes up */
1035             HvPLACEHOLDERS(hv)++;
1036         } else {
1037             *oentry = HeNEXT(entry);
1038
1039             /* If this is a stash and the key ends with ::, then someone is
1040                deleting a package. */
1041             if (sv && HvNAME(hv)) {
1042                 if (keysv) key = SvPV(keysv, klen);
1043                 if (klen > 1 && key[klen-2] == ':' && key[klen-1] == ':'
1044                  && SvTYPE(sv) == SVt_PVGV) {
1045                     const HV * const stash = GvHV((GV *)sv);
1046                     if (stash && HvNAME(stash))
1047                         mro_package_moved(NULL, stash, NULL, NULL, 0);
1048                 }
1049             }
1050
1051             if (SvOOK(hv) && entry == HvAUX(hv)->xhv_eiter /* HvEITER(hv) */)
1052                 HvLAZYDEL_on(hv);
1053             else
1054                 hv_free_ent(hv, entry);
1055             xhv->xhv_keys--; /* HvTOTALKEYS(hv)-- */
1056             if (xhv->xhv_keys == 0)
1057                 HvHASKFLAGS_off(hv);
1058         }
1059         return sv;
1060     }
1061     if (SvREADONLY(hv)) {
1062         hv_notallowed(k_flags, key, klen,
1063                         "Attempt to delete disallowed key '%"SVf"' from"
1064                         " a restricted hash");
1065     }
1066
1067     if (k_flags & HVhek_FREEKEY)
1068         Safefree(key);
1069     return NULL;
1070 }
1071
1072 STATIC void
1073 S_hsplit(pTHX_ HV *hv)
1074 {
1075     dVAR;
1076     register XPVHV* const xhv = (XPVHV*)SvANY(hv);
1077     const I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
1078     register I32 newsize = oldsize * 2;
1079     register I32 i;
1080     char *a = (char*) HvARRAY(hv);
1081     register HE **aep;
1082     int longest_chain = 0;
1083     int was_shared;
1084
1085     PERL_ARGS_ASSERT_HSPLIT;
1086
1087     /*PerlIO_printf(PerlIO_stderr(), "hsplit called for %p which had %d\n",
1088       (void*)hv, (int) oldsize);*/
1089
1090     if (HvPLACEHOLDERS_get(hv) && !SvREADONLY(hv)) {
1091       /* Can make this clear any placeholders first for non-restricted hashes,
1092          even though Storable rebuilds restricted hashes by putting in all the
1093          placeholders (first) before turning on the readonly flag, because
1094          Storable always pre-splits the hash.  */
1095       hv_clear_placeholders(hv);
1096     }
1097
1098     PL_nomemok = TRUE;
1099 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
1100     Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize)
1101           + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char);
1102     if (!a) {
1103       PL_nomemok = FALSE;
1104       return;
1105     }
1106     if (SvOOK(hv)) {
1107         Move(&a[oldsize * sizeof(HE*)], &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux);
1108     }
1109 #else
1110     Newx(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize)
1111         + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char);
1112     if (!a) {
1113       PL_nomemok = FALSE;
1114       return;
1115     }
1116     Copy(HvARRAY(hv), a, oldsize * sizeof(HE*), char);
1117     if (SvOOK(hv)) {
1118         Copy(HvAUX(hv), &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux);
1119     }
1120     Safefree(HvARRAY(hv));
1121 #endif
1122
1123     PL_nomemok = FALSE;
1124     Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char);     /* zero 2nd half*/
1125     xhv->xhv_max = --newsize;   /* HvMAX(hv) = --newsize */
1126     HvARRAY(hv) = (HE**) a;
1127     aep = (HE**)a;
1128
1129     for (i=0; i<oldsize; i++,aep++) {
1130         int left_length = 0;
1131         int right_length = 0;
1132         HE **oentry = aep;
1133         HE *entry = *aep;
1134         register HE **bep;
1135
1136         if (!entry)                             /* non-existent */
1137             continue;
1138         bep = aep+oldsize;
1139         do {
1140             if ((HeHASH(entry) & newsize) != (U32)i) {
1141                 *oentry = HeNEXT(entry);
1142                 HeNEXT(entry) = *bep;
1143                 *bep = entry;
1144                 right_length++;
1145             }
1146             else {
1147                 oentry = &HeNEXT(entry);
1148                 left_length++;
1149             }
1150             entry = *oentry;
1151         } while (entry);
1152         /* I think we don't actually need to keep track of the longest length,
1153            merely flag if anything is too long. But for the moment while
1154            developing this code I'll track it.  */
1155         if (left_length > longest_chain)
1156             longest_chain = left_length;
1157         if (right_length > longest_chain)
1158             longest_chain = right_length;
1159     }
1160
1161
1162     /* Pick your policy for "hashing isn't working" here:  */
1163     if (longest_chain <= HV_MAX_LENGTH_BEFORE_SPLIT /* split worked?  */
1164         || HvREHASH(hv)) {
1165         return;
1166     }
1167
1168     if (hv == PL_strtab) {
1169         /* Urg. Someone is doing something nasty to the string table.
1170            Can't win.  */
1171         return;
1172     }
1173
1174     /* Awooga. Awooga. Pathological data.  */
1175     /*PerlIO_printf(PerlIO_stderr(), "%p %d of %d with %d/%d buckets\n", (void*)hv,
1176       longest_chain, HvTOTALKEYS(hv), HvFILL(hv),  1+HvMAX(hv));*/
1177
1178     ++newsize;
1179     Newxz(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize)
1180          + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char);
1181     if (SvOOK(hv)) {
1182         Copy(HvAUX(hv), &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux);
1183     }
1184
1185     was_shared = HvSHAREKEYS(hv);
1186
1187     HvSHAREKEYS_off(hv);
1188     HvREHASH_on(hv);
1189
1190     aep = HvARRAY(hv);
1191
1192     for (i=0; i<newsize; i++,aep++) {
1193         register HE *entry = *aep;
1194         while (entry) {
1195             /* We're going to trash this HE's next pointer when we chain it
1196                into the new hash below, so store where we go next.  */
1197             HE * const next = HeNEXT(entry);
1198             UV hash;
1199             HE **bep;
1200
1201             /* Rehash it */
1202             PERL_HASH_INTERNAL(hash, HeKEY(entry), HeKLEN(entry));
1203
1204             if (was_shared) {
1205                 /* Unshare it.  */
1206                 HEK * const new_hek
1207                     = save_hek_flags(HeKEY(entry), HeKLEN(entry),
1208                                      hash, HeKFLAGS(entry));
1209                 unshare_hek (HeKEY_hek(entry));
1210                 HeKEY_hek(entry) = new_hek;
1211             } else {
1212                 /* Not shared, so simply write the new hash in. */
1213                 HeHASH(entry) = hash;
1214             }
1215             /*PerlIO_printf(PerlIO_stderr(), "%d ", HeKFLAGS(entry));*/
1216             HEK_REHASH_on(HeKEY_hek(entry));
1217             /*PerlIO_printf(PerlIO_stderr(), "%d\n", HeKFLAGS(entry));*/
1218
1219             /* Copy oentry to the correct new chain.  */
1220             bep = ((HE**)a) + (hash & (I32) xhv->xhv_max);
1221             HeNEXT(entry) = *bep;
1222             *bep = entry;
1223
1224             entry = next;
1225         }
1226     }
1227     Safefree (HvARRAY(hv));
1228     HvARRAY(hv) = (HE **)a;
1229 }
1230
1231 void
1232 Perl_hv_ksplit(pTHX_ HV *hv, IV newmax)
1233 {
1234     dVAR;
1235     register XPVHV* xhv = (XPVHV*)SvANY(hv);
1236     const I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
1237     register I32 newsize;
1238     register I32 i;
1239     register char *a;
1240     register HE **aep;
1241
1242     PERL_ARGS_ASSERT_HV_KSPLIT;
1243
1244     newsize = (I32) newmax;                     /* possible truncation here */
1245     if (newsize != newmax || newmax <= oldsize)
1246         return;
1247     while ((newsize & (1 + ~newsize)) != newsize) {
1248         newsize &= ~(newsize & (1 + ~newsize)); /* get proper power of 2 */
1249     }
1250     if (newsize < newmax)
1251         newsize *= 2;
1252     if (newsize < newmax)
1253         return;                                 /* overflow detection */
1254
1255     a = (char *) HvARRAY(hv);
1256     if (a) {
1257         PL_nomemok = TRUE;
1258 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
1259         Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize)
1260               + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char);
1261         if (!a) {
1262           PL_nomemok = FALSE;
1263           return;
1264         }
1265         if (SvOOK(hv)) {
1266             Copy(&a[oldsize * sizeof(HE*)], &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux);
1267         }
1268 #else
1269         Newx(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize)
1270             + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char);
1271         if (!a) {
1272           PL_nomemok = FALSE;
1273           return;
1274         }
1275         Copy(HvARRAY(hv), a, oldsize * sizeof(HE*), char);
1276         if (SvOOK(hv)) {
1277             Copy(HvAUX(hv), &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux);
1278         }
1279         Safefree(HvARRAY(hv));
1280 #endif
1281         PL_nomemok = FALSE;
1282         Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
1283     }
1284     else {
1285         Newxz(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1286     }
1287     xhv->xhv_max = --newsize;   /* HvMAX(hv) = --newsize */
1288     HvARRAY(hv) = (HE **) a;
1289     if (!xhv->xhv_keys /* !HvTOTALKEYS(hv) */)  /* skip rest if no entries */
1290         return;
1291
1292     aep = (HE**)a;
1293     for (i=0; i<oldsize; i++,aep++) {
1294         HE **oentry = aep;
1295         HE *entry = *aep;
1296
1297         if (!entry)                             /* non-existent */
1298             continue;
1299         do {
1300             register I32 j = (HeHASH(entry) & newsize);
1301
1302             if (j != i) {
1303                 j -= i;
1304                 *oentry = HeNEXT(entry);
1305                 HeNEXT(entry) = aep[j];
1306                 aep[j] = entry;
1307             }
1308             else
1309                 oentry = &HeNEXT(entry);
1310             entry = *oentry;
1311         } while (entry);
1312     }
1313 }
1314
1315 HV *
1316 Perl_newHVhv(pTHX_ HV *ohv)
1317 {
1318     dVAR;
1319     HV * const hv = newHV();
1320     STRLEN hv_max;
1321
1322     if (!ohv || !HvTOTALKEYS(ohv))
1323         return hv;
1324     hv_max = HvMAX(ohv);
1325
1326     if (!SvMAGICAL((const SV *)ohv)) {
1327         /* It's an ordinary hash, so copy it fast. AMS 20010804 */
1328         STRLEN i;
1329         const bool shared = !!HvSHAREKEYS(ohv);
1330         HE **ents, ** const oents = (HE **)HvARRAY(ohv);
1331         char *a;
1332         Newx(a, PERL_HV_ARRAY_ALLOC_BYTES(hv_max+1), char);
1333         ents = (HE**)a;
1334
1335         /* In each bucket... */
1336         for (i = 0; i <= hv_max; i++) {
1337             HE *prev = NULL;
1338             HE *oent = oents[i];
1339
1340             if (!oent) {
1341                 ents[i] = NULL;
1342                 continue;
1343             }
1344
1345             /* Copy the linked list of entries. */
1346             for (; oent; oent = HeNEXT(oent)) {
1347                 const U32 hash   = HeHASH(oent);
1348                 const char * const key = HeKEY(oent);
1349                 const STRLEN len = HeKLEN(oent);
1350                 const int flags  = HeKFLAGS(oent);
1351                 HE * const ent   = new_HE();
1352                 SV *const val    = HeVAL(oent);
1353
1354                 HeVAL(ent) = SvIMMORTAL(val) ? val : newSVsv(val);
1355                 HeKEY_hek(ent)
1356                     = shared ? share_hek_flags(key, len, hash, flags)
1357                              :  save_hek_flags(key, len, hash, flags);
1358                 if (prev)
1359                     HeNEXT(prev) = ent;
1360                 else
1361                     ents[i] = ent;
1362                 prev = ent;
1363                 HeNEXT(ent) = NULL;
1364             }
1365         }
1366
1367         HvMAX(hv)   = hv_max;
1368         HvTOTALKEYS(hv)  = HvTOTALKEYS(ohv);
1369         HvARRAY(hv) = ents;
1370     } /* not magical */
1371     else {
1372         /* Iterate over ohv, copying keys and values one at a time. */
1373         HE *entry;
1374         const I32 riter = HvRITER_get(ohv);
1375         HE * const eiter = HvEITER_get(ohv);
1376         STRLEN hv_fill = HvFILL(ohv);
1377
1378         /* Can we use fewer buckets? (hv_max is always 2^n-1) */
1379         while (hv_max && hv_max + 1 >= hv_fill * 2)
1380             hv_max = hv_max / 2;
1381         HvMAX(hv) = hv_max;
1382
1383         hv_iterinit(ohv);
1384         while ((entry = hv_iternext_flags(ohv, 0))) {
1385             SV *const val = HeVAL(entry);
1386             (void)hv_store_flags(hv, HeKEY(entry), HeKLEN(entry),
1387                                  SvIMMORTAL(val) ? val : newSVsv(val),
1388                                  HeHASH(entry), HeKFLAGS(entry));
1389         }
1390         HvRITER_set(ohv, riter);
1391         HvEITER_set(ohv, eiter);
1392     }
1393
1394     return hv;
1395 }
1396
1397 /*
1398 =for apidoc Am|HV *|hv_copy_hints_hv|HV *ohv
1399
1400 A specialised version of L</newHVhv> for copying C<%^H>.  I<ohv> must be
1401 a pointer to a hash (which may have C<%^H> magic, but should be generally
1402 non-magical), or C<NULL> (interpreted as an empty hash).  The content
1403 of I<ohv> is copied to a new hash, which has the C<%^H>-specific magic
1404 added to it.  A pointer to the new hash is returned.
1405
1406 =cut
1407 */
1408
1409 HV *
1410 Perl_hv_copy_hints_hv(pTHX_ HV *const ohv)
1411 {
1412     HV * const hv = newHV();
1413
1414     if (ohv && HvTOTALKEYS(ohv)) {
1415         STRLEN hv_max = HvMAX(ohv);
1416         STRLEN hv_fill = HvFILL(ohv);
1417         HE *entry;
1418         const I32 riter = HvRITER_get(ohv);
1419         HE * const eiter = HvEITER_get(ohv);
1420
1421         while (hv_max && hv_max + 1 >= hv_fill * 2)
1422             hv_max = hv_max / 2;
1423         HvMAX(hv) = hv_max;
1424
1425         hv_iterinit(ohv);
1426         while ((entry = hv_iternext_flags(ohv, 0))) {
1427             SV *const sv = newSVsv(HeVAL(entry));
1428             SV *heksv = newSVhek(HeKEY_hek(entry));
1429             sv_magic(sv, NULL, PERL_MAGIC_hintselem,
1430                      (char *)heksv, HEf_SVKEY);
1431             SvREFCNT_dec(heksv);
1432             (void)hv_store_flags(hv, HeKEY(entry), HeKLEN(entry),
1433                                  sv, HeHASH(entry), HeKFLAGS(entry));
1434         }
1435         HvRITER_set(ohv, riter);
1436         HvEITER_set(ohv, eiter);
1437     }
1438     hv_magic(hv, NULL, PERL_MAGIC_hints);
1439     return hv;
1440 }
1441
1442 void
1443 Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry)
1444 {
1445     dVAR;
1446     SV *val;
1447
1448     PERL_ARGS_ASSERT_HV_FREE_ENT;
1449
1450     if (!entry)
1451         return;
1452     val = HeVAL(entry);
1453     if (val && isGV(val) && isGV_with_GP(val) && GvCVu(val) && HvNAME_get(hv))
1454         mro_method_changed_in(hv);      /* deletion of method from stash */
1455     SvREFCNT_dec(val);
1456     if (HeKLEN(entry) == HEf_SVKEY) {
1457         SvREFCNT_dec(HeKEY_sv(entry));
1458         Safefree(HeKEY_hek(entry));
1459     }
1460     else if (HvSHAREKEYS(hv))
1461         unshare_hek(HeKEY_hek(entry));
1462     else
1463         Safefree(HeKEY_hek(entry));
1464     del_HE(entry);
1465 }
1466
1467
1468 void
1469 Perl_hv_delayfree_ent(pTHX_ HV *hv, register HE *entry)
1470 {
1471     dVAR;
1472
1473     PERL_ARGS_ASSERT_HV_DELAYFREE_ENT;
1474
1475     if (!entry)
1476         return;
1477     /* SvREFCNT_inc to counter the SvREFCNT_dec in hv_free_ent  */
1478     sv_2mortal(SvREFCNT_inc(HeVAL(entry)));     /* free between statements */
1479     if (HeKLEN(entry) == HEf_SVKEY) {
1480         sv_2mortal(SvREFCNT_inc(HeKEY_sv(entry)));
1481     }
1482     hv_free_ent(hv, entry);
1483 }
1484
1485 /*
1486 =for apidoc hv_clear
1487
1488 Clears a hash, making it empty.
1489
1490 =cut
1491 */
1492
1493 void
1494 Perl_hv_clear(pTHX_ HV *hv)
1495 {
1496     dVAR;
1497     register XPVHV* xhv;
1498     if (!hv)
1499         return;
1500
1501     DEBUG_A(Perl_hv_assert(aTHX_ hv));
1502
1503     xhv = (XPVHV*)SvANY(hv);
1504
1505     if (SvREADONLY(hv) && HvARRAY(hv) != NULL) {
1506         /* restricted hash: convert all keys to placeholders */
1507         STRLEN i;
1508         for (i = 0; i <= xhv->xhv_max; i++) {
1509             HE *entry = (HvARRAY(hv))[i];
1510             for (; entry; entry = HeNEXT(entry)) {
1511                 /* not already placeholder */
1512                 if (HeVAL(entry) != &PL_sv_placeholder) {
1513                     if (HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
1514                         SV* const keysv = hv_iterkeysv(entry);
1515                         Perl_croak(aTHX_
1516                                    "Attempt to delete readonly key '%"SVf"' from a restricted hash",
1517                                    (void*)keysv);
1518                     }
1519                     SvREFCNT_dec(HeVAL(entry));
1520                     HeVAL(entry) = &PL_sv_placeholder;
1521                     HvPLACEHOLDERS(hv)++;
1522                 }
1523             }
1524         }
1525         goto reset;
1526     }
1527
1528     hfreeentries(hv);
1529     HvPLACEHOLDERS_set(hv, 0);
1530     if (HvARRAY(hv))
1531         Zero(HvARRAY(hv), xhv->xhv_max+1 /* HvMAX(hv)+1 */, HE*);
1532
1533     if (SvRMAGICAL(hv))
1534         mg_clear(MUTABLE_SV(hv));
1535
1536     HvHASKFLAGS_off(hv);
1537     HvREHASH_off(hv);
1538     reset:
1539     if (SvOOK(hv)) {
1540         if(HvNAME_get(hv))
1541             mro_isa_changed_in(hv);
1542         HvEITER_set(hv, NULL);
1543     }
1544 }
1545
1546 /*
1547 =for apidoc hv_clear_placeholders
1548
1549 Clears any placeholders from a hash.  If a restricted hash has any of its keys
1550 marked as readonly and the key is subsequently deleted, the key is not actually
1551 deleted but is marked by assigning it a value of &PL_sv_placeholder.  This tags
1552 it so it will be ignored by future operations such as iterating over the hash,
1553 but will still allow the hash to have a value reassigned to the key at some
1554 future point.  This function clears any such placeholder keys from the hash.
1555 See Hash::Util::lock_keys() for an example of its use.
1556
1557 =cut
1558 */
1559
1560 void
1561 Perl_hv_clear_placeholders(pTHX_ HV *hv)
1562 {
1563     dVAR;
1564     const U32 items = (U32)HvPLACEHOLDERS_get(hv);
1565
1566     PERL_ARGS_ASSERT_HV_CLEAR_PLACEHOLDERS;
1567
1568     if (items)
1569         clear_placeholders(hv, items);
1570 }
1571
1572 static void
1573 S_clear_placeholders(pTHX_ HV *hv, U32 items)
1574 {
1575     dVAR;
1576     I32 i;
1577
1578     PERL_ARGS_ASSERT_CLEAR_PLACEHOLDERS;
1579
1580     if (items == 0)
1581         return;
1582
1583     i = HvMAX(hv);
1584     do {
1585         /* Loop down the linked list heads  */
1586         bool first = TRUE;
1587         HE **oentry = &(HvARRAY(hv))[i];
1588         HE *entry;
1589
1590         while ((entry = *oentry)) {
1591             if (HeVAL(entry) == &PL_sv_placeholder) {
1592                 *oentry = HeNEXT(entry);
1593                 if (entry == HvEITER_get(hv))
1594                     HvLAZYDEL_on(hv);
1595                 else
1596                     hv_free_ent(hv, entry);
1597
1598                 if (--items == 0) {
1599                     /* Finished.  */
1600                     HvTOTALKEYS(hv) -= (IV)HvPLACEHOLDERS_get(hv);
1601                     if (HvKEYS(hv) == 0)
1602                         HvHASKFLAGS_off(hv);
1603                     HvPLACEHOLDERS_set(hv, 0);
1604                     return;
1605                 }
1606             } else {
1607                 oentry = &HeNEXT(entry);
1608                 first = FALSE;
1609             }
1610         }
1611     } while (--i >= 0);
1612     /* You can't get here, hence assertion should always fail.  */
1613     assert (items == 0);
1614     assert (0);
1615 }
1616
1617 STATIC void
1618 S_hfreeentries(pTHX_ HV *hv)
1619 {
1620     /* This is the array that we're going to restore  */
1621     HE **const orig_array = HvARRAY(hv);
1622     HEK *name;
1623     int attempts = 100;
1624
1625     PERL_ARGS_ASSERT_HFREEENTRIES;
1626
1627     if (!orig_array)
1628         return;
1629
1630     if (SvOOK(hv)) {
1631         /* If the hash is actually a symbol table with a name, look after the
1632            name.  */
1633         struct xpvhv_aux *iter = HvAUX(hv);
1634
1635         name = iter->xhv_name;
1636         iter->xhv_name = NULL;
1637     } else {
1638         name = NULL;
1639     }
1640
1641     /* orig_array remains unchanged throughout the loop. If after freeing all
1642        the entries it turns out that one of the little blighters has triggered
1643        an action that has caused HvARRAY to be re-allocated, then we set
1644        array to the new HvARRAY, and try again.  */
1645
1646     while (1) {
1647         /* This is the one we're going to try to empty.  First time round
1648            it's the original array.  (Hopefully there will only be 1 time
1649            round) */
1650         HE ** const array = HvARRAY(hv);
1651         I32 i = HvMAX(hv);
1652
1653         /* Because we have taken xhv_name out, the only allocated pointer
1654            in the aux structure that might exist is the backreference array.
1655         */
1656
1657         if (SvOOK(hv)) {
1658             HE *entry;
1659             struct mro_meta *meta;
1660             struct xpvhv_aux *iter = HvAUX(hv);
1661             /* weak references: if called from sv_clear(), the backrefs
1662              * should already have been killed; if there are any left, its
1663              * because we're doing hv_clear() or hv_undef(), and the HV
1664              * will continue to live.
1665              * Because while freeing the entries we fake up a NULL HvARRAY
1666              * (and hence HvAUX), we need to store the backref array
1667              * somewhere else; but it still needs to be visible in case
1668              * any the things we free happen to call sv_del_backref().
1669              * We do this by storing it in magic instead.
1670              * If, during the entry freeing, a destructor happens to add
1671              * a new weak backref, then sv_add_backref will look in both
1672              * places (magic in HvAUX) for the AV, but will create a new
1673              * AV in HvAUX if it can't find one (if it finds it in magic,
1674              * it moves it back into HvAUX. So at the end of the iteration
1675              * we have to allow for this. */
1676
1677
1678             if (iter->xhv_backreferences) {
1679                 if (SvTYPE(iter->xhv_backreferences) == SVt_PVAV) {
1680                     /* The sv_magic will increase the reference count of the AV,
1681                        so we need to drop it first. */
1682                     SvREFCNT_dec(iter->xhv_backreferences);
1683                     if (AvFILLp(iter->xhv_backreferences) == -1) {
1684                         /* Turns out that the array is empty. Just free it.  */
1685                         SvREFCNT_dec(iter->xhv_backreferences);
1686
1687                     } else {
1688                         sv_magic(MUTABLE_SV(hv),
1689                                  MUTABLE_SV(iter->xhv_backreferences),
1690                                  PERL_MAGIC_backref, NULL, 0);
1691                     }
1692                 }
1693                 else {
1694                     MAGIC *mg;
1695                     sv_magic(MUTABLE_SV(hv), NULL, PERL_MAGIC_backref, NULL, 0);
1696                     mg = mg_find(MUTABLE_SV(hv), PERL_MAGIC_backref);
1697                     mg->mg_obj = (SV*)iter->xhv_backreferences;
1698                 }
1699                 iter->xhv_backreferences = NULL;
1700             }
1701
1702             entry = iter->xhv_eiter; /* HvEITER(hv) */
1703             if (entry && HvLAZYDEL(hv)) {       /* was deleted earlier? */
1704                 HvLAZYDEL_off(hv);
1705                 hv_free_ent(hv, entry);
1706             }
1707             iter->xhv_riter = -1;       /* HvRITER(hv) = -1 */
1708             iter->xhv_eiter = NULL;     /* HvEITER(hv) = NULL */
1709
1710             if((meta = iter->xhv_mro_meta)) {
1711                 if (meta->mro_linear_all) {
1712                     SvREFCNT_dec(MUTABLE_SV(meta->mro_linear_all));
1713                     meta->mro_linear_all = NULL;
1714                     /* This is just acting as a shortcut pointer.  */
1715                     meta->mro_linear_current = NULL;
1716                 } else if (meta->mro_linear_current) {
1717                     /* Only the current MRO is stored, so this owns the data.
1718                      */
1719                     SvREFCNT_dec(meta->mro_linear_current);
1720                     meta->mro_linear_current = NULL;
1721                 }
1722                 if(meta->mro_nextmethod) SvREFCNT_dec(meta->mro_nextmethod);
1723                 SvREFCNT_dec(meta->isa);
1724                 Safefree(meta);
1725                 iter->xhv_mro_meta = NULL;
1726             }
1727
1728             /* There are now no allocated pointers in the aux structure.  */
1729
1730             SvFLAGS(hv) &= ~SVf_OOK; /* Goodbye, aux structure.  */
1731             /* What aux structure?  */
1732         }
1733
1734         /* make everyone else think the array is empty, so that the destructors
1735          * called for freed entries can't recursively mess with us */
1736         HvARRAY(hv) = NULL;
1737         ((XPVHV*) SvANY(hv))->xhv_keys = 0;
1738
1739
1740         do {
1741             /* Loop down the linked list heads  */
1742             HE *entry = array[i];
1743
1744             while (entry) {
1745                 register HE * const oentry = entry;
1746                 entry = HeNEXT(entry);
1747                 hv_free_ent(hv, oentry);
1748             }
1749         } while (--i >= 0);
1750
1751         /* As there are no allocated pointers in the aux structure, it's now
1752            safe to free the array we just cleaned up, if it's not the one we're
1753            going to put back.  */
1754         if (array != orig_array) {
1755             Safefree(array);
1756         }
1757
1758         if (!HvARRAY(hv)) {
1759             /* Good. No-one added anything this time round.  */
1760             break;
1761         }
1762
1763         if (SvOOK(hv)) {
1764             /* Someone attempted to iterate or set the hash name while we had
1765                the array set to 0.  We'll catch backferences on the next time
1766                round the while loop.  */
1767             assert(HvARRAY(hv));
1768
1769             if (HvAUX(hv)->xhv_name) {
1770                 unshare_hek_or_pvn(HvAUX(hv)->xhv_name, 0, 0, 0);
1771             }
1772         }
1773
1774         if (--attempts == 0) {
1775             Perl_die(aTHX_ "panic: hfreeentries failed to free hash - something is repeatedly re-creating entries");
1776         }
1777     }
1778
1779     HvARRAY(hv) = orig_array;
1780
1781     /* If the hash was actually a symbol table, put the name back.  */
1782     if (name) {
1783         /* We have restored the original array.  If name is non-NULL, then
1784            the original array had an aux structure at the end. So this is
1785            valid:  */
1786         SvFLAGS(hv) |= SVf_OOK;
1787         HvAUX(hv)->xhv_name = name;
1788     }
1789 }
1790
1791 /*
1792 =for apidoc hv_undef
1793
1794 Undefines the hash.
1795
1796 =cut
1797 */
1798
1799 void
1800 Perl_hv_undef(pTHX_ HV *hv)
1801 {
1802     dVAR;
1803     register XPVHV* xhv;
1804     const char *name;
1805
1806     if (!hv)
1807         return;
1808     DEBUG_A(Perl_hv_assert(aTHX_ hv));
1809     xhv = (XPVHV*)SvANY(hv);
1810
1811     if ((name = HvNAME_get(hv)) && !PL_dirty)
1812         mro_isa_changed_in(hv);
1813
1814     hfreeentries(hv);
1815     if (name) {
1816         if (PL_stashcache)
1817             (void)hv_delete(PL_stashcache, name, HvNAMELEN_get(hv), G_DISCARD);
1818         hv_name_set(hv, NULL, 0, 0);
1819     }
1820     SvFLAGS(hv) &= ~SVf_OOK;
1821     Safefree(HvARRAY(hv));
1822     xhv->xhv_max   = 7; /* HvMAX(hv) = 7 (it's a normal hash) */
1823     HvARRAY(hv) = 0;
1824     HvPLACEHOLDERS_set(hv, 0);
1825
1826     if (SvRMAGICAL(hv))
1827         mg_clear(MUTABLE_SV(hv));
1828 }
1829
1830 /*
1831 =for apidoc hv_fill
1832
1833 Returns the number of hash buckets that happen to be in use. This function is
1834 wrapped by the macro C<HvFILL>.
1835
1836 Previously this value was stored in the HV structure, rather than being
1837 calculated on demand.
1838
1839 =cut
1840 */
1841
1842 STRLEN
1843 Perl_hv_fill(pTHX_ HV const *const hv)
1844 {
1845     STRLEN count = 0;
1846     HE **ents = HvARRAY(hv);
1847
1848     PERL_ARGS_ASSERT_HV_FILL;
1849
1850     if (ents) {
1851         HE *const *const last = ents + HvMAX(hv);
1852         count = last + 1 - ents;
1853
1854         do {
1855             if (!*ents)
1856                 --count;
1857         } while (++ents <= last);
1858     }
1859     return count;
1860 }
1861
1862 static struct xpvhv_aux*
1863 S_hv_auxinit(HV *hv) {
1864     struct xpvhv_aux *iter;
1865     char *array;
1866
1867     PERL_ARGS_ASSERT_HV_AUXINIT;
1868
1869     if (!HvARRAY(hv)) {
1870         Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(HvMAX(hv) + 1)
1871             + sizeof(struct xpvhv_aux), char);
1872     } else {
1873         array = (char *) HvARRAY(hv);
1874         Renew(array, PERL_HV_ARRAY_ALLOC_BYTES(HvMAX(hv) + 1)
1875               + sizeof(struct xpvhv_aux), char);
1876     }
1877     HvARRAY(hv) = (HE**) array;
1878     /* SvOOK_on(hv) attacks the IV flags.  */
1879     SvFLAGS(hv) |= SVf_OOK;
1880     iter = HvAUX(hv);
1881
1882     iter->xhv_riter = -1;       /* HvRITER(hv) = -1 */
1883     iter->xhv_eiter = NULL;     /* HvEITER(hv) = NULL */
1884     iter->xhv_name = 0;
1885     iter->xhv_backreferences = 0;
1886     iter->xhv_mro_meta = NULL;
1887     return iter;
1888 }
1889
1890 /*
1891 =for apidoc hv_iterinit
1892
1893 Prepares a starting point to traverse a hash table.  Returns the number of
1894 keys in the hash (i.e. the same as C<HvKEYS(hv)>).  The return value is
1895 currently only meaningful for hashes without tie magic.
1896
1897 NOTE: Before version 5.004_65, C<hv_iterinit> used to return the number of
1898 hash buckets that happen to be in use.  If you still need that esoteric
1899 value, you can get it through the macro C<HvFILL(hv)>.
1900
1901
1902 =cut
1903 */
1904
1905 I32
1906 Perl_hv_iterinit(pTHX_ HV *hv)
1907 {
1908     PERL_ARGS_ASSERT_HV_ITERINIT;
1909
1910     /* FIXME: Are we not NULL, or do we croak? Place bets now! */
1911
1912     if (!hv)
1913         Perl_croak(aTHX_ "Bad hash");
1914
1915     if (SvOOK(hv)) {
1916         struct xpvhv_aux * const iter = HvAUX(hv);
1917         HE * const entry = iter->xhv_eiter; /* HvEITER(hv) */
1918         if (entry && HvLAZYDEL(hv)) {   /* was deleted earlier? */
1919             HvLAZYDEL_off(hv);
1920             hv_free_ent(hv, entry);
1921         }
1922         iter->xhv_riter = -1;   /* HvRITER(hv) = -1 */
1923         iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
1924     } else {
1925         hv_auxinit(hv);
1926     }
1927
1928     /* used to be xhv->xhv_fill before 5.004_65 */
1929     return HvTOTALKEYS(hv);
1930 }
1931
1932 I32 *
1933 Perl_hv_riter_p(pTHX_ HV *hv) {
1934     struct xpvhv_aux *iter;
1935
1936     PERL_ARGS_ASSERT_HV_RITER_P;
1937
1938     if (!hv)
1939         Perl_croak(aTHX_ "Bad hash");
1940
1941     iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
1942     return &(iter->xhv_riter);
1943 }
1944
1945 HE **
1946 Perl_hv_eiter_p(pTHX_ HV *hv) {
1947     struct xpvhv_aux *iter;
1948
1949     PERL_ARGS_ASSERT_HV_EITER_P;
1950
1951     if (!hv)
1952         Perl_croak(aTHX_ "Bad hash");
1953
1954     iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
1955     return &(iter->xhv_eiter);
1956 }
1957
1958 void
1959 Perl_hv_riter_set(pTHX_ HV *hv, I32 riter) {
1960     struct xpvhv_aux *iter;
1961
1962     PERL_ARGS_ASSERT_HV_RITER_SET;
1963
1964     if (!hv)
1965         Perl_croak(aTHX_ "Bad hash");
1966
1967     if (SvOOK(hv)) {
1968         iter = HvAUX(hv);
1969     } else {
1970         if (riter == -1)
1971             return;
1972
1973         iter = hv_auxinit(hv);
1974     }
1975     iter->xhv_riter = riter;
1976 }
1977
1978 void
1979 Perl_hv_eiter_set(pTHX_ HV *hv, HE *eiter) {
1980     struct xpvhv_aux *iter;
1981
1982     PERL_ARGS_ASSERT_HV_EITER_SET;
1983
1984     if (!hv)
1985         Perl_croak(aTHX_ "Bad hash");
1986
1987     if (SvOOK(hv)) {
1988         iter = HvAUX(hv);
1989     } else {
1990         /* 0 is the default so don't go malloc()ing a new structure just to
1991            hold 0.  */
1992         if (!eiter)
1993             return;
1994
1995         iter = hv_auxinit(hv);
1996     }
1997     iter->xhv_eiter = eiter;
1998 }
1999
2000 void
2001 Perl_hv_name_set(pTHX_ HV *hv, const char *name, U32 len, U32 flags)
2002 {
2003     dVAR;
2004     struct xpvhv_aux *iter;
2005     U32 hash;
2006
2007     PERL_ARGS_ASSERT_HV_NAME_SET;
2008     PERL_UNUSED_ARG(flags);
2009
2010     if (len > I32_MAX)
2011         Perl_croak(aTHX_ "panic: hv name too long (%"UVuf")", (UV) len);
2012
2013     if (SvOOK(hv)) {
2014         iter = HvAUX(hv);
2015         if (iter->xhv_name) {
2016             unshare_hek_or_pvn(iter->xhv_name, 0, 0, 0);
2017         }
2018     } else {
2019         if (name == 0)
2020             return;
2021
2022         iter = hv_auxinit(hv);
2023     }
2024     PERL_HASH(hash, name, len);
2025     iter->xhv_name = name ? share_hek(name, len, hash) : NULL;
2026 }
2027
2028 AV **
2029 Perl_hv_backreferences_p(pTHX_ HV *hv) {
2030     struct xpvhv_aux * const iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
2031
2032     PERL_ARGS_ASSERT_HV_BACKREFERENCES_P;
2033     PERL_UNUSED_CONTEXT;
2034
2035     return &(iter->xhv_backreferences);
2036 }
2037
2038 void
2039 Perl_hv_kill_backrefs(pTHX_ HV *hv) {
2040     AV *av;
2041
2042     PERL_ARGS_ASSERT_HV_KILL_BACKREFS;
2043
2044     if (!SvOOK(hv))
2045         return;
2046
2047     av = HvAUX(hv)->xhv_backreferences;
2048
2049     if (av) {
2050         HvAUX(hv)->xhv_backreferences = 0;
2051         Perl_sv_kill_backrefs(aTHX_ MUTABLE_SV(hv), av);
2052         if (SvTYPE(av) == SVt_PVAV)
2053             SvREFCNT_dec(av);
2054     }
2055 }
2056
2057 /*
2058 hv_iternext is implemented as a macro in hv.h
2059
2060 =for apidoc hv_iternext
2061
2062 Returns entries from a hash iterator.  See C<hv_iterinit>.
2063
2064 You may call C<hv_delete> or C<hv_delete_ent> on the hash entry that the
2065 iterator currently points to, without losing your place or invalidating your
2066 iterator.  Note that in this case the current entry is deleted from the hash
2067 with your iterator holding the last reference to it.  Your iterator is flagged
2068 to free the entry on the next call to C<hv_iternext>, so you must not discard
2069 your iterator immediately else the entry will leak - call C<hv_iternext> to
2070 trigger the resource deallocation.
2071
2072 =for apidoc hv_iternext_flags
2073
2074 Returns entries from a hash iterator.  See C<hv_iterinit> and C<hv_iternext>.
2075 The C<flags> value will normally be zero; if HV_ITERNEXT_WANTPLACEHOLDERS is
2076 set the placeholders keys (for restricted hashes) will be returned in addition
2077 to normal keys. By default placeholders are automatically skipped over.
2078 Currently a placeholder is implemented with a value that is
2079 C<&Perl_sv_placeholder>. Note that the implementation of placeholders and
2080 restricted hashes may change, and the implementation currently is
2081 insufficiently abstracted for any change to be tidy.
2082
2083 =cut
2084 */
2085
2086 HE *
2087 Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags)
2088 {
2089     dVAR;
2090     register XPVHV* xhv;
2091     register HE *entry;
2092     HE *oldentry;
2093     MAGIC* mg;
2094     struct xpvhv_aux *iter;
2095
2096     PERL_ARGS_ASSERT_HV_ITERNEXT_FLAGS;
2097
2098     if (!hv)
2099         Perl_croak(aTHX_ "Bad hash");
2100
2101     xhv = (XPVHV*)SvANY(hv);
2102
2103     if (!SvOOK(hv)) {
2104         /* Too many things (well, pp_each at least) merrily assume that you can
2105            call iv_iternext without calling hv_iterinit, so we'll have to deal
2106            with it.  */
2107         hv_iterinit(hv);
2108     }
2109     iter = HvAUX(hv);
2110
2111     oldentry = entry = iter->xhv_eiter; /* HvEITER(hv) */
2112     if (SvMAGICAL(hv) && SvRMAGICAL(hv)) {
2113         if ( ( mg = mg_find((const SV *)hv, PERL_MAGIC_tied) ) ) {
2114             SV * const key = sv_newmortal();
2115             if (entry) {
2116                 sv_setsv(key, HeSVKEY_force(entry));
2117                 SvREFCNT_dec(HeSVKEY(entry));       /* get rid of previous key */
2118             }
2119             else {
2120                 char *k;
2121                 HEK *hek;
2122
2123                 /* one HE per MAGICAL hash */
2124                 iter->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */
2125                 Zero(entry, 1, HE);
2126                 Newxz(k, HEK_BASESIZE + sizeof(const SV *), char);
2127                 hek = (HEK*)k;
2128                 HeKEY_hek(entry) = hek;
2129                 HeKLEN(entry) = HEf_SVKEY;
2130             }
2131             magic_nextpack(MUTABLE_SV(hv),mg,key);
2132             if (SvOK(key)) {
2133                 /* force key to stay around until next time */
2134                 HeSVKEY_set(entry, SvREFCNT_inc_simple_NN(key));
2135                 return entry;               /* beware, hent_val is not set */
2136             }
2137             SvREFCNT_dec(HeVAL(entry));
2138             Safefree(HeKEY_hek(entry));
2139             del_HE(entry);
2140             iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
2141             return NULL;
2142         }
2143     }
2144 #if defined(DYNAMIC_ENV_FETCH) && !defined(__riscos__)  /* set up %ENV for iteration */
2145     if (!entry && SvRMAGICAL((const SV *)hv)
2146         && mg_find((const SV *)hv, PERL_MAGIC_env)) {
2147         prime_env_iter();
2148 #ifdef VMS
2149         /* The prime_env_iter() on VMS just loaded up new hash values
2150          * so the iteration count needs to be reset back to the beginning
2151          */
2152         hv_iterinit(hv);
2153         iter = HvAUX(hv);
2154         oldentry = entry = iter->xhv_eiter; /* HvEITER(hv) */
2155 #endif
2156     }
2157 #endif
2158
2159     /* hv_iterint now ensures this.  */
2160     assert (HvARRAY(hv));
2161
2162     /* At start of hash, entry is NULL.  */
2163     if (entry)
2164     {
2165         entry = HeNEXT(entry);
2166         if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
2167             /*
2168              * Skip past any placeholders -- don't want to include them in
2169              * any iteration.
2170              */
2171             while (entry && HeVAL(entry) == &PL_sv_placeholder) {
2172                 entry = HeNEXT(entry);
2173             }
2174         }
2175     }
2176
2177     /* Skip the entire loop if the hash is empty.   */
2178     if ((flags & HV_ITERNEXT_WANTPLACEHOLDERS)
2179         ? HvTOTALKEYS(hv) : HvUSEDKEYS(hv)) {
2180         while (!entry) {
2181             /* OK. Come to the end of the current list.  Grab the next one.  */
2182
2183             iter->xhv_riter++; /* HvRITER(hv)++ */
2184             if (iter->xhv_riter > (I32)xhv->xhv_max /* HvRITER(hv) > HvMAX(hv) */) {
2185                 /* There is no next one.  End of the hash.  */
2186                 iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
2187                 break;
2188             }
2189             entry = (HvARRAY(hv))[iter->xhv_riter];
2190
2191             if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
2192                 /* If we have an entry, but it's a placeholder, don't count it.
2193                    Try the next.  */
2194                 while (entry && HeVAL(entry) == &PL_sv_placeholder)
2195                     entry = HeNEXT(entry);
2196             }
2197             /* Will loop again if this linked list starts NULL
2198                (for HV_ITERNEXT_WANTPLACEHOLDERS)
2199                or if we run through it and find only placeholders.  */
2200         }
2201     }
2202
2203     if (oldentry && HvLAZYDEL(hv)) {            /* was deleted earlier? */
2204         HvLAZYDEL_off(hv);
2205         hv_free_ent(hv, oldentry);
2206     }
2207
2208     /*if (HvREHASH(hv) && entry && !HeKREHASH(entry))
2209       PerlIO_printf(PerlIO_stderr(), "Awooga %p %p\n", (void*)hv, (void*)entry);*/
2210
2211     iter->xhv_eiter = entry; /* HvEITER(hv) = entry */
2212     return entry;
2213 }
2214
2215 /*
2216 =for apidoc hv_iterkey
2217
2218 Returns the key from the current position of the hash iterator.  See
2219 C<hv_iterinit>.
2220
2221 =cut
2222 */
2223
2224 char *
2225 Perl_hv_iterkey(pTHX_ register HE *entry, I32 *retlen)
2226 {
2227     PERL_ARGS_ASSERT_HV_ITERKEY;
2228
2229     if (HeKLEN(entry) == HEf_SVKEY) {
2230         STRLEN len;
2231         char * const p = SvPV(HeKEY_sv(entry), len);
2232         *retlen = len;
2233         return p;
2234     }
2235     else {
2236         *retlen = HeKLEN(entry);
2237         return HeKEY(entry);
2238     }
2239 }
2240
2241 /* unlike hv_iterval(), this always returns a mortal copy of the key */
2242 /*
2243 =for apidoc hv_iterkeysv
2244
2245 Returns the key as an C<SV*> from the current position of the hash
2246 iterator.  The return value will always be a mortal copy of the key.  Also
2247 see C<hv_iterinit>.
2248
2249 =cut
2250 */
2251
2252 SV *
2253 Perl_hv_iterkeysv(pTHX_ register HE *entry)
2254 {
2255     PERL_ARGS_ASSERT_HV_ITERKEYSV;
2256
2257     return sv_2mortal(newSVhek(HeKEY_hek(entry)));
2258 }
2259
2260 /*
2261 =for apidoc hv_iterval
2262
2263 Returns the value from the current position of the hash iterator.  See
2264 C<hv_iterkey>.
2265
2266 =cut
2267 */
2268
2269 SV *
2270 Perl_hv_iterval(pTHX_ HV *hv, register HE *entry)
2271 {
2272     PERL_ARGS_ASSERT_HV_ITERVAL;
2273
2274     if (SvRMAGICAL(hv)) {
2275         if (mg_find((const SV *)hv, PERL_MAGIC_tied)) {
2276             SV* const sv = sv_newmortal();
2277             if (HeKLEN(entry) == HEf_SVKEY)
2278                 mg_copy(MUTABLE_SV(hv), sv, (char*)HeKEY_sv(entry), HEf_SVKEY);
2279             else
2280                 mg_copy(MUTABLE_SV(hv), sv, HeKEY(entry), HeKLEN(entry));
2281             return sv;
2282         }
2283     }
2284     return HeVAL(entry);
2285 }
2286
2287 /*
2288 =for apidoc hv_iternextsv
2289
2290 Performs an C<hv_iternext>, C<hv_iterkey>, and C<hv_iterval> in one
2291 operation.
2292
2293 =cut
2294 */
2295
2296 SV *
2297 Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen)
2298 {
2299     HE * const he = hv_iternext_flags(hv, 0);
2300
2301     PERL_ARGS_ASSERT_HV_ITERNEXTSV;
2302
2303     if (!he)
2304         return NULL;
2305     *key = hv_iterkey(he, retlen);
2306     return hv_iterval(hv, he);
2307 }
2308
2309 /*
2310
2311 Now a macro in hv.h
2312
2313 =for apidoc hv_magic
2314
2315 Adds magic to a hash.  See C<sv_magic>.
2316
2317 =cut
2318 */
2319
2320 /* possibly free a shared string if no one has access to it
2321  * len and hash must both be valid for str.
2322  */
2323 void
2324 Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
2325 {
2326     unshare_hek_or_pvn (NULL, str, len, hash);
2327 }
2328
2329
2330 void
2331 Perl_unshare_hek(pTHX_ HEK *hek)
2332 {
2333     assert(hek);
2334     unshare_hek_or_pvn(hek, NULL, 0, 0);
2335 }
2336
2337 /* possibly free a shared string if no one has access to it
2338    hek if non-NULL takes priority over the other 3, else str, len and hash
2339    are used.  If so, len and hash must both be valid for str.
2340  */
2341 STATIC void
2342 S_unshare_hek_or_pvn(pTHX_ const HEK *hek, const char *str, I32 len, U32 hash)
2343 {
2344     dVAR;
2345     register XPVHV* xhv;
2346     HE *entry;
2347     register HE **oentry;
2348     HE **first;
2349     bool is_utf8 = FALSE;
2350     int k_flags = 0;
2351     const char * const save = str;
2352     struct shared_he *he = NULL;
2353
2354     if (hek) {
2355         /* Find the shared he which is just before us in memory.  */
2356         he = (struct shared_he *)(((char *)hek)
2357                                   - STRUCT_OFFSET(struct shared_he,
2358                                                   shared_he_hek));
2359
2360         /* Assert that the caller passed us a genuine (or at least consistent)
2361            shared hek  */
2362         assert (he->shared_he_he.hent_hek == hek);
2363
2364         if (he->shared_he_he.he_valu.hent_refcount - 1) {
2365             --he->shared_he_he.he_valu.hent_refcount;
2366             return;
2367         }
2368
2369         hash = HEK_HASH(hek);
2370     } else if (len < 0) {
2371         STRLEN tmplen = -len;
2372         is_utf8 = TRUE;
2373         /* See the note in hv_fetch(). --jhi */
2374         str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2375         len = tmplen;
2376         if (is_utf8)
2377             k_flags = HVhek_UTF8;
2378         if (str != save)
2379             k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2380     }
2381
2382     /* what follows was the moral equivalent of:
2383     if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) {
2384         if (--*Svp == NULL)
2385             hv_delete(PL_strtab, str, len, G_DISCARD, hash);
2386     } */
2387     xhv = (XPVHV*)SvANY(PL_strtab);
2388     /* assert(xhv_array != 0) */
2389     first = oentry = &(HvARRAY(PL_strtab))[hash & (I32) HvMAX(PL_strtab)];
2390     if (he) {
2391         const HE *const he_he = &(he->shared_he_he);
2392         for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) {
2393             if (entry == he_he)
2394                 break;
2395         }
2396     } else {
2397         const int flags_masked = k_flags & HVhek_MASK;
2398         for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) {
2399             if (HeHASH(entry) != hash)          /* strings can't be equal */
2400                 continue;
2401             if (HeKLEN(entry) != len)
2402                 continue;
2403             if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len))     /* is this it? */
2404                 continue;
2405             if (HeKFLAGS(entry) != flags_masked)
2406                 continue;
2407             break;
2408         }
2409     }
2410
2411     if (entry) {
2412         if (--entry->he_valu.hent_refcount == 0) {
2413             *oentry = HeNEXT(entry);
2414             Safefree(entry);
2415             xhv->xhv_keys--; /* HvTOTALKEYS(hv)-- */
2416         }
2417     }
2418
2419     if (!entry)
2420         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
2421                          "Attempt to free non-existent shared string '%s'%s"
2422                          pTHX__FORMAT,
2423                          hek ? HEK_KEY(hek) : str,
2424                          ((k_flags & HVhek_UTF8) ? " (utf8)" : "") pTHX__VALUE);
2425     if (k_flags & HVhek_FREEKEY)
2426         Safefree(str);
2427 }
2428
2429 /* get a (constant) string ptr from the global string table
2430  * string will get added if it is not already there.
2431  * len and hash must both be valid for str.
2432  */
2433 HEK *
2434 Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash)
2435 {
2436     bool is_utf8 = FALSE;
2437     int flags = 0;
2438     const char * const save = str;
2439
2440     PERL_ARGS_ASSERT_SHARE_HEK;
2441
2442     if (len < 0) {
2443       STRLEN tmplen = -len;
2444       is_utf8 = TRUE;
2445       /* See the note in hv_fetch(). --jhi */
2446       str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2447       len = tmplen;
2448       /* If we were able to downgrade here, then than means that we were passed
2449          in a key which only had chars 0-255, but was utf8 encoded.  */
2450       if (is_utf8)
2451           flags = HVhek_UTF8;
2452       /* If we found we were able to downgrade the string to bytes, then
2453          we should flag that it needs upgrading on keys or each.  Also flag
2454          that we need share_hek_flags to free the string.  */
2455       if (str != save)
2456           flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2457     }
2458
2459     return share_hek_flags (str, len, hash, flags);
2460 }
2461
2462 STATIC HEK *
2463 S_share_hek_flags(pTHX_ const char *str, I32 len, register U32 hash, int flags)
2464 {
2465     dVAR;
2466     register HE *entry;
2467     const int flags_masked = flags & HVhek_MASK;
2468     const U32 hindex = hash & (I32) HvMAX(PL_strtab);
2469     register XPVHV * const xhv = (XPVHV*)SvANY(PL_strtab);
2470
2471     PERL_ARGS_ASSERT_SHARE_HEK_FLAGS;
2472
2473     /* what follows is the moral equivalent of:
2474
2475     if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
2476         hv_store(PL_strtab, str, len, NULL, hash);
2477
2478         Can't rehash the shared string table, so not sure if it's worth
2479         counting the number of entries in the linked list
2480     */
2481
2482     /* assert(xhv_array != 0) */
2483     entry = (HvARRAY(PL_strtab))[hindex];
2484     for (;entry; entry = HeNEXT(entry)) {
2485         if (HeHASH(entry) != hash)              /* strings can't be equal */
2486             continue;
2487         if (HeKLEN(entry) != len)
2488             continue;
2489         if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
2490             continue;
2491         if (HeKFLAGS(entry) != flags_masked)
2492             continue;
2493         break;
2494     }
2495
2496     if (!entry) {
2497         /* What used to be head of the list.
2498            If this is NULL, then we're the first entry for this slot, which
2499            means we need to increate fill.  */
2500         struct shared_he *new_entry;
2501         HEK *hek;
2502         char *k;
2503         HE **const head = &HvARRAY(PL_strtab)[hindex];
2504         HE *const next = *head;
2505
2506         /* We don't actually store a HE from the arena and a regular HEK.
2507            Instead we allocate one chunk of memory big enough for both,
2508            and put the HEK straight after the HE. This way we can find the
2509            HEK directly from the HE.
2510         */
2511
2512         Newx(k, STRUCT_OFFSET(struct shared_he,
2513                                 shared_he_hek.hek_key[0]) + len + 2, char);
2514         new_entry = (struct shared_he *)k;
2515         entry = &(new_entry->shared_he_he);
2516         hek = &(new_entry->shared_he_hek);
2517
2518         Copy(str, HEK_KEY(hek), len, char);
2519         HEK_KEY(hek)[len] = 0;
2520         HEK_LEN(hek) = len;
2521         HEK_HASH(hek) = hash;
2522         HEK_FLAGS(hek) = (unsigned char)flags_masked;
2523
2524         /* Still "point" to the HEK, so that other code need not know what
2525            we're up to.  */
2526         HeKEY_hek(entry) = hek;
2527         entry->he_valu.hent_refcount = 0;
2528         HeNEXT(entry) = next;
2529         *head = entry;
2530
2531         xhv->xhv_keys++; /* HvTOTALKEYS(hv)++ */
2532         if (!next) {                    /* initial entry? */
2533         } else if (xhv->xhv_keys > xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */) {
2534                 hsplit(PL_strtab);
2535         }
2536     }
2537
2538     ++entry->he_valu.hent_refcount;
2539
2540     if (flags & HVhek_FREEKEY)
2541         Safefree(str);
2542
2543     return HeKEY_hek(entry);
2544 }
2545
2546 I32 *
2547 Perl_hv_placeholders_p(pTHX_ HV *hv)
2548 {
2549     dVAR;
2550     MAGIC *mg = mg_find((const SV *)hv, PERL_MAGIC_rhash);
2551
2552     PERL_ARGS_ASSERT_HV_PLACEHOLDERS_P;
2553
2554     if (!mg) {
2555         mg = sv_magicext(MUTABLE_SV(hv), 0, PERL_MAGIC_rhash, 0, 0, 0);
2556
2557         if (!mg) {
2558             Perl_die(aTHX_ "panic: hv_placeholders_p");
2559         }
2560     }
2561     return &(mg->mg_len);
2562 }
2563
2564
2565 I32
2566 Perl_hv_placeholders_get(pTHX_ const HV *hv)
2567 {
2568     dVAR;
2569     MAGIC * const mg = mg_find((const SV *)hv, PERL_MAGIC_rhash);
2570
2571     PERL_ARGS_ASSERT_HV_PLACEHOLDERS_GET;
2572
2573     return mg ? mg->mg_len : 0;
2574 }
2575
2576 void
2577 Perl_hv_placeholders_set(pTHX_ HV *hv, I32 ph)
2578 {
2579     dVAR;
2580     MAGIC * const mg = mg_find((const SV *)hv, PERL_MAGIC_rhash);
2581
2582     PERL_ARGS_ASSERT_HV_PLACEHOLDERS_SET;
2583
2584     if (mg) {
2585         mg->mg_len = ph;
2586     } else if (ph) {
2587         if (!sv_magicext(MUTABLE_SV(hv), 0, PERL_MAGIC_rhash, 0, 0, ph))
2588             Perl_die(aTHX_ "panic: hv_placeholders_set");
2589     }
2590     /* else we don't need to add magic to record 0 placeholders.  */
2591 }
2592
2593 STATIC SV *
2594 S_refcounted_he_value(pTHX_ const struct refcounted_he *he)
2595 {
2596     dVAR;
2597     SV *value;
2598
2599     PERL_ARGS_ASSERT_REFCOUNTED_HE_VALUE;
2600
2601     switch(he->refcounted_he_data[0] & HVrhek_typemask) {
2602     case HVrhek_undef:
2603         value = newSV(0);
2604         break;
2605     case HVrhek_delete:
2606         value = &PL_sv_placeholder;
2607         break;
2608     case HVrhek_IV:
2609         value = newSViv(he->refcounted_he_val.refcounted_he_u_iv);
2610         break;
2611     case HVrhek_UV:
2612         value = newSVuv(he->refcounted_he_val.refcounted_he_u_uv);
2613         break;
2614     case HVrhek_PV:
2615     case HVrhek_PV_UTF8:
2616         /* Create a string SV that directly points to the bytes in our
2617            structure.  */
2618         value = newSV_type(SVt_PV);
2619         SvPV_set(value, (char *) he->refcounted_he_data + 1);
2620         SvCUR_set(value, he->refcounted_he_val.refcounted_he_u_len);
2621         /* This stops anything trying to free it  */
2622         SvLEN_set(value, 0);
2623         SvPOK_on(value);
2624         SvREADONLY_on(value);
2625         if ((he->refcounted_he_data[0] & HVrhek_typemask) == HVrhek_PV_UTF8)
2626             SvUTF8_on(value);
2627         break;
2628     default:
2629         Perl_croak(aTHX_ "panic: refcounted_he_value bad flags %x",
2630                    he->refcounted_he_data[0]);
2631     }
2632     return value;
2633 }
2634
2635 /*
2636 =for apidoc cop_hints_2hv
2637
2638 Generates and returns a C<HV *> from the hinthash in the provided
2639 C<COP>. Returns C<NULL> if there isn't one there.
2640
2641 =cut
2642 */
2643 HV *
2644 Perl_cop_hints_2hv(pTHX_ const COP *cop)
2645 {
2646     PERL_ARGS_ASSERT_COP_HINTS_2HV;
2647
2648     if (!cop->cop_hints_hash)
2649         return NULL;
2650
2651     return Perl_refcounted_he_chain_2hv(aTHX_ cop->cop_hints_hash);
2652 }
2653
2654 /*
2655 =for apidoc cop_hints_fetchsv
2656
2657 Fetches an entry from the hinthash in the provided C<COP>. Returns NULL
2658 if the entry isn't there.
2659
2660 =for apidoc cop_hints_fetchpvn
2661
2662 See L</cop_hints_fetchsv>. If C<flags> includes C<HVhek_UTF8>, C<key> is
2663 in UTF-8.
2664
2665 =for apidoc cop_hints_fetchpv
2666
2667 See L</cop_hints_fetchsv>. If C<flags> includes C<HVhek_UTF8>, C<key> is
2668 in UTF-8.
2669
2670 =for apidoc cop_hints_fetchpvs
2671
2672 See L</cop_hints_fetchpvn>. This is a macro that takes a constant string
2673 for its argument, which is assumed to be ASCII (rather than UTF-8).
2674
2675 =cut
2676 */
2677 SV *
2678 Perl_cop_hints_fetchpvn(pTHX_ const COP *cop, const char *key, STRLEN klen,
2679                             int flags, U32 hash)
2680 {
2681     PERL_ARGS_ASSERT_COP_HINTS_FETCHPVN;
2682
2683     /* refcounted_he_fetch takes more flags than we do. Make sure
2684      * noone's depending on being able to pass them here. */
2685     flags &= ~HVhek_UTF8;
2686
2687     return Perl_refcounted_he_fetch(aTHX_ cop->cop_hints_hash, NULL,
2688         key, klen, flags, hash);
2689 }
2690
2691 /*
2692 =for apidoc refcounted_he_chain_2hv
2693
2694 Generates and returns a C<HV *> by walking up the tree starting at the passed
2695 in C<struct refcounted_he *>.
2696
2697 =cut
2698 */
2699 HV *
2700 Perl_refcounted_he_chain_2hv(pTHX_ const struct refcounted_he *chain)
2701 {
2702     dVAR;
2703     HV *hv = newHV();
2704     U32 placeholders = 0;
2705     /* We could chase the chain once to get an idea of the number of keys,
2706        and call ksplit.  But for now we'll make a potentially inefficient
2707        hash with only 8 entries in its array.  */
2708     const U32 max = HvMAX(hv);
2709
2710     if (!HvARRAY(hv)) {
2711         char *array;
2712         Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(max + 1), char);
2713         HvARRAY(hv) = (HE**)array;
2714     }
2715
2716     while (chain) {
2717 #ifdef USE_ITHREADS
2718         U32 hash = chain->refcounted_he_hash;
2719 #else
2720         U32 hash = HEK_HASH(chain->refcounted_he_hek);
2721 #endif
2722         HE **oentry = &((HvARRAY(hv))[hash & max]);
2723         HE *entry = *oentry;
2724         SV *value;
2725
2726         for (; entry; entry = HeNEXT(entry)) {
2727             if (HeHASH(entry) == hash) {
2728                 /* We might have a duplicate key here.  If so, entry is older
2729                    than the key we've already put in the hash, so if they are
2730                    the same, skip adding entry.  */
2731 #ifdef USE_ITHREADS
2732                 const STRLEN klen = HeKLEN(entry);
2733                 const char *const key = HeKEY(entry);
2734                 if (klen == chain->refcounted_he_keylen
2735                     && (!!HeKUTF8(entry)
2736                         == !!(chain->refcounted_he_data[0] & HVhek_UTF8))
2737                     && memEQ(key, REF_HE_KEY(chain), klen))
2738                     goto next_please;
2739 #else
2740                 if (HeKEY_hek(entry) == chain->refcounted_he_hek)
2741                     goto next_please;
2742                 if (HeKLEN(entry) == HEK_LEN(chain->refcounted_he_hek)
2743                     && HeKUTF8(entry) == HEK_UTF8(chain->refcounted_he_hek)
2744                     && memEQ(HeKEY(entry), HEK_KEY(chain->refcounted_he_hek),
2745                              HeKLEN(entry)))
2746                     goto next_please;
2747 #endif
2748             }
2749         }
2750         assert (!entry);
2751         entry = new_HE();
2752
2753 #ifdef USE_ITHREADS
2754         HeKEY_hek(entry)
2755             = share_hek_flags(REF_HE_KEY(chain),
2756                               chain->refcounted_he_keylen,
2757                               chain->refcounted_he_hash,
2758                               (chain->refcounted_he_data[0]
2759                                & (HVhek_UTF8|HVhek_WASUTF8)));
2760 #else
2761         HeKEY_hek(entry) = share_hek_hek(chain->refcounted_he_hek);
2762 #endif
2763         value = refcounted_he_value(chain);
2764         if (value == &PL_sv_placeholder)
2765             placeholders++;
2766         HeVAL(entry) = value;
2767
2768         /* Link it into the chain.  */
2769         HeNEXT(entry) = *oentry;
2770         *oentry = entry;
2771
2772         HvTOTALKEYS(hv)++;
2773
2774     next_please:
2775         chain = chain->refcounted_he_next;
2776     }
2777
2778     if (placeholders) {
2779         clear_placeholders(hv, placeholders);
2780         HvTOTALKEYS(hv) -= placeholders;
2781     }
2782
2783     /* We could check in the loop to see if we encounter any keys with key
2784        flags, but it's probably not worth it, as this per-hash flag is only
2785        really meant as an optimisation for things like Storable.  */
2786     HvHASKFLAGS_on(hv);
2787     DEBUG_A(Perl_hv_assert(aTHX_ hv));
2788
2789     return hv;
2790 }
2791
2792 SV *
2793 Perl_refcounted_he_fetch(pTHX_ const struct refcounted_he *chain, SV *keysv,
2794                          const char *key, STRLEN klen, int flags, U32 hash)
2795 {
2796     dVAR;
2797     /* Just to be awkward, if you're using this interface the UTF-8-or-not-ness
2798        of your key has to exactly match that which is stored.  */
2799     SV *value = &PL_sv_placeholder;
2800
2801     if (chain) {
2802         /* No point in doing any of this if there's nothing to find.  */
2803         bool is_utf8;
2804
2805         if (keysv) {
2806             if (flags & HVhek_FREEKEY)
2807                 Safefree(key);
2808             key = SvPV_const(keysv, klen);
2809             flags = 0;
2810             is_utf8 = (SvUTF8(keysv) != 0);
2811         } else {
2812             is_utf8 = ((flags & HVhek_UTF8) ? TRUE : FALSE);
2813         }
2814
2815         if (!hash) {
2816             if (keysv && (SvIsCOW_shared_hash(keysv))) {
2817                 hash = SvSHARED_HASH(keysv);
2818             } else {
2819                 PERL_HASH(hash, key, klen);
2820             }
2821         }
2822
2823         for (; chain; chain = chain->refcounted_he_next) {
2824 #ifdef USE_ITHREADS
2825             if (hash != chain->refcounted_he_hash)
2826                 continue;
2827             if (klen != chain->refcounted_he_keylen)
2828                 continue;
2829             if (memNE(REF_HE_KEY(chain),key,klen))
2830                 continue;
2831             if (!!is_utf8 != !!(chain->refcounted_he_data[0] & HVhek_UTF8))
2832                 continue;
2833 #else
2834             if (hash != HEK_HASH(chain->refcounted_he_hek))
2835                 continue;
2836             if (klen != (STRLEN)HEK_LEN(chain->refcounted_he_hek))
2837                 continue;
2838             if (memNE(HEK_KEY(chain->refcounted_he_hek),key,klen))
2839                 continue;
2840             if (!!is_utf8 != !!HEK_UTF8(chain->refcounted_he_hek))
2841                 continue;
2842 #endif
2843
2844             value = sv_2mortal(refcounted_he_value(chain));
2845             break;
2846         }
2847     }
2848
2849     if (flags & HVhek_FREEKEY)
2850         Safefree(key);
2851
2852     return value;
2853 }
2854
2855 /*
2856 =for apidoc refcounted_he_new
2857
2858 Creates a new C<struct refcounted_he>. As S<key> is copied, and value is
2859 stored in a compact form, all references remain the property of the caller.
2860 The C<struct refcounted_he> is returned with a reference count of 1.
2861
2862 =cut
2863 */
2864
2865 struct refcounted_he *
2866 Perl_refcounted_he_new(pTHX_ struct refcounted_he *const parent,
2867                        SV *const key, SV *const value) {
2868     dVAR;
2869     STRLEN key_len;
2870     const char *key_p = SvPV_const(key, key_len);
2871     STRLEN value_len = 0;
2872     const char *value_p = NULL;
2873     char value_type;
2874     char flags;
2875     bool is_utf8 = SvUTF8(key) ? TRUE : FALSE;
2876
2877     if (SvPOK(value)) {
2878         value_type = HVrhek_PV;
2879     } else if (SvIOK(value)) {
2880         value_type = SvUOK((const SV *)value) ? HVrhek_UV : HVrhek_IV;
2881     } else if (value == &PL_sv_placeholder) {
2882         value_type = HVrhek_delete;
2883     } else if (!SvOK(value)) {
2884         value_type = HVrhek_undef;
2885     } else {
2886         value_type = HVrhek_PV;
2887     }
2888
2889     if (value_type == HVrhek_PV) {
2890         /* Do it this way so that the SvUTF8() test is after the SvPV, in case
2891            the value is overloaded, and doesn't yet have the UTF-8flag set.  */
2892         value_p = SvPV_const(value, value_len);
2893         if (SvUTF8(value))
2894             value_type = HVrhek_PV_UTF8;
2895     }
2896     flags = value_type;
2897
2898     if (is_utf8) {
2899         /* Hash keys are always stored normalised to (yes) ISO-8859-1.
2900            As we're going to be building hash keys from this value in future,
2901            normalise it now.  */
2902         key_p = (char*)bytes_from_utf8((const U8*)key_p, &key_len, &is_utf8);
2903         flags |= is_utf8 ? HVhek_UTF8 : HVhek_WASUTF8;
2904     }
2905
2906     return refcounted_he_new_common(parent, key_p, key_len, flags, value_type,
2907                                     ((value_type == HVrhek_PV
2908                                       || value_type == HVrhek_PV_UTF8) ?
2909                                      (void *)value_p : (void *)value),
2910                                     value_len);
2911 }
2912
2913 static struct refcounted_he *
2914 S_refcounted_he_new_common(pTHX_ struct refcounted_he *const parent,
2915                            const char *const key_p, const STRLEN key_len,
2916                            const char flags, char value_type,
2917                            const void *value, const STRLEN value_len) {
2918     dVAR;
2919     struct refcounted_he *he;
2920     U32 hash;
2921     const bool is_pv = value_type == HVrhek_PV || value_type == HVrhek_PV_UTF8;
2922     STRLEN key_offset = is_pv ? value_len + 2 : 1;
2923
2924     PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_COMMON;
2925
2926 #ifdef USE_ITHREADS
2927     he = (struct refcounted_he*)
2928         PerlMemShared_malloc(sizeof(struct refcounted_he) - 1
2929                              + key_len
2930                              + key_offset);
2931 #else
2932     he = (struct refcounted_he*)
2933         PerlMemShared_malloc(sizeof(struct refcounted_he) - 1
2934                              + key_offset);
2935 #endif
2936
2937     he->refcounted_he_next = parent;
2938
2939     if (is_pv) {
2940         Copy((char *)value, he->refcounted_he_data + 1, value_len + 1, char);
2941         he->refcounted_he_val.refcounted_he_u_len = value_len;
2942     } else if (value_type == HVrhek_IV) {
2943         he->refcounted_he_val.refcounted_he_u_iv = SvIVX((const SV *)value);
2944     } else if (value_type == HVrhek_UV) {
2945         he->refcounted_he_val.refcounted_he_u_uv = SvUVX((const SV *)value);
2946     }
2947
2948     PERL_HASH(hash, key_p, key_len);
2949
2950 #ifdef USE_ITHREADS
2951     he->refcounted_he_hash = hash;
2952     he->refcounted_he_keylen = key_len;
2953     Copy(key_p, he->refcounted_he_data + key_offset, key_len, char);
2954 #else
2955     he->refcounted_he_hek = share_hek_flags(key_p, key_len, hash, flags);
2956 #endif
2957
2958     if (flags & HVhek_WASUTF8) {
2959         /* If it was downgraded from UTF-8, then the pointer returned from
2960            bytes_from_utf8 is an allocated pointer that we must free.  */
2961         Safefree(key_p);
2962     }
2963
2964     he->refcounted_he_data[0] = flags;
2965     he->refcounted_he_refcnt = 1;
2966
2967     return he;
2968 }
2969
2970 /*
2971 =for apidoc refcounted_he_free
2972
2973 Decrements the reference count of the passed in C<struct refcounted_he *>
2974 by one. If the reference count reaches zero the structure's memory is freed,
2975 and C<refcounted_he_free> iterates onto the parent node.
2976
2977 =cut
2978 */
2979
2980 void
2981 Perl_refcounted_he_free(pTHX_ struct refcounted_he *he) {
2982     dVAR;
2983     PERL_UNUSED_CONTEXT;
2984
2985     while (he) {
2986         struct refcounted_he *copy;
2987         U32 new_count;
2988
2989         HINTS_REFCNT_LOCK;
2990         new_count = --he->refcounted_he_refcnt;
2991         HINTS_REFCNT_UNLOCK;
2992
2993         if (new_count) {
2994             return;
2995         }
2996
2997 #ifndef USE_ITHREADS
2998         unshare_hek_or_pvn (he->refcounted_he_hek, 0, 0, 0);
2999 #endif
3000         copy = he;
3001         he = he->refcounted_he_next;
3002         PerlMemShared_free(copy);
3003     }
3004 }
3005
3006 /* pp_entereval is aware that labels are stored with a key ':' at the top of
3007    the linked list.  */
3008 const char *
3009 Perl_fetch_cop_label(pTHX_ COP *const cop, STRLEN *len, U32 *flags) {
3010     struct refcounted_he *const chain = cop->cop_hints_hash;
3011
3012     PERL_ARGS_ASSERT_FETCH_COP_LABEL;
3013
3014     if (!chain)
3015         return NULL;
3016 #ifdef USE_ITHREADS
3017     if (chain->refcounted_he_keylen != 1)
3018         return NULL;
3019     if (*REF_HE_KEY(chain) != ':')
3020         return NULL;
3021 #else
3022     if ((STRLEN)HEK_LEN(chain->refcounted_he_hek) != 1)
3023         return NULL;
3024     if (*HEK_KEY(chain->refcounted_he_hek) != ':')
3025         return NULL;
3026 #endif
3027     /* Stop anyone trying to really mess us up by adding their own value for
3028        ':' into %^H  */
3029     if ((chain->refcounted_he_data[0] & HVrhek_typemask) != HVrhek_PV
3030         && (chain->refcounted_he_data[0] & HVrhek_typemask) != HVrhek_PV_UTF8)
3031         return NULL;
3032
3033     if (len)
3034         *len = chain->refcounted_he_val.refcounted_he_u_len;
3035     if (flags) {
3036         *flags = ((chain->refcounted_he_data[0] & HVrhek_typemask)
3037                   == HVrhek_PV_UTF8) ? SVf_UTF8 : 0;
3038     }
3039     return chain->refcounted_he_data + 1;
3040 }
3041
3042 void
3043 Perl_store_cop_label(pTHX_ COP *const cop, const char *label, STRLEN len,
3044                      U32 flags)
3045 {
3046     PERL_ARGS_ASSERT_STORE_COP_LABEL;
3047
3048     if (flags & ~(SVf_UTF8))
3049         Perl_croak(aTHX_ "panic: store_cop_label illegal flag bits 0x%" UVxf,
3050                    (UV)flags);
3051
3052     cop->cop_hints_hash
3053         = refcounted_he_new_common(cop->cop_hints_hash, ":", 1, HVrhek_PV,
3054                                    flags & SVf_UTF8 ? HVrhek_PV_UTF8 : HVrhek_PV,
3055                                    label, len);
3056 }
3057
3058 /*
3059 =for apidoc hv_assert
3060
3061 Check that a hash is in an internally consistent state.
3062
3063 =cut
3064 */
3065
3066 #ifdef DEBUGGING
3067
3068 void
3069 Perl_hv_assert(pTHX_ HV *hv)
3070 {
3071     dVAR;
3072     HE* entry;
3073     int withflags = 0;
3074     int placeholders = 0;
3075     int real = 0;
3076     int bad = 0;
3077     const I32 riter = HvRITER_get(hv);
3078     HE *eiter = HvEITER_get(hv);
3079
3080     PERL_ARGS_ASSERT_HV_ASSERT;
3081
3082     (void)hv_iterinit(hv);
3083
3084     while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))) {
3085         /* sanity check the values */
3086         if (HeVAL(entry) == &PL_sv_placeholder)
3087             placeholders++;
3088         else
3089             real++;
3090         /* sanity check the keys */
3091         if (HeSVKEY(entry)) {
3092             NOOP;   /* Don't know what to check on SV keys.  */
3093         } else if (HeKUTF8(entry)) {
3094             withflags++;
3095             if (HeKWASUTF8(entry)) {
3096                 PerlIO_printf(Perl_debug_log,
3097                             "hash key has both WASUTF8 and UTF8: '%.*s'\n",
3098                             (int) HeKLEN(entry),  HeKEY(entry));
3099                 bad = 1;
3100             }
3101         } else if (HeKWASUTF8(entry))
3102             withflags++;
3103     }
3104     if (!SvTIED_mg((const SV *)hv, PERL_MAGIC_tied)) {
3105         static const char bad_count[] = "Count %d %s(s), but hash reports %d\n";
3106         const int nhashkeys = HvUSEDKEYS(hv);
3107         const int nhashplaceholders = HvPLACEHOLDERS_get(hv);
3108
3109         if (nhashkeys != real) {
3110             PerlIO_printf(Perl_debug_log, bad_count, real, "keys", nhashkeys );
3111             bad = 1;
3112         }
3113         if (nhashplaceholders != placeholders) {
3114             PerlIO_printf(Perl_debug_log, bad_count, placeholders, "placeholder", nhashplaceholders );
3115             bad = 1;
3116         }
3117     }
3118     if (withflags && ! HvHASKFLAGS(hv)) {
3119         PerlIO_printf(Perl_debug_log,
3120                     "Hash has HASKFLAGS off but I count %d key(s) with flags\n",
3121                     withflags);
3122         bad = 1;
3123     }
3124     if (bad) {
3125         sv_dump(MUTABLE_SV(hv));
3126     }
3127     HvRITER_set(hv, riter);             /* Restore hash iterator state */
3128     HvEITER_set(hv, eiter);
3129 }
3130
3131 #endif
3132
3133 /*
3134  * Local variables:
3135  * c-indentation-style: bsd
3136  * c-basic-offset: 4
3137  * indent-tabs-mode: t
3138  * End:
3139  *
3140  * ex: set ts=8 sts=4 sw=4 noet:
3141  */