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