This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Eliminate PL_dirty
[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) {
df5f182b 738 val = action & HV_FETCH_EMPTY_HE ? NULL : 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;
f3d2f32d 990 U8 mro_changes = 0; /* 1 = isa; 2 = package moved */
0c3bb3c2
FC
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 ) {
f3d2f32d 1047 mro_changes = 2;
0c3bb3c2
FC
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 1055 }
f3d2f32d
FC
1056 else if (klen == 3 && strnEQ(key, "ISA", 3))
1057 mro_changes = 1;
35759254
FC
1058 }
1059
cd6d36ac 1060 if (d_flags & G_DISCARD)
a0714e2c 1061 sv = NULL;
94f7643d 1062 else {
79d01fbf 1063 sv = sv_2mortal(HeVAL(entry));
7996736c 1064 HeVAL(entry) = &PL_sv_placeholder;
94f7643d 1065 }
8aacddc1
NIS
1066
1067 /*
1068 * If a restricted hash, rather than really deleting the entry, put
1069 * a placeholder there. This marks the key as being "approved", so
1070 * we can still access via not-really-existing key without raising
1071 * an error.
1072 */
1073 if (SvREADONLY(hv)) {
754604c4 1074 SvREFCNT_dec(HeVAL(entry));
7996736c 1075 HeVAL(entry) = &PL_sv_placeholder;
8aacddc1
NIS
1076 /* We'll be saving this slot, so the number of allocated keys
1077 * doesn't go down, but the number placeholders goes up */
ca732855 1078 HvPLACEHOLDERS(hv)++;
8aacddc1 1079 } else {
a26e96df 1080 *oentry = HeNEXT(entry);
b79f7545 1081 if (SvOOK(hv) && entry == HvAUX(hv)->xhv_eiter /* HvEITER(hv) */)
8aacddc1
NIS
1082 HvLAZYDEL_on(hv);
1083 else
1084 hv_free_ent(hv, entry);
4c7185a0 1085 xhv->xhv_keys--; /* HvTOTALKEYS(hv)-- */
574c8022 1086 if (xhv->xhv_keys == 0)
19692e8d 1087 HvHASKFLAGS_off(hv);
8aacddc1 1088 }
0c3bb3c2 1089
f3d2f32d
FC
1090 if (mro_changes == 1) mro_isa_changed_in(hv);
1091 else if (mro_changes == 2)
1092 mro_package_moved(NULL, stash, NULL, name, namlen);
0c3bb3c2 1093
79072805
LW
1094 return sv;
1095 }
8aacddc1 1096 if (SvREADONLY(hv)) {
d4c19fe8 1097 hv_notallowed(k_flags, key, klen,
c8cd6465
NC
1098 "Attempt to delete disallowed key '%"SVf"' from"
1099 " a restricted hash");
8aacddc1
NIS
1100 }
1101
19692e8d 1102 if (k_flags & HVhek_FREEKEY)
f9a63242 1103 Safefree(key);
a0714e2c 1104 return NULL;
79072805
LW
1105}
1106
76e3520e 1107STATIC void
cea2e8a9 1108S_hsplit(pTHX_ HV *hv)
79072805 1109{
97aff369 1110 dVAR;
1e05feb3 1111 register XPVHV* const xhv = (XPVHV*)SvANY(hv);
a3b680e6 1112 const I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
79072805
LW
1113 register I32 newsize = oldsize * 2;
1114 register I32 i;
7b2c381c 1115 char *a = (char*) HvARRAY(hv);
72311751 1116 register HE **aep;
4b5190b5
NC
1117 int longest_chain = 0;
1118 int was_shared;
79072805 1119
7918f24d
NC
1120 PERL_ARGS_ASSERT_HSPLIT;
1121
18026298 1122 /*PerlIO_printf(PerlIO_stderr(), "hsplit called for %p which had %d\n",
6c9570dc 1123 (void*)hv, (int) oldsize);*/
18026298 1124
5d88ecd7 1125 if (HvPLACEHOLDERS_get(hv) && !SvREADONLY(hv)) {
18026298
NC
1126 /* Can make this clear any placeholders first for non-restricted hashes,
1127 even though Storable rebuilds restricted hashes by putting in all the
1128 placeholders (first) before turning on the readonly flag, because
1129 Storable always pre-splits the hash. */
1130 hv_clear_placeholders(hv);
1131 }
1132
3280af22 1133 PL_nomemok = TRUE;
8d6dde3e 1134#if defined(STRANGE_MALLOC) || defined(MYMALLOC)
b79f7545
NC
1135 Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize)
1136 + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char);
422a93e5 1137 if (!a) {
4a33f861 1138 PL_nomemok = FALSE;
422a93e5
GA
1139 return;
1140 }
b79f7545 1141 if (SvOOK(hv)) {
31f0e52e 1142 Move(&a[oldsize * sizeof(HE*)], &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux);
b79f7545 1143 }
4633a7c4 1144#else
a02a5408 1145 Newx(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize)
b79f7545 1146 + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char);
422a93e5 1147 if (!a) {
3280af22 1148 PL_nomemok = FALSE;
422a93e5
GA
1149 return;
1150 }
7b2c381c 1151 Copy(HvARRAY(hv), a, oldsize * sizeof(HE*), char);
b79f7545
NC
1152 if (SvOOK(hv)) {
1153 Copy(HvAUX(hv), &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux);
1154 }
9a87bd09 1155 Safefree(HvARRAY(hv));
4633a7c4
LW
1156#endif
1157
3280af22 1158 PL_nomemok = FALSE;
72311751 1159 Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
cbec9347 1160 xhv->xhv_max = --newsize; /* HvMAX(hv) = --newsize */
7b2c381c 1161 HvARRAY(hv) = (HE**) a;
72311751 1162 aep = (HE**)a;
79072805 1163
72311751 1164 for (i=0; i<oldsize; i++,aep++) {
4b5190b5
NC
1165 int left_length = 0;
1166 int right_length = 0;
a50a3493
NC
1167 HE **oentry = aep;
1168 HE *entry = *aep;
a3b680e6 1169 register HE **bep;
4b5190b5 1170
a50a3493 1171 if (!entry) /* non-existent */
79072805 1172 continue;
72311751 1173 bep = aep+oldsize;
4c9d89c5 1174 do {
eb160463 1175 if ((HeHASH(entry) & newsize) != (U32)i) {
fde52b5c 1176 *oentry = HeNEXT(entry);
72311751 1177 HeNEXT(entry) = *bep;
72311751 1178 *bep = entry;
4b5190b5 1179 right_length++;
79072805 1180 }
4b5190b5 1181 else {
fde52b5c 1182 oentry = &HeNEXT(entry);
4b5190b5
NC
1183 left_length++;
1184 }
4c9d89c5
NC
1185 entry = *oentry;
1186 } while (entry);
4b5190b5
NC
1187 /* I think we don't actually need to keep track of the longest length,
1188 merely flag if anything is too long. But for the moment while
1189 developing this code I'll track it. */
1190 if (left_length > longest_chain)
1191 longest_chain = left_length;
1192 if (right_length > longest_chain)
1193 longest_chain = right_length;
1194 }
1195
1196
1197 /* Pick your policy for "hashing isn't working" here: */
fdcd69b6 1198 if (longest_chain <= HV_MAX_LENGTH_BEFORE_SPLIT /* split worked? */
4b5190b5
NC
1199 || HvREHASH(hv)) {
1200 return;
79072805 1201 }
4b5190b5
NC
1202
1203 if (hv == PL_strtab) {
1204 /* Urg. Someone is doing something nasty to the string table.
1205 Can't win. */
1206 return;
1207 }
1208
1209 /* Awooga. Awooga. Pathological data. */
6c9570dc 1210 /*PerlIO_printf(PerlIO_stderr(), "%p %d of %d with %d/%d buckets\n", (void*)hv,
4b5190b5
NC
1211 longest_chain, HvTOTALKEYS(hv), HvFILL(hv), 1+HvMAX(hv));*/
1212
1213 ++newsize;
a02a5408 1214 Newxz(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize)
b79f7545
NC
1215 + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char);
1216 if (SvOOK(hv)) {
1217 Copy(HvAUX(hv), &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux);
1218 }
1219
4b5190b5
NC
1220 was_shared = HvSHAREKEYS(hv);
1221
4b5190b5
NC
1222 HvSHAREKEYS_off(hv);
1223 HvREHASH_on(hv);
1224
7b2c381c 1225 aep = HvARRAY(hv);
4b5190b5
NC
1226
1227 for (i=0; i<newsize; i++,aep++) {
a3b680e6 1228 register HE *entry = *aep;
4b5190b5
NC
1229 while (entry) {
1230 /* We're going to trash this HE's next pointer when we chain it
1231 into the new hash below, so store where we go next. */
9d4ba2ae 1232 HE * const next = HeNEXT(entry);
4b5190b5 1233 UV hash;
a3b680e6 1234 HE **bep;
4b5190b5
NC
1235
1236 /* Rehash it */
1237 PERL_HASH_INTERNAL(hash, HeKEY(entry), HeKLEN(entry));
1238
1239 if (was_shared) {
1240 /* Unshare it. */
aec46f14 1241 HEK * const new_hek
4b5190b5
NC
1242 = save_hek_flags(HeKEY(entry), HeKLEN(entry),
1243 hash, HeKFLAGS(entry));
1244 unshare_hek (HeKEY_hek(entry));
1245 HeKEY_hek(entry) = new_hek;
1246 } else {
1247 /* Not shared, so simply write the new hash in. */
1248 HeHASH(entry) = hash;
1249 }
1250 /*PerlIO_printf(PerlIO_stderr(), "%d ", HeKFLAGS(entry));*/
1251 HEK_REHASH_on(HeKEY_hek(entry));
1252 /*PerlIO_printf(PerlIO_stderr(), "%d\n", HeKFLAGS(entry));*/
1253
1254 /* Copy oentry to the correct new chain. */
1255 bep = ((HE**)a) + (hash & (I32) xhv->xhv_max);
4b5190b5
NC
1256 HeNEXT(entry) = *bep;
1257 *bep = entry;
1258
1259 entry = next;
1260 }
1261 }
7b2c381c
NC
1262 Safefree (HvARRAY(hv));
1263 HvARRAY(hv) = (HE **)a;
79072805
LW
1264}
1265
72940dca 1266void
864dbfa3 1267Perl_hv_ksplit(pTHX_ HV *hv, IV newmax)
72940dca 1268{
97aff369 1269 dVAR;
cbec9347 1270 register XPVHV* xhv = (XPVHV*)SvANY(hv);
a3b680e6 1271 const I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
72940dca
PP
1272 register I32 newsize;
1273 register I32 i;
72311751
GS
1274 register char *a;
1275 register HE **aep;
72940dca 1276
7918f24d
NC
1277 PERL_ARGS_ASSERT_HV_KSPLIT;
1278
72940dca
PP
1279 newsize = (I32) newmax; /* possible truncation here */
1280 if (newsize != newmax || newmax <= oldsize)
1281 return;
1282 while ((newsize & (1 + ~newsize)) != newsize) {
1283 newsize &= ~(newsize & (1 + ~newsize)); /* get proper power of 2 */
1284 }
1285 if (newsize < newmax)
1286 newsize *= 2;
1287 if (newsize < newmax)
1288 return; /* overflow detection */
1289
7b2c381c 1290 a = (char *) HvARRAY(hv);
72940dca 1291 if (a) {
3280af22 1292 PL_nomemok = TRUE;
8d6dde3e 1293#if defined(STRANGE_MALLOC) || defined(MYMALLOC)
b79f7545
NC
1294 Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize)
1295 + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char);
8aacddc1 1296 if (!a) {
4a33f861 1297 PL_nomemok = FALSE;
422a93e5
GA
1298 return;
1299 }
b79f7545 1300 if (SvOOK(hv)) {
7a9b70e9 1301 Copy(&a[oldsize * sizeof(HE*)], &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux);
b79f7545 1302 }
72940dca 1303#else
a02a5408 1304 Newx(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize)
b79f7545 1305 + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char);
8aacddc1 1306 if (!a) {
3280af22 1307 PL_nomemok = FALSE;
422a93e5
GA
1308 return;
1309 }
7b2c381c 1310 Copy(HvARRAY(hv), a, oldsize * sizeof(HE*), char);
b79f7545
NC
1311 if (SvOOK(hv)) {
1312 Copy(HvAUX(hv), &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux);
1313 }
9a87bd09 1314 Safefree(HvARRAY(hv));
72940dca 1315#endif
3280af22 1316 PL_nomemok = FALSE;
72311751 1317 Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
72940dca
PP
1318 }
1319 else {
a02a5408 1320 Newxz(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
72940dca 1321 }
cbec9347 1322 xhv->xhv_max = --newsize; /* HvMAX(hv) = --newsize */
7b2c381c 1323 HvARRAY(hv) = (HE **) a;
f4431c56 1324 if (!xhv->xhv_keys /* !HvTOTALKEYS(hv) */) /* skip rest if no entries */
72940dca
PP
1325 return;
1326
72311751
GS
1327 aep = (HE**)a;
1328 for (i=0; i<oldsize; i++,aep++) {
a50a3493
NC
1329 HE **oentry = aep;
1330 HE *entry = *aep;
1331
1332 if (!entry) /* non-existent */
72940dca 1333 continue;
4c9d89c5 1334 do {
6136c704
AL
1335 register I32 j = (HeHASH(entry) & newsize);
1336
1337 if (j != i) {
72940dca
PP
1338 j -= i;
1339 *oentry = HeNEXT(entry);
4d0fbddd 1340 HeNEXT(entry) = aep[j];
72311751 1341 aep[j] = entry;
72940dca
PP
1342 }
1343 else
1344 oentry = &HeNEXT(entry);
4c9d89c5
NC
1345 entry = *oentry;
1346 } while (entry);
72940dca
PP
1347 }
1348}
1349
b3ac6de7 1350HV *
864dbfa3 1351Perl_newHVhv(pTHX_ HV *ohv)
b3ac6de7 1352{
749123ff 1353 dVAR;
9d4ba2ae 1354 HV * const hv = newHV();
f4431c56 1355 STRLEN hv_max;
4beac62f 1356
f4431c56 1357 if (!ohv || !HvTOTALKEYS(ohv))
4beac62f 1358 return hv;
4beac62f 1359 hv_max = HvMAX(ohv);
b3ac6de7 1360
ad64d0ec 1361 if (!SvMAGICAL((const SV *)ohv)) {
b56ba0bf 1362 /* It's an ordinary hash, so copy it fast. AMS 20010804 */
eb160463 1363 STRLEN i;
a3b680e6 1364 const bool shared = !!HvSHAREKEYS(ohv);
aec46f14 1365 HE **ents, ** const oents = (HE **)HvARRAY(ohv);
ff875642 1366 char *a;
a02a5408 1367 Newx(a, PERL_HV_ARRAY_ALLOC_BYTES(hv_max+1), char);
ff875642 1368 ents = (HE**)a;
b56ba0bf
AMS
1369
1370 /* In each bucket... */
1371 for (i = 0; i <= hv_max; i++) {
6136c704 1372 HE *prev = NULL;
aec46f14 1373 HE *oent = oents[i];
b56ba0bf
AMS
1374
1375 if (!oent) {
1376 ents[i] = NULL;
1377 continue;
1378 }
1379
1380 /* Copy the linked list of entries. */
aec46f14 1381 for (; oent; oent = HeNEXT(oent)) {
a3b680e6
AL
1382 const U32 hash = HeHASH(oent);
1383 const char * const key = HeKEY(oent);
1384 const STRLEN len = HeKLEN(oent);
1385 const int flags = HeKFLAGS(oent);
6136c704 1386 HE * const ent = new_HE();
c3acb9e0 1387 SV *const val = HeVAL(oent);
b56ba0bf 1388
c3acb9e0 1389 HeVAL(ent) = SvIMMORTAL(val) ? val : newSVsv(val);
19692e8d 1390 HeKEY_hek(ent)
6e838c70 1391 = shared ? share_hek_flags(key, len, hash, flags)
19692e8d 1392 : save_hek_flags(key, len, hash, flags);
b56ba0bf
AMS
1393 if (prev)
1394 HeNEXT(prev) = ent;
1395 else
1396 ents[i] = ent;
1397 prev = ent;
1398 HeNEXT(ent) = NULL;
1399 }
1400 }
1401
1402 HvMAX(hv) = hv_max;
8aacddc1 1403 HvTOTALKEYS(hv) = HvTOTALKEYS(ohv);
b56ba0bf 1404 HvARRAY(hv) = ents;
aec46f14 1405 } /* not magical */
b56ba0bf
AMS
1406 else {
1407 /* Iterate over ohv, copying keys and values one at a time. */
b3ac6de7 1408 HE *entry;
bfcb3514
NC
1409 const I32 riter = HvRITER_get(ohv);
1410 HE * const eiter = HvEITER_get(ohv);
f4431c56 1411 STRLEN hv_fill = HvFILL(ohv);
b56ba0bf
AMS
1412
1413 /* Can we use fewer buckets? (hv_max is always 2^n-1) */
1414 while (hv_max && hv_max + 1 >= hv_fill * 2)
1415 hv_max = hv_max / 2;
1416 HvMAX(hv) = hv_max;
1417
4a76a316 1418 hv_iterinit(ohv);
e16e2ff8 1419 while ((entry = hv_iternext_flags(ohv, 0))) {
c3acb9e0 1420 SV *const val = HeVAL(entry);
04fe65b0 1421 (void)hv_store_flags(hv, HeKEY(entry), HeKLEN(entry),
c3acb9e0
NC
1422 SvIMMORTAL(val) ? val : newSVsv(val),
1423 HeHASH(entry), HeKFLAGS(entry));
b3ac6de7 1424 }
bfcb3514
NC
1425 HvRITER_set(ohv, riter);
1426 HvEITER_set(ohv, eiter);
b3ac6de7 1427 }
1c846c1f 1428
b3ac6de7
IZ
1429 return hv;
1430}
1431
defdfed5
Z
1432/*
1433=for apidoc Am|HV *|hv_copy_hints_hv|HV *ohv
1434
1435A specialised version of L</newHVhv> for copying C<%^H>. I<ohv> must be
1436a pointer to a hash (which may have C<%^H> magic, but should be generally
1437non-magical), or C<NULL> (interpreted as an empty hash). The content
1438of I<ohv> is copied to a new hash, which has the C<%^H>-specific magic
1439added to it. A pointer to the new hash is returned.
1440
1441=cut
1442*/
1443
5b9c0671
NC
1444HV *
1445Perl_hv_copy_hints_hv(pTHX_ HV *const ohv)
1446{
1447 HV * const hv = newHV();
5b9c0671 1448
f4431c56 1449 if (ohv && HvTOTALKEYS(ohv)) {
5b9c0671 1450 STRLEN hv_max = HvMAX(ohv);
f4431c56 1451 STRLEN hv_fill = HvFILL(ohv);
5b9c0671
NC
1452 HE *entry;
1453 const I32 riter = HvRITER_get(ohv);
1454 HE * const eiter = HvEITER_get(ohv);
1455
1456 while (hv_max && hv_max + 1 >= hv_fill * 2)
1457 hv_max = hv_max / 2;
1458 HvMAX(hv) = hv_max;
1459
1460 hv_iterinit(ohv);
1461 while ((entry = hv_iternext_flags(ohv, 0))) {
1462 SV *const sv = newSVsv(HeVAL(entry));
e3b1b6b1 1463 SV *heksv = newSVhek(HeKEY_hek(entry));
5b9c0671 1464 sv_magic(sv, NULL, PERL_MAGIC_hintselem,
e3b1b6b1
RGS
1465 (char *)heksv, HEf_SVKEY);
1466 SvREFCNT_dec(heksv);
04fe65b0
RGS
1467 (void)hv_store_flags(hv, HeKEY(entry), HeKLEN(entry),
1468 sv, HeHASH(entry), HeKFLAGS(entry));
5b9c0671
NC
1469 }
1470 HvRITER_set(ohv, riter);
1471 HvEITER_set(ohv, eiter);
1472 }
1473 hv_magic(hv, NULL, PERL_MAGIC_hints);
1474 return hv;
1475}
1476
79072805 1477void
864dbfa3 1478Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry)
79072805 1479{
97aff369 1480 dVAR;
16bdeea2
GS
1481 SV *val;
1482
7918f24d
NC
1483 PERL_ARGS_ASSERT_HV_FREE_ENT;
1484
68dc0745 1485 if (!entry)
79072805 1486 return;
16bdeea2 1487 val = HeVAL(entry);
00169e2c 1488 if (val && isGV(val) && isGV_with_GP(val) && GvCVu(val) && HvENAME(hv))
803f2748 1489 mro_method_changed_in(hv); /* deletion of method from stash */
16bdeea2 1490 SvREFCNT_dec(val);
68dc0745
PP
1491 if (HeKLEN(entry) == HEf_SVKEY) {
1492 SvREFCNT_dec(HeKEY_sv(entry));
8aacddc1 1493 Safefree(HeKEY_hek(entry));
44a8e56a
PP
1494 }
1495 else if (HvSHAREKEYS(hv))
68dc0745 1496 unshare_hek(HeKEY_hek(entry));
fde52b5c 1497 else
68dc0745 1498 Safefree(HeKEY_hek(entry));
d33b2eba 1499 del_HE(entry);
79072805
LW
1500}
1501
f1c32fec 1502
79072805 1503void
864dbfa3 1504Perl_hv_delayfree_ent(pTHX_ HV *hv, register HE *entry)
79072805 1505{
97aff369 1506 dVAR;
7918f24d
NC
1507
1508 PERL_ARGS_ASSERT_HV_DELAYFREE_ENT;
1509
68dc0745 1510 if (!entry)
79072805 1511 return;
bc4947fc
NC
1512 /* SvREFCNT_inc to counter the SvREFCNT_dec in hv_free_ent */
1513 sv_2mortal(SvREFCNT_inc(HeVAL(entry))); /* free between statements */
68dc0745 1514 if (HeKLEN(entry) == HEf_SVKEY) {
bc4947fc 1515 sv_2mortal(SvREFCNT_inc(HeKEY_sv(entry)));
44a8e56a 1516 }
bc4947fc 1517 hv_free_ent(hv, entry);
79072805
LW
1518}
1519
954c1994
GS
1520/*
1521=for apidoc hv_clear
1522
1523Clears a hash, making it empty.
1524
1525=cut
1526*/
1527
79072805 1528void
864dbfa3 1529Perl_hv_clear(pTHX_ HV *hv)
79072805 1530{
27da23d5 1531 dVAR;
cbec9347 1532 register XPVHV* xhv;
79072805
LW
1533 if (!hv)
1534 return;
49293501 1535
ecae49c0
NC
1536 DEBUG_A(Perl_hv_assert(aTHX_ hv));
1537
34c3c4e3
DM
1538 xhv = (XPVHV*)SvANY(hv);
1539
7b2c381c 1540 if (SvREADONLY(hv) && HvARRAY(hv) != NULL) {
34c3c4e3 1541 /* restricted hash: convert all keys to placeholders */
b464bac0
AL
1542 STRLEN i;
1543 for (i = 0; i <= xhv->xhv_max; i++) {
7b2c381c 1544 HE *entry = (HvARRAY(hv))[i];
3a676441
JH
1545 for (; entry; entry = HeNEXT(entry)) {
1546 /* not already placeholder */
7996736c 1547 if (HeVAL(entry) != &PL_sv_placeholder) {
3a676441 1548 if (HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
6136c704 1549 SV* const keysv = hv_iterkeysv(entry);
3a676441 1550 Perl_croak(aTHX_
95b63a38
JH
1551 "Attempt to delete readonly key '%"SVf"' from a restricted hash",
1552 (void*)keysv);
3a676441
JH
1553 }
1554 SvREFCNT_dec(HeVAL(entry));
7996736c 1555 HeVAL(entry) = &PL_sv_placeholder;
ca732855 1556 HvPLACEHOLDERS(hv)++;
3a676441 1557 }
34c3c4e3
DM
1558 }
1559 }
df8c6964 1560 goto reset;
49293501
MS
1561 }
1562
463ee0b2 1563 hfreeentries(hv);
ca732855 1564 HvPLACEHOLDERS_set(hv, 0);
7b2c381c 1565 if (HvARRAY(hv))
41f62432 1566 Zero(HvARRAY(hv), xhv->xhv_max+1 /* HvMAX(hv)+1 */, HE*);
a0d0e21e
LW
1567
1568 if (SvRMAGICAL(hv))
ad64d0ec 1569 mg_clear(MUTABLE_SV(hv));
574c8022 1570
19692e8d 1571 HvHASKFLAGS_off(hv);
bb443f97 1572 HvREHASH_off(hv);
df8c6964 1573 reset:
b79f7545 1574 if (SvOOK(hv)) {
00169e2c 1575 if(HvENAME_get(hv))
dd69841b 1576 mro_isa_changed_in(hv);
bfcb3514
NC
1577 HvEITER_set(hv, NULL);
1578 }
79072805
LW
1579}
1580
3540d4ce
AB
1581/*
1582=for apidoc hv_clear_placeholders
1583
1584Clears any placeholders from a hash. If a restricted hash has any of its keys
1585marked as readonly and the key is subsequently deleted, the key is not actually
1586deleted but is marked by assigning it a value of &PL_sv_placeholder. This tags
1587it so it will be ignored by future operations such as iterating over the hash,
4cdaeff7 1588but will still allow the hash to have a value reassigned to the key at some
3540d4ce
AB
1589future point. This function clears any such placeholder keys from the hash.
1590See Hash::Util::lock_keys() for an example of its use.
1591
1592=cut
1593*/
1594
1595void
1596Perl_hv_clear_placeholders(pTHX_ HV *hv)
1597{
27da23d5 1598 dVAR;
b3ca2e83
NC
1599 const U32 items = (U32)HvPLACEHOLDERS_get(hv);
1600
7918f24d
NC
1601 PERL_ARGS_ASSERT_HV_CLEAR_PLACEHOLDERS;
1602
b3ca2e83
NC
1603 if (items)
1604 clear_placeholders(hv, items);
1605}
1606
1607static void
1608S_clear_placeholders(pTHX_ HV *hv, U32 items)
1609{
1610 dVAR;
b464bac0 1611 I32 i;
d3677389 1612
7918f24d
NC
1613 PERL_ARGS_ASSERT_CLEAR_PLACEHOLDERS;
1614
d3677389
NC
1615 if (items == 0)
1616 return;
1617
b464bac0 1618 i = HvMAX(hv);
d3677389
NC
1619 do {
1620 /* Loop down the linked list heads */
6136c704 1621 bool first = TRUE;
d3677389 1622 HE **oentry = &(HvARRAY(hv))[i];
cf6db12b 1623 HE *entry;
d3677389 1624
cf6db12b 1625 while ((entry = *oentry)) {
d3677389
NC
1626 if (HeVAL(entry) == &PL_sv_placeholder) {
1627 *oentry = HeNEXT(entry);
2e58978b 1628 if (entry == HvEITER_get(hv))
d3677389
NC
1629 HvLAZYDEL_on(hv);
1630 else
1631 hv_free_ent(hv, entry);
1632
1633 if (--items == 0) {
1634 /* Finished. */
5d88ecd7 1635 HvTOTALKEYS(hv) -= (IV)HvPLACEHOLDERS_get(hv);
d3677389
NC
1636 if (HvKEYS(hv) == 0)
1637 HvHASKFLAGS_off(hv);
5d88ecd7 1638 HvPLACEHOLDERS_set(hv, 0);
d3677389
NC
1639 return;
1640 }
213ce8b3
NC
1641 } else {
1642 oentry = &HeNEXT(entry);
6136c704 1643 first = FALSE;
d3677389
NC
1644 }
1645 }
1646 } while (--i >= 0);
1647 /* You can't get here, hence assertion should always fail. */
1648 assert (items == 0);
1649 assert (0);
3540d4ce
AB
1650}
1651
76e3520e 1652STATIC void
cea2e8a9 1653S_hfreeentries(pTHX_ HV *hv)
79072805 1654{
23976bdd 1655 /* This is the array that we're going to restore */
fd7de8a8 1656 HE **const orig_array = HvARRAY(hv);
23976bdd 1657 HEK *name;
78b79c77 1658 I32 name_count;
23976bdd 1659 int attempts = 100;
3abe233e 1660
7918f24d
NC
1661 PERL_ARGS_ASSERT_HFREEENTRIES;
1662
fd7de8a8 1663 if (!orig_array)
79072805 1664 return;
a0d0e21e 1665
23976bdd
NC
1666 if (SvOOK(hv)) {
1667 /* If the hash is actually a symbol table with a name, look after the
1668 name. */
1669 struct xpvhv_aux *iter = HvAUX(hv);
1670
1671 name = iter->xhv_name;
b7247a80 1672 name_count = iter->xhv_name_count;
23976bdd
NC
1673 iter->xhv_name = NULL;
1674 } else {
1675 name = NULL;
b7247a80 1676 name_count = 0;
23976bdd
NC
1677 }
1678
23976bdd
NC
1679 /* orig_array remains unchanged throughout the loop. If after freeing all
1680 the entries it turns out that one of the little blighters has triggered
1681 an action that has caused HvARRAY to be re-allocated, then we set
1682 array to the new HvARRAY, and try again. */
1683
1684 while (1) {
1685 /* This is the one we're going to try to empty. First time round
1686 it's the original array. (Hopefully there will only be 1 time
1687 round) */
6136c704 1688 HE ** const array = HvARRAY(hv);
7440661e 1689 I32 i = HvMAX(hv);
23976bdd
NC
1690
1691 /* Because we have taken xhv_name out, the only allocated pointer
1692 in the aux structure that might exist is the backreference array.
1693 */
1694
1695 if (SvOOK(hv)) {
7440661e 1696 HE *entry;
e1a479c5 1697 struct mro_meta *meta;
09aad8f0 1698 struct xpvhv_aux *iter = HvAUX(hv);
cdb996f4
DM
1699 /* weak references: if called from sv_clear(), the backrefs
1700 * should already have been killed; if there are any left, its
1701 * because we're doing hv_clear() or hv_undef(), and the HV
1702 * will continue to live.
1703 * Because while freeing the entries we fake up a NULL HvARRAY
1704 * (and hence HvAUX), we need to store the backref array
1705 * somewhere else; but it still needs to be visible in case
1706 * any the things we free happen to call sv_del_backref().
1707 * We do this by storing it in magic instead.
1708 * If, during the entry freeing, a destructor happens to add
1709 * a new weak backref, then sv_add_backref will look in both
1710 * places (magic in HvAUX) for the AV, but will create a new
8ac9a371
DM
1711 * AV in HvAUX if it can't find one (if it finds it in magic,
1712 * it moves it back into HvAUX. So at the end of the iteration
1713 * we have to allow for this. */
1714
09aad8f0
DM
1715
1716 if (iter->xhv_backreferences) {
5648c0ae
DM
1717 if (SvTYPE(iter->xhv_backreferences) == SVt_PVAV) {
1718 /* The sv_magic will increase the reference count of the AV,
1719 so we need to drop it first. */
09aad8f0 1720 SvREFCNT_dec(iter->xhv_backreferences);
5648c0ae
DM
1721 if (AvFILLp(iter->xhv_backreferences) == -1) {
1722 /* Turns out that the array is empty. Just free it. */
1723 SvREFCNT_dec(iter->xhv_backreferences);
1b8791d1 1724
5648c0ae
DM
1725 } else {
1726 sv_magic(MUTABLE_SV(hv),
1727 MUTABLE_SV(iter->xhv_backreferences),
1728 PERL_MAGIC_backref, NULL, 0);
1729 }
1730 }
1731 else {
1732 MAGIC *mg;
1733 sv_magic(MUTABLE_SV(hv), NULL, PERL_MAGIC_backref, NULL, 0);
1734 mg = mg_find(MUTABLE_SV(hv), PERL_MAGIC_backref);
1735 mg->mg_obj = (SV*)iter->xhv_backreferences;
09aad8f0
DM
1736 }
1737 iter->xhv_backreferences = NULL;
5b285ea4 1738 }
86f55936 1739
23976bdd
NC
1740 entry = iter->xhv_eiter; /* HvEITER(hv) */
1741 if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */
1742 HvLAZYDEL_off(hv);
1743 hv_free_ent(hv, entry);
1744 }
1745 iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
4608196e 1746 iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
b79f7545 1747
e1a479c5 1748 if((meta = iter->xhv_mro_meta)) {
9953ff72
NC
1749 if (meta->mro_linear_all) {
1750 SvREFCNT_dec(MUTABLE_SV(meta->mro_linear_all));
1751 meta->mro_linear_all = NULL;
553e831a 1752 /* This is just acting as a shortcut pointer. */
3a6fa573
NC
1753 meta->mro_linear_current = NULL;
1754 } else if (meta->mro_linear_current) {
553e831a
NC
1755 /* Only the current MRO is stored, so this owns the data.
1756 */
3a6fa573
NC
1757 SvREFCNT_dec(meta->mro_linear_current);
1758 meta->mro_linear_current = NULL;
553e831a 1759 }
e1a479c5 1760 if(meta->mro_nextmethod) SvREFCNT_dec(meta->mro_nextmethod);
a49ba3fc 1761 SvREFCNT_dec(meta->isa);
e1a479c5
BB
1762 Safefree(meta);
1763 iter->xhv_mro_meta = NULL;
1764 }
1765
23976bdd 1766 /* There are now no allocated pointers in the aux structure. */
2f86008e 1767
23976bdd
NC
1768 SvFLAGS(hv) &= ~SVf_OOK; /* Goodbye, aux structure. */
1769 /* What aux structure? */
a0d0e21e 1770 }
bfcb3514 1771
23976bdd 1772 /* make everyone else think the array is empty, so that the destructors
cef0c2ea 1773 * called for freed entries can't recursively mess with us */
23976bdd 1774 HvARRAY(hv) = NULL;
23976bdd
NC
1775 ((XPVHV*) SvANY(hv))->xhv_keys = 0;
1776
7440661e
NC
1777
1778 do {
1779 /* Loop down the linked list heads */
1780 HE *entry = array[i];
1781
1782 while (entry) {
23976bdd
NC
1783 register HE * const oentry = entry;
1784 entry = HeNEXT(entry);
1785 hv_free_ent(hv, oentry);
1786 }
7440661e 1787 } while (--i >= 0);
b79f7545 1788
23976bdd
NC
1789 /* As there are no allocated pointers in the aux structure, it's now
1790 safe to free the array we just cleaned up, if it's not the one we're
1791 going to put back. */
1792 if (array != orig_array) {
1793 Safefree(array);
1794 }
b79f7545 1795
23976bdd
NC
1796 if (!HvARRAY(hv)) {
1797 /* Good. No-one added anything this time round. */
1798 break;
bfcb3514 1799 }
b79f7545 1800
23976bdd
NC
1801 if (SvOOK(hv)) {
1802 /* Someone attempted to iterate or set the hash name while we had
1803 the array set to 0. We'll catch backferences on the next time
1804 round the while loop. */
1805 assert(HvARRAY(hv));
1b8791d1 1806
23976bdd 1807 if (HvAUX(hv)->xhv_name) {
b7247a80
FC
1808 if(HvAUX(hv)->xhv_name_count) {
1809 HEK ** const name = (HEK **)HvAUX(hv)->xhv_name;
78b79c77
FC
1810 I32 const count = HvAUX(hv)->xhv_name_count;
1811 HEK **hekp = name + (count < 0 ? -count : count);
b7247a80
FC
1812 while(hekp-- > name)
1813 unshare_hek_or_pvn(*hekp, 0, 0, 0);
1814 Safefree(name);
1815 }
1816 else unshare_hek_or_pvn(HvAUX(hv)->xhv_name, 0, 0, 0);
23976bdd
NC
1817 }
1818 }
1819
1820 if (--attempts == 0) {
1821 Perl_die(aTHX_ "panic: hfreeentries failed to free hash - something is repeatedly re-creating entries");
1822 }
6136c704 1823 }
23976bdd
NC
1824
1825 HvARRAY(hv) = orig_array;
1826
1827 /* If the hash was actually a symbol table, put the name back. */
1828 if (name) {
1829 /* We have restored the original array. If name is non-NULL, then
1830 the original array had an aux structure at the end. So this is
1831 valid: */
b7247a80 1832 struct xpvhv_aux * const aux = HvAUX(hv);
23976bdd 1833 SvFLAGS(hv) |= SVf_OOK;
b7247a80
FC
1834 aux->xhv_name = name;
1835 aux->xhv_name_count = name_count;
1b8791d1 1836 }
79072805
LW
1837}
1838
954c1994
GS
1839/*
1840=for apidoc hv_undef
1841
1842Undefines the hash.
1843
1844=cut
1845*/
1846
79072805 1847void
864dbfa3 1848Perl_hv_undef(pTHX_ HV *hv)
79072805 1849{
97aff369 1850 dVAR;
cbec9347 1851 register XPVHV* xhv;
bfcb3514 1852 const char *name;
86f55936 1853
79072805
LW
1854 if (!hv)
1855 return;
ecae49c0 1856 DEBUG_A(Perl_hv_assert(aTHX_ hv));
cbec9347 1857 xhv = (XPVHV*)SvANY(hv);
dd69841b 1858
627364f1 1859 if ((name = HvENAME_get(hv)) && PL_phase != PERL_PHASE_DESTRUCT)
b9e30492
FC
1860 {
1861 /* Delete the @ISA element before calling mro_package_moved, so it
1862 does not see it. */
1863 (void)hv_delete(hv, "ISA", 3, G_DISCARD);
1864 mro_package_moved(NULL, hv, NULL, name, HvENAMELEN_get(hv));
1865 }
dd69841b 1866
463ee0b2 1867 hfreeentries(hv);
00169e2c 1868 if (name || (name = HvNAME(hv))) {
04fe65b0
RGS
1869 if (PL_stashcache)
1870 (void)hv_delete(PL_stashcache, name, HvNAMELEN_get(hv), G_DISCARD);
bd61b366 1871 hv_name_set(hv, NULL, 0, 0);
85e6fe83 1872 }
b79f7545
NC
1873 SvFLAGS(hv) &= ~SVf_OOK;
1874 Safefree(HvARRAY(hv));
cbec9347 1875 xhv->xhv_max = 7; /* HvMAX(hv) = 7 (it's a normal hash) */
7b2c381c 1876 HvARRAY(hv) = 0;
ca732855 1877 HvPLACEHOLDERS_set(hv, 0);
a0d0e21e
LW
1878
1879 if (SvRMAGICAL(hv))
ad64d0ec 1880 mg_clear(MUTABLE_SV(hv));
79072805
LW
1881}
1882
4d0fbddd
NC
1883/*
1884=for apidoc hv_fill
1885
1886Returns the number of hash buckets that happen to be in use. This function is
1887wrapped by the macro C<HvFILL>.
1888
1889Previously this value was stored in the HV structure, rather than being
1890calculated on demand.
1891
1892=cut
1893*/
1894
1895STRLEN
1896Perl_hv_fill(pTHX_ HV const *const hv)
1897{
1898 STRLEN count = 0;
1899 HE **ents = HvARRAY(hv);
1900
1901 PERL_ARGS_ASSERT_HV_FILL;
1902
1903 if (ents) {
fcd24582
NC
1904 HE *const *const last = ents + HvMAX(hv);
1905 count = last + 1 - ents;
4d0fbddd
NC
1906
1907 do {
fcd24582
NC
1908 if (!*ents)
1909 --count;
1910 } while (++ents <= last);
4d0fbddd
NC
1911 }
1912 return count;
1913}
1914
b464bac0 1915static struct xpvhv_aux*
5f66b61c 1916S_hv_auxinit(HV *hv) {
bfcb3514 1917 struct xpvhv_aux *iter;
b79f7545 1918 char *array;
bfcb3514 1919
7918f24d
NC
1920 PERL_ARGS_ASSERT_HV_AUXINIT;
1921
b79f7545 1922 if (!HvARRAY(hv)) {
a02a5408 1923 Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(HvMAX(hv) + 1)
b79f7545
NC
1924 + sizeof(struct xpvhv_aux), char);
1925 } else {
1926 array = (char *) HvARRAY(hv);
1927 Renew(array, PERL_HV_ARRAY_ALLOC_BYTES(HvMAX(hv) + 1)
1928 + sizeof(struct xpvhv_aux), char);
1929 }
1930 HvARRAY(hv) = (HE**) array;
1931 /* SvOOK_on(hv) attacks the IV flags. */
1932 SvFLAGS(hv) |= SVf_OOK;
1933 iter = HvAUX(hv);
bfcb3514
NC
1934
1935 iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
4608196e 1936 iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
bfcb3514 1937 iter->xhv_name = 0;
b7247a80 1938 iter->xhv_name_count = 0;
86f55936 1939 iter->xhv_backreferences = 0;
e1a479c5 1940 iter->xhv_mro_meta = NULL;
bfcb3514
NC
1941 return iter;
1942}
1943
954c1994
GS
1944/*
1945=for apidoc hv_iterinit
1946
1947Prepares a starting point to traverse a hash table. Returns the number of
b24b84ef 1948keys in the hash (i.e. the same as C<HvKEYS(hv)>). The return value is
1c846c1f 1949currently only meaningful for hashes without tie magic.
954c1994
GS
1950
1951NOTE: Before version 5.004_65, C<hv_iterinit> used to return the number of
1952hash buckets that happen to be in use. If you still need that esoteric
b24b84ef 1953value, you can get it through the macro C<HvFILL(hv)>.
954c1994 1954
e16e2ff8 1955
954c1994
GS
1956=cut
1957*/
1958
79072805 1959I32
864dbfa3 1960Perl_hv_iterinit(pTHX_ HV *hv)
79072805 1961{
7918f24d
NC
1962 PERL_ARGS_ASSERT_HV_ITERINIT;
1963
1964 /* FIXME: Are we not NULL, or do we croak? Place bets now! */
1965
aa689395 1966 if (!hv)
cea2e8a9 1967 Perl_croak(aTHX_ "Bad hash");
bfcb3514 1968
b79f7545 1969 if (SvOOK(hv)) {
6136c704 1970 struct xpvhv_aux * const iter = HvAUX(hv);
0bd48802 1971 HE * const entry = iter->xhv_eiter; /* HvEITER(hv) */
bfcb3514
NC
1972 if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */
1973 HvLAZYDEL_off(hv);
1974 hv_free_ent(hv, entry);
1975 }
1976 iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
4608196e 1977 iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
bfcb3514 1978 } else {
6136c704 1979 hv_auxinit(hv);
72940dca 1980 }
44a2ac75 1981
cbec9347 1982 /* used to be xhv->xhv_fill before 5.004_65 */
5d88ecd7 1983 return HvTOTALKEYS(hv);
79072805 1984}
bfcb3514
NC
1985
1986I32 *
1987Perl_hv_riter_p(pTHX_ HV *hv) {
1988 struct xpvhv_aux *iter;
1989
7918f24d
NC
1990 PERL_ARGS_ASSERT_HV_RITER_P;
1991
bfcb3514
NC
1992 if (!hv)
1993 Perl_croak(aTHX_ "Bad hash");
1994
6136c704 1995 iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
bfcb3514
NC
1996 return &(iter->xhv_riter);
1997}
1998
1999HE **
2000Perl_hv_eiter_p(pTHX_ HV *hv) {
2001 struct xpvhv_aux *iter;
2002
7918f24d
NC
2003 PERL_ARGS_ASSERT_HV_EITER_P;
2004
bfcb3514
NC
2005 if (!hv)
2006 Perl_croak(aTHX_ "Bad hash");
2007
6136c704 2008 iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
bfcb3514
NC
2009 return &(iter->xhv_eiter);
2010}
2011
2012void
2013Perl_hv_riter_set(pTHX_ HV *hv, I32 riter) {
2014 struct xpvhv_aux *iter;
2015
7918f24d
NC
2016 PERL_ARGS_ASSERT_HV_RITER_SET;
2017
bfcb3514
NC
2018 if (!hv)
2019 Perl_croak(aTHX_ "Bad hash");
2020
b79f7545
NC
2021 if (SvOOK(hv)) {
2022 iter = HvAUX(hv);
2023 } else {
bfcb3514
NC
2024 if (riter == -1)
2025 return;
2026
6136c704 2027 iter = hv_auxinit(hv);
bfcb3514
NC
2028 }
2029 iter->xhv_riter = riter;
2030}
2031
2032void
2033Perl_hv_eiter_set(pTHX_ HV *hv, HE *eiter) {
2034 struct xpvhv_aux *iter;
2035
7918f24d
NC
2036 PERL_ARGS_ASSERT_HV_EITER_SET;
2037
bfcb3514
NC
2038 if (!hv)
2039 Perl_croak(aTHX_ "Bad hash");
2040
b79f7545
NC
2041 if (SvOOK(hv)) {
2042 iter = HvAUX(hv);
2043 } else {
bfcb3514
NC
2044 /* 0 is the default so don't go malloc()ing a new structure just to
2045 hold 0. */
2046 if (!eiter)
2047 return;
2048
6136c704 2049 iter = hv_auxinit(hv);
bfcb3514
NC
2050 }
2051 iter->xhv_eiter = eiter;
2052}
2053
bfcb3514 2054void
4164be69 2055Perl_hv_name_set(pTHX_ HV *hv, const char *name, U32 len, U32 flags)
bfcb3514 2056{
97aff369 2057 dVAR;
b79f7545 2058 struct xpvhv_aux *iter;
7423f6db 2059 U32 hash;
78b79c77 2060 HEK **spot;
46c461b5 2061
7918f24d 2062 PERL_ARGS_ASSERT_HV_NAME_SET;
46c461b5 2063 PERL_UNUSED_ARG(flags);
bfcb3514 2064
4164be69
NC
2065 if (len > I32_MAX)
2066 Perl_croak(aTHX_ "panic: hv name too long (%"UVuf")", (UV) len);
2067
b79f7545
NC
2068 if (SvOOK(hv)) {
2069 iter = HvAUX(hv);
7423f6db 2070 if (iter->xhv_name) {
b7247a80 2071 if(iter->xhv_name_count) {
78b79c77 2072 if(!name) {
b7247a80 2073 HEK ** const name = (HEK **)HvAUX(hv)->xhv_name;
78b79c77
FC
2074 HEK **hekp = name + (
2075 iter->xhv_name_count < 0
2076 ? -iter->xhv_name_count
2077 : iter->xhv_name_count
2078 );
2079 while(hekp-- > name+1)
b7247a80 2080 unshare_hek_or_pvn(*hekp, 0, 0, 0);
78b79c77
FC
2081 /* The first elem may be null. */
2082 if(*name) unshare_hek_or_pvn(*name, 0, 0, 0);
b7247a80 2083 Safefree(name);
78b79c77
FC
2084 spot = &iter->xhv_name;
2085 iter->xhv_name_count = 0;
2086 }
2087 else {
2088 spot = (HEK **)iter->xhv_name;
2089 if(iter->xhv_name_count > 0) {
2090 /* shift some things over */
2091 Renew(spot, iter->xhv_name_count, HEK *);
2092 spot[iter->xhv_name_count++] = spot[1];
2093 spot[1] = spot[0];
2094 }
2095 else if(*spot) {
2096 unshare_hek_or_pvn(*spot, 0, 0, 0);
2097 }
2098 }
2099 }
2100 else {
2101 unshare_hek_or_pvn(iter->xhv_name, 0, 0, 0);
2102 spot = &iter->xhv_name;
b7247a80 2103 }
7423f6db 2104 }
78b79c77 2105 else spot = &iter->xhv_name;
16580ff5 2106 } else {
bfcb3514
NC
2107 if (name == 0)
2108 return;
2109
6136c704 2110 iter = hv_auxinit(hv);
78b79c77 2111 spot = &iter->xhv_name;
bfcb3514 2112 }
7423f6db 2113 PERL_HASH(hash, name, len);
78b79c77 2114 *spot = name ? share_hek(name, len, hash) : NULL;
b7247a80 2115 iter->xhv_name_count = 0;
bfcb3514
NC
2116}
2117
99206677
FC
2118/*
2119=for apidoc hv_ename_add
2120
2121Adds a name to a stash's internal list of effective names. See
2122C<hv_ename_delete>.
2123
2124This is called when a stash is assigned to a new location in the symbol
2125table.
2126
2127=cut
2128*/
2129
ee72b38d 2130void
78b79c77 2131Perl_hv_ename_add(pTHX_ HV *hv, const char *name, U32 len)
ee72b38d
FC
2132{
2133 dVAR;
2134 struct xpvhv_aux *aux = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
2135 U32 hash;
2136
78b79c77 2137 PERL_ARGS_ASSERT_HV_ENAME_ADD;
ee72b38d
FC
2138
2139 if (len > I32_MAX)
2140 Perl_croak(aTHX_ "panic: hv name too long (%"UVuf")", (UV) len);
2141
2142 PERL_HASH(hash, name, len);
2143
ee72b38d
FC
2144 if (aux->xhv_name_count) {
2145 HEK ** const xhv_name = (HEK **)aux->xhv_name;
78b79c77
FC
2146 I32 count = aux->xhv_name_count;
2147 HEK **hekp = xhv_name + (count < 0 ? -count : count);
ee72b38d
FC
2148 while (hekp-- > xhv_name)
2149 if (
2150 HEK_LEN(*hekp) == (I32)len && memEQ(HEK_KEY(*hekp), name, len)
78b79c77
FC
2151 ) {
2152 if (hekp == xhv_name && count < 0)
2153 aux->xhv_name_count = -count;
2154 return;
2155 }
2156 if (count < 0) aux->xhv_name_count--, count = -count;
2157 else aux->xhv_name_count++;
2158 Renewc(aux->xhv_name, count + 1, HEK *, HEK);
ee72b38d
FC
2159 ((HEK **)aux->xhv_name)[count] = share_hek(name, len, hash);
2160 }
2161 else {
2162 HEK *existing_name = aux->xhv_name;
2163 if (
78b79c77 2164 existing_name && HEK_LEN(existing_name) == (I32)len
ee72b38d
FC
2165 && memEQ(HEK_KEY(existing_name), name, len)
2166 ) return;
96517a90 2167 Newxc(aux->xhv_name, 2, HEK *, HEK);
78b79c77 2168 aux->xhv_name_count = existing_name ? 2 : -2;
ee72b38d
FC
2169 *(HEK **)aux->xhv_name = existing_name;
2170 ((HEK **)aux->xhv_name)[1] = share_hek(name, len, hash);
2171 }
2172}
2173
99206677
FC
2174/*
2175=for apidoc hv_ename_delete
2176
2177Removes a name from a stash's internal list of effective names. If this is
2178the name returned by C<HvENAME>, then another name in the list will take
2179its place (C<HvENAME> will use it).
2180
2181This is called when a stash is deleted from the symbol table.
2182
2183=cut
2184*/
2185
ee72b38d 2186void
78b79c77 2187Perl_hv_ename_delete(pTHX_ HV *hv, const char *name, U32 len)
ee72b38d
FC
2188{
2189 dVAR;
2190 struct xpvhv_aux *aux;
2191
78b79c77 2192 PERL_ARGS_ASSERT_HV_ENAME_DELETE;
ee72b38d
FC
2193
2194 if (len > I32_MAX)
2195 Perl_croak(aTHX_ "panic: hv name too long (%"UVuf")", (UV) len);
2196
2197 if (!SvOOK(hv)) return;
2198
2199 aux = HvAUX(hv);
2200 if (!aux->xhv_name) return;
2201
2202 if (aux->xhv_name_count) {
2203 HEK ** const namep = (HEK **)aux->xhv_name;
78b79c77
FC
2204 I32 const count = aux->xhv_name_count;
2205 HEK **victim = namep + (count < 0 ? -count : count);
2206 while (victim-- > namep + 1)
ee72b38d
FC
2207 if (
2208 HEK_LEN(*victim) == (I32)len
2209 && memEQ(HEK_KEY(*victim), name, len)
2210 ) {
2211 unshare_hek_or_pvn(*victim, 0, 0, 0);
78b79c77
FC
2212 if (count < 0) ++aux->xhv_name_count;
2213 else --aux->xhv_name_count;
2214 if (
2215 (aux->xhv_name_count == 1 || aux->xhv_name_count == -1)
2216 && !*namep
2217 ) { /* if there are none left */
ee72b38d
FC
2218 Safefree(namep);
2219 aux->xhv_name = NULL;
78b79c77 2220 aux->xhv_name_count = 0;
ee72b38d
FC
2221 }
2222 else {
2223 /* Move the last one back to fill the empty slot. It
2224 does not matter what order they are in. */
78b79c77 2225 *victim = *(namep + (count < 0 ? -count : count) - 1);
ee72b38d
FC
2226 }
2227 return;
2228 }
78b79c77
FC
2229 if (
2230 count > 0 && HEK_LEN(*namep) == (I32)len
2231 && memEQ(HEK_KEY(*namep),name,len)
2232 ) {
2233 aux->xhv_name_count = -count;
2234 }
ee72b38d
FC
2235 }
2236 else if(
2237 HEK_LEN(aux->xhv_name) == (I32)len
2238 && memEQ(HEK_KEY(aux->xhv_name), name, len)
2239 ) {
3f783763
FC
2240 const HEK * const namehek = aux->xhv_name;
2241 Newxc(aux->xhv_name, 1, HEK *, HEK);
2242 *(const HEK **)aux->xhv_name = namehek;
2243 aux->xhv_name_count = -1;
ee72b38d
FC
2244 }
2245}
2246
86f55936
NC
2247AV **
2248Perl_hv_backreferences_p(pTHX_ HV *hv) {
6136c704 2249 struct xpvhv_aux * const iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
7918f24d
NC
2250
2251 PERL_ARGS_ASSERT_HV_BACKREFERENCES_P;
96a5add6 2252 PERL_UNUSED_CONTEXT;
7918f24d 2253
86f55936
NC
2254 return &(iter->xhv_backreferences);
2255}
2256
09aad8f0
DM
2257void
2258Perl_hv_kill_backrefs(pTHX_ HV *hv) {
2259 AV *av;
2260
2261 PERL_ARGS_ASSERT_HV_KILL_BACKREFS;
2262
2263 if (!SvOOK(hv))
2264 return;
2265
2266 av = HvAUX(hv)->xhv_backreferences;
2267
2268 if (av) {
2269 HvAUX(hv)->xhv_backreferences = 0;
2270 Perl_sv_kill_backrefs(aTHX_ MUTABLE_SV(hv), av);
5648c0ae
DM
2271 if (SvTYPE(av) == SVt_PVAV)
2272 SvREFCNT_dec(av);
09aad8f0
DM
2273 }
2274}
2275
954c1994 2276/*
7a7b9979
NC
2277hv_iternext is implemented as a macro in hv.h
2278
954c1994
GS
2279=for apidoc hv_iternext
2280
2281Returns entries from a hash iterator. See C<hv_iterinit>.
2282
fe7bca90
NC
2283You may call C<hv_delete> or C<hv_delete_ent> on the hash entry that the
2284iterator currently points to, without losing your place or invalidating your
2285iterator. Note that in this case the current entry is deleted from the hash
2286with your iterator holding the last reference to it. Your iterator is flagged
2287to free the entry on the next call to C<hv_iternext>, so you must not discard
2288your iterator immediately else the entry will leak - call C<hv_iternext> to
2289trigger the resource deallocation.
2290
fe7bca90
NC
2291=for apidoc hv_iternext_flags
2292
2293Returns entries from a hash iterator. See C<hv_iterinit> and C<hv_iternext>.
2294The C<flags> value will normally be zero; if HV_ITERNEXT_WANTPLACEHOLDERS is
2295set the placeholders keys (for restricted hashes) will be returned in addition
2296to normal keys. By default placeholders are automatically skipped over.
7996736c
MHM
2297Currently a placeholder is implemented with a value that is
2298C<&Perl_sv_placeholder>. Note that the implementation of placeholders and
fe7bca90
NC
2299restricted hashes may change, and the implementation currently is
2300insufficiently abstracted for any change to be tidy.
e16e2ff8 2301
fe7bca90 2302=cut
e16e2ff8
NC
2303*/
2304
2305HE *
2306Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags)
2307{
27da23d5 2308 dVAR;
cbec9347 2309 register XPVHV* xhv;
79072805 2310 register HE *entry;
a0d0e21e 2311 HE *oldentry;
463ee0b2 2312 MAGIC* mg;
bfcb3514 2313 struct xpvhv_aux *iter;
79072805 2314
7918f24d
NC
2315 PERL_ARGS_ASSERT_HV_ITERNEXT_FLAGS;
2316
79072805 2317 if (!hv)
cea2e8a9 2318 Perl_croak(aTHX_ "Bad hash");
81714fb9 2319
cbec9347 2320 xhv = (XPVHV*)SvANY(hv);
bfcb3514 2321
b79f7545 2322 if (!SvOOK(hv)) {
bfcb3514
NC
2323 /* Too many things (well, pp_each at least) merrily assume that you can
2324 call iv_iternext without calling hv_iterinit, so we'll have to deal
2325 with it. */
2326 hv_iterinit(hv);
bfcb3514 2327 }
b79f7545 2328 iter = HvAUX(hv);
bfcb3514
NC
2329
2330 oldentry = entry = iter->xhv_eiter; /* HvEITER(hv) */
e62cc96a 2331 if (SvMAGICAL(hv) && SvRMAGICAL(hv)) {
ad64d0ec 2332 if ( ( mg = mg_find((const SV *)hv, PERL_MAGIC_tied) ) ) {
e62cc96a
YO
2333 SV * const key = sv_newmortal();
2334 if (entry) {
2335 sv_setsv(key, HeSVKEY_force(entry));
2336 SvREFCNT_dec(HeSVKEY(entry)); /* get rid of previous key */
2337 }
2338 else {
2339 char *k;
2340 HEK *hek;
2341
2342 /* one HE per MAGICAL hash */
2343 iter->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */
2344 Zero(entry, 1, HE);
ad64d0ec 2345 Newxz(k, HEK_BASESIZE + sizeof(const SV *), char);
e62cc96a
YO
2346 hek = (HEK*)k;
2347 HeKEY_hek(entry) = hek;
2348 HeKLEN(entry) = HEf_SVKEY;
2349 }
ad64d0ec 2350 magic_nextpack(MUTABLE_SV(hv),mg,key);
e62cc96a
YO
2351 if (SvOK(key)) {
2352 /* force key to stay around until next time */
2353 HeSVKEY_set(entry, SvREFCNT_inc_simple_NN(key));
2354 return entry; /* beware, hent_val is not set */
2355 }
ef8d46e8 2356 SvREFCNT_dec(HeVAL(entry));
e62cc96a
YO
2357 Safefree(HeKEY_hek(entry));
2358 del_HE(entry);
2359 iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
2360 return NULL;
81714fb9 2361 }
79072805 2362 }
7ee146b1 2363#if defined(DYNAMIC_ENV_FETCH) && !defined(__riscos__) /* set up %ENV for iteration */
ad64d0ec
NC
2364 if (!entry && SvRMAGICAL((const SV *)hv)
2365 && mg_find((const SV *)hv, PERL_MAGIC_env)) {
f675dbe5 2366 prime_env_iter();
03026e68
JM
2367#ifdef VMS
2368 /* The prime_env_iter() on VMS just loaded up new hash values
2369 * so the iteration count needs to be reset back to the beginning
2370 */
2371 hv_iterinit(hv);
2372 iter = HvAUX(hv);
2373 oldentry = entry = iter->xhv_eiter; /* HvEITER(hv) */
2374#endif
2375 }
f675dbe5 2376#endif
463ee0b2 2377
b79f7545
NC
2378 /* hv_iterint now ensures this. */
2379 assert (HvARRAY(hv));
2380
015a5f36 2381 /* At start of hash, entry is NULL. */
fde52b5c 2382 if (entry)
8aacddc1 2383 {
fde52b5c 2384 entry = HeNEXT(entry);
e16e2ff8
NC
2385 if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
2386 /*
2387 * Skip past any placeholders -- don't want to include them in
2388 * any iteration.
2389 */
7996736c 2390 while (entry && HeVAL(entry) == &PL_sv_placeholder) {
e16e2ff8
NC
2391 entry = HeNEXT(entry);
2392 }
8aacddc1
NIS
2393 }
2394 }
015a5f36 2395
9eb4ebd1
NC
2396 /* Skip the entire loop if the hash is empty. */
2397 if ((flags & HV_ITERNEXT_WANTPLACEHOLDERS)
2398 ? HvTOTALKEYS(hv) : HvUSEDKEYS(hv)) {
900ac051
MM
2399 while (!entry) {
2400 /* OK. Come to the end of the current list. Grab the next one. */
2401
2402 iter->xhv_riter++; /* HvRITER(hv)++ */
2403 if (iter->xhv_riter > (I32)xhv->xhv_max /* HvRITER(hv) > HvMAX(hv) */) {
2404 /* There is no next one. End of the hash. */
2405 iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
2406 break;
2407 }
2408 entry = (HvARRAY(hv))[iter->xhv_riter];
8aacddc1 2409
900ac051
MM
2410 if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
2411 /* If we have an entry, but it's a placeholder, don't count it.
2412 Try the next. */
2413 while (entry && HeVAL(entry) == &PL_sv_placeholder)
2414 entry = HeNEXT(entry);
2415 }
2416 /* Will loop again if this linked list starts NULL
2417 (for HV_ITERNEXT_WANTPLACEHOLDERS)
2418 or if we run through it and find only placeholders. */
015a5f36 2419 }
fde52b5c 2420 }
79072805 2421
72940dca
PP
2422 if (oldentry && HvLAZYDEL(hv)) { /* was deleted earlier? */
2423 HvLAZYDEL_off(hv);
68dc0745 2424 hv_free_ent(hv, oldentry);
72940dca 2425 }
a0d0e21e 2426
fdcd69b6 2427 /*if (HvREHASH(hv) && entry && !HeKREHASH(entry))
6c9570dc 2428 PerlIO_printf(PerlIO_stderr(), "Awooga %p %p\n", (void*)hv, (void*)entry);*/
fdcd69b6 2429
bfcb3514 2430 iter->xhv_eiter = entry; /* HvEITER(hv) = entry */
79072805
LW
2431 return entry;
2432}
2433
954c1994
GS
2434/*
2435=for apidoc hv_iterkey
2436
2437Returns the key from the current position of the hash iterator. See
2438C<hv_iterinit>.
2439
2440=cut
2441*/
2442
79072805 2443char *
864dbfa3 2444Perl_hv_iterkey(pTHX_ register HE *entry, I32 *retlen)
79072805 2445{
7918f24d
NC
2446 PERL_ARGS_ASSERT_HV_ITERKEY;
2447
fde52b5c 2448 if (HeKLEN(entry) == HEf_SVKEY) {
fb73857a 2449 STRLEN len;
0bd48802 2450 char * const p = SvPV(HeKEY_sv(entry), len);
fb73857a
PP
2451 *retlen = len;
2452 return p;
fde52b5c
PP
2453 }
2454 else {
2455 *retlen = HeKLEN(entry);
2456 return HeKEY(entry);
2457 }
2458}
2459
2460/* unlike hv_iterval(), this always returns a mortal copy of the key */
954c1994
GS
2461/*
2462=for apidoc hv_iterkeysv
2463
2464Returns the key as an C<SV*> from the current position of the hash
2465iterator. The return value will always be a mortal copy of the key. Also
2466see C<hv_iterinit>.
2467
2468=cut
2469*/
2470
fde52b5c 2471SV *
864dbfa3 2472Perl_hv_iterkeysv(pTHX_ register HE *entry)
fde52b5c 2473{
7918f24d
NC
2474 PERL_ARGS_ASSERT_HV_ITERKEYSV;
2475
c1b02ed8 2476 return sv_2mortal(newSVhek(HeKEY_hek(entry)));
79072805
LW
2477}
2478
954c1994
GS
2479/*
2480=for apidoc hv_iterval
2481
2482Returns the value from the current position of the hash iterator. See
2483C<hv_iterkey>.
2484
2485=cut
2486*/
2487
79072805 2488SV *
864dbfa3 2489Perl_hv_iterval(pTHX_ HV *hv, register HE *entry)
79072805 2490{
7918f24d
NC
2491 PERL_ARGS_ASSERT_HV_ITERVAL;
2492
8990e307 2493 if (SvRMAGICAL(hv)) {
ad64d0ec 2494 if (mg_find((const SV *)hv, PERL_MAGIC_tied)) {
c4420975 2495 SV* const sv = sv_newmortal();
bbce6d69 2496 if (HeKLEN(entry) == HEf_SVKEY)
ad64d0ec 2497 mg_copy(MUTABLE_SV(hv), sv, (char*)HeKEY_sv(entry), HEf_SVKEY);
a3b680e6 2498 else
ad64d0ec 2499 mg_copy(MUTABLE_SV(hv), sv, HeKEY(entry), HeKLEN(entry));
463ee0b2
LW
2500 return sv;
2501 }
79072805 2502 }
fde52b5c 2503 return HeVAL(entry);
79072805
LW
2504}
2505
954c1994
GS
2506/*
2507=for apidoc hv_iternextsv
2508
2509Performs an C<hv_iternext>, C<hv_iterkey>, and C<hv_iterval> in one
2510operation.
2511
2512=cut
2513*/
2514
a0d0e21e 2515SV *
864dbfa3 2516Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen)
a0d0e21e 2517{
0bd48802
AL
2518 HE * const he = hv_iternext_flags(hv, 0);
2519
7918f24d
NC
2520 PERL_ARGS_ASSERT_HV_ITERNEXTSV;
2521
0bd48802 2522 if (!he)
a0d0e21e
LW
2523 return NULL;
2524 *key = hv_iterkey(he, retlen);
2525 return hv_iterval(hv, he);
2526}
2527
954c1994 2528/*
bc5cdc23
NC
2529
2530Now a macro in hv.h
2531
954c1994
GS
2532=for apidoc hv_magic
2533
2534Adds magic to a hash. See C<sv_magic>.
2535
2536=cut
2537*/
2538
bbce6d69 2539/* possibly free a shared string if no one has access to it
fde52b5c
PP
2540 * len and hash must both be valid for str.
2541 */
bbce6d69 2542void
864dbfa3 2543Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
fde52b5c 2544{
19692e8d
NC
2545 unshare_hek_or_pvn (NULL, str, len, hash);
2546}
2547
2548
2549void
2550Perl_unshare_hek(pTHX_ HEK *hek)
2551{
bf11fd37 2552 assert(hek);
19692e8d
NC
2553 unshare_hek_or_pvn(hek, NULL, 0, 0);
2554}
2555
2556/* possibly free a shared string if no one has access to it
2557 hek if non-NULL takes priority over the other 3, else str, len and hash
2558 are used. If so, len and hash must both be valid for str.
2559 */
df132699 2560STATIC void
97ddebaf 2561S_unshare_hek_or_pvn(pTHX_ const HEK *hek, const char *str, I32 len, U32 hash)
19692e8d 2562{
97aff369 2563 dVAR;
cbec9347 2564 register XPVHV* xhv;
20454177 2565 HE *entry;
fde52b5c 2566 register HE **oentry;
45d1cc86 2567 HE **first;
c3654f1a 2568 bool is_utf8 = FALSE;
19692e8d 2569 int k_flags = 0;
aec46f14 2570 const char * const save = str;
cbbf8932 2571 struct shared_he *he = NULL;
c3654f1a 2572
19692e8d 2573 if (hek) {
cbae3960
NC
2574 /* Find the shared he which is just before us in memory. */
2575 he = (struct shared_he *)(((char *)hek)
2576 - STRUCT_OFFSET(struct shared_he,
2577 shared_he_hek));
2578
2579 /* Assert that the caller passed us a genuine (or at least consistent)
2580 shared hek */
2581 assert (he->shared_he_he.hent_hek == hek);
29404ae0 2582
de616631
NC
2583 if (he->shared_he_he.he_valu.hent_refcount - 1) {
2584 --he->shared_he_he.he_valu.hent_refcount;
29404ae0
NC
2585 return;
2586 }
29404ae0 2587
19692e8d
NC
2588 hash = HEK_HASH(hek);
2589 } else if (len < 0) {
2590 STRLEN tmplen = -len;
2591 is_utf8 = TRUE;
2592 /* See the note in hv_fetch(). --jhi */
2593 str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2594 len = tmplen;
2595 if (is_utf8)
2596 k_flags = HVhek_UTF8;
2597 if (str != save)
2598 k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
c3654f1a 2599 }
1c846c1f 2600
de616631 2601 /* what follows was the moral equivalent of:
6b88bc9c 2602 if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) {
a0714e2c 2603 if (--*Svp == NULL)
6b88bc9c 2604 hv_delete(PL_strtab, str, len, G_DISCARD, hash);
bbce6d69 2605 } */
cbec9347 2606 xhv = (XPVHV*)SvANY(PL_strtab);
fde52b5c 2607 /* assert(xhv_array != 0) */
45d1cc86 2608 first = oentry = &(HvARRAY(PL_strtab))[hash & (I32) HvMAX(PL_strtab)];
6c1b96a1
NC
2609 if (he) {
2610 const HE *const he_he = &(he->shared_he_he);
45d1cc86 2611 for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) {
35ab5632
NC
2612 if (entry == he_he)
2613 break;
19692e8d
NC
2614 }
2615 } else {
35a4481c 2616 const int flags_masked = k_flags & HVhek_MASK;
45d1cc86 2617 for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) {
19692e8d
NC
2618 if (HeHASH(entry) != hash) /* strings can't be equal */
2619 continue;
2620 if (HeKLEN(entry) != len)
2621 continue;
2622 if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
2623 continue;
2624 if (HeKFLAGS(entry) != flags_masked)
2625 continue;
19692e8d
NC
2626 break;
2627 }
2628 }
2629
35ab5632
NC
2630 if (entry) {
2631 if (--entry->he_valu.hent_refcount == 0) {
19692e8d 2632 *oentry = HeNEXT(entry);
cbae3960 2633 Safefree(entry);
4c7185a0 2634 xhv->xhv_keys--; /* HvTOTALKEYS(hv)-- */
19692e8d 2635 }
fde52b5c 2636 }
19692e8d 2637
9b387841
NC
2638 if (!entry)
2639 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
2640 "Attempt to free non-existent shared string '%s'%s"
2641 pTHX__FORMAT,
2642 hek ? HEK_KEY(hek) : str,
2643 ((k_flags & HVhek_UTF8) ? " (utf8)" : "") pTHX__VALUE);
19692e8d
NC
2644 if (k_flags & HVhek_FREEKEY)
2645 Safefree(str);
fde52b5c
PP
2646}
2647
bbce6d69
PP
2648/* get a (constant) string ptr from the global string table
2649 * string will get added if it is not already there.
fde52b5c
PP
2650 * len and hash must both be valid for str.
2651 */
bbce6d69 2652HEK *
864dbfa3 2653Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash)
fde52b5c 2654{
da58a35d 2655 bool is_utf8 = FALSE;
19692e8d 2656 int flags = 0;
aec46f14 2657 const char * const save = str;
da58a35d 2658
7918f24d
NC
2659 PERL_ARGS_ASSERT_SHARE_HEK;
2660
da58a35d 2661 if (len < 0) {
77caf834 2662 STRLEN tmplen = -len;
da58a35d 2663 is_utf8 = TRUE;
77caf834
JH
2664 /* See the note in hv_fetch(). --jhi */
2665 str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2666 len = tmplen;
19692e8d
NC
2667 /* If we were able to downgrade here, then than means that we were passed
2668 in a key which only had chars 0-255, but was utf8 encoded. */
2669 if (is_utf8)
2670 flags = HVhek_UTF8;
2671 /* If we found we were able to downgrade the string to bytes, then
2672 we should flag that it needs upgrading on keys or each. Also flag
2673 that we need share_hek_flags to free the string. */
2674 if (str != save)
2675 flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2676 }
2677
6e838c70 2678 return share_hek_flags (str, len, hash, flags);
19692e8d
NC
2679}
2680
6e838c70 2681STATIC HEK *
19692e8d
NC
2682S_share_hek_flags(pTHX_ const char *str, I32 len, register U32 hash, int flags)
2683{
97aff369 2684 dVAR;
19692e8d 2685 register HE *entry;
35a4481c 2686 const int flags_masked = flags & HVhek_MASK;
263cb4a6 2687 const U32 hindex = hash & (I32) HvMAX(PL_strtab);
7918f24d
NC
2688 register XPVHV * const xhv = (XPVHV*)SvANY(PL_strtab);
2689
2690 PERL_ARGS_ASSERT_SHARE_HEK_FLAGS;
bbce6d69 2691
fde52b5c 2692 /* what follows is the moral equivalent of:
1c846c1f 2693
6b88bc9c 2694 if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
a0714e2c 2695 hv_store(PL_strtab, str, len, NULL, hash);
fdcd69b6
NC
2696
2697 Can't rehash the shared string table, so not sure if it's worth
2698 counting the number of entries in the linked list
bbce6d69 2699 */
7918f24d 2700
fde52b5c 2701 /* assert(xhv_array != 0) */
263cb4a6
NC
2702 entry = (HvARRAY(PL_strtab))[hindex];
2703 for (;entry; entry = HeNEXT(entry)) {
fde52b5c
PP
2704 if (HeHASH(entry) != hash) /* strings can't be equal */
2705 continue;
2706 if (HeKLEN(entry) != len)
2707 continue;
1c846c1f 2708 if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
fde52b5c 2709 continue;
19692e8d 2710 if (HeKFLAGS(entry) != flags_masked)
c3654f1a 2711 continue;
fde52b5c
PP
2712 break;
2713 }
263cb4a6
NC
2714
2715 if (!entry) {
45d1cc86
NC
2716 /* What used to be head of the list.
2717 If this is NULL, then we're the first entry for this slot, which
2718 means we need to increate fill. */
cbae3960
NC
2719 struct shared_he *new_entry;
2720 HEK *hek;
2721 char *k;
263cb4a6
NC
2722 HE **const head = &HvARRAY(PL_strtab)[hindex];
2723 HE *const next = *head;
cbae3960
NC
2724
2725 /* We don't actually store a HE from the arena and a regular HEK.
2726 Instead we allocate one chunk of memory big enough for both,
2727 and put the HEK straight after the HE. This way we can find the
2728 HEK directly from the HE.
2729 */
2730
a02a5408 2731 Newx(k, STRUCT_OFFSET(struct shared_he,
cbae3960
NC
2732 shared_he_hek.hek_key[0]) + len + 2, char);
2733 new_entry = (struct shared_he *)k;
2734 entry = &(new_entry->shared_he_he);
2735 hek = &(new_entry->shared_he_hek);
2736
2737 Copy(str, HEK_KEY(hek), len, char);
2738 HEK_KEY(hek)[len] = 0;
2739 HEK_LEN(hek) = len;
2740 HEK_HASH(hek) = hash;
2741 HEK_FLAGS(hek) = (unsigned char)flags_masked;
2742
2743 /* Still "point" to the HEK, so that other code need not know what
2744 we're up to. */
2745 HeKEY_hek(entry) = hek;
de616631 2746 entry->he_valu.hent_refcount = 0;
263cb4a6
NC
2747 HeNEXT(entry) = next;
2748 *head = entry;
cbae3960 2749
4c7185a0 2750 xhv->xhv_keys++; /* HvTOTALKEYS(hv)++ */
263cb4a6 2751 if (!next) { /* initial entry? */
5ac36297 2752 } else if (xhv->xhv_keys > xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */) {
cbec9347 2753 hsplit(PL_strtab);
bbce6d69
PP
2754 }
2755 }
2756
de616631 2757 ++entry->he_valu.hent_refcount;
19692e8d
NC
2758
2759 if (flags & HVhek_FREEKEY)
f9a63242 2760 Safefree(str);
19692e8d 2761
6e838c70 2762 return HeKEY_hek(entry);
fde52b5c 2763}
ecae49c0 2764
ca732855
NC
2765I32 *
2766Perl_hv_placeholders_p(pTHX_ HV *hv)
2767{
2768 dVAR;
ad64d0ec 2769 MAGIC *mg = mg_find((const SV *)hv, PERL_MAGIC_rhash);
ca732855 2770
7918f24d
NC
2771 PERL_ARGS_ASSERT_HV_PLACEHOLDERS_P;
2772
ca732855 2773 if (!mg) {
ad64d0ec 2774 mg = sv_magicext(MUTABLE_SV(hv), 0, PERL_MAGIC_rhash, 0, 0, 0);
ca732855
NC
2775
2776 if (!mg) {
2777 Perl_die(aTHX_ "panic: hv_placeholders_p");
2778 }
2779 }
2780 return &(mg->mg_len);
2781}
2782
2783
2784I32
0c289d13 2785Perl_hv_placeholders_get(pTHX_ const HV *hv)
ca732855
NC
2786{
2787 dVAR;
0c289d13 2788 MAGIC * const mg = mg_find((const SV *)hv, PERL_MAGIC_rhash);
ca732855 2789
7918f24d
NC
2790 PERL_ARGS_ASSERT_HV_PLACEHOLDERS_GET;
2791
ca732855
NC
2792 return mg ? mg->mg_len : 0;
2793}
2794
2795void
ac1e784a 2796Perl_hv_placeholders_set(pTHX_ HV *hv, I32 ph)
ca732855
NC
2797{
2798 dVAR;
ad64d0ec 2799 MAGIC * const mg = mg_find((const SV *)hv, PERL_MAGIC_rhash);
ca732855 2800
7918f24d
NC
2801 PERL_ARGS_ASSERT_HV_PLACEHOLDERS_SET;
2802
ca732855
NC
2803 if (mg) {
2804 mg->mg_len = ph;
2805 } else if (ph) {
ad64d0ec 2806 if (!sv_magicext(MUTABLE_SV(hv), 0, PERL_MAGIC_rhash, 0, 0, ph))
ca732855
NC
2807 Perl_die(aTHX_ "panic: hv_placeholders_set");
2808 }
2809 /* else we don't need to add magic to record 0 placeholders. */
2810}
ecae49c0 2811
2a49f0f5 2812STATIC SV *
7b0bddfa
NC
2813S_refcounted_he_value(pTHX_ const struct refcounted_he *he)
2814{
0b2d3faa 2815 dVAR;
7b0bddfa 2816 SV *value;
7918f24d
NC
2817
2818 PERL_ARGS_ASSERT_REFCOUNTED_HE_VALUE;
2819
7b0bddfa
NC
2820 switch(he->refcounted_he_data[0] & HVrhek_typemask) {
2821 case HVrhek_undef:
2822 value = newSV(0);
2823 break;
2824 case HVrhek_delete:
2825 value = &PL_sv_placeholder;
2826 break;
2827 case HVrhek_IV:
44ebaf21
NC
2828 value = newSViv(he->refcounted_he_val.refcounted_he_u_iv);
2829 break;
2830 case HVrhek_UV:
2831 value = newSVuv(he->refcounted_he_val.refcounted_he_u_uv);
7b0bddfa
NC
2832 break;
2833 case HVrhek_PV:
44ebaf21 2834 case HVrhek_PV_UTF8:
7b0bddfa
NC
2835 /* Create a string SV that directly points to the bytes in our
2836 structure. */
b9f83d2f 2837 value = newSV_type(SVt_PV);
7b0bddfa
NC
2838 SvPV_set(value, (char *) he->refcounted_he_data + 1);
2839 SvCUR_set(value, he->refcounted_he_val.refcounted_he_u_len);
2840 /* This stops anything trying to free it */
2841 SvLEN_set(value, 0);
2842 SvPOK_on(value);
2843 SvREADONLY_on(value);
44ebaf21 2844 if ((he->refcounted_he_data[0] & HVrhek_typemask) == HVrhek_PV_UTF8)
7b0bddfa
NC
2845 SvUTF8_on(value);
2846 break;
2847 default:
20439bc7
Z
2848 Perl_croak(aTHX_ "panic: refcounted_he_value bad flags %"UVxf,
2849 (UV)he->refcounted_he_data[0]);
7b0bddfa
NC
2850 }
2851 return value;
2852}
2853
ecae49c0 2854/*
20439bc7 2855=for apidoc m|HV *|refcounted_he_chain_2hv|const struct refcounted_he *c|U32 flags
8dff4fc5 2856
20439bc7
Z
2857Generates and returns a C<HV *> representing the content of a
2858C<refcounted_he> chain.
2859I<flags> is currently unused and must be zero.
8dff4fc5
BM
2860
2861=cut
2862*/
2863HV *
20439bc7 2864Perl_refcounted_he_chain_2hv(pTHX_ const struct refcounted_he *chain, U32 flags)
8dff4fc5 2865{
20439bc7
Z
2866 dVAR;
2867 HV *hv;
2868 U32 placeholders, max;
b3ca2e83 2869
20439bc7
Z
2870 if (flags)
2871 Perl_croak(aTHX_ "panic: refcounted_he_chain_2hv bad flags %"UVxf,
2872 (UV)flags);
b3ca2e83 2873
b3ca2e83
NC
2874 /* We could chase the chain once to get an idea of the number of keys,
2875 and call ksplit. But for now we'll make a potentially inefficient
2876 hash with only 8 entries in its array. */
20439bc7
Z
2877 hv = newHV();
2878 max = HvMAX(hv);
b3ca2e83
NC
2879 if (!HvARRAY(hv)) {
2880 char *array;
2881 Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(max + 1), char);
2882 HvARRAY(hv) = (HE**)array;
2883 }
2884
20439bc7 2885 placeholders = 0;
b3ca2e83 2886 while (chain) {
cbb1fbea 2887#ifdef USE_ITHREADS
b6bbf3fa 2888 U32 hash = chain->refcounted_he_hash;
cbb1fbea
NC
2889#else
2890 U32 hash = HEK_HASH(chain->refcounted_he_hek);
2891#endif
b3ca2e83
NC
2892 HE **oentry = &((HvARRAY(hv))[hash & max]);
2893 HE *entry = *oentry;
b6bbf3fa 2894 SV *value;
cbb1fbea 2895
b3ca2e83
NC
2896 for (; entry; entry = HeNEXT(entry)) {
2897 if (HeHASH(entry) == hash) {
9f769845
NC
2898 /* We might have a duplicate key here. If so, entry is older
2899 than the key we've already put in the hash, so if they are
2900 the same, skip adding entry. */
2901#ifdef USE_ITHREADS
2902 const STRLEN klen = HeKLEN(entry);
2903 const char *const key = HeKEY(entry);
2904 if (klen == chain->refcounted_he_keylen
2905 && (!!HeKUTF8(entry)
2906 == !!(chain->refcounted_he_data[0] & HVhek_UTF8))
2907 && memEQ(key, REF_HE_KEY(chain), klen))
2908 goto next_please;
2909#else
2910 if (HeKEY_hek(entry) == chain->refcounted_he_hek)
2911 goto next_please;
2912 if (HeKLEN(entry) == HEK_LEN(chain->refcounted_he_hek)
2913 && HeKUTF8(entry) == HEK_UTF8(chain->refcounted_he_hek)
2914 && memEQ(HeKEY(entry), HEK_KEY(chain->refcounted_he_hek),
2915 HeKLEN(entry)))
2916 goto next_please;
2917#endif
b3ca2e83
NC
2918 }
2919 }
2920 assert (!entry);
2921 entry = new_HE();
2922
cbb1fbea
NC
2923#ifdef USE_ITHREADS
2924 HeKEY_hek(entry)
7b0bddfa 2925 = share_hek_flags(REF_HE_KEY(chain),
b6bbf3fa
NC
2926 chain->refcounted_he_keylen,
2927 chain->refcounted_he_hash,
2928 (chain->refcounted_he_data[0]
2929 & (HVhek_UTF8|HVhek_WASUTF8)));
cbb1fbea 2930#else
71ad1b0c 2931 HeKEY_hek(entry) = share_hek_hek(chain->refcounted_he_hek);
cbb1fbea 2932#endif
7b0bddfa
NC
2933 value = refcounted_he_value(chain);
2934 if (value == &PL_sv_placeholder)
b3ca2e83 2935 placeholders++;
b6bbf3fa 2936 HeVAL(entry) = value;
b3ca2e83
NC
2937
2938 /* Link it into the chain. */
2939 HeNEXT(entry) = *oentry;
b3ca2e83
NC
2940 *oentry = entry;
2941
2942 HvTOTALKEYS(hv)++;
2943
2944 next_please:
71ad1b0c 2945 chain = chain->refcounted_he_next;
b3ca2e83
NC
2946 }
2947
2948 if (placeholders) {
2949 clear_placeholders(hv, placeholders);
2950 HvTOTALKEYS(hv) -= placeholders;
2951 }
2952
2953 /* We could check in the loop to see if we encounter any keys with key
2954 flags, but it's probably not worth it, as this per-hash flag is only
2955 really meant as an optimisation for things like Storable. */
2956 HvHASKFLAGS_on(hv);
def9038f 2957 DEBUG_A(Perl_hv_assert(aTHX_ hv));
b3ca2e83
NC
2958
2959 return hv;
2960}
2961
20439bc7
Z
2962/*
2963=for apidoc m|SV *|refcounted_he_fetch_pvn|const struct refcounted_he *chain|const char *keypv|STRLEN keylen|U32 hash|U32 flags
2964
2965Search along a C<refcounted_he> chain for an entry with the key specified
2966by I<keypv> and I<keylen>. If I<flags> has the C<REFCOUNTED_HE_KEY_UTF8>
2967bit set, the key octets are interpreted as UTF-8, otherwise they
2968are interpreted as Latin-1. I<hash> is a precomputed hash of the key
2969string, or zero if it has not been precomputed. Returns a mortal scalar
2970representing the value associated with the key, or C<&PL_sv_placeholder>
2971if there is no value associated with the key.
2972
2973=cut
2974*/
2975
7b0bddfa 2976SV *
20439bc7
Z
2977Perl_refcounted_he_fetch_pvn(pTHX_ const struct refcounted_he *chain,
2978 const char *keypv, STRLEN keylen, U32 hash, U32 flags)
7b0bddfa 2979{
0b2d3faa 2980 dVAR;
20439bc7
Z
2981 U8 utf8_flag;
2982 PERL_ARGS_ASSERT_REFCOUNTED_HE_FETCH_PVN;
7b0bddfa 2983
20439bc7
Z
2984 if (flags & ~REFCOUNTED_HE_KEY_UTF8)
2985 Perl_croak(aTHX_ "panic: refcounted_he_fetch_pvn bad flags %"UVxf,
2986 (UV)flags);
2987 if (!chain)
2988 return &PL_sv_placeholder;
2989 if (flags & REFCOUNTED_HE_KEY_UTF8) {
2990 /* For searching purposes, canonicalise to Latin-1 where possible. */
2991 const char *keyend = keypv + keylen, *p;
2992 STRLEN nonascii_count = 0;
2993 for (p = keypv; p != keyend; p++) {
2994 U8 c = (U8)*p;
2995 if (c & 0x80) {
2996 if (!((c & 0xfe) == 0xc2 && ++p != keyend &&
2997 (((U8)*p) & 0xc0) == 0x80))
2998 goto canonicalised_key;
2999 nonascii_count++;
3000 }
cd1d2f8a 3001 }
20439bc7
Z
3002 if (nonascii_count) {
3003 char *q;
3004 const char *p = keypv, *keyend = keypv + keylen;
3005 keylen -= nonascii_count;
3006 Newx(q, keylen, char);
3007 SAVEFREEPV(q);
3008 keypv = q;
3009 for (; p != keyend; p++, q++) {
3010 U8 c = (U8)*p;
3011 *q = (char)
3012 ((c & 0x80) ? ((c & 0x03) << 6) | (((U8)*++p) & 0x3f) : c);
cd1d2f8a
NC
3013 }
3014 }
20439bc7
Z
3015 flags &= ~REFCOUNTED_HE_KEY_UTF8;
3016 canonicalised_key: ;
3017 }
3018 utf8_flag = (flags & REFCOUNTED_HE_KEY_UTF8) ? HVhek_UTF8 : 0;
3019 if (!hash)
3020 PERL_HASH(hash, keypv, keylen);
7b0bddfa 3021
20439bc7
Z
3022 for (; chain; chain = chain->refcounted_he_next) {
3023 if (
7b0bddfa 3024#ifdef USE_ITHREADS
20439bc7
Z
3025 hash == chain->refcounted_he_hash &&
3026 keylen == chain->refcounted_he_keylen &&
3027 memEQ(REF_HE_KEY(chain), keypv, keylen) &&
3028 utf8_flag == (chain->refcounted_he_data[0] & HVhek_UTF8)
7b0bddfa 3029#else
20439bc7
Z
3030 hash == HEK_HASH(chain->refcounted_he_hek) &&
3031 keylen == (STRLEN)HEK_LEN(chain->refcounted_he_hek) &&
3032 memEQ(HEK_KEY(chain->refcounted_he_hek), keypv, keylen) &&
3033 utf8_flag == (HEK_FLAGS(chain->refcounted_he_hek) & HVhek_UTF8)
7b0bddfa 3034#endif
20439bc7
Z
3035 )
3036 return sv_2mortal(refcounted_he_value(chain));
7b0bddfa 3037 }
20439bc7
Z
3038 return &PL_sv_placeholder;
3039}
7b0bddfa 3040
20439bc7
Z
3041/*
3042=for apidoc m|SV *|refcounted_he_fetch_pv|const struct refcounted_he *chain|const char *key|U32 hash|U32 flags
7b0bddfa 3043
20439bc7
Z
3044Like L</refcounted_he_fetch_pvn>, but takes a nul-terminated string
3045instead of a string/length pair.
3046
3047=cut
3048*/
3049
3050SV *
3051Perl_refcounted_he_fetch_pv(pTHX_ const struct refcounted_he *chain,
3052 const char *key, U32 hash, U32 flags)
3053{
3054 PERL_ARGS_ASSERT_REFCOUNTED_HE_FETCH_PV;
3055 return refcounted_he_fetch_pvn(chain, key, strlen(key), hash, flags);
7b0bddfa
NC
3056}
3057
b3ca2e83 3058/*
20439bc7
Z
3059=for apidoc m|SV *|refcounted_he_fetch_sv|const struct refcounted_he *chain|SV *key|U32 hash|U32 flags
3060
3061Like L</refcounted_he_fetch_pvn>, but takes a Perl scalar instead of a
3062string/length pair.
3063
3064=cut
3065*/
b3ca2e83 3066
20439bc7
Z
3067SV *
3068Perl_refcounted_he_fetch_sv(pTHX_ const struct refcounted_he *chain,
3069 SV *key, U32 hash, U32 flags)
3070{
3071 const char *keypv;
3072 STRLEN keylen;
3073 PERL_ARGS_ASSERT_REFCOUNTED_HE_FETCH_SV;
3074 if (flags & REFCOUNTED_HE_KEY_UTF8)
3075 Perl_croak(aTHX_ "panic: refcounted_he_fetch_sv bad flags %"UVxf,
3076 (UV)flags);
3077 keypv = SvPV_const(key, keylen);
3078 if (SvUTF8(key))
3079 flags |= REFCOUNTED_HE_KEY_UTF8;
3080 if (!hash && SvIsCOW_shared_hash(key))
3081 hash = SvSHARED_HASH(key);
3082 return refcounted_he_fetch_pvn(chain, keypv, keylen, hash, flags);
3083}
3084
3085/*
3086=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
3087
3088Creates a new C<refcounted_he>. This consists of a single key/value
3089pair and a reference to an existing C<refcounted_he> chain (which may
3090be empty), and thus forms a longer chain. When using the longer chain,
3091the new key/value pair takes precedence over any entry for the same key
3092further along the chain.
3093
3094The new key is specified by I<keypv> and I<keylen>. If I<flags> has
3095the C<REFCOUNTED_HE_KEY_UTF8> bit set, the key octets are interpreted
3096as UTF-8, otherwise they are interpreted as Latin-1. I<hash> is
3097a precomputed hash of the key string, or zero if it has not been
3098precomputed.
3099
3100I<value> is the scalar value to store for this key. I<value> is copied
3101by this function, which thus does not take ownership of any reference
3102to it, and later changes to the scalar will not be reflected in the
3103value visible in the C<refcounted_he>. Complex types of scalar will not
3104be stored with referential integrity, but will be coerced to strings.
3105I<value> may be either null or C<&PL_sv_placeholder> to indicate that no
3106value is to be associated with the key; this, as with any non-null value,
3107takes precedence over the existence of a value for the key further along
3108the chain.
3109
3110I<parent> points to the rest of the C<refcounted_he> chain to be
3111attached to the new C<refcounted_he>. This function takes ownership
3112of one reference to I<parent>, and returns one reference to the new
3113C<refcounted_he>.
b3ca2e83
NC
3114
3115=cut
3116*/
3117
3118struct refcounted_he *
20439bc7
Z
3119Perl_refcounted_he_new_pvn(pTHX_ struct refcounted_he *parent,
3120 const char *keypv, STRLEN keylen, U32 hash, SV *value, U32 flags)
3121{
7a89be66 3122 dVAR;
b6bbf3fa 3123 STRLEN value_len = 0;
95b63a38 3124 const char *value_p = NULL;
20439bc7 3125 bool is_pv;
b6bbf3fa 3126 char value_type;
20439bc7
Z
3127 char hekflags;
3128 STRLEN key_offset = 1;
3129 struct refcounted_he *he;
3130 PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_PVN;
b6bbf3fa 3131
20439bc7
Z
3132 if (!value || value == &PL_sv_placeholder) {
3133 value_type = HVrhek_delete;
3134 } else if (SvPOK(value)) {
b6bbf3fa
NC
3135 value_type = HVrhek_PV;
3136 } else if (SvIOK(value)) {
ad64d0ec 3137 value_type = SvUOK((const SV *)value) ? HVrhek_UV : HVrhek_IV;
b6bbf3fa
NC
3138 } else if (!SvOK(value)) {
3139 value_type = HVrhek_undef;
3140 } else {
3141 value_type = HVrhek_PV;
3142 }
20439bc7
Z
3143 is_pv = value_type == HVrhek_PV;
3144 if (is_pv) {
012da8e5
NC
3145 /* Do it this way so that the SvUTF8() test is after the SvPV, in case
3146 the value is overloaded, and doesn't yet have the UTF-8flag set. */
b6bbf3fa 3147 value_p = SvPV_const(value, value_len);
012da8e5
NC
3148 if (SvUTF8(value))
3149 value_type = HVrhek_PV_UTF8;
20439bc7
Z
3150 key_offset = value_len + 2;
3151 }
3152 hekflags = value_type;
3153
3154 if (flags & REFCOUNTED_HE_KEY_UTF8) {
3155 /* Canonicalise to Latin-1 where possible. */
3156 const char *keyend = keypv + keylen, *p;
3157 STRLEN nonascii_count = 0;
3158 for (p = keypv; p != keyend; p++) {
3159 U8 c = (U8)*p;
3160 if (c & 0x80) {
3161 if (!((c & 0xfe) == 0xc2 && ++p != keyend &&
3162 (((U8)*p) & 0xc0) == 0x80))
3163 goto canonicalised_key;
3164 nonascii_count++;
3165 }
3166 }
3167 if (nonascii_count) {
3168 char *q;
3169 const char *p = keypv, *keyend = keypv + keylen;
3170 keylen -= nonascii_count;
3171 Newx(q, keylen, char);
3172 SAVEFREEPV(q);
3173 keypv = q;
3174 for (; p != keyend; p++, q++) {
3175 U8 c = (U8)*p;
3176 *q = (char)
3177 ((c & 0x80) ? ((c & 0x03) << 6) | (((U8)*++p) & 0x3f) : c);
3178 }
3179 }
3180 flags &= ~REFCOUNTED_HE_KEY_UTF8;
3181 canonicalised_key: ;
b6bbf3fa 3182 }
20439bc7
Z
3183 if (flags & REFCOUNTED_HE_KEY_UTF8)
3184 hekflags |= HVhek_UTF8;
3185 if (!hash)
3186 PERL_HASH(hash, keypv, keylen);
012da8e5 3187
0de694c5 3188#ifdef USE_ITHREADS
10edeb5d
JH
3189 he = (struct refcounted_he*)
3190 PerlMemShared_malloc(sizeof(struct refcounted_he) - 1
20439bc7 3191 + keylen
20439bc7 3192 + key_offset);
0de694c5
NC
3193#else
3194 he = (struct refcounted_he*)
3195 PerlMemShared_malloc(sizeof(struct refcounted_he) - 1
3196 + key_offset);
3197#endif
b3ca2e83 3198
71ad1b0c 3199 he->refcounted_he_next = parent;
b6bbf3fa 3200
012da8e5 3201 if (is_pv) {
20439bc7 3202 Copy(value_p, he->refcounted_he_data + 1, value_len + 1, char);
b6bbf3fa 3203 he->refcounted_he_val.refcounted_he_u_len = value_len;
b6bbf3fa 3204 } else if (value_type == HVrhek_IV) {
20439bc7 3205 he->refcounted_he_val.refcounted_he_u_iv = SvIVX(value);
012da8e5 3206 } else if (value_type == HVrhek_UV) {
20439bc7 3207 he->refcounted_he_val.refcounted_he_u_uv = SvUVX(value);
b6bbf3fa
NC
3208 }
3209
cbb1fbea 3210#ifdef USE_ITHREADS
b6bbf3fa 3211 he->refcounted_he_hash = hash;
20439bc7
Z
3212 he->refcounted_he_keylen = keylen;
3213 Copy(keypv, he->refcounted_he_data + key_offset, keylen, char);
cbb1fbea 3214#else
20439bc7 3215 he->refcounted_he_hek = share_hek_flags(keypv, keylen, hash, hekflags);
cbb1fbea 3216#endif
b6bbf3fa 3217
20439bc7 3218 he->refcounted_he_data[0] = hekflags;
b3ca2e83
NC
3219 he->refcounted_he_refcnt = 1;
3220
3221 return he;
3222}
3223
3224/*
20439bc7 3225=for apidoc m|struct refcounted_he *|refcounted_he_new_pv|struct refcounted_he *parent|const char *key|U32 hash|SV *value|U32 flags
b3ca2e83 3226
20439bc7
Z
3227Like L</refcounted_he_new_pvn>, but takes a nul-terminated string instead
3228of a string/length pair.
3229
3230=cut
3231*/
3232
3233struct refcounted_he *
3234Perl_refcounted_he_new_pv(pTHX_ struct refcounted_he *parent,
3235 const char *key, U32 hash, SV *value, U32 flags)
3236{
3237 PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_PV;
3238 return refcounted_he_new_pvn(parent, key, strlen(key), hash, value, flags);
3239}
3240
3241/*
3242=for apidoc m|struct refcounted_he *|refcounted_he_new_sv|struct refcounted_he *parent|SV *key|U32 hash|SV *value|U32 flags
3243
3244Like L</refcounted_he_new_pvn>, but takes a Perl scalar instead of a
3245string/length pair.
3246
3247=cut
3248*/
3249
3250struct refcounted_he *
3251Perl_refcounted_he_new_sv(pTHX_ struct refcounted_he *parent,
3252 SV *key, U32 hash, SV *value, U32 flags)
3253{
3254 const char *keypv;
3255 STRLEN keylen;
3256 PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_SV;
3257 if (flags & REFCOUNTED_HE_KEY_UTF8)
3258 Perl_croak(aTHX_ "panic: refcounted_he_new_sv bad flags %"UVxf,
3259 (UV)flags);
3260 keypv = SvPV_const(key, keylen);
3261 if (SvUTF8(key))
3262 flags |= REFCOUNTED_HE_KEY_UTF8;
3263 if (!hash && SvIsCOW_shared_hash(key))
3264 hash = SvSHARED_HASH(key);
3265 return refcounted_he_new_pvn(parent, keypv, keylen, hash, value, flags);
3266}
3267
3268/*
3269=for apidoc m|void|refcounted_he_free|struct refcounted_he *he
3270
3271Decrements the reference count of a C<refcounted_he> by one. If the
3272reference count reaches zero the structure's memory is freed, which
3273(recursively) causes a reduction of its parent C<refcounted_he>'s
3274reference count. It is safe to pass a null pointer to this function:
3275no action occurs in this case.
b3ca2e83
NC
3276
3277=cut
3278*/
3279
3280void
3281Perl_refcounted_he_free(pTHX_ struct refcounted_he *he) {
53d44271 3282 dVAR;
57ca3b03
AL
3283 PERL_UNUSED_CONTEXT;
3284
b3ca2e83
NC
3285 while (he) {
3286 struct refcounted_he *copy;
cbb1fbea 3287 U32 new_count;
b3ca2e83 3288
cbb1fbea
NC
3289 HINTS_REFCNT_LOCK;
3290 new_count = --he->refcounted_he_refcnt;
3291 HINTS_REFCNT_UNLOCK;
3292
3293 if (new_count) {
b3ca2e83 3294 return;
cbb1fbea 3295 }
b3ca2e83 3296
b6bbf3fa 3297#ifndef USE_ITHREADS
71ad1b0c 3298 unshare_hek_or_pvn (he->refcounted_he_hek, 0, 0, 0);
cbb1fbea 3299#endif
b3ca2e83 3300 copy = he;
71ad1b0c 3301 he = he->refcounted_he_next;
b6bbf3fa 3302 PerlMemShared_free(copy);
b3ca2e83
NC
3303 }
3304}
3305
20439bc7
Z
3306/*
3307=for apidoc m|struct refcounted_he *|refcounted_he_inc|struct refcounted_he *he
3308
3309Increment the reference count of a C<refcounted_he>. The pointer to the
3310C<refcounted_he> is also returned. It is safe to pass a null pointer
3311to this function: no action occurs and a null pointer is returned.
3312
3313=cut
3314*/
3315
3316struct refcounted_he *
3317Perl_refcounted_he_inc(pTHX_ struct refcounted_he *he)
3318{
3319 if (he) {
3320 HINTS_REFCNT_LOCK;
3321 he->refcounted_he_refcnt++;
3322 HINTS_REFCNT_UNLOCK;
3323 }
3324 return he;
3325}
3326
47550813
NC
3327/* pp_entereval is aware that labels are stored with a key ':' at the top of
3328 the linked list. */
dca6062a 3329const char *
ce42d03d 3330Perl_fetch_cop_label(pTHX_ COP *const cop, STRLEN *len, U32 *flags) {
d6747b7a
NC
3331 struct refcounted_he *const chain = cop->cop_hints_hash;
3332
3333 PERL_ARGS_ASSERT_FETCH_COP_LABEL;
3334
dca6062a
NC
3335 if (!chain)
3336 return NULL;
3337#ifdef USE_ITHREADS
3338 if (chain->refcounted_he_keylen != 1)
3339 return NULL;
3340 if (*REF_HE_KEY(chain) != ':')
3341 return NULL;
3342#else
3343 if ((STRLEN)HEK_LEN(chain->refcounted_he_hek) != 1)
3344 return NULL;
3345 if (*HEK_KEY(chain->refcounted_he_hek) != ':')
3346 return NULL;
3347#endif
012da8e5
NC
3348 /* Stop anyone trying to really mess us up by adding their own value for
3349 ':' into %^H */
3350 if ((chain->refcounted_he_data[0] & HVrhek_typemask) != HVrhek_PV
3351 && (chain->refcounted_he_data[0] & HVrhek_typemask) != HVrhek_PV_UTF8)
3352 return NULL;
3353
dca6062a
NC
3354 if (len)
3355 *len = chain->refcounted_he_val.refcounted_he_u_len;
3356 if (flags) {
3357 *flags = ((chain->refcounted_he_data[0] & HVrhek_typemask)
3358 == HVrhek_PV_UTF8) ? SVf_UTF8 : 0;
3359 }
3360 return chain->refcounted_he_data + 1;
3361}
3362
a77ac40c
NC
3363void
3364Perl_store_cop_label(pTHX_ COP *const cop, const char *label, STRLEN len,
3365 U32 flags)
012da8e5 3366{
20439bc7 3367 SV *labelsv;
547bb267
NC
3368 PERL_ARGS_ASSERT_STORE_COP_LABEL;
3369
a77ac40c
NC
3370 if (flags & ~(SVf_UTF8))
3371 Perl_croak(aTHX_ "panic: store_cop_label illegal flag bits 0x%" UVxf,
3372 (UV)flags);
20439bc7
Z
3373 labelsv = sv_2mortal(newSVpvn(label, len));
3374 if (flags & SVf_UTF8)
3375 SvUTF8_on(labelsv);
a77ac40c 3376 cop->cop_hints_hash
20439bc7 3377 = refcounted_he_new_pvs(cop->cop_hints_hash, ":", labelsv, 0);
012da8e5
NC
3378}
3379
b3ca2e83 3380/*
ecae49c0
NC
3381=for apidoc hv_assert
3382
3383Check that a hash is in an internally consistent state.
3384
3385=cut
3386*/
3387
943795c2
NC
3388#ifdef DEBUGGING
3389
ecae49c0
NC
3390void
3391Perl_hv_assert(pTHX_ HV *hv)
3392{
57ca3b03
AL
3393 dVAR;
3394 HE* entry;
3395 int withflags = 0;
3396 int placeholders = 0;
3397 int real = 0;
3398 int bad = 0;
3399 const I32 riter = HvRITER_get(hv);
3400 HE *eiter = HvEITER_get(hv);
3401
7918f24d
NC
3402 PERL_ARGS_ASSERT_HV_ASSERT;
3403
57ca3b03
AL
3404 (void)hv_iterinit(hv);
3405
3406 while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))) {
3407 /* sanity check the values */
3408 if (HeVAL(entry) == &PL_sv_placeholder)
3409 placeholders++;
3410 else
3411 real++;
3412 /* sanity check the keys */
3413 if (HeSVKEY(entry)) {
6f207bd3 3414 NOOP; /* Don't know what to check on SV keys. */
57ca3b03
AL
3415 } else if (HeKUTF8(entry)) {
3416 withflags++;
3417 if (HeKWASUTF8(entry)) {
3418 PerlIO_printf(Perl_debug_log,
d2a455e7 3419 "hash key has both WASUTF8 and UTF8: '%.*s'\n",
57ca3b03
AL
3420 (int) HeKLEN(entry), HeKEY(entry));
3421 bad = 1;
3422 }
3423 } else if (HeKWASUTF8(entry))
3424 withflags++;
3425 }
ad64d0ec 3426 if (!SvTIED_mg((const SV *)hv, PERL_MAGIC_tied)) {
57ca3b03
AL
3427 static const char bad_count[] = "Count %d %s(s), but hash reports %d\n";
3428 const int nhashkeys = HvUSEDKEYS(hv);
3429 const int nhashplaceholders = HvPLACEHOLDERS_get(hv);
3430
3431 if (nhashkeys != real) {
3432 PerlIO_printf(Perl_debug_log, bad_count, real, "keys", nhashkeys );
3433 bad = 1;
3434 }
3435 if (nhashplaceholders != placeholders) {
3436 PerlIO_printf(Perl_debug_log, bad_count, placeholders, "placeholder", nhashplaceholders );
3437 bad = 1;
3438 }
3439 }
3440 if (withflags && ! HvHASKFLAGS(hv)) {
3441 PerlIO_printf(Perl_debug_log,
3442 "Hash has HASKFLAGS off but I count %d key(s) with flags\n",
3443 withflags);
3444 bad = 1;
3445 }
3446 if (bad) {
ad64d0ec 3447 sv_dump(MUTABLE_SV(hv));
57ca3b03
AL
3448 }
3449 HvRITER_set(hv, riter); /* Restore hash iterator state */
3450 HvEITER_set(hv, eiter);
ecae49c0 3451}
af3babe4 3452
943795c2
NC
3453#endif
3454
af3babe4
NC
3455/*
3456 * Local variables:
3457 * c-indentation-style: bsd
3458 * c-basic-offset: 4
3459 * indent-tabs-mode: t
3460 * End:
3461 *
37442d52
RGS
3462 * ex: set ts=8 sts=4 sw=4 noet:
3463 */