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