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