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