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