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