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